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