New decision procedure for Presburger arithmetic.
authorberghofe
Tue Mar 25 09:47:05 2003 +0100 (2003-03-25)
changeset 1387668f4ed8311ac
parent 13875 12997e3ddd8d
child 13877 a6b825ee48d9
New decision procedure for Presburger arithmetic.
src/HOL/Integ/Presburger.thy
src/HOL/Integ/cooper_dec.ML
src/HOL/Integ/cooper_proof.ML
src/HOL/Integ/presburger.ML
src/HOL/Integ/qelim.ML
src/HOL/Presburger.thy
src/HOL/Tools/Presburger/cooper_dec.ML
src/HOL/Tools/Presburger/cooper_proof.ML
src/HOL/Tools/Presburger/presburger.ML
src/HOL/Tools/Presburger/qelim.ML
     1.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     1.2 +++ b/src/HOL/Integ/Presburger.thy	Tue Mar 25 09:47:05 2003 +0100
     1.3 @@ -0,0 +1,1002 @@
     1.4 +(*  Title:      HOL/Integ/Presburger.thy
     1.5 +    ID:         $Id$
     1.6 +    Author:     Amine Chaieb, Tobias Nipkow and Stefan Berghofer, TU Muenchen
     1.7 +    License:    GPL (GNU GENERAL PUBLIC LICENSE)
     1.8 +
     1.9 +File containing necessary theorems for the proof
    1.10 +generation for Cooper Algorithm  
    1.11 +*)
    1.12 +
    1.13 +theory Presburger = NatSimprocs
    1.14 +files
    1.15 +  ("cooper_dec.ML")
    1.16 +  ("cooper_proof.ML")
    1.17 +  ("qelim.ML")
    1.18 +  ("presburger.ML"):
    1.19 +
    1.20 +(* Theorem for unitifying the coeffitients of x in an existential formula*)
    1.21 +
    1.22 +theorem unity_coeff_ex: "(\<exists>x::int. P (l * x)) = (\<exists>x. l dvd (1*x+0) \<and> P x)"
    1.23 +  apply (rule iffI)
    1.24 +  apply (erule exE)
    1.25 +  apply (rule_tac x = "l * x" in exI)
    1.26 +  apply simp
    1.27 +  apply (erule exE)
    1.28 +  apply (erule conjE)
    1.29 +  apply (erule dvdE)
    1.30 +  apply (rule_tac x = k in exI)
    1.31 +  apply simp
    1.32 +  done
    1.33 +
    1.34 +lemma uminus_dvd_conv: "(d dvd (t::int)) = (-d dvd t)"
    1.35 +apply(unfold dvd_def)
    1.36 +apply(rule iffI)
    1.37 +apply(clarsimp)
    1.38 +apply(rename_tac k)
    1.39 +apply(rule_tac x = "-k" in exI)
    1.40 +apply simp
    1.41 +apply(clarsimp)
    1.42 +apply(rename_tac k)
    1.43 +apply(rule_tac x = "-k" in exI)
    1.44 +apply simp
    1.45 +done
    1.46 +
    1.47 +lemma uminus_dvd_conv': "(d dvd (t::int)) = (d dvd -t)"
    1.48 +apply(unfold dvd_def)
    1.49 +apply(rule iffI)
    1.50 +apply(clarsimp)
    1.51 +apply(rule_tac x = "-k" in exI)
    1.52 +apply simp
    1.53 +apply(clarsimp)
    1.54 +apply(rule_tac x = "-k" in exI)
    1.55 +apply simp
    1.56 +done
    1.57 +
    1.58 +
    1.59 +
    1.60 +(*Theorems for the combination of proofs of the equality of P and P_m for integers x less than some integer z.*)
    1.61 +
    1.62 +theorem eq_minf_conjI: "\<exists>z1::int. \<forall>x. x < z1 \<longrightarrow> (A1 x = A2 x) \<Longrightarrow>
    1.63 +  \<exists>z2::int. \<forall>x. x < z2 \<longrightarrow> (B1 x = B2 x) \<Longrightarrow>
    1.64 +  \<exists>z::int. \<forall>x. x < z \<longrightarrow> ((A1 x \<and> B1 x) = (A2 x \<and> B2 x))"
    1.65 +  apply (erule exE)+
    1.66 +  apply (rule_tac x = "min z1 z2" in exI)
    1.67 +  apply simp
    1.68 +  done
    1.69 +
    1.70 +
    1.71 +theorem eq_minf_disjI: "\<exists>z1::int. \<forall>x. x < z1 \<longrightarrow> (A1 x = A2 x) \<Longrightarrow>
    1.72 +  \<exists>z2::int. \<forall>x. x < z2 \<longrightarrow> (B1 x = B2 x) \<Longrightarrow>
    1.73 +  \<exists>z::int. \<forall>x. x < z \<longrightarrow> ((A1 x \<or> B1 x) = (A2 x \<or> B2 x))"
    1.74 +
    1.75 +  apply (erule exE)+
    1.76 +  apply (rule_tac x = "min z1 z2" in exI)
    1.77 +  apply simp
    1.78 +  done
    1.79 +
    1.80 +
    1.81 +(*Theorems for the combination of proofs of the equality of P and P_m for integers x greather than some integer z.*)
    1.82 +
    1.83 +theorem eq_pinf_conjI: "\<exists>z1::int. \<forall>x. z1 < x \<longrightarrow> (A1 x = A2 x) \<Longrightarrow>
    1.84 +  \<exists>z2::int. \<forall>x. z2 < x \<longrightarrow> (B1 x = B2 x) \<Longrightarrow>
    1.85 +  \<exists>z::int. \<forall>x. z < x \<longrightarrow> ((A1 x \<and> B1 x) = (A2 x \<and> B2 x))"
    1.86 +  apply (erule exE)+
    1.87 +  apply (rule_tac x = "max z1 z2" in exI)
    1.88 +  apply simp
    1.89 +  done
    1.90 +
    1.91 +
    1.92 +theorem eq_pinf_disjI: "\<exists>z1::int. \<forall>x. z1 < x \<longrightarrow> (A1 x = A2 x) \<Longrightarrow>
    1.93 +  \<exists>z2::int. \<forall>x. z2 < x \<longrightarrow> (B1 x = B2 x) \<Longrightarrow>
    1.94 +  \<exists>z::int. \<forall>x. z < x  \<longrightarrow> ((A1 x \<or> B1 x) = (A2 x \<or> B2 x))"
    1.95 +  apply (erule exE)+
    1.96 +  apply (rule_tac x = "max z1 z2" in exI)
    1.97 +  apply simp
    1.98 +  done
    1.99 +(*=============================================================================*)
   1.100 +(*Theorems for the combination of proofs of the modulo D property for P
   1.101 +pluusinfinity*)
   1.102 +(* FIXME : This is THE SAME theorem as for the minusinf version, but with +k.. instead of -k.. In the future replace these both with only one*)
   1.103 +
   1.104 +theorem modd_pinf_conjI: "\<forall>(x::int) k. A x = A (x+k*d) \<Longrightarrow>
   1.105 +  \<forall>(x::int) k. B x = B (x+k*d) \<Longrightarrow>
   1.106 +  \<forall>(x::int) (k::int). (A x \<and> B x) = (A (x+k*d) \<and> B (x+k*d))"
   1.107 +  by simp
   1.108 +
   1.109 +
   1.110 +theorem modd_pinf_disjI: "\<forall>(x::int) k. A x = A (x+k*d) \<Longrightarrow>
   1.111 +  \<forall>(x::int) k. B x = B (x+k*d) \<Longrightarrow>
   1.112 +  \<forall>(x::int) (k::int). (A x \<or> B x) = (A (x+k*d) \<or> B (x+k*d))"
   1.113 +  by simp
   1.114 +
   1.115 +(*=============================================================================*)
   1.116 +(*This is one of the cases where the simplifed formula is prooved to habe some property
   1.117 +(in relation to P_m) but we need to proove the property for the original formula (P_m)*)
   1.118 +(*FIXME : This is exaclty the same thm as for minusinf.*)
   1.119 +lemma pinf_simp_eq: "ALL x. P(x) = Q(x) ==> (EX (x::int). P(x)) --> (EX (x::int). F(x))  ==> (EX (x::int). Q(x)) --> (EX (x::int). F(x)) "
   1.120 +by blast
   1.121 +
   1.122 +
   1.123 +
   1.124 +(*=============================================================================*)
   1.125 +(*Theorems for the combination of proofs of the modulo D property for P
   1.126 +minusinfinity*)
   1.127 +
   1.128 +theorem modd_minf_conjI: "\<forall>(x::int) k. A x = A (x-k*d) \<Longrightarrow>
   1.129 +  \<forall>(x::int) k. B x = B (x-k*d) \<Longrightarrow>
   1.130 +  \<forall>(x::int) (k::int). (A x \<and> B x) = (A (x-k*d) \<and> B (x-k*d))"
   1.131 +  by simp
   1.132 +
   1.133 +
   1.134 +theorem modd_minf_disjI: "\<forall>(x::int) k. A x = A (x-k*d) \<Longrightarrow>
   1.135 +  \<forall>(x::int) k. B x = B (x-k*d) \<Longrightarrow>
   1.136 +  \<forall>(x::int) (k::int). (A x \<or> B x) = (A (x-k*d) \<or> B (x-k*d))"
   1.137 +  by simp
   1.138 +
   1.139 +(*=============================================================================*)
   1.140 +(*This is one of the cases where the simplifed formula is prooved to habe some property
   1.141 +(in relation to P_m) but we need to proove the property for the original formula (P_m)*)
   1.142 +
   1.143 +lemma minf_simp_eq: "ALL x. P(x) = Q(x) ==> (EX (x::int). P(x)) --> (EX (x::int). F(x))  ==> (EX (x::int). Q(x)) --> (EX (x::int). F(x)) "
   1.144 +by blast
   1.145 +
   1.146 +(*=============================================================================*)
   1.147 +
   1.148 +(*theorem needed for prooving at runtime divide properties using the arithmetic tatic
   1.149 +(who knows only about modulo = 0)*)
   1.150 +
   1.151 +lemma zdvd_iff_zmod_eq_0: "(m dvd n) = (n mod m = (0::int))"
   1.152 +by(simp add:dvd_def zmod_eq_0_iff)
   1.153 +
   1.154 +(*=============================================================================*)
   1.155 +
   1.156 +
   1.157 +
   1.158 +(*Theorems used for the combination of proof for the backwards direction of cooper's
   1.159 +theorem. they rely exclusively on Predicate calculus.*)
   1.160 +
   1.161 +lemma not_ast_p_disjI: "(ALL x. Q(x::int) \<and> ~(EX (j::int) : {1..d}. EX (a::int) : A. Q(a - j)) --> P1(x) --> P1(x + d))
   1.162 +==>
   1.163 +(ALL x. Q(x::int) \<and> ~(EX (j::int) : {1..d}. EX (a::int) : A. Q(a - j)) --> P2(x) --> P2(x + d))
   1.164 +==>
   1.165 +(ALL x. Q(x::int) \<and> ~(EX (j::int) : {1..d}. EX (a::int) : A. Q(a - j)) -->(P1(x) \<or> P2(x)) --> (P1(x + d) \<or> P2(x + d))) "
   1.166 +by blast
   1.167 +
   1.168 +
   1.169 +
   1.170 +lemma not_ast_p_conjI: "(ALL x. Q(x::int) \<and> ~(EX (j::int) : {1..d}. EX (a::int) : A. Q(a- j)) --> P1(x) --> P1(x + d))
   1.171 +==>
   1.172 +(ALL x. Q(x::int) \<and> ~(EX (j::int) : {1..d}. EX (a::int) : A. Q(a - j)) --> P2(x) --> P2(x + d))
   1.173 +==>
   1.174 +(ALL x. Q(x::int) \<and> ~(EX (j::int) : {1..d}. EX (a::int) : A. Q(a - j)) -->(P1(x) \<and> P2(x)) --> (P1(x + d)
   1.175 +\<and> P2(x + d))) "
   1.176 +by blast
   1.177 +
   1.178 +lemma not_ast_p_Q_elim: "
   1.179 +(ALL x. Q(x::int) \<and> ~(EX (j::int) : {1..d}. EX (a::int) : A. Q(a - j)) -->P(x) --> P(x + d))
   1.180 +==> ( P = Q )
   1.181 +==> (ALL x. ~(EX (j::int) : {1..d}. EX (a::int) : A. P(a - j)) -->P(x) --> P(x + d))"
   1.182 +by blast
   1.183 +(*=============================================================================*)
   1.184 +
   1.185 +
   1.186 +(*Theorems used for the combination of proof for the backwards direction of cooper's
   1.187 +theorem. they rely exclusively on Predicate calculus.*)
   1.188 +
   1.189 +lemma not_bst_p_disjI: "(ALL x. Q(x::int) \<and> ~(EX (j::int) : {1..d}. EX (b::int) : B. Q(b+j)) --> P1(x) --> P1(x - d))
   1.190 +==>
   1.191 +(ALL x. Q(x::int) \<and> ~(EX (j::int) : {1..d}. EX (b::int) : B. Q(b+j)) --> P2(x) --> P2(x - d))
   1.192 +==>
   1.193 +(ALL x. Q(x::int) \<and> ~(EX (j::int) : {1..d}. EX (b::int) : B. Q(b+j)) -->(P1(x) \<or> P2(x)) --> (P1(x - d)
   1.194 +\<or> P2(x-d))) "
   1.195 +by blast
   1.196 +
   1.197 +
   1.198 +
   1.199 +lemma not_bst_p_conjI: "(ALL x. Q(x::int) \<and> ~(EX (j::int) : {1..d}. EX (b::int) : B. Q(b+j)) --> P1(x) --> P1(x - d))
   1.200 +==>
   1.201 +(ALL x. Q(x::int) \<and> ~(EX (j::int) : {1..d}. EX (b::int) : B. Q(b+j)) --> P2(x) --> P2(x - d))
   1.202 +==>
   1.203 +(ALL x. Q(x::int) \<and> ~(EX (j::int) : {1..d}. EX (b::int) : B. Q(b+j)) -->(P1(x) \<and> P2(x)) --> (P1(x - d)
   1.204 +\<and> P2(x-d))) "
   1.205 +by blast
   1.206 +
   1.207 +lemma not_bst_p_Q_elim: "
   1.208 +(ALL x. Q(x::int) \<and> ~(EX (j::int) : {1..d}. EX (b::int) : B. Q(b+j)) -->P(x) --> P(x - d)) 
   1.209 +==> ( P = Q )
   1.210 +==> (ALL x. ~(EX (j::int) : {1..d}. EX (b::int) : B. P(b+j)) -->P(x) --> P(x - d))"
   1.211 +by blast
   1.212 +(*=============================================================================*)
   1.213 +(*The Theorem for the second proof step- about bset. it is trivial too. *)
   1.214 +lemma bst_thm: " (EX (j::int) : {1..d}. EX (b::int) : B. P (b+j) )--> (EX x::int. P (x)) "
   1.215 +by blast
   1.216 +
   1.217 +(*The Theorem for the second proof step- about aset. it is trivial too. *)
   1.218 +lemma ast_thm: " (EX (j::int) : {1..d}. EX (a::int) : A. P (a - j) )--> (EX x::int. P (x)) "
   1.219 +by blast
   1.220 +
   1.221 +
   1.222 +(*=============================================================================*)
   1.223 +(*This is the first direction of cooper's theorem*)
   1.224 +lemma cooper_thm: "(R --> (EX x::int. P x))  ==> (Q -->(EX x::int.  P x )) ==> ((R|Q) --> (EX x::int. P x )) "
   1.225 +by blast
   1.226 +
   1.227 +(*=============================================================================*)
   1.228 +(*The full cooper's theoorem in its equivalence Form- Given the premisses it is trivial
   1.229 +too, it relies exclusively on prediacte calculus.*)
   1.230 +lemma cooper_eq_thm: "(R --> (EX x::int. P x))  ==> (Q -->(EX x::int.  P x )) ==> ((~Q)
   1.231 +--> (EX x::int. P x ) --> R) ==> (EX x::int. P x) = R|Q "
   1.232 +by blast
   1.233 +
   1.234 +(*=============================================================================*)
   1.235 +(*Some of the atomic theorems generated each time the atom does not depend on x, they
   1.236 +are trivial.*)
   1.237 +
   1.238 +lemma  fm_eq_minf: "EX z::int. ALL x. x < z --> (P = P) "
   1.239 +by blast
   1.240 +
   1.241 +lemma  fm_modd_minf: "ALL (x::int). ALL (k::int). (P = P)"
   1.242 +by blast
   1.243 +
   1.244 +lemma not_bst_p_fm: "ALL (x::int). Q(x::int) \<and> ~(EX (j::int) : {1..d}. EX (b::int) : B. Q(b+j)) --> fm --> fm"
   1.245 +by blast
   1.246 +
   1.247 +
   1.248 +
   1.249 +lemma  fm_eq_pinf: "EX z::int. ALL x. z < x --> (P = P) "
   1.250 +by blast
   1.251 +
   1.252 +(* The next 2 thms are the same as the minusinf version*)
   1.253 +lemma  fm_modd_pinf: "ALL (x::int). ALL (k::int). (P = P)"
   1.254 +by blast
   1.255 +
   1.256 +lemma not_ast_p_fm: "ALL (x::int). Q(x::int) \<and> ~(EX (j::int) : {1..d}. EX (a::int) : A. Q(a - j)) --> fm --> fm"
   1.257 +by blast
   1.258 +
   1.259 +
   1.260 +(* Theorems to be deleted from simpset when proving simplified formulaes*)
   1.261 +lemma P_eqtrue: "(P=True) = P"
   1.262 +  by rules
   1.263 +
   1.264 +lemma P_eqfalse: "(P=False) = (~P)"
   1.265 +  by rules
   1.266 +
   1.267 +(*=============================================================================*)
   1.268 +
   1.269 +(*Theorems for the generation of the bachwards direction of cooper's theorem*)
   1.270 +(*These are the 6 interesting atomic cases which have to be proved relying on the
   1.271 +properties of B-set ant the arithmetic and contradiction proofs*)
   1.272 +
   1.273 +lemma not_bst_p_lt: "0 < (d::int) ==>
   1.274 + ALL x. Q(x::int) \<and> ~(EX (j::int) : {1..d}. EX (b::int) : B. Q(b+j)) --> ( 0 < -x + a) --> (0 < -(x - d) + a )"
   1.275 +by arith
   1.276 +
   1.277 +lemma not_bst_p_gt: "\<lbrakk> (g::int) \<in> B; g = -a \<rbrakk> \<Longrightarrow>
   1.278 + ALL x. Q(x::int) \<and> ~(EX (j::int) : {1..d}. EX (b::int) : B. Q(b+j)) --> (0 < (x) + a) --> ( 0 < (x - d) + a)"
   1.279 +apply clarsimp
   1.280 +apply(rule ccontr)
   1.281 +apply(drule_tac x = "x+a" in bspec)
   1.282 +apply(simp add:atLeastAtMost_iff)
   1.283 +apply(drule_tac x = "-a" in bspec)
   1.284 +apply assumption
   1.285 +apply(simp)
   1.286 +done
   1.287 +
   1.288 +lemma not_bst_p_eq: "\<lbrakk> 0 < d; (g::int) \<in> B; g = -a - 1 \<rbrakk> \<Longrightarrow>
   1.289 + ALL x. Q(x::int) \<and> ~(EX (j::int) : {1..d}. EX (b::int) : B. Q(b+j)) --> (0 = x + a) --> (0 = (x - d) + a )"
   1.290 +apply clarsimp
   1.291 +apply(subgoal_tac "x = -a")
   1.292 + prefer 2 apply arith
   1.293 +apply(drule_tac x = "1" in bspec)
   1.294 +apply(simp add:atLeastAtMost_iff)
   1.295 +apply(drule_tac x = "-a- 1" in bspec)
   1.296 +apply assumption
   1.297 +apply(simp)
   1.298 +done
   1.299 +
   1.300 +
   1.301 +lemma not_bst_p_ne: "\<lbrakk> 0 < d; (g::int) \<in> B; g = -a \<rbrakk> \<Longrightarrow>
   1.302 + ALL x. Q(x::int) \<and> ~(EX (j::int) : {1..d}. EX (b::int) : B. Q(b+j)) --> ~(0 = x + a) --> ~(0 = (x - d) + a)"
   1.303 +apply clarsimp
   1.304 +apply(subgoal_tac "x = -a+d")
   1.305 + prefer 2 apply arith
   1.306 +apply(drule_tac x = "d" in bspec)
   1.307 +apply(simp add:atLeastAtMost_iff)
   1.308 +apply(drule_tac x = "-a" in bspec)
   1.309 +apply assumption
   1.310 +apply(simp)
   1.311 +done
   1.312 +
   1.313 +
   1.314 +lemma not_bst_p_dvd: "(d1::int) dvd d ==>
   1.315 + ALL x. Q(x::int) \<and> ~(EX (j::int) : {1..d}. EX (b::int) : B. Q(b+j)) --> d1 dvd (x + a) --> d1 dvd ((x - d) + a )"
   1.316 +apply(clarsimp simp add:dvd_def)
   1.317 +apply(rename_tac m)
   1.318 +apply(rule_tac x = "m - k" in exI)
   1.319 +apply(simp add:int_distrib)
   1.320 +done
   1.321 +
   1.322 +lemma not_bst_p_ndvd: "(d1::int) dvd d ==>
   1.323 + ALL x. Q(x::int) \<and> ~(EX (j::int) : {1..d}. EX (b::int) : B. Q(b+j)) --> ~(d1 dvd (x + a)) --> ~(d1 dvd ((x - d) + a ))"
   1.324 +apply(clarsimp simp add:dvd_def)
   1.325 +apply(rename_tac m)
   1.326 +apply(erule_tac x = "m + k" in allE)
   1.327 +apply(simp add:int_distrib)
   1.328 +done
   1.329 +
   1.330 +
   1.331 +
   1.332 +(*Theorems for the generation of the bachwards direction of cooper's theorem*)
   1.333 +(*These are the 6 interesting atomic cases which have to be proved relying on the
   1.334 +properties of A-set ant the arithmetic and contradiction proofs*)
   1.335 +
   1.336 +lemma not_ast_p_gt: "0 < (d::int) ==>
   1.337 + ALL x. Q(x::int) \<and> ~(EX (j::int) : {1..d}. EX (a::int) : A. Q(a - j)) --> ( 0 < x + t) --> (0 < (x + d) + t )"
   1.338 +by arith
   1.339 +
   1.340 +
   1.341 +lemma not_ast_p_lt: "\<lbrakk>0 < d ;(t::int) \<in> A \<rbrakk> \<Longrightarrow>
   1.342 + ALL x. Q(x::int) \<and> ~(EX (j::int) : {1..d}. EX (a::int) : A. Q(a - j)) --> (0 < -x + t) --> ( 0 < -(x + d) + t)"
   1.343 +  apply clarsimp
   1.344 +  apply (rule ccontr)
   1.345 +  apply (drule_tac x = "t-x" in bspec)
   1.346 +  apply simp
   1.347 +  apply (drule_tac x = "t" in bspec)
   1.348 +  apply assumption
   1.349 +  apply simp
   1.350 +  done
   1.351 +
   1.352 +lemma not_ast_p_eq: "\<lbrakk> 0 < d; (g::int) \<in> A; g = -t + 1 \<rbrakk> \<Longrightarrow>
   1.353 + ALL x. Q(x::int) \<and> ~(EX (j::int) : {1..d}. EX (a::int) : A. Q(a - j)) --> (0 = x + t) --> (0 = (x + d) + t )"
   1.354 +  apply clarsimp
   1.355 +  apply (drule_tac x="1" in bspec)
   1.356 +  apply simp
   1.357 +  apply (drule_tac x="- t + 1" in bspec)
   1.358 +  apply assumption
   1.359 +  apply(subgoal_tac "x = -t")
   1.360 +  prefer 2 apply arith
   1.361 +  apply simp
   1.362 +  done
   1.363 +
   1.364 +lemma not_ast_p_ne: "\<lbrakk> 0 < d; (g::int) \<in> A; g = -t \<rbrakk> \<Longrightarrow>
   1.365 + ALL x. Q(x::int) \<and> ~(EX (j::int) : {1..d}. EX (a::int) : A. Q(a - j)) --> ~(0 = x + t) --> ~(0 = (x + d) + t)"
   1.366 +  apply clarsimp
   1.367 +  apply (subgoal_tac "x = -t-d")
   1.368 +  prefer 2 apply arith
   1.369 +  apply (drule_tac x = "d" in bspec)
   1.370 +  apply simp
   1.371 +  apply (drule_tac x = "-t" in bspec)
   1.372 +  apply assumption
   1.373 +  apply simp
   1.374 +  done
   1.375 +
   1.376 +lemma not_ast_p_dvd: "(d1::int) dvd d ==>
   1.377 + ALL x. Q(x::int) \<and> ~(EX (j::int) : {1..d}. EX (a::int) : A. Q(a - j)) --> d1 dvd (x + t) --> d1 dvd ((x + d) + t )"
   1.378 +  apply(clarsimp simp add:dvd_def)
   1.379 +  apply(rename_tac m)
   1.380 +  apply(rule_tac x = "m + k" in exI)
   1.381 +  apply(simp add:int_distrib)
   1.382 +  done
   1.383 +
   1.384 +lemma not_ast_p_ndvd: "(d1::int) dvd d ==>
   1.385 + ALL x. Q(x::int) \<and> ~(EX (j::int) : {1..d}. EX (a::int) : A. Q(a - j)) --> ~(d1 dvd (x + t)) --> ~(d1 dvd ((x + d) + t ))"
   1.386 +  apply(clarsimp simp add:dvd_def)
   1.387 +  apply(rename_tac m)
   1.388 +  apply(erule_tac x = "m - k" in allE)
   1.389 +  apply(simp add:int_distrib)
   1.390 +  done
   1.391 +
   1.392 +
   1.393 +
   1.394 +(*=============================================================================*)
   1.395 +(*These are the atomic cases for the proof generation for the modulo D property for P
   1.396 +plusinfinity*)
   1.397 +(*They are fully based on arithmetics*)
   1.398 +
   1.399 +lemma  dvd_modd_pinf: "((d::int) dvd d1) ==>
   1.400 + (ALL (x::int). ALL (k::int). (((d::int) dvd (x + t)) = (d dvd (x+k*d1 + t))))"
   1.401 +  apply(clarsimp simp add:dvd_def)
   1.402 +  apply(rule iffI)
   1.403 +  apply(clarsimp)
   1.404 +  apply(rename_tac n m)
   1.405 +  apply(rule_tac x = "m + n*k" in exI)
   1.406 +  apply(simp add:int_distrib)
   1.407 +  apply(clarsimp)
   1.408 +  apply(rename_tac n m)
   1.409 +  apply(rule_tac x = "m - n*k" in exI)
   1.410 +  apply(simp add:int_distrib zmult_ac)
   1.411 +  done
   1.412 +
   1.413 +lemma  not_dvd_modd_pinf: "((d::int) dvd d1) ==>
   1.414 + (ALL (x::int). ALL k. (~((d::int) dvd (x + t))) = (~(d dvd (x+k*d1 + t))))"
   1.415 +  apply(clarsimp simp add:dvd_def)
   1.416 +  apply(rule iffI)
   1.417 +  apply(clarsimp)
   1.418 +  apply(rename_tac n m)
   1.419 +  apply(erule_tac x = "m - n*k" in allE)
   1.420 +  apply(simp add:int_distrib zmult_ac)
   1.421 +  apply(clarsimp)
   1.422 +  apply(rename_tac n m)
   1.423 +  apply(erule_tac x = "m + n*k" in allE)
   1.424 +  apply(simp add:int_distrib zmult_ac)
   1.425 +  done
   1.426 +
   1.427 +(*=============================================================================*)
   1.428 +(*These are the atomic cases for the proof generation for the equivalence of P and P
   1.429 +plusinfinity for integers x greather than some integer z.*)
   1.430 +(*They are fully based on arithmetics*)
   1.431 +
   1.432 +lemma  eq_eq_pinf: "EX z::int. ALL x. z < x --> (( 0 = x +t ) = False )"
   1.433 +  apply(rule_tac x = "-t" in exI)
   1.434 +  apply simp
   1.435 +  done
   1.436 +
   1.437 +lemma  neq_eq_pinf: "EX z::int. ALL x.  z < x --> ((~( 0 = x +t )) = True )"
   1.438 +  apply(rule_tac x = "-t" in exI)
   1.439 +  apply simp
   1.440 +  done
   1.441 +
   1.442 +lemma  le_eq_pinf: "EX z::int. ALL x.  z < x --> ( 0 < x +t  = True )"
   1.443 +  apply(rule_tac x = "-t" in exI)
   1.444 +  apply simp
   1.445 +  done
   1.446 +
   1.447 +lemma  len_eq_pinf: "EX z::int. ALL x. z < x  --> (0 < -x +t  = False )"
   1.448 +  apply(rule_tac x = "t" in exI)
   1.449 +  apply simp
   1.450 +  done
   1.451 +
   1.452 +lemma  dvd_eq_pinf: "EX z::int. ALL x.  z < x --> ((d dvd (x + t)) = (d dvd (x + t))) "
   1.453 +by simp
   1.454 +
   1.455 +lemma  not_dvd_eq_pinf: "EX z::int. ALL x. z < x  --> ((~(d dvd (x + t))) = (~(d dvd (x + t)))) "
   1.456 +by simp
   1.457 +
   1.458 +
   1.459 +
   1.460 +
   1.461 +(*=============================================================================*)
   1.462 +(*These are the atomic cases for the proof generation for the modulo D property for P
   1.463 +minusinfinity*)
   1.464 +(*They are fully based on arithmetics*)
   1.465 +
   1.466 +lemma  dvd_modd_minf: "((d::int) dvd d1) ==>
   1.467 + (ALL (x::int). ALL (k::int). (((d::int) dvd (x + t)) = (d dvd (x-k*d1 + t))))"
   1.468 +apply(clarsimp simp add:dvd_def)
   1.469 +apply(rule iffI)
   1.470 +apply(clarsimp)
   1.471 +apply(rename_tac n m)
   1.472 +apply(rule_tac x = "m - n*k" in exI)
   1.473 +apply(simp add:int_distrib)
   1.474 +apply(clarsimp)
   1.475 +apply(rename_tac n m)
   1.476 +apply(rule_tac x = "m + n*k" in exI)
   1.477 +apply(simp add:int_distrib zmult_ac)
   1.478 +done
   1.479 +
   1.480 +
   1.481 +lemma  not_dvd_modd_minf: "((d::int) dvd d1) ==>
   1.482 + (ALL (x::int). ALL k. (~((d::int) dvd (x + t))) = (~(d dvd (x-k*d1 + t))))"
   1.483 +apply(clarsimp simp add:dvd_def)
   1.484 +apply(rule iffI)
   1.485 +apply(clarsimp)
   1.486 +apply(rename_tac n m)
   1.487 +apply(erule_tac x = "m + n*k" in allE)
   1.488 +apply(simp add:int_distrib zmult_ac)
   1.489 +apply(clarsimp)
   1.490 +apply(rename_tac n m)
   1.491 +apply(erule_tac x = "m - n*k" in allE)
   1.492 +apply(simp add:int_distrib zmult_ac)
   1.493 +done
   1.494 +
   1.495 +
   1.496 +(*=============================================================================*)
   1.497 +(*These are the atomic cases for the proof generation for the equivalence of P and P
   1.498 +minusinfinity for integers x less than some integer z.*)
   1.499 +(*They are fully based on arithmetics*)
   1.500 +
   1.501 +lemma  eq_eq_minf: "EX z::int. ALL x. x < z --> (( 0 = x +t ) = False )"
   1.502 +apply(rule_tac x = "-t" in exI)
   1.503 +apply simp
   1.504 +done
   1.505 +
   1.506 +lemma  neq_eq_minf: "EX z::int. ALL x. x < z --> ((~( 0 = x +t )) = True )"
   1.507 +apply(rule_tac x = "-t" in exI)
   1.508 +apply simp
   1.509 +done
   1.510 +
   1.511 +lemma  le_eq_minf: "EX z::int. ALL x. x < z --> ( 0 < x +t  = False )"
   1.512 +apply(rule_tac x = "-t" in exI)
   1.513 +apply simp
   1.514 +done
   1.515 +
   1.516 +
   1.517 +lemma  len_eq_minf: "EX z::int. ALL x. x < z --> (0 < -x +t  = True )"
   1.518 +apply(rule_tac x = "t" in exI)
   1.519 +apply simp
   1.520 +done
   1.521 +
   1.522 +lemma  dvd_eq_minf: "EX z::int. ALL x. x < z --> ((d dvd (x + t)) = (d dvd (x + t))) "
   1.523 +by simp
   1.524 +
   1.525 +lemma  not_dvd_eq_minf: "EX z::int. ALL x. x < z --> ((~(d dvd (x + t))) = (~(d dvd (x + t)))) "
   1.526 +by simp
   1.527 +
   1.528 +
   1.529 +(*=============================================================================*)
   1.530 +(*This Theorem combines whithnesses about P minusinfinity to schow one component of the
   1.531 +equivalence proof for cooper's theorem*)
   1.532 +
   1.533 +(* FIXME: remove once they are part of the distribution *)
   1.534 +theorem int_ge_induct[consumes 1,case_names base step]:
   1.535 +  assumes ge: "k \<le> (i::int)" and
   1.536 +        base: "P(k)" and
   1.537 +        step: "\<And>i. \<lbrakk>k \<le> i; P i\<rbrakk> \<Longrightarrow> P(i+1)"
   1.538 +  shows "P i"
   1.539 +proof -
   1.540 +  { fix n have "\<And>i::int. n = nat(i-k) \<Longrightarrow> k <= i \<Longrightarrow> P i"
   1.541 +    proof (induct n)
   1.542 +      case 0
   1.543 +      hence "i = k" by arith
   1.544 +      thus "P i" using base by simp
   1.545 +    next
   1.546 +      case (Suc n)
   1.547 +      hence "n = nat((i - 1) - k)" by arith
   1.548 +      moreover
   1.549 +      have ki1: "k \<le> i - 1" using Suc.prems by arith
   1.550 +      ultimately
   1.551 +      have "P(i - 1)" by(rule Suc.hyps)
   1.552 +      from step[OF ki1 this] show ?case by simp
   1.553 +    qed
   1.554 +  }
   1.555 +  from this ge show ?thesis by fast
   1.556 +qed
   1.557 +
   1.558 +theorem int_gr_induct[consumes 1,case_names base step]:
   1.559 +  assumes gr: "k < (i::int)" and
   1.560 +        base: "P(k+1)" and
   1.561 +        step: "\<And>i. \<lbrakk>k < i; P i\<rbrakk> \<Longrightarrow> P(i+1)"
   1.562 +  shows "P i"
   1.563 +apply(rule int_ge_induct[of "k + 1"])
   1.564 +  using gr apply arith
   1.565 + apply(rule base)
   1.566 +apply(rule step)
   1.567 + apply simp+
   1.568 +done
   1.569 +
   1.570 +lemma decr_lemma: "0 < (d::int) \<Longrightarrow> x - (abs(x-z)+1) * d < z"
   1.571 +apply(induct rule: int_gr_induct)
   1.572 + apply simp
   1.573 + apply arith
   1.574 +apply (simp add:int_distrib)
   1.575 +apply arith
   1.576 +done
   1.577 +
   1.578 +lemma incr_lemma: "0 < (d::int) \<Longrightarrow> z < x + (abs(x-z)+1) * d"
   1.579 +apply(induct rule: int_gr_induct)
   1.580 + apply simp
   1.581 + apply arith
   1.582 +apply (simp add:int_distrib)
   1.583 +apply arith
   1.584 +done
   1.585 +
   1.586 +lemma  minusinfinity:
   1.587 +  assumes "0 < d" and
   1.588 +    P1eqP1: "ALL x k. P1 x = P1(x - k*d)" and
   1.589 +    ePeqP1: "EX z::int. ALL x. x < z \<longrightarrow> (P x = P1 x)"
   1.590 +  shows "(EX x. P1 x) \<longrightarrow> (EX x. P x)"
   1.591 +proof
   1.592 +  assume eP1: "EX x. P1 x"
   1.593 +  then obtain x where P1: "P1 x" ..
   1.594 +  from ePeqP1 obtain z where P1eqP: "ALL x. x < z \<longrightarrow> (P x = P1 x)" ..
   1.595 +  let ?w = "x - (abs(x-z)+1) * d"
   1.596 +  show "EX x. P x"
   1.597 +  proof
   1.598 +    have w: "?w < z" by(rule decr_lemma)
   1.599 +    have "P1 x = P1 ?w" using P1eqP1 by blast
   1.600 +    also have "\<dots> = P(?w)" using w P1eqP by blast
   1.601 +    finally show "P ?w" using P1 by blast
   1.602 +  qed
   1.603 +qed
   1.604 +
   1.605 +(*=============================================================================*)
   1.606 +(*This Theorem combines whithnesses about P minusinfinity to schow one component of the
   1.607 +equivalence proof for cooper's theorem*)
   1.608 +
   1.609 +lemma plusinfinity:
   1.610 +  assumes "0 < d" and
   1.611 +    P1eqP1: "ALL (x::int) (k::int). P1 x = P1 (x + k * d)" and
   1.612 +    ePeqP1: "EX z::int. ALL x. z < x  --> (P x = P1 x)"
   1.613 +  shows "(EX x::int. P1 x) --> (EX x::int. P x)"
   1.614 +proof
   1.615 +  assume eP1: "EX x. P1 x"
   1.616 +  then obtain x where P1: "P1 x" ..
   1.617 +  from ePeqP1 obtain z where P1eqP: "ALL x. z < x \<longrightarrow> (P x = P1 x)" ..
   1.618 +  let ?w = "x + (abs(x-z)+1) * d"
   1.619 +  show "EX x. P x"
   1.620 +  proof
   1.621 +    have w: "z < ?w" by(rule incr_lemma)
   1.622 +    have "P1 x = P1 ?w" using P1eqP1 by blast
   1.623 +    also have "\<dots> = P(?w)" using w P1eqP by blast
   1.624 +    finally show "P ?w" using P1 by blast
   1.625 +  qed
   1.626 +qed
   1.627 + 
   1.628 +
   1.629 +
   1.630 +(*=============================================================================*)
   1.631 +(*Theorem for periodic function on discrete sets*)
   1.632 +
   1.633 +lemma minf_vee:
   1.634 +  assumes dpos: "(0::int) < d" and modd: "ALL x k. P x = P(x - k*d)"
   1.635 +  shows "(EX x. P x) = (EX j : {1..d}. P j)"
   1.636 +  (is "?LHS = ?RHS")
   1.637 +proof
   1.638 +  assume ?LHS
   1.639 +  then obtain x where P: "P x" ..
   1.640 +  have "x mod d = x - (x div d)*d"
   1.641 +    by(simp add:zmod_zdiv_equality zmult_ac eq_zdiff_eq)
   1.642 +  hence Pmod: "P x = P(x mod d)" using modd by simp
   1.643 +  show ?RHS
   1.644 +  proof (cases)
   1.645 +    assume "x mod d = 0"
   1.646 +    hence "P 0" using P Pmod by simp
   1.647 +    moreover have "P 0 = P(0 - (-1)*d)" using modd by blast
   1.648 +    ultimately have "P d" by simp
   1.649 +    moreover have "d : {1..d}" using dpos by(simp add:atLeastAtMost_iff)
   1.650 +    ultimately show ?RHS ..
   1.651 +  next
   1.652 +    assume not0: "x mod d \<noteq> 0"
   1.653 +    have "P(x mod d)" using dpos P Pmod by(simp add:pos_mod_sign pos_mod_bound)
   1.654 +    moreover have "x mod d : {1..d}"
   1.655 +    proof -
   1.656 +      have "0 \<le> x mod d" by(rule pos_mod_sign)
   1.657 +      moreover have "x mod d < d" by(rule pos_mod_bound)
   1.658 +      ultimately show ?thesis using not0 by(simp add:atLeastAtMost_iff)
   1.659 +    qed
   1.660 +    ultimately show ?RHS ..
   1.661 +  qed
   1.662 +next
   1.663 +  assume ?RHS thus ?LHS by blast
   1.664 +qed
   1.665 +
   1.666 +(*=============================================================================*)
   1.667 +(*Theorem for periodic function on discrete sets*)
   1.668 +lemma pinf_vee:
   1.669 +  assumes dpos: "0 < (d::int)" and modd: "ALL (x::int) (k::int). P x = P (x+k*d)"
   1.670 +  shows "(EX x::int. P x) = (EX (j::int) : {1..d} . P j)"
   1.671 +  (is "?LHS = ?RHS")
   1.672 +proof
   1.673 +  assume ?LHS
   1.674 +  then obtain x where P: "P x" ..
   1.675 +  have "x mod d = x + (-(x div d))*d"
   1.676 +    by(simp add:zmod_zdiv_equality zmult_ac eq_zdiff_eq)
   1.677 +  hence Pmod: "P x = P(x mod d)" using modd by (simp only:)
   1.678 +  show ?RHS
   1.679 +  proof (cases)
   1.680 +    assume "x mod d = 0"
   1.681 +    hence "P 0" using P Pmod by simp
   1.682 +    moreover have "P 0 = P(0 + 1*d)" using modd by blast
   1.683 +    ultimately have "P d" by simp
   1.684 +    moreover have "d : {1..d}" using dpos by(simp add:atLeastAtMost_iff)
   1.685 +    ultimately show ?RHS ..
   1.686 +  next
   1.687 +    assume not0: "x mod d \<noteq> 0"
   1.688 +    have "P(x mod d)" using dpos P Pmod by(simp add:pos_mod_sign pos_mod_bound)
   1.689 +    moreover have "x mod d : {1..d}"
   1.690 +    proof -
   1.691 +      have "0 \<le> x mod d" by(rule pos_mod_sign)
   1.692 +      moreover have "x mod d < d" by(rule pos_mod_bound)
   1.693 +      ultimately show ?thesis using not0 by(simp add:atLeastAtMost_iff)
   1.694 +    qed
   1.695 +    ultimately show ?RHS ..
   1.696 +  qed
   1.697 +next
   1.698 +  assume ?RHS thus ?LHS by blast
   1.699 +qed
   1.700 +
   1.701 +lemma decr_mult_lemma:
   1.702 +  assumes dpos: "(0::int) < d" and
   1.703 +          minus: "ALL x::int. P x \<longrightarrow> P(x - d)" and
   1.704 +          knneg: "0 <= k"
   1.705 +  shows "ALL x. P x \<longrightarrow> P(x - k*d)"
   1.706 +using knneg
   1.707 +proof (induct rule:int_ge_induct)
   1.708 +  case base thus ?case by simp
   1.709 +next
   1.710 +  case (step i)
   1.711 +  show ?case
   1.712 +  proof
   1.713 +    fix x
   1.714 +    have "P x \<longrightarrow> P (x - i * d)" using step.hyps by blast
   1.715 +    also have "\<dots> \<longrightarrow> P(x - (i + 1) * d)"
   1.716 +      using minus[THEN spec, of "x - i * d"]
   1.717 +      by (simp add:int_distrib zdiff_zdiff_eq[symmetric])
   1.718 +    ultimately show "P x \<longrightarrow> P(x - (i + 1) * d)" by blast
   1.719 +  qed
   1.720 +qed
   1.721 +
   1.722 +lemma incr_mult_lemma:
   1.723 +  assumes dpos: "(0::int) < d" and
   1.724 +          plus: "ALL x::int. P x \<longrightarrow> P(x + d)" and
   1.725 +          knneg: "0 <= k"
   1.726 +  shows "ALL x. P x \<longrightarrow> P(x + k*d)"
   1.727 +using knneg
   1.728 +proof (induct rule:int_ge_induct)
   1.729 +  case base thus ?case by simp
   1.730 +next
   1.731 +  case (step i)
   1.732 +  show ?case
   1.733 +  proof
   1.734 +    fix x
   1.735 +    have "P x \<longrightarrow> P (x + i * d)" using step.hyps by blast
   1.736 +    also have "\<dots> \<longrightarrow> P(x + (i + 1) * d)"
   1.737 +      using plus[THEN spec, of "x + i * d"]
   1.738 +      by (simp add:int_distrib zadd_ac)
   1.739 +    ultimately show "P x \<longrightarrow> P(x + (i + 1) * d)" by blast
   1.740 +  qed
   1.741 +qed
   1.742 +
   1.743 +lemma cpmi_eq: "0 < D \<Longrightarrow> (EX z::int. ALL x. x < z --> (P x = P1 x))
   1.744 +==> (EX (j::int) : {1..D}. EX (b::int) : B. P (b+j)) --> (EX (x::int). P x) 
   1.745 +==> ALL x.~(EX (j::int) : {1..D}. EX (b::int) : B. P(b+j)) --> P (x) --> P (x - D) 
   1.746 +==> (ALL (x::int). ALL (k::int). ((P1 x)= (P1 (x-k*D))))
   1.747 +==> (EX (x::int). P(x)) = ((EX (j::int) : {1..D} . (P1(j))) | (EX (j::int) : {1..D}. EX (b::int) : B. P (b+j)))"
   1.748 +apply(rule iffI)
   1.749 +prefer 2
   1.750 +apply(drule minusinfinity)
   1.751 +apply assumption+
   1.752 +apply(fastsimp)
   1.753 +apply clarsimp
   1.754 +apply(subgoal_tac "!!k. 0<=k \<Longrightarrow> !x. P x \<longrightarrow> P (x - k*D)")
   1.755 +apply(frule_tac x = x and z=z in decr_lemma)
   1.756 +apply(subgoal_tac "P1(x - (\<bar>x - z\<bar> + 1) * D)")
   1.757 +prefer 2
   1.758 +apply(subgoal_tac "0 <= (\<bar>x - z\<bar> + 1)")
   1.759 +prefer 2 apply arith
   1.760 + apply fastsimp
   1.761 +apply(drule (1) minf_vee)
   1.762 +apply blast
   1.763 +apply(blast dest:decr_mult_lemma)
   1.764 +done
   1.765 +
   1.766 +(* Cooper Thm `, plus infinity version*)
   1.767 +lemma cppi_eq: "0 < D \<Longrightarrow> (EX z::int. ALL x. z < x --> (P x = P1 x))
   1.768 +==> (EX (j::int) : {1..D}. EX (a::int) : A. P (a - j)) --> (EX (x::int). P x) 
   1.769 +==> ALL x.~(EX (j::int) : {1..D}. EX (a::int) : A. P(a - j)) --> P (x) --> P (x + D) 
   1.770 +==> (ALL (x::int). ALL (k::int). ((P1 x)= (P1 (x+k*D))))
   1.771 +==> (EX (x::int). P(x)) = ((EX (j::int) : {1..D} . (P1(j))) | (EX (j::int) : {1..D}. EX (a::int) : A. P (a - j)))"
   1.772 +  apply(rule iffI)
   1.773 +  prefer 2
   1.774 +  apply(drule plusinfinity)
   1.775 +  apply assumption+
   1.776 +  apply(fastsimp)
   1.777 +  apply clarsimp
   1.778 +  apply(subgoal_tac "!!k. 0<=k \<Longrightarrow> !x. P x \<longrightarrow> P (x + k*D)")
   1.779 +  apply(frule_tac x = x and z=z in incr_lemma)
   1.780 +  apply(subgoal_tac "P1(x + (\<bar>x - z\<bar> + 1) * D)")
   1.781 +  prefer 2
   1.782 +  apply(subgoal_tac "0 <= (\<bar>x - z\<bar> + 1)")
   1.783 +  prefer 2 apply arith
   1.784 +  apply fastsimp
   1.785 +  apply(drule (1) pinf_vee)
   1.786 +  apply blast
   1.787 +  apply(blast dest:incr_mult_lemma)
   1.788 +  done
   1.789 +
   1.790 +
   1.791 +(*=============================================================================*)
   1.792 +
   1.793 +(*Theorems for the quantifier elminination Functions.*)
   1.794 +
   1.795 +lemma qe_ex_conj: "(EX (x::int). A x) = R
   1.796 +		==> (EX (x::int). P x) = (Q & (EX x::int. A x))
   1.797 +		==> (EX (x::int). P x) = (Q & R)"
   1.798 +by blast
   1.799 +
   1.800 +lemma qe_ex_nconj: "(EX (x::int). P x) = (True & Q)
   1.801 +		==> (EX (x::int). P x) = Q"
   1.802 +by blast
   1.803 +
   1.804 +lemma qe_conjI: "P1 = P2 ==> Q1 = Q2 ==> (P1 & Q1) = (P2 & Q2)"
   1.805 +by blast
   1.806 +
   1.807 +lemma qe_disjI: "P1 = P2 ==> Q1 = Q2 ==> (P1 | Q1) = (P2 | Q2)"
   1.808 +by blast
   1.809 +
   1.810 +lemma qe_impI: "P1 = P2 ==> Q1 = Q2 ==> (P1 --> Q1) = (P2 --> Q2)"
   1.811 +by blast
   1.812 +
   1.813 +lemma qe_eqI: "P1 = P2 ==> Q1 = Q2 ==> (P1 = Q1) = (P2 = Q2)"
   1.814 +by blast
   1.815 +
   1.816 +lemma qe_Not: "P = Q ==> (~P) = (~Q)"
   1.817 +by blast
   1.818 +
   1.819 +lemma qe_ALL: "(EX x. ~P x) = R ==> (ALL x. P x) = (~R)"
   1.820 +by blast
   1.821 +
   1.822 +(* Theorems for proving NNF *)
   1.823 +
   1.824 +lemma nnf_im: "((~P) = P1) ==> (Q=Q1) ==> ((P --> Q) = (P1 | Q1))"
   1.825 +by blast
   1.826 +
   1.827 +lemma nnf_eq: "((P & Q) = (P1 & Q1)) ==> (((~P) & (~Q)) = (P2 & Q2)) ==> ((P = Q) = ((P1 & Q1)|(P2 & Q2)))"
   1.828 +by blast
   1.829 +
   1.830 +lemma nnf_nn: "(P = Q) ==> ((~~P) = Q)"
   1.831 +  by blast
   1.832 +lemma nnf_ncj: "((~P) = P1) ==> ((~Q) = Q1) ==> ((~(P & Q)) = (P1 | Q1))"
   1.833 +by blast
   1.834 +
   1.835 +lemma nnf_ndj: "((~P) = P1) ==> ((~Q) = Q1) ==> ((~(P | Q)) = (P1 & Q1))"
   1.836 +by blast
   1.837 +lemma nnf_nim: "(P = P1) ==> ((~Q) = Q1) ==> ((~(P --> Q)) = (P1 & Q1))"
   1.838 +by blast
   1.839 +lemma nnf_neq: "((P & (~Q)) = (P1 & Q1)) ==> (((~P) & Q) = (P2 & Q2)) ==> ((~(P = Q)) = ((P1 & Q1)|(P2 & Q2)))"
   1.840 +by blast
   1.841 +lemma nnf_sdj: "((A & (~B)) = (A1 & B1)) ==> ((C & (~D)) = (C1 & D1)) ==> (A = (~C)) ==> ((~((A & B) | (C & D))) = ((A1 & B1) | (C1 & D1)))"
   1.842 +by blast
   1.843 +
   1.844 +
   1.845 +lemma qe_exI2: "A = B ==> (EX (x::int). A(x)) = (EX (x::int). B(x))"
   1.846 +  by simp
   1.847 +
   1.848 +lemma qe_exI: "(!!x::int. A x = B x) ==> (EX (x::int). A(x)) = (EX (x::int). B(x))"
   1.849 +  by rules
   1.850 +
   1.851 +lemma qe_ALLI: "(!!x::int. A x = B x) ==> (ALL (x::int). A(x)) = (ALL (x::int). B(x))"
   1.852 +  by rules
   1.853 +
   1.854 +lemma cp_expand: "(EX (x::int). P (x)) = (EX (j::int) : {1..d}. EX (b::int) : B. (P1 (j) | P(b+j)))
   1.855 +==>(EX (x::int). P (x)) = (EX (j::int) : {1..d}. EX (b::int) : B. (P1 (j) | P(b+j))) "
   1.856 +by blast
   1.857 +
   1.858 +lemma cppi_expand: "(EX (x::int). P (x)) = (EX (j::int) : {1..d}. EX (a::int) : A. (P1 (j) | P(a - j)))
   1.859 +==>(EX (x::int). P (x)) = (EX (j::int) : {1..d}. EX (a::int) : A. (P1 (j) | P(a - j))) "
   1.860 +by blast
   1.861 +
   1.862 +
   1.863 +lemma simp_from_to: "{i..j::int} = (if j < i then {} else insert i {i+1..j})"
   1.864 +apply(simp add:atLeastAtMost_def atLeast_def atMost_def)
   1.865 +apply(fastsimp)
   1.866 +done
   1.867 +
   1.868 +(* Theorems required for the adjustcoeffitienteq*)
   1.869 +
   1.870 +lemma ac_dvd_eq: assumes not0: "0 ~= (k::int)"
   1.871 +shows "((m::int) dvd (c*n+t)) = (k*m dvd ((k*c)*n+(k*t)))" (is "?P = ?Q")
   1.872 +proof
   1.873 +  assume ?P
   1.874 +  thus ?Q
   1.875 +    apply(simp add:dvd_def)
   1.876 +    apply clarify
   1.877 +    apply(rename_tac d)
   1.878 +    apply(drule_tac f = "op * k" in arg_cong)
   1.879 +    apply(simp only:int_distrib)
   1.880 +    apply(rule_tac x = "d" in exI)
   1.881 +    apply(simp only:zmult_ac)
   1.882 +    done
   1.883 +next
   1.884 +  assume ?Q
   1.885 +  then obtain d where "k * c * n + k * t = (k*m)*d" by(fastsimp simp:dvd_def)
   1.886 +  hence "(c * n + t) * k = (m*d) * k" by(simp add:int_distrib zmult_ac)
   1.887 +  hence "((c * n + t) * k) div k = ((m*d) * k) div k" by(rule arg_cong[of _ _ "%t. t div k"])
   1.888 +  hence "c*n+t = m*d" by(simp add: zdiv_zmult_self1[OF not0[symmetric]])
   1.889 +  thus ?P by(simp add:dvd_def)
   1.890 +qed
   1.891 +
   1.892 +lemma ac_lt_eq: assumes gr0: "0 < (k::int)"
   1.893 +shows "((m::int) < (c*n+t)) = (k*m <((k*c)*n+(k*t)))" (is "?P = ?Q")
   1.894 +proof
   1.895 +  assume P: ?P
   1.896 +  show ?Q using zmult_zless_mono2[OF P gr0] by(simp add: int_distrib zmult_ac)
   1.897 +next
   1.898 +  assume ?Q
   1.899 +  hence "0 < k*(c*n + t - m)" by(simp add: int_distrib zmult_ac)
   1.900 +  with gr0 have "0 < (c*n + t - m)" by(simp add:int_0_less_mult_iff)
   1.901 +  thus ?P by(simp)
   1.902 +qed
   1.903 +
   1.904 +lemma ac_eq_eq : assumes not0: "0 ~= (k::int)" shows "((m::int) = (c*n+t)) = (k*m =((k*c)*n+(k*t)) )" (is "?P = ?Q")
   1.905 +proof
   1.906 +  assume ?P
   1.907 +  thus ?Q
   1.908 +    apply(drule_tac f = "op * k" in arg_cong)
   1.909 +    apply(simp only:int_distrib)
   1.910 +    done
   1.911 +next
   1.912 +  assume ?Q
   1.913 +  hence "m * k = (c*n + t) * k" by(simp add:int_distrib zmult_ac)
   1.914 +  hence "((m) * k) div k = ((c*n + t) * k) div k" by(rule arg_cong[of _ _ "%t. t div k"])
   1.915 +  thus ?P by(simp add: zdiv_zmult_self1[OF not0[symmetric]])
   1.916 +qed
   1.917 +
   1.918 +lemma ac_pi_eq: assumes gr0: "0 < (k::int)" shows "(~((0::int) < (c*n + t))) = (0 < ((-k)*c)*n + ((-k)*t + k))"
   1.919 +proof -
   1.920 +  have "(~ (0::int) < (c*n + t)) = (0<1-(c*n + t))" by arith
   1.921 +  also have  "(1-(c*n + t)) = (-1*c)*n + (-t+1)" by(simp add: int_distrib zmult_ac)
   1.922 +  also have "0<(-1*c)*n + (-t+1) = (0 < (k*(-1*c)*n) + (k*(-t+1)))" by(rule ac_lt_eq[of _ 0,OF gr0,simplified])
   1.923 +  also have "(k*(-1*c)*n) + (k*(-t+1)) = ((-k)*c)*n + ((-k)*t + k)" by(simp add: int_distrib zmult_ac)
   1.924 +  finally show ?thesis .
   1.925 +qed
   1.926 +
   1.927 +lemma binminus_uminus_conv: "(a::int) - b = a + (-b)"
   1.928 +by arith
   1.929 +
   1.930 +lemma  linearize_dvd: "(t::int) = t1 ==> (d dvd t) = (d dvd t1)"
   1.931 +by simp
   1.932 +
   1.933 +lemma lf_lt: "(l::int) = ll ==> (r::int) = lr ==> (l < r) =(ll < lr)"
   1.934 +by simp
   1.935 +
   1.936 +lemma lf_eq: "(l::int) = ll ==> (r::int) = lr ==> (l = r) =(ll = lr)"
   1.937 +by simp
   1.938 +
   1.939 +lemma lf_dvd: "(l::int) = ll ==> (r::int) = lr ==> (l dvd r) =(ll dvd lr)"
   1.940 +by simp
   1.941 +
   1.942 +(* Theorems for transforming predicates on nat to predicates on int*)
   1.943 +
   1.944 +theorem all_nat: "(\<forall>x::nat. P x) = (\<forall>x::int. 0 <= x \<longrightarrow> P (nat x))"
   1.945 +  by (simp split add: split_nat)
   1.946 +
   1.947 +theorem ex_nat: "(\<exists>x::nat. P x) = (\<exists>x::int. 0 <= x \<and> P (nat x))"
   1.948 +  apply (simp split add: split_nat)
   1.949 +  apply (rule iffI)
   1.950 +  apply (erule exE)
   1.951 +  apply (rule_tac x = "int x" in exI)
   1.952 +  apply simp
   1.953 +  apply (erule exE)
   1.954 +  apply (rule_tac x = "nat x" in exI)
   1.955 +  apply (erule conjE)
   1.956 +  apply (erule_tac x = "nat x" in allE)
   1.957 +  apply simp
   1.958 +  done
   1.959 +
   1.960 +theorem zdiff_int_split: "P (int (x - y)) =
   1.961 +  ((y \<le> x \<longrightarrow> P (int x - int y)) \<and> (x < y \<longrightarrow> P 0))"
   1.962 +  apply (case_tac "y \<le> x")
   1.963 +  apply (simp_all add: zdiff_int)
   1.964 +  done
   1.965 +
   1.966 +theorem zdvd_int: "(x dvd y) = (int x dvd int y)"
   1.967 +  apply (simp only: dvd_def ex_nat int_int_eq [symmetric] zmult_int [symmetric]
   1.968 +    nat_0_le cong add: conj_cong)
   1.969 +  apply (rule iffI)
   1.970 +  apply rules
   1.971 +  apply (erule exE)
   1.972 +  apply (case_tac "x=0")
   1.973 +  apply (rule_tac x=0 in exI)
   1.974 +  apply simp
   1.975 +  apply (case_tac "0 \<le> k")
   1.976 +  apply rules
   1.977 +  apply (simp add: linorder_not_le)
   1.978 +  apply (drule zmult_zless_mono2_neg [OF iffD2 [OF zero_less_int_conv]])
   1.979 +  apply assumption
   1.980 +  apply (simp add: zmult_ac)
   1.981 +  done
   1.982 +
   1.983 +theorem number_of1: "(0::int) <= number_of n \<Longrightarrow> (0::int) <= number_of (n BIT b)"
   1.984 +  by simp
   1.985 +
   1.986 +theorem number_of2: "(0::int) <= number_of bin.Pls" by simp
   1.987 +
   1.988 +theorem Suc_plus1: "Suc n = n + 1" by simp
   1.989 +
   1.990 +(* specific instances of congruence rules, to prevent simplifier from looping *)
   1.991 +
   1.992 +theorem imp_le_cong: "(0 <= x \<Longrightarrow> P = P') \<Longrightarrow> (0 <= (x::nat) \<longrightarrow> P) = (0 <= x \<longrightarrow> P')"
   1.993 +  by simp
   1.994 +
   1.995 +theorem conj_le_cong: "(0 <= x \<Longrightarrow> P = P') \<Longrightarrow> (0 <= (x::nat) \<and> P) = (0 <= x \<and> P')"
   1.996 +  by simp
   1.997 +
   1.998 +use "cooper_dec.ML"
   1.999 +use "cooper_proof.ML"
  1.1000 +use "qelim.ML"
  1.1001 +use "presburger.ML"
  1.1002 +
  1.1003 +setup "Presburger.setup"
  1.1004 +
  1.1005 +end
     2.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     2.2 +++ b/src/HOL/Integ/cooper_dec.ML	Tue Mar 25 09:47:05 2003 +0100
     2.3 @@ -0,0 +1,773 @@
     2.4 +(*  Title:      HOL/Integ/cooper_dec.ML
     2.5 +    ID:         $Id$
     2.6 +    Author:     Amine Chaieb and Tobias Nipkow, TU Muenchen
     2.7 +    License:    GPL (GNU GENERAL PUBLIC LICENSE)
     2.8 +
     2.9 +File containing the implementation of Cooper Algorithm
    2.10 +decision procedure (intensively inspired from J.Harrison)
    2.11 +*)
    2.12 + 
    2.13 +signature COOPER_DEC = 
    2.14 +sig
    2.15 +  exception COOPER
    2.16 +  val is_arith_rel : term -> bool
    2.17 +  val mk_numeral : int -> term
    2.18 +  val dest_numeral : term -> int
    2.19 +  val zero : term
    2.20 +  val one : term
    2.21 +  val linear_cmul : int -> term -> term
    2.22 +  val linear_add : string list -> term -> term -> term 
    2.23 +  val linear_sub : string list -> term -> term -> term 
    2.24 +  val linear_neg : term -> term
    2.25 +  val lint : string list -> term -> term
    2.26 +  val linform : string list -> term -> term
    2.27 +  val formlcm : term -> term -> int
    2.28 +  val adjustcoeff : term -> int -> term -> term
    2.29 +  val unitycoeff : term -> term -> term
    2.30 +  val divlcm : term -> term -> int
    2.31 +  val bset : term -> term -> term list
    2.32 +  val aset : term -> term -> term list
    2.33 +  val linrep : string list -> term -> term -> term -> term
    2.34 +  val list_disj : term list -> term
    2.35 +  val simpl : term -> term
    2.36 +  val fv : term -> string list
    2.37 +  val negate : term -> term
    2.38 +  val operations : (string * (int * int -> bool)) list
    2.39 +end;
    2.40 +
    2.41 +structure  CooperDec : COOPER_DEC =
    2.42 +struct
    2.43 +
    2.44 +(* ========================================================================= *) 
    2.45 +(* Cooper's algorithm for Presburger arithmetic.                             *) 
    2.46 +(* ========================================================================= *) 
    2.47 +exception COOPER;
    2.48 +
    2.49 +(* ------------------------------------------------------------------------- *) 
    2.50 +(* Lift operations up to numerals.                                           *) 
    2.51 +(* ------------------------------------------------------------------------- *) 
    2.52 + 
    2.53 +(*Assumption : The construction of atomar formulas in linearl arithmetic is based on 
    2.54 +relation operations of Type : [int,int]---> bool *) 
    2.55 + 
    2.56 +(* ------------------------------------------------------------------------- *) 
    2.57 + 
    2.58 + 
    2.59 +(*Function is_arith_rel returns true if and only if the term is an atomar presburger 
    2.60 +formula *) 
    2.61 +fun is_arith_rel tm = case tm of 
    2.62 +	 Const(p,Type ("fun",[Type ("Numeral.bin", []),Type ("fun",[Type ("Numeral.bin", 
    2.63 +	 []),Type ("bool",[])] )])) $ _ $_ => true 
    2.64 +	|Const(p,Type ("fun",[Type ("IntDef.int", []),Type ("fun",[Type ("IntDef.int", 
    2.65 +	 []),Type ("bool",[])] )])) $ _ $_ => true 
    2.66 +	|_ => false; 
    2.67 + 
    2.68 +(*Function is_arith_rel returns true if and only if the term is an operation of the 
    2.69 +form [int,int]---> int*) 
    2.70 + 
    2.71 +(*Transform a natural number to a term*) 
    2.72 + 
    2.73 +fun mk_numeral 0 = Const("0",HOLogic.intT)
    2.74 +   |mk_numeral 1 = Const("1",HOLogic.intT)
    2.75 +   |mk_numeral n = (HOLogic.number_of_const HOLogic.intT) $ (HOLogic.mk_bin n); 
    2.76 + 
    2.77 +(*Transform an Term to an natural number*)	  
    2.78 +	  
    2.79 +fun dest_numeral (Const("0",Type ("IntDef.int", []))) = 0
    2.80 +   |dest_numeral (Const("1",Type ("IntDef.int", []))) = 1
    2.81 +   |dest_numeral (Const ("Numeral.number_of",_) $ n)= HOLogic.dest_binum n; 
    2.82 +(*Some terms often used for pattern matching*) 
    2.83 + 
    2.84 +val zero = mk_numeral 0; 
    2.85 +val one = mk_numeral 1; 
    2.86 + 
    2.87 +(*Tests if a Term is representing a number*) 
    2.88 + 
    2.89 +fun is_numeral t = (t = zero) orelse (t = one) orelse (can dest_numeral t); 
    2.90 + 
    2.91 +(*maps a unary natural function on a term containing an natural number*) 
    2.92 + 
    2.93 +fun numeral1 f n = mk_numeral (f(dest_numeral n)); 
    2.94 + 
    2.95 +(*maps a binary natural function on 2 term containing  natural numbers*) 
    2.96 + 
    2.97 +fun numeral2 f m n = mk_numeral(f(dest_numeral m) (dest_numeral n)); 
    2.98 + 
    2.99 +(* ------------------------------------------------------------------------- *) 
   2.100 +(* Operations on canonical linear terms c1 * x1 + ... + cn * xn + k          *) 
   2.101 +(*                                                                           *) 
   2.102 +(* Note that we're quite strict: the ci must be present even if 1            *) 
   2.103 +(* (but if 0 we expect the monomial to be omitted) and k must be there       *) 
   2.104 +(* even if it's zero. Thus, it's a constant iff not an addition term.        *) 
   2.105 +(* ------------------------------------------------------------------------- *) 
   2.106 + 
   2.107 + 
   2.108 +fun linear_cmul n tm =  if n = 0 then zero else let fun times n k = n*k in  
   2.109 +  ( case tm of  
   2.110 +     (Const("op +",T)  $  (Const ("op *",T1 ) $c1 $  x1) $ rest) => 
   2.111 +       Const("op +",T) $ ((Const("op *",T1) $ (numeral1 (times n) c1) $ x1)) $ (linear_cmul n rest) 
   2.112 +    |_ =>  numeral1 (times n) tm) 
   2.113 +    end ; 
   2.114 + 
   2.115 + 
   2.116 + 
   2.117 + 
   2.118 +(* Whether the first of two items comes earlier in the list  *) 
   2.119 +fun earlier [] x y = false 
   2.120 +	|earlier (h::t) x y =if h = y then false 
   2.121 +              else if h = x then true 
   2.122 +              	else earlier t x y ; 
   2.123 + 
   2.124 +fun earlierv vars (Bound i) (Bound j) = i < j 
   2.125 +   |earlierv vars (Bound _) _ = true 
   2.126 +   |earlierv vars _ (Bound _)  = false 
   2.127 +   |earlierv vars (Free (x,_)) (Free (y,_)) = earlier vars x y; 
   2.128 + 
   2.129 + 
   2.130 +fun linear_add vars tm1 tm2 = 
   2.131 +  let fun addwith x y = x + y in
   2.132 + (case (tm1,tm2) of 
   2.133 +	((Const ("op +",T1) $ ( Const("op *",T2) $ c1 $  x1) $ rest1),(Const 
   2.134 +	("op +",T3)$( Const("op *",T4) $ c2 $  x2) $ rest2)) => 
   2.135 +         if x1 = x2 then 
   2.136 +              let val c = (numeral2 (addwith) c1 c2) 
   2.137 +	      in 
   2.138 +              if c = zero then (linear_add vars rest1  rest2)  
   2.139 +	      else (Const("op +",T1) $ (Const("op *",T2) $ c $ x1) $ (linear_add vars  rest1 rest2)) 
   2.140 +              end 
   2.141 +	   else 
   2.142 +		if earlierv vars x1 x2 then (Const("op +",T1) $  
   2.143 +		(Const("op *",T2)$ c1 $ x1) $ (linear_add vars rest1 tm2)) 
   2.144 +    	       else (Const("op +",T1) $ (Const("op *",T2) $ c2 $ x2) $ (linear_add vars tm1 rest2)) 
   2.145 +   	|((Const("op +",T1) $ (Const("op *",T2) $ c1 $ x1) $ rest1) ,_) => 
   2.146 +    	  (Const("op +",T1)$ (Const("op *",T2) $ c1 $ x1) $ (linear_add vars 
   2.147 +	  rest1 tm2)) 
   2.148 +   	|(_, (Const("op +",T1) $(Const("op *",T2) $ c2 $ x2) $ rest2)) => 
   2.149 +      	  (Const("op +",T1) $ (Const("op *",T2) $ c2 $ x2) $ (linear_add vars tm1 
   2.150 +	  rest2)) 
   2.151 +   	| (_,_) => numeral2 (addwith) tm1 tm2) 
   2.152 +	 
   2.153 +	end; 
   2.154 + 
   2.155 +(*To obtain the unary - applyed on a formula*) 
   2.156 + 
   2.157 +fun linear_neg tm = linear_cmul (0 - 1) tm; 
   2.158 + 
   2.159 +(*Substraction of two terms *) 
   2.160 + 
   2.161 +fun linear_sub vars tm1 tm2 = linear_add vars tm1 (linear_neg tm2); 
   2.162 + 
   2.163 + 
   2.164 +(* ------------------------------------------------------------------------- *) 
   2.165 +(* Linearize a term.                                                         *) 
   2.166 +(* ------------------------------------------------------------------------- *) 
   2.167 + 
   2.168 +(* linearises a term from the point of view of Variable Free (x,T). 
   2.169 +After this fuction the all expressions containig ths variable will have the form  
   2.170 + c*Free(x,T) + t where c is a constant ant t is a Term which is not containing 
   2.171 + Free(x,T)*) 
   2.172 +  
   2.173 +fun lint vars tm = if is_numeral tm then tm else case tm of 
   2.174 +   (Free (x,T)) =>  (HOLogic.mk_binop "op +" ((HOLogic.mk_binop "op *" ((mk_numeral 1),Free (x,T))), zero)) 
   2.175 +  |(Bound i) =>  (Const("op +",HOLogic.intT -->HOLogic.intT -->HOLogic.intT) $ 
   2.176 +  (Const("op *",HOLogic.intT -->HOLogic.intT -->HOLogic.intT) $ (mk_numeral 1) $ (Bound i)) $ zero) 
   2.177 +  |(Const("uminus",_) $ t ) => (linear_neg (lint vars t)) 
   2.178 +  |(Const("op +",_) $ s $ t) => (linear_add vars (lint vars s) (lint vars t)) 
   2.179 +  |(Const("op -",_) $ s $ t) => (linear_sub vars (lint vars s) (lint vars t)) 
   2.180 +  |(Const ("op *",_) $ s $ t) => 
   2.181 +        let val s' = lint vars s  
   2.182 +            val t' = lint vars t  
   2.183 +        in 
   2.184 +        if is_numeral s' then (linear_cmul (dest_numeral s') t') 
   2.185 +        else if is_numeral t' then (linear_cmul (dest_numeral t') s') 
   2.186 + 
   2.187 +         else (warning "lint: apparent nonlinearity"; raise COOPER)
   2.188 +         end 
   2.189 +  |_ =>   error "lint: unknown term"; 
   2.190 +   
   2.191 + 
   2.192 + 
   2.193 +(* ------------------------------------------------------------------------- *) 
   2.194 +(* Linearize the atoms in a formula, and eliminate non-strict inequalities.  *) 
   2.195 +(* ------------------------------------------------------------------------- *) 
   2.196 + 
   2.197 +fun mkatom vars p t = Const(p,HOLogic.intT --> HOLogic.intT --> HOLogic.boolT) $ zero $ (lint vars t); 
   2.198 + 
   2.199 +fun linform vars (Const ("Divides.op dvd",_) $ c $ t) =  
   2.200 +      let val c' = (mk_numeral(abs(dest_numeral c)))  
   2.201 +      in (HOLogic.mk_binrel "Divides.op dvd" (c,lint vars t)) 
   2.202 +      end 
   2.203 +  |linform vars  (Const("op =",Type ("fun",[Type ("IntDef.int", []),_])) $ s $ t ) = (mkatom vars "op =" (Const ("op -",HOLogic.intT --> HOLogic.intT --> HOLogic.intT) $ t $ s) ) 
   2.204 +  |linform vars  (Const("op <",_)$ s $t ) = (mkatom vars "op <" (Const ("op -",HOLogic.intT --> HOLogic.intT --> HOLogic.intT) $ t $ s))
   2.205 +  |linform vars  (Const("op >",_) $ s $ t ) = (mkatom vars "op <" (Const ("op -",HOLogic.intT --> HOLogic.intT --> HOLogic.intT) $ s $ t)) 
   2.206 +  |linform vars  (Const("op <=",_)$ s $ t ) = 
   2.207 +        (mkatom vars "op <" (Const ("op -",HOLogic.intT --> HOLogic.intT --> HOLogic.intT) $ (Const("op +",HOLogic.intT --> HOLogic.intT --> HOLogic.intT) $t $(mk_numeral 1)) $ s)) 
   2.208 +  |linform vars  (Const("op >=",_)$ s $ t ) = 
   2.209 +        (mkatom vars "op <" (Const ("op -",HOLogic.intT --> HOLogic.intT --> 
   2.210 +	HOLogic.intT) $ (Const("op +",HOLogic.intT --> HOLogic.intT --> 
   2.211 +	HOLogic.intT) $s $(mk_numeral 1)) $ t)) 
   2.212 + 
   2.213 +   |linform vars  fm =  fm; 
   2.214 + 
   2.215 +(* ------------------------------------------------------------------------- *) 
   2.216 +(* Post-NNF transformation eliminating negated inequalities.                 *) 
   2.217 +(* ------------------------------------------------------------------------- *) 
   2.218 + 
   2.219 +fun posineq fm = case fm of  
   2.220 + (Const ("Not",_)$(Const("op <",_)$ c $ t)) =>
   2.221 +   (HOLogic.mk_binrel "op <"  (zero , (linear_sub [] (mk_numeral 1) (linear_add [] c t ) ))) 
   2.222 +  | ( Const ("op &",_) $ p $ q)  => HOLogic.mk_conj (posineq p,posineq q)
   2.223 +  | ( Const ("op |",_) $ p $ q ) => HOLogic.mk_disj (posineq p,posineq q)
   2.224 +  | _ => fm; 
   2.225 +  
   2.226 +
   2.227 +(* ------------------------------------------------------------------------- *) 
   2.228 +(* Find the LCM of the coefficients of x.                                    *) 
   2.229 +(* ------------------------------------------------------------------------- *) 
   2.230 +(*gcd calculates gcd (a,b) and helps lcm_num calculating lcm (a,b)*) 
   2.231 + 
   2.232 +fun gcd a b = if a=0 then b else gcd (b mod a) a ; 
   2.233 +fun lcm_num a b = (abs a*b) div (gcd (abs a) (abs b)); 
   2.234 + 
   2.235 +fun formlcm x fm = case fm of 
   2.236 +    (Const (p,_)$ _ $(Const ("op +", _)$(Const ("op *",_)$ c $ y ) $z ) ) =>  if 
   2.237 +    (is_arith_rel fm) andalso (x = y) then abs(dest_numeral c) else 1 
   2.238 +  | ( Const ("Not", _) $p) => formlcm x p 
   2.239 +  | ( Const ("op &",_) $ p $ q) => lcm_num (formlcm x p) (formlcm x q) 
   2.240 +  | ( Const ("op |",_) $ p $ q )=> lcm_num (formlcm x p) (formlcm x q) 
   2.241 +  |  _ => 1; 
   2.242 + 
   2.243 +(* ------------------------------------------------------------------------- *) 
   2.244 +(* Adjust all coefficients of x in formula; fold in reduction to +/- 1.      *) 
   2.245 +(* ------------------------------------------------------------------------- *) 
   2.246 + 
   2.247 +fun adjustcoeff x l fm = 
   2.248 +     case fm of  
   2.249 +      (Const(p,_) $d $( Const ("op +", _)$(Const ("op *",_) $ 
   2.250 +      c $ y ) $z )) => if (is_arith_rel fm) andalso (x = y) then  
   2.251 +        let val m = l div (dest_numeral c) 
   2.252 +            val n = (if p = "op <" then abs(m) else m) 
   2.253 +            val xtm = HOLogic.mk_binop "op *" ((mk_numeral (m div n)), x) 
   2.254 +	in
   2.255 +        (HOLogic.mk_binrel p ((linear_cmul n d),(HOLogic.mk_binop "op +" ( xtm ,( linear_cmul n z) )))) 
   2.256 +	end 
   2.257 +	else fm 
   2.258 +  |( Const ("Not", _) $ p) => HOLogic.Not $ (adjustcoeff x l p) 
   2.259 +  |( Const ("op &",_) $ p $ q) => HOLogic.conj$(adjustcoeff x l p) $(adjustcoeff x l q) 
   2.260 +  |( Const ("op |",_) $ p $ q) => HOLogic.disj $(adjustcoeff x l p)$ (adjustcoeff x l q) 
   2.261 +  |_ => fm; 
   2.262 + 
   2.263 +(* ------------------------------------------------------------------------- *) 
   2.264 +(* Hence make coefficient of x one in existential formula.                   *) 
   2.265 +(* ------------------------------------------------------------------------- *) 
   2.266 + 
   2.267 +fun unitycoeff x fm = 
   2.268 +  let val l = formlcm x fm 
   2.269 +      val fm' = adjustcoeff x l fm in
   2.270 +     if l = 1 then fm' else 
   2.271 +     let val xp = (HOLogic.mk_binop "op +"  
   2.272 +     		((HOLogic.mk_binop "op *" ((mk_numeral 1), x )), zero)) in 
   2.273 +      HOLogic.conj $(HOLogic.mk_binrel "Divides.op dvd" ((mk_numeral l) , xp )) $ (adjustcoeff x l fm) 
   2.274 +      end 
   2.275 +  end; 
   2.276 + 
   2.277 +(* adjustcoeffeq l fm adjusts the coeffitients c_i of x  overall in fm to l*)
   2.278 +(* Here l must be a multiple of all c_i otherwise the obtained formula is not equivalent*)
   2.279 +(*
   2.280 +fun adjustcoeffeq x l fm = 
   2.281 +    case fm of  
   2.282 +      (Const(p,_) $d $( Const ("op +", _)$(Const ("op *",_) $ 
   2.283 +      c $ y ) $z )) => if (is_arith_rel fm) andalso (x = y) then  
   2.284 +        let val m = l div (dest_numeral c) 
   2.285 +            val n = (if p = "op <" then abs(m) else m)  
   2.286 +            val xtm = (HOLogic.mk_binop "op *" ((mk_numeral ((m div n)*l) ), x))
   2.287 +            in (HOLogic.mk_binrel p ((linear_cmul n d),(HOLogic.mk_binop "op +" ( xtm ,( linear_cmul n z) )))) 
   2.288 +	    end 
   2.289 +	else fm 
   2.290 +  |( Const ("Not", _) $ p) => HOLogic.Not $ (adjustcoeffeq x l p) 
   2.291 +  |( Const ("op &",_) $ p $ q) => HOLogic.conj$(adjustcoeffeq x l p) $(adjustcoeffeq x l q) 
   2.292 +  |( Const ("op |",_) $ p $ q) => HOLogic.disj $(adjustcoeffeq x l p)$ (adjustcoeffeq x l q) 
   2.293 +  |_ => fm;
   2.294 + 
   2.295 +
   2.296 +*)
   2.297 +
   2.298 +(* ------------------------------------------------------------------------- *) 
   2.299 +(* The "minus infinity" version.                                             *) 
   2.300 +(* ------------------------------------------------------------------------- *) 
   2.301 + 
   2.302 +fun minusinf x fm = case fm of  
   2.303 +    (Const("op =",Type ("fun",[Type ("IntDef.int", []),_])) $ (c1 ) $(Const ("op +", _) $(Const ("op *",_) $ c2 $ y) $z)) => 
   2.304 +  	 if (is_arith_rel fm) andalso (x=y) andalso (c2 = one) andalso (c1 =zero) then HOLogic.false_const  
   2.305 +	 				 else fm 
   2.306 + 
   2.307 +  |(Const("op <",_) $ c $(Const ("op +", _) $(Const ("op *",_) $ pm1 $ y ) $ z 
   2.308 +  )) => 
   2.309 +        if (x =y) andalso (pm1 = one) andalso (c = zero) then HOLogic.false_const else HOLogic.true_const 
   2.310 +	 
   2.311 +  |(Const ("Not", _) $ p) => HOLogic.Not $ (minusinf x p) 
   2.312 +  |(Const ("op &",_) $ p $ q) => HOLogic.conj $ (minusinf x p) $ (minusinf x q) 
   2.313 +  |(Const ("op |",_) $ p $ q) => HOLogic.disj $ (minusinf x p) $ (minusinf x q) 
   2.314 +  |_ => fm; 
   2.315 +
   2.316 +(* ------------------------------------------------------------------------- *)
   2.317 +(* The "Plus infinity" version.                                             *)
   2.318 +(* ------------------------------------------------------------------------- *)
   2.319 +
   2.320 +fun plusinf x fm = case fm of
   2.321 +    (Const("op =",Type ("fun",[Type ("IntDef.int", []),_])) $ (c1 ) $(Const ("op +", _) $(Const ("op *",_) $ c2 $ y) $z)) =>
   2.322 +  	 if (is_arith_rel fm) andalso (x=y) andalso (c2 = one) andalso (c1 =zero) then HOLogic.false_const
   2.323 +	 				 else fm
   2.324 +
   2.325 +  |(Const("op <",_) $ c $(Const ("op +", _) $(Const ("op *",_) $ pm1 $ y ) $ z
   2.326 +  )) =>
   2.327 +        if (x =y) andalso (pm1 = one) andalso (c = zero) then HOLogic.true_const else HOLogic.false_const
   2.328 +
   2.329 +  |(Const ("Not", _) $ p) => HOLogic.Not $ (plusinf x p)
   2.330 +  |(Const ("op &",_) $ p $ q) => HOLogic.conj $ (plusinf x p) $ (plusinf x q)
   2.331 +  |(Const ("op |",_) $ p $ q) => HOLogic.disj $ (plusinf x p) $ (plusinf x q)
   2.332 +  |_ => fm;
   2.333 + 
   2.334 +(* ------------------------------------------------------------------------- *) 
   2.335 +(* The LCM of all the divisors that involve x.                               *) 
   2.336 +(* ------------------------------------------------------------------------- *) 
   2.337 + 
   2.338 +fun divlcm x (Const("Divides.op dvd",_)$ d $ (Const ("op +",_) $ (Const ("op *",_) $ c $ y ) $ z ) ) =  
   2.339 +        if x = y then abs(dest_numeral d) else 1 
   2.340 +  |divlcm x ( Const ("Not", _) $ p) = divlcm x p 
   2.341 +  |divlcm x ( Const ("op &",_) $ p $ q) = lcm_num (divlcm x p) (divlcm x q) 
   2.342 +  |divlcm x ( Const ("op |",_) $ p $ q ) = lcm_num (divlcm x p) (divlcm x q) 
   2.343 +  |divlcm x  _ = 1; 
   2.344 + 
   2.345 +(* ------------------------------------------------------------------------- *) 
   2.346 +(* Construct the B-set.                                                      *) 
   2.347 +(* ------------------------------------------------------------------------- *) 
   2.348 + 
   2.349 +fun bset x fm = case fm of 
   2.350 +   (Const ("Not", _) $ p) => if (is_arith_rel p) then  
   2.351 +          (case p of  
   2.352 +	      (Const("op =",Type ("fun",[Type ("IntDef.int", []),_])) $ c1 $ (Const ("op +", _) $(Const ("op *",_) $c2 $y) $a ) )  
   2.353 +	             => if (is_arith_rel p) andalso (x=	y) andalso (c2 = one) andalso (c1 = zero)  
   2.354 +	                then [linear_neg a] 
   2.355 +			else  bset x p 
   2.356 +   	  |_ =>[]) 
   2.357 +			 
   2.358 +			else bset x p 
   2.359 +  |(Const ("op =",Type ("fun",[Type ("IntDef.int", []),_])) $ c1 $ (Const ("op +",_) $ (Const ("op *",_) $c2 $ x) $ a)) =>  if (c1 =zero) andalso (c2 = one) then [linear_neg(linear_add [] a (mk_numeral 1))]  else [] 
   2.360 +  |(Const ("op <",_) $ c1$ (Const ("op +",_) $(Const ("op *",_)$ c2 $ x) $ a)) => if (c1 =zero) andalso (c2 = one) then [linear_neg a] else [] 
   2.361 +  |(Const ("op &",_) $ p $ q) => (bset x p) union (bset x q) 
   2.362 +  |(Const ("op |",_) $ p $ q) => (bset x p) union (bset x q) 
   2.363 +  |_ => []; 
   2.364 + 
   2.365 +(* ------------------------------------------------------------------------- *)
   2.366 +(* Construct the A-set.                                                      *)
   2.367 +(* ------------------------------------------------------------------------- *)
   2.368 +
   2.369 +fun aset x fm = case fm of
   2.370 +   (Const ("Not", _) $ p) => if (is_arith_rel p) then
   2.371 +          (case p of
   2.372 +	      (Const("op =",Type ("fun",[Type ("IntDef.int", []),_])) $ c1 $ (Const ("op +", _) $(Const ("op *",_) $c2 $y) $a ) )
   2.373 +	             => if (x=	y) andalso (c2 = one) andalso (c1 = zero)
   2.374 +	                then [linear_neg a]
   2.375 +			else  []
   2.376 +   	  |_ =>[])
   2.377 +
   2.378 +			else aset x p
   2.379 +  |(Const ("op =",Type ("fun",[Type ("IntDef.int", []),_])) $ c1 $ (Const ("op +",_) $ (Const ("op *",_) $c2 $ x) $ a)) =>  if (c1 =zero) andalso (c2 = one) then [linear_sub [] (mk_numeral 1) a]  else []
   2.380 +  |(Const ("op <",_) $ c1$ (Const ("op +",_) $(Const ("op *",_)$ c2 $ x) $ a)) => if (c1 =zero) andalso (c2 = (mk_numeral (~1))) then [a] else []
   2.381 +  |(Const ("op &",_) $ p $ q) => (aset x p) union (aset x q)
   2.382 +  |(Const ("op |",_) $ p $ q) => (aset x p) union (aset x q)
   2.383 +  |_ => [];
   2.384 +
   2.385 +
   2.386 +(* ------------------------------------------------------------------------- *) 
   2.387 +(* Replace top variable with another linear form, retaining canonicality.    *) 
   2.388 +(* ------------------------------------------------------------------------- *) 
   2.389 + 
   2.390 +fun linrep vars x t fm = case fm of  
   2.391 +   ((Const(p,_)$ d $ (Const("op +",_)$(Const("op *",_)$ c $ y) $ z))) => 
   2.392 +      if (x = y) andalso (is_arith_rel fm)  
   2.393 +      then  
   2.394 +        let val ct = linear_cmul (dest_numeral c) t  
   2.395 +	in (HOLogic.mk_binrel p (d, linear_add vars ct z)) 
   2.396 +	end 
   2.397 +	else fm 
   2.398 +  |(Const ("Not", _) $ p) => HOLogic.Not $ (linrep vars x t p) 
   2.399 +  |(Const ("op &",_) $ p $ q) => HOLogic.conj $ (linrep vars x t p) $ (linrep vars x t q) 
   2.400 +  |(Const ("op |",_) $ p $ q) => HOLogic.disj $ (linrep vars x t p) $ (linrep vars x t q) 
   2.401 +  |_ => fm; 
   2.402 + 
   2.403 +(* ------------------------------------------------------------------------- *) 
   2.404 +(* Evaluation of constant expressions.                                       *) 
   2.405 +(* ------------------------------------------------------------------------- *) 
   2.406 + 
   2.407 +val operations = 
   2.408 +  [("op =",op=), ("op <",op<), ("op >",op>), ("op <=",op<=) , ("op >=",op>=), 
   2.409 +   ("Divides.op dvd",fn (x,y) =>((y mod x) = 0))]; 
   2.410 + 
   2.411 +fun applyoperation (Some f) (a,b) = f (a, b) 
   2.412 +    |applyoperation _ (_, _) = false; 
   2.413 + 
   2.414 +(*Evaluation of constant atomic formulas*) 
   2.415 + 
   2.416 +fun evalc_atom at = case at of  
   2.417 +      (Const (p,_) $ s $ t) =>(  
   2.418 +         case assoc (operations,p) of 
   2.419 +             Some f => ((if (f ((dest_numeral s),(dest_numeral t))) then HOLogic.true_const else HOLogic.false_const)  
   2.420 +              handle _ => at) 
   2.421 +             | _ =>  at) 
   2.422 +     |Const("Not",_)$(Const (p,_) $ s $ t) =>(  
   2.423 +         case assoc (operations,p) of 
   2.424 +             Some f => ((if (f ((dest_numeral s),(dest_numeral t))) then 
   2.425 +	     HOLogic.false_const else HOLogic.true_const)  
   2.426 +              handle _ => at) 
   2.427 +             | _ =>  at) 
   2.428 +     | _ =>  at; 
   2.429 + 
   2.430 +(*Function onatoms apllys function f on the atomic formulas involved in a.*) 
   2.431 + 
   2.432 +fun onatoms f a = if (is_arith_rel a) then f a else case a of 
   2.433 + 
   2.434 +  	(Const ("Not",_) $ p) => if is_arith_rel p then HOLogic.Not $ (f p) 
   2.435 +				 
   2.436 +				else HOLogic.Not $ (onatoms f p) 
   2.437 +  	|(Const ("op &",_) $ p $ q) => HOLogic.conj $ (onatoms f p) $ (onatoms f q) 
   2.438 +  	|(Const ("op |",_) $ p $ q) => HOLogic.disj $ (onatoms f p) $ (onatoms f q) 
   2.439 +  	|(Const ("op -->",_) $ p $ q) => HOLogic.imp $ (onatoms f p) $ (onatoms f q) 
   2.440 +  	|((Const ("op =", Type ("fun",[Type ("bool", []),_]))) $ p $ q) => (Const ("op =", [HOLogic.boolT, HOLogic.boolT] ---> HOLogic.boolT)) $ (onatoms f p) $ (onatoms f q) 
   2.441 +  	|(Const("All",_) $ Abs(x,T,p)) => Const("All", [HOLogic.intT --> 
   2.442 +	HOLogic.boolT] ---> HOLogic.boolT)$ Abs (x ,T, (onatoms f p)) 
   2.443 +  	|(Const("Ex",_) $ Abs(x,T,p)) => Const("Ex", [HOLogic.intT --> HOLogic.boolT]---> HOLogic.boolT) $ Abs( x ,T, (onatoms f p)) 
   2.444 +  	|_ => a; 
   2.445 + 
   2.446 +val evalc = onatoms evalc_atom; 
   2.447 + 
   2.448 +(* ------------------------------------------------------------------------- *) 
   2.449 +(* Hence overall quantifier elimination.                                     *) 
   2.450 +(* ------------------------------------------------------------------------- *) 
   2.451 + 
   2.452 +(*Applyes a function iteratively on the list*) 
   2.453 + 
   2.454 +fun end_itlist f []     = error "end_itlist" 
   2.455 +   |end_itlist f [x]    = x 
   2.456 +   |end_itlist f (h::t) = f h (end_itlist f t); 
   2.457 + 
   2.458 + 
   2.459 +(*list_disj[conj] makes a disj[conj] of a given list. used with conjucts or disjuncts 
   2.460 +it liearises iterated conj[disj]unctions. *) 
   2.461 + 
   2.462 +fun disj_help p q = HOLogic.disj $ p $ q ; 
   2.463 + 
   2.464 +fun list_disj l = 
   2.465 +  if l = [] then HOLogic.false_const else end_itlist disj_help l; 
   2.466 +   
   2.467 +fun conj_help p q = HOLogic.conj $ p $ q ; 
   2.468 + 
   2.469 +fun list_conj l = 
   2.470 +  if l = [] then HOLogic.true_const else end_itlist conj_help l; 
   2.471 +   
   2.472 +(*Simplification of Formulas *) 
   2.473 + 
   2.474 +(*Function q_bnd_chk checks if a quantified Formula makes sens : Means if in 
   2.475 +the body of the existential quantifier there are bound variables to the 
   2.476 +existential quantifier.*) 
   2.477 + 
   2.478 +fun has_bound fm =let fun has_boundh fm i = case fm of 
   2.479 +		 Bound n => (i = n) 
   2.480 +		 |Abs (_,_,p) => has_boundh p (i+1) 
   2.481 +		 |t1 $ t2 => (has_boundh t1 i) orelse (has_boundh t2 i) 
   2.482 +		 |_ =>false
   2.483 +
   2.484 +in  case fm of 
   2.485 +	Bound _ => true 
   2.486 +       |Abs (_,_,p) => has_boundh p 0 
   2.487 +       |t1 $ t2 => (has_bound t1 ) orelse (has_bound t2 ) 
   2.488 +       |_ =>false
   2.489 +end;
   2.490 + 
   2.491 +(*has_sub_abs checks if in a given Formula there are subformulas which are quantifed 
   2.492 +too. Is no used no more.*) 
   2.493 + 
   2.494 +fun has_sub_abs fm = case fm of  
   2.495 +		 Abs (_,_,_) => true 
   2.496 +		 |t1 $ t2 => (has_bound t1 ) orelse (has_bound t2 ) 
   2.497 +		 |_ =>false ; 
   2.498 +		  
   2.499 +(*update_bounds called with i=0 udates the numeration of bounded variables because the 
   2.500 +formula will not be quantified any more.*) 
   2.501 + 
   2.502 +fun update_bounds fm i = case fm of 
   2.503 +		 Bound n => if n >= i then Bound (n-1) else fm 
   2.504 +		 |Abs (x,T,p) => Abs(x,T,(update_bounds p (i+1))) 
   2.505 +		 |t1 $ t2 => (update_bounds t1 i) $ (update_bounds t2 i) 
   2.506 +		 |_ => fm ; 
   2.507 + 
   2.508 +(*psimpl : Simplification of propositions (general purpose)*) 
   2.509 +fun psimpl1 fm = case fm of 
   2.510 +    Const("Not",_) $ Const ("False",_) => HOLogic.true_const 
   2.511 +  | Const("Not",_) $ Const ("True",_) => HOLogic.false_const 
   2.512 +  | Const("op &",_) $ Const ("False",_) $ q => HOLogic.false_const 
   2.513 +  | Const("op &",_) $ p $ Const ("False",_)  => HOLogic.false_const 
   2.514 +  | Const("op &",_) $ Const ("True",_) $ q => q 
   2.515 +  | Const("op &",_) $ p $ Const ("True",_) => p 
   2.516 +  | Const("op |",_) $ Const ("False",_) $ q => q 
   2.517 +  | Const("op |",_) $ p $ Const ("False",_)  => p 
   2.518 +  | Const("op |",_) $ Const ("True",_) $ q => HOLogic.true_const 
   2.519 +  | Const("op |",_) $ p $ Const ("True",_)  => HOLogic.true_const 
   2.520 +  | Const("op -->",_) $ Const ("False",_) $ q => HOLogic.true_const 
   2.521 +  | Const("op -->",_) $ Const ("True",_) $  q => q 
   2.522 +  | Const("op -->",_) $ p $ Const ("True",_)  => HOLogic.true_const 
   2.523 +  | Const("op -->",_) $ p $ Const ("False",_)  => HOLogic.Not $  p 
   2.524 +  | Const("op =", Type ("fun",[Type ("bool", []),_])) $ Const ("True",_) $ q => q 
   2.525 +  | Const("op =", Type ("fun",[Type ("bool", []),_])) $ p $ Const ("True",_) => p 
   2.526 +  | Const("op =", Type ("fun",[Type ("bool", []),_])) $ Const ("False",_) $ q => HOLogic.Not $  q 
   2.527 +  | Const("op =", Type ("fun",[Type ("bool", []),_])) $ p $ Const ("False",_)  => HOLogic.Not $  p 
   2.528 +  | _ => fm; 
   2.529 + 
   2.530 +fun psimpl fm = case fm of 
   2.531 +   Const ("Not",_) $ p => psimpl1 (HOLogic.Not $ (psimpl p)) 
   2.532 +  | Const("op &",_) $ p $ q => psimpl1 (HOLogic.mk_conj (psimpl p,psimpl q)) 
   2.533 +  | Const("op |",_) $ p $ q => psimpl1 (HOLogic.mk_disj (psimpl p,psimpl q)) 
   2.534 +  | Const("op -->",_) $ p $ q => psimpl1 (HOLogic.mk_imp(psimpl p,psimpl q)) 
   2.535 +  | Const("op =", Type ("fun",[Type ("bool", []),_])) $ p $ q => psimpl1 (HOLogic.mk_eq(psimpl p,psimpl q)) 
   2.536 +  | _ => fm; 
   2.537 + 
   2.538 + 
   2.539 +(*simpl : Simplification of Terms involving quantifiers too. 
   2.540 + This function is able to drop out some quantified expressions where there are no 
   2.541 + bound varaibles.*) 
   2.542 +  
   2.543 +fun simpl1 fm  = 
   2.544 +  case fm of 
   2.545 +    Const("All",_) $Abs(x,_,p) => if (has_bound fm ) then fm  
   2.546 +    				else (update_bounds p 0) 
   2.547 +  | Const("Ex",_) $ Abs (x,_,p) => if has_bound fm then fm  
   2.548 +    				else (update_bounds p 0) 
   2.549 +  | _ => psimpl1 fm; 
   2.550 + 
   2.551 +fun simpl fm = case fm of 
   2.552 +    Const ("Not",_) $ p => simpl1 (HOLogic.Not $(simpl p))  
   2.553 +  | Const ("op &",_) $ p $ q => simpl1 (HOLogic.mk_conj (simpl p ,simpl q))  
   2.554 +  | Const ("op |",_) $ p $ q => simpl1 (HOLogic.mk_disj (simpl p ,simpl q ))  
   2.555 +  | Const ("op -->",_) $ p $ q => simpl1 (HOLogic.mk_imp(simpl p ,simpl q ))  
   2.556 +  | Const("op =", Type ("fun",[Type ("bool", []),_]))$ p $ q => simpl1 
   2.557 +  (HOLogic.mk_eq(simpl p ,simpl q ))  
   2.558 +  | Const ("All",Ta) $ Abs(Vn,VT,p) => simpl1(Const("All",Ta) $ 
   2.559 +  Abs(Vn,VT,simpl p ))  
   2.560 +  | Const ("Ex",Ta)  $ Abs(Vn,VT,p) => simpl1(Const("Ex",Ta)  $ 
   2.561 +  Abs(Vn,VT,simpl p ))  
   2.562 +  | _ => fm; 
   2.563 + 
   2.564 +(* ------------------------------------------------------------------------- *) 
   2.565 + 
   2.566 +(* Puts fm into NNF*) 
   2.567 + 
   2.568 +fun  nnf fm = if (is_arith_rel fm) then fm  
   2.569 +else (case fm of 
   2.570 +  ( Const ("op &",_) $ p $ q)  => HOLogic.conj $ (nnf p) $(nnf q) 
   2.571 +  | (Const("op |",_) $ p $q) => HOLogic.disj $ (nnf p)$(nnf q) 
   2.572 +  | (Const ("op -->",_)  $ p $ q) => HOLogic.disj $ (nnf (HOLogic.Not $ p)) $ (nnf q) 
   2.573 +  | ((Const ("op =", Type ("fun",[Type ("bool", []),_]))) $ p $ q) =>(HOLogic.disj $ (HOLogic.conj $ (nnf p) $ (nnf q)) $ (HOLogic.conj $ (nnf (HOLogic.Not $ p) ) $ (nnf(HOLogic.Not $ q)))) 
   2.574 +  | (Const ("Not",_)) $ ((Const ("Not",_)) $ p) => (nnf p) 
   2.575 +  | (Const ("Not",_)) $ (( Const ("op &",_)) $ p $ q) =>HOLogic.disj $ (nnf(HOLogic.Not $ p)) $ (nnf(HOLogic.Not $q)) 
   2.576 +  | (Const ("Not",_)) $ (( Const ("op |",_)) $ p $ q) =>HOLogic.conj $ (nnf(HOLogic.Not $ p)) $ (nnf(HOLogic.Not $ q)) 
   2.577 +  | (Const ("Not",_)) $ (( Const ("op -->",_)) $ p $ q ) =>HOLogic.conj $ (nnf p) $(nnf(HOLogic.Not $ q)) 
   2.578 +  | (Const ("Not",_)) $ ((Const ("op =", Type ("fun",[Type ("bool", []),_]))) $ p $ q ) =>(HOLogic.disj $ (HOLogic.conj $(nnf p) $ (nnf(HOLogic.Not $ q))) $ (HOLogic.conj $(nnf(HOLogic.Not $ p)) $ (nnf q))) 
   2.579 +  | _ => fm); 
   2.580 + 
   2.581 + 
   2.582 +(* Function remred to remove redundancy in a list while keeping the order of appearance of the 
   2.583 +elements. but VERY INEFFICIENT!! *) 
   2.584 + 
   2.585 +fun remred1 el [] = [] 
   2.586 +    |remred1 el (h::t) = if el=h then (remred1 el t) else h::(remred1 el t); 
   2.587 +     
   2.588 +fun remred [] = [] 
   2.589 +    |remred (x::l) =  x::(remred1 x (remred l)); 
   2.590 + 
   2.591 +(*Makes sure that all free Variables are of the type integer but this function is only 
   2.592 +used temporarily, this job must be done by the parser later on.*) 
   2.593 + 
   2.594 +fun mk_uni_vars T  (node $ rest) = (case node of 
   2.595 +    Free (name,_) => Free (name,T) $ (mk_uni_vars T rest) 
   2.596 +    |_=> (mk_uni_vars T node) $ (mk_uni_vars T rest )  ) 
   2.597 +    |mk_uni_vars T (Free (v,_)) = Free (v,T) 
   2.598 +    |mk_uni_vars T tm = tm; 
   2.599 + 
   2.600 +fun mk_uni_int T (Const ("0",T2)) = if T = T2 then (mk_numeral 0) else (Const ("0",T2)) 
   2.601 +    |mk_uni_int T (Const ("1",T2)) = if T = T2 then (mk_numeral 1) else (Const ("1",T2)) 
   2.602 +    |mk_uni_int T (node $ rest) = (mk_uni_int T node) $ (mk_uni_int T rest )  
   2.603 +    |mk_uni_int T (Abs(AV,AT,p)) = Abs(AV,AT,mk_uni_int T p) 
   2.604 +    |mk_uni_int T tm = tm; 
   2.605 + 
   2.606 +
   2.607 +(* Minusinfinity Version*) 
   2.608 +fun coopermi vars1 fm = 
   2.609 +  case fm of 
   2.610 +   Const ("Ex",_) $ Abs(x0,T,p0) => let 
   2.611 +    val (xn,p1) = variant_abs (x0,T,p0) 
   2.612 +    val x = Free (xn,T)  
   2.613 +    val vars = (xn::vars1) 
   2.614 +    val p = unitycoeff x  (posineq (simpl p1))
   2.615 +    val p_inf = simpl (minusinf x p) 
   2.616 +    val bset = bset x p 
   2.617 +    val js = 1 upto divlcm x p  
   2.618 +    fun p_element j b = linrep vars x (linear_add vars b (mk_numeral j)) p  
   2.619 +    fun stage j = list_disj (linrep vars x (mk_numeral j) p_inf :: map (p_element j) bset)  
   2.620 +   in (list_disj (map stage js))
   2.621 +    end 
   2.622 +  | _ => error "cooper: not an existential formula"; 
   2.623 + 
   2.624 +
   2.625 +
   2.626 +(* The plusinfinity version of cooper*)
   2.627 +fun cooperpi vars1 fm =
   2.628 +  case fm of
   2.629 +   Const ("Ex",_) $ Abs(x0,T,p0) => let 
   2.630 +    val (xn,p1) = variant_abs (x0,T,p0)
   2.631 +    val x = Free (xn,T)
   2.632 +    val vars = (xn::vars1)
   2.633 +    val p = unitycoeff x  (posineq (simpl p1))
   2.634 +    val p_inf = simpl (plusinf x p)
   2.635 +    val aset = aset x p
   2.636 +    val js = 1 upto divlcm x p
   2.637 +    fun p_element j a = linrep vars x (linear_sub vars a (mk_numeral j)) p
   2.638 +    fun stage j = list_disj (linrep vars x (mk_numeral j) p_inf :: map (p_element j) aset)
   2.639 +   in (list_disj (map stage js))
   2.640 +   end
   2.641 +  | _ => error "cooper: not an existential formula";
   2.642 +  
   2.643 +
   2.644 +
   2.645 +(*Cooper main procedure*) 
   2.646 +  
   2.647 +fun cooper vars1 fm =
   2.648 +  case fm of
   2.649 +   Const ("Ex",_) $ Abs(x0,T,p0) => let 
   2.650 +    val (xn,p1) = variant_abs (x0,T,p0)
   2.651 +    val x = Free (xn,T)
   2.652 +    val vars = (xn::vars1)
   2.653 +    val p = unitycoeff x  (posineq (simpl p1))
   2.654 +    val ast = aset x p
   2.655 +    val bst = bset x p
   2.656 +    val js = 1 upto divlcm x p
   2.657 +    val (p_inf,f,S ) = 
   2.658 +    if (length bst) < (length ast) 
   2.659 +     then (minusinf x p,linear_add,bst)
   2.660 +     else (plusinf x p, linear_sub,ast)
   2.661 +    fun p_element j a = linrep vars x (f vars a (mk_numeral j)) p
   2.662 +    fun stage j = list_disj (linrep vars x (mk_numeral j) p_inf :: map (p_element j) S)
   2.663 +   in (list_disj (map stage js))
   2.664 +   end
   2.665 +  | _ => error "cooper: not an existential formula";
   2.666 +
   2.667 +
   2.668 +
   2.669 + 
   2.670 +(*Function itlist applys a double parametred function f : 'a->'b->b iteratively to a List l : 'a 
   2.671 +list With End condition b. ict calculates f(e1,f(f(e2,f(e3,...(...f(en,b))..))))) 
   2.672 + assuming l = [e1,e2,...,en]*) 
   2.673 + 
   2.674 +fun itlist f l b = case l of 
   2.675 +    [] => b 
   2.676 +  | (h::t) => f h (itlist f t b); 
   2.677 + 
   2.678 +(* ------------------------------------------------------------------------- *) 
   2.679 +(* Free variables in terms and formulas.	                             *) 
   2.680 +(* ------------------------------------------------------------------------- *) 
   2.681 + 
   2.682 +fun fvt tml = case tml of 
   2.683 +    [] => [] 
   2.684 +  | Free(x,_)::r => x::(fvt r) 
   2.685 + 
   2.686 +fun fv fm = fvt (term_frees fm); 
   2.687 + 
   2.688 + 
   2.689 +(* ========================================================================= *) 
   2.690 +(* Quantifier elimination.                                                   *) 
   2.691 +(* ========================================================================= *) 
   2.692 +(*conj[/disj]uncts lists iterated conj[disj]unctions*) 
   2.693 + 
   2.694 +fun disjuncts fm = case fm of 
   2.695 +    Const ("op |",_) $ p $ q => (disjuncts p) @ (disjuncts q) 
   2.696 +  | _ => [fm]; 
   2.697 + 
   2.698 +fun conjuncts fm = case fm of 
   2.699 +    Const ("op &",_) $p $ q => (conjuncts p) @ (conjuncts q) 
   2.700 +  | _ => [fm]; 
   2.701 + 
   2.702 + 
   2.703 + 
   2.704 +(* ------------------------------------------------------------------------- *) 
   2.705 +(* Lift procedure given literal modifier, formula normalizer & basic quelim. *) 
   2.706 +(* ------------------------------------------------------------------------- *) 
   2.707 +   
   2.708 +fun lift_qelim afn nfn qfn isat = 
   2.709 + let   fun qelim x vars p = 
   2.710 +  let val cjs = conjuncts p 
   2.711 +      val (ycjs,ncjs) = partition (has_bound) cjs in 
   2.712 +      (if ycjs = [] then p else 
   2.713 +                          let val q = (qfn vars ((HOLogic.exists_const HOLogic.intT 
   2.714 +			  ) $ Abs(x,HOLogic.intT,(list_conj ycjs)))) in 
   2.715 +                          (itlist conj_help ncjs q)  
   2.716 +			  end) 
   2.717 +       end 
   2.718 +    
   2.719 +  fun qelift vars fm = if (isat fm) then afn vars fm 
   2.720 +    else  
   2.721 +    case fm of 
   2.722 +      Const ("Not",_) $ p => HOLogic.Not $ (qelift vars p) 
   2.723 +    | Const ("op &",_) $ p $q => HOLogic.conj $ (qelift vars p) $ (qelift vars q) 
   2.724 +    | Const ("op |",_) $ p $ q => HOLogic.disj $ (qelift vars p) $ (qelift vars q) 
   2.725 +    | Const ("op -->",_) $ p $ q => HOLogic.imp $ (qelift vars p) $ (qelift vars q) 
   2.726 +    | Const ("op =",Type ("fun",[Type ("bool", []),_])) $ p $ q => HOLogic.mk_eq ((qelift vars p),(qelift vars q)) 
   2.727 +    | Const ("All",QT) $ Abs(x,T,p) => HOLogic.Not $(qelift vars (Const ("Ex",QT) $ Abs(x,T,(HOLogic.Not $ p)))) 
   2.728 +    | Const ("Ex",_) $ Abs (x,T,p)  => let  val djs = disjuncts(nfn(qelift (x::vars) p)) in 
   2.729 +    			list_disj(map (qelim x vars) djs) end 
   2.730 +    | _ => fm 
   2.731 + 
   2.732 +  in (fn fm => simpl(qelift (fv fm) fm)) 
   2.733 +  end; 
   2.734 + 
   2.735 + 
   2.736 +(* ------------------------------------------------------------------------- *) 
   2.737 +(* Cleverer (proposisional) NNF with conditional and literal modification.   *) 
   2.738 +(* ------------------------------------------------------------------------- *) 
   2.739 + 
   2.740 +(*Function Negate used by cnnf, negates a formula p*) 
   2.741 + 
   2.742 +fun negate (Const ("Not",_) $ p) = p 
   2.743 +    |negate p = (HOLogic.Not $ p); 
   2.744 + 
   2.745 +fun cnnf lfn = 
   2.746 +  let fun cnnfh fm = case  fm of 
   2.747 +      (Const ("op &",_) $ p $ q) => HOLogic.mk_conj(cnnfh p,cnnfh q) 
   2.748 +    | (Const ("op |",_) $ p $ q) => HOLogic.mk_disj(cnnfh p,cnnfh q) 
   2.749 +    | (Const ("op -->",_) $ p $q) => HOLogic.mk_disj(cnnfh(HOLogic.Not $ p),cnnfh q) 
   2.750 +    | (Const ("op =",Type ("fun",[Type ("bool", []),_])) $ p $ q) => HOLogic.mk_disj( 
   2.751 +    		HOLogic.mk_conj(cnnfh p,cnnfh q), 
   2.752 +		HOLogic.mk_conj(cnnfh(HOLogic.Not $ p),cnnfh(HOLogic.Not $q))) 
   2.753 +
   2.754 +    | (Const ("Not",_) $ (Const("Not",_) $ p)) => cnnfh p 
   2.755 +    | (Const ("Not",_) $ (Const ("op &",_) $ p $ q)) => HOLogic.mk_disj(cnnfh(HOLogic.Not $ p),cnnfh(HOLogic.Not $ q)) 
   2.756 +    | (Const ("Not",_) $(Const ("op |",_) $ (Const ("op &",_) $ p $ q) $  
   2.757 +    			(Const ("op &",_) $ p1 $ r))) => if p1 = negate p then 
   2.758 +		         HOLogic.mk_disj(  
   2.759 +			   cnnfh (HOLogic.mk_conj(p,cnnfh(HOLogic.Not $ q))), 
   2.760 +			   cnnfh (HOLogic.mk_conj(p1,cnnfh(HOLogic.Not $ r)))) 
   2.761 +			 else  HOLogic.mk_conj(
   2.762 +			  cnnfh (HOLogic.mk_disj(cnnfh (HOLogic.Not $ p),cnnfh(HOLogic.Not $ q))), 
   2.763 +			   cnnfh (HOLogic.mk_disj(cnnfh (HOLogic.Not $ p1),cnnfh(HOLogic.Not $ r)))
   2.764 +			 ) 
   2.765 +    | (Const ("Not",_) $ (Const ("op |",_) $ p $ q)) => HOLogic.mk_conj(cnnfh(HOLogic.Not $ p),cnnfh(HOLogic.Not $ q)) 
   2.766 +    | (Const ("Not",_) $ (Const ("op -->",_) $ p $q)) => HOLogic.mk_conj(cnnfh p,cnnfh(HOLogic.Not $ q)) 
   2.767 +    | (Const ("Not",_) $ (Const ("op =",Type ("fun",[Type ("bool", []),_]))  $ p $ q)) => HOLogic.mk_disj(HOLogic.mk_conj(cnnfh p,cnnfh(HOLogic.Not $ q)),HOLogic.mk_conj(cnnfh(HOLogic.Not $ p),cnnfh q)) 
   2.768 +    | _ => lfn fm  
   2.769 +  in cnnfh o simpl
   2.770 +  end; 
   2.771 + 
   2.772 +(*End- function the quantifierelimination an decion procedure of presburger formulas.*)   
   2.773 +val integer_qelim = simpl o evalc o (lift_qelim linform (simpl o (cnnf posineq o evalc)) cooper is_arith_rel) ; 
   2.774 +
   2.775 +end;
   2.776 + 
   2.777 \ No newline at end of file
     3.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     3.2 +++ b/src/HOL/Integ/cooper_proof.ML	Tue Mar 25 09:47:05 2003 +0100
     3.3 @@ -0,0 +1,1488 @@
     3.4 +(*  Title:      HOL/Integ/cooper_proof.ML
     3.5 +    ID:         $Id$
     3.6 +    Author:     Amine Chaieb and Tobias Nipkow, TU Muenchen
     3.7 +    License:    GPL (GNU GENERAL PUBLIC LICENSE)
     3.8 +
     3.9 +File containing the implementation of the proof
    3.10 +generation for Cooper Algorithm
    3.11 +*)
    3.12 +
    3.13 +signature COOPER_PROOF =
    3.14 +sig
    3.15 +  val qe_Not : thm
    3.16 +  val qe_conjI : thm
    3.17 +  val qe_disjI : thm
    3.18 +  val qe_impI : thm
    3.19 +  val qe_eqI : thm
    3.20 +  val qe_exI : thm
    3.21 +  val qe_get_terms : thm -> term * term
    3.22 +  val cooper_prv : Sign.sg -> term -> term -> string list -> thm
    3.23 +  val proof_of_evalc : Sign.sg -> term -> thm
    3.24 +  val proof_of_cnnf : Sign.sg -> term -> (term -> thm) -> thm
    3.25 +  val proof_of_linform : Sign.sg -> string list -> term -> thm
    3.26 +end;
    3.27 +
    3.28 +structure CooperProof : COOPER_PROOF =
    3.29 +struct
    3.30 +
    3.31 +open CooperDec;
    3.32 +
    3.33 +(*-----------------------------------------------------------------*)
    3.34 +(*-----------------------------------------------------------------*)
    3.35 +(*-----------------------------------------------------------------*)
    3.36 +(*---                                                           ---*)
    3.37 +(*---                                                           ---*)
    3.38 +(*---         Protocoling part                                  ---*)
    3.39 +(*---                                                           ---*)
    3.40 +(*---           includes the protocolling datastructure         ---*)
    3.41 +(*---                                                           ---*)
    3.42 +(*---          and the protocolling fuctions                    ---*)
    3.43 +(*---                                                           ---*)
    3.44 +(*---                                                           ---*)
    3.45 +(*-----------------------------------------------------------------*)
    3.46 +(*-----------------------------------------------------------------*)
    3.47 +(*-----------------------------------------------------------------*)
    3.48 +
    3.49 +val presburger_ss = simpset_of (theory "Presburger")
    3.50 +  addsimps [zdiff_def] delsimps [symmetric zdiff_def];
    3.51 +val cboolT = ctyp_of (sign_of HOL.thy) HOLogic.boolT;
    3.52 +
    3.53 +(*Theorems that will be used later for the proofgeneration*)
    3.54 +
    3.55 +val zdvd_iff_zmod_eq_0 = thm "zdvd_iff_zmod_eq_0";
    3.56 +val unity_coeff_ex = thm "unity_coeff_ex";
    3.57 +
    3.58 +(* Thorems for proving the adjustment of the coeffitients*)
    3.59 +
    3.60 +val ac_lt_eq =  thm "ac_lt_eq";
    3.61 +val ac_eq_eq = thm "ac_eq_eq";
    3.62 +val ac_dvd_eq = thm "ac_dvd_eq";
    3.63 +val ac_pi_eq = thm "ac_pi_eq";
    3.64 +
    3.65 +(* The logical compination of the sythetised properties*)
    3.66 +val qe_Not = thm "qe_Not";
    3.67 +val qe_conjI = thm "qe_conjI";
    3.68 +val qe_disjI = thm "qe_disjI";
    3.69 +val qe_impI = thm "qe_impI";
    3.70 +val qe_eqI = thm "qe_eqI";
    3.71 +val qe_exI = thm "qe_exI";
    3.72 +val qe_ALLI = thm "qe_ALLI";
    3.73 +
    3.74 +(*Modulo D property for Pminusinf an Plusinf *)
    3.75 +val fm_modd_minf = thm "fm_modd_minf";
    3.76 +val not_dvd_modd_minf = thm "not_dvd_modd_minf";
    3.77 +val dvd_modd_minf = thm "dvd_modd_minf";
    3.78 +
    3.79 +val fm_modd_pinf = thm "fm_modd_pinf";
    3.80 +val not_dvd_modd_pinf = thm "not_dvd_modd_pinf";
    3.81 +val dvd_modd_pinf = thm "dvd_modd_pinf";
    3.82 +
    3.83 +(* the minusinfinity proprty*)
    3.84 +
    3.85 +val fm_eq_minf = thm "fm_eq_minf";
    3.86 +val neq_eq_minf = thm "neq_eq_minf";
    3.87 +val eq_eq_minf = thm "eq_eq_minf";
    3.88 +val le_eq_minf = thm "le_eq_minf";
    3.89 +val len_eq_minf = thm "len_eq_minf";
    3.90 +val not_dvd_eq_minf = thm "not_dvd_eq_minf";
    3.91 +val dvd_eq_minf = thm "dvd_eq_minf";
    3.92 +
    3.93 +(* the Plusinfinity proprty*)
    3.94 +
    3.95 +val fm_eq_pinf = thm "fm_eq_pinf";
    3.96 +val neq_eq_pinf = thm "neq_eq_pinf";
    3.97 +val eq_eq_pinf = thm "eq_eq_pinf";
    3.98 +val le_eq_pinf = thm "le_eq_pinf";
    3.99 +val len_eq_pinf = thm "len_eq_pinf";
   3.100 +val not_dvd_eq_pinf = thm "not_dvd_eq_pinf";
   3.101 +val dvd_eq_pinf = thm "dvd_eq_pinf";
   3.102 +
   3.103 +(*Logical construction of the Property*)
   3.104 +val eq_minf_conjI = thm "eq_minf_conjI";
   3.105 +val eq_minf_disjI = thm "eq_minf_disjI";
   3.106 +val modd_minf_disjI = thm "modd_minf_disjI";
   3.107 +val modd_minf_conjI = thm "modd_minf_conjI";
   3.108 +
   3.109 +val eq_pinf_conjI = thm "eq_pinf_conjI";
   3.110 +val eq_pinf_disjI = thm "eq_pinf_disjI";
   3.111 +val modd_pinf_disjI = thm "modd_pinf_disjI";
   3.112 +val modd_pinf_conjI = thm "modd_pinf_conjI";
   3.113 +
   3.114 +(*A/B - set Theorem *)
   3.115 +
   3.116 +val bst_thm = thm "bst_thm";
   3.117 +val ast_thm = thm "ast_thm";
   3.118 +
   3.119 +(*Cooper Backwards...*)
   3.120 +(*Bset*)
   3.121 +val not_bst_p_fm = thm "not_bst_p_fm";
   3.122 +val not_bst_p_ne = thm "not_bst_p_ne";
   3.123 +val not_bst_p_eq = thm "not_bst_p_eq";
   3.124 +val not_bst_p_gt = thm "not_bst_p_gt";
   3.125 +val not_bst_p_lt = thm "not_bst_p_lt";
   3.126 +val not_bst_p_ndvd = thm "not_bst_p_ndvd";
   3.127 +val not_bst_p_dvd = thm "not_bst_p_dvd";
   3.128 +
   3.129 +(*Aset*)
   3.130 +val not_ast_p_fm = thm "not_ast_p_fm";
   3.131 +val not_ast_p_ne = thm "not_ast_p_ne";
   3.132 +val not_ast_p_eq = thm "not_ast_p_eq";
   3.133 +val not_ast_p_gt = thm "not_ast_p_gt";
   3.134 +val not_ast_p_lt = thm "not_ast_p_lt";
   3.135 +val not_ast_p_ndvd = thm "not_ast_p_ndvd";
   3.136 +val not_ast_p_dvd = thm "not_ast_p_dvd";
   3.137 +
   3.138 +(*Logical construction of the prop*)
   3.139 +(*Bset*)
   3.140 +val not_bst_p_conjI = thm "not_bst_p_conjI";
   3.141 +val not_bst_p_disjI = thm "not_bst_p_disjI";
   3.142 +val not_bst_p_Q_elim = thm "not_bst_p_Q_elim";
   3.143 +
   3.144 +(*Aset*)
   3.145 +val not_ast_p_conjI = thm "not_ast_p_conjI";
   3.146 +val not_ast_p_disjI = thm "not_ast_p_disjI";
   3.147 +val not_ast_p_Q_elim = thm "not_ast_p_Q_elim";
   3.148 +
   3.149 +(*Cooper*)
   3.150 +val cppi_eq = thm "cppi_eq";
   3.151 +val cpmi_eq = thm "cpmi_eq";
   3.152 +
   3.153 +(*Others*)
   3.154 +val simp_from_to = thm "simp_from_to";
   3.155 +val P_eqtrue = thm "P_eqtrue";
   3.156 +val P_eqfalse = thm "P_eqfalse";
   3.157 +
   3.158 +(*For Proving NNF*)
   3.159 +
   3.160 +val nnf_nn = thm "nnf_nn";
   3.161 +val nnf_im = thm "nnf_im";
   3.162 +val nnf_eq = thm "nnf_eq";
   3.163 +val nnf_sdj = thm "nnf_sdj";
   3.164 +val nnf_ncj = thm "nnf_ncj";
   3.165 +val nnf_nim = thm "nnf_nim";
   3.166 +val nnf_neq = thm "nnf_neq";
   3.167 +val nnf_ndj = thm "nnf_ndj";
   3.168 +
   3.169 +(*For Proving term linearizition*)
   3.170 +val linearize_dvd = thm "linearize_dvd";
   3.171 +val lf_lt = thm "lf_lt";
   3.172 +val lf_eq = thm "lf_eq";
   3.173 +val lf_dvd = thm "lf_dvd";
   3.174 +
   3.175 +
   3.176 +
   3.177 +(* ------------------------------------------------------------------------- *)
   3.178 +(*Datatatype declarations for Proofprotocol for the cooperprocedure.*)
   3.179 +(* ------------------------------------------------------------------------- *)
   3.180 +
   3.181 +
   3.182 +
   3.183 +(* ------------------------------------------------------------------------- *)
   3.184 +(*Datatatype declarations for Proofprotocol for the adjustcoeff step.*)
   3.185 +(* ------------------------------------------------------------------------- *)
   3.186 +datatype CpLog = No
   3.187 +                |Simp of term*CpLog
   3.188 +		|Blast of CpLog*CpLog
   3.189 +		|Aset of (term*term*(term list)*term)
   3.190 +		|Bset of (term*term*(term list)*term)
   3.191 +		|Minusinf of CpLog*CpLog
   3.192 +		|Cooper of term*CpLog*CpLog*CpLog
   3.193 +		|Eq_minf of term*term
   3.194 +		|Modd_minf of term*term
   3.195 +		|Eq_minf_conjI of CpLog*CpLog
   3.196 +		|Modd_minf_conjI of CpLog*CpLog	
   3.197 +		|Modd_minf_disjI of CpLog*CpLog
   3.198 +		|Eq_minf_disjI of CpLog*CpLog	
   3.199 +		|Not_bst_p of term*term*term*term*CpLog
   3.200 +		|Not_bst_p_atomic of term
   3.201 +		|Not_bst_p_conjI of CpLog*CpLog
   3.202 +		|Not_bst_p_disjI of CpLog*CpLog
   3.203 +		|Not_ast_p of term*term*term*term*CpLog
   3.204 +		|Not_ast_p_atomic of term
   3.205 +		|Not_ast_p_conjI of CpLog*CpLog
   3.206 +		|Not_ast_p_disjI of CpLog*CpLog
   3.207 +		|CpLogError;
   3.208 +
   3.209 +
   3.210 +
   3.211 +datatype ACLog = ACAt of int*term
   3.212 +                |ACPI of int*term
   3.213 +                |ACfm of term
   3.214 +                |ACNeg of ACLog
   3.215 +		|ACConst of string*ACLog*ACLog;
   3.216 +
   3.217 +
   3.218 +
   3.219 +(* ------------------------------------------------------------------------- *)
   3.220 +(*Datatatype declarations for Proofprotocol for the CNNF step.*)
   3.221 +(* ------------------------------------------------------------------------- *)
   3.222 +
   3.223 +
   3.224 +datatype NNFLog = NNFAt of term
   3.225 +                |NNFSimp of NNFLog
   3.226 +                |NNFNN of NNFLog
   3.227 +		|NNFConst of string*NNFLog*NNFLog;
   3.228 +
   3.229 +(* ------------------------------------------------------------------------- *)
   3.230 +(*Datatatype declarations for Proofprotocol for the linform  step.*)
   3.231 +(* ------------------------------------------------------------------------- *)
   3.232 +
   3.233 +
   3.234 +datatype LfLog = LfAt of term
   3.235 +                |LfAtdvd of term
   3.236 +                |Lffm of term
   3.237 +                |LfConst of string*LfLog*LfLog
   3.238 +		|LfNot of LfLog
   3.239 +		|LfQ of string*string*typ*LfLog;
   3.240 +
   3.241 +
   3.242 +(* ------------------------------------------------------------------------- *)
   3.243 +(*Datatatype declarations for Proofprotocol for the evaluation- evalc-  step.*)
   3.244 +(* ------------------------------------------------------------------------- *)
   3.245 +
   3.246 +
   3.247 +datatype EvalLog = EvalAt of term
   3.248 +                |Evalfm of term
   3.249 +		|EvalConst of string*EvalLog*EvalLog;
   3.250 +
   3.251 +(* ------------------------------------------------------------------------- *)
   3.252 +(*This function norm_zero_one  replaces the occurences of Numeral1 and Numeral0*)
   3.253 +(*Respectively by their abstract representation Const("1",..) and COnst("0",..)*)
   3.254 +(*this is necessary because the theorems use this representation.*)
   3.255 +(* This function should be elminated in next versions...*)
   3.256 +(* ------------------------------------------------------------------------- *)
   3.257 +
   3.258 +fun norm_zero_one fm = case fm of
   3.259 +  (Const ("op *",_) $ c $ t) => 
   3.260 +    if c = one then (norm_zero_one t)
   3.261 +    else if (dest_numeral c = ~1) 
   3.262 +         then (Const("uminus",HOLogic.intT --> HOLogic.intT) $ (norm_zero_one t))
   3.263 +         else (HOLogic.mk_binop "op *" (norm_zero_one c,norm_zero_one t))
   3.264 +  |(node $ rest) => ((norm_zero_one node)$(norm_zero_one rest))
   3.265 +  |(Abs(x,T,p)) => (Abs(x,T,(norm_zero_one p)))
   3.266 +  |_ => fm;
   3.267 +
   3.268 +
   3.269 +(* ------------------------------------------------------------------------- *)
   3.270 +(* Intended to tell that here we changed the structure of the formula with respect to the posineq theorem : ~(0 < t) = 0 < 1-t*)
   3.271 +(* ------------------------------------------------------------------------- *)
   3.272 +fun adjustcoeffeq_wp  x l fm = 
   3.273 +    case fm of  
   3.274 +  (Const("Not",_)$(Const("op <",_) $(Const("0",_)) $(rt as (Const ("op +", _)$(Const ("op *",_) $    c $ y ) $z )))) => 
   3.275 +  if (x = y) 
   3.276 +  then let  
   3.277 +       val m = l div (dest_numeral c) 
   3.278 +       val n = abs (m)
   3.279 +       val xtm = (HOLogic.mk_binop "op *" ((mk_numeral ((m div n)*l) ), x)) 
   3.280 +       val rs = (HOLogic.mk_binrel "op <" (zero,linear_sub [] one (HOLogic.mk_binop "op +" ( xtm ,( linear_cmul n z) )))) 
   3.281 +       in (ACPI(n,fm),rs)
   3.282 +       end
   3.283 +  else  let val rs = (HOLogic.mk_binrel "op <" (zero,linear_sub [] one rt )) 
   3.284 +        in (ACPI(1,fm),rs)
   3.285 +        end
   3.286 +
   3.287 +  |(Const(p,_) $d $( Const ("op +", _)$(Const ("op *",_) $ 
   3.288 +      c $ y ) $z )) => if (is_arith_rel fm) andalso (x = y) then  
   3.289 +        let val m = l div (dest_numeral c) 
   3.290 +           val n = (if p = "op <" then abs(m) else m)  
   3.291 +           val xtm = (HOLogic.mk_binop "op *" ((mk_numeral ((m div n)*l) ), x))
   3.292 +           val rs = (HOLogic.mk_binrel p ((linear_cmul n d),(HOLogic.mk_binop "op +" ( xtm ,( linear_cmul n z) )))) 
   3.293 +	   in (ACAt(n,fm),rs)
   3.294 +	   end
   3.295 +        else (ACfm(fm),fm) 
   3.296 +  |( Const ("Not", _) $ p) => let val (rsp,rsr) = adjustcoeffeq_wp x l p 
   3.297 +                              in (ACNeg(rsp),HOLogic.Not $ rsr) 
   3.298 +                              end
   3.299 +  |( Const ("op &",_) $ p $ q) =>let val (rspp,rspr) = adjustcoeffeq_wp x l p
   3.300 +                                     val (rsqp,rsqr) = adjustcoeffeq_wp x l q
   3.301 +
   3.302 +                                  in (ACConst ("CJ",rspp,rsqp), HOLogic.mk_conj (rspr,rsqr)) 
   3.303 +                                  end 
   3.304 +  |( Const ("op |",_) $ p $ q) =>let val (rspp,rspr) = adjustcoeffeq_wp x l p
   3.305 +                                     val (rsqp,rsqr) = adjustcoeffeq_wp x l q
   3.306 +
   3.307 +                                  in (ACConst ("DJ",rspp,rsqp), HOLogic.mk_disj (rspr,rsqr)) 
   3.308 +                                  end
   3.309 +
   3.310 +  |_ => (ACfm(fm),fm);
   3.311 +
   3.312 +
   3.313 +(*_________________________________________*)
   3.314 +(*-----------------------------------------*)
   3.315 +(* Protocol generation for the liform step *)
   3.316 +(*_________________________________________*)
   3.317 +(*-----------------------------------------*)
   3.318 +
   3.319 +
   3.320 +fun linform_wp fm = 
   3.321 +  let fun at_linform_wp at =
   3.322 +    case at of
   3.323 +      (Const("op <=",_)$s$t) => LfAt(at)
   3.324 +      |(Const("op <",_)$s$t) => LfAt(at)
   3.325 +      |(Const("op =",_)$s$t) => LfAt(at)
   3.326 +      |(Const("Divides.op dvd",_)$s$t) => LfAtdvd(at)
   3.327 +  in
   3.328 +  if is_arith_rel fm 
   3.329 +  then at_linform_wp fm 
   3.330 +  else case fm of
   3.331 +    (Const("Not",_) $ A) => LfNot(linform_wp A)
   3.332 +   |(Const("op &",_)$ A $ B) => LfConst("CJ",linform_wp A, linform_wp B)
   3.333 +   |(Const("op |",_)$ A $ B) => LfConst("DJ",linform_wp A, linform_wp B)
   3.334 +   |(Const("op -->",_)$ A $ B) => LfConst("IM",linform_wp A, linform_wp B)
   3.335 +   |(Const("op =",Type ("fun",[Type ("bool", []),_]))$ A $ B) => LfConst("EQ",linform_wp A, linform_wp B)
   3.336 +   |Const("Ex",_)$Abs(x,T,p) => 
   3.337 +     let val (xn,p1) = variant_abs(x,T,p)
   3.338 +     in LfQ("Ex",xn,T,linform_wp p1)
   3.339 +     end 
   3.340 +   |Const("All",_)$Abs(x,T,p) => 
   3.341 +     let val (xn,p1) = variant_abs(x,T,p)
   3.342 +     in LfQ("All",xn,T,linform_wp p1)
   3.343 +     end 
   3.344 +end;
   3.345 +
   3.346 +
   3.347 +(* ------------------------------------------------------------------------- *)
   3.348 +(*For simlified formulas we just notice the original formula, for whitch we habe been
   3.349 +intendes to make the proof.*)
   3.350 +(* ------------------------------------------------------------------------- *)
   3.351 +fun simpl_wp (fm,pr) = let val fm2 = simpl fm
   3.352 +				in (fm2,Simp(fm,pr))
   3.353 +				end;
   3.354 +
   3.355 +	
   3.356 +(* ------------------------------------------------------------------------- *)
   3.357 +(*Help function for the generation of the proof EX.P_{minus \infty} --> EX. P(x) *)
   3.358 +(* ------------------------------------------------------------------------- *)
   3.359 +fun minusinf_wph x fm = let fun mk_atomar_minusinf_proof x fm = (Modd_minf(x,fm),Eq_minf(x,fm))
   3.360 +  
   3.361 +	      fun combine_minusinf_proofs opr (ppr1,ppr2) (qpr1,qpr2) = case opr of 
   3.362 +		 "CJ" => (Modd_minf_conjI(ppr1,qpr1),Eq_minf_conjI(ppr2,qpr2))
   3.363 +		|"DJ" => (Modd_minf_disjI(ppr1,qpr1),Eq_minf_disjI(ppr2,qpr2))
   3.364 +	in 
   3.365 + 
   3.366 + case fm of 
   3.367 + (Const ("Not", _) $  (Const("op =",Type ("fun",[Type ("IntDef.int", []),_])) $ c1 $ (Const ("op +", _) $(Const ("op *",_) $ c2 $ y) $z))) => 
   3.368 +     if (x=y) andalso (c1= zero) andalso (c2= one) then (HOLogic.true_const ,(mk_atomar_minusinf_proof x fm))
   3.369 +        else (fm ,(mk_atomar_minusinf_proof x fm))
   3.370 + |(Const("op =",Type ("fun",[Type ("IntDef.int", []),_])) $ c1 $(Const ("op +", _) $(Const ("op *",_) $ c2 $ y) $z)) =>
   3.371 +  	 if (is_arith_rel fm) andalso (x=y) andalso (c1= zero) andalso (c2= one)
   3.372 +	 then (HOLogic.false_const ,(mk_atomar_minusinf_proof x fm))
   3.373 +	 				 else (fm,(mk_atomar_minusinf_proof x fm)) 
   3.374 + |(Const("op <",_) $ c1 $(Const ("op +", _) $(Const ("op *",_) $ c2 $ y ) $ z )) =>
   3.375 +       if (y=x) andalso (c1 = zero) then 
   3.376 +        if c2 = one then (HOLogic.false_const,(mk_atomar_minusinf_proof x fm)) else
   3.377 +	(HOLogic.true_const,(mk_atomar_minusinf_proof x fm))
   3.378 +	else (fm,(mk_atomar_minusinf_proof x fm))
   3.379 +  
   3.380 +  |(Const("Not",_)$(Const ("Divides.op dvd",_) $_ )) => (fm,mk_atomar_minusinf_proof x fm)
   3.381 +  
   3.382 +  |(Const ("Divides.op dvd",_) $_ ) => (fm,mk_atomar_minusinf_proof x fm)
   3.383 +  
   3.384 +  |(Const ("op &",_) $ p $ q) => let val (pfm,ppr) = minusinf_wph x p
   3.385 +  				    val (qfm,qpr) = minusinf_wph x q
   3.386 +				    val pr = (combine_minusinf_proofs "CJ" ppr qpr)
   3.387 +				     in 
   3.388 +				     (HOLogic.conj $ pfm $qfm , pr)
   3.389 +				     end 
   3.390 +  |(Const ("op |",_) $ p $ q) => let val (pfm,ppr) = minusinf_wph x p
   3.391 +  				     val (qfm,qpr) = minusinf_wph x q
   3.392 +				     val pr = (combine_minusinf_proofs "DJ" ppr qpr)
   3.393 +				     in 
   3.394 +				     (HOLogic.disj $ pfm $qfm , pr)
   3.395 +				     end 
   3.396 +
   3.397 +  |_ => (fm,(mk_atomar_minusinf_proof x fm))
   3.398 +  
   3.399 +  end;					 
   3.400 +(* ------------------------------------------------------------------------- *)	    (* Protokol for the Proof of the property of the minusinfinity formula*)
   3.401 +(* Just combines the to protokols *)
   3.402 +(* ------------------------------------------------------------------------- *)
   3.403 +fun minusinf_wp x fm  = let val (fm2,pr) = (minusinf_wph x fm)
   3.404 +                       in (fm2,Minusinf(pr))
   3.405 +                        end;
   3.406 +
   3.407 +(* ------------------------------------------------------------------------- *)
   3.408 +(*Help function for the generation of the proof EX.P_{plus \infty} --> EX. P(x) *)
   3.409 +(* ------------------------------------------------------------------------- *)
   3.410 +
   3.411 +fun plusinf_wph x fm = let fun mk_atomar_plusinf_proof x fm = (Modd_minf(x,fm),Eq_minf(x,fm))
   3.412 +  
   3.413 +	      fun combine_plusinf_proofs opr (ppr1,ppr2) (qpr1,qpr2) = case opr of 
   3.414 +		 "CJ" => (Modd_minf_conjI(ppr1,qpr1),Eq_minf_conjI(ppr2,qpr2))
   3.415 +		|"DJ" => (Modd_minf_disjI(ppr1,qpr1),Eq_minf_disjI(ppr2,qpr2))
   3.416 +	in 
   3.417 + 
   3.418 + case fm of 
   3.419 + (Const ("Not", _) $  (Const("op =",Type ("fun",[Type ("IntDef.int", []),_])) $ c1 $ (Const ("op +", _) $(Const ("op *",_) $ c2 $ y) $z))) => 
   3.420 +     if (x=y) andalso (c1= zero) andalso (c2= one) then (HOLogic.true_const ,(mk_atomar_plusinf_proof x fm))
   3.421 +        else (fm ,(mk_atomar_plusinf_proof x fm))
   3.422 + |(Const("op =",Type ("fun",[Type ("IntDef.int", []),_])) $ c1 $(Const ("op +", _) $(Const ("op *",_) $ c2 $ y) $z)) =>
   3.423 +  	 if (is_arith_rel fm) andalso (x=y) andalso (c1= zero) andalso (c2= one)
   3.424 +	 then (HOLogic.false_const ,(mk_atomar_plusinf_proof x fm))
   3.425 +	 				 else (fm,(mk_atomar_plusinf_proof x fm)) 
   3.426 + |(Const("op <",_) $ c1 $(Const ("op +", _) $(Const ("op *",_) $ c2 $ y ) $ z )) =>
   3.427 +       if (y=x) andalso (c1 = zero) then 
   3.428 +        if c2 = one then (HOLogic.true_const,(mk_atomar_plusinf_proof x fm)) else
   3.429 +	(HOLogic.false_const,(mk_atomar_plusinf_proof x fm))
   3.430 +	else (fm,(mk_atomar_plusinf_proof x fm))
   3.431 +  
   3.432 +  |(Const("Not",_)$(Const ("Divides.op dvd",_) $_ )) => (fm,mk_atomar_plusinf_proof x fm)
   3.433 +  
   3.434 +  |(Const ("Divides.op dvd",_) $_ ) => (fm,mk_atomar_plusinf_proof x fm)
   3.435 +  
   3.436 +  |(Const ("op &",_) $ p $ q) => let val (pfm,ppr) = plusinf_wph x p
   3.437 +  				    val (qfm,qpr) = plusinf_wph x q
   3.438 +				    val pr = (combine_plusinf_proofs "CJ" ppr qpr)
   3.439 +				     in 
   3.440 +				     (HOLogic.conj $ pfm $qfm , pr)
   3.441 +				     end 
   3.442 +  |(Const ("op |",_) $ p $ q) => let val (pfm,ppr) = plusinf_wph x p
   3.443 +  				     val (qfm,qpr) = plusinf_wph x q
   3.444 +				     val pr = (combine_plusinf_proofs "DJ" ppr qpr)
   3.445 +				     in 
   3.446 +				     (HOLogic.disj $ pfm $qfm , pr)
   3.447 +				     end 
   3.448 +
   3.449 +  |_ => (fm,(mk_atomar_plusinf_proof x fm))
   3.450 +  
   3.451 +  end;					 
   3.452 +(* ------------------------------------------------------------------------- *)	    (* Protokol for the Proof of the property of the minusinfinity formula*)
   3.453 +(* Just combines the to protokols *)
   3.454 +(* ------------------------------------------------------------------------- *)
   3.455 +fun plusinf_wp x fm  = let val (fm2,pr) = (plusinf_wph x fm)
   3.456 +                       in (fm2,Minusinf(pr))
   3.457 +                        end;
   3.458 +
   3.459 +
   3.460 +(* ------------------------------------------------------------------------- *)
   3.461 +(*Protocol that we here uses Bset.*)
   3.462 +(* ------------------------------------------------------------------------- *)
   3.463 +fun bset_wp x fm = let val bs = bset x fm in
   3.464 +				(bs,Bset(x,fm,bs,mk_numeral (divlcm x fm)))
   3.465 +				end;
   3.466 +
   3.467 +(* ------------------------------------------------------------------------- *)
   3.468 +(*Protocol that we here uses Aset.*)
   3.469 +(* ------------------------------------------------------------------------- *)
   3.470 +fun aset_wp x fm = let val ast = aset x fm in
   3.471 +				(ast,Aset(x,fm,ast,mk_numeral (divlcm x fm)))
   3.472 +				end;
   3.473 + 
   3.474 +
   3.475 +
   3.476 +(* ------------------------------------------------------------------------- *)
   3.477 +(*function list to Set, constructs a set containing all elements of a given list.*)
   3.478 +(* ------------------------------------------------------------------------- *)
   3.479 +fun list_to_set T1 l = let val T = (HOLogic.mk_setT T1) in 
   3.480 +	case l of 
   3.481 +		[] => Const ("{}",T)
   3.482 +		|(h::t) => Const("insert", T1 --> (T --> T)) $ h $(list_to_set T1 t)
   3.483 +		end;
   3.484 +		
   3.485 +
   3.486 +(*====================================================================*)
   3.487 +(* ------------------------------------------------------------------------- *)
   3.488 +(* ------------------------------------------------------------------------- *)
   3.489 +(*Protocol for the proof of the backward direction of the cooper theorem.*)
   3.490 +(* Helpfunction - Protokols evereything about the proof reconstruction*)
   3.491 +(* ------------------------------------------------------------------------- *)
   3.492 +fun not_bst_p_wph fm = case fm of
   3.493 +	Const("Not",_) $ R => if (is_arith_rel R) then (Not_bst_p_atomic (fm)) else CpLogError
   3.494 +	|Const("op &",_) $ ls $ rs => Not_bst_p_conjI((not_bst_p_wph ls),(not_bst_p_wph rs))
   3.495 +	|Const("op |",_) $ ls $ rs => Not_bst_p_disjI((not_bst_p_wph ls),(not_bst_p_wph rs))
   3.496 +	|_ => Not_bst_p_atomic (fm);
   3.497 +(* ------------------------------------------------------------------------- *)	
   3.498 +(* Main protocoling function for the backward direction gives the Bset and the divlcm and the Formula herself. Needed as inherited attributes for the proof reconstruction*)
   3.499 +(* ------------------------------------------------------------------------- *)
   3.500 +fun not_bst_p_wp x fm = let val prt = not_bst_p_wph fm
   3.501 +			    val D = mk_numeral (divlcm x fm)
   3.502 +			    val B = map norm_zero_one (bset x fm)
   3.503 +			in (Not_bst_p (x,fm,D,(list_to_set HOLogic.intT B) , prt))
   3.504 +			end;
   3.505 +(*====================================================================*)
   3.506 +(* ------------------------------------------------------------------------- *)
   3.507 +(* ------------------------------------------------------------------------- *)
   3.508 +(*Protocol for the proof of the backward direction of the cooper theorem.*)
   3.509 +(* Helpfunction - Protokols evereything about the proof reconstruction*)
   3.510 +(* ------------------------------------------------------------------------- *)
   3.511 +fun not_ast_p_wph fm = case fm of
   3.512 +	Const("Not",_) $ R => if (is_arith_rel R) then (Not_ast_p_atomic (fm)) else CpLogError
   3.513 +	|Const("op &",_) $ ls $ rs => Not_ast_p_conjI((not_ast_p_wph ls),(not_ast_p_wph rs))
   3.514 +	|Const("op |",_) $ ls $ rs => Not_ast_p_disjI((not_ast_p_wph ls),(not_ast_p_wph rs))
   3.515 +	|_ => Not_ast_p_atomic (fm);
   3.516 +(* ------------------------------------------------------------------------- *)	
   3.517 +(* Main protocoling function for the backward direction gives the Bset and the divlcm and the Formula herself. Needed as inherited attributes for the proof reconstruction*)
   3.518 +(* ------------------------------------------------------------------------- *)
   3.519 +fun not_ast_p_wp x fm = let val prt = not_ast_p_wph fm
   3.520 +			    val D = mk_numeral (divlcm x fm)
   3.521 +			    val B = map norm_zero_one (aset x fm)
   3.522 +			in (Not_ast_p (x,fm,D,(list_to_set HOLogic.intT B) , prt))
   3.523 +			end;
   3.524 +
   3.525 +(*======================================================*)
   3.526 +(* Protokolgeneration for the formula evaluation process*)
   3.527 +(*======================================================*)
   3.528 +
   3.529 +fun evalc_wp fm = 
   3.530 +  let fun evalc_atom_wp at =case at of  
   3.531 +    (Const (p,_) $ s $ t) =>(  
   3.532 +    case assoc (operations,p) of 
   3.533 +        Some f => ((if (f ((dest_numeral s),(dest_numeral t))) then EvalAt(HOLogic.mk_eq(at,HOLogic.true_const)) else EvalAt(HOLogic.mk_eq(at, HOLogic.false_const)))  
   3.534 +		   handle _ => Evalfm(at)) 
   3.535 +        | _ =>  Evalfm(at)) 
   3.536 +     |Const("Not",_)$(Const (p,_) $ s $ t) =>(  
   3.537 +       case assoc (operations,p) of 
   3.538 +         Some f => ((if (f ((dest_numeral s),(dest_numeral t))) then 
   3.539 +	  EvalAt(HOLogic.mk_eq(at, HOLogic.false_const))  else EvalAt(HOLogic.mk_eq(at,HOLogic.true_const)))  
   3.540 +		      handle _ => Evalfm(at)) 
   3.541 +         | _ => Evalfm(at)) 
   3.542 +     | _ => Evalfm(at)  
   3.543 + 
   3.544 +  in
   3.545 +   case fm of
   3.546 +    (Const("op &",_)$A$B) => EvalConst("CJ",evalc_wp A,evalc_wp B)
   3.547 +   |(Const("op |",_)$A$B) => EvalConst("DJ",evalc_wp A,evalc_wp B) 
   3.548 +   |(Const("op -->",_)$A$B) => EvalConst("IM",evalc_wp A,evalc_wp B) 
   3.549 +   |(Const("op =", Type ("fun",[Type ("bool", []),_]))$A$B) => EvalConst("EQ",evalc_wp A,evalc_wp B) 
   3.550 +   |_ => evalc_atom_wp fm
   3.551 +  end;
   3.552 +
   3.553 +
   3.554 +
   3.555 +(*======================================================*)
   3.556 +(* Protokolgeneration for the NNF Transformation        *)
   3.557 +(*======================================================*)
   3.558 +
   3.559 +fun cnnf_wp f = 
   3.560 +  let fun hcnnf_wp fm =
   3.561 +    case fm of
   3.562 +    (Const ("op &",_) $ p $ q) => NNFConst("CJ",hcnnf_wp p,hcnnf_wp q) 
   3.563 +    | (Const ("op |",_) $ p $ q) =>  NNFConst("DJ",hcnnf_wp p,hcnnf_wp q)
   3.564 +    | (Const ("op -->",_) $ p $q) => NNFConst("IM",hcnnf_wp (HOLogic.Not $ p),hcnnf_wp q)
   3.565 +    | (Const ("op =",Type ("fun",[Type ("bool", []),_])) $ p $ q) => NNFConst("EQ",hcnnf_wp (HOLogic.mk_conj(p,q)),hcnnf_wp (HOLogic.mk_conj((HOLogic.Not $ p), (HOLogic.Not $ q)))) 
   3.566 +
   3.567 +    | (Const ("Not",_) $ (Const("Not",_) $ p)) => NNFNN(hcnnf_wp p) 
   3.568 +    | (Const ("Not",_) $ (Const ("op &",_) $ p $ q)) => NNFConst ("NCJ",(hcnnf_wp(HOLogic.Not $ p)),(hcnnf_wp(HOLogic.Not $ q))) 
   3.569 +    | (Const ("Not",_) $(Const ("op |",_) $ (A as (Const ("op &",_) $ p $ q)) $  
   3.570 +    			(B as (Const ("op &",_) $ p1 $ r)))) => if p1 = negate p then 
   3.571 +		         NNFConst("SDJ",  
   3.572 +			   NNFConst("CJ",hcnnf_wp p,hcnnf_wp(HOLogic.Not $ q)),
   3.573 +			   NNFConst("CJ",hcnnf_wp p1,hcnnf_wp(HOLogic.Not $ r)))
   3.574 +			 else  NNFConst ("NDJ",(hcnnf_wp(HOLogic.Not $ A)),(hcnnf_wp(HOLogic.Not $ B))) 
   3.575 +
   3.576 +    | (Const ("Not",_) $ (Const ("op |",_) $ p $ q)) => NNFConst ("NDJ",(hcnnf_wp(HOLogic.Not $ p)),(hcnnf_wp(HOLogic.Not $ q))) 
   3.577 +    | (Const ("Not",_) $ (Const ("op -->",_) $ p $q)) =>  NNFConst ("NIM",(hcnnf_wp(p)),(hcnnf_wp(HOLogic.Not $ q))) 
   3.578 +    | (Const ("Not",_) $ (Const ("op =",Type ("fun",[Type ("bool", []),_]))  $ p $ q)) =>NNFConst ("NEQ",(NNFConst("CJ",hcnnf_wp p,hcnnf_wp(HOLogic.Not $ q))),(NNFConst("CJ",hcnnf_wp(HOLogic.Not $ p),hcnnf_wp q))) 
   3.579 +    | _ => NNFAt(fm)  
   3.580 +  in NNFSimp(hcnnf_wp f)
   3.581 +end; 
   3.582 +   
   3.583 +
   3.584 +
   3.585 +
   3.586 +
   3.587 +
   3.588 +(* ------------------------------------------------------------------------- *)
   3.589 +(*Cooper decision Procedure with proof protocoling*)
   3.590 +(* ------------------------------------------------------------------------- *)
   3.591 +
   3.592 +fun coopermi_wp vars fm =
   3.593 +  case fm of
   3.594 +   Const ("Ex",_) $ Abs(xo,T,po) => let 
   3.595 +    val (xn,np) = variant_abs(xo,T,po) 
   3.596 +    val x = (Free(xn , T))
   3.597 +    val p = np     (* Is this a legal proof for the P=NP Problem??*)
   3.598 +    val (p_inf,miprt) = simpl_wp (minusinf_wp x p)
   3.599 +    val (bset,bsprt) = bset_wp x p
   3.600 +    val nbst_p_prt = not_bst_p_wp x p
   3.601 +    val dlcm = divlcm x p 
   3.602 +    val js = 1 upto dlcm 
   3.603 +    fun p_element j b = linrep vars x (linear_add vars b (mk_numeral j)) p 
   3.604 +    fun stage j = list_disj (linrep vars x (mk_numeral j) p_inf :: map (p_element j) bset) 
   3.605 +   in (list_disj (map stage js),Cooper(mk_numeral dlcm,miprt,bsprt,nbst_p_prt))
   3.606 +   end
   3.607 +   
   3.608 +  | _ => (error "cooper: not an existential formula",No);
   3.609 +				
   3.610 +fun cooperpi_wp vars fm =
   3.611 +  case fm of
   3.612 +   Const ("Ex",_) $ Abs(xo,T,po) => let 
   3.613 +    val (xn,np) = variant_abs(xo,T,po) 
   3.614 +    val x = (Free(xn , T))
   3.615 +    val p = np     (* Is this a legal proof for the P=NP Problem??*)
   3.616 +    val (p_inf,piprt) = simpl_wp (plusinf_wp x p)
   3.617 +    val (aset,asprt) = aset_wp x p
   3.618 +    val nast_p_prt = not_ast_p_wp x p
   3.619 +    val dlcm = divlcm x p 
   3.620 +    val js = 1 upto dlcm 
   3.621 +    fun p_element j a = linrep vars x (linear_sub vars a (mk_numeral j)) p 
   3.622 +    fun stage j = list_disj (linrep vars x (mk_numeral j) p_inf :: map (p_element j) aset) 
   3.623 +   in (list_disj (map stage js),Cooper(mk_numeral dlcm,piprt,asprt,nast_p_prt))
   3.624 +   end
   3.625 +  | _ => (error "cooper: not an existential formula",No);
   3.626 +				
   3.627 +
   3.628 +
   3.629 +
   3.630 +
   3.631 +(*-----------------------------------------------------------------*)
   3.632 +(*-----------------------------------------------------------------*)
   3.633 +(*-----------------------------------------------------------------*)
   3.634 +(*---                                                           ---*)
   3.635 +(*---                                                           ---*)
   3.636 +(*---      Interpretation and Proofgeneration Part              ---*)
   3.637 +(*---                                                           ---*)
   3.638 +(*---      Protocole interpretation functions                   ---*)
   3.639 +(*---                                                           ---*)
   3.640 +(*---      and proofgeneration functions                        ---*)
   3.641 +(*---                                                           ---*)
   3.642 +(*---                                                           ---*)
   3.643 +(*---                                                           ---*)
   3.644 +(*---                                                           ---*)
   3.645 +(*-----------------------------------------------------------------*)
   3.646 +(*-----------------------------------------------------------------*)
   3.647 +(*-----------------------------------------------------------------*)
   3.648 +
   3.649 +(* ------------------------------------------------------------------------- *)
   3.650 +(* Returns both sides of an equvalence in the theorem*)
   3.651 +(* ------------------------------------------------------------------------- *)
   3.652 +fun qe_get_terms th = let val (_$(Const("op =",Type ("fun",[Type ("bool", []),_])) $ A $ B )) = prop_of th in (A,B) end;
   3.653 +
   3.654 +
   3.655 +(*-------------------------------------------------------------*)
   3.656 +(*-------------------------------------------------------------*)
   3.657 +(*-------------------------------------------------------------*)
   3.658 +(*-------------------------------------------------------------*)
   3.659 +
   3.660 +(* ------------------------------------------------------------------------- *)
   3.661 +(* Modified version of the simple version with minimal amount of checking and postprocessing*)
   3.662 +(* ------------------------------------------------------------------------- *)
   3.663 +
   3.664 +fun simple_prove_goal_cterm2 G tacs =
   3.665 +  let
   3.666 +    fun check None = error "prove_goal: tactic failed"
   3.667 +      | check (Some (thm, _)) = (case nprems_of thm of
   3.668 +            0 => thm
   3.669 +          | i => !result_error_fn thm (string_of_int i ^ " unsolved goals!"))
   3.670 +  in check (Seq.pull (EVERY tacs (trivial G))) end;
   3.671 +
   3.672 +(*-------------------------------------------------------------*)
   3.673 +(*-------------------------------------------------------------*)
   3.674 +(*-------------------------------------------------------------*)
   3.675 +(*-------------------------------------------------------------*)
   3.676 +(*-------------------------------------------------------------*)
   3.677 +
   3.678 +fun cert_Trueprop sg t = cterm_of sg (HOLogic.mk_Trueprop t);
   3.679 +
   3.680 +(* ------------------------------------------------------------------------- *)
   3.681 +(*This function proove elementar will be used to generate proofs at runtime*)
   3.682 +(*It is is based on the isabelle function proove_goalw_cterm and is thought to *)
   3.683 +(*prove properties such as a dvd b (essentially) that are only to make at
   3.684 +runtime.*)
   3.685 +(* ------------------------------------------------------------------------- *)
   3.686 +fun prove_elementar sg s fm2 = case s of 
   3.687 +  (*"ss" like simplification with simpset*)
   3.688 +  "ss" =>
   3.689 +    let
   3.690 +      val ss = presburger_ss addsimps
   3.691 +        [zdvd_iff_zmod_eq_0,unity_coeff_ex]
   3.692 +      val ct =  cert_Trueprop sg fm2
   3.693 +    in 
   3.694 +      simple_prove_goal_cterm2 ct [simp_tac ss 1, TRY (simple_arith_tac 1)]
   3.695 +    end
   3.696 +
   3.697 +  (*"bl" like blast tactic*)
   3.698 +  (* Is only used in the harrisons like proof procedure *)
   3.699 +  | "bl" =>
   3.700 +     let val ct = cert_Trueprop sg fm2
   3.701 +     in
   3.702 +       simple_prove_goal_cterm2 ct [blast_tac HOL_cs 1]
   3.703 +     end
   3.704 +
   3.705 +  (*"ed" like Existence disjunctions ...*)
   3.706 +  (* Is only used in the harrisons like proof procedure *)
   3.707 +  | "ed" =>
   3.708 +    let
   3.709 +      val ex_disj_tacs =
   3.710 +        let
   3.711 +          val tac1 = EVERY[REPEAT(resolve_tac [disjI1,disjI2] 1), etac exI 1]
   3.712 +          val tac2 = EVERY[etac exE 1, rtac exI 1,
   3.713 +            REPEAT(resolve_tac [disjI1,disjI2] 1), assumption 1]
   3.714 +	in [rtac iffI 1,
   3.715 +          etac exE 1, REPEAT(EVERY[etac disjE 1, tac1]), tac1,
   3.716 +          REPEAT(EVERY[etac disjE 1, tac2]), tac2]
   3.717 +        end
   3.718 +
   3.719 +      val ct = cert_Trueprop sg fm2
   3.720 +    in 
   3.721 +      simple_prove_goal_cterm2 ct ex_disj_tacs
   3.722 +    end
   3.723 +
   3.724 +  | "fa" =>
   3.725 +    let val ct = cert_Trueprop sg fm2
   3.726 +    in simple_prove_goal_cterm2 ct [simple_arith_tac 1]
   3.727 +    end
   3.728 +
   3.729 +  | "sa" =>
   3.730 +    let
   3.731 +      val ss = presburger_ss addsimps zadd_ac
   3.732 +      val ct = cert_Trueprop sg fm2
   3.733 +    in 
   3.734 +      simple_prove_goal_cterm2 ct [simp_tac ss 1, TRY (simple_arith_tac 1)]
   3.735 +    end
   3.736 +
   3.737 +  | "ac" =>
   3.738 +    let
   3.739 +      val ss = HOL_basic_ss addsimps zadd_ac
   3.740 +      val ct = cert_Trueprop sg fm2
   3.741 +    in 
   3.742 +      simple_prove_goal_cterm2 ct [simp_tac ss 1]
   3.743 +    end
   3.744 +
   3.745 +  | "lf" =>
   3.746 +    let
   3.747 +      val ss = presburger_ss addsimps zadd_ac
   3.748 +      val ct = cert_Trueprop sg fm2
   3.749 +    in 
   3.750 +      simple_prove_goal_cterm2 ct [simp_tac ss 1, TRY (simple_arith_tac 1)]
   3.751 +    end;
   3.752 +
   3.753 +
   3.754 +
   3.755 +(* ------------------------------------------------------------------------- *)
   3.756 +(* This function return an Isabelle proof, of the adjustcoffeq result.*)
   3.757 +(* The proofs are in Presburger.thy and are generally based on the arithmetic *)
   3.758 +(* ------------------------------------------------------------------------- *)
   3.759 +fun proof_of_adjustcoeffeq sg (prt,rs) = case prt of
   3.760 +   ACfm fm => instantiate' [Some cboolT]
   3.761 +    [Some (cterm_of sg fm)] refl
   3.762 + | ACAt (k,at as (Const(p,_) $a $( Const ("op +", _)$(Const ("op *",_) $ 
   3.763 +      c $ x ) $t ))) => 
   3.764 +   let
   3.765 +     val ck = cterm_of sg (mk_numeral k)
   3.766 +     val cc = cterm_of sg c
   3.767 +     val ct = cterm_of sg t
   3.768 +     val cx = cterm_of sg x
   3.769 +     val ca = cterm_of sg a
   3.770 +   in case p of
   3.771 +     "op <" => let val pre = prove_elementar sg "ss" 
   3.772 +	                  (HOLogic.mk_binrel "op <" (Const("0",HOLogic.intT),(mk_numeral k)))
   3.773 +	           val th1 = (pre RS (instantiate' [] [Some ck,Some ca,Some cc, Some cx, Some ct] (ac_lt_eq)))
   3.774 +		      in [th1,(prove_elementar sg "ss" (HOLogic.mk_eq (snd (qe_get_terms th1) ,rs)))] MRS trans
   3.775 +                   end
   3.776 +    |"op =" =>let val pre = prove_elementar sg "ss" 
   3.777 +	    (HOLogic.Not $ (HOLogic.mk_binrel "op =" (Const("0",HOLogic.intT),(mk_numeral k))))
   3.778 +	          in let val th1 = (pre RS(instantiate' [] [Some ck,Some ca,Some cc, Some cx, Some ct] (ac_eq_eq)))
   3.779 +	             in [th1,(prove_elementar sg "ss" (HOLogic.mk_eq (snd (qe_get_terms th1) ,rs)))] MRS trans
   3.780 +                      end
   3.781 +                  end
   3.782 +    |"Divides.op dvd" =>let val pre = prove_elementar sg "ss" 
   3.783 +	   (HOLogic.Not $ (HOLogic.mk_binrel "op =" (Const("0",HOLogic.intT),(mk_numeral k))))
   3.784 +	                 val th1 = (pre RS (instantiate' [] [Some ck,Some ca,Some cc, Some cx, Some ct]) (ac_dvd_eq))
   3.785 +                         in [th1,(prove_elementar sg "ss" (HOLogic.mk_eq (snd (qe_get_terms th1) ,rs)))] MRS trans
   3.786 +                        
   3.787 +                          end
   3.788 +  end
   3.789 + |ACPI(k,at as (Const("Not",_)$(Const("op <",_) $a $( Const ("op +", _)$(Const ("op *",_) $ c $ x ) $t )))) => 
   3.790 +   let
   3.791 +     val ck = cterm_of sg (mk_numeral k)
   3.792 +     val cc = cterm_of sg c
   3.793 +     val ct = cterm_of sg t
   3.794 +     val cx = cterm_of sg x
   3.795 +     val pre = prove_elementar sg "ss" 
   3.796 +       (HOLogic.mk_binrel "op <" (Const("0",HOLogic.intT),(mk_numeral k)))
   3.797 +       val th1 = (pre RS (instantiate' [] [Some ck,Some cc, Some cx, Some ct] (ac_pi_eq)))
   3.798 +
   3.799 +         in [th1,(prove_elementar sg "sa" (HOLogic.mk_eq (snd (qe_get_terms th1) ,rs)))] MRS trans
   3.800 +   end
   3.801 + |ACNeg(pr) => let val (Const("Not",_)$nrs) = rs
   3.802 +               in (proof_of_adjustcoeffeq sg (pr,nrs)) RS (qe_Not) 
   3.803 +               end
   3.804 + |ACConst(s,pr1,pr2) =>
   3.805 +   let val (Const(_,_)$rs1$rs2) = rs
   3.806 +       val th1 = proof_of_adjustcoeffeq sg (pr1,rs1)
   3.807 +       val th2 = proof_of_adjustcoeffeq sg (pr2,rs2)
   3.808 +       in case s of 
   3.809 +	 "CJ" => [th1,th2] MRS (qe_conjI)
   3.810 +         |"DJ" => [th1,th2] MRS (qe_disjI)
   3.811 +         |"IM" => [th1,th2] MRS (qe_impI)
   3.812 +         |"EQ" => [th1,th2] MRS (qe_eqI)
   3.813 +   end;
   3.814 +
   3.815 +
   3.816 +
   3.817 +
   3.818 +
   3.819 +
   3.820 +(* ------------------------------------------------------------------------- *)
   3.821 +(* This function return an Isabelle proof, of some properties on the atoms*)
   3.822 +(* The proofs are in Presburger.thy and are generally based on the arithmetic *)
   3.823 +(* This function doese only instantiate the the theorems in the theory *)
   3.824 +(* ------------------------------------------------------------------------- *)
   3.825 +fun atomar_minf_proof_of sg dlcm (Modd_minf (x,fm1)) =
   3.826 +  let
   3.827 +    (*Some certified Terms*)
   3.828 +    
   3.829 +   val ctrue = cterm_of sg HOLogic.true_const
   3.830 +   val cfalse = cterm_of sg HOLogic.false_const
   3.831 +   val fm = norm_zero_one fm1
   3.832 +  in  case fm1 of 
   3.833 +      (Const ("Not", _) $ (Const("op =",Type ("fun",[Type ("IntDef.int", []),_])) $ c1 $ (Const ("op +", _) $(Const ("op *",_) $ c2 $ y) $z))) => 
   3.834 +         if (x=y) andalso (c1= zero) andalso (c2= one) then (instantiate' [Some cboolT] [Some ctrue] (fm_modd_minf))
   3.835 +           else (instantiate' [Some cboolT] [Some (cterm_of sg fm)] (fm_modd_minf))
   3.836 +
   3.837 +      |(Const("op =",Type ("fun",[Type ("IntDef.int", []),_])) $ c1 $(Const ("op +", _) $(Const ("op *",_) $ c2 $ y) $z)) =>
   3.838 +  	   if (is_arith_rel fm) andalso (x=y) andalso (c1= zero) andalso (c2= one) 
   3.839 +	   then (instantiate' [Some cboolT] [Some cfalse] (fm_modd_minf))
   3.840 +	 	 else (instantiate' [Some cboolT] [Some (cterm_of sg fm)] (fm_modd_minf)) 
   3.841 +
   3.842 +      |(Const("op <",_) $ c1 $(Const ("op +", _) $(Const ("op *",_) $ pm1 $ y ) $ z )) =>
   3.843 +           if (y=x) andalso (c1 = zero) then 
   3.844 +            if (pm1 = one) then (instantiate' [Some cboolT] [Some cfalse] (fm_modd_minf)) else
   3.845 +	     (instantiate' [Some cboolT] [Some ctrue] (fm_modd_minf))
   3.846 +	    else (instantiate' [Some cboolT] [Some (cterm_of sg fm)] (fm_modd_minf))
   3.847 +  
   3.848 +      |Const ("Not",_) $ (Const("Divides.op dvd",_)$ d $ (Const ("op +",_) $ (Const ("op *",_) $ c $ y ) $ z)) => 
   3.849 +         if y=x then  let val cz = cterm_of sg (norm_zero_one z)
   3.850 +			  val fm2 = HOLogic.mk_binrel "op =" (HOLogic.mk_binop "Divides.op mod" (dlcm,d),norm_zero_one zero)
   3.851 +	 	      in(instantiate' [] [Some cz ] ((((prove_elementar sg "ss" fm2)) RS(((zdvd_iff_zmod_eq_0)RS sym) RS iffD1) ) RS (not_dvd_modd_minf)))
   3.852 +		      end
   3.853 +		else (instantiate' [Some cboolT] [Some (cterm_of sg fm)] (fm_modd_minf))
   3.854 +      |(Const("Divides.op dvd",_)$ d $ (db as (Const ("op +",_) $ (Const ("op *",_) $
   3.855 +      c $ y ) $ z))) => 
   3.856 +         if y=x then  let val cz = cterm_of sg (norm_zero_one z)
   3.857 +			  val fm2 = HOLogic.mk_binrel "op =" (HOLogic.mk_binop "Divides.op mod" (dlcm,d),norm_zero_one zero)
   3.858 +	 	      in(instantiate' [] [Some cz ] ((((prove_elementar sg "ss" fm2)) RS (((zdvd_iff_zmod_eq_0)RS sym) RS iffD1) ) RS (dvd_modd_minf)))
   3.859 +		      end
   3.860 +		else (instantiate' [Some cboolT] [Some (cterm_of sg fm)] (fm_modd_minf))
   3.861 +		
   3.862 +    
   3.863 +   |_ => instantiate' [Some cboolT] [Some (cterm_of sg fm)] (fm_modd_minf)
   3.864 +   end	
   3.865 +
   3.866 + |atomar_minf_proof_of sg dlcm (Eq_minf (x,fm1)) =  let
   3.867 +       (*Some certified types*)
   3.868 +   val fm = norm_zero_one fm1
   3.869 +    in  case fm1 of 
   3.870 +      (Const ("Not", _) $ (Const("op =",Type ("fun",[Type ("IntDef.int", []),_])) $ c1 $ (Const ("op +", _) $(Const ("op *",_) $ c2 $ y) $z))) => 
   3.871 +         if  (x=y) andalso (c1=zero) andalso (c2=one) 
   3.872 +	   then (instantiate' [] [Some (cterm_of sg (norm_zero_one z))] (neq_eq_minf))
   3.873 +           else (instantiate' [Some cboolT] [Some (cterm_of sg fm)] (fm_eq_minf))
   3.874 +
   3.875 +      |(Const("op =",Type ("fun",[Type ("IntDef.int", []),_])) $ c1 $(Const ("op +", _) $(Const ("op *",_) $ c2 $ y) $z)) =>
   3.876 +  	   if (is_arith_rel fm) andalso (x=y) andalso ((c1=zero) orelse (c1 = norm_zero_one zero)) andalso ((c2=one) orelse (c1 = norm_zero_one one))
   3.877 +	     then (instantiate' [] [Some (cterm_of sg (norm_zero_one z))] (eq_eq_minf))
   3.878 +	     else (instantiate' [Some cboolT] [Some (cterm_of sg fm)] (fm_eq_minf)) 
   3.879 +
   3.880 +      |(Const("op <",_) $ c1 $(Const ("op +", _) $(Const ("op *",_) $ pm1 $ y ) $ z )) =>
   3.881 +           if (y=x) andalso (c1 =zero) then 
   3.882 +            if pm1 = one then (instantiate' [] [Some (cterm_of sg (norm_zero_one z))] (le_eq_minf)) else
   3.883 +	     (instantiate' [] [Some (cterm_of sg (norm_zero_one z))] (len_eq_minf))
   3.884 +	    else (instantiate' [Some cboolT] [Some (cterm_of sg fm)] (fm_eq_minf))
   3.885 +      |Const ("Not",_) $ (Const("Divides.op dvd",_)$ d $ (Const ("op +",_) $ (Const ("op *",_) $ c $ y ) $ z)) => 
   3.886 +         if y=x then  let val cd = cterm_of sg (norm_zero_one d)
   3.887 +	 		  val cz = cterm_of sg (norm_zero_one z)
   3.888 +	 	      in(instantiate' [] [Some cd,  Some cz] (not_dvd_eq_minf)) 
   3.889 +		      end
   3.890 +
   3.891 +		else (instantiate' [Some cboolT] [Some (cterm_of sg fm)] (fm_eq_minf))
   3.892 +		
   3.893 +      |(Const("Divides.op dvd",_)$ d $ (Const ("op +",_) $ (Const ("op *",_) $ c $ y ) $ z)) => 
   3.894 +         if y=x then  let val cd = cterm_of sg (norm_zero_one d)
   3.895 +	 		  val cz = cterm_of sg (norm_zero_one z)
   3.896 +	 	      in(instantiate' [] [Some cd, Some cz ] (dvd_eq_minf))
   3.897 +		      end
   3.898 +		else (instantiate' [Some cboolT] [Some (cterm_of sg fm)] (fm_eq_minf))
   3.899 +
   3.900 +      		
   3.901 +    |_ => (instantiate' [Some cboolT] [Some (cterm_of sg fm)] (fm_eq_minf))
   3.902 + end;
   3.903 +
   3.904 +
   3.905 +(* ------------------------------------------------------------------------- *)
   3.906 +(* This function combines proofs of some special form already synthetised from the subtrees to make*)
   3.907 +(* a new proof of the same form. The combination occures whith isabelle theorems which have been already prooved *)
   3.908 +(*these Theorems are in Presburger.thy and mostly do not relay on the arithmetic.*)
   3.909 +(* These are Theorems for the Property of P_{-infty}*)
   3.910 +(* ------------------------------------------------------------------------- *)
   3.911 +fun combine_minf_proof s pr1 pr2 = case s of
   3.912 +    "ECJ" => [pr1 , pr2] MRS (eq_minf_conjI)
   3.913 +
   3.914 +   |"EDJ" => [pr1 , pr2] MRS (eq_minf_disjI)
   3.915 +   
   3.916 +   |"MCJ" => [pr1 , pr2] MRS (modd_minf_conjI)
   3.917 +
   3.918 +   |"MDJ" => [pr1 , pr2] MRS (modd_minf_disjI);
   3.919 +
   3.920 +(* ------------------------------------------------------------------------- *)
   3.921 +(*This function return an isabelle Proof for the minusinfinity theorem*)
   3.922 +(* It interpretates the protool and gives the protokoles property of P_{...} as a theorem*)
   3.923 +(* ------------------------------------------------------------------------- *)
   3.924 +fun minf_proof_ofh sg dlcm prl = case prl of 
   3.925 +
   3.926 +    Eq_minf (_) => atomar_minf_proof_of sg dlcm prl
   3.927 +    
   3.928 +   |Modd_minf (_) => atomar_minf_proof_of sg dlcm prl
   3.929 +   
   3.930 +   |Eq_minf_conjI (prl1,prl2) => let val pr1 = minf_proof_ofh sg dlcm prl1
   3.931 +   				    val pr2 = minf_proof_ofh sg dlcm prl2
   3.932 +				 in (combine_minf_proof "ECJ" pr1 pr2)
   3.933 +				 end
   3.934 +				 
   3.935 +   |Eq_minf_disjI (prl1,prl2) => let val pr1 = minf_proof_ofh sg dlcm prl1
   3.936 +   				    val pr2 = minf_proof_ofh sg dlcm prl2
   3.937 +				 in (combine_minf_proof "EDJ" pr1 pr2)
   3.938 +				 end
   3.939 +				 
   3.940 +   |Modd_minf_conjI (prl1,prl2) => let val pr1 = minf_proof_ofh sg dlcm prl1
   3.941 +   				    val pr2 = minf_proof_ofh sg dlcm prl2
   3.942 +				 in (combine_minf_proof "MCJ" pr1 pr2)
   3.943 +				 end
   3.944 +				 
   3.945 +   |Modd_minf_disjI (prl1,prl2) => let val pr1 = minf_proof_ofh sg dlcm prl1
   3.946 +   				    val pr2 = minf_proof_ofh sg dlcm prl2
   3.947 +				 in (combine_minf_proof "MDJ" pr1 pr2)
   3.948 +				 end;
   3.949 +(* ------------------------------------------------------------------------- *)
   3.950 +(* Main function For the rest both properies of P_{..} are needed and here both theorems are returned.*)				 
   3.951 +(* ------------------------------------------------------------------------- *)
   3.952 +fun  minf_proof_of sg dlcm (Minusinf (prl1,prl2))  = 
   3.953 +  let val pr1 = minf_proof_ofh sg dlcm prl1
   3.954 +      val pr2 = minf_proof_ofh sg dlcm prl2
   3.955 +  in (pr1, pr2)
   3.956 +end;
   3.957 +				 
   3.958 +
   3.959 +
   3.960 +
   3.961 +(* ------------------------------------------------------------------------- *)
   3.962 +(* This function return an Isabelle proof, of some properties on the atoms*)
   3.963 +(* The proofs are in Presburger.thy and are generally based on the arithmetic *)
   3.964 +(* This function doese only instantiate the the theorems in the theory *)
   3.965 +(* ------------------------------------------------------------------------- *)
   3.966 +fun atomar_pinf_proof_of sg dlcm (Modd_minf (x,fm1)) =
   3.967 + let
   3.968 +    (*Some certified Terms*)
   3.969 +    
   3.970 +  val ctrue = cterm_of sg HOLogic.true_const
   3.971 +  val cfalse = cterm_of sg HOLogic.false_const
   3.972 +  val fm = norm_zero_one fm1
   3.973 + in  case fm1 of 
   3.974 +      (Const ("Not", _) $ (Const("op =",Type ("fun",[Type ("IntDef.int", []),_])) $ c1 $ (Const ("op +", _) $(Const ("op *",_) $ c2 $ y) $z))) => 
   3.975 +         if ((x=y) andalso (c1= zero) andalso (c2= one))
   3.976 +	 then (instantiate' [Some cboolT] [Some ctrue] (fm_modd_pinf))
   3.977 +         else (instantiate' [Some cboolT] [Some (cterm_of sg fm)] (fm_modd_pinf))
   3.978 +
   3.979 +      |(Const("op =",Type ("fun",[Type ("IntDef.int", []),_])) $ c1 $(Const ("op +", _) $(Const ("op *",_) $ c2 $ y) $z)) =>
   3.980 +  	if ((is_arith_rel fm) andalso (x = y) andalso (c1 = zero)  andalso (c2 = one)) 
   3.981 +	then (instantiate' [Some cboolT] [Some cfalse] (fm_modd_pinf))
   3.982 +	else (instantiate' [Some cboolT] [Some (cterm_of sg fm)] (fm_modd_pinf))
   3.983 +
   3.984 +      |(Const("op <",_) $ c1 $(Const ("op +", _) $(Const ("op *",_) $ pm1 $ y ) $ z )) =>
   3.985 +        if ((y=x) andalso (c1 = zero)) then 
   3.986 +          if (pm1 = one) 
   3.987 +	  then (instantiate' [Some cboolT] [Some ctrue] (fm_modd_pinf)) 
   3.988 +	  else (instantiate' [Some cboolT] [Some cfalse] (fm_modd_pinf))
   3.989 +	else (instantiate' [Some cboolT] [Some (cterm_of sg fm)] (fm_modd_pinf))
   3.990 +  
   3.991 +      |Const ("Not",_) $ (Const("Divides.op dvd",_)$ d $ (Const ("op +",_) $ (Const ("op *",_) $ c $ y ) $ z)) => 
   3.992 +         if y=x then  let val cz = cterm_of sg (norm_zero_one z)
   3.993 +			  val fm2 = HOLogic.mk_binrel "op =" (HOLogic.mk_binop "Divides.op mod" (dlcm,d),norm_zero_one zero)
   3.994 +	 	      in(instantiate' [] [Some cz ] ((((prove_elementar sg "ss" fm2)) RS(((zdvd_iff_zmod_eq_0)RS sym) RS iffD1) ) RS (not_dvd_modd_pinf)))
   3.995 +		      end
   3.996 +		else (instantiate' [Some cboolT] [Some (cterm_of sg fm)] (fm_modd_pinf))
   3.997 +      |(Const("Divides.op dvd",_)$ d $ (db as (Const ("op +",_) $ (Const ("op *",_) $
   3.998 +      c $ y ) $ z))) => 
   3.999 +         if y=x then  let val cz = cterm_of sg (norm_zero_one z)
  3.1000 +			  val fm2 = HOLogic.mk_binrel "op =" (HOLogic.mk_binop "Divides.op mod" (dlcm,d),norm_zero_one zero)
  3.1001 +	 	      in(instantiate' [] [Some cz ] ((((prove_elementar sg "ss" fm2)) RS (((zdvd_iff_zmod_eq_0)RS sym) RS iffD1) ) RS (dvd_modd_pinf)))
  3.1002 +		      end
  3.1003 +		else (instantiate' [Some cboolT] [Some (cterm_of sg fm)] (fm_modd_pinf))
  3.1004 +		
  3.1005 +    
  3.1006 +   |_ => instantiate' [Some cboolT] [Some (cterm_of sg fm)] (fm_modd_pinf)
  3.1007 +   end	
  3.1008 +
  3.1009 + |atomar_pinf_proof_of sg dlcm (Eq_minf (x,fm1)) =  let
  3.1010 +					val fm = norm_zero_one fm1
  3.1011 +    in  case fm1 of 
  3.1012 +      (Const ("Not", _) $ (Const("op =",Type ("fun",[Type ("IntDef.int", []),_])) $ c1 $ (Const ("op +", _) $(Const ("op *",_) $ c2 $ y) $z))) => 
  3.1013 +         if  (x=y) andalso (c1=zero) andalso (c2=one) 
  3.1014 +	   then (instantiate' [] [Some (cterm_of sg (norm_zero_one z))] (neq_eq_pinf))
  3.1015 +           else (instantiate' [Some cboolT] [Some (cterm_of sg fm)] (fm_eq_pinf))
  3.1016 +
  3.1017 +      |(Const("op =",Type ("fun",[Type ("IntDef.int", []),_])) $ c1 $(Const ("op +", _) $(Const ("op *",_) $ c2 $ y) $z)) =>
  3.1018 +  	   if (is_arith_rel fm) andalso (x=y) andalso ((c1=zero) orelse (c1 = norm_zero_one zero)) andalso ((c2=one) orelse (c1 = norm_zero_one one))
  3.1019 +	     then (instantiate' [] [Some (cterm_of sg (norm_zero_one z))] (eq_eq_pinf))
  3.1020 +	     else (instantiate' [Some cboolT] [Some (cterm_of sg fm)] (fm_eq_pinf)) 
  3.1021 +
  3.1022 +      |(Const("op <",_) $ c1 $(Const ("op +", _) $(Const ("op *",_) $ pm1 $ y ) $ z )) =>
  3.1023 +           if (y=x) andalso (c1 =zero) then 
  3.1024 +            if pm1 = one then (instantiate' [] [Some (cterm_of sg (norm_zero_one z))] (le_eq_pinf)) else
  3.1025 +	     (instantiate' [] [Some (cterm_of sg (norm_zero_one z))] (len_eq_pinf))
  3.1026 +	    else (instantiate' [Some cboolT] [Some (cterm_of sg fm)] (fm_eq_pinf))
  3.1027 +      |Const ("Not",_) $ (Const("Divides.op dvd",_)$ d $ (Const ("op +",_) $ (Const ("op *",_) $ c $ y ) $ z)) => 
  3.1028 +         if y=x then  let val cd = cterm_of sg (norm_zero_one d)
  3.1029 +	 		  val cz = cterm_of sg (norm_zero_one z)
  3.1030 +	 	      in(instantiate' [] [Some cd,  Some cz] (not_dvd_eq_pinf)) 
  3.1031 +		      end
  3.1032 +
  3.1033 +		else (instantiate' [Some cboolT] [Some (cterm_of sg fm)] (fm_eq_pinf))
  3.1034 +		
  3.1035 +      |(Const("Divides.op dvd",_)$ d $ (Const ("op +",_) $ (Const ("op *",_) $ c $ y ) $ z)) => 
  3.1036 +         if y=x then  let val cd = cterm_of sg (norm_zero_one d)
  3.1037 +	 		  val cz = cterm_of sg (norm_zero_one z)
  3.1038 +	 	      in(instantiate' [] [Some cd, Some cz ] (dvd_eq_pinf))
  3.1039 +		      end
  3.1040 +		else (instantiate' [Some cboolT] [Some (cterm_of sg fm)] (fm_eq_pinf))
  3.1041 +
  3.1042 +      		
  3.1043 +    |_ => (instantiate' [Some cboolT] [Some (cterm_of sg fm)] (fm_eq_pinf))
  3.1044 + end;
  3.1045 +
  3.1046 +
  3.1047 +(* ------------------------------------------------------------------------- *)
  3.1048 +(* This function combines proofs of some special form already synthetised from the subtrees to make*)
  3.1049 +(* a new proof of the same form. The combination occures whith isabelle theorems which have been already prooved *)
  3.1050 +(*these Theorems are in Presburger.thy and mostly do not relay on the arithmetic.*)
  3.1051 +(* These are Theorems for the Property of P_{+infty}*)
  3.1052 +(* ------------------------------------------------------------------------- *)
  3.1053 +fun combine_pinf_proof s pr1 pr2 = case s of
  3.1054 +    "ECJ" => [pr1 , pr2] MRS (eq_pinf_conjI)
  3.1055 +
  3.1056 +   |"EDJ" => [pr1 , pr2] MRS (eq_pinf_disjI)
  3.1057 +   
  3.1058 +   |"MCJ" => [pr1 , pr2] MRS (modd_pinf_conjI)
  3.1059 +
  3.1060 +   |"MDJ" => [pr1 , pr2] MRS (modd_pinf_disjI);
  3.1061 +
  3.1062 +(* ------------------------------------------------------------------------- *)
  3.1063 +(*This function return an isabelle Proof for the minusinfinity theorem*)
  3.1064 +(* It interpretates the protool and gives the protokoles property of P_{...} as a theorem*)
  3.1065 +(* ------------------------------------------------------------------------- *)
  3.1066 +fun pinf_proof_ofh sg dlcm prl = case prl of 
  3.1067 +
  3.1068 +    Eq_minf (_) => atomar_pinf_proof_of sg dlcm prl
  3.1069 +    
  3.1070 +   |Modd_minf (_) => atomar_pinf_proof_of sg dlcm prl
  3.1071 +   
  3.1072 +   |Eq_minf_conjI (prl1,prl2) => let val pr1 = pinf_proof_ofh sg dlcm prl1
  3.1073 +   				    val pr2 = pinf_proof_ofh sg dlcm prl2
  3.1074 +				 in (combine_pinf_proof "ECJ" pr1 pr2)
  3.1075 +				 end
  3.1076 +				 
  3.1077 +   |Eq_minf_disjI (prl1,prl2) => let val pr1 = pinf_proof_ofh sg dlcm prl1
  3.1078 +   				    val pr2 = pinf_proof_ofh sg dlcm prl2
  3.1079 +				 in (combine_pinf_proof "EDJ" pr1 pr2)
  3.1080 +				 end
  3.1081 +				 
  3.1082 +   |Modd_minf_conjI (prl1,prl2) => let val pr1 = pinf_proof_ofh sg dlcm prl1
  3.1083 +   				    val pr2 = pinf_proof_ofh sg dlcm prl2
  3.1084 +				 in (combine_pinf_proof "MCJ" pr1 pr2)
  3.1085 +				 end
  3.1086 +				 
  3.1087 +   |Modd_minf_disjI (prl1,prl2) => let val pr1 = pinf_proof_ofh sg dlcm prl1
  3.1088 +   				    val pr2 = pinf_proof_ofh sg dlcm prl2
  3.1089 +				 in (combine_pinf_proof "MDJ" pr1 pr2)
  3.1090 +				 end;
  3.1091 +(* ------------------------------------------------------------------------- *)
  3.1092 +(* Main function For the rest both properies of P_{..} are needed and here both theorems are returned.*)				 
  3.1093 +(* ------------------------------------------------------------------------- *)
  3.1094 +fun pinf_proof_of sg dlcm (Minusinf (prl1,prl2))  = 
  3.1095 +  let val pr1 = pinf_proof_ofh sg dlcm prl1
  3.1096 +      val pr2 = pinf_proof_ofh sg dlcm prl2
  3.1097 +  in (pr1, pr2)
  3.1098 +end;
  3.1099 +				 
  3.1100 +
  3.1101 +
  3.1102 +
  3.1103 +(* ------------------------------------------------------------------------- *)
  3.1104 +(* Here we generate the theorem for the Bset Property in the simple direction*)
  3.1105 +(* It is just an instantiation*)
  3.1106 +(* ------------------------------------------------------------------------- *)
  3.1107 +fun bsetproof_of sg (Bset(x as Free(xn,xT),fm,bs,dlcm))   = 
  3.1108 +  let
  3.1109 +    val cp = cterm_of sg (absfree (xn,xT,(norm_zero_one fm)))
  3.1110 +    val cdlcm = cterm_of sg dlcm
  3.1111 +    val cB = cterm_of sg (list_to_set HOLogic.intT (map norm_zero_one bs))
  3.1112 +  in instantiate' [] [Some cdlcm,Some cB, Some cp] (bst_thm)
  3.1113 +    end;
  3.1114 +
  3.1115 +
  3.1116 +
  3.1117 +
  3.1118 +(* ------------------------------------------------------------------------- *)
  3.1119 +(* Here we generate the theorem for the Bset Property in the simple direction*)
  3.1120 +(* It is just an instantiation*)
  3.1121 +(* ------------------------------------------------------------------------- *)
  3.1122 +fun asetproof_of sg (Aset(x as Free(xn,xT),fm,ast,dlcm))   = 
  3.1123 +  let
  3.1124 +    val cp = cterm_of sg (absfree (xn,xT,(norm_zero_one fm)))
  3.1125 +    val cdlcm = cterm_of sg dlcm
  3.1126 +    val cA = cterm_of sg (list_to_set HOLogic.intT (map norm_zero_one ast))
  3.1127 +  in instantiate' [] [Some cdlcm,Some cA, Some cp] (ast_thm)
  3.1128 +end;
  3.1129 +
  3.1130 +
  3.1131 +
  3.1132 +
  3.1133 +(* ------------------------------------------------------------------------- *)    
  3.1134 +(* Protokol interpretation function for the backwards direction for cooper's Theorem*)
  3.1135 +
  3.1136 +(* For the generation of atomic Theorems*)
  3.1137 +(* Prove the premisses on runtime and then make RS*)
  3.1138 +(* ------------------------------------------------------------------------- *)
  3.1139 +fun generate_atomic_not_bst_p sg (x as Free(xn,xT)) fm dlcm B at = 
  3.1140 +  let
  3.1141 +    val cdlcm = cterm_of sg dlcm
  3.1142 +    val cB = cterm_of sg B
  3.1143 +    val cfma = cterm_of sg (absfree (xn,xT,(norm_zero_one fm)))
  3.1144 +    val cat = cterm_of sg (norm_zero_one at)
  3.1145 +  in
  3.1146 +  case at of 
  3.1147 +   (Const ("Not", _) $ (Const("op =",Type ("fun",[Type ("IntDef.int", []),_])) $ c1 $ (Const ("op +", _) $(Const ("op *",_) $ c2 $ y) $z))) => 
  3.1148 +      if  (x=y) andalso (c1=zero) andalso (c2=one) 
  3.1149 +	 then let val th1 = prove_elementar sg "ss" (Const ("op :",HOLogic.intT --> (HOLogic.mk_setT HOLogic.intT) --> HOLogic.boolT) $ (norm_zero_one (linear_cmul ~1 z)) $ B)
  3.1150 +	          val th2 =  prove_elementar sg "ss" (HOLogic.mk_eq ((norm_zero_one (linear_cmul ~1 z)),Const("uminus",HOLogic.intT --> HOLogic.intT) $(norm_zero_one  z)))
  3.1151 +		  val th3 = prove_elementar sg "ss" (HOLogic.mk_binrel "op <" (Const("0",HOLogic.intT),dlcm))
  3.1152 +	 in  (instantiate' [] [Some cfma]([th3,th1,th2] MRS (not_bst_p_ne)))
  3.1153 +	 end
  3.1154 +         else (instantiate' [] [Some cfma,  Some cdlcm, Some cB,Some cat] (not_bst_p_fm))
  3.1155 +
  3.1156 +   |(Const("op =",Type ("fun",[Type ("IntDef.int", []),_])) $ c1 $(Const ("op +", T) $(Const ("op *",_) $ c2 $ y) $z)) =>
  3.1157 +     if (is_arith_rel at) andalso (x=y)
  3.1158 +	then let val bst_z = norm_zero_one (linear_neg (linear_add [] z (mk_numeral 1)))
  3.1159 +	         in let val th1 = prove_elementar sg "ss" (Const ("op :",HOLogic.intT --> (HOLogic.mk_setT HOLogic.intT) --> HOLogic.boolT) $ bst_z $ B)
  3.1160 +	          val th2 =  prove_elementar sg "ss" (HOLogic.mk_eq (bst_z,Const("op -",T) $ (Const("uminus",HOLogic.intT --> HOLogic.intT) $(norm_zero_one z)) $ (Const("1",HOLogic.intT))))
  3.1161 +		  val th3 = prove_elementar sg "ss" (HOLogic.mk_binrel "op <" (Const("0",HOLogic.intT),dlcm))
  3.1162 +	 in  (instantiate' [] [Some cfma] ([th3,th1,th2] MRS (not_bst_p_eq)))
  3.1163 +	 end
  3.1164 +       end
  3.1165 +         else (instantiate' [] [Some cfma,  Some cdlcm, Some cB,Some cat] (not_bst_p_fm))
  3.1166 +
  3.1167 +   |(Const("op <",_) $ c1 $(Const ("op +", _) $(Const ("op *",_) $ pm1 $ y ) $ z )) =>
  3.1168 +        if (y=x) andalso (c1 =zero) then 
  3.1169 +        if pm1 = one then 
  3.1170 +	  let val th1 = prove_elementar sg "ss" (Const ("op :",HOLogic.intT --> (HOLogic.mk_setT HOLogic.intT) --> HOLogic.boolT) $ (norm_zero_one (linear_cmul ~1 z)) $ B)
  3.1171 +              val th2 =  prove_elementar sg "ss" (HOLogic.mk_eq ((norm_zero_one (linear_cmul ~1 z)),Const("uminus",HOLogic.intT --> HOLogic.intT) $(norm_zero_one z)))
  3.1172 +	  in  (instantiate' [] [Some cfma,  Some cdlcm]([th1,th2] MRS (not_bst_p_gt)))
  3.1173 +	    end
  3.1174 +	 else let val th1 = prove_elementar sg "ss" (HOLogic.mk_binrel "op <" (Const("0",HOLogic.intT),dlcm))
  3.1175 +	      in (instantiate' [] [Some cfma, Some cB,Some (cterm_of sg (norm_zero_one z))] (th1 RS (not_bst_p_lt)))
  3.1176 +	      end
  3.1177 +      else (instantiate' [] [Some cfma,  Some cdlcm, Some cB,Some cat] (not_bst_p_fm))
  3.1178 +
  3.1179 +   |Const ("Not",_) $ (Const("Divides.op dvd",_)$ d $ (Const ("op +",_) $ (Const ("op *",_) $ c $ y ) $ z)) => 
  3.1180 +      if y=x then  
  3.1181 +           let val cz = cterm_of sg (norm_zero_one z)
  3.1182 +	       val th1 = (prove_elementar sg "ss"  (HOLogic.mk_binrel "op =" (HOLogic.mk_binop "Divides.op mod" (dlcm,d),norm_zero_one zero))) RS (((zdvd_iff_zmod_eq_0)RS sym) RS iffD1)
  3.1183 + 	     in (instantiate' []  [Some cfma, Some cB,Some cz] (th1 RS (not_bst_p_ndvd)))
  3.1184 +	     end
  3.1185 +      else (instantiate' [] [Some cfma,  Some cdlcm, Some cB,Some cat] (not_bst_p_fm))
  3.1186 +
  3.1187 +   |(Const("Divides.op dvd",_)$ d $ (Const ("op +",_) $ (Const ("op *",_) $ c $ y ) $ z)) => 
  3.1188 +       if y=x then  
  3.1189 +	 let val cz = cterm_of sg (norm_zero_one z)
  3.1190 +	     val th1 = (prove_elementar sg "ss"  (HOLogic.mk_binrel "op =" (HOLogic.mk_binop "Divides.op mod" (dlcm,d),norm_zero_one zero))) RS (((zdvd_iff_zmod_eq_0)RS sym) RS iffD1)
  3.1191 + 	    in (instantiate' []  [Some cfma,Some cB,Some cz] (th1 RS (not_bst_p_dvd)))
  3.1192 +	  end
  3.1193 +      else (instantiate' [] [Some cfma,  Some cdlcm, Some cB,Some cat] (not_bst_p_fm))
  3.1194 +      		
  3.1195 +   |_ => (instantiate' [] [Some cfma,  Some cdlcm, Some cB,Some cat] (not_bst_p_fm))
  3.1196 +      		
  3.1197 +    end;
  3.1198 +    
  3.1199 +(* ------------------------------------------------------------------------- *)    
  3.1200 +(* Main interpretation function for this backwards dirction*)
  3.1201 +(* if atomic do generate atomis formulae else Construct theorems and then make RS with the construction theorems*)
  3.1202 +(*Help Function*)
  3.1203 +(* ------------------------------------------------------------------------- *)
  3.1204 +fun not_bst_p_proof_of_h sg x fm dlcm B prt = case prt of 
  3.1205 +	(Not_bst_p_atomic(fm2)) => (generate_atomic_not_bst_p sg x fm dlcm B fm2)
  3.1206 +	
  3.1207 +	|(Not_bst_p_conjI(pr1,pr2)) => 
  3.1208 +			let val th1 = (not_bst_p_proof_of_h sg x fm dlcm B pr1)
  3.1209 +			    val th2 = (not_bst_p_proof_of_h sg x fm dlcm B pr2)
  3.1210 +			    in ([th1,th2] MRS (not_bst_p_conjI))
  3.1211 +			    end
  3.1212 +
  3.1213 +	|(Not_bst_p_disjI(pr1,pr2)) => 
  3.1214 +			let val th1 = (not_bst_p_proof_of_h sg x fm dlcm B pr1)
  3.1215 +			    val th2 = (not_bst_p_proof_of_h sg x fm dlcm B pr2)
  3.1216 +			    in ([th1,th2] MRS not_bst_p_disjI)
  3.1217 +			    end;
  3.1218 +(* Main function*)
  3.1219 +fun not_bst_p_proof_of sg (Not_bst_p(x as Free(xn,xT),fm,dlcm,B,prl)) =
  3.1220 +  let val th =  not_bst_p_proof_of_h sg x fm dlcm B prl
  3.1221 +      val fma = absfree (xn,xT, norm_zero_one fm)
  3.1222 +  in let val th1 =  prove_elementar sg "ss"  (HOLogic.mk_eq (fma,fma))
  3.1223 +     in [th,th1] MRS (not_bst_p_Q_elim)
  3.1224 +     end
  3.1225 +  end;
  3.1226 +
  3.1227 +
  3.1228 +(* ------------------------------------------------------------------------- *)    
  3.1229 +(* Protokol interpretation function for the backwards direction for cooper's Theorem*)
  3.1230 +
  3.1231 +(* For the generation of atomic Theorems*)
  3.1232 +(* Prove the premisses on runtime and then make RS*)
  3.1233 +(* ------------------------------------------------------------------------- *)
  3.1234 +fun generate_atomic_not_ast_p sg (x as Free(xn,xT)) fm dlcm A at = 
  3.1235 +  let
  3.1236 +    val cdlcm = cterm_of sg dlcm
  3.1237 +    val cA = cterm_of sg A
  3.1238 +    val cfma = cterm_of sg (absfree (xn,xT,(norm_zero_one fm)))
  3.1239 +    val cat = cterm_of sg (norm_zero_one at)
  3.1240 +  in
  3.1241 +  case at of 
  3.1242 +   (Const ("Not", _) $ (Const("op =",Type ("fun",[Type ("IntDef.int", []),_])) $ c1 $ (Const ("op +", _) $(Const ("op *",_) $ c2 $ y) $z))) => 
  3.1243 +      if  (x=y) andalso (c1=zero) andalso (c2=one) 
  3.1244 +	 then let val th1 = prove_elementar sg "ss" (Const ("op :",HOLogic.intT --> (HOLogic.mk_setT HOLogic.intT) --> HOLogic.boolT) $ (norm_zero_one (linear_cmul ~1 z)) $ A)
  3.1245 +	          val th2 =  prove_elementar sg "ss" (HOLogic.mk_eq ((norm_zero_one (linear_cmul ~1 z)),Const("uminus",HOLogic.intT --> HOLogic.intT) $(norm_zero_one  z)))
  3.1246 +		  val th3 = prove_elementar sg "ss" (HOLogic.mk_binrel "op <" (Const("0",HOLogic.intT),dlcm))
  3.1247 +	 in  (instantiate' [] [Some cfma]([th3,th1,th2] MRS (not_ast_p_ne)))
  3.1248 +	 end
  3.1249 +         else (instantiate' [] [Some cfma,  Some cdlcm, Some cA,Some cat] (not_ast_p_fm))
  3.1250 +
  3.1251 +   |(Const("op =",Type ("fun",[Type ("IntDef.int", []),_])) $ c1 $(Const ("op +", T) $(Const ("op *",_) $ c2 $ y) $z)) =>
  3.1252 +     if (is_arith_rel at) andalso (x=y)
  3.1253 +	then let val ast_z = norm_zero_one (linear_sub [] one z )
  3.1254 +	         val th1 = prove_elementar sg "ss" (Const ("op :",HOLogic.intT --> (HOLogic.mk_setT HOLogic.intT) --> HOLogic.boolT) $ ast_z $ A)
  3.1255 +	         val th2 =  prove_elementar sg "ss" (HOLogic.mk_eq (ast_z,Const("op +",T) $ (Const("uminus",HOLogic.intT --> HOLogic.intT) $(norm_zero_one z)) $ (Const("1",HOLogic.intT))))
  3.1256 +		 val th3 = prove_elementar sg "ss" (HOLogic.mk_binrel "op <" (Const("0",HOLogic.intT),dlcm))
  3.1257 +	 in  (instantiate' [] [Some cfma] ([th3,th1,th2] MRS (not_ast_p_eq)))
  3.1258 +       end
  3.1259 +         else (instantiate' [] [Some cfma,  Some cdlcm, Some cA,Some cat] (not_ast_p_fm))
  3.1260 +
  3.1261 +   |(Const("op <",_) $ c1 $(Const ("op +", _) $(Const ("op *",_) $ pm1 $ y ) $ z )) =>
  3.1262 +        if (y=x) andalso (c1 =zero) then 
  3.1263 +        if pm1 = (mk_numeral ~1) then 
  3.1264 +	  let val th1 = prove_elementar sg "ss" (Const ("op :",HOLogic.intT --> (HOLogic.mk_setT HOLogic.intT) --> HOLogic.boolT) $ (norm_zero_one z) $ A)
  3.1265 +              val th2 =  prove_elementar sg "ss" (HOLogic.mk_binrel "op <" (zero,dlcm))
  3.1266 +	  in  (instantiate' [] [Some cfma]([th2,th1] MRS (not_ast_p_lt)))
  3.1267 +	    end
  3.1268 +	 else let val th1 = prove_elementar sg "ss" (HOLogic.mk_binrel "op <" (Const("0",HOLogic.intT),dlcm))
  3.1269 +	      in (instantiate' [] [Some cfma, Some cA,Some (cterm_of sg (norm_zero_one z))] (th1 RS (not_ast_p_gt)))
  3.1270 +	      end
  3.1271 +      else (instantiate' [] [Some cfma,  Some cdlcm, Some cA,Some cat] (not_ast_p_fm))
  3.1272 +
  3.1273 +   |Const ("Not",_) $ (Const("Divides.op dvd",_)$ d $ (Const ("op +",_) $ (Const ("op *",_) $ c $ y ) $ z)) => 
  3.1274 +      if y=x then  
  3.1275 +           let val cz = cterm_of sg (norm_zero_one z)
  3.1276 +	       val th1 = (prove_elementar sg "ss"  (HOLogic.mk_binrel "op =" (HOLogic.mk_binop "Divides.op mod" (dlcm,d),norm_zero_one zero))) RS (((zdvd_iff_zmod_eq_0)RS sym) RS iffD1)
  3.1277 + 	     in (instantiate' []  [Some cfma, Some cA,Some cz] (th1 RS (not_ast_p_ndvd)))
  3.1278 +	     end
  3.1279 +      else (instantiate' [] [Some cfma,  Some cdlcm, Some cA,Some cat] (not_ast_p_fm))
  3.1280 +
  3.1281 +   |(Const("Divides.op dvd",_)$ d $ (Const ("op +",_) $ (Const ("op *",_) $ c $ y ) $ z)) => 
  3.1282 +       if y=x then  
  3.1283 +	 let val cz = cterm_of sg (norm_zero_one z)
  3.1284 +	     val th1 = (prove_elementar sg "ss"  (HOLogic.mk_binrel "op =" (HOLogic.mk_binop "Divides.op mod" (dlcm,d),norm_zero_one zero))) RS (((zdvd_iff_zmod_eq_0)RS sym) RS iffD1)
  3.1285 + 	    in (instantiate' []  [Some cfma,Some cA,Some cz] (th1 RS (not_ast_p_dvd)))
  3.1286 +	  end
  3.1287 +      else (instantiate' [] [Some cfma,  Some cdlcm, Some cA,Some cat] (not_ast_p_fm))
  3.1288 +      		
  3.1289 +   |_ => (instantiate' [] [Some cfma,  Some cdlcm, Some cA,Some cat] (not_ast_p_fm))
  3.1290 +      		
  3.1291 +    end;
  3.1292 +    
  3.1293 +(* ------------------------------------------------------------------------- *)    
  3.1294 +(* Main interpretation function for this backwards dirction*)
  3.1295 +(* if atomic do generate atomis formulae else Construct theorems and then make RS with the construction theorems*)
  3.1296 +(*Help Function*)
  3.1297 +(* ------------------------------------------------------------------------- *)
  3.1298 +fun not_ast_p_proof_of_h sg x fm dlcm A prt = case prt of 
  3.1299 +	(Not_ast_p_atomic(fm2)) => (generate_atomic_not_ast_p sg x fm dlcm A fm2)
  3.1300 +	
  3.1301 +	|(Not_ast_p_conjI(pr1,pr2)) => 
  3.1302 +			let val th1 = (not_ast_p_proof_of_h sg x fm dlcm A pr1)
  3.1303 +			    val th2 = (not_ast_p_proof_of_h sg x fm dlcm A pr2)
  3.1304 +			    in ([th1,th2] MRS (not_ast_p_conjI))
  3.1305 +			    end
  3.1306 +
  3.1307 +	|(Not_ast_p_disjI(pr1,pr2)) => 
  3.1308 +			let val th1 = (not_ast_p_proof_of_h sg x fm dlcm A pr1)
  3.1309 +			    val th2 = (not_ast_p_proof_of_h sg x fm dlcm A pr2)
  3.1310 +			    in ([th1,th2] MRS (not_ast_p_disjI))
  3.1311 +			    end;
  3.1312 +(* Main function*)
  3.1313 +fun not_ast_p_proof_of sg (Not_ast_p(x as Free(xn,xT),fm,dlcm,A,prl)) =
  3.1314 +  let val th =  not_ast_p_proof_of_h sg x fm dlcm A prl
  3.1315 +      val fma = absfree (xn,xT, norm_zero_one fm)
  3.1316 +      val th1 =  prove_elementar sg "ss"  (HOLogic.mk_eq (fma,fma))
  3.1317 +  in [th,th1] MRS (not_ast_p_Q_elim)
  3.1318 +end;
  3.1319 +
  3.1320 +
  3.1321 +
  3.1322 +
  3.1323 +(* ------------------------------------------------------------------------- *)
  3.1324 +(* Interpretaion of Protocols of the cooper procedure : minusinfinity version*)
  3.1325 +(* ------------------------------------------------------------------------- *)
  3.1326 +
  3.1327 +
  3.1328 +fun coopermi_proof_of sg x (Cooper (dlcm,Simp(fm,miprt),bsprt,nbst_p_prt)) =
  3.1329 +  (* Get the Bset thm*)
  3.1330 +  let val bst = bsetproof_of sg bsprt
  3.1331 +      val (mit1,mit2) = minf_proof_of sg dlcm miprt
  3.1332 +      val fm1 = norm_zero_one (simpl fm) 
  3.1333 +      val dpos = prove_elementar sg "ss" (HOLogic.mk_binrel "op <" (zero,dlcm));
  3.1334 +      val nbstpthm = not_bst_p_proof_of sg nbst_p_prt
  3.1335 +    (* Return the four theorems needed to proove the whole Cooper Theorem*)
  3.1336 +  in (dpos,mit2,bst,nbstpthm,mit1)
  3.1337 +end;
  3.1338 +
  3.1339 +
  3.1340 +(* ------------------------------------------------------------------------- *)
  3.1341 +(* Interpretaion of Protocols of the cooper procedure : plusinfinity version *)
  3.1342 +(* ------------------------------------------------------------------------- *)
  3.1343 +
  3.1344 +
  3.1345 +fun cooperpi_proof_of sg x (Cooper (dlcm,Simp(fm,miprt),bsprt,nast_p_prt)) =
  3.1346 +  let val ast = asetproof_of sg bsprt
  3.1347 +      val (mit1,mit2) = pinf_proof_of sg dlcm miprt
  3.1348 +      val fm1 = norm_zero_one (simpl fm) 
  3.1349 +      val dpos = prove_elementar sg "ss" (HOLogic.mk_binrel "op <" (zero,dlcm));
  3.1350 +      val nastpthm = not_ast_p_proof_of sg nast_p_prt
  3.1351 +  in (dpos,mit2,ast,nastpthm,mit1)
  3.1352 +end;
  3.1353 +
  3.1354 +
  3.1355 +(* ------------------------------------------------------------------------- *)
  3.1356 +(* Interpretaion of Protocols of the cooper procedure : full version*)
  3.1357 +(* ------------------------------------------------------------------------- *)
  3.1358 +
  3.1359 +
  3.1360 +
  3.1361 +fun cooper_thm sg s (x as Free(xn,xT)) vars cfm = case s of
  3.1362 +  "pi" => let val (rs,prt) = cooperpi_wp (xn::vars) (HOLogic.mk_exists(xn,xT,cfm))
  3.1363 +	      val (dpsthm,th1,th2,nbpth,th3) = cooperpi_proof_of sg x prt
  3.1364 +		   in [dpsthm,th1,th2,nbpth,th3] MRS (cppi_eq)
  3.1365 +           end
  3.1366 +  |"mi" => let val (rs,prt) = coopermi_wp (xn::vars) (HOLogic.mk_exists(xn,xT,cfm))
  3.1367 +	       val (dpsthm,th1,th2,nbpth,th3) = coopermi_proof_of sg x prt
  3.1368 +		   in [dpsthm,th1,th2,nbpth,th3] MRS (cpmi_eq)
  3.1369 +                end
  3.1370 + |_ => error "parameter error";
  3.1371 +
  3.1372 +(* ------------------------------------------------------------------------- *)
  3.1373 +(* This function should evoluate to the end prove Procedure for one quantifier elimination for Presburger arithmetic*)
  3.1374 +(* It shoud be plugged in the qfnp argument of the quantifier elimination proof function*)
  3.1375 +(* ------------------------------------------------------------------------- *)
  3.1376 +
  3.1377 +fun cooper_prv sg (x as Free(xn,xT)) efm vars = let 
  3.1378 +   val l = formlcm x efm
  3.1379 +   val ac_thm = proof_of_adjustcoeffeq sg (adjustcoeffeq_wp  x l efm)
  3.1380 +   val fm = snd (qe_get_terms ac_thm)
  3.1381 +   val  cfm = unitycoeff x fm
  3.1382 +   val afm = adjustcoeff x l fm
  3.1383 +   val P = absfree(xn,xT,afm)
  3.1384 +   val ss = presburger_ss addsimps
  3.1385 +     [simp_from_to] delsimps [P_eqtrue, P_eqfalse, bex_triv, insert_iff]
  3.1386 +   val uth = instantiate' [] [Some (cterm_of sg P) , Some (cterm_of sg (mk_numeral l))] (unity_coeff_ex)
  3.1387 +   val e_ac_thm = (forall_intr (cterm_of sg x) ac_thm) COMP (qe_exI)
  3.1388 +   val cms = if ((length (aset x cfm)) < (length (bset x cfm))) then "pi" else "mi"
  3.1389 +   val cp_thm = cooper_thm sg cms x vars cfm
  3.1390 +   val exp_cp_thm = refl RS (simplify ss (cp_thm RSN (2,trans)))
  3.1391 +   val (lsuth,rsuth) = qe_get_terms (uth)
  3.1392 +   val (lseacth,rseacth) = qe_get_terms(e_ac_thm)
  3.1393 +   val (lscth,rscth) = qe_get_terms (exp_cp_thm)
  3.1394 +   val  u_c_thm = [([uth,prove_elementar sg "ss" (HOLogic.mk_eq (rsuth,lscth))] MRS trans),exp_cp_thm] MRS trans
  3.1395 + in  ([e_ac_thm,[(prove_elementar sg "ss" (HOLogic.mk_eq (rseacth,lsuth))),u_c_thm] MRS trans] MRS trans)
  3.1396 +   end
  3.1397 +|cooper_prv _ _ _ _ = error "Parameters format";
  3.1398 +
  3.1399 +
  3.1400 +(*====================================================*)
  3.1401 +(*Interpretation function for the evaluation protokol *)
  3.1402 +(*====================================================*)
  3.1403 +
  3.1404 +fun proof_of_evalc sg fm =
  3.1405 +let
  3.1406 +fun proof_of_evalch prt = case prt of
  3.1407 +  EvalAt(at) => prove_elementar sg "ss" at
  3.1408 + |Evalfm(fm) => instantiate' [Some cboolT] [Some (cterm_of sg fm)] refl
  3.1409 + |EvalConst(s,pr1,pr2) => 
  3.1410 +   let val th1 = proof_of_evalch pr1
  3.1411 +       val th2 = proof_of_evalch pr2
  3.1412 +   in case s of
  3.1413 +     "CJ" =>[th1,th2] MRS (qe_conjI)
  3.1414 +    |"DJ" =>[th1,th2] MRS (qe_disjI)
  3.1415 +    |"IM" =>[th1,th2] MRS (qe_impI)
  3.1416 +    |"EQ" =>[th1,th2] MRS (qe_eqI)
  3.1417 +    end
  3.1418 +in proof_of_evalch (evalc_wp fm)
  3.1419 +end;
  3.1420 +
  3.1421 +(*============================================================*)
  3.1422 +(*Interpretation function for the NNF-Transformation protokol *)
  3.1423 +(*============================================================*)
  3.1424 +
  3.1425 +fun proof_of_cnnf sg fm pf = 
  3.1426 +let fun proof_of_cnnfh prt pat = case prt of
  3.1427 +  NNFAt(at) => pat at
  3.1428 + |NNFSimp (pr) => let val th1 = proof_of_cnnfh pr pat
  3.1429 +                  in let val fm2 = snd (qe_get_terms th1) 
  3.1430 +		     in [th1,prove_elementar sg "ss" (HOLogic.mk_eq(fm2 ,simpl fm2))] MRS trans
  3.1431 +                     end
  3.1432 +                  end
  3.1433 + |NNFNN (pr) => (proof_of_cnnfh pr pat) RS (nnf_nn)
  3.1434 + |NNFConst (s,pr1,pr2) =>
  3.1435 +   let val th1 = proof_of_cnnfh pr1 pat
  3.1436 +       val th2 = proof_of_cnnfh pr2 pat
  3.1437 +   in case s of
  3.1438 +     "CJ" => [th1,th2] MRS (qe_conjI)
  3.1439 +    |"DJ" => [th1,th2] MRS (qe_disjI)
  3.1440 +    |"IM" => [th1,th2] MRS (nnf_im)
  3.1441 +    |"EQ" => [th1,th2] MRS (nnf_eq)
  3.1442 +    |"SDJ" => let val (Const("op &",_)$A$_) = fst (qe_get_terms th1)
  3.1443 +	          val (Const("op &",_)$C$_) = fst (qe_get_terms th2)
  3.1444 +	      in [th1,th2,prove_elementar sg "ss" (HOLogic.mk_eq (A,HOLogic.Not $ C))] MRS (nnf_sdj)
  3.1445 +	      end
  3.1446 +    |"NCJ" => [th1,th2] MRS (nnf_ncj)
  3.1447 +    |"NIM" => [th1,th2] MRS (nnf_nim)
  3.1448 +    |"NEQ" => [th1,th2] MRS (nnf_neq)
  3.1449 +    |"NDJ" => [th1,th2] MRS (nnf_ndj)
  3.1450 +   end
  3.1451 +in proof_of_cnnfh (cnnf_wp fm) pf
  3.1452 +end;
  3.1453 +
  3.1454 +
  3.1455 +
  3.1456 +
  3.1457 +(*====================================================*)
  3.1458 +(* Interpretation function for the linform protokol   *)
  3.1459 +(*====================================================*)
  3.1460 +
  3.1461 +
  3.1462 +fun proof_of_linform sg vars f = 
  3.1463 +  let fun proof_of_linformh prt = 
  3.1464 +  case prt of
  3.1465 +    (LfAt (at)) =>  prove_elementar sg "lf" (HOLogic.mk_eq (at, linform vars at))
  3.1466 +   |(LfAtdvd (Const("Divides.op dvd",_)$d$t)) => (prove_elementar sg "lf" (HOLogic.mk_eq (t, lint vars t))) RS (instantiate' [] [None , None, Some (cterm_of sg d)](linearize_dvd))
  3.1467 +   |(Lffm (fm)) => (instantiate' [Some cboolT] [Some (cterm_of sg fm)] refl)
  3.1468 +   |(LfConst (s,pr1,pr2)) =>
  3.1469 +     let val th1 = proof_of_linformh pr1
  3.1470 +	 val th2 = proof_of_linformh pr2
  3.1471 +     in case s of
  3.1472 +       "CJ" => [th1,th2] MRS (qe_conjI)
  3.1473 +      |"DJ" =>[th1,th2] MRS (qe_disjI)
  3.1474 +      |"IM" =>[th1,th2] MRS (qe_impI)
  3.1475 +      |"EQ" =>[th1,th2] MRS (qe_eqI)
  3.1476 +     end
  3.1477 +   |(LfNot(pr)) => 
  3.1478 +     let val th = proof_of_linformh pr
  3.1479 +     in (th RS (qe_Not))
  3.1480 +     end
  3.1481 +   |(LfQ(s,xn,xT,pr)) => 
  3.1482 +     let val th = forall_intr (cterm_of sg (Free(xn,xT)))(proof_of_linformh pr)
  3.1483 +     in if s = "Ex" 
  3.1484 +        then (th COMP(qe_exI) )
  3.1485 +        else (th COMP(qe_ALLI) )
  3.1486 +     end
  3.1487 +in
  3.1488 + proof_of_linformh (linform_wp f)
  3.1489 +end;
  3.1490 +
  3.1491 +end;
     4.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     4.2 +++ b/src/HOL/Integ/presburger.ML	Tue Mar 25 09:47:05 2003 +0100
     4.3 @@ -0,0 +1,231 @@
     4.4 +(*  Title:      HOL/Integ/presburger.ML
     4.5 +    ID:         $Id$
     4.6 +    Author:     Amine Chaieb and Stefan Berghofer, TU Muenchen
     4.7 +    License:    GPL (GNU GENERAL PUBLIC LICENSE)
     4.8 +
     4.9 +Tactic for solving arithmetical Goals in Presburger Arithmetic
    4.10 +*)
    4.11 +
    4.12 +signature PRESBURGER = 
    4.13 +sig
    4.14 + val presburger_tac : bool -> int -> tactic
    4.15 + val presburger_method : bool -> int -> Proof.method
    4.16 + val setup : (theory -> theory) list
    4.17 + val trace : bool ref
    4.18 +end;
    4.19 +
    4.20 +structure Presburger: PRESBURGER =
    4.21 +struct
    4.22 +
    4.23 +val trace = ref false;
    4.24 +fun trace_msg s = if !trace then tracing s else ();
    4.25 +
    4.26 +(*-----------------------------------------------------------------*)
    4.27 +(*cooper_pp: provefunction for the one-exstance quantifier elimination*)
    4.28 +(* Here still only one problem : The proof for the arithmetical transformations done on the dvd atomic formulae*)
    4.29 +(*-----------------------------------------------------------------*)
    4.30 +
    4.31 +val presburger_ss = simpset_of (theory "Presburger");
    4.32 +
    4.33 +fun cooper_pp sg vrl (fm as e$Abs(xn,xT,p)) = 
    4.34 +  let val (xn1,p1) = variant_abs (xn,xT,p)
    4.35 +  in (CooperProof.cooper_prv sg (Free (xn1, xT)) p1 vrl) end;
    4.36 +
    4.37 +fun mnnf_pp sg fm = CooperProof.proof_of_cnnf sg fm
    4.38 +  (CooperProof.proof_of_evalc sg);
    4.39 +
    4.40 +fun mproof_of_int_qelim sg fm =
    4.41 +  Qelim.proof_of_mlift_qelim sg CooperDec.is_arith_rel
    4.42 +    (CooperProof.proof_of_linform sg) (mnnf_pp sg) (cooper_pp sg) fm;
    4.43 +
    4.44 +(* Theorems to be used in this tactic*)
    4.45 +
    4.46 +val zdvd_int = thm "zdvd_int";
    4.47 +val zdiff_int_split = thm "zdiff_int_split";
    4.48 +val all_nat = thm "all_nat";
    4.49 +val ex_nat = thm "ex_nat";
    4.50 +val number_of1 = thm "number_of1";
    4.51 +val number_of2 = thm "number_of2";
    4.52 +val split_zdiv = thm "split_zdiv";
    4.53 +val split_zmod = thm "split_zmod";
    4.54 +val mod_div_equality' = thm "mod_div_equality'";
    4.55 +val split_div' = thm "split_div'";
    4.56 +val Suc_plus1 = thm "Suc_plus1";
    4.57 +val imp_le_cong = thm "imp_le_cong";
    4.58 +val conj_le_cong = thm "conj_le_cong";
    4.59 +
    4.60 +(* extract all the constants in a term*)
    4.61 +fun add_term_typed_consts (Const (c, T), cs) = (c,T) ins cs
    4.62 +  | add_term_typed_consts (t $ u, cs) =
    4.63 +      add_term_typed_consts (t, add_term_typed_consts (u, cs))
    4.64 +  | add_term_typed_consts (Abs (_, _, t), cs) = add_term_typed_consts (t, cs)
    4.65 +  | add_term_typed_consts (_, cs) = cs;
    4.66 +
    4.67 +fun term_typed_consts t = add_term_typed_consts(t,[]);
    4.68 +
    4.69 +(* put a term into eta long beta normal form *)
    4.70 +fun eta_long Ts (Abs (s, T, t)) = Abs (s, T, eta_long (T :: Ts) t)
    4.71 +  | eta_long Ts t = (case strip_comb t of
    4.72 +      (Abs _, _) => eta_long Ts (Envir.beta_norm t)
    4.73 +    | (u, ts) => 
    4.74 +      let val Us = binder_types (fastype_of1 (Ts, t))
    4.75 +      in list_abs (map (pair "x") Us, Unify.combound
    4.76 +        (list_comb (u, map (eta_long Ts) ts), 0, length Us))
    4.77 +      end);
    4.78 +
    4.79 +(* Some Types*)
    4.80 +val bT = HOLogic.boolT;
    4.81 +val iT = HOLogic.intT;
    4.82 +val binT = HOLogic.binT;
    4.83 +val nT = HOLogic.natT;
    4.84 +
    4.85 +(* Allowed Consts in formulae for presburger tactic*)
    4.86 +
    4.87 +val allowed_consts =
    4.88 +  [("All", (iT --> bT) --> bT),
    4.89 +   ("Ex", (iT --> bT) --> bT),
    4.90 +   ("All", (nT --> bT) --> bT),
    4.91 +   ("Ex", (nT --> bT) --> bT),
    4.92 +
    4.93 +   ("op &", bT --> bT --> bT),
    4.94 +   ("op |", bT --> bT --> bT),
    4.95 +   ("op -->", bT --> bT --> bT),
    4.96 +   ("op =", bT --> bT --> bT),
    4.97 +   ("Not", bT --> bT),
    4.98 +
    4.99 +   ("op <=", iT --> iT --> bT),
   4.100 +   ("op =", iT --> iT --> bT),
   4.101 +   ("op <", iT --> iT --> bT),
   4.102 +   ("Divides.op dvd", iT --> iT --> bT),
   4.103 +   ("Divides.op div", iT --> iT --> iT),
   4.104 +   ("Divides.op mod", iT --> iT --> iT),
   4.105 +   ("op +", iT --> iT --> iT),
   4.106 +   ("op -", iT --> iT --> iT),
   4.107 +   ("op *", iT --> iT --> iT), 
   4.108 +   ("HOL.abs", iT --> iT),
   4.109 +   ("uminus", iT --> iT),
   4.110 +
   4.111 +   ("op <=", nT --> nT --> bT),
   4.112 +   ("op =", nT --> nT --> bT),
   4.113 +   ("op <", nT --> nT --> bT),
   4.114 +   ("Divides.op dvd", nT --> nT --> bT),
   4.115 +   ("Divides.op div", nT --> nT --> nT),
   4.116 +   ("Divides.op mod", nT --> nT --> nT),
   4.117 +   ("op +", nT --> nT --> nT),
   4.118 +   ("op -", nT --> nT --> nT),
   4.119 +   ("op *", nT --> nT --> nT), 
   4.120 +   ("Suc", nT --> nT),
   4.121 +
   4.122 +   ("Numeral.bin.Bit", binT --> bT --> binT),
   4.123 +   ("Numeral.bin.Pls", binT),
   4.124 +   ("Numeral.bin.Min", binT),
   4.125 +   ("Numeral.number_of", binT --> iT),
   4.126 +   ("Numeral.number_of", binT --> nT),
   4.127 +   ("0", nT),
   4.128 +   ("0", iT),
   4.129 +   ("1", nT),
   4.130 +   ("1", iT),
   4.131 +
   4.132 +   ("False", bT),
   4.133 +   ("True", bT)];
   4.134 +
   4.135 +(*returns true if the formula is relevant for presburger arithmetic tactic*)
   4.136 +fun relevant t = (term_typed_consts t) subset allowed_consts;
   4.137 +
   4.138 +(* Preparation of the formula to be sent to the Integer quantifier *)
   4.139 +(* elimination procedure                                           *)
   4.140 +(* Transforms meta implications and meta quantifiers to object     *)
   4.141 +(* implications and object quantifiers                             *)
   4.142 +
   4.143 +fun prepare_for_presburger q fm = 
   4.144 +  let
   4.145 +    val ps = Logic.strip_params fm
   4.146 +    val hs = map HOLogic.dest_Trueprop (Logic.strip_assums_hyp fm)
   4.147 +    val c = HOLogic.dest_Trueprop (Logic.strip_assums_concl fm)
   4.148 +    val _ = if relevant c then () else raise CooperDec.COOPER
   4.149 +    fun mk_all ((s, T), (P,n)) =
   4.150 +      if 0 mem loose_bnos P then
   4.151 +        (HOLogic.all_const T $ Abs (s, T, P), n)
   4.152 +      else (incr_boundvars ~1 P, n-1)
   4.153 +    fun mk_all2 (v, t) = HOLogic.all_const (fastype_of v) $ lambda v t;
   4.154 +    val (rhs,irhs) = partition relevant hs
   4.155 +    val np = length ps
   4.156 +    val (fm',np) =  foldr (fn ((x, T), (fm,n)) => mk_all ((x, T), (fm,n)))
   4.157 +      (ps,(foldr HOLogic.mk_imp (rhs, c), np))
   4.158 +    val (vs, _) = partition (fn t => q orelse (type_of t) = nT)
   4.159 +      (term_frees fm' @ term_vars fm');
   4.160 +    val fm2 = foldr mk_all2 (vs, fm')
   4.161 +  in (fm2, np + length vs, length rhs) end;
   4.162 +
   4.163 +(*Object quantifier to meta --*)
   4.164 +fun spec_step n th = if (n=0) then th else (spec_step (n-1) th) RS spec ;
   4.165 +
   4.166 +(* object implication to meta---*)
   4.167 +fun mp_step n th = if (n=0) then th else (mp_step (n-1) th) RS mp;
   4.168 +
   4.169 +(* the presburger tactic*)
   4.170 +fun presburger_tac q i st =
   4.171 +  let
   4.172 +    val g = BasisLibrary.List.nth (prems_of st, i - 1);
   4.173 +    val sg = sign_of_thm st;
   4.174 +    (* Transform the term*)
   4.175 +    val (t,np,nh) = prepare_for_presburger q g
   4.176 +    (* Some simpsets for dealing with mod div abs and nat*)
   4.177 +
   4.178 +    val simpset0 = HOL_basic_ss
   4.179 +      addsimps [mod_div_equality', Suc_plus1]
   4.180 +      addsplits [split_zdiv, split_zmod, split_div']
   4.181 +    (* Simp rules for changing (n::int) to int n *)
   4.182 +    val simpset1 = HOL_basic_ss
   4.183 +      addsimps [nat_number_of_def, zdvd_int] @ map (fn r => r RS sym)
   4.184 +        [int_int_eq, zle_int, zless_int, zadd_int, zmult_int]
   4.185 +      addsplits [zdiff_int_split]
   4.186 +    (*simp rules for elimination of int n*)
   4.187 +
   4.188 +    val simpset2 = HOL_basic_ss
   4.189 +      addsimps [nat_0_le, all_nat, ex_nat, number_of1, number_of2, int_0, int_1]
   4.190 +      addcongs [conj_le_cong, imp_le_cong]
   4.191 +    (* simp rules for elimination of abs *)
   4.192 +
   4.193 +    val simpset3 = HOL_basic_ss addsplits [zabs_split]
   4.194 +	      
   4.195 +    val ct = cterm_of sg (HOLogic.mk_Trueprop t)
   4.196 +
   4.197 +    (* Theorem for the nat --> int transformation *)
   4.198 +    val pre_thm = Seq.hd (EVERY
   4.199 +      [simp_tac simpset0 i,
   4.200 +       TRY (simp_tac simpset1 i), TRY (simp_tac simpset2 i),
   4.201 +       TRY (simp_tac simpset3 i), TRY (simp_tac presburger_ss i)]
   4.202 +      (trivial ct))
   4.203 +
   4.204 +    fun assm_tac i = REPEAT_DETERM_N nh (assume_tac i);
   4.205 +
   4.206 +    (* The result of the quantifier elimination *)
   4.207 +    val (th, tac) = case (prop_of pre_thm) of
   4.208 +        Const ("==>", _) $ (Const ("Trueprop", _) $ t1) $ _ =>
   4.209 +          (trace_msg ("calling procedure with term:\n" ^
   4.210 +             Sign.string_of_term sg t1);
   4.211 +           ((mproof_of_int_qelim sg (eta_long [] t1) RS iffD2) RS pre_thm,
   4.212 +            assm_tac (i + 1) THEN (if q then I else TRY) (rtac TrueI i)))
   4.213 +      | _ => (pre_thm, assm_tac i)
   4.214 +  in (rtac (((mp_step nh) o (spec_step np)) th) i THEN tac) st
   4.215 +  end handle Subscript => no_tac st | CooperDec.COOPER => no_tac st;
   4.216 +
   4.217 +fun presburger_args meth =
   4.218 +  Method.simple_args (Scan.optional (Args.$$$ "no_quantify" >> K false) true)
   4.219 +    (fn q => fn _ => meth q 1);
   4.220 +
   4.221 +fun presburger_method q i = Method.METHOD (fn facts =>
   4.222 +  Method.insert_tac facts 1 THEN presburger_tac q i)
   4.223 +
   4.224 +val setup =
   4.225 +  [Method.add_method ("presburger",
   4.226 +     presburger_args presburger_method,
   4.227 +     "decision procedure for Presburger arithmetic"),
   4.228 +   ArithTheoryData.map (fn {splits, inj_consts, discrete, presburger} =>
   4.229 +     {splits = splits, inj_consts = inj_consts, discrete = discrete,
   4.230 +      presburger = Some (presburger_tac true)})];
   4.231 +
   4.232 +end;
   4.233 +
   4.234 +val presburger_tac = Presburger.presburger_tac true;
     5.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     5.2 +++ b/src/HOL/Integ/qelim.ML	Tue Mar 25 09:47:05 2003 +0100
     5.3 @@ -0,0 +1,176 @@
     5.4 +(*  Title:      HOL/Integ/qelim.ML
     5.5 +    ID:         $Id$
     5.6 +    Author:     Amine Chaieb and Tobias Nipkow, TU Muenchen
     5.7 +    License:    GPL (GNU GENERAL PUBLIC LICENSE)
     5.8 +
     5.9 +File containing the implementation of the proof protocoling
    5.10 +and proof generation for multiple quantified formulae.
    5.11 +*)
    5.12 +
    5.13 +signature QELIM =
    5.14 +sig
    5.15 + val proof_of_mlift_qelim: Sign.sg -> (term -> bool) ->
    5.16 +   (string list -> term -> thm) -> (term -> thm) ->
    5.17 +   (string list -> term -> thm) -> term -> thm
    5.18 +end;
    5.19 +
    5.20 +structure Qelim : QELIM =
    5.21 +struct
    5.22 +open CooperDec;
    5.23 +open CooperProof;
    5.24 +
    5.25 +(*-----------------------------------------------------------------*)
    5.26 +(*-----------------------------------------------------------------*)
    5.27 +(*-----------------------------------------------------------------*)
    5.28 +(*---                                                           ---*)
    5.29 +(*---                                                           ---*)
    5.30 +(*---         Protocoling part                                  ---*)
    5.31 +(*---                                                           ---*)
    5.32 +(*---           includes the protocolling datastructure         ---*)
    5.33 +(*---                                                           ---*)
    5.34 +(*---          and the protocolling fuctions                    ---*)
    5.35 +(*---                                                           ---*)
    5.36 +(*---                                                           ---*)
    5.37 +(*---                                                           ---*)
    5.38 +(*-----------------------------------------------------------------*)
    5.39 +(*-----------------------------------------------------------------*)
    5.40 +(*-----------------------------------------------------------------*)
    5.41 +
    5.42 +
    5.43 +val cboolT = ctyp_of (sign_of HOL.thy) HOLogic.boolT;
    5.44 +
    5.45 +(* List of the theorems to be used in the following*)
    5.46 +
    5.47 +val qe_ex_conj = thm "qe_ex_conj";
    5.48 +val qe_ex_nconj = thm "qe_ex_nconj";
    5.49 +val qe_ALL = thm "qe_ALL";
    5.50 +
    5.51 +
    5.52 +(*Datatype declaration for the protocoling procedure.*)
    5.53 +
    5.54 +
    5.55 +datatype QeLog = AFN of term*(string list)
    5.56 +                |QFN of term*(string list)
    5.57 +                |ExConj of term*QeLog
    5.58 +                |ExDisj of (string*typ*term)*term*QeLog*QeLog
    5.59 +                |QeConst of string*QeLog*QeLog
    5.60 +                |QeNot of QeLog
    5.61 +                |QeAll of QeLog
    5.62 +                |Lift_Qelim of term*QeLog
    5.63 +		|QeUnk of term;
    5.64 +
    5.65 +datatype mQeLog = mQeProof of (string list)*mQeLog
    5.66 +		|mAFN of term
    5.67 +                |mNFN of mQeLog
    5.68 +                |mQeConst of string*mQeLog*mQeLog
    5.69 +                |mQeNot of mQeLog
    5.70 +		|mQelim of term*(string list)*mQeLog
    5.71 +		|mQeAll of mQeLog
    5.72 +		|mQefm of term;
    5.73 +
    5.74 +(* This is the protokoling my function for the quantifier elimination*)
    5.75 +fun mlift_qelim_wp isat vars = 
    5.76 +  let fun mqelift_wp vars fm = if (isat fm) then mAFN(fm)
    5.77 +    else  
    5.78 +    (case fm of 
    5.79 +     ( Const ("Not",_) $ p) => mQeNot(mqelift_wp vars p)
    5.80 +    |( Const ("op &",_) $ p $q) => mQeConst("CJ", mqelift_wp vars p,mqelift_wp vars q) 
    5.81 +
    5.82 +    |( Const ("op |",_) $ p $q) => mQeConst("DJ", mqelift_wp vars p,mqelift_wp vars q) 
    5.83 +
    5.84 +    |( Const ("op -->",_) $ p $q) => mQeConst("IM", mqelift_wp vars p,mqelift_wp vars q) 
    5.85 +
    5.86 +    |( Const ("op =",Type ("fun",[Type ("bool", []),_])) $ p $q) =>mQeConst("EQ", mqelift_wp vars p,mqelift_wp vars q) 
    5.87 +
    5.88 +    				
    5.89 +    |( Const ("All",QT) $ Abs(x,T,p)) =>mQeAll (mqelift_wp vars (Const("Ex",QT) $ Abs(x,T,(HOLogic.Not $ p))))
    5.90 +
    5.91 +    |(Const ("Ex",_) $ Abs (x,T,p))  => 
    5.92 +      let val (x1,p1) = variant_abs (x,T,p)
    5.93 +          val prt = mqelift_wp (x1::vars) p1
    5.94 +      in mQelim(Free(x1,T),vars,mNFN(prt))
    5.95 +      end
    5.96 +    | _ => mQefm(fm)
    5.97 +   ) 
    5.98 +     
    5.99 +  in (fn fm => mQeProof(vars,mNFN(mqelift_wp vars fm )))
   5.100 +  end;  
   5.101 +
   5.102 +
   5.103 +
   5.104 +
   5.105 +(*-----------------------------------------------------------------*)
   5.106 +(*-----------------------------------------------------------------*)
   5.107 +(*-----------------------------------------------------------------*)
   5.108 +(*---                                                           ---*)
   5.109 +(*---                                                           ---*)
   5.110 +(*---      Interpretation and Proofgeneration Part              ---*)
   5.111 +(*---                                                           ---*)
   5.112 +(*---      Protocole interpretation functions                   ---*)
   5.113 +(*---                                                           ---*)
   5.114 +(*---      and proofgeneration functions                        ---*)
   5.115 +(*---                                                           ---*)
   5.116 +(*---                                                           ---*)
   5.117 +(*---                                                           ---*)
   5.118 +(*---                                                           ---*)
   5.119 +(*-----------------------------------------------------------------*)
   5.120 +(*-----------------------------------------------------------------*)
   5.121 +(*-----------------------------------------------------------------*)
   5.122 +
   5.123 +(*-----------------------------------------------------------------*)
   5.124 +(*-----------------------------------------------------------------*)
   5.125 +(*function that interpretates the protokol generated by the _wp function*)
   5.126 +
   5.127 +
   5.128 +(* proof_of_lift_qelim interpretates a protokol for the quantifier elimination one some quantified formula. It uses the functions afnp nfnp and qfnp as proof functions to generate a prove for the hole quantifier elimination.*)
   5.129 +(* afnp : must retun a proof for the transformations on the atomic formalae*)
   5.130 +(* nfnp : must return a proof for the post one-quatifiers elimination process*)
   5.131 +(* qfnp mus return a proof for the one quantifier elimination (existential) *)
   5.132 +(* All these function are independent of the theory on whitch we are trying to prove quantifier elimination*)
   5.133 +(* But the following invariants mus be respected : *)
   5.134 +(* afnp : term -> string list -> thm*)
   5.135 +(*   nfnp : term -> thm*)
   5.136 +(*   qfnp : term -> string list -> thm*)
   5.137 +(*For all theorms generated by these function must hold :*)
   5.138 +(*    All of them are logical equivalences.*)
   5.139 +(*    on left side of the equivalence must appear the term exactely as ist was given as a parameter (or eventually modulo Gamma, where Gamma are the rules whitch are allowed to be used during unification ex. beta reduction.....)*)
   5.140 +(* qfnp must take as an argument for the term an existential quantified formula*)
   5.141 +(*-----------------------------------------------------------------*)
   5.142 +(*-----------------------------------------------------------------*)
   5.143 +
   5.144 +fun proof_of_mlift_qelim sg isat afnp nfnp qfnp =
   5.145 + let fun h_proof_of_mlift_qelim isat afnp nfnp qfnp prtkl vrl = 
   5.146 +   (case prtkl of 
   5.147 +   mAFN (fm) => afnp vrl fm 
   5.148 +   |mNFN (prt) => let val th1 = h_proof_of_mlift_qelim isat  afnp nfnp qfnp prt vrl 
   5.149 +                  val th2 = nfnp (snd (qe_get_terms th1)) 
   5.150 +                    in [th1,th2] MRS trans 
   5.151 +                 end 
   5.152 +   |mQeConst (s,pr1,pr2) =>  
   5.153 +     let val th1 =  h_proof_of_mlift_qelim isat afnp nfnp qfnp pr1 vrl  
   5.154 +         val th2 =  h_proof_of_mlift_qelim isat afnp nfnp qfnp pr2 vrl  
   5.155 +     in (case s of 
   5.156 +        "CJ" => [th1,th2] MRS (qe_conjI)  
   5.157 +       |"DJ" => [th1,th2] MRS (qe_disjI)  
   5.158 +       |"IM" => [th1,th2] MRS (qe_impI)  
   5.159 +       |"EQ" => [th1,th2] MRS (qe_eqI)  
   5.160 +       )  
   5.161 +    end  
   5.162 +   |mQeNot (pr) =>(h_proof_of_mlift_qelim isat afnp nfnp qfnp pr vrl ) RS (qe_Not)  
   5.163 +   |mQeAll(pr) => (h_proof_of_mlift_qelim isat afnp nfnp qfnp pr vrl ) RS (qe_ALL) 
   5.164 +   |mQelim (x as (Free(xn,xT)),vl,pr) => 
   5.165 +     let val th_1 = h_proof_of_mlift_qelim isat afnp nfnp qfnp pr vl
   5.166 +         val mQeProof(l2,pr2) = mlift_qelim_wp isat (xn::vrl) (snd(qe_get_terms th_1))
   5.167 +         val th_2 = [th_1,(h_proof_of_mlift_qelim isat afnp nfnp qfnp pr2 l2)] MRS trans
   5.168 +         val th1 = (forall_intr (cterm_of sg x) th_2) COMP (qe_exI)
   5.169 +	 val th2 = qfnp vl (snd (qe_get_terms th1)) 
   5.170 +       in [th1,th2] MRS trans 
   5.171 +       end
   5.172 +   |mQefm (fm) => instantiate' [Some cboolT] [Some (cterm_of sg fm)] refl
   5.173 +)
   5.174 +in (fn fm => let val mQeProof(vars,prt) = (mlift_qelim_wp isat (fv fm) fm)
   5.175 +                 in (h_proof_of_mlift_qelim isat afnp nfnp qfnp prt vars)
   5.176 +                 end)
   5.177 +end;
   5.178 +
   5.179 +end;
     6.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     6.2 +++ b/src/HOL/Presburger.thy	Tue Mar 25 09:47:05 2003 +0100
     6.3 @@ -0,0 +1,1002 @@
     6.4 +(*  Title:      HOL/Integ/Presburger.thy
     6.5 +    ID:         $Id$
     6.6 +    Author:     Amine Chaieb, Tobias Nipkow and Stefan Berghofer, TU Muenchen
     6.7 +    License:    GPL (GNU GENERAL PUBLIC LICENSE)
     6.8 +
     6.9 +File containing necessary theorems for the proof
    6.10 +generation for Cooper Algorithm  
    6.11 +*)
    6.12 +
    6.13 +theory Presburger = NatSimprocs
    6.14 +files
    6.15 +  ("cooper_dec.ML")
    6.16 +  ("cooper_proof.ML")
    6.17 +  ("qelim.ML")
    6.18 +  ("presburger.ML"):
    6.19 +
    6.20 +(* Theorem for unitifying the coeffitients of x in an existential formula*)
    6.21 +
    6.22 +theorem unity_coeff_ex: "(\<exists>x::int. P (l * x)) = (\<exists>x. l dvd (1*x+0) \<and> P x)"
    6.23 +  apply (rule iffI)
    6.24 +  apply (erule exE)
    6.25 +  apply (rule_tac x = "l * x" in exI)
    6.26 +  apply simp
    6.27 +  apply (erule exE)
    6.28 +  apply (erule conjE)
    6.29 +  apply (erule dvdE)
    6.30 +  apply (rule_tac x = k in exI)
    6.31 +  apply simp
    6.32 +  done
    6.33 +
    6.34 +lemma uminus_dvd_conv: "(d dvd (t::int)) = (-d dvd t)"
    6.35 +apply(unfold dvd_def)
    6.36 +apply(rule iffI)
    6.37 +apply(clarsimp)
    6.38 +apply(rename_tac k)
    6.39 +apply(rule_tac x = "-k" in exI)
    6.40 +apply simp
    6.41 +apply(clarsimp)
    6.42 +apply(rename_tac k)
    6.43 +apply(rule_tac x = "-k" in exI)
    6.44 +apply simp
    6.45 +done
    6.46 +
    6.47 +lemma uminus_dvd_conv': "(d dvd (t::int)) = (d dvd -t)"
    6.48 +apply(unfold dvd_def)
    6.49 +apply(rule iffI)
    6.50 +apply(clarsimp)
    6.51 +apply(rule_tac x = "-k" in exI)
    6.52 +apply simp
    6.53 +apply(clarsimp)
    6.54 +apply(rule_tac x = "-k" in exI)
    6.55 +apply simp
    6.56 +done
    6.57 +
    6.58 +
    6.59 +
    6.60 +(*Theorems for the combination of proofs of the equality of P and P_m for integers x less than some integer z.*)
    6.61 +
    6.62 +theorem eq_minf_conjI: "\<exists>z1::int. \<forall>x. x < z1 \<longrightarrow> (A1 x = A2 x) \<Longrightarrow>
    6.63 +  \<exists>z2::int. \<forall>x. x < z2 \<longrightarrow> (B1 x = B2 x) \<Longrightarrow>
    6.64 +  \<exists>z::int. \<forall>x. x < z \<longrightarrow> ((A1 x \<and> B1 x) = (A2 x \<and> B2 x))"
    6.65 +  apply (erule exE)+
    6.66 +  apply (rule_tac x = "min z1 z2" in exI)
    6.67 +  apply simp
    6.68 +  done
    6.69 +
    6.70 +
    6.71 +theorem eq_minf_disjI: "\<exists>z1::int. \<forall>x. x < z1 \<longrightarrow> (A1 x = A2 x) \<Longrightarrow>
    6.72 +  \<exists>z2::int. \<forall>x. x < z2 \<longrightarrow> (B1 x = B2 x) \<Longrightarrow>
    6.73 +  \<exists>z::int. \<forall>x. x < z \<longrightarrow> ((A1 x \<or> B1 x) = (A2 x \<or> B2 x))"
    6.74 +
    6.75 +  apply (erule exE)+
    6.76 +  apply (rule_tac x = "min z1 z2" in exI)
    6.77 +  apply simp
    6.78 +  done
    6.79 +
    6.80 +
    6.81 +(*Theorems for the combination of proofs of the equality of P and P_m for integers x greather than some integer z.*)
    6.82 +
    6.83 +theorem eq_pinf_conjI: "\<exists>z1::int. \<forall>x. z1 < x \<longrightarrow> (A1 x = A2 x) \<Longrightarrow>
    6.84 +  \<exists>z2::int. \<forall>x. z2 < x \<longrightarrow> (B1 x = B2 x) \<Longrightarrow>
    6.85 +  \<exists>z::int. \<forall>x. z < x \<longrightarrow> ((A1 x \<and> B1 x) = (A2 x \<and> B2 x))"
    6.86 +  apply (erule exE)+
    6.87 +  apply (rule_tac x = "max z1 z2" in exI)
    6.88 +  apply simp
    6.89 +  done
    6.90 +
    6.91 +
    6.92 +theorem eq_pinf_disjI: "\<exists>z1::int. \<forall>x. z1 < x \<longrightarrow> (A1 x = A2 x) \<Longrightarrow>
    6.93 +  \<exists>z2::int. \<forall>x. z2 < x \<longrightarrow> (B1 x = B2 x) \<Longrightarrow>
    6.94 +  \<exists>z::int. \<forall>x. z < x  \<longrightarrow> ((A1 x \<or> B1 x) = (A2 x \<or> B2 x))"
    6.95 +  apply (erule exE)+
    6.96 +  apply (rule_tac x = "max z1 z2" in exI)
    6.97 +  apply simp
    6.98 +  done
    6.99 +(*=============================================================================*)
   6.100 +(*Theorems for the combination of proofs of the modulo D property for P
   6.101 +pluusinfinity*)
   6.102 +(* FIXME : This is THE SAME theorem as for the minusinf version, but with +k.. instead of -k.. In the future replace these both with only one*)
   6.103 +
   6.104 +theorem modd_pinf_conjI: "\<forall>(x::int) k. A x = A (x+k*d) \<Longrightarrow>
   6.105 +  \<forall>(x::int) k. B x = B (x+k*d) \<Longrightarrow>
   6.106 +  \<forall>(x::int) (k::int). (A x \<and> B x) = (A (x+k*d) \<and> B (x+k*d))"
   6.107 +  by simp
   6.108 +
   6.109 +
   6.110 +theorem modd_pinf_disjI: "\<forall>(x::int) k. A x = A (x+k*d) \<Longrightarrow>
   6.111 +  \<forall>(x::int) k. B x = B (x+k*d) \<Longrightarrow>
   6.112 +  \<forall>(x::int) (k::int). (A x \<or> B x) = (A (x+k*d) \<or> B (x+k*d))"
   6.113 +  by simp
   6.114 +
   6.115 +(*=============================================================================*)
   6.116 +(*This is one of the cases where the simplifed formula is prooved to habe some property
   6.117 +(in relation to P_m) but we need to proove the property for the original formula (P_m)*)
   6.118 +(*FIXME : This is exaclty the same thm as for minusinf.*)
   6.119 +lemma pinf_simp_eq: "ALL x. P(x) = Q(x) ==> (EX (x::int). P(x)) --> (EX (x::int). F(x))  ==> (EX (x::int). Q(x)) --> (EX (x::int). F(x)) "
   6.120 +by blast
   6.121 +
   6.122 +
   6.123 +
   6.124 +(*=============================================================================*)
   6.125 +(*Theorems for the combination of proofs of the modulo D property for P
   6.126 +minusinfinity*)
   6.127 +
   6.128 +theorem modd_minf_conjI: "\<forall>(x::int) k. A x = A (x-k*d) \<Longrightarrow>
   6.129 +  \<forall>(x::int) k. B x = B (x-k*d) \<Longrightarrow>
   6.130 +  \<forall>(x::int) (k::int). (A x \<and> B x) = (A (x-k*d) \<and> B (x-k*d))"
   6.131 +  by simp
   6.132 +
   6.133 +
   6.134 +theorem modd_minf_disjI: "\<forall>(x::int) k. A x = A (x-k*d) \<Longrightarrow>
   6.135 +  \<forall>(x::int) k. B x = B (x-k*d) \<Longrightarrow>
   6.136 +  \<forall>(x::int) (k::int). (A x \<or> B x) = (A (x-k*d) \<or> B (x-k*d))"
   6.137 +  by simp
   6.138 +
   6.139 +(*=============================================================================*)
   6.140 +(*This is one of the cases where the simplifed formula is prooved to habe some property
   6.141 +(in relation to P_m) but we need to proove the property for the original formula (P_m)*)
   6.142 +
   6.143 +lemma minf_simp_eq: "ALL x. P(x) = Q(x) ==> (EX (x::int). P(x)) --> (EX (x::int). F(x))  ==> (EX (x::int). Q(x)) --> (EX (x::int). F(x)) "
   6.144 +by blast
   6.145 +
   6.146 +(*=============================================================================*)
   6.147 +
   6.148 +(*theorem needed for prooving at runtime divide properties using the arithmetic tatic
   6.149 +(who knows only about modulo = 0)*)
   6.150 +
   6.151 +lemma zdvd_iff_zmod_eq_0: "(m dvd n) = (n mod m = (0::int))"
   6.152 +by(simp add:dvd_def zmod_eq_0_iff)
   6.153 +
   6.154 +(*=============================================================================*)
   6.155 +
   6.156 +
   6.157 +
   6.158 +(*Theorems used for the combination of proof for the backwards direction of cooper's
   6.159 +theorem. they rely exclusively on Predicate calculus.*)
   6.160 +
   6.161 +lemma not_ast_p_disjI: "(ALL x. Q(x::int) \<and> ~(EX (j::int) : {1..d}. EX (a::int) : A. Q(a - j)) --> P1(x) --> P1(x + d))
   6.162 +==>
   6.163 +(ALL x. Q(x::int) \<and> ~(EX (j::int) : {1..d}. EX (a::int) : A. Q(a - j)) --> P2(x) --> P2(x + d))
   6.164 +==>
   6.165 +(ALL x. Q(x::int) \<and> ~(EX (j::int) : {1..d}. EX (a::int) : A. Q(a - j)) -->(P1(x) \<or> P2(x)) --> (P1(x + d) \<or> P2(x + d))) "
   6.166 +by blast
   6.167 +
   6.168 +
   6.169 +
   6.170 +lemma not_ast_p_conjI: "(ALL x. Q(x::int) \<and> ~(EX (j::int) : {1..d}. EX (a::int) : A. Q(a- j)) --> P1(x) --> P1(x + d))
   6.171 +==>
   6.172 +(ALL x. Q(x::int) \<and> ~(EX (j::int) : {1..d}. EX (a::int) : A. Q(a - j)) --> P2(x) --> P2(x + d))
   6.173 +==>
   6.174 +(ALL x. Q(x::int) \<and> ~(EX (j::int) : {1..d}. EX (a::int) : A. Q(a - j)) -->(P1(x) \<and> P2(x)) --> (P1(x + d)
   6.175 +\<and> P2(x + d))) "
   6.176 +by blast
   6.177 +
   6.178 +lemma not_ast_p_Q_elim: "
   6.179 +(ALL x. Q(x::int) \<and> ~(EX (j::int) : {1..d}. EX (a::int) : A. Q(a - j)) -->P(x) --> P(x + d))
   6.180 +==> ( P = Q )
   6.181 +==> (ALL x. ~(EX (j::int) : {1..d}. EX (a::int) : A. P(a - j)) -->P(x) --> P(x + d))"
   6.182 +by blast
   6.183 +(*=============================================================================*)
   6.184 +
   6.185 +
   6.186 +(*Theorems used for the combination of proof for the backwards direction of cooper's
   6.187 +theorem. they rely exclusively on Predicate calculus.*)
   6.188 +
   6.189 +lemma not_bst_p_disjI: "(ALL x. Q(x::int) \<and> ~(EX (j::int) : {1..d}. EX (b::int) : B. Q(b+j)) --> P1(x) --> P1(x - d))
   6.190 +==>
   6.191 +(ALL x. Q(x::int) \<and> ~(EX (j::int) : {1..d}. EX (b::int) : B. Q(b+j)) --> P2(x) --> P2(x - d))
   6.192 +==>
   6.193 +(ALL x. Q(x::int) \<and> ~(EX (j::int) : {1..d}. EX (b::int) : B. Q(b+j)) -->(P1(x) \<or> P2(x)) --> (P1(x - d)
   6.194 +\<or> P2(x-d))) "
   6.195 +by blast
   6.196 +
   6.197 +
   6.198 +
   6.199 +lemma not_bst_p_conjI: "(ALL x. Q(x::int) \<and> ~(EX (j::int) : {1..d}. EX (b::int) : B. Q(b+j)) --> P1(x) --> P1(x - d))
   6.200 +==>
   6.201 +(ALL x. Q(x::int) \<and> ~(EX (j::int) : {1..d}. EX (b::int) : B. Q(b+j)) --> P2(x) --> P2(x - d))
   6.202 +==>
   6.203 +(ALL x. Q(x::int) \<and> ~(EX (j::int) : {1..d}. EX (b::int) : B. Q(b+j)) -->(P1(x) \<and> P2(x)) --> (P1(x - d)
   6.204 +\<and> P2(x-d))) "
   6.205 +by blast
   6.206 +
   6.207 +lemma not_bst_p_Q_elim: "
   6.208 +(ALL x. Q(x::int) \<and> ~(EX (j::int) : {1..d}. EX (b::int) : B. Q(b+j)) -->P(x) --> P(x - d)) 
   6.209 +==> ( P = Q )
   6.210 +==> (ALL x. ~(EX (j::int) : {1..d}. EX (b::int) : B. P(b+j)) -->P(x) --> P(x - d))"
   6.211 +by blast
   6.212 +(*=============================================================================*)
   6.213 +(*The Theorem for the second proof step- about bset. it is trivial too. *)
   6.214 +lemma bst_thm: " (EX (j::int) : {1..d}. EX (b::int) : B. P (b+j) )--> (EX x::int. P (x)) "
   6.215 +by blast
   6.216 +
   6.217 +(*The Theorem for the second proof step- about aset. it is trivial too. *)
   6.218 +lemma ast_thm: " (EX (j::int) : {1..d}. EX (a::int) : A. P (a - j) )--> (EX x::int. P (x)) "
   6.219 +by blast
   6.220 +
   6.221 +
   6.222 +(*=============================================================================*)
   6.223 +(*This is the first direction of cooper's theorem*)
   6.224 +lemma cooper_thm: "(R --> (EX x::int. P x))  ==> (Q -->(EX x::int.  P x )) ==> ((R|Q) --> (EX x::int. P x )) "
   6.225 +by blast
   6.226 +
   6.227 +(*=============================================================================*)
   6.228 +(*The full cooper's theoorem in its equivalence Form- Given the premisses it is trivial
   6.229 +too, it relies exclusively on prediacte calculus.*)
   6.230 +lemma cooper_eq_thm: "(R --> (EX x::int. P x))  ==> (Q -->(EX x::int.  P x )) ==> ((~Q)
   6.231 +--> (EX x::int. P x ) --> R) ==> (EX x::int. P x) = R|Q "
   6.232 +by blast
   6.233 +
   6.234 +(*=============================================================================*)
   6.235 +(*Some of the atomic theorems generated each time the atom does not depend on x, they
   6.236 +are trivial.*)
   6.237 +
   6.238 +lemma  fm_eq_minf: "EX z::int. ALL x. x < z --> (P = P) "
   6.239 +by blast
   6.240 +
   6.241 +lemma  fm_modd_minf: "ALL (x::int). ALL (k::int). (P = P)"
   6.242 +by blast
   6.243 +
   6.244 +lemma not_bst_p_fm: "ALL (x::int). Q(x::int) \<and> ~(EX (j::int) : {1..d}. EX (b::int) : B. Q(b+j)) --> fm --> fm"
   6.245 +by blast
   6.246 +
   6.247 +
   6.248 +
   6.249 +lemma  fm_eq_pinf: "EX z::int. ALL x. z < x --> (P = P) "
   6.250 +by blast
   6.251 +
   6.252 +(* The next 2 thms are the same as the minusinf version*)
   6.253 +lemma  fm_modd_pinf: "ALL (x::int). ALL (k::int). (P = P)"
   6.254 +by blast
   6.255 +
   6.256 +lemma not_ast_p_fm: "ALL (x::int). Q(x::int) \<and> ~(EX (j::int) : {1..d}. EX (a::int) : A. Q(a - j)) --> fm --> fm"
   6.257 +by blast
   6.258 +
   6.259 +
   6.260 +(* Theorems to be deleted from simpset when proving simplified formulaes*)
   6.261 +lemma P_eqtrue: "(P=True) = P"
   6.262 +  by rules
   6.263 +
   6.264 +lemma P_eqfalse: "(P=False) = (~P)"
   6.265 +  by rules
   6.266 +
   6.267 +(*=============================================================================*)
   6.268 +
   6.269 +(*Theorems for the generation of the bachwards direction of cooper's theorem*)
   6.270 +(*These are the 6 interesting atomic cases which have to be proved relying on the
   6.271 +properties of B-set ant the arithmetic and contradiction proofs*)
   6.272 +
   6.273 +lemma not_bst_p_lt: "0 < (d::int) ==>
   6.274 + ALL x. Q(x::int) \<and> ~(EX (j::int) : {1..d}. EX (b::int) : B. Q(b+j)) --> ( 0 < -x + a) --> (0 < -(x - d) + a )"
   6.275 +by arith
   6.276 +
   6.277 +lemma not_bst_p_gt: "\<lbrakk> (g::int) \<in> B; g = -a \<rbrakk> \<Longrightarrow>
   6.278 + ALL x. Q(x::int) \<and> ~(EX (j::int) : {1..d}. EX (b::int) : B. Q(b+j)) --> (0 < (x) + a) --> ( 0 < (x - d) + a)"
   6.279 +apply clarsimp
   6.280 +apply(rule ccontr)
   6.281 +apply(drule_tac x = "x+a" in bspec)
   6.282 +apply(simp add:atLeastAtMost_iff)
   6.283 +apply(drule_tac x = "-a" in bspec)
   6.284 +apply assumption
   6.285 +apply(simp)
   6.286 +done
   6.287 +
   6.288 +lemma not_bst_p_eq: "\<lbrakk> 0 < d; (g::int) \<in> B; g = -a - 1 \<rbrakk> \<Longrightarrow>
   6.289 + ALL x. Q(x::int) \<and> ~(EX (j::int) : {1..d}. EX (b::int) : B. Q(b+j)) --> (0 = x + a) --> (0 = (x - d) + a )"
   6.290 +apply clarsimp
   6.291 +apply(subgoal_tac "x = -a")
   6.292 + prefer 2 apply arith
   6.293 +apply(drule_tac x = "1" in bspec)
   6.294 +apply(simp add:atLeastAtMost_iff)
   6.295 +apply(drule_tac x = "-a- 1" in bspec)
   6.296 +apply assumption
   6.297 +apply(simp)
   6.298 +done
   6.299 +
   6.300 +
   6.301 +lemma not_bst_p_ne: "\<lbrakk> 0 < d; (g::int) \<in> B; g = -a \<rbrakk> \<Longrightarrow>
   6.302 + ALL x. Q(x::int) \<and> ~(EX (j::int) : {1..d}. EX (b::int) : B. Q(b+j)) --> ~(0 = x + a) --> ~(0 = (x - d) + a)"
   6.303 +apply clarsimp
   6.304 +apply(subgoal_tac "x = -a+d")
   6.305 + prefer 2 apply arith
   6.306 +apply(drule_tac x = "d" in bspec)
   6.307 +apply(simp add:atLeastAtMost_iff)
   6.308 +apply(drule_tac x = "-a" in bspec)
   6.309 +apply assumption
   6.310 +apply(simp)
   6.311 +done
   6.312 +
   6.313 +
   6.314 +lemma not_bst_p_dvd: "(d1::int) dvd d ==>
   6.315 + ALL x. Q(x::int) \<and> ~(EX (j::int) : {1..d}. EX (b::int) : B. Q(b+j)) --> d1 dvd (x + a) --> d1 dvd ((x - d) + a )"
   6.316 +apply(clarsimp simp add:dvd_def)
   6.317 +apply(rename_tac m)
   6.318 +apply(rule_tac x = "m - k" in exI)
   6.319 +apply(simp add:int_distrib)
   6.320 +done
   6.321 +
   6.322 +lemma not_bst_p_ndvd: "(d1::int) dvd d ==>
   6.323 + ALL x. Q(x::int) \<and> ~(EX (j::int) : {1..d}. EX (b::int) : B. Q(b+j)) --> ~(d1 dvd (x + a)) --> ~(d1 dvd ((x - d) + a ))"
   6.324 +apply(clarsimp simp add:dvd_def)
   6.325 +apply(rename_tac m)
   6.326 +apply(erule_tac x = "m + k" in allE)
   6.327 +apply(simp add:int_distrib)
   6.328 +done
   6.329 +
   6.330 +
   6.331 +
   6.332 +(*Theorems for the generation of the bachwards direction of cooper's theorem*)
   6.333 +(*These are the 6 interesting atomic cases which have to be proved relying on the
   6.334 +properties of A-set ant the arithmetic and contradiction proofs*)
   6.335 +
   6.336 +lemma not_ast_p_gt: "0 < (d::int) ==>
   6.337 + ALL x. Q(x::int) \<and> ~(EX (j::int) : {1..d}. EX (a::int) : A. Q(a - j)) --> ( 0 < x + t) --> (0 < (x + d) + t )"
   6.338 +by arith
   6.339 +
   6.340 +
   6.341 +lemma not_ast_p_lt: "\<lbrakk>0 < d ;(t::int) \<in> A \<rbrakk> \<Longrightarrow>
   6.342 + ALL x. Q(x::int) \<and> ~(EX (j::int) : {1..d}. EX (a::int) : A. Q(a - j)) --> (0 < -x + t) --> ( 0 < -(x + d) + t)"
   6.343 +  apply clarsimp
   6.344 +  apply (rule ccontr)
   6.345 +  apply (drule_tac x = "t-x" in bspec)
   6.346 +  apply simp
   6.347 +  apply (drule_tac x = "t" in bspec)
   6.348 +  apply assumption
   6.349 +  apply simp
   6.350 +  done
   6.351 +
   6.352 +lemma not_ast_p_eq: "\<lbrakk> 0 < d; (g::int) \<in> A; g = -t + 1 \<rbrakk> \<Longrightarrow>
   6.353 + ALL x. Q(x::int) \<and> ~(EX (j::int) : {1..d}. EX (a::int) : A. Q(a - j)) --> (0 = x + t) --> (0 = (x + d) + t )"
   6.354 +  apply clarsimp
   6.355 +  apply (drule_tac x="1" in bspec)
   6.356 +  apply simp
   6.357 +  apply (drule_tac x="- t + 1" in bspec)
   6.358 +  apply assumption
   6.359 +  apply(subgoal_tac "x = -t")
   6.360 +  prefer 2 apply arith
   6.361 +  apply simp
   6.362 +  done
   6.363 +
   6.364 +lemma not_ast_p_ne: "\<lbrakk> 0 < d; (g::int) \<in> A; g = -t \<rbrakk> \<Longrightarrow>
   6.365 + ALL x. Q(x::int) \<and> ~(EX (j::int) : {1..d}. EX (a::int) : A. Q(a - j)) --> ~(0 = x + t) --> ~(0 = (x + d) + t)"
   6.366 +  apply clarsimp
   6.367 +  apply (subgoal_tac "x = -t-d")
   6.368 +  prefer 2 apply arith
   6.369 +  apply (drule_tac x = "d" in bspec)
   6.370 +  apply simp
   6.371 +  apply (drule_tac x = "-t" in bspec)
   6.372 +  apply assumption
   6.373 +  apply simp
   6.374 +  done
   6.375 +
   6.376 +lemma not_ast_p_dvd: "(d1::int) dvd d ==>
   6.377 + ALL x. Q(x::int) \<and> ~(EX (j::int) : {1..d}. EX (a::int) : A. Q(a - j)) --> d1 dvd (x + t) --> d1 dvd ((x + d) + t )"
   6.378 +  apply(clarsimp simp add:dvd_def)
   6.379 +  apply(rename_tac m)
   6.380 +  apply(rule_tac x = "m + k" in exI)
   6.381 +  apply(simp add:int_distrib)
   6.382 +  done
   6.383 +
   6.384 +lemma not_ast_p_ndvd: "(d1::int) dvd d ==>
   6.385 + ALL x. Q(x::int) \<and> ~(EX (j::int) : {1..d}. EX (a::int) : A. Q(a - j)) --> ~(d1 dvd (x + t)) --> ~(d1 dvd ((x + d) + t ))"
   6.386 +  apply(clarsimp simp add:dvd_def)
   6.387 +  apply(rename_tac m)
   6.388 +  apply(erule_tac x = "m - k" in allE)
   6.389 +  apply(simp add:int_distrib)
   6.390 +  done
   6.391 +
   6.392 +
   6.393 +
   6.394 +(*=============================================================================*)
   6.395 +(*These are the atomic cases for the proof generation for the modulo D property for P
   6.396 +plusinfinity*)
   6.397 +(*They are fully based on arithmetics*)
   6.398 +
   6.399 +lemma  dvd_modd_pinf: "((d::int) dvd d1) ==>
   6.400 + (ALL (x::int). ALL (k::int). (((d::int) dvd (x + t)) = (d dvd (x+k*d1 + t))))"
   6.401 +  apply(clarsimp simp add:dvd_def)
   6.402 +  apply(rule iffI)
   6.403 +  apply(clarsimp)
   6.404 +  apply(rename_tac n m)
   6.405 +  apply(rule_tac x = "m + n*k" in exI)
   6.406 +  apply(simp add:int_distrib)
   6.407 +  apply(clarsimp)
   6.408 +  apply(rename_tac n m)
   6.409 +  apply(rule_tac x = "m - n*k" in exI)
   6.410 +  apply(simp add:int_distrib zmult_ac)
   6.411 +  done
   6.412 +
   6.413 +lemma  not_dvd_modd_pinf: "((d::int) dvd d1) ==>
   6.414 + (ALL (x::int). ALL k. (~((d::int) dvd (x + t))) = (~(d dvd (x+k*d1 + t))))"
   6.415 +  apply(clarsimp simp add:dvd_def)
   6.416 +  apply(rule iffI)
   6.417 +  apply(clarsimp)
   6.418 +  apply(rename_tac n m)
   6.419 +  apply(erule_tac x = "m - n*k" in allE)
   6.420 +  apply(simp add:int_distrib zmult_ac)
   6.421 +  apply(clarsimp)
   6.422 +  apply(rename_tac n m)
   6.423 +  apply(erule_tac x = "m + n*k" in allE)
   6.424 +  apply(simp add:int_distrib zmult_ac)
   6.425 +  done
   6.426 +
   6.427 +(*=============================================================================*)
   6.428 +(*These are the atomic cases for the proof generation for the equivalence of P and P
   6.429 +plusinfinity for integers x greather than some integer z.*)
   6.430 +(*They are fully based on arithmetics*)
   6.431 +
   6.432 +lemma  eq_eq_pinf: "EX z::int. ALL x. z < x --> (( 0 = x +t ) = False )"
   6.433 +  apply(rule_tac x = "-t" in exI)
   6.434 +  apply simp
   6.435 +  done
   6.436 +
   6.437 +lemma  neq_eq_pinf: "EX z::int. ALL x.  z < x --> ((~( 0 = x +t )) = True )"
   6.438 +  apply(rule_tac x = "-t" in exI)
   6.439 +  apply simp
   6.440 +  done
   6.441 +
   6.442 +lemma  le_eq_pinf: "EX z::int. ALL x.  z < x --> ( 0 < x +t  = True )"
   6.443 +  apply(rule_tac x = "-t" in exI)
   6.444 +  apply simp
   6.445 +  done
   6.446 +
   6.447 +lemma  len_eq_pinf: "EX z::int. ALL x. z < x  --> (0 < -x +t  = False )"
   6.448 +  apply(rule_tac x = "t" in exI)
   6.449 +  apply simp
   6.450 +  done
   6.451 +
   6.452 +lemma  dvd_eq_pinf: "EX z::int. ALL x.  z < x --> ((d dvd (x + t)) = (d dvd (x + t))) "
   6.453 +by simp
   6.454 +
   6.455 +lemma  not_dvd_eq_pinf: "EX z::int. ALL x. z < x  --> ((~(d dvd (x + t))) = (~(d dvd (x + t)))) "
   6.456 +by simp
   6.457 +
   6.458 +
   6.459 +
   6.460 +
   6.461 +(*=============================================================================*)
   6.462 +(*These are the atomic cases for the proof generation for the modulo D property for P
   6.463 +minusinfinity*)
   6.464 +(*They are fully based on arithmetics*)
   6.465 +
   6.466 +lemma  dvd_modd_minf: "((d::int) dvd d1) ==>
   6.467 + (ALL (x::int). ALL (k::int). (((d::int) dvd (x + t)) = (d dvd (x-k*d1 + t))))"
   6.468 +apply(clarsimp simp add:dvd_def)
   6.469 +apply(rule iffI)
   6.470 +apply(clarsimp)
   6.471 +apply(rename_tac n m)
   6.472 +apply(rule_tac x = "m - n*k" in exI)
   6.473 +apply(simp add:int_distrib)
   6.474 +apply(clarsimp)
   6.475 +apply(rename_tac n m)
   6.476 +apply(rule_tac x = "m + n*k" in exI)
   6.477 +apply(simp add:int_distrib zmult_ac)
   6.478 +done
   6.479 +
   6.480 +
   6.481 +lemma  not_dvd_modd_minf: "((d::int) dvd d1) ==>
   6.482 + (ALL (x::int). ALL k. (~((d::int) dvd (x + t))) = (~(d dvd (x-k*d1 + t))))"
   6.483 +apply(clarsimp simp add:dvd_def)
   6.484 +apply(rule iffI)
   6.485 +apply(clarsimp)
   6.486 +apply(rename_tac n m)
   6.487 +apply(erule_tac x = "m + n*k" in allE)
   6.488 +apply(simp add:int_distrib zmult_ac)
   6.489 +apply(clarsimp)
   6.490 +apply(rename_tac n m)
   6.491 +apply(erule_tac x = "m - n*k" in allE)
   6.492 +apply(simp add:int_distrib zmult_ac)
   6.493 +done
   6.494 +
   6.495 +
   6.496 +(*=============================================================================*)
   6.497 +(*These are the atomic cases for the proof generation for the equivalence of P and P
   6.498 +minusinfinity for integers x less than some integer z.*)
   6.499 +(*They are fully based on arithmetics*)
   6.500 +
   6.501 +lemma  eq_eq_minf: "EX z::int. ALL x. x < z --> (( 0 = x +t ) = False )"
   6.502 +apply(rule_tac x = "-t" in exI)
   6.503 +apply simp
   6.504 +done
   6.505 +
   6.506 +lemma  neq_eq_minf: "EX z::int. ALL x. x < z --> ((~( 0 = x +t )) = True )"
   6.507 +apply(rule_tac x = "-t" in exI)
   6.508 +apply simp
   6.509 +done
   6.510 +
   6.511 +lemma  le_eq_minf: "EX z::int. ALL x. x < z --> ( 0 < x +t  = False )"
   6.512 +apply(rule_tac x = "-t" in exI)
   6.513 +apply simp
   6.514 +done
   6.515 +
   6.516 +
   6.517 +lemma  len_eq_minf: "EX z::int. ALL x. x < z --> (0 < -x +t  = True )"
   6.518 +apply(rule_tac x = "t" in exI)
   6.519 +apply simp
   6.520 +done
   6.521 +
   6.522 +lemma  dvd_eq_minf: "EX z::int. ALL x. x < z --> ((d dvd (x + t)) = (d dvd (x + t))) "
   6.523 +by simp
   6.524 +
   6.525 +lemma  not_dvd_eq_minf: "EX z::int. ALL x. x < z --> ((~(d dvd (x + t))) = (~(d dvd (x + t)))) "
   6.526 +by simp
   6.527 +
   6.528 +
   6.529 +(*=============================================================================*)
   6.530 +(*This Theorem combines whithnesses about P minusinfinity to schow one component of the
   6.531 +equivalence proof for cooper's theorem*)
   6.532 +
   6.533 +(* FIXME: remove once they are part of the distribution *)
   6.534 +theorem int_ge_induct[consumes 1,case_names base step]:
   6.535 +  assumes ge: "k \<le> (i::int)" and
   6.536 +        base: "P(k)" and
   6.537 +        step: "\<And>i. \<lbrakk>k \<le> i; P i\<rbrakk> \<Longrightarrow> P(i+1)"
   6.538 +  shows "P i"
   6.539 +proof -
   6.540 +  { fix n have "\<And>i::int. n = nat(i-k) \<Longrightarrow> k <= i \<Longrightarrow> P i"
   6.541 +    proof (induct n)
   6.542 +      case 0
   6.543 +      hence "i = k" by arith
   6.544 +      thus "P i" using base by simp
   6.545 +    next
   6.546 +      case (Suc n)
   6.547 +      hence "n = nat((i - 1) - k)" by arith
   6.548 +      moreover
   6.549 +      have ki1: "k \<le> i - 1" using Suc.prems by arith
   6.550 +      ultimately
   6.551 +      have "P(i - 1)" by(rule Suc.hyps)
   6.552 +      from step[OF ki1 this] show ?case by simp
   6.553 +    qed
   6.554 +  }
   6.555 +  from this ge show ?thesis by fast
   6.556 +qed
   6.557 +
   6.558 +theorem int_gr_induct[consumes 1,case_names base step]:
   6.559 +  assumes gr: "k < (i::int)" and
   6.560 +        base: "P(k+1)" and
   6.561 +        step: "\<And>i. \<lbrakk>k < i; P i\<rbrakk> \<Longrightarrow> P(i+1)"
   6.562 +  shows "P i"
   6.563 +apply(rule int_ge_induct[of "k + 1"])
   6.564 +  using gr apply arith
   6.565 + apply(rule base)
   6.566 +apply(rule step)
   6.567 + apply simp+
   6.568 +done
   6.569 +
   6.570 +lemma decr_lemma: "0 < (d::int) \<Longrightarrow> x - (abs(x-z)+1) * d < z"
   6.571 +apply(induct rule: int_gr_induct)
   6.572 + apply simp
   6.573 + apply arith
   6.574 +apply (simp add:int_distrib)
   6.575 +apply arith
   6.576 +done
   6.577 +
   6.578 +lemma incr_lemma: "0 < (d::int) \<Longrightarrow> z < x + (abs(x-z)+1) * d"
   6.579 +apply(induct rule: int_gr_induct)
   6.580 + apply simp
   6.581 + apply arith
   6.582 +apply (simp add:int_distrib)
   6.583 +apply arith
   6.584 +done
   6.585 +
   6.586 +lemma  minusinfinity:
   6.587 +  assumes "0 < d" and
   6.588 +    P1eqP1: "ALL x k. P1 x = P1(x - k*d)" and
   6.589 +    ePeqP1: "EX z::int. ALL x. x < z \<longrightarrow> (P x = P1 x)"
   6.590 +  shows "(EX x. P1 x) \<longrightarrow> (EX x. P x)"
   6.591 +proof
   6.592 +  assume eP1: "EX x. P1 x"
   6.593 +  then obtain x where P1: "P1 x" ..
   6.594 +  from ePeqP1 obtain z where P1eqP: "ALL x. x < z \<longrightarrow> (P x = P1 x)" ..
   6.595 +  let ?w = "x - (abs(x-z)+1) * d"
   6.596 +  show "EX x. P x"
   6.597 +  proof
   6.598 +    have w: "?w < z" by(rule decr_lemma)
   6.599 +    have "P1 x = P1 ?w" using P1eqP1 by blast
   6.600 +    also have "\<dots> = P(?w)" using w P1eqP by blast
   6.601 +    finally show "P ?w" using P1 by blast
   6.602 +  qed
   6.603 +qed
   6.604 +
   6.605 +(*=============================================================================*)
   6.606 +(*This Theorem combines whithnesses about P minusinfinity to schow one component of the
   6.607 +equivalence proof for cooper's theorem*)
   6.608 +
   6.609 +lemma plusinfinity:
   6.610 +  assumes "0 < d" and
   6.611 +    P1eqP1: "ALL (x::int) (k::int). P1 x = P1 (x + k * d)" and
   6.612 +    ePeqP1: "EX z::int. ALL x. z < x  --> (P x = P1 x)"
   6.613 +  shows "(EX x::int. P1 x) --> (EX x::int. P x)"
   6.614 +proof
   6.615 +  assume eP1: "EX x. P1 x"
   6.616 +  then obtain x where P1: "P1 x" ..
   6.617 +  from ePeqP1 obtain z where P1eqP: "ALL x. z < x \<longrightarrow> (P x = P1 x)" ..
   6.618 +  let ?w = "x + (abs(x-z)+1) * d"
   6.619 +  show "EX x. P x"
   6.620 +  proof
   6.621 +    have w: "z < ?w" by(rule incr_lemma)
   6.622 +    have "P1 x = P1 ?w" using P1eqP1 by blast
   6.623 +    also have "\<dots> = P(?w)" using w P1eqP by blast
   6.624 +    finally show "P ?w" using P1 by blast
   6.625 +  qed
   6.626 +qed
   6.627 + 
   6.628 +
   6.629 +
   6.630 +(*=============================================================================*)
   6.631 +(*Theorem for periodic function on discrete sets*)
   6.632 +
   6.633 +lemma minf_vee:
   6.634 +  assumes dpos: "(0::int) < d" and modd: "ALL x k. P x = P(x - k*d)"
   6.635 +  shows "(EX x. P x) = (EX j : {1..d}. P j)"
   6.636 +  (is "?LHS = ?RHS")
   6.637 +proof
   6.638 +  assume ?LHS
   6.639 +  then obtain x where P: "P x" ..
   6.640 +  have "x mod d = x - (x div d)*d"
   6.641 +    by(simp add:zmod_zdiv_equality zmult_ac eq_zdiff_eq)
   6.642 +  hence Pmod: "P x = P(x mod d)" using modd by simp
   6.643 +  show ?RHS
   6.644 +  proof (cases)
   6.645 +    assume "x mod d = 0"
   6.646 +    hence "P 0" using P Pmod by simp
   6.647 +    moreover have "P 0 = P(0 - (-1)*d)" using modd by blast
   6.648 +    ultimately have "P d" by simp
   6.649 +    moreover have "d : {1..d}" using dpos by(simp add:atLeastAtMost_iff)
   6.650 +    ultimately show ?RHS ..
   6.651 +  next
   6.652 +    assume not0: "x mod d \<noteq> 0"
   6.653 +    have "P(x mod d)" using dpos P Pmod by(simp add:pos_mod_sign pos_mod_bound)
   6.654 +    moreover have "x mod d : {1..d}"
   6.655 +    proof -
   6.656 +      have "0 \<le> x mod d" by(rule pos_mod_sign)
   6.657 +      moreover have "x mod d < d" by(rule pos_mod_bound)
   6.658 +      ultimately show ?thesis using not0 by(simp add:atLeastAtMost_iff)
   6.659 +    qed
   6.660 +    ultimately show ?RHS ..
   6.661 +  qed
   6.662 +next
   6.663 +  assume ?RHS thus ?LHS by blast
   6.664 +qed
   6.665 +
   6.666 +(*=============================================================================*)
   6.667 +(*Theorem for periodic function on discrete sets*)
   6.668 +lemma pinf_vee:
   6.669 +  assumes dpos: "0 < (d::int)" and modd: "ALL (x::int) (k::int). P x = P (x+k*d)"
   6.670 +  shows "(EX x::int. P x) = (EX (j::int) : {1..d} . P j)"
   6.671 +  (is "?LHS = ?RHS")
   6.672 +proof
   6.673 +  assume ?LHS
   6.674 +  then obtain x where P: "P x" ..
   6.675 +  have "x mod d = x + (-(x div d))*d"
   6.676 +    by(simp add:zmod_zdiv_equality zmult_ac eq_zdiff_eq)
   6.677 +  hence Pmod: "P x = P(x mod d)" using modd by (simp only:)
   6.678 +  show ?RHS
   6.679 +  proof (cases)
   6.680 +    assume "x mod d = 0"
   6.681 +    hence "P 0" using P Pmod by simp
   6.682 +    moreover have "P 0 = P(0 + 1*d)" using modd by blast
   6.683 +    ultimately have "P d" by simp
   6.684 +    moreover have "d : {1..d}" using dpos by(simp add:atLeastAtMost_iff)
   6.685 +    ultimately show ?RHS ..
   6.686 +  next
   6.687 +    assume not0: "x mod d \<noteq> 0"
   6.688 +    have "P(x mod d)" using dpos P Pmod by(simp add:pos_mod_sign pos_mod_bound)
   6.689 +    moreover have "x mod d : {1..d}"
   6.690 +    proof -
   6.691 +      have "0 \<le> x mod d" by(rule pos_mod_sign)
   6.692 +      moreover have "x mod d < d" by(rule pos_mod_bound)
   6.693 +      ultimately show ?thesis using not0 by(simp add:atLeastAtMost_iff)
   6.694 +    qed
   6.695 +    ultimately show ?RHS ..
   6.696 +  qed
   6.697 +next
   6.698 +  assume ?RHS thus ?LHS by blast
   6.699 +qed
   6.700 +
   6.701 +lemma decr_mult_lemma:
   6.702 +  assumes dpos: "(0::int) < d" and
   6.703 +          minus: "ALL x::int. P x \<longrightarrow> P(x - d)" and
   6.704 +          knneg: "0 <= k"
   6.705 +  shows "ALL x. P x \<longrightarrow> P(x - k*d)"
   6.706 +using knneg
   6.707 +proof (induct rule:int_ge_induct)
   6.708 +  case base thus ?case by simp
   6.709 +next
   6.710 +  case (step i)
   6.711 +  show ?case
   6.712 +  proof
   6.713 +    fix x
   6.714 +    have "P x \<longrightarrow> P (x - i * d)" using step.hyps by blast
   6.715 +    also have "\<dots> \<longrightarrow> P(x - (i + 1) * d)"
   6.716 +      using minus[THEN spec, of "x - i * d"]
   6.717 +      by (simp add:int_distrib zdiff_zdiff_eq[symmetric])
   6.718 +    ultimately show "P x \<longrightarrow> P(x - (i + 1) * d)" by blast
   6.719 +  qed
   6.720 +qed
   6.721 +
   6.722 +lemma incr_mult_lemma:
   6.723 +  assumes dpos: "(0::int) < d" and
   6.724 +          plus: "ALL x::int. P x \<longrightarrow> P(x + d)" and
   6.725 +          knneg: "0 <= k"
   6.726 +  shows "ALL x. P x \<longrightarrow> P(x + k*d)"
   6.727 +using knneg
   6.728 +proof (induct rule:int_ge_induct)
   6.729 +  case base thus ?case by simp
   6.730 +next
   6.731 +  case (step i)
   6.732 +  show ?case
   6.733 +  proof
   6.734 +    fix x
   6.735 +    have "P x \<longrightarrow> P (x + i * d)" using step.hyps by blast
   6.736 +    also have "\<dots> \<longrightarrow> P(x + (i + 1) * d)"
   6.737 +      using plus[THEN spec, of "x + i * d"]
   6.738 +      by (simp add:int_distrib zadd_ac)
   6.739 +    ultimately show "P x \<longrightarrow> P(x + (i + 1) * d)" by blast
   6.740 +  qed
   6.741 +qed
   6.742 +
   6.743 +lemma cpmi_eq: "0 < D \<Longrightarrow> (EX z::int. ALL x. x < z --> (P x = P1 x))
   6.744 +==> (EX (j::int) : {1..D}. EX (b::int) : B. P (b+j)) --> (EX (x::int). P x) 
   6.745 +==> ALL x.~(EX (j::int) : {1..D}. EX (b::int) : B. P(b+j)) --> P (x) --> P (x - D) 
   6.746 +==> (ALL (x::int). ALL (k::int). ((P1 x)= (P1 (x-k*D))))
   6.747 +==> (EX (x::int). P(x)) = ((EX (j::int) : {1..D} . (P1(j))) | (EX (j::int) : {1..D}. EX (b::int) : B. P (b+j)))"
   6.748 +apply(rule iffI)
   6.749 +prefer 2
   6.750 +apply(drule minusinfinity)
   6.751 +apply assumption+
   6.752 +apply(fastsimp)
   6.753 +apply clarsimp
   6.754 +apply(subgoal_tac "!!k. 0<=k \<Longrightarrow> !x. P x \<longrightarrow> P (x - k*D)")
   6.755 +apply(frule_tac x = x and z=z in decr_lemma)
   6.756 +apply(subgoal_tac "P1(x - (\<bar>x - z\<bar> + 1) * D)")
   6.757 +prefer 2
   6.758 +apply(subgoal_tac "0 <= (\<bar>x - z\<bar> + 1)")
   6.759 +prefer 2 apply arith
   6.760 + apply fastsimp
   6.761 +apply(drule (1) minf_vee)
   6.762 +apply blast
   6.763 +apply(blast dest:decr_mult_lemma)
   6.764 +done
   6.765 +
   6.766 +(* Cooper Thm `, plus infinity version*)
   6.767 +lemma cppi_eq: "0 < D \<Longrightarrow> (EX z::int. ALL x. z < x --> (P x = P1 x))
   6.768 +==> (EX (j::int) : {1..D}. EX (a::int) : A. P (a - j)) --> (EX (x::int). P x) 
   6.769 +==> ALL x.~(EX (j::int) : {1..D}. EX (a::int) : A. P(a - j)) --> P (x) --> P (x + D) 
   6.770 +==> (ALL (x::int). ALL (k::int). ((P1 x)= (P1 (x+k*D))))
   6.771 +==> (EX (x::int). P(x)) = ((EX (j::int) : {1..D} . (P1(j))) | (EX (j::int) : {1..D}. EX (a::int) : A. P (a - j)))"
   6.772 +  apply(rule iffI)
   6.773 +  prefer 2
   6.774 +  apply(drule plusinfinity)
   6.775 +  apply assumption+
   6.776 +  apply(fastsimp)
   6.777 +  apply clarsimp
   6.778 +  apply(subgoal_tac "!!k. 0<=k \<Longrightarrow> !x. P x \<longrightarrow> P (x + k*D)")
   6.779 +  apply(frule_tac x = x and z=z in incr_lemma)
   6.780 +  apply(subgoal_tac "P1(x + (\<bar>x - z\<bar> + 1) * D)")
   6.781 +  prefer 2
   6.782 +  apply(subgoal_tac "0 <= (\<bar>x - z\<bar> + 1)")
   6.783 +  prefer 2 apply arith
   6.784 +  apply fastsimp
   6.785 +  apply(drule (1) pinf_vee)
   6.786 +  apply blast
   6.787 +  apply(blast dest:incr_mult_lemma)
   6.788 +  done
   6.789 +
   6.790 +
   6.791 +(*=============================================================================*)
   6.792 +
   6.793 +(*Theorems for the quantifier elminination Functions.*)
   6.794 +
   6.795 +lemma qe_ex_conj: "(EX (x::int). A x) = R
   6.796 +		==> (EX (x::int). P x) = (Q & (EX x::int. A x))
   6.797 +		==> (EX (x::int). P x) = (Q & R)"
   6.798 +by blast
   6.799 +
   6.800 +lemma qe_ex_nconj: "(EX (x::int). P x) = (True & Q)
   6.801 +		==> (EX (x::int). P x) = Q"
   6.802 +by blast
   6.803 +
   6.804 +lemma qe_conjI: "P1 = P2 ==> Q1 = Q2 ==> (P1 & Q1) = (P2 & Q2)"
   6.805 +by blast
   6.806 +
   6.807 +lemma qe_disjI: "P1 = P2 ==> Q1 = Q2 ==> (P1 | Q1) = (P2 | Q2)"
   6.808 +by blast
   6.809 +
   6.810 +lemma qe_impI: "P1 = P2 ==> Q1 = Q2 ==> (P1 --> Q1) = (P2 --> Q2)"
   6.811 +by blast
   6.812 +
   6.813 +lemma qe_eqI: "P1 = P2 ==> Q1 = Q2 ==> (P1 = Q1) = (P2 = Q2)"
   6.814 +by blast
   6.815 +
   6.816 +lemma qe_Not: "P = Q ==> (~P) = (~Q)"
   6.817 +by blast
   6.818 +
   6.819 +lemma qe_ALL: "(EX x. ~P x) = R ==> (ALL x. P x) = (~R)"
   6.820 +by blast
   6.821 +
   6.822 +(* Theorems for proving NNF *)
   6.823 +
   6.824 +lemma nnf_im: "((~P) = P1) ==> (Q=Q1) ==> ((P --> Q) = (P1 | Q1))"
   6.825 +by blast
   6.826 +
   6.827 +lemma nnf_eq: "((P & Q) = (P1 & Q1)) ==> (((~P) & (~Q)) = (P2 & Q2)) ==> ((P = Q) = ((P1 & Q1)|(P2 & Q2)))"
   6.828 +by blast
   6.829 +
   6.830 +lemma nnf_nn: "(P = Q) ==> ((~~P) = Q)"
   6.831 +  by blast
   6.832 +lemma nnf_ncj: "((~P) = P1) ==> ((~Q) = Q1) ==> ((~(P & Q)) = (P1 | Q1))"
   6.833 +by blast
   6.834 +
   6.835 +lemma nnf_ndj: "((~P) = P1) ==> ((~Q) = Q1) ==> ((~(P | Q)) = (P1 & Q1))"
   6.836 +by blast
   6.837 +lemma nnf_nim: "(P = P1) ==> ((~Q) = Q1) ==> ((~(P --> Q)) = (P1 & Q1))"
   6.838 +by blast
   6.839 +lemma nnf_neq: "((P & (~Q)) = (P1 & Q1)) ==> (((~P) & Q) = (P2 & Q2)) ==> ((~(P = Q)) = ((P1 & Q1)|(P2 & Q2)))"
   6.840 +by blast
   6.841 +lemma nnf_sdj: "((A & (~B)) = (A1 & B1)) ==> ((C & (~D)) = (C1 & D1)) ==> (A = (~C)) ==> ((~((A & B) | (C & D))) = ((A1 & B1) | (C1 & D1)))"
   6.842 +by blast
   6.843 +
   6.844 +
   6.845 +lemma qe_exI2: "A = B ==> (EX (x::int). A(x)) = (EX (x::int). B(x))"
   6.846 +  by simp
   6.847 +
   6.848 +lemma qe_exI: "(!!x::int. A x = B x) ==> (EX (x::int). A(x)) = (EX (x::int). B(x))"
   6.849 +  by rules
   6.850 +
   6.851 +lemma qe_ALLI: "(!!x::int. A x = B x) ==> (ALL (x::int). A(x)) = (ALL (x::int). B(x))"
   6.852 +  by rules
   6.853 +
   6.854 +lemma cp_expand: "(EX (x::int). P (x)) = (EX (j::int) : {1..d}. EX (b::int) : B. (P1 (j) | P(b+j)))
   6.855 +==>(EX (x::int). P (x)) = (EX (j::int) : {1..d}. EX (b::int) : B. (P1 (j) | P(b+j))) "
   6.856 +by blast
   6.857 +
   6.858 +lemma cppi_expand: "(EX (x::int). P (x)) = (EX (j::int) : {1..d}. EX (a::int) : A. (P1 (j) | P(a - j)))
   6.859 +==>(EX (x::int). P (x)) = (EX (j::int) : {1..d}. EX (a::int) : A. (P1 (j) | P(a - j))) "
   6.860 +by blast
   6.861 +
   6.862 +
   6.863 +lemma simp_from_to: "{i..j::int} = (if j < i then {} else insert i {i+1..j})"
   6.864 +apply(simp add:atLeastAtMost_def atLeast_def atMost_def)
   6.865 +apply(fastsimp)
   6.866 +done
   6.867 +
   6.868 +(* Theorems required for the adjustcoeffitienteq*)
   6.869 +
   6.870 +lemma ac_dvd_eq: assumes not0: "0 ~= (k::int)"
   6.871 +shows "((m::int) dvd (c*n+t)) = (k*m dvd ((k*c)*n+(k*t)))" (is "?P = ?Q")
   6.872 +proof
   6.873 +  assume ?P
   6.874 +  thus ?Q
   6.875 +    apply(simp add:dvd_def)
   6.876 +    apply clarify
   6.877 +    apply(rename_tac d)
   6.878 +    apply(drule_tac f = "op * k" in arg_cong)
   6.879 +    apply(simp only:int_distrib)
   6.880 +    apply(rule_tac x = "d" in exI)
   6.881 +    apply(simp only:zmult_ac)
   6.882 +    done
   6.883 +next
   6.884 +  assume ?Q
   6.885 +  then obtain d where "k * c * n + k * t = (k*m)*d" by(fastsimp simp:dvd_def)
   6.886 +  hence "(c * n + t) * k = (m*d) * k" by(simp add:int_distrib zmult_ac)
   6.887 +  hence "((c * n + t) * k) div k = ((m*d) * k) div k" by(rule arg_cong[of _ _ "%t. t div k"])
   6.888 +  hence "c*n+t = m*d" by(simp add: zdiv_zmult_self1[OF not0[symmetric]])
   6.889 +  thus ?P by(simp add:dvd_def)
   6.890 +qed
   6.891 +
   6.892 +lemma ac_lt_eq: assumes gr0: "0 < (k::int)"
   6.893 +shows "((m::int) < (c*n+t)) = (k*m <((k*c)*n+(k*t)))" (is "?P = ?Q")
   6.894 +proof
   6.895 +  assume P: ?P
   6.896 +  show ?Q using zmult_zless_mono2[OF P gr0] by(simp add: int_distrib zmult_ac)
   6.897 +next
   6.898 +  assume ?Q
   6.899 +  hence "0 < k*(c*n + t - m)" by(simp add: int_distrib zmult_ac)
   6.900 +  with gr0 have "0 < (c*n + t - m)" by(simp add:int_0_less_mult_iff)
   6.901 +  thus ?P by(simp)
   6.902 +qed
   6.903 +
   6.904 +lemma ac_eq_eq : assumes not0: "0 ~= (k::int)" shows "((m::int) = (c*n+t)) = (k*m =((k*c)*n+(k*t)) )" (is "?P = ?Q")
   6.905 +proof
   6.906 +  assume ?P
   6.907 +  thus ?Q
   6.908 +    apply(drule_tac f = "op * k" in arg_cong)
   6.909 +    apply(simp only:int_distrib)
   6.910 +    done
   6.911 +next
   6.912 +  assume ?Q
   6.913 +  hence "m * k = (c*n + t) * k" by(simp add:int_distrib zmult_ac)
   6.914 +  hence "((m) * k) div k = ((c*n + t) * k) div k" by(rule arg_cong[of _ _ "%t. t div k"])
   6.915 +  thus ?P by(simp add: zdiv_zmult_self1[OF not0[symmetric]])
   6.916 +qed
   6.917 +
   6.918 +lemma ac_pi_eq: assumes gr0: "0 < (k::int)" shows "(~((0::int) < (c*n + t))) = (0 < ((-k)*c)*n + ((-k)*t + k))"
   6.919 +proof -
   6.920 +  have "(~ (0::int) < (c*n + t)) = (0<1-(c*n + t))" by arith
   6.921 +  also have  "(1-(c*n + t)) = (-1*c)*n + (-t+1)" by(simp add: int_distrib zmult_ac)
   6.922 +  also have "0<(-1*c)*n + (-t+1) = (0 < (k*(-1*c)*n) + (k*(-t+1)))" by(rule ac_lt_eq[of _ 0,OF gr0,simplified])
   6.923 +  also have "(k*(-1*c)*n) + (k*(-t+1)) = ((-k)*c)*n + ((-k)*t + k)" by(simp add: int_distrib zmult_ac)
   6.924 +  finally show ?thesis .
   6.925 +qed
   6.926 +
   6.927 +lemma binminus_uminus_conv: "(a::int) - b = a + (-b)"
   6.928 +by arith
   6.929 +
   6.930 +lemma  linearize_dvd: "(t::int) = t1 ==> (d dvd t) = (d dvd t1)"
   6.931 +by simp
   6.932 +
   6.933 +lemma lf_lt: "(l::int) = ll ==> (r::int) = lr ==> (l < r) =(ll < lr)"
   6.934 +by simp
   6.935 +
   6.936 +lemma lf_eq: "(l::int) = ll ==> (r::int) = lr ==> (l = r) =(ll = lr)"
   6.937 +by simp
   6.938 +
   6.939 +lemma lf_dvd: "(l::int) = ll ==> (r::int) = lr ==> (l dvd r) =(ll dvd lr)"
   6.940 +by simp
   6.941 +
   6.942 +(* Theorems for transforming predicates on nat to predicates on int*)
   6.943 +
   6.944 +theorem all_nat: "(\<forall>x::nat. P x) = (\<forall>x::int. 0 <= x \<longrightarrow> P (nat x))"
   6.945 +  by (simp split add: split_nat)
   6.946 +
   6.947 +theorem ex_nat: "(\<exists>x::nat. P x) = (\<exists>x::int. 0 <= x \<and> P (nat x))"
   6.948 +  apply (simp split add: split_nat)
   6.949 +  apply (rule iffI)
   6.950 +  apply (erule exE)
   6.951 +  apply (rule_tac x = "int x" in exI)
   6.952 +  apply simp
   6.953 +  apply (erule exE)
   6.954 +  apply (rule_tac x = "nat x" in exI)
   6.955 +  apply (erule conjE)
   6.956 +  apply (erule_tac x = "nat x" in allE)
   6.957 +  apply simp
   6.958 +  done
   6.959 +
   6.960 +theorem zdiff_int_split: "P (int (x - y)) =
   6.961 +  ((y \<le> x \<longrightarrow> P (int x - int y)) \<and> (x < y \<longrightarrow> P 0))"
   6.962 +  apply (case_tac "y \<le> x")
   6.963 +  apply (simp_all add: zdiff_int)
   6.964 +  done
   6.965 +
   6.966 +theorem zdvd_int: "(x dvd y) = (int x dvd int y)"
   6.967 +  apply (simp only: dvd_def ex_nat int_int_eq [symmetric] zmult_int [symmetric]
   6.968 +    nat_0_le cong add: conj_cong)
   6.969 +  apply (rule iffI)
   6.970 +  apply rules
   6.971 +  apply (erule exE)
   6.972 +  apply (case_tac "x=0")
   6.973 +  apply (rule_tac x=0 in exI)
   6.974 +  apply simp
   6.975 +  apply (case_tac "0 \<le> k")
   6.976 +  apply rules
   6.977 +  apply (simp add: linorder_not_le)
   6.978 +  apply (drule zmult_zless_mono2_neg [OF iffD2 [OF zero_less_int_conv]])
   6.979 +  apply assumption
   6.980 +  apply (simp add: zmult_ac)
   6.981 +  done
   6.982 +
   6.983 +theorem number_of1: "(0::int) <= number_of n \<Longrightarrow> (0::int) <= number_of (n BIT b)"
   6.984 +  by simp
   6.985 +
   6.986 +theorem number_of2: "(0::int) <= number_of bin.Pls" by simp
   6.987 +
   6.988 +theorem Suc_plus1: "Suc n = n + 1" by simp
   6.989 +
   6.990 +(* specific instances of congruence rules, to prevent simplifier from looping *)
   6.991 +
   6.992 +theorem imp_le_cong: "(0 <= x \<Longrightarrow> P = P') \<Longrightarrow> (0 <= (x::nat) \<longrightarrow> P) = (0 <= x \<longrightarrow> P')"
   6.993 +  by simp
   6.994 +
   6.995 +theorem conj_le_cong: "(0 <= x \<Longrightarrow> P = P') \<Longrightarrow> (0 <= (x::nat) \<and> P) = (0 <= x \<and> P')"
   6.996 +  by simp
   6.997 +
   6.998 +use "cooper_dec.ML"
   6.999 +use "cooper_proof.ML"
  6.1000 +use "qelim.ML"
  6.1001 +use "presburger.ML"
  6.1002 +
  6.1003 +setup "Presburger.setup"
  6.1004 +
  6.1005 +end
     7.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     7.2 +++ b/src/HOL/Tools/Presburger/cooper_dec.ML	Tue Mar 25 09:47:05 2003 +0100
     7.3 @@ -0,0 +1,773 @@
     7.4 +(*  Title:      HOL/Integ/cooper_dec.ML
     7.5 +    ID:         $Id$
     7.6 +    Author:     Amine Chaieb and Tobias Nipkow, TU Muenchen
     7.7 +    License:    GPL (GNU GENERAL PUBLIC LICENSE)
     7.8 +
     7.9 +File containing the implementation of Cooper Algorithm
    7.10 +decision procedure (intensively inspired from J.Harrison)
    7.11 +*)
    7.12 + 
    7.13 +signature COOPER_DEC = 
    7.14 +sig
    7.15 +  exception COOPER
    7.16 +  val is_arith_rel : term -> bool
    7.17 +  val mk_numeral : int -> term
    7.18 +  val dest_numeral : term -> int
    7.19 +  val zero : term
    7.20 +  val one : term
    7.21 +  val linear_cmul : int -> term -> term
    7.22 +  val linear_add : string list -> term -> term -> term 
    7.23 +  val linear_sub : string list -> term -> term -> term 
    7.24 +  val linear_neg : term -> term
    7.25 +  val lint : string list -> term -> term
    7.26 +  val linform : string list -> term -> term
    7.27 +  val formlcm : term -> term -> int
    7.28 +  val adjustcoeff : term -> int -> term -> term
    7.29 +  val unitycoeff : term -> term -> term
    7.30 +  val divlcm : term -> term -> int
    7.31 +  val bset : term -> term -> term list
    7.32 +  val aset : term -> term -> term list
    7.33 +  val linrep : string list -> term -> term -> term -> term
    7.34 +  val list_disj : term list -> term
    7.35 +  val simpl : term -> term
    7.36 +  val fv : term -> string list
    7.37 +  val negate : term -> term
    7.38 +  val operations : (string * (int * int -> bool)) list
    7.39 +end;
    7.40 +
    7.41 +structure  CooperDec : COOPER_DEC =
    7.42 +struct
    7.43 +
    7.44 +(* ========================================================================= *) 
    7.45 +(* Cooper's algorithm for Presburger arithmetic.                             *) 
    7.46 +(* ========================================================================= *) 
    7.47 +exception COOPER;
    7.48 +
    7.49 +(* ------------------------------------------------------------------------- *) 
    7.50 +(* Lift operations up to numerals.                                           *) 
    7.51 +(* ------------------------------------------------------------------------- *) 
    7.52 + 
    7.53 +(*Assumption : The construction of atomar formulas in linearl arithmetic is based on 
    7.54 +relation operations of Type : [int,int]---> bool *) 
    7.55 + 
    7.56 +(* ------------------------------------------------------------------------- *) 
    7.57 + 
    7.58 + 
    7.59 +(*Function is_arith_rel returns true if and only if the term is an atomar presburger 
    7.60 +formula *) 
    7.61 +fun is_arith_rel tm = case tm of 
    7.62 +	 Const(p,Type ("fun",[Type ("Numeral.bin", []),Type ("fun",[Type ("Numeral.bin", 
    7.63 +	 []),Type ("bool",[])] )])) $ _ $_ => true 
    7.64 +	|Const(p,Type ("fun",[Type ("IntDef.int", []),Type ("fun",[Type ("IntDef.int", 
    7.65 +	 []),Type ("bool",[])] )])) $ _ $_ => true 
    7.66 +	|_ => false; 
    7.67 + 
    7.68 +(*Function is_arith_rel returns true if and only if the term is an operation of the 
    7.69 +form [int,int]---> int*) 
    7.70 + 
    7.71 +(*Transform a natural number to a term*) 
    7.72 + 
    7.73 +fun mk_numeral 0 = Const("0",HOLogic.intT)
    7.74 +   |mk_numeral 1 = Const("1",HOLogic.intT)
    7.75 +   |mk_numeral n = (HOLogic.number_of_const HOLogic.intT) $ (HOLogic.mk_bin n); 
    7.76 + 
    7.77 +(*Transform an Term to an natural number*)	  
    7.78 +	  
    7.79 +fun dest_numeral (Const("0",Type ("IntDef.int", []))) = 0
    7.80 +   |dest_numeral (Const("1",Type ("IntDef.int", []))) = 1
    7.81 +   |dest_numeral (Const ("Numeral.number_of",_) $ n)= HOLogic.dest_binum n; 
    7.82 +(*Some terms often used for pattern matching*) 
    7.83 + 
    7.84 +val zero = mk_numeral 0; 
    7.85 +val one = mk_numeral 1; 
    7.86 + 
    7.87 +(*Tests if a Term is representing a number*) 
    7.88 + 
    7.89 +fun is_numeral t = (t = zero) orelse (t = one) orelse (can dest_numeral t); 
    7.90 + 
    7.91 +(*maps a unary natural function on a term containing an natural number*) 
    7.92 + 
    7.93 +fun numeral1 f n = mk_numeral (f(dest_numeral n)); 
    7.94 + 
    7.95 +(*maps a binary natural function on 2 term containing  natural numbers*) 
    7.96 + 
    7.97 +fun numeral2 f m n = mk_numeral(f(dest_numeral m) (dest_numeral n)); 
    7.98 + 
    7.99 +(* ------------------------------------------------------------------------- *) 
   7.100 +(* Operations on canonical linear terms c1 * x1 + ... + cn * xn + k          *) 
   7.101 +(*                                                                           *) 
   7.102 +(* Note that we're quite strict: the ci must be present even if 1            *) 
   7.103 +(* (but if 0 we expect the monomial to be omitted) and k must be there       *) 
   7.104 +(* even if it's zero. Thus, it's a constant iff not an addition term.        *) 
   7.105 +(* ------------------------------------------------------------------------- *) 
   7.106 + 
   7.107 + 
   7.108 +fun linear_cmul n tm =  if n = 0 then zero else let fun times n k = n*k in  
   7.109 +  ( case tm of  
   7.110 +     (Const("op +",T)  $  (Const ("op *",T1 ) $c1 $  x1) $ rest) => 
   7.111 +       Const("op +",T) $ ((Const("op *",T1) $ (numeral1 (times n) c1) $ x1)) $ (linear_cmul n rest) 
   7.112 +    |_ =>  numeral1 (times n) tm) 
   7.113 +    end ; 
   7.114 + 
   7.115 + 
   7.116 + 
   7.117 + 
   7.118 +(* Whether the first of two items comes earlier in the list  *) 
   7.119 +fun earlier [] x y = false 
   7.120 +	|earlier (h::t) x y =if h = y then false 
   7.121 +              else if h = x then true 
   7.122 +              	else earlier t x y ; 
   7.123 + 
   7.124 +fun earlierv vars (Bound i) (Bound j) = i < j 
   7.125 +   |earlierv vars (Bound _) _ = true 
   7.126 +   |earlierv vars _ (Bound _)  = false 
   7.127 +   |earlierv vars (Free (x,_)) (Free (y,_)) = earlier vars x y; 
   7.128 + 
   7.129 + 
   7.130 +fun linear_add vars tm1 tm2 = 
   7.131 +  let fun addwith x y = x + y in
   7.132 + (case (tm1,tm2) of 
   7.133 +	((Const ("op +",T1) $ ( Const("op *",T2) $ c1 $  x1) $ rest1),(Const 
   7.134 +	("op +",T3)$( Const("op *",T4) $ c2 $  x2) $ rest2)) => 
   7.135 +         if x1 = x2 then 
   7.136 +              let val c = (numeral2 (addwith) c1 c2) 
   7.137 +	      in 
   7.138 +              if c = zero then (linear_add vars rest1  rest2)  
   7.139 +	      else (Const("op +",T1) $ (Const("op *",T2) $ c $ x1) $ (linear_add vars  rest1 rest2)) 
   7.140 +              end 
   7.141 +	   else 
   7.142 +		if earlierv vars x1 x2 then (Const("op +",T1) $  
   7.143 +		(Const("op *",T2)$ c1 $ x1) $ (linear_add vars rest1 tm2)) 
   7.144 +    	       else (Const("op +",T1) $ (Const("op *",T2) $ c2 $ x2) $ (linear_add vars tm1 rest2)) 
   7.145 +   	|((Const("op +",T1) $ (Const("op *",T2) $ c1 $ x1) $ rest1) ,_) => 
   7.146 +    	  (Const("op +",T1)$ (Const("op *",T2) $ c1 $ x1) $ (linear_add vars 
   7.147 +	  rest1 tm2)) 
   7.148 +   	|(_, (Const("op +",T1) $(Const("op *",T2) $ c2 $ x2) $ rest2)) => 
   7.149 +      	  (Const("op +",T1) $ (Const("op *",T2) $ c2 $ x2) $ (linear_add vars tm1 
   7.150 +	  rest2)) 
   7.151 +   	| (_,_) => numeral2 (addwith) tm1 tm2) 
   7.152 +	 
   7.153 +	end; 
   7.154 + 
   7.155 +(*To obtain the unary - applyed on a formula*) 
   7.156 + 
   7.157 +fun linear_neg tm = linear_cmul (0 - 1) tm; 
   7.158 + 
   7.159 +(*Substraction of two terms *) 
   7.160 + 
   7.161 +fun linear_sub vars tm1 tm2 = linear_add vars tm1 (linear_neg tm2); 
   7.162 + 
   7.163 + 
   7.164 +(* ------------------------------------------------------------------------- *) 
   7.165 +(* Linearize a term.                                                         *) 
   7.166 +(* ------------------------------------------------------------------------- *) 
   7.167 + 
   7.168 +(* linearises a term from the point of view of Variable Free (x,T). 
   7.169 +After this fuction the all expressions containig ths variable will have the form  
   7.170 + c*Free(x,T) + t where c is a constant ant t is a Term which is not containing 
   7.171 + Free(x,T)*) 
   7.172 +  
   7.173 +fun lint vars tm = if is_numeral tm then tm else case tm of 
   7.174 +   (Free (x,T)) =>  (HOLogic.mk_binop "op +" ((HOLogic.mk_binop "op *" ((mk_numeral 1),Free (x,T))), zero)) 
   7.175 +  |(Bound i) =>  (Const("op +",HOLogic.intT -->HOLogic.intT -->HOLogic.intT) $ 
   7.176 +  (Const("op *",HOLogic.intT -->HOLogic.intT -->HOLogic.intT) $ (mk_numeral 1) $ (Bound i)) $ zero) 
   7.177 +  |(Const("uminus",_) $ t ) => (linear_neg (lint vars t)) 
   7.178 +  |(Const("op +",_) $ s $ t) => (linear_add vars (lint vars s) (lint vars t)) 
   7.179 +  |(Const("op -",_) $ s $ t) => (linear_sub vars (lint vars s) (lint vars t)) 
   7.180 +  |(Const ("op *",_) $ s $ t) => 
   7.181 +        let val s' = lint vars s  
   7.182 +            val t' = lint vars t  
   7.183 +        in 
   7.184 +        if is_numeral s' then (linear_cmul (dest_numeral s') t') 
   7.185 +        else if is_numeral t' then (linear_cmul (dest_numeral t') s') 
   7.186 + 
   7.187 +         else (warning "lint: apparent nonlinearity"; raise COOPER)
   7.188 +         end 
   7.189 +  |_ =>   error "lint: unknown term"; 
   7.190 +   
   7.191 + 
   7.192 + 
   7.193 +(* ------------------------------------------------------------------------- *) 
   7.194 +(* Linearize the atoms in a formula, and eliminate non-strict inequalities.  *) 
   7.195 +(* ------------------------------------------------------------------------- *) 
   7.196 + 
   7.197 +fun mkatom vars p t = Const(p,HOLogic.intT --> HOLogic.intT --> HOLogic.boolT) $ zero $ (lint vars t); 
   7.198 + 
   7.199 +fun linform vars (Const ("Divides.op dvd",_) $ c $ t) =  
   7.200 +      let val c' = (mk_numeral(abs(dest_numeral c)))  
   7.201 +      in (HOLogic.mk_binrel "Divides.op dvd" (c,lint vars t)) 
   7.202 +      end 
   7.203 +  |linform vars  (Const("op =",Type ("fun",[Type ("IntDef.int", []),_])) $ s $ t ) = (mkatom vars "op =" (Const ("op -",HOLogic.intT --> HOLogic.intT --> HOLogic.intT) $ t $ s) ) 
   7.204 +  |linform vars  (Const("op <",_)$ s $t ) = (mkatom vars "op <" (Const ("op -",HOLogic.intT --> HOLogic.intT --> HOLogic.intT) $ t $ s))
   7.205 +  |linform vars  (Const("op >",_) $ s $ t ) = (mkatom vars "op <" (Const ("op -",HOLogic.intT --> HOLogic.intT --> HOLogic.intT) $ s $ t)) 
   7.206 +  |linform vars  (Const("op <=",_)$ s $ t ) = 
   7.207 +        (mkatom vars "op <" (Const ("op -",HOLogic.intT --> HOLogic.intT --> HOLogic.intT) $ (Const("op +",HOLogic.intT --> HOLogic.intT --> HOLogic.intT) $t $(mk_numeral 1)) $ s)) 
   7.208 +  |linform vars  (Const("op >=",_)$ s $ t ) = 
   7.209 +        (mkatom vars "op <" (Const ("op -",HOLogic.intT --> HOLogic.intT --> 
   7.210 +	HOLogic.intT) $ (Const("op +",HOLogic.intT --> HOLogic.intT --> 
   7.211 +	HOLogic.intT) $s $(mk_numeral 1)) $ t)) 
   7.212 + 
   7.213 +   |linform vars  fm =  fm; 
   7.214 + 
   7.215 +(* ------------------------------------------------------------------------- *) 
   7.216 +(* Post-NNF transformation eliminating negated inequalities.                 *) 
   7.217 +(* ------------------------------------------------------------------------- *) 
   7.218 + 
   7.219 +fun posineq fm = case fm of  
   7.220 + (Const ("Not",_)$(Const("op <",_)$ c $ t)) =>
   7.221 +   (HOLogic.mk_binrel "op <"  (zero , (linear_sub [] (mk_numeral 1) (linear_add [] c t ) ))) 
   7.222 +  | ( Const ("op &",_) $ p $ q)  => HOLogic.mk_conj (posineq p,posineq q)
   7.223 +  | ( Const ("op |",_) $ p $ q ) => HOLogic.mk_disj (posineq p,posineq q)
   7.224 +  | _ => fm; 
   7.225 +  
   7.226 +
   7.227 +(* ------------------------------------------------------------------------- *) 
   7.228 +(* Find the LCM of the coefficients of x.                                    *) 
   7.229 +(* ------------------------------------------------------------------------- *) 
   7.230 +(*gcd calculates gcd (a,b) and helps lcm_num calculating lcm (a,b)*) 
   7.231 + 
   7.232 +fun gcd a b = if a=0 then b else gcd (b mod a) a ; 
   7.233 +fun lcm_num a b = (abs a*b) div (gcd (abs a) (abs b)); 
   7.234 + 
   7.235 +fun formlcm x fm = case fm of 
   7.236 +    (Const (p,_)$ _ $(Const ("op +", _)$(Const ("op *",_)$ c $ y ) $z ) ) =>  if 
   7.237 +    (is_arith_rel fm) andalso (x = y) then abs(dest_numeral c) else 1 
   7.238 +  | ( Const ("Not", _) $p) => formlcm x p 
   7.239 +  | ( Const ("op &",_) $ p $ q) => lcm_num (formlcm x p) (formlcm x q) 
   7.240 +  | ( Const ("op |",_) $ p $ q )=> lcm_num (formlcm x p) (formlcm x q) 
   7.241 +  |  _ => 1; 
   7.242 + 
   7.243 +(* ------------------------------------------------------------------------- *) 
   7.244 +(* Adjust all coefficients of x in formula; fold in reduction to +/- 1.      *) 
   7.245 +(* ------------------------------------------------------------------------- *) 
   7.246 + 
   7.247 +fun adjustcoeff x l fm = 
   7.248 +     case fm of  
   7.249 +      (Const(p,_) $d $( Const ("op +", _)$(Const ("op *",_) $ 
   7.250 +      c $ y ) $z )) => if (is_arith_rel fm) andalso (x = y) then  
   7.251 +        let val m = l div (dest_numeral c) 
   7.252 +            val n = (if p = "op <" then abs(m) else m) 
   7.253 +            val xtm = HOLogic.mk_binop "op *" ((mk_numeral (m div n)), x) 
   7.254 +	in
   7.255 +        (HOLogic.mk_binrel p ((linear_cmul n d),(HOLogic.mk_binop "op +" ( xtm ,( linear_cmul n z) )))) 
   7.256 +	end 
   7.257 +	else fm 
   7.258 +  |( Const ("Not", _) $ p) => HOLogic.Not $ (adjustcoeff x l p) 
   7.259 +  |( Const ("op &",_) $ p $ q) => HOLogic.conj$(adjustcoeff x l p) $(adjustcoeff x l q) 
   7.260 +  |( Const ("op |",_) $ p $ q) => HOLogic.disj $(adjustcoeff x l p)$ (adjustcoeff x l q) 
   7.261 +  |_ => fm; 
   7.262 + 
   7.263 +(* ------------------------------------------------------------------------- *) 
   7.264 +(* Hence make coefficient of x one in existential formula.                   *) 
   7.265 +(* ------------------------------------------------------------------------- *) 
   7.266 + 
   7.267 +fun unitycoeff x fm = 
   7.268 +  let val l = formlcm x fm 
   7.269 +      val fm' = adjustcoeff x l fm in
   7.270 +     if l = 1 then fm' else 
   7.271 +     let val xp = (HOLogic.mk_binop "op +"  
   7.272 +     		((HOLogic.mk_binop "op *" ((mk_numeral 1), x )), zero)) in 
   7.273 +      HOLogic.conj $(HOLogic.mk_binrel "Divides.op dvd" ((mk_numeral l) , xp )) $ (adjustcoeff x l fm) 
   7.274 +      end 
   7.275 +  end; 
   7.276 + 
   7.277 +(* adjustcoeffeq l fm adjusts the coeffitients c_i of x  overall in fm to l*)
   7.278 +(* Here l must be a multiple of all c_i otherwise the obtained formula is not equivalent*)
   7.279 +(*
   7.280 +fun adjustcoeffeq x l fm = 
   7.281 +    case fm of  
   7.282 +      (Const(p,_) $d $( Const ("op +", _)$(Const ("op *",_) $ 
   7.283 +      c $ y ) $z )) => if (is_arith_rel fm) andalso (x = y) then  
   7.284 +        let val m = l div (dest_numeral c) 
   7.285 +            val n = (if p = "op <" then abs(m) else m)  
   7.286 +            val xtm = (HOLogic.mk_binop "op *" ((mk_numeral ((m div n)*l) ), x))
   7.287 +            in (HOLogic.mk_binrel p ((linear_cmul n d),(HOLogic.mk_binop "op +" ( xtm ,( linear_cmul n z) )))) 
   7.288 +	    end 
   7.289 +	else fm 
   7.290 +  |( Const ("Not", _) $ p) => HOLogic.Not $ (adjustcoeffeq x l p) 
   7.291 +  |( Const ("op &",_) $ p $ q) => HOLogic.conj$(adjustcoeffeq x l p) $(adjustcoeffeq x l q) 
   7.292 +  |( Const ("op |",_) $ p $ q) => HOLogic.disj $(adjustcoeffeq x l p)$ (adjustcoeffeq x l q) 
   7.293 +  |_ => fm;
   7.294 + 
   7.295 +
   7.296 +*)
   7.297 +
   7.298 +(* ------------------------------------------------------------------------- *) 
   7.299 +(* The "minus infinity" version.                                             *) 
   7.300 +(* ------------------------------------------------------------------------- *) 
   7.301 + 
   7.302 +fun minusinf x fm = case fm of  
   7.303 +    (Const("op =",Type ("fun",[Type ("IntDef.int", []),_])) $ (c1 ) $(Const ("op +", _) $(Const ("op *",_) $ c2 $ y) $z)) => 
   7.304 +  	 if (is_arith_rel fm) andalso (x=y) andalso (c2 = one) andalso (c1 =zero) then HOLogic.false_const  
   7.305 +	 				 else fm 
   7.306 + 
   7.307 +  |(Const("op <",_) $ c $(Const ("op +", _) $(Const ("op *",_) $ pm1 $ y ) $ z 
   7.308 +  )) => 
   7.309 +        if (x =y) andalso (pm1 = one) andalso (c = zero) then HOLogic.false_const else HOLogic.true_const 
   7.310 +	 
   7.311 +  |(Const ("Not", _) $ p) => HOLogic.Not $ (minusinf x p) 
   7.312 +  |(Const ("op &",_) $ p $ q) => HOLogic.conj $ (minusinf x p) $ (minusinf x q) 
   7.313 +  |(Const ("op |",_) $ p $ q) => HOLogic.disj $ (minusinf x p) $ (minusinf x q) 
   7.314 +  |_ => fm; 
   7.315 +
   7.316 +(* ------------------------------------------------------------------------- *)
   7.317 +(* The "Plus infinity" version.                                             *)
   7.318 +(* ------------------------------------------------------------------------- *)
   7.319 +
   7.320 +fun plusinf x fm = case fm of
   7.321 +    (Const("op =",Type ("fun",[Type ("IntDef.int", []),_])) $ (c1 ) $(Const ("op +", _) $(Const ("op *",_) $ c2 $ y) $z)) =>
   7.322 +  	 if (is_arith_rel fm) andalso (x=y) andalso (c2 = one) andalso (c1 =zero) then HOLogic.false_const
   7.323 +	 				 else fm
   7.324 +
   7.325 +  |(Const("op <",_) $ c $(Const ("op +", _) $(Const ("op *",_) $ pm1 $ y ) $ z
   7.326 +  )) =>
   7.327 +        if (x =y) andalso (pm1 = one) andalso (c = zero) then HOLogic.true_const else HOLogic.false_const
   7.328 +
   7.329 +  |(Const ("Not", _) $ p) => HOLogic.Not $ (plusinf x p)
   7.330 +  |(Const ("op &",_) $ p $ q) => HOLogic.conj $ (plusinf x p) $ (plusinf x q)
   7.331 +  |(Const ("op |",_) $ p $ q) => HOLogic.disj $ (plusinf x p) $ (plusinf x q)
   7.332 +  |_ => fm;
   7.333 + 
   7.334 +(* ------------------------------------------------------------------------- *) 
   7.335 +(* The LCM of all the divisors that involve x.                               *) 
   7.336 +(* ------------------------------------------------------------------------- *) 
   7.337 + 
   7.338 +fun divlcm x (Const("Divides.op dvd",_)$ d $ (Const ("op +",_) $ (Const ("op *",_) $ c $ y ) $ z ) ) =  
   7.339 +        if x = y then abs(dest_numeral d) else 1 
   7.340 +  |divlcm x ( Const ("Not", _) $ p) = divlcm x p 
   7.341 +  |divlcm x ( Const ("op &",_) $ p $ q) = lcm_num (divlcm x p) (divlcm x q) 
   7.342 +  |divlcm x ( Const ("op |",_) $ p $ q ) = lcm_num (divlcm x p) (divlcm x q) 
   7.343 +  |divlcm x  _ = 1; 
   7.344 + 
   7.345 +(* ------------------------------------------------------------------------- *) 
   7.346 +(* Construct the B-set.                                                      *) 
   7.347 +(* ------------------------------------------------------------------------- *) 
   7.348 + 
   7.349 +fun bset x fm = case fm of 
   7.350 +   (Const ("Not", _) $ p) => if (is_arith_rel p) then  
   7.351 +          (case p of  
   7.352 +	      (Const("op =",Type ("fun",[Type ("IntDef.int", []),_])) $ c1 $ (Const ("op +", _) $(Const ("op *",_) $c2 $y) $a ) )  
   7.353 +	             => if (is_arith_rel p) andalso (x=	y) andalso (c2 = one) andalso (c1 = zero)  
   7.354 +	                then [linear_neg a] 
   7.355 +			else  bset x p 
   7.356 +   	  |_ =>[]) 
   7.357 +			 
   7.358 +			else bset x p 
   7.359 +  |(Const ("op =",Type ("fun",[Type ("IntDef.int", []),_])) $ c1 $ (Const ("op +",_) $ (Const ("op *",_) $c2 $ x) $ a)) =>  if (c1 =zero) andalso (c2 = one) then [linear_neg(linear_add [] a (mk_numeral 1))]  else [] 
   7.360 +  |(Const ("op <",_) $ c1$ (Const ("op +",_) $(Const ("op *",_)$ c2 $ x) $ a)) => if (c1 =zero) andalso (c2 = one) then [linear_neg a] else [] 
   7.361 +  |(Const ("op &",_) $ p $ q) => (bset x p) union (bset x q) 
   7.362 +  |(Const ("op |",_) $ p $ q) => (bset x p) union (bset x q) 
   7.363 +  |_ => []; 
   7.364 + 
   7.365 +(* ------------------------------------------------------------------------- *)
   7.366 +(* Construct the A-set.                                                      *)
   7.367 +(* ------------------------------------------------------------------------- *)
   7.368 +
   7.369 +fun aset x fm = case fm of
   7.370 +   (Const ("Not", _) $ p) => if (is_arith_rel p) then
   7.371 +          (case p of
   7.372 +	      (Const("op =",Type ("fun",[Type ("IntDef.int", []),_])) $ c1 $ (Const ("op +", _) $(Const ("op *",_) $c2 $y) $a ) )
   7.373 +	             => if (x=	y) andalso (c2 = one) andalso (c1 = zero)
   7.374 +	                then [linear_neg a]
   7.375 +			else  []
   7.376 +   	  |_ =>[])
   7.377 +
   7.378 +			else aset x p
   7.379 +  |(Const ("op =",Type ("fun",[Type ("IntDef.int", []),_])) $ c1 $ (Const ("op +",_) $ (Const ("op *",_) $c2 $ x) $ a)) =>  if (c1 =zero) andalso (c2 = one) then [linear_sub [] (mk_numeral 1) a]  else []
   7.380 +  |(Const ("op <",_) $ c1$ (Const ("op +",_) $(Const ("op *",_)$ c2 $ x) $ a)) => if (c1 =zero) andalso (c2 = (mk_numeral (~1))) then [a] else []
   7.381 +  |(Const ("op &",_) $ p $ q) => (aset x p) union (aset x q)
   7.382 +  |(Const ("op |",_) $ p $ q) => (aset x p) union (aset x q)
   7.383 +  |_ => [];
   7.384 +
   7.385 +
   7.386 +(* ------------------------------------------------------------------------- *) 
   7.387 +(* Replace top variable with another linear form, retaining canonicality.    *) 
   7.388 +(* ------------------------------------------------------------------------- *) 
   7.389 + 
   7.390 +fun linrep vars x t fm = case fm of  
   7.391 +   ((Const(p,_)$ d $ (Const("op +",_)$(Const("op *",_)$ c $ y) $ z))) => 
   7.392 +      if (x = y) andalso (is_arith_rel fm)  
   7.393 +      then  
   7.394 +        let val ct = linear_cmul (dest_numeral c) t  
   7.395 +	in (HOLogic.mk_binrel p (d, linear_add vars ct z)) 
   7.396 +	end 
   7.397 +	else fm 
   7.398 +  |(Const ("Not", _) $ p) => HOLogic.Not $ (linrep vars x t p) 
   7.399 +  |(Const ("op &",_) $ p $ q) => HOLogic.conj $ (linrep vars x t p) $ (linrep vars x t q) 
   7.400 +  |(Const ("op |",_) $ p $ q) => HOLogic.disj $ (linrep vars x t p) $ (linrep vars x t q) 
   7.401 +  |_ => fm; 
   7.402 + 
   7.403 +(* ------------------------------------------------------------------------- *) 
   7.404 +(* Evaluation of constant expressions.                                       *) 
   7.405 +(* ------------------------------------------------------------------------- *) 
   7.406 + 
   7.407 +val operations = 
   7.408 +  [("op =",op=), ("op <",op<), ("op >",op>), ("op <=",op<=) , ("op >=",op>=), 
   7.409 +   ("Divides.op dvd",fn (x,y) =>((y mod x) = 0))]; 
   7.410 + 
   7.411 +fun applyoperation (Some f) (a,b) = f (a, b) 
   7.412 +    |applyoperation _ (_, _) = false; 
   7.413 + 
   7.414 +(*Evaluation of constant atomic formulas*) 
   7.415 + 
   7.416 +fun evalc_atom at = case at of  
   7.417 +      (Const (p,_) $ s $ t) =>(  
   7.418 +         case assoc (operations,p) of 
   7.419 +             Some f => ((if (f ((dest_numeral s),(dest_numeral t))) then HOLogic.true_const else HOLogic.false_const)  
   7.420 +              handle _ => at) 
   7.421 +             | _ =>  at) 
   7.422 +     |Const("Not",_)$(Const (p,_) $ s $ t) =>(  
   7.423 +         case assoc (operations,p) of 
   7.424 +             Some f => ((if (f ((dest_numeral s),(dest_numeral t))) then 
   7.425 +	     HOLogic.false_const else HOLogic.true_const)  
   7.426 +              handle _ => at) 
   7.427 +             | _ =>  at) 
   7.428 +     | _ =>  at; 
   7.429 + 
   7.430 +(*Function onatoms apllys function f on the atomic formulas involved in a.*) 
   7.431 + 
   7.432 +fun onatoms f a = if (is_arith_rel a) then f a else case a of 
   7.433 + 
   7.434 +  	(Const ("Not",_) $ p) => if is_arith_rel p then HOLogic.Not $ (f p) 
   7.435 +				 
   7.436 +				else HOLogic.Not $ (onatoms f p) 
   7.437 +  	|(Const ("op &",_) $ p $ q) => HOLogic.conj $ (onatoms f p) $ (onatoms f q) 
   7.438 +  	|(Const ("op |",_) $ p $ q) => HOLogic.disj $ (onatoms f p) $ (onatoms f q) 
   7.439 +  	|(Const ("op -->",_) $ p $ q) => HOLogic.imp $ (onatoms f p) $ (onatoms f q) 
   7.440 +  	|((Const ("op =", Type ("fun",[Type ("bool", []),_]))) $ p $ q) => (Const ("op =", [HOLogic.boolT, HOLogic.boolT] ---> HOLogic.boolT)) $ (onatoms f p) $ (onatoms f q) 
   7.441 +  	|(Const("All",_) $ Abs(x,T,p)) => Const("All", [HOLogic.intT --> 
   7.442 +	HOLogic.boolT] ---> HOLogic.boolT)$ Abs (x ,T, (onatoms f p)) 
   7.443 +  	|(Const("Ex",_) $ Abs(x,T,p)) => Const("Ex", [HOLogic.intT --> HOLogic.boolT]---> HOLogic.boolT) $ Abs( x ,T, (onatoms f p)) 
   7.444 +  	|_ => a; 
   7.445 + 
   7.446 +val evalc = onatoms evalc_atom; 
   7.447 + 
   7.448 +(* ------------------------------------------------------------------------- *) 
   7.449 +(* Hence overall quantifier elimination.                                     *) 
   7.450 +(* ------------------------------------------------------------------------- *) 
   7.451 + 
   7.452 +(*Applyes a function iteratively on the list*) 
   7.453 + 
   7.454 +fun end_itlist f []     = error "end_itlist" 
   7.455 +   |end_itlist f [x]    = x 
   7.456 +   |end_itlist f (h::t) = f h (end_itlist f t); 
   7.457 + 
   7.458 + 
   7.459 +(*list_disj[conj] makes a disj[conj] of a given list. used with conjucts or disjuncts 
   7.460 +it liearises iterated conj[disj]unctions. *) 
   7.461 + 
   7.462 +fun disj_help p q = HOLogic.disj $ p $ q ; 
   7.463 + 
   7.464 +fun list_disj l = 
   7.465 +  if l = [] then HOLogic.false_const else end_itlist disj_help l; 
   7.466 +   
   7.467 +fun conj_help p q = HOLogic.conj $ p $ q ; 
   7.468 + 
   7.469 +fun list_conj l = 
   7.470 +  if l = [] then HOLogic.true_const else end_itlist conj_help l; 
   7.471 +   
   7.472 +(*Simplification of Formulas *) 
   7.473 + 
   7.474 +(*Function q_bnd_chk checks if a quantified Formula makes sens : Means if in 
   7.475 +the body of the existential quantifier there are bound variables to the 
   7.476 +existential quantifier.*) 
   7.477 + 
   7.478 +fun has_bound fm =let fun has_boundh fm i = case fm of 
   7.479 +		 Bound n => (i = n) 
   7.480 +		 |Abs (_,_,p) => has_boundh p (i+1) 
   7.481 +		 |t1 $ t2 => (has_boundh t1 i) orelse (has_boundh t2 i) 
   7.482 +		 |_ =>false
   7.483 +
   7.484 +in  case fm of 
   7.485 +	Bound _ => true 
   7.486 +       |Abs (_,_,p) => has_boundh p 0 
   7.487 +       |t1 $ t2 => (has_bound t1 ) orelse (has_bound t2 ) 
   7.488 +       |_ =>false
   7.489 +end;
   7.490 + 
   7.491 +(*has_sub_abs checks if in a given Formula there are subformulas which are quantifed 
   7.492 +too. Is no used no more.*) 
   7.493 + 
   7.494 +fun has_sub_abs fm = case fm of  
   7.495 +		 Abs (_,_,_) => true 
   7.496 +		 |t1 $ t2 => (has_bound t1 ) orelse (has_bound t2 ) 
   7.497 +		 |_ =>false ; 
   7.498 +		  
   7.499 +(*update_bounds called with i=0 udates the numeration of bounded variables because the 
   7.500 +formula will not be quantified any more.*) 
   7.501 + 
   7.502 +fun update_bounds fm i = case fm of 
   7.503 +		 Bound n => if n >= i then Bound (n-1) else fm 
   7.504 +		 |Abs (x,T,p) => Abs(x,T,(update_bounds p (i+1))) 
   7.505 +		 |t1 $ t2 => (update_bounds t1 i) $ (update_bounds t2 i) 
   7.506 +		 |_ => fm ; 
   7.507 + 
   7.508 +(*psimpl : Simplification of propositions (general purpose)*) 
   7.509 +fun psimpl1 fm = case fm of 
   7.510 +    Const("Not",_) $ Const ("False",_) => HOLogic.true_const 
   7.511 +  | Const("Not",_) $ Const ("True",_) => HOLogic.false_const 
   7.512 +  | Const("op &",_) $ Const ("False",_) $ q => HOLogic.false_const 
   7.513 +  | Const("op &",_) $ p $ Const ("False",_)  => HOLogic.false_const 
   7.514 +  | Const("op &",_) $ Const ("True",_) $ q => q 
   7.515 +  | Const("op &",_) $ p $ Const ("True",_) => p 
   7.516 +  | Const("op |",_) $ Const ("False",_) $ q => q 
   7.517 +  | Const("op |",_) $ p $ Const ("False",_)  => p 
   7.518 +  | Const("op |",_) $ Const ("True",_) $ q => HOLogic.true_const 
   7.519 +  | Const("op |",_) $ p $ Const ("True",_)  => HOLogic.true_const 
   7.520 +  | Const("op -->",_) $ Const ("False",_) $ q => HOLogic.true_const 
   7.521 +  | Const("op -->",_) $ Const ("True",_) $  q => q 
   7.522 +  | Const("op -->",_) $ p $ Const ("True",_)  => HOLogic.true_const 
   7.523 +  | Const("op -->",_) $ p $ Const ("False",_)  => HOLogic.Not $  p 
   7.524 +  | Const("op =", Type ("fun",[Type ("bool", []),_])) $ Const ("True",_) $ q => q 
   7.525 +  | Const("op =", Type ("fun",[Type ("bool", []),_])) $ p $ Const ("True",_) => p 
   7.526 +  | Const("op =", Type ("fun",[Type ("bool", []),_])) $ Const ("False",_) $ q => HOLogic.Not $  q 
   7.527 +  | Const("op =", Type ("fun",[Type ("bool", []),_])) $ p $ Const ("False",_)  => HOLogic.Not $  p 
   7.528 +  | _ => fm; 
   7.529 + 
   7.530 +fun psimpl fm = case fm of 
   7.531 +   Const ("Not",_) $ p => psimpl1 (HOLogic.Not $ (psimpl p)) 
   7.532 +  | Const("op &",_) $ p $ q => psimpl1 (HOLogic.mk_conj (psimpl p,psimpl q)) 
   7.533 +  | Const("op |",_) $ p $ q => psimpl1 (HOLogic.mk_disj (psimpl p,psimpl q)) 
   7.534 +  | Const("op -->",_) $ p $ q => psimpl1 (HOLogic.mk_imp(psimpl p,psimpl q)) 
   7.535 +  | Const("op =", Type ("fun",[Type ("bool", []),_])) $ p $ q => psimpl1 (HOLogic.mk_eq(psimpl p,psimpl q)) 
   7.536 +  | _ => fm; 
   7.537 + 
   7.538 + 
   7.539 +(*simpl : Simplification of Terms involving quantifiers too. 
   7.540 + This function is able to drop out some quantified expressions where there are no 
   7.541 + bound varaibles.*) 
   7.542 +  
   7.543 +fun simpl1 fm  = 
   7.544 +  case fm of 
   7.545 +    Const("All",_) $Abs(x,_,p) => if (has_bound fm ) then fm  
   7.546 +    				else (update_bounds p 0) 
   7.547 +  | Const("Ex",_) $ Abs (x,_,p) => if has_bound fm then fm  
   7.548 +    				else (update_bounds p 0) 
   7.549 +  | _ => psimpl1 fm; 
   7.550 + 
   7.551 +fun simpl fm = case fm of 
   7.552 +    Const ("Not",_) $ p => simpl1 (HOLogic.Not $(simpl p))  
   7.553 +  | Const ("op &",_) $ p $ q => simpl1 (HOLogic.mk_conj (simpl p ,simpl q))  
   7.554 +  | Const ("op |",_) $ p $ q => simpl1 (HOLogic.mk_disj (simpl p ,simpl q ))  
   7.555 +  | Const ("op -->",_) $ p $ q => simpl1 (HOLogic.mk_imp(simpl p ,simpl q ))  
   7.556 +  | Const("op =", Type ("fun",[Type ("bool", []),_]))$ p $ q => simpl1 
   7.557 +  (HOLogic.mk_eq(simpl p ,simpl q ))  
   7.558 +  | Const ("All",Ta) $ Abs(Vn,VT,p) => simpl1(Const("All",Ta) $ 
   7.559 +  Abs(Vn,VT,simpl p ))  
   7.560 +  | Const ("Ex",Ta)  $ Abs(Vn,VT,p) => simpl1(Const("Ex",Ta)  $ 
   7.561 +  Abs(Vn,VT,simpl p ))  
   7.562 +  | _ => fm; 
   7.563 + 
   7.564 +(* ------------------------------------------------------------------------- *) 
   7.565 + 
   7.566 +(* Puts fm into NNF*) 
   7.567 + 
   7.568 +fun  nnf fm = if (is_arith_rel fm) then fm  
   7.569 +else (case fm of 
   7.570 +  ( Const ("op &",_) $ p $ q)  => HOLogic.conj $ (nnf p) $(nnf q) 
   7.571 +  | (Const("op |",_) $ p $q) => HOLogic.disj $ (nnf p)$(nnf q) 
   7.572 +  | (Const ("op -->",_)  $ p $ q) => HOLogic.disj $ (nnf (HOLogic.Not $ p)) $ (nnf q) 
   7.573 +  | ((Const ("op =", Type ("fun",[Type ("bool", []),_]))) $ p $ q) =>(HOLogic.disj $ (HOLogic.conj $ (nnf p) $ (nnf q)) $ (HOLogic.conj $ (nnf (HOLogic.Not $ p) ) $ (nnf(HOLogic.Not $ q)))) 
   7.574 +  | (Const ("Not",_)) $ ((Const ("Not",_)) $ p) => (nnf p) 
   7.575 +  | (Const ("Not",_)) $ (( Const ("op &",_)) $ p $ q) =>HOLogic.disj $ (nnf(HOLogic.Not $ p)) $ (nnf(HOLogic.Not $q)) 
   7.576 +  | (Const ("Not",_)) $ (( Const ("op |",_)) $ p $ q) =>HOLogic.conj $ (nnf(HOLogic.Not $ p)) $ (nnf(HOLogic.Not $ q)) 
   7.577 +  | (Const ("Not",_)) $ (( Const ("op -->",_)) $ p $ q ) =>HOLogic.conj $ (nnf p) $(nnf(HOLogic.Not $ q)) 
   7.578 +  | (Const ("Not",_)) $ ((Const ("op =", Type ("fun",[Type ("bool", []),_]))) $ p $ q ) =>(HOLogic.disj $ (HOLogic.conj $(nnf p) $ (nnf(HOLogic.Not $ q))) $ (HOLogic.conj $(nnf(HOLogic.Not $ p)) $ (nnf q))) 
   7.579 +  | _ => fm); 
   7.580 + 
   7.581 + 
   7.582 +(* Function remred to remove redundancy in a list while keeping the order of appearance of the 
   7.583 +elements. but VERY INEFFICIENT!! *) 
   7.584 + 
   7.585 +fun remred1 el [] = [] 
   7.586 +    |remred1 el (h::t) = if el=h then (remred1 el t) else h::(remred1 el t); 
   7.587 +     
   7.588 +fun remred [] = [] 
   7.589 +    |remred (x::l) =  x::(remred1 x (remred l)); 
   7.590 + 
   7.591 +(*Makes sure that all free Variables are of the type integer but this function is only 
   7.592 +used temporarily, this job must be done by the parser later on.*) 
   7.593 + 
   7.594 +fun mk_uni_vars T  (node $ rest) = (case node of 
   7.595 +    Free (name,_) => Free (name,T) $ (mk_uni_vars T rest) 
   7.596 +    |_=> (mk_uni_vars T node) $ (mk_uni_vars T rest )  ) 
   7.597 +    |mk_uni_vars T (Free (v,_)) = Free (v,T) 
   7.598 +    |mk_uni_vars T tm = tm; 
   7.599 + 
   7.600 +fun mk_uni_int T (Const ("0",T2)) = if T = T2 then (mk_numeral 0) else (Const ("0",T2)) 
   7.601 +    |mk_uni_int T (Const ("1",T2)) = if T = T2 then (mk_numeral 1) else (Const ("1",T2)) 
   7.602 +    |mk_uni_int T (node $ rest) = (mk_uni_int T node) $ (mk_uni_int T rest )  
   7.603 +    |mk_uni_int T (Abs(AV,AT,p)) = Abs(AV,AT,mk_uni_int T p) 
   7.604 +    |mk_uni_int T tm = tm; 
   7.605 + 
   7.606 +
   7.607 +(* Minusinfinity Version*) 
   7.608 +fun coopermi vars1 fm = 
   7.609 +  case fm of 
   7.610 +   Const ("Ex",_) $ Abs(x0,T,p0) => let 
   7.611 +    val (xn,p1) = variant_abs (x0,T,p0) 
   7.612 +    val x = Free (xn,T)  
   7.613 +    val vars = (xn::vars1) 
   7.614 +    val p = unitycoeff x  (posineq (simpl p1))
   7.615 +    val p_inf = simpl (minusinf x p) 
   7.616 +    val bset = bset x p 
   7.617 +    val js = 1 upto divlcm x p  
   7.618 +    fun p_element j b = linrep vars x (linear_add vars b (mk_numeral j)) p  
   7.619 +    fun stage j = list_disj (linrep vars x (mk_numeral j) p_inf :: map (p_element j) bset)  
   7.620 +   in (list_disj (map stage js))
   7.621 +    end 
   7.622 +  | _ => error "cooper: not an existential formula"; 
   7.623 + 
   7.624 +
   7.625 +
   7.626 +(* The plusinfinity version of cooper*)
   7.627 +fun cooperpi vars1 fm =
   7.628 +  case fm of
   7.629 +   Const ("Ex",_) $ Abs(x0,T,p0) => let 
   7.630 +    val (xn,p1) = variant_abs (x0,T,p0)
   7.631 +    val x = Free (xn,T)
   7.632 +    val vars = (xn::vars1)
   7.633 +    val p = unitycoeff x  (posineq (simpl p1))
   7.634 +    val p_inf = simpl (plusinf x p)
   7.635 +    val aset = aset x p
   7.636 +    val js = 1 upto divlcm x p
   7.637 +    fun p_element j a = linrep vars x (linear_sub vars a (mk_numeral j)) p
   7.638 +    fun stage j = list_disj (linrep vars x (mk_numeral j) p_inf :: map (p_element j) aset)
   7.639 +   in (list_disj (map stage js))
   7.640 +   end
   7.641 +  | _ => error "cooper: not an existential formula";
   7.642 +  
   7.643 +
   7.644 +
   7.645 +(*Cooper main procedure*) 
   7.646 +  
   7.647 +fun cooper vars1 fm =
   7.648 +  case fm of
   7.649 +   Const ("Ex",_) $ Abs(x0,T,p0) => let 
   7.650 +    val (xn,p1) = variant_abs (x0,T,p0)
   7.651 +    val x = Free (xn,T)
   7.652 +    val vars = (xn::vars1)
   7.653 +    val p = unitycoeff x  (posineq (simpl p1))
   7.654 +    val ast = aset x p
   7.655 +    val bst = bset x p
   7.656 +    val js = 1 upto divlcm x p
   7.657 +    val (p_inf,f,S ) = 
   7.658 +    if (length bst) < (length ast) 
   7.659 +     then (minusinf x p,linear_add,bst)
   7.660 +     else (plusinf x p, linear_sub,ast)
   7.661 +    fun p_element j a = linrep vars x (f vars a (mk_numeral j)) p
   7.662 +    fun stage j = list_disj (linrep vars x (mk_numeral j) p_inf :: map (p_element j) S)
   7.663 +   in (list_disj (map stage js))
   7.664 +   end
   7.665 +  | _ => error "cooper: not an existential formula";
   7.666 +
   7.667 +
   7.668 +
   7.669 + 
   7.670 +(*Function itlist applys a double parametred function f : 'a->'b->b iteratively to a List l : 'a 
   7.671 +list With End condition b. ict calculates f(e1,f(f(e2,f(e3,...(...f(en,b))..))))) 
   7.672 + assuming l = [e1,e2,...,en]*) 
   7.673 + 
   7.674 +fun itlist f l b = case l of 
   7.675 +    [] => b 
   7.676 +  | (h::t) => f h (itlist f t b); 
   7.677 + 
   7.678 +(* ------------------------------------------------------------------------- *) 
   7.679 +(* Free variables in terms and formulas.	                             *) 
   7.680 +(* ------------------------------------------------------------------------- *) 
   7.681 + 
   7.682 +fun fvt tml = case tml of 
   7.683 +    [] => [] 
   7.684 +  | Free(x,_)::r => x::(fvt r) 
   7.685 + 
   7.686 +fun fv fm = fvt (term_frees fm); 
   7.687 + 
   7.688 + 
   7.689 +(* ========================================================================= *) 
   7.690 +(* Quantifier elimination.                                                   *) 
   7.691 +(* ========================================================================= *) 
   7.692 +(*conj[/disj]uncts lists iterated conj[disj]unctions*) 
   7.693 + 
   7.694 +fun disjuncts fm = case fm of 
   7.695 +    Const ("op |",_) $ p $ q => (disjuncts p) @ (disjuncts q) 
   7.696 +  | _ => [fm]; 
   7.697 + 
   7.698 +fun conjuncts fm = case fm of 
   7.699 +    Const ("op &",_) $p $ q => (conjuncts p) @ (conjuncts q) 
   7.700 +  | _ => [fm]; 
   7.701 + 
   7.702 + 
   7.703 + 
   7.704 +(* ------------------------------------------------------------------------- *) 
   7.705 +(* Lift procedure given literal modifier, formula normalizer & basic quelim. *) 
   7.706 +(* ------------------------------------------------------------------------- *) 
   7.707 +   
   7.708 +fun lift_qelim afn nfn qfn isat = 
   7.709 + let   fun qelim x vars p = 
   7.710 +  let val cjs = conjuncts p 
   7.711 +      val (ycjs,ncjs) = partition (has_bound) cjs in 
   7.712 +      (if ycjs = [] then p else 
   7.713 +                          let val q = (qfn vars ((HOLogic.exists_const HOLogic.intT 
   7.714 +			  ) $ Abs(x,HOLogic.intT,(list_conj ycjs)))) in 
   7.715 +                          (itlist conj_help ncjs q)  
   7.716 +			  end) 
   7.717 +       end 
   7.718 +    
   7.719 +  fun qelift vars fm = if (isat fm) then afn vars fm 
   7.720 +    else  
   7.721 +    case fm of 
   7.722 +      Const ("Not",_) $ p => HOLogic.Not $ (qelift vars p) 
   7.723 +    | Const ("op &",_) $ p $q => HOLogic.conj $ (qelift vars p) $ (qelift vars q) 
   7.724 +    | Const ("op |",_) $ p $ q => HOLogic.disj $ (qelift vars p) $ (qelift vars q) 
   7.725 +    | Const ("op -->",_) $ p $ q => HOLogic.imp $ (qelift vars p) $ (qelift vars q) 
   7.726 +    | Const ("op =",Type ("fun",[Type ("bool", []),_])) $ p $ q => HOLogic.mk_eq ((qelift vars p),(qelift vars q)) 
   7.727 +    | Const ("All",QT) $ Abs(x,T,p) => HOLogic.Not $(qelift vars (Const ("Ex",QT) $ Abs(x,T,(HOLogic.Not $ p)))) 
   7.728 +    | Const ("Ex",_) $ Abs (x,T,p)  => let  val djs = disjuncts(nfn(qelift (x::vars) p)) in 
   7.729 +    			list_disj(map (qelim x vars) djs) end 
   7.730 +    | _ => fm 
   7.731 + 
   7.732 +  in (fn fm => simpl(qelift (fv fm) fm)) 
   7.733 +  end; 
   7.734 + 
   7.735 + 
   7.736 +(* ------------------------------------------------------------------------- *) 
   7.737 +(* Cleverer (proposisional) NNF with conditional and literal modification.   *) 
   7.738 +(* ------------------------------------------------------------------------- *) 
   7.739 + 
   7.740 +(*Function Negate used by cnnf, negates a formula p*) 
   7.741 + 
   7.742 +fun negate (Const ("Not",_) $ p) = p 
   7.743 +    |negate p = (HOLogic.Not $ p); 
   7.744 + 
   7.745 +fun cnnf lfn = 
   7.746 +  let fun cnnfh fm = case  fm of 
   7.747 +      (Const ("op &",_) $ p $ q) => HOLogic.mk_conj(cnnfh p,cnnfh q) 
   7.748 +    | (Const ("op |",_) $ p $ q) => HOLogic.mk_disj(cnnfh p,cnnfh q) 
   7.749 +    | (Const ("op -->",_) $ p $q) => HOLogic.mk_disj(cnnfh(HOLogic.Not $ p),cnnfh q) 
   7.750 +    | (Const ("op =",Type ("fun",[Type ("bool", []),_])) $ p $ q) => HOLogic.mk_disj( 
   7.751 +    		HOLogic.mk_conj(cnnfh p,cnnfh q), 
   7.752 +		HOLogic.mk_conj(cnnfh(HOLogic.Not $ p),cnnfh(HOLogic.Not $q))) 
   7.753 +
   7.754 +    | (Const ("Not",_) $ (Const("Not",_) $ p)) => cnnfh p 
   7.755 +    | (Const ("Not",_) $ (Const ("op &",_) $ p $ q)) => HOLogic.mk_disj(cnnfh(HOLogic.Not $ p),cnnfh(HOLogic.Not $ q)) 
   7.756 +    | (Const ("Not",_) $(Const ("op |",_) $ (Const ("op &",_) $ p $ q) $  
   7.757 +    			(Const ("op &",_) $ p1 $ r))) => if p1 = negate p then 
   7.758 +		         HOLogic.mk_disj(  
   7.759 +			   cnnfh (HOLogic.mk_conj(p,cnnfh(HOLogic.Not $ q))), 
   7.760 +			   cnnfh (HOLogic.mk_conj(p1,cnnfh(HOLogic.Not $ r)))) 
   7.761 +			 else  HOLogic.mk_conj(
   7.762 +			  cnnfh (HOLogic.mk_disj(cnnfh (HOLogic.Not $ p),cnnfh(HOLogic.Not $ q))), 
   7.763 +			   cnnfh (HOLogic.mk_disj(cnnfh (HOLogic.Not $ p1),cnnfh(HOLogic.Not $ r)))
   7.764 +			 ) 
   7.765 +    | (Const ("Not",_) $ (Const ("op |",_) $ p $ q)) => HOLogic.mk_conj(cnnfh(HOLogic.Not $ p),cnnfh(HOLogic.Not $ q)) 
   7.766 +    | (Const ("Not",_) $ (Const ("op -->",_) $ p $q)) => HOLogic.mk_conj(cnnfh p,cnnfh(HOLogic.Not $ q)) 
   7.767 +    | (Const ("Not",_) $ (Const ("op =",Type ("fun",[Type ("bool", []),_]))  $ p $ q)) => HOLogic.mk_disj(HOLogic.mk_conj(cnnfh p,cnnfh(HOLogic.Not $ q)),HOLogic.mk_conj(cnnfh(HOLogic.Not $ p),cnnfh q)) 
   7.768 +    | _ => lfn fm  
   7.769 +  in cnnfh o simpl
   7.770 +  end; 
   7.771 + 
   7.772 +(*End- function the quantifierelimination an decion procedure of presburger formulas.*)   
   7.773 +val integer_qelim = simpl o evalc o (lift_qelim linform (simpl o (cnnf posineq o evalc)) cooper is_arith_rel) ; 
   7.774 +
   7.775 +end;
   7.776 + 
   7.777 \ No newline at end of file
     8.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     8.2 +++ b/src/HOL/Tools/Presburger/cooper_proof.ML	Tue Mar 25 09:47:05 2003 +0100
     8.3 @@ -0,0 +1,1488 @@
     8.4 +(*  Title:      HOL/Integ/cooper_proof.ML
     8.5 +    ID:         $Id$
     8.6 +    Author:     Amine Chaieb and Tobias Nipkow, TU Muenchen
     8.7 +    License:    GPL (GNU GENERAL PUBLIC LICENSE)
     8.8 +
     8.9 +File containing the implementation of the proof
    8.10 +generation for Cooper Algorithm
    8.11 +*)
    8.12 +
    8.13 +signature COOPER_PROOF =
    8.14 +sig
    8.15 +  val qe_Not : thm
    8.16 +  val qe_conjI : thm
    8.17 +  val qe_disjI : thm
    8.18 +  val qe_impI : thm
    8.19 +  val qe_eqI : thm
    8.20 +  val qe_exI : thm
    8.21 +  val qe_get_terms : thm -> term * term
    8.22 +  val cooper_prv : Sign.sg -> term -> term -> string list -> thm
    8.23 +  val proof_of_evalc : Sign.sg -> term -> thm
    8.24 +  val proof_of_cnnf : Sign.sg -> term -> (term -> thm) -> thm
    8.25 +  val proof_of_linform : Sign.sg -> string list -> term -> thm
    8.26 +end;
    8.27 +
    8.28 +structure CooperProof : COOPER_PROOF =
    8.29 +struct
    8.30 +
    8.31 +open CooperDec;
    8.32 +
    8.33 +(*-----------------------------------------------------------------*)
    8.34 +(*-----------------------------------------------------------------*)
    8.35 +(*-----------------------------------------------------------------*)
    8.36 +(*---                                                           ---*)
    8.37 +(*---                                                           ---*)
    8.38 +(*---         Protocoling part                                  ---*)
    8.39 +(*---                                                           ---*)
    8.40 +(*---           includes the protocolling datastructure         ---*)
    8.41 +(*---                                                           ---*)
    8.42 +(*---          and the protocolling fuctions                    ---*)
    8.43 +(*---                                                           ---*)
    8.44 +(*---                                                           ---*)
    8.45 +(*-----------------------------------------------------------------*)
    8.46 +(*-----------------------------------------------------------------*)
    8.47 +(*-----------------------------------------------------------------*)
    8.48 +
    8.49 +val presburger_ss = simpset_of (theory "Presburger")
    8.50 +  addsimps [zdiff_def] delsimps [symmetric zdiff_def];
    8.51 +val cboolT = ctyp_of (sign_of HOL.thy) HOLogic.boolT;
    8.52 +
    8.53 +(*Theorems that will be used later for the proofgeneration*)
    8.54 +
    8.55 +val zdvd_iff_zmod_eq_0 = thm "zdvd_iff_zmod_eq_0";
    8.56 +val unity_coeff_ex = thm "unity_coeff_ex";
    8.57 +
    8.58 +(* Thorems for proving the adjustment of the coeffitients*)
    8.59 +
    8.60 +val ac_lt_eq =  thm "ac_lt_eq";
    8.61 +val ac_eq_eq = thm "ac_eq_eq";
    8.62 +val ac_dvd_eq = thm "ac_dvd_eq";
    8.63 +val ac_pi_eq = thm "ac_pi_eq";
    8.64 +
    8.65 +(* The logical compination of the sythetised properties*)
    8.66 +val qe_Not = thm "qe_Not";
    8.67 +val qe_conjI = thm "qe_conjI";
    8.68 +val qe_disjI = thm "qe_disjI";
    8.69 +val qe_impI = thm "qe_impI";
    8.70 +val qe_eqI = thm "qe_eqI";
    8.71 +val qe_exI = thm "qe_exI";
    8.72 +val qe_ALLI = thm "qe_ALLI";
    8.73 +
    8.74 +(*Modulo D property for Pminusinf an Plusinf *)
    8.75 +val fm_modd_minf = thm "fm_modd_minf";
    8.76 +val not_dvd_modd_minf = thm "not_dvd_modd_minf";
    8.77 +val dvd_modd_minf = thm "dvd_modd_minf";
    8.78 +
    8.79 +val fm_modd_pinf = thm "fm_modd_pinf";
    8.80 +val not_dvd_modd_pinf = thm "not_dvd_modd_pinf";
    8.81 +val dvd_modd_pinf = thm "dvd_modd_pinf";
    8.82 +
    8.83 +(* the minusinfinity proprty*)
    8.84 +
    8.85 +val fm_eq_minf = thm "fm_eq_minf";
    8.86 +val neq_eq_minf = thm "neq_eq_minf";
    8.87 +val eq_eq_minf = thm "eq_eq_minf";
    8.88 +val le_eq_minf = thm "le_eq_minf";
    8.89 +val len_eq_minf = thm "len_eq_minf";
    8.90 +val not_dvd_eq_minf = thm "not_dvd_eq_minf";
    8.91 +val dvd_eq_minf = thm "dvd_eq_minf";
    8.92 +
    8.93 +(* the Plusinfinity proprty*)
    8.94 +
    8.95 +val fm_eq_pinf = thm "fm_eq_pinf";
    8.96 +val neq_eq_pinf = thm "neq_eq_pinf";
    8.97 +val eq_eq_pinf = thm "eq_eq_pinf";
    8.98 +val le_eq_pinf = thm "le_eq_pinf";
    8.99 +val len_eq_pinf = thm "len_eq_pinf";
   8.100 +val not_dvd_eq_pinf = thm "not_dvd_eq_pinf";
   8.101 +val dvd_eq_pinf = thm "dvd_eq_pinf";
   8.102 +
   8.103 +(*Logical construction of the Property*)
   8.104 +val eq_minf_conjI = thm "eq_minf_conjI";
   8.105 +val eq_minf_disjI = thm "eq_minf_disjI";
   8.106 +val modd_minf_disjI = thm "modd_minf_disjI";
   8.107 +val modd_minf_conjI = thm "modd_minf_conjI";
   8.108 +
   8.109 +val eq_pinf_conjI = thm "eq_pinf_conjI";
   8.110 +val eq_pinf_disjI = thm "eq_pinf_disjI";
   8.111 +val modd_pinf_disjI = thm "modd_pinf_disjI";
   8.112 +val modd_pinf_conjI = thm "modd_pinf_conjI";
   8.113 +
   8.114 +(*A/B - set Theorem *)
   8.115 +
   8.116 +val bst_thm = thm "bst_thm";
   8.117 +val ast_thm = thm "ast_thm";
   8.118 +
   8.119 +(*Cooper Backwards...*)
   8.120 +(*Bset*)
   8.121 +val not_bst_p_fm = thm "not_bst_p_fm";
   8.122 +val not_bst_p_ne = thm "not_bst_p_ne";
   8.123 +val not_bst_p_eq = thm "not_bst_p_eq";
   8.124 +val not_bst_p_gt = thm "not_bst_p_gt";
   8.125 +val not_bst_p_lt = thm "not_bst_p_lt";
   8.126 +val not_bst_p_ndvd = thm "not_bst_p_ndvd";
   8.127 +val not_bst_p_dvd = thm "not_bst_p_dvd";
   8.128 +
   8.129 +(*Aset*)
   8.130 +val not_ast_p_fm = thm "not_ast_p_fm";
   8.131 +val not_ast_p_ne = thm "not_ast_p_ne";
   8.132 +val not_ast_p_eq = thm "not_ast_p_eq";
   8.133 +val not_ast_p_gt = thm "not_ast_p_gt";
   8.134 +val not_ast_p_lt = thm "not_ast_p_lt";
   8.135 +val not_ast_p_ndvd = thm "not_ast_p_ndvd";
   8.136 +val not_ast_p_dvd = thm "not_ast_p_dvd";
   8.137 +
   8.138 +(*Logical construction of the prop*)
   8.139 +(*Bset*)
   8.140 +val not_bst_p_conjI = thm "not_bst_p_conjI";
   8.141 +val not_bst_p_disjI = thm "not_bst_p_disjI";
   8.142 +val not_bst_p_Q_elim = thm "not_bst_p_Q_elim";
   8.143 +
   8.144 +(*Aset*)
   8.145 +val not_ast_p_conjI = thm "not_ast_p_conjI";
   8.146 +val not_ast_p_disjI = thm "not_ast_p_disjI";
   8.147 +val not_ast_p_Q_elim = thm "not_ast_p_Q_elim";
   8.148 +
   8.149 +(*Cooper*)
   8.150 +val cppi_eq = thm "cppi_eq";
   8.151 +val cpmi_eq = thm "cpmi_eq";
   8.152 +
   8.153 +(*Others*)
   8.154 +val simp_from_to = thm "simp_from_to";
   8.155 +val P_eqtrue = thm "P_eqtrue";
   8.156 +val P_eqfalse = thm "P_eqfalse";
   8.157 +
   8.158 +(*For Proving NNF*)
   8.159 +
   8.160 +val nnf_nn = thm "nnf_nn";
   8.161 +val nnf_im = thm "nnf_im";
   8.162 +val nnf_eq = thm "nnf_eq";
   8.163 +val nnf_sdj = thm "nnf_sdj";
   8.164 +val nnf_ncj = thm "nnf_ncj";
   8.165 +val nnf_nim = thm "nnf_nim";
   8.166 +val nnf_neq = thm "nnf_neq";
   8.167 +val nnf_ndj = thm "nnf_ndj";
   8.168 +
   8.169 +(*For Proving term linearizition*)
   8.170 +val linearize_dvd = thm "linearize_dvd";
   8.171 +val lf_lt = thm "lf_lt";
   8.172 +val lf_eq = thm "lf_eq";
   8.173 +val lf_dvd = thm "lf_dvd";
   8.174 +
   8.175 +
   8.176 +
   8.177 +(* ------------------------------------------------------------------------- *)
   8.178 +(*Datatatype declarations for Proofprotocol for the cooperprocedure.*)
   8.179 +(* ------------------------------------------------------------------------- *)
   8.180 +
   8.181 +
   8.182 +
   8.183 +(* ------------------------------------------------------------------------- *)
   8.184 +(*Datatatype declarations for Proofprotocol for the adjustcoeff step.*)
   8.185 +(* ------------------------------------------------------------------------- *)
   8.186 +datatype CpLog = No
   8.187 +                |Simp of term*CpLog
   8.188 +		|Blast of CpLog*CpLog
   8.189 +		|Aset of (term*term*(term list)*term)
   8.190 +		|Bset of (term*term*(term list)*term)
   8.191 +		|Minusinf of CpLog*CpLog
   8.192 +		|Cooper of term*CpLog*CpLog*CpLog
   8.193 +		|Eq_minf of term*term
   8.194 +		|Modd_minf of term*term
   8.195 +		|Eq_minf_conjI of CpLog*CpLog
   8.196 +		|Modd_minf_conjI of CpLog*CpLog	
   8.197 +		|Modd_minf_disjI of CpLog*CpLog
   8.198 +		|Eq_minf_disjI of CpLog*CpLog	
   8.199 +		|Not_bst_p of term*term*term*term*CpLog
   8.200 +		|Not_bst_p_atomic of term
   8.201 +		|Not_bst_p_conjI of CpLog*CpLog
   8.202 +		|Not_bst_p_disjI of CpLog*CpLog
   8.203 +		|Not_ast_p of term*term*term*term*CpLog
   8.204 +		|Not_ast_p_atomic of term
   8.205 +		|Not_ast_p_conjI of CpLog*CpLog
   8.206 +		|Not_ast_p_disjI of CpLog*CpLog
   8.207 +		|CpLogError;
   8.208 +
   8.209 +
   8.210 +
   8.211 +datatype ACLog = ACAt of int*term
   8.212 +                |ACPI of int*term
   8.213 +                |ACfm of term
   8.214 +                |ACNeg of ACLog
   8.215 +		|ACConst of string*ACLog*ACLog;
   8.216 +
   8.217 +
   8.218 +
   8.219 +(* ------------------------------------------------------------------------- *)
   8.220 +(*Datatatype declarations for Proofprotocol for the CNNF step.*)
   8.221 +(* ------------------------------------------------------------------------- *)
   8.222 +
   8.223 +
   8.224 +datatype NNFLog = NNFAt of term
   8.225 +                |NNFSimp of NNFLog
   8.226 +                |NNFNN of NNFLog
   8.227 +		|NNFConst of string*NNFLog*NNFLog;
   8.228 +
   8.229 +(* ------------------------------------------------------------------------- *)
   8.230 +(*Datatatype declarations for Proofprotocol for the linform  step.*)
   8.231 +(* ------------------------------------------------------------------------- *)
   8.232 +
   8.233 +
   8.234 +datatype LfLog = LfAt of term
   8.235 +                |LfAtdvd of term
   8.236 +                |Lffm of term
   8.237 +                |LfConst of string*LfLog*LfLog
   8.238 +		|LfNot of LfLog
   8.239 +		|LfQ of string*string*typ*LfLog;
   8.240 +
   8.241 +
   8.242 +(* ------------------------------------------------------------------------- *)
   8.243 +(*Datatatype declarations for Proofprotocol for the evaluation- evalc-  step.*)
   8.244 +(* ------------------------------------------------------------------------- *)
   8.245 +
   8.246 +
   8.247 +datatype EvalLog = EvalAt of term
   8.248 +                |Evalfm of term
   8.249 +		|EvalConst of string*EvalLog*EvalLog;
   8.250 +
   8.251 +(* ------------------------------------------------------------------------- *)
   8.252 +(*This function norm_zero_one  replaces the occurences of Numeral1 and Numeral0*)
   8.253 +(*Respectively by their abstract representation Const("1",..) and COnst("0",..)*)
   8.254 +(*this is necessary because the theorems use this representation.*)
   8.255 +(* This function should be elminated in next versions...*)
   8.256 +(* ------------------------------------------------------------------------- *)
   8.257 +
   8.258 +fun norm_zero_one fm = case fm of
   8.259 +  (Const ("op *",_) $ c $ t) => 
   8.260 +    if c = one then (norm_zero_one t)
   8.261 +    else if (dest_numeral c = ~1) 
   8.262 +         then (Const("uminus",HOLogic.intT --> HOLogic.intT) $ (norm_zero_one t))
   8.263 +         else (HOLogic.mk_binop "op *" (norm_zero_one c,norm_zero_one t))
   8.264 +  |(node $ rest) => ((norm_zero_one node)$(norm_zero_one rest))
   8.265 +  |(Abs(x,T,p)) => (Abs(x,T,(norm_zero_one p)))
   8.266 +  |_ => fm;
   8.267 +
   8.268 +
   8.269 +(* ------------------------------------------------------------------------- *)
   8.270 +(* Intended to tell that here we changed the structure of the formula with respect to the posineq theorem : ~(0 < t) = 0 < 1-t*)
   8.271 +(* ------------------------------------------------------------------------- *)
   8.272 +fun adjustcoeffeq_wp  x l fm = 
   8.273 +    case fm of  
   8.274 +  (Const("Not",_)$(Const("op <",_) $(Const("0",_)) $(rt as (Const ("op +", _)$(Const ("op *",_) $    c $ y ) $z )))) => 
   8.275 +  if (x = y) 
   8.276 +  then let  
   8.277 +       val m = l div (dest_numeral c) 
   8.278 +       val n = abs (m)
   8.279 +       val xtm = (HOLogic.mk_binop "op *" ((mk_numeral ((m div n)*l) ), x)) 
   8.280 +       val rs = (HOLogic.mk_binrel "op <" (zero,linear_sub [] one (HOLogic.mk_binop "op +" ( xtm ,( linear_cmul n z) )))) 
   8.281 +       in (ACPI(n,fm),rs)
   8.282 +       end
   8.283 +  else  let val rs = (HOLogic.mk_binrel "op <" (zero,linear_sub [] one rt )) 
   8.284 +        in (ACPI(1,fm),rs)
   8.285 +        end
   8.286 +
   8.287 +  |(Const(p,_) $d $( Const ("op +", _)$(Const ("op *",_) $ 
   8.288 +      c $ y ) $z )) => if (is_arith_rel fm) andalso (x = y) then  
   8.289 +        let val m = l div (dest_numeral c) 
   8.290 +           val n = (if p = "op <" then abs(m) else m)  
   8.291 +           val xtm = (HOLogic.mk_binop "op *" ((mk_numeral ((m div n)*l) ), x))
   8.292 +           val rs = (HOLogic.mk_binrel p ((linear_cmul n d),(HOLogic.mk_binop "op +" ( xtm ,( linear_cmul n z) )))) 
   8.293 +	   in (ACAt(n,fm),rs)
   8.294 +	   end
   8.295 +        else (ACfm(fm),fm) 
   8.296 +  |( Const ("Not", _) $ p) => let val (rsp,rsr) = adjustcoeffeq_wp x l p 
   8.297 +                              in (ACNeg(rsp),HOLogic.Not $ rsr) 
   8.298 +                              end
   8.299 +  |( Const ("op &",_) $ p $ q) =>let val (rspp,rspr) = adjustcoeffeq_wp x l p
   8.300 +                                     val (rsqp,rsqr) = adjustcoeffeq_wp x l q
   8.301 +
   8.302 +                                  in (ACConst ("CJ",rspp,rsqp), HOLogic.mk_conj (rspr,rsqr)) 
   8.303 +                                  end 
   8.304 +  |( Const ("op |",_) $ p $ q) =>let val (rspp,rspr) = adjustcoeffeq_wp x l p
   8.305 +                                     val (rsqp,rsqr) = adjustcoeffeq_wp x l q
   8.306 +
   8.307 +                                  in (ACConst ("DJ",rspp,rsqp), HOLogic.mk_disj (rspr,rsqr)) 
   8.308 +                                  end
   8.309 +
   8.310 +  |_ => (ACfm(fm),fm);
   8.311 +
   8.312 +
   8.313 +(*_________________________________________*)
   8.314 +(*-----------------------------------------*)
   8.315 +(* Protocol generation for the liform step *)
   8.316 +(*_________________________________________*)
   8.317 +(*-----------------------------------------*)
   8.318 +
   8.319 +
   8.320 +fun linform_wp fm = 
   8.321 +  let fun at_linform_wp at =
   8.322 +    case at of
   8.323 +      (Const("op <=",_)$s$t) => LfAt(at)
   8.324 +      |(Const("op <",_)$s$t) => LfAt(at)
   8.325 +      |(Const("op =",_)$s$t) => LfAt(at)
   8.326 +      |(Const("Divides.op dvd",_)$s$t) => LfAtdvd(at)
   8.327 +  in
   8.328 +  if is_arith_rel fm 
   8.329 +  then at_linform_wp fm 
   8.330 +  else case fm of
   8.331 +    (Const("Not",_) $ A) => LfNot(linform_wp A)
   8.332 +   |(Const("op &",_)$ A $ B) => LfConst("CJ",linform_wp A, linform_wp B)
   8.333 +   |(Const("op |",_)$ A $ B) => LfConst("DJ",linform_wp A, linform_wp B)
   8.334 +   |(Const("op -->",_)$ A $ B) => LfConst("IM",linform_wp A, linform_wp B)
   8.335 +   |(Const("op =",Type ("fun",[Type ("bool", []),_]))$ A $ B) => LfConst("EQ",linform_wp A, linform_wp B)
   8.336 +   |Const("Ex",_)$Abs(x,T,p) => 
   8.337 +     let val (xn,p1) = variant_abs(x,T,p)
   8.338 +     in LfQ("Ex",xn,T,linform_wp p1)
   8.339 +     end 
   8.340 +   |Const("All",_)$Abs(x,T,p) => 
   8.341 +     let val (xn,p1) = variant_abs(x,T,p)
   8.342 +     in LfQ("All",xn,T,linform_wp p1)
   8.343 +     end 
   8.344 +end;
   8.345 +
   8.346 +
   8.347 +(* ------------------------------------------------------------------------- *)
   8.348 +(*For simlified formulas we just notice the original formula, for whitch we habe been
   8.349 +intendes to make the proof.*)
   8.350 +(* ------------------------------------------------------------------------- *)
   8.351 +fun simpl_wp (fm,pr) = let val fm2 = simpl fm
   8.352 +				in (fm2,Simp(fm,pr))
   8.353 +				end;
   8.354 +
   8.355 +	
   8.356 +(* ------------------------------------------------------------------------- *)
   8.357 +(*Help function for the generation of the proof EX.P_{minus \infty} --> EX. P(x) *)
   8.358 +(* ------------------------------------------------------------------------- *)
   8.359 +fun minusinf_wph x fm = let fun mk_atomar_minusinf_proof x fm = (Modd_minf(x,fm),Eq_minf(x,fm))
   8.360 +  
   8.361 +	      fun combine_minusinf_proofs opr (ppr1,ppr2) (qpr1,qpr2) = case opr of 
   8.362 +		 "CJ" => (Modd_minf_conjI(ppr1,qpr1),Eq_minf_conjI(ppr2,qpr2))
   8.363 +		|"DJ" => (Modd_minf_disjI(ppr1,qpr1),Eq_minf_disjI(ppr2,qpr2))
   8.364 +	in 
   8.365 + 
   8.366 + case fm of 
   8.367 + (Const ("Not", _) $  (Const("op =",Type ("fun",[Type ("IntDef.int", []),_])) $ c1 $ (Const ("op +", _) $(Const ("op *",_) $ c2 $ y) $z))) => 
   8.368 +     if (x=y) andalso (c1= zero) andalso (c2= one) then (HOLogic.true_const ,(mk_atomar_minusinf_proof x fm))
   8.369 +        else (fm ,(mk_atomar_minusinf_proof x fm))
   8.370 + |(Const("op =",Type ("fun",[Type ("IntDef.int", []),_])) $ c1 $(Const ("op +", _) $(Const ("op *",_) $ c2 $ y) $z)) =>
   8.371 +  	 if (is_arith_rel fm) andalso (x=y) andalso (c1= zero) andalso (c2= one)
   8.372 +	 then (HOLogic.false_const ,(mk_atomar_minusinf_proof x fm))
   8.373 +	 				 else (fm,(mk_atomar_minusinf_proof x fm)) 
   8.374 + |(Const("op <",_) $ c1 $(Const ("op +", _) $(Const ("op *",_) $ c2 $ y ) $ z )) =>
   8.375 +       if (y=x) andalso (c1 = zero) then 
   8.376 +        if c2 = one then (HOLogic.false_const,(mk_atomar_minusinf_proof x fm)) else
   8.377 +	(HOLogic.true_const,(mk_atomar_minusinf_proof x fm))
   8.378 +	else (fm,(mk_atomar_minusinf_proof x fm))
   8.379 +  
   8.380 +  |(Const("Not",_)$(Const ("Divides.op dvd",_) $_ )) => (fm,mk_atomar_minusinf_proof x fm)
   8.381 +  
   8.382 +  |(Const ("Divides.op dvd",_) $_ ) => (fm,mk_atomar_minusinf_proof x fm)
   8.383 +  
   8.384 +  |(Const ("op &",_) $ p $ q) => let val (pfm,ppr) = minusinf_wph x p
   8.385 +  				    val (qfm,qpr) = minusinf_wph x q
   8.386 +				    val pr = (combine_minusinf_proofs "CJ" ppr qpr)
   8.387 +				     in 
   8.388 +				     (HOLogic.conj $ pfm $qfm , pr)
   8.389 +				     end 
   8.390 +  |(Const ("op |",_) $ p $ q) => let val (pfm,ppr) = minusinf_wph x p
   8.391 +  				     val (qfm,qpr) = minusinf_wph x q
   8.392 +				     val pr = (combine_minusinf_proofs "DJ" ppr qpr)
   8.393 +				     in 
   8.394 +				     (HOLogic.disj $ pfm $qfm , pr)
   8.395 +				     end 
   8.396 +
   8.397 +  |_ => (fm,(mk_atomar_minusinf_proof x fm))
   8.398 +  
   8.399 +  end;					 
   8.400 +(* ------------------------------------------------------------------------- *)	    (* Protokol for the Proof of the property of the minusinfinity formula*)
   8.401 +(* Just combines the to protokols *)
   8.402 +(* ------------------------------------------------------------------------- *)
   8.403 +fun minusinf_wp x fm  = let val (fm2,pr) = (minusinf_wph x fm)
   8.404 +                       in (fm2,Minusinf(pr))
   8.405 +                        end;
   8.406 +
   8.407 +(* ------------------------------------------------------------------------- *)
   8.408 +(*Help function for the generation of the proof EX.P_{plus \infty} --> EX. P(x) *)
   8.409 +(* ------------------------------------------------------------------------- *)
   8.410 +
   8.411 +fun plusinf_wph x fm = let fun mk_atomar_plusinf_proof x fm = (Modd_minf(x,fm),Eq_minf(x,fm))
   8.412 +  
   8.413 +	      fun combine_plusinf_proofs opr (ppr1,ppr2) (qpr1,qpr2) = case opr of 
   8.414 +		 "CJ" => (Modd_minf_conjI(ppr1,qpr1),Eq_minf_conjI(ppr2,qpr2))
   8.415 +		|"DJ" => (Modd_minf_disjI(ppr1,qpr1),Eq_minf_disjI(ppr2,qpr2))
   8.416 +	in 
   8.417 + 
   8.418 + case fm of 
   8.419 + (Const ("Not", _) $  (Const("op =",Type ("fun",[Type ("IntDef.int", []),_])) $ c1 $ (Const ("op +", _) $(Const ("op *",_) $ c2 $ y) $z))) => 
   8.420 +     if (x=y) andalso (c1= zero) andalso (c2= one) then (HOLogic.true_const ,(mk_atomar_plusinf_proof x fm))
   8.421 +        else (fm ,(mk_atomar_plusinf_proof x fm))
   8.422 + |(Const("op =",Type ("fun",[Type ("IntDef.int", []),_])) $ c1 $(Const ("op +", _) $(Const ("op *",_) $ c2 $ y) $z)) =>
   8.423 +  	 if (is_arith_rel fm) andalso (x=y) andalso (c1= zero) andalso (c2= one)
   8.424 +	 then (HOLogic.false_const ,(mk_atomar_plusinf_proof x fm))
   8.425 +	 				 else (fm,(mk_atomar_plusinf_proof x fm)) 
   8.426 + |(Const("op <",_) $ c1 $(Const ("op +", _) $(Const ("op *",_) $ c2 $ y ) $ z )) =>
   8.427 +       if (y=x) andalso (c1 = zero) then 
   8.428 +        if c2 = one then (HOLogic.true_const,(mk_atomar_plusinf_proof x fm)) else
   8.429 +	(HOLogic.false_const,(mk_atomar_plusinf_proof x fm))
   8.430 +	else (fm,(mk_atomar_plusinf_proof x fm))
   8.431 +  
   8.432 +  |(Const("Not",_)$(Const ("Divides.op dvd",_) $_ )) => (fm,mk_atomar_plusinf_proof x fm)
   8.433 +  
   8.434 +  |(Const ("Divides.op dvd",_) $_ ) => (fm,mk_atomar_plusinf_proof x fm)
   8.435 +  
   8.436 +  |(Const ("op &",_) $ p $ q) => let val (pfm,ppr) = plusinf_wph x p
   8.437 +  				    val (qfm,qpr) = plusinf_wph x q
   8.438 +				    val pr = (combine_plusinf_proofs "CJ" ppr qpr)
   8.439 +				     in 
   8.440 +				     (HOLogic.conj $ pfm $qfm , pr)
   8.441 +				     end 
   8.442 +  |(Const ("op |",_) $ p $ q) => let val (pfm,ppr) = plusinf_wph x p
   8.443 +  				     val (qfm,qpr) = plusinf_wph x q
   8.444 +				     val pr = (combine_plusinf_proofs "DJ" ppr qpr)
   8.445 +				     in 
   8.446 +				     (HOLogic.disj $ pfm $qfm , pr)
   8.447 +				     end 
   8.448 +
   8.449 +  |_ => (fm,(mk_atomar_plusinf_proof x fm))
   8.450 +  
   8.451 +  end;					 
   8.452 +(* ------------------------------------------------------------------------- *)	    (* Protokol for the Proof of the property of the minusinfinity formula*)
   8.453 +(* Just combines the to protokols *)
   8.454 +(* ------------------------------------------------------------------------- *)
   8.455 +fun plusinf_wp x fm  = let val (fm2,pr) = (plusinf_wph x fm)
   8.456 +                       in (fm2,Minusinf(pr))
   8.457 +                        end;
   8.458 +
   8.459 +
   8.460 +(* ------------------------------------------------------------------------- *)
   8.461 +(*Protocol that we here uses Bset.*)
   8.462 +(* ------------------------------------------------------------------------- *)
   8.463 +fun bset_wp x fm = let val bs = bset x fm in
   8.464 +				(bs,Bset(x,fm,bs,mk_numeral (divlcm x fm)))
   8.465 +				end;
   8.466 +
   8.467 +(* ------------------------------------------------------------------------- *)
   8.468 +(*Protocol that we here uses Aset.*)
   8.469 +(* ------------------------------------------------------------------------- *)
   8.470 +fun aset_wp x fm = let val ast = aset x fm in
   8.471 +				(ast,Aset(x,fm,ast,mk_numeral (divlcm x fm)))
   8.472 +				end;
   8.473 + 
   8.474 +
   8.475 +
   8.476 +(* ------------------------------------------------------------------------- *)
   8.477 +(*function list to Set, constructs a set containing all elements of a given list.*)
   8.478 +(* ------------------------------------------------------------------------- *)
   8.479 +fun list_to_set T1 l = let val T = (HOLogic.mk_setT T1) in 
   8.480 +	case l of 
   8.481 +		[] => Const ("{}",T)
   8.482 +		|(h::t) => Const("insert", T1 --> (T --> T)) $ h $(list_to_set T1 t)
   8.483 +		end;
   8.484 +		
   8.485 +
   8.486 +(*====================================================================*)
   8.487 +(* ------------------------------------------------------------------------- *)
   8.488 +(* ------------------------------------------------------------------------- *)
   8.489 +(*Protocol for the proof of the backward direction of the cooper theorem.*)
   8.490 +(* Helpfunction - Protokols evereything about the proof reconstruction*)
   8.491 +(* ------------------------------------------------------------------------- *)
   8.492 +fun not_bst_p_wph fm = case fm of
   8.493 +	Const("Not",_) $ R => if (is_arith_rel R) then (Not_bst_p_atomic (fm)) else CpLogError
   8.494 +	|Const("op &",_) $ ls $ rs => Not_bst_p_conjI((not_bst_p_wph ls),(not_bst_p_wph rs))
   8.495 +	|Const("op |",_) $ ls $ rs => Not_bst_p_disjI((not_bst_p_wph ls),(not_bst_p_wph rs))
   8.496 +	|_ => Not_bst_p_atomic (fm);
   8.497 +(* ------------------------------------------------------------------------- *)	
   8.498 +(* Main protocoling function for the backward direction gives the Bset and the divlcm and the Formula herself. Needed as inherited attributes for the proof reconstruction*)
   8.499 +(* ------------------------------------------------------------------------- *)
   8.500 +fun not_bst_p_wp x fm = let val prt = not_bst_p_wph fm
   8.501 +			    val D = mk_numeral (divlcm x fm)
   8.502 +			    val B = map norm_zero_one (bset x fm)
   8.503 +			in (Not_bst_p (x,fm,D,(list_to_set HOLogic.intT B) , prt))
   8.504 +			end;
   8.505 +(*====================================================================*)
   8.506 +(* ------------------------------------------------------------------------- *)
   8.507 +(* ------------------------------------------------------------------------- *)
   8.508 +(*Protocol for the proof of the backward direction of the cooper theorem.*)
   8.509 +(* Helpfunction - Protokols evereything about the proof reconstruction*)
   8.510 +(* ------------------------------------------------------------------------- *)
   8.511 +fun not_ast_p_wph fm = case fm of
   8.512 +	Const("Not",_) $ R => if (is_arith_rel R) then (Not_ast_p_atomic (fm)) else CpLogError
   8.513 +	|Const("op &",_) $ ls $ rs => Not_ast_p_conjI((not_ast_p_wph ls),(not_ast_p_wph rs))
   8.514 +	|Const("op |",_) $ ls $ rs => Not_ast_p_disjI((not_ast_p_wph ls),(not_ast_p_wph rs))
   8.515 +	|_ => Not_ast_p_atomic (fm);
   8.516 +(* ------------------------------------------------------------------------- *)	
   8.517 +(* Main protocoling function for the backward direction gives the Bset and the divlcm and the Formula herself. Needed as inherited attributes for the proof reconstruction*)
   8.518 +(* ------------------------------------------------------------------------- *)
   8.519 +fun not_ast_p_wp x fm = let val prt = not_ast_p_wph fm
   8.520 +			    val D = mk_numeral (divlcm x fm)
   8.521 +			    val B = map norm_zero_one (aset x fm)
   8.522 +			in (Not_ast_p (x,fm,D,(list_to_set HOLogic.intT B) , prt))
   8.523 +			end;
   8.524 +
   8.525 +(*======================================================*)
   8.526 +(* Protokolgeneration for the formula evaluation process*)
   8.527 +(*======================================================*)
   8.528 +
   8.529 +fun evalc_wp fm = 
   8.530 +  let fun evalc_atom_wp at =case at of  
   8.531 +    (Const (p,_) $ s $ t) =>(  
   8.532 +    case assoc (operations,p) of 
   8.533 +        Some f => ((if (f ((dest_numeral s),(dest_numeral t))) then EvalAt(HOLogic.mk_eq(at,HOLogic.true_const)) else EvalAt(HOLogic.mk_eq(at, HOLogic.false_const)))  
   8.534 +		   handle _ => Evalfm(at)) 
   8.535 +        | _ =>  Evalfm(at)) 
   8.536 +     |Const("Not",_)$(Const (p,_) $ s $ t) =>(  
   8.537 +       case assoc (operations,p) of 
   8.538 +         Some f => ((if (f ((dest_numeral s),(dest_numeral t))) then 
   8.539 +	  EvalAt(HOLogic.mk_eq(at, HOLogic.false_const))  else EvalAt(HOLogic.mk_eq(at,HOLogic.true_const)))  
   8.540 +		      handle _ => Evalfm(at)) 
   8.541 +         | _ => Evalfm(at)) 
   8.542 +     | _ => Evalfm(at)  
   8.543 + 
   8.544 +  in
   8.545 +   case fm of
   8.546 +    (Const("op &",_)$A$B) => EvalConst("CJ",evalc_wp A,evalc_wp B)
   8.547 +   |(Const("op |",_)$A$B) => EvalConst("DJ",evalc_wp A,evalc_wp B) 
   8.548 +   |(Const("op -->",_)$A$B) => EvalConst("IM",evalc_wp A,evalc_wp B) 
   8.549 +   |(Const("op =", Type ("fun",[Type ("bool", []),_]))$A$B) => EvalConst("EQ",evalc_wp A,evalc_wp B) 
   8.550 +   |_ => evalc_atom_wp fm
   8.551 +  end;
   8.552 +
   8.553 +
   8.554 +
   8.555 +(*======================================================*)
   8.556 +(* Protokolgeneration for the NNF Transformation        *)
   8.557 +(*======================================================*)
   8.558 +
   8.559 +fun cnnf_wp f = 
   8.560 +  let fun hcnnf_wp fm =
   8.561 +    case fm of
   8.562 +    (Const ("op &",_) $ p $ q) => NNFConst("CJ",hcnnf_wp p,hcnnf_wp q) 
   8.563 +    | (Const ("op |",_) $ p $ q) =>  NNFConst("DJ",hcnnf_wp p,hcnnf_wp q)
   8.564 +    | (Const ("op -->",_) $ p $q) => NNFConst("IM",hcnnf_wp (HOLogic.Not $ p),hcnnf_wp q)
   8.565 +    | (Const ("op =",Type ("fun",[Type ("bool", []),_])) $ p $ q) => NNFConst("EQ",hcnnf_wp (HOLogic.mk_conj(p,q)),hcnnf_wp (HOLogic.mk_conj((HOLogic.Not $ p), (HOLogic.Not $ q)))) 
   8.566 +
   8.567 +    | (Const ("Not",_) $ (Const("Not",_) $ p)) => NNFNN(hcnnf_wp p) 
   8.568 +    | (Const ("Not",_) $ (Const ("op &",_) $ p $ q)) => NNFConst ("NCJ",(hcnnf_wp(HOLogic.Not $ p)),(hcnnf_wp(HOLogic.Not $ q))) 
   8.569 +    | (Const ("Not",_) $(Const ("op |",_) $ (A as (Const ("op &",_) $ p $ q)) $  
   8.570 +    			(B as (Const ("op &",_) $ p1 $ r)))) => if p1 = negate p then 
   8.571 +		         NNFConst("SDJ",  
   8.572 +			   NNFConst("CJ",hcnnf_wp p,hcnnf_wp(HOLogic.Not $ q)),
   8.573 +			   NNFConst("CJ",hcnnf_wp p1,hcnnf_wp(HOLogic.Not $ r)))
   8.574 +			 else  NNFConst ("NDJ",(hcnnf_wp(HOLogic.Not $ A)),(hcnnf_wp(HOLogic.Not $ B))) 
   8.575 +
   8.576 +    | (Const ("Not",_) $ (Const ("op |",_) $ p $ q)) => NNFConst ("NDJ",(hcnnf_wp(HOLogic.Not $ p)),(hcnnf_wp(HOLogic.Not $ q))) 
   8.577 +    | (Const ("Not",_) $ (Const ("op -->",_) $ p $q)) =>  NNFConst ("NIM",(hcnnf_wp(p)),(hcnnf_wp(HOLogic.Not $ q))) 
   8.578 +    | (Const ("Not",_) $ (Const ("op =",Type ("fun",[Type ("bool", []),_]))  $ p $ q)) =>NNFConst ("NEQ",(NNFConst("CJ",hcnnf_wp p,hcnnf_wp(HOLogic.Not $ q))),(NNFConst("CJ",hcnnf_wp(HOLogic.Not $ p),hcnnf_wp q))) 
   8.579 +    | _ => NNFAt(fm)  
   8.580 +  in NNFSimp(hcnnf_wp f)
   8.581 +end; 
   8.582 +   
   8.583 +
   8.584 +
   8.585 +
   8.586 +
   8.587 +
   8.588 +(* ------------------------------------------------------------------------- *)
   8.589 +(*Cooper decision Procedure with proof protocoling*)
   8.590 +(* ------------------------------------------------------------------------- *)
   8.591 +
   8.592 +fun coopermi_wp vars fm =
   8.593 +  case fm of
   8.594 +   Const ("Ex",_) $ Abs(xo,T,po) => let 
   8.595 +    val (xn,np) = variant_abs(xo,T,po) 
   8.596 +    val x = (Free(xn , T))
   8.597 +    val p = np     (* Is this a legal proof for the P=NP Problem??*)
   8.598 +    val (p_inf,miprt) = simpl_wp (minusinf_wp x p)
   8.599 +    val (bset,bsprt) = bset_wp x p
   8.600 +    val nbst_p_prt = not_bst_p_wp x p
   8.601 +    val dlcm = divlcm x p 
   8.602 +    val js = 1 upto dlcm 
   8.603 +    fun p_element j b = linrep vars x (linear_add vars b (mk_numeral j)) p 
   8.604 +    fun stage j = list_disj (linrep vars x (mk_numeral j) p_inf :: map (p_element j) bset) 
   8.605 +   in (list_disj (map stage js),Cooper(mk_numeral dlcm,miprt,bsprt,nbst_p_prt))
   8.606 +   end
   8.607 +   
   8.608 +  | _ => (error "cooper: not an existential formula",No);
   8.609 +				
   8.610 +fun cooperpi_wp vars fm =
   8.611 +  case fm of
   8.612 +   Const ("Ex",_) $ Abs(xo,T,po) => let 
   8.613 +    val (xn,np) = variant_abs(xo,T,po) 
   8.614 +    val x = (Free(xn , T))
   8.615 +    val p = np     (* Is this a legal proof for the P=NP Problem??*)
   8.616 +    val (p_inf,piprt) = simpl_wp (plusinf_wp x p)
   8.617 +    val (aset,asprt) = aset_wp x p
   8.618 +    val nast_p_prt = not_ast_p_wp x p
   8.619 +    val dlcm = divlcm x p 
   8.620 +    val js = 1 upto dlcm 
   8.621 +    fun p_element j a = linrep vars x (linear_sub vars a (mk_numeral j)) p 
   8.622 +    fun stage j = list_disj (linrep vars x (mk_numeral j) p_inf :: map (p_element j) aset) 
   8.623 +   in (list_disj (map stage js),Cooper(mk_numeral dlcm,piprt,asprt,nast_p_prt))
   8.624 +   end
   8.625 +  | _ => (error "cooper: not an existential formula",No);
   8.626 +				
   8.627 +
   8.628 +
   8.629 +
   8.630 +
   8.631 +(*-----------------------------------------------------------------*)
   8.632 +(*-----------------------------------------------------------------*)
   8.633 +(*-----------------------------------------------------------------*)
   8.634 +(*---                                                           ---*)
   8.635 +(*---                                                           ---*)
   8.636 +(*---      Interpretation and Proofgeneration Part              ---*)
   8.637 +(*---                                                           ---*)
   8.638 +(*---      Protocole interpretation functions                   ---*)
   8.639 +(*---                                                           ---*)
   8.640 +(*---      and proofgeneration functions                        ---*)
   8.641 +(*---                                                           ---*)
   8.642 +(*---                                                           ---*)
   8.643 +(*---                                                           ---*)
   8.644 +(*---                                                           ---*)
   8.645 +(*-----------------------------------------------------------------*)
   8.646 +(*-----------------------------------------------------------------*)
   8.647 +(*-----------------------------------------------------------------*)
   8.648 +
   8.649 +(* ------------------------------------------------------------------------- *)
   8.650 +(* Returns both sides of an equvalence in the theorem*)
   8.651 +(* ------------------------------------------------------------------------- *)
   8.652 +fun qe_get_terms th = let val (_$(Const("op =",Type ("fun",[Type ("bool", []),_])) $ A $ B )) = prop_of th in (A,B) end;
   8.653 +
   8.654 +
   8.655 +(*-------------------------------------------------------------*)
   8.656 +(*-------------------------------------------------------------*)
   8.657 +(*-------------------------------------------------------------*)
   8.658 +(*-------------------------------------------------------------*)
   8.659 +
   8.660 +(* ------------------------------------------------------------------------- *)
   8.661 +(* Modified version of the simple version with minimal amount of checking and postprocessing*)
   8.662 +(* ------------------------------------------------------------------------- *)
   8.663 +
   8.664 +fun simple_prove_goal_cterm2 G tacs =
   8.665 +  let
   8.666 +    fun check None = error "prove_goal: tactic failed"
   8.667 +      | check (Some (thm, _)) = (case nprems_of thm of
   8.668 +            0 => thm
   8.669 +          | i => !result_error_fn thm (string_of_int i ^ " unsolved goals!"))
   8.670 +  in check (Seq.pull (EVERY tacs (trivial G))) end;
   8.671 +
   8.672 +(*-------------------------------------------------------------*)
   8.673 +(*-------------------------------------------------------------*)
   8.674 +(*-------------------------------------------------------------*)
   8.675 +(*-------------------------------------------------------------*)
   8.676 +(*-------------------------------------------------------------*)
   8.677 +
   8.678 +fun cert_Trueprop sg t = cterm_of sg (HOLogic.mk_Trueprop t);
   8.679 +
   8.680 +(* ------------------------------------------------------------------------- *)
   8.681 +(*This function proove elementar will be used to generate proofs at runtime*)
   8.682 +(*It is is based on the isabelle function proove_goalw_cterm and is thought to *)
   8.683 +(*prove properties such as a dvd b (essentially) that are only to make at
   8.684 +runtime.*)
   8.685 +(* ------------------------------------------------------------------------- *)
   8.686 +fun prove_elementar sg s fm2 = case s of 
   8.687 +  (*"ss" like simplification with simpset*)
   8.688 +  "ss" =>
   8.689 +    let
   8.690 +      val ss = presburger_ss addsimps
   8.691 +        [zdvd_iff_zmod_eq_0,unity_coeff_ex]
   8.692 +      val ct =  cert_Trueprop sg fm2
   8.693 +    in 
   8.694 +      simple_prove_goal_cterm2 ct [simp_tac ss 1, TRY (simple_arith_tac 1)]
   8.695 +    end
   8.696 +
   8.697 +  (*"bl" like blast tactic*)
   8.698 +  (* Is only used in the harrisons like proof procedure *)
   8.699 +  | "bl" =>
   8.700 +     let val ct = cert_Trueprop sg fm2
   8.701 +     in
   8.702 +       simple_prove_goal_cterm2 ct [blast_tac HOL_cs 1]
   8.703 +     end
   8.704 +
   8.705 +  (*"ed" like Existence disjunctions ...*)
   8.706 +  (* Is only used in the harrisons like proof procedure *)
   8.707 +  | "ed" =>
   8.708 +    let
   8.709 +      val ex_disj_tacs =
   8.710 +        let
   8.711 +          val tac1 = EVERY[REPEAT(resolve_tac [disjI1,disjI2] 1), etac exI 1]
   8.712 +          val tac2 = EVERY[etac exE 1, rtac exI 1,
   8.713 +            REPEAT(resolve_tac [disjI1,disjI2] 1), assumption 1]
   8.714 +	in [rtac iffI 1,
   8.715 +          etac exE 1, REPEAT(EVERY[etac disjE 1, tac1]), tac1,
   8.716 +          REPEAT(EVERY[etac disjE 1, tac2]), tac2]
   8.717 +        end
   8.718 +
   8.719 +      val ct = cert_Trueprop sg fm2
   8.720 +    in 
   8.721 +      simple_prove_goal_cterm2 ct ex_disj_tacs
   8.722 +    end
   8.723 +
   8.724 +  | "fa" =>
   8.725 +    let val ct = cert_Trueprop sg fm2
   8.726 +    in simple_prove_goal_cterm2 ct [simple_arith_tac 1]
   8.727 +    end
   8.728 +
   8.729 +  | "sa" =>
   8.730 +    let
   8.731 +      val ss = presburger_ss addsimps zadd_ac
   8.732 +      val ct = cert_Trueprop sg fm2
   8.733 +    in 
   8.734 +      simple_prove_goal_cterm2 ct [simp_tac ss 1, TRY (simple_arith_tac 1)]
   8.735 +    end
   8.736 +
   8.737 +  | "ac" =>
   8.738 +    let
   8.739 +      val ss = HOL_basic_ss addsimps zadd_ac
   8.740 +      val ct = cert_Trueprop sg fm2
   8.741 +    in 
   8.742 +      simple_prove_goal_cterm2 ct [simp_tac ss 1]
   8.743 +    end
   8.744 +
   8.745 +  | "lf" =>
   8.746 +    let
   8.747 +      val ss = presburger_ss addsimps zadd_ac
   8.748 +      val ct = cert_Trueprop sg fm2
   8.749 +    in 
   8.750 +      simple_prove_goal_cterm2 ct [simp_tac ss 1, TRY (simple_arith_tac 1)]
   8.751 +    end;
   8.752 +
   8.753 +
   8.754 +
   8.755 +(* ------------------------------------------------------------------------- *)
   8.756 +(* This function return an Isabelle proof, of the adjustcoffeq result.*)
   8.757 +(* The proofs are in Presburger.thy and are generally based on the arithmetic *)
   8.758 +(* ------------------------------------------------------------------------- *)
   8.759 +fun proof_of_adjustcoeffeq sg (prt,rs) = case prt of
   8.760 +   ACfm fm => instantiate' [Some cboolT]
   8.761 +    [Some (cterm_of sg fm)] refl
   8.762 + | ACAt (k,at as (Const(p,_) $a $( Const ("op +", _)$(Const ("op *",_) $ 
   8.763 +      c $ x ) $t ))) => 
   8.764 +   let
   8.765 +     val ck = cterm_of sg (mk_numeral k)
   8.766 +     val cc = cterm_of sg c
   8.767 +     val ct = cterm_of sg t
   8.768 +     val cx = cterm_of sg x
   8.769 +     val ca = cterm_of sg a
   8.770 +   in case p of
   8.771 +     "op <" => let val pre = prove_elementar sg "ss" 
   8.772 +	                  (HOLogic.mk_binrel "op <" (Const("0",HOLogic.intT),(mk_numeral k)))
   8.773 +	           val th1 = (pre RS (instantiate' [] [Some ck,Some ca,Some cc, Some cx, Some ct] (ac_lt_eq)))
   8.774 +		      in [th1,(prove_elementar sg "ss" (HOLogic.mk_eq (snd (qe_get_terms th1) ,rs)))] MRS trans
   8.775 +                   end
   8.776 +    |"op =" =>let val pre = prove_elementar sg "ss" 
   8.777 +	    (HOLogic.Not $ (HOLogic.mk_binrel "op =" (Const("0",HOLogic.intT),(mk_numeral k))))
   8.778 +	          in let val th1 = (pre RS(instantiate' [] [Some ck,Some ca,Some cc, Some cx, Some ct] (ac_eq_eq)))
   8.779 +	             in [th1,(prove_elementar sg "ss" (HOLogic.mk_eq (snd (qe_get_terms th1) ,rs)))] MRS trans
   8.780 +                      end
   8.781 +                  end
   8.782 +    |"Divides.op dvd" =>let val pre = prove_elementar sg "ss" 
   8.783 +	   (HOLogic.Not $ (HOLogic.mk_binrel "op =" (Const("0",HOLogic.intT),(mk_numeral k))))
   8.784 +	                 val th1 = (pre RS (instantiate' [] [Some ck,Some ca,Some cc, Some cx, Some ct]) (ac_dvd_eq))
   8.785 +                         in [th1,(prove_elementar sg "ss" (HOLogic.mk_eq (snd (qe_get_terms th1) ,rs)))] MRS trans
   8.786 +                        
   8.787 +                          end
   8.788 +  end
   8.789 + |ACPI(k,at as (Const("Not",_)$(Const("op <",_) $a $( Const ("op +", _)$(Const ("op *",_) $ c $ x ) $t )))) => 
   8.790 +   let
   8.791 +     val ck = cterm_of sg (mk_numeral k)
   8.792 +     val cc = cterm_of sg c
   8.793 +     val ct = cterm_of sg t
   8.794 +     val cx = cterm_of sg x
   8.795 +     val pre = prove_elementar sg "ss" 
   8.796 +       (HOLogic.mk_binrel "op <" (Const("0",HOLogic.intT),(mk_numeral k)))
   8.797 +       val th1 = (pre RS (instantiate' [] [Some ck,Some cc, Some cx, Some ct] (ac_pi_eq)))
   8.798 +
   8.799 +         in [th1,(prove_elementar sg "sa" (HOLogic.mk_eq (snd (qe_get_terms th1) ,rs)))] MRS trans
   8.800 +   end
   8.801 + |ACNeg(pr) => let val (Const("Not",_)$nrs) = rs
   8.802 +               in (proof_of_adjustcoeffeq sg (pr,nrs)) RS (qe_Not) 
   8.803 +               end
   8.804 + |ACConst(s,pr1,pr2) =>
   8.805 +   let val (Const(_,_)$rs1$rs2) = rs
   8.806 +       val th1 = proof_of_adjustcoeffeq sg (pr1,rs1)
   8.807 +       val th2 = proof_of_adjustcoeffeq sg (pr2,rs2)
   8.808 +       in case s of 
   8.809 +	 "CJ" => [th1,th2] MRS (qe_conjI)
   8.810 +         |"DJ" => [th1,th2] MRS (qe_disjI)
   8.811 +         |"IM" => [th1,th2] MRS (qe_impI)
   8.812 +         |"EQ" => [th1,th2] MRS (qe_eqI)
   8.813 +   end;
   8.814 +
   8.815 +
   8.816 +
   8.817 +
   8.818 +
   8.819 +
   8.820 +(* ------------------------------------------------------------------------- *)
   8.821 +(* This function return an Isabelle proof, of some properties on the atoms*)
   8.822 +(* The proofs are in Presburger.thy and are generally based on the arithmetic *)
   8.823 +(* This function doese only instantiate the the theorems in the theory *)
   8.824 +(* ------------------------------------------------------------------------- *)
   8.825 +fun atomar_minf_proof_of sg dlcm (Modd_minf (x,fm1)) =
   8.826 +  let
   8.827 +    (*Some certified Terms*)
   8.828 +    
   8.829 +   val ctrue = cterm_of sg HOLogic.true_const
   8.830 +   val cfalse = cterm_of sg HOLogic.false_const
   8.831 +   val fm = norm_zero_one fm1
   8.832 +  in  case fm1 of 
   8.833 +      (Const ("Not", _) $ (Const("op =",Type ("fun",[Type ("IntDef.int", []),_])) $ c1 $ (Const ("op +", _) $(Const ("op *",_) $ c2 $ y) $z))) => 
   8.834 +         if (x=y) andalso (c1= zero) andalso (c2= one) then (instantiate' [Some cboolT] [Some ctrue] (fm_modd_minf))
   8.835 +           else (instantiate' [Some cboolT] [Some (cterm_of sg fm)] (fm_modd_minf))
   8.836 +
   8.837 +      |(Const("op =",Type ("fun",[Type ("IntDef.int", []),_])) $ c1 $(Const ("op +", _) $(Const ("op *",_) $ c2 $ y) $z)) =>
   8.838 +  	   if (is_arith_rel fm) andalso (x=y) andalso (c1= zero) andalso (c2= one) 
   8.839 +	   then (instantiate' [Some cboolT] [Some cfalse] (fm_modd_minf))
   8.840 +	 	 else (instantiate' [Some cboolT] [Some (cterm_of sg fm)] (fm_modd_minf)) 
   8.841 +
   8.842 +      |(Const("op <",_) $ c1 $(Const ("op +", _) $(Const ("op *",_) $ pm1 $ y ) $ z )) =>
   8.843 +           if (y=x) andalso (c1 = zero) then 
   8.844 +            if (pm1 = one) then (instantiate' [Some cboolT] [Some cfalse] (fm_modd_minf)) else
   8.845 +	     (instantiate' [Some cboolT] [Some ctrue] (fm_modd_minf))
   8.846 +	    else (instantiate' [Some cboolT] [Some (cterm_of sg fm)] (fm_modd_minf))
   8.847 +  
   8.848 +      |Const ("Not",_) $ (Const("Divides.op dvd",_)$ d $ (Const ("op +",_) $ (Const ("op *",_) $ c $ y ) $ z)) => 
   8.849 +         if y=x then  let val cz = cterm_of sg (norm_zero_one z)
   8.850 +			  val fm2 = HOLogic.mk_binrel "op =" (HOLogic.mk_binop "Divides.op mod" (dlcm,d),norm_zero_one zero)
   8.851 +	 	      in(instantiate' [] [Some cz ] ((((prove_elementar sg "ss" fm2)) RS(((zdvd_iff_zmod_eq_0)RS sym) RS iffD1) ) RS (not_dvd_modd_minf)))
   8.852 +		      end
   8.853 +		else (instantiate' [Some cboolT] [Some (cterm_of sg fm)] (fm_modd_minf))
   8.854 +      |(Const("Divides.op dvd",_)$ d $ (db as (Const ("op +",_) $ (Const ("op *",_) $
   8.855 +      c $ y ) $ z))) => 
   8.856 +         if y=x then  let val cz = cterm_of sg (norm_zero_one z)
   8.857 +			  val fm2 = HOLogic.mk_binrel "op =" (HOLogic.mk_binop "Divides.op mod" (dlcm,d),norm_zero_one zero)
   8.858 +	 	      in(instantiate' [] [Some cz ] ((((prove_elementar sg "ss" fm2)) RS (((zdvd_iff_zmod_eq_0)RS sym) RS iffD1) ) RS (dvd_modd_minf)))
   8.859 +		      end
   8.860 +		else (instantiate' [Some cboolT] [Some (cterm_of sg fm)] (fm_modd_minf))
   8.861 +		
   8.862 +    
   8.863 +   |_ => instantiate' [Some cboolT] [Some (cterm_of sg fm)] (fm_modd_minf)
   8.864 +   end	
   8.865 +
   8.866 + |atomar_minf_proof_of sg dlcm (Eq_minf (x,fm1)) =  let
   8.867 +       (*Some certified types*)
   8.868 +   val fm = norm_zero_one fm1
   8.869 +    in  case fm1 of 
   8.870 +      (Const ("Not", _) $ (Const("op =",Type ("fun",[Type ("IntDef.int", []),_])) $ c1 $ (Const ("op +", _) $(Const ("op *",_) $ c2 $ y) $z))) => 
   8.871 +         if  (x=y) andalso (c1=zero) andalso (c2=one) 
   8.872 +	   then (instantiate' [] [Some (cterm_of sg (norm_zero_one z))] (neq_eq_minf))
   8.873 +           else (instantiate' [Some cboolT] [Some (cterm_of sg fm)] (fm_eq_minf))
   8.874 +
   8.875 +      |(Const("op =",Type ("fun",[Type ("IntDef.int", []),_])) $ c1 $(Const ("op +", _) $(Const ("op *",_) $ c2 $ y) $z)) =>
   8.876 +  	   if (is_arith_rel fm) andalso (x=y) andalso ((c1=zero) orelse (c1 = norm_zero_one zero)) andalso ((c2=one) orelse (c1 = norm_zero_one one))
   8.877 +	     then (instantiate' [] [Some (cterm_of sg (norm_zero_one z))] (eq_eq_minf))
   8.878 +	     else (instantiate' [Some cboolT] [Some (cterm_of sg fm)] (fm_eq_minf)) 
   8.879 +
   8.880 +      |(Const("op <",_) $ c1 $(Const ("op +", _) $(Const ("op *",_) $ pm1 $ y ) $ z )) =>
   8.881 +           if (y=x) andalso (c1 =zero) then 
   8.882 +            if pm1 = one then (instantiate' [] [Some (cterm_of sg (norm_zero_one z))] (le_eq_minf)) else
   8.883 +	     (instantiate' [] [Some (cterm_of sg (norm_zero_one z))] (len_eq_minf))
   8.884 +	    else (instantiate' [Some cboolT] [Some (cterm_of sg fm)] (fm_eq_minf))
   8.885 +      |Const ("Not",_) $ (Const("Divides.op dvd",_)$ d $ (Const ("op +",_) $ (Const ("op *",_) $ c $ y ) $ z)) => 
   8.886 +         if y=x then  let val cd = cterm_of sg (norm_zero_one d)
   8.887 +	 		  val cz = cterm_of sg (norm_zero_one z)
   8.888 +	 	      in(instantiate' [] [Some cd,  Some cz] (not_dvd_eq_minf)) 
   8.889 +		      end
   8.890 +
   8.891 +		else (instantiate' [Some cboolT] [Some (cterm_of sg fm)] (fm_eq_minf))
   8.892 +		
   8.893 +      |(Const("Divides.op dvd",_)$ d $ (Const ("op +",_) $ (Const ("op *",_) $ c $ y ) $ z)) => 
   8.894 +         if y=x then  let val cd = cterm_of sg (norm_zero_one d)
   8.895 +	 		  val cz = cterm_of sg (norm_zero_one z)
   8.896 +	 	      in(instantiate' [] [Some cd, Some cz ] (dvd_eq_minf))
   8.897 +		      end
   8.898 +		else (instantiate' [Some cboolT] [Some (cterm_of sg fm)] (fm_eq_minf))
   8.899 +
   8.900 +      		
   8.901 +    |_ => (instantiate' [Some cboolT] [Some (cterm_of sg fm)] (fm_eq_minf))
   8.902 + end;
   8.903 +
   8.904 +
   8.905 +(* ------------------------------------------------------------------------- *)
   8.906 +(* This function combines proofs of some special form already synthetised from the subtrees to make*)
   8.907 +(* a new proof of the same form. The combination occures whith isabelle theorems which have been already prooved *)
   8.908 +(*these Theorems are in Presburger.thy and mostly do not relay on the arithmetic.*)
   8.909 +(* These are Theorems for the Property of P_{-infty}*)
   8.910 +(* ------------------------------------------------------------------------- *)
   8.911 +fun combine_minf_proof s pr1 pr2 = case s of
   8.912 +    "ECJ" => [pr1 , pr2] MRS (eq_minf_conjI)
   8.913 +
   8.914 +   |"EDJ" => [pr1 , pr2] MRS (eq_minf_disjI)
   8.915 +   
   8.916 +   |"MCJ" => [pr1 , pr2] MRS (modd_minf_conjI)
   8.917 +
   8.918 +   |"MDJ" => [pr1 , pr2] MRS (modd_minf_disjI);
   8.919 +
   8.920 +(* ------------------------------------------------------------------------- *)
   8.921 +(*This function return an isabelle Proof for the minusinfinity theorem*)
   8.922 +(* It interpretates the protool and gives the protokoles property of P_{...} as a theorem*)
   8.923 +(* ------------------------------------------------------------------------- *)
   8.924 +fun minf_proof_ofh sg dlcm prl = case prl of 
   8.925 +
   8.926 +    Eq_minf (_) => atomar_minf_proof_of sg dlcm prl
   8.927 +    
   8.928 +   |Modd_minf (_) => atomar_minf_proof_of sg dlcm prl
   8.929 +   
   8.930 +   |Eq_minf_conjI (prl1,prl2) => let val pr1 = minf_proof_ofh sg dlcm prl1
   8.931 +   				    val pr2 = minf_proof_ofh sg dlcm prl2
   8.932 +				 in (combine_minf_proof "ECJ" pr1 pr2)
   8.933 +				 end
   8.934 +				 
   8.935 +   |Eq_minf_disjI (prl1,prl2) => let val pr1 = minf_proof_ofh sg dlcm prl1
   8.936 +   				    val pr2 = minf_proof_ofh sg dlcm prl2
   8.937 +				 in (combine_minf_proof "EDJ" pr1 pr2)
   8.938 +				 end
   8.939 +				 
   8.940 +   |Modd_minf_conjI (prl1,prl2) => let val pr1 = minf_proof_ofh sg dlcm prl1
   8.941 +   				    val pr2 = minf_proof_ofh sg dlcm prl2
   8.942 +				 in (combine_minf_proof "MCJ" pr1 pr2)
   8.943 +				 end
   8.944 +				 
   8.945 +   |Modd_minf_disjI (prl1,prl2) => let val pr1 = minf_proof_ofh sg dlcm prl1
   8.946 +   				    val pr2 = minf_proof_ofh sg dlcm prl2
   8.947 +				 in (combine_minf_proof "MDJ" pr1 pr2)
   8.948 +				 end;
   8.949 +(* ------------------------------------------------------------------------- *)
   8.950 +(* Main function For the rest both properies of P_{..} are needed and here both theorems are returned.*)				 
   8.951 +(* ------------------------------------------------------------------------- *)
   8.952 +fun  minf_proof_of sg dlcm (Minusinf (prl1,prl2))  = 
   8.953 +  let val pr1 = minf_proof_ofh sg dlcm prl1
   8.954 +      val pr2 = minf_proof_ofh sg dlcm prl2
   8.955 +  in (pr1, pr2)
   8.956 +end;
   8.957 +				 
   8.958 +
   8.959 +
   8.960 +
   8.961 +(* ------------------------------------------------------------------------- *)
   8.962 +(* This function return an Isabelle proof, of some properties on the atoms*)
   8.963 +(* The proofs are in Presburger.thy and are generally based on the arithmetic *)
   8.964 +(* This function doese only instantiate the the theorems in the theory *)
   8.965 +(* ------------------------------------------------------------------------- *)
   8.966 +fun atomar_pinf_proof_of sg dlcm (Modd_minf (x,fm1)) =
   8.967 + let
   8.968 +    (*Some certified Terms*)
   8.969 +    
   8.970 +  val ctrue = cterm_of sg HOLogic.true_const
   8.971 +  val cfalse = cterm_of sg HOLogic.false_const
   8.972 +  val fm = norm_zero_one fm1
   8.973 + in  case fm1 of 
   8.974 +      (Const ("Not", _) $ (Const("op =",Type ("fun",[Type ("IntDef.int", []),_])) $ c1 $ (Const ("op +", _) $(Const ("op *",_) $ c2 $ y) $z))) => 
   8.975 +         if ((x=y) andalso (c1= zero) andalso (c2= one))
   8.976 +	 then (instantiate' [Some cboolT] [Some ctrue] (fm_modd_pinf))
   8.977 +         else (instantiate' [Some cboolT] [Some (cterm_of sg fm)] (fm_modd_pinf))
   8.978 +
   8.979 +      |(Const("op =",Type ("fun",[Type ("IntDef.int", []),_])) $ c1 $(Const ("op +", _) $(Const ("op *",_) $ c2 $ y) $z)) =>
   8.980 +  	if ((is_arith_rel fm) andalso (x = y) andalso (c1 = zero)  andalso (c2 = one)) 
   8.981 +	then (instantiate' [Some cboolT] [Some cfalse] (fm_modd_pinf))
   8.982 +	else (instantiate' [Some cboolT] [Some (cterm_of sg fm)] (fm_modd_pinf))
   8.983 +
   8.984 +      |(Const("op <",_) $ c1 $(Const ("op +", _) $(Const ("op *",_) $ pm1 $ y ) $ z )) =>
   8.985 +        if ((y=x) andalso (c1 = zero)) then 
   8.986 +          if (pm1 = one) 
   8.987 +	  then (instantiate' [Some cboolT] [Some ctrue] (fm_modd_pinf)) 
   8.988 +	  else (instantiate' [Some cboolT] [Some cfalse] (fm_modd_pinf))
   8.989 +	else (instantiate' [Some cboolT] [Some (cterm_of sg fm)] (fm_modd_pinf))
   8.990 +  
   8.991 +      |Const ("Not",_) $ (Const("Divides.op dvd",_)$ d $ (Const ("op +",_) $ (Const ("op *",_) $ c $ y ) $ z)) => 
   8.992 +         if y=x then  let val cz = cterm_of sg (norm_zero_one z)
   8.993 +			  val fm2 = HOLogic.mk_binrel "op =" (HOLogic.mk_binop "Divides.op mod" (dlcm,d),norm_zero_one zero)
   8.994 +	 	      in(instantiate' [] [Some cz ] ((((prove_elementar sg "ss" fm2)) RS(((zdvd_iff_zmod_eq_0)RS sym) RS iffD1) ) RS (not_dvd_modd_pinf)))
   8.995 +		      end
   8.996 +		else (instantiate' [Some cboolT] [Some (cterm_of sg fm)] (fm_modd_pinf))
   8.997 +      |(Const("Divides.op dvd",_)$ d $ (db as (Const ("op +",_) $ (Const ("op *",_) $
   8.998 +      c $ y ) $ z))) => 
   8.999 +         if y=x then  let val cz = cterm_of sg (norm_zero_one z)
  8.1000 +			  val fm2 = HOLogic.mk_binrel "op =" (HOLogic.mk_binop "Divides.op mod" (dlcm,d),norm_zero_one zero)
  8.1001 +	 	      in(instantiate' [] [Some cz ] ((((prove_elementar sg "ss" fm2)) RS (((zdvd_iff_zmod_eq_0)RS sym) RS iffD1) ) RS (dvd_modd_pinf)))
  8.1002 +		      end
  8.1003 +		else (instantiate' [Some cboolT] [Some (cterm_of sg fm)] (fm_modd_pinf))
  8.1004 +		
  8.1005 +    
  8.1006 +   |_ => instantiate' [Some cboolT] [Some (cterm_of sg fm)] (fm_modd_pinf)
  8.1007 +   end	
  8.1008 +
  8.1009 + |atomar_pinf_proof_of sg dlcm (Eq_minf (x,fm1)) =  let
  8.1010 +					val fm = norm_zero_one fm1
  8.1011 +    in  case fm1 of 
  8.1012 +      (Const ("Not", _) $ (Const("op =",Type ("fun",[Type ("IntDef.int", []),_])) $ c1 $ (Const ("op +", _) $(Const ("op *",_) $ c2 $ y) $z))) => 
  8.1013 +         if  (x=y) andalso (c1=zero) andalso (c2=one) 
  8.1014 +	   then (instantiate' [] [Some (cterm_of sg (norm_zero_one z))] (neq_eq_pinf))
  8.1015 +           else (instantiate' [Some cboolT] [Some (cterm_of sg fm)] (fm_eq_pinf))
  8.1016 +
  8.1017 +      |(Const("op =",Type ("fun",[Type ("IntDef.int", []),_])) $ c1 $(Const ("op +", _) $(Const ("op *",_) $ c2 $ y) $z)) =>
  8.1018 +  	   if (is_arith_rel fm) andalso (x=y) andalso ((c1=zero) orelse (c1 = norm_zero_one zero)) andalso ((c2=one) orelse (c1 = norm_zero_one one))
  8.1019 +	     then (instantiate' [] [Some (cterm_of sg (norm_zero_one z))] (eq_eq_pinf))
  8.1020 +	     else (instantiate' [Some cboolT] [Some (cterm_of sg fm)] (fm_eq_pinf)) 
  8.1021 +
  8.1022 +      |(Const("op <",_) $ c1 $(Const ("op +", _) $(Const ("op *",_) $ pm1 $ y ) $ z )) =>
  8.1023 +           if (y=x) andalso (c1 =zero) then 
  8.1024 +            if pm1 = one then (instantiate' [] [Some (cterm_of sg (norm_zero_one z))] (le_eq_pinf)) else
  8.1025 +	     (instantiate' [] [Some (cterm_of sg (norm_zero_one z))] (len_eq_pinf))
  8.1026 +	    else (instantiate' [Some cboolT] [Some (cterm_of sg fm)] (fm_eq_pinf))
  8.1027 +      |Const ("Not",_) $ (Const("Divides.op dvd",_)$ d $ (Const ("op +",_) $ (Const ("op *",_) $ c $ y ) $ z)) => 
  8.1028 +         if y=x then  let val cd = cterm_of sg (norm_zero_one d)
  8.1029 +	 		  val cz = cterm_of sg (norm_zero_one z)
  8.1030 +	 	      in(instantiate' [] [Some cd,  Some cz] (not_dvd_eq_pinf)) 
  8.1031 +		      end
  8.1032 +
  8.1033 +		else (instantiate' [Some cboolT] [Some (cterm_of sg fm)] (fm_eq_pinf))
  8.1034 +		
  8.1035 +      |(Const("Divides.op dvd",_)$ d $ (Const ("op +",_) $ (Const ("op *",_) $ c $ y ) $ z)) => 
  8.1036 +         if y=x then  let val cd = cterm_of sg (norm_zero_one d)
  8.1037 +	 		  val cz = cterm_of sg (norm_zero_one z)
  8.1038 +	 	      in(instantiate' [] [Some cd, Some cz ] (dvd_eq_pinf))
  8.1039 +		      end
  8.1040 +		else (instantiate' [Some cboolT] [Some (cterm_of sg fm)] (fm_eq_pinf))
  8.1041 +
  8.1042 +      		
  8.1043 +    |_ => (instantiate' [Some cboolT] [Some (cterm_of sg fm)] (fm_eq_pinf))
  8.1044 + end;
  8.1045 +
  8.1046 +
  8.1047 +(* ------------------------------------------------------------------------- *)
  8.1048 +(* This function combines proofs of some special form already synthetised from the subtrees to make*)
  8.1049 +(* a new proof of the same form. The combination occures whith isabelle theorems which have been already prooved *)
  8.1050 +(*these Theorems are in Presburger.thy and mostly do not relay on the arithmetic.*)
  8.1051 +(* These are Theorems for the Property of P_{+infty}*)
  8.1052 +(* ------------------------------------------------------------------------- *)
  8.1053 +fun combine_pinf_proof s pr1 pr2 = case s of
  8.1054 +    "ECJ" => [pr1 , pr2] MRS (eq_pinf_conjI)
  8.1055 +
  8.1056 +   |"EDJ" => [pr1 , pr2] MRS (eq_pinf_disjI)
  8.1057 +   
  8.1058 +   |"MCJ" => [pr1 , pr2] MRS (modd_pinf_conjI)
  8.1059 +
  8.1060 +   |"MDJ" => [pr1 , pr2] MRS (modd_pinf_disjI);
  8.1061 +
  8.1062 +(* ------------------------------------------------------------------------- *)
  8.1063 +(*This function return an isabelle Proof for the minusinfinity theorem*)
  8.1064 +(* It interpretates the protool and gives the protokoles property of P_{...} as a theorem*)
  8.1065 +(* ------------------------------------------------------------------------- *)
  8.1066 +fun pinf_proof_ofh sg dlcm prl = case prl of 
  8.1067 +
  8.1068 +    Eq_minf (_) => atomar_pinf_proof_of sg dlcm prl
  8.1069 +    
  8.1070 +   |Modd_minf (_) => atomar_pinf_proof_of sg dlcm prl
  8.1071 +   
  8.1072 +   |Eq_minf_conjI (prl1,prl2) => let val pr1 = pinf_proof_ofh sg dlcm prl1
  8.1073 +   				    val pr2 = pinf_proof_ofh sg dlcm prl2
  8.1074 +				 in (combine_pinf_proof "ECJ" pr1 pr2)
  8.1075 +				 end
  8.1076 +				 
  8.1077 +   |Eq_minf_disjI (prl1,prl2) => let val pr1 = pinf_proof_ofh sg dlcm prl1
  8.1078 +   				    val pr2 = pinf_proof_ofh sg dlcm prl2
  8.1079 +				 in (combine_pinf_proof "EDJ" pr1 pr2)
  8.1080 +				 end
  8.1081 +				 
  8.1082 +   |Modd_minf_conjI (prl1,prl2) => let val pr1 = pinf_proof_ofh sg dlcm prl1
  8.1083 +   				    val pr2 = pinf_proof_ofh sg dlcm prl2
  8.1084 +				 in (combine_pinf_proof "MCJ" pr1 pr2)
  8.1085 +				 end
  8.1086 +				 
  8.1087 +   |Modd_minf_disjI (prl1,prl2) => let val pr1 = pinf_proof_ofh sg dlcm prl1
  8.1088 +   				    val pr2 = pinf_proof_ofh sg dlcm prl2
  8.1089 +				 in (combine_pinf_proof "MDJ" pr1 pr2)
  8.1090 +				 end;
  8.1091 +(* ------------------------------------------------------------------------- *)
  8.1092 +(* Main function For the rest both properies of P_{..} are needed and here both theorems are returned.*)				 
  8.1093 +(* ------------------------------------------------------------------------- *)
  8.1094 +fun pinf_proof_of sg dlcm (Minusinf (prl1,prl2))  = 
  8.1095 +  let val pr1 = pinf_proof_ofh sg dlcm prl1
  8.1096 +      val pr2 = pinf_proof_ofh sg dlcm prl2
  8.1097 +  in (pr1, pr2)
  8.1098 +end;
  8.1099 +				 
  8.1100 +
  8.1101 +
  8.1102 +
  8.1103 +(* ------------------------------------------------------------------------- *)
  8.1104 +(* Here we generate the theorem for the Bset Property in the simple direction*)
  8.1105 +(* It is just an instantiation*)
  8.1106 +(* ------------------------------------------------------------------------- *)
  8.1107 +fun bsetproof_of sg (Bset(x as Free(xn,xT),fm,bs,dlcm))   = 
  8.1108 +  let
  8.1109 +    val cp = cterm_of sg (absfree (xn,xT,(norm_zero_one fm)))
  8.1110 +    val cdlcm = cterm_of sg dlcm
  8.1111 +    val cB = cterm_of sg (list_to_set HOLogic.intT (map norm_zero_one bs))
  8.1112 +  in instantiate' [] [Some cdlcm,Some cB, Some cp] (bst_thm)
  8.1113 +    end;
  8.1114 +
  8.1115 +
  8.1116 +
  8.1117 +
  8.1118 +(* ------------------------------------------------------------------------- *)
  8.1119 +(* Here we generate the theorem for the Bset Property in the simple direction*)
  8.1120 +(* It is just an instantiation*)
  8.1121 +(* ------------------------------------------------------------------------- *)
  8.1122 +fun asetproof_of sg (Aset(x as Free(xn,xT),fm,ast,dlcm))   = 
  8.1123 +  let
  8.1124 +    val cp = cterm_of sg (absfree (xn,xT,(norm_zero_one fm)))
  8.1125 +    val cdlcm = cterm_of sg dlcm
  8.1126 +    val cA = cterm_of sg (list_to_set HOLogic.intT (map norm_zero_one ast))
  8.1127 +  in instantiate' [] [Some cdlcm,Some cA, Some cp] (ast_thm)
  8.1128 +end;
  8.1129 +
  8.1130 +
  8.1131 +
  8.1132 +
  8.1133 +(* ------------------------------------------------------------------------- *)    
  8.1134 +(* Protokol interpretation function for the backwards direction for cooper's Theorem*)
  8.1135 +
  8.1136 +(* For the generation of atomic Theorems*)
  8.1137 +(* Prove the premisses on runtime and then make RS*)
  8.1138 +(* ------------------------------------------------------------------------- *)
  8.1139 +fun generate_atomic_not_bst_p sg (x as Free(xn,xT)) fm dlcm B at = 
  8.1140 +  let
  8.1141 +    val cdlcm = cterm_of sg dlcm
  8.1142 +    val cB = cterm_of sg B
  8.1143 +    val cfma = cterm_of sg (absfree (xn,xT,(norm_zero_one fm)))
  8.1144 +    val cat = cterm_of sg (norm_zero_one at)
  8.1145 +  in
  8.1146 +  case at of 
  8.1147 +   (Const ("Not", _) $ (Const("op =",Type ("fun",[Type ("IntDef.int", []),_])) $ c1 $ (Const ("op +", _) $(Const ("op *",_) $ c2 $ y) $z))) => 
  8.1148 +      if  (x=y) andalso (c1=zero) andalso (c2=one) 
  8.1149 +	 then let val th1 = prove_elementar sg "ss" (Const ("op :",HOLogic.intT --> (HOLogic.mk_setT HOLogic.intT) --> HOLogic.boolT) $ (norm_zero_one (linear_cmul ~1 z)) $ B)
  8.1150 +	          val th2 =  prove_elementar sg "ss" (HOLogic.mk_eq ((norm_zero_one (linear_cmul ~1 z)),Const("uminus",HOLogic.intT --> HOLogic.intT) $(norm_zero_one  z)))
  8.1151 +		  val th3 = prove_elementar sg "ss" (HOLogic.mk_binrel "op <" (Const("0",HOLogic.intT),dlcm))
  8.1152 +	 in  (instantiate' [] [Some cfma]([th3,th1,th2] MRS (not_bst_p_ne)))
  8.1153 +	 end
  8.1154 +         else (instantiate' [] [Some cfma,  Some cdlcm, Some cB,Some cat] (not_bst_p_fm))
  8.1155 +
  8.1156 +   |(Const("op =",Type ("fun",[Type ("IntDef.int", []),_])) $ c1 $(Const ("op +", T) $(Const ("op *",_) $ c2 $ y) $z)) =>
  8.1157 +     if (is_arith_rel at) andalso (x=y)
  8.1158 +	then let val bst_z = norm_zero_one (linear_neg (linear_add [] z (mk_numeral 1)))
  8.1159 +	         in let val th1 = prove_elementar sg "ss" (Const ("op :",HOLogic.intT --> (HOLogic.mk_setT HOLogic.intT) --> HOLogic.boolT) $ bst_z $ B)
  8.1160 +	          val th2 =  prove_elementar sg "ss" (HOLogic.mk_eq (bst_z,Const("op -",T) $ (Const("uminus",HOLogic.intT --> HOLogic.intT) $(norm_zero_one z)) $ (Const("1",HOLogic.intT))))
  8.1161 +		  val th3 = prove_elementar sg "ss" (HOLogic.mk_binrel "op <" (Const("0",HOLogic.intT),dlcm))
  8.1162 +	 in  (instantiate' [] [Some cfma] ([th3,th1,th2] MRS (not_bst_p_eq)))
  8.1163 +	 end
  8.1164 +       end
  8.1165 +         else (instantiate' [] [Some cfma,  Some cdlcm, Some cB,Some cat] (not_bst_p_fm))
  8.1166 +
  8.1167 +   |(Const("op <",_) $ c1 $(Const ("op +", _) $(Const ("op *",_) $ pm1 $ y ) $ z )) =>
  8.1168 +        if (y=x) andalso (c1 =zero) then 
  8.1169 +        if pm1 = one then 
  8.1170 +	  let val th1 = prove_elementar sg "ss" (Const ("op :",HOLogic.intT --> (HOLogic.mk_setT HOLogic.intT) --> HOLogic.boolT) $ (norm_zero_one (linear_cmul ~1 z)) $ B)
  8.1171 +              val th2 =  prove_elementar sg "ss" (HOLogic.mk_eq ((norm_zero_one (linear_cmul ~1 z)),Const("uminus",HOLogic.intT --> HOLogic.intT) $(norm_zero_one z)))
  8.1172 +	  in  (instantiate' [] [Some cfma,  Some cdlcm]([th1,th2] MRS (not_bst_p_gt)))
  8.1173 +	    end
  8.1174 +	 else let val th1 = prove_elementar sg "ss" (HOLogic.mk_binrel "op <" (Const("0",HOLogic.intT),dlcm))
  8.1175 +	      in (instantiate' [] [Some cfma, Some cB,Some (cterm_of sg (norm_zero_one z))] (th1 RS (not_bst_p_lt)))
  8.1176 +	      end
  8.1177 +      else (instantiate' [] [Some cfma,  Some cdlcm, Some cB,Some cat] (not_bst_p_fm))
  8.1178 +
  8.1179 +   |Const ("Not",_) $ (Const("Divides.op dvd",_)$ d $ (Const ("op +",_) $ (Const ("op *",_) $ c $ y ) $ z)) => 
  8.1180 +      if y=x then  
  8.1181 +           let val cz = cterm_of sg (norm_zero_one z)
  8.1182 +	       val th1 = (prove_elementar sg "ss"  (HOLogic.mk_binrel "op =" (HOLogic.mk_binop "Divides.op mod" (dlcm,d),norm_zero_one zero))) RS (((zdvd_iff_zmod_eq_0)RS sym) RS iffD1)
  8.1183 + 	     in (instantiate' []  [Some cfma, Some cB,Some cz] (th1 RS (not_bst_p_ndvd)))
  8.1184 +	     end
  8.1185 +      else (instantiate' [] [Some cfma,  Some cdlcm, Some cB,Some cat] (not_bst_p_fm))
  8.1186 +
  8.1187 +   |(Const("Divides.op dvd",_)$ d $ (Const ("op +",_) $ (Const ("op *",_) $ c $ y ) $ z)) => 
  8.1188 +       if y=x then  
  8.1189 +	 let val cz = cterm_of sg (norm_zero_one z)
  8.1190 +	     val th1 = (prove_elementar sg "ss"  (HOLogic.mk_binrel "op =" (HOLogic.mk_binop "Divides.op mod" (dlcm,d),norm_zero_one zero))) RS (((zdvd_iff_zmod_eq_0)RS sym) RS iffD1)
  8.1191 + 	    in (instantiate' []  [Some cfma,Some cB,Some cz] (th1 RS (not_bst_p_dvd)))
  8.1192 +	  end
  8.1193 +      else (instantiate' [] [Some cfma,  Some cdlcm, Some cB,Some cat] (not_bst_p_fm))
  8.1194 +      		
  8.1195 +   |_ => (instantiate' [] [Some cfma,  Some cdlcm, Some cB,Some cat] (not_bst_p_fm))
  8.1196 +      		
  8.1197 +    end;
  8.1198 +    
  8.1199 +(* ------------------------------------------------------------------------- *)    
  8.1200 +(* Main interpretation function for this backwards dirction*)
  8.1201 +(* if atomic do generate atomis formulae else Construct theorems and then make RS with the construction theorems*)
  8.1202 +(*Help Function*)
  8.1203 +(* ------------------------------------------------------------------------- *)
  8.1204 +fun not_bst_p_proof_of_h sg x fm dlcm B prt = case prt of 
  8.1205 +	(Not_bst_p_atomic(fm2)) => (generate_atomic_not_bst_p sg x fm dlcm B fm2)
  8.1206 +	
  8.1207 +	|(Not_bst_p_conjI(pr1,pr2)) => 
  8.1208 +			let val th1 = (not_bst_p_proof_of_h sg x fm dlcm B pr1)
  8.1209 +			    val th2 = (not_bst_p_proof_of_h sg x fm dlcm B pr2)
  8.1210 +			    in ([th1,th2] MRS (not_bst_p_conjI))
  8.1211 +			    end
  8.1212 +
  8.1213 +	|(Not_bst_p_disjI(pr1,pr2)) => 
  8.1214 +			let val th1 = (not_bst_p_proof_of_h sg x fm dlcm B pr1)
  8.1215 +			    val th2 = (not_bst_p_proof_of_h sg x fm dlcm B pr2)
  8.1216 +			    in ([th1,th2] MRS not_bst_p_disjI)
  8.1217 +			    end;
  8.1218 +(* Main function*)
  8.1219 +fun not_bst_p_proof_of sg (Not_bst_p(x as Free(xn,xT),fm,dlcm,B,prl)) =
  8.1220 +  let val th =  not_bst_p_proof_of_h sg x fm dlcm B prl
  8.1221 +      val fma = absfree (xn,xT, norm_zero_one fm)
  8.1222 +  in let val th1 =  prove_elementar sg "ss"  (HOLogic.mk_eq (fma,fma))
  8.1223 +     in [th,th1] MRS (not_bst_p_Q_elim)
  8.1224 +     end
  8.1225 +  end;
  8.1226 +
  8.1227 +
  8.1228 +(* ------------------------------------------------------------------------- *)    
  8.1229 +(* Protokol interpretation function for the backwards direction for cooper's Theorem*)
  8.1230 +
  8.1231 +(* For the generation of atomic Theorems*)
  8.1232 +(* Prove the premisses on runtime and then make RS*)
  8.1233 +(* ------------------------------------------------------------------------- *)
  8.1234 +fun generate_atomic_not_ast_p sg (x as Free(xn,xT)) fm dlcm A at = 
  8.1235 +  let
  8.1236 +    val cdlcm = cterm_of sg dlcm
  8.1237 +    val cA = cterm_of sg A
  8.1238 +    val cfma = cterm_of sg (absfree (xn,xT,(norm_zero_one fm)))
  8.1239 +    val cat = cterm_of sg (norm_zero_one at)
  8.1240 +  in
  8.1241 +  case at of 
  8.1242 +   (Const ("Not", _) $ (Const("op =",Type ("fun",[Type ("IntDef.int", []),_])) $ c1 $ (Const ("op +", _) $(Const ("op *",_) $ c2 $ y) $z))) => 
  8.1243 +      if  (x=y) andalso (c1=zero) andalso (c2=one) 
  8.1244 +	 then let val th1 = prove_elementar sg "ss" (Const ("op :",HOLogic.intT --> (HOLogic.mk_setT HOLogic.intT) --> HOLogic.boolT) $ (norm_zero_one (linear_cmul ~1 z)) $ A)
  8.1245 +	          val th2 =  prove_elementar sg "ss" (HOLogic.mk_eq ((norm_zero_one (linear_cmul ~1 z)),Const("uminus",HOLogic.intT --> HOLogic.intT) $(norm_zero_one  z)))
  8.1246 +		  val th3 = prove_elementar sg "ss" (HOLogic.mk_binrel "op <" (Const("0",HOLogic.intT),dlcm))
  8.1247 +	 in  (instantiate' [] [Some cfma]([th3,th1,th2] MRS (not_ast_p_ne)))
  8.1248 +	 end
  8.1249 +         else (instantiate' [] [Some cfma,  Some cdlcm, Some cA,Some cat] (not_ast_p_fm))
  8.1250 +
  8.1251 +   |(Const("op =",Type ("fun",[Type ("IntDef.int", []),_])) $ c1 $(Const ("op +", T) $(Const ("op *",_) $ c2 $ y) $z)) =>
  8.1252 +     if (is_arith_rel at) andalso (x=y)
  8.1253 +	then let val ast_z = norm_zero_one (linear_sub [] one z )
  8.1254 +	         val th1 = prove_elementar sg "ss" (Const ("op :",HOLogic.intT --> (HOLogic.mk_setT HOLogic.intT) --> HOLogic.boolT) $ ast_z $ A)
  8.1255 +	         val th2 =  prove_elementar sg "ss" (HOLogic.mk_eq (ast_z,Const("op +",T) $ (Const("uminus",HOLogic.intT --> HOLogic.intT) $(norm_zero_one z)) $ (Const("1",HOLogic.intT))))
  8.1256 +		 val th3 = prove_elementar sg "ss" (HOLogic.mk_binrel "op <" (Const("0",HOLogic.intT),dlcm))
  8.1257 +	 in  (instantiate' [] [Some cfma] ([th3,th1,th2] MRS (not_ast_p_eq)))
  8.1258 +       end
  8.1259 +         else (instantiate' [] [Some cfma,  Some cdlcm, Some cA,Some cat] (not_ast_p_fm))
  8.1260 +
  8.1261 +   |(Const("op <",_) $ c1 $(Const ("op +", _) $(Const ("op *",_) $ pm1 $ y ) $ z )) =>
  8.1262 +        if (y=x) andalso (c1 =zero) then 
  8.1263 +        if pm1 = (mk_numeral ~1) then 
  8.1264 +	  let val th1 = prove_elementar sg "ss" (Const ("op :",HOLogic.intT --> (HOLogic.mk_setT HOLogic.intT) --> HOLogic.boolT) $ (norm_zero_one z) $ A)
  8.1265 +              val th2 =  prove_elementar sg "ss" (HOLogic.mk_binrel "op <" (zero,dlcm))
  8.1266 +	  in  (instantiate' [] [Some cfma]([th2,th1] MRS (not_ast_p_lt)))
  8.1267 +	    end
  8.1268 +	 else let val th1 = prove_elementar sg "ss" (HOLogic.mk_binrel "op <" (Const("0",HOLogic.intT),dlcm))
  8.1269 +	      in (instantiate' [] [Some cfma, Some cA,Some (cterm_of sg (norm_zero_one z))] (th1 RS (not_ast_p_gt)))
  8.1270 +	      end
  8.1271 +      else (instantiate' [] [Some cfma,  Some cdlcm, Some cA,Some cat] (not_ast_p_fm))
  8.1272 +
  8.1273 +   |Const ("Not",_) $ (Const("Divides.op dvd",_)$ d $ (Const ("op +",_) $ (Const ("op *",_) $ c $ y ) $ z)) => 
  8.1274 +      if y=x then  
  8.1275 +           let val cz = cterm_of sg (norm_zero_one z)
  8.1276 +	       val th1 = (prove_elementar sg "ss"  (HOLogic.mk_binrel "op =" (HOLogic.mk_binop "Divides.op mod" (dlcm,d),norm_zero_one zero))) RS (((zdvd_iff_zmod_eq_0)RS sym) RS iffD1)
  8.1277 + 	     in (instantiate' []  [Some cfma, Some cA,Some cz] (th1 RS (not_ast_p_ndvd)))
  8.1278 +	     end
  8.1279 +      else (instantiate' [] [Some cfma,  Some cdlcm, Some cA,Some cat] (not_ast_p_fm))
  8.1280 +
  8.1281 +   |(Const("Divides.op dvd",_)$ d $ (Const ("op +",_) $ (Const ("op *",_) $ c $ y ) $ z)) => 
  8.1282 +       if y=x then  
  8.1283 +	 let val cz = cterm_of sg (norm_zero_one z)
  8.1284 +	     val th1 = (prove_elementar sg "ss"  (HOLogic.mk_binrel "op =" (HOLogic.mk_binop "Divides.op mod" (dlcm,d),norm_zero_one zero))) RS (((zdvd_iff_zmod_eq_0)RS sym) RS iffD1)
  8.1285 + 	    in (instantiate' []  [Some cfma,Some cA,Some cz] (th1 RS (not_ast_p_dvd)))
  8.1286 +	  end
  8.1287 +      else (instantiate' [] [Some cfma,  Some cdlcm, Some cA,Some cat] (not_ast_p_fm))
  8.1288 +      		
  8.1289 +   |_ => (instantiate' [] [Some cfma,  Some cdlcm, Some cA,Some cat] (not_ast_p_fm))
  8.1290 +      		
  8.1291 +    end;
  8.1292 +    
  8.1293 +(* ------------------------------------------------------------------------- *)    
  8.1294 +(* Main interpretation function for this backwards dirction*)
  8.1295 +(* if atomic do generate atomis formulae else Construct theorems and then make RS with the construction theorems*)
  8.1296 +(*Help Function*)
  8.1297 +(* ------------------------------------------------------------------------- *)
  8.1298 +fun not_ast_p_proof_of_h sg x fm dlcm A prt = case prt of 
  8.1299 +	(Not_ast_p_atomic(fm2)) => (generate_atomic_not_ast_p sg x fm dlcm A fm2)
  8.1300 +	
  8.1301 +	|(Not_ast_p_conjI(pr1,pr2)) => 
  8.1302 +			let val th1 = (not_ast_p_proof_of_h sg x fm dlcm A pr1)
  8.1303 +			    val th2 = (not_ast_p_proof_of_h sg x fm dlcm A pr2)
  8.1304 +			    in ([th1,th2] MRS (not_ast_p_conjI))
  8.1305 +			    end
  8.1306 +
  8.1307 +	|(Not_ast_p_disjI(pr1,pr2)) => 
  8.1308 +			let val th1 = (not_ast_p_proof_of_h sg x fm dlcm A pr1)
  8.1309 +			    val th2 = (not_ast_p_proof_of_h sg x fm dlcm A pr2)
  8.1310 +			    in ([th1,th2] MRS (not_ast_p_disjI))
  8.1311 +			    end;
  8.1312 +(* Main function*)
  8.1313 +fun not_ast_p_proof_of sg (Not_ast_p(x as Free(xn,xT),fm,dlcm,A,prl)) =
  8.1314 +  let val th =  not_ast_p_proof_of_h sg x fm dlcm A prl
  8.1315 +      val fma = absfree (xn,xT, norm_zero_one fm)
  8.1316 +      val th1 =  prove_elementar sg "ss"  (HOLogic.mk_eq (fma,fma))
  8.1317 +  in [th,th1] MRS (not_ast_p_Q_elim)
  8.1318 +end;
  8.1319 +
  8.1320 +
  8.1321 +
  8.1322 +
  8.1323 +(* ------------------------------------------------------------------------- *)
  8.1324 +(* Interpretaion of Protocols of the cooper procedure : minusinfinity version*)
  8.1325 +(* ------------------------------------------------------------------------- *)
  8.1326 +
  8.1327 +
  8.1328 +fun coopermi_proof_of sg x (Cooper (dlcm,Simp(fm,miprt),bsprt,nbst_p_prt)) =
  8.1329 +  (* Get the Bset thm*)
  8.1330 +  let val bst = bsetproof_of sg bsprt
  8.1331 +      val (mit1,mit2) = minf_proof_of sg dlcm miprt
  8.1332 +      val fm1 = norm_zero_one (simpl fm) 
  8.1333 +      val dpos = prove_elementar sg "ss" (HOLogic.mk_binrel "op <" (zero,dlcm));
  8.1334 +      val nbstpthm = not_bst_p_proof_of sg nbst_p_prt
  8.1335 +    (* Return the four theorems needed to proove the whole Cooper Theorem*)
  8.1336 +  in (dpos,mit2,bst,nbstpthm,mit1)
  8.1337 +end;
  8.1338 +
  8.1339 +
  8.1340 +(* ------------------------------------------------------------------------- *)
  8.1341 +(* Interpretaion of Protocols of the cooper procedure : plusinfinity version *)
  8.1342 +(* ------------------------------------------------------------------------- *)
  8.1343 +
  8.1344 +
  8.1345 +fun cooperpi_proof_of sg x (Cooper (dlcm,Simp(fm,miprt),bsprt,nast_p_prt)) =
  8.1346 +  let val ast = asetproof_of sg bsprt
  8.1347 +      val (mit1,mit2) = pinf_proof_of sg dlcm miprt
  8.1348 +      val fm1 = norm_zero_one (simpl fm) 
  8.1349 +      val dpos = prove_elementar sg "ss" (HOLogic.mk_binrel "op <" (zero,dlcm));
  8.1350 +      val nastpthm = not_ast_p_proof_of sg nast_p_prt
  8.1351 +  in (dpos,mit2,ast,nastpthm,mit1)
  8.1352 +end;
  8.1353 +
  8.1354 +
  8.1355 +(* ------------------------------------------------------------------------- *)
  8.1356 +(* Interpretaion of Protocols of the cooper procedure : full version*)
  8.1357 +(* ------------------------------------------------------------------------- *)
  8.1358 +
  8.1359 +
  8.1360 +
  8.1361 +fun cooper_thm sg s (x as Free(xn,xT)) vars cfm = case s of
  8.1362 +  "pi" => let val (rs,prt) = cooperpi_wp (xn::vars) (HOLogic.mk_exists(xn,xT,cfm))
  8.1363 +	      val (dpsthm,th1,th2,nbpth,th3) = cooperpi_proof_of sg x prt
  8.1364 +		   in [dpsthm,th1,th2,nbpth,th3] MRS (cppi_eq)
  8.1365 +           end
  8.1366 +  |"mi" => let val (rs,prt) = coopermi_wp (xn::vars) (HOLogic.mk_exists(xn,xT,cfm))
  8.1367 +	       val (dpsthm,th1,th2,nbpth,th3) = coopermi_proof_of sg x prt
  8.1368 +		   in [dpsthm,th1,th2,nbpth,th3] MRS (cpmi_eq)
  8.1369 +                end
  8.1370 + |_ => error "parameter error";
  8.1371 +
  8.1372 +(* ------------------------------------------------------------------------- *)
  8.1373 +(* This function should evoluate to the end prove Procedure for one quantifier elimination for Presburger arithmetic*)
  8.1374 +(* It shoud be plugged in the qfnp argument of the quantifier elimination proof function*)
  8.1375 +(* ------------------------------------------------------------------------- *)
  8.1376 +
  8.1377 +fun cooper_prv sg (x as Free(xn,xT)) efm vars = let 
  8.1378 +   val l = formlcm x efm
  8.1379 +   val ac_thm = proof_of_adjustcoeffeq sg (adjustcoeffeq_wp  x l efm)
  8.1380 +   val fm = snd (qe_get_terms ac_thm)
  8.1381 +   val  cfm = unitycoeff x fm
  8.1382 +   val afm = adjustcoeff x l fm
  8.1383 +   val P = absfree(xn,xT,afm)
  8.1384 +   val ss = presburger_ss addsimps
  8.1385 +     [simp_from_to] delsimps [P_eqtrue, P_eqfalse, bex_triv, insert_iff]
  8.1386 +   val uth = instantiate' [] [Some (cterm_of sg P) , Some (cterm_of sg (mk_numeral l))] (unity_coeff_ex)
  8.1387 +   val e_ac_thm = (forall_intr (cterm_of sg x) ac_thm) COMP (qe_exI)
  8.1388 +   val cms = if ((length (aset x cfm)) < (length (bset x cfm))) then "pi" else "mi"
  8.1389 +   val cp_thm = cooper_thm sg cms x vars cfm
  8.1390 +   val exp_cp_thm = refl RS (simplify ss (cp_thm RSN (2,trans)))
  8.1391 +   val (lsuth,rsuth) = qe_get_terms (uth)
  8.1392 +   val (lseacth,rseacth) = qe_get_terms(e_ac_thm)
  8.1393 +   val (lscth,rscth) = qe_get_terms (exp_cp_thm)
  8.1394 +   val  u_c_thm = [([uth,prove_elementar sg "ss" (HOLogic.mk_eq (rsuth,lscth))] MRS trans),exp_cp_thm] MRS trans
  8.1395 + in  ([e_ac_thm,[(prove_elementar sg "ss" (HOLogic.mk_eq (rseacth,lsuth))),u_c_thm] MRS trans] MRS trans)
  8.1396 +   end
  8.1397 +|cooper_prv _ _ _ _ = error "Parameters format";
  8.1398 +
  8.1399 +
  8.1400 +(*====================================================*)
  8.1401 +(*Interpretation function for the evaluation protokol *)
  8.1402 +(*====================================================*)
  8.1403 +
  8.1404 +fun proof_of_evalc sg fm =
  8.1405 +let
  8.1406 +fun proof_of_evalch prt = case prt of
  8.1407 +  EvalAt(at) => prove_elementar sg "ss" at
  8.1408 + |Evalfm(fm) => instantiate' [Some cboolT] [Some (cterm_of sg fm)] refl
  8.1409 + |EvalConst(s,pr1,pr2) => 
  8.1410 +   let val th1 = proof_of_evalch pr1
  8.1411 +       val th2 = proof_of_evalch pr2
  8.1412 +   in case s of
  8.1413 +     "CJ" =>[th1,th2] MRS (qe_conjI)
  8.1414 +    |"DJ" =>[th1,th2] MRS (qe_disjI)
  8.1415 +    |"IM" =>[th1,th2] MRS (qe_impI)
  8.1416 +    |"EQ" =>[th1,th2] MRS (qe_eqI)
  8.1417 +    end
  8.1418 +in proof_of_evalch (evalc_wp fm)
  8.1419 +end;
  8.1420 +
  8.1421 +(*============================================================*)
  8.1422 +(*Interpretation function for the NNF-Transformation protokol *)
  8.1423 +(*============================================================*)
  8.1424 +
  8.1425 +fun proof_of_cnnf sg fm pf = 
  8.1426 +let fun proof_of_cnnfh prt pat = case prt of
  8.1427 +  NNFAt(at) => pat at
  8.1428 + |NNFSimp (pr) => let val th1 = proof_of_cnnfh pr pat
  8.1429 +                  in let val fm2 = snd (qe_get_terms th1) 
  8.1430 +		     in [th1,prove_elementar sg "ss" (HOLogic.mk_eq(fm2 ,simpl fm2))] MRS trans
  8.1431 +                     end
  8.1432 +                  end
  8.1433 + |NNFNN (pr) => (proof_of_cnnfh pr pat) RS (nnf_nn)
  8.1434 + |NNFConst (s,pr1,pr2) =>
  8.1435 +   let val th1 = proof_of_cnnfh pr1 pat
  8.1436 +       val th2 = proof_of_cnnfh pr2 pat
  8.1437 +   in case s of
  8.1438 +     "CJ" => [th1,th2] MRS (qe_conjI)
  8.1439 +    |"DJ" => [th1,th2] MRS (qe_disjI)
  8.1440 +    |"IM" => [th1,th2] MRS (nnf_im)
  8.1441 +    |"EQ" => [th1,th2] MRS (nnf_eq)
  8.1442 +    |"SDJ" => let val (Const("op &",_)$A$_) = fst (qe_get_terms th1)
  8.1443 +	          val (Const("op &",_)$C$_) = fst (qe_get_terms th2)
  8.1444 +	      in [th1,th2,prove_elementar sg "ss" (HOLogic.mk_eq (A,HOLogic.Not $ C))] MRS (nnf_sdj)
  8.1445 +	      end
  8.1446 +    |"NCJ" => [th1,th2] MRS (nnf_ncj)
  8.1447 +    |"NIM" => [th1,th2] MRS (nnf_nim)
  8.1448 +    |"NEQ" => [th1,th2] MRS (nnf_neq)
  8.1449 +    |"NDJ" => [th1,th2] MRS (nnf_ndj)
  8.1450 +   end
  8.1451 +in proof_of_cnnfh (cnnf_wp fm) pf
  8.1452 +end;
  8.1453 +
  8.1454 +
  8.1455 +
  8.1456 +
  8.1457 +(*====================================================*)
  8.1458 +(* Interpretation function for the linform protokol   *)
  8.1459 +(*====================================================*)
  8.1460 +
  8.1461 +
  8.1462 +fun proof_of_linform sg vars f = 
  8.1463 +  let fun proof_of_linformh prt = 
  8.1464 +  case prt of
  8.1465 +    (LfAt (at)) =>  prove_elementar sg "lf" (HOLogic.mk_eq (at, linform vars at))
  8.1466 +   |(LfAtdvd (Const("Divides.op dvd",_)$d$t)) => (prove_elementar sg "lf" (HOLogic.mk_eq (t, lint vars t))) RS (instantiate' [] [None , None, Some (cterm_of sg d)](linearize_dvd))
  8.1467 +   |(Lffm (fm)) => (instantiate' [Some cboolT] [Some (cterm_of sg fm)] refl)
  8.1468 +   |(LfConst (s,pr1,pr2)) =>
  8.1469 +     let val th1 = proof_of_linformh pr1
  8.1470 +	 val th2 = proof_of_linformh pr2
  8.1471 +     in case s of
  8.1472 +       "CJ" => [th1,th2] MRS (qe_conjI)
  8.1473 +      |"DJ" =>[th1,th2] MRS (qe_disjI)
  8.1474 +      |"IM" =>[th1,th2] MRS (qe_impI)
  8.1475 +      |"EQ" =>[th1,th2] MRS (qe_eqI)
  8.1476 +     end
  8.1477 +   |(LfNot(pr)) => 
  8.1478 +     let val th = proof_of_linformh pr
  8.1479 +     in (th RS (qe_Not))
  8.1480 +     end
  8.1481 +   |(LfQ(s,xn,xT,pr)) => 
  8.1482 +     let val th = forall_intr (cterm_of sg (Free(xn,xT)))(proof_of_linformh pr)
  8.1483 +     in if s = "Ex" 
  8.1484 +        then (th COMP(qe_exI) )
  8.1485 +        else (th COMP(qe_ALLI) )
  8.1486 +     end
  8.1487 +in
  8.1488 + proof_of_linformh (linform_wp f)
  8.1489 +end;
  8.1490 +
  8.1491 +end;
     9.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     9.2 +++ b/src/HOL/Tools/Presburger/presburger.ML	Tue Mar 25 09:47:05 2003 +0100
     9.3 @@ -0,0 +1,231 @@
     9.4 +(*  Title:      HOL/Integ/presburger.ML
     9.5 +    ID:         $Id$
     9.6 +    Author:     Amine Chaieb and Stefan Berghofer, TU Muenchen
     9.7 +    License:    GPL (GNU GENERAL PUBLIC LICENSE)
     9.8 +
     9.9 +Tactic for solving arithmetical Goals in Presburger Arithmetic
    9.10 +*)
    9.11 +
    9.12 +signature PRESBURGER = 
    9.13 +sig
    9.14 + val presburger_tac : bool -> int -> tactic
    9.15 + val presburger_method : bool -> int -> Proof.method
    9.16 + val setup : (theory -> theory) list
    9.17 + val trace : bool ref
    9.18 +end;
    9.19 +
    9.20 +structure Presburger: PRESBURGER =
    9.21 +struct
    9.22 +
    9.23 +val trace = ref false;
    9.24 +fun trace_msg s = if !trace then tracing s else ();
    9.25 +
    9.26 +(*-----------------------------------------------------------------*)
    9.27 +(*cooper_pp: provefunction for the one-exstance quantifier elimination*)
    9.28 +(* Here still only one problem : The proof for the arithmetical transformations done on the dvd atomic formulae*)
    9.29 +(*-----------------------------------------------------------------*)
    9.30 +
    9.31 +val presburger_ss = simpset_of (theory "Presburger");
    9.32 +
    9.33 +fun cooper_pp sg vrl (fm as e$Abs(xn,xT,p)) = 
    9.34 +  let val (xn1,p1) = variant_abs (xn,xT,p)
    9.35 +  in (CooperProof.cooper_prv sg (Free (xn1, xT)) p1 vrl) end;
    9.36 +
    9.37 +fun mnnf_pp sg fm = CooperProof.proof_of_cnnf sg fm
    9.38 +  (CooperProof.proof_of_evalc sg);
    9.39 +
    9.40 +fun mproof_of_int_qelim sg fm =
    9.41 +  Qelim.proof_of_mlift_qelim sg CooperDec.is_arith_rel
    9.42 +    (CooperProof.proof_of_linform sg) (mnnf_pp sg) (cooper_pp sg) fm;
    9.43 +
    9.44 +(* Theorems to be used in this tactic*)
    9.45 +
    9.46 +val zdvd_int = thm "zdvd_int";
    9.47 +val zdiff_int_split = thm "zdiff_int_split";
    9.48 +val all_nat = thm "all_nat";
    9.49 +val ex_nat = thm "ex_nat";
    9.50 +val number_of1 = thm "number_of1";
    9.51 +val number_of2 = thm "number_of2";
    9.52 +val split_zdiv = thm "split_zdiv";
    9.53 +val split_zmod = thm "split_zmod";
    9.54 +val mod_div_equality' = thm "mod_div_equality'";
    9.55 +val split_div' = thm "split_div'";
    9.56 +val Suc_plus1 = thm "Suc_plus1";
    9.57 +val imp_le_cong = thm "imp_le_cong";
    9.58 +val conj_le_cong = thm "conj_le_cong";
    9.59 +
    9.60 +(* extract all the constants in a term*)
    9.61 +fun add_term_typed_consts (Const (c, T), cs) = (c,T) ins cs
    9.62 +  | add_term_typed_consts (t $ u, cs) =
    9.63 +      add_term_typed_consts (t, add_term_typed_consts (u, cs))
    9.64 +  | add_term_typed_consts (Abs (_, _, t), cs) = add_term_typed_consts (t, cs)
    9.65 +  | add_term_typed_consts (_, cs) = cs;
    9.66 +
    9.67 +fun term_typed_consts t = add_term_typed_consts(t,[]);
    9.68 +
    9.69 +(* put a term into eta long beta normal form *)
    9.70 +fun eta_long Ts (Abs (s, T, t)) = Abs (s, T, eta_long (T :: Ts) t)
    9.71 +  | eta_long Ts t = (case strip_comb t of
    9.72 +      (Abs _, _) => eta_long Ts (Envir.beta_norm t)
    9.73 +    | (u, ts) => 
    9.74 +      let val Us = binder_types (fastype_of1 (Ts, t))
    9.75 +      in list_abs (map (pair "x") Us, Unify.combound
    9.76 +        (list_comb (u, map (eta_long Ts) ts), 0, length Us))
    9.77 +      end);
    9.78 +
    9.79 +(* Some Types*)
    9.80 +val bT = HOLogic.boolT;
    9.81 +val iT = HOLogic.intT;
    9.82 +val binT = HOLogic.binT;
    9.83 +val nT = HOLogic.natT;
    9.84 +
    9.85 +(* Allowed Consts in formulae for presburger tactic*)
    9.86 +
    9.87 +val allowed_consts =
    9.88 +  [("All", (iT --> bT) --> bT),
    9.89 +   ("Ex", (iT --> bT) --> bT),
    9.90 +   ("All", (nT --> bT) --> bT),
    9.91 +   ("Ex", (nT --> bT) --> bT),
    9.92 +
    9.93 +   ("op &", bT --> bT --> bT),
    9.94 +   ("op |", bT --> bT --> bT),
    9.95 +   ("op -->", bT --> bT --> bT),
    9.96 +   ("op =", bT --> bT --> bT),
    9.97 +   ("Not", bT --> bT),
    9.98 +
    9.99 +   ("op <=", iT --> iT --> bT),
   9.100 +   ("op =", iT --> iT --> bT),
   9.101 +   ("op <", iT --> iT --> bT),
   9.102 +   ("Divides.op dvd", iT --> iT --> bT),
   9.103 +   ("Divides.op div", iT --> iT --> iT),
   9.104 +   ("Divides.op mod", iT --> iT --> iT),
   9.105 +   ("op +", iT --> iT --> iT),
   9.106 +   ("op -", iT --> iT --> iT),
   9.107 +   ("op *", iT --> iT --> iT), 
   9.108 +   ("HOL.abs", iT --> iT),
   9.109 +   ("uminus", iT --> iT),
   9.110 +
   9.111 +   ("op <=", nT --> nT --> bT),
   9.112 +   ("op =", nT --> nT --> bT),
   9.113 +   ("op <", nT --> nT --> bT),
   9.114 +   ("Divides.op dvd", nT --> nT --> bT),
   9.115 +   ("Divides.op div", nT --> nT --> nT),
   9.116 +   ("Divides.op mod", nT --> nT --> nT),
   9.117 +   ("op +", nT --> nT --> nT),
   9.118 +   ("op -", nT --> nT --> nT),
   9.119 +   ("op *", nT --> nT --> nT), 
   9.120 +   ("Suc", nT --> nT),
   9.121 +
   9.122 +   ("Numeral.bin.Bit", binT --> bT --> binT),
   9.123 +   ("Numeral.bin.Pls", binT),
   9.124 +   ("Numeral.bin.Min", binT),
   9.125 +   ("Numeral.number_of", binT --> iT),
   9.126 +   ("Numeral.number_of", binT --> nT),
   9.127 +   ("0", nT),
   9.128 +   ("0", iT),
   9.129 +   ("1", nT),
   9.130 +   ("1", iT),
   9.131 +
   9.132 +   ("False", bT),
   9.133 +   ("True", bT)];
   9.134 +
   9.135 +(*returns true if the formula is relevant for presburger arithmetic tactic*)
   9.136 +fun relevant t = (term_typed_consts t) subset allowed_consts;
   9.137 +
   9.138 +(* Preparation of the formula to be sent to the Integer quantifier *)
   9.139 +(* elimination procedure                                           *)
   9.140 +(* Transforms meta implications and meta quantifiers to object     *)
   9.141 +(* implications and object quantifiers                             *)
   9.142 +
   9.143 +fun prepare_for_presburger q fm = 
   9.144 +  let
   9.145 +    val ps = Logic.strip_params fm
   9.146 +    val hs = map HOLogic.dest_Trueprop (Logic.strip_assums_hyp fm)
   9.147 +    val c = HOLogic.dest_Trueprop (Logic.strip_assums_concl fm)
   9.148 +    val _ = if relevant c then () else raise CooperDec.COOPER
   9.149 +    fun mk_all ((s, T), (P,n)) =
   9.150 +      if 0 mem loose_bnos P then
   9.151 +        (HOLogic.all_const T $ Abs (s, T, P), n)
   9.152 +      else (incr_boundvars ~1 P, n-1)
   9.153 +    fun mk_all2 (v, t) = HOLogic.all_const (fastype_of v) $ lambda v t;
   9.154 +    val (rhs,irhs) = partition relevant hs
   9.155 +    val np = length ps
   9.156 +    val (fm',np) =  foldr (fn ((x, T), (fm,n)) => mk_all ((x, T), (fm,n)))
   9.157 +      (ps,(foldr HOLogic.mk_imp (rhs, c), np))
   9.158 +    val (vs, _) = partition (fn t => q orelse (type_of t) = nT)
   9.159 +      (term_frees fm' @ term_vars fm');
   9.160 +    val fm2 = foldr mk_all2 (vs, fm')
   9.161 +  in (fm2, np + length vs, length rhs) end;
   9.162 +
   9.163 +(*Object quantifier to meta --*)
   9.164 +fun spec_step n th = if (n=0) then th else (spec_step (n-1) th) RS spec ;
   9.165 +
   9.166 +(* object implication to meta---*)
   9.167 +fun mp_step n th = if (n=0) then th else (mp_step (n-1) th) RS mp;
   9.168 +
   9.169 +(* the presburger tactic*)
   9.170 +fun presburger_tac q i st =
   9.171 +  let
   9.172 +    val g = BasisLibrary.List.nth (prems_of st, i - 1);
   9.173 +    val sg = sign_of_thm st;
   9.174 +    (* Transform the term*)
   9.175 +    val (t,np,nh) = prepare_for_presburger q g
   9.176 +    (* Some simpsets for dealing with mod div abs and nat*)
   9.177 +
   9.178 +    val simpset0 = HOL_basic_ss
   9.179 +      addsimps [mod_div_equality', Suc_plus1]
   9.180 +      addsplits [split_zdiv, split_zmod, split_div']
   9.181 +    (* Simp rules for changing (n::int) to int n *)
   9.182 +    val simpset1 = HOL_basic_ss
   9.183 +      addsimps [nat_number_of_def, zdvd_int] @ map (fn r => r RS sym)
   9.184 +        [int_int_eq, zle_int, zless_int, zadd_int, zmult_int]
   9.185 +      addsplits [zdiff_int_split]
   9.186 +    (*simp rules for elimination of int n*)
   9.187 +
   9.188 +    val simpset2 = HOL_basic_ss
   9.189 +      addsimps [nat_0_le, all_nat, ex_nat, number_of1, number_of2, int_0, int_1]
   9.190 +      addcongs [conj_le_cong, imp_le_cong]
   9.191 +    (* simp rules for elimination of abs *)
   9.192 +
   9.193 +    val simpset3 = HOL_basic_ss addsplits [zabs_split]
   9.194 +	      
   9.195 +    val ct = cterm_of sg (HOLogic.mk_Trueprop t)
   9.196 +
   9.197 +    (* Theorem for the nat --> int transformation *)
   9.198 +    val pre_thm = Seq.hd (EVERY
   9.199 +      [simp_tac simpset0 i,
   9.200 +       TRY (simp_tac simpset1 i), TRY (simp_tac simpset2 i),
   9.201 +       TRY (simp_tac simpset3 i), TRY (simp_tac presburger_ss i)]
   9.202 +      (trivial ct))
   9.203 +
   9.204 +    fun assm_tac i = REPEAT_DETERM_N nh (assume_tac i);
   9.205 +
   9.206 +    (* The result of the quantifier elimination *)
   9.207 +    val (th, tac) = case (prop_of pre_thm) of
   9.208 +        Const ("==>", _) $ (Const ("Trueprop", _) $ t1) $ _ =>
   9.209 +          (trace_msg ("calling procedure with term:\n" ^
   9.210 +             Sign.string_of_term sg t1);
   9.211 +           ((mproof_of_int_qelim sg (eta_long [] t1) RS iffD2) RS pre_thm,
   9.212 +            assm_tac (i + 1) THEN (if q then I else TRY) (rtac TrueI i)))
   9.213 +      | _ => (pre_thm, assm_tac i)
   9.214 +  in (rtac (((mp_step nh) o (spec_step np)) th) i THEN tac) st
   9.215 +  end handle Subscript => no_tac st | CooperDec.COOPER => no_tac st;
   9.216 +
   9.217 +fun presburger_args meth =
   9.218 +  Method.simple_args (Scan.optional (Args.$$$ "no_quantify" >> K false) true)
   9.219 +    (fn q => fn _ => meth q 1);
   9.220 +
   9.221 +fun presburger_method q i = Method.METHOD (fn facts =>
   9.222 +  Method.insert_tac facts 1 THEN presburger_tac q i)
   9.223 +
   9.224 +val setup =
   9.225 +  [Method.add_method ("presburger",
   9.226 +     presburger_args presburger_method,
   9.227 +     "decision procedure for Presburger arithmetic"),
   9.228 +   ArithTheoryData.map (fn {splits, inj_consts, discrete, presburger} =>
   9.229 +     {splits = splits, inj_consts = inj_consts, discrete = discrete,
   9.230 +      presburger = Some (presburger_tac true)})];
   9.231 +
   9.232 +end;
   9.233 +
   9.234 +val presburger_tac = Presburger.presburger_tac true;
    10.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    10.2 +++ b/src/HOL/Tools/Presburger/qelim.ML	Tue Mar 25 09:47:05 2003 +0100
    10.3 @@ -0,0 +1,176 @@
    10.4 +(*  Title:      HOL/Integ/qelim.ML
    10.5 +    ID:         $Id$
    10.6 +    Author:     Amine Chaieb and Tobias Nipkow, TU Muenchen
    10.7 +    License:    GPL (GNU GENERAL PUBLIC LICENSE)
    10.8 +
    10.9 +File containing the implementation of the proof protocoling
   10.10 +and proof generation for multiple quantified formulae.
   10.11 +*)
   10.12 +
   10.13 +signature QELIM =
   10.14 +sig
   10.15 + val proof_of_mlift_qelim: Sign.sg -> (term -> bool) ->
   10.16 +   (string list -> term -> thm) -> (term -> thm) ->
   10.17 +   (string list -> term -> thm) -> term -> thm
   10.18 +end;
   10.19 +
   10.20 +structure Qelim : QELIM =
   10.21 +struct
   10.22 +open CooperDec;
   10.23 +open CooperProof;
   10.24 +
   10.25 +(*-----------------------------------------------------------------*)
   10.26 +(*-----------------------------------------------------------------*)
   10.27 +(*-----------------------------------------------------------------*)
   10.28 +(*---                                                           ---*)
   10.29 +(*---                                                           ---*)
   10.30 +(*---         Protocoling part                                  ---*)
   10.31 +(*---                                                           ---*)
   10.32 +(*---           includes the protocolling datastructure         ---*)
   10.33 +(*---                                                           ---*)
   10.34 +(*---          and the protocolling fuctions                    ---*)
   10.35 +(*---                                                           ---*)
   10.36 +(*---                                                           ---*)
   10.37 +(*---                                                           ---*)
   10.38 +(*-----------------------------------------------------------------*)
   10.39 +(*-----------------------------------------------------------------*)
   10.40 +(*-----------------------------------------------------------------*)
   10.41 +
   10.42 +
   10.43 +val cboolT = ctyp_of (sign_of HOL.thy) HOLogic.boolT;
   10.44 +
   10.45 +(* List of the theorems to be used in the following*)
   10.46 +
   10.47 +val qe_ex_conj = thm "qe_ex_conj";
   10.48 +val qe_ex_nconj = thm "qe_ex_nconj";
   10.49 +val qe_ALL = thm "qe_ALL";
   10.50 +
   10.51 +
   10.52 +(*Datatype declaration for the protocoling procedure.*)
   10.53 +
   10.54 +
   10.55 +datatype QeLog = AFN of term*(string list)
   10.56 +                |QFN of term*(string list)
   10.57 +                |ExConj of term*QeLog
   10.58 +                |ExDisj of (string*typ*term)*term*QeLog*QeLog
   10.59 +                |QeConst of string*QeLog*QeLog
   10.60 +                |QeNot of QeLog
   10.61 +                |QeAll of QeLog
   10.62 +                |Lift_Qelim of term*QeLog
   10.63 +		|QeUnk of term;
   10.64 +
   10.65 +datatype mQeLog = mQeProof of (string list)*mQeLog
   10.66 +		|mAFN of term
   10.67 +                |mNFN of mQeLog
   10.68 +                |mQeConst of string*mQeLog*mQeLog
   10.69 +                |mQeNot of mQeLog
   10.70 +		|mQelim of term*(string list)*mQeLog
   10.71 +		|mQeAll of mQeLog
   10.72 +		|mQefm of term;
   10.73 +
   10.74 +(* This is the protokoling my function for the quantifier elimination*)
   10.75 +fun mlift_qelim_wp isat vars = 
   10.76 +  let fun mqelift_wp vars fm = if (isat fm) then mAFN(fm)
   10.77 +    else  
   10.78 +    (case fm of 
   10.79 +     ( Const ("Not",_) $ p) => mQeNot(mqelift_wp vars p)
   10.80 +    |( Const ("op &",_) $ p $q) => mQeConst("CJ", mqelift_wp vars p,mqelift_wp vars q) 
   10.81 +
   10.82 +    |( Const ("op |",_) $ p $q) => mQeConst("DJ", mqelift_wp vars p,mqelift_wp vars q) 
   10.83 +
   10.84 +    |( Const ("op -->",_) $ p $q) => mQeConst("IM", mqelift_wp vars p,mqelift_wp vars q) 
   10.85 +
   10.86 +    |( Const ("op =",Type ("fun",[Type ("bool", []),_])) $ p $q) =>mQeConst("EQ", mqelift_wp vars p,mqelift_wp vars q) 
   10.87 +
   10.88 +    				
   10.89 +    |( Const ("All",QT) $ Abs(x,T,p)) =>mQeAll (mqelift_wp vars (Const("Ex",QT) $ Abs(x,T,(HOLogic.Not $ p))))
   10.90 +
   10.91 +    |(Const ("Ex",_) $ Abs (x,T,p))  => 
   10.92 +      let val (x1,p1) = variant_abs (x,T,p)
   10.93 +          val prt = mqelift_wp (x1::vars) p1
   10.94 +      in mQelim(Free(x1,T),vars,mNFN(prt))
   10.95 +      end
   10.96 +    | _ => mQefm(fm)
   10.97 +   ) 
   10.98 +     
   10.99 +  in (fn fm => mQeProof(vars,mNFN(mqelift_wp vars fm )))
  10.100 +  end;  
  10.101 +
  10.102 +
  10.103 +
  10.104 +
  10.105 +(*-----------------------------------------------------------------*)
  10.106 +(*-----------------------------------------------------------------*)
  10.107 +(*-----------------------------------------------------------------*)
  10.108 +(*---                                                           ---*)
  10.109 +(*---                                                           ---*)
  10.110 +(*---      Interpretation and Proofgeneration Part              ---*)
  10.111 +(*---                                                           ---*)
  10.112 +(*---      Protocole interpretation functions                   ---*)
  10.113 +(*---                                                           ---*)
  10.114 +(*---      and proofgeneration functions                        ---*)
  10.115 +(*---                                                           ---*)
  10.116 +(*---                                                           ---*)
  10.117 +(*---                                                           ---*)
  10.118 +(*---                                                           ---*)
  10.119 +(*-----------------------------------------------------------------*)
  10.120 +(*-----------------------------------------------------------------*)
  10.121 +(*-----------------------------------------------------------------*)
  10.122 +
  10.123 +(*-----------------------------------------------------------------*)
  10.124 +(*-----------------------------------------------------------------*)
  10.125 +(*function that interpretates the protokol generated by the _wp function*)
  10.126 +
  10.127 +
  10.128 +(* proof_of_lift_qelim interpretates a protokol for the quantifier elimination one some quantified formula. It uses the functions afnp nfnp and qfnp as proof functions to generate a prove for the hole quantifier elimination.*)
  10.129 +(* afnp : must retun a proof for the transformations on the atomic formalae*)
  10.130 +(* nfnp : must return a proof for the post one-quatifiers elimination process*)
  10.131 +(* qfnp mus return a proof for the one quantifier elimination (existential) *)
  10.132 +(* All these function are independent of the theory on whitch we are trying to prove quantifier elimination*)
  10.133 +(* But the following invariants mus be respected : *)
  10.134 +(* afnp : term -> string list -> thm*)
  10.135 +(*   nfnp : term -> thm*)
  10.136 +(*   qfnp : term -> string list -> thm*)
  10.137 +(*For all theorms generated by these function must hold :*)
  10.138 +(*    All of them are logical equivalences.*)
  10.139 +(*    on left side of the equivalence must appear the term exactely as ist was given as a parameter (or eventually modulo Gamma, where Gamma are the rules whitch are allowed to be used during unification ex. beta reduction.....)*)
  10.140 +(* qfnp must take as an argument for the term an existential quantified formula*)
  10.141 +(*-----------------------------------------------------------------*)
  10.142 +(*-----------------------------------------------------------------*)
  10.143 +
  10.144 +fun proof_of_mlift_qelim sg isat afnp nfnp qfnp =
  10.145 + let fun h_proof_of_mlift_qelim isat afnp nfnp qfnp prtkl vrl = 
  10.146 +   (case prtkl of 
  10.147 +   mAFN (fm) => afnp vrl fm 
  10.148 +   |mNFN (prt) => let val th1 = h_proof_of_mlift_qelim isat  afnp nfnp qfnp prt vrl 
  10.149 +                  val th2 = nfnp (snd (qe_get_terms th1)) 
  10.150 +                    in [th1,th2] MRS trans 
  10.151 +                 end 
  10.152 +   |mQeConst (s,pr1,pr2) =>  
  10.153 +     let val th1 =  h_proof_of_mlift_qelim isat afnp nfnp qfnp pr1 vrl  
  10.154 +         val th2 =  h_proof_of_mlift_qelim isat afnp nfnp qfnp pr2 vrl  
  10.155 +     in (case s of 
  10.156 +        "CJ" => [th1,th2] MRS (qe_conjI)  
  10.157 +       |"DJ" => [th1,th2] MRS (qe_disjI)  
  10.158 +       |"IM" => [th1,th2] MRS (qe_impI)  
  10.159 +       |"EQ" => [th1,th2] MRS (qe_eqI)  
  10.160 +       )  
  10.161 +    end  
  10.162 +   |mQeNot (pr) =>(h_proof_of_mlift_qelim isat afnp nfnp qfnp pr vrl ) RS (qe_Not)  
  10.163 +   |mQeAll(pr) => (h_proof_of_mlift_qelim isat afnp nfnp qfnp pr vrl ) RS (qe_ALL) 
  10.164 +   |mQelim (x as (Free(xn,xT)),vl,pr) => 
  10.165 +     let val th_1 = h_proof_of_mlift_qelim isat afnp nfnp qfnp pr vl
  10.166 +         val mQeProof(l2,pr2) = mlift_qelim_wp isat (xn::vrl) (snd(qe_get_terms th_1))
  10.167 +         val th_2 = [th_1,(h_proof_of_mlift_qelim isat afnp nfnp qfnp pr2 l2)] MRS trans
  10.168 +         val th1 = (forall_intr (cterm_of sg x) th_2) COMP (qe_exI)
  10.169 +	 val th2 = qfnp vl (snd (qe_get_terms th1)) 
  10.170 +       in [th1,th2] MRS trans 
  10.171 +       end
  10.172 +   |mQefm (fm) => instantiate' [Some cboolT] [Some (cterm_of sg fm)] refl
  10.173 +)
  10.174 +in (fn fm => let val mQeProof(vars,prt) = (mlift_qelim_wp isat (fv fm) fm)
  10.175 +                 in (h_proof_of_mlift_qelim isat afnp nfnp qfnp prt vars)
  10.176 +                 end)
  10.177 +end;
  10.178 +
  10.179 +end;