src/HOL/Library/Executable_Set.thy
author haftmann
Thu Mar 05 08:23:11 2009 +0100 (2009-03-05)
changeset 30304 d8e4cd2ac2a1
parent 29110 476c46e99ada
child 30664 167da873c3b3
permissions -rw-r--r--
set operations Int, Un, INTER, UNION, Inter, Union, empty, UNIV are now proper qualified constants with authentic syntax
haftmann@23854
     1
(*  Title:      HOL/Library/Executable_Set.thy
haftmann@23854
     2
    ID:         $Id$
haftmann@23854
     3
    Author:     Stefan Berghofer, TU Muenchen
haftmann@23854
     4
*)
haftmann@23854
     5
haftmann@23854
     6
header {* Implementation of finite sets by lists *}
haftmann@23854
     7
haftmann@23854
     8
theory Executable_Set
haftmann@27487
     9
imports Plain "~~/src/HOL/List"
haftmann@23854
    10
begin
haftmann@23854
    11
haftmann@23854
    12
subsection {* Definitional rewrites *}
haftmann@23854
    13
haftmann@28522
    14
definition subset :: "'a set \<Rightarrow> 'a set \<Rightarrow> bool" where
haftmann@28522
    15
  "subset = op \<le>"
haftmann@28522
    16
haftmann@28522
    17
declare subset_def [symmetric, code unfold]
haftmann@28522
    18
haftmann@28939
    19
lemma [code]: "subset A B \<longleftrightarrow> (\<forall>x\<in>A. x \<in> B)"
haftmann@28522
    20
  unfolding subset_def subset_eq ..
haftmann@23854
    21
haftmann@28522
    22
definition is_empty :: "'a set \<Rightarrow> bool" where
haftmann@28522
    23
  "is_empty A \<longleftrightarrow> A = {}"
haftmann@28522
    24
haftmann@28522
    25
definition eq_set :: "'a set \<Rightarrow> 'a set \<Rightarrow> bool" where
haftmann@28522
    26
  [code del]: "eq_set = op ="
haftmann@28522
    27
haftmann@28522
    28
lemma [code]: "eq_set A B \<longleftrightarrow> A \<subseteq> B \<and> B \<subseteq> A"
haftmann@28522
    29
  unfolding eq_set_def by auto
berghofe@26816
    30
nipkow@29107
    31
(* FIXME allow for Stefan's code generator:
nipkow@29107
    32
declare set_eq_subset[code unfold]
nipkow@29107
    33
*)
nipkow@29107
    34
haftmann@23854
    35
lemma [code]:
haftmann@23854
    36
  "a \<in> A \<longleftrightarrow> (\<exists>x\<in>A. x = a)"
haftmann@23854
    37
  unfolding bex_triv_one_point1 ..
haftmann@23854
    38
haftmann@28939
    39
definition filter_set :: "('a \<Rightarrow> bool) \<Rightarrow> 'a set \<Rightarrow> 'a set" where
haftmann@23854
    40
  "filter_set P xs = {x\<in>xs. P x}"
haftmann@23854
    41
nipkow@29107
    42
declare filter_set_def[symmetric, code unfold] 
nipkow@29107
    43
haftmann@23854
    44
haftmann@23854
    45
subsection {* Operations on lists *}
haftmann@23854
    46
haftmann@23854
    47
subsubsection {* Basic definitions *}
haftmann@23854
    48
haftmann@23854
    49
definition
haftmann@23854
    50
  flip :: "('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> 'b \<Rightarrow> 'a \<Rightarrow> 'c" where
haftmann@23854
    51
  "flip f a b = f b a"
haftmann@23854
    52
haftmann@23854
    53
definition
haftmann@23854
    54
  member :: "'a list \<Rightarrow> 'a \<Rightarrow> bool" where
haftmann@23854
    55
  "member xs x \<longleftrightarrow> x \<in> set xs"
haftmann@23854
    56
haftmann@23854
    57
definition
haftmann@23854
    58
  insertl :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
haftmann@23854
    59
  "insertl x xs = (if member xs x then xs else x#xs)"
haftmann@23854
    60
haftmann@23854
    61
lemma [code target: List]: "member [] y \<longleftrightarrow> False"
haftmann@23854
    62
  and [code target: List]: "member (x#xs) y \<longleftrightarrow> y = x \<or> member xs y"
