merged
authorhaftmann
Sat May 08 17:15:50 2010 +0200 (2010-05-08)
changeset 367545ce217fc769a
parent 36738 dce592144219
parent 36753 5cf4e9128f22
child 36755 d1b498f2f50b
child 36756 c1ae8a0b4265
merged
src/HOL/Tools/Groebner_Basis/groebner.ML
src/HOL/Tools/Groebner_Basis/normalizer.ML
src/HOL/Tools/semiring_normalizer.ML
     1.1 --- a/src/HOL/Decision_Procs/Dense_Linear_Order.thy	Fri May 07 23:44:10 2010 +0200
     1.2 +++ b/src/HOL/Decision_Procs/Dense_Linear_Order.thy	Sat May 08 17:15:50 2010 +0200
     1.3 @@ -700,14 +700,14 @@
     1.4          val th = implies_elim (instantiate' [SOME (ctyp_of_term x)] (map SOME [c,x,t])
     1.5               (if neg then @{thm neg_prod_sum_lt} else @{thm pos_prod_sum_lt})) cth
     1.6          val rth = Conv.fconv_rule (Conv.arg_conv (Conv.binop_conv
     1.7 -                   (Normalizer.semiring_normalize_ord_conv ctxt (earlier vs)))) th
     1.8 +                   (Semiring_Normalizer.semiring_normalize_ord_conv ctxt (earlier vs)))) th
     1.9        in rth end
    1.10      | ("x+t",[t]) =>
    1.11         let
    1.12          val T = ctyp_of_term x
    1.13          val th = instantiate' [SOME T] [SOME x, SOME t] @{thm "sum_lt"}
    1.14          val rth = Conv.fconv_rule (Conv.arg_conv (Conv.binop_conv
    1.15 -              (Normalizer.semiring_normalize_ord_conv ctxt (earlier vs)))) th
    1.16 +              (Semiring_Normalizer.semiring_normalize_ord_conv ctxt (earlier vs)))) th
    1.17         in  rth end
    1.18      | ("c*x",[c]) =>
    1.19         let
    1.20 @@ -744,14 +744,14 @@
    1.21          val th = implies_elim (instantiate' [SOME T] (map SOME [c,x,t])
    1.22               (if neg then @{thm neg_prod_sum_le} else @{thm pos_prod_sum_le})) cth
    1.23          val rth = Conv.fconv_rule (Conv.arg_conv (Conv.binop_conv
    1.24 -                   (Normalizer.semiring_normalize_ord_conv ctxt (earlier vs)))) th
    1.25 +                   (Semiring_Normalizer.semiring_normalize_ord_conv ctxt (earlier vs)))) th
    1.26        in rth end
    1.27      | ("x+t",[t]) =>
    1.28         let
    1.29          val T = ctyp_of_term x
    1.30          val th = instantiate' [SOME T] [SOME x, SOME t] @{thm "sum_le"}
    1.31          val rth = Conv.fconv_rule (Conv.arg_conv (Conv.binop_conv
    1.32 -              (Normalizer.semiring_normalize_ord_conv ctxt (earlier vs)))) th
    1.33 +              (Semiring_Normalizer.semiring_normalize_ord_conv ctxt (earlier vs)))) th
    1.34         in  rth end
    1.35      | ("c*x",[c]) =>
    1.36         let
    1.37 @@ -786,14 +786,14 @@
    1.38          val th = implies_elim
    1.39                   (instantiate' [SOME T] (map SOME [c,x,t]) @{thm nz_prod_sum_eq}) cth
    1.40          val rth = Conv.fconv_rule (Conv.arg_conv (Conv.binop_conv
    1.41 -                   (Normalizer.semiring_normalize_ord_conv ctxt (earlier vs)))) th
    1.42 +                   (Semiring_Normalizer.semiring_normalize_ord_conv ctxt (earlier vs)))) th
    1.43        in rth end
    1.44      | ("x+t",[t]) =>
    1.45         let
    1.46          val T = ctyp_of_term x
    1.47          val th = instantiate' [SOME T] [SOME x, SOME t] @{thm "sum_eq"}
    1.48          val rth = Conv.fconv_rule (Conv.arg_conv (Conv.binop_conv
    1.49 -              (Normalizer.semiring_normalize_ord_conv ctxt (earlier vs)))) th
    1.50 +              (Semiring_Normalizer.semiring_normalize_ord_conv ctxt (earlier vs)))) th
    1.51         in  rth end
    1.52      | ("c*x",[c]) =>
    1.53         let
    1.54 @@ -822,7 +822,7 @@
    1.55         val th = instantiate' [SOME T] [SOME ca, SOME cb] less_iff_diff_less_0
    1.56         val nth = Conv.fconv_rule
    1.57           (Conv.arg_conv (Conv.arg1_conv
    1.58 -              (Normalizer.semiring_normalize_ord_conv @{context} (earlier vs)))) th
    1.59 +              (Semiring_Normalizer.semiring_normalize_ord_conv @{context} (earlier vs)))) th
    1.60         val rth = transitive nth (xnormalize_conv ctxt vs (Thm.rhs_of nth))
    1.61     in rth end
    1.62  | Const(@{const_name Orderings.less_eq},_)$a$b =>
    1.63 @@ -831,7 +831,7 @@
    1.64         val th = instantiate' [SOME T] [SOME ca, SOME cb] le_iff_diff_le_0
    1.65         val nth = Conv.fconv_rule
    1.66           (Conv.arg_conv (Conv.arg1_conv
    1.67 -              (Normalizer.semiring_normalize_ord_conv @{context} (earlier vs)))) th
    1.68 +              (Semiring_Normalizer.semiring_normalize_ord_conv @{context} (earlier vs)))) th
    1.69         val rth = transitive nth (xnormalize_conv ctxt vs (Thm.rhs_of nth))
    1.70     in rth end
    1.71  
    1.72 @@ -841,7 +841,7 @@
    1.73         val th = instantiate' [SOME T] [SOME ca, SOME cb] eq_iff_diff_eq_0
    1.74         val nth = Conv.fconv_rule
    1.75           (Conv.arg_conv (Conv.arg1_conv
    1.76 -              (Normalizer.semiring_normalize_ord_conv @{context} (earlier vs)))) th
    1.77 +              (Semiring_Normalizer.semiring_normalize_ord_conv @{context} (earlier vs)))) th
    1.78         val rth = transitive nth (xnormalize_conv ctxt vs (Thm.rhs_of nth))
    1.79     in rth end
    1.80  | @{term "Not"} $(Const("op =",_)$a$b) => Conv.arg_conv (field_isolate_conv phi ctxt vs) ct
     2.1 --- a/src/HOL/Groebner_Basis.thy	Fri May 07 23:44:10 2010 +0200
     2.2 +++ b/src/HOL/Groebner_Basis.thy	Sat May 08 17:15:50 2010 +0200
     2.3 @@ -2,341 +2,14 @@
     2.4      Author:     Amine Chaieb, TU Muenchen
     2.5  *)
     2.6  
     2.7 -header {* Semiring normalization and Groebner Bases *}
     2.8 +header {* Groebner bases *}
     2.9  
    2.10  theory Groebner_Basis
    2.11 -imports Numeral_Simprocs Nat_Transfer
    2.12 +imports Semiring_Normalization
    2.13  uses
    2.14 -  "Tools/Groebner_Basis/normalizer.ML"
    2.15 -  ("Tools/Groebner_Basis/groebner.ML")
    2.16 -begin
    2.17 -
    2.18 -subsection {* Semiring normalization *}
    2.19 -
    2.20 -setup Normalizer.setup
    2.21 -
    2.22 -locale normalizing_semiring =
    2.23 -  fixes add mul pwr r0 r1
    2.24 -  assumes add_a:"(add x (add y z) = add (add x y) z)"
    2.25 -    and add_c: "add x y = add y x" and add_0:"add r0 x = x"
    2.26 -    and mul_a:"mul x (mul y z) = mul (mul x y) z" and mul_c:"mul x y = mul y x"
    2.27 -    and mul_1:"mul r1 x = x" and  mul_0:"mul r0 x = r0"
    2.28 -    and mul_d:"mul x (add y z) = add (mul x y) (mul x z)"
    2.29 -    and pwr_0:"pwr x 0 = r1" and pwr_Suc:"pwr x (Suc n) = mul x (pwr x n)"
    2.30 -begin
    2.31 -
    2.32 -lemma mul_pwr:"mul (pwr x p) (pwr x q) = pwr x (p + q)"
    2.33 -proof (induct p)
    2.34 -  case 0
    2.35 -  then show ?case by (auto simp add: pwr_0 mul_1)
    2.36 -next
    2.37 -  case Suc
    2.38 -  from this [symmetric] show ?case
    2.39 -    by (auto simp add: pwr_Suc mul_1 mul_a)
    2.40 -qed
    2.41 -
    2.42 -lemma pwr_mul: "pwr (mul x y) q = mul (pwr x q) (pwr y q)"
    2.43 -proof (induct q arbitrary: x y, auto simp add:pwr_0 pwr_Suc mul_1)
    2.44 -  fix q x y
    2.45 -  assume "\<And>x y. pwr (mul x y) q = mul (pwr x q) (pwr y q)"
    2.46 -  have "mul (mul x y) (mul (pwr x q) (pwr y q)) = mul x (mul y (mul (pwr x q) (pwr y q)))"
    2.47 -    by (simp add: mul_a)
    2.48 -  also have "\<dots> = (mul (mul y (mul (pwr y q) (pwr x q))) x)" by (simp add: mul_c)
    2.49 -  also have "\<dots> = (mul (mul y (pwr y q)) (mul (pwr x q) x))" by (simp add: mul_a)
    2.50 -  finally show "mul (mul x y) (mul (pwr x q) (pwr y q)) =
    2.51 -    mul (mul x (pwr x q)) (mul y (pwr y q))" by (simp add: mul_c)
    2.52 -qed
    2.53 -
    2.54 -lemma pwr_pwr: "pwr (pwr x p) q = pwr x (p * q)"
    2.55 -proof (induct p arbitrary: q)
    2.56 -  case 0
    2.57 -  show ?case using pwr_Suc mul_1 pwr_0 by (induct q) auto
    2.58 -next
    2.59 -  case Suc
    2.60 -  thus ?case by (auto simp add: mul_pwr [symmetric] pwr_mul pwr_Suc)
    2.61 -qed
    2.62 -
    2.63 -lemma semiring_ops:
    2.64 -  shows "TERM (add x y)" and "TERM (mul x y)" and "TERM (pwr x n)"
    2.65 -    and "TERM r0" and "TERM r1" .
    2.66 -
    2.67 -lemma semiring_rules:
    2.68 -  "add (mul a m) (mul b m) = mul (add a b) m"
    2.69 -  "add (mul a m) m = mul (add a r1) m"
    2.70 -  "add m (mul a m) = mul (add a r1) m"
    2.71 -  "add m m = mul (add r1 r1) m"
    2.72 -  "add r0 a = a"
    2.73 -  "add a r0 = a"
    2.74 -  "mul a b = mul b a"
    2.75 -  "mul (add a b) c = add (mul a c) (mul b c)"
    2.76 -  "mul r0 a = r0"
    2.77 -  "mul a r0 = r0"
    2.78 -  "mul r1 a = a"
    2.79 -  "mul a r1 = a"
    2.80 -  "mul (mul lx ly) (mul rx ry) = mul (mul lx rx) (mul ly ry)"
    2.81 -  "mul (mul lx ly) (mul rx ry) = mul lx (mul ly (mul rx ry))"
    2.82 -  "mul (mul lx ly) (mul rx ry) = mul rx (mul (mul lx ly) ry)"
    2.83 -  "mul (mul lx ly) rx = mul (mul lx rx) ly"
    2.84 -  "mul (mul lx ly) rx = mul lx (mul ly rx)"
    2.85 -  "mul lx (mul rx ry) = mul (mul lx rx) ry"
    2.86 -  "mul lx (mul rx ry) = mul rx (mul lx ry)"
    2.87 -  "add (add a b) (add c d) = add (add a c) (add b d)"
    2.88 -  "add (add a b) c = add a (add b c)"
    2.89 -  "add a (add c d) = add c (add a d)"
    2.90 -  "add (add a b) c = add (add a c) b"
    2.91 -  "add a c = add c a"
    2.92 -  "add a (add c d) = add (add a c) d"
    2.93 -  "mul (pwr x p) (pwr x q) = pwr x (p + q)"
    2.94 -  "mul x (pwr x q) = pwr x (Suc q)"
    2.95 -  "mul (pwr x q) x = pwr x (Suc q)"
    2.96 -  "mul x x = pwr x 2"
    2.97 -  "pwr (mul x y) q = mul (pwr x q) (pwr y q)"
    2.98 -  "pwr (pwr x p) q = pwr x (p * q)"
    2.99 -  "pwr x 0 = r1"
   2.100 -  "pwr x 1 = x"
   2.101 -  "mul x (add y z) = add (mul x y) (mul x z)"
   2.102 -  "pwr x (Suc q) = mul x (pwr x q)"
   2.103 -  "pwr x (2*n) = mul (pwr x n) (pwr x n)"
   2.104 -  "pwr x (Suc (2*n)) = mul x (mul (pwr x n) (pwr x n))"
   2.105 -proof -
   2.106 -  show "add (mul a m) (mul b m) = mul (add a b) m" using mul_d mul_c by simp
   2.107 -next show"add (mul a m) m = mul (add a r1) m" using mul_d mul_c mul_1 by simp
   2.108 -next show "add m (mul a m) = mul (add a r1) m" using mul_c mul_d mul_1 add_c by simp
   2.109 -next show "add m m = mul (add r1 r1) m" using mul_c mul_d mul_1 by simp
   2.110 -next show "add r0 a = a" using add_0 by simp
   2.111 -next show "add a r0 = a" using add_0 add_c by simp
   2.112 -next show "mul a b = mul b a" using mul_c by simp
   2.113 -next show "mul (add a b) c = add (mul a c) (mul b c)" using mul_c mul_d by simp
   2.114 -next show "mul r0 a = r0" using mul_0 by simp
   2.115 -next show "mul a r0 = r0" using mul_0 mul_c by simp
   2.116 -next show "mul r1 a = a" using mul_1 by simp
   2.117 -next show "mul a r1 = a" using mul_1 mul_c by simp
   2.118 -next show "mul (mul lx ly) (mul rx ry) = mul (mul lx rx) (mul ly ry)"
   2.119 -    using mul_c mul_a by simp
   2.120 -next show "mul (mul lx ly) (mul rx ry) = mul lx (mul ly (mul rx ry))"
   2.121 -    using mul_a by simp
   2.122 -next
   2.123 -  have "mul (mul lx ly) (mul rx ry) = mul (mul rx ry) (mul lx ly)" by (rule mul_c)
   2.124 -  also have "\<dots> = mul rx (mul ry (mul lx ly))" using mul_a by simp
   2.125 -  finally
   2.126 -  show "mul (mul lx ly) (mul rx ry) = mul rx (mul (mul lx ly) ry)"
   2.127 -    using mul_c by simp
   2.128 -next show "mul (mul lx ly) rx = mul (mul lx rx) ly" using mul_c mul_a by simp
   2.129 -next
   2.130 -  show "mul (mul lx ly) rx = mul lx (mul ly rx)" by (simp add: mul_a)
   2.131 -next show "mul lx (mul rx ry) = mul (mul lx rx) ry" by (simp add: mul_a )
   2.132 -next show "mul lx (mul rx ry) = mul rx (mul lx ry)" by (simp add: mul_a,simp add: mul_c)
   2.133 -next show "add (add a b) (add c d) = add (add a c) (add b d)"
   2.134 -    using add_c add_a by simp
   2.135 -next show "add (add a b) c = add a (add b c)" using add_a by simp
   2.136 -next show "add a (add c d) = add c (add a d)"
   2.137 -    apply (simp add: add_a) by (simp only: add_c)
   2.138 -next show "add (add a b) c = add (add a c) b" using add_a add_c by simp
   2.139 -next show "add a c = add c a" by (rule add_c)
   2.140 -next show "add a (add c d) = add (add a c) d" using add_a by simp
   2.141 -next show "mul (pwr x p) (pwr x q) = pwr x (p + q)" by (rule mul_pwr)
   2.142 -next show "mul x (pwr x q) = pwr x (Suc q)" using pwr_Suc by simp
   2.143 -next show "mul (pwr x q) x = pwr x (Suc q)" using pwr_Suc mul_c by simp
   2.144 -next show "mul x x = pwr x 2" by (simp add: nat_number' pwr_Suc pwr_0 mul_1 mul_c)
   2.145 -next show "pwr (mul x y) q = mul (pwr x q) (pwr y q)" by (rule pwr_mul)
   2.146 -next show "pwr (pwr x p) q = pwr x (p * q)" by (rule pwr_pwr)
   2.147 -next show "pwr x 0 = r1" using pwr_0 .
   2.148 -next show "pwr x 1 = x" unfolding One_nat_def by (simp add: nat_number' pwr_Suc pwr_0 mul_1 mul_c)
   2.149 -next show "mul x (add y z) = add (mul x y) (mul x z)" using mul_d by simp
   2.150 -next show "pwr x (Suc q) = mul x (pwr x q)" using pwr_Suc by simp
   2.151 -next show "pwr x (2 * n) = mul (pwr x n) (pwr x n)" by (simp add: nat_number' mul_pwr)
   2.152 -next show "pwr x (Suc (2 * n)) = mul x (mul (pwr x n) (pwr x n))"
   2.153 -    by (simp add: nat_number' pwr_Suc mul_pwr)
   2.154 -qed
   2.155 -
   2.156 -
   2.157 -lemmas normalizing_semiring_axioms' =
   2.158 -  normalizing_semiring_axioms [normalizer
   2.159 -    semiring ops: semiring_ops
   2.160 -    semiring rules: semiring_rules]
   2.161 -
   2.162 -end
   2.163 -
   2.164 -sublocale comm_semiring_1
   2.165 -  < normalizing!: normalizing_semiring plus times power zero one
   2.166 -proof
   2.167 -qed (simp_all add: algebra_simps)
   2.168 -
   2.169 -declaration {* Normalizer.semiring_funs @{thm normalizing.normalizing_semiring_axioms'} *}
   2.170 -
   2.171 -locale normalizing_ring = normalizing_semiring +
   2.172 -  fixes sub :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"
   2.173 -    and neg :: "'a \<Rightarrow> 'a"
   2.174 -  assumes neg_mul: "neg x = mul (neg r1) x"
   2.175 -    and sub_add: "sub x y = add x (neg y)"
   2.176 +  ("Tools/groebner.ML")
   2.177  begin
   2.178  
   2.179 -lemma ring_ops: shows "TERM (sub x y)" and "TERM (neg x)" .
   2.180 -
   2.181 -lemmas ring_rules = neg_mul sub_add
   2.182 -
   2.183 -lemmas normalizing_ring_axioms' =
   2.184 -  normalizing_ring_axioms [normalizer
   2.185 -    semiring ops: semiring_ops
   2.186 -    semiring rules: semiring_rules
   2.187 -    ring ops: ring_ops
   2.188 -    ring rules: ring_rules]
   2.189 -
   2.190 -end
   2.191 -
   2.192 -sublocale comm_ring_1
   2.193 -  < normalizing!: normalizing_ring plus times power zero one minus uminus
   2.194 -proof
   2.195 -qed (simp_all add: diff_minus)
   2.196 -
   2.197 -declaration {* Normalizer.semiring_funs @{thm normalizing.normalizing_ring_axioms'} *}
   2.198 -
   2.199 -locale normalizing_field = normalizing_ring +
   2.200 -  fixes divide :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"
   2.201 -    and inverse:: "'a \<Rightarrow> 'a"
   2.202 -  assumes divide_inverse: "divide x y = mul x (inverse y)"
   2.203 -     and inverse_divide: "inverse x = divide r1 x"
   2.204 -begin
   2.205 -
   2.206 -lemma field_ops: shows "TERM (divide x y)" and "TERM (inverse x)" .
   2.207 -
   2.208 -lemmas field_rules = divide_inverse inverse_divide
   2.209 -
   2.210 -lemmas normalizing_field_axioms' =
   2.211 -  normalizing_field_axioms [normalizer
   2.212 -    semiring ops: semiring_ops
   2.213 -    semiring rules: semiring_rules
   2.214 -    ring ops: ring_ops
   2.215 -    ring rules: ring_rules
   2.216 -    field ops: field_ops
   2.217 -    field rules: field_rules]
   2.218 -
   2.219 -end
   2.220 -
   2.221 -locale normalizing_semiring_cancel = normalizing_semiring +
   2.222 -  assumes add_cancel: "add (x::'a) y = add x z \<longleftrightarrow> y = z"
   2.223 -  and add_mul_solve: "add (mul w y) (mul x z) =
   2.224 -    add (mul w z) (mul x y) \<longleftrightarrow> w = x \<or> y = z"
   2.225 -begin
   2.226 -
   2.227 -lemma noteq_reduce: "a \<noteq> b \<and> c \<noteq> d \<longleftrightarrow> add (mul a c) (mul b d) \<noteq> add (mul a d) (mul b c)"
   2.228 -proof-
   2.229 -  have "a \<noteq> b \<and> c \<noteq> d \<longleftrightarrow> \<not> (a = b \<or> c = d)" by simp
   2.230 -  also have "\<dots> \<longleftrightarrow> add (mul a c) (mul b d) \<noteq> add (mul a d) (mul b c)"
   2.231 -    using add_mul_solve by blast
   2.232 -  finally show "a \<noteq> b \<and> c \<noteq> d \<longleftrightarrow> add (mul a c) (mul b d) \<noteq> add (mul a d) (mul b c)"
   2.233 -    by simp
   2.234 -qed
   2.235 -
   2.236 -lemma add_scale_eq_noteq: "\<lbrakk>r \<noteq> r0 ; (a = b) \<and> ~(c = d)\<rbrakk>
   2.237 -  \<Longrightarrow> add a (mul r c) \<noteq> add b (mul r d)"
   2.238 -proof(clarify)
   2.239 -  assume nz: "r\<noteq> r0" and cnd: "c\<noteq>d"
   2.240 -    and eq: "add b (mul r c) = add b (mul r d)"
   2.241 -  hence "mul r c = mul r d" using cnd add_cancel by simp
   2.242 -  hence "add (mul r0 d) (mul r c) = add (mul r0 c) (mul r d)"
   2.243 -    using mul_0 add_cancel by simp
   2.244 -  thus "False" using add_mul_solve nz cnd by simp
   2.245 -qed
   2.246 -
   2.247 -lemma add_r0_iff: " x = add x a \<longleftrightarrow> a = r0"
   2.248 -proof-
   2.249 -  have "a = r0 \<longleftrightarrow> add x a = add x r0" by (simp add: add_cancel)
   2.250 -  thus "x = add x a \<longleftrightarrow> a = r0" by (auto simp add: add_c add_0)
   2.251 -qed
   2.252 -
   2.253 -declare normalizing_semiring_axioms' [normalizer del]
   2.254 -
   2.255 -lemmas normalizing_semiring_cancel_axioms' =
   2.256 -  normalizing_semiring_cancel_axioms [normalizer
   2.257 -    semiring ops: semiring_ops
   2.258 -    semiring rules: semiring_rules
   2.259 -    idom rules: noteq_reduce add_scale_eq_noteq]
   2.260 -
   2.261 -end
   2.262 -
   2.263 -locale normalizing_ring_cancel = normalizing_semiring_cancel + normalizing_ring + 
   2.264 -  assumes subr0_iff: "sub x y = r0 \<longleftrightarrow> x = y"
   2.265 -begin
   2.266 -
   2.267 -declare normalizing_ring_axioms' [normalizer del]
   2.268 -
   2.269 -lemmas normalizing_ring_cancel_axioms' = normalizing_ring_cancel_axioms [normalizer
   2.270 -  semiring ops: semiring_ops
   2.271 -  semiring rules: semiring_rules
   2.272 -  ring ops: ring_ops
   2.273 -  ring rules: ring_rules
   2.274 -  idom rules: noteq_reduce add_scale_eq_noteq
   2.275 -  ideal rules: subr0_iff add_r0_iff]
   2.276 -
   2.277 -end
   2.278 -
   2.279 -sublocale idom
   2.280 -  < normalizing!: normalizing_ring_cancel plus times power zero one minus uminus
   2.281 -proof
   2.282 -  fix w x y z
   2.283 -  show "w * y + x * z = w * z + x * y \<longleftrightarrow> w = x \<or> y = z"
   2.284 -  proof
   2.285 -    assume "w * y + x * z = w * z + x * y"
   2.286 -    then have "w * y + x * z - w * z - x * y = 0" by (simp add: algebra_simps)
   2.287 -    then have "w * (y - z) - x * (y - z) = 0" by (simp add: algebra_simps)
   2.288 -    then have "(y - z) * (w - x) = 0" by (simp add: algebra_simps)
   2.289 -    then have "y - z = 0 \<or> w - x = 0" by (rule divisors_zero)
   2.290 -    then show "w = x \<or> y = z" by auto
   2.291 -  qed (auto simp add: add_ac)
   2.292 -qed (simp_all add: algebra_simps)
   2.293 -
   2.294 -declaration {* Normalizer.semiring_funs @{thm normalizing.normalizing_ring_cancel_axioms'} *}
   2.295 -
   2.296 -interpretation normalizing_nat!: normalizing_semiring_cancel
   2.297 -  "op +" "op *" "op ^" "0::nat" "1"
   2.298 -proof (unfold_locales, simp add: algebra_simps)
   2.299 -  fix w x y z ::"nat"
   2.300 -  { assume p: "w * y + x * z = w * z + x * y" and ynz: "y \<noteq> z"
   2.301 -    hence "y < z \<or> y > z" by arith
   2.302 -    moreover {
   2.303 -      assume lt:"y <z" hence "\<exists>k. z = y + k \<and> k > 0" by (rule_tac x="z - y" in exI, auto)
   2.304 -      then obtain k where kp: "k>0" and yz:"z = y + k" by blast
   2.305 -      from p have "(w * y + x *y) + x*k = (w * y + x*y) + w*k" by (simp add: yz algebra_simps)
   2.306 -      hence "x*k = w*k" by simp
   2.307 -      hence "w = x" using kp by simp }
   2.308 -    moreover {
   2.309 -      assume lt: "y >z" hence "\<exists>k. y = z + k \<and> k>0" by (rule_tac x="y - z" in exI, auto)
   2.310 -      then obtain k where kp: "k>0" and yz:"y = z + k" by blast
   2.311 -      from p have "(w * z + x *z) + w*k = (w * z + x*z) + x*k" by (simp add: yz algebra_simps)
   2.312 -      hence "w*k = x*k" by simp
   2.313 -      hence "w = x" using kp by simp }
   2.314 -    ultimately have "w=x" by blast }
   2.315 -  thus "(w * y + x * z = w * z + x * y) = (w = x \<or> y = z)" by auto
   2.316 -qed
   2.317 -
   2.318 -declaration {* Normalizer.semiring_funs @{thm normalizing_nat.normalizing_semiring_cancel_axioms'} *}
   2.319 -
   2.320 -locale normalizing_field_cancel = normalizing_ring_cancel + normalizing_field
   2.321 -begin
   2.322 -
   2.323 -declare normalizing_field_axioms' [normalizer del]
   2.324 -
   2.325 -lemmas normalizing_field_cancel_axioms' = normalizing_field_cancel_axioms [normalizer
   2.326 -  semiring ops: semiring_ops
   2.327 -  semiring rules: semiring_rules
   2.328 -  ring ops: ring_ops
   2.329 -  ring rules: ring_rules
   2.330 -  field ops: field_ops
   2.331 -  field rules: field_rules
   2.332 -  idom rules: noteq_reduce add_scale_eq_noteq
   2.333 -  ideal rules: subr0_iff add_r0_iff]
   2.334 -
   2.335 -end
   2.336 -
   2.337 -sublocale field 
   2.338 -  < normalizing!: normalizing_field_cancel plus times power zero one minus uminus divide inverse
   2.339 -proof
   2.340 -qed (simp_all add: divide_inverse)
   2.341 -
   2.342 -declaration {* Normalizer.field_funs @{thm normalizing.normalizing_field_cancel_axioms'} *}
   2.343 - 
   2.344 -
   2.345  subsection {* Groebner Bases *}
   2.346  
   2.347  lemmas bool_simps = simp_thms(1-34)
   2.348 @@ -367,6 +40,11 @@
   2.349  
   2.350  setup Algebra_Simplification.setup
   2.351  
   2.352 +use "Tools/groebner.ML"
   2.353 +
   2.354 +method_setup algebra = Groebner.algebra_method
   2.355 +  "solve polynomial equations over (semi)rings and ideal membership problems using Groebner bases"
   2.356 +
   2.357  declare dvd_def[algebra]
   2.358  declare dvd_eq_mod_eq_0[symmetric, algebra]
   2.359  declare mod_div_trivial[algebra]
   2.360 @@ -395,9 +73,4 @@
   2.361  declare zmod_eq_dvd_iff[algebra]
   2.362  declare nat_mod_eq_iff[algebra]
   2.363  
   2.364 -use "Tools/Groebner_Basis/groebner.ML"
   2.365 -
   2.366 -method_setup algebra = Groebner.algebra_method
   2.367 -  "solve polynomial equations over (semi)rings and ideal membership problems using Groebner bases"
   2.368 -
   2.369  end
     3.1 --- a/src/HOL/Int.thy	Fri May 07 23:44:10 2010 +0200
     3.2 +++ b/src/HOL/Int.thy	Sat May 08 17:15:50 2010 +0200
     3.3 @@ -2173,6 +2173,25 @@
     3.4    apply (auto simp add: dvd_imp_le)
     3.5    done
     3.6  
     3.7 +lemma zdvd_period:
     3.8 +  fixes a d :: int
     3.9 +  assumes "a dvd d"
    3.10 +  shows "a dvd (x + t) \<longleftrightarrow> a dvd ((x + c * d) + t)"
    3.11 +proof -
    3.12 +  from assms obtain k where "d = a * k" by (rule dvdE)
    3.13 +  show ?thesis proof
    3.14 +    assume "a dvd (x + t)"
    3.15 +    then obtain l where "x + t = a * l" by (rule dvdE)
    3.16 +    then have "x = a * l - t" by simp
    3.17 +    with `d = a * k` show "a dvd x + c * d + t" by simp
    3.18 +  next
    3.19 +    assume "a dvd x + c * d + t"
    3.20 +    then obtain l where "x + c * d + t = a * l" by (rule dvdE)
    3.21 +    then have "x = a * l - c * d - t" by simp
    3.22 +    with `d = a * k` show "a dvd (x + t)" by simp
    3.23 +  qed
    3.24 +qed
    3.25 +
    3.26  
    3.27  subsection {* Configuration of the code generator *}
    3.28  
     4.1 --- a/src/HOL/IsaMakefile	Fri May 07 23:44:10 2010 +0200
     4.2 +++ b/src/HOL/IsaMakefile	Sat May 08 17:15:50 2010 +0200
     4.3 @@ -271,6 +271,7 @@
     4.4    Random.thy \
     4.5    Random_Sequence.thy \
     4.6    Recdef.thy \
     4.7 +  Semiring_Normalization.thy \
     4.8    SetInterval.thy \
     4.9    Sledgehammer.thy \
    4.10    String.thy \
    4.11 @@ -283,10 +284,9 @@
    4.12    $(SRC)/Tools/Metis/metis.ML \
    4.13    Tools/ATP_Manager/atp_manager.ML \
    4.14    Tools/ATP_Manager/atp_systems.ML \
    4.15 -  Tools/Groebner_Basis/groebner.ML \
    4.16 -  Tools/Groebner_Basis/normalizer.ML \
    4.17    Tools/choice_specification.ML \
    4.18    Tools/int_arith.ML \
    4.19 +  Tools/groebner.ML \
    4.20    Tools/list_code.ML \
    4.21    Tools/meson.ML \
    4.22    Tools/nat_numeral_simprocs.ML \
    4.23 @@ -313,6 +313,7 @@
    4.24    Tools/Quotient/quotient_term.ML \
    4.25    Tools/Quotient/quotient_typ.ML \
    4.26    Tools/recdef.ML \
    4.27 +  Tools/semiring_normalizer.ML \
    4.28    Tools/Sledgehammer/meson_tactic.ML \
    4.29    Tools/Sledgehammer/metis_tactics.ML \
    4.30    Tools/Sledgehammer/sledgehammer_fact_filter.ML \
     5.1 --- a/src/HOL/Library/Sum_Of_Squares/sum_of_squares.ML	Fri May 07 23:44:10 2010 +0200
     5.2 +++ b/src/HOL/Library/Sum_Of_Squares/sum_of_squares.ML	Sat May 08 17:15:50 2010 +0200
     5.3 @@ -1194,8 +1194,8 @@
     5.4    (* FIXME: Replace tryfind by get_first !! *)
     5.5  fun real_nonlinear_prover proof_method ctxt =
     5.6   let
     5.7 -  val {add,mul,neg,pow,sub,main} =  Normalizer.semiring_normalizers_ord_wrapper ctxt
     5.8 -      (the (Normalizer.match ctxt @{cterm "(0::real) + 1"}))
     5.9 +  val {add,mul,neg,pow,sub,main} =  Semiring_Normalizer.semiring_normalizers_ord_wrapper ctxt
    5.10 +      (the (Semiring_Normalizer.match ctxt @{cterm "(0::real) + 1"}))
    5.11       simple_cterm_ord
    5.12    val (real_poly_add_conv,real_poly_mul_conv,real_poly_neg_conv,
    5.13         real_poly_pow_conv,real_poly_sub_conv,real_poly_conv) = (add,mul,neg,pow,sub,main)
    5.14 @@ -1222,7 +1222,7 @@
    5.15     in
    5.16    (let val th = tryfind trivial_axiom (keq @ klep @ kltp)
    5.17     in
    5.18 -    (fconv_rule (arg_conv (arg1_conv real_poly_conv) then_conv Normalizer.field_comp_conv) th, RealArith.Trivial)
    5.19 +    (fconv_rule (arg_conv (arg1_conv real_poly_conv) then_conv Numeral_Simprocs.field_comp_conv) th, RealArith.Trivial)
    5.20     end)
    5.21     handle Failure _ =>
    5.22       (let val proof =
    5.23 @@ -1309,8 +1309,8 @@
    5.24  
    5.25  fun real_nonlinear_subst_prover prover ctxt =
    5.26   let
    5.27 -  val {add,mul,neg,pow,sub,main} =  Normalizer.semiring_normalizers_ord_wrapper ctxt
    5.28 -      (the (Normalizer.match ctxt @{cterm "(0::real) + 1"}))
    5.29 +  val {add,mul,neg,pow,sub,main} =  Semiring_Normalizer.semiring_normalizers_ord_wrapper ctxt
    5.30 +      (the (Semiring_Normalizer.match ctxt @{cterm "(0::real) + 1"}))
    5.31       simple_cterm_ord
    5.32  
    5.33    val (real_poly_add_conv,real_poly_mul_conv,real_poly_neg_conv,
     6.1 --- a/src/HOL/Library/normarith.ML	Fri May 07 23:44:10 2010 +0200
     6.2 +++ b/src/HOL/Library/normarith.ML	Sat May 08 17:15:50 2010 +0200
     6.3 @@ -166,9 +166,9 @@
     6.4   let 
     6.5    (* FIXME : Should be computed statically!! *)
     6.6    val real_poly_conv = 
     6.7 -    Normalizer.semiring_normalize_wrapper ctxt
     6.8 -     (the (Normalizer.match ctxt @{cterm "(0::real) + 1"}))
     6.9 - in fconv_rule (arg_conv ((rewr_conv @{thm ge_iff_diff_ge_0}) then_conv arg_conv (Normalizer.field_comp_conv then_conv real_poly_conv)))
    6.10 +    Semiring_Normalizer.semiring_normalize_wrapper ctxt
    6.11 +     (the (Semiring_Normalizer.match ctxt @{cterm "(0::real) + 1"}))
    6.12 + in fconv_rule (arg_conv ((rewr_conv @{thm ge_iff_diff_ge_0}) then_conv arg_conv (Numeral_Simprocs.field_comp_conv then_conv real_poly_conv)))
    6.13  end;
    6.14  
    6.15   fun absc cv ct = case term_of ct of 
    6.16 @@ -190,8 +190,8 @@
    6.17   val apply_pth5 = rewr_conv @{thm pth_5};
    6.18   val apply_pth6 = rewr_conv @{thm pth_6};
    6.19   val apply_pth7 = rewrs_conv @{thms pth_7};
    6.20 - val apply_pth8 = rewr_conv @{thm pth_8} then_conv arg1_conv Normalizer.field_comp_conv then_conv (try_conv (rewr_conv (mk_meta_eq @{thm scaleR_zero_left})));
    6.21 - val apply_pth9 = rewrs_conv @{thms pth_9} then_conv arg1_conv (arg1_conv Normalizer.field_comp_conv);
    6.22 + val apply_pth8 = rewr_conv @{thm pth_8} then_conv arg1_conv Numeral_Simprocs.field_comp_conv then_conv (try_conv (rewr_conv (mk_meta_eq @{thm scaleR_zero_left})));
    6.23 + val apply_pth9 = rewrs_conv @{thms pth_9} then_conv arg1_conv (arg1_conv Numeral_Simprocs.field_comp_conv);
    6.24   val apply_ptha = rewr_conv @{thm pth_a};
    6.25   val apply_pthb = rewrs_conv @{thms pth_b};
    6.26   val apply_pthc = rewrs_conv @{thms pth_c};
    6.27 @@ -204,7 +204,7 @@
    6.28   | _ => error "headvector: non-canonical term"
    6.29  
    6.30  fun vector_cmul_conv ct =
    6.31 -   ((apply_pth5 then_conv arg1_conv Normalizer.field_comp_conv) else_conv
    6.32 +   ((apply_pth5 then_conv arg1_conv Numeral_Simprocs.field_comp_conv) else_conv
    6.33      (apply_pth6 then_conv binop_conv vector_cmul_conv)) ct
    6.34  
    6.35  fun vector_add_conv ct = apply_pth7 ct 
    6.36 @@ -277,8 +277,8 @@
    6.37    let 
    6.38     (* FIXME: Should be computed statically!!*)
    6.39     val real_poly_conv = 
    6.40 -      Normalizer.semiring_normalize_wrapper ctxt
    6.41 -       (the (Normalizer.match ctxt @{cterm "(0::real) + 1"}))
    6.42 +      Semiring_Normalizer.semiring_normalize_wrapper ctxt
    6.43 +       (the (Semiring_Normalizer.match ctxt @{cterm "(0::real) + 1"}))
    6.44     val sources = map (Thm.dest_arg o Thm.dest_arg1 o concl) nubs
    6.45     val rawdests = fold_rev (find_normedterms o Thm.dest_arg o concl) (ges @ gts) [] 
    6.46     val _ = if not (forall fst rawdests) then error "real_vector_combo_prover: Sanity check" 
    6.47 @@ -383,8 +383,8 @@
    6.48   fun splitequation ctxt th acc =
    6.49    let 
    6.50     val real_poly_neg_conv = #neg
    6.51 -       (Normalizer.semiring_normalizers_ord_wrapper ctxt
    6.52 -        (the (Normalizer.match ctxt @{cterm "(0::real) + 1"})) simple_cterm_ord)
    6.53 +       (Semiring_Normalizer.semiring_normalizers_ord_wrapper ctxt
    6.54 +        (the (Semiring_Normalizer.match ctxt @{cterm "(0::real) + 1"})) simple_cterm_ord)
    6.55     val (th1,th2) = conj_pair(rawrule th)
    6.56    in th1::fconv_rule (arg_conv (arg_conv real_poly_neg_conv)) th2::acc
    6.57    end
    6.58 @@ -396,7 +396,7 @@
    6.59    fun init_conv ctxt = 
    6.60     Simplifier.rewrite (Simplifier.context ctxt 
    6.61       (HOL_basic_ss addsimps ([(*@{thm vec_0}, @{thm vec_1},*) @{thm dist_norm}, @{thm diff_0_right}, @{thm right_minus}, @{thm diff_self}, @{thm norm_zero}] @ @{thms arithmetic_simps} @ @{thms norm_pths})))
    6.62 -   then_conv Normalizer.field_comp_conv 
    6.63 +   then_conv Numeral_Simprocs.field_comp_conv 
    6.64     then_conv nnf_conv
    6.65  
    6.66   fun pure ctxt = fst o RealArith.gen_prover_real_arith ctxt (real_vector_prover ctxt);
     7.1 --- a/src/HOL/Library/positivstellensatz.ML	Fri May 07 23:44:10 2010 +0200
     7.2 +++ b/src/HOL/Library/positivstellensatz.ML	Sat May 08 17:15:50 2010 +0200
     7.3 @@ -747,11 +747,11 @@
     7.4   let
     7.5    fun simple_cterm_ord t u = Term_Ord.term_ord (term_of t, term_of u) = LESS
     7.6    val {add,mul,neg,pow,sub,main} = 
     7.7 -     Normalizer.semiring_normalizers_ord_wrapper ctxt
     7.8 -      (the (Normalizer.match ctxt @{cterm "(0::real) + 1"})) 
     7.9 +     Semiring_Normalizer.semiring_normalizers_ord_wrapper ctxt
    7.10 +      (the (Semiring_Normalizer.match ctxt @{cterm "(0::real) + 1"})) 
    7.11       simple_cterm_ord
    7.12  in gen_real_arith ctxt
    7.13 -   (cterm_of_rat, Normalizer.field_comp_conv, Normalizer.field_comp_conv, Normalizer.field_comp_conv,
    7.14 +   (cterm_of_rat, Numeral_Simprocs.field_comp_conv, Numeral_Simprocs.field_comp_conv, Numeral_Simprocs.field_comp_conv,
    7.15      main,neg,add,mul, prover)
    7.16  end;
    7.17  
     8.1 --- a/src/HOL/Presburger.thy	Fri May 07 23:44:10 2010 +0200
     8.2 +++ b/src/HOL/Presburger.thy	Sat May 08 17:15:50 2010 +0200
     8.3 @@ -457,14 +457,4 @@
     8.4  lemma [presburger, algebra]: "m mod (Suc (Suc 0)) = Suc 0 \<longleftrightarrow> \<not> 2 dvd m " by presburger
     8.5  lemma [presburger, algebra]: "m mod 2 = (1::int) \<longleftrightarrow> \<not> 2 dvd m " by presburger
     8.6  
     8.7 -
     8.8 -lemma zdvd_period:
     8.9 -  fixes a d :: int
    8.10 -  assumes advdd: "a dvd d"
    8.11 -  shows "a dvd (x + t) \<longleftrightarrow> a dvd ((x + c * d) + t)"
    8.12 -  using advdd
    8.13 -  apply -
    8.14 -  apply (rule iffI)
    8.15 -  by algebra+
    8.16 -
    8.17  end
     9.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     9.2 +++ b/src/HOL/Semiring_Normalization.thy	Sat May 08 17:15:50 2010 +0200
     9.3 @@ -0,0 +1,336 @@
     9.4 +(*  Title:      HOL/Semiring_Normalization.thy
     9.5 +    Author:     Amine Chaieb, TU Muenchen
     9.6 +*)
     9.7 +
     9.8 +header {* Semiring normalization *}
     9.9 +
    9.10 +theory Semiring_Normalization
    9.11 +imports Numeral_Simprocs Nat_Transfer
    9.12 +uses
    9.13 +  "Tools/semiring_normalizer.ML"
    9.14 +begin
    9.15 +
    9.16 +setup Semiring_Normalizer.setup
    9.17 +
    9.18 +locale normalizing_semiring =
    9.19 +  fixes add mul pwr r0 r1
    9.20 +  assumes add_a:"(add x (add y z) = add (add x y) z)"
    9.21 +    and add_c: "add x y = add y x" and add_0:"add r0 x = x"
    9.22 +    and mul_a:"mul x (mul y z) = mul (mul x y) z" and mul_c:"mul x y = mul y x"
    9.23 +    and mul_1:"mul r1 x = x" and  mul_0:"mul r0 x = r0"
    9.24 +    and mul_d:"mul x (add y z) = add (mul x y) (mul x z)"
    9.25 +    and pwr_0:"pwr x 0 = r1" and pwr_Suc:"pwr x (Suc n) = mul x (pwr x n)"
    9.26 +begin
    9.27 +
    9.28 +lemma mul_pwr:"mul (pwr x p) (pwr x q) = pwr x (p + q)"
    9.29 +proof (induct p)
    9.30 +  case 0
    9.31 +  then show ?case by (auto simp add: pwr_0 mul_1)
    9.32 +next
    9.33 +  case Suc
    9.34 +  from this [symmetric] show ?case
    9.35 +    by (auto simp add: pwr_Suc mul_1 mul_a)
    9.36 +qed
    9.37 +
    9.38 +lemma pwr_mul: "pwr (mul x y) q = mul (pwr x q) (pwr y q)"
    9.39 +proof (induct q arbitrary: x y, auto simp add:pwr_0 pwr_Suc mul_1)
    9.40 +  fix q x y
    9.41 +  assume "\<And>x y. pwr (mul x y) q = mul (pwr x q) (pwr y q)"
    9.42 +  have "mul (mul x y) (mul (pwr x q) (pwr y q)) = mul x (mul y (mul (pwr x q) (pwr y q)))"
    9.43 +    by (simp add: mul_a)
    9.44 +  also have "\<dots> = (mul (mul y (mul (pwr y q) (pwr x q))) x)" by (simp add: mul_c)
    9.45 +  also have "\<dots> = (mul (mul y (pwr y q)) (mul (pwr x q) x))" by (simp add: mul_a)
    9.46 +  finally show "mul (mul x y) (mul (pwr x q) (pwr y q)) =
    9.47 +    mul (mul x (pwr x q)) (mul y (pwr y q))" by (simp add: mul_c)
    9.48 +qed
    9.49 +
    9.50 +lemma pwr_pwr: "pwr (pwr x p) q = pwr x (p * q)"
    9.51 +proof (induct p arbitrary: q)
    9.52 +  case 0
    9.53 +  show ?case using pwr_Suc mul_1 pwr_0 by (induct q) auto
    9.54 +next
    9.55 +  case Suc
    9.56 +  thus ?case by (auto simp add: mul_pwr [symmetric] pwr_mul pwr_Suc)
    9.57 +qed
    9.58 +
    9.59 +lemma semiring_ops:
    9.60 +  shows "TERM (add x y)" and "TERM (mul x y)" and "TERM (pwr x n)"
    9.61 +    and "TERM r0" and "TERM r1" .
    9.62 +
    9.63 +lemma semiring_rules:
    9.64 +  "add (mul a m) (mul b m) = mul (add a b) m"
    9.65 +  "add (mul a m) m = mul (add a r1) m"
    9.66 +  "add m (mul a m) = mul (add a r1) m"
    9.67 +  "add m m = mul (add r1 r1) m"
    9.68 +  "add r0 a = a"
    9.69 +  "add a r0 = a"
    9.70 +  "mul a b = mul b a"
    9.71 +  "mul (add a b) c = add (mul a c) (mul b c)"
    9.72 +  "mul r0 a = r0"
    9.73 +  "mul a r0 = r0"
    9.74 +  "mul r1 a = a"
    9.75 +  "mul a r1 = a"
    9.76 +  "mul (mul lx ly) (mul rx ry) = mul (mul lx rx) (mul ly ry)"
    9.77 +  "mul (mul lx ly) (mul rx ry) = mul lx (mul ly (mul rx ry))"
    9.78 +  "mul (mul lx ly) (mul rx ry) = mul rx (mul (mul lx ly) ry)"
    9.79 +  "mul (mul lx ly) rx = mul (mul lx rx) ly"
    9.80 +  "mul (mul lx ly) rx = mul lx (mul ly rx)"
    9.81 +  "mul lx (mul rx ry) = mul (mul lx rx) ry"
    9.82 +  "mul lx (mul rx ry) = mul rx (mul lx ry)"
    9.83 +  "add (add a b) (add c d) = add (add a c) (add b d)"
    9.84 +  "add (add a b) c = add a (add b c)"
    9.85 +  "add a (add c d) = add c (add a d)"
    9.86 +  "add (add a b) c = add (add a c) b"
    9.87 +  "add a c = add c a"
    9.88 +  "add a (add c d) = add (add a c) d"
    9.89 +  "mul (pwr x p) (pwr x q) = pwr x (p + q)"
    9.90 +  "mul x (pwr x q) = pwr x (Suc q)"
    9.91 +  "mul (pwr x q) x = pwr x (Suc q)"
    9.92 +  "mul x x = pwr x 2"
    9.93 +  "pwr (mul x y) q = mul (pwr x q) (pwr y q)"
    9.94 +  "pwr (pwr x p) q = pwr x (p * q)"
    9.95 +  "pwr x 0 = r1"
    9.96 +  "pwr x 1 = x"
    9.97 +  "mul x (add y z) = add (mul x y) (mul x z)"
    9.98 +  "pwr x (Suc q) = mul x (pwr x q)"
    9.99 +  "pwr x (2*n) = mul (pwr x n) (pwr x n)"
   9.100 +  "pwr x (Suc (2*n)) = mul x (mul (pwr x n) (pwr x n))"
   9.101 +proof -
   9.102 +  show "add (mul a m) (mul b m) = mul (add a b) m" using mul_d mul_c by simp
   9.103 +next show"add (mul a m) m = mul (add a r1) m" using mul_d mul_c mul_1 by simp
   9.104 +next show "add m (mul a m) = mul (add a r1) m" using mul_c mul_d mul_1 add_c by simp
   9.105 +next show "add m m = mul (add r1 r1) m" using mul_c mul_d mul_1 by simp
   9.106 +next show "add r0 a = a" using add_0 by simp
   9.107 +next show "add a r0 = a" using add_0 add_c by simp
   9.108 +next show "mul a b = mul b a" using mul_c by simp
   9.109 +next show "mul (add a b) c = add (mul a c) (mul b c)" using mul_c mul_d by simp
   9.110 +next show "mul r0 a = r0" using mul_0 by simp
   9.111 +next show "mul a r0 = r0" using mul_0 mul_c by simp
   9.112 +next show "mul r1 a = a" using mul_1 by simp
   9.113 +next show "mul a r1 = a" using mul_1 mul_c by simp
   9.114 +next show "mul (mul lx ly) (mul rx ry) = mul (mul lx rx) (mul ly ry)"
   9.115 +    using mul_c mul_a by simp
   9.116 +next show "mul (mul lx ly) (mul rx ry) = mul lx (mul ly (mul rx ry))"
   9.117 +    using mul_a by simp
   9.118 +next
   9.119 +  have "mul (mul lx ly) (mul rx ry) = mul (mul rx ry) (mul lx ly)" by (rule mul_c)
   9.120 +  also have "\<dots> = mul rx (mul ry (mul lx ly))" using mul_a by simp
   9.121 +  finally
   9.122 +  show "mul (mul lx ly) (mul rx ry) = mul rx (mul (mul lx ly) ry)"
   9.123 +    using mul_c by simp
   9.124 +next show "mul (mul lx ly) rx = mul (mul lx rx) ly" using mul_c mul_a by simp
   9.125 +next
   9.126 +  show "mul (mul lx ly) rx = mul lx (mul ly rx)" by (simp add: mul_a)
   9.127 +next show "mul lx (mul rx ry) = mul (mul lx rx) ry" by (simp add: mul_a )
   9.128 +next show "mul lx (mul rx ry) = mul rx (mul lx ry)" by (simp add: mul_a,simp add: mul_c)
   9.129 +next show "add (add a b) (add c d) = add (add a c) (add b d)"
   9.130 +    using add_c add_a by simp
   9.131 +next show "add (add a b) c = add a (add b c)" using add_a by simp
   9.132 +next show "add a (add c d) = add c (add a d)"
   9.133 +    apply (simp add: add_a) by (simp only: add_c)
   9.134 +next show "add (add a b) c = add (add a c) b" using add_a add_c by simp
   9.135 +next show "add a c = add c a" by (rule add_c)
   9.136 +next show "add a (add c d) = add (add a c) d" using add_a by simp
   9.137 +next show "mul (pwr x p) (pwr x q) = pwr x (p + q)" by (rule mul_pwr)
   9.138 +next show "mul x (pwr x q) = pwr x (Suc q)" using pwr_Suc by simp
   9.139 +next show "mul (pwr x q) x = pwr x (Suc q)" using pwr_Suc mul_c by simp
   9.140 +next show "mul x x = pwr x 2" by (simp add: nat_number' pwr_Suc pwr_0 mul_1 mul_c)
   9.141 +next show "pwr (mul x y) q = mul (pwr x q) (pwr y q)" by (rule pwr_mul)
   9.142 +next show "pwr (pwr x p) q = pwr x (p * q)" by (rule pwr_pwr)
   9.143 +next show "pwr x 0 = r1" using pwr_0 .
   9.144 +next show "pwr x 1 = x" unfolding One_nat_def by (simp add: nat_number' pwr_Suc pwr_0 mul_1 mul_c)
   9.145 +next show "mul x (add y z) = add (mul x y) (mul x z)" using mul_d by simp
   9.146 +next show "pwr x (Suc q) = mul x (pwr x q)" using pwr_Suc by simp
   9.147 +next show "pwr x (2 * n) = mul (pwr x n) (pwr x n)" by (simp add: nat_number' mul_pwr)
   9.148 +next show "pwr x (Suc (2 * n)) = mul x (mul (pwr x n) (pwr x n))"
   9.149 +    by (simp add: nat_number' pwr_Suc mul_pwr)
   9.150 +qed
   9.151 +
   9.152 +
   9.153 +lemmas normalizing_semiring_axioms' =
   9.154 +  normalizing_semiring_axioms [normalizer
   9.155 +    semiring ops: semiring_ops
   9.156 +    semiring rules: semiring_rules]
   9.157 +
   9.158 +end
   9.159 +
   9.160 +sublocale comm_semiring_1
   9.161 +  < normalizing!: normalizing_semiring plus times power zero one
   9.162 +proof
   9.163 +qed (simp_all add: algebra_simps)
   9.164 +
   9.165 +declaration {* Semiring_Normalizer.semiring_funs @{thm normalizing.normalizing_semiring_axioms'} *}
   9.166 +
   9.167 +locale normalizing_ring = normalizing_semiring +
   9.168 +  fixes sub :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"
   9.169 +    and neg :: "'a \<Rightarrow> 'a"
   9.170 +  assumes neg_mul: "neg x = mul (neg r1) x"
   9.171 +    and sub_add: "sub x y = add x (neg y)"
   9.172 +begin
   9.173 +
   9.174 +lemma ring_ops: shows "TERM (sub x y)" and "TERM (neg x)" .
   9.175 +
   9.176 +lemmas ring_rules = neg_mul sub_add
   9.177 +
   9.178 +lemmas normalizing_ring_axioms' =
   9.179 +  normalizing_ring_axioms [normalizer
   9.180 +    semiring ops: semiring_ops
   9.181 +    semiring rules: semiring_rules
   9.182 +    ring ops: ring_ops
   9.183 +    ring rules: ring_rules]
   9.184 +
   9.185 +end
   9.186 +
   9.187 +sublocale comm_ring_1
   9.188 +  < normalizing!: normalizing_ring plus times power zero one minus uminus
   9.189 +proof
   9.190 +qed (simp_all add: diff_minus)
   9.191 +
   9.192 +declaration {* Semiring_Normalizer.semiring_funs @{thm normalizing.normalizing_ring_axioms'} *}
   9.193 +
   9.194 +locale normalizing_field = normalizing_ring +
   9.195 +  fixes divide :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"
   9.196 +    and inverse:: "'a \<Rightarrow> 'a"
   9.197 +  assumes divide_inverse: "divide x y = mul x (inverse y)"
   9.198 +     and inverse_divide: "inverse x = divide r1 x"
   9.199 +begin
   9.200 +
   9.201 +lemma field_ops: shows "TERM (divide x y)" and "TERM (inverse x)" .
   9.202 +
   9.203 +lemmas field_rules = divide_inverse inverse_divide
   9.204 +
   9.205 +lemmas normalizing_field_axioms' =
   9.206 +  normalizing_field_axioms [normalizer
   9.207 +    semiring ops: semiring_ops
   9.208 +    semiring rules: semiring_rules
   9.209 +    ring ops: ring_ops
   9.210 +    ring rules: ring_rules
   9.211 +    field ops: field_ops
   9.212 +    field rules: field_rules]
   9.213 +
   9.214 +end
   9.215 +
   9.216 +locale normalizing_semiring_cancel = normalizing_semiring +
   9.217 +  assumes add_cancel: "add (x::'a) y = add x z \<longleftrightarrow> y = z"
   9.218 +  and add_mul_solve: "add (mul w y) (mul x z) =
   9.219 +    add (mul w z) (mul x y) \<longleftrightarrow> w = x \<or> y = z"
   9.220 +begin
   9.221 +
   9.222 +lemma noteq_reduce: "a \<noteq> b \<and> c \<noteq> d \<longleftrightarrow> add (mul a c) (mul b d) \<noteq> add (mul a d) (mul b c)"
   9.223 +proof-
   9.224 +  have "a \<noteq> b \<and> c \<noteq> d \<longleftrightarrow> \<not> (a = b \<or> c = d)" by simp
   9.225 +  also have "\<dots> \<longleftrightarrow> add (mul a c) (mul b d) \<noteq> add (mul a d) (mul b c)"
   9.226 +    using add_mul_solve by blast
   9.227 +  finally show "a \<noteq> b \<and> c \<noteq> d \<longleftrightarrow> add (mul a c) (mul b d) \<noteq> add (mul a d) (mul b c)"
   9.228 +    by simp
   9.229 +qed
   9.230 +
   9.231 +lemma add_scale_eq_noteq: "\<lbrakk>r \<noteq> r0 ; (a = b) \<and> ~(c = d)\<rbrakk>
   9.232 +  \<Longrightarrow> add a (mul r c) \<noteq> add b (mul r d)"
   9.233 +proof(clarify)
   9.234 +  assume nz: "r\<noteq> r0" and cnd: "c\<noteq>d"
   9.235 +    and eq: "add b (mul r c) = add b (mul r d)"
   9.236 +  hence "mul r c = mul r d" using cnd add_cancel by simp
   9.237 +  hence "add (mul r0 d) (mul r c) = add (mul r0 c) (mul r d)"
   9.238 +    using mul_0 add_cancel by simp
   9.239 +  thus "False" using add_mul_solve nz cnd by simp
   9.240 +qed
   9.241 +
   9.242 +lemma add_r0_iff: " x = add x a \<longleftrightarrow> a = r0"
   9.243 +proof-
   9.244 +  have "a = r0 \<longleftrightarrow> add x a = add x r0" by (simp add: add_cancel)
   9.245 +  thus "x = add x a \<longleftrightarrow> a = r0" by (auto simp add: add_c add_0)
   9.246 +qed
   9.247 +
   9.248 +declare normalizing_semiring_axioms' [normalizer del]
   9.249 +
   9.250 +lemmas normalizing_semiring_cancel_axioms' =
   9.251 +  normalizing_semiring_cancel_axioms [normalizer
   9.252 +    semiring ops: semiring_ops
   9.253 +    semiring rules: semiring_rules
   9.254 +    idom rules: noteq_reduce add_scale_eq_noteq]
   9.255 +
   9.256 +end
   9.257 +
   9.258 +locale normalizing_ring_cancel = normalizing_semiring_cancel + normalizing_ring + 
   9.259 +  assumes subr0_iff: "sub x y = r0 \<longleftrightarrow> x = y"
   9.260 +begin
   9.261 +
   9.262 +declare normalizing_ring_axioms' [normalizer del]
   9.263 +
   9.264 +lemmas normalizing_ring_cancel_axioms' = normalizing_ring_cancel_axioms [normalizer
   9.265 +  semiring ops: semiring_ops
   9.266 +  semiring rules: semiring_rules
   9.267 +  ring ops: ring_ops
   9.268 +  ring rules: ring_rules
   9.269 +  idom rules: noteq_reduce add_scale_eq_noteq
   9.270 +  ideal rules: subr0_iff add_r0_iff]
   9.271 +
   9.272 +end
   9.273 +
   9.274 +sublocale idom
   9.275 +  < normalizing!: normalizing_ring_cancel plus times power zero one minus uminus
   9.276 +proof
   9.277 +  fix w x y z
   9.278 +  show "w * y + x * z = w * z + x * y \<longleftrightarrow> w = x \<or> y = z"
   9.279 +  proof
   9.280 +    assume "w * y + x * z = w * z + x * y"
   9.281 +    then have "w * y + x * z - w * z - x * y = 0" by (simp add: algebra_simps)
   9.282 +    then have "w * (y - z) - x * (y - z) = 0" by (simp add: algebra_simps)
   9.283 +    then have "(y - z) * (w - x) = 0" by (simp add: algebra_simps)
   9.284 +    then have "y - z = 0 \<or> w - x = 0" by (rule divisors_zero)
   9.285 +    then show "w = x \<or> y = z" by auto
   9.286 +  qed (auto simp add: add_ac)
   9.287 +qed (simp_all add: algebra_simps)
   9.288 +
   9.289 +declaration {* Semiring_Normalizer.semiring_funs @{thm normalizing.normalizing_ring_cancel_axioms'} *}
   9.290 +
   9.291 +interpretation normalizing_nat!: normalizing_semiring_cancel
   9.292 +  "op +" "op *" "op ^" "0::nat" "1"
   9.293 +proof (unfold_locales, simp add: algebra_simps)
   9.294 +  fix w x y z ::"nat"
   9.295 +  { assume p: "w * y + x * z = w * z + x * y" and ynz: "y \<noteq> z"
   9.296 +    hence "y < z \<or> y > z" by arith
   9.297 +    moreover {
   9.298 +      assume lt:"y <z" hence "\<exists>k. z = y + k \<and> k > 0" by (rule_tac x="z - y" in exI, auto)
   9.299 +      then obtain k where kp: "k>0" and yz:"z = y + k" by blast
   9.300 +      from p have "(w * y + x *y) + x*k = (w * y + x*y) + w*k" by (simp add: yz algebra_simps)
   9.301 +      hence "x*k = w*k" by simp
   9.302 +      hence "w = x" using kp by simp }
   9.303 +    moreover {
   9.304 +      assume lt: "y >z" hence "\<exists>k. y = z + k \<and> k>0" by (rule_tac x="y - z" in exI, auto)
   9.305 +      then obtain k where kp: "k>0" and yz:"y = z + k" by blast
   9.306 +      from p have "(w * z + x *z) + w*k = (w * z + x*z) + x*k" by (simp add: yz algebra_simps)
   9.307 +      hence "w*k = x*k" by simp
   9.308 +      hence "w = x" using kp by simp }
   9.309 +    ultimately have "w=x" by blast }
   9.310 +  thus "(w * y + x * z = w * z + x * y) = (w = x \<or> y = z)" by auto
   9.311 +qed
   9.312 +
   9.313 +declaration {* Semiring_Normalizer.semiring_funs @{thm normalizing_nat.normalizing_semiring_cancel_axioms'} *}
   9.314 +
   9.315 +locale normalizing_field_cancel = normalizing_ring_cancel + normalizing_field
   9.316 +begin
   9.317 +
   9.318 +declare normalizing_field_axioms' [normalizer del]
   9.319 +
   9.320 +lemmas normalizing_field_cancel_axioms' = normalizing_field_cancel_axioms [normalizer
   9.321 +  semiring ops: semiring_ops
   9.322 +  semiring rules: semiring_rules
   9.323 +  ring ops: ring_ops
   9.324 +  ring rules: ring_rules
   9.325 +  field ops: field_ops
   9.326 +  field rules: field_rules
   9.327 +  idom rules: noteq_reduce add_scale_eq_noteq
   9.328 +  ideal rules: subr0_iff add_r0_iff]
   9.329 +
   9.330 +end
   9.331 +
   9.332 +sublocale field 
   9.333 +  < normalizing!: normalizing_field_cancel plus times power zero one minus uminus divide inverse
   9.334 +proof
   9.335 +qed (simp_all add: divide_inverse)
   9.336 +
   9.337 +declaration {* Semiring_Normalizer.field_funs @{thm normalizing.normalizing_field_cancel_axioms'} *}
   9.338 +
   9.339 +end
    10.1 --- a/src/HOL/Tools/Groebner_Basis/groebner.ML	Fri May 07 23:44:10 2010 +0200
    10.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    10.3 @@ -1,1045 +0,0 @@
    10.4 -(*  Title:      HOL/Tools/Groebner_Basis/groebner.ML
    10.5 -    Author:     Amine Chaieb, TU Muenchen
    10.6 -*)
    10.7 -
    10.8 -signature GROEBNER =
    10.9 -sig
   10.10 -  val ring_and_ideal_conv :
   10.11 -    {idom: thm list, ring: cterm list * thm list, field: cterm list * thm list,
   10.12 -     vars: cterm list, semiring: cterm list * thm list, ideal : thm list} ->
   10.13 -    (cterm -> Rat.rat) -> (Rat.rat -> cterm) ->
   10.14 -    conv ->  conv ->
   10.15 -     {ring_conv : conv, 
   10.16 -     simple_ideal: (cterm list -> cterm -> (cterm * cterm -> order) -> cterm list),
   10.17 -     multi_ideal: cterm list -> cterm list -> cterm list -> (cterm * cterm) list,
   10.18 -     poly_eq_ss: simpset, unwind_conv : conv}
   10.19 -  val ring_tac: thm list -> thm list -> Proof.context -> int -> tactic
   10.20 -  val ideal_tac: thm list -> thm list -> Proof.context -> int -> tactic
   10.21 -  val algebra_tac: thm list -> thm list -> Proof.context -> int -> tactic
   10.22 -  val algebra_method: (Proof.context -> Method.method) context_parser
   10.23 -end
   10.24 -
   10.25 -structure Groebner : GROEBNER =
   10.26 -struct
   10.27 -
   10.28 -open Conv Drule Thm;
   10.29 -
   10.30 -fun is_comb ct =
   10.31 -  (case Thm.term_of ct of
   10.32 -    _ $ _ => true
   10.33 -  | _ => false);
   10.34 -
   10.35 -val concl = Thm.cprop_of #> Thm.dest_arg;
   10.36 -
   10.37 -fun is_binop ct ct' =
   10.38 -  (case Thm.term_of ct' of
   10.39 -    c $ _ $ _ => term_of ct aconv c
   10.40 -  | _ => false);
   10.41 -
   10.42 -fun dest_binary ct ct' =
   10.43 -  if is_binop ct ct' then Thm.dest_binop ct'
   10.44 -  else raise CTERM ("dest_binary: bad binop", [ct, ct'])
   10.45 -
   10.46 -fun inst_thm inst = Thm.instantiate ([], inst);
   10.47 -
   10.48 -val rat_0 = Rat.zero;
   10.49 -val rat_1 = Rat.one;
   10.50 -val minus_rat = Rat.neg;
   10.51 -val denominator_rat = Rat.quotient_of_rat #> snd #> Rat.rat_of_int;
   10.52 -fun int_of_rat a =
   10.53 -    case Rat.quotient_of_rat a of (i,1) => i | _ => error "int_of_rat: not an int";
   10.54 -val lcm_rat = fn x => fn y => Rat.rat_of_int (Integer.lcm (int_of_rat x) (int_of_rat y));
   10.55 -
   10.56 -val (eqF_intr, eqF_elim) =
   10.57 -  let val [th1,th2] = @{thms PFalse}
   10.58 -  in (fn th => th COMP th2, fn th => th COMP th1) end;
   10.59 -
   10.60 -val (PFalse, PFalse') =
   10.61 - let val PFalse_eq = nth @{thms simp_thms} 13
   10.62 - in (PFalse_eq RS iffD1, PFalse_eq RS iffD2) end;
   10.63 -
   10.64 -
   10.65 -(* Type for recording history, i.e. how a polynomial was obtained. *)
   10.66 -
   10.67 -datatype history =
   10.68 -   Start of int
   10.69 - | Mmul of (Rat.rat * int list) * history
   10.70 - | Add of history * history;
   10.71 -
   10.72 -
   10.73 -(* Monomial ordering. *)
   10.74 -
   10.75 -fun morder_lt m1 m2=
   10.76 -    let fun lexorder l1 l2 =
   10.77 -            case (l1,l2) of
   10.78 -                ([],[]) => false
   10.79 -              | (x1::o1,x2::o2) => x1 > x2 orelse x1 = x2 andalso lexorder o1 o2
   10.80 -              | _ => error "morder: inconsistent monomial lengths"
   10.81 -        val n1 = Integer.sum m1
   10.82 -        val n2 = Integer.sum m2 in
   10.83 -    n1 < n2 orelse n1 = n2 andalso lexorder m1 m2
   10.84 -    end;
   10.85 -
   10.86 -fun morder_le m1 m2 = morder_lt m1 m2 orelse (m1 = m2);
   10.87 -
   10.88 -fun morder_gt m1 m2 = morder_lt m2 m1;
   10.89 -
   10.90 -(* Arithmetic on canonical polynomials. *)
   10.91 -
   10.92 -fun grob_neg l = map (fn (c,m) => (minus_rat c,m)) l;
   10.93 -
   10.94 -fun grob_add l1 l2 =
   10.95 -  case (l1,l2) of
   10.96 -    ([],l2) => l2
   10.97 -  | (l1,[]) => l1
   10.98 -  | ((c1,m1)::o1,(c2,m2)::o2) =>
   10.99 -        if m1 = m2 then
  10.100 -          let val c = c1+/c2 val rest = grob_add o1 o2 in
  10.101 -          if c =/ rat_0 then rest else (c,m1)::rest end
  10.102 -        else if morder_lt m2 m1 then (c1,m1)::(grob_add o1 l2)
  10.103 -        else (c2,m2)::(grob_add l1 o2);
  10.104 -
  10.105 -fun grob_sub l1 l2 = grob_add l1 (grob_neg l2);
  10.106 -
  10.107 -fun grob_mmul (c1,m1) (c2,m2) = (c1*/c2, ListPair.map (op +) (m1, m2));
  10.108 -
  10.109 -fun grob_cmul cm pol = map (grob_mmul cm) pol;
  10.110 -
  10.111 -fun grob_mul l1 l2 =
  10.112 -  case l1 of
  10.113 -    [] => []
  10.114 -  | (h1::t1) => grob_add (grob_cmul h1 l2) (grob_mul t1 l2);
  10.115 -
  10.116 -fun grob_inv l =
  10.117 -  case l of
  10.118 -    [(c,vs)] => if (forall (fn x => x = 0) vs) then
  10.119 -                  if (c =/ rat_0) then error "grob_inv: division by zero"
  10.120 -                  else [(rat_1 // c,vs)]
  10.121 -              else error "grob_inv: non-constant divisor polynomial"
  10.122 -  | _ => error "grob_inv: non-constant divisor polynomial";
  10.123 -
  10.124 -fun grob_div l1 l2 =
  10.125 -  case l2 of
  10.126 -    [(c,l)] => if (forall (fn x => x = 0) l) then
  10.127 -                 if c =/ rat_0 then error "grob_div: division by zero"
  10.128 -                 else grob_cmul (rat_1 // c,l) l1
  10.129 -             else error "grob_div: non-constant divisor polynomial"
  10.130 -  | _ => error "grob_div: non-constant divisor polynomial";
  10.131 -
  10.132 -fun grob_pow vars l n =
  10.133 -  if n < 0 then error "grob_pow: negative power"
  10.134 -  else if n = 0 then [(rat_1,map (fn v => 0) vars)]
  10.135 -  else grob_mul l (grob_pow vars l (n - 1));
  10.136 -
  10.137 -fun degree vn p =
  10.138 - case p of
  10.139 -  [] => error "Zero polynomial"
  10.140 -| [(c,ns)] => nth ns vn
  10.141 -| (c,ns)::p' => Int.max (nth ns vn, degree vn p');
  10.142 -
  10.143 -fun head_deg vn p = let val d = degree vn p in
  10.144 - (d,fold (fn (c,r) => fn q => grob_add q [(c, map_index (fn (i,n) => if i = vn then 0 else n) r)]) (filter (fn (c,ns) => c <>/ rat_0 andalso nth ns vn = d) p) []) end;
  10.145 -
  10.146 -val is_zerop = forall (fn (c,ns) => c =/ rat_0 andalso forall (curry (op =) 0) ns);
  10.147 -val grob_pdiv =
  10.148 - let fun pdiv_aux vn (n,a) p k s =
  10.149 -  if is_zerop s then (k,s) else
  10.150 -  let val (m,b) = head_deg vn s
  10.151 -  in if m < n then (k,s) else
  10.152 -     let val p' = grob_mul p [(rat_1, map_index (fn (i,v) => if i = vn then m - n else 0)
  10.153 -                                                (snd (hd s)))]
  10.154 -     in if a = b then pdiv_aux vn (n,a) p k (grob_sub s p')
  10.155 -        else pdiv_aux vn (n,a) p (k + 1) (grob_sub (grob_mul a s) (grob_mul b p'))
  10.156 -     end
  10.157 -  end
  10.158 - in fn vn => fn s => fn p => pdiv_aux vn (head_deg vn p) p 0 s
  10.159 - end;
  10.160 -
  10.161 -(* Monomial division operation. *)
  10.162 -
  10.163 -fun mdiv (c1,m1) (c2,m2) =
  10.164 -  (c1//c2,
  10.165 -   map2 (fn n1 => fn n2 => if n1 < n2 then error "mdiv" else n1 - n2) m1 m2);
  10.166 -
  10.167 -(* Lowest common multiple of two monomials. *)
  10.168 -
  10.169 -fun mlcm (c1,m1) (c2,m2) = (rat_1, ListPair.map Int.max (m1, m2));
  10.170 -
  10.171 -(* Reduce monomial cm by polynomial pol, returning replacement for cm.  *)
  10.172 -
  10.173 -fun reduce1 cm (pol,hpol) =
  10.174 -  case pol of
  10.175 -    [] => error "reduce1"
  10.176 -  | cm1::cms => ((let val (c,m) = mdiv cm cm1 in
  10.177 -                    (grob_cmul (minus_rat c,m) cms,
  10.178 -                     Mmul((minus_rat c,m),hpol)) end)
  10.179 -                handle  ERROR _ => error "reduce1");
  10.180 -
  10.181 -(* Try this for all polynomials in a basis.  *)
  10.182 -fun tryfind f l =
  10.183 -    case l of
  10.184 -        [] => error "tryfind"
  10.185 -      | (h::t) => ((f h) handle ERROR _ => tryfind f t);
  10.186 -
  10.187 -fun reduceb cm basis = tryfind (fn p => reduce1 cm p) basis;
  10.188 -
  10.189 -(* Reduction of a polynomial (always picking largest monomial possible).     *)
  10.190 -
  10.191 -fun reduce basis (pol,hist) =
  10.192 -  case pol of
  10.193 -    [] => (pol,hist)
  10.194 -  | cm::ptl => ((let val (q,hnew) = reduceb cm basis in
  10.195 -                   reduce basis (grob_add q ptl,Add(hnew,hist)) end)
  10.196 -               handle (ERROR _) =>
  10.197 -                   (let val (q,hist') = reduce basis (ptl,hist) in
  10.198 -                       (cm::q,hist') end));
  10.199 -
  10.200 -(* Check for orthogonality w.r.t. LCM.                                       *)
  10.201 -
  10.202 -fun orthogonal l p1 p2 =
  10.203 -  snd l = snd(grob_mmul (hd p1) (hd p2));
  10.204 -
  10.205 -(* Compute S-polynomial of two polynomials.                                  *)
  10.206 -
  10.207 -fun spoly cm ph1 ph2 =
  10.208 -  case (ph1,ph2) of
  10.209 -    (([],h),p) => ([],h)
  10.210 -  | (p,([],h)) => ([],h)
  10.211 -  | ((cm1::ptl1,his1),(cm2::ptl2,his2)) =>
  10.212 -        (grob_sub (grob_cmul (mdiv cm cm1) ptl1)
  10.213 -                  (grob_cmul (mdiv cm cm2) ptl2),
  10.214 -         Add(Mmul(mdiv cm cm1,his1),
  10.215 -             Mmul(mdiv (minus_rat(fst cm),snd cm) cm2,his2)));
  10.216 -
  10.217 -(* Make a polynomial monic.                                                  *)
  10.218 -
  10.219 -fun monic (pol,hist) =
  10.220 -  if null pol then (pol,hist) else
  10.221 -  let val (c',m') = hd pol in
  10.222 -  (map (fn (c,m) => (c//c',m)) pol,
  10.223 -   Mmul((rat_1 // c',map (K 0) m'),hist)) end;
  10.224 -
  10.225 -(* The most popular heuristic is to order critical pairs by LCM monomial.    *)
  10.226 -
  10.227 -fun forder ((c1,m1),_) ((c2,m2),_) = morder_lt m1 m2;
  10.228 -
  10.229 -fun poly_lt  p q =
  10.230 -  case (p,q) of
  10.231 -    (p,[]) => false
  10.232 -  | ([],q) => true
  10.233 -  | ((c1,m1)::o1,(c2,m2)::o2) =>
  10.234 -        c1 </ c2 orelse
  10.235 -        c1 =/ c2 andalso ((morder_lt m1 m2) orelse m1 = m2 andalso poly_lt o1 o2);
  10.236 -
  10.237 -fun align  ((p,hp),(q,hq)) =
  10.238 -  if poly_lt p q then ((p,hp),(q,hq)) else ((q,hq),(p,hp));
  10.239 -fun forall2 p l1 l2 =
  10.240 -  case (l1,l2) of
  10.241 -    ([],[]) => true
  10.242 -  | (h1::t1,h2::t2) => p h1 h2 andalso forall2 p t1 t2
  10.243 -  | _ => false;
  10.244 -
  10.245 -fun poly_eq p1 p2 =
  10.246 -  forall2 (fn (c1,m1) => fn (c2,m2) => c1 =/ c2 andalso (m1: int list) = m2) p1 p2;
  10.247 -
  10.248 -fun memx ((p1,h1),(p2,h2)) ppairs =
  10.249 -  not (exists (fn ((q1,_),(q2,_)) => poly_eq p1 q1 andalso poly_eq p2 q2) ppairs);
  10.250 -
  10.251 -(* Buchberger's second criterion.                                            *)
  10.252 -
  10.253 -fun criterion2 basis (lcm,((p1,h1),(p2,h2))) opairs =
  10.254 -  exists (fn g => not(poly_eq (fst g) p1) andalso not(poly_eq (fst g) p2) andalso
  10.255 -                   can (mdiv lcm) (hd(fst g)) andalso
  10.256 -                   not(memx (align (g,(p1,h1))) (map snd opairs)) andalso
  10.257 -                   not(memx (align (g,(p2,h2))) (map snd opairs))) basis;
  10.258 -
  10.259 -(* Test for hitting constant polynomial.                                     *)
  10.260 -
  10.261 -fun constant_poly p =
  10.262 -  length p = 1 andalso forall (fn x => x = 0) (snd(hd p));
  10.263 -
  10.264 -(* Grobner basis algorithm.                                                  *)
  10.265 -
  10.266 -(* FIXME: try to get rid of mergesort? *)
  10.267 -fun merge ord l1 l2 =
  10.268 - case l1 of
  10.269 -  [] => l2
  10.270 - | h1::t1 =>
  10.271 -   case l2 of
  10.272 -    [] => l1
  10.273 -   | h2::t2 => if ord h1 h2 then h1::(merge ord t1 l2)
  10.274 -               else h2::(merge ord l1 t2);
  10.275 -fun mergesort ord l =
  10.276 - let
  10.277 - fun mergepairs l1 l2 =
  10.278 -  case (l1,l2) of
  10.279 -   ([s],[]) => s
  10.280 - | (l,[]) => mergepairs [] l
  10.281 - | (l,[s1]) => mergepairs (s1::l) []
  10.282 - | (l,(s1::s2::ss)) => mergepairs ((merge ord s1 s2)::l) ss
  10.283 - in if null l  then []  else mergepairs [] (map (fn x => [x]) l)
  10.284 - end;
  10.285 -
  10.286 -
  10.287 -fun grobner_basis basis pairs =
  10.288 - case pairs of
  10.289 -   [] => basis
  10.290 - | (l,(p1,p2))::opairs =>
  10.291 -   let val (sph as (sp,hist)) = monic (reduce basis (spoly l p1 p2))
  10.292 -   in 
  10.293 -    if null sp orelse criterion2 basis (l,(p1,p2)) opairs
  10.294 -    then grobner_basis basis opairs
  10.295 -    else if constant_poly sp then grobner_basis (sph::basis) []
  10.296 -    else 
  10.297 -     let 
  10.298 -      val rawcps = map (fn p => (mlcm (hd(fst p)) (hd sp),align(p,sph)))
  10.299 -                              basis
  10.300 -      val newcps = filter (fn (l,(p,q)) => not(orthogonal l (fst p) (fst q)))
  10.301 -                        rawcps
  10.302 -     in grobner_basis (sph::basis)
  10.303 -                 (merge forder opairs (mergesort forder newcps))
  10.304 -     end
  10.305 -   end;
  10.306 -
  10.307 -(* Interreduce initial polynomials.                                          *)
  10.308 -
  10.309 -fun grobner_interreduce rpols ipols =
  10.310 -  case ipols of
  10.311 -    [] => map monic (rev rpols)
  10.312 -  | p::ps => let val p' = reduce (rpols @ ps) p in
  10.313 -             if null (fst p') then grobner_interreduce rpols ps
  10.314 -             else grobner_interreduce (p'::rpols) ps end;
  10.315 -
  10.316 -(* Overall function.                                                         *)
  10.317 -
  10.318 -fun grobner pols =
  10.319 -    let val npols = map_index (fn (n, p) => (p, Start n)) pols
  10.320 -        val phists = filter (fn (p,_) => not (null p)) npols
  10.321 -        val bas = grobner_interreduce [] (map monic phists)
  10.322 -        val prs0 = map_product pair bas bas
  10.323 -        val prs1 = filter (fn ((x,_),(y,_)) => poly_lt x y) prs0
  10.324 -        val prs2 = map (fn (p,q) => (mlcm (hd(fst p)) (hd(fst q)),(p,q))) prs1
  10.325 -        val prs3 =
  10.326 -            filter (fn (l,(p,q)) => not(orthogonal l (fst p) (fst q))) prs2 in
  10.327 -        grobner_basis bas (mergesort forder prs3) end;
  10.328 -
  10.329 -(* Get proof of contradiction from Grobner basis.                            *)
  10.330 -
  10.331 -fun find p l =
  10.332 -  case l of
  10.333 -      [] => error "find"
  10.334 -    | (h::t) => if p(h) then h else find p t;
  10.335 -
  10.336 -fun grobner_refute pols =
  10.337 -  let val gb = grobner pols in
  10.338 -  snd(find (fn (p,h) => length p = 1 andalso forall (fn x=> x=0) (snd(hd p))) gb)
  10.339 -  end;
  10.340 -
  10.341 -(* Turn proof into a certificate as sum of multipliers.                      *)
  10.342 -(* In principle this is very inefficient: in a heavily shared proof it may   *)
  10.343 -(* make the same calculation many times. Could put in a cache or something.  *)
  10.344 -
  10.345 -fun resolve_proof vars prf =
  10.346 -  case prf of
  10.347 -    Start(~1) => []
  10.348 -  | Start m => [(m,[(rat_1,map (K 0) vars)])]
  10.349 -  | Mmul(pol,lin) =>
  10.350 -        let val lis = resolve_proof vars lin in
  10.351 -            map (fn (n,p) => (n,grob_cmul pol p)) lis end
  10.352 -  | Add(lin1,lin2) =>
  10.353 -        let val lis1 = resolve_proof vars lin1
  10.354 -            val lis2 = resolve_proof vars lin2
  10.355 -            val dom = distinct (op =) (union (op =) (map fst lis1) (map fst lis2))
  10.356 -        in
  10.357 -            map (fn n => let val a = these (AList.lookup (op =) lis1 n)
  10.358 -                             val b = these (AList.lookup (op =) lis2 n)
  10.359 -                         in (n,grob_add a b) end) dom end;
  10.360 -
  10.361 -(* Run the procedure and produce Weak Nullstellensatz certificate.           *)
  10.362 -
  10.363 -fun grobner_weak vars pols =
  10.364 -    let val cert = resolve_proof vars (grobner_refute pols)
  10.365 -        val l =
  10.366 -            fold_rev (fold_rev (lcm_rat o denominator_rat o fst) o snd) cert (rat_1) in
  10.367 -        (l,map (fn (i,p) => (i,map (fn (d,m) => (l*/d,m)) p)) cert) end;
  10.368 -
  10.369 -(* Prove a polynomial is in ideal generated by others, using Grobner basis.  *)
  10.370 -
  10.371 -fun grobner_ideal vars pols pol =
  10.372 -  let val (pol',h) = reduce (grobner pols) (grob_neg pol,Start(~1)) in
  10.373 -  if not (null pol') then error "grobner_ideal: not in the ideal" else
  10.374 -  resolve_proof vars h end;
  10.375 -
  10.376 -(* Produce Strong Nullstellensatz certificate for a power of pol.            *)
  10.377 -
  10.378 -fun grobner_strong vars pols pol =
  10.379 -    let val vars' = @{cterm "True"}::vars
  10.380 -        val grob_z = [(rat_1,1::(map (fn x => 0) vars))]
  10.381 -        val grob_1 = [(rat_1,(map (fn x => 0) vars'))]
  10.382 -        fun augment p= map (fn (c,m) => (c,0::m)) p
  10.383 -        val pols' = map augment pols
  10.384 -        val pol' = augment pol
  10.385 -        val allpols = (grob_sub (grob_mul grob_z pol') grob_1)::pols'
  10.386 -        val (l,cert) = grobner_weak vars' allpols
  10.387 -        val d = fold (fold (Integer.max o hd o snd) o snd) cert 0
  10.388 -        fun transform_monomial (c,m) =
  10.389 -            grob_cmul (c,tl m) (grob_pow vars pol (d - hd m))
  10.390 -        fun transform_polynomial q = fold_rev (grob_add o transform_monomial) q []
  10.391 -        val cert' = map (fn (c,q) => (c-1,transform_polynomial q))
  10.392 -                        (filter (fn (k,_) => k <> 0) cert) in
  10.393 -        (d,l,cert') end;
  10.394 -
  10.395 -
  10.396 -(* Overall parametrized universal procedure for (semi)rings.                 *)
  10.397 -(* We return an ideal_conv and the actual ring prover.                       *)
  10.398 -
  10.399 -fun refute_disj rfn tm =
  10.400 - case term_of tm of
  10.401 -  Const("op |",_)$l$r =>
  10.402 -   compose_single(refute_disj rfn (dest_arg tm),2,compose_single(refute_disj rfn (dest_arg1 tm),2,disjE))
  10.403 -  | _ => rfn tm ;
  10.404 -
  10.405 -val notnotD = @{thm notnotD};
  10.406 -fun mk_binop ct x y = capply (capply ct x) y
  10.407 -
  10.408 -val mk_comb = capply;
  10.409 -fun is_neg t =
  10.410 -    case term_of t of
  10.411 -      (Const("Not",_)$p) => true
  10.412 -    | _  => false;
  10.413 -fun is_eq t =
  10.414 - case term_of t of
  10.415 - (Const("op =",_)$_$_) => true
  10.416 -| _  => false;
  10.417 -
  10.418 -fun end_itlist f l =
  10.419 -  case l of
  10.420 -        []     => error "end_itlist"
  10.421 -      | [x]    => x
  10.422 -      | (h::t) => f h (end_itlist f t);
  10.423 -
  10.424 -val list_mk_binop = fn b => end_itlist (mk_binop b);
  10.425 -
  10.426 -val list_dest_binop = fn b =>
  10.427 - let fun h acc t =
  10.428 -  ((let val (l,r) = dest_binary b t in h (h acc r) l end)
  10.429 -   handle CTERM _ => (t::acc)) (* Why had I handle _ => ? *)
  10.430 - in h []
  10.431 - end;
  10.432 -
  10.433 -val strip_exists =
  10.434 - let fun h (acc, t) =
  10.435 -      case (term_of t) of
  10.436 -       Const("Ex",_)$Abs(x,T,p) => h (dest_abs NONE (dest_arg t) |>> (fn v => v::acc))
  10.437 -     | _ => (acc,t)
  10.438 - in fn t => h ([],t)
  10.439 - end;
  10.440 -
  10.441 -fun is_forall t =
  10.442 - case term_of t of
  10.443 -  (Const("All",_)$Abs(_,_,_)) => true
  10.444 -| _ => false;
  10.445 -
  10.446 -val mk_object_eq = fn th => th COMP meta_eq_to_obj_eq;
  10.447 -val bool_simps = @{thms bool_simps};
  10.448 -val nnf_simps = @{thms nnf_simps};
  10.449 -val nnf_conv = Simplifier.rewrite (HOL_basic_ss addsimps bool_simps addsimps nnf_simps)
  10.450 -val weak_dnf_conv = Simplifier.rewrite (HOL_basic_ss addsimps @{thms weak_dnf_simps});
  10.451 -val initial_conv =
  10.452 -    Simplifier.rewrite
  10.453 -     (HOL_basic_ss addsimps nnf_simps
  10.454 -       addsimps [not_all, not_ex]
  10.455 -       addsimps map (fn th => th RS sym) (@{thms ex_simps} @ @{thms all_simps}));
  10.456 -
  10.457 -val specl = fold_rev (fn x => fn th => instantiate' [] [SOME x] (th RS spec));
  10.458 -
  10.459 -val cTrp = @{cterm "Trueprop"};
  10.460 -val cConj = @{cterm "op &"};
  10.461 -val (cNot,false_tm) = (@{cterm "Not"}, @{cterm "False"});
  10.462 -val assume_Trueprop = mk_comb cTrp #> assume;
  10.463 -val list_mk_conj = list_mk_binop cConj;
  10.464 -val conjs = list_dest_binop cConj;
  10.465 -val mk_neg = mk_comb cNot;
  10.466 -
  10.467 -fun striplist dest = 
  10.468 - let
  10.469 -  fun h acc x = case try dest x of
  10.470 -    SOME (a,b) => h (h acc b) a
  10.471 -  | NONE => x::acc
  10.472 - in h [] end;
  10.473 -fun list_mk_binop b = foldr1 (fn (s,t) => Thm.capply (Thm.capply b s) t);
  10.474 -
  10.475 -val eq_commute = mk_meta_eq @{thm eq_commute};
  10.476 -
  10.477 -fun sym_conv eq = 
  10.478 - let val (l,r) = Thm.dest_binop eq
  10.479 - in instantiate' [SOME (ctyp_of_term l)] [SOME l, SOME r] eq_commute
  10.480 - end;
  10.481 -
  10.482 -  (* FIXME : copied from cqe.ML -- complex QE*)
  10.483 -fun conjuncts ct =
  10.484 - case term_of ct of
  10.485 -  @{term "op &"}$_$_ => (Thm.dest_arg1 ct)::(conjuncts (Thm.dest_arg ct))
  10.486 -| _ => [ct];
  10.487 -
  10.488 -fun fold1 f = foldr1 (uncurry f);
  10.489 -
  10.490 -val list_conj = fold1 (fn c => fn c' => Thm.capply (Thm.capply @{cterm "op &"} c) c') ;
  10.491 -
  10.492 -fun mk_conj_tab th = 
  10.493 - let fun h acc th = 
  10.494 -   case prop_of th of
  10.495 -   @{term "Trueprop"}$(@{term "op &"}$p$q) => 
  10.496 -     h (h acc (th RS conjunct2)) (th RS conjunct1)
  10.497 -  | @{term "Trueprop"}$p => (p,th)::acc
  10.498 -in fold (Termtab.insert Thm.eq_thm) (h [] th) Termtab.empty end;
  10.499 -
  10.500 -fun is_conj (@{term "op &"}$_$_) = true
  10.501 -  | is_conj _ = false;
  10.502 -
  10.503 -fun prove_conj tab cjs = 
  10.504 - case cjs of 
  10.505 -   [c] => if is_conj (term_of c) then prove_conj tab (conjuncts c) else tab c
  10.506 - | c::cs => conjI OF [prove_conj tab [c], prove_conj tab cs];
  10.507 -
  10.508 -fun conj_ac_rule eq = 
  10.509 - let 
  10.510 -  val (l,r) = Thm.dest_equals eq
  10.511 -  val ctabl = mk_conj_tab (assume (Thm.capply @{cterm Trueprop} l))
  10.512 -  val ctabr = mk_conj_tab (assume (Thm.capply @{cterm Trueprop} r))
  10.513 -  fun tabl c = the (Termtab.lookup ctabl (term_of c))
  10.514 -  fun tabr c = the (Termtab.lookup ctabr (term_of c))
  10.515 -  val thl  = prove_conj tabl (conjuncts r) |> implies_intr_hyps
  10.516 -  val thr  = prove_conj tabr (conjuncts l) |> implies_intr_hyps
  10.517 -  val eqI = instantiate' [] [SOME l, SOME r] @{thm iffI}
  10.518 - in implies_elim (implies_elim eqI thl) thr |> mk_meta_eq end;
  10.519 -
  10.520 - (* END FIXME.*)
  10.521 -
  10.522 -   (* Conversion for the equivalence of existential statements where 
  10.523 -      EX quantifiers are rearranged differently *)
  10.524 - fun ext T = cterm_rule (instantiate' [SOME T] []) @{cpat Ex}
  10.525 - fun mk_ex v t = Thm.capply (ext (ctyp_of_term v)) (Thm.cabs v t)
  10.526 -
  10.527 -fun choose v th th' = case concl_of th of 
  10.528 -  @{term Trueprop} $ (Const("Ex",_)$_) => 
  10.529 -   let
  10.530 -    val p = (funpow 2 Thm.dest_arg o cprop_of) th
  10.531 -    val T = (hd o Thm.dest_ctyp o ctyp_of_term) p
  10.532 -    val th0 = fconv_rule (Thm.beta_conversion true)
  10.533 -        (instantiate' [SOME T] [SOME p, (SOME o Thm.dest_arg o cprop_of) th'] exE)
  10.534 -    val pv = (Thm.rhs_of o Thm.beta_conversion true) 
  10.535 -          (Thm.capply @{cterm Trueprop} (Thm.capply p v))
  10.536 -    val th1 = forall_intr v (implies_intr pv th')
  10.537 -   in implies_elim (implies_elim th0 th) th1  end
  10.538 -| _ => error ""
  10.539 -
  10.540 -fun simple_choose v th = 
  10.541 -   choose v (assume ((Thm.capply @{cterm Trueprop} o mk_ex v) ((Thm.dest_arg o hd o #hyps o Thm.crep_thm) th))) th
  10.542 -
  10.543 -
  10.544 - fun mkexi v th = 
  10.545 -  let 
  10.546 -   val p = Thm.cabs v (Thm.dest_arg (Thm.cprop_of th))
  10.547 -  in implies_elim 
  10.548 -    (fconv_rule (Thm.beta_conversion true) (instantiate' [SOME (ctyp_of_term v)] [SOME p, SOME v] @{thm exI}))
  10.549 -      th
  10.550 -  end
  10.551 - fun ex_eq_conv t = 
  10.552 -  let 
  10.553 -  val (p0,q0) = Thm.dest_binop t
  10.554 -  val (vs',P) = strip_exists p0 
  10.555 -  val (vs,_) = strip_exists q0 
  10.556 -   val th = assume (Thm.capply @{cterm Trueprop} P)
  10.557 -   val th1 =  implies_intr_hyps (fold simple_choose vs' (fold mkexi vs th))
  10.558 -   val th2 =  implies_intr_hyps (fold simple_choose vs (fold mkexi vs' th))
  10.559 -   val p = (Thm.dest_arg o Thm.dest_arg1 o cprop_of) th1
  10.560 -   val q = (Thm.dest_arg o Thm.dest_arg o cprop_of) th1
  10.561 -  in implies_elim (implies_elim (instantiate' [] [SOME p, SOME q] iffI) th1) th2
  10.562 -     |> mk_meta_eq
  10.563 -  end;
  10.564 -
  10.565 -
  10.566 - fun getname v = case term_of v of 
  10.567 -  Free(s,_) => s
  10.568 - | Var ((s,_),_) => s
  10.569 - | _ => "x"
  10.570 - fun mk_eq s t = Thm.capply (Thm.capply @{cterm "op == :: bool => _"} s) t
  10.571 - fun mkeq s t = Thm.capply @{cterm Trueprop} (Thm.capply (Thm.capply @{cterm "op = :: bool => _"} s) t)
  10.572 - fun mk_exists v th = arg_cong_rule (ext (ctyp_of_term v))
  10.573 -   (Thm.abstract_rule (getname v) v th)
  10.574 - val simp_ex_conv = 
  10.575 -     Simplifier.rewrite (HOL_basic_ss addsimps @{thms simp_thms(39)})
  10.576 -
  10.577 -fun frees t = Thm.add_cterm_frees t [];
  10.578 -fun free_in v t = member op aconvc (frees t) v;
  10.579 -
  10.580 -val vsubst = let
  10.581 - fun vsubst (t,v) tm =  
  10.582 -   (Thm.rhs_of o Thm.beta_conversion false) (Thm.capply (Thm.cabs v tm) t)
  10.583 -in fold vsubst end;
  10.584 -
  10.585 -
  10.586 -(** main **)
  10.587 -
  10.588 -fun ring_and_ideal_conv
  10.589 -  {vars, semiring = (sr_ops, sr_rules), ring = (r_ops, r_rules), 
  10.590 -   field = (f_ops, f_rules), idom, ideal}
  10.591 -  dest_const mk_const ring_eq_conv ring_normalize_conv =
  10.592 -let
  10.593 -  val [add_pat, mul_pat, pow_pat, zero_tm, one_tm] = sr_ops;
  10.594 -  val [ring_add_tm, ring_mul_tm, ring_pow_tm] =
  10.595 -    map dest_fun2 [add_pat, mul_pat, pow_pat];
  10.596 -
  10.597 -  val (ring_sub_tm, ring_neg_tm) =
  10.598 -    (case r_ops of
  10.599 -     [sub_pat, neg_pat] => (dest_fun2 sub_pat, dest_fun neg_pat)
  10.600 -    |_  => (@{cterm "True"}, @{cterm "True"}));
  10.601 -
  10.602 -  val (field_div_tm, field_inv_tm) =
  10.603 -    (case f_ops of
  10.604 -       [div_pat, inv_pat] => (dest_fun2 div_pat, dest_fun inv_pat)
  10.605 -     | _ => (@{cterm "True"}, @{cterm "True"}));
  10.606 -
  10.607 -  val [idom_thm, neq_thm] = idom;
  10.608 -  val [idl_sub, idl_add0] = 
  10.609 -     if length ideal = 2 then ideal else [eq_commute, eq_commute]
  10.610 -  fun ring_dest_neg t =
  10.611 -    let val (l,r) = dest_comb t 
  10.612 -    in if Term.could_unify(term_of l,term_of ring_neg_tm) then r 
  10.613 -       else raise CTERM ("ring_dest_neg", [t])
  10.614 -    end
  10.615 -
  10.616 - val ring_mk_neg = fn tm => mk_comb (ring_neg_tm) (tm);
  10.617 - fun field_dest_inv t =
  10.618 -    let val (l,r) = dest_comb t in
  10.619 -        if Term.could_unify(term_of l, term_of field_inv_tm) then r 
  10.620 -        else raise CTERM ("field_dest_inv", [t])
  10.621 -    end
  10.622 - val ring_dest_add = dest_binary ring_add_tm;
  10.623 - val ring_mk_add = mk_binop ring_add_tm;
  10.624 - val ring_dest_sub = dest_binary ring_sub_tm;
  10.625 - val ring_mk_sub = mk_binop ring_sub_tm;
  10.626 - val ring_dest_mul = dest_binary ring_mul_tm;
  10.627 - val ring_mk_mul = mk_binop ring_mul_tm;
  10.628 - val field_dest_div = dest_binary field_div_tm;
  10.629 - val field_mk_div = mk_binop field_div_tm;
  10.630 - val ring_dest_pow = dest_binary ring_pow_tm;
  10.631 - val ring_mk_pow = mk_binop ring_pow_tm ;
  10.632 - fun grobvars tm acc =
  10.633 -    if can dest_const tm then acc
  10.634 -    else if can ring_dest_neg tm then grobvars (dest_arg tm) acc
  10.635 -    else if can ring_dest_pow tm then grobvars (dest_arg1 tm) acc
  10.636 -    else if can ring_dest_add tm orelse can ring_dest_sub tm
  10.637 -            orelse can ring_dest_mul tm
  10.638 -    then grobvars (dest_arg1 tm) (grobvars (dest_arg tm) acc)
  10.639 -    else if can field_dest_inv tm
  10.640 -         then
  10.641 -          let val gvs = grobvars (dest_arg tm) [] 
  10.642 -          in if null gvs then acc else tm::acc
  10.643 -          end
  10.644 -    else if can field_dest_div tm then
  10.645 -         let val lvs = grobvars (dest_arg1 tm) acc
  10.646 -             val gvs = grobvars (dest_arg tm) []
  10.647 -          in if null gvs then lvs else tm::acc
  10.648 -          end 
  10.649 -    else tm::acc ;
  10.650 -
  10.651 -fun grobify_term vars tm =
  10.652 -((if not (member (op aconvc) vars tm) then raise CTERM ("Not a variable", [tm]) else
  10.653 -     [(rat_1,map (fn i => if i aconvc tm then 1 else 0) vars)])
  10.654 -handle  CTERM _ =>
  10.655 - ((let val x = dest_const tm
  10.656 - in if x =/ rat_0 then [] else [(x,map (fn v => 0) vars)]
  10.657 - end)
  10.658 - handle ERROR _ =>
  10.659 -  ((grob_neg(grobify_term vars (ring_dest_neg tm)))
  10.660 -  handle CTERM _ =>
  10.661 -   (
  10.662 -   (grob_inv(grobify_term vars (field_dest_inv tm)))
  10.663 -   handle CTERM _ => 
  10.664 -    ((let val (l,r) = ring_dest_add tm
  10.665 -    in grob_add (grobify_term vars l) (grobify_term vars r)
  10.666 -    end)
  10.667 -    handle CTERM _ =>
  10.668 -     ((let val (l,r) = ring_dest_sub tm
  10.669 -     in grob_sub (grobify_term vars l) (grobify_term vars r)
  10.670 -     end)
  10.671 -     handle  CTERM _ =>
  10.672 -      ((let val (l,r) = ring_dest_mul tm
  10.673 -      in grob_mul (grobify_term vars l) (grobify_term vars r)
  10.674 -      end)
  10.675 -       handle CTERM _ =>
  10.676 -        (  (let val (l,r) = field_dest_div tm
  10.677 -          in grob_div (grobify_term vars l) (grobify_term vars r)
  10.678 -          end)
  10.679 -         handle CTERM _ =>
  10.680 -          ((let val (l,r) = ring_dest_pow tm
  10.681 -          in grob_pow vars (grobify_term vars l) ((term_of #> HOLogic.dest_number #> snd) r)
  10.682 -          end)
  10.683 -           handle CTERM _ => error "grobify_term: unknown or invalid term")))))))));
  10.684 -val eq_tm = idom_thm |> concl |> dest_arg |> dest_arg |> dest_fun2;
  10.685 -val dest_eq = dest_binary eq_tm;
  10.686 -
  10.687 -fun grobify_equation vars tm =
  10.688 -    let val (l,r) = dest_binary eq_tm tm
  10.689 -    in grob_sub (grobify_term vars l) (grobify_term vars r)
  10.690 -    end;
  10.691 -
  10.692 -fun grobify_equations tm =
  10.693 - let
  10.694 -  val cjs = conjs tm
  10.695 -  val  rawvars = fold_rev (fn eq => fn a =>
  10.696 -                                       grobvars (dest_arg1 eq) (grobvars (dest_arg eq) a)) cjs []
  10.697 -  val vars = sort (fn (x, y) => Term_Ord.term_ord(term_of x,term_of y))
  10.698 -                  (distinct (op aconvc) rawvars)
  10.699 - in (vars,map (grobify_equation vars) cjs)
  10.700 - end;
  10.701 -
  10.702 -val holify_polynomial =
  10.703 - let fun holify_varpow (v,n) =
  10.704 -  if n = 1 then v else ring_mk_pow v (Numeral.mk_cnumber @{ctyp "nat"} n)  (* FIXME *)
  10.705 - fun holify_monomial vars (c,m) =
  10.706 -  let val xps = map holify_varpow (filter (fn (_,n) => n <> 0) (vars ~~ m))
  10.707 -   in end_itlist ring_mk_mul (mk_const c :: xps)
  10.708 -  end
  10.709 - fun holify_polynomial vars p =
  10.710 -     if null p then mk_const (rat_0)
  10.711 -     else end_itlist ring_mk_add (map (holify_monomial vars) p)
  10.712 - in holify_polynomial
  10.713 - end ;
  10.714 -val idom_rule = simplify (HOL_basic_ss addsimps [idom_thm]);
  10.715 -fun prove_nz n = eqF_elim
  10.716 -                 (ring_eq_conv(mk_binop eq_tm (mk_const n) (mk_const(rat_0))));
  10.717 -val neq_01 = prove_nz (rat_1);
  10.718 -fun neq_rule n th = [prove_nz n, th] MRS neq_thm;
  10.719 -fun mk_add th1 = combination(arg_cong_rule ring_add_tm th1);
  10.720 -
  10.721 -fun refute tm =
  10.722 - if tm aconvc false_tm then assume_Trueprop tm else
  10.723 - ((let
  10.724 -   val (nths0,eths0) = List.partition (is_neg o concl) (HOLogic.conj_elims (assume_Trueprop tm))
  10.725 -   val  nths = filter (is_eq o dest_arg o concl) nths0
  10.726 -   val eths = filter (is_eq o concl) eths0
  10.727 -  in
  10.728 -   if null eths then
  10.729 -    let
  10.730 -      val th1 = end_itlist (fn th1 => fn th2 => idom_rule(HOLogic.conj_intr th1 th2)) nths
  10.731 -      val th2 = Conv.fconv_rule
  10.732 -                ((arg_conv #> arg_conv)
  10.733 -                     (binop_conv ring_normalize_conv)) th1
  10.734 -      val conc = th2 |> concl |> dest_arg
  10.735 -      val (l,r) = conc |> dest_eq
  10.736 -    in implies_intr (mk_comb cTrp tm)
  10.737 -                    (equal_elim (arg_cong_rule cTrp (eqF_intr th2))
  10.738 -                           (reflexive l |> mk_object_eq))
  10.739 -    end
  10.740 -   else
  10.741 -   let
  10.742 -    val (vars,l,cert,noteqth) =(
  10.743 -     if null nths then
  10.744 -      let val (vars,pols) = grobify_equations(list_mk_conj(map concl eths))
  10.745 -          val (l,cert) = grobner_weak vars pols
  10.746 -      in (vars,l,cert,neq_01)
  10.747 -      end
  10.748 -     else
  10.749 -      let
  10.750 -       val nth = end_itlist (fn th1 => fn th2 => idom_rule(HOLogic.conj_intr th1 th2)) nths
  10.751 -       val (vars,pol::pols) =
  10.752 -          grobify_equations(list_mk_conj(dest_arg(concl nth)::map concl eths))
  10.753 -       val (deg,l,cert) = grobner_strong vars pols pol
  10.754 -       val th1 = Conv.fconv_rule((arg_conv o arg_conv)(binop_conv ring_normalize_conv)) nth
  10.755 -       val th2 = funpow deg (idom_rule o HOLogic.conj_intr th1) neq_01
  10.756 -      in (vars,l,cert,th2)
  10.757 -      end)
  10.758 -    val cert_pos = map (fn (i,p) => (i,filter (fn (c,m) => c >/ rat_0) p)) cert
  10.759 -    val cert_neg = map (fn (i,p) => (i,map (fn (c,m) => (minus_rat c,m))
  10.760 -                                            (filter (fn (c,m) => c </ rat_0) p))) cert
  10.761 -    val  herts_pos = map (fn (i,p) => (i,holify_polynomial vars p)) cert_pos
  10.762 -    val  herts_neg = map (fn (i,p) => (i,holify_polynomial vars p)) cert_neg
  10.763 -    fun thm_fn pols =
  10.764 -        if null pols then reflexive(mk_const rat_0) else
  10.765 -        end_itlist mk_add
  10.766 -            (map (fn (i,p) => arg_cong_rule (mk_comb ring_mul_tm p)
  10.767 -              (nth eths i |> mk_meta_eq)) pols)
  10.768 -    val th1 = thm_fn herts_pos
  10.769 -    val th2 = thm_fn herts_neg
  10.770 -    val th3 = HOLogic.conj_intr(mk_add (symmetric th1) th2 |> mk_object_eq) noteqth
  10.771 -    val th4 = Conv.fconv_rule ((arg_conv o arg_conv o binop_conv) ring_normalize_conv)
  10.772 -                               (neq_rule l th3)
  10.773 -    val (l,r) = dest_eq(dest_arg(concl th4))
  10.774 -   in implies_intr (mk_comb cTrp tm)
  10.775 -                        (equal_elim (arg_cong_rule cTrp (eqF_intr th4))
  10.776 -                   (reflexive l |> mk_object_eq))
  10.777 -   end
  10.778 -  end) handle ERROR _ => raise CTERM ("Gorbner-refute: unable to refute",[tm]))
  10.779 -
  10.780 -fun ring tm =
  10.781 - let
  10.782 -  fun mk_forall x p =
  10.783 -      mk_comb (cterm_rule (instantiate' [SOME (ctyp_of_term x)] []) @{cpat "All:: (?'a => bool) => _"}) (cabs x p)
  10.784 -  val avs = add_cterm_frees tm []
  10.785 -  val P' = fold mk_forall avs tm
  10.786 -  val th1 = initial_conv(mk_neg P')
  10.787 -  val (evs,bod) = strip_exists(concl th1) in
  10.788 -   if is_forall bod then raise CTERM("ring: non-universal formula",[tm])
  10.789 -   else
  10.790 -   let
  10.791 -    val th1a = weak_dnf_conv bod
  10.792 -    val boda = concl th1a
  10.793 -    val th2a = refute_disj refute boda
  10.794 -    val th2b = [mk_object_eq th1a, (th2a COMP notI) COMP PFalse'] MRS trans
  10.795 -    val th2 = fold (fn v => fn th => (forall_intr v th) COMP allI) evs (th2b RS PFalse)
  10.796 -    val th3 = equal_elim
  10.797 -                (Simplifier.rewrite (HOL_basic_ss addsimps [not_ex RS sym])
  10.798 -                          (th2 |> cprop_of)) th2
  10.799 -    in specl avs
  10.800 -             ([[[mk_object_eq th1, th3 RS PFalse'] MRS trans] MRS PFalse] MRS notnotD)
  10.801 -   end
  10.802 - end
  10.803 -fun ideal tms tm ord =
  10.804 - let
  10.805 -  val rawvars = fold_rev grobvars (tm::tms) []
  10.806 -  val vars = sort ord (distinct (fn (x,y) => (term_of x) aconv (term_of y)) rawvars)
  10.807 -  val pols = map (grobify_term vars) tms
  10.808 -  val pol = grobify_term vars tm
  10.809 -  val cert = grobner_ideal vars pols pol
  10.810 - in map_range (fn n => these (AList.lookup (op =) cert n) |> holify_polynomial vars)
  10.811 -   (length pols)
  10.812 - end
  10.813 -
  10.814 -fun poly_eq_conv t = 
  10.815 - let val (a,b) = Thm.dest_binop t
  10.816 - in fconv_rule (arg_conv (arg1_conv ring_normalize_conv)) 
  10.817 -     (instantiate' [] [SOME a, SOME b] idl_sub)
  10.818 - end
  10.819 - val poly_eq_simproc = 
  10.820 -  let 
  10.821 -   fun proc phi  ss t = 
  10.822 -    let val th = poly_eq_conv t
  10.823 -    in if Thm.is_reflexive th then NONE else SOME th
  10.824 -    end
  10.825 -   in make_simproc {lhss = [Thm.lhs_of idl_sub], 
  10.826 -                name = "poly_eq_simproc", proc = proc, identifier = []}
  10.827 -   end;
  10.828 -  val poly_eq_ss = HOL_basic_ss addsimps @{thms simp_thms}
  10.829 -                        addsimprocs [poly_eq_simproc]
  10.830 -
  10.831 - local
  10.832 -  fun is_defined v t =
  10.833 -  let 
  10.834 -   val mons = striplist(dest_binary ring_add_tm) t 
  10.835 -  in member (op aconvc) mons v andalso 
  10.836 -    forall (fn m => v aconvc m 
  10.837 -          orelse not(member (op aconvc) (Thm.add_cterm_frees m []) v)) mons
  10.838 -  end
  10.839 -
  10.840 -  fun isolate_variable vars tm =
  10.841 -  let 
  10.842 -   val th = poly_eq_conv tm
  10.843 -   val th' = (sym_conv then_conv poly_eq_conv) tm
  10.844 -   val (v,th1) = 
  10.845 -   case find_first(fn v=> is_defined v (Thm.dest_arg1 (Thm.rhs_of th))) vars of
  10.846 -    SOME v => (v,th')
  10.847 -   | NONE => (the (find_first 
  10.848 -          (fn v => is_defined v (Thm.dest_arg1 (Thm.rhs_of th'))) vars) ,th)
  10.849 -   val th2 = transitive th1 
  10.850 -        (instantiate' []  [(SOME o Thm.dest_arg1 o Thm.rhs_of) th1, SOME v] 
  10.851 -          idl_add0)
  10.852 -   in fconv_rule(funpow 2 arg_conv ring_normalize_conv) th2
  10.853 -   end
  10.854 - in
  10.855 - fun unwind_polys_conv tm =
  10.856 - let 
  10.857 -  val (vars,bod) = strip_exists tm
  10.858 -  val cjs = striplist (dest_binary @{cterm "op &"}) bod
  10.859 -  val th1 = (the (get_first (try (isolate_variable vars)) cjs) 
  10.860 -             handle Option => raise CTERM ("unwind_polys_conv",[tm]))
  10.861 -  val eq = Thm.lhs_of th1
  10.862 -  val bod' = list_mk_binop @{cterm "op &"} (eq::(remove op aconvc eq cjs))
  10.863 -  val th2 = conj_ac_rule (mk_eq bod bod')
  10.864 -  val th3 = transitive th2 
  10.865 -         (Drule.binop_cong_rule @{cterm "op &"} th1 
  10.866 -                (reflexive (Thm.dest_arg (Thm.rhs_of th2))))
  10.867 -  val v = Thm.dest_arg1(Thm.dest_arg1(Thm.rhs_of th3))
  10.868 -  val vars' = (remove op aconvc v vars) @ [v]
  10.869 -  val th4 = fconv_rule (arg_conv simp_ex_conv) (mk_exists v th3)
  10.870 -  val th5 = ex_eq_conv (mk_eq tm (fold mk_ex (remove op aconvc v vars) (Thm.lhs_of th4)))
  10.871 - in transitive th5 (fold mk_exists (remove op aconvc v vars) th4)
  10.872 - end;
  10.873 -end
  10.874 -
  10.875 -local
  10.876 - fun scrub_var v m =
  10.877 -  let 
  10.878 -   val ps = striplist ring_dest_mul m 
  10.879 -   val ps' = remove op aconvc v ps
  10.880 -  in if null ps' then one_tm else fold1 ring_mk_mul ps'
  10.881 -  end
  10.882 - fun find_multipliers v mons =
  10.883 -  let 
  10.884 -   val mons1 = filter (fn m => free_in v m) mons 
  10.885 -   val mons2 = map (scrub_var v) mons1 
  10.886 -   in  if null mons2 then zero_tm else fold1 ring_mk_add mons2
  10.887 -  end
  10.888 -
  10.889 - fun isolate_monomials vars tm =
  10.890 - let 
  10.891 -  val (cmons,vmons) =
  10.892 -    List.partition (fn m => null (inter (op aconvc) vars (frees m)))
  10.893 -                   (striplist ring_dest_add tm)
  10.894 -  val cofactors = map (fn v => find_multipliers v vmons) vars
  10.895 -  val cnc = if null cmons then zero_tm
  10.896 -             else Thm.capply ring_neg_tm
  10.897 -                    (list_mk_binop ring_add_tm cmons) 
  10.898 -  in (cofactors,cnc)
  10.899 -  end;
  10.900 -
  10.901 -fun isolate_variables evs ps eq =
  10.902 - let 
  10.903 -  val vars = filter (fn v => free_in v eq) evs
  10.904 -  val (qs,p) = isolate_monomials vars eq
  10.905 -  val rs = ideal (qs @ ps) p 
  10.906 -              (fn (s,t) => Term_Ord.term_ord (term_of s, term_of t))
  10.907 - in (eq, take (length qs) rs ~~ vars)
  10.908 - end;
  10.909 - fun subst_in_poly i p = Thm.rhs_of (ring_normalize_conv (vsubst i p));
  10.910 -in
  10.911 - fun solve_idealism evs ps eqs =
  10.912 -  if null evs then [] else
  10.913 -  let 
  10.914 -   val (eq,cfs) = get_first (try (isolate_variables evs ps)) eqs |> the
  10.915 -   val evs' = subtract op aconvc evs (map snd cfs)
  10.916 -   val eqs' = map (subst_in_poly cfs) (remove op aconvc eq eqs)
  10.917 -  in cfs @ solve_idealism evs' ps eqs'
  10.918 -  end;
  10.919 -end;
  10.920 -
  10.921 -
  10.922 -in {ring_conv = ring, simple_ideal = ideal, multi_ideal = solve_idealism, 
  10.923 -    poly_eq_ss = poly_eq_ss, unwind_conv = unwind_polys_conv}
  10.924 -end;
  10.925 -
  10.926 -
  10.927 -fun find_term bounds tm =
  10.928 -  (case term_of tm of
  10.929 -    Const ("op =", T) $ _ $ _ =>
  10.930 -      if domain_type T = HOLogic.boolT then find_args bounds tm
  10.931 -      else dest_arg tm
  10.932 -  | Const ("Not", _) $ _ => find_term bounds (dest_arg tm)
  10.933 -  | Const ("All", _) $ _ => find_body bounds (dest_arg tm)
  10.934 -  | Const ("Ex", _) $ _ => find_body bounds (dest_arg tm)
  10.935 -  | Const ("op &", _) $ _ $ _ => find_args bounds tm
  10.936 -  | Const ("op |", _) $ _ $ _ => find_args bounds tm
  10.937 -  | Const ("op -->", _) $ _ $ _ => find_args bounds tm
  10.938 -  | @{term "op ==>"} $_$_ => find_args bounds tm
  10.939 -  | Const("op ==",_)$_$_ => find_args bounds tm
  10.940 -  | @{term Trueprop}$_ => find_term bounds (dest_arg tm)
  10.941 -  | _ => raise TERM ("find_term", []))
  10.942 -and find_args bounds tm =
  10.943 -  let val (t, u) = Thm.dest_binop tm
  10.944 -  in (find_term bounds t handle TERM _ => find_term bounds u) end
  10.945 -and find_body bounds b =
  10.946 -  let val (_, b') = dest_abs (SOME (Name.bound bounds)) b
  10.947 -  in find_term (bounds + 1) b' end;
  10.948 -
  10.949 -
  10.950 -fun get_ring_ideal_convs ctxt form = 
  10.951 - case try (find_term 0) form of
  10.952 -  NONE => NONE
  10.953 -| SOME tm =>
  10.954 -  (case Normalizer.match ctxt tm of
  10.955 -    NONE => NONE
  10.956 -  | SOME (res as (theory, {is_const, dest_const, 
  10.957 -          mk_const, conv = ring_eq_conv})) =>
  10.958 -     SOME (ring_and_ideal_conv theory
  10.959 -          dest_const (mk_const (ctyp_of_term tm)) (ring_eq_conv ctxt)
  10.960 -          (Normalizer.semiring_normalize_wrapper ctxt res)))
  10.961 -
  10.962 -fun ring_solve ctxt form =
  10.963 -  (case try (find_term 0 (* FIXME !? *)) form of
  10.964 -    NONE => reflexive form
  10.965 -  | SOME tm =>
  10.966 -      (case Normalizer.match ctxt tm of
  10.967 -        NONE => reflexive form
  10.968 -      | SOME (res as (theory, {is_const, dest_const, mk_const, conv = ring_eq_conv})) =>
  10.969 -        #ring_conv (ring_and_ideal_conv theory
  10.970 -          dest_const (mk_const (ctyp_of_term tm)) (ring_eq_conv ctxt)
  10.971 -          (Normalizer.semiring_normalize_wrapper ctxt res)) form));
  10.972 -
  10.973 -fun presimplify ctxt add_thms del_thms = asm_full_simp_tac (Simplifier.context ctxt
  10.974 -  (HOL_basic_ss addsimps (Algebra_Simplification.get ctxt) delsimps del_thms addsimps add_thms));
  10.975 -
  10.976 -fun ring_tac add_ths del_ths ctxt =
  10.977 -  Object_Logic.full_atomize_tac
  10.978 -  THEN' presimplify ctxt add_ths del_ths
  10.979 -  THEN' CSUBGOAL (fn (p, i) =>
  10.980 -    rtac (let val form = Object_Logic.dest_judgment p
  10.981 -          in case get_ring_ideal_convs ctxt form of
  10.982 -           NONE => reflexive form
  10.983 -          | SOME thy => #ring_conv thy form
  10.984 -          end) i
  10.985 -      handle TERM _ => no_tac
  10.986 -        | CTERM _ => no_tac
  10.987 -        | THM _ => no_tac);
  10.988 -
  10.989 -local
  10.990 - fun lhs t = case term_of t of
  10.991 -  Const("op =",_)$_$_ => Thm.dest_arg1 t
  10.992 - | _=> raise CTERM ("ideal_tac - lhs",[t])
  10.993 - fun exitac NONE = no_tac
  10.994 -   | exitac (SOME y) = rtac (instantiate' [SOME (ctyp_of_term y)] [NONE,SOME y] exI) 1
  10.995 -in 
  10.996 -fun ideal_tac add_ths del_ths ctxt = 
  10.997 -  presimplify ctxt add_ths del_ths
  10.998 - THEN'
  10.999 - CSUBGOAL (fn (p, i) =>
 10.1000 -  case get_ring_ideal_convs ctxt p of
 10.1001 -   NONE => no_tac
 10.1002 - | SOME thy => 
 10.1003 -  let
 10.1004 -   fun poly_exists_tac {asms = asms, concl = concl, prems = prems,
 10.1005 -            params = params, context = ctxt, schematics = scs} = 
 10.1006 -    let
 10.1007 -     val (evs,bod) = strip_exists (Thm.dest_arg concl)
 10.1008 -     val ps = map_filter (try (lhs o Thm.dest_arg)) asms 
 10.1009 -     val cfs = (map swap o #multi_ideal thy evs ps) 
 10.1010 -                   (map Thm.dest_arg1 (conjuncts bod))
 10.1011 -     val ws = map (exitac o AList.lookup op aconvc cfs) evs
 10.1012 -    in EVERY (rev ws) THEN Method.insert_tac prems 1 
 10.1013 -        THEN ring_tac add_ths del_ths ctxt 1
 10.1014 -   end
 10.1015 -  in  
 10.1016 -     clarify_tac @{claset} i 
 10.1017 -     THEN Object_Logic.full_atomize_tac i 
 10.1018 -     THEN asm_full_simp_tac (Simplifier.context ctxt (#poly_eq_ss thy)) i 
 10.1019 -     THEN clarify_tac @{claset} i 
 10.1020 -     THEN (REPEAT (CONVERSION (#unwind_conv thy) i))
 10.1021 -     THEN SUBPROOF poly_exists_tac ctxt i
 10.1022 -  end
 10.1023 - handle TERM _ => no_tac
 10.1024 -     | CTERM _ => no_tac
 10.1025 -     | THM _ => no_tac); 
 10.1026 -end;
 10.1027 -
 10.1028 -fun algebra_tac add_ths del_ths ctxt i = 
 10.1029 - ring_tac add_ths del_ths ctxt i ORELSE ideal_tac add_ths del_ths ctxt i
 10.1030 - 
 10.1031 -local
 10.1032 -
 10.1033 -fun keyword k = Scan.lift (Args.$$$ k -- Args.colon) >> K ()
 10.1034 -val addN = "add"
 10.1035 -val delN = "del"
 10.1036 -val any_keyword = keyword addN || keyword delN
 10.1037 -val thms = Scan.repeat (Scan.unless any_keyword Attrib.multi_thm) >> flat;
 10.1038 -
 10.1039 -in
 10.1040 -
 10.1041 -val algebra_method = ((Scan.optional (keyword addN |-- thms) []) -- 
 10.1042 -   (Scan.optional (keyword delN |-- thms) [])) >>
 10.1043 -  (fn (add_ths, del_ths) => fn ctxt =>
 10.1044 -       SIMPLE_METHOD' (algebra_tac add_ths del_ths ctxt))
 10.1045 -
 10.1046 -end;
 10.1047 -
 10.1048 -end;
    11.1 --- a/src/HOL/Tools/Groebner_Basis/normalizer.ML	Fri May 07 23:44:10 2010 +0200
    11.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    11.3 @@ -1,1062 +0,0 @@
    11.4 -(*  Title:      HOL/Tools/Groebner_Basis/normalizer.ML
    11.5 -    Author:     Amine Chaieb, TU Muenchen
    11.6 -
    11.7 -Normalization of expressions in semirings.
    11.8 -*)
    11.9 -
   11.10 -signature NORMALIZER = 
   11.11 -sig
   11.12 -  type entry
   11.13 -  val get: Proof.context -> (thm * entry) list
   11.14 -  val match: Proof.context -> cterm -> entry option
   11.15 -  val del: attribute
   11.16 -  val add: {semiring: cterm list * thm list, ring: cterm list * thm list,
   11.17 -    field: cterm list * thm list, idom: thm list, ideal: thm list} -> attribute
   11.18 -  val funs: thm -> {is_const: morphism -> cterm -> bool,
   11.19 -    dest_const: morphism -> cterm -> Rat.rat,
   11.20 -    mk_const: morphism -> ctyp -> Rat.rat -> cterm,
   11.21 -    conv: morphism -> Proof.context -> cterm -> thm} -> declaration
   11.22 -  val semiring_funs: thm -> declaration
   11.23 -  val field_funs: thm -> declaration
   11.24 -
   11.25 -  val semiring_normalize_conv: Proof.context -> conv
   11.26 -  val semiring_normalize_ord_conv: Proof.context -> (cterm -> cterm -> bool) -> conv
   11.27 -  val semiring_normalize_wrapper: Proof.context -> entry -> conv
   11.28 -  val semiring_normalize_ord_wrapper: Proof.context -> entry
   11.29 -    -> (cterm -> cterm -> bool) -> conv
   11.30 -  val semiring_normalizers_conv: cterm list -> cterm list * thm list
   11.31 -    -> cterm list * thm list -> cterm list * thm list ->
   11.32 -      (cterm -> bool) * conv * conv * conv -> (cterm -> cterm -> bool) ->
   11.33 -        {add: conv, mul: conv, neg: conv, main: conv, pow: conv, sub: conv}
   11.34 -  val semiring_normalizers_ord_wrapper:  Proof.context -> entry ->
   11.35 -    (cterm -> cterm -> bool) ->
   11.36 -      {add: conv, mul: conv, neg: conv, main: conv, pow: conv, sub: conv}
   11.37 -  val field_comp_conv: conv
   11.38 -
   11.39 -  val setup: theory -> theory
   11.40 -end
   11.41 -
   11.42 -structure Normalizer: NORMALIZER = 
   11.43 -struct
   11.44 -
   11.45 -(** some conversion **)
   11.46 -
   11.47 -local
   11.48 - val zr = @{cpat "0"}
   11.49 - val zT = ctyp_of_term zr
   11.50 - val geq = @{cpat "op ="}
   11.51 - val eqT = Thm.dest_ctyp (ctyp_of_term geq) |> hd
   11.52 - val add_frac_eq = mk_meta_eq @{thm "add_frac_eq"}
   11.53 - val add_frac_num = mk_meta_eq @{thm "add_frac_num"}
   11.54 - val add_num_frac = mk_meta_eq @{thm "add_num_frac"}
   11.55 -
   11.56 - fun prove_nz ss T t =
   11.57 -    let
   11.58 -      val z = instantiate_cterm ([(zT,T)],[]) zr
   11.59 -      val eq = instantiate_cterm ([(eqT,T)],[]) geq
   11.60 -      val th = Simplifier.rewrite (ss addsimps @{thms simp_thms})
   11.61 -           (Thm.capply @{cterm "Trueprop"} (Thm.capply @{cterm "Not"}
   11.62 -                  (Thm.capply (Thm.capply eq t) z)))
   11.63 -    in equal_elim (symmetric th) TrueI
   11.64 -    end
   11.65 -
   11.66 - fun proc phi ss ct =
   11.67 -  let
   11.68 -    val ((x,y),(w,z)) =
   11.69 -         (Thm.dest_binop #> (fn (a,b) => (Thm.dest_binop a, Thm.dest_binop b))) ct
   11.70 -    val _ = map (HOLogic.dest_number o term_of) [x,y,z,w]
   11.71 -    val T = ctyp_of_term x
   11.72 -    val [y_nz, z_nz] = map (prove_nz ss T) [y, z]
   11.73 -    val th = instantiate' [SOME T] (map SOME [y,z,x,w]) add_frac_eq
   11.74 -  in SOME (implies_elim (implies_elim th y_nz) z_nz)
   11.75 -  end
   11.76 -  handle CTERM _ => NONE | TERM _ => NONE | THM _ => NONE
   11.77 -
   11.78 - fun proc2 phi ss ct =
   11.79 -  let
   11.80 -    val (l,r) = Thm.dest_binop ct
   11.81 -    val T = ctyp_of_term l
   11.82 -  in (case (term_of l, term_of r) of
   11.83 -      (Const(@{const_name Rings.divide},_)$_$_, _) =>
   11.84 -        let val (x,y) = Thm.dest_binop l val z = r
   11.85 -            val _ = map (HOLogic.dest_number o term_of) [x,y,z]
   11.86 -            val ynz = prove_nz ss T y
   11.87 -        in SOME (implies_elim (instantiate' [SOME T] (map SOME [y,x,z]) add_frac_num) ynz)
   11.88 -        end
   11.89 -     | (_, Const (@{const_name Rings.divide},_)$_$_) =>
   11.90 -        let val (x,y) = Thm.dest_binop r val z = l
   11.91 -            val _ = map (HOLogic.dest_number o term_of) [x,y,z]
   11.92 -            val ynz = prove_nz ss T y
   11.93 -        in SOME (implies_elim (instantiate' [SOME T] (map SOME [y,z,x]) add_num_frac) ynz)
   11.94 -        end
   11.95 -     | _ => NONE)
   11.96 -  end
   11.97 -  handle CTERM _ => NONE | TERM _ => NONE | THM _ => NONE
   11.98 -
   11.99 - fun is_number (Const(@{const_name Rings.divide},_)$a$b) = is_number a andalso is_number b
  11.100 -   | is_number t = can HOLogic.dest_number t
  11.101 -
  11.102 - val is_number = is_number o term_of
  11.103 -
  11.104 - fun proc3 phi ss ct =
  11.105 -  (case term_of ct of
  11.106 -    Const(@{const_name Orderings.less},_)$(Const(@{const_name Rings.divide},_)$_$_)$_ =>
  11.107 -      let
  11.108 -        val ((a,b),c) = Thm.dest_binop ct |>> Thm.dest_binop
  11.109 -        val _ = map is_number [a,b,c]
  11.110 -        val T = ctyp_of_term c
  11.111 -        val th = instantiate' [SOME T] (map SOME [a,b,c]) @{thm "divide_less_eq"}
  11.112 -      in SOME (mk_meta_eq th) end
  11.113 -  | Const(@{const_name Orderings.less_eq},_)$(Const(@{const_name Rings.divide},_)$_$_)$_ =>
  11.114 -      let
  11.115 -        val ((a,b),c) = Thm.dest_binop ct |>> Thm.dest_binop
  11.116 -        val _ = map is_number [a,b,c]
  11.117 -        val T = ctyp_of_term c
  11.118 -        val th = instantiate' [SOME T] (map SOME [a,b,c]) @{thm "divide_le_eq"}
  11.119 -      in SOME (mk_meta_eq th) end
  11.120 -  | Const("op =",_)$(Const(@{const_name Rings.divide},_)$_$_)$_ =>
  11.121 -      let
  11.122 -        val ((a,b),c) = Thm.dest_binop ct |>> Thm.dest_binop
  11.123 -        val _ = map is_number [a,b,c]
  11.124 -        val T = ctyp_of_term c
  11.125 -        val th = instantiate' [SOME T] (map SOME [a,b,c]) @{thm "divide_eq_eq"}
  11.126 -      in SOME (mk_meta_eq th) end
  11.127 -  | Const(@{const_name Orderings.less},_)$_$(Const(@{const_name Rings.divide},_)$_$_) =>
  11.128 -    let
  11.129 -      val (a,(b,c)) = Thm.dest_binop ct ||> Thm.dest_binop
  11.130 -        val _ = map is_number [a,b,c]
  11.131 -        val T = ctyp_of_term c
  11.132 -        val th = instantiate' [SOME T] (map SOME [a,b,c]) @{thm "less_divide_eq"}
  11.133 -      in SOME (mk_meta_eq th) end
  11.134 -  | Const(@{const_name Orderings.less_eq},_)$_$(Const(@{const_name Rings.divide},_)$_$_) =>
  11.135 -    let
  11.136 -      val (a,(b,c)) = Thm.dest_binop ct ||> Thm.dest_binop
  11.137 -        val _ = map is_number [a,b,c]
  11.138 -        val T = ctyp_of_term c
  11.139 -        val th = instantiate' [SOME T] (map SOME [a,b,c]) @{thm "le_divide_eq"}
  11.140 -      in SOME (mk_meta_eq th) end
  11.141 -  | Const("op =",_)$_$(Const(@{const_name Rings.divide},_)$_$_) =>
  11.142 -    let
  11.143 -      val (a,(b,c)) = Thm.dest_binop ct ||> Thm.dest_binop
  11.144 -        val _ = map is_number [a,b,c]
  11.145 -        val T = ctyp_of_term c
  11.146 -        val th = instantiate' [SOME T] (map SOME [a,b,c]) @{thm "eq_divide_eq"}
  11.147 -      in SOME (mk_meta_eq th) end
  11.148 -  | _ => NONE)
  11.149 -  handle TERM _ => NONE | CTERM _ => NONE | THM _ => NONE
  11.150 -
  11.151 -val add_frac_frac_simproc =
  11.152 -       make_simproc {lhss = [@{cpat "(?x::?'a::field)/?y + (?w::?'a::field)/?z"}],
  11.153 -                     name = "add_frac_frac_simproc",
  11.154 -                     proc = proc, identifier = []}
  11.155 -
  11.156 -val add_frac_num_simproc =
  11.157 -       make_simproc {lhss = [@{cpat "(?x::?'a::field)/?y + ?z"}, @{cpat "?z + (?x::?'a::field)/?y"}],
  11.158 -                     name = "add_frac_num_simproc",
  11.159 -                     proc = proc2, identifier = []}
  11.160 -
  11.161 -val ord_frac_simproc =
  11.162 -  make_simproc
  11.163 -    {lhss = [@{cpat "(?a::(?'a::{field, ord}))/?b < ?c"},
  11.164 -             @{cpat "(?a::(?'a::{field, ord}))/?b <= ?c"},
  11.165 -             @{cpat "?c < (?a::(?'a::{field, ord}))/?b"},
  11.166 -             @{cpat "?c <= (?a::(?'a::{field, ord}))/?b"},
  11.167 -             @{cpat "?c = ((?a::(?'a::{field, ord}))/?b)"},
  11.168 -             @{cpat "((?a::(?'a::{field, ord}))/ ?b) = ?c"}],
  11.169 -             name = "ord_frac_simproc", proc = proc3, identifier = []}
  11.170 -
  11.171 -val ths = [@{thm "mult_numeral_1"}, @{thm "mult_numeral_1_right"},
  11.172 -           @{thm "divide_Numeral1"},
  11.173 -           @{thm "divide_zero"}, @{thm "divide_Numeral0"},
  11.174 -           @{thm "divide_divide_eq_left"}, 
  11.175 -           @{thm "times_divide_eq_left"}, @{thm "times_divide_eq_right"},
  11.176 -           @{thm "times_divide_times_eq"},
  11.177 -           @{thm "divide_divide_eq_right"},
  11.178 -           @{thm "diff_def"}, @{thm "minus_divide_left"},
  11.179 -           @{thm "Numeral1_eq1_nat"}, @{thm "add_divide_distrib"} RS sym,
  11.180 -           @{thm field_divide_inverse} RS sym, @{thm inverse_divide}, 
  11.181 -           Conv.fconv_rule (Conv.arg_conv (Conv.arg1_conv (Conv.rewr_conv (mk_meta_eq @{thm mult_commute}))))   
  11.182 -           (@{thm field_divide_inverse} RS sym)]
  11.183 -
  11.184 -in
  11.185 -
  11.186 -val field_comp_conv = (Simplifier.rewrite
  11.187 -(HOL_basic_ss addsimps @{thms "semiring_norm"}
  11.188 -              addsimps ths addsimps @{thms simp_thms}
  11.189 -              addsimprocs Numeral_Simprocs.field_cancel_numeral_factors
  11.190 -               addsimprocs [add_frac_frac_simproc, add_frac_num_simproc,
  11.191 -                            ord_frac_simproc]
  11.192 -                addcongs [@{thm "if_weak_cong"}]))
  11.193 -then_conv (Simplifier.rewrite (HOL_basic_ss addsimps
  11.194 -  [@{thm numeral_1_eq_1},@{thm numeral_0_eq_0}] @ @{thms numerals(1-2)}))
  11.195 -
  11.196 -end
  11.197 -
  11.198 -
  11.199 -(** data **)
  11.200 -
  11.201 -type entry =
  11.202 - {vars: cterm list,
  11.203 -  semiring: cterm list * thm list,
  11.204 -  ring: cterm list * thm list,
  11.205 -  field: cterm list * thm list,
  11.206 -  idom: thm list,
  11.207 -  ideal: thm list} *
  11.208 - {is_const: cterm -> bool,
  11.209 -  dest_const: cterm -> Rat.rat,
  11.210 -  mk_const: ctyp -> Rat.rat -> cterm,
  11.211 -  conv: Proof.context -> cterm -> thm};
  11.212 -
  11.213 -structure Data = Generic_Data
  11.214 -(
  11.215 -  type T = (thm * entry) list;
  11.216 -  val empty = [];
  11.217 -  val extend = I;
  11.218 -  val merge = AList.merge Thm.eq_thm (K true);
  11.219 -);
  11.220 -
  11.221 -val get = Data.get o Context.Proof;
  11.222 -
  11.223 -fun match ctxt tm =
  11.224 -  let
  11.225 -    fun match_inst
  11.226 -        ({vars, semiring = (sr_ops, sr_rules), 
  11.227 -          ring = (r_ops, r_rules), field = (f_ops, f_rules), idom, ideal},
  11.228 -         fns as {is_const, dest_const, mk_const, conv}) pat =
  11.229 -       let
  11.230 -        fun h instT =
  11.231 -          let
  11.232 -            val substT = Thm.instantiate (instT, []);
  11.233 -            val substT_cterm = Drule.cterm_rule substT;
  11.234 -
  11.235 -            val vars' = map substT_cterm vars;
  11.236 -            val semiring' = (map substT_cterm sr_ops, map substT sr_rules);
  11.237 -            val ring' = (map substT_cterm r_ops, map substT r_rules);
  11.238 -            val field' = (map substT_cterm f_ops, map substT f_rules);
  11.239 -            val idom' = map substT idom;
  11.240 -            val ideal' = map substT ideal;
  11.241 -
  11.242 -            val result = ({vars = vars', semiring = semiring', 
  11.243 -                           ring = ring', field = field', idom = idom', ideal = ideal'}, fns);
  11.244 -          in SOME result end
  11.245 -      in (case try Thm.match (pat, tm) of
  11.246 -           NONE => NONE
  11.247 -         | SOME (instT, _) => h instT)
  11.248 -      end;
  11.249 -
  11.250 -    fun match_struct (_,
  11.251 -        entry as ({semiring = (sr_ops, _), ring = (r_ops, _), field = (f_ops, _), ...}, _): entry) =
  11.252 -      get_first (match_inst entry) (sr_ops @ r_ops @ f_ops);
  11.253 -  in get_first match_struct (get ctxt) end;
  11.254 -
  11.255 -
  11.256 -(* logical content *)
  11.257 -
  11.258 -val semiringN = "semiring";
  11.259 -val ringN = "ring";
  11.260 -val idomN = "idom";
  11.261 -val idealN = "ideal";
  11.262 -val fieldN = "field";
  11.263 -
  11.264 -val del = Thm.declaration_attribute (Data.map o AList.delete Thm.eq_thm);
  11.265 -
  11.266 -fun add {semiring = (sr_ops, sr_rules), ring = (r_ops, r_rules), 
  11.267 -         field = (f_ops, f_rules), idom, ideal} =
  11.268 -  Thm.declaration_attribute (fn key => fn context => context |> Data.map
  11.269 -    let
  11.270 -      val ctxt = Context.proof_of context;
  11.271 -
  11.272 -      fun check kind name xs n =
  11.273 -        null xs orelse length xs = n orelse
  11.274 -        error ("Expected " ^ string_of_int n ^ " " ^ kind ^ " for " ^ name);
  11.275 -      val check_ops = check "operations";
  11.276 -      val check_rules = check "rules";
  11.277 -
  11.278 -      val _ =
  11.279 -        check_ops semiringN sr_ops 5 andalso
  11.280 -        check_rules semiringN sr_rules 37 andalso
  11.281 -        check_ops ringN r_ops 2 andalso
  11.282 -        check_rules ringN r_rules 2 andalso
  11.283 -        check_ops fieldN f_ops 2 andalso
  11.284 -        check_rules fieldN f_rules 2 andalso
  11.285 -        check_rules idomN idom 2;
  11.286 -
  11.287 -      val mk_meta = Local_Defs.meta_rewrite_rule ctxt;
  11.288 -      val sr_rules' = map mk_meta sr_rules;
  11.289 -      val r_rules' = map mk_meta r_rules;
  11.290 -      val f_rules' = map mk_meta f_rules;
  11.291 -
  11.292 -      fun rule i = nth sr_rules' (i - 1);
  11.293 -
  11.294 -      val (cx, cy) = Thm.dest_binop (hd sr_ops);
  11.295 -      val cz = rule 34 |> Thm.rhs_of |> Thm.dest_arg |> Thm.dest_arg;
  11.296 -      val cn = rule 36 |> Thm.rhs_of |> Thm.dest_arg |> Thm.dest_arg;
  11.297 -      val ((clx, crx), (cly, cry)) =
  11.298 -        rule 13 |> Thm.rhs_of |> Thm.dest_binop |> pairself Thm.dest_binop;
  11.299 -      val ((ca, cb), (cc, cd)) =
  11.300 -        rule 20 |> Thm.lhs_of |> Thm.dest_binop |> pairself Thm.dest_binop;
  11.301 -      val cm = rule 1 |> Thm.rhs_of |> Thm.dest_arg;
  11.302 -      val (cp, cq) = rule 26 |> Thm.lhs_of |> Thm.dest_binop |> pairself Thm.dest_arg;
  11.303 -
  11.304 -      val vars = [ca, cb, cc, cd, cm, cn, cp, cq, cx, cy, cz, clx, crx, cly, cry];
  11.305 -      val semiring = (sr_ops, sr_rules');
  11.306 -      val ring = (r_ops, r_rules');
  11.307 -      val field = (f_ops, f_rules');
  11.308 -      val ideal' = map (symmetric o mk_meta) ideal
  11.309 -    in
  11.310 -      AList.delete Thm.eq_thm key #>
  11.311 -      cons (key, ({vars = vars, semiring = semiring, 
  11.312 -                          ring = ring, field = field, idom = idom, ideal = ideal'},
  11.313 -             {is_const = undefined, dest_const = undefined, mk_const = undefined,
  11.314 -             conv = undefined}))
  11.315 -    end);
  11.316 -
  11.317 -
  11.318 -(* extra-logical functions *)
  11.319 -
  11.320 -fun funs raw_key {is_const, dest_const, mk_const, conv} phi = 
  11.321 - Data.map (fn data =>
  11.322 -  let
  11.323 -    val key = Morphism.thm phi raw_key;
  11.324 -    val _ = AList.defined Thm.eq_thm data key orelse
  11.325 -      raise THM ("No data entry for structure key", 0, [key]);
  11.326 -    val fns = {is_const = is_const phi, dest_const = dest_const phi,
  11.327 -      mk_const = mk_const phi, conv = conv phi};
  11.328 -  in AList.map_entry Thm.eq_thm key (apsnd (K fns)) data end);
  11.329 -
  11.330 -fun semiring_funs key = funs key
  11.331 -   {is_const = fn phi => can HOLogic.dest_number o Thm.term_of,
  11.332 -    dest_const = fn phi => fn ct =>
  11.333 -      Rat.rat_of_int (snd
  11.334 -        (HOLogic.dest_number (Thm.term_of ct)
  11.335 -          handle TERM _ => error "ring_dest_const")),
  11.336 -    mk_const = fn phi => fn cT => fn x => Numeral.mk_cnumber cT
  11.337 -      (case Rat.quotient_of_rat x of (i, 1) => i | _ => error "int_of_rat: bad int"),
  11.338 -    conv = fn phi => fn _ => Simplifier.rewrite (HOL_basic_ss addsimps @{thms semiring_norm})
  11.339 -      then_conv Simplifier.rewrite (HOL_basic_ss addsimps
  11.340 -        (@{thms numeral_1_eq_1} @ @{thms numeral_0_eq_0} @ @{thms numerals(1-2)}))};
  11.341 -
  11.342 -fun field_funs key =
  11.343 -  let
  11.344 -    fun numeral_is_const ct =
  11.345 -      case term_of ct of
  11.346 -       Const (@{const_name Rings.divide},_) $ a $ b =>
  11.347 -         can HOLogic.dest_number a andalso can HOLogic.dest_number b
  11.348 -     | Const (@{const_name Rings.inverse},_)$t => can HOLogic.dest_number t
  11.349 -     | t => can HOLogic.dest_number t
  11.350 -    fun dest_const ct = ((case term_of ct of
  11.351 -       Const (@{const_name Rings.divide},_) $ a $ b=>
  11.352 -        Rat.rat_of_quotient (snd (HOLogic.dest_number a), snd (HOLogic.dest_number b))
  11.353 -     | Const (@{const_name Rings.inverse},_)$t => 
  11.354 -                   Rat.inv (Rat.rat_of_int (snd (HOLogic.dest_number t)))
  11.355 -     | t => Rat.rat_of_int (snd (HOLogic.dest_number t))) 
  11.356 -       handle TERM _ => error "ring_dest_const")
  11.357 -    fun mk_const phi cT x =
  11.358 -      let val (a, b) = Rat.quotient_of_rat x
  11.359 -      in if b = 1 then Numeral.mk_cnumber cT a
  11.360 -        else Thm.capply
  11.361 -             (Thm.capply (Drule.cterm_rule (instantiate' [SOME cT] []) @{cpat "op /"})
  11.362 -                         (Numeral.mk_cnumber cT a))
  11.363 -             (Numeral.mk_cnumber cT b)
  11.364 -      end
  11.365 -  in funs key
  11.366 -     {is_const = K numeral_is_const,
  11.367 -      dest_const = K dest_const,
  11.368 -      mk_const = mk_const,
  11.369 -      conv = K (K field_comp_conv)}
  11.370 -  end;
  11.371 -
  11.372 -
  11.373 -
  11.374 -(** auxiliary **)
  11.375 -
  11.376 -fun is_comb ct =
  11.377 -  (case Thm.term_of ct of
  11.378 -    _ $ _ => true
  11.379 -  | _ => false);
  11.380 -
  11.381 -val concl = Thm.cprop_of #> Thm.dest_arg;
  11.382 -
  11.383 -fun is_binop ct ct' =
  11.384 -  (case Thm.term_of ct' of
  11.385 -    c $ _ $ _ => term_of ct aconv c
  11.386 -  | _ => false);
  11.387 -
  11.388 -fun dest_binop ct ct' =
  11.389 -  if is_binop ct ct' then Thm.dest_binop ct'
  11.390 -  else raise CTERM ("dest_binop: bad binop", [ct, ct'])
  11.391 -
  11.392 -fun inst_thm inst = Thm.instantiate ([], inst);
  11.393 -
  11.394 -val dest_numeral = term_of #> HOLogic.dest_number #> snd;
  11.395 -val is_numeral = can dest_numeral;
  11.396 -
  11.397 -val numeral01_conv = Simplifier.rewrite
  11.398 -                         (HOL_basic_ss addsimps [@{thm numeral_1_eq_1}, @{thm numeral_0_eq_0}]);
  11.399 -val zero1_numeral_conv = 
  11.400 - Simplifier.rewrite (HOL_basic_ss addsimps [@{thm numeral_1_eq_1} RS sym, @{thm numeral_0_eq_0} RS sym]);
  11.401 -fun zerone_conv cv = zero1_numeral_conv then_conv cv then_conv numeral01_conv;
  11.402 -val natarith = [@{thm "add_nat_number_of"}, @{thm "diff_nat_number_of"},
  11.403 -                @{thm "mult_nat_number_of"}, @{thm "eq_nat_number_of"}, 
  11.404 -                @{thm "less_nat_number_of"}];
  11.405 -
  11.406 -val nat_add_conv = 
  11.407 - zerone_conv 
  11.408 -  (Simplifier.rewrite 
  11.409 -    (HOL_basic_ss 
  11.410 -       addsimps @{thms arith_simps} @ natarith @ @{thms rel_simps}
  11.411 -             @ [@{thm if_False}, @{thm if_True}, @{thm Nat.add_0}, @{thm add_Suc},
  11.412 -                 @{thm add_number_of_left}, @{thm Suc_eq_plus1}]
  11.413 -             @ map (fn th => th RS sym) @{thms numerals}));
  11.414 -
  11.415 -val zeron_tm = @{cterm "0::nat"};
  11.416 -val onen_tm  = @{cterm "1::nat"};
  11.417 -val true_tm = @{cterm "True"};
  11.418 -
  11.419 -
  11.420 -(** normalizing conversions **)
  11.421 -
  11.422 -(* core conversion *)
  11.423 -
  11.424 -fun semiring_normalizers_conv vars (sr_ops, sr_rules) (r_ops, r_rules) (f_ops, f_rules)
  11.425 -  (is_semiring_constant, semiring_add_conv, semiring_mul_conv, semiring_pow_conv) =
  11.426 -let
  11.427 -
  11.428 -val [pthm_02, pthm_03, pthm_04, pthm_05, pthm_07, pthm_08,
  11.429 -     pthm_09, pthm_10, pthm_11, pthm_12, pthm_13, pthm_14, pthm_15, pthm_16,
  11.430 -     pthm_17, pthm_18, pthm_19, pthm_21, pthm_22, pthm_23, pthm_24,
  11.431 -     pthm_25, pthm_26, pthm_27, pthm_28, pthm_29, pthm_30, pthm_31, pthm_32,
  11.432 -     pthm_33, pthm_34, pthm_35, pthm_36, pthm_37, pthm_38,pthm_39,pthm_40] = sr_rules;
  11.433 -
  11.434 -val [ca, cb, cc, cd, cm, cn, cp, cq, cx, cy, cz, clx, crx, cly, cry] = vars;
  11.435 -val [add_pat, mul_pat, pow_pat, zero_tm, one_tm] = sr_ops;
  11.436 -val [add_tm, mul_tm, pow_tm] = map (Thm.dest_fun o Thm.dest_fun) [add_pat, mul_pat, pow_pat];
  11.437 -
  11.438 -val dest_add = dest_binop add_tm
  11.439 -val dest_mul = dest_binop mul_tm
  11.440 -fun dest_pow tm =
  11.441 - let val (l,r) = dest_binop pow_tm tm
  11.442 - in if is_numeral r then (l,r) else raise CTERM ("dest_pow",[tm])
  11.443 - end;
  11.444 -val is_add = is_binop add_tm
  11.445 -val is_mul = is_binop mul_tm
  11.446 -fun is_pow tm = is_binop pow_tm tm andalso is_numeral(Thm.dest_arg tm);
  11.447 -
  11.448 -val (neg_mul,sub_add,sub_tm,neg_tm,dest_sub,is_sub,cx',cy') =
  11.449 -  (case (r_ops, r_rules) of
  11.450 -    ([sub_pat, neg_pat], [neg_mul, sub_add]) =>
  11.451 -      let
  11.452 -        val sub_tm = Thm.dest_fun (Thm.dest_fun sub_pat)
  11.453 -        val neg_tm = Thm.dest_fun neg_pat
  11.454 -        val dest_sub = dest_binop sub_tm
  11.455 -        val is_sub = is_binop sub_tm
  11.456 -      in (neg_mul,sub_add,sub_tm,neg_tm,dest_sub,is_sub, neg_mul |> concl |> Thm.dest_arg,
  11.457 -          sub_add |> concl |> Thm.dest_arg |> Thm.dest_arg)
  11.458 -      end
  11.459 -    | _ => (TrueI, TrueI, true_tm, true_tm, (fn t => (t,t)), K false, true_tm, true_tm));
  11.460 -
  11.461 -val (divide_inverse, inverse_divide, divide_tm, inverse_tm, is_divide) = 
  11.462 -  (case (f_ops, f_rules) of 
  11.463 -   ([divide_pat, inverse_pat], [div_inv, inv_div]) => 
  11.464 -     let val div_tm = funpow 2 Thm.dest_fun divide_pat
  11.465 -         val inv_tm = Thm.dest_fun inverse_pat
  11.466 -     in (div_inv, inv_div, div_tm, inv_tm, is_binop div_tm)
  11.467 -     end
  11.468 -   | _ => (TrueI, TrueI, true_tm, true_tm, K false));
  11.469 -
  11.470 -in fn variable_order =>
  11.471 - let
  11.472 -
  11.473 -(* Conversion for "x^n * x^m", with either x^n = x and/or x^m = x possible.  *)
  11.474 -(* Also deals with "const * const", but both terms must involve powers of    *)
  11.475 -(* the same variable, or both be constants, or behaviour may be incorrect.   *)
  11.476 -
  11.477 - fun powvar_mul_conv tm =
  11.478 -  let
  11.479 -  val (l,r) = dest_mul tm
  11.480 -  in if is_semiring_constant l andalso is_semiring_constant r
  11.481 -     then semiring_mul_conv tm
  11.482 -     else
  11.483 -      ((let
  11.484 -         val (lx,ln) = dest_pow l
  11.485 -        in
  11.486 -         ((let val (rx,rn) = dest_pow r
  11.487 -               val th1 = inst_thm [(cx,lx),(cp,ln),(cq,rn)] pthm_29
  11.488 -                val (tm1,tm2) = Thm.dest_comb(concl th1) in
  11.489 -               transitive th1 (Drule.arg_cong_rule tm1 (nat_add_conv tm2)) end)
  11.490 -           handle CTERM _ =>
  11.491 -            (let val th1 = inst_thm [(cx,lx),(cq,ln)] pthm_31
  11.492 -                 val (tm1,tm2) = Thm.dest_comb(concl th1) in
  11.493 -               transitive th1 (Drule.arg_cong_rule tm1 (nat_add_conv tm2)) end)) end)
  11.494 -       handle CTERM _ =>
  11.495 -           ((let val (rx,rn) = dest_pow r
  11.496 -                val th1 = inst_thm [(cx,rx),(cq,rn)] pthm_30
  11.497 -                val (tm1,tm2) = Thm.dest_comb(concl th1) in
  11.498 -               transitive th1 (Drule.arg_cong_rule tm1 (nat_add_conv tm2)) end)
  11.499 -           handle CTERM _ => inst_thm [(cx,l)] pthm_32
  11.500 -
  11.501 -))
  11.502 - end;
  11.503 -
  11.504 -(* Remove "1 * m" from a monomial, and just leave m.                         *)
  11.505 -
  11.506 - fun monomial_deone th =
  11.507 -       (let val (l,r) = dest_mul(concl th) in
  11.508 -           if l aconvc one_tm
  11.509 -          then transitive th (inst_thm [(ca,r)] pthm_13)  else th end)
  11.510 -       handle CTERM _ => th;
  11.511 -
  11.512 -(* Conversion for "(monomial)^n", where n is a numeral.                      *)
  11.513 -
  11.514 - val monomial_pow_conv =
  11.515 -  let
  11.516 -   fun monomial_pow tm bod ntm =
  11.517 -    if not(is_comb bod)
  11.518 -    then reflexive tm
  11.519 -    else
  11.520 -     if is_semiring_constant bod
  11.521 -     then semiring_pow_conv tm
  11.522 -     else
  11.523 -      let
  11.524 -      val (lopr,r) = Thm.dest_comb bod
  11.525 -      in if not(is_comb lopr)
  11.526 -         then reflexive tm
  11.527 -        else
  11.528 -          let
  11.529 -          val (opr,l) = Thm.dest_comb lopr
  11.530 -         in
  11.531 -           if opr aconvc pow_tm andalso is_numeral r
  11.532 -          then
  11.533 -            let val th1 = inst_thm [(cx,l),(cp,r),(cq,ntm)] pthm_34
  11.534 -                val (l,r) = Thm.dest_comb(concl th1)
  11.535 -           in transitive th1 (Drule.arg_cong_rule l (nat_add_conv r))
  11.536 -           end
  11.537 -           else
  11.538 -            if opr aconvc mul_tm
  11.539 -            then
  11.540 -             let
  11.541 -              val th1 = inst_thm [(cx,l),(cy,r),(cq,ntm)] pthm_33
  11.542 -             val (xy,z) = Thm.dest_comb(concl th1)
  11.543 -              val (x,y) = Thm.dest_comb xy
  11.544 -              val thl = monomial_pow y l ntm
  11.545 -              val thr = monomial_pow z r ntm
  11.546 -             in transitive th1 (combination (Drule.arg_cong_rule x thl) thr)
  11.547 -             end
  11.548 -             else reflexive tm
  11.549 -          end
  11.550 -      end
  11.551 -  in fn tm =>
  11.552 -   let
  11.553 -    val (lopr,r) = Thm.dest_comb tm
  11.554 -    val (opr,l) = Thm.dest_comb lopr
  11.555 -   in if not (opr aconvc pow_tm) orelse not(is_numeral r)
  11.556 -      then raise CTERM ("monomial_pow_conv", [tm])
  11.557 -      else if r aconvc zeron_tm
  11.558 -      then inst_thm [(cx,l)] pthm_35
  11.559 -      else if r aconvc onen_tm
  11.560 -      then inst_thm [(cx,l)] pthm_36
  11.561 -      else monomial_deone(monomial_pow tm l r)
  11.562 -   end
  11.563 -  end;
  11.564 -
  11.565 -(* Multiplication of canonical monomials.                                    *)
  11.566 - val monomial_mul_conv =
  11.567 -  let
  11.568 -   fun powvar tm =
  11.569 -    if is_semiring_constant tm then one_tm
  11.570 -    else
  11.571 -     ((let val (lopr,r) = Thm.dest_comb tm
  11.572 -           val (opr,l) = Thm.dest_comb lopr
  11.573 -       in if opr aconvc pow_tm andalso is_numeral r then l 
  11.574 -          else raise CTERM ("monomial_mul_conv",[tm]) end)
  11.575 -     handle CTERM _ => tm)   (* FIXME !? *)
  11.576 -   fun  vorder x y =
  11.577 -    if x aconvc y then 0
  11.578 -    else
  11.579 -     if x aconvc one_tm then ~1
  11.580 -     else if y aconvc one_tm then 1
  11.581 -      else if variable_order x y then ~1 else 1
  11.582 -   fun monomial_mul tm l r =
  11.583 -    ((let val (lx,ly) = dest_mul l val vl = powvar lx
  11.584 -      in
  11.585 -      ((let
  11.586 -        val (rx,ry) = dest_mul r
  11.587 -         val vr = powvar rx
  11.588 -         val ord = vorder vl vr
  11.589 -        in
  11.590 -         if ord = 0
  11.591 -        then
  11.592 -          let
  11.593 -             val th1 = inst_thm [(clx,lx),(cly,ly),(crx,rx),(cry,ry)] pthm_15
  11.594 -             val (tm1,tm2) = Thm.dest_comb(concl th1)
  11.595 -             val (tm3,tm4) = Thm.dest_comb tm1
  11.596 -             val th2 = Drule.fun_cong_rule (Drule.arg_cong_rule tm3 (powvar_mul_conv tm4)) tm2
  11.597 -             val th3 = transitive th1 th2
  11.598 -              val  (tm5,tm6) = Thm.dest_comb(concl th3)
  11.599 -              val  (tm7,tm8) = Thm.dest_comb tm6
  11.600 -             val  th4 = monomial_mul tm6 (Thm.dest_arg tm7) tm8
  11.601 -         in  transitive th3 (Drule.arg_cong_rule tm5 th4)
  11.602 -         end
  11.603 -         else
  11.604 -          let val th0 = if ord < 0 then pthm_16 else pthm_17
  11.605 -             val th1 = inst_thm [(clx,lx),(cly,ly),(crx,rx),(cry,ry)] th0
  11.606 -             val (tm1,tm2) = Thm.dest_comb(concl th1)
  11.607 -             val (tm3,tm4) = Thm.dest_comb tm2
  11.608 -         in transitive th1 (Drule.arg_cong_rule tm1 (monomial_mul tm2 (Thm.dest_arg tm3) tm4))
  11.609 -         end
  11.610 -        end)
  11.611 -       handle CTERM _ =>
  11.612 -        (let val vr = powvar r val ord = vorder vl vr
  11.613 -        in
  11.614 -          if ord = 0 then
  11.615 -           let
  11.616 -           val th1 = inst_thm [(clx,lx),(cly,ly),(crx,r)] pthm_18
  11.617 -                 val (tm1,tm2) = Thm.dest_comb(concl th1)
  11.618 -           val (tm3,tm4) = Thm.dest_comb tm1
  11.619 -           val th2 = Drule.fun_cong_rule (Drule.arg_cong_rule tm3 (powvar_mul_conv tm4)) tm2
  11.620 -          in transitive th1 th2
  11.621 -          end
  11.622 -          else
  11.623 -          if ord < 0 then
  11.624 -            let val th1 = inst_thm [(clx,lx),(cly,ly),(crx,r)] pthm_19
  11.625 -                val (tm1,tm2) = Thm.dest_comb(concl th1)
  11.626 -                val (tm3,tm4) = Thm.dest_comb tm2
  11.627 -           in transitive th1 (Drule.arg_cong_rule tm1 (monomial_mul tm2 (Thm.dest_arg tm3) tm4))
  11.628 -           end
  11.629 -           else inst_thm [(ca,l),(cb,r)] pthm_09
  11.630 -        end)) end)
  11.631 -     handle CTERM _ =>
  11.632 -      (let val vl = powvar l in
  11.633 -        ((let
  11.634 -          val (rx,ry) = dest_mul r
  11.635 -          val vr = powvar rx
  11.636 -           val ord = vorder vl vr
  11.637 -         in if ord = 0 then
  11.638 -              let val th1 = inst_thm [(clx,l),(crx,rx),(cry,ry)] pthm_21
  11.639 -                 val (tm1,tm2) = Thm.dest_comb(concl th1)
  11.640 -                 val (tm3,tm4) = Thm.dest_comb tm1
  11.641 -             in transitive th1 (Drule.fun_cong_rule (Drule.arg_cong_rule tm3 (powvar_mul_conv tm4)) tm2)
  11.642 -             end
  11.643 -             else if ord > 0 then
  11.644 -                 let val th1 = inst_thm [(clx,l),(crx,rx),(cry,ry)] pthm_22
  11.645 -                     val (tm1,tm2) = Thm.dest_comb(concl th1)
  11.646 -                    val (tm3,tm4) = Thm.dest_comb tm2
  11.647 -                in transitive th1 (Drule.arg_cong_rule tm1 (monomial_mul tm2 (Thm.dest_arg tm3) tm4))
  11.648 -                end
  11.649 -             else reflexive tm
  11.650 -         end)
  11.651 -        handle CTERM _ =>
  11.652 -          (let val vr = powvar r
  11.653 -               val  ord = vorder vl vr
  11.654 -          in if ord = 0 then powvar_mul_conv tm
  11.655 -              else if ord > 0 then inst_thm [(ca,l),(cb,r)] pthm_09
  11.656 -              else reflexive tm
  11.657 -          end)) end))
  11.658 -  in fn tm => let val (l,r) = dest_mul tm in monomial_deone(monomial_mul tm l r)
  11.659 -             end
  11.660 -  end;
  11.661 -(* Multiplication by monomial of a polynomial.                               *)
  11.662 -
  11.663 - val polynomial_monomial_mul_conv =
  11.664 -  let
  11.665 -   fun pmm_conv tm =
  11.666 -    let val (l,r) = dest_mul tm
  11.667 -    in
  11.668 -    ((let val (y,z) = dest_add r
  11.669 -          val th1 = inst_thm [(cx,l),(cy,y),(cz,z)] pthm_37
  11.670 -          val (tm1,tm2) = Thm.dest_comb(concl th1)
  11.671 -          val (tm3,tm4) = Thm.dest_comb tm1
  11.672 -          val th2 = combination (Drule.arg_cong_rule tm3 (monomial_mul_conv tm4)) (pmm_conv tm2)
  11.673 -      in transitive th1 th2
  11.674 -      end)
  11.675 -     handle CTERM _ => monomial_mul_conv tm)
  11.676 -   end
  11.677 - in pmm_conv
  11.678 - end;
  11.679 -
  11.680 -(* Addition of two monomials identical except for constant multiples.        *)
  11.681 -
  11.682 -fun monomial_add_conv tm =
  11.683 - let val (l,r) = dest_add tm
  11.684 - in if is_semiring_constant l andalso is_semiring_constant r
  11.685 -    then semiring_add_conv tm
  11.686 -    else
  11.687 -     let val th1 =
  11.688 -           if is_mul l andalso is_semiring_constant(Thm.dest_arg1 l)
  11.689 -           then if is_mul r andalso is_semiring_constant(Thm.dest_arg1 r) then
  11.690 -                    inst_thm [(ca,Thm.dest_arg1 l),(cm,Thm.dest_arg r), (cb,Thm.dest_arg1 r)] pthm_02
  11.691 -                else inst_thm [(ca,Thm.dest_arg1 l),(cm,r)] pthm_03
  11.692 -           else if is_mul r andalso is_semiring_constant(Thm.dest_arg1 r)
  11.693 -           then inst_thm [(cm,l),(ca,Thm.dest_arg1 r)] pthm_04
  11.694 -           else inst_thm [(cm,r)] pthm_05
  11.695 -         val (tm1,tm2) = Thm.dest_comb(concl th1)
  11.696 -         val (tm3,tm4) = Thm.dest_comb tm1
  11.697 -         val th2 = Drule.arg_cong_rule tm3 (semiring_add_conv tm4)
  11.698 -         val th3 = transitive th1 (Drule.fun_cong_rule th2 tm2)
  11.699 -         val tm5 = concl th3
  11.700 -      in
  11.701 -      if (Thm.dest_arg1 tm5) aconvc zero_tm
  11.702 -      then transitive th3 (inst_thm [(ca,Thm.dest_arg tm5)] pthm_11)
  11.703 -      else monomial_deone th3
  11.704 -     end
  11.705 - end;
  11.706 -
  11.707 -(* Ordering on monomials.                                                    *)
  11.708 -
  11.709 -fun striplist dest =
  11.710 - let fun strip x acc =
  11.711 -   ((let val (l,r) = dest x in
  11.712 -        strip l (strip r acc) end)
  11.713 -    handle CTERM _ => x::acc)    (* FIXME !? *)
  11.714 - in fn x => strip x []
  11.715 - end;
  11.716 -
  11.717 -
  11.718 -fun powervars tm =
  11.719 - let val ptms = striplist dest_mul tm
  11.720 - in if is_semiring_constant (hd ptms) then tl ptms else ptms
  11.721 - end;
  11.722 -val num_0 = 0;
  11.723 -val num_1 = 1;
  11.724 -fun dest_varpow tm =
  11.725 - ((let val (x,n) = dest_pow tm in (x,dest_numeral n) end)
  11.726 -   handle CTERM _ =>
  11.727 -   (tm,(if is_semiring_constant tm then num_0 else num_1)));
  11.728 -
  11.729 -val morder =
  11.730 - let fun lexorder l1 l2 =
  11.731 -  case (l1,l2) of
  11.732 -    ([],[]) => 0
  11.733 -  | (vps,[]) => ~1
  11.734 -  | ([],vps) => 1
  11.735 -  | (((x1,n1)::vs1),((x2,n2)::vs2)) =>
  11.736 -     if variable_order x1 x2 then 1
  11.737 -     else if variable_order x2 x1 then ~1
  11.738 -     else if n1 < n2 then ~1
  11.739 -     else if n2 < n1 then 1
  11.740 -     else lexorder vs1 vs2
  11.741 - in fn tm1 => fn tm2 =>
  11.742 -  let val vdegs1 = map dest_varpow (powervars tm1)
  11.743 -      val vdegs2 = map dest_varpow (powervars tm2)
  11.744 -      val deg1 = fold (Integer.add o snd) vdegs1 num_0
  11.745 -      val deg2 = fold (Integer.add o snd) vdegs2 num_0
  11.746 -  in if deg1 < deg2 then ~1 else if deg1 > deg2 then 1
  11.747 -                            else lexorder vdegs1 vdegs2
  11.748 -  end
  11.749 - end;
  11.750 -
  11.751 -(* Addition of two polynomials.                                              *)
  11.752 -
  11.753 -val polynomial_add_conv =
  11.754 - let
  11.755 - fun dezero_rule th =
  11.756 -  let
  11.757 -   val tm = concl th
  11.758 -  in
  11.759 -   if not(is_add tm) then th else
  11.760 -   let val (lopr,r) = Thm.dest_comb tm
  11.761 -       val l = Thm.dest_arg lopr
  11.762 -   in
  11.763 -    if l aconvc zero_tm
  11.764 -    then transitive th (inst_thm [(ca,r)] pthm_07)   else
  11.765 -        if r aconvc zero_tm
  11.766 -        then transitive th (inst_thm [(ca,l)] pthm_08)  else th
  11.767 -   end
  11.768 -  end
  11.769 - fun padd tm =
  11.770 -  let
  11.771 -   val (l,r) = dest_add tm
  11.772 -  in
  11.773 -   if l aconvc zero_tm then inst_thm [(ca,r)] pthm_07
  11.774 -   else if r aconvc zero_tm then inst_thm [(ca,l)] pthm_08
  11.775 -   else
  11.776 -    if is_add l
  11.777 -    then
  11.778 -     let val (a,b) = dest_add l
  11.779 -     in
  11.780 -     if is_add r then
  11.781 -      let val (c,d) = dest_add r
  11.782 -          val ord = morder a c
  11.783 -      in
  11.784 -       if ord = 0 then
  11.785 -        let val th1 = inst_thm [(ca,a),(cb,b),(cc,c),(cd,d)] pthm_23
  11.786 -            val (tm1,tm2) = Thm.dest_comb(concl th1)
  11.787 -            val (tm3,tm4) = Thm.dest_comb tm1
  11.788 -            val th2 = Drule.arg_cong_rule tm3 (monomial_add_conv tm4)
  11.789 -        in dezero_rule (transitive th1 (combination th2 (padd tm2)))
  11.790 -        end
  11.791 -       else (* ord <> 0*)
  11.792 -        let val th1 =
  11.793 -                if ord > 0 then inst_thm [(ca,a),(cb,b),(cc,r)] pthm_24
  11.794 -                else inst_thm [(ca,l),(cc,c),(cd,d)] pthm_25
  11.795 -            val (tm1,tm2) = Thm.dest_comb(concl th1)
  11.796 -        in dezero_rule (transitive th1 (Drule.arg_cong_rule tm1 (padd tm2)))
  11.797 -        end
  11.798 -      end
  11.799 -     else (* not (is_add r)*)
  11.800 -      let val ord = morder a r
  11.801 -      in
  11.802 -       if ord = 0 then
  11.803 -        let val th1 = inst_thm [(ca,a),(cb,b),(cc,r)] pthm_26
  11.804 -            val (tm1,tm2) = Thm.dest_comb(concl th1)
  11.805 -            val (tm3,tm4) = Thm.dest_comb tm1
  11.806 -            val th2 = Drule.fun_cong_rule (Drule.arg_cong_rule tm3 (monomial_add_conv tm4)) tm2
  11.807 -        in dezero_rule (transitive th1 th2)
  11.808 -        end
  11.809 -       else (* ord <> 0*)
  11.810 -        if ord > 0 then
  11.811 -          let val th1 = inst_thm [(ca,a),(cb,b),(cc,r)] pthm_24
  11.812 -              val (tm1,tm2) = Thm.dest_comb(concl th1)
  11.813 -          in dezero_rule (transitive th1 (Drule.arg_cong_rule tm1 (padd tm2)))
  11.814 -          end
  11.815 -        else dezero_rule (inst_thm [(ca,l),(cc,r)] pthm_27)
  11.816 -      end
  11.817 -    end
  11.818 -   else (* not (is_add l)*)
  11.819 -    if is_add r then
  11.820 -      let val (c,d) = dest_add r
  11.821 -          val  ord = morder l c
  11.822 -      in
  11.823 -       if ord = 0 then
  11.824 -         let val th1 = inst_thm [(ca,l),(cc,c),(cd,d)] pthm_28
  11.825 -             val (tm1,tm2) = Thm.dest_comb(concl th1)
  11.826 -             val (tm3,tm4) = Thm.dest_comb tm1
  11.827 -             val th2 = Drule.fun_cong_rule (Drule.arg_cong_rule tm3 (monomial_add_conv tm4)) tm2
  11.828 -         in dezero_rule (transitive th1 th2)
  11.829 -         end
  11.830 -       else
  11.831 -        if ord > 0 then reflexive tm
  11.832 -        else
  11.833 -         let val th1 = inst_thm [(ca,l),(cc,c),(cd,d)] pthm_25
  11.834 -             val (tm1,tm2) = Thm.dest_comb(concl th1)
  11.835 -         in dezero_rule (transitive th1 (Drule.arg_cong_rule tm1 (padd tm2)))
  11.836 -         end
  11.837 -      end
  11.838 -    else
  11.839 -     let val ord = morder l r
  11.840 -     in
  11.841 -      if ord = 0 then monomial_add_conv tm
  11.842 -      else if ord > 0 then dezero_rule(reflexive tm)
  11.843 -      else dezero_rule (inst_thm [(ca,l),(cc,r)] pthm_27)
  11.844 -     end
  11.845 -  end
  11.846 - in padd
  11.847 - end;
  11.848 -
  11.849 -(* Multiplication of two polynomials.                                        *)
  11.850 -
  11.851 -val polynomial_mul_conv =
  11.852 - let
  11.853 -  fun pmul tm =
  11.854 -   let val (l,r) = dest_mul tm
  11.855 -   in
  11.856 -    if not(is_add l) then polynomial_monomial_mul_conv tm
  11.857 -    else
  11.858 -     if not(is_add r) then
  11.859 -      let val th1 = inst_thm [(ca,l),(cb,r)] pthm_09
  11.860 -      in transitive th1 (polynomial_monomial_mul_conv(concl th1))
  11.861 -      end
  11.862 -     else
  11.863 -       let val (a,b) = dest_add l
  11.864 -           val th1 = inst_thm [(ca,a),(cb,b),(cc,r)] pthm_10
  11.865 -           val (tm1,tm2) = Thm.dest_comb(concl th1)
  11.866 -           val (tm3,tm4) = Thm.dest_comb tm1
  11.867 -           val th2 = Drule.arg_cong_rule tm3 (polynomial_monomial_mul_conv tm4)
  11.868 -           val th3 = transitive th1 (combination th2 (pmul tm2))
  11.869 -       in transitive th3 (polynomial_add_conv (concl th3))
  11.870 -       end
  11.871 -   end
  11.872 - in fn tm =>
  11.873 -   let val (l,r) = dest_mul tm
  11.874 -   in
  11.875 -    if l aconvc zero_tm then inst_thm [(ca,r)] pthm_11
  11.876 -    else if r aconvc zero_tm then inst_thm [(ca,l)] pthm_12
  11.877 -    else if l aconvc one_tm then inst_thm [(ca,r)] pthm_13
  11.878 -    else if r aconvc one_tm then inst_thm [(ca,l)] pthm_14
  11.879 -    else pmul tm
  11.880 -   end
  11.881 - end;
  11.882 -
  11.883 -(* Power of polynomial (optimized for the monomial and trivial cases).       *)
  11.884 -
  11.885 -fun num_conv n =
  11.886 -  nat_add_conv (Thm.capply @{cterm Suc} (Numeral.mk_cnumber @{ctyp nat} (dest_numeral n - 1)))
  11.887 -  |> Thm.symmetric;
  11.888 -
  11.889 -
  11.890 -val polynomial_pow_conv =
  11.891 - let
  11.892 -  fun ppow tm =
  11.893 -    let val (l,n) = dest_pow tm
  11.894 -    in
  11.895 -     if n aconvc zeron_tm then inst_thm [(cx,l)] pthm_35
  11.896 -     else if n aconvc onen_tm then inst_thm [(cx,l)] pthm_36
  11.897 -     else
  11.898 -         let val th1 = num_conv n
  11.899 -             val th2 = inst_thm [(cx,l),(cq,Thm.dest_arg (concl th1))] pthm_38
  11.900 -             val (tm1,tm2) = Thm.dest_comb(concl th2)
  11.901 -             val th3 = transitive th2 (Drule.arg_cong_rule tm1 (ppow tm2))
  11.902 -             val th4 = transitive (Drule.arg_cong_rule (Thm.dest_fun tm) th1) th3
  11.903 -         in transitive th4 (polynomial_mul_conv (concl th4))
  11.904 -         end
  11.905 -    end
  11.906 - in fn tm =>
  11.907 -       if is_add(Thm.dest_arg1 tm) then ppow tm else monomial_pow_conv tm
  11.908 - end;
  11.909 -
  11.910 -(* Negation.                                                                 *)
  11.911 -
  11.912 -fun polynomial_neg_conv tm =
  11.913 -   let val (l,r) = Thm.dest_comb tm in
  11.914 -        if not (l aconvc neg_tm) then raise CTERM ("polynomial_neg_conv",[tm]) else
  11.915 -        let val th1 = inst_thm [(cx',r)] neg_mul
  11.916 -            val th2 = transitive th1 (Conv.arg1_conv semiring_mul_conv (concl th1))
  11.917 -        in transitive th2 (polynomial_monomial_mul_conv (concl th2))
  11.918 -        end
  11.919 -   end;
  11.920 -
  11.921 -
  11.922 -(* Subtraction.                                                              *)
  11.923 -fun polynomial_sub_conv tm =
  11.924 -  let val (l,r) = dest_sub tm
  11.925 -      val th1 = inst_thm [(cx',l),(cy',r)] sub_add
  11.926 -      val (tm1,tm2) = Thm.dest_comb(concl th1)
  11.927 -      val th2 = Drule.arg_cong_rule tm1 (polynomial_neg_conv tm2)
  11.928 -  in transitive th1 (transitive th2 (polynomial_add_conv (concl th2)))
  11.929 -  end;
  11.930 -
  11.931 -(* Conversion from HOL term.                                                 *)
  11.932 -
  11.933 -fun polynomial_conv tm =
  11.934 - if is_semiring_constant tm then semiring_add_conv tm
  11.935 - else if not(is_comb tm) then reflexive tm
  11.936 - else
  11.937 -  let val (lopr,r) = Thm.dest_comb tm
  11.938 -  in if lopr aconvc neg_tm then
  11.939 -       let val th1 = Drule.arg_cong_rule lopr (polynomial_conv r)
  11.940 -       in transitive th1 (polynomial_neg_conv (concl th1))
  11.941 -       end
  11.942 -     else if lopr aconvc inverse_tm then
  11.943 -       let val th1 = Drule.arg_cong_rule lopr (polynomial_conv r)
  11.944 -       in transitive th1 (semiring_mul_conv (concl th1))
  11.945 -       end
  11.946 -     else
  11.947 -       if not(is_comb lopr) then reflexive tm
  11.948 -       else
  11.949 -         let val (opr,l) = Thm.dest_comb lopr
  11.950 -         in if opr aconvc pow_tm andalso is_numeral r
  11.951 -            then
  11.952 -              let val th1 = Drule.fun_cong_rule (Drule.arg_cong_rule opr (polynomial_conv l)) r
  11.953 -              in transitive th1 (polynomial_pow_conv (concl th1))
  11.954 -              end
  11.955 -         else if opr aconvc divide_tm 
  11.956 -            then
  11.957 -              let val th1 = combination (Drule.arg_cong_rule opr (polynomial_conv l)) 
  11.958 -                                        (polynomial_conv r)
  11.959 -                  val th2 = (Conv.rewr_conv divide_inverse then_conv polynomial_mul_conv)
  11.960 -                              (Thm.rhs_of th1)
  11.961 -              in transitive th1 th2
  11.962 -              end
  11.963 -            else
  11.964 -              if opr aconvc add_tm orelse opr aconvc mul_tm orelse opr aconvc sub_tm
  11.965 -              then
  11.966 -               let val th1 = combination (Drule.arg_cong_rule opr (polynomial_conv l)) (polynomial_conv r)
  11.967 -                   val f = if opr aconvc add_tm then polynomial_add_conv
  11.968 -                      else if opr aconvc mul_tm then polynomial_mul_conv
  11.969 -                      else polynomial_sub_conv
  11.970 -               in transitive th1 (f (concl th1))
  11.971 -               end
  11.972 -              else reflexive tm
  11.973 -         end
  11.974 -  end;
  11.975 - in
  11.976 -   {main = polynomial_conv,
  11.977 -    add = polynomial_add_conv,
  11.978 -    mul = polynomial_mul_conv,
  11.979 -    pow = polynomial_pow_conv,
  11.980 -    neg = polynomial_neg_conv,
  11.981 -    sub = polynomial_sub_conv}
  11.982 - end
  11.983 -end;
  11.984 -
  11.985 -val nat_exp_ss =
  11.986 -  HOL_basic_ss addsimps (@{thms nat_number} @ @{thms nat_arith} @ @{thms arith_simps} @ @{thms rel_simps})
  11.987 -    addsimps [@{thm Let_def}, @{thm if_False}, @{thm if_True}, @{thm Nat.add_0}, @{thm add_Suc}];
  11.988 -
  11.989 -fun simple_cterm_ord t u = Term_Ord.term_ord (term_of t, term_of u) = LESS;
  11.990 -
  11.991 -
  11.992 -(* various normalizing conversions *)
  11.993 -
  11.994 -fun semiring_normalizers_ord_wrapper ctxt ({vars, semiring, ring, field, idom, ideal}, 
  11.995 -                                     {conv, dest_const, mk_const, is_const}) ord =
  11.996 -  let
  11.997 -    val pow_conv =
  11.998 -      Conv.arg_conv (Simplifier.rewrite nat_exp_ss)
  11.999 -      then_conv Simplifier.rewrite
 11.1000 -        (HOL_basic_ss addsimps [nth (snd semiring) 31, nth (snd semiring) 34])
 11.1001 -      then_conv conv ctxt
 11.1002 -    val dat = (is_const, conv ctxt, conv ctxt, pow_conv)
 11.1003 -  in semiring_normalizers_conv vars semiring ring field dat ord end;
 11.1004 -
 11.1005 -fun semiring_normalize_ord_wrapper ctxt ({vars, semiring, ring, field, idom, ideal}, {conv, dest_const, mk_const, is_const}) ord =
 11.1006 - #main (semiring_normalizers_ord_wrapper ctxt ({vars = vars, semiring = semiring, ring = ring, field = field, idom = idom, ideal = ideal},{conv = conv, dest_const = dest_const, mk_const = mk_const, is_const = is_const}) ord);
 11.1007 -
 11.1008 -fun semiring_normalize_wrapper ctxt data = 
 11.1009 -  semiring_normalize_ord_wrapper ctxt data simple_cterm_ord;
 11.1010 -
 11.1011 -fun semiring_normalize_ord_conv ctxt ord tm =
 11.1012 -  (case match ctxt tm of
 11.1013 -    NONE => reflexive tm
 11.1014 -  | SOME res => semiring_normalize_ord_wrapper ctxt res ord tm);
 11.1015 - 
 11.1016 -fun semiring_normalize_conv ctxt = semiring_normalize_ord_conv ctxt simple_cterm_ord;
 11.1017 -
 11.1018 -
 11.1019 -(** Isar setup **)
 11.1020 -
 11.1021 -local
 11.1022 -
 11.1023 -fun keyword k = Scan.lift (Args.$$$ k -- Args.colon) >> K ();
 11.1024 -fun keyword2 k1 k2 = Scan.lift (Args.$$$ k1 -- Args.$$$ k2 -- Args.colon) >> K ();
 11.1025 -fun keyword3 k1 k2 k3 =
 11.1026 -  Scan.lift (Args.$$$ k1 -- Args.$$$ k2 -- Args.$$$ k3 -- Args.colon) >> K ();
 11.1027 -
 11.1028 -val opsN = "ops";
 11.1029 -val rulesN = "rules";
 11.1030 -
 11.1031 -val normN = "norm";
 11.1032 -val constN = "const";
 11.1033 -val delN = "del";
 11.1034 -
 11.1035 -val any_keyword =
 11.1036 -  keyword2 semiringN opsN || keyword2 semiringN rulesN ||
 11.1037 -  keyword2 ringN opsN || keyword2 ringN rulesN ||
 11.1038 -  keyword2 fieldN opsN || keyword2 fieldN rulesN ||
 11.1039 -  keyword2 idomN rulesN || keyword2 idealN rulesN;
 11.1040 -
 11.1041 -val thms = Scan.repeat (Scan.unless any_keyword Attrib.multi_thm) >> flat;
 11.1042 -val terms = thms >> map Drule.dest_term;
 11.1043 -
 11.1044 -fun optional scan = Scan.optional scan [];
 11.1045 -
 11.1046 -in
 11.1047 -
 11.1048 -val setup =
 11.1049 -  Attrib.setup @{binding normalizer}
 11.1050 -    (Scan.lift (Args.$$$ delN >> K del) ||
 11.1051 -      ((keyword2 semiringN opsN |-- terms) --
 11.1052 -       (keyword2 semiringN rulesN |-- thms)) --
 11.1053 -      (optional (keyword2 ringN opsN |-- terms) --
 11.1054 -       optional (keyword2 ringN rulesN |-- thms)) --
 11.1055 -      (optional (keyword2 fieldN opsN |-- terms) --
 11.1056 -       optional (keyword2 fieldN rulesN |-- thms)) --
 11.1057 -      optional (keyword2 idomN rulesN |-- thms) --
 11.1058 -      optional (keyword2 idealN rulesN |-- thms)
 11.1059 -      >> (fn ((((sr, r), f), id), idl) => 
 11.1060 -             add {semiring = sr, ring = r, field = f, idom = id, ideal = idl}))
 11.1061 -    "semiring normalizer data";
 11.1062 -
 11.1063 -end;
 11.1064 -
 11.1065 -end;
    12.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    12.2 +++ b/src/HOL/Tools/groebner.ML	Sat May 08 17:15:50 2010 +0200
    12.3 @@ -0,0 +1,1045 @@
    12.4 +(*  Title:      HOL/Tools/Groebner_Basis/groebner.ML
    12.5 +    Author:     Amine Chaieb, TU Muenchen
    12.6 +*)
    12.7 +
    12.8 +signature GROEBNER =
    12.9 +sig
   12.10 +  val ring_and_ideal_conv :
   12.11 +    {idom: thm list, ring: cterm list * thm list, field: cterm list * thm list,
   12.12 +     vars: cterm list, semiring: cterm list * thm list, ideal : thm list} ->
   12.13 +    (cterm -> Rat.rat) -> (Rat.rat -> cterm) ->
   12.14 +    conv ->  conv ->
   12.15 +     {ring_conv : conv, 
   12.16 +     simple_ideal: (cterm list -> cterm -> (cterm * cterm -> order) -> cterm list),
   12.17 +     multi_ideal: cterm list -> cterm list -> cterm list -> (cterm * cterm) list,
   12.18 +     poly_eq_ss: simpset, unwind_conv : conv}
   12.19 +  val ring_tac: thm list -> thm list -> Proof.context -> int -> tactic
   12.20 +  val ideal_tac: thm list -> thm list -> Proof.context -> int -> tactic
   12.21 +  val algebra_tac: thm list -> thm list -> Proof.context -> int -> tactic
   12.22 +  val algebra_method: (Proof.context -> Method.method) context_parser
   12.23 +end
   12.24 +
   12.25 +structure Groebner : GROEBNER =
   12.26 +struct
   12.27 +
   12.28 +open Conv Drule Thm;
   12.29 +
   12.30 +fun is_comb ct =
   12.31 +  (case Thm.term_of ct of
   12.32 +    _ $ _ => true
   12.33 +  | _ => false);
   12.34 +
   12.35 +val concl = Thm.cprop_of #> Thm.dest_arg;
   12.36 +
   12.37 +fun is_binop ct ct' =
   12.38 +  (case Thm.term_of ct' of
   12.39 +    c $ _ $ _ => term_of ct aconv c
   12.40 +  | _ => false);
   12.41 +
   12.42 +fun dest_binary ct ct' =
   12.43 +  if is_binop ct ct' then Thm.dest_binop ct'
   12.44 +  else raise CTERM ("dest_binary: bad binop", [ct, ct'])
   12.45 +
   12.46 +fun inst_thm inst = Thm.instantiate ([], inst);
   12.47 +
   12.48 +val rat_0 = Rat.zero;
   12.49 +val rat_1 = Rat.one;
   12.50 +val minus_rat = Rat.neg;
   12.51 +val denominator_rat = Rat.quotient_of_rat #> snd #> Rat.rat_of_int;
   12.52 +fun int_of_rat a =
   12.53 +    case Rat.quotient_of_rat a of (i,1) => i | _ => error "int_of_rat: not an int";
   12.54 +val lcm_rat = fn x => fn y => Rat.rat_of_int (Integer.lcm (int_of_rat x) (int_of_rat y));
   12.55 +
   12.56 +val (eqF_intr, eqF_elim) =
   12.57 +  let val [th1,th2] = @{thms PFalse}
   12.58 +  in (fn th => th COMP th2, fn th => th COMP th1) end;
   12.59 +
   12.60 +val (PFalse, PFalse') =
   12.61 + let val PFalse_eq = nth @{thms simp_thms} 13
   12.62 + in (PFalse_eq RS iffD1, PFalse_eq RS iffD2) end;
   12.63 +
   12.64 +
   12.65 +(* Type for recording history, i.e. how a polynomial was obtained. *)
   12.66 +
   12.67 +datatype history =
   12.68 +   Start of int
   12.69 + | Mmul of (Rat.rat * int list) * history
   12.70 + | Add of history * history;
   12.71 +
   12.72 +
   12.73 +(* Monomial ordering. *)
   12.74 +
   12.75 +fun morder_lt m1 m2=
   12.76 +    let fun lexorder l1 l2 =
   12.77 +            case (l1,l2) of
   12.78 +                ([],[]) => false
   12.79 +              | (x1::o1,x2::o2) => x1 > x2 orelse x1 = x2 andalso lexorder o1 o2
   12.80 +              | _ => error "morder: inconsistent monomial lengths"
   12.81 +        val n1 = Integer.sum m1
   12.82 +        val n2 = Integer.sum m2 in
   12.83 +    n1 < n2 orelse n1 = n2 andalso lexorder m1 m2
   12.84 +    end;
   12.85 +
   12.86 +fun morder_le m1 m2 = morder_lt m1 m2 orelse (m1 = m2);
   12.87 +
   12.88 +fun morder_gt m1 m2 = morder_lt m2 m1;
   12.89 +
   12.90 +(* Arithmetic on canonical polynomials. *)
   12.91 +
   12.92 +fun grob_neg l = map (fn (c,m) => (minus_rat c,m)) l;
   12.93 +
   12.94 +fun grob_add l1 l2 =
   12.95 +  case (l1,l2) of
   12.96 +    ([],l2) => l2
   12.97 +  | (l1,[]) => l1
   12.98 +  | ((c1,m1)::o1,(c2,m2)::o2) =>
   12.99 +        if m1 = m2 then
  12.100 +          let val c = c1+/c2 val rest = grob_add o1 o2 in
  12.101 +          if c =/ rat_0 then rest else (c,m1)::rest end
  12.102 +        else if morder_lt m2 m1 then (c1,m1)::(grob_add o1 l2)
  12.103 +        else (c2,m2)::(grob_add l1 o2);
  12.104 +
  12.105 +fun grob_sub l1 l2 = grob_add l1 (grob_neg l2);
  12.106 +
  12.107 +fun grob_mmul (c1,m1) (c2,m2) = (c1*/c2, ListPair.map (op +) (m1, m2));
  12.108 +
  12.109 +fun grob_cmul cm pol = map (grob_mmul cm) pol;
  12.110 +
  12.111 +fun grob_mul l1 l2 =
  12.112 +  case l1 of
  12.113 +    [] => []
  12.114 +  | (h1::t1) => grob_add (grob_cmul h1 l2) (grob_mul t1 l2);
  12.115 +
  12.116 +fun grob_inv l =
  12.117 +  case l of
  12.118 +    [(c,vs)] => if (forall (fn x => x = 0) vs) then
  12.119 +                  if (c =/ rat_0) then error "grob_inv: division by zero"
  12.120 +                  else [(rat_1 // c,vs)]
  12.121 +              else error "grob_inv: non-constant divisor polynomial"
  12.122 +  | _ => error "grob_inv: non-constant divisor polynomial";
  12.123 +
  12.124 +fun grob_div l1 l2 =
  12.125 +  case l2 of
  12.126 +    [(c,l)] => if (forall (fn x => x = 0) l) then
  12.127 +                 if c =/ rat_0 then error "grob_div: division by zero"
  12.128 +                 else grob_cmul (rat_1 // c,l) l1
  12.129 +             else error "grob_div: non-constant divisor polynomial"
  12.130 +  | _ => error "grob_div: non-constant divisor polynomial";
  12.131 +
  12.132 +fun grob_pow vars l n =
  12.133 +  if n < 0 then error "grob_pow: negative power"
  12.134 +  else if n = 0 then [(rat_1,map (fn v => 0) vars)]
  12.135 +  else grob_mul l (grob_pow vars l (n - 1));
  12.136 +
  12.137 +fun degree vn p =
  12.138 + case p of
  12.139 +  [] => error "Zero polynomial"
  12.140 +| [(c,ns)] => nth ns vn
  12.141 +| (c,ns)::p' => Int.max (nth ns vn, degree vn p');
  12.142 +
  12.143 +fun head_deg vn p = let val d = degree vn p in
  12.144 + (d,fold (fn (c,r) => fn q => grob_add q [(c, map_index (fn (i,n) => if i = vn then 0 else n) r)]) (filter (fn (c,ns) => c <>/ rat_0 andalso nth ns vn = d) p) []) end;
  12.145 +
  12.146 +val is_zerop = forall (fn (c,ns) => c =/ rat_0 andalso forall (curry (op =) 0) ns);
  12.147 +val grob_pdiv =
  12.148 + let fun pdiv_aux vn (n,a) p k s =
  12.149 +  if is_zerop s then (k,s) else
  12.150 +  let val (m,b) = head_deg vn s
  12.151 +  in if m < n then (k,s) else
  12.152 +     let val p' = grob_mul p [(rat_1, map_index (fn (i,v) => if i = vn then m - n else 0)
  12.153 +                                                (snd (hd s)))]
  12.154 +     in if a = b then pdiv_aux vn (n,a) p k (grob_sub s p')
  12.155 +        else pdiv_aux vn (n,a) p (k + 1) (grob_sub (grob_mul a s) (grob_mul b p'))
  12.156 +     end
  12.157 +  end
  12.158 + in fn vn => fn s => fn p => pdiv_aux vn (head_deg vn p) p 0 s
  12.159 + end;
  12.160 +
  12.161 +(* Monomial division operation. *)
  12.162 +
  12.163 +fun mdiv (c1,m1) (c2,m2) =
  12.164 +  (c1//c2,
  12.165 +   map2 (fn n1 => fn n2 => if n1 < n2 then error "mdiv" else n1 - n2) m1 m2);
  12.166 +
  12.167 +(* Lowest common multiple of two monomials. *)
  12.168 +
  12.169 +fun mlcm (c1,m1) (c2,m2) = (rat_1, ListPair.map Int.max (m1, m2));
  12.170 +
  12.171 +(* Reduce monomial cm by polynomial pol, returning replacement for cm.  *)
  12.172 +
  12.173 +fun reduce1 cm (pol,hpol) =
  12.174 +  case pol of
  12.175 +    [] => error "reduce1"
  12.176 +  | cm1::cms => ((let val (c,m) = mdiv cm cm1 in
  12.177 +                    (grob_cmul (minus_rat c,m) cms,
  12.178 +                     Mmul((minus_rat c,m),hpol)) end)
  12.179 +                handle  ERROR _ => error "reduce1");
  12.180 +
  12.181 +(* Try this for all polynomials in a basis.  *)
  12.182 +fun tryfind f l =
  12.183 +    case l of
  12.184 +        [] => error "tryfind"
  12.185 +      | (h::t) => ((f h) handle ERROR _ => tryfind f t);
  12.186 +
  12.187 +fun reduceb cm basis = tryfind (fn p => reduce1 cm p) basis;
  12.188 +
  12.189 +(* Reduction of a polynomial (always picking largest monomial possible).     *)
  12.190 +
  12.191 +fun reduce basis (pol,hist) =
  12.192 +  case pol of
  12.193 +    [] => (pol,hist)
  12.194 +  | cm::ptl => ((let val (q,hnew) = reduceb cm basis in
  12.195 +                   reduce basis (grob_add q ptl,Add(hnew,hist)) end)
  12.196 +               handle (ERROR _) =>
  12.197 +                   (let val (q,hist') = reduce basis (ptl,hist) in
  12.198 +                       (cm::q,hist') end));
  12.199 +
  12.200 +(* Check for orthogonality w.r.t. LCM.                                       *)
  12.201 +
  12.202 +fun orthogonal l p1 p2 =
  12.203 +  snd l = snd(grob_mmul (hd p1) (hd p2));
  12.204 +
  12.205 +(* Compute S-polynomial of two polynomials.                                  *)
  12.206 +
  12.207 +fun spoly cm ph1 ph2 =
  12.208 +  case (ph1,ph2) of
  12.209 +    (([],h),p) => ([],h)
  12.210 +  | (p,([],h)) => ([],h)
  12.211 +  | ((cm1::ptl1,his1),(cm2::ptl2,his2)) =>
  12.212 +        (grob_sub (grob_cmul (mdiv cm cm1) ptl1)
  12.213 +                  (grob_cmul (mdiv cm cm2) ptl2),
  12.214 +         Add(Mmul(mdiv cm cm1,his1),
  12.215 +             Mmul(mdiv (minus_rat(fst cm),snd cm) cm2,his2)));
  12.216 +
  12.217 +(* Make a polynomial monic.                                                  *)
  12.218 +
  12.219 +fun monic (pol,hist) =
  12.220 +  if null pol then (pol,hist) else
  12.221 +  let val (c',m') = hd pol in
  12.222 +  (map (fn (c,m) => (c//c',m)) pol,
  12.223 +   Mmul((rat_1 // c',map (K 0) m'),hist)) end;
  12.224 +
  12.225 +(* The most popular heuristic is to order critical pairs by LCM monomial.    *)
  12.226 +
  12.227 +fun forder ((c1,m1),_) ((c2,m2),_) = morder_lt m1 m2;
  12.228 +
  12.229 +fun poly_lt  p q =
  12.230 +  case (p,q) of
  12.231 +    (p,[]) => false
  12.232 +  | ([],q) => true
  12.233 +  | ((c1,m1)::o1,(c2,m2)::o2) =>
  12.234 +        c1 </ c2 orelse
  12.235 +        c1 =/ c2 andalso ((morder_lt m1 m2) orelse m1 = m2 andalso poly_lt o1 o2);
  12.236 +
  12.237 +fun align  ((p,hp),(q,hq)) =
  12.238 +  if poly_lt p q then ((p,hp),(q,hq)) else ((q,hq),(p,hp));
  12.239 +fun forall2 p l1 l2 =
  12.240 +  case (l1,l2) of
  12.241 +    ([],[]) => true
  12.242 +  | (h1::t1,h2::t2) => p h1 h2 andalso forall2 p t1 t2
  12.243 +  | _ => false;
  12.244 +
  12.245 +fun poly_eq p1 p2 =
  12.246 +  forall2 (fn (c1,m1) => fn (c2,m2) => c1 =/ c2 andalso (m1: int list) = m2) p1 p2;
  12.247 +
  12.248 +fun memx ((p1,h1),(p2,h2)) ppairs =
  12.249 +  not (exists (fn ((q1,_),(q2,_)) => poly_eq p1 q1 andalso poly_eq p2 q2) ppairs);
  12.250 +
  12.251 +(* Buchberger's second criterion.                                            *)
  12.252 +
  12.253 +fun criterion2 basis (lcm,((p1,h1),(p2,h2))) opairs =
  12.254 +  exists (fn g => not(poly_eq (fst g) p1) andalso not(poly_eq (fst g) p2) andalso
  12.255 +                   can (mdiv lcm) (hd(fst g)) andalso
  12.256 +                   not(memx (align (g,(p1,h1))) (map snd opairs)) andalso
  12.257 +                   not(memx (align (g,(p2,h2))) (map snd opairs))) basis;
  12.258 +
  12.259 +(* Test for hitting constant polynomial.                                     *)
  12.260 +
  12.261 +fun constant_poly p =
  12.262 +  length p = 1 andalso forall (fn x => x = 0) (snd(hd p));
  12.263 +
  12.264 +(* Grobner basis algorithm.                                                  *)
  12.265 +
  12.266 +(* FIXME: try to get rid of mergesort? *)
  12.267 +fun merge ord l1 l2 =
  12.268 + case l1 of
  12.269 +  [] => l2
  12.270 + | h1::t1 =>
  12.271 +   case l2 of
  12.272 +    [] => l1
  12.273 +   | h2::t2 => if ord h1 h2 then h1::(merge ord t1 l2)
  12.274 +               else h2::(merge ord l1 t2);
  12.275 +fun mergesort ord l =
  12.276 + let
  12.277 + fun mergepairs l1 l2 =
  12.278 +  case (l1,l2) of
  12.279 +   ([s],[]) => s
  12.280 + | (l,[]) => mergepairs [] l
  12.281 + | (l,[s1]) => mergepairs (s1::l) []
  12.282 + | (l,(s1::s2::ss)) => mergepairs ((merge ord s1 s2)::l) ss
  12.283 + in if null l  then []  else mergepairs [] (map (fn x => [x]) l)
  12.284 + end;
  12.285 +
  12.286 +
  12.287 +fun grobner_basis basis pairs =
  12.288 + case pairs of
  12.289 +   [] => basis
  12.290 + | (l,(p1,p2))::opairs =>
  12.291 +   let val (sph as (sp,hist)) = monic (reduce basis (spoly l p1 p2))
  12.292 +   in 
  12.293 +    if null sp orelse criterion2 basis (l,(p1,p2)) opairs
  12.294 +    then grobner_basis basis opairs
  12.295 +    else if constant_poly sp then grobner_basis (sph::basis) []
  12.296 +    else 
  12.297 +     let 
  12.298 +      val rawcps = map (fn p => (mlcm (hd(fst p)) (hd sp),align(p,sph)))
  12.299 +                              basis
  12.300 +      val newcps = filter (fn (l,(p,q)) => not(orthogonal l (fst p) (fst q)))
  12.301 +                        rawcps
  12.302 +     in grobner_basis (sph::basis)
  12.303 +                 (merge forder opairs (mergesort forder newcps))
  12.304 +     end
  12.305 +   end;
  12.306 +
  12.307 +(* Interreduce initial polynomials.                                          *)
  12.308 +
  12.309 +fun grobner_interreduce rpols ipols =
  12.310 +  case ipols of
  12.311 +    [] => map monic (rev rpols)
  12.312 +  | p::ps => let val p' = reduce (rpols @ ps) p in
  12.313 +             if null (fst p') then grobner_interreduce rpols ps
  12.314 +             else grobner_interreduce (p'::rpols) ps end;
  12.315 +
  12.316 +(* Overall function.                                                         *)
  12.317 +
  12.318 +fun grobner pols =
  12.319 +    let val npols = map_index (fn (n, p) => (p, Start n)) pols
  12.320 +        val phists = filter (fn (p,_) => not (null p)) npols
  12.321 +        val bas = grobner_interreduce [] (map monic phists)
  12.322 +        val prs0 = map_product pair bas bas
  12.323 +        val prs1 = filter (fn ((x,_),(y,_)) => poly_lt x y) prs0
  12.324 +        val prs2 = map (fn (p,q) => (mlcm (hd(fst p)) (hd(fst q)),(p,q))) prs1
  12.325 +        val prs3 =
  12.326 +            filter (fn (l,(p,q)) => not(orthogonal l (fst p) (fst q))) prs2 in
  12.327 +        grobner_basis bas (mergesort forder prs3) end;
  12.328 +
  12.329 +(* Get proof of contradiction from Grobner basis.                            *)
  12.330 +
  12.331 +fun find p l =
  12.332 +  case l of
  12.333 +      [] => error "find"
  12.334 +    | (h::t) => if p(h) then h else find p t;
  12.335 +
  12.336 +fun grobner_refute pols =
  12.337 +  let val gb = grobner pols in
  12.338 +  snd(find (fn (p,h) => length p = 1 andalso forall (fn x=> x=0) (snd(hd p))) gb)
  12.339 +  end;
  12.340 +
  12.341 +(* Turn proof into a certificate as sum of multipliers.                      *)
  12.342 +(* In principle this is very inefficient: in a heavily shared proof it may   *)
  12.343 +(* make the same calculation many times. Could put in a cache or something.  *)
  12.344 +
  12.345 +fun resolve_proof vars prf =
  12.346 +  case prf of
  12.347 +    Start(~1) => []
  12.348 +  | Start m => [(m,[(rat_1,map (K 0) vars)])]
  12.349 +  | Mmul(pol,lin) =>
  12.350 +        let val lis = resolve_proof vars lin in
  12.351 +            map (fn (n,p) => (n,grob_cmul pol p)) lis end
  12.352 +  | Add(lin1,lin2) =>
  12.353 +        let val lis1 = resolve_proof vars lin1
  12.354 +            val lis2 = resolve_proof vars lin2
  12.355 +            val dom = distinct (op =) (union (op =) (map fst lis1) (map fst lis2))
  12.356 +        in
  12.357 +            map (fn n => let val a = these (AList.lookup (op =) lis1 n)
  12.358 +                             val b = these (AList.lookup (op =) lis2 n)
  12.359 +                         in (n,grob_add a b) end) dom end;
  12.360 +
  12.361 +(* Run the procedure and produce Weak Nullstellensatz certificate.           *)
  12.362 +
  12.363 +fun grobner_weak vars pols =
  12.364 +    let val cert = resolve_proof vars (grobner_refute pols)
  12.365 +        val l =
  12.366 +            fold_rev (fold_rev (lcm_rat o denominator_rat o fst) o snd) cert (rat_1) in
  12.367 +        (l,map (fn (i,p) => (i,map (fn (d,m) => (l*/d,m)) p)) cert) end;
  12.368 +
  12.369 +(* Prove a polynomial is in ideal generated by others, using Grobner basis.  *)
  12.370 +
  12.371 +fun grobner_ideal vars pols pol =
  12.372 +  let val (pol',h) = reduce (grobner pols) (grob_neg pol,Start(~1)) in
  12.373 +  if not (null pol') then error "grobner_ideal: not in the ideal" else
  12.374 +  resolve_proof vars h end;
  12.375 +
  12.376 +(* Produce Strong Nullstellensatz certificate for a power of pol.            *)
  12.377 +
  12.378 +fun grobner_strong vars pols pol =
  12.379 +    let val vars' = @{cterm "True"}::vars
  12.380 +        val grob_z = [(rat_1,1::(map (fn x => 0) vars))]
  12.381 +        val grob_1 = [(rat_1,(map (fn x => 0) vars'))]
  12.382 +        fun augment p= map (fn (c,m) => (c,0::m)) p
  12.383 +        val pols' = map augment pols
  12.384 +        val pol' = augment pol
  12.385 +        val allpols = (grob_sub (grob_mul grob_z pol') grob_1)::pols'
  12.386 +        val (l,cert) = grobner_weak vars' allpols
  12.387 +        val d = fold (fold (Integer.max o hd o snd) o snd) cert 0
  12.388 +        fun transform_monomial (c,m) =
  12.389 +            grob_cmul (c,tl m) (grob_pow vars pol (d - hd m))
  12.390 +        fun transform_polynomial q = fold_rev (grob_add o transform_monomial) q []
  12.391 +        val cert' = map (fn (c,q) => (c-1,transform_polynomial q))
  12.392 +                        (filter (fn (k,_) => k <> 0) cert) in
  12.393 +        (d,l,cert') end;
  12.394 +
  12.395 +
  12.396 +(* Overall parametrized universal procedure for (semi)rings.                 *)
  12.397 +(* We return an ideal_conv and the actual ring prover.                       *)
  12.398 +
  12.399 +fun refute_disj rfn tm =
  12.400 + case term_of tm of
  12.401 +  Const("op |",_)$l$r =>
  12.402 +   compose_single(refute_disj rfn (dest_arg tm),2,compose_single(refute_disj rfn (dest_arg1 tm),2,disjE))
  12.403 +  | _ => rfn tm ;
  12.404 +
  12.405 +val notnotD = @{thm notnotD};
  12.406 +fun mk_binop ct x y = capply (capply ct x) y
  12.407 +
  12.408 +val mk_comb = capply;
  12.409 +fun is_neg t =
  12.410 +    case term_of t of
  12.411 +      (Const("Not",_)$p) => true
  12.412 +    | _  => false;
  12.413 +fun is_eq t =
  12.414 + case term_of t of
  12.415 + (Const("op =",_)$_$_) => true
  12.416 +| _  => false;
  12.417 +
  12.418 +fun end_itlist f l =
  12.419 +  case l of
  12.420 +        []     => error "end_itlist"
  12.421 +      | [x]    => x
  12.422 +      | (h::t) => f h (end_itlist f t);
  12.423 +
  12.424 +val list_mk_binop = fn b => end_itlist (mk_binop b);
  12.425 +
  12.426 +val list_dest_binop = fn b =>
  12.427 + let fun h acc t =
  12.428 +  ((let val (l,r) = dest_binary b t in h (h acc r) l end)
  12.429 +   handle CTERM _ => (t::acc)) (* Why had I handle _ => ? *)
  12.430 + in h []
  12.431 + end;
  12.432 +
  12.433 +val strip_exists =
  12.434 + let fun h (acc, t) =
  12.435 +      case (term_of t) of
  12.436 +       Const("Ex",_)$Abs(x,T,p) => h (dest_abs NONE (dest_arg t) |>> (fn v => v::acc))
  12.437 +     | _ => (acc,t)
  12.438 + in fn t => h ([],t)
  12.439 + end;
  12.440 +
  12.441 +fun is_forall t =
  12.442 + case term_of t of
  12.443 +  (Const("All",_)$Abs(_,_,_)) => true
  12.444 +| _ => false;
  12.445 +
  12.446 +val mk_object_eq = fn th => th COMP meta_eq_to_obj_eq;
  12.447 +val bool_simps = @{thms bool_simps};
  12.448 +val nnf_simps = @{thms nnf_simps};
  12.449 +val nnf_conv = Simplifier.rewrite (HOL_basic_ss addsimps bool_simps addsimps nnf_simps)
  12.450 +val weak_dnf_conv = Simplifier.rewrite (HOL_basic_ss addsimps @{thms weak_dnf_simps});
  12.451 +val initial_conv =
  12.452 +    Simplifier.rewrite
  12.453 +     (HOL_basic_ss addsimps nnf_simps
  12.454 +       addsimps [not_all, not_ex]
  12.455 +       addsimps map (fn th => th RS sym) (@{thms ex_simps} @ @{thms all_simps}));
  12.456 +
  12.457 +val specl = fold_rev (fn x => fn th => instantiate' [] [SOME x] (th RS spec));
  12.458 +
  12.459 +val cTrp = @{cterm "Trueprop"};
  12.460 +val cConj = @{cterm "op &"};
  12.461 +val (cNot,false_tm) = (@{cterm "Not"}, @{cterm "False"});
  12.462 +val assume_Trueprop = mk_comb cTrp #> assume;
  12.463 +val list_mk_conj = list_mk_binop cConj;
  12.464 +val conjs = list_dest_binop cConj;
  12.465 +val mk_neg = mk_comb cNot;
  12.466 +
  12.467 +fun striplist dest = 
  12.468 + let
  12.469 +  fun h acc x = case try dest x of
  12.470 +    SOME (a,b) => h (h acc b) a
  12.471 +  | NONE => x::acc
  12.472 + in h [] end;
  12.473 +fun list_mk_binop b = foldr1 (fn (s,t) => Thm.capply (Thm.capply b s) t);
  12.474 +
  12.475 +val eq_commute = mk_meta_eq @{thm eq_commute};
  12.476 +
  12.477 +fun sym_conv eq = 
  12.478 + let val (l,r) = Thm.dest_binop eq
  12.479 + in instantiate' [SOME (ctyp_of_term l)] [SOME l, SOME r] eq_commute
  12.480 + end;
  12.481 +
  12.482 +  (* FIXME : copied from cqe.ML -- complex QE*)
  12.483 +fun conjuncts ct =
  12.484 + case term_of ct of
  12.485 +  @{term "op &"}$_$_ => (Thm.dest_arg1 ct)::(conjuncts (Thm.dest_arg ct))
  12.486 +| _ => [ct];
  12.487 +
  12.488 +fun fold1 f = foldr1 (uncurry f);
  12.489 +
  12.490 +val list_conj = fold1 (fn c => fn c' => Thm.capply (Thm.capply @{cterm "op &"} c) c') ;
  12.491 +
  12.492 +fun mk_conj_tab th = 
  12.493 + let fun h acc th = 
  12.494 +   case prop_of th of
  12.495 +   @{term "Trueprop"}$(@{term "op &"}$p$q) => 
  12.496 +     h (h acc (th RS conjunct2)) (th RS conjunct1)
  12.497 +  | @{term "Trueprop"}$p => (p,th)::acc
  12.498 +in fold (Termtab.insert Thm.eq_thm) (h [] th) Termtab.empty end;
  12.499 +
  12.500 +fun is_conj (@{term "op &"}$_$_) = true
  12.501 +  | is_conj _ = false;
  12.502 +
  12.503 +fun prove_conj tab cjs = 
  12.504 + case cjs of 
  12.505 +   [c] => if is_conj (term_of c) then prove_conj tab (conjuncts c) else tab c
  12.506 + | c::cs => conjI OF [prove_conj tab [c], prove_conj tab cs];
  12.507 +
  12.508 +fun conj_ac_rule eq = 
  12.509 + let 
  12.510 +  val (l,r) = Thm.dest_equals eq
  12.511 +  val ctabl = mk_conj_tab (assume (Thm.capply @{cterm Trueprop} l))
  12.512 +  val ctabr = mk_conj_tab (assume (Thm.capply @{cterm Trueprop} r))
  12.513 +  fun tabl c = the (Termtab.lookup ctabl (term_of c))
  12.514 +  fun tabr c = the (Termtab.lookup ctabr (term_of c))
  12.515 +  val thl  = prove_conj tabl (conjuncts r) |> implies_intr_hyps
  12.516 +  val thr  = prove_conj tabr (conjuncts l) |> implies_intr_hyps
  12.517 +  val eqI = instantiate' [] [SOME l, SOME r] @{thm iffI}
  12.518 + in implies_elim (implies_elim eqI thl) thr |> mk_meta_eq end;
  12.519 +
  12.520 + (* END FIXME.*)
  12.521 +
  12.522 +   (* Conversion for the equivalence of existential statements where 
  12.523 +      EX quantifiers are rearranged differently *)
  12.524 + fun ext T = cterm_rule (instantiate' [SOME T] []) @{cpat Ex}
  12.525 + fun mk_ex v t = Thm.capply (ext (ctyp_of_term v)) (Thm.cabs v t)
  12.526 +
  12.527 +fun choose v th th' = case concl_of th of 
  12.528 +  @{term Trueprop} $ (Const("Ex",_)$_) => 
  12.529 +   let
  12.530 +    val p = (funpow 2 Thm.dest_arg o cprop_of) th
  12.531 +    val T = (hd o Thm.dest_ctyp o ctyp_of_term) p
  12.532 +    val th0 = fconv_rule (Thm.beta_conversion true)
  12.533 +        (instantiate' [SOME T] [SOME p, (SOME o Thm.dest_arg o cprop_of) th'] exE)
  12.534 +    val pv = (Thm.rhs_of o Thm.beta_conversion true) 
  12.535 +          (Thm.capply @{cterm Trueprop} (Thm.capply p v))
  12.536 +    val th1 = forall_intr v (implies_intr pv th')
  12.537 +   in implies_elim (implies_elim th0 th) th1  end
  12.538 +| _ => error ""
  12.539 +
  12.540 +fun simple_choose v th = 
  12.541 +   choose v (assume ((Thm.capply @{cterm Trueprop} o mk_ex v) ((Thm.dest_arg o hd o #hyps o Thm.crep_thm) th))) th
  12.542 +
  12.543 +
  12.544 + fun mkexi v th = 
  12.545 +  let 
  12.546 +   val p = Thm.cabs v (Thm.dest_arg (Thm.cprop_of th))
  12.547 +  in implies_elim 
  12.548 +    (fconv_rule (Thm.beta_conversion true) (instantiate' [SOME (ctyp_of_term v)] [SOME p, SOME v] @{thm exI}))
  12.549 +      th
  12.550 +  end
  12.551 + fun ex_eq_conv t = 
  12.552 +  let 
  12.553 +  val (p0,q0) = Thm.dest_binop t
  12.554 +  val (vs',P) = strip_exists p0 
  12.555 +  val (vs,_) = strip_exists q0 
  12.556 +   val th = assume (Thm.capply @{cterm Trueprop} P)
  12.557 +   val th1 =  implies_intr_hyps (fold simple_choose vs' (fold mkexi vs th))
  12.558 +   val th2 =  implies_intr_hyps (fold simple_choose vs (fold mkexi vs' th))
  12.559 +   val p = (Thm.dest_arg o Thm.dest_arg1 o cprop_of) th1
  12.560 +   val q = (Thm.dest_arg o Thm.dest_arg o cprop_of) th1
  12.561 +  in implies_elim (implies_elim (instantiate' [] [SOME p, SOME q] iffI) th1) th2
  12.562 +     |> mk_meta_eq
  12.563 +  end;
  12.564 +
  12.565 +
  12.566 + fun getname v = case term_of v of 
  12.567 +  Free(s,_) => s
  12.568 + | Var ((s,_),_) => s
  12.569 + | _ => "x"
  12.570 + fun mk_eq s t = Thm.capply (Thm.capply @{cterm "op == :: bool => _"} s) t
  12.571 + fun mkeq s t = Thm.capply @{cterm Trueprop} (Thm.capply (Thm.capply @{cterm "op = :: bool => _"} s) t)
  12.572 + fun mk_exists v th = arg_cong_rule (ext (ctyp_of_term v))
  12.573 +   (Thm.abstract_rule (getname v) v th)
  12.574 + val simp_ex_conv = 
  12.575 +     Simplifier.rewrite (HOL_basic_ss addsimps @{thms simp_thms(39)})
  12.576 +
  12.577 +fun frees t = Thm.add_cterm_frees t [];
  12.578 +fun free_in v t = member op aconvc (frees t) v;
  12.579 +
  12.580 +val vsubst = let
  12.581 + fun vsubst (t,v) tm =  
  12.582 +   (Thm.rhs_of o Thm.beta_conversion false) (Thm.capply (Thm.cabs v tm) t)
  12.583 +in fold vsubst end;
  12.584 +
  12.585 +
  12.586 +(** main **)
  12.587 +
  12.588 +fun ring_and_ideal_conv
  12.589 +  {vars, semiring = (sr_ops, sr_rules), ring = (r_ops, r_rules), 
  12.590 +   field = (f_ops, f_rules), idom, ideal}
  12.591 +  dest_const mk_const ring_eq_conv ring_normalize_conv =
  12.592 +let
  12.593 +  val [add_pat, mul_pat, pow_pat, zero_tm, one_tm] = sr_ops;
  12.594 +  val [ring_add_tm, ring_mul_tm, ring_pow_tm] =
  12.595 +    map dest_fun2 [add_pat, mul_pat, pow_pat];
  12.596 +
  12.597 +  val (ring_sub_tm, ring_neg_tm) =
  12.598 +    (case r_ops of
  12.599 +     [sub_pat, neg_pat] => (dest_fun2 sub_pat, dest_fun neg_pat)
  12.600 +    |_  => (@{cterm "True"}, @{cterm "True"}));
  12.601 +
  12.602 +  val (field_div_tm, field_inv_tm) =
  12.603 +    (case f_ops of
  12.604 +       [div_pat, inv_pat] => (dest_fun2 div_pat, dest_fun inv_pat)
  12.605 +     | _ => (@{cterm "True"}, @{cterm "True"}));
  12.606 +
  12.607 +  val [idom_thm, neq_thm] = idom;
  12.608 +  val [idl_sub, idl_add0] = 
  12.609 +     if length ideal = 2 then ideal else [eq_commute, eq_commute]
  12.610 +  fun ring_dest_neg t =
  12.611 +    let val (l,r) = dest_comb t 
  12.612 +    in if Term.could_unify(term_of l,term_of ring_neg_tm) then r 
  12.613 +       else raise CTERM ("ring_dest_neg", [t])
  12.614 +    end
  12.615 +
  12.616 + val ring_mk_neg = fn tm => mk_comb (ring_neg_tm) (tm);
  12.617 + fun field_dest_inv t =
  12.618 +    let val (l,r) = dest_comb t in
  12.619 +        if Term.could_unify(term_of l, term_of field_inv_tm) then r 
  12.620 +        else raise CTERM ("field_dest_inv", [t])
  12.621 +    end
  12.622 + val ring_dest_add = dest_binary ring_add_tm;
  12.623 + val ring_mk_add = mk_binop ring_add_tm;
  12.624 + val ring_dest_sub = dest_binary ring_sub_tm;
  12.625 + val ring_mk_sub = mk_binop ring_sub_tm;
  12.626 + val ring_dest_mul = dest_binary ring_mul_tm;
  12.627 + val ring_mk_mul = mk_binop ring_mul_tm;
  12.628 + val field_dest_div = dest_binary field_div_tm;
  12.629 + val field_mk_div = mk_binop field_div_tm;
  12.630 + val ring_dest_pow = dest_binary ring_pow_tm;
  12.631 + val ring_mk_pow = mk_binop ring_pow_tm ;
  12.632 + fun grobvars tm acc =
  12.633 +    if can dest_const tm then acc
  12.634 +    else if can ring_dest_neg tm then grobvars (dest_arg tm) acc
  12.635 +    else if can ring_dest_pow tm then grobvars (dest_arg1 tm) acc
  12.636 +    else if can ring_dest_add tm orelse can ring_dest_sub tm
  12.637 +            orelse can ring_dest_mul tm
  12.638 +    then grobvars (dest_arg1 tm) (grobvars (dest_arg tm) acc)
  12.639 +    else if can field_dest_inv tm
  12.640 +         then
  12.641 +          let val gvs = grobvars (dest_arg tm) [] 
  12.642 +          in if null gvs then acc else tm::acc
  12.643 +          end
  12.644 +    else if can field_dest_div tm then
  12.645 +         let val lvs = grobvars (dest_arg1 tm) acc
  12.646 +             val gvs = grobvars (dest_arg tm) []
  12.647 +          in if null gvs then lvs else tm::acc
  12.648 +          end 
  12.649 +    else tm::acc ;
  12.650 +
  12.651 +fun grobify_term vars tm =
  12.652 +((if not (member (op aconvc) vars tm) then raise CTERM ("Not a variable", [tm]) else
  12.653 +     [(rat_1,map (fn i => if i aconvc tm then 1 else 0) vars)])
  12.654 +handle  CTERM _ =>
  12.655 + ((let val x = dest_const tm
  12.656 + in if x =/ rat_0 then [] else [(x,map (fn v => 0) vars)]
  12.657 + end)
  12.658 + handle ERROR _ =>
  12.659 +  ((grob_neg(grobify_term vars (ring_dest_neg tm)))
  12.660 +  handle CTERM _ =>
  12.661 +   (
  12.662 +   (grob_inv(grobify_term vars (field_dest_inv tm)))
  12.663 +   handle CTERM _ => 
  12.664 +    ((let val (l,r) = ring_dest_add tm
  12.665 +    in grob_add (grobify_term vars l) (grobify_term vars r)
  12.666 +    end)
  12.667 +    handle CTERM _ =>
  12.668 +     ((let val (l,r) = ring_dest_sub tm
  12.669 +     in grob_sub (grobify_term vars l) (grobify_term vars r)
  12.670 +     end)
  12.671 +     handle  CTERM _ =>
  12.672 +      ((let val (l,r) = ring_dest_mul tm
  12.673 +      in grob_mul (grobify_term vars l) (grobify_term vars r)
  12.674 +      end)
  12.675 +       handle CTERM _ =>
  12.676 +        (  (let val (l,r) = field_dest_div tm
  12.677 +          in grob_div (grobify_term vars l) (grobify_term vars r)
  12.678 +          end)
  12.679 +         handle CTERM _ =>
  12.680 +          ((let val (l,r) = ring_dest_pow tm
  12.681 +          in grob_pow vars (grobify_term vars l) ((term_of #> HOLogic.dest_number #> snd) r)
  12.682 +          end)
  12.683 +           handle CTERM _ => error "grobify_term: unknown or invalid term")))))))));
  12.684 +val eq_tm = idom_thm |> concl |> dest_arg |> dest_arg |> dest_fun2;
  12.685 +val dest_eq = dest_binary eq_tm;
  12.686 +
  12.687 +fun grobify_equation vars tm =
  12.688 +    let val (l,r) = dest_binary eq_tm tm
  12.689 +    in grob_sub (grobify_term vars l) (grobify_term vars r)
  12.690 +    end;
  12.691 +
  12.692 +fun grobify_equations tm =
  12.693 + let
  12.694 +  val cjs = conjs tm
  12.695 +  val  rawvars = fold_rev (fn eq => fn a =>
  12.696 +                                       grobvars (dest_arg1 eq) (grobvars (dest_arg eq) a)) cjs []
  12.697 +  val vars = sort (fn (x, y) => Term_Ord.term_ord(term_of x,term_of y))
  12.698 +                  (distinct (op aconvc) rawvars)
  12.699 + in (vars,map (grobify_equation vars) cjs)
  12.700 + end;
  12.701 +
  12.702 +val holify_polynomial =
  12.703 + let fun holify_varpow (v,n) =
  12.704 +  if n = 1 then v else ring_mk_pow v (Numeral.mk_cnumber @{ctyp "nat"} n)  (* FIXME *)
  12.705 + fun holify_monomial vars (c,m) =
  12.706 +  let val xps = map holify_varpow (filter (fn (_,n) => n <> 0) (vars ~~ m))
  12.707 +   in end_itlist ring_mk_mul (mk_const c :: xps)
  12.708 +  end
  12.709 + fun holify_polynomial vars p =
  12.710 +     if null p then mk_const (rat_0)
  12.711 +     else end_itlist ring_mk_add (map (holify_monomial vars) p)
  12.712 + in holify_polynomial
  12.713 + end ;
  12.714 +val idom_rule = simplify (HOL_basic_ss addsimps [idom_thm]);
  12.715 +fun prove_nz n = eqF_elim
  12.716 +                 (ring_eq_conv(mk_binop eq_tm (mk_const n) (mk_const(rat_0))));
  12.717 +val neq_01 = prove_nz (rat_1);
  12.718 +fun neq_rule n th = [prove_nz n, th] MRS neq_thm;
  12.719 +fun mk_add th1 = combination(arg_cong_rule ring_add_tm th1);
  12.720 +
  12.721 +fun refute tm =
  12.722 + if tm aconvc false_tm then assume_Trueprop tm else
  12.723 + ((let
  12.724 +   val (nths0,eths0) = List.partition (is_neg o concl) (HOLogic.conj_elims (assume_Trueprop tm))
  12.725 +   val  nths = filter (is_eq o dest_arg o concl) nths0
  12.726 +   val eths = filter (is_eq o concl) eths0
  12.727 +  in
  12.728 +   if null eths then
  12.729 +    let
  12.730 +      val th1 = end_itlist (fn th1 => fn th2 => idom_rule(HOLogic.conj_intr th1 th2)) nths
  12.731 +      val th2 = Conv.fconv_rule
  12.732 +                ((arg_conv #> arg_conv)
  12.733 +                     (binop_conv ring_normalize_conv)) th1
  12.734 +      val conc = th2 |> concl |> dest_arg
  12.735 +      val (l,r) = conc |> dest_eq
  12.736 +    in implies_intr (mk_comb cTrp tm)
  12.737 +                    (equal_elim (arg_cong_rule cTrp (eqF_intr th2))
  12.738 +                           (reflexive l |> mk_object_eq))
  12.739 +    end
  12.740 +   else
  12.741 +   let
  12.742 +    val (vars,l,cert,noteqth) =(
  12.743 +     if null nths then
  12.744 +      let val (vars,pols) = grobify_equations(list_mk_conj(map concl eths))
  12.745 +          val (l,cert) = grobner_weak vars pols
  12.746 +      in (vars,l,cert,neq_01)
  12.747 +      end
  12.748 +     else
  12.749 +      let
  12.750 +       val nth = end_itlist (fn th1 => fn th2 => idom_rule(HOLogic.conj_intr th1 th2)) nths
  12.751 +       val (vars,pol::pols) =
  12.752 +          grobify_equations(list_mk_conj(dest_arg(concl nth)::map concl eths))
  12.753 +       val (deg,l,cert) = grobner_strong vars pols pol
  12.754 +       val th1 = Conv.fconv_rule((arg_conv o arg_conv)(binop_conv ring_normalize_conv)) nth
  12.755 +       val th2 = funpow deg (idom_rule o HOLogic.conj_intr th1) neq_01
  12.756 +      in (vars,l,cert,th2)
  12.757 +      end)
  12.758 +    val cert_pos = map (fn (i,p) => (i,filter (fn (c,m) => c >/ rat_0) p)) cert
  12.759 +    val cert_neg = map (fn (i,p) => (i,map (fn (c,m) => (minus_rat c,m))
  12.760 +                                            (filter (fn (c,m) => c </ rat_0) p))) cert
  12.761 +    val  herts_pos = map (fn (i,p) => (i,holify_polynomial vars p)) cert_pos
  12.762 +    val  herts_neg = map (fn (i,p) => (i,holify_polynomial vars p)) cert_neg
  12.763 +    fun thm_fn pols =
  12.764 +        if null pols then reflexive(mk_const rat_0) else
  12.765 +        end_itlist mk_add
  12.766 +            (map (fn (i,p) => arg_cong_rule (mk_comb ring_mul_tm p)
  12.767 +              (nth eths i |> mk_meta_eq)) pols)
  12.768 +    val th1 = thm_fn herts_pos
  12.769 +    val th2 = thm_fn herts_neg
  12.770 +    val th3 = HOLogic.conj_intr(mk_add (symmetric th1) th2 |> mk_object_eq) noteqth
  12.771 +    val th4 = Conv.fconv_rule ((arg_conv o arg_conv o binop_conv) ring_normalize_conv)
  12.772 +                               (neq_rule l th3)
  12.773 +    val (l,r) = dest_eq(dest_arg(concl th4))
  12.774 +   in implies_intr (mk_comb cTrp tm)
  12.775 +                        (equal_elim (arg_cong_rule cTrp (eqF_intr th4))
  12.776 +                   (reflexive l |> mk_object_eq))
  12.777 +   end
  12.778 +  end) handle ERROR _ => raise CTERM ("Gorbner-refute: unable to refute",[tm]))
  12.779 +
  12.780 +fun ring tm =
  12.781 + let
  12.782 +  fun mk_forall x p =
  12.783 +      mk_comb (cterm_rule (instantiate' [SOME (ctyp_of_term x)] []) @{cpat "All:: (?'a => bool) => _"}) (cabs x p)
  12.784 +  val avs = add_cterm_frees tm []
  12.785 +  val P' = fold mk_forall avs tm
  12.786 +  val th1 = initial_conv(mk_neg P')
  12.787 +  val (evs,bod) = strip_exists(concl th1) in
  12.788 +   if is_forall bod then raise CTERM("ring: non-universal formula",[tm])
  12.789 +   else
  12.790 +   let
  12.791 +    val th1a = weak_dnf_conv bod
  12.792 +    val boda = concl th1a
  12.793 +    val th2a = refute_disj refute boda
  12.794 +    val th2b = [mk_object_eq th1a, (th2a COMP notI) COMP PFalse'] MRS trans
  12.795 +    val th2 = fold (fn v => fn th => (forall_intr v th) COMP allI) evs (th2b RS PFalse)
  12.796 +    val th3 = equal_elim
  12.797 +                (Simplifier.rewrite (HOL_basic_ss addsimps [not_ex RS sym])
  12.798 +                          (th2 |> cprop_of)) th2
  12.799 +    in specl avs
  12.800 +             ([[[mk_object_eq th1, th3 RS PFalse'] MRS trans] MRS PFalse] MRS notnotD)
  12.801 +   end
  12.802 + end
  12.803 +fun ideal tms tm ord =
  12.804 + let
  12.805 +  val rawvars = fold_rev grobvars (tm::tms) []
  12.806 +  val vars = sort ord (distinct (fn (x,y) => (term_of x) aconv (term_of y)) rawvars)
  12.807 +  val pols = map (grobify_term vars) tms
  12.808 +  val pol = grobify_term vars tm
  12.809 +  val cert = grobner_ideal vars pols pol
  12.810 + in map_range (fn n => these (AList.lookup (op =) cert n) |> holify_polynomial vars)
  12.811 +   (length pols)
  12.812 + end
  12.813 +
  12.814 +fun poly_eq_conv t = 
  12.815 + let val (a,b) = Thm.dest_binop t
  12.816 + in fconv_rule (arg_conv (arg1_conv ring_normalize_conv)) 
  12.817 +     (instantiate' [] [SOME a, SOME b] idl_sub)
  12.818 + end
  12.819 + val poly_eq_simproc = 
  12.820 +  let 
  12.821 +   fun proc phi  ss t = 
  12.822 +    let val th = poly_eq_conv t
  12.823 +    in if Thm.is_reflexive th then NONE else SOME th
  12.824 +    end
  12.825 +   in make_simproc {lhss = [Thm.lhs_of idl_sub], 
  12.826 +                name = "poly_eq_simproc", proc = proc, identifier = []}
  12.827 +   end;
  12.828 +  val poly_eq_ss = HOL_basic_ss addsimps @{thms simp_thms}
  12.829 +                        addsimprocs [poly_eq_simproc]
  12.830 +
  12.831 + local
  12.832 +  fun is_defined v t =
  12.833 +  let 
  12.834 +   val mons = striplist(dest_binary ring_add_tm) t 
  12.835 +  in member (op aconvc) mons v andalso 
  12.836 +    forall (fn m => v aconvc m 
  12.837 +          orelse not(member (op aconvc) (Thm.add_cterm_frees m []) v)) mons
  12.838 +  end
  12.839 +
  12.840 +  fun isolate_variable vars tm =
  12.841 +  let 
  12.842 +   val th = poly_eq_conv tm
  12.843 +   val th' = (sym_conv then_conv poly_eq_conv) tm
  12.844 +   val (v,th1) = 
  12.845 +   case find_first(fn v=> is_defined v (Thm.dest_arg1 (Thm.rhs_of th))) vars of
  12.846 +    SOME v => (v,th')
  12.847 +   | NONE => (the (find_first 
  12.848 +          (fn v => is_defined v (Thm.dest_arg1 (Thm.rhs_of th'))) vars) ,th)
  12.849 +   val th2 = transitive th1 
  12.850 +        (instantiate' []  [(SOME o Thm.dest_arg1 o Thm.rhs_of) th1, SOME v] 
  12.851 +          idl_add0)
  12.852 +   in fconv_rule(funpow 2 arg_conv ring_normalize_conv) th2
  12.853 +   end
  12.854 + in
  12.855 + fun unwind_polys_conv tm =
  12.856 + let 
  12.857 +  val (vars,bod) = strip_exists tm
  12.858 +  val cjs = striplist (dest_binary @{cterm "op &"}) bod
  12.859 +  val th1 = (the (get_first (try (isolate_variable vars)) cjs) 
  12.860 +             handle Option => raise CTERM ("unwind_polys_conv",[tm]))
  12.861 +  val eq = Thm.lhs_of th1
  12.862 +  val bod' = list_mk_binop @{cterm "op &"} (eq::(remove op aconvc eq cjs))
  12.863 +  val th2 = conj_ac_rule (mk_eq bod bod')
  12.864 +  val th3 = transitive th2 
  12.865 +         (Drule.binop_cong_rule @{cterm "op &"} th1 
  12.866 +                (reflexive (Thm.dest_arg (Thm.rhs_of th2))))
  12.867 +  val v = Thm.dest_arg1(Thm.dest_arg1(Thm.rhs_of th3))
  12.868 +  val vars' = (remove op aconvc v vars) @ [v]
  12.869 +  val th4 = fconv_rule (arg_conv simp_ex_conv) (mk_exists v th3)
  12.870 +  val th5 = ex_eq_conv (mk_eq tm (fold mk_ex (remove op aconvc v vars) (Thm.lhs_of th4)))
  12.871 + in transitive th5 (fold mk_exists (remove op aconvc v vars) th4)
  12.872 + end;
  12.873 +end
  12.874 +
  12.875 +local
  12.876 + fun scrub_var v m =
  12.877 +  let 
  12.878 +   val ps = striplist ring_dest_mul m 
  12.879 +   val ps' = remove op aconvc v ps
  12.880 +  in if null ps' then one_tm else fold1 ring_mk_mul ps'
  12.881 +  end
  12.882 + fun find_multipliers v mons =
  12.883 +  let 
  12.884 +   val mons1 = filter (fn m => free_in v m) mons 
  12.885 +   val mons2 = map (scrub_var v) mons1 
  12.886 +   in  if null mons2 then zero_tm else fold1 ring_mk_add mons2
  12.887 +  end
  12.888 +
  12.889 + fun isolate_monomials vars tm =
  12.890 + let 
  12.891 +  val (cmons,vmons) =
  12.892 +    List.partition (fn m => null (inter (op aconvc) vars (frees m)))
  12.893 +                   (striplist ring_dest_add tm)
  12.894 +  val cofactors = map (fn v => find_multipliers v vmons) vars
  12.895 +  val cnc = if null cmons then zero_tm
  12.896 +             else Thm.capply ring_neg_tm
  12.897 +                    (list_mk_binop ring_add_tm cmons) 
  12.898 +  in (cofactors,cnc)
  12.899 +  end;
  12.900 +
  12.901 +fun isolate_variables evs ps eq =
  12.902 + let 
  12.903 +  val vars = filter (fn v => free_in v eq) evs
  12.904 +  val (qs,p) = isolate_monomials vars eq
  12.905 +  val rs = ideal (qs @ ps) p 
  12.906 +              (fn (s,t) => Term_Ord.term_ord (term_of s, term_of t))
  12.907 + in (eq, take (length qs) rs ~~ vars)
  12.908 + end;
  12.909 + fun subst_in_poly i p = Thm.rhs_of (ring_normalize_conv (vsubst i p));
  12.910 +in
  12.911 + fun solve_idealism evs ps eqs =
  12.912 +  if null evs then [] else
  12.913 +  let 
  12.914 +   val (eq,cfs) = get_first (try (isolate_variables evs ps)) eqs |> the
  12.915 +   val evs' = subtract op aconvc evs (map snd cfs)
  12.916 +   val eqs' = map (subst_in_poly cfs) (remove op aconvc eq eqs)
  12.917 +  in cfs @ solve_idealism evs' ps eqs'
  12.918 +  end;
  12.919 +end;
  12.920 +
  12.921 +
  12.922 +in {ring_conv = ring, simple_ideal = ideal, multi_ideal = solve_idealism, 
  12.923 +    poly_eq_ss = poly_eq_ss, unwind_conv = unwind_polys_conv}
  12.924 +end;
  12.925 +
  12.926 +
  12.927 +fun find_term bounds tm =
  12.928 +  (case term_of tm of
  12.929 +    Const ("op =", T) $ _ $ _ =>
  12.930 +      if domain_type T = HOLogic.boolT then find_args bounds tm
  12.931 +      else dest_arg tm
  12.932 +  | Const ("Not", _) $ _ => find_term bounds (dest_arg tm)
  12.933 +  | Const ("All", _) $ _ => find_body bounds (dest_arg tm)
  12.934 +  | Const ("Ex", _) $ _ => find_body bounds (dest_arg tm)
  12.935 +  | Const ("op &", _) $ _ $ _ => find_args bounds tm
  12.936 +  | Const ("op |", _) $ _ $ _ => find_args bounds tm
  12.937 +  | Const ("op -->", _) $ _ $ _ => find_args bounds tm
  12.938 +  | @{term "op ==>"} $_$_ => find_args bounds tm
  12.939 +  | Const("op ==",_)$_$_ => find_args bounds tm
  12.940 +  | @{term Trueprop}$_ => find_term bounds (dest_arg tm)
  12.941 +  | _ => raise TERM ("find_term", []))
  12.942 +and find_args bounds tm =
  12.943 +  let val (t, u) = Thm.dest_binop tm
  12.944 +  in (find_term bounds t handle TERM _ => find_term bounds u) end
  12.945 +and find_body bounds b =
  12.946 +  let val (_, b') = dest_abs (SOME (Name.bound bounds)) b
  12.947 +  in find_term (bounds + 1) b' end;
  12.948 +
  12.949 +
  12.950 +fun get_ring_ideal_convs ctxt form = 
  12.951 + case try (find_term 0) form of
  12.952 +  NONE => NONE
  12.953 +| SOME tm =>
  12.954 +  (case Semiring_Normalizer.match ctxt tm of
  12.955 +    NONE => NONE
  12.956 +  | SOME (res as (theory, {is_const, dest_const, 
  12.957 +          mk_const, conv = ring_eq_conv})) =>
  12.958 +     SOME (ring_and_ideal_conv theory
  12.959 +          dest_const (mk_const (ctyp_of_term tm)) (ring_eq_conv ctxt)
  12.960 +          (Semiring_Normalizer.semiring_normalize_wrapper ctxt res)))
  12.961 +
  12.962 +fun ring_solve ctxt form =
  12.963 +  (case try (find_term 0 (* FIXME !? *)) form of
  12.964 +    NONE => reflexive form
  12.965 +  | SOME tm =>
  12.966 +      (case Semiring_Normalizer.match ctxt tm of
  12.967 +        NONE => reflexive form
  12.968 +      | SOME (res as (theory, {is_const, dest_const, mk_const, conv = ring_eq_conv})) =>
  12.969 +        #ring_conv (ring_and_ideal_conv theory
  12.970 +          dest_const (mk_const (ctyp_of_term tm)) (ring_eq_conv ctxt)
  12.971 +          (Semiring_Normalizer.semiring_normalize_wrapper ctxt res)) form));
  12.972 +
  12.973 +fun presimplify ctxt add_thms del_thms = asm_full_simp_tac (Simplifier.context ctxt
  12.974 +  (HOL_basic_ss addsimps (Algebra_Simplification.get ctxt) delsimps del_thms addsimps add_thms));
  12.975 +
  12.976 +fun ring_tac add_ths del_ths ctxt =
  12.977 +  Object_Logic.full_atomize_tac
  12.978 +  THEN' presimplify ctxt add_ths del_ths
  12.979 +  THEN' CSUBGOAL (fn (p, i) =>
  12.980 +    rtac (let val form = Object_Logic.dest_judgment p
  12.981 +          in case get_ring_ideal_convs ctxt form of
  12.982 +           NONE => reflexive form
  12.983 +          | SOME thy => #ring_conv thy form
  12.984 +          end) i
  12.985 +      handle TERM _ => no_tac
  12.986 +        | CTERM _ => no_tac
  12.987 +        | THM _ => no_tac);
  12.988 +
  12.989 +local
  12.990 + fun lhs t = case term_of t of
  12.991 +  Const("op =",_)$_$_ => Thm.dest_arg1 t
  12.992 + | _=> raise CTERM ("ideal_tac - lhs",[t])
  12.993 + fun exitac NONE = no_tac
  12.994 +   | exitac (SOME y) = rtac (instantiate' [SOME (ctyp_of_term y)] [NONE,SOME y] exI) 1
  12.995 +in 
  12.996 +fun ideal_tac add_ths del_ths ctxt = 
  12.997 +  presimplify ctxt add_ths del_ths
  12.998 + THEN'
  12.999 + CSUBGOAL (fn (p, i) =>
 12.1000 +  case get_ring_ideal_convs ctxt p of
 12.1001 +   NONE => no_tac
 12.1002 + | SOME thy => 
 12.1003 +  let
 12.1004 +   fun poly_exists_tac {asms = asms, concl = concl, prems = prems,
 12.1005 +            params = params, context = ctxt, schematics = scs} = 
 12.1006 +    let
 12.1007 +     val (evs,bod) = strip_exists (Thm.dest_arg concl)
 12.1008 +     val ps = map_filter (try (lhs o Thm.dest_arg)) asms 
 12.1009 +     val cfs = (map swap o #multi_ideal thy evs ps) 
 12.1010 +                   (map Thm.dest_arg1 (conjuncts bod))
 12.1011 +     val ws = map (exitac o AList.lookup op aconvc cfs) evs
 12.1012 +    in EVERY (rev ws) THEN Method.insert_tac prems 1 
 12.1013 +        THEN ring_tac add_ths del_ths ctxt 1
 12.1014 +   end
 12.1015 +  in  
 12.1016 +     clarify_tac @{claset} i 
 12.1017 +     THEN Object_Logic.full_atomize_tac i 
 12.1018 +     THEN asm_full_simp_tac (Simplifier.context ctxt (#poly_eq_ss thy)) i 
 12.1019 +     THEN clarify_tac @{claset} i 
 12.1020 +     THEN (REPEAT (CONVERSION (#unwind_conv thy) i))
 12.1021 +     THEN SUBPROOF poly_exists_tac ctxt i
 12.1022 +  end
 12.1023 + handle TERM _ => no_tac
 12.1024 +     | CTERM _ => no_tac
 12.1025 +     | THM _ => no_tac); 
 12.1026 +end;
 12.1027 +
 12.1028 +fun algebra_tac add_ths del_ths ctxt i = 
 12.1029 + ring_tac add_ths del_ths ctxt i ORELSE ideal_tac add_ths del_ths ctxt i
 12.1030 + 
 12.1031 +local
 12.1032 +
 12.1033 +fun keyword k = Scan.lift (Args.$$$ k -- Args.colon) >> K ()
 12.1034 +val addN = "add"
 12.1035 +val delN = "del"
 12.1036 +val any_keyword = keyword addN || keyword delN
 12.1037 +val thms = Scan.repeat (Scan.unless any_keyword Attrib.multi_thm) >> flat;
 12.1038 +
 12.1039 +in
 12.1040 +
 12.1041 +val algebra_method = ((Scan.optional (keyword addN |-- thms) []) -- 
 12.1042 +   (Scan.optional (keyword delN |-- thms) [])) >>
 12.1043 +  (fn (add_ths, del_ths) => fn ctxt =>
 12.1044 +       SIMPLE_METHOD' (algebra_tac add_ths del_ths ctxt))
 12.1045 +
 12.1046 +end;
 12.1047 +
 12.1048 +end;
    13.1 --- a/src/HOL/Tools/numeral_simprocs.ML	Fri May 07 23:44:10 2010 +0200
    13.2 +++ b/src/HOL/Tools/numeral_simprocs.ML	Sat May 08 17:15:50 2010 +0200
    13.3 @@ -1,7 +1,7 @@
    13.4  (* Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    13.5     Copyright   2000  University of Cambridge
    13.6  
    13.7 -Simprocs for the integer numerals.
    13.8 +Simprocs for the (integer) numerals.
    13.9  *)
   13.10  
   13.11  (*To quote from Provers/Arith/cancel_numeral_factor.ML:
   13.12 @@ -24,6 +24,7 @@
   13.13    val field_combine_numerals: simproc
   13.14    val field_cancel_numeral_factors: simproc list
   13.15    val num_ss: simpset
   13.16 +  val field_comp_conv: conv
   13.17  end;
   13.18  
   13.19  structure Numeral_Simprocs : NUMERAL_SIMPROCS =
   13.20 @@ -602,6 +603,157 @@
   13.21        "(l::'a::field_inverse_zero) / (m * n)"],
   13.22       K DivideCancelFactor.proc)];
   13.23  
   13.24 +local
   13.25 + val zr = @{cpat "0"}
   13.26 + val zT = ctyp_of_term zr
   13.27 + val geq = @{cpat "op ="}
   13.28 + val eqT = Thm.dest_ctyp (ctyp_of_term geq) |> hd
   13.29 + val add_frac_eq = mk_meta_eq @{thm "add_frac_eq"}
   13.30 + val add_frac_num = mk_meta_eq @{thm "add_frac_num"}
   13.31 + val add_num_frac = mk_meta_eq @{thm "add_num_frac"}
   13.32 +
   13.33 + fun prove_nz ss T t =
   13.34 +    let
   13.35 +      val z = instantiate_cterm ([(zT,T)],[]) zr
   13.36 +      val eq = instantiate_cterm ([(eqT,T)],[]) geq
   13.37 +      val th = Simplifier.rewrite (ss addsimps @{thms simp_thms})
   13.38 +           (Thm.capply @{cterm "Trueprop"} (Thm.capply @{cterm "Not"}
   13.39 +                  (Thm.capply (Thm.capply eq t) z)))
   13.40 +    in equal_elim (symmetric th) TrueI
   13.41 +    end
   13.42 +
   13.43 + fun proc phi ss ct =
   13.44 +  let
   13.45 +    val ((x,y),(w,z)) =
   13.46 +         (Thm.dest_binop #> (fn (a,b) => (Thm.dest_binop a, Thm.dest_binop b))) ct
   13.47 +    val _ = map (HOLogic.dest_number o term_of) [x,y,z,w]
   13.48 +    val T = ctyp_of_term x
   13.49 +    val [y_nz, z_nz] = map (prove_nz ss T) [y, z]
   13.50 +    val th = instantiate' [SOME T] (map SOME [y,z,x,w]) add_frac_eq
   13.51 +  in SOME (implies_elim (implies_elim th y_nz) z_nz)
   13.52 +  end
   13.53 +  handle CTERM _ => NONE | TERM _ => NONE | THM _ => NONE
   13.54 +
   13.55 + fun proc2 phi ss ct =
   13.56 +  let
   13.57 +    val (l,r) = Thm.dest_binop ct
   13.58 +    val T = ctyp_of_term l
   13.59 +  in (case (term_of l, term_of r) of
   13.60 +      (Const(@{const_name Rings.divide},_)$_$_, _) =>
   13.61 +        let val (x,y) = Thm.dest_binop l val z = r
   13.62 +            val _ = map (HOLogic.dest_number o term_of) [x,y,z]
   13.63 +            val ynz = prove_nz ss T y
   13.64 +        in SOME (implies_elim (instantiate' [SOME T] (map SOME [y,x,z]) add_frac_num) ynz)
   13.65 +        end
   13.66 +     | (_, Const (@{const_name Rings.divide},_)$_$_) =>
   13.67 +        let val (x,y) = Thm.dest_binop r val z = l
   13.68 +            val _ = map (HOLogic.dest_number o term_of) [x,y,z]
   13.69 +            val ynz = prove_nz ss T y
   13.70 +        in SOME (implies_elim (instantiate' [SOME T] (map SOME [y,z,x]) add_num_frac) ynz)
   13.71 +        end
   13.72 +     | _ => NONE)
   13.73 +  end
   13.74 +  handle CTERM _ => NONE | TERM _ => NONE | THM _ => NONE
   13.75 +
   13.76 + fun is_number (Const(@{const_name Rings.divide},_)$a$b) = is_number a andalso is_number b
   13.77 +   | is_number t = can HOLogic.dest_number t
   13.78 +
   13.79 + val is_number = is_number o term_of
   13.80 +
   13.81 + fun proc3 phi ss ct =
   13.82 +  (case term_of ct of
   13.83 +    Const(@{const_name Orderings.less},_)$(Const(@{const_name Rings.divide},_)$_$_)$_ =>
   13.84 +      let
   13.85 +        val ((a,b),c) = Thm.dest_binop ct |>> Thm.dest_binop
   13.86 +        val _ = map is_number [a,b,c]
   13.87 +        val T = ctyp_of_term c
   13.88 +        val th = instantiate' [SOME T] (map SOME [a,b,c]) @{thm "divide_less_eq"}
   13.89 +      in SOME (mk_meta_eq th) end
   13.90 +  | Const(@{const_name Orderings.less_eq},_)$(Const(@{const_name Rings.divide},_)$_$_)$_ =>
   13.91 +      let
   13.92 +        val ((a,b),c) = Thm.dest_binop ct |>> Thm.dest_binop
   13.93 +        val _ = map is_number [a,b,c]
   13.94 +        val T = ctyp_of_term c
   13.95 +        val th = instantiate' [SOME T] (map SOME [a,b,c]) @{thm "divide_le_eq"}
   13.96 +      in SOME (mk_meta_eq th) end
   13.97 +  | Const("op =",_)$(Const(@{const_name Rings.divide},_)$_$_)$_ =>
   13.98 +      let
   13.99 +        val ((a,b),c) = Thm.dest_binop ct |>> Thm.dest_binop
  13.100 +        val _ = map is_number [a,b,c]
  13.101 +        val T = ctyp_of_term c
  13.102 +        val th = instantiate' [SOME T] (map SOME [a,b,c]) @{thm "divide_eq_eq"}
  13.103 +      in SOME (mk_meta_eq th) end
  13.104 +  | Const(@{const_name Orderings.less},_)$_$(Const(@{const_name Rings.divide},_)$_$_) =>
  13.105 +    let
  13.106 +      val (a,(b,c)) = Thm.dest_binop ct ||> Thm.dest_binop
  13.107 +        val _ = map is_number [a,b,c]
  13.108 +        val T = ctyp_of_term c
  13.109 +        val th = instantiate' [SOME T] (map SOME [a,b,c]) @{thm "less_divide_eq"}
  13.110 +      in SOME (mk_meta_eq th) end
  13.111 +  | Const(@{const_name Orderings.less_eq},_)$_$(Const(@{const_name Rings.divide},_)$_$_) =>
  13.112 +    let
  13.113 +      val (a,(b,c)) = Thm.dest_binop ct ||> Thm.dest_binop
  13.114 +        val _ = map is_number [a,b,c]
  13.115 +        val T = ctyp_of_term c
  13.116 +        val th = instantiate' [SOME T] (map SOME [a,b,c]) @{thm "le_divide_eq"}
  13.117 +      in SOME (mk_meta_eq th) end
  13.118 +  | Const("op =",_)$_$(Const(@{const_name Rings.divide},_)$_$_) =>
  13.119 +    let
  13.120 +      val (a,(b,c)) = Thm.dest_binop ct ||> Thm.dest_binop
  13.121 +        val _ = map is_number [a,b,c]
  13.122 +        val T = ctyp_of_term c
  13.123 +        val th = instantiate' [SOME T] (map SOME [a,b,c]) @{thm "eq_divide_eq"}
  13.124 +      in SOME (mk_meta_eq th) end
  13.125 +  | _ => NONE)
  13.126 +  handle TERM _ => NONE | CTERM _ => NONE | THM _ => NONE
  13.127 +
  13.128 +val add_frac_frac_simproc =
  13.129 +       make_simproc {lhss = [@{cpat "(?x::?'a::field)/?y + (?w::?'a::field)/?z"}],
  13.130 +                     name = "add_frac_frac_simproc",
  13.131 +                     proc = proc, identifier = []}
  13.132 +
  13.133 +val add_frac_num_simproc =
  13.134 +       make_simproc {lhss = [@{cpat "(?x::?'a::field)/?y + ?z"}, @{cpat "?z + (?x::?'a::field)/?y"}],
  13.135 +                     name = "add_frac_num_simproc",
  13.136 +                     proc = proc2, identifier = []}
  13.137 +
  13.138 +val ord_frac_simproc =
  13.139 +  make_simproc
  13.140 +    {lhss = [@{cpat "(?a::(?'a::{field, ord}))/?b < ?c"},
  13.141 +             @{cpat "(?a::(?'a::{field, ord}))/?b <= ?c"},
  13.142 +             @{cpat "?c < (?a::(?'a::{field, ord}))/?b"},
  13.143 +             @{cpat "?c <= (?a::(?'a::{field, ord}))/?b"},
  13.144 +             @{cpat "?c = ((?a::(?'a::{field, ord}))/?b)"},
  13.145 +             @{cpat "((?a::(?'a::{field, ord}))/ ?b) = ?c"}],
  13.146 +             name = "ord_frac_simproc", proc = proc3, identifier = []}
  13.147 +
  13.148 +val ths = [@{thm "mult_numeral_1"}, @{thm "mult_numeral_1_right"},
  13.149 +           @{thm "divide_Numeral1"},
  13.150 +           @{thm "divide_zero"}, @{thm "divide_Numeral0"},
  13.151 +           @{thm "divide_divide_eq_left"}, 
  13.152 +           @{thm "times_divide_eq_left"}, @{thm "times_divide_eq_right"},
  13.153 +           @{thm "times_divide_times_eq"},
  13.154 +           @{thm "divide_divide_eq_right"},
  13.155 +           @{thm "diff_def"}, @{thm "minus_divide_left"},
  13.156 +           @{thm "Numeral1_eq1_nat"}, @{thm "add_divide_distrib"} RS sym,
  13.157 +           @{thm field_divide_inverse} RS sym, @{thm inverse_divide}, 
  13.158 +           Conv.fconv_rule (Conv.arg_conv (Conv.arg1_conv (Conv.rewr_conv (mk_meta_eq @{thm mult_commute}))))   
  13.159 +           (@{thm field_divide_inverse} RS sym)]
  13.160 +
  13.161 +in
  13.162 +
  13.163 +val field_comp_conv = (Simplifier.rewrite
  13.164 +(HOL_basic_ss addsimps @{thms "semiring_norm"}
  13.165 +              addsimps ths addsimps @{thms simp_thms}
  13.166 +              addsimprocs field_cancel_numeral_factors
  13.167 +               addsimprocs [add_frac_frac_simproc, add_frac_num_simproc,
  13.168 +                            ord_frac_simproc]
  13.169 +                addcongs [@{thm "if_weak_cong"}]))
  13.170 +then_conv (Simplifier.rewrite (HOL_basic_ss addsimps
  13.171 +  [@{thm numeral_1_eq_1},@{thm numeral_0_eq_0}] @ @{thms numerals(1-2)}))
  13.172 +
  13.173 +end
  13.174 +
  13.175  end;
  13.176  
  13.177  Addsimprocs Numeral_Simprocs.cancel_numerals;
    14.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    14.2 +++ b/src/HOL/Tools/semiring_normalizer.ML	Sat May 08 17:15:50 2010 +0200
    14.3 @@ -0,0 +1,907 @@
    14.4 +(*  Title:      HOL/Tools/Groebner_Basis/normalizer.ML
    14.5 +    Author:     Amine Chaieb, TU Muenchen
    14.6 +
    14.7 +Normalization of expressions in semirings.
    14.8 +*)
    14.9 +
   14.10 +signature SEMIRING_NORMALIZER = 
   14.11 +sig
   14.12 +  type entry
   14.13 +  val get: Proof.context -> (thm * entry) list
   14.14 +  val match: Proof.context -> cterm -> entry option
   14.15 +  val del: attribute
   14.16 +  val add: {semiring: cterm list * thm list, ring: cterm list * thm list,
   14.17 +    field: cterm list * thm list, idom: thm list, ideal: thm list} -> attribute
   14.18 +  val funs: thm -> {is_const: morphism -> cterm -> bool,
   14.19 +    dest_const: morphism -> cterm -> Rat.rat,
   14.20 +    mk_const: morphism -> ctyp -> Rat.rat -> cterm,
   14.21 +    conv: morphism -> Proof.context -> cterm -> thm} -> declaration
   14.22 +  val semiring_funs: thm -> declaration
   14.23 +  val field_funs: thm -> declaration
   14.24 +
   14.25 +  val semiring_normalize_conv: Proof.context -> conv
   14.26 +  val semiring_normalize_ord_conv: Proof.context -> (cterm -> cterm -> bool) -> conv
   14.27 +  val semiring_normalize_wrapper: Proof.context -> entry -> conv
   14.28 +  val semiring_normalize_ord_wrapper: Proof.context -> entry
   14.29 +    -> (cterm -> cterm -> bool) -> conv
   14.30 +  val semiring_normalizers_conv: cterm list -> cterm list * thm list
   14.31 +    -> cterm list * thm list -> cterm list * thm list ->
   14.32 +      (cterm -> bool) * conv * conv * conv -> (cterm -> cterm -> bool) ->
   14.33 +        {add: conv, mul: conv, neg: conv, main: conv, pow: conv, sub: conv}
   14.34 +  val semiring_normalizers_ord_wrapper:  Proof.context -> entry ->
   14.35 +    (cterm -> cterm -> bool) ->
   14.36 +      {add: conv, mul: conv, neg: conv, main: conv, pow: conv, sub: conv}
   14.37 +
   14.38 +  val setup: theory -> theory
   14.39 +end
   14.40 +
   14.41 +structure Semiring_Normalizer: SEMIRING_NORMALIZER = 
   14.42 +struct
   14.43 +
   14.44 +(** data **)
   14.45 +
   14.46 +type entry =
   14.47 + {vars: cterm list,
   14.48 +  semiring: cterm list * thm list,
   14.49 +  ring: cterm list * thm list,
   14.50 +  field: cterm list * thm list,
   14.51 +  idom: thm list,
   14.52 +  ideal: thm list} *
   14.53 + {is_const: cterm -> bool,
   14.54 +  dest_const: cterm -> Rat.rat,
   14.55 +  mk_const: ctyp -> Rat.rat -> cterm,
   14.56 +  conv: Proof.context -> cterm -> thm};
   14.57 +
   14.58 +structure Data = Generic_Data
   14.59 +(
   14.60 +  type T = (thm * entry) list;
   14.61 +  val empty = [];
   14.62 +  val extend = I;
   14.63 +  val merge = AList.merge Thm.eq_thm (K true);
   14.64 +);
   14.65 +
   14.66 +val get = Data.get o Context.Proof;
   14.67 +
   14.68 +fun match ctxt tm =
   14.69 +  let
   14.70 +    fun match_inst
   14.71 +        ({vars, semiring = (sr_ops, sr_rules), 
   14.72 +          ring = (r_ops, r_rules), field = (f_ops, f_rules), idom, ideal},
   14.73 +         fns as {is_const, dest_const, mk_const, conv}) pat =
   14.74 +       let
   14.75 +        fun h instT =
   14.76 +          let
   14.77 +            val substT = Thm.instantiate (instT, []);
   14.78 +            val substT_cterm = Drule.cterm_rule substT;
   14.79 +
   14.80 +            val vars' = map substT_cterm vars;
   14.81 +            val semiring' = (map substT_cterm sr_ops, map substT sr_rules);
   14.82 +            val ring' = (map substT_cterm r_ops, map substT r_rules);
   14.83 +            val field' = (map substT_cterm f_ops, map substT f_rules);
   14.84 +            val idom' = map substT idom;
   14.85 +            val ideal' = map substT ideal;
   14.86 +
   14.87 +            val result = ({vars = vars', semiring = semiring', 
   14.88 +                           ring = ring', field = field', idom = idom', ideal = ideal'}, fns);
   14.89 +          in SOME result end
   14.90 +      in (case try Thm.match (pat, tm) of
   14.91 +           NONE => NONE
   14.92 +         | SOME (instT, _) => h instT)
   14.93 +      end;
   14.94 +
   14.95 +    fun match_struct (_,
   14.96 +        entry as ({semiring = (sr_ops, _), ring = (r_ops, _), field = (f_ops, _), ...}, _): entry) =
   14.97 +      get_first (match_inst entry) (sr_ops @ r_ops @ f_ops);
   14.98 +  in get_first match_struct (get ctxt) end;
   14.99 +
  14.100 +
  14.101 +(* logical content *)
  14.102 +
  14.103 +val semiringN = "semiring";
  14.104 +val ringN = "ring";
  14.105 +val idomN = "idom";
  14.106 +val idealN = "ideal";
  14.107 +val fieldN = "field";
  14.108 +
  14.109 +val del = Thm.declaration_attribute (Data.map o AList.delete Thm.eq_thm);
  14.110 +
  14.111 +fun add {semiring = (sr_ops, sr_rules), ring = (r_ops, r_rules), 
  14.112 +         field = (f_ops, f_rules), idom, ideal} =
  14.113 +  Thm.declaration_attribute (fn key => fn context => context |> Data.map
  14.114 +    let
  14.115 +      val ctxt = Context.proof_of context;
  14.116 +
  14.117 +      fun check kind name xs n =
  14.118 +        null xs orelse length xs = n orelse
  14.119 +        error ("Expected " ^ string_of_int n ^ " " ^ kind ^ " for " ^ name);
  14.120 +      val check_ops = check "operations";
  14.121 +      val check_rules = check "rules";
  14.122 +
  14.123 +      val _ =
  14.124 +        check_ops semiringN sr_ops 5 andalso
  14.125 +        check_rules semiringN sr_rules 37 andalso
  14.126 +        check_ops ringN r_ops 2 andalso
  14.127 +        check_rules ringN r_rules 2 andalso
  14.128 +        check_ops fieldN f_ops 2 andalso
  14.129 +        check_rules fieldN f_rules 2 andalso
  14.130 +        check_rules idomN idom 2;
  14.131 +
  14.132 +      val mk_meta = Local_Defs.meta_rewrite_rule ctxt;
  14.133 +      val sr_rules' = map mk_meta sr_rules;
  14.134 +      val r_rules' = map mk_meta r_rules;
  14.135 +      val f_rules' = map mk_meta f_rules;
  14.136 +
  14.137 +      fun rule i = nth sr_rules' (i - 1);
  14.138 +
  14.139 +      val (cx, cy) = Thm.dest_binop (hd sr_ops);
  14.140 +      val cz = rule 34 |> Thm.rhs_of |> Thm.dest_arg |> Thm.dest_arg;
  14.141 +      val cn = rule 36 |> Thm.rhs_of |> Thm.dest_arg |> Thm.dest_arg;
  14.142 +      val ((clx, crx), (cly, cry)) =
  14.143 +        rule 13 |> Thm.rhs_of |> Thm.dest_binop |> pairself Thm.dest_binop;
  14.144 +      val ((ca, cb), (cc, cd)) =
  14.145 +        rule 20 |> Thm.lhs_of |> Thm.dest_binop |> pairself Thm.dest_binop;
  14.146 +      val cm = rule 1 |> Thm.rhs_of |> Thm.dest_arg;
  14.147 +      val (cp, cq) = rule 26 |> Thm.lhs_of |> Thm.dest_binop |> pairself Thm.dest_arg;
  14.148 +
  14.149 +      val vars = [ca, cb, cc, cd, cm, cn, cp, cq, cx, cy, cz, clx, crx, cly, cry];
  14.150 +      val semiring = (sr_ops, sr_rules');
  14.151 +      val ring = (r_ops, r_rules');
  14.152 +      val field = (f_ops, f_rules');
  14.153 +      val ideal' = map (symmetric o mk_meta) ideal
  14.154 +    in
  14.155 +      AList.delete Thm.eq_thm key #>
  14.156 +      cons (key, ({vars = vars, semiring = semiring, 
  14.157 +                          ring = ring, field = field, idom = idom, ideal = ideal'},
  14.158 +             {is_const = undefined, dest_const = undefined, mk_const = undefined,
  14.159 +             conv = undefined}))
  14.160 +    end);
  14.161 +
  14.162 +
  14.163 +(* extra-logical functions *)
  14.164 +
  14.165 +fun funs raw_key {is_const, dest_const, mk_const, conv} phi = 
  14.166 + Data.map (fn data =>
  14.167 +  let
  14.168 +    val key = Morphism.thm phi raw_key;
  14.169 +    val _ = AList.defined Thm.eq_thm data key orelse
  14.170 +      raise THM ("No data entry for structure key", 0, [key]);
  14.171 +    val fns = {is_const = is_const phi, dest_const = dest_const phi,
  14.172 +      mk_const = mk_const phi, conv = conv phi};
  14.173 +  in AList.map_entry Thm.eq_thm key (apsnd (K fns)) data end);
  14.174 +
  14.175 +fun semiring_funs key = funs key
  14.176 +   {is_const = fn phi => can HOLogic.dest_number o Thm.term_of,
  14.177 +    dest_const = fn phi => fn ct =>
  14.178 +      Rat.rat_of_int (snd
  14.179 +        (HOLogic.dest_number (Thm.term_of ct)
  14.180 +          handle TERM _ => error "ring_dest_const")),
  14.181 +    mk_const = fn phi => fn cT => fn x => Numeral.mk_cnumber cT
  14.182 +      (case Rat.quotient_of_rat x of (i, 1) => i | _ => error "int_of_rat: bad int"),
  14.183 +    conv = fn phi => fn _ => Simplifier.rewrite (HOL_basic_ss addsimps @{thms semiring_norm})
  14.184 +      then_conv Simplifier.rewrite (HOL_basic_ss addsimps
  14.185 +        (@{thms numeral_1_eq_1} @ @{thms numeral_0_eq_0} @ @{thms numerals(1-2)}))};
  14.186 +
  14.187 +fun field_funs key =
  14.188 +  let
  14.189 +    fun numeral_is_const ct =
  14.190 +      case term_of ct of
  14.191 +       Const (@{const_name Rings.divide},_) $ a $ b =>
  14.192 +         can HOLogic.dest_number a andalso can HOLogic.dest_number b
  14.193 +     | Const (@{const_name Rings.inverse},_)$t => can HOLogic.dest_number t
  14.194 +     | t => can HOLogic.dest_number t
  14.195 +    fun dest_const ct = ((case term_of ct of
  14.196 +       Const (@{const_name Rings.divide},_) $ a $ b=>
  14.197 +        Rat.rat_of_quotient (snd (HOLogic.dest_number a), snd (HOLogic.dest_number b))
  14.198 +     | Const (@{const_name Rings.inverse},_)$t => 
  14.199 +                   Rat.inv (Rat.rat_of_int (snd (HOLogic.dest_number t)))
  14.200 +     | t => Rat.rat_of_int (snd (HOLogic.dest_number t))) 
  14.201 +       handle TERM _ => error "ring_dest_const")
  14.202 +    fun mk_const phi cT x =
  14.203 +      let val (a, b) = Rat.quotient_of_rat x
  14.204 +      in if b = 1 then Numeral.mk_cnumber cT a
  14.205 +        else Thm.capply
  14.206 +             (Thm.capply (Drule.cterm_rule (instantiate' [SOME cT] []) @{cpat "op /"})
  14.207 +                         (Numeral.mk_cnumber cT a))
  14.208 +             (Numeral.mk_cnumber cT b)
  14.209 +      end
  14.210 +  in funs key
  14.211 +     {is_const = K numeral_is_const,
  14.212 +      dest_const = K dest_const,
  14.213 +      mk_const = mk_const,
  14.214 +      conv = K (K Numeral_Simprocs.field_comp_conv)}
  14.215 +  end;
  14.216 +
  14.217 +
  14.218 +
  14.219 +(** auxiliary **)
  14.220 +
  14.221 +fun is_comb ct =
  14.222 +  (case Thm.term_of ct of
  14.223 +    _ $ _ => true
  14.224 +  | _ => false);
  14.225 +
  14.226 +val concl = Thm.cprop_of #> Thm.dest_arg;
  14.227 +
  14.228 +fun is_binop ct ct' =
  14.229 +  (case Thm.term_of ct' of
  14.230 +    c $ _ $ _ => term_of ct aconv c
  14.231 +  | _ => false);
  14.232 +
  14.233 +fun dest_binop ct ct' =
  14.234 +  if is_binop ct ct' then Thm.dest_binop ct'
  14.235 +  else raise CTERM ("dest_binop: bad binop", [ct, ct'])
  14.236 +
  14.237 +fun inst_thm inst = Thm.instantiate ([], inst);
  14.238 +
  14.239 +val dest_numeral = term_of #> HOLogic.dest_number #> snd;
  14.240 +val is_numeral = can dest_numeral;
  14.241 +
  14.242 +val numeral01_conv = Simplifier.rewrite
  14.243 +                         (HOL_basic_ss addsimps [@{thm numeral_1_eq_1}, @{thm numeral_0_eq_0}]);
  14.244 +val zero1_numeral_conv = 
  14.245 + Simplifier.rewrite (HOL_basic_ss addsimps [@{thm numeral_1_eq_1} RS sym, @{thm numeral_0_eq_0} RS sym]);
  14.246 +fun zerone_conv cv = zero1_numeral_conv then_conv cv then_conv numeral01_conv;
  14.247 +val natarith = [@{thm "add_nat_number_of"}, @{thm "diff_nat_number_of"},
  14.248 +                @{thm "mult_nat_number_of"}, @{thm "eq_nat_number_of"}, 
  14.249 +                @{thm "less_nat_number_of"}];
  14.250 +
  14.251 +val nat_add_conv = 
  14.252 + zerone_conv 
  14.253 +  (Simplifier.rewrite 
  14.254 +    (HOL_basic_ss 
  14.255 +       addsimps @{thms arith_simps} @ natarith @ @{thms rel_simps}
  14.256 +             @ [@{thm if_False}, @{thm if_True}, @{thm Nat.add_0}, @{thm add_Suc},
  14.257 +                 @{thm add_number_of_left}, @{thm Suc_eq_plus1}]
  14.258 +             @ map (fn th => th RS sym) @{thms numerals}));
  14.259 +
  14.260 +val zeron_tm = @{cterm "0::nat"};
  14.261 +val onen_tm  = @{cterm "1::nat"};
  14.262 +val true_tm = @{cterm "True"};
  14.263 +
  14.264 +
  14.265 +(** normalizing conversions **)
  14.266 +
  14.267 +(* core conversion *)
  14.268 +
  14.269 +fun semiring_normalizers_conv vars (sr_ops, sr_rules) (r_ops, r_rules) (f_ops, f_rules)
  14.270 +  (is_semiring_constant, semiring_add_conv, semiring_mul_conv, semiring_pow_conv) =
  14.271 +let
  14.272 +
  14.273 +val [pthm_02, pthm_03, pthm_04, pthm_05, pthm_07, pthm_08,
  14.274 +     pthm_09, pthm_10, pthm_11, pthm_12, pthm_13, pthm_14, pthm_15, pthm_16,
  14.275 +     pthm_17, pthm_18, pthm_19, pthm_21, pthm_22, pthm_23, pthm_24,
  14.276 +     pthm_25, pthm_26, pthm_27, pthm_28, pthm_29, pthm_30, pthm_31, pthm_32,
  14.277 +     pthm_33, pthm_34, pthm_35, pthm_36, pthm_37, pthm_38,pthm_39,pthm_40] = sr_rules;
  14.278 +
  14.279 +val [ca, cb, cc, cd, cm, cn, cp, cq, cx, cy, cz, clx, crx, cly, cry] = vars;
  14.280 +val [add_pat, mul_pat, pow_pat, zero_tm, one_tm] = sr_ops;
  14.281 +val [add_tm, mul_tm, pow_tm] = map (Thm.dest_fun o Thm.dest_fun) [add_pat, mul_pat, pow_pat];
  14.282 +
  14.283 +val dest_add = dest_binop add_tm
  14.284 +val dest_mul = dest_binop mul_tm
  14.285 +fun dest_pow tm =
  14.286 + let val (l,r) = dest_binop pow_tm tm
  14.287 + in if is_numeral r then (l,r) else raise CTERM ("dest_pow",[tm])
  14.288 + end;
  14.289 +val is_add = is_binop add_tm
  14.290 +val is_mul = is_binop mul_tm
  14.291 +fun is_pow tm = is_binop pow_tm tm andalso is_numeral(Thm.dest_arg tm);
  14.292 +
  14.293 +val (neg_mul,sub_add,sub_tm,neg_tm,dest_sub,is_sub,cx',cy') =
  14.294 +  (case (r_ops, r_rules) of
  14.295 +    ([sub_pat, neg_pat], [neg_mul, sub_add]) =>
  14.296 +      let
  14.297 +        val sub_tm = Thm.dest_fun (Thm.dest_fun sub_pat)
  14.298 +        val neg_tm = Thm.dest_fun neg_pat
  14.299 +        val dest_sub = dest_binop sub_tm
  14.300 +        val is_sub = is_binop sub_tm
  14.301 +      in (neg_mul,sub_add,sub_tm,neg_tm,dest_sub,is_sub, neg_mul |> concl |> Thm.dest_arg,
  14.302 +          sub_add |> concl |> Thm.dest_arg |> Thm.dest_arg)
  14.303 +      end
  14.304 +    | _ => (TrueI, TrueI, true_tm, true_tm, (fn t => (t,t)), K false, true_tm, true_tm));
  14.305 +
  14.306 +val (divide_inverse, inverse_divide, divide_tm, inverse_tm, is_divide) = 
  14.307 +  (case (f_ops, f_rules) of 
  14.308 +   ([divide_pat, inverse_pat], [div_inv, inv_div]) => 
  14.309 +     let val div_tm = funpow 2 Thm.dest_fun divide_pat
  14.310 +         val inv_tm = Thm.dest_fun inverse_pat
  14.311 +     in (div_inv, inv_div, div_tm, inv_tm, is_binop div_tm)
  14.312 +     end
  14.313 +   | _ => (TrueI, TrueI, true_tm, true_tm, K false));
  14.314 +
  14.315 +in fn variable_order =>
  14.316 + let
  14.317 +
  14.318 +(* Conversion for "x^n * x^m", with either x^n = x and/or x^m = x possible.  *)
  14.319 +(* Also deals with "const * const", but both terms must involve powers of    *)
  14.320 +(* the same variable, or both be constants, or behaviour may be incorrect.   *)
  14.321 +
  14.322 + fun powvar_mul_conv tm =
  14.323 +  let
  14.324 +  val (l,r) = dest_mul tm
  14.325 +  in if is_semiring_constant l andalso is_semiring_constant r
  14.326 +     then semiring_mul_conv tm
  14.327 +     else
  14.328 +      ((let
  14.329 +         val (lx,ln) = dest_pow l
  14.330 +        in
  14.331 +         ((let val (rx,rn) = dest_pow r
  14.332 +               val th1 = inst_thm [(cx,lx),(cp,ln),(cq,rn)] pthm_29
  14.333 +                val (tm1,tm2) = Thm.dest_comb(concl th1) in
  14.334 +               transitive th1 (Drule.arg_cong_rule tm1 (nat_add_conv tm2)) end)
  14.335 +           handle CTERM _ =>
  14.336 +            (let val th1 = inst_thm [(cx,lx),(cq,ln)] pthm_31
  14.337 +                 val (tm1,tm2) = Thm.dest_comb(concl th1) in
  14.338 +               transitive th1 (Drule.arg_cong_rule tm1 (nat_add_conv tm2)) end)) end)
  14.339 +       handle CTERM _ =>
  14.340 +           ((let val (rx,rn) = dest_pow r
  14.341 +                val th1 = inst_thm [(cx,rx),(cq,rn)] pthm_30
  14.342 +                val (tm1,tm2) = Thm.dest_comb(concl th1) in
  14.343 +               transitive th1 (Drule.arg_cong_rule tm1 (nat_add_conv tm2)) end)
  14.344 +           handle CTERM _ => inst_thm [(cx,l)] pthm_32
  14.345 +
  14.346 +))
  14.347 + end;
  14.348 +
  14.349 +(* Remove "1 * m" from a monomial, and just leave m.                         *)
  14.350 +
  14.351 + fun monomial_deone th =
  14.352 +       (let val (l,r) = dest_mul(concl th) in
  14.353 +           if l aconvc one_tm
  14.354 +          then transitive th (inst_thm [(ca,r)] pthm_13)  else th end)
  14.355 +       handle CTERM _ => th;
  14.356 +
  14.357 +(* Conversion for "(monomial)^n", where n is a numeral.                      *)
  14.358 +
  14.359 + val monomial_pow_conv =
  14.360 +  let
  14.361 +   fun monomial_pow tm bod ntm =
  14.362 +    if not(is_comb bod)
  14.363 +    then reflexive tm
  14.364 +    else
  14.365 +     if is_semiring_constant bod
  14.366 +     then semiring_pow_conv tm
  14.367 +     else
  14.368 +      let
  14.369 +      val (lopr,r) = Thm.dest_comb bod
  14.370 +      in if not(is_comb lopr)
  14.371 +         then reflexive tm
  14.372 +        else
  14.373 +          let
  14.374 +          val (opr,l) = Thm.dest_comb lopr
  14.375 +         in
  14.376 +           if opr aconvc pow_tm andalso is_numeral r
  14.377 +          then
  14.378 +            let val th1 = inst_thm [(cx,l),(cp,r),(cq,ntm)] pthm_34
  14.379 +                val (l,r) = Thm.dest_comb(concl th1)
  14.380 +           in transitive th1 (Drule.arg_cong_rule l (nat_add_conv r))
  14.381 +           end
  14.382 +           else
  14.383 +            if opr aconvc mul_tm
  14.384 +            then
  14.385 +             let
  14.386 +              val th1 = inst_thm [(cx,l),(cy,r),(cq,ntm)] pthm_33
  14.387 +             val (xy,z) = Thm.dest_comb(concl th1)
  14.388 +              val (x,y) = Thm.dest_comb xy
  14.389 +              val thl = monomial_pow y l ntm
  14.390 +              val thr = monomial_pow z r ntm
  14.391 +             in transitive th1 (combination (Drule.arg_cong_rule x thl) thr)
  14.392 +             end
  14.393 +             else reflexive tm
  14.394 +          end
  14.395 +      end
  14.396 +  in fn tm =>
  14.397 +   let
  14.398 +    val (lopr,r) = Thm.dest_comb tm
  14.399 +    val (opr,l) = Thm.dest_comb lopr
  14.400 +   in if not (opr aconvc pow_tm) orelse not(is_numeral r)
  14.401 +      then raise CTERM ("monomial_pow_conv", [tm])
  14.402 +      else if r aconvc zeron_tm
  14.403 +      then inst_thm [(cx,l)] pthm_35
  14.404 +      else if r aconvc onen_tm
  14.405 +      then inst_thm [(cx,l)] pthm_36
  14.406 +      else monomial_deone(monomial_pow tm l r)
  14.407 +   end
  14.408 +  end;
  14.409 +
  14.410 +(* Multiplication of canonical monomials.                                    *)
  14.411 + val monomial_mul_conv =
  14.412 +  let
  14.413 +   fun powvar tm =
  14.414 +    if is_semiring_constant tm then one_tm
  14.415 +    else
  14.416 +     ((let val (lopr,r) = Thm.dest_comb tm
  14.417 +           val (opr,l) = Thm.dest_comb lopr
  14.418 +       in if opr aconvc pow_tm andalso is_numeral r then l 
  14.419 +          else raise CTERM ("monomial_mul_conv",[tm]) end)
  14.420 +     handle CTERM _ => tm)   (* FIXME !? *)
  14.421 +   fun  vorder x y =
  14.422 +    if x aconvc y then 0
  14.423 +    else
  14.424 +     if x aconvc one_tm then ~1
  14.425 +     else if y aconvc one_tm then 1
  14.426 +      else if variable_order x y then ~1 else 1
  14.427 +   fun monomial_mul tm l r =
  14.428 +    ((let val (lx,ly) = dest_mul l val vl = powvar lx
  14.429 +      in
  14.430 +      ((let
  14.431 +        val (rx,ry) = dest_mul r
  14.432 +         val vr = powvar rx
  14.433 +         val ord = vorder vl vr
  14.434 +        in
  14.435 +         if ord = 0
  14.436 +        then
  14.437 +          let
  14.438 +             val th1 = inst_thm [(clx,lx),(cly,ly),(crx,rx),(cry,ry)] pthm_15
  14.439 +             val (tm1,tm2) = Thm.dest_comb(concl th1)
  14.440 +             val (tm3,tm4) = Thm.dest_comb tm1
  14.441 +             val th2 = Drule.fun_cong_rule (Drule.arg_cong_rule tm3 (powvar_mul_conv tm4)) tm2
  14.442 +             val th3 = transitive th1 th2
  14.443 +              val  (tm5,tm6) = Thm.dest_comb(concl th3)
  14.444 +              val  (tm7,tm8) = Thm.dest_comb tm6
  14.445 +             val  th4 = monomial_mul tm6 (Thm.dest_arg tm7) tm8
  14.446 +         in  transitive th3 (Drule.arg_cong_rule tm5 th4)
  14.447 +         end
  14.448 +         else
  14.449 +          let val th0 = if ord < 0 then pthm_16 else pthm_17
  14.450 +             val th1 = inst_thm [(clx,lx),(cly,ly),(crx,rx),(cry,ry)] th0
  14.451 +             val (tm1,tm2) = Thm.dest_comb(concl th1)
  14.452 +             val (tm3,tm4) = Thm.dest_comb tm2
  14.453 +         in transitive th1 (Drule.arg_cong_rule tm1 (monomial_mul tm2 (Thm.dest_arg tm3) tm4))
  14.454 +         end
  14.455 +        end)
  14.456 +       handle CTERM _ =>
  14.457 +        (let val vr = powvar r val ord = vorder vl vr
  14.458 +        in
  14.459 +          if ord = 0 then
  14.460 +           let
  14.461 +           val th1 = inst_thm [(clx,lx),(cly,ly),(crx,r)] pthm_18
  14.462 +                 val (tm1,tm2) = Thm.dest_comb(concl th1)
  14.463 +           val (tm3,tm4) = Thm.dest_comb tm1
  14.464 +           val th2 = Drule.fun_cong_rule (Drule.arg_cong_rule tm3 (powvar_mul_conv tm4)) tm2
  14.465 +          in transitive th1 th2
  14.466 +          end
  14.467 +          else
  14.468 +          if ord < 0 then
  14.469 +            let val th1 = inst_thm [(clx,lx),(cly,ly),(crx,r)] pthm_19
  14.470 +                val (tm1,tm2) = Thm.dest_comb(concl th1)
  14.471 +                val (tm3,tm4) = Thm.dest_comb tm2
  14.472 +           in transitive th1 (Drule.arg_cong_rule tm1 (monomial_mul tm2 (Thm.dest_arg tm3) tm4))
  14.473 +           end
  14.474 +           else inst_thm [(ca,l),(cb,r)] pthm_09
  14.475 +        end)) end)
  14.476 +     handle CTERM _ =>
  14.477 +      (let val vl = powvar l in
  14.478 +        ((let
  14.479 +          val (rx,ry) = dest_mul r
  14.480 +          val vr = powvar rx
  14.481 +           val ord = vorder vl vr
  14.482 +         in if ord = 0 then
  14.483 +              let val th1 = inst_thm [(clx,l),(crx,rx),(cry,ry)] pthm_21
  14.484 +                 val (tm1,tm2) = Thm.dest_comb(concl th1)
  14.485 +                 val (tm3,tm4) = Thm.dest_comb tm1
  14.486 +             in transitive th1 (Drule.fun_cong_rule (Drule.arg_cong_rule tm3 (powvar_mul_conv tm4)) tm2)
  14.487 +             end
  14.488 +             else if ord > 0 then
  14.489 +                 let val th1 = inst_thm [(clx,l),(crx,rx),(cry,ry)] pthm_22
  14.490 +                     val (tm1,tm2) = Thm.dest_comb(concl th1)
  14.491 +                    val (tm3,tm4) = Thm.dest_comb tm2
  14.492 +                in transitive th1 (Drule.arg_cong_rule tm1 (monomial_mul tm2 (Thm.dest_arg tm3) tm4))
  14.493 +                end
  14.494 +             else reflexive tm
  14.495 +         end)
  14.496 +        handle CTERM _ =>
  14.497 +          (let val vr = powvar r
  14.498 +               val  ord = vorder vl vr
  14.499 +          in if ord = 0 then powvar_mul_conv tm
  14.500 +              else if ord > 0 then inst_thm [(ca,l),(cb,r)] pthm_09
  14.501 +              else reflexive tm
  14.502 +          end)) end))
  14.503 +  in fn tm => let val (l,r) = dest_mul tm in monomial_deone(monomial_mul tm l r)
  14.504 +             end
  14.505 +  end;
  14.506 +(* Multiplication by monomial of a polynomial.                               *)
  14.507 +
  14.508 + val polynomial_monomial_mul_conv =
  14.509 +  let
  14.510 +   fun pmm_conv tm =
  14.511 +    let val (l,r) = dest_mul tm
  14.512 +    in
  14.513 +    ((let val (y,z) = dest_add r
  14.514 +          val th1 = inst_thm [(cx,l),(cy,y),(cz,z)] pthm_37
  14.515 +          val (tm1,tm2) = Thm.dest_comb(concl th1)
  14.516 +          val (tm3,tm4) = Thm.dest_comb tm1
  14.517 +          val th2 = combination (Drule.arg_cong_rule tm3 (monomial_mul_conv tm4)) (pmm_conv tm2)
  14.518 +      in transitive th1 th2
  14.519 +      end)
  14.520 +     handle CTERM _ => monomial_mul_conv tm)
  14.521 +   end
  14.522 + in pmm_conv
  14.523 + end;
  14.524 +
  14.525 +(* Addition of two monomials identical except for constant multiples.        *)
  14.526 +
  14.527 +fun monomial_add_conv tm =
  14.528 + let val (l,r) = dest_add tm
  14.529 + in if is_semiring_constant l andalso is_semiring_constant r
  14.530 +    then semiring_add_conv tm
  14.531 +    else
  14.532 +     let val th1 =
  14.533 +           if is_mul l andalso is_semiring_constant(Thm.dest_arg1 l)
  14.534 +           then if is_mul r andalso is_semiring_constant(Thm.dest_arg1 r) then
  14.535 +                    inst_thm [(ca,Thm.dest_arg1 l),(cm,Thm.dest_arg r), (cb,Thm.dest_arg1 r)] pthm_02
  14.536 +                else inst_thm [(ca,Thm.dest_arg1 l),(cm,r)] pthm_03
  14.537 +           else if is_mul r andalso is_semiring_constant(Thm.dest_arg1 r)
  14.538 +           then inst_thm [(cm,l),(ca,Thm.dest_arg1 r)] pthm_04
  14.539 +           else inst_thm [(cm,r)] pthm_05
  14.540 +         val (tm1,tm2) = Thm.dest_comb(concl th1)
  14.541 +         val (tm3,tm4) = Thm.dest_comb tm1
  14.542 +         val th2 = Drule.arg_cong_rule tm3 (semiring_add_conv tm4)
  14.543 +         val th3 = transitive th1 (Drule.fun_cong_rule th2 tm2)
  14.544 +         val tm5 = concl th3
  14.545 +      in
  14.546 +      if (Thm.dest_arg1 tm5) aconvc zero_tm
  14.547 +      then transitive th3 (inst_thm [(ca,Thm.dest_arg tm5)] pthm_11)
  14.548 +      else monomial_deone th3
  14.549 +     end
  14.550 + end;
  14.551 +
  14.552 +(* Ordering on monomials.                                                    *)
  14.553 +
  14.554 +fun striplist dest =
  14.555 + let fun strip x acc =
  14.556 +   ((let val (l,r) = dest x in
  14.557 +        strip l (strip r acc) end)
  14.558 +    handle CTERM _ => x::acc)    (* FIXME !? *)
  14.559 + in fn x => strip x []
  14.560 + end;
  14.561 +
  14.562 +
  14.563 +fun powervars tm =
  14.564 + let val ptms = striplist dest_mul tm
  14.565 + in if is_semiring_constant (hd ptms) then tl ptms else ptms
  14.566 + end;
  14.567 +val num_0 = 0;
  14.568 +val num_1 = 1;
  14.569 +fun dest_varpow tm =
  14.570 + ((let val (x,n) = dest_pow tm in (x,dest_numeral n) end)
  14.571 +   handle CTERM _ =>
  14.572 +   (tm,(if is_semiring_constant tm then num_0 else num_1)));
  14.573 +
  14.574 +val morder =
  14.575 + let fun lexorder l1 l2 =
  14.576 +  case (l1,l2) of
  14.577 +    ([],[]) => 0
  14.578 +  | (vps,[]) => ~1
  14.579 +  | ([],vps) => 1
  14.580 +  | (((x1,n1)::vs1),((x2,n2)::vs2)) =>
  14.581 +     if variable_order x1 x2 then 1
  14.582 +     else if variable_order x2 x1 then ~1
  14.583 +     else if n1 < n2 then ~1
  14.584 +     else if n2 < n1 then 1
  14.585 +     else lexorder vs1 vs2
  14.586 + in fn tm1 => fn tm2 =>
  14.587 +  let val vdegs1 = map dest_varpow (powervars tm1)
  14.588 +      val vdegs2 = map dest_varpow (powervars tm2)
  14.589 +      val deg1 = fold (Integer.add o snd) vdegs1 num_0
  14.590 +      val deg2 = fold (Integer.add o snd) vdegs2 num_0
  14.591 +  in if deg1 < deg2 then ~1 else if deg1 > deg2 then 1
  14.592 +                            else lexorder vdegs1 vdegs2
  14.593 +  end
  14.594 + end;
  14.595 +
  14.596 +(* Addition of two polynomials.                                              *)
  14.597 +
  14.598 +val polynomial_add_conv =
  14.599 + let
  14.600 + fun dezero_rule th =
  14.601 +  let
  14.602 +   val tm = concl th
  14.603 +  in
  14.604 +   if not(is_add tm) then th else
  14.605 +   let val (lopr,r) = Thm.dest_comb tm
  14.606 +       val l = Thm.dest_arg lopr
  14.607 +   in
  14.608 +    if l aconvc zero_tm
  14.609 +    then transitive th (inst_thm [(ca,r)] pthm_07)   else
  14.610 +        if r aconvc zero_tm
  14.611 +        then transitive th (inst_thm [(ca,l)] pthm_08)  else th
  14.612 +   end
  14.613 +  end
  14.614 + fun padd tm =
  14.615 +  let
  14.616 +   val (l,r) = dest_add tm
  14.617 +  in
  14.618 +   if l aconvc zero_tm then inst_thm [(ca,r)] pthm_07
  14.619 +   else if r aconvc zero_tm then inst_thm [(ca,l)] pthm_08
  14.620 +   else
  14.621 +    if is_add l
  14.622 +    then
  14.623 +     let val (a,b) = dest_add l
  14.624 +     in
  14.625 +     if is_add r then
  14.626 +      let val (c,d) = dest_add r
  14.627 +          val ord = morder a c
  14.628 +      in
  14.629 +       if ord = 0 then
  14.630 +        let val th1 = inst_thm [(ca,a),(cb,b),(cc,c),(cd,d)] pthm_23
  14.631 +            val (tm1,tm2) = Thm.dest_comb(concl th1)
  14.632 +            val (tm3,tm4) = Thm.dest_comb tm1
  14.633 +            val th2 = Drule.arg_cong_rule tm3 (monomial_add_conv tm4)
  14.634 +        in dezero_rule (transitive th1 (combination th2 (padd tm2)))
  14.635 +        end
  14.636 +       else (* ord <> 0*)
  14.637 +        let val th1 =
  14.638 +                if ord > 0 then inst_thm [(ca,a),(cb,b),(cc,r)] pthm_24
  14.639 +                else inst_thm [(ca,l),(cc,c),(cd,d)] pthm_25
  14.640 +            val (tm1,tm2) = Thm.dest_comb(concl th1)
  14.641 +        in dezero_rule (transitive th1 (Drule.arg_cong_rule tm1 (padd tm2)))
  14.642 +        end
  14.643 +      end
  14.644 +     else (* not (is_add r)*)
  14.645 +      let val ord = morder a r
  14.646 +      in
  14.647 +       if ord = 0 then
  14.648 +        let val th1 = inst_thm [(ca,a),(cb,b),(cc,r)] pthm_26
  14.649 +            val (tm1,tm2) = Thm.dest_comb(concl th1)
  14.650 +            val (tm3,tm4) = Thm.dest_comb tm1
  14.651 +            val th2 = Drule.fun_cong_rule (Drule.arg_cong_rule tm3 (monomial_add_conv tm4)) tm2
  14.652 +        in dezero_rule (transitive th1 th2)
  14.653 +        end
  14.654 +       else (* ord <> 0*)
  14.655 +        if ord > 0 then
  14.656 +          let val th1 = inst_thm [(ca,a),(cb,b),(cc,r)] pthm_24
  14.657 +              val (tm1,tm2) = Thm.dest_comb(concl th1)
  14.658 +          in dezero_rule (transitive th1 (Drule.arg_cong_rule tm1 (padd tm2)))
  14.659 +          end
  14.660 +        else dezero_rule (inst_thm [(ca,l),(cc,r)] pthm_27)
  14.661 +      end
  14.662 +    end
  14.663 +   else (* not (is_add l)*)
  14.664 +    if is_add r then
  14.665 +      let val (c,d) = dest_add r
  14.666 +          val  ord = morder l c
  14.667 +      in
  14.668 +       if ord = 0 then
  14.669 +         let val th1 = inst_thm [(ca,l),(cc,c),(cd,d)] pthm_28
  14.670 +             val (tm1,tm2) = Thm.dest_comb(concl th1)
  14.671 +             val (tm3,tm4) = Thm.dest_comb tm1
  14.672 +             val th2 = Drule.fun_cong_rule (Drule.arg_cong_rule tm3 (monomial_add_conv tm4)) tm2
  14.673 +         in dezero_rule (transitive th1 th2)
  14.674 +         end
  14.675 +       else
  14.676 +        if ord > 0 then reflexive tm
  14.677 +        else
  14.678 +         let val th1 = inst_thm [(ca,l),(cc,c),(cd,d)] pthm_25
  14.679 +             val (tm1,tm2) = Thm.dest_comb(concl th1)
  14.680 +         in dezero_rule (transitive th1 (Drule.arg_cong_rule tm1 (padd tm2)))
  14.681 +         end
  14.682 +      end
  14.683 +    else
  14.684 +     let val ord = morder l r
  14.685 +     in
  14.686 +      if ord = 0 then monomial_add_conv tm
  14.687 +      else if ord > 0 then dezero_rule(reflexive tm)
  14.688 +      else dezero_rule (inst_thm [(ca,l),(cc,r)] pthm_27)
  14.689 +     end
  14.690 +  end
  14.691 + in padd
  14.692 + end;
  14.693 +
  14.694 +(* Multiplication of two polynomials.                                        *)
  14.695 +
  14.696 +val polynomial_mul_conv =
  14.697 + let
  14.698 +  fun pmul tm =
  14.699 +   let val (l,r) = dest_mul tm
  14.700 +   in
  14.701 +    if not(is_add l) then polynomial_monomial_mul_conv tm
  14.702 +    else
  14.703 +     if not(is_add r) then
  14.704 +      let val th1 = inst_thm [(ca,l),(cb,r)] pthm_09
  14.705 +      in transitive th1 (polynomial_monomial_mul_conv(concl th1))
  14.706 +      end
  14.707 +     else
  14.708 +       let val (a,b) = dest_add l
  14.709 +           val th1 = inst_thm [(ca,a),(cb,b),(cc,r)] pthm_10
  14.710 +           val (tm1,tm2) = Thm.dest_comb(concl th1)
  14.711 +           val (tm3,tm4) = Thm.dest_comb tm1
  14.712 +           val th2 = Drule.arg_cong_rule tm3 (polynomial_monomial_mul_conv tm4)
  14.713 +           val th3 = transitive th1 (combination th2 (pmul tm2))
  14.714 +       in transitive th3 (polynomial_add_conv (concl th3))
  14.715 +       end
  14.716 +   end
  14.717 + in fn tm =>
  14.718 +   let val (l,r) = dest_mul tm
  14.719 +   in
  14.720 +    if l aconvc zero_tm then inst_thm [(ca,r)] pthm_11
  14.721 +    else if r aconvc zero_tm then inst_thm [(ca,l)] pthm_12
  14.722 +    else if l aconvc one_tm then inst_thm [(ca,r)] pthm_13
  14.723 +    else if r aconvc one_tm then inst_thm [(ca,l)] pthm_14
  14.724 +    else pmul tm
  14.725 +   end
  14.726 + end;
  14.727 +
  14.728 +(* Power of polynomial (optimized for the monomial and trivial cases).       *)
  14.729 +
  14.730 +fun num_conv n =
  14.731 +  nat_add_conv (Thm.capply @{cterm Suc} (Numeral.mk_cnumber @{ctyp nat} (dest_numeral n - 1)))
  14.732 +  |> Thm.symmetric;
  14.733 +
  14.734 +
  14.735 +val polynomial_pow_conv =
  14.736 + let
  14.737 +  fun ppow tm =
  14.738 +    let val (l,n) = dest_pow tm
  14.739 +    in
  14.740 +     if n aconvc zeron_tm then inst_thm [(cx,l)] pthm_35
  14.741 +     else if n aconvc onen_tm then inst_thm [(cx,l)] pthm_36
  14.742 +     else
  14.743 +         let val th1 = num_conv n
  14.744 +             val th2 = inst_thm [(cx,l),(cq,Thm.dest_arg (concl th1))] pthm_38
  14.745 +             val (tm1,tm2) = Thm.dest_comb(concl th2)
  14.746 +             val th3 = transitive th2 (Drule.arg_cong_rule tm1 (ppow tm2))
  14.747 +             val th4 = transitive (Drule.arg_cong_rule (Thm.dest_fun tm) th1) th3
  14.748 +         in transitive th4 (polynomial_mul_conv (concl th4))
  14.749 +         end
  14.750 +    end
  14.751 + in fn tm =>
  14.752 +       if is_add(Thm.dest_arg1 tm) then ppow tm else monomial_pow_conv tm
  14.753 + end;
  14.754 +
  14.755 +(* Negation.                                                                 *)
  14.756 +
  14.757 +fun polynomial_neg_conv tm =
  14.758 +   let val (l,r) = Thm.dest_comb tm in
  14.759 +        if not (l aconvc neg_tm) then raise CTERM ("polynomial_neg_conv",[tm]) else
  14.760 +        let val th1 = inst_thm [(cx',r)] neg_mul
  14.761 +            val th2 = transitive th1 (Conv.arg1_conv semiring_mul_conv (concl th1))
  14.762 +        in transitive th2 (polynomial_monomial_mul_conv (concl th2))
  14.763 +        end
  14.764 +   end;
  14.765 +
  14.766 +
  14.767 +(* Subtraction.                                                              *)
  14.768 +fun polynomial_sub_conv tm =
  14.769 +  let val (l,r) = dest_sub tm
  14.770 +      val th1 = inst_thm [(cx',l),(cy',r)] sub_add
  14.771 +      val (tm1,tm2) = Thm.dest_comb(concl th1)
  14.772 +      val th2 = Drule.arg_cong_rule tm1 (polynomial_neg_conv tm2)
  14.773 +  in transitive th1 (transitive th2 (polynomial_add_conv (concl th2)))
  14.774 +  end;
  14.775 +
  14.776 +(* Conversion from HOL term.                                                 *)
  14.777 +
  14.778 +fun polynomial_conv tm =
  14.779 + if is_semiring_constant tm then semiring_add_conv tm
  14.780 + else if not(is_comb tm) then reflexive tm
  14.781 + else
  14.782 +  let val (lopr,r) = Thm.dest_comb tm
  14.783 +  in if lopr aconvc neg_tm then
  14.784 +       let val th1 = Drule.arg_cong_rule lopr (polynomial_conv r)
  14.785 +       in transitive th1 (polynomial_neg_conv (concl th1))
  14.786 +       end
  14.787 +     else if lopr aconvc inverse_tm then
  14.788 +       let val th1 = Drule.arg_cong_rule lopr (polynomial_conv r)
  14.789 +       in transitive th1 (semiring_mul_conv (concl th1))
  14.790 +       end
  14.791 +     else
  14.792 +       if not(is_comb lopr) then reflexive tm
  14.793 +       else
  14.794 +         let val (opr,l) = Thm.dest_comb lopr
  14.795 +         in if opr aconvc pow_tm andalso is_numeral r
  14.796 +            then
  14.797 +              let val th1 = Drule.fun_cong_rule (Drule.arg_cong_rule opr (polynomial_conv l)) r
  14.798 +              in transitive th1 (polynomial_pow_conv (concl th1))
  14.799 +              end
  14.800 +         else if opr aconvc divide_tm 
  14.801 +            then
  14.802 +              let val th1 = combination (Drule.arg_cong_rule opr (polynomial_conv l)) 
  14.803 +                                        (polynomial_conv r)
  14.804 +                  val th2 = (Conv.rewr_conv divide_inverse then_conv polynomial_mul_conv)
  14.805 +                              (Thm.rhs_of th1)
  14.806 +              in transitive th1 th2
  14.807 +              end
  14.808 +            else
  14.809 +              if opr aconvc add_tm orelse opr aconvc mul_tm orelse opr aconvc sub_tm
  14.810 +              then
  14.811 +               let val th1 = combination (Drule.arg_cong_rule opr (polynomial_conv l)) (polynomial_conv r)
  14.812 +                   val f = if opr aconvc add_tm then polynomial_add_conv
  14.813 +                      else if opr aconvc mul_tm then polynomial_mul_conv
  14.814 +                      else polynomial_sub_conv
  14.815 +               in transitive th1 (f (concl th1))
  14.816 +               end
  14.817 +              else reflexive tm
  14.818 +         end
  14.819 +  end;
  14.820 + in
  14.821 +   {main = polynomial_conv,
  14.822 +    add = polynomial_add_conv,
  14.823 +    mul = polynomial_mul_conv,
  14.824 +    pow = polynomial_pow_conv,
  14.825 +    neg = polynomial_neg_conv,
  14.826 +    sub = polynomial_sub_conv}
  14.827 + end
  14.828 +end;
  14.829 +
  14.830 +val nat_exp_ss =
  14.831 +  HOL_basic_ss addsimps (@{thms nat_number} @ @{thms nat_arith} @ @{thms arith_simps} @ @{thms rel_simps})
  14.832 +    addsimps [@{thm Let_def}, @{thm if_False}, @{thm if_True}, @{thm Nat.add_0}, @{thm add_Suc}];
  14.833 +
  14.834 +fun simple_cterm_ord t u = Term_Ord.term_ord (term_of t, term_of u) = LESS;
  14.835 +
  14.836 +
  14.837 +(* various normalizing conversions *)
  14.838 +
  14.839 +fun semiring_normalizers_ord_wrapper ctxt ({vars, semiring, ring, field, idom, ideal}, 
  14.840 +                                     {conv, dest_const, mk_const, is_const}) ord =
  14.841 +  let
  14.842 +    val pow_conv =
  14.843 +      Conv.arg_conv (Simplifier.rewrite nat_exp_ss)
  14.844 +      then_conv Simplifier.rewrite
  14.845 +        (HOL_basic_ss addsimps [nth (snd semiring) 31, nth (snd semiring) 34])
  14.846 +      then_conv conv ctxt
  14.847 +    val dat = (is_const, conv ctxt, conv ctxt, pow_conv)
  14.848 +  in semiring_normalizers_conv vars semiring ring field dat ord end;
  14.849 +
  14.850 +fun semiring_normalize_ord_wrapper ctxt ({vars, semiring, ring, field, idom, ideal}, {conv, dest_const, mk_const, is_const}) ord =
  14.851 + #main (semiring_normalizers_ord_wrapper ctxt ({vars = vars, semiring = semiring, ring = ring, field = field, idom = idom, ideal = ideal},{conv = conv, dest_const = dest_const, mk_const = mk_const, is_const = is_const}) ord);
  14.852 +
  14.853 +fun semiring_normalize_wrapper ctxt data = 
  14.854 +  semiring_normalize_ord_wrapper ctxt data simple_cterm_ord;
  14.855 +
  14.856 +fun semiring_normalize_ord_conv ctxt ord tm =
  14.857 +  (case match ctxt tm of
  14.858 +    NONE => reflexive tm
  14.859 +  | SOME res => semiring_normalize_ord_wrapper ctxt res ord tm);
  14.860 + 
  14.861 +fun semiring_normalize_conv ctxt = semiring_normalize_ord_conv ctxt simple_cterm_ord;
  14.862 +
  14.863 +
  14.864 +(** Isar setup **)
  14.865 +
  14.866 +local
  14.867 +
  14.868 +fun keyword k = Scan.lift (Args.$$$ k -- Args.colon) >> K ();
  14.869 +fun keyword2 k1 k2 = Scan.lift (Args.$$$ k1 -- Args.$$$ k2 -- Args.colon) >> K ();
  14.870 +fun keyword3 k1 k2 k3 =
  14.871 +  Scan.lift (Args.$$$ k1 -- Args.$$$ k2 -- Args.$$$ k3 -- Args.colon) >> K ();
  14.872 +
  14.873 +val opsN = "ops";
  14.874 +val rulesN = "rules";
  14.875 +
  14.876 +val normN = "norm";
  14.877 +val constN = "const";
  14.878 +val delN = "del";
  14.879 +
  14.880 +val any_keyword =
  14.881 +  keyword2 semiringN opsN || keyword2 semiringN rulesN ||
  14.882 +  keyword2 ringN opsN || keyword2 ringN rulesN ||
  14.883 +  keyword2 fieldN opsN || keyword2 fieldN rulesN ||
  14.884 +  keyword2 idomN rulesN || keyword2 idealN rulesN;
  14.885 +
  14.886 +val thms = Scan.repeat (Scan.unless any_keyword Attrib.multi_thm) >> flat;
  14.887 +val terms = thms >> map Drule.dest_term;
  14.888 +
  14.889 +fun optional scan = Scan.optional scan [];
  14.890 +
  14.891 +in
  14.892 +
  14.893 +val setup =
  14.894 +  Attrib.setup @{binding normalizer}
  14.895 +    (Scan.lift (Args.$$$ delN >> K del) ||
  14.896 +      ((keyword2 semiringN opsN |-- terms) --
  14.897 +       (keyword2 semiringN rulesN |-- thms)) --
  14.898 +      (optional (keyword2 ringN opsN |-- terms) --
  14.899 +       optional (keyword2 ringN rulesN |-- thms)) --
  14.900 +      (optional (keyword2 fieldN opsN |-- terms) --
  14.901 +       optional (keyword2 fieldN rulesN |-- thms)) --
  14.902 +      optional (keyword2 idomN rulesN |-- thms) --
  14.903 +      optional (keyword2 idealN rulesN |-- thms)
  14.904 +      >> (fn ((((sr, r), f), id), idl) => 
  14.905 +             add {semiring = sr, ring = r, field = f, idom = id, ideal = idl}))
  14.906 +    "semiring normalizer data";
  14.907 +
  14.908 +end;
  14.909 +
  14.910 +end;
    15.1 --- a/src/HOL/ex/Groebner_Examples.thy	Fri May 07 23:44:10 2010 +0200
    15.2 +++ b/src/HOL/ex/Groebner_Examples.thy	Sat May 08 17:15:50 2010 +0200
    15.3 @@ -14,21 +14,21 @@
    15.4    fixes x :: int
    15.5    shows "x ^ 3 = x ^ 3" 
    15.6    apply (tactic {* ALLGOALS (CONVERSION
    15.7 -    (Conv.arg_conv (Conv.arg1_conv (Normalizer.semiring_normalize_conv @{context})))) *})
    15.8 +    (Conv.arg_conv (Conv.arg1_conv (Semiring_Normalizer.semiring_normalize_conv @{context})))) *})
    15.9    by (rule refl)
   15.10  
   15.11  lemma
   15.12    fixes x :: int
   15.13    shows "(x - (-2))^5 = x ^ 5 + (10 * x ^ 4 + (40 * x ^ 3 + (80 * x\<twosuperior> + (80 * x + 32))))" 
   15.14    apply (tactic {* ALLGOALS (CONVERSION
   15.15 -    (Conv.arg_conv (Conv.arg1_conv (Normalizer.semiring_normalize_conv @{context})))) *})
   15.16 +    (Conv.arg_conv (Conv.arg1_conv (Semiring_Normalizer.semiring_normalize_conv @{context})))) *})
   15.17    by (rule refl)
   15.18  
   15.19  schematic_lemma
   15.20    fixes x :: int
   15.21    shows "(x - (-2))^5  * (y - 78) ^ 8 = ?X" 
   15.22    apply (tactic {* ALLGOALS (CONVERSION
   15.23 -    (Conv.arg_conv (Conv.arg1_conv (Normalizer.semiring_normalize_conv @{context})))) *})
   15.24 +    (Conv.arg_conv (Conv.arg1_conv (Semiring_Normalizer.semiring_normalize_conv @{context})))) *})
   15.25    by (rule refl)
   15.26  
   15.27  lemma "((-3) ^ (Suc (Suc (Suc 0)))) == (X::'a::{number_ring})"