src/HOL/Library/More_List.thy
author haftmann
Wed Sep 29 09:08:00 2010 +0200 (2010-09-29)
changeset 39778 9b1814140bcf
parent 39773 38852e989efa
child 39791 a91430778479
permissions -rw-r--r--
delete code lemma explicitly
haftmann@37025
     1
(*  Author:  Florian Haftmann, TU Muenchen *)
haftmann@37025
     2
haftmann@37025
     3
header {* Operations on lists beyond the standard List theory *}
haftmann@37025
     4
haftmann@37025
     5
theory More_List
haftmann@37025
     6
imports Main
haftmann@37025
     7
begin
haftmann@37025
     8
haftmann@37025
     9
hide_const (open) Finite_Set.fold
haftmann@37025
    10
haftmann@37025
    11
text {* Repairing code generator setup *}
haftmann@37025
    12
haftmann@37025
    13
declare (in lattice) Inf_fin_set_fold [code_unfold del]
haftmann@37025
    14
declare (in lattice) Sup_fin_set_fold [code_unfold del]
haftmann@37025
    15
declare (in linorder) Min_fin_set_fold [code_unfold del]
haftmann@37025
    16
declare (in linorder) Max_fin_set_fold [code_unfold del]
haftmann@37025
    17
declare (in complete_lattice) Inf_set_fold [code_unfold del]
haftmann@37025
    18
declare (in complete_lattice) Sup_set_fold [code_unfold del]
haftmann@37025
    19
haftmann@37025
    20
text {* Fold combinator with canonical argument order *}
haftmann@37025
    21
haftmann@37025
    22
primrec fold :: "('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'a list \<Rightarrow> 'b \<Rightarrow> 'b" where
haftmann@37025
    23
    "fold f [] = id"
haftmann@37025
    24
  | "fold f (x # xs) = fold f xs \<circ> f x"
haftmann@37025
    25
haftmann@37025
    26
lemma foldl_fold:
haftmann@37025
    27
  "foldl f s xs = fold (\<lambda>x s. f s x) xs s"
haftmann@37025
    28
  by (induct xs arbitrary: s) simp_all
haftmann@37025
    29
haftmann@37025
    30
lemma foldr_fold_rev:
haftmann@37025
    31
  "foldr f xs = fold f (rev xs)"
nipkow@39302
    32
  by (simp add: foldr_foldl foldl_fold fun_eq_iff)
haftmann@37025
    33
haftmann@37025
    34
lemma fold_rev_conv [code_unfold]:
haftmann@37025
    35
  "fold f (rev xs) = foldr f xs"
haftmann@37025
    36
  by (simp add: foldr_fold_rev)
haftmann@37025
    37
  
haftmann@37025
    38
lemma fold_cong [fundef_cong, recdef_cong]:
haftmann@37025
    39
  "a = b \<Longrightarrow> xs = ys \<Longrightarrow> (\<And>x. x \<in> set xs \<Longrightarrow> f x = g x)
haftmann@37025
    40
    \<Longrightarrow> fold f xs a = fold g ys b"
haftmann@37025
    41
  by (induct ys arbitrary: a b xs) simp_all
haftmann@37025
    42
haftmann@37025
    43
lemma fold_id:
haftmann@37025
    44
  assumes "\<And>x. x \<in> set xs \<Longrightarrow> f x = id"
haftmann@37025
    45
  shows "fold f xs = id"
haftmann@37025
    46
  using assms by (induct xs) simp_all
haftmann@37025
    47
haftmann@37025
    48
lemma fold_apply:
haftmann@37025
    49
  assumes "\<And>x. x \<in> set xs \<Longrightarrow> h \<circ> g x = f x \<circ> h"
haftmann@37025
    50
  shows "h \<circ> fold g xs = fold f xs \<circ> h"
nipkow@39302
    51
  using assms by (induct xs) (simp_all add: fun_eq_iff)
haftmann@37025
    52
haftmann@37025
    53
