(*  Title:       Termination of the Goodstein Sequence
    Author:      Jasmin Blanchette <jasmin.blanchette at inria.fr>, 2017
    Maintainer:  Jasmin Blanchette <jasmin.blanchette at inria.fr>
*)

section \<open>Termination of the Goodstein Sequence\<close>

theory Goodstein_Sequence
imports Multiset_More Syntactic_Ordinal
begin

text \<open>
The \<open>goodstein\<close> function returns the successive values of the Goodstein
sequence. It is defined in terms of \<open>encode\<close> and \<open>decode\<close> functions,
which convert between natural numbers and ordinals. The development culminates
with a proof of Goodstein's theorem.
\<close>

subsection \<open>Lemmas about Division\<close>

lemma div_mult_le: "m div n * n \<le> m" for m n :: nat
  by (fact div_times_less_eq_dividend)

lemma power_div_same_base:
  "b ^ y \<noteq> 0 \<Longrightarrow> x \<ge> y \<Longrightarrow> b ^ x div b ^ y = b ^ (x - y)" for b :: "'a::semidom_divide"
  by (metis add_diff_inverse leD nonzero_mult_div_cancel_left power_add)

subsection \<open>Hereditary and Nonhereditary Base-\<open>n\<close> Systems\<close>

context
  fixes base :: nat
  assumes base_ge_2: "base \<ge> 2"
begin

inductive well_base :: "'a multiset \<Rightarrow> bool" where
  "(\<forall>n. count M n < base) \<Longrightarrow> well_base M"

lemma well_base_filter: "well_base M \<Longrightarrow> well_base {#m \<in># M. p m#}"
  by (auto simp: well_base.simps)

lemma well_base_image_inj: "well_base M \<Longrightarrow> inj_on f (set_mset M) \<Longrightarrow> well_base (image_mset f M)"
  unfolding well_base.simps by (metis count_image_mset_le_count_inj_on le_less_trans)

lemma well_base_bound:
  assumes
    "well_base M" and
    "\<forall>m \<in># M. m < n"
  shows "(\<Sum>m \<in># M. base ^ m) < base ^ n"
  using assms
proof (induct n arbitrary: M)
  case (Suc n)
  note ih = this(1) and well_M = this(2) and in_M_lt_Sn = this(3)

  let ?Meq = "{#m \<in># M. m = n#}"
  let ?Mne = "{#m \<in># M. m \<noteq> n#}"
  let ?K = "{#base ^ m. m \<in># M#}"

  have M: "M = ?Meq + ?Mne"
    by (simp)

  have well_Mne: "well_base ?Mne"
    by (rule well_base_filter[OF well_M])

  have in_Mne_lt_n: "\<forall>m \<in># ?Mne. m < n"
    using in_M_lt_Sn by auto

  have "sum_mset (image_mset ((^) base) ?Meq) \<le> (base - 1) * base ^ n"
    unfolding filter_eq_replicate_mset using base_ge_2
    by simp (metis Suc_pred diff_self_eq_0 le_SucE less_imp_le less_le_trans less_numeral_extra(3)
      pos2 well_M well_base.cases zero_less_diff)
  moreover have "base * base ^ n = base ^ n + (base - Suc 0) * base ^ n"
    using base_ge_2 mult_eq_if by auto
  ultimately show ?case
    using ih[OF well_Mne in_Mne_lt_n] by (subst M) (simp del: union_filter_mset_complement)
qed simp

inductive well_base\<^sub>h :: "hmultiset \<Rightarrow> bool" where
  "(\<forall>N \<in># hmsetmset M. well_base\<^sub>h N) \<Longrightarrow> well_base (hmsetmset M) \<Longrightarrow> well_base\<^sub>h M"

lemma well_base\<^sub>h_mono_hmset: "well_base\<^sub>h M \<Longrightarrow> hmsetmset N \<subseteq># hmsetmset M \<Longrightarrow> well_base\<^sub>h N"
  by (induct rule: well_base\<^sub>h.induct, rule well_base\<^sub>h.intros, blast)
    (meson leD leI order_trans subseteq_mset_def well_base.simps)

lemma well_base\<^sub>h_imp_well_base: "well_base\<^sub>h M \<Longrightarrow> well_base (hmsetmset M)"
  by (erule well_base\<^sub>h.cases) simp

subsection \<open>Encoding of Natural Numbers into Ordinals\<close>

function encode :: "nat \<Rightarrow> nat \<Rightarrow> hmultiset" where
  "encode e n =
   (if n = 0 then 0 else of_nat (n mod base) * \<omega>^(encode 0 e) + encode (e + 1) (n div base))"
  by pat_completeness auto
termination
  using base_ge_2
proof (relation "measure (\<lambda>(e, n). n * (base ^ e + 1))"; simp)
  fix e n :: nat
  assume n_ge_0: "n > 0"

  have "e + e \<le> 2 ^ e"
    by (induct e; simp) (metis add_diff_cancel_left' add_leD1 diff_is_0_eq' double_not_eq_Suc_double
      le_antisym mult_2 not_less_eq_eq power_eq_0_iff zero_neq_numeral)
  also have "\<dots> \<le> base ^ e"
    using base_ge_2 by (simp add: power_mono)
  also have "\<dots> \<le> n * base ^ e"
    using n_ge_0 by (simp add: Suc_leI)
  also have "\<dots> < n + n * base ^ e"
    using n_ge_0 by simp
  finally show "e + e < n + n * base ^ e"
    by assumption

  have "n div base * (base * base ^ e) \<le> n * base ^ e"
    using base_ge_2 by (auto intro: div_mult_le)
  moreover have "n div base < n"
    using n_ge_0 base_ge_2 by simp
  ultimately show "n div base + n div base * (base * base ^ e) < n + n * base ^ e"
    by linarith
qed

declare encode.simps[simp del]

lemma encode_0[simp]: "encode e 0 = 0"
  by (subst encode.simps) simp

lemma encode_Suc:
  "encode e (Suc n) = of_nat (Suc n mod base) * \<omega>^(encode 0 e) + encode (e + 1) (Suc n div base)"
  by (subst encode.simps) simp

lemma encode_0_iff: "encode e n = 0 \<longleftrightarrow> n = 0"
proof (induct n arbitrary: e rule: less_induct)
  case (less n)
  note ih = this

  show ?case
  proof (cases n)
    case 0
    thus ?thesis
      by simp
  next
    case n: (Suc m)
    show ?thesis
    proof (cases "n mod base = 0")
      case True
      hence "n div base \<noteq> 0"
        using div_eq_0_iff n by fastforce
      thus ?thesis
        using ih[of "Suc m div base"] n
        by (simp add: encode_Suc) (metis One_nat_def base_ge_2 div_eq_dividend_iff div_le_dividend
          leD lessI nat_neq_iff numeral_2_eq_2)
    next
      case False
      thus ?thesis
        using n plus_hmultiset_def by (simp add: encode_Suc[unfolded of_nat_times_\<omega>_exp])
    qed
  qed
qed

lemma encode_Suc_exp: "encode (Suc e) n = encode e (base * n)"
  using base_ge_2
  by (subst (1 2) encode.simps, subst (4) encode.simps, simp add: zero_hmultiset_def[symmetric])

lemma encode_exp_0: "encode e n = encode 0 (base ^ e * n)"
  by (induct e arbitrary: n) (simp_all add: encode_Suc_exp mult.assoc mult.commute)

lemma mem_hmsetmset_encodeD: "M \<in># hmsetmset (encode e n) \<Longrightarrow> \<exists>e' \<ge> e. M = encode 0 e'"
proof (induct e n rule: encode.induct)
  case (1 e n)
  note ih = this(1-2) and M_in = this(3)

  show ?case
  proof (cases n)
    case 0
    thus ?thesis
      using M_in by simp
  next
    case n: (Suc m)

    {
      assume "M \<in># replicate_mset (n mod base) (encode 0 e)"
      hence ?thesis
        by (meson in_replicate_mset order_refl)
    }
    moreover
    {
      assume "M \<in># hmsetmset (encode (e + 1) (n div base))"
      hence ?thesis
        using ih(2) le_add1 n order_trans by blast
    }
    ultimately show ?thesis
      using M_in[unfolded n encode_Suc[unfolded of_nat_times_\<omega>_exp], folded n]
      unfolding hmsetmset_plus by auto
  qed
qed

