src/HOL/Library/Countable.thy
author wenzelm
Sun Apr 12 12:07:48 2015 +0200 (2015-04-12)
changeset 60029 b2acd5301615
parent 59643 f3be9235503d
child 60500 903bb1495239
permissions -rw-r--r--
tuned -- avoid ML warnings;
haftmann@26169
     1
(*  Title:      HOL/Library/Countable.thy
haftmann@26350
     2
    Author:     Alexander Krauss, TU Muenchen
huffman@43534
     3
    Author:     Brian Huffman, Portland State University
blanchet@58160
     4
    Author:     Jasmin Blanchette, TU Muenchen
haftmann@26169
     5
*)
haftmann@26169
     6
wenzelm@58881
     7
section {* Encoding (almost) everything into natural numbers *}
haftmann@26169
     8
haftmann@26169
     9
theory Countable
blanchet@58372
    10
imports Old_Datatype Rat Nat_Bijection
haftmann@26169
    11
begin
haftmann@26169
    12
haftmann@26169
    13
subsection {* The class of countable types *}
haftmann@26169
    14
haftmann@29797
    15
class countable =
haftmann@26169
    16
  assumes ex_inj: "\<exists>to_nat \<Colon> 'a \<Rightarrow> nat. inj to_nat"
haftmann@26169
    17
haftmann@26169
    18
lemma countable_classI:
haftmann@26169
    19
  fixes f :: "'a \<Rightarrow> nat"
haftmann@26169
    20
  assumes "\<And>x y. f x = f y \<Longrightarrow> x = y"
haftmann@26169
    21
  shows "OFCLASS('a, countable_class)"
haftmann@26169
    22
proof (intro_classes, rule exI)
haftmann@26169
    23
  show "inj f"
haftmann@26169
    24
    by (rule injI [OF assms]) assumption
haftmann@26169
    25
qed
haftmann@26169
    26
haftmann@26169
    27
huffman@26585
    28
subsection {* Conversion functions *}
haftmann@26169
    29
haftmann@26169
    30
definition to_nat :: "'a\<Colon>countable \<Rightarrow> nat" where
haftmann@26169
    31
  "to_nat = (SOME f. inj f)"
haftmann@26169
    32
haftmann@26169
    33
definition from_nat :: "nat \<Rightarrow> 'a\<Colon>countable" where
haftmann@26169
    34
  "from_nat = inv (to_nat \<Colon> 'a \<Rightarrow> nat)"
haftmann@26169
    35
haftmann@26169
    36
lemma inj_to_nat [simp]: "inj to_nat"
haftmann@26169
    37
  by (rule exE_some [OF ex_inj]) (simp add: to_nat_def)
haftmann@26169
    38
hoelzl@43992
    39
lemma inj_on_to_nat[simp, intro]: "inj_on to_nat S"
hoelzl@43992
    40
  using inj_to_nat by (auto simp: inj_on_def)
hoelzl@43992
    41
huffman@29910
    42
lemma surj_from_nat [simp]: "surj from_nat"
huffman@29910
    43
  unfolding from_nat_def by (simp add: inj_imp_surj_inv)
huffman@29910
    44
haftmann@26169
    45
lemma to_nat_split [simp]: "to_nat x = to_nat y \<longleftrightarrow> x = y"
haftmann@26169
    46
  using injD [OF inj_to_nat] by auto
haftmann@26169
    47
haftmann@26169
    48
lemma from_nat_to_nat [simp]:
haftmann@26169
    49
  "from_nat (to_nat x) = x"
haftmann@26169
    50
  by (simp add: from_nat_def)
haftmann@26169
    51
haftmann@26169
    52
blanchet@58160
    53
subsection {* Finite types are countable *}
haftmann@26169
    54
haftmann@26169
    55
subclass (in finite) countable
haftmann@28823
    56
proof
haftmann@26169
    57
  have "finite (UNIV\<Colon>'a set)" by (rule finite_UNIV)
nipkow@31992
    58
  with finite_conv_nat_seg_image [of "UNIV::'a set"]
haftmann@26169
    59
  obtain n and f :: "nat \<Rightarrow> 'a" 
haftmann@26169
    60
    where "UNIV = f ` {i. i < n}" by auto
haftmann@26169
    61
  then have "surj f" unfolding surj_def by auto
haftmann@26169
    62
  then have "inj (inv f)" by (rule surj_imp_inj_inv)