lemma fold_invariant: 
haftmann@37025
    54
  assumes "\<And>x. x \<in> set xs \<Longrightarrow> Q x" and "P s"
haftmann@37025
    55
    and "\<And>x s. Q x \<Longrightarrow> P s \<Longrightarrow> P (f x s)"
haftmann@37025
    56
  shows "P (fold f xs s)"
haftmann@37025
    57
  using assms by (induct xs arbitrary: s) simp_all
haftmann@37025
    58
haftmann@37025
    59
lemma fold_weak_invariant:
haftmann@37025
    60
  assumes "P s"
haftmann@37025
    61
    and "\<And>s x. x \<in> set xs \<Longrightarrow> P s \<Longrightarrow> P (f x s)"
haftmann@37025
    62
  shows "P (fold f xs s)"
haftmann@37025
    63
  using assms by (induct xs arbitrary: s) simp_all
haftmann@37025
    64
haftmann@37025
    65
lemma fold_append [simp]:
haftmann@37025
    66
  "fold f (xs @ ys) = fold f ys \<circ> fold f xs"
haftmann@37025
    67
  by (induct xs) simp_all
haftmann@37025
    68
haftmann@37025
    69
lemma fold_map [code_unfold]:
haftmann@37025
    70
  "fold g (map f xs) = fold (g o f) xs"
haftmann@37025
    71
  by (induct xs) simp_all
haftmann@37025
    72
haftmann@37025
    73
lemma fold_rev:
haftmann@37025
    74
  assumes "\<And>x y. x \<in> set xs \<Longrightarrow> y \<in> set xs \<Longrightarrow> f y \<circ> f x = f x \<circ> f y"
haftmann@37025
    75
  shows "fold f (rev xs) = fold f xs"
haftmann@37025
    76
  using assms by (induct xs) (simp_all del: o_apply add: fold_apply)
haftmann@37025
    77
haftmann@37025
    78
lemma foldr_fold:
haftmann@37025
    79
  assumes "\<And>x y. x \<in> set xs \<Longrightarrow> y \<in> set xs \<Longrightarrow> f y \<circ> f x = f x \<circ> f y"
haftmann@37025
    80
  shows "foldr f xs = fold f xs"
haftmann@37025
    81
  using assms unfolding foldr_fold_rev by (rule fold_rev)
haftmann@37025
    82
haftmann@37025
    83
lemma fold_Cons_rev:
haftmann@37025
    84
  "fold Cons xs = append (rev xs)"
haftmann@37025
    85
  by (induct xs) simp_all
haftmann@37025
    86
haftmann@37025
    87
lemma rev_conv_fold [code]:
haftmann@37025
    88
  "rev xs = fold Cons xs []"
haftmann@37025
    89
  by (simp add: fold_Cons_rev)
haftmann@37025
    90
haftmann@37025
    91
lemma fold_append_concat_rev:
haftmann@37025
    92
  "fold append xss = append (concat (rev xss))"
haftmann@37025
    93
  by (induct xss) simp_all
haftmann@37025
    94
haftmann@37025
    95
lemma concat_conv_foldr [code]:
haftmann@37025
    96
  "concat xss = foldr append xss []"
haftmann@37025
    97
  by (simp add: fold_append_concat_rev foldr_fold_rev)
haftmann@37025
    98
haftmann@37025
    99
lemma fold_plus_listsum_rev:
haftmann@37025
   100
  "fold plus xs = plus (listsum (rev xs))"
haftmann@37025
   101
  by (induct xs) (simp_all add: add.assoc)
haftmann@37025
   102
haftmann@39778
   103
declare listsum_foldl [code del]
haftmann@39778
   104
haftmann@39773
   105
lemma (in monoid_add) listsum_conv_fold [code]:
haftmann@39773
   106
  "listsum xs = fold (\<lambda>x y. y + x) xs 0"
haftmann@39773
   107
  by (auto simp add: listsum_foldl foldl_fold fun_eq_iff)
haftmann@37025
   108
haftmann@39773
   109