lemma less_imp_encode_less: "n < p \<Longrightarrow> encode e n < encode e p"
proof (induct e n arbitrary: p rule: encode.induct)
  case (1 e n)
  note ih = this(1-2) and n_lt_p = this(3)

  show ?case
  proof (cases "n = 0")
    case True
    thus ?thesis
      using n_lt_p base_ge_2 encode_0_iff[of e p] le_less by fastforce
  next
    case n_nz: False

    let ?Ma = "replicate_mset (n mod base) (encode 0 e)"
    let ?Na = "replicate_mset (p mod base) (encode 0 e)"
    let ?Pa = "replicate_mset (n mod base - p mod base) (encode 0 e)"

    have "HMSet ?Ma + encode (Suc e) (n div base) < HMSet ?Na + encode (Suc e) (p div base)"
    proof (cases "n mod base < p mod base")
      case mod_lt: True
      show ?thesis
        by (rule add_less_le_mono, simp add: mod_lt,
          metis ih(2)[of "p div base", OF n_nz] Suc_eq_plus1 div_le_mono le_less n_lt_p)
    next
      case mod_ge: False
      hence div_lt: "n div base < p div base"
        by (metis add_le_cancel_left div_le_mono div_mult_mod_eq le_neq_implies_less less_imp_le
          n_lt_p nat_neq_iff)

      let ?M = "hmsetmset (encode (Suc e) (n div base))"
      let ?N = "hmsetmset (encode (Suc e) (p div base))"

      have "?M < ?N"
        by (auto intro!: ih(2)[folded Suc_eq_plus1] n_nz div_lt)
      then obtain X Y where
        X_nemp: "X \<noteq> {#}" and
        X_sub: "X \<subseteq># ?N" and
        M: "?M = ?N - X + Y" and
        ex_gt: "\<forall>y. y \<in># Y \<longrightarrow> (\<exists>x. x \<in># X \<and> x > y)"
        using less_multiset\<^sub>D\<^sub>M by metis

      {
        fix x
        assume x_in_X: "x \<in># X"
        hence x_in_N: "x \<in># ?N"
          using X_sub by blast
        then obtain e' where
          e'_gt: "e' > e" and
          x: "x = encode 0 e'"
          by (auto simp: Suc_le_eq dest: mem_hmsetmset_encodeD)

        have "x > encode 0 e"
          unfolding x using ih(1)[OF n_nz] e'_gt by (blast dest: Suc_lessD)
      }
      hence ex_gt_e: "\<exists>x \<in># X. x > encode 0 e"
        using X_nemp by auto

      have X_sub': "X \<subseteq># ?Na + ?N"
        using X_sub by (simp add: subset_mset.add_increasing)
      have mam_eq: "?Ma + ?M = ?Na + ?N - X + (Y + ?Pa)"
      proof -
        from mod_ge have "?Ma = ?Na + ?Pa"
          by (simp add: replicate_mset_plus [symmetric])
        moreover have "?Na + ?N - X = ?Na + (?N - X)"
          by (meson X_sub multiset_diff_union_assoc)
        ultimately show ?thesis
          by (simp add: M)
      qed
      have max_X: "\<And>k. k \<in># Y + ?Pa \<Longrightarrow> \<exists>a. a \<in># X \<and> k < a"
        using ex_gt mod_ge ex_gt_e by (metis in_replicate_mset union_iff)

      show ?thesis
        by (subst (4 8) hmultiset.collapse[symmetric],
          unfold HMSet_plus[symmetric] HMSet_less less_multiset\<^sub>D\<^sub>M,
          rule exI[of _ X], rule exI[of _ "Y + ?Pa"],
          intro conjI impI allI X_nemp X_sub' mam_eq, elim max_X)
    qed
    thus ?thesis
      using n_nz n_lt_p by (subst (1 2) encode.simps[unfolded of_nat_times_\<omega>_exp]) auto
  qed
qed

inductive aligned\<^sub>e :: "nat \<Rightarrow> hmultiset \<Rightarrow> bool" where
  "(\<forall>m \<in># hmsetmset M. m \<ge> encode 0 e) \<Longrightarrow> aligned\<^sub>e e M"

lemma aligned\<^sub>e_encode: "aligned\<^sub>e e (encode e M)"
  by (subst encode_exp_0, rule aligned\<^sub>e.intros,
    metis encode_exp_0 leD leI lessI less_imp_encode_less lift_Suc_mono_less_iff
      mem_hmsetmset_encodeD)

lemma well_base\<^sub>h_encode: "well_base\<^sub>h (encode e n)"
proof (induct e n rule: encode.induct)
  case (1 e n)
  note ih = this

  have well2: "\<forall>M \<in># hmsetmset (encode (Suc e) (n div base)). well_base\<^sub>h M"
    using ih(2) well_base\<^sub>h.cases by (metis Suc_eq_plus1 Zero_not_Suc count_empty div_0
      encode_0_iff hmsetmset_empty_iff in_countE)

  have cnt1: "count (hmsetmset (encode (Suc e) (n div base))) (encode 0 e) = 0"
    using aligned\<^sub>e_encode[unfolded aligned\<^sub>e.simps]
      less_imp_encode_less[of n "Suc n" for n, simplified]
    by (meson count_inI leD)

  show ?case
  proof (rule well_base\<^sub>h.intros)
    show "\<forall>M \<in># hmsetmset (encode e n). well_base\<^sub>h M"
      by (subst encode.simps[unfolded of_nat_times_\<omega>_exp],
        simp add: zero_hmultiset_def hmsetmset_plus, use ih(1) well2 in blast)
  next
    show "well_base (hmsetmset (encode e n))"
      using cnt1 base_ge_2
      by (subst encode.simps[unfolded of_nat_times_\<omega>_exp],
        simp add: well_base.simps zero_hmultiset_def hmsetmset_plus,
        metis ih(2) well_base\<^sub>h.simps Suc_eq_plus1 less_numeral_extra(3) well_base.simps)
  qed
qed

subsection \<open>Decoding of Natural Numbers from Ordinals\<close>

primrec decode :: "nat \<Rightarrow> hmultiset \<Rightarrow> nat" where
  "decode e (HMSet M) = (\<Sum>m \<in># M. base ^ decode 0 m) div base ^ e"

lemma decode_unfold: "decode e M = (\<Sum>m \<in># hmsetmset M. base ^ decode 0 m) div base ^ e"
  by (cases M) simp

lemma decode_0[simp]: "decode e 0 = 0"
  unfolding zero_hmultiset_def by simp

inductive aligned\<^sub>d :: "nat \<Rightarrow> hmultiset \<Rightarrow> bool" where
  "(\<forall>m \<in># hmsetmset M. decode 0 m \<ge> e) \<Longrightarrow> aligned\<^sub>d e M"

lemma aligned\<^sub>d_0[simp]: "aligned\<^sub>d 0 M"
  by (rule aligned\<^sub>d.intros) simp

lemma aligned\<^sub>d_mono_exp_Suc: "aligned\<^sub>d (Suc e) M \<Longrightarrow> aligned\<^sub>d e M"
  by (auto simp: aligned\<^sub>d.simps)

lemma aligned\<^sub>d_mono_hmset:
  assumes "aligned\<^sub>d e M" and "hmsetmset M' \<subseteq># hmsetmset M"
  shows "aligned\<^sub>d e M'"
  using assms by (auto simp: aligned\<^sub>d.simps)

lemma decode_exp_shift_Suc:
  assumes align\<^sub>d: "aligned\<^sub>d (Suc e) M"
  shows "decode e M = base * decode (Suc e) M"
proof (subst (1 2) decode_unfold, subst (1 2) sum_mset_distrib_div_if_dvd)
  note align' = align\<^sub>d[unfolded aligned\<^sub>d.simps, simplified, unfolded Suc_le_eq]

  show "\<forall>m \<in># hmsetmset M. base ^ Suc e dvd base ^ decode 0 m"
    using align' Suc_leI le_imp_power_dvd by blast

  show "\<forall>m \<in># hmsetmset M. base ^ e dvd base ^ decode 0 m"
    using align' by (simp add: le_imp_power_dvd le_less)

  have base_e_nz: "base ^ e \<noteq> 0"
    using base_ge_2 by simp

  have mult_base:
    "base ^ decode 0 m div base ^ e = base * (base ^ decode 0 m div (base * base ^ e))"
    if m_in: "m \<in># hmsetmset M" for m
    using m_in align'
    by (subst power_div_same_base[OF base_e_nz], force,
      metis Suc_diff_Suc Suc_leI mult_is_0 power_Suc power_div_same_base power_not_zero)

  show "(\<Sum>m\<in>#hmsetmset M. base ^ decode 0 m div base ^ e) =
    base * (\<Sum>m\<in>#hmsetmset M. base ^ decode 0 m div base ^ Suc e)"
    by (auto simp: sum_mset_distrib_left intro!: arg_cong[of _ _ sum_mset] image_mset_cong
      elim!: mult_base)
qed

lemma decode_exp_shift:
  assumes "aligned\<^sub>d e M"
  shows "decode 0 M = base ^ e * decode e M"
  using assms by (induct e) (auto simp: decode_exp_shift_Suc dest: aligned\<^sub>d_mono_exp_Suc)

lemma decode_plus:
  assumes align\<^sub>d_M: "aligned\<^sub>d e M"
  shows "decode e (M + N) = decode e M + decode e N"
  using align\<^sub>d_M[unfolded aligned\<^sub>d.simps, simplified]
  by (subst (1 2 3) decode_unfold) (auto simp: hmsetmset_plus
    intro!: le_imp_power_dvd div_plus_div_distrib_dvd_left[OF sum_mset_dvd])

lemma less_imp_decode_less:
  assumes
    "well_base\<^sub>h M" and
    "aligned\<^sub>d e M" and
    "aligned\<^sub>d e N" and
    "M < N"
  shows "decode e M < decode e N"
  using assms
proof (induct M arbitrary: N e rule: less_induct)
  case (less M)
  note ih = this(1) and well\<^sub>h_M = this(2) and align\<^sub>d_M = this(3) and align\<^sub>d_N = this(4) and
    M_lt_N = this(5)

  obtain K Ma Na where
    M: "M = K + Ma" and
    N: "N = K + Na" and
    hds: "head_\<omega> Ma < head_\<omega> Na"
    using hmset_pair_decompose_less[OF M_lt_N] by blast

  obtain H where
    H: "head_\<omega> Na = \<omega>^H"
    using hds head_\<omega>_def by fastforce
  have H_in: "H \<in># hmsetmset Na"
    by (metis (no_types) H Max_in add_mset_eq_single add_mset_not_empty finite_set_mset head_\<omega>_def
      hmsetmset_empty_iff hmultiset.simps(1) set_mset_eq_empty_iff zero_hmultiset_def)

  have well\<^sub>h_Ma: "well_base\<^sub>h Ma"
    by (rule well_base\<^sub>h_mono_hmset[OF well\<^sub>h_M]) (simp add: M hmsetmset_plus)
  have align\<^sub>d_K: "aligned\<^sub>d e K"
    using M align\<^sub>d_M aligned\<^sub>d_mono_hmset hmsetmset_plus by auto
  have align\<^sub>d_Ma: "aligned\<^sub>d e Ma"
    using M align\<^sub>d_M aligned\<^sub>d_mono_hmset hmsetmset_plus by auto
  have align\<^sub>d_Na: "aligned\<^sub>d e Na"
    using N align\<^sub>d_N aligned\<^sub>d_mono_hmset hmsetmset_plus by auto

  have "inj_on (decode 0) (set_mset (hmsetmset Ma))"
    unfolding inj_on_def
  proof clarify
    fix x y
    assume
      x_in: "x \<in># hmsetmset Ma" and
      y_in: "y \<in># hmsetmset Ma" and
      dec_eq: "decode 0 x = decode 0 y"

    {
      fix x y
      assume
        x_in: "x \<in># hmsetmset Ma" and
        y_in: "y \<in># hmsetmset Ma" and
        x_lt_y: "x < y"

      have x_lt_M: "x < M"
        unfolding M using mem_hmsetmset_imp_less[OF x_in] by (simp add: trans_less_add2_hmset)
      have well\<^sub>h_x: "well_base\<^sub>h x"
        using well\<^sub>h_Ma well_base\<^sub>h.simps x_in by blast

      have "decode 0 x < decode 0 y"
        by (rule ih[OF x_lt_M well\<^sub>h_x aligned\<^sub>d_0 aligned\<^sub>d_0 x_lt_y])
    }
    thus "x = y"
      using x_in y_in dec_eq by (metis leI less_irrefl_nat order.not_eq_order_implies_strict)
  qed
  hence well_dec_Ma: "well_base (image_mset (decode 0) (hmsetmset Ma))"
    by (rule well_base_image_inj[OF well_base\<^sub>h_imp_well_base[OF well\<^sub>h_Ma]])

  have H_bound: "\<forall>m \<in># hmsetmset Ma. decode 0 m < decode 0 H"
  proof
    fix m
    assume m_in: "m \<in># hmsetmset Ma"

    have "\<forall>m \<in># hmsetmset (head_\<omega> Ma). m < H"
      using hds[unfolded H] using head_\<omega>_def by auto
    hence m_lt_H: "m < H"
      using m_in
      by (metis Max_less_iff empty_iff finite_set_mset head_\<omega>_def hmultiset.sel insert_iff
        set_mset_add_mset_insert)

    have m_lt_M: "m < M"
      using mem_hmsetmset_imp_less[OF m_in] by (simp add: M trans_less_add2_hmset)

    have well\<^sub>h_m: "well_base\<^sub>h m"
      using m_in well\<^sub>h_Ma well_base\<^sub>h.cases by blast

    show "decode 0 m < decode 0 H"
      by (rule ih[OF m_lt_M well\<^sub>h_m aligned\<^sub>d_0 aligned\<^sub>d_0 m_lt_H])
  qed

  have "decode 0 Ma < base ^ decode 0 H"
    using well_base_bound[OF well_dec_Ma, simplified, OF H_bound] by (subst decode_unfold) simp
  also have "\<dots> \<le> decode 0 Na"
    by (subst (2) decode_unfold, simp, rule sum_image_mset_mono_mem[OF H_in])
  finally have "decode e Ma < decode e Na"
    using decode_exp_shift[OF align\<^sub>d_Ma] decode_exp_shift[OF align\<^sub>d_Na] by simp
  thus "decode e M < decode e N"
    unfolding M N by (simp add: decode_plus[OF align\<^sub>d_K])
qed

lemma inj_decode: "inj_on (decode e) {M. well_base\<^sub>h M \<and> aligned\<^sub>d e M}"
  unfolding inj_on_def Ball_def mem_Collect_eq
  by (metis less_imp_decode_less less_irrefl_nat neqE)

lemma decode_0_iff: "well_base\<^sub>h M \<Longrightarrow> aligned\<^sub>d e M \<Longrightarrow> decode e M = 0 \<longleftrightarrow> M = 0"
  by (metis aligned\<^sub>d_0 decode_0 decode_exp_shift encode_0 less_imp_decode_less mult_0_right neqE
    not_less_zero well_base\<^sub>h_encode)

lemma decode_encode: "decode e (encode e n) = n"
proof (induct e n rule: encode.induct)
  case (1 e n)
  note ih = this

  show ?case
  proof (cases "n = 0")
    case n_nz: False

    have align\<^sub>d1: "aligned\<^sub>d e (of_nat (n mod base) * \<omega>^(encode 0 e))"
      unfolding of_nat_times_\<omega>_exp using n_nz by (auto simp: ih(1) aligned\<^sub>d.simps)
    have align\<^sub>d2: "aligned\<^sub>d (Suc e) (encode (Suc e) (n div base))"
      by (safe intro!: aligned\<^sub>d.intros, subst ih(1)[OF n_nz, symmetric],
        auto dest: mem_hmsetmset_encodeD intro!: Suc_le_eq[THEN iffD2]
          less_imp_decode_less[OF well_base\<^sub>h_encode aligned\<^sub>d_0 aligned\<^sub>d_0] less_imp_encode_less)

    show ?thesis
      using ih base_ge_2
      by (subst encode.simps[unfolded of_nat_times_\<omega>_exp])
        (simp add: decode_plus[OF align\<^sub>d1[unfolded of_nat_times_\<omega>_exp]]
           decode_exp_shift_Suc[OF align\<^sub>d2])
  qed simp
qed

lemma encode_decode_exp_0: "well_base\<^sub>h M \<Longrightarrow> encode 0 (decode 0 M) = M"
  by (auto intro: inj_onD[OF inj_decode] decode_encode well_base\<^sub>h_encode)

end

lemma well_base\<^sub>h_mono_base:
  assumes
    well\<^sub>h: "well_base\<^sub>h base M" and
    two: "2 \<le> base" and
    bases: "base \<le> base'"
  shows "well_base\<^sub>h base' M"
  using two well\<^sub>h
  by (induct rule: well_base\<^sub>h.induct)
    (meson two bases less_le_trans order_trans well_base\<^sub>h.intros well_base.simps)

subsection \<open>The Goodstein Sequence and Goodstein's Theorem\<close>

context
  fixes start :: nat
begin

primrec goodstein :: "nat \<Rightarrow> nat" where
  "goodstein 0 = start"
| "goodstein (Suc i) = decode (i + 3) 0 (encode (i + 2) 0 (goodstein i)) - 1"

lemma goodstein_step:
  assumes gi_gt_0: "goodstein i > 0"
  shows "encode (i + 2) 0 (goodstein i) > encode (i + 3) 0 (goodstein (i + 1))"
proof -
  let ?Ei = "encode (i + 2) 0 (goodstein i)"
  let ?reencode = "encode (i + 3) 0"
  let ?decoded_Ei = "decode (i + 3) 0 ?Ei"

  have two_le: "2 \<le> i + 3"
    by simp

  have "well_base\<^sub>h (i + 2) ?Ei"
    by (rule well_base\<^sub>h_encode) simp
  hence well\<^sub>h: "well_base\<^sub>h (i + 3) ?Ei"
    by (rule well_base\<^sub>h_mono_base) simp_all

  have decoded_Ei_gt_0: "?decoded_Ei > 0"
    by (metis gi_gt_0 gr0I encode_0_iff le_add2 decode_0_iff[OF _ well\<^sub>h aligned\<^sub>d_0] two_le)

  have "?reencode (?decoded_Ei - 1) < ?reencode ?decoded_Ei"
    by (rule less_imp_encode_less[OF two_le]) (use decoded_Ei_gt_0 in linarith)
  also have "\<dots> = ?Ei"
    by (simp only: encode_decode_exp_0[OF two_le well\<^sub>h])
  finally show ?thesis
    by simp
qed

theorem goodsteins_theorem: "\<exists>i. goodstein i = 0"
proof -
  let ?G = "\<lambda>i. encode (i + 2) 0 (goodstein i)"

  obtain i where
    "\<not> ?G i > ?G (i + 1)"
    using wf_iff_no_infinite_down_chain[THEN iffD1, OF wf,
      unfolded not_ex not_all mem_Collect_eq prod.case, rule_format, of ?G]
    by auto
  hence "goodstein i = 0"
    using goodstein_step by (metis add.assoc gr0I one_plus_numeral semiring_norm(3))
  thus ?thesis
    by blast
qed

end

end


(*  Title:      FOL/ex/Quantifiers_Int.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1991  University of Cambridge
*)

section \<open>First-Order Logic: quantifier examples (intuitionistic version)\<close>

theory Quantifiers_Int
imports IFOL
begin

lemma \<open>(\<forall>x y. P(x,y)) \<longrightarrow> (\<forall>y x. P(x,y))\<close>
  by (tactic "IntPr.fast_tac \<^context> 1")

lemma \<open>(\<exists>x y. P(x,y)) \<longrightarrow> (\<exists>y x. P(x,y))\<close>
  by (tactic "IntPr.fast_tac \<^context> 1")

\<comment> \<open>Converse is false\<close>
lemma \<open>(\<forall>x. P(x)) \<or> (\<forall>x. Q(x)) \<longrightarrow> (\<forall>x. P(x) \<or> Q(x))\<close>
  by (tactic "IntPr.fast_tac \<^context> 1")

lemma \<open>(\<forall>x. P \<longrightarrow> Q(x)) \<longleftrightarrow> (P \<longrightarrow> (\<forall>x. Q(x)))\<close>
  by (tactic "IntPr.fast_tac \<^context> 1")

lemma \<open>(\<forall>x. P(x) \<longrightarrow> Q) \<longleftrightarrow> ((\<exists>x. P(x)) \<longrightarrow> Q)\<close>
  by (tactic "IntPr.fast_tac \<^context> 1")

text \<open>Some harder ones\<close>

lemma \<open>(\<exists>x. P(x) \<or> Q(x)) \<longleftrightarrow> (\<exists>x. P(x)) \<or> (\<exists>x. Q(x))\<close>
  by (tactic "IntPr.fast_tac \<^context> 1")

\<comment> \<open>Converse is false\<close>
lemma \<open>(\<exists>x. P(x) \<and> Q(x)) \<longrightarrow> (\<exists>x. P(x)) \<and> (\<exists>x. Q(x))\<close>
  by (tactic "IntPr.fast_tac \<^context> 1")

text \<open>Basic test of quantifier reasoning\<close>

\<comment> \<open>TRUE\<close>
lemma \<open>(\<exists>y. \<forall>x. Q(x,y)) \<longrightarrow> (\<forall>x. \<exists>y. Q(x,y))\<close>
  by (tactic "IntPr.fast_tac \<^context> 1")

lemma \<open>(\<forall>x. Q(x)) \<longrightarrow> (\<exists>x. Q(x))\<close>
  by (tactic "IntPr.fast_tac \<^context> 1")

text \<open>The following should fail, as they are false!\<close>

lemma \<open>(\<forall>x. \<exists>y. Q(x,y)) \<longrightarrow> (\<exists>y. \<forall>x. Q(x,y))\<close>
  apply (tactic "IntPr.fast_tac \<^context> 1")?
  oops

lemma \<open>(\<exists>x. Q(x)) \<longrightarrow> (\<forall>x. Q(x))\<close>
  apply (tactic "IntPr.fast_tac \<^context> 1")?
  oops

schematic_goal \<open>P(?a) \<longrightarrow> (\<forall>x. P(x))\<close>
  apply (tactic "IntPr.fast_tac \<^context> 1")?
  oops

schematic_goal \<open>(P(?a) \<longrightarrow> (\<forall>x. Q(x))) \<longrightarrow> (\<forall>x. P(x) \<longrightarrow> Q(x))\<close>
  apply (tactic "IntPr.fast_tac \<^context> 1")?
  oops

text \<open>Back to things that are provable \dots\<close>

lemma \<open>(\<forall>x. P(x) \<longrightarrow> Q(x)) \<and> (\<exists>x. P(x)) \<longrightarrow> (\<exists>x. Q(x))\<close>
  by (tactic "IntPr.fast_tac \<^context> 1")

\<comment> \<open>An example of why exI should be delayed as long as possible\<close>
lemma \<open>(P \<longrightarrow> (\<exists>x. Q(x))) \<and> P \<longrightarrow> (\<exists>x. Q(x))\<close>
  by (tactic "IntPr.fast_tac \<^context> 1")

schematic_goal \<open>(\<forall>x. P(x) \<longrightarrow> Q(f(x))) \<and> (\<forall>x. Q(x) \<longrightarrow> R(g(x))) \<and> P(d) \<longrightarrow> R(?a)\<close>
  by (tactic "IntPr.fast_tac \<^context> 1")

lemma \<open>(\<forall>x. Q(x)) \<longrightarrow> (\<exists>x. Q(x))\<close>
  by (tactic "IntPr.fast_tac \<^context> 1")

text \<open>Some slow ones\<close>

\<comment> \<open>Principia Mathematica *11.53\<close>
lemma \<open>(\<forall>x y. P(x) \<longrightarrow> Q(y)) \<longleftrightarrow> ((\<exists>x. P(x)) \<longrightarrow> (\<forall>y. Q(y)))\<close>
  by (tactic "IntPr.fast_tac \<^context> 1")

(*Principia Mathematica *11.55  *)
lemma \<open>(\<exists>x y. P(x) \<and> Q(x,y)) \<longleftrightarrow> (\<exists>x. P(x) \<and> (\<exists>y. Q(x,y)))\<close>
  by (tactic "IntPr.fast_tac \<^context> 1")

(*Principia Mathematica *11.61  *)
lemma \<open>(\<exists>y. \<forall>x. P(x) \<longrightarrow> Q(x,y)) \<longrightarrow> (\<forall>x. P(x) \<longrightarrow> (\<exists>y. Q(x,y)))\<close>
  by (tactic "IntPr.fast_tac \<^context> 1")

end


(* Title: Program Correctness Component Based on Kleene Algebra with Tests
   Author: Victor Gomes, Georg Struth
   Maintainer: Victor Gomes <victor.gomes@cl.cam.ac.uk>
               Georg Struth <g.struth@sheffield.ac.uk>
*)

section \<open>Two Standalone Components\<close>

theory VC_KAT_scratch
  imports Main
begin

subsection \<open>Component Based on Kleene Algebra with Tests\<close>

text \<open>This component supports the verification and step-wise refinement of simple while programs
in a partial correctness setting.\<close>

subsubsection \<open>KAT: Definition and Basic Properties\<close>

notation times (infixl "\<cdot>" 70)

class plus_ord = plus + ord +
  assumes less_eq_def: "x \<le> y \<longleftrightarrow> x + y = y"
  and less_def: "x < y \<longleftrightarrow> x \<le> y \<and> x \<noteq> y"

class dioid = semiring + one + zero + plus_ord +
  assumes add_idem [simp]: "x + x = x"
  and mult_onel [simp]: "1 \<cdot> x = x"
  and mult_oner [simp]: "x \<cdot> 1 = x"
  and add_zerol [simp]: "0 + x = x"
  and annil [simp]: "0 \<cdot> x = 0"
  and annir [simp]: "x \<cdot> 0 = 0"

begin

subclass monoid_mult
  by (standard, simp_all)

subclass order
  apply (standard, simp_all add: less_def less_eq_def add_commute)
  apply force
  by (metis add_assoc)

lemma mult_isol: "x \<le> y \<Longrightarrow> z \<cdot> x \<le> z \<cdot> y"
  by (metis distrib_left less_eq_def)

lemma mult_isor: "x \<le> y \<Longrightarrow> x \<cdot> z \<le> y \<cdot> z"
  by (metis distrib_right less_eq_def)

lemma add_iso: "x \<le> y \<Longrightarrow> x + z \<le> y + z"
  by (metis (no_types, lifting) abel_semigroup.commute add.abel_semigroup_axioms add.semigroup_axioms add_idem less_eq_def semigroup.assoc)

lemma add_lub: "x + y \<le> z \<longleftrightarrow> x \<le> z \<and> y \<le> z"
  by (metis add_assoc add_commute less_eq_def order.ordering_axioms ordering.refl)

end

class kleene_algebra = dioid +
  fixes star :: "'a \<Rightarrow> 'a" ("_\<^sup>\<star>" [101] 100)
  assumes star_unfoldl: "1 + x \<cdot> x\<^sup>\<star> \<le> x\<^sup>\<star>"
  and star_unfoldr: "1 + x\<^sup>\<star> \<cdot> x \<le> x\<^sup>\<star>"
  and star_inductl: "z + x \<cdot> y \<le> y \<Longrightarrow> x\<^sup>\<star> \<cdot> z \<le> y"
  and star_inductr: "z + y \<cdot> x \<le> y \<Longrightarrow> z \<cdot> x\<^sup>\<star> \<le> y"

begin

lemma star_sim: "x \<cdot> y \<le> z \<cdot> x \<Longrightarrow> x \<cdot> y\<^sup>\<star> \<le> z\<^sup>\<star> \<cdot> x"
proof -
  assume "x \<cdot> y \<le> z \<cdot> x"
  hence "x + z\<^sup>\<star> \<cdot> x \<cdot> y \<le> x + z\<^sup>\<star> \<cdot> z \<cdot> x"
    by (metis add_lub distrib_left eq_refl less_eq_def mult_assoc)
  also have  "... \<le> z\<^sup>\<star> \<cdot> x"
    using add_lub mult_isor star_unfoldr by fastforce
  finally show ?thesis
    by (simp add: star_inductr)
qed

end

class kat = kleene_algebra +
  fixes at :: "'a \<Rightarrow> 'a"
  assumes test_one [simp]: "at (at 1) = 1"
  and test_mult [simp]: "at (at (at (at x) \<cdot> at (at y))) = at (at y) \<cdot> at (at x)"
  and test_mult_comp [simp]: "at x \<cdot> at (at x) = 0"
  and test_de_morgan: "at x + at y = at (at (at x) \<cdot> at (at y))"

begin

definition t_op :: "'a \<Rightarrow> 'a" ("t_" [100] 101) where
  "t x = at (at x)"

lemma t_n [simp]: "t (at x) = at x"
  by (metis add_idem test_de_morgan test_mult t_op_def)

lemma t_comm: "t x \<cdot> t y = t y \<cdot> t x"
  by (metis add_commute test_de_morgan test_mult t_op_def)

lemma t_idem [simp]: "t x \<cdot> t x = t x"
  by (metis add_idem test_de_morgan test_mult t_op_def)

lemma t_mult_closed [simp]: "t (t x \<cdot> t y) = t x \<cdot> t y"
  using t_comm t_op_def by auto

subsubsection\<open>Propositional Hoare Logic\<close>

definition H :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" where
  "H p x q \<longleftrightarrow> t p \<cdot> x \<le> x \<cdot> t q"

definition if_then_else :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" ("if _ then _ else _ fi" [64,64,64] 63) where
  "if p then x else y fi = t p \<cdot> x + at p \<cdot> y"

definition while :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" ("while _ do _ od" [64,64] 63) where
  "while p do x od = (t p \<cdot> x)\<^sup>\<star> \<cdot> at p"

definition while_inv :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" ("while _ inv _ do _ od" [64,64,64] 63) where
  "while p inv i do x od = while p do x od"

lemma H_skip: "H p 1 p"
  by (simp add: H_def)

lemma H_cons: "t p \<le> t p' \<Longrightarrow> t q' \<le> t q \<Longrightarrow> H p' x q' \<Longrightarrow> H p x q"
  by (meson H_def mult_isol mult_isor order.trans)

lemma H_seq: "H r y q \<Longrightarrow> H p x r  \<Longrightarrow> H p (x \<cdot> y) q"
proof -
  assume h1: "H p x r" and h2: "H r y q"
  hence h3: "t p \<cdot> x \<le> x \<cdot> t r" and h4: "t r \<cdot> y \<le> y \<cdot> t q"
    using H_def apply  blast using H_def h2 by blast
  hence "t p \<cdot> x \<cdot> y \<le> x \<cdot> t r \<cdot> y"
    using mult_isor by blast
  also have "... \<le> x \<cdot> y \<cdot> t q"
    by (simp add: h4 mult_isol mult_assoc)
  finally show ?thesis
    by (simp add: H_def mult_assoc)
qed

lemma H_cond: "H (t p \<cdot> t r) x q \<Longrightarrow> H (t p \<cdot> at r) y q \<Longrightarrow> H p (if r then x else y fi) q"
proof -
  assume h1: "H (t p \<cdot> t r) x q" and h2: "H (t p \<cdot> at r) y q"
  hence h3: "t r \<cdot> t p \<cdot> t r \<cdot> x \<le> t r \<cdot> x \<cdot> t q" and h4: "at r \<cdot> t p \<cdot> at r \<cdot> y \<le> at r \<cdot> y \<cdot> t q"
    by (simp add: H_def mult_isol mult_assoc, metis H_def h2 mult_isol mult_assoc t_mult_closed t_n)
  hence h5: "t p \<cdot> t r \<cdot> x \<le> t r \<cdot> x \<cdot> t q" and  h6: "t p \<cdot> at r \<cdot> y \<le> at r \<cdot> y \<cdot> t q"
    by (simp add: mult_assoc t_comm, metis h4 mult_assoc t_comm t_idem t_n)
  have "t p \<cdot> (t r \<cdot> x + at r \<cdot> y) = t p \<cdot> t r \<cdot> x + t p \<cdot> at r \<cdot> y"
    by (simp add: distrib_left mult_assoc)
  also have "... \<le> t r \<cdot> x \<cdot> t q + t p \<cdot> at r \<cdot> y"
    using h5 add_iso by blast
  also have "... \<le> t r \<cdot> x \<cdot> t q + at r \<cdot> y \<cdot> t q"
    by (simp add: add_commute h6 add_iso)
  finally show ?thesis
    by (simp add: H_def if_then_else_def distrib_right)
qed

lemma H_loop: "H (t p \<cdot> t r) x p \<Longrightarrow> H p (while r do x od) (t p \<cdot> at r)"
proof -
  assume  "H (t p \<cdot> t r) x p"
  hence "t r \<cdot> t p \<cdot> t r \<cdot> x \<le> t r \<cdot> x \<cdot> t p"
    by (metis H_def distrib_left less_eq_def mult_assoc t_mult_closed)
  hence "t p \<cdot> t r \<cdot> x \<le> t r \<cdot> x \<cdot> t p"
    by (simp add: mult_assoc t_comm)
  hence "t p \<cdot> (t r \<cdot> x)\<^sup>\<star> \<cdot> at r \<le> (t r \<cdot> x)\<^sup>\<star> \<cdot> t p \<cdot> at r"
    by (metis mult_isor star_sim mult_assoc)
  hence "t p \<cdot> (t r \<cdot> x)\<^sup>\<star> \<cdot> at r \<le> (t r \<cdot> x)\<^sup>\<star> \<cdot> at r \<cdot> t p \<cdot> at r"
    by (metis mult_assoc t_comm t_idem t_n)
  thus ?thesis
    by (metis H_def mult_assoc t_mult_closed t_n while_def)
qed

lemma H_while_inv: "t p \<le> t i \<Longrightarrow> t i \<cdot> at r \<le> t q \<Longrightarrow> H (t i \<cdot> t r) x i \<Longrightarrow> H p (while r inv i do x od) q"
  by (metis H_cons H_loop t_mult_closed t_n while_inv_def)

end

subsubsection\<open>Soundness and Relation KAT\<close>

notation relcomp (infixl ";" 70)

interpretation rel_d: dioid Id "{}" "(\<union>)" "(;)" "(\<subseteq>)" "(\<subset>)"
  by (standard, auto)

lemma (in dioid) power_inductl: "z + x \<cdot> y \<le> y \<Longrightarrow> x ^ i \<cdot> z \<le> y"
  apply (induct i; clarsimp simp add: add_lub)
  by (metis local.dual_order.trans local.mult_isol mult_assoc)

lemma (in dioid) power_inductr: "z + y \<cdot> x \<le> y \<Longrightarrow> z \<cdot> x ^ i \<le> y"
  apply (induct i; clarsimp simp add: add_lub)
  proof -
    fix i
    assume "z \<cdot> x ^ i \<le> y" "z \<le> y" "y \<cdot> x \<le> y"
    hence "(z \<cdot> x ^ i) \<cdot> x \<le> y"
      using local.dual_order.trans local.mult_isor by blast
    thus "z \<cdot> (x \<cdot> x ^ i) \<le> y"
      by (simp add: mult_assoc local.power_commutes)
  qed

lemma power_is_relpow: "rel_d.power X i = X ^^ i"
  by (induct i, simp_all add: relpow_commute)

lemma rel_star_def: "X^* = (\<Union>i. rel_d.power X i)"
  by (simp add: power_is_relpow rtrancl_is_UN_relpow)

lemma rel_star_contl: "X ; Y^* = (\<Union>i. X ; rel_d.power Y i)"
  by (simp add: rel_star_def relcomp_UNION_distrib)

lemma rel_star_contr: "X^* ; Y = (\<Union>i. (rel_d.power X i) ; Y)"
  by (simp add: rel_star_def relcomp_UNION_distrib2)

definition rel_at :: "'a rel \<Rightarrow> 'a rel" where
  "rel_at X = Id \<inter> - X"

interpretation rel_kat: kat Id "{}" "(\<union>)" "(;)" "(\<subseteq>)" "(\<subset>)" rtrancl rel_at
  apply standard
  apply auto[2]
  by (auto simp: rel_star_contr rel_d.power_inductl rel_star_contl  SUP_least rel_d.power_inductr rel_at_def)

subsubsection\<open>Embedding Predicates in Relations\<close>

type_synonym 'a pred = "'a \<Rightarrow> bool"

abbreviation p2r :: "'a pred \<Rightarrow> 'a rel" ("\<lceil>_\<rceil>") where
  "\<lceil>P\<rceil> \<equiv> {(s,s) |s. P s}"

lemma t_p2r [simp]: "rel_kat.t_op \<lceil>P\<rceil> = \<lceil>P\<rceil>"
  by (auto simp add: rel_kat.t_op_def rel_at_def)

lemma p2r_neg_hom [simp]: "rel_at \<lceil>P\<rceil> = \<lceil>\<lambda>s. \<not> P s\<rceil>"
  by (auto simp: rel_at_def)

lemma p2r_conj_hom [simp]: "\<lceil>P\<rceil> \<inter> \<lceil>Q\<rceil> = \<lceil>\<lambda>s.  P s \<and> Q s\<rceil>"
  by auto

lemma p2r_conj_hom_var [simp]: "\<lceil>P\<rceil> ; \<lceil>Q\<rceil> = \<lceil>\<lambda>s. P s \<and> Q s\<rceil>"
  by auto

lemma p2r_disj_hom [simp]: "\<lceil>P\<rceil> \<union> \<lceil>Q\<rceil> = \<lceil>\<lambda>s. P s \<or> Q s\<rceil>"
  by auto

lemma impl_prop [simp]: "\<lceil>P\<rceil> \<subseteq> \<lceil>Q\<rceil> \<longleftrightarrow> (\<forall>s. P s \<longrightarrow>  Q s)"
  by auto

subsubsection \<open>Store and Assignment\<close>

type_synonym 'a store = "string  \<Rightarrow> 'a"

definition gets :: "string \<Rightarrow> ('a store \<Rightarrow> 'a) \<Rightarrow> 'a store rel" ("_ ::= _" [70, 65] 61) where
  "v ::= e = {(s, s(v := e s)) |s. True}"

lemma H_assign: "rel_kat.H \<lceil>\<lambda>s. P (s (v := e s))\<rceil> (v ::= e) \<lceil>P\<rceil>"
  by (auto simp: gets_def rel_kat.H_def rel_kat.t_op_def rel_at_def)

lemma H_assign_var: "(\<forall>s. P s \<longrightarrow> Q (s (v := e s))) \<Longrightarrow> rel_kat.H \<lceil>P\<rceil> (v ::= e) \<lceil>Q\<rceil>"
  by (auto simp: gets_def rel_kat.H_def rel_kat.t_op_def rel_at_def)

abbreviation H_sugar :: "'a pred \<Rightarrow> 'a rel \<Rightarrow> 'a pred \<Rightarrow> bool" ("PRE _ _ POST _" [64,64,64] 63) where
  "PRE P X POST Q \<equiv> rel_kat.H \<lceil>P\<rceil> X \<lceil>Q\<rceil>"

abbreviation if_then_else_sugar :: "'a pred \<Rightarrow> 'a rel \<Rightarrow> 'a rel \<Rightarrow> 'a rel" ("IF _ THEN _ ELSE _ FI" [64,64,64] 63) where
  "IF P THEN X ELSE Y FI \<equiv> rel_kat.if_then_else \<lceil>P\<rceil> X Y"

abbreviation while_inv_sugar :: "'a pred \<Rightarrow> 'a pred \<Rightarrow> 'a rel \<Rightarrow> 'a rel" ("WHILE _ INV _ DO _ OD" [64,64,64] 63) where
  "WHILE P INV I DO X OD \<equiv> rel_kat.while_inv \<lceil>P\<rceil> \<lceil>I\<rceil> X"

subsubsection \<open>Verification Example\<close>

lemma euclid:
  "PRE (\<lambda>s::nat store. s ''x'' = x \<and> s ''y'' = y)
   (WHILE (\<lambda>s. s ''y'' \<noteq> 0) INV (\<lambda>s. gcd (s ''x'') (s ''y'') = gcd x y)
    DO
     (''z'' ::= (\<lambda>s. s ''y''));
     (''y'' ::= (\<lambda>s. s ''x'' mod s ''y''));
     (''x'' ::= (\<lambda>s. s ''z''))
    OD)
   POST (\<lambda>s. s ''x'' = gcd x y)"
  apply (rule rel_kat.H_while_inv, simp_all, clarsimp)
  apply (intro rel_kat.H_seq)
  apply (subst H_assign, simp)+
  apply (rule H_assign_var)
  using gcd_red_nat by auto

subsubsection \<open>Definition of Refinement KAT\<close>

class rkat = kat +
  fixes R :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"
  assumes R1: "H p (R p q) q"
  and R2: "H p x q \<Longrightarrow> x \<le> R p q"

begin

subsubsection \<open>Propositional Refinement Calculus\<close>

lemma R_skip: "1 \<le> R p p"
  by (simp add: H_skip R2)

lemma R_cons: "t p \<le> t p' \<Longrightarrow> t q' \<le> t q \<Longrightarrow> R p' q' \<le> R p q"
  by (simp add: H_cons R2 R1)

lemma R_seq: "(R p r) \<cdot> (R r q) \<le> R p q"
  using H_seq R2 R1 by blast

lemma R_cond: "if v then (R (t v \<cdot> t p) q) else (R (at v \<cdot> t p) q) fi \<le> R p q"
  by (metis H_cond R1 R2 t_comm t_n)

lemma R_loop: "while q do (R (t p \<cdot> t q) p) od  \<le> R p (t p \<cdot> at q)"
  by (simp add: H_loop R2 R1)

end

subsubsection \<open>Soundness and Relation RKAT\<close>

definition rel_R :: "'a rel \<Rightarrow> 'a rel \<Rightarrow> 'a rel" where
  "rel_R P Q = \<Union>{X. rel_kat.H P X Q}"

interpretation rel_rkat: rkat Id "{}" "(\<union>)"  "(;)" "(\<subseteq>)" "(\<subset>)" rtrancl rel_at rel_R
  by (standard, auto simp: rel_R_def rel_kat.H_def rel_kat.t_op_def rel_at_def)

subsubsection \<open>Assignment Laws\<close>

lemma R_assign: "(\<forall>s. P s \<longrightarrow> Q (s (v := e s))) \<Longrightarrow> (v ::= e) \<subseteq> rel_R \<lceil>P\<rceil> \<lceil>Q\<rceil>"
  by (simp add: H_assign_var rel_rkat.R2)

lemma R_assignr: "(\<forall>s. Q' s \<longrightarrow> Q (s (v := e s))) \<Longrightarrow> (rel_R \<lceil>P\<rceil> \<lceil>Q'\<rceil>) ; (v ::= e) \<subseteq> rel_R \<lceil>P\<rceil> \<lceil>Q\<rceil>"
proof -
  assume a1: "\<forall>s. Q' s \<longrightarrow> Q (s(v := e s))"
  have "\<forall>p pa cs f. \<exists>fa. (p fa \<or> cs ::= f \<subseteq> rel_R \<lceil>p\<rceil> \<lceil>pa\<rceil>) \<and> (\<not> pa (fa(cs := f fa::'a)) \<or> cs ::= f \<subseteq> rel_R \<lceil>p\<rceil> \<lceil>pa\<rceil>)"
    using R_assign by blast
  hence "v ::= e \<subseteq> rel_R \<lceil>Q'\<rceil> \<lceil>Q\<rceil>"
    using a1 by blast
  thus ?thesis
    by (meson dual_order.trans rel_d.mult_isol rel_rkat.R_seq)
qed

lemma R_assignl: "(\<forall>s. P s \<longrightarrow> P' (s (v := e s))) \<Longrightarrow> (v ::= e) ; (rel_R \<lceil>P'\<rceil> \<lceil>Q\<rceil>) \<subseteq> rel_R \<lceil>P\<rceil> \<lceil>Q\<rceil>"
proof -
  assume a1: "\<forall>s. P s \<longrightarrow> P' (s(v := e s))"
  have "\<forall>p pa cs f. \<exists>fa. (p fa \<or> cs ::= f \<subseteq> rel_R \<lceil>p\<rceil> \<lceil>pa\<rceil>) \<and> (\<not> pa (fa(cs := f fa::'a)) \<or> cs ::= f \<subseteq> rel_R \<lceil>p\<rceil> \<lceil>pa\<rceil>)"
    using R_assign by blast
  then have "v ::= e \<subseteq> rel_R \<lceil>P\<rceil> \<lceil>P'\<rceil>"
    using a1 by blast
  then show ?thesis
    by (meson dual_order.trans rel_d.mult_isor rel_rkat.R_seq)
qed

subsubsection \<open>Refinement Example\<close>

lemma var_swap_ref1:
  "rel_R \<lceil>\<lambda>s. s ''x'' = a \<and> s ''y'' = b\<rceil> \<lceil>\<lambda>s. s ''x'' = b \<and> s ''y'' = a\<rceil>
   \<supseteq> (''z'' ::= (\<lambda>s. s ''x'')); rel_R \<lceil>\<lambda>s. s ''z'' = a \<and> s ''y'' = b\<rceil> \<lceil>\<lambda>s. s ''x'' = b \<and> s ''y'' = a\<rceil>"
  by (rule R_assignl, auto)

lemma var_swap_ref2:
  "rel_R \<lceil>\<lambda>s. s ''z'' = a \<and> s ''y'' = b\<rceil> \<lceil>\<lambda>s. s ''x'' = b \<and> s ''y'' = a\<rceil>
   \<supseteq> (''x'' ::= (\<lambda>s. s ''y'')); rel_R \<lceil>\<lambda>s. s ''z'' = a \<and> s ''x'' = b\<rceil> \<lceil>\<lambda>s. s ''x'' = b \<and> s ''y'' = a\<rceil>"
  by (rule R_assignl, auto)

lemma var_swap_ref3:
  "rel_R \<lceil>\<lambda>s. s ''z'' = a \<and> s ''x'' = b\<rceil> \<lceil>\<lambda>s. s ''x'' = b \<and> s ''y'' = a\<rceil>
   \<supseteq> (''y'' ::= (\<lambda>s. s ''z'')); rel_R \<lceil>\<lambda>s. s ''x'' = b \<and> s ''y'' = a\<rceil> \<lceil>\<lambda>s. s ''x'' = b \<and> s ''y'' = a\<rceil>"
  by (rule R_assignl, auto)

lemma var_swap_ref_var:
  "rel_R \<lceil>\<lambda>s. s ''x'' = a \<and> s ''y'' = b\<rceil> \<lceil>\<lambda>s. s ''x'' = b \<and> s ''y'' = a\<rceil>
   \<supseteq> (''z'' ::= (\<lambda>s. s ''x'')); (''x'' ::= (\<lambda>s. s ''y'')); (''y'' ::= (\<lambda>s. s ''z''))"
  using var_swap_ref1 var_swap_ref2 var_swap_ref3 rel_rkat.R_skip  by fastforce

end


theory Sum
  imports Main
begin

section {* Sum *}

fun sum :: "nat \<Rightarrow> nat" where
  "sum 0 = 0"
  | "sum (Suc n') = (Suc n') + sum n'"

value "sum 0"
value "sum 1"
value "sum 2"
value "sum 3"

lemma test_sum: "sum 1 = 1" by simp
lemma test_sum2: "sum (Suc 1) = 3" by simp
lemma test_sum3: "sum (Suc (Suc 1)) = 6" by simp

theorem sum_thy: "\<forall>n :: nat. sum (Suc n) > sum n" by simp

end


(*  Title:       Primitive recursive coding of finite sets
    Author:      Michael Nedzelsky <MichaelNedzelsky at yandex.ru>, 2008
    Maintainer:  Michael Nedzelsky <MichaelNedzelsky at yandex.ru>
*)

section \<open>Finite sets\<close>

theory PRecFinSet
imports PRecFun
begin

text \<open>
  We introduce a particular mapping \<open>nat_to_set\<close> from natural
  numbers to finite sets of natural numbers and a particular mapping
  \<open>set_to_nat\<close> from finite sets of natural numbers to natural
  numbers.  See \cite{Rogers} and \cite{Soare} for more information.
\<close>

definition
  c_in :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  "c_in = (\<lambda> x u. (u div (2 ^ x)) mod 2)"

lemma c_in_is_pr: "c_in \<in> PrimRec2"
proof -
  from mod_is_pr power_is_pr div_is_pr have "(\<lambda> x u. (u div (2 ^ x)) mod 2) \<in> PrimRec2" by prec
  with c_in_def show ?thesis by auto
qed

definition
  nat_to_set :: "nat \<Rightarrow> nat set" where
  "nat_to_set u \<equiv> {x. 2^x \<le> u \<and> c_in x u = 1}"

lemma c_in_upper_bound: "c_in x u = 1 \<Longrightarrow> 2 ^ x \<le> u"
proof -
  assume A: "c_in x u = 1"
  then have S1: "(u div (2^x)) mod 2 = 1" by (unfold c_in_def)
  then have S2: "u div (2^x) > 0" by arith
  show ?thesis
  proof (rule ccontr)
    assume "\<not> 2 ^ x \<le> u"
    then have "u < 2^x" by auto
    then have "u div (2^x) = 0" by (rule div_less)
    with S2 show False by auto
  qed
qed

lemma nat_to_set_upper_bound: "x \<in> nat_to_set u \<Longrightarrow> 2 ^ x \<le> u" by (simp add: nat_to_set_def)

lemma x_lt_2_x: "x < 2 ^ x" by (induct x) auto

lemma nat_to_set_upper_bound1: "x \<in> nat_to_set u \<Longrightarrow> x < u"
proof -
  assume "x \<in> nat_to_set u"
  then have S1: "2 ^ x \<le> u" by (simp add: nat_to_set_def)
  have S2: "x < 2 ^ x" by (rule x_lt_2_x)
  from S1 S2 show ?thesis by auto
qed

lemma nat_to_set_upper_bound2: "nat_to_set u \<subseteq> {i. i < u}"
proof -
  from nat_to_set_upper_bound1 show ?thesis by blast
qed

lemma nat_to_set_is_finite: "finite (nat_to_set u)"
proof -
  have S1: "finite {i. i<u}"
  proof -
    let ?B = "{i. i<u}"
    let ?f = "(\<lambda> (x::nat). x)"
    have "?B = ?f ` ?B" by auto
    then show "finite ?B" by (rule nat_seg_image_imp_finite)
  qed
  have S2: "nat_to_set u \<subseteq> {i. i<u}" by (rule nat_to_set_upper_bound2)
  from S2 S1 show ?thesis by (rule finite_subset)
qed

lemma x_in_u_eq: "(x \<in> nat_to_set u) = (c_in x u = 1)" by (auto simp add: nat_to_set_def c_in_upper_bound)

definition
  log2 :: "nat \<Rightarrow> nat" where
  "log2 = (\<lambda> x. Least(%z. x < 2^(z+1)))"

lemma log2_at_0: "log2 0 = 0"
proof -
  let ?v = "log2 0"
  have S1: "0 \<le> ?v" by auto
  have S2: "?v = Least(%(z::nat). (0::nat)<2^(z+1))" by (simp add: log2_def)
  have S3: "(0::nat)<2^(0+1)" by auto
  from S3 have S4: "Least(%(z::nat). (0::nat)<2^(z+1)) \<le> 0" by (rule Least_le)
  from S2 S4 have S5: "?v \<le> 0" by auto
  from S1 S5 have S6: "?v = 0" by auto
  thus ?thesis by auto
qed

lemma log2_at_1: "log2 1 = 0"
proof -
  let ?v = "log2 1"
  have S1: "0 \<le> ?v" by auto
  have S2: "?v = Least(%(z::nat). (1::nat)<2^(z+1))" by (simp add: log2_def)
  have S3: "(1::nat)<2^(0+1)" by auto
  from S3 have S4: "Least(%(z::nat). (1::nat)<2^(z+1)) \<le> 0" by (rule Least_le)
  from S2 S4 have S5: "?v \<le> 0" by auto
  from S1 S5 have S6: "?v = 0" by auto
  thus ?thesis by auto
qed

lemma log2_le: "x > 0 \<Longrightarrow> 2 ^ log2 x \<le> x"
proof -
  assume A: "x > 0"
  show ?thesis
  proof (cases)
    assume A1: "log2 x = 0"
    with A show ?thesis by auto
  next
    assume A1: "log2 x \<noteq> 0"
    then have S1: "log2 x > 0" by auto
    define y where "y = log2 x - 1"
    from S1 y_def have S2: "log2 x = y + 1" by auto
    then have S3: "y < log2 x" by auto
    have "2^(y+1) \<le> x"
    proof (rule ccontr)
      assume A2: "\<not> 2^(y+1) \<le> x" then have "x < 2^(y+1)" by auto
      then have "log2 x \<le> y" by (simp add: log2_def Least_le)
      with S3 show False by auto
   qed
   with S2 show ?thesis by auto
  qed
qed

lemma log2_gt: "x < 2 ^ (log2 x + 1)"
proof -
  have "x < 2^x" by (rule x_lt_2_x)
  then have S1: "x < 2^(x+1)" by simp
  define y where "y = x"
  from S1 y_def have S2: "x < 2^(y+1)" by auto
  let ?P = "\<lambda> z. x < 2^(z+1)"
  from S2 have S3: "?P y" by auto
  then have S4: "?P (Least ?P)" by (rule LeastI)
  from log2_def have S5: "log2 x = Least ?P" by (unfold log2_def, auto)
  from S4 S5 show ?thesis by auto
qed

lemma x_div_x: "x > 0 \<Longrightarrow> (x::nat) div x = 1" by auto
lemma div_ge: "(k::nat) \<le> m div n \<Longrightarrow> n*k \<le> m"
proof -
  assume A: "k \<le> m div n"
  have S1: "n * (m div n) + m mod n = m" by (rule mult_div_mod_eq)
  have S2: "0 \<le> m mod n" by auto
  from S1 S2 have S3: "n * (m div n) \<le> m" by arith
  from A have S4: "n * k \<le>  n * (m div n)" by auto
  from S4 S3 show ?thesis by (rule order_trans)
qed
lemma div_lt: "m < n*k \<Longrightarrow> m div n < (k::nat)"
proof -
  assume A: "m < n*k"
  show ?thesis
  proof (rule ccontr)
    assume "\<not> m div n < k"
    then have S1: "k \<le> m div n" by auto
    then have S2: "n*k \<le> m" by (rule div_ge)
    with A show False by auto
  qed
qed

lemma log2_lm1: "u > 0 \<Longrightarrow> u div 2 ^ (log2 u) = 1"
proof -
  assume A: "u > 0"
  then have S1: "2^(log2 u) \<le> u" by (rule log2_le)
  have S2: "u < 2^(log2 u+1)" by (rule log2_gt)
  then have S3: "u < (2^log2 u)*2" by simp
  have "(2::nat) > 0" by simp
  then have "(2::nat)^log2 u > 0" by simp
  then have S4: "(2::nat)^log2 u div 2^log2 u = 1" by auto
  from S1 have S5: "(2::nat)^log2 u div 2^log2 u  \<le> u div 2^log2 u" by (rule div_le_mono)
  with S4 have S6: "1 \<le> u div 2^log2 u" by auto
  from S3 have S7: "u div 2^log2 u < 2" by (rule div_lt)
  from S6 S7 show ?thesis by auto
qed

lemma log2_lm2: "u > 0 \<Longrightarrow> c_in (log2 u) u = 1"
proof -
  assume A: "u > 0"
  then have S1: "u div 2 ^ (log2 u) = 1" by (rule log2_lm1)
  have "c_in (log2 u) u = (u div 2 ^ (log2 u)) mod 2" by (simp add: c_in_def)
  also from S1 have "\<dots> = 1 mod 2" by simp
  also have "\<dots> = 1" by auto
  finally show ?thesis by auto
qed

lemma log2_lm3: "log2 u < x \<Longrightarrow> c_in x u = 0"
proof -
  assume A: "log2 u < x"
  then have S1: "(log2 u)+1 \<le> x" by auto
  have S2: "1 \<le> (2::nat)" by auto
  from S1 S2 have S3: "(2::nat)^ ((log2 u)+1) \<le> 2^x" by (rule power_increasing)
  have S4: "u < (2::nat)^ ((log2 u)+1)" by (rule log2_gt)
  from S3 S4 have S5: "u < 2^x" by auto
  then have S6: "u div 2^x = 0" by (rule div_less)
  have "c_in x u = (u div 2^x) mod 2" by (simp add: c_in_def)
  also from S6 have "\<dots> = 0 mod 2" by simp
  also have "\<dots> = 0" by auto
  finally have ?thesis by auto
  thus ?thesis by auto
qed

lemma log2_lm4: "c_in x u = 1 \<Longrightarrow> x \<le> log2 u"
proof -
  assume A: "c_in x u = 1"
  show ?thesis
  proof (rule ccontr)
    assume "\<not> x \<le> log2 u"
    then have S1: "log2 u < x" by auto
    then have S2: "c_in x u = 0" by (rule log2_lm3)
    with A show False by auto
  qed
qed

lemma nat_to_set_lub: "x \<in> nat_to_set u \<Longrightarrow> x \<le> log2 u"
proof -
  assume "x \<in> nat_to_set u"
  then have S1: "c_in x u = 1" by (simp add: x_in_u_eq)
  then show ?thesis by (rule log2_lm4)
qed

lemma log2_lm5: "u > 0 \<Longrightarrow> log2 u \<in> nat_to_set u"
proof -
  assume A: "u > 0"
  then have "c_in (log2 u) u = 1" by (rule log2_lm2)
  then show ?thesis by (simp add: x_in_u_eq)
qed

lemma pos_imp_ne: "u > 0 \<Longrightarrow> nat_to_set u \<noteq> {}"
proof -
  assume "u > 0"
  then have "log2 u \<in> nat_to_set u" by (rule log2_lm5)
  thus ?thesis by auto
qed

lemma empty_is_zero: "nat_to_set u = {} \<Longrightarrow> u = 0"
proof (rule ccontr)
  assume A1: "nat_to_set u = {}"
  assume A2: "u \<noteq> 0" then have S1: "u > 0" by auto
  from S1 have "nat_to_set u \<noteq> {}" by (rule pos_imp_ne)
  with A1 show False by auto
qed

lemma log2_is_max: "u > 0 \<Longrightarrow> log2 u = Max (nat_to_set u)"
proof -
  assume A: "u > 0"
  then have S1: "log2 u \<in> nat_to_set u" by (rule log2_lm5)
  define max where "max = Max (nat_to_set u)"
  from A have ne: "nat_to_set u \<noteq> {}" by (rule pos_imp_ne)
  have finite: "finite (nat_to_set u)" by (rule nat_to_set_is_finite)
  from max_def finite ne have max_in: "max \<in> nat_to_set u" by simp
  from max_in have S2: "c_in max u = 1" by (simp add: x_in_u_eq)
  then have S3: "max \<le> log2 u" by (rule log2_lm4)
  from finite ne S1 max_def have S4: "log2 u \<le> max" by simp
  from S3 S4 max_def show ?thesis by auto
qed

lemma zero_is_empty: "nat_to_set 0 = {}"
proof -
  have S1: "{i. i<(0::nat)} = {}" by blast
  have S2: "nat_to_set 0 \<subseteq> {i. i<0}" by (rule nat_to_set_upper_bound2)
  from S1 S2 show ?thesis by auto
qed

lemma ne_imp_pos: "nat_to_set u \<noteq> {} \<Longrightarrow> u > 0"
proof (rule ccontr)
  assume A1: "nat_to_set u \<noteq> {}"
  assume "\<not> 0 < u" then have "u = 0" by auto
  then have "nat_to_set u = {}" by (simp add: zero_is_empty)
  with A1 show False by auto
qed

lemma div_mod_lm: "y < x \<Longrightarrow> ((u + (2::nat) ^ x) div (2::nat)^y) mod 2 = (u div (2::nat)^y) mod 2"
proof -
  assume y_lt_x: "y < x"
  let ?n = "(2::nat)^y"
  have n_pos: "0 < ?n" by auto
  let ?s = "x-y"
  from y_lt_x have s_pos: "0 < ?s" by auto
  from y_lt_x have S3: "x = y + ?s" by auto
  from S3 have "(2::nat)^x = (2::nat)^(y + ?s)" by auto
  moreover have "(2::nat)^(y +?s) = (2::nat)^y * 2^ ?s" by (rule power_add)
  ultimately have "(2::nat)^x = 2^y * 2^?s" by auto
  then have S4: "u + (2::nat)^x = u + (2::nat)^y * 2^?s" by auto
  from n_pos have S5: "(u + (2::nat)^y * 2^?s) div 2^y = 2^?s + (u div 2^y)" by simp
  from S4 S5 have S6: "(u + (2::nat)^x) div 2^y = 2^?s + (u div 2^y)" by auto
  from s_pos have S8: "?s = (?s - 1) + 1" by auto
  have "(2::nat) ^ ((?s - (1::nat)) + (1::nat)) = (2::nat) ^ (?s - (1::nat)) * 2^1" by (rule power_add)
  with S8 have S9: "(2::nat) ^ ?s = (2::nat) ^ (?s - (1::nat)) * 2" by auto
  then have S10: "2^?s + (u div 2^y) = (u div 2^y) + (2::nat) ^ (?s - (1::nat)) * 2" by auto
  have S11: "((u div 2^y) + (2::nat) ^ (?s - (1::nat)) * 2) mod 2 = (u div 2^y) mod 2" by (rule mod_mult_self1)
  from S6 S10 S11 show ?thesis by auto
qed

lemma add_power: "u < 2^x \<Longrightarrow> nat_to_set (u + 2^x) = nat_to_set u \<union> {x}"
proof -
  assume A: "u < 2^x"
  have log2_is_x: "log2 (u+2^x) = x"
  proof (unfold log2_def, rule Least_equality)
    from A show "u+2^x < 2^(x+1)" by auto
  next
    fix z
    assume A1: "u + 2^x < 2^(z+1)"
    show "x \<le> z"
    proof (rule ccontr)
      assume "\<not> x \<le> z"
      then have "z < x" by auto
      then have L1: "z+1 \<le> x" by auto
      have L2: "1 \<le> (2::nat)" by auto
      from L1 L2 have L3: "(2::nat)^(z+1) \<le> (2::nat)^x" by (rule power_increasing)
      with A1 show False by auto
    qed
  qed
  show ?thesis
  proof (rule subset_antisym)
    show "nat_to_set (u + 2 ^ x) \<subseteq> nat_to_set u \<union> {x}"
    proof fix y
      assume A1: "y \<in> nat_to_set (u + 2 ^ x)"
      show "y \<in> nat_to_set u \<union> {x}"
      proof
        assume "y \<notin> {x}" then have S1: "y \<noteq> x" by auto
        from A1 have "y \<le> log2 (u + 2 ^ x)" by (rule nat_to_set_lub)
        with log2_is_x have "y \<le> x" by auto
        with S1 have y_lt_x: "y < x" by auto
        from A1 have "c_in y (u + 2 ^ x) = 1" by (simp add: x_in_u_eq)
        then have S2: "((u + 2 ^ x) div 2^y) mod 2 = 1" by (unfold c_in_def)
        from y_lt_x have "((u + (2::nat) ^ x) div (2::nat)^y) mod 2 = (u div (2::nat)^y) mod 2" by (rule div_mod_lm)
        with S2 have "(u div 2^y) mod 2 = 1" by auto
        then have "c_in y u = 1" by (simp add: c_in_def)
        then show "y \<in> nat_to_set u" by (simp add: x_in_u_eq)
      qed
    qed
  next
  show "nat_to_set u \<union> {x} \<subseteq> nat_to_set (u + 2 ^ x)"
  proof fix y
    assume A1: "y \<in> nat_to_set u \<union> {x}"
    show "y \<in> nat_to_set (u + 2 ^ x)"
    proof cases
      assume "y \<in> {x}"
      then have "y=x" by auto
      then have "y = log2 (u + 2 ^ x)" by (simp add: log2_is_x)
      then show ?thesis by (simp add: log2_lm5)
    next
      assume y_notin: "y \<notin> {x}"
      then have y_ne_x: "y \<noteq> x" by auto
      from A1 y_notin have y_in: "y \<in> nat_to_set u" by auto
      have y_lt_x: "y < x"
      proof (rule ccontr)
        assume "\<not> y < x"
        with y_ne_x have y_gt_x: "x < y" by auto
        have "1 < (2::nat)" by auto
        from y_gt_x this have L1: "(2::nat)^x < 2^y" by (rule power_strict_increasing)
        from y_in have L2: "2^y \<le> u" by (rule nat_to_set_upper_bound)
        from L1 L2 have "(2::nat)^x < u" by arith
        with A show False by auto
      qed
      from y_in have "c_in y u = 1" by (simp add: x_in_u_eq)
      then have S2: "(u div 2^y) mod 2 = 1" by (unfold c_in_def)
      from y_lt_x have "((u + (2::nat) ^ x) div (2::nat)^y) mod 2 = (u div (2::nat)^y) mod 2" by (rule div_mod_lm)
      with S2 have "((u + (2::nat) ^ x)div 2^y) mod 2 = 1" by auto
      then have "c_in y (u + (2::nat) ^ x) = 1" by (simp add: c_in_def)
      then show "y \<in> nat_to_set (u + (2::nat) ^ x)" by (simp add: x_in_u_eq)
    qed
  qed
  qed
qed

theorem nat_to_set_inj: "nat_to_set u = nat_to_set v \<Longrightarrow> u = v"
proof -
  assume A: "nat_to_set u = nat_to_set v"
  let ?P = "\<lambda> (n::nat). (\<forall> (D::nat set). finite D \<and> card D \<le> n \<longrightarrow> (\<forall> u v. nat_to_set u = D \<and> nat_to_set v = D \<longrightarrow> u = v))"
  have P_at_0: "?P 0"
  proof fix D show "finite D \<and> card D \<le> 0 \<longrightarrow> (\<forall>u v. nat_to_set u = D \<and> nat_to_set v = D \<longrightarrow> u = v)"
    proof (rule impI)
      assume A1: "finite D \<and> card D \<le> 0"
      from A1 have S1: "finite D" by auto
      from A1 have S2: "card D = 0" by auto
      from S1 S2 have S3: "D = {}" by auto
      show "(\<forall>u v. nat_to_set u = D \<and> nat_to_set v = D \<longrightarrow> u = v)"
      proof (rule allI, rule allI) fix u v show "nat_to_set u = D \<and> nat_to_set v = D \<longrightarrow> u = v"
        proof
          assume A2: " nat_to_set u = D \<and> nat_to_set v = D"
          from A2 have L1: "nat_to_set u = D" by auto
          from A2 have L2: "nat_to_set v = D" by auto
          from L1 S3 have "nat_to_set u = {}" by auto
          then have u_z: "u = 0" by (rule empty_is_zero)
          from L2 S3 have "nat_to_set v = {}" by auto
          then have v_z: "v = 0" by (rule empty_is_zero)
          from u_z v_z show "u=v" by auto
        qed
      qed
    qed
  qed
  have P_at_Suc: "\<And> n. ?P n \<Longrightarrow> ?P (Suc n)"
  proof - fix n
    assume A_n: "?P n"
    show "?P (Suc n)"
    proof fix D show "finite D \<and> card D \<le> Suc n \<longrightarrow> (\<forall>u v. nat_to_set u = D \<and> nat_to_set v = D \<longrightarrow> u = v)"
    proof (rule impI)
      assume A1: "finite D \<and> card D \<le> Suc n"
      from A1 have S1: "finite D" by auto
      from A1 have S2: "card D \<le> Suc n" by auto
      show "(\<forall>u v. nat_to_set u = D \<and> nat_to_set v = D \<longrightarrow> u = v)"
      proof (rule allI, rule allI, rule impI)
        fix u v
        assume A2: " nat_to_set u = D \<and> nat_to_set v = D"
        from A2 have d_u_d: "nat_to_set u = D" by auto
        from A2 have d_v_d: "nat_to_set v = D" by auto
        show "u = v"
        proof (cases)
          assume A3: "D = {}"
          from A3 d_u_d have "nat_to_set u = {}" by auto
          then have u_z: "u = 0" by (rule empty_is_zero)
          from A3 d_v_d have "nat_to_set v = {}" by auto
          then have v_z: "v = 0" by (rule empty_is_zero)
          from u_z v_z show "u = v" by auto
        next
          assume A3: "D \<noteq> {}"
          from A3 d_u_d have "nat_to_set u \<noteq> {}" by auto
          then have u_pos: "u > 0" by (rule ne_imp_pos)
          from A3 d_v_d have "nat_to_set v \<noteq> {}" by auto
          then have v_pos: "v > 0" by (rule ne_imp_pos)
          define m where "m = Max D"
          from S1 m_def A3 have m_in: "m \<in> D" by auto
          from d_u_d m_def have m_u: "m = Max (nat_to_set u)" by auto
          from d_v_d m_def have m_v: "m = Max (nat_to_set v)" by auto
          from u_pos m_u log2_is_max have m_log_u: "m = log2 u" by auto
          from v_pos m_v log2_is_max have m_log_v: "m = log2 v" by auto
          define D1 where "D1 = D - {m}"
          define u1 where "u1 = u - 2^m"
          define v1 where "v1 = v - 2^m"
          have card_D1: "card D1 \<le> n"
          proof -
            from D1_def S1 m_in have "card D1 = (card D) - 1" by (simp add: card_Diff_singleton)
            with S2 show ?thesis by auto
          qed
          have u_u1: "u = u1 + 2^m"
          proof -
            from u_pos have L1: "2 ^ log2 u \<le> u" by (rule log2_le)
            with m_log_u have L2: "2 ^ m \<le> u" by auto
            with u1_def show ?thesis by auto
          qed
          have u1_d1: "nat_to_set u1 = D1"
          proof -
            from m_log_u log2_gt have "u < 2^(m+1)" by auto
            with u_u1 have u1_lt_2_m: "u1 < 2^m" by auto
            with u_u1 have L1: "nat_to_set u = nat_to_set u1 \<union> {m}" by (simp add: add_power)
            have m_notin: "m \<notin> nat_to_set u1"
            proof (rule ccontr)
              assume "\<not> m \<notin> nat_to_set u1" then have "m \<in> nat_to_set u1" by auto
              then have "2^m \<le> u1" by (rule nat_to_set_upper_bound)
              with u1_lt_2_m show False by auto
            qed
            from L1 m_notin have "nat_to_set u1 = nat_to_set u - {m}" by auto
            with d_u_d have "nat_to_set u1 = D - {m}" by auto
            with D1_def show ?thesis by auto
          qed
          have v_v1: "v = v1 + 2^m"
          proof -
            from v_pos have L1: "2 ^ log2 v \<le> v" by (rule log2_le)
            with m_log_v have L2: "2 ^ m \<le> v" by auto
            with v1_def show ?thesis by auto
          qed
          have v1_d1: "nat_to_set v1 = D1"
          proof -
            from m_log_v log2_gt have "v < 2^(m+1)" by auto
            with v_v1 have v1_lt_2_m: "v1 < 2^m" by auto
            with v_v1 have L1: "nat_to_set v = nat_to_set v1 \<union> {m}" by (simp add: add_power)
            have m_notin: "m \<notin> nat_to_set v1"
            proof (rule ccontr)
              assume "\<not> m \<notin> nat_to_set v1" then have "m \<in> nat_to_set v1" by auto
              then have "2^m \<le> v1" by (rule nat_to_set_upper_bound)
              with v1_lt_2_m show False by auto
            qed
            from L1 m_notin have "nat_to_set v1 = nat_to_set v - {m}" by auto
            with d_v_d have "nat_to_set v1 = D - {m}" by auto
            with D1_def show ?thesis by auto
          qed
          from S1 D1_def have P1: "finite D1" by auto
          with card_D1 have P2: "finite D1 \<and> card D1 \<le> n" by auto
          from A_n P2 have "(\<forall>u v. nat_to_set u = D1 \<and> nat_to_set v = D1 \<longrightarrow> u = v)" by auto
          with u1_d1 v1_d1 have "u1 = v1" by auto
          with u_u1 v_v1 show "u = v" by auto
        qed
      qed
    qed
  qed
qed
  from P_at_0 P_at_Suc have main: "\<And> n. ?P n" by (rule nat.induct)
  define D where "D = nat_to_set u"
  from D_def A have P1: "nat_to_set u = D" by auto
  from D_def A have P2: "nat_to_set v = D" by auto
  from D_def nat_to_set_is_finite have d_finite: "finite D" by auto
  define n where "n = card D"
  from n_def d_finite have card_le: "card D \<le> n" by auto
  from d_finite card_le have P3: "finite D \<and> card D \<le> n" by auto
  with main have P4: "\<forall>u v. nat_to_set u = D \<and> nat_to_set v = D \<longrightarrow> u = v" by auto
  with P1 P2 show "u = v" by auto
qed

definition
  set_to_nat :: "nat set => nat" where
  "set_to_nat = (\<lambda> D. sum (\<lambda> x. 2 ^ x) D)"

lemma two_power_sum: "sum (\<lambda> x. (2::nat) ^ x) {i. i< Suc m} = (2 ^ Suc m) - 1"
proof (induct m)
  show "sum (\<lambda> x. (2::nat) ^ x) {i. i< Suc 0} = (2 ^ Suc 0) - 1" by auto
next
  fix n
  assume A: "sum (\<lambda> x. (2::nat) ^ x) {i. i< Suc n} = (2 ^ Suc n) - 1"
  show "sum (\<lambda> x. (2::nat) ^ x) {i. i< Suc (Suc n)} = (2 ^ Suc (Suc n)) - 1"
  proof -
    let ?f = "\<lambda> x. (2::nat) ^ x"
    have S1: "{i. i< Suc (Suc n)} = {i. i \<le> Suc n}" by auto
    have S2: "{i. i \<le> Suc n} = {i. i < Suc n} \<union> { Suc n}" by auto
    from S1 S2 have S3: "{i. i< Suc (Suc n)} = {i. i < Suc n} \<union> { Suc n}" by auto
    have S4: "{i. i < Suc n} = (\<lambda> x. x) ` {i. i < Suc n}" by auto
    then have S5: "finite {i. i < Suc n}" by (rule nat_seg_image_imp_finite)
    have S6: "Suc n \<notin> {i. i < Suc n}" by auto
    from S5 S6 sum.insert have S7: "sum ?f ({i. i< Suc n} \<union> {Suc n}) = 2 ^ Suc n + sum ?f {i. i< Suc n}" by auto
    from S3 have "sum ?f {i. i< Suc (Suc n)} = sum ?f ({i. i< Suc n} \<union> {Suc n})" by auto
    also from S7 have "\<dots> = 2 ^ Suc n + sum ?f {i. i< Suc n}" by auto
    also from A have "\<dots> = 2 ^ Suc n + (((2::nat) ^ Suc n)-(1::nat))" by auto
    also have "\<dots> = (2 ^ Suc (Suc n)) - 1" by auto
    finally show ?thesis by auto
  qed
qed

lemma finite_interval: "finite {i. (i::nat)<m}"
proof -
  have "{i. i < m} = (\<lambda> x. x) ` {i. i < m}" by auto
  then show ?thesis by (rule nat_seg_image_imp_finite)
qed

lemma set_to_nat_at_empty: "set_to_nat {} = 0" by (unfold set_to_nat_def, rule sum.empty)

lemma set_to_nat_of_interval: "set_to_nat {i. (i::nat)<m} = 2 ^ m - 1"
proof (induct m)
  show "set_to_nat {i. i < 0} = 2 ^ 0 - 1"
  proof -
    have S1: "{i. (i::nat) < 0} = {}" by auto
    with set_to_nat_at_empty have "set_to_nat {i. i<0} = 0" by auto
    thus ?thesis by auto
  qed
next
  fix n show "set_to_nat {i. i < Suc n} = 2 ^ Suc n - 1" by (unfold set_to_nat_def, rule two_power_sum)
qed

lemma set_to_nat_mono: "\<lbrakk> finite B; A \<subseteq> B\<rbrakk> \<Longrightarrow> set_to_nat A \<le> set_to_nat B"
proof -
  assume b_finite: "finite B"
  assume a_le_b: "A \<subseteq> B"
  let ?f = "\<lambda> (x::nat). (2::nat) ^ x"
  have S1: "set_to_nat A = sum ?f A" by (simp add: set_to_nat_def)
  have S2: "set_to_nat B = sum ?f B" by (simp add: set_to_nat_def)
  have S3: "\<And> x. x  \<in> B - A \<Longrightarrow> 0 \<le> ?f x" by auto
  from b_finite a_le_b S3 have "sum ?f A \<le> sum ?f B" by (rule sum_mono2)
  with S1 S2 show ?thesis by auto
qed

theorem nat_to_set_srj: "finite (D::nat set) \<Longrightarrow> nat_to_set (set_to_nat D) = D"
proof -
  assume A: "finite D"
  let ?P = "\<lambda> (n::nat). (\<forall> (D::nat set). finite D \<and> card D = n \<longrightarrow> nat_to_set (set_to_nat D) = D)"
  have P_at_0: "?P 0"
  proof (rule allI)
    fix D
    show "finite D \<and> card D = 0 \<longrightarrow> nat_to_set (set_to_nat D) = D"
    proof
      assume A1: "finite D \<and> card D = 0"
      from A1 have S1: "finite D" by auto
      from A1 have S2: "card D = 0" by auto
      from S1 S2 have S3: "D = {}" by auto
      with set_to_nat_def have "set_to_nat D = sum (\<lambda> x. 2 ^ x) D" by simp
      with S3 sum.empty have "set_to_nat D = 0" by auto
      with zero_is_empty S3 show "nat_to_set (set_to_nat D) = D" by auto
    qed
  qed
  have P_at_Suc: "\<And> n. ?P n \<Longrightarrow> ?P (Suc n)"
  proof - fix n
    assume A_n: "?P n"
    show "?P (Suc n)"
    proof
      fix D show "finite D \<and> card D = Suc n \<longrightarrow> nat_to_set (set_to_nat D) = D"
      proof
        assume A1: "finite D \<and> card D = Suc n"
        from A1 have S1: "finite D" by auto
        from A1 have S2: "card D = Suc n" by auto
        define m where "m = Max D"
        from S2 have D_ne: "D \<noteq> {}" by auto
        with S1 m_def have m_in: "m \<in> D" by auto
        define D1 where "D1 = D - {m}"
        from S1 D1_def have d1_finite: "finite D1" by auto
        from D1_def m_in S1 have "card D1 = card D - 1" by (simp add: card_Diff_singleton)
        with S2 have card_d1: "card D1 = n" by auto
        from d1_finite card_d1 have "finite D1 \<and> card D1 = n" by auto
        with A_n have S3: "nat_to_set (set_to_nat D1) = D1" by auto
        define u where "u = set_to_nat D"
        define u1 where "u1 = set_to_nat D1"
        from S1 m_in have "sum (\<lambda> (x::nat). (2::nat) ^ x) D = 2 ^ m + sum (\<lambda> x. 2 ^ x) (D - {m})"
          by (rule sum.remove)
        with set_to_nat_def have "set_to_nat D = 2 ^ m + set_to_nat (D - {m})" by auto
        with u_def u1_def D1_def have u_u1: "u = u1 + 2 ^ m" by auto
        from S3 u1_def have d1_u1: "nat_to_set u1 = D1" by auto
        have u1_lt: "u1 < 2 ^ m"
        proof -
          have L1: "D1 \<subseteq> {i. i<m}"
          proof fix x
            assume A1: "x \<in> D1"
            show "x \<in> {i. i<m}"
            proof
              from A1 D1_def have L1_1: "x \<in> D" by auto
              from S1 D_ne L1_1 m_def have L1_2: "x \<le> m" by auto
              with A1 L1_1 D1_def have "x \<noteq> m" by auto
              with L1_2 show "x < m" by auto
            qed
          qed
          have L2: "finite {i. i<m}" by (rule finite_interval)
          from L2 L1 have "set_to_nat D1 \<le> set_to_nat {i. i<m}" by (rule set_to_nat_mono)
          with u1_def have "u1 \<le> set_to_nat {i. i<m}" by auto
          with set_to_nat_of_interval have L3: "u1 \<le> 2 ^ m - 1" by auto
          have "0 < (2::nat) ^ m" by auto
          then have "(2::nat) ^ m - 1 < (2::nat) ^ m" by auto
          with L3 show ?thesis by arith
        qed
        from u_def have "nat_to_set (set_to_nat D) = nat_to_set u" by auto
        also from u_u1 have "\<dots> = nat_to_set (u1 + 2 ^ m)" by auto
        also from u1_lt have "\<dots> = nat_to_set u1 \<union> {m}" by (rule add_power)
        also from d1_u1 have "\<dots> = D1 \<union> {m}" by auto
        also from D1_def m_in have "\<dots> = D" by auto
        finally show "nat_to_set (set_to_nat D) = D" by auto
      qed
    qed
  qed
  from P_at_0 P_at_Suc have main: "\<And> n. ?P n" by (rule nat.induct)
  from A main show ?thesis by auto
qed

theorem nat_to_set_srj1: "finite (D::nat set) \<Longrightarrow> \<exists> u. nat_to_set u = D"
proof -
  assume A: "finite D"
  show " \<exists> u. nat_to_set u = D"
  proof
    from A show "nat_to_set (set_to_nat D) = D" by (rule nat_to_set_srj)
  qed
qed

lemma sum_of_pr_is_pr: "g \<in> PrimRec1 \<Longrightarrow> (\<lambda> n. sum g {i. i<n}) \<in> PrimRec1"
proof -
  assume g_is_pr: "g \<in> PrimRec1"
  define f where "f n = sum g {i. i<n}" for n
  from f_def have f_at_0: "f 0 = 0" by auto
  define h where "h a b = g a + b" for a b
  from g_is_pr have h_is_pr: "h \<in> PrimRec2" unfolding h_def by prec
  have f_at_Suc: "\<forall> y. f (Suc y) = h y (f y)"
  proof
    fix y show "f (Suc y) = h y (f y)"
    proof -
      from f_def have S1: "f (Suc y) = sum g {i. i < Suc y}" by auto
      have S2: "{i. i < Suc y} = {i. i < y} \<union> {y}" by auto
      have S3: "finite {i. i < y}" by (rule finite_interval)
      have S4: "y \<notin> {i. i < y}" by auto
      from S1 S2 have "f (Suc y) = sum g ({i. (i::nat) < y} \<union> {y})" by auto
      also from S3 S4 sum.insert have "\<dots> = g y + sum g {i. i<y}" by auto
      also from f_def have "\<dots> = g y + f y" by auto
      also from h_def have "\<dots> = h y (f y)" by auto
      finally show ?thesis by auto
    qed
  qed
  from h_is_pr f_at_0 f_at_Suc have f_is_pr: "f \<in> PrimRec1" by (rule pr_rec1_scheme)
  with f_def [abs_def] show ?thesis by auto
qed

lemma sum_of_pr_is_pr2: "p \<in> PrimRec2 \<Longrightarrow> (\<lambda> n m. sum (\<lambda> x. p x m) {i. i<n}) \<in> PrimRec2"
proof -
  assume p_is_pr: "p \<in> PrimRec2"
  define f where "f n m = sum (\<lambda> x. p x m) {i. i<n}" for n m
  define g :: "nat \<Rightarrow> nat" where "g x = 0" for x
  have g_is_pr: "g \<in> PrimRec1" by (unfold g_def, rule const_is_pr [where ?n=0])
  have f_at_0: "\<forall> x. f 0 x = g x"
  proof
    fix x from f_def g_def show "f 0 x = g x" by auto
  qed
  define h where "h a b c = p a c + b" for a b c
  from p_is_pr have h_is_pr: "h \<in> PrimRec3" unfolding h_def by prec
  have f_at_Suc: "\<forall> x y. f (Suc y) x = h y (f y x) x"
  proof (rule allI, rule allI)
    fix x y show "f (Suc y) x = h y (f y x) x"
    proof -
      from f_def have S1: "f (Suc y) x = sum (\<lambda> z. p z x)  {i. i < Suc y}" by auto
      have S2: "{i. i < Suc y} = {i. i < y} \<union> {y}" by auto
      have S3: "finite {i. i < y}" by (rule finite_interval)
      have S4: "y \<notin> {i. i < y}" by auto
      define g1 where "g1 z = p z x" for z
      from S1 S2 g1_def have "f (Suc y) x = sum g1 ({i. (i::nat) < y} \<union> {y})" by auto
      also from S3 S4 sum.insert have "\<dots> = g1 y + sum g1 {i. i<y}" by auto
      also from f_def g1_def have "\<dots> = g1 y + f y x" by auto
      also from h_def g1_def  have "\<dots> = h y (f y x) x" by auto
      finally show ?thesis by auto
    qed
  qed
  from g_is_pr h_is_pr f_at_0 f_at_Suc have f_is_pr: "f \<in> PrimRec2" by (rule pr_rec_scheme)
  with f_def [abs_def] show ?thesis by auto
qed

lemma sum_is_pr: "g \<in> PrimRec1 \<Longrightarrow> (\<lambda> u. sum g (nat_to_set u)) \<in> PrimRec1"
proof -
  assume g_is_pr: "g \<in> PrimRec1"
  define g1 where "g1 x u = (if (c_in x u = 1) then (g x) else 0)" for x u
  have g1_is_pr: "g1 \<in> PrimRec2"
  proof (unfold g1_def, rule if_eq_is_pr2)
    show "c_in \<in> PrimRec2" by (rule c_in_is_pr)
  next
    show "(\<lambda>x y. 1) \<in> PrimRec2" by (rule const_is_pr_2 [where ?n=1])
  next
    from g_is_pr show "(\<lambda>x y. g x) \<in> PrimRec2" by prec
  next
    show "(\<lambda>x y. 0) \<in> PrimRec2" by (rule const_is_pr_2 [where ?n=0])
  qed
  define f where "f u = sum (\<lambda> x. g1 x u) {i. (i::nat) < u}" for u
  define f1 where "f1 u v = sum (\<lambda> x. g1 x v) {i. (i::nat) < u}"  for u v
  from g1_is_pr have "(\<lambda> (u::nat) v. sum (\<lambda> x. g1 x v) {i. (i::nat) < u}) \<in> PrimRec2"
    by (rule sum_of_pr_is_pr2)
  with f1_def [abs_def] have f1_is_pr: "f1 \<in> PrimRec2" by auto
  from f_def f1_def have f_f1: "f = (\<lambda> u. f1 u u)" by auto
  from f1_is_pr have "(\<lambda> u. f1 u u) \<in> PrimRec1" by prec
  with f_f1 have f_is_pr: "f \<in> PrimRec1" by auto
  have f_is_result: "f = (\<lambda> u. sum g (nat_to_set u))"
  proof
    fix u show "f u = sum g (nat_to_set u)"
    proof -
      define U where "U = {i. i < u}"
      define A where "A = {x \<in> U. c_in x u = 1}"
      define B where "B = {x \<in> U. c_in x u \<noteq> 1}"
      have U_finite: "finite U" by (unfold U_def, rule finite_interval)
      from A_def U_finite have A_finite: "finite A" by auto
      from B_def U_finite have B_finite: "finite B" by auto
      from U_def A_def B_def have U_A_B: "U = A \<union> B" by auto
      from U_def A_def B_def have A_B: "A \<inter> B = {}" by auto
      from B_def g1_def have B_z: "sum (\<lambda> x. g1 x u) B = 0" by auto
      have u_in_U: "nat_to_set u \<subseteq> U" by (unfold U_def, rule nat_to_set_upper_bound2)
      from u_in_U x_in_u_eq A_def have A_u: "A = nat_to_set u" by auto
      from A_u x_in_u_eq g1_def have A_res: "sum (\<lambda> x. g1 x u) A = sum g (nat_to_set u)" by auto
      from f_def have "f u = sum (\<lambda> x. g1 x u) {i. (i::nat) < u}" by auto
      also from U_def have "\<dots> = sum (\<lambda> x. g1 x u) U" by auto
      also from U_A_B have "\<dots> = sum (\<lambda> x. g1 x u) (A \<union> B)" by auto
      also from A_finite B_finite A_B have "\<dots> = sum (\<lambda> x. g1 x u) A + sum (\<lambda> x. g1 x u) B" by (rule sum.union_disjoint)
      also from B_z have "\<dots> = sum (\<lambda> x. g1 x u) A" by auto
      also from A_res have "\<dots> = sum g (nat_to_set u)" by auto
      finally show ?thesis by auto
    qed
  qed
  with f_is_pr show ?thesis by auto
qed

definition
  c_card :: "nat \<Rightarrow> nat" where
  "c_card = (\<lambda> u. card (nat_to_set u))"

theorem c_card_is_pr: "c_card \<in> PrimRec1"
proof -
  define g :: "nat \<Rightarrow> nat" where "g x = 1" for x
  have g_is_pr: "g \<in> PrimRec1" by (unfold g_def, rule const_is_pr)
  have "c_card = (\<lambda> u. sum g (nat_to_set u))"
  proof
    fix u show "c_card u = sum g (nat_to_set u)" by (unfold c_card_def, unfold g_def, rule card_eq_sum)
  qed
  moreover from g_is_pr have "(\<lambda> u. sum g (nat_to_set u)) \<in> PrimRec1" by (rule sum_is_pr)
  ultimately show ?thesis by auto
qed

definition
  c_insert :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  "c_insert = (\<lambda> x u. if c_in x u = 1 then u else u + 2^x)"

lemma c_insert_is_pr: "c_insert \<in> PrimRec2"
proof (unfold c_insert_def, rule if_eq_is_pr2)
  show "c_in \<in> PrimRec2" by (rule c_in_is_pr)
next
  show "(\<lambda>x y. 1) \<in> PrimRec2" by (rule const_is_pr_2)
next
  show "(\<lambda>x y. y) \<in> PrimRec2" by (rule pr_id2_2)
next
  from power_is_pr show "(\<lambda>x y. y + 2 ^ x) \<in> PrimRec2" by prec
qed

lemma insert_lemma: "x \<notin> nat_to_set u \<Longrightarrow> set_to_nat (nat_to_set u \<union> {x}) = u + 2 ^ x"
proof -
  assume A: "x \<notin> nat_to_set u"
  define D where "D = nat_to_set u"
  from A D_def have S1: "x \<notin> D" by auto
  have "finite (nat_to_set u)" by (rule nat_to_set_is_finite)
  with D_def have D_finite: "finite D" by auto
  let ?f = "\<lambda> (x::nat). (2::nat)^x"
  from set_to_nat_def have "set_to_nat (D \<union> {x}) = sum ?f (D \<union> {x})" by auto
  also from D_finite S1 have "\<dots> = ?f x + sum ?f D" by simp
  also from set_to_nat_def have "\<dots> = 2 ^ x + set_to_nat D" by auto
  finally have "set_to_nat (D \<union> {x}) = set_to_nat D + 2 ^ x" by auto
  with D_def show ?thesis by auto
qed

lemma c_insert_df: "c_insert = (\<lambda> x u. set_to_nat ((nat_to_set u) \<union> {x}))"
proof (rule ext, rule ext)
  fix x u show "c_insert x u = set_to_nat (nat_to_set u \<union> {x})"
  proof (cases)
    assume A: "x \<in> nat_to_set u"
    then have "nat_to_set u \<union> {x} = nat_to_set u" by auto
    then have S1: "set_to_nat (nat_to_set u \<union> {x}) = u" by auto
    from A have "c_in x u = 1" by (simp add: x_in_u_eq)
    then have "c_insert x u = u" by (unfold c_insert_def, simp)
    with S1 show ?thesis by auto
  next
    assume A: "x \<notin> nat_to_set u"
    then have S1: "c_in x u \<noteq> 1" by (simp add: x_in_u_eq)
    then have S2: "c_insert x u = u + 2 ^ x" by (unfold c_insert_def, simp)
    from A have "set_to_nat (nat_to_set u \<union> {x}) = u + 2 ^ x" by (rule insert_lemma)
    with S2 show ?thesis by auto
  qed
qed

definition
  c_remove :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  "c_remove = (\<lambda> x u. if c_in x u = 0 then u else u - 2^x)"

lemma c_remove_is_pr: "c_remove \<in> PrimRec2"
proof (unfold c_remove_def, rule if_eq_is_pr2)
  show "c_in \<in> PrimRec2" by (rule c_in_is_pr)
next
  show "(\<lambda>x y. 0) \<in> PrimRec2" by (rule const_is_pr_2)
next
  show "(\<lambda>x y. y) \<in> PrimRec2" by (rule pr_id2_2)
next
  from power_is_pr show "(\<lambda>x y. y - 2 ^ x) \<in> PrimRec2" by prec
qed

lemma remove_lemma: "x \<in> nat_to_set u \<Longrightarrow> set_to_nat (nat_to_set u - {x}) = u - 2 ^ x"
proof -
  assume A: "x \<in> nat_to_set u"
  define D where "D = nat_to_set u - {x}"
  from A D_def have S1: "x \<notin> D" by auto
  have "finite (nat_to_set u)" by (rule nat_to_set_is_finite)
  with D_def have D_finite: "finite D" by auto
  let ?f = "\<lambda> (x::nat). (2::nat)^x"
  from set_to_nat_def have "set_to_nat (D \<union> {x}) = sum ?f (D \<union> {x})" by auto
  also from D_finite S1 have "\<dots> = ?f x + sum ?f D" by simp
  also from set_to_nat_def have "\<dots> = 2 ^ x + set_to_nat D" by auto
  finally have S2: "set_to_nat (D \<union> {x}) = set_to_nat D + 2 ^ x" by auto
  from A D_def have "D \<union> {x} = nat_to_set u" by auto
  with S2 have S3: "u = set_to_nat D + 2 ^ x" by auto
  from A have S4: "2 ^ x \<le> u" by (rule nat_to_set_upper_bound)
  with S3 D_def show ?thesis by auto
qed

lemma c_remove_df: "c_remove = (\<lambda> x u. set_to_nat ((nat_to_set u) - {x}))"
proof (rule ext, rule ext)
  fix x u show "c_remove x u = set_to_nat (nat_to_set u - {x})"
  proof (cases)
    assume A: "x \<in> nat_to_set u"
    then have S1: "c_in x u = 1" by (simp add: x_in_u_eq)
    then have S2: "c_remove x u = u - 2^x" by (simp add: c_remove_def)
    from A have "set_to_nat (nat_to_set u - {x}) = u - 2 ^ x" by (rule remove_lemma)
    with S2 show ?thesis by auto
  next
    assume A: "x \<notin> nat_to_set u"
    then have S1: "c_in x u \<noteq> 1" by (simp add: x_in_u_eq)
    then have S2: "c_remove x u = u" by (simp add: c_remove_def c_in_def)
    from A have "nat_to_set u - {x} = nat_to_set u" by auto
    with S2 show ?thesis by auto
  qed
qed

definition
  c_union :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  "c_union = (\<lambda> u v. set_to_nat (nat_to_set u \<union> nat_to_set v))"

theorem c_union_is_pr: "c_union \<in> PrimRec2"
proof -
  define f where "f y x = set_to_nat ((nat_to_set (c_fst x)) \<union> {z \<in> nat_to_set (c_snd x). z < y})"
    for y x
  have f_is_pr: "f \<in> PrimRec2"
  proof -
    define g where "g = c_fst"
    from c_fst_is_pr g_def have g_is_pr: "g \<in> PrimRec1" by auto
    define h where "h a b c = (if c_in a (c_snd c) = 1 then c_insert a b else b)" for a b c
    from c_in_is_pr c_insert_is_pr have h_is_pr: "h \<in> PrimRec3" unfolding h_def by prec
    have f_at_0: "\<forall> x. f 0 x = g x"
    proof
      fix x show "f 0 x = g x" by (unfold f_def, unfold g_def, simp)
    qed
    have f_at_Suc: "\<forall> x y. f (Suc y) x = h y (f y x) x"
    proof (rule allI, rule allI)
      fix x y show "f (Suc y) x = h y (f y x) x"
      proof (cases)
        assume A: "c_in y (c_snd x) = 1"
        then have S1: "y \<in> (nat_to_set (c_snd x))" by (simp add: x_in_u_eq)
        from A h_def have S2: "h y (f y x) x = c_insert y (f y x)" by auto
        from S1 have S3: "{z \<in> nat_to_set (c_snd x). z < Suc y} = {z \<in> nat_to_set (c_snd x). z < y} \<union> {y}" by auto
        from nat_to_set_is_finite have S4: "finite ((nat_to_set (c_fst x)) \<union> {z \<in> nat_to_set (c_snd x). z < y})" by auto
        with nat_to_set_srj f_def have S5: "nat_to_set (f y x) = (nat_to_set (c_fst x)) \<union> {z \<in> nat_to_set (c_snd x). z < y}" by auto
        from f_def have S6: "f (Suc y) x = set_to_nat ((nat_to_set (c_fst x)) \<union> {z \<in> nat_to_set (c_snd x). z < Suc y})" by simp
        also from S3 have "\<dots> = set_to_nat (((nat_to_set (c_fst x)) \<union> {z \<in> nat_to_set (c_snd x). z < y}) \<union> {y})" by auto
        also from S5 have "\<dots> = set_to_nat (nat_to_set (f y x) \<union> {y})" by auto
        also have "\<dots> = c_insert y (f y x)" by (simp add: c_insert_df)
        finally show ?thesis by (simp add: S2)
      next
        assume A: "\<not> c_in y (c_snd x) = 1"
        then have S1: "y \<notin> (nat_to_set (c_snd x))" by (simp add: x_in_u_eq)
        from A h_def have S2: "h y (f y x) x = f y x" by auto
        have S3: "{z \<in> nat_to_set (c_snd x). z < Suc y} = {z \<in> nat_to_set (c_snd x). z < y}"
        proof -
          have "{z \<in> nat_to_set (c_snd x). z < Suc y} = {z \<in> nat_to_set (c_snd x). z < y} \<union> {z \<in> nat_to_set (c_snd x). z = y}"
            by auto
          with S1 show ?thesis by auto
        qed
        from nat_to_set_is_finite have S4: "finite ((nat_to_set (c_fst x)) \<union> {z \<in> nat_to_set (c_snd x). z < y})" by auto
        with nat_to_set_srj f_def have S5: "nat_to_set (f y x) = (nat_to_set (c_fst x)) \<union> {z \<in> nat_to_set (c_snd x). z < y}" by auto
        from f_def have S6: "f (Suc y) x = set_to_nat ((nat_to_set (c_fst x)) \<union> {z \<in> nat_to_set (c_snd x). z < Suc y})" by simp
        also from S3 have "\<dots> = set_to_nat (((nat_to_set (c_fst x)) \<union> {z \<in> nat_to_set (c_snd x). z < y}))" by auto
        also from S5 have "\<dots> = set_to_nat (nat_to_set (f y x))" by auto
        also have "\<dots> = f y x" by simp
        finally show ?thesis by (simp add: S2)
      qed
    qed
    from g_is_pr h_is_pr f_at_0 f_at_Suc show ?thesis by (rule pr_rec_scheme)
  qed
  define union where "union u v = f v (c_pair u v)" for u v
  from f_is_pr have union_is_pr: "union \<in> PrimRec2" unfolding union_def by prec
  have "\<And> u v. union u v = set_to_nat (nat_to_set u \<union> nat_to_set v)"
  proof -
    fix u v show "union u v = set_to_nat (nat_to_set u \<union> nat_to_set v)"
    proof -
      from nat_to_set_upper_bound1 have "{z \<in> nat_to_set v. z < v} = nat_to_set v" by auto
      with union_def f_def show ?thesis by auto
    qed
  qed
  then have "union = (\<lambda> u v. set_to_nat (nat_to_set u \<union> nat_to_set v))" by (simp add: ext)
  with c_union_def have "c_union = union" by simp
  with union_is_pr show ?thesis by simp
qed

definition
  c_diff :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  "c_diff = (\<lambda> u v. set_to_nat (nat_to_set u - nat_to_set v))"

theorem c_diff_is_pr: "c_diff \<in> PrimRec2"
proof -
  define f where "f y x = set_to_nat ((nat_to_set (c_fst x)) - {z \<in> nat_to_set (c_snd x). z < y})"
    for y x
  have f_is_pr: "f \<in> PrimRec2"
  proof -
    define g where "g = c_fst"
    from c_fst_is_pr g_def have g_is_pr: "g \<in> PrimRec1" by auto
    define h where "h a b c = (if c_in a (c_snd c) = 1 then c_remove a b else b)" for a b c
    from c_in_is_pr c_remove_is_pr have h_is_pr: "h \<in> PrimRec3" unfolding h_def by prec
    have f_at_0: "\<forall> x. f 0 x = g x"
    proof
      fix x show "f 0 x = g x" by (unfold f_def, unfold g_def, simp)
    qed
    have f_at_Suc: "\<forall> x y. f (Suc y) x = h y (f y x) x"
    proof (rule allI, rule allI)
      fix x y show "f (Suc y) x = h y (f y x) x"
      proof (cases)
        assume A: "c_in y (c_snd x) = 1"
        then have S1: "y \<in> (nat_to_set (c_snd x))" by (simp add: x_in_u_eq)
        from A h_def have S2: "h y (f y x) x = c_remove y (f y x)" by auto
        have "(nat_to_set (c_fst x)) - ({z \<in> nat_to_set (c_snd x). z < y} \<union> {y}) =
              ((nat_to_set (c_fst x)) - ({z \<in> nat_to_set (c_snd x). z < y}) - {y})" by auto
        then have lm1: "set_to_nat (nat_to_set (c_fst x) - ({z \<in> nat_to_set (c_snd x). z < y} \<union> {y})) =
                        set_to_nat (nat_to_set (c_fst x) - {z \<in> nat_to_set (c_snd x). z < y} - {y})" by auto
        from S1 have S3: "{z \<in> nat_to_set (c_snd x). z < Suc y} = {z \<in> nat_to_set (c_snd x). z < y} \<union> {y}" by auto
        from nat_to_set_is_finite have S4: "finite ((nat_to_set (c_fst x)) - {z \<in> nat_to_set (c_snd x). z < y})" by auto
        with nat_to_set_srj f_def have S5: "nat_to_set (f y x) = (nat_to_set (c_fst x)) - {z \<in> nat_to_set (c_snd x). z < y}" by auto
        from f_def have S6: "f (Suc y) x = set_to_nat ((nat_to_set (c_fst x)) - {z \<in> nat_to_set (c_snd x). z < Suc y})" by simp
        also from S3 have "\<dots> = set_to_nat ((nat_to_set (c_fst x)) - ({z \<in> nat_to_set (c_snd x). z < y} \<union> {y}))" by auto
        also have "\<dots> = set_to_nat (((nat_to_set (c_fst x)) - ({z \<in> nat_to_set (c_snd x). z < y}) - {y}))" by (rule lm1)
        also from S5 have "\<dots> = set_to_nat (nat_to_set (f y x) - {y})" by auto
        also have "\<dots> = c_remove y (f y x)" by (simp add: c_remove_df)
        finally show ?thesis by (simp add: S2)
      next
        assume A: "\<not> c_in y (c_snd x) = 1"
        then have S1: "y \<notin> (nat_to_set (c_snd x))" by (simp add: x_in_u_eq)
        from A h_def have S2: "h y (f y x) x = f y x" by auto
        have S3: "{z \<in> nat_to_set (c_snd x). z < Suc y} = {z \<in> nat_to_set (c_snd x). z < y}"
        proof -
          have "{z \<in> nat_to_set (c_snd x). z < Suc y} = {z \<in> nat_to_set (c_snd x). z < y} \<union> {z \<in> nat_to_set (c_snd x). z = y}"
            by auto
          with S1 show ?thesis by auto
        qed
        from nat_to_set_is_finite have S4: "finite ((nat_to_set (c_fst x)) - {z \<in> nat_to_set (c_snd x). z < y})" by auto
        with nat_to_set_srj f_def have S5: "nat_to_set (f y x) = (nat_to_set (c_fst x)) - {z \<in> nat_to_set (c_snd x). z < y}" by auto
        from f_def have S6: "f (Suc y) x = set_to_nat ((nat_to_set (c_fst x)) - {z \<in> nat_to_set (c_snd x). z < Suc y})" by simp
        also from S3 have "\<dots> = set_to_nat (((nat_to_set (c_fst x)) - {z \<in> nat_to_set (c_snd x). z < y}))" by auto
        also from S5 have "\<dots> = set_to_nat (nat_to_set (f y x))" by auto
        also have "\<dots> = f y x" by simp
        finally show ?thesis by (simp add: S2)
      qed
    qed
    from g_is_pr h_is_pr f_at_0 f_at_Suc show ?thesis by (rule pr_rec_scheme)
  qed
  define diff where "diff u v = f v (c_pair u v)" for u v
  from f_is_pr have diff_is_pr: "diff \<in> PrimRec2" unfolding diff_def by prec
  have "\<And> u v. diff u v = set_to_nat (nat_to_set u - nat_to_set v)"
  proof -
    fix u v show "diff u v = set_to_nat (nat_to_set u - nat_to_set v)"
    proof -
      from nat_to_set_upper_bound1 have "{z \<in> nat_to_set v. z < v} = nat_to_set v" by auto
      with diff_def f_def show ?thesis by auto
    qed
  qed
  then have "diff = (\<lambda> u v. set_to_nat (nat_to_set u - nat_to_set v))" by (simp add: ext)
  with c_diff_def have "c_diff = diff" by simp
  with diff_is_pr show ?thesis by simp
qed

definition
  c_intersect :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  "c_intersect = (\<lambda> u v. set_to_nat (nat_to_set u \<inter> nat_to_set v))"

theorem c_intersect_is_pr: "c_intersect \<in> PrimRec2"
proof -
  define f where "f u v = c_diff (c_union u v) (c_union (c_diff u v) (c_diff v u))" for u v
  from c_diff_is_pr c_union_is_pr have f_is_pr: "f \<in> PrimRec2" unfolding f_def by prec
  have "\<And> u v. f u v = c_intersect u v"
  proof -
    fix u v show "f u v = c_intersect u v"
    proof -
      let ?A = "nat_to_set u"
      let ?B = "nat_to_set v"
      have A_fin: "finite ?A" by (rule nat_to_set_is_finite)
      have B_fin: "finite ?B" by (rule nat_to_set_is_finite)
      have S1: "c_union u v = set_to_nat (?A \<union> ?B)" by (simp add: c_union_def)
      have S2: "c_diff u v = set_to_nat (?A - ?B)" by (simp add: c_diff_def)
      have S3: "c_diff v u = set_to_nat (?B - ?A)" by (simp add: c_diff_def)
      from S2 A_fin B_fin have S4: "nat_to_set (c_diff u v) = ?A - ?B" by  (simp add: nat_to_set_srj)
      from S3 A_fin B_fin have S5: "nat_to_set (c_diff v u) = ?B - ?A" by  (simp add: nat_to_set_srj)
      from S4 S5 have S6: "c_union (c_diff u v) (c_diff v u) = set_to_nat ((?A - ?B) \<union> (?B - ?A))" by (simp add: c_union_def)
      from S1 A_fin B_fin have S7: "nat_to_set (c_union u v) = ?A \<union> ?B" by  (simp add: nat_to_set_srj)
      from S6 A_fin B_fin have S8: "nat_to_set (c_union (c_diff u v) (c_diff v u)) = (?A - ?B) \<union> (?B - ?A)" by  (simp add: nat_to_set_srj)
      from S7 S8 have S9: "f u v = set_to_nat ((?A \<union> ?B) - ((?A - ?B) \<union> (?B - ?A)))" by (simp add: c_diff_def f_def)
      have S10: "?A \<inter> ?B = (?A \<union> ?B) - ((?A - ?B) \<union> (?B - ?A))" by auto
      with S9 have S11: "f u v = set_to_nat (?A \<inter> ?B)" by auto
      have "c_intersect u v = set_to_nat (?A \<inter> ?B)" by (simp add: c_intersect_def)
      with S11 show ?thesis by auto
    qed
  qed
  then have "f = c_intersect" by (simp add: ext)
  with f_is_pr show ?thesis by auto
qed

end