haftmann@26169
    63
  then show "\<exists>to_nat \<Colon> 'a \<Rightarrow> nat. inj to_nat" by (rule exI[of inj])
haftmann@26169
    64
qed
haftmann@26169
    65
haftmann@26169
    66
blanchet@58160
    67
subsection {* Automatically proving countability of old-style datatypes *}
huffman@43534
    68
blanchet@58112
    69
inductive finite_item :: "'a Old_Datatype.item \<Rightarrow> bool" where
huffman@43534
    70
  undefined: "finite_item undefined"
blanchet@58112
    71
| In0: "finite_item x \<Longrightarrow> finite_item (Old_Datatype.In0 x)"
blanchet@58112
    72
| In1: "finite_item x \<Longrightarrow> finite_item (Old_Datatype.In1 x)"
blanchet@58112
    73
| Leaf: "finite_item (Old_Datatype.Leaf a)"
blanchet@58112
    74
| Scons: "\<lbrakk>finite_item x; finite_item y\<rbrakk> \<Longrightarrow> finite_item (Old_Datatype.Scons x y)"
huffman@43534
    75
huffman@43534
    76
function
blanchet@58112
    77
  nth_item :: "nat \<Rightarrow> ('a::countable) Old_Datatype.item"
huffman@43534
    78
where
huffman@43534
    79
  "nth_item 0 = undefined"
huffman@43534
    80
| "nth_item (Suc n) =
huffman@43534
    81
  (case sum_decode n of
huffman@43534
    82
    Inl i \<Rightarrow>
huffman@43534
    83
    (case sum_decode i of
blanchet@58112
    84
      Inl j \<Rightarrow> Old_Datatype.In0 (nth_item j)
blanchet@58112
    85
    | Inr j \<Rightarrow> Old_Datatype.In1 (nth_item j))
huffman@43534
    86
  | Inr i \<Rightarrow>
huffman@43534
    87
    (case sum_decode i of
blanchet@58112
    88
      Inl j \<Rightarrow> Old_Datatype.Leaf (from_nat j)
huffman@43534
    89
    | Inr j \<Rightarrow>
huffman@43534
    90
      (case prod_decode j of
blanchet@58112
    91
        (a, b) \<Rightarrow> Old_Datatype.Scons (nth_item a) (nth_item b))))"
huffman@43534
    92
by pat_completeness auto
huffman@43534
    93
huffman@43534
    94
lemma le_sum_encode_Inl: "x \<le> y \<Longrightarrow> x \<le> sum_encode (Inl y)"
huffman@43534
    95
unfolding sum_encode_def by simp
huffman@43534
    96
huffman@43534
    97
lemma le_sum_encode_Inr: "x \<le> y \<Longrightarrow> x \<le> sum_encode (Inr y)"
huffman@43534
    98
unfolding sum_encode_def by simp
huffman@43534
    99
huffman@43534
   100
termination
huffman@43534
   101
by (relation "measure id")
huffman@43534
   102
  (auto simp add: sum_encode_eq [symmetric] prod_encode_eq [symmetric]
huffman@43534
   103
    le_imp_less_Suc le_sum_encode_Inl le_sum_encode_Inr
huffman@43534
   104
    le_prod_encode_1 le_prod_encode_2)
huffman@43534
   105
huffman@43534
   106
lemma nth_item_covers: "finite_item x \<Longrightarrow> \<exists>n. nth_item n = x"
huffman@43534
   107
proof (induct set: finite_item)
huffman@43534
   108
  case undefined
huffman@43534
   109
  have "nth_item 0 = undefined" by simp
huffman@43534
   110
  thus ?case ..
huffman@43534
   111
next
huffman@43534
   112
  case (In0 x)
huffman@43534
   113
  then obtain n where "nth_item n = x" by fast
blanchet@58112
   114
  hence "nth_item (Suc (sum_encode (Inl (sum_encode (Inl n))))) = Old_Datatype.In0 x" by simp
huffman@43534
   115
  thus ?case ..
huffman@43534
   116
next
huffman@43534
   117
  case (In1 x)
huffman@43534
   118
  then obtain n where "nth_item n = x" by fast
blanchet@58112
   119
  hence "nth_item (Suc (sum_encode (Inl (sum_encode (Inr n))))) = Old_Datatype.In1 x" by simp
huffman@43534
   120
  thus ?case ..
huffman@43534
   121
