(* Author: Maximilian Schäffeler *)

theory Value_Iteration
  imports "MDP-Rewards.MDP_reward"
begin

context MDP_att_\<L>
begin

section \<open>Value Iteration\<close>
text \<open>
In the previous sections we derived that repeated application of @{const "\<L>\<^sub>b"} to any bounded
function from states to the reals converges to the optimal value of the MDP @{const "\<nu>\<^sub>b_opt"}.

We can turn this procedure into an algorithm that computes not only an approximation of
@{const "\<nu>\<^sub>b_opt"} but also a policy that is arbitrarily close to optimal.

Most of the proofs rely on the assumption that the supremum in @{const "\<L>\<^sub>b"} can always be attained.
\<close>

text \<open>
The following lemma shows that the relation we use to prove termination of the value iteration
algorithm decreases in each step.
In essence, the distance of the estimate to the optimal value decreases by a factor of at
least @{term l} per iteration.\<close>

abbreviation "term_measure \<equiv> (\<lambda>(eps, v). LEAST n. (2 * l * dist ((\<L>\<^sub>b^^(Suc n)) v) ((\<L>\<^sub>b^^n) v) < eps * (1-l)))"

lemma Least_Suc_less:
  assumes "\<exists>n. P n" "\<not>P 0"
  shows "Least (\<lambda>n. P (Suc n)) < Least P"
  using assms by (auto simp: Least_Suc)

function value_iteration :: "real \<Rightarrow> ('s \<Rightarrow>\<^sub>b real) \<Rightarrow> ('s \<Rightarrow>\<^sub>b real)" where
  "value_iteration eps v =
  (if 2 * l * dist v (\<L>\<^sub>b v) < eps * (1-l) \<or> eps \<le> 0 then \<L>\<^sub>b v else value_iteration eps (\<L>\<^sub>b v))"
  by auto
termination
proof (relation "Wellfounded.measure term_measure")
  fix eps v
  assume h: "\<not> (2 * l * dist v (\<L>\<^sub>b v) < eps * (1 - l) \<or> eps \<le> 0)"
  show "((eps, \<L>\<^sub>b v), eps, v) \<in> Wellfounded.measure term_measure"
  proof -
    have "(\<lambda>n. dist ((\<L>\<^sub>b ^^ Suc n) v) ((\<L>\<^sub>b ^^ n) v)) \<longlonglongrightarrow> 0"
      using dist_\<L>\<^sub>b_tendsto
      by (auto simp: dist_commute)
    hence *: "\<exists>n. dist ((\<L>\<^sub>b ^^ Suc n) v) ((\<L>\<^sub>b ^^ n) v) < eps" if "eps > 0" for eps
      unfolding LIMSEQ_def using that by auto
    have **: "0 < l * 2" if "0 \<noteq> l"
      using zero_le_disc that by linarith
    hence "(LEAST n. (2 * l) * dist ((\<L>\<^sub>b ^^ (Suc (Suc n))) v) ((\<L>\<^sub>b ^^ (Suc n)) v) < eps * (1 - l)) <
      (LEAST n. (2 * l) * dist ((\<L>\<^sub>b ^^ Suc n) v) ((\<L>\<^sub>b ^^ n) v) <  eps * (1 - l))" if "0 \<noteq> l"
        using h *[of "eps * (1-l) / (2 * l)"] that
        by (fastforce simp: ** algebra_simps dist_commute pos_less_divide_eq intro!: Least_Suc_less)
      thus ?thesis
      using h by (cases "l = 0") (auto simp: funpow_swap1)
  qed
qed auto

text \<open>
The distance between an estimate for the value and the optimal value can be bounded with respect to
the distance between the estimate and the result of applying it to @{const \<L>\<^sub>b}
\<close>
(* 2nd to last inequality in the proof of Thm 6.3.1 *)
lemma contraction_\<L>_dist: "(1 - l) * dist v \<nu>\<^sub>b_opt \<le> dist v (\<L>\<^sub>b v)"
  using contraction_dist contraction_\<L> disc_lt_one zero_le_disc by fastforce

lemma dist_\<L>\<^sub>b_opt_eps:
  assumes "eps > 0" "2 * l * dist v (\<L>\<^sub>b v) < eps * (1-l)"
  shows "2 * dist (\<L>\<^sub>b v) \<nu>\<^sub>b_opt < eps"
proof -
  have "2 * l * dist v \<nu>\<^sub>b_opt * (1 - l) \<le> 2 * l * dist v (\<L>\<^sub>b v)"
    using contraction_\<L>_dist by (simp add: mult_left_mono mult.commute)
  hence "2 * l * dist v \<nu>\<^sub>b_opt * (1 - l) < eps * (1-l)"
    using assms(2) by linarith
  hence "2 * l * dist v \<nu>\<^sub>b_opt < eps"
    by force
  thus "2 * dist (\<L>\<^sub>b v) \<nu>\<^sub>b_opt < eps"
    using contraction_\<L>[of v \<nu>\<^sub>b_opt] by auto
qed

lemma dist_\<L>\<^sub>b_lt_dist_opt: "dist v (\<L>\<^sub>b v) \<le> 2 * dist v \<nu>\<^sub>b_opt"
proof -
  have le1: "dist v (\<L>\<^sub>b v) \<le> dist v \<nu>\<^sub>b_opt + dist (\<L>\<^sub>b v) \<nu>\<^sub>b_opt"
    by (simp add: dist_triangle dist_commute)
  have le2: "dist (\<L>\<^sub>b v) \<nu>\<^sub>b_opt \<le> l * dist v \<nu>\<^sub>b_opt"
    using \<L>\<^sub>b_opt contraction_\<L> by metis
  show ?thesis
    using mult_right_mono[of l 1] disc_lt_one
    by (fastforce intro!: order.trans[OF le2] order.trans[OF le1])
qed

text \<open>
The estimates above allow to give a bound on the error of @{const value_iteration}.
\<close>
declare value_iteration.simps[simp del]

lemma value_iteration_error:
  assumes "eps > 0"
  shows "2 * dist (value_iteration eps v) \<nu>\<^sub>b_opt < eps"
  using assms dist_\<L>\<^sub>b_opt_eps value_iteration.simps
  by (induction eps v rule: value_iteration.induct) auto

text \<open>
After the value iteration terminates, one can easily obtain a stationary deterministic
epsilon-optimal policy.

Such a policy does not exist in general, attainment of the supremum in @{const \<L>\<^sub>b} is required.
\<close>
definition "find_policy (v :: 's \<Rightarrow>\<^sub>b real) s = arg_max_on (\<lambda>a. L\<^sub>a a v s) (A s)"

definition "vi_policy eps v = find_policy (value_iteration eps v)"

abbreviation "vi u n \<equiv> (\<L>\<^sub>b ^^ n) u"

lemma \<L>\<^sub>b_iter_mono:
  assumes "u \<le> v" shows "vi u n \<le> vi v n"
  using assms \<L>\<^sub>b_mono by (induction n) auto

lemma
  assumes "vi v (Suc n) \<le> vi v n"
  shows "vi v (Suc n + m) \<le> vi v (n + m)"
proof -
  have "vi v (Suc n + m) = vi (vi v (Suc n)) m"
    by (simp add: Groups.add_ac(2) funpow_add funpow_swap1)
  also have "... \<le> vi (vi v n) m"
    using \<L>\<^sub>b_iter_mono[OF assms] by auto
  also have "... = vi v (n + m)"
    by (simp add: add.commute funpow_add)
  finally show ?thesis .
qed

lemma
  assumes "vi v n \<le> vi v (Suc n)"
  shows "vi v (n + m) \<le> vi v (Suc n + m)"
proof -
  have "vi v (n + m) \<le> vi (vi v n) m"
    by (simp add: Groups.add_ac(2) funpow_add funpow_swap1)
  also have "\<dots> \<le> vi v (Suc n + m)"
    using \<L>\<^sub>b_iter_mono[OF assms] by (auto simp only: add.commute funpow_add o_apply)
  finally show ?thesis .
qed

lemma "(\<lambda>n. dist (vi v (Suc n)) (vi v n)) \<longlonglongrightarrow> 0"
  using dist_\<L>\<^sub>b_tendsto[of v] by (auto simp: dist_commute)

end

context MDP_att_\<L>
begin

lemma is_arg_max_find_policy: "is_arg_max (\<lambda>d. L\<^sub>a d (apply_bfun v) s) (\<lambda>d. d \<in> A s)  (find_policy v s)"
  using Sup_att
  by (simp add: find_policy_def arg_max_on_def arg_max_def someI_ex max_L_ex_def has_arg_max_def)

text \<open>
The error of the resulting policy is bounded by the distance from its value to the value computed
by the value iteration plus the error in the value iteration itself.
We show that both are less than @{term "eps / 2"} when the algorithm terminates.
\<close>
lemma find_policy_dist_\<L>\<^sub>b:
  assumes "eps > 0" "2 * l * dist v (\<L>\<^sub>b v) < eps * (1-l)"
  shows "2 * dist (\<nu>\<^sub>b (mk_stationary_det (find_policy (\<L>\<^sub>b v)))) (\<L>\<^sub>b v) \<le> eps"
proof -
  let ?d = "mk_dec_det (find_policy (\<L>\<^sub>b v))"
  let ?p = "mk_stationary ?d"
  have L_eq_\<L>\<^sub>b: "L (mk_dec_det (find_policy v)) v = \<L>\<^sub>b v" for v
    by (auto simp: L_eq_L\<^sub>a_det \<L>\<^sub>b_eq_argmax_L\<^sub>a[OF is_arg_max_find_policy])
  have "dist (\<nu>\<^sub>b ?p) (\<L>\<^sub>b v) = dist (L ?d (\<nu>\<^sub>b ?p)) (\<L>\<^sub>b v)"
    using L_\<nu>_fix by force
  also have "\<dots> \<le> dist (L ?d (\<nu>\<^sub>b ?p)) (\<L>\<^sub>b (\<L>\<^sub>b v)) + dist (\<L>\<^sub>b (\<L>\<^sub>b v)) (\<L>\<^sub>b v)"
    using dist_triangle by blast
  also have "\<dots> = dist (L ?d (\<nu>\<^sub>b ?p)) (L ?d (\<L>\<^sub>b v)) + dist (\<L>\<^sub>b (\<L>\<^sub>b v)) (\<L>\<^sub>b v)"
    by (auto simp: L_eq_\<L>\<^sub>b)
  also have "\<dots> \<le> l *  dist (\<nu>\<^sub>b ?p) (\<L>\<^sub>b v) + l * dist (\<L>\<^sub>b v) v"
    using contraction_\<L> contraction_L by (fastforce intro!: add_mono)
  finally have aux: "dist (\<nu>\<^sub>b ?p) (\<L>\<^sub>b v) \<le> l * dist (\<nu>\<^sub>b ?p) (\<L>\<^sub>b v) + l * dist (\<L>\<^sub>b v) v" .
  hence "dist (\<nu>\<^sub>b ?p) (\<L>\<^sub>b v) * (1 - l) \<le> l * dist (\<L>\<^sub>b v) v"
    by (auto simp: algebra_simps)
  hence *: "2 * dist (\<nu>\<^sub>b ?p) (\<L>\<^sub>b v) * (1 - l) \<le> 2 * l * dist (\<L>\<^sub>b v) v"
    using zero_le_disc mult_left_mono by auto
  hence "2 * dist (\<nu>\<^sub>b ?p) (\<L>\<^sub>b v) * (1 - l) \<le> eps * (1 - l)"
     using assms by (fastforce simp: dist_commute intro!: order.trans[OF *])
  thus "2 * dist (\<nu>\<^sub>b ?p) (\<L>\<^sub>b v) \<le> eps"
    by auto
qed

lemma find_policy_error_bound:
  assumes "eps > 0" "2 * l * dist v (\<L>\<^sub>b v) < eps * (1-l)"
  shows "dist (\<nu>\<^sub>b (mk_stationary_det (find_policy (\<L>\<^sub>b v)))) \<nu>\<^sub>b_opt < eps"
proof -
  let ?p = "mk_stationary_det (find_policy (\<L>\<^sub>b v))"
  have "dist (\<nu>\<^sub>b ?p) \<nu>\<^sub>b_opt \<le> dist (\<nu>\<^sub>b ?p) (\<L>\<^sub>b v) + dist (\<L>\<^sub>b v) \<nu>\<^sub>b_opt"
    using dist_triangle by blast
  thus ?thesis
    using find_policy_dist_\<L>\<^sub>b[OF assms] dist_\<L>\<^sub>b_opt_eps[OF assms] by simp
qed

lemma vi_policy_opt:
  assumes "0 < eps"
  shows "dist (\<nu>\<^sub>b (mk_stationary_det (vi_policy eps v))) \<nu>\<^sub>b_opt < eps"
  unfolding vi_policy_def
  using assms
proof (induction eps v rule: value_iteration.induct)
  case (1 v)
  then show ?case
    using find_policy_error_bound by (subst value_iteration.simps) auto
qed

lemma lemma_6_3_1_d:
  assumes "eps > 0" "2 * l * dist (vi v (Suc n)) (vi v n) < eps * (1-l)"
  shows "2 * dist (vi v (Suc n)) \<nu>\<^sub>b_opt < eps"
  using dist_\<L>\<^sub>b_opt_eps assms by (simp add: dist_commute)
