src/HOL/Library/Countable.thy
author haftmann
Tue Feb 03 21:26:21 2009 +0100 (2009-02-03)
changeset 29797 08ef36ed2f8a
parent 29511 7071b017cb35
child 29880 3dee8ff45d3d
permissions -rw-r--r--
handling type classes without parameters
haftmann@26169
     1
(*  Title:      HOL/Library/Countable.thy
haftmann@26350
     2
    Author:     Alexander Krauss, TU Muenchen
haftmann@26169
     3
*)
haftmann@26169
     4
haftmann@26169
     5
header {* Encoding (almost) everything into natural numbers *}
haftmann@26169
     6
haftmann@26169
     7
theory Countable
haftmann@27487
     8
imports Plain "~~/src/HOL/List" "~~/src/HOL/Hilbert_Choice"
haftmann@26169
     9
begin
haftmann@26169
    10
haftmann@26169
    11
subsection {* The class of countable types *}
haftmann@26169
    12
haftmann@29797
    13
class countable =
haftmann@26169
    14
  assumes ex_inj: "\<exists>to_nat \<Colon> 'a \<Rightarrow> nat. inj to_nat"
haftmann@26169
    15
haftmann@26169
    16
lemma countable_classI:
haftmann@26169
    17
  fixes f :: "'a \<Rightarrow> nat"
haftmann@26169
    18
  assumes "\<And>x y. f x = f y \<Longrightarrow> x = y"
haftmann@26169
    19
  shows "OFCLASS('a, countable_class)"
haftmann@26169
    20
proof (intro_classes, rule exI)
haftmann@26169
    21
  show "inj f"
haftmann@26169
    22
    by (rule injI [OF assms]) assumption
haftmann@26169
    23
qed
haftmann@26169
    24
haftmann@26169
    25
huffman@26585
    26
subsection {* Conversion functions *}
haftmann@26169
    27
haftmann@26169
    28
definition to_nat :: "'a\<Colon>countable \<Rightarrow> nat" where
haftmann@26169
    29
  "to_nat = (SOME f. inj f)"
haftmann@26169
    30
haftmann@26169
    31
definition from_nat :: "nat \<Rightarrow> 'a\<Colon>countable" where
haftmann@26169
    32
  "from_nat = inv (to_nat \<Colon> 'a \<Rightarrow> nat)"
haftmann@26169
    33
haftmann@26169
    34
lemma inj_to_nat [simp]: "inj to_nat"
haftmann@26169
    35
  by (rule exE_some [OF ex_inj]) (simp add: to_nat_def)
haftmann@26169
    36
haftmann@26169
    37
lemma to_nat_split [simp]: "to_nat x = to_nat y \<longleftrightarrow> x = y"
haftmann@26169
    38
  using injD [OF inj_to_nat] by auto
haftmann@26169
    39
haftmann@26169
    40
lemma from_nat_to_nat [simp]:
haftmann@26169
    41
  "from_nat (to_nat x) = x"
haftmann@26169
    42
  by (simp add: from_nat_def)
haftmann@26169
    43
haftmann@26169
    44
haftmann@26169
    45
subsection {* Countable types *}
haftmann@26169
    46
haftmann@26169
    47
instance nat :: countable
haftmann@26169
    48
  by (rule countable_classI [of "id"]) simp 
haftmann@26169
    49
haftmann@26169
    50
subclass (in finite) countable
haftmann@28823
    51
proof
haftmann@26169
    52
  have "finite (UNIV\<Colon>'a set)" by (rule finite_UNIV)
haftmann@26169
    53
  with finite_conv_nat_seg_image [of UNIV]
haftmann@26169
    54
  obtain n and f :: "nat \<Rightarrow> 'a" 
haftmann@26169
    55
    where "UNIV = f ` {i. i < n}" by auto
haftmann@26169
    56
  then have "surj f" unfolding surj_def by auto
haftmann@26169
    57
  then have "inj (inv f)" by (rule surj_imp_inj_inv)
haftmann@26169
    58
  then show "\<exists>to_nat \<Colon> 'a \<Rightarrow> nat. inj to_nat" by (rule exI[of inj])
haftmann@26169
    59
qed
haftmann@26169
    60
haftmann@26169
    61
text {* Pairs *}
haftmann@26169
    62