next
huffman@43534
   122
  case (Leaf a)
blanchet@58112
   123
  have "nth_item (Suc (sum_encode (Inr (sum_encode (Inl (to_nat a)))))) = Old_Datatype.Leaf a"
blanchet@58112
   124
    by simp
huffman@43534
   125
  thus ?case ..
huffman@43534
   126
next
huffman@43534
   127
  case (Scons x y)
huffman@43534
   128
  then obtain i j where "nth_item i = x" and "nth_item j = y" by fast
huffman@43534
   129
  hence "nth_item
blanchet@58112
   130
    (Suc (sum_encode (Inr (sum_encode (Inr (prod_encode (i, j))))))) = Old_Datatype.Scons x y"
blanchet@58112
   131
    by simp
huffman@43534
   132
  thus ?case ..
huffman@43534
   133
qed
huffman@43534
   134
huffman@43534
   135
theorem countable_datatype:
blanchet@58112
   136
  fixes Rep :: "'b \<Rightarrow> ('a::countable) Old_Datatype.item"
blanchet@58112
   137
  fixes Abs :: "('a::countable) Old_Datatype.item \<Rightarrow> 'b"
blanchet@58112
   138
  fixes rep_set :: "('a::countable) Old_Datatype.item \<Rightarrow> bool"
huffman@43534
   139
  assumes type: "type_definition Rep Abs (Collect rep_set)"
huffman@43534
   140
  assumes finite_item: "\<And>x. rep_set x \<Longrightarrow> finite_item x"
huffman@43534
   141
  shows "OFCLASS('b, countable_class)"
huffman@43534
   142
proof
huffman@43534
   143
  def f \<equiv> "\<lambda>y. LEAST n. nth_item n = Rep y"
huffman@43534
   144
  {
huffman@43534
   145
    fix y :: 'b
huffman@43534
   146
    have "rep_set (Rep y)"
huffman@43534
   147
      using type_definition.Rep [OF type] by simp
huffman@43534
   148
    hence "finite_item (Rep y)"
huffman@43534
   149
      by (rule finite_item)
huffman@43534
   150
    hence "\<exists>n. nth_item n = Rep y"
huffman@43534
   151
      by (rule nth_item_covers)
huffman@43534
   152
    hence "nth_item (f y) = Rep y"
huffman@43534
   153
      unfolding f_def by (rule LeastI_ex)
huffman@43534
   154
    hence "Abs (nth_item (f y)) = y"
huffman@43534
   155
      using type_definition.Rep_inverse [OF type] by simp
huffman@43534
   156
  }
huffman@43534
   157
  hence "inj f"
huffman@43534
   158
    by (rule inj_on_inverseI)
huffman@43534
   159
  thus "\<exists>f::'b \<Rightarrow> nat. inj f"
huffman@43534
   160
    by - (rule exI)
huffman@43534
   161
qed
huffman@43534
   162
wenzelm@47432
   163
ML {*
blanchet@58161
   164
  fun old_countable_datatype_tac ctxt =
blanchet@58160
   165
    SUBGOAL (fn (goal, _) =>
huffman@43534
   166
      let
huffman@43534
   167
        val ty_name =
huffman@43534
   168
          (case goal of
wenzelm@56243
   169
            (_ $ Const (@{const_name Pure.type}, Type (@{type_name itself}, [Type (n, _)]))) => n
huffman@43534
   170
          | _ => raise Match)
huffman@43534
   171
        val typedef_info = hd (Typedef.get_info ctxt ty_name)
huffman@43534
   172
        val typedef_thm = #type_definition (snd typedef_info)
huffman@43534
   173
        val pred_name =
wenzelm@59582
   174
          (case HOLogic.dest_Trueprop (Thm.concl_of typedef_thm) of
blanchet@58160
   175
            (_ $ _ $ _ $ (_ $ Const (n, _))) => n
huffman@43534
   176
          | _ => raise Match)
huffman@43534
   177
        val induct_info = Inductive.the_inductive ctxt pred_name
huffman@43534
   178
        val pred_names = #names (fst induct_info)
huffman@43534
   179
        val induct_thms = #inducts (snd induct_info)
huffman@43534
   180
        val alist = pred_names ~~ induct_thms
huffman@43534
   181
        val induct_thm = the (AList.lookup (op =) alist pred_name)
huffman@49187
   182
        val vars = rev (Term.add_vars (Thm.prop_of induct_thm) [])
wenzelm@59643
   183
        val insts = vars |> map (fn (_, T) => try (Thm.cterm_of ctxt)
huffman@49187
   184
          (Const (@{const_name Countable.finite_item}, T)))
huffman@49187
   185
        val induct_thm' = Drule.instantiate' [] insts induct_thm
huffman@43534
   186
        val rules = @{thms finite_item.intros}
huffman@43534
   187
      in
huffman@43534
   188
        SOLVED' (fn i => EVERY
huffman@43534
   189
          [rtac @{thm countable_datatype} i,
huffman@43534
   190
           rtac typedef_thm i,
huffman@49187
   191
           etac induct_thm' i,
wenzelm@59498
   192
           REPEAT (resolve_tac ctxt rules i ORELSE atac i)]) 1
huffman@43534
   193
      end)