end

context MDP_act_disc begin

definition "find_policy' (v :: 's \<Rightarrow>\<^sub>b real) s = arb_act (opt_acts v s)"

definition "vi_policy' eps v = find_policy' (value_iteration eps v)"

lemma is_arg_max_find_policy': "is_arg_max (\<lambda>d. L\<^sub>a d (apply_bfun v) s) (\<lambda>d. d \<in> A s) (find_policy' v s)"
  using is_opt_act_some by (auto simp: find_policy'_def is_opt_act_def)

lemma find_policy'_dist_\<L>\<^sub>b:
  assumes "eps > 0" "2 * l * dist v (\<L>\<^sub>b v) < eps * (1-l)"
  shows "2 * dist (\<nu>\<^sub>b (mk_stationary_det (find_policy' (\<L>\<^sub>b v)))) (\<L>\<^sub>b v) \<le> eps"
proof -
  let ?d = "mk_dec_det (find_policy' (\<L>\<^sub>b v))"
  let ?p = "mk_stationary ?d"
  have L_eq_\<L>\<^sub>b: "L (mk_dec_det (find_policy' v)) v = \<L>\<^sub>b v" for v
    by (auto simp: L_eq_L\<^sub>a_det \<L>\<^sub>b_eq_argmax_L\<^sub>a[OF is_arg_max_find_policy'])
  have "dist (\<nu>\<^sub>b ?p) (\<L>\<^sub>b v) = dist (L ?d (\<nu>\<^sub>b ?p)) (\<L>\<^sub>b v)"
    using L_\<nu>_fix by force
  also have "\<dots> \<le> dist (L ?d (\<nu>\<^sub>b ?p)) (\<L>\<^sub>b (\<L>\<^sub>b v)) + dist (\<L>\<^sub>b (\<L>\<^sub>b v)) (\<L>\<^sub>b v)"
    using dist_triangle by blast
  also have "\<dots> = dist (L ?d (\<nu>\<^sub>b ?p)) (L ?d (\<L>\<^sub>b v)) + dist (\<L>\<^sub>b (\<L>\<^sub>b v)) (\<L>\<^sub>b v)"
    by (auto simp: L_eq_\<L>\<^sub>b)
  also have "\<dots> \<le> l *  dist (\<nu>\<^sub>b ?p) (\<L>\<^sub>b v) + l * dist (\<L>\<^sub>b v) v"
    using contraction_\<L> contraction_L by (fastforce intro!: add_mono)
  finally have aux: "dist (\<nu>\<^sub>b ?p) (\<L>\<^sub>b v) \<le> l * dist (\<nu>\<^sub>b ?p) (\<L>\<^sub>b v) + l * dist (\<L>\<^sub>b v) v" .
  hence "dist (\<nu>\<^sub>b ?p) (\<L>\<^sub>b v) * (1 - l) \<le> l * dist (\<L>\<^sub>b v) v"
    by (auto simp: algebra_simps)
  hence *: "2 * dist (\<nu>\<^sub>b ?p) (\<L>\<^sub>b v) * (1 - l) \<le> 2 * l * dist (\<L>\<^sub>b v) v"
    using zero_le_disc mult_left_mono by auto
  hence "2 * dist (\<nu>\<^sub>b ?p) (\<L>\<^sub>b v) * (1 - l) \<le> eps * (1 - l)"
     using assms by (fastforce simp: dist_commute intro!: order.trans[OF *])
  thus "2 * dist (\<nu>\<^sub>b ?p) (\<L>\<^sub>b v) \<le> eps"
    by auto
qed

lemma find_policy'_error_bound:
  assumes "eps > 0" "2 * l * dist v (\<L>\<^sub>b v) < eps * (1-l)"
  shows "dist (\<nu>\<^sub>b (mk_stationary_det (find_policy' (\<L>\<^sub>b v)))) \<nu>\<^sub>b_opt < eps"
proof -
  let ?p = "mk_stationary_det (find_policy' (\<L>\<^sub>b v))"
  have "dist (\<nu>\<^sub>b ?p) \<nu>\<^sub>b_opt \<le> dist (\<nu>\<^sub>b ?p) (\<L>\<^sub>b v) + dist (\<L>\<^sub>b v) \<nu>\<^sub>b_opt"
    using dist_triangle by blast
  thus ?thesis
    using find_policy'_dist_\<L>\<^sub>b[OF assms] dist_\<L>\<^sub>b_opt_eps[OF assms] by simp
qed

lemma vi_policy'_opt:
  assumes "eps > 0" "l > 0"
  shows "dist (\<nu>\<^sub>b (mk_stationary_det (vi_policy' eps v))) \<nu>\<^sub>b_opt < eps"
  unfolding vi_policy'_def
  using assms
proof (induction eps v rule: value_iteration.induct)
  case (1 eps v)
  then show ?case
    using find_policy'_error_bound by (auto simp: value_iteration.simps[of _ v])
qed

end
end


theory Exercise4
  imports IMP
begin

inductive astep :: "aexp \<times> state \<Rightarrow> aexp \<Rightarrow> bool" (infix "\<leadsto>" 50) where
var: "(V x,s) \<leadsto> N (s x)" |
ints: "(Plus (N i) (N j),s) \<leadsto> N (i + j)" |
fplus: "(Plus i j,s) \<leadsto> a \<Longrightarrow> (Plus (Plus i j) b,s) \<leadsto> (Plus a b)" |
splus: "(Plus i j,s) \<leadsto> b \<Longrightarrow> (Plus a (Plus i j),s) \<leadsto> (Plus a b)"

lemmas astep_induct = astep.induct[split_format(complete)]

theorem astep_preserve: "(a,s) \<leadsto> a' \<Longrightarrow> aval a s = aval a' s"
proof (induction rule: astep_induct)
  fix x s
  show "aval (V x) s = aval (N (s x)) s" by simp
next
  fix i j s
  show "aval (Plus (N i) (N j)) s = aval (N (i + j)) s" by simp
next
  fix i j s a b
  assume "(Plus i j,s) \<leadsto> a"
    and "aval (Plus i j) s = aval a s"
  thus "aval (Plus (Plus i j) b) s = aval (Plus a b) s"
    by simp
next
  fix i j s b a
  assume "(Plus i j,s) \<leadsto> b"
    and "aval (Plus i j) s = aval b s"
  thus "aval (Plus a (Plus i j)) s = aval (Plus a b) s"
    by simp
qed

(* To be honest, this other solution looks like it is a
   much more sensible choice here:
    https://github.com/kolya-vasiliev/concrete-semantics/blob/ae2a4b32ec63766e6a11e043d85d082c70eeaebc/Chap_seven.thy#L68-L69

   I debated switching to that approach after I saw it,
   but I decided in interest of transparency to stick with
   my initial approach for now. However, should this
   small-step semantic be needed for later exercises, I
   won't be shocked if I need to come back and rename my
   current implementation so that I can use that more
   productive implementation. *)

end


theory "FMap-Nominal"
  imports FMap "Nominal-Utils" "~~/src/HOL/Library/FuncSet"
begin

subsubsection {* Permtuations on finite maps *}

instantiation "fmap" :: (pt,pt) pt
begin
  lift_definition permute_fmap :: "perm \<Rightarrow> 'a::pt f\<rightharpoonup> 'b::pt \<Rightarrow> 'a f\<rightharpoonup> 'b"
    is "\<lambda> p f . p \<bullet> f" by (metis (full_types) dom_perm_rev permute_finite)

  instance
  apply(default)
  apply(transfer, simp)+
  done
end

subsubsection {* Finite maps have finite support *}

lemma map_between_finite:
  assumes "finite A"
  and "finite B"
  shows "finite {m. dom m = A \<and> ran m = B}"
proof (rule finite_imageD[OF finite_subset])
  def f  \<equiv> "\<lambda> m. (\<lambda> x \<in> A. (the (m x) :: 'b))"
  def g  \<equiv> "\<lambda> f x. (if x \<in> A then Some (f x :: 'b) else None)"
  show "f ` {m. dom m = A \<and> ran m = B} \<subseteq> extensional_funcset A B"
    by (auto simp add: extensional_funcset_def ran_def f_def)
  show "finite (extensional_funcset A B)"
    by (rule finite_PiE[OF assms])
  show "inj_on f {m. dom m = A \<and> ran m = B}"
    apply(rule inj_on_inverseI[of _ g])
    unfolding f_def g_def
    by (auto simp add: dom_def fun_eq_iff)
qed

lemma perm_finite: "finite (dom m2) \<Longrightarrow> finite {m1. dom m1 = dom m2 \<and> ran m1 = ran m2}"
  by (rule map_between_finite[OF _ finite_range])

lemma supp_set_elem_finite:
  assumes "finite S"
  and "(m::'a::fs) \<in> S"
  and "y \<in> supp m"
  shows "y \<in> supp S"
  using assms supp_of_finite_sets
  by auto

lemma supp_map_union:
  assumes "finite (dom (m:: 'a::fs \<rightharpoonup> 'b::fs))"
  shows  "supp m = (supp (dom m) \<union> supp (ran m))"
proof-
have "finite (ran m)" using assms by (rule finite_range)
{
  fix x

  let ?f = "(\<lambda>b . (x \<rightleftharpoons> b) \<bullet> m)"

  assume "x \<notin> supp (ran m)" and "x \<notin> supp (dom m)"

  { fix m'
    assume "dom m = dom m'" and "ran m = ran m'"
    assume "m' \<noteq> m"
    then obtain d where "m' d \<noteq> m d" by auto
    hence "d \<in> dom m" and "d \<in> dom m'" using `dom m = dom m'` by (auto simp add: dom_def)

    have "x \<notin> supp d" using `finite (dom m)` `x \<notin> supp (dom m)` `d \<in> dom m`
      by (metis supp_set_elem_finite)

    have "{b. ?f b d = m' d} = {b. (x \<rightleftharpoons> b) \<bullet> m ( (x \<rightleftharpoons> b) \<bullet> d) = m' d}"
      by (metis (hide_lams, no_types) Nominal2_Base.swap_commute eqvt_bound eqvt_lambda permute_swap_cancel2)
    also have "... =  (\<Union> d' \<in> dom m . {b . (x \<rightleftharpoons> b) \<bullet> d = d' \<and> (x \<rightleftharpoons> b) \<bullet> m d' = m' d})"
      using `d \<in> dom m'` `dom m = dom m'`
      apply auto
      apply (metis Some_eqvt domD domI permute_fun_app_eq permute_self permute_swap_cancel swap_eqvt)
      apply (metis permute_self permute_swap_cancel swap_eqvt)
      apply (metis permute_self permute_swap_cancel swap_eqvt)
      done
    finally
    have "finite ({b. ?f b d = m' d})"
      apply (rule ssubst)
      proof
        fix d'
        assume "d' \<in> dom m"

        have "d \<noteq> d' \<or> m d' \<noteq> m' d"
          using `m' d \<noteq> m d` by auto
        moreover
        { assume  "d \<noteq> d'"
          hence "finite {b . (x \<rightleftharpoons> b) \<bullet> d = d'}" using `x \<notin> supp d`
            by (auto elim!: finite_subset[rotated] simp add: supp_def)
        }
        moreover
        { assume  "d = d'" and "m d' \<noteq> m' d"

          have "the (m d') \<in> ran m" using `d' \<in> dom m`
            by (auto simp add: ran_def)
          hence "x \<notin> supp (the (m d'))" using `finite (ran m)` `ran m = ran m'` `x \<notin> supp (ran m)`
            by (metis supp_set_elem_finite)
          hence "x \<notin> supp (m d')" using `d' \<in> dom m`
            by (auto simp add: ran_def supp_Some)
          hence "finite {b. (x \<rightleftharpoons> b) \<bullet> m d' = m' d}" using `m d' \<noteq> m' d`
            by (auto elim!: finite_subset[rotated] simp add: supp_def)
        }
        ultimately
        have "finite {b . (x \<rightleftharpoons> b) \<bullet> d = d'} \<or> finite {b. (x \<rightleftharpoons> b) \<bullet> m d' = m' d}" by auto
        thus "finite {b . (x \<rightleftharpoons> b) \<bullet> d = d' \<and> (x \<rightleftharpoons> b) \<bullet> m d' = m' d}" by auto
      next
        show "finite (dom m)" by fact
      qed
    hence "finite ({b. ?f b = m'})"
      by (auto elim: finite_subset[rotated])
  }
  moreover
    have "finite {m'. dom m' = dom m \<and> ran m' = ran m}" using perm_finite[OF `finite (dom m)`] .
    hence "finite {m'. dom m' = dom m \<and> ran m' = ran m \<and> m' \<noteq> m}"
      by (auto elim!: finite_subset[rotated])
  ultimately
  have "finite (\<Union> {{b. (x \<rightleftharpoons> b) \<bullet> m = m'} | m'. dom m' = dom m \<and> ran m' = ran m \<and> m' \<noteq> m})"
    by auto
  hence "finite {b. dom (?f b) = dom m \<and> ran (?f b) = ran m \<and> ?f b \<noteq> m}"
    by (auto elim!: finite_subset[rotated])

  with `x \<notin> supp (ran m)` and `x \<notin> supp (dom m)`
  have "x \<notin> supp m"
    unfolding supp_def
    apply simp
    apply (rule finite_subset[of _ "
          {b. dom ((x \<rightleftharpoons> b) \<bullet> m) \<noteq> dom m} \<union> {b. ran ((x \<rightleftharpoons> b) \<bullet> m) \<noteq> ran m}
              \<union> {b. dom (?f b) = dom m \<and> ran (?f b) = ran m \<and> ?f b \<noteq> m}"])
    by auto
} moreover
{ fix x
  have "{b. (x \<rightleftharpoons> b) \<bullet> dom m \<noteq> dom m} \<subseteq> {b. (x \<rightleftharpoons> b) \<bullet> m \<noteq> m}" by auto
  hence "x \<in> supp (dom m) \<Longrightarrow> x \<in> supp m"
  by (auto elim!: infinite_super simp add: supp_def)
} moreover
{ fix x
  have "{b. (x \<rightleftharpoons> b) \<bullet> ran m \<noteq> ran m} \<subseteq> {b. (x \<rightleftharpoons> b) \<bullet> m \<noteq> m}" by auto
  hence "x \<in> supp (ran m) \<Longrightarrow> x \<in> supp m"
  by (auto elim!: infinite_super simp add: supp_def)
} ultimately
show ?thesis by auto
qed

lemma supp_fmap_transfer[transfer_rule]:
  "(pcr_fmap op= op= ===> op =) supp supp"
  unfolding supp_def[abs_def] by transfer_prover

lemma supp_fmap:
  "supp (m:: 'a::fs f\<rightharpoonup> 'b::fs) = (supp (fdom m) \<union> supp (fran m))"
by transfer(erule supp_map_union)

instance "fmap" :: (fs,fs) fs
  by (default, auto intro: finite_sets_supp simp add: supp_fmap)

subsubsection {* Equivariance lemmas related to finite maps *}

lemma lookup_eqvt[eqvt]:
  "\<pi> \<bullet> lookup m x = lookup (\<pi> \<bullet> m) (\<pi> \<bullet> x)"
  by transfer simp

lemma the_lookup_eqvt:
  "x \<in> fdom m \<Longrightarrow> \<pi> \<bullet> (m f! x) = (\<pi> \<bullet> m) f! (\<pi> \<bullet> x)"
  apply (transfer fixing: x)
  apply auto
  by (metis Some_eqvt permute_fun_app_eq option.sel)

lemma fempty_eqvt[eqvt, simp]:
  "\<pi> \<bullet> fempty = fempty"
  by (transfer, auto simp add: permute_fun_def)

lemma fempty_supp[simp]: "supp fempty = {}"
  by (metis eqvtI fempty_eqvt supp_fun_eqvt)

lemma fempty_fresh[simp]: "a \<sharp> fempty"
  by (simp add: fresh_def)

lemma fempty_fresh_star[simp]: "a \<sharp>* fempty"
  by (simp add: fresh_star_def)

lemma fdom_perm: "fdom (\<pi> \<bullet> f) = \<pi> \<bullet> (fdom f)"
  apply transfer by (rule dom_perm)
lemmas fdom_perm_rev[simp,eqvt] = fdom_perm[symmetric]

lemma fmap_upd_eqvt[eqvt]: "p \<bullet> (fmap_upd f x y) = fmap_upd (p \<bullet> f) (p \<bullet> x) (p \<bullet> y)"
  by transfer (metis Some_eqvt fun_upd_eqvt)

lemma fmap_restr_eqvt:
  "finite d \<Longrightarrow> \<pi> \<bullet> (fmap_restr d m) = fmap_restr (\<pi> \<bullet> d) (\<pi> \<bullet> m)"
proof
case goal1 thus ?case by (metis fdom_fmap_restr fdom_perm_rev inter_eqvt permute_finite)
case goal2
  hence "finite (\<pi> \<bullet> d)" by simp

  from goal2(2) have "x \<in> \<pi> \<bullet> fdom m \<inter> \<pi> \<bullet> d" by (metis (full_types) fdom_fmap_restr fdom_perm_rev goal1 inter_eqvt)
  then obtain y where "x = \<pi> \<bullet> y" and "y \<in> fdom m \<inter> d" by (auto simp add: permute_set_def)

  have "(\<pi> \<bullet> fmap_restr d m) f! x = (\<pi> \<bullet> fmap_restr d m) f! (\<pi> \<bullet> y)" by (simp add: `x = _`)
  also have "... = \<pi> \<bullet> ((fmap_restr d m) f! y)" using `finite d` `y \<in> fdom m \<inter> d` by (metis fdom_fmap_restr the_lookup_eqvt)
  also have "... = \<pi> \<bullet> (m f! y)" using `y \<in> _` by (simp add: lookup_fmap_restr[OF `finite d`])
  also have "... = (\<pi> \<bullet> m) f! x" using `x = _` `y \<in> _` by (simp add: the_lookup_eqvt)
  also have "... = fmap_restr (\<pi> \<bullet> d) (\<pi> \<bullet> m) f! x" using `x \<in> _ \<inter> _` by (simp add: lookup_fmap_restr[OF `finite (\<pi> \<bullet> d)`])
  finally show ?case.
qed

lemma fmap_delete_eqvt[eqvt]:
  "\<pi> \<bullet> fmap_delete x m = fmap_delete (\<pi> \<bullet> x) (\<pi> \<bullet> m)"
  by transfer simp

lemma fmap_add_eqvt[eqvt]:
  "\<pi> \<bullet> m1 f++ m2 = (\<pi> \<bullet> m1) f++ (\<pi> \<bullet> m2)"
  by transfer simp

lemma fmap_of_eqvt[eqvt]:
  "\<pi> \<bullet> fmap_of l = fmap_of (\<pi> \<bullet> l)"
by transfer (rule map_of_eqvt)

subsubsection {* Freshness and support *}

lemma sharp_Env: "atom x \<sharp> (\<rho> :: 'a::at_base f\<rightharpoonup> 'b::pure) \<longleftrightarrow> x \<notin> fdom \<rho>"
  apply (subst fresh_def)
  apply (simp  add: supp_fmap)
  apply (subst (1 2) fresh_def[symmetric])
  apply (simp add: fresh_finite_set_at_base[OF finite_fdom] pure_fresh)
  done

lemma supp_fmap_upd[simp]:
  "supp (m((x::'a::fs) f\<mapsto> v::'b::fs)) = supp (fmap_delete x m) \<union> supp x \<union> supp v"
  apply (subst (1 2) supp_fmap)
  apply (subst (1 2 3 4) supp_of_finite_sets)
  apply simp_all[4]
  apply auto
  done

lemma fresh_fmap_upd_eq:
  "a \<sharp> m((x::'a::fs) f\<mapsto> v::'b::fs) \<longleftrightarrow> (a \<sharp> (fmap_delete x m) \<and> a \<sharp> x \<and> a \<sharp> v)"
  unfolding fresh_def by simp

lemma fresh_star_fmap_upd_eq:
  "a \<sharp>* m((x::'a::fs) f\<mapsto> v::'b::fs) \<longleftrightarrow> (a \<sharp>* (fmap_delete x m) \<and> a \<sharp>* x \<and> a \<sharp>* v)"
by (metis fresh_fmap_upd_eq fresh_star_def)

end


(*  Title:      HOL/Nitpick_Examples/Induct_Nits.thy
    Author:     Jasmin Blanchette, TU Muenchen
    Copyright   2009-2011

Examples featuring Nitpick applied to (co)inductive definitions.
*)

section \<open>Examples Featuring Nitpick Applied to (Co)inductive Definitions\<close>

theory Induct_Nits
imports MainRLT
begin

nitpick_params [verbose, card = 1-8, unary_ints,
                sat_solver = MiniSat, max_threads = 1, timeout = 240]

inductive p1 :: "nat \<Rightarrow> bool" where
"p1 0" |
"p1 n \<Longrightarrow> p1 (n + 2)"

coinductive q1 :: "nat \<Rightarrow> bool" where
"q1 0" |
"q1 n \<Longrightarrow> q1 (n + 2)"

lemma "p1 = q1"
nitpick [expect = none]
nitpick [wf, expect = none]
nitpick [non_wf, expect = none]
nitpick [non_wf, dont_star_linear_preds, expect = none]
oops

lemma "p1 \<noteq> q1"
nitpick [expect = potential]
nitpick [wf, expect = potential]
nitpick [non_wf, expect = potential]
nitpick [non_wf, dont_star_linear_preds, expect = potential]
oops

lemma "p1 (n - 2) \<Longrightarrow> p1 n"
nitpick [expect = genuine]
nitpick [non_wf, expect = genuine]
nitpick [non_wf, dont_star_linear_preds, expect = genuine]
oops

lemma "q1 (n - 2) \<Longrightarrow> q1 n"
nitpick [expect = genuine]
nitpick [non_wf, expect = genuine]
nitpick [non_wf, dont_star_linear_preds, expect = genuine]
oops

inductive p2 :: "nat \<Rightarrow> bool" where
"p2 n \<Longrightarrow> p2 n"

coinductive q2 :: "nat \<Rightarrow> bool" where
"q2 n \<Longrightarrow> q2 n"

lemma "p2 = bot"
nitpick [expect = none]
nitpick [dont_star_linear_preds, expect = none]
sorry

lemma "q2 = bot"
nitpick [expect = genuine]
nitpick [dont_star_linear_preds, expect = genuine]
nitpick [wf, expect = quasi_genuine]
oops

lemma "p2 = top"
nitpick [expect = genuine]
nitpick [dont_star_linear_preds, expect = genuine]
oops

lemma "q2 = top"
nitpick [expect = none]
nitpick [dont_star_linear_preds, expect = none]
nitpick [wf, expect = quasi_genuine]
sorry

lemma "p2 = q2"
nitpick [expect = genuine]
nitpick [dont_star_linear_preds, expect = genuine]
oops

lemma "p2 n"
nitpick [expect = genuine]
nitpick [dont_star_linear_preds, expect = genuine]
nitpick [dont_specialize, expect = genuine]
oops

lemma "q2 n"
nitpick [expect = none]
nitpick [dont_star_linear_preds, expect = none]
sorry

lemma "\<not> p2 n"
nitpick [expect = none]
nitpick [dont_star_linear_preds, expect = none]
sorry

lemma "\<not> q2 n"
nitpick [expect = genuine]
nitpick [dont_star_linear_preds, expect = genuine]
nitpick [dont_specialize, expect = genuine]
oops

inductive p3 and p4 where
"p3 0" |
"p3 n \<Longrightarrow> p4 (Suc n)" |
"p4 n \<Longrightarrow> p3 (Suc n)"

coinductive q3 and q4 where
"q3 0" |
"q3 n \<Longrightarrow> q4 (Suc n)" |
"q4 n \<Longrightarrow> q3 (Suc n)"

lemma "p3 = q3"
nitpick [expect = none]
nitpick [non_wf, expect = none]
sorry

lemma "p4 = q4"
nitpick [expect = none]
nitpick [non_wf, expect = none]
sorry

lemma "p3 = top - p4"
nitpick [expect = none]
nitpick [non_wf, expect = none]
sorry

lemma "q3 = top - q4"
nitpick [expect = none]
nitpick [non_wf, expect = none]
sorry

lemma "inf p3 q4 \<noteq> bot"
nitpick [expect = potential]
nitpick [non_wf, expect = potential]
sorry

lemma "inf q3 p4 \<noteq> bot"
nitpick [expect = potential]
nitpick [non_wf, expect = potential]
sorry

lemma "sup p3 q4 \<noteq> top"
nitpick [expect = potential]
nitpick [non_wf, expect = potential]
sorry

lemma "sup q3 p4 \<noteq> top"
nitpick [expect = potential]
nitpick [non_wf, expect = potential]
sorry

end


(*  Author:  Stefan Berghofer et al.
*)

subsection \<open>Signed division: negative results rounded towards zero rather than minus infinity.\<close>

theory Signed_Division
  imports Main
begin

class signed_division =
  fixes signed_divide :: \<open>'a \<Rightarrow> 'a \<Rightarrow> 'a\<close> (infixl "sdiv" 70)
  and signed_modulo :: \<open>'a \<Rightarrow> 'a \<Rightarrow> 'a\<close> (infixl "smod" 70)

instantiation int :: signed_division
begin

definition signed_divide_int :: \<open>int \<Rightarrow> int \<Rightarrow> int\<close>
  where \<open>k sdiv l = sgn k * sgn l * (\<bar>k\<bar> div \<bar>l\<bar>)\<close> for k l :: int

definition signed_modulo_int :: \<open>int \<Rightarrow> int \<Rightarrow> int\<close>
  where \<open>k smod l = k - (k sdiv l) * l\<close> for k l :: int

instance ..

end

lemma int_sdiv_simps [simp]:
    "(a :: int) sdiv 1 = a"
    "(a :: int) sdiv 0 = 0"
    "(a :: int) sdiv -1 = -a"
  apply (auto simp: signed_divide_int_def sgn_if)
  done

lemma sgn_div_eq_sgn_mult:
    "a div b \<noteq> 0 \<Longrightarrow> sgn ((a :: int) div b) = sgn (a * b)"
  apply (clarsimp simp: sgn_if zero_le_mult_iff neg_imp_zdiv_nonneg_iff not_less)
  apply (metis less_le mult_le_0_iff neg_imp_zdiv_neg_iff not_less pos_imp_zdiv_neg_iff zdiv_eq_0_iff)
  done

lemma sgn_sdiv_eq_sgn_mult:
  "a sdiv b \<noteq> 0 \<Longrightarrow> sgn ((a :: int) sdiv b) = sgn (a * b)"
  by (auto simp: signed_divide_int_def sgn_div_eq_sgn_mult sgn_mult)

lemma int_sdiv_same_is_1 [simp]:
    "a \<noteq> 0 \<Longrightarrow> ((a :: int) sdiv b = a) = (b = 1)"
  apply (rule iffI)
   apply (clarsimp simp: signed_divide_int_def)
   apply (subgoal_tac "b > 0")
    apply (case_tac "a > 0")
     apply (clarsimp simp: sgn_if)
  apply (simp_all add: not_less algebra_split_simps sgn_if split: if_splits)
  using int_div_less_self [of a b] apply linarith
    apply (metis add.commute add.inverse_inverse group_cancel.rule0 int_div_less_self linorder_neqE_linordered_idom neg_0_le_iff_le not_less verit_comp_simplify1(1) zless_imp_add1_zle)
   apply (metis div_minus_right neg_imp_zdiv_neg_iff neg_le_0_iff_le not_less order.not_eq_order_implies_strict)
  apply (metis abs_le_zero_iff abs_of_nonneg neg_imp_zdiv_nonneg_iff order.not_eq_order_implies_strict)
  done

lemma int_sdiv_negated_is_minus1 [simp]:
    "a \<noteq> 0 \<Longrightarrow> ((a :: int) sdiv b = - a) = (b = -1)"
  apply (clarsimp simp: signed_divide_int_def)
  apply (rule iffI)
   apply (subgoal_tac "b < 0")
    apply (case_tac "a > 0")
     apply (clarsimp simp: sgn_if algebra_split_simps not_less)
     apply (case_tac "sgn (a * b) = -1")
      apply (simp_all add: not_less algebra_split_simps sgn_if split: if_splits)
     apply (metis add.inverse_inverse int_div_less_self int_one_le_iff_zero_less less_le neg_0_less_iff_less)
    apply (metis add.inverse_inverse div_minus_right int_div_less_self int_one_le_iff_zero_less less_le neg_0_less_iff_less)
   apply (metis less_le neg_less_0_iff_less not_less pos_imp_zdiv_neg_iff)
  apply (metis div_minus_right dual_order.eq_iff neg_imp_zdiv_nonneg_iff neg_less_0_iff_less)
  done

lemma sdiv_int_range:
    "(a :: int) sdiv b \<in> { - (abs a) .. (abs a) }"
  apply (unfold signed_divide_int_def)
  apply (subgoal_tac "(abs a) div (abs b) \<le> (abs a)")
   apply (auto simp add: sgn_if not_less)
      apply (metis le_less le_less_trans neg_equal_0_iff_equal neg_less_iff_less not_le pos_imp_zdiv_neg_iff)
     apply (metis add.inverse_neutral div_int_pos_iff le_less neg_le_iff_le order_trans)
    apply (metis div_minus_right le_less_trans neg_imp_zdiv_neg_iff neg_less_0_iff_less not_le)
  using div_int_pos_iff apply fastforce
  apply (auto simp add: abs_if not_less)
     apply (metis add.inverse_inverse add_0_left div_by_1 div_minus_right less_le neg_0_le_iff_le not_le not_one_le_zero zdiv_mono2 zless_imp_add1_zle)
    apply (metis div_by_1 neg_0_less_iff_less pos_imp_zdiv_pos_iff zdiv_mono2 zero_less_one)
   apply (metis add.inverse_neutral div_by_0 div_by_1 int_div_less_self int_one_le_iff_zero_less less_le less_minus_iff order_refl)
  apply (metis div_by_1 divide_int_def int_div_less_self less_le linorder_neqE_linordered_idom order_refl unique_euclidean_semiring_numeral_class.div_less)
  done

lemma sdiv_int_div_0 [simp]:
  "(x :: int) sdiv 0 = 0"
  by (clarsimp simp: signed_divide_int_def)

lemma sdiv_int_0_div [simp]:
  "0 sdiv (x :: int) = 0"
  by (clarsimp simp: signed_divide_int_def)

lemma smod_int_alt_def:
     "(a::int) smod b = sgn (a) * (abs a mod abs b)"
  apply (clarsimp simp: signed_modulo_int_def signed_divide_int_def)
  apply (clarsimp simp: minus_div_mult_eq_mod [symmetric] abs_sgn sgn_mult sgn_if algebra_split_simps)
  done

lemma smod_int_range:
  "b \<noteq> 0 \<Longrightarrow> (a::int) smod b \<in> { - abs b + 1 .. abs b - 1 }"
  apply (case_tac  "b > 0")
   apply (insert pos_mod_conj [where a=a and b=b])[1]
   apply (insert pos_mod_conj [where a="-a" and b=b])[1]
   apply (auto simp: smod_int_alt_def algebra_simps sgn_if
              abs_if not_less add1_zle_eq [simplified add.commute])[1]
    apply (metis add_nonneg_nonneg int_one_le_iff_zero_less le_less less_add_same_cancel2 not_le pos_mod_conj)
  apply (metis (full_types) add.inverse_inverse eucl_rel_int eucl_rel_int_iff le_less_trans neg_0_le_iff_le)
  apply (insert neg_mod_conj [where a=a and b="b"])[1]
  apply (insert neg_mod_conj [where a="-a" and b="b"])[1]
  apply (clarsimp simp: smod_int_alt_def algebra_simps sgn_if
            abs_if not_less add1_zle_eq [simplified add.commute])
  apply (metis neg_0_less_iff_less neg_mod_conj not_le not_less_iff_gr_or_eq order_trans pos_mod_conj)
  done

lemma smod_int_compares:
   "\<lbrakk> 0 \<le> a; 0 < b \<rbrakk> \<Longrightarrow> (a :: int) smod b < b"
   "\<lbrakk> 0 \<le> a; 0 < b \<rbrakk> \<Longrightarrow> 0 \<le> (a :: int) smod b"
   "\<lbrakk> a \<le> 0; 0 < b \<rbrakk> \<Longrightarrow> -b < (a :: int) smod b"
   "\<lbrakk> a \<le> 0; 0 < b \<rbrakk> \<Longrightarrow> (a :: int) smod b \<le> 0"
   "\<lbrakk> 0 \<le> a; b < 0 \<rbrakk> \<Longrightarrow> (a :: int) smod b < - b"
   "\<lbrakk> 0 \<le> a; b < 0 \<rbrakk> \<Longrightarrow> 0 \<le> (a :: int) smod b"
   "\<lbrakk> a \<le> 0; b < 0 \<rbrakk> \<Longrightarrow> (a :: int) smod b \<le> 0"
   "\<lbrakk> a \<le> 0; b < 0 \<rbrakk> \<Longrightarrow> b \<le> (a :: int) smod b"
  apply (insert smod_int_range [where a=a and b=b])
  apply (auto simp: add1_zle_eq smod_int_alt_def sgn_if)
  done

lemma smod_int_mod_0 [simp]:
  "x smod (0 :: int) = x"
  by (clarsimp simp: signed_modulo_int_def)

lemma smod_int_0_mod [simp]:
  "0 smod (x :: int) = 0"
  by (clarsimp simp: smod_int_alt_def)

lemma smod_mod_positive:
    "\<lbrakk> 0 \<le> (a :: int); 0 \<le> b \<rbrakk> \<Longrightarrow> a smod b = a mod b"
  by (clarsimp simp: smod_int_alt_def zsgn_def)

end


(* Author: Fabian Hellauer
           Fabian Immler
*)
theory Float_Format_Conversions
  imports
    "IEEE_Floating_Point.IEEE"
    "HOL-Library.Float"
begin

section \<open>IEEE.float to Float.float\<close>

fun Float_of_normal :: "format \<Rightarrow> representation \<Rightarrow> Float.float" where
  "Float_of_normal x (s,e,f) =
    Float ((-1)^s * (2 ^ fracwidth x + f)) (int e - bias x - fracwidth x)"

lemma Float_of_normal_correct:
  assumes "e > 0"
  shows "real_of_float (Float_of_normal x (s,e,f)) = valof x (s,e,f)"
  using assms
  by (simp add: powr_realpow powr_diff) (simp add: field_simps)

corollary Float_of_normal_rep:
  "is_normal x r \<Longrightarrow> real_of_float (Float_of_normal x r) = valof x r"
  unfolding is_normal_def
  by (cases r) (simp del: Float_of_normal.simps add: Float_of_normal_correct)

fun Float_of_subn_or_0 :: "format \<Rightarrow> representation \<Rightarrow> Float.float" where
  "Float_of_subn_or_0 x (s,_,f) =
    Float ((-1)^s * f) ((1 :: int) - bias x - fracwidth x)"

lemma Float_of_subn_or_0_correct:
  shows "real_of_float (Float_of_subn_or_0 x (s,0,f)) = valof x (s,0,f)"
  by (simp add: powr_realpow powr_diff)

corollary Float_of_subn_or_0_rep:
  "is_denormal x r \<or> is_zero x r \<Longrightarrow> real_of_float (Float_of_subn_or_0 x r) = valof x r"
  unfolding is_denormal_def is_zero_def
  by (cases r) (auto simp del: Float_of_subn_or_0.simps simp add: Float_of_subn_or_0_correct)

subsection \<open>Combining the finite cases\<close>

fun Float_of_finite :: "format \<Rightarrow> representation \<Rightarrow> Float.float" where
  "Float_of_finite x (s,0,f) = Float_of_subn_or_0 x (s,0,f)" |
  "Float_of_finite x (s,e,f) = Float_of_normal x (s,e,f)"

theorem Float_of_finite_correct: "real_of_float (Float_of_finite x r) = valof x r"
  using Float_of_finite.simps Float_of_normal_correct Float_of_subn_or_0_correct
  by (cases r) (metis Suc_pred neq0_conv)

section \<open>Float.float to IEEE.float\<close>

definition normal_rep_of_Float_b :: "format \<Rightarrow> nat \<Rightarrow> Float.float \<Rightarrow> representation"
  where
    "normal_rep_of_Float_b x b f =
  (if is_float_pos f then 0 else 1,
    nat (Float.exponent f + int (bias x) + b),
    nat (\<bar>Float.mantissa f\<bar> * 2 ^ (fracwidth x - b) - 2 ^ fracwidth x))"

lemma normal_rep_of_Float_b_correct:
  fixes b :: nat
  assumes f_not_zero: "\<not>is_float_zero f"
  assumes exponent_b: "0 < Float.exponent f + int (bias x) + b"
    and mantissa_b: "0 \<le> \<bar>Float.mantissa f\<bar> * 2 ^ (fracwidth x - b) - 2 ^ fracwidth x"
    and b_ok: "fracwidth x \<ge> b"
  shows "valof x (normal_rep_of_Float_b x b f) = real_of_float f"
  using assms
proof  (cases "is_float_pos f")
  case True
  have if_false: "\<not>nat (Float.exponent f + int (bias x) + b) = 0"
    using exponent_b by linarith
  have a: "?thesis \<longleftrightarrow>
    2 ^ nat (Float.exponent f + int (bias x) + int b) *
    (1 + real (nat (\<bar>mantissa f\<bar> * 2 ^ (fracwidth x - b) - 2 ^ fracwidth x)) / 2 ^ fracwidth x) /
    2 ^ bias x
    =
    real_of_int (mantissa f) *
    2 powr real_of_int (Float.exponent f)"
    using if_false normal_rep_of_Float_b_def mantissa_exponent valof.simps powr_realpow
    by (simp add: True)
  have m_greater: "mantissa f > 0"
    by (metis Float.compute_is_float_pos Float_mantissa_exponent True)
  then have "\<bar>mantissa f\<bar> = mantissa f"
    by simp
  then have s2: "real (nat (\<bar>mantissa f\<bar> * 2 ^ (fracwidth x - b) - 2 ^ fracwidth x))
    = \<bar>mantissa f\<bar> * 2 ^ (fracwidth x - b) - 2 ^ fracwidth x"
    using mantissa_b by auto
  have s3: "\<bar>real_of_int (mantissa f)\<bar> = real_of_int (mantissa f)"
    using \<open>0 < mantissa f\<close> by linarith
  have s4: "(real_of_int (Float.exponent f) + (real (fracwidth x) + real (bias x)))
    = real_of_int (Float.exponent f + bias x + fracwidth x)"
    by simp
  have s5: "real (nat (Float.exponent f + int (bias x) + int b)) + real (fracwidth x - b)
    = real_of_int (Float.exponent f + int (bias x) + int (fracwidth x))"
    using if_false b_ok by linarith
  show ?thesis
    unfolding a
    by (simp add: s2 s3 divide_simps powr_realpow[symmetric] powr_add[symmetric])
        (simp add: s4 s5)
next
  case False
  have if_false: "nat (Float.exponent f + int (bias x) + int b) \<noteq> 0"
    using exponent_b by linarith
  have a: "?thesis \<longleftrightarrow>
    - (2 ^ nat (Float.exponent f + int (bias x) + int b) *
    (1 + real (nat (\<bar>mantissa f\<bar> * 2 ^ (fracwidth x - b) - 2 ^ fracwidth x)) / 2 ^ fracwidth x) /
    2 ^ bias x)
    =
    real_of_int (mantissa f) *
    2 powr real_of_int (Float.exponent f)"
    using if_false normal_rep_of_Float_b_def mantissa_exponent valof.simps powr_realpow
    by (simp add: False)
  have m_smaller: "mantissa f < 0"
    by (metis False Float.compute_is_float_pos Float.compute_is_float_zero Float_mantissa_exponent
        f_not_zero linorder_neqE_linordered_idom)
  then have "\<bar>mantissa f\<bar> = - mantissa f"
    by simp
  then have s2: "real (nat (\<bar>mantissa f\<bar> * 2 ^ (fracwidth x - b) - 2 ^ fracwidth x))
    = \<bar>mantissa f\<bar> * 2 ^ (fracwidth x - b) - 2 ^ fracwidth x"
    using mantissa_b by auto
  have s3: "\<bar>real_of_int (mantissa f)\<bar> = - real_of_int (mantissa f)"
    using \<open>0 > mantissa f\<close> by linarith
  have s4: "(real_of_int (Float.exponent f) + (real (fracwidth x) + real (bias x)))
    = real_of_int (Float.exponent f + bias x + fracwidth x)"
    by simp
  have s5: "real (nat (Float.exponent f + int (bias x) + int b)) + real (fracwidth x - b)
    = real_of_int (Float.exponent f + int (bias x) + int (fracwidth x))"
    using if_false b_ok by linarith
  show ?thesis
    unfolding a
    by (simp add: s2 s3 divide_simps powr_realpow[symmetric] powr_add[symmetric])
      (simp add: s4 s5)
qed

lemma floorlog_pos_iff: "floorlog b x > 0 \<longleftrightarrow> x > 0 \<and> b > 1"
  by (auto simp: floorlog_def)

lemma bitlen_pos_iff: "bitlen x > 0 \<longleftrightarrow> x > 0"
  by (auto simp: bitlen_def floorlog_pos_iff)

definition normal_rep_of_Float :: "format \<Rightarrow> Float.float \<Rightarrow> representation" where
  "normal_rep_of_Float x f = normal_rep_of_Float_b x (nat (bitlen \<bar>mantissa f\<bar> - 1)) f"

lemma normal_rep_of_Float_correct:
  assumes "\<not>is_float_zero f"
  assumes mantissa: "bitlen \<bar>mantissa f\<bar> \<le> fracwidth x"
  assumes exponent: "- int (bias x) - bitlen \<bar>mantissa f\<bar> + 1 < Float.exponent f"
    "exponent f < 2^(expwidth x) - int (bias x) - fracwidth x"
  shows "valof x (normal_rep_of_Float x f) = real_of_float f" (is ?th1)
    and "is_valid x (normal_rep_of_Float x f)" (is ?th2)
    and "is_normal x (normal_rep_of_Float x f)" (is ?th3)
proof -
  from assms(1) have mnz[simp]: "mantissa f \<noteq> 0"
    by (auto simp: is_float_zero_def mantissa_exponent)
  let ?bl = "bitlen \<bar>mantissa f\<bar>"
  have bl_pos: "?bl > 0"
    by (auto simp: bitlen_pos_iff)
  have "\<bar>Float.mantissa f\<bar> * 2 ^ (fracwidth x - nat (?bl - 1)) - 2 ^ fracwidth x \<ge>
    2 ^ (nat (?bl - 1)) * 2 ^ (fracwidth x - nat (?bl - 1)) - 2 ^ fracwidth x"
    using bitlen_bounds[of "\<bar>mantissa f\<bar>"] bl_pos
    by (auto simp: bitlen_def floorlog_def)
  also have "2 ^ (nat (?bl - 1)) * 2 ^ (fracwidth x - nat (?bl - 1)) - 2 ^ fracwidth x
    = (2::int) ^ (nat (?bl - 1) + (fracwidth x - nat (?bl - 1))) - 2 ^ fracwidth x"
    unfolding power_add[symmetric]
    by auto
  also have "(nat (?bl - 1) + (fracwidth x - nat (?bl - 1))) = fracwidth x"
    using assms by simp
  finally have mantissa_ok: "0 \<le> \<bar>mantissa f\<bar> * 2 ^ (fracwidth x - nat (?bl - 1)) - 2 ^ fracwidth x"
    by simp
  have "\<bar>mantissa f\<bar> * (2::real) ^ (fracwidth x - nat (?bl - 1)) <
      2 ^ nat (?bl) * (2::real) ^ (fracwidth x - nat (?bl - 1))"
    using abs_real_le_2_powr_bitlen bitlen_nonneg powr_int
    by auto
  also have "\<dots> = 2 ^ (nat (?bl) + fracwidth x - nat (?bl - 1))"
    unfolding power_add[symmetric]
    using mantissa
    by simp
  also
  have "?bl > 0" by fact
  then have "nat (?bl) + fracwidth x - nat (?bl - 1) = fracwidth x + 1"
    using assms
    by (simp)
  finally
  have "\<bar>mantissa f\<bar> * (2::real) ^ (fracwidth x - nat (?bl - 1)) < 2 ^ (fracwidth x + 1)"
    by simp
  then have "real_of_int (\<bar>mantissa f\<bar> * 2 ^ (fracwidth x - nat (?bl - 1))) <
    real_of_int (2 ^ (fracwidth x + 1) - 1) + 1"
    by simp
  then have "\<bar>mantissa f\<bar> * 2 ^ (fracwidth x - nat (?bl - 1)) < 2 ^ (fracwidth x + 1)"
    unfolding int_le_real_less[symmetric]
    by simp
  then have "\<bar>mantissa f\<bar> * 2 ^ (fracwidth x - nat (?bl - 1)) < 2 ^ (fracwidth x + 1)"
    by simp
  then have "\<bar>mantissa f\<bar> * 2 ^ (fracwidth x - nat (?bl - 1)) - 2 ^ fracwidth x < 2 ^ fracwidth x"
    by (simp)
  with mantissa_ok
  have l: "nat (\<bar>mantissa f\<bar> * 2 ^ (fracwidth x - nat (?bl - 1)) - 2 ^ fracwidth x) < 2 ^ fracwidth x"
    by (simp add: nat_less_iff)

  have emax: "nat (Float.exponent f + int (bias x) + (bitlen \<bar>mantissa f\<bar> - 1)) < emax x"
    using exponent mantissa
    by (auto simp: emax_def nat_less_iff of_nat_diff)
  show ?th1
    unfolding normal_rep_of_Float_def
    using assms mantissa_ok mantissa
    by (intro normal_rep_of_Float_b_correct) auto
  show ?th2
    unfolding normal_rep_of_Float_def
    using assms l
    by (auto simp: normal_rep_of_Float_b_def nat_less_iff is_valid_def)
  show ?th3
    using bl_pos exponent emax
    by (auto simp: normal_rep_of_Float_def normal_rep_of_Float_b_def is_normal_def bl_pos emax_def)
qed

lemma general_valof_topfloat:
  assumes ew_ok: "expwidth x \<ge> 2"
  shows "valof x (topfloat x) = largest x"
proof -
  let ?fw = "2 ^ fracwidth x"
  from ew_ok have "((2::nat) ^ expwidth x - 1 - 1) \<ge> 1"
    by simp (metis Suc_1 Suc_leI linorder_neqE_nat nat.simps(1) not_le not_numeral_le_zero
        numerals(2) power.simps(1) power_inject_exp power_one_right zero_less_diff zero_less_power)
  moreover have "real (?fw - Suc 0) = real (?fw) - 1"
    by (simp add: of_nat_diff)
  moreover have "(?fw - (1::real)) / ?fw = 1 - 1 / ?fw"
  proof -
    have f1: "\<forall>r ra rb. (r::real) / rb + ra / rb + - 1 * ((ra + r) / rb) = 0"
      by (simp add: add_divide_distrib)
    have "- (1::real) + ?fw + 1 = ?fw"
      by auto
    then have f2: "(1::real) / ?fw + (- 1 + ?fw) / ?fw + - 1 * (?fw / ?fw) = 0"
      using f1 by metis
    have f3: "((?fw - (1::real)) / ?fw \<noteq> 1 - 1 / ?fw) = ((1::real) / ?fw + (- 1 + ?fw) / ?fw \<noteq> 1)"
      by fastforce
    have "(1::real) / ?fw + (- 1 + ?fw) / ?fw = 1"
      using f2 by simp
    then show "(?fw - (1::real)) / ?fw = 1 - 1 / ?fw"
      using f3 by meson
  qed
  ultimately show ?thesis
    unfolding emax_def topfloat_def largest_def
    by auto
qed

definition subnormal_rep_of_Float :: "format \<Rightarrow> Float.float \<Rightarrow> representation"
  where
    "subnormal_rep_of_Float x f =
  (if is_float_nonneg f then 0 else 1,
    0,
    nat (\<bar>Float.mantissa f\<bar> * 2 ^ nat (exponent f + bias x + fracwidth x - 1)))"

lemma floorlog_leD: "floorlog b x \<le> w \<Longrightarrow> b > 1 \<Longrightarrow> x < b ^ w"
  by (metis One_nat_def floorlog_bounds less_Suc0 less_le_trans neq0_conv power_0 power_increasing_iff zero_le)

lemma bitlen_leD: "nat x < 2 ^ w" if "bitlen x \<le> w"
  using that
  by (auto simp: bitlen_def dest!: floorlog_leD)

lemma subnormal_rep_of_Float_correct:
  assumes "\<not>is_float_zero f"
  assumes mantissa: "bitlen \<bar>mantissa f\<bar> \<le> 1 - exponent f - bias x"
  assumes exponent: "fracwidth x - int (bias x) < exponent f"

shows "valof x (subnormal_rep_of_Float x f) = real_of_float f" (is ?th1)
  and "is_valid x (subnormal_rep_of_Float x f)" (is ?th2)
  and "is_denormal x (subnormal_rep_of_Float x f)" (is ?th3)
proof -
  have mnz: "mantissa f \<noteq> 0" using assms(1) by (auto simp: is_float_zero_def mantissa_exponent)
  then have "bitlen (\<bar>mantissa f\<bar> * 2 ^ nat (Float.exponent f + int (bias x) + int (fracwidth x) - 1)) =
    bitlen \<bar>mantissa f\<bar> + Float.exponent f + int (bias x) + int (fracwidth x) - 1"
    using exponent
    by simp
  also have "\<dots> \<le> fracwidth x"
    using mantissa
    by simp
  finally have "bitlen (\<bar>mantissa f\<bar> * 2 ^ nat (Float.exponent f + int (bias x) + int (fracwidth x) - 1)) \<le> fracwidth x"
    .
  from bitlen_leD[OF this]
  have 1: "nat (\<bar>mantissa f\<bar> * 2 ^ nat (Float.exponent f + int (bias x) + int (fracwidth x) - 1))
    < 2 ^ fracwidth x"
    by (auto simp: bitlen_def)

  have 2: "\<bar>mantissa f\<bar> * 2 ^ nat (Float.exponent f + int (bias x) + int (fracwidth x) - 1) > 0"
    using mnz
    by (auto simp: intro!: mult_pos_pos)

  have req: "real (nat (Float.exponent f + int (bias x) + int (fracwidth x) - 1)) =
        real_of_int (Float.exponent f) + real (bias x) + real (fracwidth x) - 1"
    using exponent by auto
  have not_le: "2 powr real_of_int (Float.exponent f) \<le> 0 \<longleftrightarrow> False"
    by (simp add: antisym_conv)
  show ?th2
    using 1
    by (auto simp: subnormal_rep_of_Float_def is_valid_def)
  show ?th3
    using 2
    by (auto simp: subnormal_rep_of_Float_def is_denormal_def)
  show ?th1
    by (auto simp: subnormal_rep_of_Float_def powr_realpow[symmetric] powr_add diff_add_eq req
        powr_diff is_float_nonneg_def zero_le_mult_iff not_le
        mantissa_exponent)
qed

definition float_rep_of_Float :: "format \<Rightarrow> Float.float \<Rightarrow> representation" where
  "float_rep_of_Float x f = (
    if is_float_zero f
    then (0,0,0)
    else
      let (m, e) = (mantissa f, exponent f)
      in
        if bitlen (abs m) + e \<le> 1 - int (bias x)
        then subnormal_rep_of_Float x f
        else normal_rep_of_Float x f
  )"

lemma is_valid_0: "is_valid x (0, 0, 0)"
  by (auto simp: is_valid_def)

lemma is_zero_0: "is_zero x (0, 0, 0)"
  by (auto simp: is_finite_def is_denormal_def is_normal_def is_valid_0 is_zero_def)

theorem float_rep_of_Float:
  "valof x (float_rep_of_Float x f) = real_of_float f"
  "is_valid x (float_rep_of_Float x f)"
  "is_finite x (float_rep_of_Float x f)"
  if "bitlen \<bar>mantissa f\<bar> \<le> int (fracwidth x)"
    "int (fracwidth x) - int (bias x) < Float.exponent f"
    "Float.exponent f < 2 ^ expwidth x - int (bias x) - int (fracwidth x)"
  using that
  by (auto simp: float_rep_of_Float_def is_float_zero_def is_finite_def is_zero_0
      intro!: subnormal_rep_of_Float_correct normal_rep_of_Float_correct is_valid_0)

section \<open>Lifting to Type @{type float}\<close>

definition "Float_of_IEEE x = Float_of_finite float_format (Rep_float x)"

theorem Float_of_IEEE: "real_of_float (Float_of_IEEE x) = Val x"
  by (auto simp: Float_of_IEEE_def Float_of_finite_correct Val_def)

definition "IEEE_of_Float x = Abs_float (float_rep_of_Float float_format x)"

lemma Finite_Abs_float_iff:
  "Finite (Abs_float x) \<longleftrightarrow> is_finite float_format x" if "is_valid float_format x"
  using that
  by (auto simp: Finite_def Isnormal_def Abs_float_inverse is_finite_def
      Isdenormal_def Iszero_def)

theorem IEEE_of_Float: "Val (IEEE_of_Float x) = real_of_float x"
  and IEEE_of_Float_Finite: "Finite (IEEE_of_Float x)"
  if "bitlen (abs (mantissa x)) \<le> 52" "- 971 < exponent x" "exponent x < 973"
  using that float_rep_of_Float[of x float_format]
  by (auto simp: Val_def IEEE_of_Float_def float_format_def bias_def Abs_float_inverse
      Finite_Abs_float_iff)

end


(*
  File:   Eval_Numeral.thy
  Author: Manuel Eberl <manuel@pruvisto.org>

  Evaluation of terms involving rational numerals with the simplifier.
*)
section \<open>Evaluating expressions with rational numerals\<close>
theory Eval_Numeral
imports
  Complex_Main
begin

lemma real_numeral_to_Ratreal:
  "(0::real) = Ratreal (Frct (0, 1))"
  "(1::real) = Ratreal (Frct (1, 1))"
  "(numeral x :: real) = Ratreal (Frct (numeral x, 1))"
  "(1::int) = numeral Num.One"
  by (simp_all add: rat_number_collapse)

lemma real_equals_code: "Ratreal x = Ratreal y \<longleftrightarrow> x = y"
  by simp

lemma Rat_normalize_idempotent: "Rat.normalize (Rat.normalize x) = Rat.normalize x"
apply (cases "Rat.normalize x")
using Rat.normalize_stable[OF normalize_denom_pos normalize_coprime] apply auto
done

lemma uminus_pow_Numeral1: "(-(x::_::monoid_mult)) ^ Numeral1 = -x" by simp

lemmas power_numeral_simps = power_0 uminus_pow_Numeral1 power_minus_Bit0 power_minus_Bit1

lemma Fract_normalize: "Fract (fst (Rat.normalize (x,y))) (snd (Rat.normalize (x,y))) = Fract x y"
  by (rule quotient_of_inject) (simp add: quotient_of_Fract Rat_normalize_idempotent)

lemma Frct_add: "Frct (a, numeral b) + Frct (c, numeral d) =
                   Frct (Rat.normalize (a * numeral d + c * numeral b, numeral (b*d)))"
  by (auto simp: rat_number_collapse Fract_normalize)

lemma Frct_uminus: "-(Frct (a,b)) = Frct (-a,b)" by simp

lemma Frct_diff: "Frct (a, numeral b) - Frct (c, numeral d) =
                    Frct (Rat.normalize (a * numeral d - c * numeral b, numeral (b*d)))"
  by (auto simp: rat_number_collapse Fract_normalize)

lemma Frct_mult: "Frct (a, numeral b) * Frct (c, numeral d) = Frct (a*c, numeral (b*d))"
  by simp

lemma Frct_inverse: "inverse (Frct (a, b)) = Frct (b, a)" by simp

lemma Frct_divide: "Frct (a, numeral b) / Frct (c, numeral d) = Frct (a*numeral d, numeral b * c)"
  by simp

lemma Frct_pow: "Frct (a, numeral b) ^ c = Frct (a ^ c, numeral b ^ c)"
  by (induction c) (simp_all add: rat_number_collapse)

lemma Frct_less: "Frct (a, numeral b) < Frct (c, numeral d) \<longleftrightarrow> a * numeral d < c * numeral b"
  by simp

lemma Frct_le: "Frct (a, numeral b) \<le> Frct (c, numeral d) \<longleftrightarrow> a * numeral d \<le> c * numeral b"
  by simp

lemma Frct_equals: "Frct (a, numeral b) = Frct (c, numeral d) \<longleftrightarrow> a * numeral d = c * numeral b"
apply (intro iffI antisym)
apply (subst Frct_le[symmetric], simp)+
apply (subst Frct_le, simp)+
done

lemma real_power_code: "(Ratreal x) ^ y = Ratreal (x ^ y)" by (simp add: of_rat_power)

lemmas real_arith_code =
  real_plus_code real_minus_code real_times_code real_uminus_code real_inverse_code
  real_divide_code real_power_code real_less_code real_less_eq_code real_equals_code

lemmas rat_arith_code =
  Frct_add Frct_uminus Frct_diff Frct_mult Frct_inverse Frct_divide Frct_pow
  Frct_less Frct_le Frct_equals

lemma gcd_numeral_red: "gcd (numeral x::int) (numeral y) = gcd (numeral y) (numeral x mod numeral y)"
  by (fact gcd_red_int)

lemma divmod_one:
  "divmod (Num.One) (Num.One) = (Numeral1, 0)"
  "divmod (Num.One) (Num.Bit0 x) = (0, Numeral1)"
  "divmod (Num.One) (Num.Bit1 x) = (0, Numeral1)"
  "divmod x (Num.One) = (numeral x, 0)"
  unfolding divmod_def by simp_all

lemmas divmod_numeral_simps =
  div_0 div_by_0 mod_0 mod_by_0
  fst_divmod [symmetric]
  snd_divmod [symmetric]
  divmod_cancel
  divmod_steps [simplified rel_simps if_True] divmod_trivial
  rel_simps

lemma Suc_0_to_numeral: "Suc 0 = Numeral1" by simp
lemmas Suc_to_numeral = Suc_0_to_numeral Num.Suc_1 Num.Suc_numeral

lemma rat_powr:
  "0 powr y = 0"
  "x > 0 \<Longrightarrow> x powr Ratreal (Frct (0, Numeral1)) = Ratreal (Frct (Numeral1, Numeral1))"
  "x > 0 \<Longrightarrow> x powr Ratreal (Frct (numeral a, Numeral1)) = x ^ numeral a"
  "x > 0 \<Longrightarrow> x powr Ratreal (Frct (-numeral a, Numeral1)) = inverse (x ^ numeral a)"
  by (simp_all add: rat_number_collapse powr_minus)

lemmas eval_numeral_simps =
  real_numeral_to_Ratreal real_arith_code rat_arith_code Num.arith_simps
  Rat.normalize_def fst_conv snd_conv gcd_0_int gcd_0_left_int gcd.bottom_right_bottom gcd.bottom_left_bottom
  gcd_neg1_int gcd_neg2_int gcd_numeral_red zmod_numeral_Bit0 zmod_numeral_Bit1 power_numeral_simps
  divmod_numeral_simps numeral_One [symmetric] Groups.Let_0 Num.Let_numeral Suc_to_numeral power_numeral
  greaterThanLessThan_iff atLeastAtMost_iff atLeastLessThan_iff greaterThanAtMost_iff rat_powr
  Num.pow.simps Num.sqr.simps Product_Type.split of_int_numeral of_int_neg_numeral of_nat_numeral

ML \<open>
signature EVAL_NUMERAL =
sig
  val eval_numeral_tac : Proof.context -> int -> tactic
end

structure Eval_Numeral : EVAL_NUMERAL =
struct

fun eval_numeral_tac ctxt =
  let
    val ctxt' = put_simpset HOL_ss ctxt addsimps @{thms eval_numeral_simps}
  in
    SELECT_GOAL (SOLVE (Simplifier.simp_tac ctxt' 1))
  end

end
\<close>

lemma "21254387548659589512*314213523632464357453884361*2342523623324234*564327438587241734743*
          12561712738645824362329316482973164398214286 powr 2 /
         (1130246312978423123+231212374631082764842731842*122474378389424362347451251263) >
        (12313244512931247243543279768645745929475829310651205623844::real)"
  by (tactic \<open>Eval_Numeral.eval_numeral_tac @{context} 1\<close>)

end


(*  Title:      ZF/Nat.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1994  University of Cambridge
*)

section\<open>The Natural numbers As a Least Fixed Point\<close>

theory Nat imports OrdQuant Bool begin

definition
  nat :: i  where
    "nat == lfp(Inf, %X. {0} \<union> {succ(i). i \<in> X})"

definition
  quasinat :: "i => o"  where
    "quasinat(n) == n=0 | (\<exists>m. n = succ(m))"

definition
  (*Has an unconditional succ case, which is used in "recursor" below.*)
  nat_case :: "[i, i=>i, i]=>i"  where
    "nat_case(a,b,k) == THE y. k=0 & y=a | (\<exists>x. k=succ(x) & y=b(x))"

definition
  nat_rec :: "[i, i, [i,i]=>i]=>i"  where
    "nat_rec(k,a,b) ==
          wfrec(Memrel(nat), k, %n f. nat_case(a, %m. b(m, f`m), n))"

  (*Internalized relations on the naturals*)

definition
  Le :: i  where
    "Le == {<x,y>:nat*nat. x \<le> y}"

definition
  Lt :: i  where
    "Lt == {<x, y>:nat*nat. x < y}"

definition
  Ge :: i  where
    "Ge == {<x,y>:nat*nat. y \<le> x}"

definition
  Gt :: i  where
    "Gt == {<x,y>:nat*nat. y < x}"

definition
  greater_than :: "i=>i"  where
    "greater_than(n) == {i \<in> nat. n < i}"

text\<open>No need for a less-than operator: a natural number is its list of
predecessors!\<close>

lemma nat_bnd_mono: "bnd_mono(Inf, %X. {0} \<union> {succ(i). i \<in> X})"
apply (rule bnd_monoI)
apply (cut_tac infinity, blast, blast)
done

(* @{term"nat = {0} \<union> {succ(x). x \<in> nat}"} *)
lemmas nat_unfold = nat_bnd_mono [THEN nat_def [THEN def_lfp_unfold]]

(** Type checking of 0 and successor **)

lemma nat_0I [iff,TC]: "0 \<in> nat"
apply (subst nat_unfold)
apply (rule singletonI [THEN UnI1])
done

lemma nat_succI [intro!,TC]: "n \<in> nat ==> succ(n) \<in> nat"
apply (subst nat_unfold)
apply (erule RepFunI [THEN UnI2])
done

lemma nat_1I [iff,TC]: "1 \<in> nat"
by (rule nat_0I [THEN nat_succI])

lemma nat_2I [iff,TC]: "2 \<in> nat"
by (rule nat_1I [THEN nat_succI])

lemma bool_subset_nat: "bool \<subseteq> nat"
by (blast elim!: boolE)

lemmas bool_into_nat = bool_subset_nat [THEN subsetD]

subsection\<open>Injectivity Properties and Induction\<close>

(*Mathematical induction*)
lemma nat_induct [case_names 0 succ, induct set: nat]:
    "[| n \<in> nat;  P(0);  !!x. [| x \<in> nat;  P(x) |] ==> P(succ(x)) |] ==> P(n)"
by (erule def_induct [OF nat_def nat_bnd_mono], blast)

lemma natE:
 assumes "n \<in> nat"
 obtains ("0") "n=0" | (succ) x where "x \<in> nat" "n=succ(x)"
using assms
by (rule nat_unfold [THEN equalityD1, THEN subsetD, THEN UnE]) auto

lemma nat_into_Ord [simp]: "n \<in> nat ==> Ord(n)"
by (erule nat_induct, auto)

(* @{term"i \<in> nat ==> 0 \<le> i"}; same thing as @{term"0<succ(i)"}  *)
lemmas nat_0_le = nat_into_Ord [THEN Ord_0_le]

(* @{term"i \<in> nat ==> i \<le> i"}; same thing as @{term"i<succ(i)"}  *)
lemmas nat_le_refl = nat_into_Ord [THEN le_refl]

lemma Ord_nat [iff]: "Ord(nat)"
apply (rule OrdI)
apply (erule_tac [2] nat_into_Ord [THEN Ord_is_Transset])
apply (unfold Transset_def)
apply (rule ballI)
apply (erule nat_induct, auto)
done

lemma Limit_nat [iff]: "Limit(nat)"
apply (unfold Limit_def)
apply (safe intro!: ltI Ord_nat)
apply (erule ltD)
done

lemma naturals_not_limit: "a \<in> nat ==> ~ Limit(a)"
by (induct a rule: nat_induct, auto)

lemma succ_natD: "succ(i): nat ==> i \<in> nat"
by (rule Ord_trans [OF succI1], auto)

lemma nat_succ_iff [iff]: "succ(n): nat \<longleftrightarrow> n \<in> nat"
by (blast dest!: succ_natD)

lemma nat_le_Limit: "Limit(i) ==> nat \<le> i"
apply (rule subset_imp_le)
apply (simp_all add: Limit_is_Ord)
apply (rule subsetI)
apply (erule nat_induct)
 apply (erule Limit_has_0 [THEN ltD])
apply (blast intro: Limit_has_succ [THEN ltD] ltI Limit_is_Ord)
done

(* [| succ(i): k;  k \<in> nat |] ==> i \<in> k *)
lemmas succ_in_naturalD = Ord_trans [OF succI1 _ nat_into_Ord]

lemma lt_nat_in_nat: "[| m<n;  n \<in> nat |] ==> m \<in> nat"
apply (erule ltE)
apply (erule Ord_trans, assumption, simp)
done

lemma le_in_nat: "[| m \<le> n; n \<in> nat |] ==> m \<in> nat"
by (blast dest!: lt_nat_in_nat)

subsection\<open>Variations on Mathematical Induction\<close>

(*complete induction*)

lemmas complete_induct = Ord_induct [OF _ Ord_nat, case_names less, consumes 1]

lemma complete_induct_rule [case_names less, consumes 1]:
  "i \<in> nat \<Longrightarrow> (\<And>x. x \<in> nat \<Longrightarrow> (\<And>y. y \<in> x \<Longrightarrow> P(y)) \<Longrightarrow> P(x)) \<Longrightarrow> P(i)"
  using complete_induct [of i P] by simp

(*Induction starting from m rather than 0*)
lemma nat_induct_from:
  assumes "m \<le> n" "m \<in> nat" "n \<in> nat"
    and "P(m)"
    and "!!x. [| x \<in> nat;  m \<le> x;  P(x) |] ==> P(succ(x))"
  shows "P(n)"
proof -
  from assms(3) have "m \<le> n \<longrightarrow> P(m) \<longrightarrow> P(n)"
    by (rule nat_induct) (use assms(5) in \<open>simp_all add: distrib_simps le_succ_iff\<close>)
  with assms(1,2,4) show ?thesis by blast
qed

(*Induction suitable for subtraction and less-than*)
lemma diff_induct [case_names 0 0_succ succ_succ, consumes 2]:
    "[| m \<in> nat;  n \<in> nat;
        !!x. x \<in> nat ==> P(x,0);
        !!y. y \<in> nat ==> P(0,succ(y));
        !!x y. [| x \<in> nat;  y \<in> nat;  P(x,y) |] ==> P(succ(x),succ(y)) |]
     ==> P(m,n)"
apply (erule_tac x = m in rev_bspec)
apply (erule nat_induct, simp)
apply (rule ballI)
apply (rename_tac i j)
apply (erule_tac n=j in nat_induct, auto)
done

(** Induction principle analogous to trancl_induct **)

lemma succ_lt_induct_lemma [rule_format]:
     "m \<in> nat ==> P(m,succ(m)) \<longrightarrow> (\<forall>x\<in>nat. P(m,x) \<longrightarrow> P(m,succ(x))) \<longrightarrow>
                 (\<forall>n\<in>nat. m<n \<longrightarrow> P(m,n))"
apply (erule nat_induct)
 apply (intro impI, rule nat_induct [THEN ballI])
   prefer 4 apply (intro impI, rule nat_induct [THEN ballI])
apply (auto simp add: le_iff)
done

lemma succ_lt_induct:
    "[| m<n;  n \<in> nat;
        P(m,succ(m));
        !!x. [| x \<in> nat;  P(m,x) |] ==> P(m,succ(x)) |]
     ==> P(m,n)"
by (blast intro: succ_lt_induct_lemma lt_nat_in_nat)

subsection\<open>quasinat: to allow a case-split rule for \<^term>\<open>nat_case\<close>\<close>

text\<open>True if the argument is zero or any successor\<close>

lemma [iff]: "quasinat(succ(x))"
by (simp add: quasinat_def)

lemma nat_imp_quasinat: "n \<in> nat ==> quasinat(n)"
by (erule natE, simp_all)

lemma non_nat_case: "~ quasinat(x) ==> nat_case(a,b,x) = 0"
by (simp add: quasinat_def nat_case_def)

lemma nat_cases_disj: "k=0 | (\<exists>y. k = succ(y)) | ~ quasinat(k)"
apply (case_tac "k=0", simp)
apply (case_tac "\<exists>m. k = succ(m)")
apply (simp_all add: quasinat_def)
done

lemma nat_cases:
     "[|k=0 ==> P;  !!y. k = succ(y) ==> P; ~ quasinat(k) ==> P|] ==> P"
by (insert nat_cases_disj [of k], blast)

(** nat_case **)

lemma nat_case_0 [simp]: "nat_case(a,b,0) = a"
by (simp add: nat_case_def)

lemma nat_case_succ [simp]: "nat_case(a,b,succ(n)) = b(n)"
by (simp add: nat_case_def)

lemma nat_case_type [TC]:
    "[| n \<in> nat;  a \<in> C(0);  !!m. m \<in> nat ==> b(m): C(succ(m)) |]
     ==> nat_case(a,b,n) \<in> C(n)"
by (erule nat_induct, auto)

lemma split_nat_case:
  "P(nat_case(a,b,k)) \<longleftrightarrow>
   ((k=0 \<longrightarrow> P(a)) & (\<forall>x. k=succ(x) \<longrightarrow> P(b(x))) & (~ quasinat(k) \<longrightarrow> P(0)))"
apply (rule nat_cases [of k])
apply (auto simp add: non_nat_case)
done

subsection\<open>Recursion on the Natural Numbers\<close>

(** nat_rec is used to define eclose and transrec, then becomes obsolete.
    The operator rec, from arith.thy, has fewer typing conditions **)

lemma nat_rec_0: "nat_rec(0,a,b) = a"
apply (rule nat_rec_def [THEN def_wfrec, THEN trans])
 apply (rule wf_Memrel)
apply (rule nat_case_0)
done

lemma nat_rec_succ: "m \<in> nat ==> nat_rec(succ(m),a,b) = b(m, nat_rec(m,a,b))"
apply (rule nat_rec_def [THEN def_wfrec, THEN trans])
 apply (rule wf_Memrel)
apply (simp add: vimage_singleton_iff)
done

(** The union of two natural numbers is a natural number -- their maximum **)

lemma Un_nat_type [TC]: "[| i \<in> nat; j \<in> nat |] ==> i \<union> j \<in> nat"
apply (rule Un_least_lt [THEN ltD])
apply (simp_all add: lt_def)
done

lemma Int_nat_type [TC]: "[| i \<in> nat; j \<in> nat |] ==> i \<inter> j \<in> nat"
apply (rule Int_greatest_lt [THEN ltD])
apply (simp_all add: lt_def)
done

(*needed to simplify unions over nat*)
lemma nat_nonempty [simp]: "nat \<noteq> 0"
by blast

text\<open>A natural number is the set of its predecessors\<close>
lemma nat_eq_Collect_lt: "i \<in> nat ==> {j\<in>nat. j<i} = i"
apply (rule equalityI)
apply (blast dest: ltD)
apply (auto simp add: Ord_mem_iff_lt)
apply (blast intro: lt_trans)
done

lemma Le_iff [iff]: "<x,y> \<in> Le \<longleftrightarrow> x \<le> y & x \<in> nat & y \<in> nat"
by (force simp add: Le_def)

end


section\<open>The Delta System Lemma\label{sec:dsl}\<close>

theory Delta_System
  imports
    Cardinal_Library

begin

text\<open>A \<^emph>\<open>delta system\<close> is family of sets with a common pairwise
intersection.\<close>

definition
  delta_system :: "i \<Rightarrow> o" where
  "delta_system(D) \<equiv> \<exists>r. \<forall>A\<in>D. \<forall>B\<in>D. A \<noteq> B \<longrightarrow> A \<inter> B = r"

lemma delta_systemI[intro]:
  assumes "\<forall>A\<in>D. \<forall>B\<in>D. A \<noteq> B \<longrightarrow> A \<inter> B = r"
  shows "delta_system(D)"
  using assms unfolding delta_system_def by simp

lemma delta_systemD[dest]:
  "delta_system(D) \<Longrightarrow> \<exists>r. \<forall>A\<in>D. \<forall>B\<in>D. A \<noteq> B \<longrightarrow> A \<inter> B = r"
  unfolding delta_system_def by simp

text\<open>Hence, pairwise intersections equal the intersection of the whole
family.\<close>

lemma delta_system_root_eq_Inter:
  assumes "delta_system(D)"
  shows "\<forall>A\<in>D. \<forall>B\<in>D. A \<noteq> B \<longrightarrow> A \<inter> B = \<Inter>D"
proof (clarify, intro equalityI, auto)
  fix A' B' x C
  assume hyp:"A'\<in>D" "B'\<in> D" "A'\<noteq>B'" "x\<in>A'" "x\<in>B'" "C\<in>D"
  with assms
  obtain r where delta:"\<forall>A\<in>D. \<forall>B\<in>D. A \<noteq> B \<longrightarrow> A \<inter> B = r"
    by auto
  show "x \<in> C"
  proof (cases "C=A'")
    case True
    with hyp and assms
    show ?thesis by simp
  next
    case False
    moreover
    note hyp
    moreover from calculation and delta
    have "r = C \<inter> A'" "A' \<inter> B' = r" "x\<in>r" by auto
    ultimately
    show ?thesis by simp
  qed
qed

text\<open>The \<^emph>\<open>Delta System Lemma\<close> (DSL) states that any uncountable family of
finite sets includes an uncountable delta system. This is the simplest
non trivial version; others, for cardinals greater than \<^term>\<open>\<aleph>\<^bsub>1\<^esub>\<close>  assume
some weak versions of the generalized continuum hypothesis for the
cardinals involved.

The proof is essentially the one in \cite[III.2.6]{kunen2011set} for the
case  \<^term>\<open>\<aleph>\<^bsub>1\<^esub>\<close>; another similar presentation can be found in
\cite[Chap.~16]{JW}.\<close>

lemma delta_system_Aleph1:
  assumes "\<forall>A\<in>F. Finite(A)" "F \<approx> \<aleph>\<^bsub>1\<^esub>"
  shows "\<exists>D. D \<subseteq> F \<and> delta_system(D) \<and> D \<approx> \<aleph>\<^bsub>1\<^esub>"
proof -
  text\<open>Since all members are finite,\<close>
  from \<open>\<forall>A\<in>F. Finite(A)\<close>
  have "(\<lambda>A\<in>F. |A|) : F \<rightarrow> \<omega>" (is "?cards : _")
    by (rule_tac lam_type) simp
  moreover from this
  have a:"?cards -`` {n} = { A\<in>F . |A| = n }" for n
    using vimage_lam by auto
  moreover
  note \<open>F \<approx> \<aleph>\<^bsub>1\<^esub>\<close>
  moreover from calculation
  text\<open>there are uncountably many have the same cardinal:\<close>
  obtain n where "n\<in>\<omega>" "|?cards -`` {n}| = \<aleph>\<^bsub>1\<^esub>"
    using eqpoll_Aleph1_cardinal_vimage[of F ?cards] by auto
  moreover
  define G where "G \<equiv> ?cards -`` {n}"
  moreover from calculation
  have "G \<subseteq> F" by auto
  ultimately
  text\<open>Therefore, without loss of generality, we can assume that all
  elements of the family have cardinality \<^term>\<open>n\<in>\<omega>\<close>.\<close>
  have "A\<in>G \<Longrightarrow> |A| = n" and "G \<approx> \<aleph>\<^bsub>1\<^esub>" for A
    using cardinal_Card_eqpoll_iff by auto
  with \<open>n\<in>\<omega>\<close>
  text\<open>So we prove the result by induction on this \<^term>\<open>n\<close> and
  generalizing \<^term>\<open>G\<close>, since the argument requires changing the
  family in order to apply the inductive hypothesis.\<close>
  have "\<exists>D. D \<subseteq> G \<and> delta_system(D) \<and> D \<approx> \<aleph>\<^bsub>1\<^esub>"
  proof (induct arbitrary:G)
    case 0 \<comment> \<open>This case is impossible\<close>
    then
    have "G \<subseteq> {0}"
      using cardinal_0_iff_0 by auto
    with \<open>G \<approx> \<aleph>\<^bsub>1\<^esub>\<close>
    show ?case
      using nat_lt_Aleph1 subset_imp_le_cardinal[of G "{0}"]
        lt_trans2 cardinal_Card_eqpoll_iff by auto
  next
    case (succ n)
    then
    have "\<forall>a\<in>G. Finite(a)"
      using Finite_cardinal_iff' nat_into_Finite[of "succ(n)"]
      by fastforce
    show "\<exists>D. D \<subseteq> G \<and> delta_system(D) \<and> D \<approx> \<aleph>\<^bsub>1\<^esub>"
    proof (cases "\<exists>p. {A\<in>G . p \<in> A} \<approx> \<aleph>\<^bsub>1\<^esub>")
      case True \<comment> \<open>the positive case, uncountably many sets with a
                    common element\<close>
      then
      obtain p where "{A\<in>G . p \<in> A} \<approx> \<aleph>\<^bsub>1\<^esub>" by blast
      moreover from this
      have "{A-{p} . A\<in>{X\<in>G. p\<in>X}} \<approx> \<aleph>\<^bsub>1\<^esub>" (is "?F \<approx> _")
        using Diff_bij[of "{A\<in>G . p \<in> A}" "{p}"]
          comp_bij[OF bij_converse_bij, where C="\<aleph>\<^bsub>1\<^esub>"] by fast
      text\<open>Now using the hypothesis of the successor case,\<close>
      moreover from \<open>\<And>A. A\<in>G \<Longrightarrow> |A|=succ(n)\<close> \<open>\<forall>a\<in>G. Finite(a)\<close>
        and this
      have "p\<in>A \<Longrightarrow> A\<in>G \<Longrightarrow> |A - {p}| = n" for A
        using Finite_imp_succ_cardinal_Diff[of _ p] by force
      moreover from this and \<open>n\<in>\<omega>\<close>
      have "\<forall>a\<in>?F. Finite(a)"
        using Finite_cardinal_iff' nat_into_Finite by auto
      moreover
      text\<open>we may apply the inductive hypothesis to the new family \<^term>\<open>?F\<close>:\<close>
      note \<open>(\<And>A. A \<in> ?F \<Longrightarrow> |A| = n) \<Longrightarrow> ?F \<approx> \<aleph>\<^bsub>1\<^esub> \<Longrightarrow>
             \<exists>D. D \<subseteq> ?F \<and> delta_system(D) \<and> D \<approx> \<aleph>\<^bsub>1\<^esub>\<close>
      ultimately
      obtain D where "D\<subseteq>{A-{p} . A\<in>{X\<in>G. p\<in>X}}" "delta_system(D)" "D \<approx> \<aleph>\<^bsub>1\<^esub>"
        by auto
      moreover from this
      obtain r where "\<forall>A\<in>D. \<forall>B\<in>D. A \<noteq> B \<longrightarrow> A \<inter> B = r"
        by fastforce
      then
      have "\<forall>A\<in>D.\<forall>B\<in>D. A\<union>{p} \<noteq> B\<union>{p}\<longrightarrow>(A \<union> {p}) \<inter> (B \<union> {p}) = r\<union>{p}"
        by blast
      ultimately
      have "delta_system({B \<union> {p} . B\<in>D})" (is "delta_system(?D)")
        by fastforce
      moreover from \<open>D \<approx> \<aleph>\<^bsub>1\<^esub>\<close>
      have "|D| = \<aleph>\<^bsub>1\<^esub>" "Infinite(D)"
        using cardinal_eqpoll_iff
        by (auto intro!: uncountable_iff_subset_eqpoll_Aleph1[THEN iffD2]
            uncountable_imp_Infinite) force
      moreover from this
      have "?D \<approx> \<aleph>\<^bsub>1\<^esub>"
        using cardinal_map_Un[of D "{p}"] naturals_lt_nat
          cardinal_eqpoll_iff[THEN iffD1] by simp
      moreover
      note \<open>D \<subseteq> {A-{p} . A\<in>{X\<in>G. p\<in>X}}\<close>
      have "?D \<subseteq> G"
      proof -
        {
          fix A
          assume "A\<in>G" "p\<in>A"
          moreover from this
          have "A = A - {p} \<union> {p}"
            by blast
          ultimately
          have "A -{p} \<union> {p} \<in> G"
            by auto
        }
        with \<open>D \<subseteq> {A-{p} . A\<in>{X\<in>G. p\<in>X}}\<close>
        show ?thesis
          by blast
      qed
      ultimately
      show "\<exists>D. D \<subseteq> G \<and> delta_system(D) \<and> D \<approx> \<aleph>\<^bsub>1\<^esub>" by auto
    next
      case False
      note \<open>\<not> (\<exists>p. {A \<in> G . p \<in> A} \<approx> \<aleph>\<^bsub>1\<^esub>)\<close> \<comment> \<open>the other case\<close>
      moreover from \<open>G \<approx> \<aleph>\<^bsub>1\<^esub>\<close>
      have "{A \<in> G . p \<in> A} \<lesssim> \<aleph>\<^bsub>1\<^esub>" (is "?G(p) \<lesssim> _") for p
        by (blast intro:lepoll_eq_trans[OF subset_imp_lepoll])
      ultimately
      have "?G(p) \<prec> \<aleph>\<^bsub>1\<^esub>" for p
        unfolding lesspoll_def by simp
      then (* may omit the previous step if unfolding here: *)
      have "?G(p) \<lesssim> \<omega>" for p
        using lesspoll_aleph_plus_one[of 0] Aleph_zero_eq_nat by auto
      moreover
      have "{A \<in> G . S \<inter> A \<noteq> 0} = (\<Union>p\<in>S. ?G(p))" for S
        by auto
      ultimately
      have "countable(S) \<Longrightarrow> countable({A \<in> G . S \<inter> A \<noteq> 0})" for S
        using InfCard_nat Card_nat
         le_Card_iff[THEN iffD2, THEN [3] leqpoll_imp_cardinal_UN_le,
           THEN [2] le_Card_iff[THEN iffD1], of \<omega> S]
        unfolding countable_def by simp
      text\<open>For every countable subfamily of \<^term>\<open>G\<close> there is another some
      element disjoint from all of them:\<close>
      have "\<exists>A\<in>G. \<forall>S\<in>X. S \<inter> A = 0" if "|X| < \<aleph>\<^bsub>1\<^esub>" "X \<subseteq> G" for X
      proof -
        from \<open>n\<in>\<omega>\<close> \<open>\<And>A. A\<in>G \<Longrightarrow> |A| = succ(n)\<close>
        have "A\<in>G \<Longrightarrow> Finite(A)" for A
          using cardinal_Card_eqpoll_iff
          unfolding Finite_def by fastforce
        with \<open>X\<subseteq>G\<close>
        have "A\<in>X \<Longrightarrow> countable(A)" for A
          using Finite_imp_countable by auto
        with \<open>|X| < \<aleph>\<^bsub>1\<^esub>\<close>
        have "countable(\<Union>X)"
          using Card_nat[THEN cardinal_lt_csucc_iff, of X]
            countable_union_countable countable_iff_cardinal_le_nat
          unfolding Aleph_def by simp
        with \<open>countable(_) \<Longrightarrow> countable({A \<in> G . _  \<inter> A \<noteq> 0})\<close>
        have "countable({A \<in> G . (\<Union>X) \<inter> A \<noteq> 0})" .
        with \<open>G \<approx> \<aleph>\<^bsub>1\<^esub>\<close>
        obtain B where "B\<in>G" "B \<notin> {A \<in> G . (\<Union>X) \<inter> A \<noteq> 0}"
          using nat_lt_Aleph1 cardinal_Card_eqpoll_iff[of "\<aleph>\<^bsub>1\<^esub>" G]
            uncountable_not_subset_countable[of "{A \<in> G . (\<Union>X) \<inter> A \<noteq> 0}" G]
            uncountable_iff_nat_lt_cardinal
          by auto
        then
        show "\<exists>A\<in>G. \<forall>S\<in>X. S \<inter> A = 0" by auto
      qed
      moreover from \<open>G \<approx> \<aleph>\<^bsub>1\<^esub>\<close>
      obtain b where "b\<in>G"
        using uncountable_iff_subset_eqpoll_Aleph1
          uncountable_not_empty by blast
      ultimately
      text\<open>Hence, the hypotheses to perform a bounded-cardinal selection
      are satisfied,\<close>
      obtain S where "S:\<aleph>\<^bsub>1\<^esub>\<rightarrow>G" "\<alpha>\<in>\<aleph>\<^bsub>1\<^esub> \<Longrightarrow> \<beta>\<in>\<aleph>\<^bsub>1\<^esub> \<Longrightarrow> \<alpha><\<beta> \<Longrightarrow> S`\<alpha> \<inter> S`\<beta> = 0"
        for \<alpha> \<beta>
        using bounded_cardinal_selection[of "\<aleph>\<^bsub>1\<^esub>" G "\<lambda>s a. s \<inter> a = 0" b]
        by force
      then
      have "\<alpha> \<in> \<aleph>\<^bsub>1\<^esub> \<Longrightarrow> \<beta> \<in> \<aleph>\<^bsub>1\<^esub> \<Longrightarrow> \<alpha>\<noteq>\<beta> \<Longrightarrow> S`\<alpha> \<inter> S`\<beta> = 0" for \<alpha> \<beta>
        using lt_neq_symmetry[of "\<aleph>\<^bsub>1\<^esub>" "\<lambda>\<alpha> \<beta>. S`\<alpha> \<inter> S`\<beta> = 0"] Card_is_Ord
        by auto blast
      text\<open>and a symmetry argument shows that obtained \<^term>\<open>S\<close> is
      an injective  \<^term>\<open>\<aleph>\<^bsub>1\<^esub>\<close>-sequence of disjoint elements of \<^term>\<open>G\<close>.\<close>
      moreover from this and \<open>\<And>A. A\<in>G \<Longrightarrow> |A| = succ(n)\<close> \<open>S : \<aleph>\<^bsub>1\<^esub> \<rightarrow> G\<close>
      have "S \<in> inj(\<aleph>\<^bsub>1\<^esub>, G)"
        using cardinal_succ_not_0 Int_eq_zero_imp_not_eq[of "\<aleph>\<^bsub>1\<^esub>" "\<lambda>x. S`x"]
        unfolding inj_def by fastforce
      moreover from calculation
      have "range(S) \<approx> \<aleph>\<^bsub>1\<^esub>"
        using inj_bij_range eqpoll_sym unfolding eqpoll_def by fast
      moreover from calculation
      have "range(S) \<subseteq> G"
        using inj_is_fun range_fun_subset_codomain by fast
      ultimately
      show "\<exists>D. D \<subseteq> G \<and> delta_system(D) \<and> D \<approx> \<aleph>\<^bsub>1\<^esub>"
        using inj_is_fun range_eq_image[of S "\<aleph>\<^bsub>1\<^esub>" G]
          image_function[OF fun_is_function, OF inj_is_fun, of S "\<aleph>\<^bsub>1\<^esub>" G]
          domain_of_fun[OF inj_is_fun, of S "\<aleph>\<^bsub>1\<^esub>" G]
        by (rule_tac x="S``\<aleph>\<^bsub>1\<^esub>" in exI) auto
      text\<open>This finishes the successor case and hence the proof.\<close>
    qed
  qed
  with \<open>G \<subseteq> F\<close>
  show ?thesis by blast
qed

lemma delta_system_uncountable:
  assumes "\<forall>A\<in>F. Finite(A)" "uncountable(F)"
  shows "\<exists>D. D \<subseteq> F \<and> delta_system(D) \<and> D \<approx> \<aleph>\<^bsub>1\<^esub>"
proof -
  from assms
  obtain S where "S \<subseteq> F" "S \<approx> \<aleph>\<^bsub>1\<^esub>"
    using uncountable_iff_subset_eqpoll_Aleph1[of F] by auto
  moreover from \<open>\<forall>A\<in>F. Finite(A)\<close> and this
  have "\<forall>A\<in>S. Finite(A)" by auto
  ultimately
  show ?thesis using delta_system_Aleph1[of S]
    by auto
qed

end


theory Base
  imports Main
begin

section {* Preliminaries *}

record 'a partial_object =
  carrier :: "'a set"

text {* From \texttt{HOL/SenSocialChoice/FSect.thy} in AFP. By Peter Gammie *}
lemma finite_subset_induct_var [consumes 2, case_names empty insert]:
  assumes "finite F" and "F \<subseteq> A"
    and empty: "P {}"
    and insert: "\<And>a F. \<lbrakk>finite F; a \<in> A; F \<subseteq> A; a \<notin> F; P F\<rbrakk> \<Longrightarrow> P (insert a F)"
  shows "P F"
proof -
  from `finite F`
  have "F \<subseteq> A \<Longrightarrow> ?thesis"
  proof induct
    show "P {}" by fact
  next
    fix x F
    assume "finite F" and "x \<notin> F" and
      P: "F \<subseteq> A \<Longrightarrow> P F" and i: "insert x F \<subseteq> A"
    show "P (insert x F)"
    proof (rule insert)
      from i show "x \<in> A" by blast
      from i have "F \<subseteq> A" by blast
      with P show "P F" .
      show "finite F" by fact
      show "x \<notin> F" by fact
      show "F \<subseteq> A" by fact
    qed
  qed
  with `F \<subseteq> A` show ?thesis by blast
qed

text {* To talk about functions between structures with carrier sets,
we need some notion of a function's \emph {type}. *}

definition ftype :: "'a set \<Rightarrow> 'b set \<Rightarrow> ('a \<Rightarrow> 'b) set" (infixr "\<rightarrow>" 60) where
  "ftype A B \<equiv> {f. \<forall>x. x \<in> A \<longrightarrow> f x \<in> B}"

text {* We could also define \emph{ftype} as a predicate rather than
as a set. *}

lemma ftype_pred: "(f \<in> A \<rightarrow> B) = (\<forall>x. x \<in> A \<longrightarrow> f x \<in> B)"
  by (simp add: ftype_def)

text {* Typing rules for composition and application can then be
derived, as well as the type of the identity function. *}

lemma typed_composition: "\<lbrakk>f \<in> A \<rightarrow> B; g \<in> B \<rightarrow> C\<rbrakk> \<Longrightarrow> g \<circ> f \<in> A \<rightarrow> C"
  by (simp add: ftype_def)

lemma typed_application: "\<lbrakk>x \<in> A; f \<in> A \<rightarrow> B\<rbrakk> \<Longrightarrow> f x \<in> B"
  by (simp add: ftype_def)

lemma typed_abstraction: "\<forall>x. f x \<in> A \<Longrightarrow> f \<in> UNIV \<rightarrow> A"
  by (simp add: ftype_def)

lemma typed_mapping: "\<lbrakk>f \<in> A \<rightarrow> B; X \<subseteq> A\<rbrakk> \<Longrightarrow> f ` X \<subseteq> B"
  by (metis ftype_pred image_subsetI set_mp)

lemma id_type: "id \<in> A \<rightarrow> A"
  by (simp add: ftype_def)

end