haftmann@23854
    63
  unfolding member_def by (induct xs) simp_all
haftmann@23854
    64
haftmann@23854
    65
fun
haftmann@23854
    66
  drop_first :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list" where
haftmann@23854
    67
  "drop_first f [] = []"
haftmann@23854
    68
| "drop_first f (x#xs) = (if f x then xs else x # drop_first f xs)"
haftmann@23854
    69
declare drop_first.simps [code del]
haftmann@23854
    70
declare drop_first.simps [code target: List]
haftmann@23854
    71
haftmann@23854
    72
declare remove1.simps [code del]
haftmann@23854
    73
lemma [code target: List]:
haftmann@23854
    74
  "remove1 x xs = (if member xs x then drop_first (\<lambda>y. y = x) xs else xs)"
haftmann@23854
    75
proof (cases "member xs x")
haftmann@23854
    76
  case False thus ?thesis unfolding member_def by (induct xs) auto
haftmann@23854
    77
next
haftmann@23854
    78
  case True
haftmann@23854
    79
  have "remove1 x xs = drop_first (\<lambda>y. y = x) xs" by (induct xs) simp_all
haftmann@23854
    80
  with True show ?thesis by simp
haftmann@23854
    81
qed
haftmann@23854
    82
haftmann@23854
    83
lemma member_nil [simp]:
haftmann@23854
    84
  "member [] = (\<lambda>x. False)"
berghofe@26816
    85
proof (rule ext)
haftmann@23854
    86
  fix x
haftmann@23854
    87
  show "member [] x = False" unfolding member_def by simp
haftmann@23854
    88
qed
haftmann@23854
    89
haftmann@23854
    90
lemma member_insertl [simp]:
haftmann@23854
    91
  "x \<in> set (insertl x xs)"
haftmann@23854
    92
  unfolding insertl_def member_def mem_iff by simp
haftmann@23854
    93
haftmann@23854
    94
lemma insertl_member [simp]:
haftmann@23854
    95
  fixes xs x
haftmann@23854
    96
  assumes member: "member xs x"
haftmann@23854
    97
  shows "insertl x xs = xs"
haftmann@23854
    98
  using member unfolding insertl_def by simp
haftmann@23854
    99
haftmann@23854
   100
lemma insertl_not_member [simp]:
haftmann@23854
   101
  fixes xs x
haftmann@23854
   102
  assumes member: "\<not> (member xs x)"
haftmann@23854
   103
  shows "insertl x xs = x # xs"
haftmann@23854
   104
  using member unfolding insertl_def by simp
haftmann@23854
   105
haftmann@23854
   106
lemma foldr_remove1_empty [simp]:
haftmann@23854
   107
  "foldr remove1 xs [] = []"
haftmann@23854
   108
  by (induct xs) simp_all
haftmann@23854
   109
haftmann@23854
   110
haftmann@23854
   111
subsubsection {* Derived definitions *}
haftmann@23854
   112
haftmann@23854
   113
function unionl :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list"
haftmann@23854
   114
where
haftmann@23854
   115
  "unionl [] ys = ys"
haftmann@23854
   116
| "unionl xs ys = foldr insertl xs ys"
haftmann@23854
   117
by pat_completeness auto
haftmann@23854
   118
termination by lexicographic_order
haftmann@23854
   119
wenzelm@26312
   120
lemmas unionl_eq = unionl.simps(2)
haftmann@23854
   121
haftmann@23854
   122
function intersect :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list"
haftmann@23854
   123
where
haftmann@23854
   124
  "intersect [] ys = []"
haftmann@23854
   125
| "intersect xs [] = []"
haftmann@23854
   126
| "intersect xs ys = filter (member xs) ys"
haftmann@23854
   127
by pat_completeness auto
haftmann@23854
   128
termination by lexicographic_order
haftmann@23854
   129
wenzelm@26312
   130
lemmas intersect_eq = intersect.simps(3)
haftmann@23854
   131
haftmann@23854
   132
function subtract :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list"
haftmann@23854
   133
where
haftmann@23854
   134
  "subtract [] ys = ys"
haftmann@23854
   135
| "subtract xs [] = []"
haftmann@23854
   136
| "subtract xs ys = foldr remove1 xs ys"
haftmann@23854
   137
by pat_completeness auto
haftmann@23854
   138
termination by lexicographic_order
haftmann@23854
   139