haftmann@26169
    63
primrec sum :: "nat \<Rightarrow> nat"
haftmann@26169
    64
where
haftmann@26169
    65
  "sum 0 = 0"
haftmann@26169
    66
| "sum (Suc n) = Suc n + sum n"
haftmann@26169
    67
haftmann@26169
    68
lemma sum_arith: "sum n = n * Suc n div 2"
haftmann@26169
    69
  by (induct n) auto
haftmann@26169
    70
haftmann@26169
    71
lemma sum_mono: "n \<ge> m \<Longrightarrow> sum n \<ge> sum m"
haftmann@26169
    72
  by (induct n m rule: diff_induct) auto
haftmann@26169
    73
haftmann@26169
    74
definition
haftmann@26169
    75
  "pair_encode = (\<lambda>(m, n). sum (m + n) + m)"
haftmann@26169
    76
haftmann@26169
    77
lemma inj_pair_cencode: "inj pair_encode"
haftmann@26169
    78
  unfolding pair_encode_def
haftmann@26169
    79
proof (rule injI, simp only: split_paired_all split_conv)
haftmann@26169
    80
  fix a b c d
haftmann@26169
    81
  assume eq: "sum (a + b) + a = sum (c + d) + c"
haftmann@26169
    82
  have "a + b = c + d \<or> a + b \<ge> Suc (c + d) \<or> c + d \<ge> Suc (a + b)" by arith
haftmann@26169
    83
  then
haftmann@26169
    84
  show "(a, b) = (c, d)"
haftmann@26169
    85
  proof (elim disjE)
haftmann@26169
    86
    assume sumeq: "a + b = c + d"
haftmann@26169
    87
    then have "a = c" using eq by auto
haftmann@26169
    88
    moreover from sumeq this have "b = d" by auto
haftmann@26169
    89
    ultimately show ?thesis by simp
haftmann@26169
    90
  next
haftmann@26169
    91
    assume "a + b \<ge> Suc (c + d)"
haftmann@26169
    92
    from sum_mono[OF this] eq
haftmann@26169
    93
    show ?thesis by auto
haftmann@26169
    94
  next
haftmann@26169
    95
    assume "c + d \<ge> Suc (a + b)"
haftmann@26169
    96
    from sum_mono[OF this] eq
haftmann@26169
    97
    show ?thesis by auto
haftmann@26169
    98
  qed
haftmann@26169
    99
qed
haftmann@26169
   100
haftmann@26169
   101
instance "*" :: (countable, countable) countable
haftmann@26169
   102
by (rule countable_classI [of "\<lambda>(x, y). pair_encode (to_nat x, to_nat y)"])
haftmann@26169
   103
  (auto dest: injD [OF inj_pair_cencode] injD [OF inj_to_nat])
haftmann@26169
   104
haftmann@26169
   105
haftmann@26169
   106
text {* Sums *}
haftmann@26169
   107
haftmann@26169
   108
