src/HOL/Library/More_List.thy
changeset 45990 b7b905b23b2a
parent 45989 b39256df5f8a
child 45991 3289ac99d714
     1.1 --- a/src/HOL/Library/More_List.thy	Mon Dec 26 22:17:10 2011 +0100
     1.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
     1.3 @@ -1,312 +0,0 @@
     1.4 -(* Author:  Florian Haftmann, TU Muenchen *)
     1.5 -
     1.6 -header {* Operations on lists beyond the standard List theory *}
     1.7 -
     1.8 -theory More_List
     1.9 -imports Main Multiset
    1.10 -begin
    1.11 -
    1.12 -hide_const (open) Finite_Set.fold
    1.13 -
    1.14 -text {* Repairing code generator setup *}
    1.15 -
    1.16 -declare (in lattice) Inf_fin_set_fold [code_unfold del]
    1.17 -declare (in lattice) Sup_fin_set_fold [code_unfold del]
    1.18 -declare (in linorder) Min_fin_set_fold [code_unfold del]
    1.19 -declare (in linorder) Max_fin_set_fold [code_unfold del]
    1.20 -declare (in complete_lattice) Inf_set_fold [code_unfold del]
    1.21 -declare (in complete_lattice) Sup_set_fold [code_unfold del]
    1.22 -
    1.23 -
    1.24 -text {* Fold combinator with canonical argument order *}
    1.25 -
    1.26 -primrec fold :: "('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'a list \<Rightarrow> 'b \<Rightarrow> 'b" where
    1.27 -    "fold f [] = id"
    1.28 -  | "fold f (x # xs) = fold f xs \<circ> f x"
    1.29 -
    1.30 -lemma foldl_fold:
    1.31 -  "foldl f s xs = fold (\<lambda>x s. f s x) xs s"
    1.32 -  by (induct xs arbitrary: s) simp_all
    1.33 -
    1.34 -lemma foldr_fold_rev:
    1.35 -  "foldr f xs = fold f (rev xs)"
    1.36 -  by (simp add: foldr_foldl foldl_fold fun_eq_iff)
    1.37 -
    1.38 -lemma fold_rev_conv [code_unfold]:
    1.39 -  "fold f (rev xs) = foldr f xs"
    1.40 -  by (simp add: foldr_fold_rev)
    1.41 -  
    1.42 -lemma fold_cong [fundef_cong]:
    1.43 -  "a = b \<Longrightarrow> xs = ys \<Longrightarrow> (\<And>x. x \<in> set xs \<Longrightarrow> f x = g x)
    1.44 -    \<Longrightarrow> fold f xs a = fold g ys b"
    1.45 -  by (induct ys arbitrary: a b xs) simp_all
    1.46 -
    1.47 -lemma fold_id:
    1.48 -  assumes "\<And>x. x \<in> set xs \<Longrightarrow> f x = id"
    1.49 -  shows "fold f xs = id"
    1.50 -  using assms by (induct xs) simp_all
    1.51 -
    1.52 -lemma fold_commute:
    1.53 -  assumes "\<And>x. x \<in> set xs \<Longrightarrow> h \<circ> g x = f x \<circ> h"
    1.54 -  shows "h \<circ> fold g xs = fold f xs \<circ> h"
    1.55 -  using assms by (induct xs) (simp_all add: fun_eq_iff)
    1.56 -
    1.57 -lemma fold_commute_apply:
    1.58 -  assumes "\<And>x. x \<in> set xs \<Longrightarrow> h \<circ> g x = f x \<circ> h"
    1.59 -  shows "h (fold g xs s) = fold f xs (h s)"
    1.60 -proof -
    1.61 -  from assms have "h \<circ> fold g xs = fold f xs \<circ> h" by (rule fold_commute)
    1.62 -  then show ?thesis by (simp add: fun_eq_iff)
    1.63 -qed
    1.64 -
    1.65 -lemma fold_invariant: 
    1.66 -  assumes "\<And>x. x \<in> set xs \<Longrightarrow> Q x" and "P s"
    1.67 -    and "\<And>x s. Q x \<Longrightarrow> P s \<Longrightarrow> P (f x s)"
    1.68 -  shows "P (fold f xs s)"
    1.69 -  using assms by (induct xs arbitrary: s) simp_all
    1.70 -
    1.71 -lemma fold_weak_invariant:
    1.72 -  assumes "P s"
    1.73 -    and "\<And>s x. x \<in> set xs \<Longrightarrow> P s \<Longrightarrow> P (f x s)"
    1.74 -  shows "P (fold f xs s)"
    1.75 -  using assms by (induct xs arbitrary: s) simp_all
    1.76 -
    1.77 -lemma fold_append [simp]:
    1.78 -  "fold f (xs @ ys) = fold f ys \<circ> fold f xs"
    1.79 -  by (induct xs) simp_all
    1.80 -
    1.81 -lemma fold_map [code_unfold]:
    1.82 -  "fold g (map f xs) = fold (g o f) xs"
    1.83 -  by (induct xs) simp_all
    1.84 -
    1.85 -lemma fold_remove1_split:
    1.86 -  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"
    1.87 -    and x: "x \<in> set xs"
    1.88 -  shows "fold f xs = fold f (remove1 x xs) \<circ> f x"
    1.89 -  using assms by (induct xs) (auto simp add: o_assoc [symmetric])
    1.90 -
    1.91 -lemma fold_multiset_equiv:
    1.92 -  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"
    1.93 -    and equiv: "multiset_of xs = multiset_of ys"
    1.94 -  shows "fold f xs = fold f ys"
    1.95 -using f equiv [symmetric] proof (induct xs arbitrary: ys)
    1.96 -  case Nil then show ?case by simp
    1.97 -next
    1.98 -  case (Cons x xs)
    1.99 -  then have *: "set ys = set (x # xs)" by (blast dest: multiset_of_eq_setD)
   1.100 -  have "\<And>x y. x \<in> set ys \<Longrightarrow> y \<in> set ys \<Longrightarrow> f x \<circ> f y = f y \<circ> f x" 
   1.101 -    by (rule Cons.prems(1)) (simp_all add: *)
   1.102 -  moreover from * have "x \<in> set ys" by simp
   1.103 -  ultimately have "fold f ys = fold f (remove1 x ys) \<circ> f x" by (fact fold_remove1_split)
   1.104 -  moreover from Cons.prems have "fold f xs = fold f (remove1 x ys)" by (auto intro: Cons.hyps)
   1.105 -  ultimately show ?case by simp
   1.106 -qed
   1.107 -
   1.108 -lemma fold_rev:
   1.109 -  assumes "\<And>x y. x \<in> set xs \<Longrightarrow> y \<in> set xs \<Longrightarrow> f y \<circ> f x = f x \<circ> f y"
   1.110 -  shows "fold f (rev xs) = fold f xs"
   1.111 -  by (rule fold_multiset_equiv, rule assms) (simp_all add: in_multiset_in_set)
   1.112 -
   1.113 -lemma foldr_fold:
   1.114 -  assumes "\<And>x y. x \<in> set xs \<Longrightarrow> y \<in> set xs \<Longrightarrow> f y \<circ> f x = f x \<circ> f y"
   1.115 -  shows "foldr f xs = fold f xs"
   1.116 -  using assms unfolding foldr_fold_rev by (rule fold_rev)
   1.117 -
   1.118 -lemma fold_Cons_rev:
   1.119 -  "fold Cons xs = append (rev xs)"
   1.120 -  by (induct xs) simp_all
   1.121 -
   1.122 -lemma rev_conv_fold [code]:
   1.123 -  "rev xs = fold Cons xs []"
   1.124 -  by (simp add: fold_Cons_rev)
   1.125 -
   1.126 -lemma fold_append_concat_rev:
   1.127 -  "fold append xss = append (concat (rev xss))"
   1.128 -  by (induct xss) simp_all
   1.129 -
   1.130 -lemma concat_conv_foldr [code]:
   1.131 -  "concat xss = foldr append xss []"
   1.132 -  by (simp add: fold_append_concat_rev foldr_fold_rev)
   1.133 -
   1.134 -lemma fold_plus_listsum_rev:
   1.135 -  "fold plus xs = plus (listsum (rev xs))"
   1.136 -  by (induct xs) (simp_all add: add.assoc)
   1.137 -
   1.138 -lemma (in monoid_add) listsum_conv_fold [code]:
   1.139 -  "listsum xs = fold (\<lambda>x y. y + x) xs 0"
   1.140 -  by (auto simp add: listsum_foldl foldl_fold fun_eq_iff)
   1.141 -
   1.142 -lemma (in linorder) sort_key_conv_fold:
   1.143 -  assumes "inj_on f (set xs)"
   1.144 -  shows "sort_key f xs = fold (insort_key f) xs []"
   1.145 -proof -
   1.146 -  have "fold (insort_key f) (rev xs) = fold (insort_key f) xs"
   1.147 -  proof (rule fold_rev, rule ext)
   1.148 -    fix zs
   1.149 -    fix x y
   1.150 -    assume "x \<in> set xs" "y \<in> set xs"
   1.151 -    with assms have *: "f y = f x \<Longrightarrow> y = x" by (auto dest: inj_onD)
   1.152 -    have **: "x = y \<longleftrightarrow> y = x" by auto
   1.153 -    show "(insort_key f y \<circ> insort_key f x) zs = (insort_key f x \<circ> insort_key f y) zs"
   1.154 -      by (induct zs) (auto intro: * simp add: **)
   1.155 -  qed
   1.156 -  then show ?thesis by (simp add: sort_key_def foldr_fold_rev)
   1.157 -qed
   1.158 -
   1.159 -lemma (in linorder) sort_conv_fold:
   1.160 -  "sort xs = fold insort xs []"
   1.161 -  by (rule sort_key_conv_fold) simp
   1.162 -
   1.163 -
   1.164 -text {* @{const Finite_Set.fold} and @{const fold} *}
   1.165 -
   1.166 -lemma (in comp_fun_commute) fold_set_remdups:
   1.167 -  "Finite_Set.fold f y (set xs) = fold f (remdups xs) y"
   1.168 -  by (rule sym, induct xs arbitrary: y) (simp_all add: fold_fun_comm insert_absorb)
   1.169 -
   1.170 -lemma (in comp_fun_idem) fold_set:
   1.171 -  "Finite_Set.fold f y (set xs) = fold f xs y"
   1.172 -  by (rule sym, induct xs arbitrary: y) (simp_all add: fold_fun_comm)
   1.173 -
   1.174 -lemma (in ab_semigroup_idem_mult) fold1_set:
   1.175 -  assumes "xs \<noteq> []"
   1.176 -  shows "Finite_Set.fold1 times (set xs) = fold times (tl xs) (hd xs)"
   1.177 -proof -
   1.178 -  interpret comp_fun_idem times by (fact comp_fun_idem)
   1.179 -  from assms obtain y ys where xs: "xs = y # ys"
   1.180 -    by (cases xs) auto
   1.181 -  show ?thesis
   1.182 -  proof (cases "set ys = {}")
   1.183 -    case True with xs show ?thesis by simp
   1.184 -  next
   1.185 -    case False
   1.186 -    then have "fold1 times (insert y (set ys)) = Finite_Set.fold times y (set ys)"
   1.187 -      by (simp only: finite_set fold1_eq_fold_idem)
   1.188 -    with xs show ?thesis by (simp add: fold_set mult_commute)
   1.189 -  qed
   1.190 -qed
   1.191 -
   1.192 -lemma (in lattice) Inf_fin_set_fold:
   1.193 -  "Inf_fin (set (x # xs)) = fold inf xs x"
   1.194 -proof -
   1.195 -  interpret ab_semigroup_idem_mult "inf :: 'a \<Rightarrow> 'a \<Rightarrow> 'a"
   1.196 -    by (fact ab_semigroup_idem_mult_inf)
   1.197 -  show ?thesis
   1.198 -    by (simp add: Inf_fin_def fold1_set del: set.simps)
   1.199 -qed
   1.200 -
   1.201 -lemma (in lattice) Inf_fin_set_foldr [code_unfold]:
   1.202 -  "Inf_fin (set (x # xs)) = foldr inf xs x"
   1.203 -  by (simp add: Inf_fin_set_fold ac_simps foldr_fold fun_eq_iff del: set.simps)
   1.204 -
   1.205 -lemma (in lattice) Sup_fin_set_fold:
   1.206 -  "Sup_fin (set (x # xs)) = fold sup xs x"
   1.207 -proof -
   1.208 -  interpret ab_semigroup_idem_mult "sup :: 'a \<Rightarrow> 'a \<Rightarrow> 'a"
   1.209 -    by (fact ab_semigroup_idem_mult_sup)
   1.210 -  show ?thesis
   1.211 -    by (simp add: Sup_fin_def fold1_set del: set.simps)
   1.212 -qed
   1.213 -
   1.214 -lemma (in lattice) Sup_fin_set_foldr [code_unfold]:
   1.215 -  "Sup_fin (set (x # xs)) = foldr sup xs x"
   1.216 -  by (simp add: Sup_fin_set_fold ac_simps foldr_fold fun_eq_iff del: set.simps)
   1.217 -
   1.218 -lemma (in linorder) Min_fin_set_fold:
   1.219 -  "Min (set (x # xs)) = fold min xs x"
   1.220 -proof -
   1.221 -  interpret ab_semigroup_idem_mult "min :: 'a \<Rightarrow> 'a \<Rightarrow> 'a"
   1.222 -    by (fact ab_semigroup_idem_mult_min)
   1.223 -  show ?thesis
   1.224 -    by (simp add: Min_def fold1_set del: set.simps)
   1.225 -qed
   1.226 -
   1.227 -lemma (in linorder) Min_fin_set_foldr [code_unfold]:
   1.228 -  "Min (set (x # xs)) = foldr min xs x"
   1.229 -  by (simp add: Min_fin_set_fold ac_simps foldr_fold fun_eq_iff del: set.simps)
   1.230 -
   1.231 -lemma (in linorder) Max_fin_set_fold:
   1.232 -  "Max (set (x # xs)) = fold max xs x"
   1.233 -proof -
   1.234 -  interpret ab_semigroup_idem_mult "max :: 'a \<Rightarrow> 'a \<Rightarrow> 'a"
   1.235 -    by (fact ab_semigroup_idem_mult_max)
   1.236 -  show ?thesis
   1.237 -    by (simp add: Max_def fold1_set del: set.simps)
   1.238 -qed
   1.239 -
   1.240 -lemma (in linorder) Max_fin_set_foldr [code_unfold]:
   1.241 -  "Max (set (x # xs)) = foldr max xs x"
   1.242 -  by (simp add: Max_fin_set_fold ac_simps foldr_fold fun_eq_iff del: set.simps)
   1.243 -
   1.244 -lemma (in complete_lattice) Inf_set_fold:
   1.245 -  "Inf (set xs) = fold inf xs top"
   1.246 -proof -
   1.247 -  interpret comp_fun_idem "inf :: 'a \<Rightarrow> 'a \<Rightarrow> 'a"
   1.248 -    by (fact comp_fun_idem_inf)
   1.249 -  show ?thesis by (simp add: Inf_fold_inf fold_set inf_commute)
   1.250 -qed
   1.251 -
   1.252 -lemma (in complete_lattice) Inf_set_foldr [code_unfold]:
   1.253 -  "Inf (set xs) = foldr inf xs top"
   1.254 -  by (simp add: Inf_set_fold ac_simps foldr_fold fun_eq_iff)
   1.255 -
   1.256 -lemma (in complete_lattice) Sup_set_fold:
   1.257 -  "Sup (set xs) = fold sup xs bot"
   1.258 -proof -
   1.259 -  interpret comp_fun_idem "sup :: 'a \<Rightarrow> 'a \<Rightarrow> 'a"
   1.260 -    by (fact comp_fun_idem_sup)
   1.261 -  show ?thesis by (simp add: Sup_fold_sup fold_set sup_commute)
   1.262 -qed
   1.263 -
   1.264 -lemma (in complete_lattice) Sup_set_foldr [code_unfold]:
   1.265 -  "Sup (set xs) = foldr sup xs bot"
   1.266 -  by (simp add: Sup_set_fold ac_simps foldr_fold fun_eq_iff)
   1.267 -
   1.268 -lemma (in complete_lattice) INFI_set_fold:
   1.269 -  "INFI (set xs) f = fold (inf \<circ> f) xs top"
   1.270 -  unfolding INF_def set_map [symmetric] Inf_set_fold fold_map ..
   1.271 -
   1.272 -lemma (in complete_lattice) SUPR_set_fold:
   1.273 -  "SUPR (set xs) f = fold (sup \<circ> f) xs bot"
   1.274 -  unfolding SUP_def set_map [symmetric] Sup_set_fold fold_map ..
   1.275 -
   1.276 -
   1.277 -text {* @{text nth_map} *}
   1.278 -
   1.279 -definition nth_map :: "nat \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> 'a list \<Rightarrow> 'a list" where
   1.280 -  "nth_map n f xs = (if n < length xs then
   1.281 -       take n xs @ [f (xs ! n)] @ drop (Suc n) xs
   1.282 -     else xs)"
   1.283 -
   1.284 -lemma nth_map_id:
   1.285 -  "n \<ge> length xs \<Longrightarrow> nth_map n f xs = xs"
   1.286 -  by (simp add: nth_map_def)
   1.287 -
   1.288 -lemma nth_map_unfold:
   1.289 -  "n < length xs \<Longrightarrow> nth_map n f xs = take n xs @ [f (xs ! n)] @ drop (Suc n) xs"
   1.290 -  by (simp add: nth_map_def)
   1.291 -
   1.292 -lemma nth_map_Nil [simp]:
   1.293 -  "nth_map n f [] = []"
   1.294 -  by (simp add: nth_map_def)
   1.295 -
   1.296 -lemma nth_map_zero [simp]:
   1.297 -  "nth_map 0 f (x # xs) = f x # xs"
   1.298 -  by (simp add: nth_map_def)
   1.299 -
   1.300 -lemma nth_map_Suc [simp]:
   1.301 -  "nth_map (Suc n) f (x # xs) = x # nth_map n f xs"
   1.302 -  by (simp add: nth_map_def)
   1.303 -
   1.304 -
   1.305 -text {* monad operation *}
   1.306 -
   1.307 -definition bind :: "'a list \<Rightarrow> ('a \<Rightarrow> 'b list) \<Rightarrow> 'b list" where
   1.308 -  "bind xs f = concat (map f xs)"
   1.309 -
   1.310 -lemma bind_simps [simp]:
   1.311 -  "bind [] f = []"
   1.312 -  "bind (x # xs) f = f x @ bind xs f"
   1.313 -  by (simp_all add: bind_def)
   1.314 -
   1.315 -end