23 fun cring_one T = Const("1",T); |
21 fun cring_one T = Const("1",T); |
24 |
22 |
25 (* reification functions *) |
23 (* reification functions *) |
26 (* add two polynom expressions *) |
24 (* add two polynom expressions *) |
27 fun polT t = Type ("Commutative_Ring.pol",[t]); |
25 fun polT t = Type ("Commutative_Ring.pol",[t]); |
28 fun polexT t = Type("Commutative_Ring.polex",[t]); |
26 fun polexT t = Type("Commutative_Ring.polex",[t]); |
29 val nT = HOLogic.natT; |
27 val nT = HOLogic.natT; |
30 fun listT T = Type ("List.list",[T]); |
28 fun listT T = Type ("List.list",[T]); |
31 |
29 |
32 (* Reification of the constructors *) |
30 (* Reification of the constructors *) |
33 (* Nat*) |
31 (* Nat*) |
38 (* Lists *) |
36 (* Lists *) |
39 fun reif_list T [] = Const("List.list.Nil",listT T) |
37 fun reif_list T [] = Const("List.list.Nil",listT T) |
40 | reif_list T (x::xs) = Const("List.list.Cons",[T,listT T] ---> listT T) |
38 | reif_list T (x::xs) = Const("List.list.Cons",[T,listT T] ---> listT T) |
41 $x$(reif_list T xs); |
39 $x$(reif_list T xs); |
42 |
40 |
43 (* pol*) |
41 (* pol *) |
44 fun pol_Pc t = Const("Commutative_Ring.pol.Pc",t --> polT t); |
42 fun pol_Pc t = Const("Commutative_Ring.pol.Pc",t --> polT t); |
45 fun pol_Pinj t = Const("Commutative_Ring.pol.Pinj",[nT,polT t] ---> polT t); |
43 fun pol_Pinj t = Const("Commutative_Ring.pol.Pinj",[nT,polT t] ---> polT t); |
46 fun pol_PX t = Const("Commutative_Ring.pol.PX",[polT t, nT, polT t] ---> polT t); |
44 fun pol_PX t = Const("Commutative_Ring.pol.PX",[polT t, nT, polT t] ---> polT t); |
47 |
45 |
48 (* polex *) |
46 (* polex *) |
50 fun polex_sub t = Const("Commutative_Ring.polex.Sub",[polexT t,polexT t] ---> polexT t); |
48 fun polex_sub t = Const("Commutative_Ring.polex.Sub",[polexT t,polexT t] ---> polexT t); |
51 fun polex_mul t = Const("Commutative_Ring.polex.Mul",[polexT t,polexT t] ---> polexT t); |
49 fun polex_mul t = Const("Commutative_Ring.polex.Mul",[polexT t,polexT t] ---> polexT t); |
52 fun polex_neg t = Const("Commutative_Ring.polex.Neg",polexT t --> polexT t); |
50 fun polex_neg t = Const("Commutative_Ring.polex.Neg",polexT t --> polexT t); |
53 fun polex_pol t = Const("Commutative_Ring.polex.Pol",polT t --> polexT t); |
51 fun polex_pol t = Const("Commutative_Ring.polex.Pol",polT t --> polexT t); |
54 fun polex_pow t = Const("Commutative_Ring.polex.Pow",[polexT t, nT] ---> polexT t); |
52 fun polex_pow t = Const("Commutative_Ring.polex.Pow",[polexT t, nT] ---> polexT t); |
|
53 |
55 (* reification of natural numbers *) |
54 (* reification of natural numbers *) |
56 fun reif_nat n = |
55 fun reif_nat n = |
57 if n>0 then succ$(reif_nat (n-1)) |
56 if n>0 then succ$(reif_nat (n-1)) |
58 else if n=0 then zero |
57 else if n=0 then zero |
59 else raise CRing "ring_tac: reif_nat negative n"; |
58 else raise CRing "ring_tac: reif_nat negative n"; |
89 |
88 |
90 | _ => (polex_pol T) $ (reif_pol T vs t); |
89 | _ => (polex_pol T) $ (reif_pol T vs t); |
91 |
90 |
92 (* reification of the equation *) |
91 (* reification of the equation *) |
93 val cr_sort = Sign.read_sort (the_context ()) "{comm_ring,recpower}"; |
92 val cr_sort = Sign.read_sort (the_context ()) "{comm_ring,recpower}"; |
94 fun reif_eq sg (eq as Const("op =",Type("fun",a::_))$lhs$rhs) = |
93 fun reif_eq thy (eq as Const("op =",Type("fun",a::_))$lhs$rhs) = |
95 if Sign.of_sort (the_context()) (a,cr_sort) |
94 if Sign.of_sort thy (a,cr_sort) |
96 then |
95 then |
97 let val fs = term_frees eq |
96 let val fs = term_frees eq |
98 val cvs = cterm_of sg (reif_list a fs) |
97 val cvs = cterm_of thy (reif_list a fs) |
99 val clhs = cterm_of sg (reif_polex a fs lhs) |
98 val clhs = cterm_of thy (reif_polex a fs lhs) |
100 val crhs = cterm_of sg (reif_polex a fs rhs) |
99 val crhs = cterm_of thy (reif_polex a fs rhs) |
101 val ca = ctyp_of sg a |
100 val ca = ctyp_of thy a |
102 in (ca,cvs,clhs, crhs) |
101 in (ca,cvs,clhs, crhs) |
103 end |
102 end |
104 else raise CRing "reif_eq: not an equation over comm_ring + recpower" |
103 else raise CRing "reif_eq: not an equation over comm_ring + recpower" |
105 | reif_eq sg _ = raise CRing "reif_eq: not an equation"; |
104 | reif_eq _ _ = raise CRing "reif_eq: not an equation"; |
106 |
105 |
107 (*The cring tactic *) |
106 (*The cring tactic *) |
108 (* Attention: You have to make sure that no t^0 is in the goal!! *) |
107 (* Attention: You have to make sure that no t^0 is in the goal!! *) |
109 (* Use simply rewriting t^0 = 1 *) |
108 (* Use simply rewriting t^0 = 1 *) |
110 fun cring_ss sg = simpset_of sg |
109 val cring_simps = |
111 addsimps |
110 map thm ["mkPX_def", "mkPinj_def","sub_def", "power_add","even_def","pow_if"] @ |
112 (map thm ["mkPX_def", "mkPinj_def","sub_def", |
111 [sym OF [thm "power_add"]]; |
113 "power_add","even_def","pow_if"]) |
|
114 addsimps [sym OF [thm "power_add"]]; |
|
115 |
112 |
116 val norm_eq = thm "norm_eq" |
113 val norm_eq = thm "norm_eq" |
117 fun comm_ring_tac i =(fn st => |
|
118 let |
|
119 val g = List.nth (prems_of st, i - 1) |
|
120 val sg = sign_of_thm st |
|
121 val (ca,cvs,clhs,crhs) = reif_eq sg (HOLogic.dest_Trueprop g) |
|
122 val norm_eq_th = simplify (cring_ss sg) |
|
123 (instantiate' [SOME ca] [SOME clhs, SOME crhs, SOME cvs] |
|
124 norm_eq) |
|
125 in ((cut_rules_tac [norm_eq_th] i) |
|
126 THEN (simp_tac (cring_ss sg) i) |
|
127 THEN (simp_tac (cring_ss sg) i)) st |
|
128 end); |
|
129 |
114 |
130 fun comm_ring_method i = Method.METHOD (fn facts => |
115 fun comm_ring_tac ctxt = SUBGOAL (fn (g, i) => |
131 Method.insert_tac facts 1 THEN comm_ring_tac i); |
116 let |
132 val algebra_method = comm_ring_method; |
117 val thy = ProofContext.theory_of ctxt |
|
118 val cring_ss = Simplifier.local_simpset_of ctxt (* FIXME really the full simpset!? *) |
|
119 addsimps cring_simps |
|
120 val (ca, cvs, clhs, crhs) = reif_eq thy (HOLogic.dest_Trueprop g) |
|
121 val norm_eq_th = |
|
122 simplify cring_ss (instantiate' [SOME ca] [SOME clhs, SOME crhs, SOME cvs] norm_eq) |
|
123 in |
|
124 cut_rules_tac [norm_eq_th] i |
|
125 THEN (simp_tac cring_ss i) |
|
126 THEN (simp_tac cring_ss i) |
|
127 end); |
|
128 |
|
129 val comm_ring_meth = |
|
130 Method.ctxt_args (fn ctxt => Method.SIMPLE_METHOD' HEADGOAL (comm_ring_tac ctxt)); |
133 |
131 |
134 val setup = |
132 val setup = |
135 Method.add_method ("comm_ring", |
133 Method.add_method ("comm_ring", comm_ring_meth, |
136 Method.no_args (comm_ring_method 1), |
134 "reflective decision procedure for equalities over commutative rings") #> |
137 "reflective decision procedure for equalities over commutative rings") #> |
135 Method.add_method ("algebra", comm_ring_meth, |
138 Method.add_method ("algebra", |
136 "method for proving algebraic properties (same as comm_ring)"); |
139 Method.no_args (algebra_method 1), |
|
140 "Method for proving algebraic properties: for now only comm_ring"); |
|
141 |
137 |
142 end; |
138 end; |