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