author | haftmann |
Thu, 29 Dec 2011 13:41:41 +0100 | |
changeset 46033 | 6fc579c917b8 |
parent 45993 | 3ca49a4bcc9f |
child 46133 | d9fe85d3d2cd |
permissions | -rw-r--r-- |
45973 | 1 |
(* Author: Florian Haftmann, TU Muenchen *) |
37025 | 2 |
|
3 |
header {* Operations on lists beyond the standard List theory *} |
|
4 |
||
5 |
theory More_List |
|
45990
b7b905b23b2a
incorporated More_Set and More_List into the Main body -- to be consolidated later
haftmann
parents:
45973
diff
changeset
|
6 |
imports List |
37025 | 7 |
begin |
8 |
||
9 |
text {* Fold combinator with canonical argument order *} |
|
10 |
||
11 |
primrec fold :: "('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'a list \<Rightarrow> 'b \<Rightarrow> 'b" where |
|
12 |
"fold f [] = id" |
|
13 |
| "fold f (x # xs) = fold f xs \<circ> f x" |
|
14 |
||
15 |
lemma foldl_fold: |
|
16 |
"foldl f s xs = fold (\<lambda>x s. f s x) xs s" |
|
17 |
by (induct xs arbitrary: s) simp_all |
|
18 |
||
19 |
lemma foldr_fold_rev: |
|
20 |
"foldr f xs = fold f (rev xs)" |
|
39302
d7728f65b353
renamed lemmas: ext_iff -> fun_eq_iff, set_ext_iff -> set_eq_iff, set_ext -> set_eqI
nipkow
parents:
39198
diff
changeset
|
21 |
by (simp add: foldr_foldl foldl_fold fun_eq_iff) |
37025 | 22 |
|
23 |
lemma fold_rev_conv [code_unfold]: |
|
24 |
"fold f (rev xs) = foldr f xs" |
|
25 |
by (simp add: foldr_fold_rev) |
|
26 |
||
44013
5cfc1c36ae97
moved recdef package to HOL/Library/Old_Recdef.thy
krauss
parents:
42871
diff
changeset
|
27 |
lemma fold_cong [fundef_cong]: |
37025 | 28 |
"a = b \<Longrightarrow> xs = ys \<Longrightarrow> (\<And>x. x \<in> set xs \<Longrightarrow> f x = g x) |
29 |
\<Longrightarrow> fold f xs a = fold g ys b" |
|
30 |
by (induct ys arbitrary: a b xs) simp_all |
|
31 |
||
32 |
lemma fold_id: |
|
33 |
assumes "\<And>x. x \<in> set xs \<Longrightarrow> f x = id" |
|
34 |
shows "fold f xs = id" |
|
35 |
using assms by (induct xs) simp_all |
|
36 |
||
39921 | 37 |
lemma fold_commute: |
37025 | 38 |
assumes "\<And>x. x \<in> set xs \<Longrightarrow> h \<circ> g x = f x \<circ> h" |
39 |
shows "h \<circ> fold g xs = fold f xs \<circ> h" |
|
39302
d7728f65b353
renamed lemmas: ext_iff -> fun_eq_iff, set_ext_iff -> set_eq_iff, set_ext -> set_eqI
nipkow
parents:
39198
diff
changeset
|
40 |
using assms by (induct xs) (simp_all add: fun_eq_iff) |
37025 | 41 |
|
39921 | 42 |
lemma fold_commute_apply: |
43 |
assumes "\<And>x. x \<in> set xs \<Longrightarrow> h \<circ> g x = f x \<circ> h" |
|
44 |
shows "h (fold g xs s) = fold f xs (h s)" |
|
45 |
proof - |
|
46 |
from assms have "h \<circ> fold g xs = fold f xs \<circ> h" by (rule fold_commute) |
|
47 |
then show ?thesis by (simp add: fun_eq_iff) |
|
48 |
qed |
|
49 |
||
37025 | 50 |
lemma fold_invariant: |
51 |
assumes "\<And>x. x \<in> set xs \<Longrightarrow> Q x" and "P s" |
|
52 |
and "\<And>x s. Q x \<Longrightarrow> P s \<Longrightarrow> P (f x s)" |
|
53 |
shows "P (fold f xs s)" |
|
54 |
using assms by (induct xs arbitrary: s) simp_all |
|
55 |
||
56 |
lemma fold_weak_invariant: |
|
57 |
assumes "P s" |
|
58 |
and "\<And>s x. x \<in> set xs \<Longrightarrow> P s \<Longrightarrow> P (f x s)" |
|
59 |
shows "P (fold f xs s)" |
|
60 |
using assms by (induct xs arbitrary: s) simp_all |
|
61 |
||
62 |
lemma fold_append [simp]: |
|
63 |
"fold f (xs @ ys) = fold f ys \<circ> fold f xs" |
|
64 |
by (induct xs) simp_all |
|
65 |
||
66 |
lemma fold_map [code_unfold]: |
|
67 |
"fold g (map f xs) = fold (g o f) xs" |
|
68 |
by (induct xs) simp_all |
|
69 |
||
40949
1d46d893d682
lemmas fold_remove1_split and fold_multiset_equiv
haftmann
parents:
39921
diff
changeset
|
70 |
lemma fold_remove1_split: |
1d46d893d682
lemmas fold_remove1_split and fold_multiset_equiv
haftmann
parents:
39921
diff
changeset
|
71 |
assumes f: "\<And>x y. x \<in> set xs \<Longrightarrow> y \<in> set xs \<Longrightarrow> f x \<circ> f y = f y \<circ> f x" |
1d46d893d682
lemmas fold_remove1_split and fold_multiset_equiv
haftmann
parents:
39921
diff
changeset
|
72 |
and x: "x \<in> set xs" |
1d46d893d682
lemmas fold_remove1_split and fold_multiset_equiv
haftmann
parents:
39921
diff
changeset
|
73 |
shows "fold f xs = fold f (remove1 x xs) \<circ> f x" |
1d46d893d682
lemmas fold_remove1_split and fold_multiset_equiv
haftmann
parents:
39921
diff
changeset
|
74 |
using assms by (induct xs) (auto simp add: o_assoc [symmetric]) |
1d46d893d682
lemmas fold_remove1_split and fold_multiset_equiv
haftmann
parents:
39921
diff
changeset
|
75 |
|
37025 | 76 |
lemma fold_rev: |
77 |
assumes "\<And>x y. x \<in> set xs \<Longrightarrow> y \<in> set xs \<Longrightarrow> f y \<circ> f x = f x \<circ> f y" |
|
78 |
shows "fold f (rev xs) = fold f xs" |
|
45990
b7b905b23b2a
incorporated More_Set and More_List into the Main body -- to be consolidated later
haftmann
parents:
45973
diff
changeset
|
79 |
using assms by (induct xs) (simp_all add: fold_commute_apply fun_eq_iff) |
37025 | 80 |
|
81 |
lemma foldr_fold: |
|
82 |
assumes "\<And>x y. x \<in> set xs \<Longrightarrow> y \<in> set xs \<Longrightarrow> f y \<circ> f x = f x \<circ> f y" |
|
83 |
shows "foldr f xs = fold f xs" |
|
84 |
using assms unfolding foldr_fold_rev by (rule fold_rev) |
|
85 |
||
86 |
lemma fold_Cons_rev: |
|
87 |
"fold Cons xs = append (rev xs)" |
|
88 |
by (induct xs) simp_all |
|
89 |
||
90 |
lemma rev_conv_fold [code]: |
|
91 |
"rev xs = fold Cons xs []" |
|
92 |
by (simp add: fold_Cons_rev) |
|
93 |
||
94 |
lemma fold_append_concat_rev: |
|
95 |
"fold append xss = append (concat (rev xss))" |
|
96 |
by (induct xss) simp_all |
|
97 |
||
98 |
lemma concat_conv_foldr [code]: |
|
99 |
"concat xss = foldr append xss []" |
|
100 |
by (simp add: fold_append_concat_rev foldr_fold_rev) |
|
101 |
||
102 |
lemma fold_plus_listsum_rev: |
|
103 |
"fold plus xs = plus (listsum (rev xs))" |
|
104 |
by (induct xs) (simp_all add: add.assoc) |
|
105 |
||
39773 | 106 |
lemma (in monoid_add) listsum_conv_fold [code]: |
107 |
"listsum xs = fold (\<lambda>x y. y + x) xs 0" |
|
108 |
by (auto simp add: listsum_foldl foldl_fold fun_eq_iff) |
|
37025 | 109 |
|
39773 | 110 |
lemma (in linorder) sort_key_conv_fold: |
37025 | 111 |
assumes "inj_on f (set xs)" |
112 |
shows "sort_key f xs = fold (insort_key f) xs []" |
|
113 |
proof - |
|
114 |
have "fold (insort_key f) (rev xs) = fold (insort_key f) xs" |
|
115 |
proof (rule fold_rev, rule ext) |
|
116 |
fix zs |
|
117 |
fix x y |
|
118 |
assume "x \<in> set xs" "y \<in> set xs" |
|
119 |
with assms have *: "f y = f x \<Longrightarrow> y = x" by (auto dest: inj_onD) |
|
39773 | 120 |
have **: "x = y \<longleftrightarrow> y = x" by auto |
37025 | 121 |
show "(insort_key f y \<circ> insort_key f x) zs = (insort_key f x \<circ> insort_key f y) zs" |
39773 | 122 |
by (induct zs) (auto intro: * simp add: **) |
37025 | 123 |
qed |
124 |
then show ?thesis by (simp add: sort_key_def foldr_fold_rev) |
|
125 |
qed |
|
126 |
||
39773 | 127 |
lemma (in linorder) sort_conv_fold: |
37025 | 128 |
"sort xs = fold insort xs []" |
129 |
by (rule sort_key_conv_fold) simp |
|
130 |
||
45145 | 131 |
|
37025 | 132 |
text {* @{const Finite_Set.fold} and @{const fold} *} |
133 |
||
45990
b7b905b23b2a
incorporated More_Set and More_List into the Main body -- to be consolidated later
haftmann
parents:
45973
diff
changeset
|
134 |
lemma (in comp_fun_commute) fold_set_fold_remdups: |
37025 | 135 |
"Finite_Set.fold f y (set xs) = fold f (remdups xs) y" |
136 |
by (rule sym, induct xs arbitrary: y) (simp_all add: fold_fun_comm insert_absorb) |
|
137 |
||
45990
b7b905b23b2a
incorporated More_Set and More_List into the Main body -- to be consolidated later
haftmann
parents:
45973
diff
changeset
|
138 |
lemma (in comp_fun_idem) fold_set_fold: |
37025 | 139 |
"Finite_Set.fold f y (set xs) = fold f xs y" |
140 |
by (rule sym, induct xs arbitrary: y) (simp_all add: fold_fun_comm) |
|
141 |
||
45990
b7b905b23b2a
incorporated More_Set and More_List into the Main body -- to be consolidated later
haftmann
parents:
45973
diff
changeset
|
142 |
lemma (in ab_semigroup_idem_mult) fold1_set_fold: |
37025 | 143 |
assumes "xs \<noteq> []" |
144 |
shows "Finite_Set.fold1 times (set xs) = fold times (tl xs) (hd xs)" |
|
145 |
proof - |
|
42871
1c0b99f950d9
names of fold_set locales resemble name of characteristic property more closely
haftmann
parents:
40951
diff
changeset
|
146 |
interpret comp_fun_idem times by (fact comp_fun_idem) |
37025 | 147 |
from assms obtain y ys where xs: "xs = y # ys" |
148 |
by (cases xs) auto |
|
149 |
show ?thesis |
|
150 |
proof (cases "set ys = {}") |
|
151 |
case True with xs show ?thesis by simp |
|
152 |
next |
|
153 |
case False |
|
154 |
then have "fold1 times (insert y (set ys)) = Finite_Set.fold times y (set ys)" |
|
155 |
by (simp only: finite_set fold1_eq_fold_idem) |
|
45990
b7b905b23b2a
incorporated More_Set and More_List into the Main body -- to be consolidated later
haftmann
parents:
45973
diff
changeset
|
156 |
with xs show ?thesis by (simp add: fold_set_fold mult_commute) |
37025 | 157 |
qed |
158 |
qed |
|
159 |
||
160 |
lemma (in lattice) Inf_fin_set_fold: |
|
161 |
"Inf_fin (set (x # xs)) = fold inf xs x" |
|
162 |
proof - |
|
163 |
interpret ab_semigroup_idem_mult "inf :: 'a \<Rightarrow> 'a \<Rightarrow> 'a" |
|
164 |
by (fact ab_semigroup_idem_mult_inf) |
|
165 |
show ?thesis |
|
45990
b7b905b23b2a
incorporated More_Set and More_List into the Main body -- to be consolidated later
haftmann
parents:
45973
diff
changeset
|
166 |
by (simp add: Inf_fin_def fold1_set_fold del: set.simps) |
37025 | 167 |
qed |
168 |
||
169 |
lemma (in lattice) Inf_fin_set_foldr [code_unfold]: |
|
170 |
"Inf_fin (set (x # xs)) = foldr inf xs x" |
|
39302
d7728f65b353
renamed lemmas: ext_iff -> fun_eq_iff, set_ext_iff -> set_eq_iff, set_ext -> set_eqI
nipkow
parents:
39198
diff
changeset
|
171 |
by (simp add: Inf_fin_set_fold ac_simps foldr_fold fun_eq_iff del: set.simps) |
37025 | 172 |
|
173 |
lemma (in lattice) Sup_fin_set_fold: |
|
174 |
"Sup_fin (set (x # xs)) = fold sup xs x" |
|
175 |
proof - |
|
176 |
interpret ab_semigroup_idem_mult "sup :: 'a \<Rightarrow> 'a \<Rightarrow> 'a" |
|
177 |
by (fact ab_semigroup_idem_mult_sup) |
|
178 |
show ?thesis |
|
45990
b7b905b23b2a
incorporated More_Set and More_List into the Main body -- to be consolidated later
haftmann
parents:
45973
diff
changeset
|
179 |
by (simp add: Sup_fin_def fold1_set_fold del: set.simps) |
37025 | 180 |
qed |
181 |
||
182 |
lemma (in lattice) Sup_fin_set_foldr [code_unfold]: |
|
183 |
"Sup_fin (set (x # xs)) = foldr sup xs x" |
|
39302
d7728f65b353
renamed lemmas: ext_iff -> fun_eq_iff, set_ext_iff -> set_eq_iff, set_ext -> set_eqI
nipkow
parents:
39198
diff
changeset
|
184 |
by (simp add: Sup_fin_set_fold ac_simps foldr_fold fun_eq_iff del: set.simps) |
37025 | 185 |
|
186 |
lemma (in linorder) Min_fin_set_fold: |
|
187 |
"Min (set (x # xs)) = fold min xs x" |
|
188 |
proof - |
|
189 |
interpret ab_semigroup_idem_mult "min :: 'a \<Rightarrow> 'a \<Rightarrow> 'a" |
|
190 |
by (fact ab_semigroup_idem_mult_min) |
|
191 |
show ?thesis |
|
45990
b7b905b23b2a
incorporated More_Set and More_List into the Main body -- to be consolidated later
haftmann
parents:
45973
diff
changeset
|
192 |
by (simp add: Min_def fold1_set_fold del: set.simps) |
37025 | 193 |
qed |
194 |
||
195 |
lemma (in linorder) Min_fin_set_foldr [code_unfold]: |
|
196 |
"Min (set (x # xs)) = foldr min xs x" |
|
39302
d7728f65b353
renamed lemmas: ext_iff -> fun_eq_iff, set_ext_iff -> set_eq_iff, set_ext -> set_eqI
nipkow
parents:
39198
diff
changeset
|
197 |
by (simp add: Min_fin_set_fold ac_simps foldr_fold fun_eq_iff del: set.simps) |
37025 | 198 |
|
199 |
lemma (in linorder) Max_fin_set_fold: |
|
200 |
"Max (set (x # xs)) = fold max xs x" |
|
201 |
proof - |
|
202 |
interpret ab_semigroup_idem_mult "max :: 'a \<Rightarrow> 'a \<Rightarrow> 'a" |
|
203 |
by (fact ab_semigroup_idem_mult_max) |
|
204 |
show ?thesis |
|
45990
b7b905b23b2a
incorporated More_Set and More_List into the Main body -- to be consolidated later
haftmann
parents:
45973
diff
changeset
|
205 |
by (simp add: Max_def fold1_set_fold del: set.simps) |
37025 | 206 |
qed |
207 |
||
208 |
lemma (in linorder) Max_fin_set_foldr [code_unfold]: |
|
209 |
"Max (set (x # xs)) = foldr max xs x" |
|
39302
d7728f65b353
renamed lemmas: ext_iff -> fun_eq_iff, set_ext_iff -> set_eq_iff, set_ext -> set_eqI
nipkow
parents:
39198
diff
changeset
|
210 |
by (simp add: Max_fin_set_fold ac_simps foldr_fold fun_eq_iff del: set.simps) |
37025 | 211 |
|
212 |
lemma (in complete_lattice) Inf_set_fold: |
|
213 |
"Inf (set xs) = fold inf xs top" |
|
214 |
proof - |
|
42871
1c0b99f950d9
names of fold_set locales resemble name of characteristic property more closely
haftmann
parents:
40951
diff
changeset
|
215 |
interpret comp_fun_idem "inf :: 'a \<Rightarrow> 'a \<Rightarrow> 'a" |
1c0b99f950d9
names of fold_set locales resemble name of characteristic property more closely
haftmann
parents:
40951
diff
changeset
|
216 |
by (fact comp_fun_idem_inf) |
45990
b7b905b23b2a
incorporated More_Set and More_List into the Main body -- to be consolidated later
haftmann
parents:
45973
diff
changeset
|
217 |
show ?thesis by (simp add: Inf_fold_inf fold_set_fold inf_commute) |
37025 | 218 |
qed |
219 |
||
220 |
lemma (in complete_lattice) Inf_set_foldr [code_unfold]: |
|
221 |
"Inf (set xs) = foldr inf xs top" |
|
39302
d7728f65b353
renamed lemmas: ext_iff -> fun_eq_iff, set_ext_iff -> set_eq_iff, set_ext -> set_eqI
nipkow
parents:
39198
diff
changeset
|
222 |
by (simp add: Inf_set_fold ac_simps foldr_fold fun_eq_iff) |
37025 | 223 |
|
224 |
lemma (in complete_lattice) Sup_set_fold: |
|
225 |
"Sup (set xs) = fold sup xs bot" |
|
226 |
proof - |
|
42871
1c0b99f950d9
names of fold_set locales resemble name of characteristic property more closely
haftmann
parents:
40951
diff
changeset
|
227 |
interpret comp_fun_idem "sup :: 'a \<Rightarrow> 'a \<Rightarrow> 'a" |
1c0b99f950d9
names of fold_set locales resemble name of characteristic property more closely
haftmann
parents:
40951
diff
changeset
|
228 |
by (fact comp_fun_idem_sup) |
45993
3ca49a4bcc9f
dropped fact whose names clash with corresponding facts on canonical fold
haftmann
parents:
45990
diff
changeset
|
229 |
show ?thesis by (simp add: Sup_fold_sup fold_set_fold sup_commute) |
37025 | 230 |
qed |
231 |
||
232 |
lemma (in complete_lattice) Sup_set_foldr [code_unfold]: |
|
233 |
"Sup (set xs) = foldr sup xs bot" |
|
39302
d7728f65b353
renamed lemmas: ext_iff -> fun_eq_iff, set_ext_iff -> set_eq_iff, set_ext -> set_eqI
nipkow
parents:
39198
diff
changeset
|
234 |
by (simp add: Sup_set_fold ac_simps foldr_fold fun_eq_iff) |
37025 | 235 |
|
236 |
lemma (in complete_lattice) INFI_set_fold: |
|
237 |
"INFI (set xs) f = fold (inf \<circ> f) xs top" |
|
44928
7ef6505bde7f
renamed Complete_Lattices lemmas, removed legacy names
hoelzl
parents:
44013
diff
changeset
|
238 |
unfolding INF_def set_map [symmetric] Inf_set_fold fold_map .. |
37025 | 239 |
|
240 |
lemma (in complete_lattice) SUPR_set_fold: |
|
241 |
"SUPR (set xs) f = fold (sup \<circ> f) xs bot" |
|
44928
7ef6505bde7f
renamed Complete_Lattices lemmas, removed legacy names
hoelzl
parents:
44013
diff
changeset
|
242 |
unfolding SUP_def set_map [symmetric] Sup_set_fold fold_map .. |
37025 | 243 |
|
45145 | 244 |
|
37028 | 245 |
text {* @{text nth_map} *} |
37025 | 246 |
|
247 |
definition nth_map :: "nat \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> 'a list \<Rightarrow> 'a list" where |
|
248 |
"nth_map n f xs = (if n < length xs then |
|
249 |
take n xs @ [f (xs ! n)] @ drop (Suc n) xs |
|
250 |
else xs)" |
|
251 |
||
252 |
lemma nth_map_id: |
|
253 |
"n \<ge> length xs \<Longrightarrow> nth_map n f xs = xs" |
|
254 |
by (simp add: nth_map_def) |
|
255 |
||
256 |
lemma nth_map_unfold: |
|
257 |
"n < length xs \<Longrightarrow> nth_map n f xs = take n xs @ [f (xs ! n)] @ drop (Suc n) xs" |
|
258 |
by (simp add: nth_map_def) |
|
259 |
||
260 |
lemma nth_map_Nil [simp]: |
|
261 |
"nth_map n f [] = []" |
|
262 |
by (simp add: nth_map_def) |
|
263 |
||
264 |
lemma nth_map_zero [simp]: |
|
265 |
"nth_map 0 f (x # xs) = f x # xs" |
|
266 |
by (simp add: nth_map_def) |
|
267 |
||
268 |
lemma nth_map_Suc [simp]: |
|
269 |
"nth_map (Suc n) f (x # xs) = x # nth_map n f xs" |
|
270 |
by (simp add: nth_map_def) |
|
271 |
||
45145 | 272 |
|
273 |
text {* monad operation *} |
|
274 |
||
275 |
definition bind :: "'a list \<Rightarrow> ('a \<Rightarrow> 'b list) \<Rightarrow> 'b list" where |
|
276 |
"bind xs f = concat (map f xs)" |
|
277 |
||
278 |
lemma bind_simps [simp]: |
|
279 |
"bind [] f = []" |
|
280 |
"bind (x # xs) f = f x @ bind xs f" |
|
281 |
by (simp_all add: bind_def) |
|
282 |
||
37025 | 283 |
end |