instance "+":: (countable, countable) countable
haftmann@26169
   109
  by (rule countable_classI [of "(\<lambda>x. case x of Inl a \<Rightarrow> to_nat (False, to_nat a)
haftmann@26169
   110
                                     | Inr b \<Rightarrow> to_nat (True, to_nat b))"])
haftmann@26169
   111
    (auto split:sum.splits)
haftmann@26169
   112
haftmann@26169
   113
haftmann@26169
   114
text {* Integers *}
haftmann@26169
   115
haftmann@26169
   116
lemma int_cases: "(i::int) = 0 \<or> i < 0 \<or> i > 0"
haftmann@26169
   117
by presburger
haftmann@26169
   118
haftmann@26169
   119
lemma int_pos_neg_zero:
haftmann@26169
   120
  obtains (zero) "(z::int) = 0" "sgn z = 0" "abs z = 0"
haftmann@26169
   121
  | (pos) n where "z = of_nat n" "sgn z = 1" "abs z = of_nat n"
haftmann@26169
   122
  | (neg) n where "z = - (of_nat n)" "sgn z = -1" "abs z = of_nat n"
krauss@26580
   123
apply atomize_elim
haftmann@26169
   124
apply (insert int_cases[of z])
haftmann@26169
   125
apply (auto simp:zsgn_def)
haftmann@26169
   126
apply (rule_tac x="nat (-z)" in exI, simp)
haftmann@26169
   127
apply (rule_tac x="nat z" in exI, simp)
haftmann@26169
   128
done
haftmann@26169
   129
haftmann@26169
   130
instance int :: countable
haftmann@26169
   131
proof (rule countable_classI [of "(\<lambda>i. to_nat (nat (sgn i + 1), nat (abs i)))"], 
haftmann@26169
   132
    auto dest: injD [OF inj_to_nat])
haftmann@26169
   133
  fix x y 
haftmann@26169
   134
  assume a: "nat (sgn x + 1) = nat (sgn y + 1)" "nat (abs x) = nat (abs y)"
haftmann@26169
   135
  show "x = y"
haftmann@26169
   136
  proof (cases rule: int_pos_neg_zero[of x])
haftmann@26169
   137
    case zero 
haftmann@26169
   138
    with a show "x = y" by (cases rule: int_pos_neg_zero[of y]) auto
haftmann@26169
   139
  next
haftmann@26169
   140
    case (pos n)
haftmann@26169
   141
    with a show "x = y" by (cases rule: int_pos_neg_zero[of y]) auto
haftmann@26169
   142
  next
haftmann@26169
   143
    case (neg n)
haftmann@26169
   144
    with a show "x = y" by (cases rule: int_pos_neg_zero[of y]) auto
haftmann@26169
   145
  qed
haftmann@26169
   146
qed
haftmann@26169
   147
haftmann@26169
   148
haftmann@26169
   149
text {* Options *}
haftmann@26169
   150
haftmann@26169
   151
instance option :: (countable) countable
haftmann@26169
   152
by (rule countable_classI[of "\<lambda>x. case x of None \<Rightarrow> 0
haftmann@26169
   153
                                     | Some y \<Rightarrow> Suc (to_nat y)"])
haftmann@26169
   154
 (auto split:option.splits)
haftmann@26169
   155
haftmann@26169
   156
haftmann@26169
   157
text {* Lists *}
haftmann@26169
   158
haftmann@26169
   159
lemma from_nat_to_nat_map [simp]: "map from_nat (map to_nat xs) = xs"
haftmann@26169
   160
  by (simp add: comp_def map_compose [symmetric])
haftmann@26169
   161
haftmann@26169
   162
primrec
haftmann@26169
   163
  list_encode :: "'a\<Colon>countable list \<Rightarrow> nat"
haftmann@26169
   164
where
haftmann@26169
   165
  "list_encode [] = 0"
haftmann@26169
   166
| "list_encode (x#xs) = Suc (to_nat (x, list_encode xs))"
haftmann@26169
   167
haftmann@26169
   168
instance list :: (countable) countable
haftmann@26169
   169
proof (rule countable_classI [of "list_encode"])
haftmann@26169
   170
  fix xs ys :: "'a list"
haftmann@26169
   171
  assume cenc: "list_encode xs = list_encode ys"
haftmann@26169
   172
  then show "xs = ys"
haftmann@26169
   173
  proof (induct xs arbitrary: ys)
haftmann@26169
   174
    case (Nil ys)
haftmann@26169
   175
    with cenc show ?case by (cases ys, auto)
haftmann@26169
   176
  next
haftmann@26169
   177
    case (Cons x xs' ys)
haftmann@26169
   178
    thus ?case by (cases ys) auto
haftmann@26169
   179
  qed
haftmann@26169
   180
qed
haftmann@26169
   181
huffman@26243
   182
huffman@26243
   183
text {* Functions *}
huffman@26243
   184
huffman@26243
   185
instance "fun" :: (finite, countable) countable
huffman@26243
   186
proof
huffman@26243
   187
  obtain xs :: "'a list" where xs: "set xs = UNIV"
huffman@26243
   188
    using finite_list [OF finite_UNIV] ..
huffman@26243
   189
  show "\<exists>to_nat::('a \<Rightarrow> 'b) \<Rightarrow> nat. inj to_nat"
huffman@26243
   190
  proof
huffman@26243
   191
    show "inj (\<lambda>f. to_nat (map f xs))"
huffman@26243
   192
      by (rule injI, simp add: xs expand_fun_eq)
huffman@26243
   193
  qed
huffman@26243
   194
qed
huffman@26243
   195
haftmann@26169
   196
end