lemma (in linorder) sort_key_conv_fold:
haftmann@37025
   110
  assumes "inj_on f (set xs)"
haftmann@37025
   111
  shows "sort_key f xs = fold (insort_key f) xs []"
haftmann@37025
   112
proof -
haftmann@37025
   113
  have "fold (insort_key f) (rev xs) = fold (insort_key f) xs"
haftmann@37025
   114
  proof (rule fold_rev, rule ext)
haftmann@37025
   115
    fix zs
haftmann@37025
   116
    fix x y
haftmann@37025
   117
    assume "x \<in> set xs" "y \<in> set xs"
haftmann@37025
   118
    with assms have *: "f y = f x \<Longrightarrow> y = x" by (auto dest: inj_onD)
haftmann@39773
   119
    have **: "x = y \<longleftrightarrow> y = x" by auto
haftmann@37025
   120
    show "(insort_key f y \<circ> insort_key f x) zs = (insort_key f x \<circ> insort_key f y) zs"
haftmann@39773
   121
      by (induct zs) (auto intro: * simp add: **)
haftmann@37025
   122
  qed
haftmann@37025
   123
  then show ?thesis by (simp add: sort_key_def foldr_fold_rev)
haftmann@37025
   124
qed
haftmann@37025
   125
haftmann@39773
   126
lemma (in linorder) sort_conv_fold:
haftmann@37025
   127
  "sort xs = fold insort xs []"
haftmann@37025
   128
  by (rule sort_key_conv_fold) simp
haftmann@37025
   129
haftmann@37025
   130
text {* @{const Finite_Set.fold} and @{const fold} *}
haftmann@37025
   131
haftmann@37025
   132
lemma (in fun_left_comm) fold_set_remdups:
haftmann@37025
   133
  "Finite_Set.fold f y (set xs) = fold f (remdups xs) y"
haftmann@37025
   134
  by (rule sym, induct xs arbitrary: y) (simp_all add: fold_fun_comm insert_absorb)
haftmann@37025
   135
haftmann@37025
   136
lemma (in fun_left_comm_idem) fold_set:
haftmann@37025
   137
  "Finite_Set.fold f y (set xs) = fold f xs y"
haftmann@37025
   138
  by (rule sym, induct xs arbitrary: y) (simp_all add: fold_fun_comm)
haftmann@37025
   139
haftmann@37025
   140
lemma (in ab_semigroup_idem_mult) fold1_set:
haftmann@37025
   141
  assumes "xs \<noteq> []"
haftmann@37025
   142
  shows "Finite_Set.fold1 times (set xs) = fold times (tl xs) (hd xs)"
haftmann@37025
   143
proof -
haftmann@37025
   144
  interpret fun_left_comm_idem times by (fact fun_left_comm_idem)
haftmann@37025
   145
  from assms obtain y ys where xs: "xs = y # ys"
haftmann@37025
   146
    by (cases xs) auto
haftmann@37025
   147
  show ?thesis
haftmann@37025
   148
  proof (cases "set ys = {}")
haftmann@37025
   149
    case True with xs show ?thesis by simp
haftmann@37025
   150
  next
haftmann@37025
   151
    case False
haftmann@37025
   152
    then have "fold1 times (insert y (set ys)) = Finite_Set.fold times y (set ys)"
haftmann@37025
   153
      by (simp only: finite_set fold1_eq_fold_idem)
haftmann@37025
   154
    with xs show ?thesis by (simp add: fold_set mult_commute)
haftmann@37025
   155
  qed
haftmann@37025
   156
qed
haftmann@37025
   157
haftmann@37025
   158
lemma (in lattice) Inf_fin_set_fold:
haftmann@37025
   159
  "Inf_fin (set (x # xs)) = fold inf xs x"
haftmann@37025
   160
proof -
haftmann@37025
   161
  interpret ab_semigroup_idem_mult "inf :: 'a \<Rightarrow> 'a \<Rightarrow> 'a"
haftmann@37025
   162
    by (fact ab_semigroup_idem_mult_inf)