wenzelm@47432
   194
*}
wenzelm@47432
   195
huffman@43534
   196
hide_const (open) finite_item nth_item
huffman@43534
   197
huffman@43534
   198
blanchet@58315
   199
subsection {* Automatically proving countability of datatypes *}
blanchet@58160
   200
blanchet@58160
   201
ML_file "bnf_lfp_countable.ML"
blanchet@58160
   202
blanchet@58161
   203
ML {*
blanchet@58161
   204
fun countable_datatype_tac ctxt st =
wenzelm@60029
   205
  (case try (fn () => HEADGOAL (old_countable_datatype_tac ctxt) st) () of
wenzelm@60029
   206
    SOME res => res
wenzelm@60029
   207
  | NONE => BNF_LFP_Countable.countable_datatype_tac ctxt st);
blanchet@58161
   208
blanchet@58161
   209
(* compatibility *)
blanchet@58161
   210
fun countable_tac ctxt =
blanchet@58161
   211
  SELECT_GOAL (countable_datatype_tac ctxt);
blanchet@58161
   212
*}
blanchet@58161
   213
blanchet@58160
   214
method_setup countable_datatype = {*
blanchet@58161
   215
  Scan.succeed (SIMPLE_METHOD o countable_datatype_tac)
blanchet@58160
   216
*} "prove countable class instances for datatypes"
blanchet@58160
   217
blanchet@58160
   218
blanchet@58160
   219
subsection {* More Countable types *}
blanchet@58160
   220
blanchet@58160
   221
text {* Naturals *}
huffman@43534
   222
blanchet@58160
   223
instance nat :: countable
blanchet@58160
   224
  by (rule countable_classI [of "id"]) simp
blanchet@58160
   225
blanchet@58160
   226
text {* Pairs *}
blanchet@58160
   227
blanchet@58160
   228
instance prod :: (countable, countable) countable
blanchet@58160
   229
  by (rule countable_classI [of "\<lambda>(x, y). prod_encode (to_nat x, to_nat y)"])
blanchet@58160
   230
    (auto simp add: prod_encode_eq)
blanchet@58158
   231
blanchet@58160
   232
text {* Sums *}
blanchet@58160
   233
blanchet@58160
   234
