haftmann@26169: (* Title: HOL/Library/Countable.thy haftmann@26169: ID: $Id$ haftmann@26169: Author: Tobias Nipkow haftmann@26169: *) haftmann@26169: haftmann@26169: header {* Encoding (almost) everything into natural numbers *} haftmann@26169: haftmann@26169: theory Countable haftmann@26169: imports Finite_Set List Hilbert_Choice haftmann@26169: begin haftmann@26169: haftmann@26169: subsection {* The class of countable types *} haftmann@26169: haftmann@26169: class countable = itself + haftmann@26169: assumes ex_inj: "\to_nat \ 'a \ nat. inj to_nat" haftmann@26169: haftmann@26169: lemma countable_classI: haftmann@26169: fixes f :: "'a \ nat" haftmann@26169: assumes "\x y. f x = f y \ x = y" haftmann@26169: shows "OFCLASS('a, countable_class)" haftmann@26169: proof (intro_classes, rule exI) haftmann@26169: show "inj f" haftmann@26169: by (rule injI [OF assms]) assumption haftmann@26169: qed haftmann@26169: haftmann@26169: haftmann@26169: subsection {* Converion functions *} haftmann@26169: haftmann@26169: definition to_nat :: "'a\countable \ nat" where haftmann@26169: "to_nat = (SOME f. inj f)" haftmann@26169: haftmann@26169: definition from_nat :: "nat \ 'a\countable" where haftmann@26169: "from_nat = inv (to_nat \ 'a \ nat)" haftmann@26169: haftmann@26169: lemma inj_to_nat [simp]: "inj to_nat" haftmann@26169: by (rule exE_some [OF ex_inj]) (simp add: to_nat_def) haftmann@26169: haftmann@26169: lemma to_nat_split [simp]: "to_nat x = to_nat y \ x = y" haftmann@26169: using injD [OF inj_to_nat] by auto haftmann@26169: haftmann@26169: lemma from_nat_to_nat [simp]: haftmann@26169: "from_nat (to_nat x) = x" haftmann@26169: by (simp add: from_nat_def) haftmann@26169: haftmann@26169: haftmann@26169: subsection {* Countable types *} haftmann@26169: haftmann@26169: instance nat :: countable haftmann@26169: by (rule countable_classI [of "id"]) simp haftmann@26169: haftmann@26169: subclass (in finite) countable haftmann@26169: proof unfold_locales haftmann@26169: have "finite (UNIV\'a set)" by (rule finite_UNIV) haftmann@26169: with finite_conv_nat_seg_image [of UNIV] haftmann@26169: obtain n and f :: "nat \ 'a" haftmann@26169: where "UNIV = f ` {i. i < n}" by auto haftmann@26169: then have "surj f" unfolding surj_def by auto haftmann@26169: then have "inj (inv f)" by (rule surj_imp_inj_inv) haftmann@26169: then show "\to_nat \ 'a \ nat. inj to_nat" by (rule exI[of inj]) haftmann@26169: qed haftmann@26169: haftmann@26169: text {* Pairs *} haftmann@26169: haftmann@26169: primrec sum :: "nat \ nat" haftmann@26169: where haftmann@26169: "sum 0 = 0" haftmann@26169: | "sum (Suc n) = Suc n + sum n" haftmann@26169: haftmann@26169: lemma sum_arith: "sum n = n * Suc n div 2" haftmann@26169: by (induct n) auto haftmann@26169: haftmann@26169: lemma sum_mono: "n \ m \ sum n \ sum m" haftmann@26169: by (induct n m rule: diff_induct) auto haftmann@26169: haftmann@26169: definition haftmann@26169: "pair_encode = (\(m, n). sum (m + n) + m)" haftmann@26169: haftmann@26169: lemma inj_pair_cencode: "inj pair_encode" haftmann@26169: unfolding pair_encode_def haftmann@26169: proof (rule injI, simp only: split_paired_all split_conv) haftmann@26169: fix a b c d haftmann@26169: assume eq: "sum (a + b) + a = sum (c + d) + c" haftmann@26169: have "a + b = c + d \ a + b \ Suc (c + d) \ c + d \ Suc (a + b)" by arith haftmann@26169: then haftmann@26169: show "(a, b) = (c, d)" haftmann@26169: proof (elim disjE) haftmann@26169: assume sumeq: "a + b = c + d" haftmann@26169: then have "a = c" using eq by auto haftmann@26169: moreover from sumeq this have "b = d" by auto haftmann@26169: ultimately show ?thesis by simp haftmann@26169: next haftmann@26169: assume "a + b \ Suc (c + d)" haftmann@26169: from sum_mono[OF this] eq haftmann@26169: show ?thesis by auto haftmann@26169: next haftmann@26169: assume "c + d \ Suc (a + b)" haftmann@26169: from sum_mono[OF this] eq haftmann@26169: show ?thesis by auto haftmann@26169: qed haftmann@26169: qed haftmann@26169: haftmann@26169: instance "*" :: (countable, countable) countable haftmann@26169: by (rule countable_classI [of "\(x, y). pair_encode (to_nat x, to_nat y)"]) haftmann@26169: (auto dest: injD [OF inj_pair_cencode] injD [OF inj_to_nat]) haftmann@26169: haftmann@26169: haftmann@26169: text {* Sums *} haftmann@26169: haftmann@26169: instance "+":: (countable, countable) countable haftmann@26169: by (rule countable_classI [of "(\x. case x of Inl a \ to_nat (False, to_nat a) haftmann@26169: | Inr b \ to_nat (True, to_nat b))"]) haftmann@26169: (auto split:sum.splits) haftmann@26169: haftmann@26169: haftmann@26169: text {* Integers *} haftmann@26169: haftmann@26169: lemma int_cases: "(i::int) = 0 \ i < 0 \ i > 0" haftmann@26169: by presburger haftmann@26169: haftmann@26169: lemma int_pos_neg_zero: haftmann@26169: obtains (zero) "(z::int) = 0" "sgn z = 0" "abs z = 0" haftmann@26169: | (pos) n where "z = of_nat n" "sgn z = 1" "abs z = of_nat n" haftmann@26169: | (neg) n where "z = - (of_nat n)" "sgn z = -1" "abs z = of_nat n" haftmann@26169: apply elim_to_cases haftmann@26169: apply (insert int_cases[of z]) haftmann@26169: apply (auto simp:zsgn_def) haftmann@26169: apply (rule_tac x="nat (-z)" in exI, simp) haftmann@26169: apply (rule_tac x="nat z" in exI, simp) haftmann@26169: done haftmann@26169: haftmann@26169: instance int :: countable haftmann@26169: proof (rule countable_classI [of "(\i. to_nat (nat (sgn i + 1), nat (abs i)))"], haftmann@26169: auto dest: injD [OF inj_to_nat]) haftmann@26169: fix x y haftmann@26169: assume a: "nat (sgn x + 1) = nat (sgn y + 1)" "nat (abs x) = nat (abs y)" haftmann@26169: show "x = y" haftmann@26169: proof (cases rule: int_pos_neg_zero[of x]) haftmann@26169: case zero haftmann@26169: with a show "x = y" by (cases rule: int_pos_neg_zero[of y]) auto haftmann@26169: next haftmann@26169: case (pos n) haftmann@26169: with a show "x = y" by (cases rule: int_pos_neg_zero[of y]) auto haftmann@26169: next haftmann@26169: case (neg n) haftmann@26169: with a show "x = y" by (cases rule: int_pos_neg_zero[of y]) auto haftmann@26169: qed haftmann@26169: qed haftmann@26169: haftmann@26169: haftmann@26169: text {* Options *} haftmann@26169: haftmann@26169: instance option :: (countable) countable haftmann@26169: by (rule countable_classI[of "\x. case x of None \ 0 haftmann@26169: | Some y \ Suc (to_nat y)"]) haftmann@26169: (auto split:option.splits) haftmann@26169: haftmann@26169: haftmann@26169: text {* Lists *} haftmann@26169: haftmann@26169: lemma from_nat_to_nat_map [simp]: "map from_nat (map to_nat xs) = xs" haftmann@26169: by (simp add: comp_def map_compose [symmetric]) haftmann@26169: haftmann@26169: primrec haftmann@26169: list_encode :: "'a\countable list \ nat" haftmann@26169: where haftmann@26169: "list_encode [] = 0" haftmann@26169: | "list_encode (x#xs) = Suc (to_nat (x, list_encode xs))" haftmann@26169: haftmann@26169: instance list :: (countable) countable haftmann@26169: proof (rule countable_classI [of "list_encode"]) haftmann@26169: fix xs ys :: "'a list" haftmann@26169: assume cenc: "list_encode xs = list_encode ys" haftmann@26169: then show "xs = ys" haftmann@26169: proof (induct xs arbitrary: ys) haftmann@26169: case (Nil ys) haftmann@26169: with cenc show ?case by (cases ys, auto) haftmann@26169: next haftmann@26169: case (Cons x xs' ys) haftmann@26169: thus ?case by (cases ys) auto haftmann@26169: qed haftmann@26169: qed haftmann@26169: huffman@26243: huffman@26243: text {* Functions *} huffman@26243: huffman@26243: instance "fun" :: (finite, countable) countable huffman@26243: proof huffman@26243: obtain xs :: "'a list" where xs: "set xs = UNIV" huffman@26243: using finite_list [OF finite_UNIV] .. huffman@26243: show "\to_nat::('a \ 'b) \ nat. inj to_nat" huffman@26243: proof huffman@26243: show "inj (\f. to_nat (map f xs))" huffman@26243: by (rule injI, simp add: xs expand_fun_eq) huffman@26243: qed huffman@26243: qed huffman@26243: haftmann@26169: end