wenzelm@26312
   140
lemmas subtract_eq = subtract.simps(3)
haftmann@23854
   141
haftmann@23854
   142
function map_distinct :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a list \<Rightarrow> 'b list"
haftmann@23854
   143
where
haftmann@23854
   144
  "map_distinct f [] = []"
haftmann@23854
   145
| "map_distinct f xs = foldr (insertl o f) xs []"
haftmann@23854
   146
by pat_completeness auto
haftmann@23854
   147
termination by lexicographic_order
haftmann@23854
   148
wenzelm@26312
   149
lemmas map_distinct_eq = map_distinct.simps(2)
haftmann@23854
   150
haftmann@23854
   151
function unions :: "'a list list \<Rightarrow> 'a list"
haftmann@23854
   152
where
haftmann@23854
   153
  "unions [] = []"
haftmann@23854
   154
| "unions xs = foldr unionl xs []"
haftmann@23854
   155
by pat_completeness auto
haftmann@23854
   156
termination by lexicographic_order
haftmann@23854
   157
wenzelm@26312
   158
lemmas unions_eq = unions.simps(2)
haftmann@23854
   159
haftmann@23854
   160
consts intersects :: "'a list list \<Rightarrow> 'a list"
haftmann@23854
   161
primrec
haftmann@23854
   162
  "intersects (x#xs) = foldr intersect xs x"
haftmann@23854
   163
haftmann@23854
   164
definition
haftmann@23854
   165
  map_union :: "'a list \<Rightarrow> ('a \<Rightarrow> 'b list) \<Rightarrow> 'b list" where
haftmann@23854
   166
  "map_union xs f = unions (map f xs)"
haftmann@23854
   167
haftmann@23854
   168
definition
haftmann@23854
   169
  map_inter :: "'a list \<Rightarrow> ('a \<Rightarrow> 'b list) \<Rightarrow> 'b list" where
haftmann@23854
   170
  "map_inter xs f = intersects (map f xs)"
haftmann@23854
   171
haftmann@23854
   172
haftmann@23854
   173
subsection {* Isomorphism proofs *}
haftmann@23854
   174
haftmann@23854
   175
lemma iso_member:
haftmann@23854
   176
  "member xs x \<longleftrightarrow> x \<in> set xs"
haftmann@23854
   177
  unfolding member_def mem_iff ..
haftmann@23854
   178
haftmann@23854
   179
lemma iso_insert:
haftmann@23854
   180
  "set (insertl x xs) = insert x (set xs)"
haftmann@30304
   181
  unfolding insertl_def iso_member by (simp add: insert_absorb)
haftmann@23854
   182
haftmann@23854
   183
lemma iso_remove1:
haftmann@23854
   184
  assumes distnct: "distinct xs"
haftmann@23854
   185
  shows "set (remove1 x xs) = set xs - {x}"
haftmann@23854
   186
  using distnct set_remove1_eq by auto
haftmann@23854
   187
haftmann@23854
   188
lemma iso_union:
haftmann@23854
   189
  "set (unionl xs ys) = set xs \<union> set ys"
wenzelm@26312
   190
  unfolding unionl_eq
haftmann@23854
   191
  by (induct xs arbitrary: ys) (simp_all add: iso_insert)
haftmann@23854
   192
haftmann@23854
   193
lemma iso_intersect:
haftmann@23854
   194
  "set (intersect xs ys) = set xs \<inter> set ys"
wenzelm@26312
   195
  unfolding intersect_eq Int_def by (simp add: Int_def iso_member) auto
haftmann@23854
   196
haftmann@23854
   197
definition
haftmann@23854
   198
  subtract' :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
haftmann@23854
   199
  "subtract' = flip subtract"
haftmann@23854
   200
haftmann@23854
   201
lemma iso_subtract:
haftmann@23854
   202
  fixes ys
haftmann@23854
   203
  assumes distnct: "distinct ys"
haftmann@23854
   204
  shows "set (subtract' ys xs) = set ys - set xs"
haftmann@23854
   205
    and "distinct (subtract' ys xs)"
wenzelm@26312
   206
  unfolding subtract'_def flip_def subtract_eq
haftmann@23854
   207
  using distnct by (induct xs arbitrary: ys) auto
haftmann@23854
   208
haftmann@23854
   209
lemma iso_map_distinct:
haftmann@23854
   210
  "set (map_distinct f xs) = image f (set xs)"