haftmann@37025
   163
  show ?thesis
haftmann@37025
   164
    by (simp add: Inf_fin_def fold1_set del: set.simps)
haftmann@37025
   165
qed
haftmann@37025
   166
haftmann@37025
   167
lemma (in lattice) Inf_fin_set_foldr [code_unfold]:
haftmann@37025
   168
  "Inf_fin (set (x # xs)) = foldr inf xs x"
nipkow@39302
   169
  by (simp add: Inf_fin_set_fold ac_simps foldr_fold fun_eq_iff del: set.simps)
haftmann@37025
   170
haftmann@37025
   171
lemma (in lattice) Sup_fin_set_fold:
haftmann@37025
   172
  "Sup_fin (set (x # xs)) = fold sup xs x"
haftmann@37025
   173
proof -
haftmann@37025
   174
  interpret ab_semigroup_idem_mult "sup :: 'a \<Rightarrow> 'a \<Rightarrow> 'a"
haftmann@37025
   175
    by (fact ab_semigroup_idem_mult_sup)
haftmann@37025
   176
  show ?thesis
haftmann@37025
   177
    by (simp add: Sup_fin_def fold1_set del: set.simps)
haftmann@37025
   178
qed
haftmann@37025
   179
haftmann@37025
   180
lemma (in lattice) Sup_fin_set_foldr [code_unfold]:
haftmann@37025
   181
  "Sup_fin (set (x # xs)) = foldr sup xs x"
nipkow@39302
   182
  by (simp add: Sup_fin_set_fold ac_simps foldr_fold fun_eq_iff del: set.simps)
haftmann@37025
   183
haftmann@37025
   184
lemma (in linorder) Min_fin_set_fold:
haftmann@37025
   185
  "Min (set (x # xs)) = fold min xs x"
haftmann@37025
   186
proof -
haftmann@37025
   187
  interpret ab_semigroup_idem_mult "min :: 'a \<Rightarrow> 'a \<Rightarrow> 'a"
haftmann@37025
   188
    by (fact ab_semigroup_idem_mult_min)
haftmann@37025
   189
  show ?thesis
haftmann@37025
   190
    by (simp add: Min_def fold1_set del: set.simps)
haftmann@37025
   191
qed
haftmann@37025
   192
haftmann@37025
   193
lemma (in linorder) Min_fin_set_foldr [code_unfold]:
haftmann@37025
   194
  "Min (set (x # xs)) = foldr min xs x"
nipkow@39302
   195
  by (simp add: Min_fin_set_fold ac_simps foldr_fold fun_eq_iff del: set.simps)
haftmann@37025
   196
haftmann@37025
   197
lemma (in linorder) Max_fin_set_fold:
haftmann@37025
   198
  "Max (set (x # xs)) = fold max xs x"
haftmann@37025
   199
proof -
haftmann@37025
   200
  interpret ab_semigroup_idem_mult "max :: 'a \<Rightarrow> 'a \<Rightarrow> 'a"
haftmann@37025
   201
    by (fact ab_semigroup_idem_mult_max)
haftmann@37025
   202
  show ?thesis
haftmann@37025
   203
    by (simp add: Max_def fold1_set del: set.simps)
haftmann@37025
   204
qed
haftmann@37025
   205
haftmann@37025
   206
lemma (in linorder) Max_fin_set_foldr [code_unfold]:
haftmann@37025
   207
  "Max (set (x # xs)) = foldr max xs x"
nipkow@39302
   208
  by (simp add: Max_fin_set_fold ac_simps foldr_fold fun_eq_iff del: set.simps)
haftmann@37025
   209
haftmann@37025
   210
lemma (in complete_lattice) Inf_set_fold:
haftmann@37025
   211
  "Inf (set xs) = fold inf xs top"
haftmann@37025
   212
proof -
haftmann@37025
   213
  interpret fun_left_comm_idem "inf :: 'a \<Rightarrow> 'a \<Rightarrow> 'a"
