author berghofe Tue Mar 25 09:47:05 2003 +0100 (2003-03-25) changeset 13876 68f4ed8311ac parent 13875 12997e3ddd8d child 13877 a6b825ee48d9
New decision procedure for Presburger arithmetic.
 src/HOL/Integ/Presburger.thy file | annotate | diff | revisions src/HOL/Integ/cooper_dec.ML file | annotate | diff | revisions src/HOL/Integ/cooper_proof.ML file | annotate | diff | revisions src/HOL/Integ/presburger.ML file | annotate | diff | revisions src/HOL/Integ/qelim.ML file | annotate | diff | revisions src/HOL/Presburger.thy file | annotate | diff | revisions src/HOL/Tools/Presburger/cooper_dec.ML file | annotate | diff | revisions src/HOL/Tools/Presburger/cooper_proof.ML file | annotate | diff | revisions src/HOL/Tools/Presburger/presburger.ML file | annotate | diff | revisions src/HOL/Tools/Presburger/qelim.ML file | annotate | diff | revisions
     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.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.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.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.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.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.317 +apply(rename_tac m)
1.318 +apply(rule_tac x = "m - k" in exI)
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.325 +apply(rename_tac m)
1.326 +apply(erule_tac x = "m + k" in allE)
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.379 +  apply(rename_tac m)
1.380 +  apply(rule_tac x = "m + k" in exI)
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.387 +  apply(rename_tac m)
1.388 +  apply(erule_tac x = "m - k" in allE)
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.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.407 +  apply(clarsimp)
1.408 +  apply(rename_tac n m)
1.409 +  apply(rule_tac x = "m - n*k" in exI)
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.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.421 +  apply(clarsimp)
1.422 +  apply(rename_tac n m)
1.423 +  apply(erule_tac x = "m + n*k" in allE)
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.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.474 +apply(clarsimp)
1.475 +apply(rename_tac n m)
1.476 +apply(rule_tac x = "m + n*k" in exI)
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.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.489 +apply(clarsimp)
1.490 +apply(rename_tac n m)
1.491 +apply(erule_tac x = "m - n*k" in allE)
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.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.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.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.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.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.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.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 <=",_)st) => LfAt(at) 8.324 + |(Const("op <",_)st) => LfAt(at) 8.325 + |(Const("op =",_)st) => LfAt(at) 8.326 + |(Const("Divides.op dvd",_)st) => 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 &",_)AB) => EvalConst("CJ",evalc_wp A,evalc_wp B) 8.547 + |(Const("op |",_)AB) => EvalConst("DJ",evalc_wp A,evalc_wp B) 8.548 + |(Const("op -->",_)AB) => EvalConst("IM",evalc_wp A,evalc_wp B) 8.549 + |(Const("op =", Type ("fun",[Type ("bool", []),_]))AB) => 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(_,_)rs1rs2) = 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",_)dt)) => (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 eAbs(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;