wenzelm@20324
|
1 |
(* Title: HOL/FunDef.thy
|
wenzelm@20324
|
2 |
Author: Alexander Krauss, TU Muenchen
|
wenzelm@20324
|
3 |
*)
|
wenzelm@20324
|
4 |
|
krauss@29118
|
5 |
header {* Function Definitions and Termination Proofs *}
|
wenzelm@22816
|
6 |
|
krauss@19564
|
7 |
theory FunDef
|
krauss@40354
|
8 |
imports Partial_Function Wellfounded
|
wenzelm@22816
|
9 |
uses
|
krauss@29118
|
10 |
"Tools/prop_logic.ML"
|
krauss@29118
|
11 |
"Tools/sat_solver.ML"
|
krauss@33088
|
12 |
("Tools/Function/function_common.ML")
|
haftmann@31771
|
13 |
("Tools/Function/context_tree.ML")
|
krauss@33088
|
14 |
("Tools/Function/function_core.ML")
|
haftmann@31771
|
15 |
("Tools/Function/sum_tree.ML")
|
haftmann@31771
|
16 |
("Tools/Function/mutual.ML")
|
haftmann@31771
|
17 |
("Tools/Function/pattern_split.ML")
|
krauss@33088
|
18 |
("Tools/Function/function.ML")
|
krauss@33089
|
19 |
("Tools/Function/relation.ML")
|
haftmann@31771
|
20 |
("Tools/Function/measure_functions.ML")
|
haftmann@31771
|
21 |
("Tools/Function/lexicographic_order.ML")
|
krauss@33083
|
22 |
("Tools/Function/pat_completeness.ML")
|
krauss@33087
|
23 |
("Tools/Function/fun.ML")
|
krauss@33471
|
24 |
("Tools/Function/induction_schema.ML")
|
haftmann@31771
|
25 |
("Tools/Function/termination.ML")
|
haftmann@31771
|
26 |
("Tools/Function/scnp_solve.ML")
|
haftmann@31771
|
27 |
("Tools/Function/scnp_reconstruct.ML")
|
krauss@19564
|
28 |
begin
|
krauss@19564
|
29 |
|
krauss@29118
|
30 |
subsection {* Definitions with default value. *}
|
krauss@20536
|
31 |
|
krauss@20536
|
32 |
definition
|
wenzelm@21404
|
33 |
THE_default :: "'a \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> 'a" where
|
krauss@20536
|
34 |
"THE_default d P = (if (\<exists>!x. P x) then (THE x. P x) else d)"
|
krauss@20536
|
35 |
|
krauss@20536
|
36 |
lemma THE_defaultI': "\<exists>!x. P x \<Longrightarrow> P (THE_default d P)"
|
wenzelm@22816
|
37 |
by (simp add: theI' THE_default_def)
|
krauss@20536
|
38 |
|
wenzelm@22816
|
39 |
lemma THE_default1_equality:
|
wenzelm@22816
|
40 |
"\<lbrakk>\<exists>!x. P x; P a\<rbrakk> \<Longrightarrow> THE_default d P = a"
|
wenzelm@22816
|
41 |
by (simp add: the1_equality THE_default_def)
|
krauss@20536
|
42 |
|
krauss@20536
|
43 |
lemma THE_default_none:
|
wenzelm@22816
|
44 |
"\<not>(\<exists>!x. P x) \<Longrightarrow> THE_default d P = d"
|
wenzelm@22816
|
45 |
by (simp add:THE_default_def)
|
krauss@20536
|
46 |
|
krauss@20536
|
47 |
|
krauss@19564
|
48 |
lemma fundef_ex1_existence:
|
wenzelm@22816
|
49 |
assumes f_def: "f == (\<lambda>x::'a. THE_default (d x) (\<lambda>y. G x y))"
|
wenzelm@22816
|
50 |
assumes ex1: "\<exists>!y. G x y"
|
wenzelm@22816
|
51 |
shows "G x (f x)"
|
wenzelm@22816
|
52 |
apply (simp only: f_def)
|
wenzelm@22816
|
53 |
apply (rule THE_defaultI')
|
wenzelm@22816
|
54 |
apply (rule ex1)
|
wenzelm@22816
|
55 |
done
|
krauss@21051
|
56 |
|
krauss@19564
|
57 |
lemma fundef_ex1_uniqueness:
|
wenzelm@22816
|
58 |
assumes f_def: "f == (\<lambda>x::'a. THE_default (d x) (\<lambda>y. G x y))"
|
wenzelm@22816
|
59 |
assumes ex1: "\<exists>!y. G x y"
|
wenzelm@22816
|
60 |
assumes elm: "G x (h x)"
|
wenzelm@22816
|
61 |
shows "h x = f x"
|
wenzelm@22816
|
62 |
apply (simp only: f_def)
|
wenzelm@22816
|
63 |
apply (rule THE_default1_equality [symmetric])
|
wenzelm@22816
|
64 |
apply (rule ex1)
|
wenzelm@22816
|
65 |
apply (rule elm)
|
wenzelm@22816
|
66 |
done
|
krauss@19564
|
67 |
|
krauss@19564
|
68 |
lemma fundef_ex1_iff:
|
wenzelm@22816
|
69 |
assumes f_def: "f == (\<lambda>x::'a. THE_default (d x) (\<lambda>y. G x y))"
|
wenzelm@22816
|
70 |
assumes ex1: "\<exists>!y. G x y"
|
wenzelm@22816
|
71 |
shows "(G x y) = (f x = y)"
|
krauss@20536
|
72 |
apply (auto simp:ex1 f_def THE_default1_equality)
|
wenzelm@22816
|
73 |
apply (rule THE_defaultI')
|
wenzelm@22816
|
74 |
apply (rule ex1)
|
wenzelm@22816
|
75 |
done
|
krauss@19564
|
76 |
|
krauss@20654
|
77 |
lemma fundef_default_value:
|
wenzelm@22816
|
78 |
assumes f_def: "f == (\<lambda>x::'a. THE_default (d x) (\<lambda>y. G x y))"
|
wenzelm@22816
|
79 |
assumes graph: "\<And>x y. G x y \<Longrightarrow> D x"
|
wenzelm@22816
|
80 |
assumes "\<not> D x"
|
wenzelm@22816
|
81 |
shows "f x = d x"
|
krauss@20654
|
82 |
proof -
|
krauss@21051
|
83 |
have "\<not>(\<exists>y. G x y)"
|
krauss@20654
|
84 |
proof
|
krauss@21512
|
85 |
assume "\<exists>y. G x y"
|
krauss@21512
|
86 |
hence "D x" using graph ..
|
krauss@21512
|
87 |
with `\<not> D x` show False ..
|
krauss@20654
|
88 |
qed
|
krauss@21051
|
89 |
hence "\<not>(\<exists>!y. G x y)" by blast
|
wenzelm@22816
|
90 |
|
krauss@20654
|
91 |
thus ?thesis
|
krauss@20654
|
92 |
unfolding f_def
|
krauss@20654
|
93 |
by (rule THE_default_none)
|
krauss@20654
|
94 |
qed
|
krauss@20654
|
95 |
|
berghofe@23739
|
96 |
definition in_rel_def[simp]:
|
berghofe@23739
|
97 |
"in_rel R x y == (x, y) \<in> R"
|
berghofe@23739
|
98 |
|
berghofe@23739
|
99 |
lemma wf_in_rel:
|
berghofe@23739
|
100 |
"wf R \<Longrightarrow> wfP (in_rel R)"
|
berghofe@23739
|
101 |
by (simp add: wfP_def)
|
berghofe@23739
|
102 |
|
krauss@33088
|
103 |
use "Tools/Function/function_common.ML"
|
haftmann@31771
|
104 |
use "Tools/Function/context_tree.ML"
|
krauss@33088
|
105 |
use "Tools/Function/function_core.ML"
|
haftmann@31771
|
106 |
use "Tools/Function/sum_tree.ML"
|
haftmann@31771
|
107 |
use "Tools/Function/mutual.ML"
|
haftmann@31771
|
108 |
use "Tools/Function/pattern_split.ML"
|
krauss@33089
|
109 |
use "Tools/Function/relation.ML"
|
krauss@33088
|
110 |
use "Tools/Function/function.ML"
|
krauss@33083
|
111 |
use "Tools/Function/pat_completeness.ML"
|
krauss@33087
|
112 |
use "Tools/Function/fun.ML"
|
krauss@33471
|
113 |
use "Tools/Function/induction_schema.ML"
|
krauss@19564
|
114 |
|
krauss@25567
|
115 |
setup {*
|
krauss@33088
|
116 |
Function.setup
|
krauss@33083
|
117 |
#> Pat_Completeness.setup
|
krauss@33087
|
118 |
#> Function_Fun.setup
|
krauss@33471
|
119 |
#> Induction_Schema.setup
|
krauss@25567
|
120 |
*}
|
krauss@19770
|
121 |
|
krauss@29118
|
122 |
subsection {* Measure Functions *}
|
krauss@29118
|
123 |
|
krauss@29118
|
124 |
inductive is_measure :: "('a \<Rightarrow> nat) \<Rightarrow> bool"
|
krauss@29118
|
125 |
where is_measure_trivial: "is_measure f"
|
krauss@29118
|
126 |
|
haftmann@31771
|
127 |
use "Tools/Function/measure_functions.ML"
|
krauss@29118
|
128 |
setup MeasureFunctions.setup
|
krauss@29118
|
129 |
|
krauss@29118
|
130 |
lemma measure_size[measure_function]: "is_measure size"
|
krauss@29118
|
131 |
by (rule is_measure_trivial)
|
krauss@29118
|
132 |
|
krauss@29118
|
133 |
lemma measure_fst[measure_function]: "is_measure f \<Longrightarrow> is_measure (\<lambda>p. f (fst p))"
|
krauss@29118
|
134 |
by (rule is_measure_trivial)
|
krauss@29118
|
135 |
lemma measure_snd[measure_function]: "is_measure f \<Longrightarrow> is_measure (\<lambda>p. f (snd p))"
|
krauss@29118
|
136 |
by (rule is_measure_trivial)
|
krauss@29118
|
137 |
|
haftmann@31771
|
138 |
use "Tools/Function/lexicographic_order.ML"
|
krauss@33088
|
139 |
setup Lexicographic_Order.setup
|
krauss@29118
|
140 |
|
krauss@29118
|
141 |
|
krauss@29118
|
142 |
subsection {* Congruence Rules *}
|
krauss@29118
|
143 |
|
haftmann@22838
|
144 |
lemma let_cong [fundef_cong]:
|
haftmann@22838
|
145 |
"M = N \<Longrightarrow> (\<And>x. x = N \<Longrightarrow> f x = g x) \<Longrightarrow> Let M f = Let N g"
|
wenzelm@22816
|
146 |
unfolding Let_def by blast
|
krauss@22622
|
147 |
|
wenzelm@22816
|
148 |
lemmas [fundef_cong] =
|
haftmann@22838
|
149 |
if_cong image_cong INT_cong UN_cong
|
haftmann@22838
|
150 |
bex_cong ball_cong imp_cong
|
krauss@19564
|
151 |
|
wenzelm@22816
|
152 |
lemma split_cong [fundef_cong]:
|
haftmann@22838
|
153 |
"(\<And>x y. (x, y) = q \<Longrightarrow> f x y = g x y) \<Longrightarrow> p = q
|
wenzelm@22816
|
154 |
\<Longrightarrow> split f p = split g q"
|
wenzelm@22816
|
155 |
by (auto simp: split_def)
|
krauss@19934
|
156 |
|
wenzelm@22816
|
157 |
lemma comp_cong [fundef_cong]:
|
haftmann@22838
|
158 |
"f (g x) = f' (g' x') \<Longrightarrow> (f o g) x = (f' o g') x'"
|
wenzelm@22816
|
159 |
unfolding o_apply .
|
krauss@19934
|
160 |
|
krauss@29118
|
161 |
subsection {* Simp rules for termination proofs *}
|
krauss@26875
|
162 |
|
krauss@26749
|
163 |
lemma termination_basic_simps[termination_simp]:
|
krauss@26749
|
164 |
"x < (y::nat) \<Longrightarrow> x < y + z"
|
krauss@26749
|
165 |
"x < z \<Longrightarrow> x < y + z"
|
krauss@26875
|
166 |
"x \<le> y \<Longrightarrow> x \<le> y + (z::nat)"
|
krauss@26875
|
167 |
"x \<le> z \<Longrightarrow> x \<le> y + (z::nat)"
|
krauss@26875
|
168 |
"x < y \<Longrightarrow> x \<le> (y::nat)"
|
krauss@26749
|
169 |
by arith+
|
krauss@26749
|
170 |
|
krauss@26875
|
171 |
declare le_imp_less_Suc[termination_simp]
|
krauss@26875
|
172 |
|
krauss@26875
|
173 |
lemma prod_size_simp[termination_simp]:
|
krauss@26875
|
174 |
"prod_size f g p = f (fst p) + g (snd p) + Suc 0"
|
krauss@26875
|
175 |
by (induct p) auto
|
krauss@26875
|
176 |
|
krauss@29118
|
177 |
subsection {* Decomposition *}
|
krauss@29118
|
178 |
|
krauss@29118
|
179 |
lemma less_by_empty:
|
krauss@29118
|
180 |
"A = {} \<Longrightarrow> A \<subseteq> B"
|
krauss@29118
|
181 |
and union_comp_emptyL:
|
krauss@29118
|
182 |
"\<lbrakk> A O C = {}; B O C = {} \<rbrakk> \<Longrightarrow> (A \<union> B) O C = {}"
|
krauss@29118
|
183 |
and union_comp_emptyR:
|
krauss@29118
|
184 |
"\<lbrakk> A O B = {}; A O C = {} \<rbrakk> \<Longrightarrow> A O (B \<union> C) = {}"
|
krauss@29118
|
185 |
and wf_no_loop:
|
krauss@29118
|
186 |
"R O R = {} \<Longrightarrow> wf R"
|
krauss@29118
|
187 |
by (auto simp add: wf_comp_self[of R])
|
krauss@29118
|
188 |
|
krauss@29118
|
189 |
|
krauss@29118
|
190 |
subsection {* Reduction Pairs *}
|
krauss@29118
|
191 |
|
krauss@29118
|
192 |
definition
|
krauss@32231
|
193 |
"reduction_pair P = (wf (fst P) \<and> fst P O snd P \<subseteq> fst P)"
|
krauss@29118
|
194 |
|
krauss@32231
|
195 |
lemma reduction_pairI[intro]: "wf R \<Longrightarrow> R O S \<subseteq> R \<Longrightarrow> reduction_pair (R, S)"
|
krauss@29118
|
196 |
unfolding reduction_pair_def by auto
|
krauss@29118
|
197 |
|
krauss@29118
|
198 |
lemma reduction_pair_lemma:
|
krauss@29118
|
199 |
assumes rp: "reduction_pair P"
|
krauss@29118
|
200 |
assumes "R \<subseteq> fst P"
|
krauss@29118
|
201 |
assumes "S \<subseteq> snd P"
|
krauss@29118
|
202 |
assumes "wf S"
|
krauss@29118
|
203 |
shows "wf (R \<union> S)"
|
krauss@29118
|
204 |
proof -
|
krauss@32231
|
205 |
from rp `S \<subseteq> snd P` have "wf (fst P)" "fst P O S \<subseteq> fst P"
|
krauss@29118
|
206 |
unfolding reduction_pair_def by auto
|
krauss@29118
|
207 |
with `wf S` have "wf (fst P \<union> S)"
|
krauss@29118
|
208 |
by (auto intro: wf_union_compatible)
|
krauss@29118
|
209 |
moreover from `R \<subseteq> fst P` have "R \<union> S \<subseteq> fst P \<union> S" by auto
|
krauss@29118
|
210 |
ultimately show ?thesis by (rule wf_subset)
|
krauss@29118
|
211 |
qed
|
krauss@29118
|
212 |
|
krauss@29118
|
213 |
definition
|
krauss@29118
|
214 |
"rp_inv_image = (\<lambda>(R,S) f. (inv_image R f, inv_image S f))"
|
krauss@29118
|
215 |
|
krauss@29118
|
216 |
lemma rp_inv_image_rp:
|
krauss@29118
|
217 |
"reduction_pair P \<Longrightarrow> reduction_pair (rp_inv_image P f)"
|
krauss@29118
|
218 |
unfolding reduction_pair_def rp_inv_image_def split_def
|
krauss@29118
|
219 |
by force
|
krauss@29118
|
220 |
|
krauss@29118
|
221 |
|
krauss@29118
|
222 |
subsection {* Concrete orders for SCNP termination proofs *}
|
krauss@29118
|
223 |
|
krauss@29118
|
224 |
definition "pair_less = less_than <*lex*> less_than"
|
haftmann@37767
|
225 |
definition "pair_leq = pair_less^="
|
krauss@29118
|
226 |
definition "max_strict = max_ext pair_less"
|
haftmann@37767
|
227 |
definition "max_weak = max_ext pair_leq \<union> {({}, {})}"
|
haftmann@37767
|
228 |
definition "min_strict = min_ext pair_less"
|
haftmann@37767
|
229 |
definition "min_weak = min_ext pair_leq \<union> {({}, {})}"
|
krauss@29118
|
230 |
|
krauss@29118
|
231 |
lemma wf_pair_less[simp]: "wf pair_less"
|
krauss@29118
|
232 |
by (auto simp: pair_less_def)
|
krauss@29118
|
233 |
|
wenzelm@29127
|
234 |
text {* Introduction rules for @{text pair_less}/@{text pair_leq} *}
|
krauss@29118
|
235 |
lemma pair_leqI1: "a < b \<Longrightarrow> ((a, s), (b, t)) \<in> pair_leq"
|
krauss@29118
|
236 |
and pair_leqI2: "a \<le> b \<Longrightarrow> s \<le> t \<Longrightarrow> ((a, s), (b, t)) \<in> pair_leq"
|
krauss@29118
|
237 |
and pair_lessI1: "a < b \<Longrightarrow> ((a, s), (b, t)) \<in> pair_less"
|
krauss@29118
|
238 |
and pair_lessI2: "a \<le> b \<Longrightarrow> s < t \<Longrightarrow> ((a, s), (b, t)) \<in> pair_less"
|
krauss@29118
|
239 |
unfolding pair_leq_def pair_less_def by auto
|
krauss@29118
|
240 |
|
krauss@29118
|
241 |
text {* Introduction rules for max *}
|
krauss@29118
|
242 |
lemma smax_emptyI:
|
krauss@29118
|
243 |
"finite Y \<Longrightarrow> Y \<noteq> {} \<Longrightarrow> ({}, Y) \<in> max_strict"
|
krauss@29118
|
244 |
and smax_insertI:
|
krauss@29118
|
245 |
"\<lbrakk>y \<in> Y; (x, y) \<in> pair_less; (X, Y) \<in> max_strict\<rbrakk> \<Longrightarrow> (insert x X, Y) \<in> max_strict"
|
krauss@29118
|
246 |
and wmax_emptyI:
|
krauss@29118
|
247 |
"finite X \<Longrightarrow> ({}, X) \<in> max_weak"
|
krauss@29118
|
248 |
and wmax_insertI:
|
krauss@29118
|
249 |
"\<lbrakk>y \<in> YS; (x, y) \<in> pair_leq; (XS, YS) \<in> max_weak\<rbrakk> \<Longrightarrow> (insert x XS, YS) \<in> max_weak"
|
krauss@29118
|
250 |
unfolding max_strict_def max_weak_def by (auto elim!: max_ext.cases)
|
krauss@29118
|
251 |
|
krauss@29118
|
252 |
text {* Introduction rules for min *}
|
krauss@29118
|
253 |
lemma smin_emptyI:
|
krauss@29118
|
254 |
"X \<noteq> {} \<Longrightarrow> (X, {}) \<in> min_strict"
|
krauss@29118
|
255 |
and smin_insertI:
|
krauss@29118
|
256 |
"\<lbrakk>x \<in> XS; (x, y) \<in> pair_less; (XS, YS) \<in> min_strict\<rbrakk> \<Longrightarrow> (XS, insert y YS) \<in> min_strict"
|
krauss@29118
|
257 |
and wmin_emptyI:
|
krauss@29118
|
258 |
"(X, {}) \<in> min_weak"
|
krauss@29118
|
259 |
and wmin_insertI:
|
krauss@29118
|
260 |
"\<lbrakk>x \<in> XS; (x, y) \<in> pair_leq; (XS, YS) \<in> min_weak\<rbrakk> \<Longrightarrow> (XS, insert y YS) \<in> min_weak"
|
krauss@29118
|
261 |
by (auto simp: min_strict_def min_weak_def min_ext_def)
|
krauss@29118
|
262 |
|
krauss@29118
|
263 |
text {* Reduction Pairs *}
|
krauss@29118
|
264 |
|
krauss@29118
|
265 |
lemma max_ext_compat:
|
krauss@32231
|
266 |
assumes "R O S \<subseteq> R"
|
krauss@32231
|
267 |
shows "max_ext R O (max_ext S \<union> {({},{})}) \<subseteq> max_ext R"
|
krauss@29118
|
268 |
using assms
|
krauss@29118
|
269 |
apply auto
|
krauss@29118
|
270 |
apply (elim max_ext.cases)
|
krauss@29118
|
271 |
apply rule
|
krauss@29118
|
272 |
apply auto[3]
|
krauss@29118
|
273 |
apply (drule_tac x=xa in meta_spec)
|
krauss@29118
|
274 |
apply simp
|
krauss@29118
|
275 |
apply (erule bexE)
|
krauss@29118
|
276 |
apply (drule_tac x=xb in meta_spec)
|
krauss@29118
|
277 |
by auto
|
krauss@29118
|
278 |
|
krauss@29118
|
279 |
lemma max_rpair_set: "reduction_pair (max_strict, max_weak)"
|
krauss@29118
|
280 |
unfolding max_strict_def max_weak_def
|
krauss@29118
|
281 |
apply (intro reduction_pairI max_ext_wf)
|
krauss@29118
|
282 |
apply simp
|
krauss@29118
|
283 |
apply (rule max_ext_compat)
|
krauss@29118
|
284 |
by (auto simp: pair_less_def pair_leq_def)
|
krauss@29118
|
285 |
|
krauss@29118
|
286 |
lemma min_ext_compat:
|
krauss@32231
|
287 |
assumes "R O S \<subseteq> R"
|
krauss@32231
|
288 |
shows "min_ext R O (min_ext S \<union> {({},{})}) \<subseteq> min_ext R"
|
krauss@29118
|
289 |
using assms
|
krauss@29118
|
290 |
apply (auto simp: min_ext_def)
|
krauss@29118
|
291 |
apply (drule_tac x=ya in bspec, assumption)
|
krauss@29118
|
292 |
apply (erule bexE)
|
krauss@29118
|
293 |
apply (drule_tac x=xc in bspec)
|
krauss@29118
|
294 |
apply assumption
|
krauss@29118
|
295 |
by auto
|
krauss@29118
|
296 |
|
krauss@29118
|
297 |
lemma min_rpair_set: "reduction_pair (min_strict, min_weak)"
|
krauss@29118
|
298 |
unfolding min_strict_def min_weak_def
|
krauss@29118
|
299 |
apply (intro reduction_pairI min_ext_wf)
|
krauss@29118
|
300 |
apply simp
|
krauss@29118
|
301 |
apply (rule min_ext_compat)
|
krauss@29118
|
302 |
by (auto simp: pair_less_def pair_leq_def)
|
krauss@29118
|
303 |
|
krauss@29118
|
304 |
|
krauss@29118
|
305 |
subsection {* Tool setup *}
|
krauss@29118
|
306 |
|
haftmann@31771
|
307 |
use "Tools/Function/termination.ML"
|
haftmann@31771
|
308 |
use "Tools/Function/scnp_solve.ML"
|
haftmann@31771
|
309 |
use "Tools/Function/scnp_reconstruct.ML"
|
krauss@29118
|
310 |
|
krauss@29118
|
311 |
setup {* ScnpReconstruct.setup *}
|
wenzelm@30482
|
312 |
|
wenzelm@30482
|
313 |
ML_val -- "setup inactive"
|
wenzelm@30482
|
314 |
{*
|
krauss@36514
|
315 |
Context.theory_map (Function_Common.set_termination_prover
|
krauss@36514
|
316 |
(ScnpReconstruct.decomp_scnp_tac [ScnpSolve.MAX, ScnpSolve.MIN, ScnpSolve.MS]))
|
krauss@29118
|
317 |
*}
|
krauss@26875
|
318 |
|
krauss@19564
|
319 |
end
|