129 |
129 |
130 val defALL_regroup = |
130 val defALL_regroup = |
131 Simplifier.simproc (Theory.sign_of (the_context ())) |
131 Simplifier.simproc (Theory.sign_of (the_context ())) |
132 "defined ALL" ["ALL x. P x"] Quantifier1.rearrange_all; |
132 "defined ALL" ["ALL x. P x"] Quantifier1.rearrange_all; |
133 |
133 |
|
134 (*** Simproc for Let ***) |
|
135 |
|
136 val use_let_simproc = ref true; |
|
137 |
|
138 local |
|
139 val Let_folded = thm "Let_folded"; |
|
140 val Let_unfold = thm "Let_unfold"; |
|
141 |
|
142 val f_Let_unfold = |
|
143 let val [(_$(f$_)$_)] = prems_of Let_unfold in cterm_of (sign_of (the_context ())) f end |
|
144 val f_Let_folded = |
|
145 let val [(_$(f$_)$_)] = prems_of Let_folded in cterm_of (sign_of (the_context ())) f end; |
|
146 val g_Let_folded = |
|
147 let val [(_$_$(g$_))] = prems_of Let_folded in cterm_of (sign_of (the_context ())) g end; |
|
148 in |
|
149 val let_simproc = |
|
150 Simplifier.simproc (Theory.sign_of (the_context ())) "let_simp" ["Let x f"] |
|
151 (fn sg => fn ss => fn t => |
|
152 (case t of (Const ("Let",_)$x$f) => (* x and f are already in normal form *) |
|
153 if not (!use_let_simproc) then None |
|
154 else if is_Free x orelse is_Bound x orelse is_Const x |
|
155 then Some Let_def |
|
156 else |
|
157 let |
|
158 val n = case f of (Abs (x,_,_)) => x | _ => "x"; |
|
159 val cx = cterm_of sg x; |
|
160 val {T=xT,...} = rep_cterm cx; |
|
161 val cf = cterm_of sg f; |
|
162 val fx_g = Simplifier.rewrite ss (Thm.capply cf cx); |
|
163 val (_$_$g) = prop_of fx_g; |
|
164 val g' = abstract_over (x,g); |
|
165 in (if (g aconv g') |
|
166 then |
|
167 let |
|
168 val rl = cterm_instantiate [(f_Let_unfold,cf)] Let_unfold; |
|
169 in Some (rl OF [fx_g]) end |
|
170 else if betapply (f,x) aconv g then None (* avoid identity conversion *) |
|
171 else let |
|
172 val abs_g'= Abs (n,xT,g'); |
|
173 val g'x = abs_g'$x; |
|
174 val g_g'x = symmetric (beta_conversion false (cterm_of sg g'x)); |
|
175 val rl = cterm_instantiate |
|
176 [(f_Let_folded,cterm_of sg f), |
|
177 (g_Let_folded,cterm_of sg abs_g')] |
|
178 Let_folded; |
|
179 in Some (rl OF [transitive fx_g g_g'x]) end) |
|
180 end |
|
181 | _ => None)) |
|
182 end |
134 |
183 |
135 (*** Case splitting ***) |
184 (*** Case splitting ***) |
136 |
185 |
137 (*Make meta-equalities. The operator below is Trueprop*) |
186 (*Make meta-equalities. The operator below is Trueprop*) |
138 |
187 |
246 imp_disjL, conj_assoc, disj_assoc, |
295 imp_disjL, conj_assoc, disj_assoc, |
247 de_Morgan_conj, de_Morgan_disj, imp_disj1, imp_disj2, not_imp, |
296 de_Morgan_conj, de_Morgan_disj, imp_disj1, imp_disj2, not_imp, |
248 disj_not1, not_all, not_ex, cases_simp, |
297 disj_not1, not_all, not_ex, cases_simp, |
249 thm "the_eq_trivial", the_sym_eq_trivial] |
298 thm "the_eq_trivial", the_sym_eq_trivial] |
250 @ ex_simps @ all_simps @ simp_thms) |
299 @ ex_simps @ all_simps @ simp_thms) |
251 addsimprocs [defALL_regroup,defEX_regroup] |
300 addsimprocs [defALL_regroup,defEX_regroup,let_simproc] |
252 addcongs [imp_cong] |
301 addcongs [imp_cong] |
253 addsplits [split_if]; |
302 addsplits [split_if]; |
254 |
303 |
255 fun hol_simplify rews = Simplifier.full_simplify (HOL_basic_ss addsimps rews); |
304 fun hol_simplify rews = Simplifier.full_simplify (HOL_basic_ss addsimps rews); |
256 |
305 |