instance sum :: (countable, countable) countable
blanchet@58160
   235
  by (rule countable_classI [of "(\<lambda>x. case x of Inl a \<Rightarrow> to_nat (False, to_nat a)
blanchet@58160
   236
                                     | Inr b \<Rightarrow> to_nat (True, to_nat b))"])
blanchet@58160
   237
    (simp split: sum.split_asm)
blanchet@58160
   238
blanchet@58160
   239
text {* Integers *}
blanchet@58158
   240
blanchet@58160
   241
instance int :: countable
blanchet@58160
   242
  by (rule countable_classI [of int_encode]) (simp add: int_encode_eq)
blanchet@58160
   243
blanchet@58160
   244
text {* Options *}
blanchet@58160
   245
blanchet@58160
   246
instance option :: (countable) countable
blanchet@58160
   247
  by countable_datatype
blanchet@58160
   248
blanchet@58160
   249
text {* Lists *}
blanchet@58160
   250
blanchet@58160
   251
instance list :: (countable) countable
blanchet@58160
   252
  by countable_datatype
blanchet@58160
   253
blanchet@58160
   254
text {* String literals *}
blanchet@58160
   255
blanchet@58160
   256
instance String.literal :: countable
blanchet@58221
   257
  by (rule countable_classI [of "to_nat \<circ> String.explode"]) (auto simp add: explode_inject)
blanchet@58160
   258
blanchet@58160
   259
text {* Functions *}
blanchet@58160
   260
blanchet@58160
   261
instance "fun" :: (finite, countable) countable
blanchet@58160
   262
proof
blanchet@58160
   263
  obtain xs :: "'a list" where xs: "set xs = UNIV"
blanchet@58160
   264
    using finite_list [OF finite_UNIV] ..
blanchet@58160
   265
  show "\<exists>to_nat::('a \<Rightarrow> 'b) \<Rightarrow> nat. inj to_nat"
blanchet@58160
   266
  proof
blanchet@58160
   267
    show "inj (\<lambda>f. to_nat (map f xs))"
blanchet@58160
   268
      by (rule injI, simp add: xs fun_eq_iff)
blanchet@58160
   269
  qed
blanchet@58160
   270
qed
blanchet@58160
   271
blanchet@58160
   272
text {* Typereps *}
blanchet@58158
   273
huffman@43534
   274
instance typerep :: countable
blanchet@58160
   275
  by countable_datatype
blanchet@58160
   276
blanchet@58160
   277
blanchet@58160
   278
subsection {* The rationals are countably infinite *}
blanchet@58160
   279
blanchet@58160
   280
definition nat_to_rat_surj :: "nat \<Rightarrow> rat" where
blanchet@58160
   281
  "nat_to_rat_surj n = (let (a, b) = prod_decode n in Fract (int_decode a) (int_decode b))"
blanchet@58160
   282
blanchet@58160
   283
lemma surj_nat_to_rat_surj: "surj nat_to_rat_surj"
blanchet@58160
   284
unfolding surj_def
blanchet@58160
   285
proof
blanchet@58160
   286
  fix r::rat
blanchet@58160
   287
  show "\<exists>n. r = nat_to_rat_surj n"
blanchet@58160
   288
  proof (cases r)
blanchet@58160
   289
    fix i j assume [simp]: "r = Fract i j" and "j > 0"
blanchet@58161
   290
    have "r = (let m = int_encode i; n = int_encode j in nat_to_rat_surj (prod_encode (m, n)))"
blanchet@58160
   291
      by (simp add: Let_def nat_to_rat_surj_def)
blanchet@58161
   292
    thus "\<exists>n. r = nat_to_rat_surj n" by(auto simp: Let_def)
blanchet@58160
   293
  qed
blanchet@58160
   294
qed
blanchet@58160
   295
blanchet@58160
   296
lemma Rats_eq_range_nat_to_rat_surj: "\<rat> = range nat_to_rat_surj"
blanchet@58160
   297
  by (simp add: Rats_def surj_nat_to_rat_surj)
blanchet@58160
   298
blanchet@58160
   299
context field_char_0
blanchet@58160
   300
begin
blanchet@58160
   301
blanchet@58160
   302
lemma Rats_eq_range_of_rat_o_nat_to_rat_surj:
blanchet@58221
   303
  "\<rat> = range (of_rat \<circ> nat_to_rat_surj)"
blanchet@58160
   304
  using surj_nat_to_rat_surj
blanchet@58160
   305
  by (auto simp: Rats_def image_def surj_def) (blast intro: arg_cong[where f = of_rat])
blanchet@58160
   306
blanchet@58160
   307
lemma surj_of_rat_nat_to_rat_surj:
blanchet@58221
   308
  "r \<in> \<rat> \<Longrightarrow> \<exists>n. r = of_rat (nat_to_rat_surj n)"
blanchet@58160
   309
  by (simp add: Rats_eq_range_of_rat_o_nat_to_rat_surj image_def)
huffman@43534
   310
huffman@43534
   311
end
blanchet@58160
   312
blanchet@58160
   313
instance rat :: countable
blanchet@58160
   314
proof
blanchet@58160
   315
  show "\<exists>to_nat::rat \<Rightarrow> nat. inj to_nat"
blanchet@58160
   316
  proof
blanchet@58160
   317
    have "surj nat_to_rat_surj"
blanchet@58160
   318
      by (rule surj_nat_to_rat_surj)
blanchet@58160
   319
    then show "inj (inv nat_to_rat_surj)"
blanchet@58160
   320
      by (rule surj_imp_inj_inv)
blanchet@58160
   321
  qed
blanchet@58160
   322
qed
blanchet@58160
   323
blanchet@58160
   324
end