wenzelm@26312
   211
  unfolding map_distinct_eq by (induct xs) (simp_all add: iso_insert)
haftmann@23854
   212
haftmann@23854
   213
lemma iso_unions:
haftmann@23854
   214
  "set (unions xss) = \<Union> set (map set xss)"
wenzelm@26312
   215
  unfolding unions_eq
haftmann@23854
   216
proof (induct xss)
haftmann@23854
   217
  case Nil show ?case by simp
haftmann@23854
   218
next
haftmann@23854
   219
  case (Cons xs xss) thus ?case by (induct xs) (simp_all add: iso_insert)
haftmann@23854
   220
qed
haftmann@23854
   221
haftmann@23854
   222
lemma iso_intersects:
haftmann@23854
   223
  "set (intersects (xs#xss)) = \<Inter> set (map set (xs#xss))"
haftmann@23854
   224
  by (induct xss) (simp_all add: Int_def iso_member, auto)
haftmann@23854
   225
haftmann@23854
   226
lemma iso_UNION:
haftmann@23854
   227
  "set (map_union xs f) = UNION (set xs) (set o f)"
haftmann@23854
   228
  unfolding map_union_def iso_unions by simp
haftmann@23854
   229
haftmann@23854
   230
lemma iso_INTER:
haftmann@23854
   231
  "set (map_inter (x#xs) f) = INTER (set (x#xs)) (set o f)"
haftmann@23854
   232
  unfolding map_inter_def iso_intersects by (induct xs) (simp_all add: iso_member, auto)
haftmann@23854
   233
haftmann@23854
   234
definition
haftmann@23854
   235
  Blall :: "'a list \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> bool" where
haftmann@23854
   236
  "Blall = flip list_all"
haftmann@23854
   237
definition
haftmann@23854
   238
  Blex :: "'a list \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> bool" where
haftmann@23854
   239
  "Blex = flip list_ex"
haftmann@23854
   240
haftmann@23854
   241
lemma iso_Ball:
haftmann@23854
   242
  "Blall xs f = Ball (set xs) f"
haftmann@23854
   243
  unfolding Blall_def flip_def by (induct xs) simp_all
haftmann@23854
   244
haftmann@23854
   245
lemma iso_Bex:
haftmann@23854
   246
  "Blex xs f = Bex (set xs) f"
haftmann@23854
   247
  unfolding Blex_def flip_def by (induct xs) simp_all
haftmann@23854
   248
haftmann@23854
   249
lemma iso_filter:
haftmann@23854
   250
  "set (filter P xs) = filter_set P (set xs)"
haftmann@23854
   251
  unfolding filter_set_def by (induct xs) auto
haftmann@23854
   252
haftmann@23854
   253
subsection {* code generator setup *}
haftmann@23854
   254
haftmann@23854
   255
ML {*
haftmann@23854
   256
nonfix inter;
haftmann@23854
   257
nonfix union;
haftmann@23854
   258
nonfix subset;
haftmann@23854
   259
*}
haftmann@23854
   260
haftmann@23854
   261
subsubsection {* const serializations *}
haftmann@23854
   262
haftmann@23854
   263
consts_code
haftmann@30304
   264
  "Set.empty" ("{*[]*}")
haftmann@23854
   265
  insert ("{*insertl*}")
haftmann@28522
   266
  is_empty ("{*null*}")
haftmann@23854
   267
  "op \<union>" ("{*unionl*}")
haftmann@23854
   268
  "op \<inter>" ("{*intersect*}")
haftmann@23854
   269
  "op - \<Colon> 'a set \<Rightarrow> 'a set \<Rightarrow> 'a set" ("{* flip subtract *}")
haftmann@23854
   270
  image ("{*map_distinct*}")
haftmann@23854
   271
  Union ("{*unions*}")
haftmann@23854
   272
  Inter ("{*intersects*}")
haftmann@23854
   273
  UNION ("{*map_union*}")
haftmann@23854
   274
  INTER ("{*map_inter*}")
haftmann@23854
   275
  Ball ("{*Blall*}")
haftmann@23854
   276
  Bex ("{*Blex*}")
haftmann@23854
   277
  filter_set ("{*filter*}")
nipkow@29110
   278
  fold ("{* foldl o flip *}")
haftmann@23854
   279
haftmann@23854
   280
end