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