haftmann@37025
   214
    by (fact fun_left_comm_idem_inf)
haftmann@37025
   215
  show ?thesis by (simp add: Inf_fold_inf fold_set inf_commute)
haftmann@37025
   216
qed
haftmann@37025
   217
haftmann@37025
   218
lemma (in complete_lattice) Inf_set_foldr [code_unfold]:
haftmann@37025
   219
  "Inf (set xs) = foldr inf xs top"
nipkow@39302
   220
  by (simp add: Inf_set_fold ac_simps foldr_fold fun_eq_iff)
haftmann@37025
   221
haftmann@37025
   222
lemma (in complete_lattice) Sup_set_fold:
haftmann@37025
   223
  "Sup (set xs) = fold sup xs bot"
haftmann@37025
   224
proof -
haftmann@37025
   225
  interpret fun_left_comm_idem "sup :: 'a \<Rightarrow> 'a \<Rightarrow> 'a"
haftmann@37025
   226
    by (fact fun_left_comm_idem_sup)
haftmann@37025
   227
  show ?thesis by (simp add: Sup_fold_sup fold_set sup_commute)
haftmann@37025
   228
qed
haftmann@37025
   229
haftmann@37025
   230
lemma (in complete_lattice) Sup_set_foldr [code_unfold]:
haftmann@37025
   231
  "Sup (set xs) = foldr sup xs bot"
nipkow@39302
   232
  by (simp add: Sup_set_fold ac_simps foldr_fold fun_eq_iff)
haftmann@37025
   233
haftmann@37025
   234
lemma (in complete_lattice) INFI_set_fold:
haftmann@37025
   235
  "INFI (set xs) f = fold (inf \<circ> f) xs top"
haftmann@37025
   236
  unfolding INFI_def set_map [symmetric] Inf_set_fold fold_map ..
haftmann@37025
   237
haftmann@37025
   238
lemma (in complete_lattice) SUPR_set_fold:
haftmann@37025
   239
  "SUPR (set xs) f = fold (sup \<circ> f) xs bot"
haftmann@37025
   240
  unfolding SUPR_def set_map [symmetric] Sup_set_fold fold_map ..
haftmann@37025
   241
haftmann@37028
   242
text {* @{text nth_map} *}
haftmann@37025
   243
haftmann@37025
   244
definition nth_map :: "nat \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> 'a list \<Rightarrow> 'a list" where
haftmann@37025
   245
  "nth_map n f xs = (if n < length xs then
haftmann@37025
   246
       take n xs @ [f (xs ! n)] @ drop (Suc n) xs
haftmann@37025
   247
     else xs)"
haftmann@37025
   248
haftmann@37025
   249
lemma nth_map_id:
haftmann@37025
   250
  "n \<ge> length xs \<Longrightarrow> nth_map n f xs = xs"
haftmann@37025
   251
  by (simp add: nth_map_def)
haftmann@37025
   252
haftmann@37025
   253
lemma nth_map_unfold:
haftmann@37025
   254
  "n < length xs \<Longrightarrow> nth_map n f xs = take n xs @ [f (xs ! n)] @ drop (Suc n) xs"
haftmann@37025
   255
  by (simp add: nth_map_def)
haftmann@37025
   256
haftmann@37025
   257
lemma nth_map_Nil [simp]:
haftmann@37025
   258
  "nth_map n f [] = []"
haftmann@37025
   259
  by (simp add: nth_map_def)
haftmann@37025
   260
haftmann@37025
   261
lemma nth_map_zero [simp]:
haftmann@37025
   262
  "nth_map 0 f (x # xs) = f x # xs"
haftmann@37025
   263
  by (simp add: nth_map_def)
haftmann@37025
   264
haftmann@37025
   265
lemma nth_map_Suc [simp]:
haftmann@37025
   266
  "nth_map (Suc n) f (x # xs) = x # nth_map n f xs"
haftmann@37025
   267
  by (simp add: nth_map_def)
haftmann@37025
   268
haftmann@37025
   269
end