(*  Title:      HOL/Quotient.thy
    Author:     Cezary Kaliszyk and Christian Urban
*)

section \<open>Definition of Quotient Types\<close>

theory Quotient
imports Lifting
keywords
  "print_quotmapsQ3" "print_quotientsQ3" "print_quotconsts" :: diag and
  "quotient_type" :: thy_goal and "/" and
  "quotient_definition" :: thy_goal
begin

text \<open>
  Basic definition for equivalence relations
  that are represented by predicates.
\<close>

text \<open>Composition of Relations\<close>

abbreviation
  rel_conj :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> bool" (infixr "OOO" 75)
where
  "r1 OOO r2 \<equiv> r1 OO r2 OO r1"

lemma eq_comp_r:
  shows "((op =) OOO R) = R"
  by (auto simp add: fun_eq_iff)

context includes lifting_syntax
begin

subsection \<open>Quotient Predicate\<close>

definition
  "Quotient3 R Abs Rep \<longleftrightarrow>
     (\<forall>a. Abs (Rep a) = a) \<and> (\<forall>a. R (Rep a) (Rep a)) \<and>
     (\<forall>r s. R r s \<longleftrightarrow> R r r \<and> R s s \<and> Abs r = Abs s)"

lemma Quotient3I:
  assumes "\<And>a. Abs (Rep a) = a"
    and "\<And>a. R (Rep a) (Rep a)"
    and "\<And>r s. R r s \<longleftrightarrow> R r r \<and> R s s \<and> Abs r = Abs s"
  shows "Quotient3 R Abs Rep"
  using assms unfolding Quotient3_def by blast

context
  fixes R Abs Rep
  assumes a: "Quotient3 R Abs Rep"
begin

lemma Quotient3_abs_rep:
  "Abs (Rep a) = a"
  using a
  unfolding Quotient3_def
  by simp

lemma Quotient3_rep_reflp:
  "R (Rep a) (Rep a)"
  using a
  unfolding Quotient3_def
  by blast

lemma Quotient3_rel:
  "R r r \<and> R s s \<and> Abs r = Abs s \<longleftrightarrow> R r s" \<comment> \<open>orientation does not loop on rewriting\<close>
  using a
  unfolding Quotient3_def
  by blast

lemma Quotient3_refl1:
  "R r s \<Longrightarrow> R r r"
  using a unfolding Quotient3_def
  by fast

lemma Quotient3_refl2:
  "R r s \<Longrightarrow> R s s"
  using a unfolding Quotient3_def
  by fast

lemma Quotient3_rel_rep:
  "R (Rep a) (Rep b) \<longleftrightarrow> a = b"
  using a
  unfolding Quotient3_def
  by metis

lemma Quotient3_rep_abs:
  "R r r \<Longrightarrow> R (Rep (Abs r)) r"
  using a unfolding Quotient3_def
  by blast

lemma Quotient3_rel_abs:
  "R r s \<Longrightarrow> Abs r = Abs s"
  using a unfolding Quotient3_def
  by blast

lemma Quotient3_symp:
  "symp R"
  using a unfolding Quotient3_def using sympI by metis

lemma Quotient3_transp:
  "transp R"
  using a unfolding Quotient3_def using transpI by (metis (full_types))

lemma Quotient3_part_equivp:
  "part_equivp R"
  by (metis Quotient3_rep_reflp Quotient3_symp Quotient3_transp part_equivpI)

lemma abs_o_rep:
  "Abs o Rep = id"
  unfolding fun_eq_iff
  by (simp add: Quotient3_abs_rep)

lemma equals_rsp:
  assumes b: "R xa xb" "R ya yb"
  shows "R xa ya = R xb yb"
  using b Quotient3_symp Quotient3_transp
  by (blast elim: sympE transpE)

lemma rep_abs_rsp:
  assumes b: "R x1 x2"
  shows "R x1 (Rep (Abs x2))"
  using b Quotient3_rel Quotient3_abs_rep Quotient3_rep_reflp
  by metis

lemma rep_abs_rsp_left:
  assumes b: "R x1 x2"
  shows "R (Rep (Abs x1)) x2"
  using b Quotient3_rel Quotient3_abs_rep Quotient3_rep_reflp
  by metis

end

lemma identity_quotient3:
  "Quotient3 (op =) id id"
  unfolding Quotient3_def id_def
  by blast

lemma fun_quotient3:
  assumes q1: "Quotient3 R1 abs1 rep1"
  and     q2: "Quotient3 R2 abs2 rep2"
  shows "Quotient3 (R1 ===> R2) (rep1 ---> abs2) (abs1 ---> rep2)"
proof -
  have "\<And>a.(rep1 ---> abs2) ((abs1 ---> rep2) a) = a"
    using q1 q2 by (simp add: Quotient3_def fun_eq_iff)
  moreover
  have "\<And>a.(R1 ===> R2) ((abs1 ---> rep2) a) ((abs1 ---> rep2) a)"
    by (rule rel_funI)
      (insert q1 q2 Quotient3_rel_abs [of R1 abs1 rep1] Quotient3_rel_rep [of R2 abs2 rep2],
        simp (no_asm) add: Quotient3_def, simp)

  moreover
  {
  fix r s
  have "(R1 ===> R2) r s = ((R1 ===> R2) r r \<and> (R1 ===> R2) s s \<and>
        (rep1 ---> abs2) r  = (rep1 ---> abs2) s)"
  proof -

    have "(R1 ===> R2) r s \<Longrightarrow> (R1 ===> R2) r r" unfolding rel_fun_def
      using Quotient3_part_equivp[OF q1] Quotient3_part_equivp[OF q2]
      by (metis (full_types) part_equivp_def)
    moreover have "(R1 ===> R2) r s \<Longrightarrow> (R1 ===> R2) s s" unfolding rel_fun_def
      using Quotient3_part_equivp[OF q1] Quotient3_part_equivp[OF q2]
      by (metis (full_types) part_equivp_def)
    moreover have "(R1 ===> R2) r s \<Longrightarrow> (rep1 ---> abs2) r  = (rep1 ---> abs2) s"
      apply(auto simp add: rel_fun_def fun_eq_iff) using q1 q2 unfolding Quotient3_def by metis
    moreover have "((R1 ===> R2) r r \<and> (R1 ===> R2) s s \<and>
        (rep1 ---> abs2) r  = (rep1 ---> abs2) s) \<Longrightarrow> (R1 ===> R2) r s"
      apply(auto simp add: rel_fun_def fun_eq_iff) using q1 q2 unfolding Quotient3_def
    by (metis map_fun_apply)

    ultimately show ?thesis by blast
 qed
 }
 ultimately show ?thesis by (intro Quotient3I) (assumption+)
qed

lemma lambda_prs:
  assumes q1: "Quotient3 R1 Abs1 Rep1"
  and     q2: "Quotient3 R2 Abs2 Rep2"
  shows "(Rep1 ---> Abs2) (\<lambda>x. Rep2 (f (Abs1 x))) = (\<lambda>x. f x)"
  unfolding fun_eq_iff
  using Quotient3_abs_rep[OF q1] Quotient3_abs_rep[OF q2]
  by simp

lemma lambda_prs1:
  assumes q1: "Quotient3 R1 Abs1 Rep1"
  and     q2: "Quotient3 R2 Abs2 Rep2"
  shows "(Rep1 ---> Abs2) (\<lambda>x. (Abs1 ---> Rep2) f x) = (\<lambda>x. f x)"
  unfolding fun_eq_iff
  using Quotient3_abs_rep[OF q1] Quotient3_abs_rep[OF q2]
  by simp

text\<open>
  In the following theorem R1 can be instantiated with anything,
  but we know some of the types of the Rep and Abs functions;
  so by solving Quotient assumptions we can get a unique R1 that
  will be provable; which is why we need to use \<open>apply_rsp\<close> and
  not the primed version\<close>

lemma apply_rspQ3:
  fixes f g::"'a \<Rightarrow> 'c"
  assumes q: "Quotient3 R1 Abs1 Rep1"
  and     a: "(R1 ===> R2) f g" "R1 x y"
  shows "R2 (f x) (g y)"
  using a by (auto elim: rel_funE)

lemma apply_rspQ3'':
  assumes "Quotient3 R Abs Rep"
  and "(R ===> S) f f"
  shows "S (f (Rep x)) (f (Rep x))"
proof -
  from assms(1) have "R (Rep x) (Rep x)" by (rule Quotient3_rep_reflp)
  then show ?thesis using assms(2) by (auto intro: apply_rsp')
qed

subsection \<open>lemmas for regularisation of ball and bex\<close>

lemma ball_reg_eqv:
  fixes P :: "'a \<Rightarrow> bool"
  assumes a: "equivp R"
  shows "Ball (Respects R) P = (All P)"
  using a
  unfolding equivp_def
  by (auto simp add: in_respects)

lemma bex_reg_eqv:
  fixes P :: "'a \<Rightarrow> bool"
  assumes a: "equivp R"
  shows "Bex (Respects R) P = (Ex P)"
  using a
  unfolding equivp_def
  by (auto simp add: in_respects)

lemma ball_reg_right:
  assumes a: "\<And>x. x \<in> R \<Longrightarrow> P x \<longrightarrow> Q x"
  shows "All P \<longrightarrow> Ball R Q"
  using a by fast

lemma bex_reg_left:
  assumes a: "\<And>x. x \<in> R \<Longrightarrow> Q x \<longrightarrow> P x"
  shows "Bex R Q \<longrightarrow> Ex P"
  using a by fast

lemma ball_reg_left:
  assumes a: "equivp R"
  shows "(\<And>x. (Q x \<longrightarrow> P x)) \<Longrightarrow> Ball (Respects R) Q \<longrightarrow> All P"
  using a by (metis equivp_reflp in_respects)

lemma bex_reg_right:
  assumes a: "equivp R"
  shows "(\<And>x. (Q x \<longrightarrow> P x)) \<Longrightarrow> Ex Q \<longrightarrow> Bex (Respects R) P"
  using a by (metis equivp_reflp in_respects)

lemma ball_reg_eqv_range:
  fixes P::"'a \<Rightarrow> bool"
  and x::"'a"
  assumes a: "equivp R2"
  shows   "(Ball (Respects (R1 ===> R2)) (\<lambda>f. P (f x)) = All (\<lambda>f. P (f x)))"
  apply(rule iffI)
  apply(rule allI)
  apply(drule_tac x="\<lambda>y. f x" in bspec)
  apply(simp add: in_respects rel_fun_def)
  apply(rule impI)
  using a equivp_reflp_symp_transp[of "R2"]
  apply (auto elim: equivpE reflpE)
  done

lemma bex_reg_eqv_range:
  assumes a: "equivp R2"
  shows   "(Bex (Respects (R1 ===> R2)) (\<lambda>f. P (f x)) = Ex (\<lambda>f. P (f x)))"
  apply(auto)
  apply(rule_tac x="\<lambda>y. f x" in bexI)
  apply(simp)
  apply(simp add: Respects_def in_respects rel_fun_def)
  apply(rule impI)
  using a equivp_reflp_symp_transp[of "R2"]
  apply (auto elim: equivpE reflpE)
  done

(* Next four lemmas are unused *)
lemma all_reg:
  assumes a: "!x :: 'a. (P x --> Q x)"
  and     b: "All P"
  shows "All Q"
  using a b by fast

lemma ex_reg:
  assumes a: "!x :: 'a. (P x --> Q x)"
  and     b: "Ex P"
  shows "Ex Q"
  using a b by fast

lemma ball_reg:
  assumes a: "!x :: 'a. (x \<in> R --> P x --> Q x)"
  and     b: "Ball R P"
  shows "Ball R Q"
  using a b by fast

lemma bex_reg:
  assumes a: "!x :: 'a. (x \<in> R --> P x --> Q x)"
  and     b: "Bex R P"
  shows "Bex R Q"
  using a b by fast

lemma ball_all_comm:
  assumes "\<And>y. (\<forall>x\<in>P. A x y) \<longrightarrow> (\<forall>x. B x y)"
  shows "(\<forall>x\<in>P. \<forall>y. A x y) \<longrightarrow> (\<forall>x. \<forall>y. B x y)"
  using assms by auto

lemma bex_ex_comm:
  assumes "(\<exists>y. \<exists>x. A x y) \<longrightarrow> (\<exists>y. \<exists>x\<in>P. B x y)"
  shows "(\<exists>x. \<exists>y. A x y) \<longrightarrow> (\<exists>x\<in>P. \<exists>y. B x y)"
  using assms by auto

subsection \<open>Bounded abstraction\<close>

definition
  Babs :: "'a set \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b"
where
  "x \<in> p \<Longrightarrow> Babs p m x = m x"

lemma babs_rsp:
  assumes q: "Quotient3 R1 Abs1 Rep1"
  and     a: "(R1 ===> R2) f g"
  shows      "(R1 ===> R2) (Babs (Respects R1) f) (Babs (Respects R1) g)"
  apply (auto simp add: Babs_def in_respects rel_fun_def)
  apply (subgoal_tac "x \<in> Respects R1 \<and> y \<in> Respects R1")
  using a apply (simp add: Babs_def rel_fun_def)
  apply (simp add: in_respects rel_fun_def)
  using Quotient3_rel[OF q]
  by metis

lemma babs_prs:
  assumes q1: "Quotient3 R1 Abs1 Rep1"
  and     q2: "Quotient3 R2 Abs2 Rep2"
  shows "((Rep1 ---> Abs2) (Babs (Respects R1) ((Abs1 ---> Rep2) f))) = f"
  apply (rule ext)
  apply (simp add:)
  apply (subgoal_tac "Rep1 x \<in> Respects R1")
  apply (simp add: Babs_def Quotient3_abs_rep[OF q1] Quotient3_abs_rep[OF q2])
  apply (simp add: in_respects Quotient3_rel_rep[OF q1])
  done

lemma babs_simp:
  assumes q: "Quotient3 R1 Abs Rep"
  shows "((R1 ===> R2) (Babs (Respects R1) f) (Babs (Respects R1) g)) = ((R1 ===> R2) f g)"
  apply(rule iffI)
  apply(simp_all only: babs_rsp[OF q])
  apply(auto simp add: Babs_def rel_fun_def)
  apply (subgoal_tac "x \<in> Respects R1 \<and> y \<in> Respects R1")
  apply(metis Babs_def)
  apply (simp add: in_respects)
  using Quotient3_rel[OF q]
  by metis

(* If a user proves that a particular functional relation
   is an equivalence this may be useful in regularising *)
lemma babs_reg_eqv:
  shows "equivp R \<Longrightarrow> Babs (Respects R) P = P"
  by (simp add: fun_eq_iff Babs_def in_respects equivp_reflp)

(* 3 lemmas needed for proving repabs_inj *)
lemma ball_rsp:
  assumes a: "(R ===> (op =)) f g"
  shows "Ball (Respects R) f = Ball (Respects R) g"
  using a by (auto simp add: Ball_def in_respects elim: rel_funE)

lemma bex_rsp:
  assumes a: "(R ===> (op =)) f g"
  shows "(Bex (Respects R) f = Bex (Respects R) g)"
  using a by (auto simp add: Bex_def in_respects elim: rel_funE)

lemma bex1_rsp:
  assumes a: "(R ===> (op =)) f g"
  shows "Ex1 (\<lambda>x. x \<in> Respects R \<and> f x) = Ex1 (\<lambda>x. x \<in> Respects R \<and> g x)"
  using a by (auto elim: rel_funE simp add: Ex1_def in_respects)

(* 2 lemmas needed for cleaning of quantifiers *)
lemma all_prs:
  assumes a: "Quotient3 R absf repf"
  shows "Ball (Respects R) ((absf ---> id) f) = All f"
  using a unfolding Quotient3_def Ball_def in_respects id_apply comp_def map_fun_def
  by metis

lemma ex_prs:
  assumes a: "Quotient3 R absf repf"
  shows "Bex (Respects R) ((absf ---> id) f) = Ex f"
  using a unfolding Quotient3_def Bex_def in_respects id_apply comp_def map_fun_def
  by metis

subsection \<open>\<open>Bex1_rel\<close> quantifier\<close>

definition
  Bex1_rel :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> bool"
where
  "Bex1_rel R P \<longleftrightarrow> (\<exists>x \<in> Respects R. P x) \<and> (\<forall>x \<in> Respects R. \<forall>y \<in> Respects R. ((P x \<and> P y) \<longrightarrow> (R x y)))"

lemma bex1_rel_aux:
  "\<lbrakk>\<forall>xa ya. R xa ya \<longrightarrow> x xa = y ya; Bex1_rel R x\<rbrakk> \<Longrightarrow> Bex1_rel R y"
  unfolding Bex1_rel_def
  apply (erule conjE)+
  apply (erule bexE)
  apply rule
  apply (rule_tac x="xa" in bexI)
  apply metis
  apply metis
  apply rule+
  apply (erule_tac x="xaa" in ballE)
  prefer 2
  apply (metis)
  apply (erule_tac x="ya" in ballE)
  prefer 2
  apply (metis)
  apply (metis in_respects)
  done

lemma bex1_rel_aux2:
  "\<lbrakk>\<forall>xa ya. R xa ya \<longrightarrow> x xa = y ya; Bex1_rel R y\<rbrakk> \<Longrightarrow> Bex1_rel R x"
  unfolding Bex1_rel_def
  apply (erule conjE)+
  apply (erule bexE)
  apply rule
  apply (rule_tac x="xa" in bexI)
  apply metis
  apply metis
  apply rule+
  apply (erule_tac x="xaa" in ballE)
  prefer 2
  apply (metis)
  apply (erule_tac x="ya" in ballE)
  prefer 2
  apply (metis)
  apply (metis in_respects)
  done

lemma bex1_rel_rsp:
  assumes a: "Quotient3 R absf repf"
  shows "((R ===> op =) ===> op =) (Bex1_rel R) (Bex1_rel R)"
  apply (simp add: rel_fun_def)
  apply clarify
  apply rule
  apply (simp_all add: bex1_rel_aux bex1_rel_aux2)
  apply (erule bex1_rel_aux2)
  apply assumption
  done

lemma ex1_prs:
  assumes a: "Quotient3 R absf repf"
  shows "((absf ---> id) ---> id) (Bex1_rel R) f = Ex1 f"
apply (simp add:)
apply (subst Bex1_rel_def)
apply (subst Bex_def)
apply (subst Ex1_def)
apply simp
apply rule
 apply (erule conjE)+
 apply (erule_tac exE)
 apply (erule conjE)
 apply (subgoal_tac "\<forall>y. R y y \<longrightarrow> f (absf y) \<longrightarrow> R x y")
  apply (rule_tac x="absf x" in exI)
  apply (simp)
  apply rule+
  using a unfolding Quotient3_def
  apply metis
 apply rule+
 apply (erule_tac x="x" in ballE)
  apply (erule_tac x="y" in ballE)
   apply simp
  apply (simp add: in_respects)
 apply (simp add: in_respects)
apply (erule_tac exE)
 apply rule
 apply (rule_tac x="repf x" in exI)
 apply (simp only: in_respects)
  apply rule
 apply (metis Quotient3_rel_rep[OF a])
using a unfolding Quotient3_def apply (simp)
apply rule+
using a unfolding Quotient3_def in_respects
apply metis
done

lemma bex1_bexeq_reg:
  shows "(\<exists>!x\<in>Respects R. P x) \<longrightarrow> (Bex1_rel R (\<lambda>x. P x))"
  by (auto simp add: Ex1_def Bex1_rel_def Bex_def Ball_def in_respects)

lemma bex1_bexeq_reg_eqv:
  assumes a: "equivp R"
  shows "(\<exists>!x. P x) \<longrightarrow> Bex1_rel R P"
  using equivp_reflp[OF a]
  apply (intro impI)
  apply (elim ex1E)
  apply (rule mp[OF bex1_bexeq_reg])
  apply (rule_tac a="x" in ex1I)
  apply (subst in_respects)
  apply (rule conjI)
  apply assumption
  apply assumption
  apply clarify
  apply (erule_tac x="xa" in allE)
  apply simp
  done

subsection \<open>Various respects and preserve lemmas\<close>

lemma quot_rel_rsp:
  assumes a: "Quotient3 R Abs Rep"
  shows "(R ===> R ===> op =) R R"
  apply(rule rel_funI)+
  apply(rule equals_rsp[OF a])
  apply(assumption)+
  done

lemma o_prs:
  assumes q1: "Quotient3 R1 Abs1 Rep1"
  and     q2: "Quotient3 R2 Abs2 Rep2"
  and     q3: "Quotient3 R3 Abs3 Rep3"
  shows "((Abs2 ---> Rep3) ---> (Abs1 ---> Rep2) ---> (Rep1 ---> Abs3)) op \<circ> = op \<circ>"
  and   "(id ---> (Abs1 ---> id) ---> Rep1 ---> id) op \<circ> = op \<circ>"
  using Quotient3_abs_rep[OF q1] Quotient3_abs_rep[OF q2] Quotient3_abs_rep[OF q3]
  by (simp_all add: fun_eq_iff)

lemma o_rsp:
  "((R2 ===> R3) ===> (R1 ===> R2) ===> (R1 ===> R3)) op \<circ> op \<circ>"
  "(op = ===> (R1 ===> op =) ===> R1 ===> op =) op \<circ> op \<circ>"
  by (force elim: rel_funE)+

lemma cond_prs:
  assumes a: "Quotient3 R absf repf"
  shows "absf (if a then repf b else repf c) = (if a then b else c)"
  using a unfolding Quotient3_def by auto

lemma if_prs:
  assumes q: "Quotient3 R Abs Rep"
  shows "(id ---> Rep ---> Rep ---> Abs) If = If"
  using Quotient3_abs_rep[OF q]
  by (auto simp add: fun_eq_iff)

lemma if_rsp:
  assumes q: "Quotient3 R Abs Rep"
  shows "(op = ===> R ===> R ===> R) If If"
  by force

lemma let_prs:
  assumes q1: "Quotient3 R1 Abs1 Rep1"
  and     q2: "Quotient3 R2 Abs2 Rep2"
  shows "(Rep2 ---> (Abs2 ---> Rep1) ---> Abs1) Let = Let"
  using Quotient3_abs_rep[OF q1] Quotient3_abs_rep[OF q2]
  by (auto simp add: fun_eq_iff)

lemma let_rsp:
  shows "(R1 ===> (R1 ===> R2) ===> R2) Let Let"
  by (force elim: rel_funE)

lemma id_rsp:
  shows "(R ===> R) id id"
  by auto

lemma id_prs:
  assumes a: "Quotient3 R Abs Rep"
  shows "(Rep ---> Abs) id = id"
  by (simp add: fun_eq_iff Quotient3_abs_rep [OF a])

end

locale quot_type =
  fixes R :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
  and   Abs :: "'a set \<Rightarrow> 'b"
  and   Rep :: "'b \<Rightarrow> 'a set"
  assumes equivp: "part_equivp R"
  and     rep_prop: "\<And>y. \<exists>x. R x x \<and> Rep y = Collect (R x)"
  and     rep_inverse: "\<And>x. Abs (Rep x) = x"
  and     abs_inverse: "\<And>c. (\<exists>x. ((R x x) \<and> (c = Collect (R x)))) \<Longrightarrow> (Rep (Abs c)) = c"
  and     rep_inject: "\<And>x y. (Rep x = Rep y) = (x = y)"
begin

definition
  abs :: "'a \<Rightarrow> 'b"
where
  "abs x = Abs (Collect (R x))"

definition
  rep :: "'b \<Rightarrow> 'a"
where
  "rep a = (SOME x. x \<in> Rep a)"

lemma some_collect:
  assumes "R r r"
  shows "R (SOME x. x \<in> Collect (R r)) = R r"
  apply simp
  by (metis assms exE_some equivp[simplified part_equivp_def])

lemma Quotient:
  shows "Quotient3 R abs rep"
  unfolding Quotient3_def abs_def rep_def
  proof (intro conjI allI)
    fix a r s
    show x: "R (SOME x. x \<in> Rep a) (SOME x. x \<in> Rep a)" proof -
      obtain x where r: "R x x" and rep: "Rep a = Collect (R x)" using rep_prop[of a] by auto
      have "R (SOME x. x \<in> Rep a) x"  using r rep some_collect by metis
      then have "R x (SOME x. x \<in> Rep a)" using part_equivp_symp[OF equivp] by fast
      then show "R (SOME x. x \<in> Rep a) (SOME x. x \<in> Rep a)"
        using part_equivp_transp[OF equivp] by (metis \<open>R (SOME x. x \<in> Rep a) x\<close>)
    qed
    have "Collect (R (SOME x. x \<in> Rep a)) = (Rep a)" by (metis some_collect rep_prop)
    then show "Abs (Collect (R (SOME x. x \<in> Rep a))) = a" using rep_inverse by auto
    have "R r r \<Longrightarrow> R s s \<Longrightarrow> Abs (Collect (R r)) = Abs (Collect (R s)) \<longleftrightarrow> R r = R s"
    proof -
      assume "R r r" and "R s s"
      then have "Abs (Collect (R r)) = Abs (Collect (R s)) \<longleftrightarrow> Collect (R r) = Collect (R s)"
        by (metis abs_inverse)
      also have "Collect (R r) = Collect (R s) \<longleftrightarrow> (\<lambda>A x. x \<in> A) (Collect (R r)) = (\<lambda>A x. x \<in> A) (Collect (R s))"
        by rule simp_all
      finally show "Abs (Collect (R r)) = Abs (Collect (R s)) \<longleftrightarrow> R r = R s" by simp
    qed
    then show "R r s \<longleftrightarrow> R r r \<and> R s s \<and> (Abs (Collect (R r)) = Abs (Collect (R s)))"
      using equivp[simplified part_equivp_def] by metis
    qed

end

subsection \<open>Quotient composition\<close>

lemma OOO_quotient3:
  fixes R1 :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
  fixes Abs1 :: "'a \<Rightarrow> 'b" and Rep1 :: "'b \<Rightarrow> 'a"
  fixes Abs2 :: "'b \<Rightarrow> 'c" and Rep2 :: "'c \<Rightarrow> 'b"
  fixes R2' :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
  fixes R2 :: "'b \<Rightarrow> 'b \<Rightarrow> bool"
  assumes R1: "Quotient3 R1 Abs1 Rep1"
  assumes R2: "Quotient3 R2 Abs2 Rep2"
  assumes Abs1: "\<And>x y. R2' x y \<Longrightarrow> R1 x x \<Longrightarrow> R1 y y \<Longrightarrow> R2 (Abs1 x) (Abs1 y)"
  assumes Rep1: "\<And>x y. R2 x y \<Longrightarrow> R2' (Rep1 x) (Rep1 y)"
  shows "Quotient3 (R1 OO R2' OO R1) (Abs2 \<circ> Abs1) (Rep1 \<circ> Rep2)"
apply (rule Quotient3I)
   apply (simp add: o_def Quotient3_abs_rep [OF R2] Quotient3_abs_rep [OF R1])
  apply simp
  apply (rule_tac b="Rep1 (Rep2 a)" in relcomppI)
   apply (rule Quotient3_rep_reflp [OF R1])
  apply (rule_tac b="Rep1 (Rep2 a)" in relcomppI [rotated])
   apply (rule Quotient3_rep_reflp [OF R1])
  apply (rule Rep1)
  apply (rule Quotient3_rep_reflp [OF R2])
 apply safe
    apply (rename_tac x y)
    apply (drule Abs1)
      apply (erule Quotient3_refl2 [OF R1])
     apply (erule Quotient3_refl1 [OF R1])
    apply (drule Quotient3_refl1 [OF R2], drule Rep1)
    apply (subgoal_tac "R1 r (Rep1 (Abs1 x))")
     apply (rule_tac b="Rep1 (Abs1 x)" in relcomppI, assumption)
     apply (erule relcomppI)
     apply (erule Quotient3_symp [OF R1, THEN sympD])
    apply (rule Quotient3_rel[symmetric, OF R1, THEN iffD2])
    apply (rule conjI, erule Quotient3_refl1 [OF R1])
    apply (rule conjI, rule Quotient3_rep_reflp [OF R1])
    apply (subst Quotient3_abs_rep [OF R1])
    apply (erule Quotient3_rel_abs [OF R1])
   apply (rename_tac x y)
   apply (drule Abs1)
     apply (erule Quotient3_refl2 [OF R1])
    apply (erule Quotient3_refl1 [OF R1])
   apply (drule Quotient3_refl2 [OF R2], drule Rep1)
   apply (subgoal_tac "R1 s (Rep1 (Abs1 y))")
    apply (rule_tac b="Rep1 (Abs1 y)" in relcomppI, assumption)
    apply (erule relcomppI)
    apply (erule Quotient3_symp [OF R1, THEN sympD])
   apply (rule Quotient3_rel[symmetric, OF R1, THEN iffD2])
   apply (rule conjI, erule Quotient3_refl2 [OF R1])
   apply (rule conjI, rule Quotient3_rep_reflp [OF R1])
   apply (subst Quotient3_abs_rep [OF R1])
   apply (erule Quotient3_rel_abs [OF R1, THEN sym])
  apply simp
  apply (rule Quotient3_rel_abs [OF R2])
  apply (rule Quotient3_rel_abs [OF R1, THEN ssubst], assumption)
  apply (rule Quotient3_rel_abs [OF R1, THEN subst], assumption)
  apply (erule Abs1)
   apply (erule Quotient3_refl2 [OF R1])
  apply (erule Quotient3_refl1 [OF R1])
 apply (rename_tac a b c d)
 apply simp
 apply (rule_tac b="Rep1 (Abs1 r)" in relcomppI)
  apply (rule Quotient3_rel[symmetric, OF R1, THEN iffD2])
  apply (rule conjI, erule Quotient3_refl1 [OF R1])
  apply (simp add: Quotient3_abs_rep [OF R1] Quotient3_rep_reflp [OF R1])
 apply (rule_tac b="Rep1 (Abs1 s)" in relcomppI [rotated])
  apply (rule Quotient3_rel[symmetric, OF R1, THEN iffD2])
  apply (simp add: Quotient3_abs_rep [OF R1] Quotient3_rep_reflp [OF R1])
  apply (erule Quotient3_refl2 [OF R1])
 apply (rule Rep1)
 apply (drule Abs1)
   apply (erule Quotient3_refl2 [OF R1])
  apply (erule Quotient3_refl1 [OF R1])
 apply (drule Abs1)
  apply (erule Quotient3_refl2 [OF R1])
 apply (erule Quotient3_refl1 [OF R1])
 apply (drule Quotient3_rel_abs [OF R1])
 apply (drule Quotient3_rel_abs [OF R1])
 apply (drule Quotient3_rel_abs [OF R1])
 apply (drule Quotient3_rel_abs [OF R1])
 apply simp
 apply (rule Quotient3_rel[symmetric, OF R2, THEN iffD2])
 apply simp
done

lemma OOO_eq_quotient3:
  fixes R1 :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
  fixes Abs1 :: "'a \<Rightarrow> 'b" and Rep1 :: "'b \<Rightarrow> 'a"
  fixes Abs2 :: "'b \<Rightarrow> 'c" and Rep2 :: "'c \<Rightarrow> 'b"
  assumes R1: "Quotient3 R1 Abs1 Rep1"
  assumes R2: "Quotient3 op= Abs2 Rep2"
  shows "Quotient3 (R1 OOO op=) (Abs2 \<circ> Abs1) (Rep1 \<circ> Rep2)"
using assms
by (rule OOO_quotient3) auto

subsection \<open>Quotient3 to Quotient\<close>

lemma Quotient3_to_Quotient:
assumes "Quotient3 R Abs Rep"
and "T \<equiv> \<lambda>x y. R x x \<and> Abs x = y"
shows "Quotient R Abs Rep T"
using assms unfolding Quotient3_def by (intro QuotientI) blast+

lemma Quotient3_to_Quotient_equivp:
assumes q: "Quotient3 R Abs Rep"
and T_def: "T \<equiv> \<lambda>x y. Abs x = y"
and eR: "equivp R"
shows "Quotient R Abs Rep T"
proof (intro QuotientI)
  fix a
  show "Abs (Rep a) = a" using q by(rule Quotient3_abs_rep)
next
  fix a
  show "R (Rep a) (Rep a)" using q by(rule Quotient3_rep_reflp)
next
  fix r s
  show "R r s = (R r r \<and> R s s \<and> Abs r = Abs s)" using q by(rule Quotient3_rel[symmetric])
next
  show "T = (\<lambda>x y. R x x \<and> Abs x = y)" using T_def equivp_reflp[OF eR] by simp
qed

subsection \<open>ML setup\<close>

text \<open>Auxiliary data for the quotient package\<close>

named_theorems quot_equiv "equivalence relation theorems"
  and quot_respect "respectfulness theorems"
  and quot_preserve "preservation theorems"
  and id_simps "identity simp rules for maps"
  and quot_thm "quotient theorems"
ML_file "Tools/Quotient/quotient_info.ML"

declare [[mapQ3 "fun" = (rel_fun, fun_quotient3)]]

lemmas [quot_thm] = fun_quotient3
lemmas [quot_respect] = quot_rel_rsp if_rsp o_rsp let_rsp id_rsp
lemmas [quot_preserve] = if_prs o_prs let_prs id_prs
lemmas [quot_equiv] = identity_equivp

text \<open>Lemmas about simplifying id's.\<close>
lemmas [id_simps] =
  id_def[symmetric]
  map_fun_id
  id_apply
  id_o
  o_id
  eq_comp_r
  vimage_id

text \<open>Translation functions for the lifting process.\<close>
ML_file "Tools/Quotient/quotient_term.ML"

text \<open>Definitions of the quotient types.\<close>
ML_file "Tools/Quotient/quotient_type.ML"

text \<open>Definitions for quotient constants.\<close>
ML_file "Tools/Quotient/quotient_def.ML"

text \<open>
  An auxiliary constant for recording some information
  about the lifted theorem in a tactic.
\<close>
definition
  Quot_True :: "'a \<Rightarrow> bool"
where
  "Quot_True x \<longleftrightarrow> True"

lemma
  shows QT_all: "Quot_True (All P) \<Longrightarrow> Quot_True P"
  and   QT_ex:  "Quot_True (Ex P) \<Longrightarrow> Quot_True P"
  and   QT_ex1: "Quot_True (Ex1 P) \<Longrightarrow> Quot_True P"
  and   QT_lam: "Quot_True (\<lambda>x. P x) \<Longrightarrow> (\<And>x. Quot_True (P x))"
  and   QT_ext: "(\<And>x. Quot_True (a x) \<Longrightarrow> f x = g x) \<Longrightarrow> (Quot_True a \<Longrightarrow> f = g)"
  by (simp_all add: Quot_True_def ext)

lemma QT_imp: "Quot_True a \<equiv> Quot_True b"
  by (simp add: Quot_True_def)

context includes lifting_syntax
begin

text \<open>Tactics for proving the lifted theorems\<close>
ML_file "Tools/Quotient/quotient_tacs.ML"

end

subsection \<open>Methods / Interface\<close>

method_setup lifting =
  \<open>Attrib.thms >> (fn thms => fn ctxt =>
       SIMPLE_METHOD' (Quotient_Tacs.lift_tac ctxt [] thms))\<close>
  \<open>lift theorems to quotient types\<close>

method_setup lifting_setup =
  \<open>Attrib.thm >> (fn thm => fn ctxt =>
       SIMPLE_METHOD' (Quotient_Tacs.lift_procedure_tac ctxt [] thm))\<close>
  \<open>set up the three goals for the quotient lifting procedure\<close>

method_setup descending =
  \<open>Scan.succeed (fn ctxt => SIMPLE_METHOD' (Quotient_Tacs.descend_tac ctxt []))\<close>
  \<open>decend theorems to the raw level\<close>

method_setup descending_setup =
  \<open>Scan.succeed (fn ctxt => SIMPLE_METHOD' (Quotient_Tacs.descend_procedure_tac ctxt []))\<close>
  \<open>set up the three goals for the decending theorems\<close>

method_setup partiality_descending =
  \<open>Scan.succeed (fn ctxt => SIMPLE_METHOD' (Quotient_Tacs.partiality_descend_tac ctxt []))\<close>
  \<open>decend theorems to the raw level\<close>

method_setup partiality_descending_setup =
  \<open>Scan.succeed (fn ctxt =>
       SIMPLE_METHOD' (Quotient_Tacs.partiality_descend_procedure_tac ctxt []))\<close>
  \<open>set up the three goals for the decending theorems\<close>

method_setup regularize =
  \<open>Scan.succeed (fn ctxt => SIMPLE_METHOD' (Quotient_Tacs.regularize_tac ctxt))\<close>
  \<open>prove the regularization goals from the quotient lifting procedure\<close>

method_setup injection =
  \<open>Scan.succeed (fn ctxt => SIMPLE_METHOD' (Quotient_Tacs.all_injection_tac ctxt))\<close>
  \<open>prove the rep/abs injection goals from the quotient lifting procedure\<close>

method_setup cleaning =
  \<open>Scan.succeed (fn ctxt => SIMPLE_METHOD' (Quotient_Tacs.clean_tac ctxt))\<close>
  \<open>prove the cleaning goals from the quotient lifting procedure\<close>

attribute_setup quot_lifted =
  \<open>Scan.succeed Quotient_Tacs.lifted_attrib\<close>
  \<open>lift theorems to quotient types\<close>

no_notation
  rel_conj (infixr "OOO" 75)

end


theory ShortestPath
imports
  Graph_Theory.Graph_Theory
begin

section \<open>Shortest Path (with non-negative edge costs)\<close>
text\<open>The following theory is used in the verification of a certifying algorithm's checker for shortest path. For more information see \cite{FrameworkVerificationofCertifyingComputations}.\<close>

locale basic_sp =
  fin_digraph +
  fixes dist :: "'a \<Rightarrow> ereal"
  fixes c :: "'b \<Rightarrow> real"
  fixes s :: "'a"
  assumes general_source_val: "dist s \<le> 0"
  assumes trian:
    "\<And>e. e \<in> arcs G \<Longrightarrow>
      dist (head G e) \<le> dist (tail G e) + c e"

locale basic_just_sp =
  basic_sp +
  fixes num :: "'a \<Rightarrow> enat"
  assumes just:
    "\<And>v. \<lbrakk>v \<in> verts G; v \<noteq> s; num v \<noteq> \<infinity>\<rbrakk> \<Longrightarrow>
      \<exists> e \<in> arcs G. v = head G e \<and>
        dist v = dist (tail G e) + c e  \<and>
        num v = num (tail G e) + (enat 1)"

locale shortest_path_pos_cost =
  basic_just_sp +
  assumes s_in_G: "s \<in> verts G"
  assumes tail_val: "dist s = 0"
  assumes no_path: "\<And>v. v \<in> verts G \<Longrightarrow> dist v = \<infinity> \<longleftrightarrow> num v = \<infinity>"
  assumes pos_cost: "\<And>e. e \<in> arcs G \<Longrightarrow> 0 \<le> c e"

locale basic_just_sp_pred =
  basic_sp +
  fixes num :: "'a \<Rightarrow> enat"
  fixes pred :: "'a \<Rightarrow> 'b option"
  assumes just:
    "\<And>v. \<lbrakk>v \<in> verts G; v \<noteq> s; num v \<noteq> \<infinity>\<rbrakk> \<Longrightarrow>
      \<exists> e \<in> arcs G.
        e = the (pred v) \<and>
        v = head G e \<and>
        dist v = dist (tail G e) + c e  \<and>
        num v = num (tail G e) + (enat 1)"

sublocale basic_just_sp_pred \<subseteq> basic_just_sp
using basic_just_sp_pred_axioms
unfolding basic_just_sp_pred_def
   basic_just_sp_pred_axioms_def
by unfold_locales (blast)

locale shortest_path_pos_cost_pred =
  basic_just_sp_pred +
  assumes s_in_G: "s \<in> verts G"
  assumes tail_val: "dist s = 0"
  assumes no_path: "\<And>v. v \<in> verts G \<Longrightarrow> dist v = \<infinity> \<longleftrightarrow> num v = \<infinity>"
  assumes pos_cost: "\<And>e. e \<in> arcs G \<Longrightarrow> 0 \<le> c e"

sublocale shortest_path_pos_cost_pred \<subseteq> shortest_path_pos_cost
using shortest_path_pos_cost_pred_axioms
by unfold_locales
   (auto simp: shortest_path_pos_cost_pred_def
   shortest_path_pos_cost_pred_axioms_def)

lemma tail_value_helper:
  assumes "hd p = last p"
  assumes "distinct p"
  assumes "p \<noteq> []"
  shows "p = [hd p]"
  by (metis assms distinct.simps(2) list.sel(1) neq_Nil_conv last_ConsR last_in_set)

lemma (in basic_sp) dist_le_cost:
  fixes v :: 'a
  fixes p :: "'b list"
  assumes "awalk s p v"
  shows "dist v \<le> awalk_cost c p"
  using assms
  proof (induct "length p" arbitrary: p v)
  case 0
    hence "s = v" by auto
    thus ?case using 0(1) general_source_val
      by (metis awalk_cost_Nil length_0_conv zero_ereal_def)
  next
  case (Suc n)
    then obtain p' e where p'e: "p = p' @ [e]"
      by (cases p rule: rev_cases) auto
    then obtain u where ewu: "awalk s p' u \<and> awalk u [e] v"
      using awalk_append_iff Suc(3) by simp
    then have du: "dist u \<le> ereal (awalk_cost c p')"
      using Suc p'e by simp
    from ewu have ust: "u = tail G e" and vta: "v = head G e"
      by auto
    then have "dist v \<le> dist u + c e"
      using ewu du ust trian[where e=e] by force
    with du have "dist v \<le> ereal (awalk_cost c p') + c e"
      by (metis add_right_mono order_trans)
    thus "dist v \<le> awalk_cost c p"
      using awalk_cost_append p'e by simp
  qed

lemma (in fin_digraph) witness_path:
  assumes "\<mu> c s v = ereal r"
  shows "\<exists> p. apath s p v \<and> \<mu> c s v = awalk_cost c p"
proof -
  have sv: "s \<rightarrow>\<^sup>* v"
    using shortest_path_inf[of s v c] assms by fastforce
  {
    fix p assume "awalk s p v"
    then have no_neg_cyc:
    "\<not> (\<exists>w q. awalk w q w \<and> w \<in> set (awalk_verts s p) \<and> awalk_cost c q < 0)"
      using neg_cycle_imp_inf_\<mu> assms by force
  }
  thus ?thesis using no_neg_cyc_reach_imp_path[OF sv] by presburger
qed

lemma (in basic_sp)  dist_le_\<mu>:
  fixes v :: 'a
  assumes "v \<in> verts G"
  shows "dist v \<le> \<mu> c s v"
proof (rule ccontr)
  assume nt: "\<not> ?thesis"
  show False
  proof (cases "\<mu> c s v")
    show "\<And>r. \<mu> c s v = ereal r \<Longrightarrow> False"
    proof -
      fix r assume r_asm: "\<mu> c s v = ereal r"
      hence sv: "s \<rightarrow>\<^sup>* v"
        using shortest_path_inf[where u=s and v=v and f=c] by auto
      obtain p where
        "awalk s p v"
        "\<mu> c s v = awalk_cost c p"
        using witness_path[OF r_asm] unfolding apath_def by force
      thus False using nt dist_le_cost by simp
    qed
  next
    show "\<mu> c s v = \<infinity> \<Longrightarrow> False" using nt by simp
  next
    show "\<mu> c s v = - \<infinity> \<Longrightarrow> False" using dist_le_cost
    proof -
      assume asm: "\<mu> c s v = - \<infinity>"
      let ?C = "(\<lambda>x. ereal (awalk_cost c x)) ` {p. awalk s p v}"
      have "\<exists>x\<in> ?C. x < dist v"
        using nt unfolding \<mu>_def not_le INF_less_iff by simp
      then obtain p where
        "awalk s p v"
        "awalk_cost c p < dist v"
        by force
      thus False using dist_le_cost by force
    qed
  qed
qed

lemma (in basic_just_sp) dist_ge_\<mu>:
  fixes v :: 'a
  assumes "v \<in> verts G"
  assumes "num v \<noteq> \<infinity>"
  assumes "dist v \<noteq> -\<infinity>"
  assumes "\<mu> c s s = ereal 0"
  assumes "dist s = 0"
  assumes "\<And>u. u\<in>verts G \<Longrightarrow> u\<noteq>s \<Longrightarrow>
            num u \<noteq> \<infinity> \<Longrightarrow> num u \<noteq> enat 0"
  shows "dist v \<ge> \<mu> c s v"
proof -
  obtain n where "enat n = num v" using assms(2) by force
  thus ?thesis using assms
  proof(induct n arbitrary: v)
  case 0 thus ?case by (cases "v=s", auto)
  next
  case (Suc n)
    thus ?case
    proof (cases "v=s")
    case False
      obtain e where e_assms:
        "e \<in> arcs G"
        "v = head G e"
        "dist v = dist (tail G e) + ereal (c e)"
        "num v = num (tail G e) + enat 1"
        using just[OF Suc(3) False Suc(4)] by blast
      then have nsinf:"num (tail G e) \<noteq> \<infinity>"
        by (metis Suc(2) enat.simps(3) enat_1 plus_enat_simps(2))
      then have ns:"enat n = num (tail G e)"
        using e_assms(4) Suc(2) by force
      have  ds: "dist (tail G e) = \<mu> c s (tail G e)"
        using Suc(1)[OF ns tail_in_verts[OF e_assms(1)] nsinf]
        Suc(5-8) e_assms(3) dist_le_\<mu>[OF tail_in_verts[OF e_assms(1)]]
        by simp
      have dmuc:"dist v \<ge> \<mu> c s (tail G e) + ereal (c e)"
        using e_assms(3) ds  by auto
      thus ?thesis
      proof (cases "dist v = \<infinity>")
      case False
        have "arc_to_ends G e = (tail G e, v)"
          unfolding arc_to_ends_def
          by (simp add: e_assms(2))
        obtain r where  \<mu>r: "\<mu> c s (tail G e) = ereal r"
           using e_assms(3) Suc(5) ds False
           by (cases "\<mu> c s (tail G e)", auto)
        obtain p where
          "awalk s p (tail G e)" and
          \<mu>s: "\<mu> c s (tail G e) = ereal (awalk_cost c p)"
          using witness_path[OF \<mu>r] unfolding apath_def
          by blast
        then have pe: "awalk s (p @ [e]) v"
          using e_assms(1,2) by (auto simp: awalk_simps)
        hence muc:"\<mu> c s v \<le> \<mu> c s (tail G e) + ereal (c e)"
        using \<mu>s min_cost_le_walk_cost[OF pe] by simp
        thus  "dist v \<ge> \<mu> c s v"  using dmuc by simp
      qed simp
    qed (simp add: Suc(6,7))
  qed
qed

lemma (in shortest_path_pos_cost) num_not0:
  fixes v :: 'a
  assumes "v \<in> verts G"
  assumes "v \<noteq> s"
  assumes "num v \<noteq> \<infinity>"
  shows "num v \<noteq> enat 0"
proof -
  obtain ku where "num v = ku + enat 1"
    using assms just by blast
  thus ?thesis  by (induct ku) auto
qed

lemma (in shortest_path_pos_cost) dist_ne_ninf:
  fixes v :: 'a
  assumes "v \<in> verts G"
  shows "dist v \<noteq> -\<infinity>"
proof (cases "num v = \<infinity>")
case False
  obtain n where "enat n = num v"
    using False by force
  thus ?thesis using assms False
  proof(induct n arbitrary: v)
  case 0 thus ?case
    using num_not0 tail_val by (cases "v=s", auto)
  next
  case (Suc n)
    thus ?case
    proof (cases "v=s")
    case True
      thus ?thesis using tail_val by simp
    next
    case False
      obtain e where e_assms:
        "e \<in> arcs G"
        "dist v = dist (tail G e) + ereal (c e)"
        "num v = num (tail G e) + enat 1"
        using just[OF Suc(3) False Suc(4)] by blast
      then have nsinf:"num (tail G e) \<noteq> \<infinity>"
        by (metis Suc(2) enat.simps(3) enat_1 plus_enat_simps(2))
      then have ns:"enat n = num (tail G e)"
        using e_assms(3) Suc(2) by force
      have "dist (tail G e ) \<noteq> - \<infinity>"
        by (rule Suc(1) [OF ns tail_in_verts[OF e_assms(1)] nsinf])
      thus ?thesis using e_assms(2) by simp
    qed
  qed
next
case True
  thus ?thesis using no_path[OF assms] by simp
qed

theorem (in shortest_path_pos_cost) correct_shortest_path:
  fixes v :: 'a
  assumes "v \<in> verts G"
  shows "dist v = \<mu> c s v"
  using no_path[OF assms(1)] dist_le_\<mu>[OF assms(1)]
    dist_ge_\<mu>[OF assms(1) _ dist_ne_ninf[OF assms(1)]
    tail_value_check[OF s_in_G] tail_val num_not0]
    by fastforce

corollary (in shortest_path_pos_cost_pred) correct_shortest_path_pred:
  fixes v :: 'a
  assumes "v \<in> verts G"
  shows "dist v = \<mu> c s v"
  using correct_shortest_path assms by simp

end


theory NN_is_countable
  imports Countable ETCS_Ordinal_Inequalities

begin

lemma nonzero_to_any_power:
  assumes "a \<in>\<^sub>c \<nat>\<^sub>c" "b \<in>\<^sub>c \<nat>\<^sub>c"  "a \<noteq> zero"
  shows "a ^\<^sub>\<nat> b \<noteq> zero"
  by (simp add: assms(1) assms(2) assms(3) exp_order_preserving1 nonzero_to_k_nonzero)

lemma RENAME_ME:
  assumes "a \<in>\<^sub>c \<nat>\<^sub>c" "b \<in>\<^sub>c \<nat>\<^sub>c"
  assumes "a \<noteq> successor \<circ>\<^sub>c zero"
  shows "(b =  zero) = (a ^\<^sub>\<nat> b = successor \<circ>\<^sub>c zero)"
proof(auto)
  show "b = zero \<Longrightarrow> a ^\<^sub>\<nat> zero = successor \<circ>\<^sub>c zero"
    by (simp add: assms(1) exp_respects_Zero_Left)
  show "a ^\<^sub>\<nat> b = successor \<circ>\<^sub>c zero \<Longrightarrow> b = zero"
    by (smt (verit, best) add_respects_zero_on_right assms(1) assms(2) assms(3) cfunc_type_def comp_type exists_implies_leq_true exp_closure exp_order_preserving1 exp_order_preserving_converse exp_respects_Zero_Left exp_respects_one_left exp_respects_successor lqe_antisymmetry nonzero_is_succ s0_is_right_id zero_type)
qed

lemma exp_cancellative:
  assumes "a \<in>\<^sub>c \<nat>\<^sub>c" "b \<in>\<^sub>c \<nat>\<^sub>c" "c \<in>\<^sub>c \<nat>\<^sub>c" "a \<noteq> zero" "a \<noteq> successor \<circ>\<^sub>c zero"
  shows  "(a ^\<^sub>\<nat> b = a ^\<^sub>\<nat> c) = (b = c)"
proof(auto)
  assume "(a ^\<^sub>\<nat> b = a ^\<^sub>\<nat> c)"
  have "a ^\<^sub>\<nat> b \<noteq> zero"
    by (simp add: assms(1) assms(2) assms(4) nonzero_to_any_power)

  show "b = c"
  proof(cases "leq \<circ>\<^sub>c \<langle>b, c\<rangle> = \<t>")
    assume "leq \<circ>\<^sub>c \<langle>b, c\<rangle> = \<t>"
    then obtain k where k_type[type_rule]: "k \<in>\<^sub>c \<nat>\<^sub>c" and k_def: "k +\<^sub>\<nat> b = c"
      by (meson  assms(2) assms(3) leq_true_implies_exists)
    then have "a ^\<^sub>\<nat> b = (a ^\<^sub>\<nat> k) \<cdot>\<^sub>\<nat> (a ^\<^sub>\<nat> b)"
      using \<open>a ^\<^sub>\<nat> b = a ^\<^sub>\<nat> c\<close> assms(1) assms(2) exp_right_dist by force
    then have "successor \<circ>\<^sub>c zero = a ^\<^sub>\<nat> k"
      by (typecheck_cfuncs, metis \<open>a ^\<^sub>\<nat> b = a ^\<^sub>\<nat> c\<close> \<open>a ^\<^sub>\<nat> b \<noteq> zero\<close> assms(1) assms(3) exp_closure l_mult_cancellative mult_commutative s0_is_right_id)
    then have "k = zero"
      using  assms(1) assms(5) k_type RENAME_ME by force
    then show "b = c"
      using add_respects_zero_on_left assms(2) k_def by presburger
  next
    assume "leq \<circ>\<^sub>c \<langle>b,c\<rangle> \<noteq> \<t>"
    then have "leq \<circ>\<^sub>c \<langle>c,b\<rangle> = \<t>"
      using \<open>leq \<circ>\<^sub>c \<langle>b,c\<rangle> \<noteq> \<t>\<close> assms(2) assms(3) lqe_connexity by blast
    then obtain k where k_type[type_rule]: "k \<in>\<^sub>c \<nat>\<^sub>c" and k_def: "k +\<^sub>\<nat> c = b"
      by (meson  assms(2) assms(3) leq_true_implies_exists)
    then have "a ^\<^sub>\<nat> b = (a ^\<^sub>\<nat> k) \<cdot>\<^sub>\<nat> (a ^\<^sub>\<nat> c)"
      using assms(1) assms(3) exp_right_dist by force
    then have "successor \<circ>\<^sub>c zero = a ^\<^sub>\<nat> k"
      by (typecheck_cfuncs, metis \<open>a ^\<^sub>\<nat> b = a ^\<^sub>\<nat> c\<close> \<open>a ^\<^sub>\<nat> b \<noteq> zero\<close> assms(1) assms(3) exp_closure l_mult_cancellative mult_commutative s0_is_right_id)
    then have "k = zero"
      using  assms(1) assms(5) k_type RENAME_ME by force
    then show "b = c"
      using add_respects_zero_on_left assms(3) k_def by force
  qed
qed

(*
lemma exp_cancellative2:
  assumes "a \<in>\<^sub>c \<nat>\<^sub>c" "b \<in>\<^sub>c \<nat>\<^sub>c" "c \<in>\<^sub>c \<nat>\<^sub>c" "a \<noteq> zero"
  shows  "(b ^\<^sub>\<nat> a = c ^\<^sub>\<nat> a) = (b = c)"
proof(auto)
 *)

(*

proof(auto)
  assume "b ^\<^sub>\<nat> a = c ^\<^sub>\<nat> a"
  obtain k where k_type[type_rule]: "k \<in>\<^sub>c \<nat>\<^sub>c" and k_def: "successor \<circ>\<^sub>c k   = a"
    using assms(1) assms(4) nonzero_is_succ by blast
  then have "b ^\<^sub>\<nat> ((successor \<circ>\<^sub>c zero) +\<^sub>\<nat> k) = c ^\<^sub>\<nat> ((successor \<circ>\<^sub>c zero) +\<^sub>\<nat> k)"
    using \<open>b ^\<^sub>\<nat> a = c ^\<^sub>\<nat> a\<close> add_respects_succ3 add_respects_zero_on_left k_def by (typecheck_cfuncs, presburger)
  then have "(b ^\<^sub>\<nat> (successor \<circ>\<^sub>c zero)) \<cdot>\<^sub>\<nat> (b ^\<^sub>\<nat> k) = (c ^\<^sub>\<nat> (successor \<circ>\<^sub>c zero)) \<cdot>\<^sub>\<nat> (c ^\<^sub>\<nat> k)"
    by (typecheck_cfuncs, metis \<open>b ^\<^sub>\<nat> a = c ^\<^sub>\<nat> a\<close> assms(2) assms(3) exp_respects_one_right exp_respects_successor k_def)
  then have "b \<cdot>\<^sub>\<nat> (b ^\<^sub>\<nat> k) = c  \<cdot>\<^sub>\<nat> (c ^\<^sub>\<nat> k)"
    by (metis \<open>b ^\<^sub>\<nat> a = c ^\<^sub>\<nat> a\<close> assms(2) assms(3) exp_respects_successor k_def k_type)
  show "b = c"
  proof(cases "leq \<circ>\<^sub>c \<langle>b ^\<^sub>\<nat> k,c ^\<^sub>\<nat> k\<rangle> = \<t>")
    assume "leq \<circ>\<^sub>c \<langle>b ^\<^sub>\<nat> k,c ^\<^sub>\<nat> k\<rangle> = \<t>"
    then obtain j where j_type[type_rule]: "j \<in>\<^sub>c \<nat>\<^sub>c" and j_def: "(b ^\<^sub>\<nat> k) +\<^sub>\<nat> j = c ^\<^sub>\<nat> k"
      by (metis add_commutes assms(2) assms(3) exp_closure k_type leq_true_implies_exists)
    have "j = zero"
    proof(rule ccontr)
      oops
*)

(*Proposition 2.6.10*)
lemma NxN_is_countable:
  "countable(\<nat>\<^sub>c \<times>\<^sub>c \<nat>\<^sub>c)"
proof -
  obtain \<phi> where \<phi>_def: " \<phi> = mult2 \<circ>\<^sub>c \<langle>exp_uncurried \<circ>\<^sub>c \<langle>(successor \<circ>\<^sub>c successor \<circ>\<^sub>c zero) \<circ>\<^sub>c \<beta>\<^bsub>(\<nat>\<^sub>c \<times>\<^sub>c \<nat>\<^sub>c)\<^esub>, left_cart_proj \<nat>\<^sub>c \<nat>\<^sub>c\<rangle>       ,
                                   exp_uncurried \<circ>\<^sub>c \<langle>(successor \<circ>\<^sub>c successor \<circ>\<^sub>c successor \<circ>\<^sub>c zero) \<circ>\<^sub>c \<beta>\<^bsub>(\<nat>\<^sub>c \<times>\<^sub>c \<nat>\<^sub>c)\<^esub>, right_cart_proj \<nat>\<^sub>c \<nat>\<^sub>c\<rangle>   \<rangle>"
    by auto
  have \<phi>_type[type_rule]: "\<phi> : \<nat>\<^sub>c \<times>\<^sub>c \<nat>\<^sub>c \<rightarrow> \<nat>\<^sub>c"
    unfolding \<phi>_def by typecheck_cfuncs

  have \<phi>_injective: "injective(\<phi>)"
  proof(unfold injective_def, auto)
    fix mn st
    assume mn_type: "mn \<in>\<^sub>c domain \<phi>"
    assume st_type: "st \<in>\<^sub>c domain \<phi>"
    assume equals: "\<phi> \<circ>\<^sub>c mn = \<phi> \<circ>\<^sub>c st"

    have mn_type2: "mn \<in>\<^sub>c \<nat>\<^sub>c \<times>\<^sub>c \<nat>\<^sub>c"
      using \<phi>_type cfunc_type_def mn_type by force
    have st_type2: "st \<in>\<^sub>c \<nat>\<^sub>c \<times>\<^sub>c \<nat>\<^sub>c"
      using \<phi>_type cfunc_type_def st_type by force

    obtain m and n where m_type[type_rule]: "m \<in>\<^sub>c \<nat>\<^sub>c" and n_type[type_rule]: "n \<in>\<^sub>c \<nat>\<^sub>c" and mn_def: "mn = \<langle>m,n\<rangle>"
      using cart_prod_decomp mn_type2 by blast
    obtain s and t where s_type[type_rule]: "s \<in>\<^sub>c \<nat>\<^sub>c" and t_type[type_rule]: "t \<in>\<^sub>c \<nat>\<^sub>c" and st_def: "st = \<langle>s,t\<rangle>"
      using cart_prod_decomp st_type2 by blast

    have simplify: "\<And> u v. u \<in>\<^sub>c \<nat>\<^sub>c \<Longrightarrow> v \<in>\<^sub>c \<nat>\<^sub>c \<Longrightarrow> \<phi> \<circ>\<^sub>c \<langle>u,v\<rangle> = ((successor \<circ>\<^sub>c successor \<circ>\<^sub>c zero)^\<^sub>\<nat> u) \<cdot>\<^sub>\<nat> ((successor \<circ>\<^sub>c successor \<circ>\<^sub>c successor \<circ>\<^sub>c zero)^\<^sub>\<nat> v)"
    proof(unfold \<phi>_def)
      fix u v
      assume u_type[type_rule]: "u \<in>\<^sub>c \<nat>\<^sub>c"
      assume v_type[type_rule]: "v \<in>\<^sub>c \<nat>\<^sub>c"
      have "(mult2 \<circ>\<^sub>c \<langle>exp_uncurried \<circ>\<^sub>c \<langle>(successor \<circ>\<^sub>c successor \<circ>\<^sub>c zero) \<circ>\<^sub>c \<beta>\<^bsub>\<nat>\<^sub>c \<times>\<^sub>c \<nat>\<^sub>c\<^esub>,left_cart_proj \<nat>\<^sub>c \<nat>\<^sub>c\<rangle>,
                      exp_uncurried \<circ>\<^sub>c \<langle>(successor \<circ>\<^sub>c successor \<circ>\<^sub>c successor \<circ>\<^sub>c zero) \<circ>\<^sub>c \<beta>\<^bsub>\<nat>\<^sub>c \<times>\<^sub>c \<nat>\<^sub>c\<^esub>,right_cart_proj \<nat>\<^sub>c \<nat>\<^sub>c\<rangle>\<rangle>) \<circ>\<^sub>c \<langle>u,v\<rangle> =
             mult2 \<circ>\<^sub>c \<langle>exp_uncurried \<circ>\<^sub>c \<langle>(successor \<circ>\<^sub>c successor \<circ>\<^sub>c zero) \<circ>\<^sub>c   \<beta>\<^bsub>\<nat>\<^sub>c \<times>\<^sub>c \<nat>\<^sub>c\<^esub>,left_cart_proj \<nat>\<^sub>c \<nat>\<^sub>c\<rangle>,
                      exp_uncurried \<circ>\<^sub>c \<langle>(successor \<circ>\<^sub>c successor \<circ>\<^sub>c successor \<circ>\<^sub>c zero) \<circ>\<^sub>c \<beta>\<^bsub>\<nat>\<^sub>c \<times>\<^sub>c \<nat>\<^sub>c\<^esub>,right_cart_proj \<nat>\<^sub>c \<nat>\<^sub>c\<rangle>\<rangle> \<circ>\<^sub>c \<langle>u,v\<rangle>"
        by (typecheck_cfuncs, smt (z3) comp_associative2)
      also have "... = mult2 \<circ>\<^sub>c \<langle>exp_uncurried \<circ>\<^sub>c \<langle>(successor \<circ>\<^sub>c successor \<circ>\<^sub>c zero) \<circ>\<^sub>c   \<beta>\<^bsub>\<nat>\<^sub>c \<times>\<^sub>c \<nat>\<^sub>c\<^esub>,left_cart_proj \<nat>\<^sub>c \<nat>\<^sub>c\<rangle> \<circ>\<^sub>c \<langle>u,v\<rangle>,
                      exp_uncurried \<circ>\<^sub>c \<langle>(successor \<circ>\<^sub>c successor \<circ>\<^sub>c successor \<circ>\<^sub>c zero) \<circ>\<^sub>c \<beta>\<^bsub>\<nat>\<^sub>c \<times>\<^sub>c \<nat>\<^sub>c\<^esub>,right_cart_proj \<nat>\<^sub>c \<nat>\<^sub>c\<rangle> \<circ>\<^sub>c \<langle>u,v\<rangle>\<rangle>"
        by (typecheck_cfuncs, smt (z3) cfunc_prod_comp comp_associative2)
      also have "... = mult2 \<circ>\<^sub>c \<langle>exp_uncurried \<circ>\<^sub>c \<langle>(successor \<circ>\<^sub>c successor \<circ>\<^sub>c zero) \<circ>\<^sub>c   (\<beta>\<^bsub>\<nat>\<^sub>c \<times>\<^sub>c \<nat>\<^sub>c\<^esub>  \<circ>\<^sub>c \<langle>u,v\<rangle>),left_cart_proj \<nat>\<^sub>c \<nat>\<^sub>c \<circ>\<^sub>c \<langle>u,v\<rangle>\<rangle> ,
                      exp_uncurried \<circ>\<^sub>c \<langle>(successor \<circ>\<^sub>c successor \<circ>\<^sub>c successor \<circ>\<^sub>c zero) \<circ>\<^sub>c (\<beta>\<^bsub>\<nat>\<^sub>c \<times>\<^sub>c \<nat>\<^sub>c\<^esub>  \<circ>\<^sub>c \<langle>u,v\<rangle>),right_cart_proj \<nat>\<^sub>c \<nat>\<^sub>c  \<circ>\<^sub>c \<langle>u,v\<rangle> \<rangle>  \<rangle>"
        by (typecheck_cfuncs, smt (z3) cfunc_prod_comp comp_associative2)
      also have "... = mult2 \<circ>\<^sub>c \<langle>exp_uncurried \<circ>\<^sub>c \<langle>(successor \<circ>\<^sub>c successor \<circ>\<^sub>c zero) \<circ>\<^sub>c   (id one),left_cart_proj \<nat>\<^sub>c \<nat>\<^sub>c \<circ>\<^sub>c \<langle>u,v\<rangle>\<rangle> ,
                      exp_uncurried \<circ>\<^sub>c \<langle>(successor \<circ>\<^sub>c successor \<circ>\<^sub>c successor \<circ>\<^sub>c zero) \<circ>\<^sub>c (id one),right_cart_proj \<nat>\<^sub>c \<nat>\<^sub>c  \<circ>\<^sub>c \<langle>u,v\<rangle>\<rangle>  \<rangle>"
        by (typecheck_cfuncs, metis (full_types)  one_unique_element)
      also have "... = mult2 \<circ>\<^sub>c \<langle>exp_uncurried \<circ>\<^sub>c \<langle>(successor \<circ>\<^sub>c successor \<circ>\<^sub>c zero) ,left_cart_proj \<nat>\<^sub>c \<nat>\<^sub>c \<circ>\<^sub>c \<langle>u,v\<rangle>\<rangle> ,
                      exp_uncurried \<circ>\<^sub>c \<langle>(successor \<circ>\<^sub>c successor \<circ>\<^sub>c successor \<circ>\<^sub>c zero) ,right_cart_proj \<nat>\<^sub>c \<nat>\<^sub>c  \<circ>\<^sub>c \<langle>u,v\<rangle>\<rangle>  \<rangle>"
        by (typecheck_cfuncs, metis id_right_unit2)
      also have "... = mult2 \<circ>\<^sub>c \<langle>exp_uncurried \<circ>\<^sub>c \<langle>(successor \<circ>\<^sub>c successor \<circ>\<^sub>c zero) , u \<rangle> ,
                      exp_uncurried \<circ>\<^sub>c \<langle>(successor \<circ>\<^sub>c successor \<circ>\<^sub>c successor \<circ>\<^sub>c zero) ,v\<rangle>  \<rangle>"
        using left_cart_proj_cfunc_prod mn_def right_cart_proj_cfunc_prod by (typecheck_cfuncs, auto)
      also have "... =((successor \<circ>\<^sub>c successor \<circ>\<^sub>c zero)^\<^sub>\<nat> u) \<cdot>\<^sub>\<nat> ((successor \<circ>\<^sub>c successor \<circ>\<^sub>c successor \<circ>\<^sub>c zero)^\<^sub>\<nat> v)"
        by (metis exp_def mult_def)
      then show "(mult2 \<circ>\<^sub>c \<langle>exp_uncurried \<circ>\<^sub>c\<langle>(successor \<circ>\<^sub>c successor \<circ>\<^sub>c zero) \<circ>\<^sub>c \<beta>\<^bsub>\<nat>\<^sub>c \<times>\<^sub>c \<nat>\<^sub>c\<^esub>,left_cart_proj \<nat>\<^sub>c \<nat>\<^sub>c\<rangle>,exp_uncurried \<circ>\<^sub>c \<langle>(successor \<circ>\<^sub>c successor \<circ>\<^sub>c successor \<circ>\<^sub>c zero) \<circ>\<^sub>c \<beta>\<^bsub>\<nat>\<^sub>c \<times>\<^sub>c \<nat>\<^sub>c\<^esub>,right_cart_proj \<nat>\<^sub>c \<nat>\<^sub>c\<rangle>\<rangle>) \<circ>\<^sub>c  \<langle>u,v\<rangle> =
                 (successor \<circ>\<^sub>c successor \<circ>\<^sub>c zero) ^\<^sub>\<nat> u \<cdot>\<^sub>\<nat> (successor \<circ>\<^sub>c successor \<circ>\<^sub>c successor \<circ>\<^sub>c zero) ^\<^sub>\<nat> v"
        by (metis calculation)
    qed

    have equals2: "((successor \<circ>\<^sub>c successor \<circ>\<^sub>c zero)^\<^sub>\<nat> m) \<cdot>\<^sub>\<nat> ((successor \<circ>\<^sub>c successor \<circ>\<^sub>c successor \<circ>\<^sub>c zero)^\<^sub>\<nat> n) =
              ((successor \<circ>\<^sub>c successor \<circ>\<^sub>c zero)^\<^sub>\<nat> s) \<cdot>\<^sub>\<nat> ((successor \<circ>\<^sub>c successor \<circ>\<^sub>c successor \<circ>\<^sub>c zero)^\<^sub>\<nat> t)"
      using equals m_type mn_def n_type s_type simplify st_def t_type by force
    show "mn = st"
    proof(cases "leq \<circ>\<^sub>c \<langle>m, s\<rangle> = \<t>")
      assume "leq \<circ>\<^sub>c \<langle>m,s\<rangle> = \<t>"
      then obtain k where k_type[type_rule]: "k \<in>\<^sub>c \<nat>\<^sub>c" and k_def: "k +\<^sub>\<nat> m = s"
        by (meson leq_true_implies_exists m_type s_type)
      then have "((successor \<circ>\<^sub>c successor \<circ>\<^sub>c zero)^\<^sub>\<nat> m) \<cdot>\<^sub>\<nat>  ((successor \<circ>\<^sub>c successor \<circ>\<^sub>c successor \<circ>\<^sub>c zero)^\<^sub>\<nat>  n) =
                ((successor \<circ>\<^sub>c successor \<circ>\<^sub>c  zero)^\<^sub>\<nat> m) \<cdot>\<^sub>\<nat> ((successor \<circ>\<^sub>c successor \<circ>\<^sub>c  zero)^\<^sub>\<nat> k) \<cdot>\<^sub>\<nat> ((successor \<circ>\<^sub>c successor \<circ>\<^sub>c successor \<circ>\<^sub>c zero)^\<^sub>\<nat>  t)"
        by (typecheck_cfuncs, metis add_commutes equals2 exp_right_dist k_def)
      then have f1: "((successor \<circ>\<^sub>c successor \<circ>\<^sub>c successor \<circ>\<^sub>c zero)^\<^sub>\<nat>  n) =
                     ((successor \<circ>\<^sub>c successor \<circ>\<^sub>c  zero)^\<^sub>\<nat> k) \<cdot>\<^sub>\<nat> ((successor \<circ>\<^sub>c successor \<circ>\<^sub>c successor \<circ>\<^sub>c zero)^\<^sub>\<nat>  t)"
        by (typecheck_cfuncs, metis  exp_closure l_mult_cancellative m_type mult_associative nonzero_to_any_power zero_is_not_successor)
      show ?thesis
      proof(cases "k = zero")
        assume "k = zero"
        then have "n=t"
          by (metis exp_cancellative exp_closure exp_respects_Zero_Left f1 n_type s0_is_left_id succ_inject succ_n_type t_type zero_is_not_successor zero_type)
        then show ?thesis
          using \<open>k = zero\<close> add_respects_zero_on_left k_def m_type mn_def st_def by auto
      next
        assume "k \<noteq> zero"
        then have even: "is_even \<circ>\<^sub>c ((successor \<circ>\<^sub>c successor \<circ>\<^sub>c successor \<circ>\<^sub>c zero)^\<^sub>\<nat>  n) = \<t>"
          using exp_closure exp_def f1 k_type mult_evens_is_even2 powers_of_two_are_even succ_n_type t_type zero_type by force
        have "is_odd \<circ>\<^sub>c ((successor \<circ>\<^sub>c successor \<circ>\<^sub>c successor \<circ>\<^sub>c zero)^\<^sub>\<nat>  n) = \<t>"
          by (metis even exp_def exp_respects_Zero_Left mult_evens_is_even2 n_type not_even_and_odd powers_of_three_are_odd s0_is_left_id succ_n_type three_is_odd)
        then have False
          using even exp_closure n_type not_even_and_odd succ_n_type zero_type by auto
        then show ?thesis
          by simp
        (*Now repeat with s \<le> m *)
      qed
    next
      assume "leq \<circ>\<^sub>c \<langle>m,s\<rangle> \<noteq> \<t>"
      then have "leq \<circ>\<^sub>c \<langle>s,m\<rangle> = \<t>"
        using lqe_connexity m_type s_type by blast
      then  obtain p where p_type[type_rule]: "p \<in>\<^sub>c \<nat>\<^sub>c" and p_def: "m = p +\<^sub>\<nat> s"
        using leq_true_implies_exists m_type s_type by blast
      then have "((successor \<circ>\<^sub>c successor \<circ>\<^sub>c zero)^\<^sub>\<nat> p) \<cdot>\<^sub>\<nat> ((successor \<circ>\<^sub>c successor \<circ>\<^sub>c zero)^\<^sub>\<nat> s) \<cdot>\<^sub>\<nat> ((successor \<circ>\<^sub>c successor \<circ>\<^sub>c successor \<circ>\<^sub>c zero)^\<^sub>\<nat>  n) =
                ((successor \<circ>\<^sub>c successor \<circ>\<^sub>c  zero)^\<^sub>\<nat> s) \<cdot>\<^sub>\<nat> ((successor \<circ>\<^sub>c successor \<circ>\<^sub>c successor \<circ>\<^sub>c zero)^\<^sub>\<nat>  t)"
        by (typecheck_cfuncs, metis equals2 exp_right_dist p_def)
      then have "((successor \<circ>\<^sub>c successor \<circ>\<^sub>c zero)^\<^sub>\<nat> s) \<cdot>\<^sub>\<nat> ((successor \<circ>\<^sub>c successor \<circ>\<^sub>c zero)^\<^sub>\<nat> p) \<cdot>\<^sub>\<nat> ((successor \<circ>\<^sub>c successor \<circ>\<^sub>c successor \<circ>\<^sub>c zero)^\<^sub>\<nat>  n) =
                ((successor \<circ>\<^sub>c successor \<circ>\<^sub>c  zero)^\<^sub>\<nat> s) \<cdot>\<^sub>\<nat> ((successor \<circ>\<^sub>c successor \<circ>\<^sub>c successor \<circ>\<^sub>c zero)^\<^sub>\<nat>  t)"
        using  mult_commutative by (typecheck_cfuncs, presburger)
      then have f1: "((successor \<circ>\<^sub>c successor \<circ>\<^sub>c zero)^\<^sub>\<nat> p) \<cdot>\<^sub>\<nat>  ((successor \<circ>\<^sub>c successor \<circ>\<^sub>c successor \<circ>\<^sub>c zero)^\<^sub>\<nat>  n) =
                                                               ((successor \<circ>\<^sub>c successor \<circ>\<^sub>c successor \<circ>\<^sub>c zero)^\<^sub>\<nat>  t)"
        by (typecheck_cfuncs, metis  exp_closure l_mult_cancellative mult_associative nonzero_to_any_power s_type zero_is_not_successor)
      show ?thesis
      proof(cases "p = zero")
        assume "p = zero"
        then have "n=t"
          using \<open>leq \<circ>\<^sub>c \<langle>m,s\<rangle> \<noteq> \<t>\<close> \<open>leq \<circ>\<^sub>c \<langle>s,m\<rangle> = \<t>\<close> add_respects_zero_on_left p_def s_type by auto
        then show ?thesis
          by (simp add: \<open>p = zero\<close> add_respects_zero_on_left mn_def p_def s_type st_def)
      next
        assume "p \<noteq> zero"
        then have even: "is_even \<circ>\<^sub>c  ((successor \<circ>\<^sub>c successor \<circ>\<^sub>c successor \<circ>\<^sub>c zero)^\<^sub>\<nat>  t) = \<t>"
          by (metis exp_closure exp_def f1 mult_evens_is_even2 n_type p_type powers_of_two_are_even succ_n_type zero_type)
        have "is_odd \<circ>\<^sub>c  ((successor \<circ>\<^sub>c successor \<circ>\<^sub>c successor \<circ>\<^sub>c zero)^\<^sub>\<nat>  t) = \<t>"
          by (typecheck_cfuncs, metis comp_associative2 exp_def exp_respects_Zero_Left is_even_def2 is_even_not_is_odd is_odd_def2 powers_of_three_are_odd)
        then have False
          using even exp_closure not_even_and_odd succ_n_type t_type zero_type by auto
        then show ?thesis
          by simp
      qed
    qed
  qed
  then show ?thesis
    using \<phi>_type countable_def injective_imp_monomorphism by blast
qed

end


theory Functions imports Main begin

text{*
@{thm[display] id_def[no_vars]}
\rulename{id_def}

@{thm[display] o_def[no_vars]}
\rulename{o_def}

@{thm[display] o_assoc[no_vars]}
\rulename{o_assoc}
*}

text{*
@{thm[display] fun_upd_apply[no_vars]}
\rulename{fun_upd_apply}

@{thm[display] fun_upd_upd[no_vars]}
\rulename{fun_upd_upd}
*}

text{*
definitions of injective, surjective, bijective

@{thm[display] inj_on_def[no_vars]}
\rulename{inj_on_def}

@{thm[display] surj_def[no_vars]}
\rulename{surj_def}

@{thm[display] bij_def[no_vars]}
\rulename{bij_def}
*}

text{*
possibly interesting theorems about inv
*}

text{*
@{thm[display] inv_f_f[no_vars]}
\rulename{inv_f_f}

@{thm[display] inj_imp_surj_inv[no_vars]}
\rulename{inj_imp_surj_inv}

@{thm[display] surj_imp_inj_inv[no_vars]}
\rulename{surj_imp_inj_inv}

@{thm[display] surj_f_inv_f[no_vars]}
\rulename{surj_f_inv_f}

@{thm[display] bij_imp_bij_inv[no_vars]}
\rulename{bij_imp_bij_inv}

@{thm[display] inv_inv_eq[no_vars]}
\rulename{inv_inv_eq}

@{thm[display] o_inv_distrib[no_vars]}
\rulename{o_inv_distrib}
*}

text{*
small sample proof

@{thm[display] ext[no_vars]}
\rulename{ext}

@{thm[display] fun_eq_iff[no_vars]}
\rulename{fun_eq_iff}
*}

lemma "inj f \<Longrightarrow> (f o g = f o h) = (g = h)"
  apply (simp add: fun_eq_iff inj_on_def)
  apply (auto)
  done

text{*
\begin{isabelle}
inj\ f\ \isasymLongrightarrow \ (f\ \isasymcirc \ g\ =\ f\ \isasymcirc \ h)\ =\ (g\ =\ h)\isanewline
\ 1.\ \isasymforall x\ y.\ f\ x\ =\ f\ y\ \isasymlongrightarrow \ x\ =\ y\ \isasymLongrightarrow \isanewline
\ \ \ \ (\isasymforall x.\ f\ (g\ x)\ =\ f\ (h\ x))\ =\ (\isasymforall x.\ g\ x\ =\ h\ x)
\end{isabelle}
*}

text{*image, inverse image*}

text{*
@{thm[display] image_def[no_vars]}
\rulename{image_def}
*}

text{*
@{thm[display] image_Un[no_vars]}
\rulename{image_Un}
*}

text{*
@{thm[display] image_comp[no_vars]}
\rulename{image_comp}

@{thm[display] image_Int[no_vars]}
\rulename{image_Int}

@{thm[display] bij_image_Compl_eq[no_vars]}
\rulename{bij_image_Compl_eq}
*}

text{*
illustrates Union as well as image
*}

lemma "f`A \<union> g`A = (\<Union>x\<in>A. {f x, g x})"
by blast

lemma "f ` {(x,y). P x y} = {f(x,y) | x y. P x y}"
by blast

text{*actually a macro!*}

lemma "range f = f`UNIV"
by blast

text{*
inverse image
*}

text{*
@{thm[display] vimage_def[no_vars]}
\rulename{vimage_def}

@{thm[display] vimage_Compl[no_vars]}
\rulename{vimage_Compl}
*}

end


section \<open>Numeric approximations to Constants\<close>

theory Approximations
imports "../Complex_Transcendental" "../Harmonic_Numbers"
begin

text \<open>
  In this theory, we will approximate some standard mathematical constants with high precision,
  using only Isabelle's simplifier. (no oracles, code generator, etc.)

  The constants we will look at are: $\pi$, $e$, $\ln 2$, and $\gamma$ (the Euler--Mascheroni
  constant).
\<close>

lemma eval_fact:
  "fact 0 = 1"
  "fact (Suc 0) = 1"
  "fact (numeral n) = numeral n * fact (pred_numeral n)"
  by (simp, simp, simp_all only: numeral_eq_Suc fact_Suc,
      simp only: numeral_eq_Suc [symmetric] of_nat_numeral)

lemma sum_poly_horner_expand:
  "(\<Sum>k<(numeral n::nat). f k * x^k) = f 0 + (\<Sum>k<pred_numeral n. f (k+1) * x^k) * x"
  "(\<Sum>k<Suc 0. f k * x^k) = (f 0 :: 'a :: semiring_1)"
  "(\<Sum>k<(0::nat). f k * x^k) = 0"
proof -
  {
    fix m :: nat
    have "(\<Sum>k<Suc m. f k * x^k) = f 0 + (\<Sum>k=Suc 0..<Suc m. f k * x^k)"
      by (subst atLeast0LessThan [symmetric], subst sum_head_upt_Suc) simp_all
    also have "(\<Sum>k=Suc 0..<Suc m. f k * x^k) = (\<Sum>k<m. f (k+1) * x^k) * x"
      by (subst sum_shift_bounds_Suc_ivl)
         (simp add: sum_distrib_right algebra_simps atLeast0LessThan power_commutes)
    finally have "(\<Sum>k<Suc m. f k * x ^ k) = f 0 + (\<Sum>k<m. f (k + 1) * x ^ k) * x" .
  }
  from this[of "pred_numeral n"]
    show "(\<Sum>k<numeral n. f k * x^k) = f 0 + (\<Sum>k<pred_numeral n. f (k+1) * x^k) * x"
    by (simp add: numeral_eq_Suc)
qed simp_all

lemma power_less_one:
  assumes "n > 0" "x \<ge> 0" "x < 1"
  shows   "x ^ n < (1::'a::linordered_semidom)"
proof -
  from assms consider "x > 0" | "x = 0" by force
  thus ?thesis
  proof cases
    assume "x > 0"
    with assms show ?thesis
      by (cases n) (simp, hypsubst, rule power_Suc_less_one)
  qed (insert assms, cases n, simp_all)
qed

lemma combine_bounds:
  "x \<in> {a1..b1} \<Longrightarrow> y \<in> {a2..b2} \<Longrightarrow> a3 = a1 + a2 \<Longrightarrow> b3 = b1 + b2 \<Longrightarrow> x + y \<in> {a3..(b3::real)}"
  "x \<in> {a1..b1} \<Longrightarrow> y \<in> {a2..b2} \<Longrightarrow> a3 = a1 - b2 \<Longrightarrow> b3 = b1 - a2 \<Longrightarrow> x - y \<in> {a3..(b3::real)}"
  "c \<ge> 0 \<Longrightarrow> x \<in> {a..b} \<Longrightarrow> c * x \<in> {c*a..c*b}"
  by (auto simp: mult_left_mono)

lemma approx_coarsen:
  "\<bar>x - a1\<bar> \<le> eps1 \<Longrightarrow> \<bar>a1 - a2\<bar> \<le> eps2 - eps1 \<Longrightarrow> \<bar>x - a2\<bar> \<le> (eps2 :: real)"
  by simp

subsection \<open>Approximations of the exponential function\<close>

lemma two_power_fact_le_fact:
  assumes "n \<ge> 1"
  shows   "2^k * fact n \<le> (fact (n + k) :: 'a :: {semiring_char_0,linordered_semidom})"
proof (induction k)
  case (Suc k)
  have "2 ^ Suc k * fact n = 2 * (2 ^ k * fact n)" by (simp add: algebra_simps)
  also note Suc.IH
  also from assms have "of_nat 1 + of_nat 1 \<le> of_nat n + (of_nat (Suc k) :: 'a)"
    by (intro add_mono) (unfold of_nat_le_iff, simp_all)
  hence "2 * (fact (n + k) :: 'a) \<le> of_nat (n + Suc k) * fact (n + k)"
    by (intro mult_right_mono) (simp_all add: add_ac)
  also have "\<dots> = fact (n + Suc k)" by simp
  finally show ?case by - (simp add: mult_left_mono)
qed simp_all

text \<open>
  We approximate the exponential function with inputs between $0$ and $2$ by its
  Taylor series expansion and bound the error term with $0$ from below and with a
  geometric series from above.
\<close>
lemma exp_approx:
  assumes "n > 0" "0 \<le> x" "x < 2"
  shows   "exp (x::real) - (\<Sum>k<n. x^k / fact k) \<in> {0..(2 * x^n / (2 - x)) / fact n}"
proof (unfold atLeastAtMost_iff, safe)
  define approx where "approx = (\<Sum>k<n. x^k / fact k)"
  have "(\<lambda>k. x^k / fact k) sums exp x"
    using exp_converges[of x] by (simp add: field_simps)
  from sums_split_initial_segment[OF this, of n]
    have sums: "(\<lambda>k. x^n * (x^k / fact (n+k))) sums (exp x - approx)"
    by (simp add: approx_def algebra_simps power_add)

  from assms show "(exp x - approx) \<ge> 0"
    by (intro sums_le[OF _ sums_zero sums]) auto

  have "\<forall>k. x^n * (x^k / fact (n+k)) \<le> (x^n / fact n) * (x / 2)^k"
  proof
    fix k :: nat
    have "x^n * (x^k / fact (n + k)) = x^(n+k) / fact (n + k)" by (simp add: power_add)
    also from assms have "\<dots> \<le> x^(n+k) / (2^k * fact n)"
      by (intro divide_left_mono two_power_fact_le_fact zero_le_power) simp_all
    also have "\<dots> = (x^n / fact n) * (x / 2) ^ k"
      by (simp add: field_simps power_add)
    finally show "x^n * (x^k / fact (n+k)) \<le> (x^n / fact n) * (x / 2)^k" .
  qed
  moreover note sums
  moreover {
    from assms have "(\<lambda>k. (x^n / fact n) * (x / 2)^k) sums ((x^n / fact n) * (1 / (1 - x / 2)))"
      by (intro sums_mult geometric_sums) simp_all
    also from assms have "((x^n / fact n) * (1 / (1 - x / 2))) = (2 * x^n / (2 - x)) / fact n"
      by (auto simp: divide_simps)
    finally have "(\<lambda>k. (x^n / fact n) * (x / 2)^k) sums \<dots>" .
  }
  ultimately show "(exp x - approx) \<le> (2 * x^n / (2 - x)) / fact n"
    by (rule sums_le)
qed

text \<open>
  The following variant gives a simpler error estimate for inputs between $0$ and $1$:
\<close>
lemma exp_approx':
  assumes "n > 0" "0 \<le> x" "x \<le> 1"
  shows   "\<bar>exp (x::real) - (\<Sum>k\<le>n. x^k / fact k)\<bar> \<le> x ^ n / fact n"
proof -
  from assms have "x^n / (2 - x) \<le> x^n / 1" by (intro frac_le) simp_all
  hence "(2 * x^n / (2 - x)) / fact n \<le> 2 * x^n / fact n"
    using assms by (simp add: divide_simps)
  with exp_approx[of n x] assms
    have "exp (x::real) - (\<Sum>k<n. x^k / fact k) \<in> {0..2 * x^n / fact n}" by simp
  moreover have "(\<Sum>k\<le>n. x^k / fact k) = (\<Sum>k<n. x^k / fact k) + x ^ n / fact n"
    by (simp add: lessThan_Suc_atMost [symmetric])
  ultimately show "\<bar>exp (x::real) - (\<Sum>k\<le>n. x^k / fact k)\<bar> \<le> x ^ n / fact n"
    unfolding atLeastAtMost_iff by linarith
qed

text \<open>
  By adding $x^n / n!$ to the approximation (i.e. taking one more term from the
  Taylor series), one can get the error bound down to $x^n / n!$.

  This means that the number of accurate binary digits produced by the approximation is
  asymptotically equal to $(n \log n - n) / \log 2$ by Stirling's formula.
\<close>
lemma exp_approx'':
  assumes "n > 0" "0 \<le> x" "x \<le> 1"
  shows   "\<bar>exp (x::real) - (\<Sum>k\<le>n. x^k / fact k)\<bar> \<le> 1 / fact n"
proof -
  from assms have "\<bar>exp x - (\<Sum>k\<le>n. x ^ k / fact k)\<bar> \<le> x ^ n / fact n"
    by (rule exp_approx')
  also from assms have "\<dots> \<le> 1 / fact n" by (simp add: divide_simps power_le_one)
  finally show ?thesis .
qed

text \<open>
  We now define an approximation function for Euler's constant $e$.
\<close>

definition euler_approx :: "nat \<Rightarrow> real" where
  "euler_approx n = (\<Sum>k\<le>n. inverse (fact k))"

definition euler_approx_aux :: "nat \<Rightarrow> nat" where
  "euler_approx_aux n = (\<Sum>k\<le>n. \<Prod>{k + 1..n})"

lemma exp_1_approx:
  "n > 0 \<Longrightarrow> \<bar>exp (1::real) - euler_approx n\<bar> \<le> 1 / fact n"
  using exp_approx''[of n 1] by (simp add: euler_approx_def divide_simps)

text \<open>
  The following allows us to compute the numerator and the denominator of the result
  separately, which greatly reduces the amount of rational number arithmetic that we
  have to do.
\<close>
lemma euler_approx_altdef [code]:
  "euler_approx n = real (euler_approx_aux n) / real (fact n)"
proof -
  have "real (\<Sum>k\<le>n. \<Prod>{k+1..n}) = (\<Sum>k\<le>n. \<Prod>i=k+1..n. real i)" by simp
  also have "\<dots> / fact n = (\<Sum>k\<le>n. 1 / (fact n / (\<Prod>i=k+1..n. real i)))"
    by (simp add: sum_divide_distrib)
  also have "\<dots> = (\<Sum>k\<le>n. 1 / fact k)"
  proof (intro sum.cong refl)
    fix k assume k: "k \<in> {..n}"
    have "fact n = (\<Prod>i=1..n. real i)" by (simp add: fact_prod)
    also from k have "{1..n} = {1..k} \<union> {k+1..n}" by auto
    also have "prod real \<dots> / (\<Prod>i=k+1..n. real i) = (\<Prod>i=1..k. real i)"
      by (subst nonzero_divide_eq_eq, simp, subst prod.union_disjoint [symmetric]) auto
    also have "\<dots> = fact k" by (simp add: fact_prod)
    finally show "1 / (fact n / prod real {k + 1..n}) = 1 / fact k" by simp
  qed
  also have "\<dots> = euler_approx n" by (simp add: euler_approx_def field_simps)
  finally show ?thesis by (simp add: euler_approx_aux_def)
qed

lemma euler_approx_aux_Suc:
  "euler_approx_aux (Suc m) = 1 + Suc m * euler_approx_aux m"
  unfolding euler_approx_aux_def
  by (subst sum_distrib_left) (simp add: atLeastAtMostSuc_conv)

lemma eval_euler_approx_aux:
  "euler_approx_aux 0 = 1"
  "euler_approx_aux 1 = 2"
  "euler_approx_aux (Suc 0) = 2"
  "euler_approx_aux (numeral n) = 1 + numeral n * euler_approx_aux (pred_numeral n)" (is "?th")
proof -
  have A: "euler_approx_aux (Suc m) = 1 + Suc m * euler_approx_aux m" for m :: nat
    unfolding euler_approx_aux_def
    by (subst sum_distrib_left) (simp add: atLeastAtMostSuc_conv)
  show ?th by (subst numeral_eq_Suc, subst A, subst numeral_eq_Suc [symmetric]) simp
qed (simp_all add: euler_approx_aux_def)

lemma euler_approx_aux_code [code]:
  "euler_approx_aux n = (if n = 0 then 1 else 1 + n * euler_approx_aux (n - 1))"
  by (cases n) (simp_all add: eval_euler_approx_aux euler_approx_aux_Suc)

lemmas eval_euler_approx = euler_approx_altdef eval_euler_approx_aux

text \<open>Approximations of $e$ to 60 decimals / 128 and 64 bits:\<close>

lemma euler_60_decimals:
  "\<bar>exp 1 - 2.718281828459045235360287471352662497757247093699959574966968\<bar>
      \<le> inverse (10^60::real)"
  by (rule approx_coarsen, rule exp_1_approx[of 48])
     (simp_all add: eval_euler_approx eval_fact)

lemma euler_128:
  "\<bar>exp 1 - 924983374546220337150911035843336795079 / 2 ^ 128\<bar> \<le> inverse (2 ^ 128 :: real)"
  by (rule approx_coarsen[OF euler_60_decimals]) simp_all

lemma euler_64:
  "\<bar>exp 1 - 50143449209799256683 / 2 ^ 64\<bar> \<le> inverse (2 ^ 64 :: real)"
  by (rule approx_coarsen[OF euler_128]) simp_all

text \<open>
  An approximation of $e$ to 60 decimals. This is about as far as we can go with the
  simplifier with this kind of setup; the exported code of the code generator, on the other
  hand, can easily approximate $e$ to 1000 decimals and verify that approximation within
  fractions of a second.
\<close>

(* (Uncommented because we don't want to use the code generator;
   don't forget to import Code\_Target\_Numeral)) *)
(*
lemma "\<bar>exp 1 - 2.7182818284590452353602874713526624977572470936999595749669676277240766303535475945713821785251664274274663919320030599218174135966290435729003342952605956307381323286279434907632338298807531952510190115738341879307021540891499348841675092447614606680822648001684774118537423454424371075390777449920695517027618386062613313845830007520449338265602976067371132007093287091274437470472306969772093101416928368190255151086574637721112523897844250569536967707854499699679468644549059879316368892300987931277361782154249992295763514822082698951936680331825288693984964651058209392398294887933203625094431173012381970684161403970198376793206832823764648042953118023287825098194558153017567173613320698112509961818815930416903515988885193458072738667385894228792284998920868058257492796104841984443634632449684875602336248270419786232090021609902353043699418491463140934317381436405462531520961836908887070167683964243781405927145635490613031072085103837505101157477041718986106873969655212671546889570350354021\<bar>
  \<le> inverse (10^1000::real)"
  by (rule approx_coarsen, rule exp_1_approx[of 450], simp) eval
*)

subsection \<open>Approximation of $\ln 2$\<close>

text \<open>
  The following three auxiliary constants allow us to force the simplifier to
  evaluate intermediate results, simulating call-by-value.
\<close>

definition "ln_approx_aux3 x' e n y d \<longleftrightarrow>
  \<bar>(2 * y) * (\<Sum>k<n. inverse (real (2*k+1)) * (y^2)^k) + d - x'\<bar> \<le> e - d"
definition "ln_approx_aux2 x' e n y \<longleftrightarrow>
  ln_approx_aux3 x' e n y (y^(2*n+1) / (1 - y^2) / real (2*n+1))"
definition "ln_approx_aux1 x' e n x \<longleftrightarrow>
  ln_approx_aux2 x' e n ((x - 1) / (x + 1))"

lemma ln_approx_abs'':
  fixes x :: real and n :: nat
  defines "y \<equiv> (x-1)/(x+1)"
  defines "approx \<equiv> (\<Sum>k<n. 2*y^(2*k+1) / of_nat (2*k+1))"
  defines "d \<equiv> y^(2*n+1) / (1 - y^2) / of_nat (2*n+1)"
  assumes x: "x > 1"
  assumes A: "ln_approx_aux1 x' e n x"
  shows   "\<bar>ln x - x'\<bar> \<le> e"
proof (rule approx_coarsen[OF ln_approx_abs[OF x, of n]], goal_cases)
  case 1
  from A have "\<bar>2 * y * (\<Sum>k<n. inverse (real (2 * k + 1)) * y\<^sup>2 ^ k) + d - x'\<bar> \<le> e - d"
    by (simp only: ln_approx_aux3_def ln_approx_aux2_def ln_approx_aux1_def
                   y_def [symmetric] d_def [symmetric])
  also have "2 * y * (\<Sum>k<n. inverse (real (2 * k + 1)) * y\<^sup>2 ^ k) =
               (\<Sum>k<n. 2 * y^(2*k+1) / (real (2 * k + 1)))"
    by (subst sum_distrib_left, simp, subst power_mult)
       (simp_all add: divide_simps mult_ac power_mult)
  finally show ?case by (simp only: d_def y_def approx_def)
qed

text \<open>
  We unfold the above three constants successively and then compute the
  sum using a Horner scheme.
\<close>
lemma ln_2_40_decimals:
  "\<bar>ln 2 - 0.6931471805599453094172321214581765680755\<bar>
      \<le> inverse (10^40 :: real)"
  apply (rule ln_approx_abs''[where n = 40], simp)
  apply (simp, simp add: ln_approx_aux1_def)
  apply (simp add: ln_approx_aux2_def power2_eq_square power_divide)
  apply (simp add: ln_approx_aux3_def power2_eq_square)
  apply (simp add: sum_poly_horner_expand)
  done

lemma ln_2_128:
  "\<bar>ln 2 - 235865763225513294137944142764154484399 / 2 ^ 128\<bar> \<le> inverse (2 ^ 128 :: real)"
  by (rule approx_coarsen[OF ln_2_40_decimals]) simp_all

lemma ln_2_64:
  "\<bar>ln 2 - 12786308645202655660 / 2 ^ 64\<bar> \<le> inverse (2 ^ 64 :: real)"
  by (rule approx_coarsen[OF ln_2_128]) simp_all

subsection \<open>Approximation of the Euler--Mascheroni constant\<close>

text \<open>
  Unfortunatly, the best approximation we have formalised for the Euler--Mascheroni
  constant converges only quadratically. This is too slow to compute more than a
  few decimals, but we can get almost 4 decimals / 14 binary digits this way,
  which is not too bad.
\<close>
lemma euler_mascheroni_approx:
  defines "approx \<equiv> 0.577257 :: real" and "e \<equiv> 0.000063 :: real"
  shows   "abs (euler_mascheroni - approx :: real) < e"
  (is "abs (_ - ?approx) < ?e")
proof -
  define l :: real
    where "l = 47388813395531028639296492901910937/82101866951584879688289000000000000"
  define u :: real
    where "u = 142196984054132045946501548559032969 / 246305600854754639064867000000000000"
  have impI: "P \<longrightarrow> Q" if Q for P Q using that by blast
  have hsum_63: "harm 63 = (310559566510213034489743057 / 65681493561267903750631200 :: real)"
    by (simp add: harm_expand)
  from harm_Suc[of 63] have hsum_64: "harm 64 =
          623171679694215690971693339 / (131362987122535807501262400::real)"
    by (subst (asm) hsum_63) simp
  have "ln (64::real) = real (6::nat) * ln 2" by (subst ln_realpow[symmetric]) simp_all
  hence "ln (real_of_nat (Suc 63)) \<in> {4.158883083293<..<4.158883083367}" using ln_2_64
    by (simp add: abs_real_def split: if_split_asm)
  from euler_mascheroni_bounds'[OF _ this]
    have "(euler_mascheroni :: real) \<in> {l<..<u}"
    by (simp add: hsum_63 del: greaterThanLessThan_iff) (simp only: l_def u_def)
  also have "\<dots> \<subseteq> {approx - e<..<approx + e}"
    by (subst greaterThanLessThan_subseteq_greaterThanLessThan, rule impI)
       (simp add: approx_def e_def u_def l_def)
  finally show ?thesis by (simp add: abs_real_def)
qed

subsection \<open>Approximation of pi\<close>

subsubsection \<open>Approximating the arctangent\<close>

text\<open>
  The arctangent can be used to approximate pi. Fortunately, its Taylor series expansion
  converges exponentially for small values, so we can get $\Theta(n)$ digits of precision
  with $n$ summands of the expansion.
\<close>

definition arctan_approx where
  "arctan_approx n x = x * (\<Sum>k<n. (-(x^2))^k / real (2*k+1))"

lemma arctan_series':
  assumes "\<bar>x\<bar> \<le> 1"
  shows "(\<lambda>k. (-1)^k * (1 / real (k*2+1) * x ^ (k*2+1))) sums arctan x"
  using summable_arctan_series[OF assms] arctan_series[OF assms] by (simp add: sums_iff)

lemma arctan_approx:
  assumes x: "0 \<le> x" "x < 1" and n: "even n"
  shows   "arctan x - arctan_approx n x \<in> {0..x^(2*n+1) / (1-x^4)}"
proof -
  define c where "c k = 1 / (1+(4*real k + 2*real n)) - x\<^sup>2 / (3+(4*real k + 2*real n))" for k
  from assms have "(\<lambda>k. (-1) ^ k * (1 / real (k * 2 + 1) * x^(k*2+1))) sums arctan x"
    using arctan_series' by simp
  also have "(\<lambda>k. (-1) ^ k * (1 / real (k * 2 + 1) * x^(k*2+1))) =
                 (\<lambda>k. x * ((- (x^2))^k / real (2*k+1)))"
    by (simp add: power2_eq_square power_mult power_mult_distrib mult_ac power_minus')
  finally have "(\<lambda>k. x * ((- x\<^sup>2) ^ k / real (2 * k + 1))) sums arctan x" .
  from sums_split_initial_segment[OF this, of n]
    have "(\<lambda>i. x * ((- x\<^sup>2) ^ (i + n) / real (2 * (i + n) + 1))) sums
            (arctan x - arctan_approx n x)"
    by (simp add: arctan_approx_def sum_distrib_left)
  from sums_group[OF this, of 2] assms
    have sums: "(\<lambda>k. x * (x\<^sup>2)^n * (x^4)^k * c k) sums (arctan x - arctan_approx n x)"
    by (simp add: algebra_simps power_add power_mult [symmetric] c_def)

  from assms have "0 \<le> arctan x - arctan_approx n x"
    by (intro sums_le[OF _ sums_zero sums] allI mult_nonneg_nonneg)
       (auto intro!: frac_le power_le_one simp: c_def)
  moreover {
    from assms have "c k \<le> 1 - 0" for k unfolding c_def
      by (intro diff_mono divide_nonneg_nonneg add_nonneg_nonneg) auto
    with assms have "x * x\<^sup>2 ^ n * (x ^ 4) ^ k * c k \<le> x * x\<^sup>2 ^ n * (x ^ 4) ^ k * 1" for k
      by (intro mult_left_mono mult_right_mono mult_nonneg_nonneg) simp_all
    with assms have "arctan x - arctan_approx n x \<le> x * (x\<^sup>2)^n * (1 / (1 - x^4))"
      by (intro sums_le[OF _ sums sums_mult[OF geometric_sums]] allI mult_left_mono)
         (auto simp: power_less_one)
    also have "x * (x^2)^n = x^(2*n+1)" by (simp add: power_mult power_add)
    finally have "arctan x - arctan_approx n x \<le> x^(2*n+1) / (1 - x^4)" by simp
  }
  ultimately show ?thesis by simp
qed

lemma arctan_approx_def': "arctan_approx n (1/x) =
  (\<Sum>k<n. inverse (real (2 * k + 1) * (- x\<^sup>2) ^ k)) / x"
proof -
  have "(-1)^k / b = 1 / ((-1)^k * b)" for k :: nat and b :: real
    by (cases "even k") auto
  thus ?thesis by (simp add: arctan_approx_def  field_simps power_minus')
qed

lemma expand_arctan_approx:
  "(\<Sum>k<(numeral n::nat). inverse (f k) * inverse (x ^ k)) =
     inverse (f 0) + (\<Sum>k<pred_numeral n. inverse (f (k+1)) * inverse (x^k)) / x"
  "(\<Sum>k<Suc 0. inverse (f k) * inverse (x^k)) = inverse (f 0 :: 'a :: field)"
  "(\<Sum>k<(0::nat). inverse (f k) * inverse (x^k)) = 0"
proof -
  {
    fix m :: nat
    have "(\<Sum>k<Suc m. inverse (f k * x^k)) =
             inverse (f 0) + (\<Sum>k=Suc 0..<Suc m. inverse (f k * x^k))"
      by (subst atLeast0LessThan [symmetric], subst sum_head_upt_Suc) simp_all
    also have "(\<Sum>k=Suc 0..<Suc m. inverse (f k * x^k)) = (\<Sum>k<m. inverse (f (k+1) * x^k)) / x"
      by (subst sum_shift_bounds_Suc_ivl)
         (simp add: sum_distrib_left divide_inverse algebra_simps
                    atLeast0LessThan power_commutes)
    finally have "(\<Sum>k<Suc m. inverse (f k) * inverse (x ^ k)) =
                      inverse (f 0) + (\<Sum>k<m. inverse (f (k + 1)) * inverse (x ^ k)) / x" by simp
  }
  from this[of "pred_numeral n"]
    show "(\<Sum>k<numeral n. inverse (f k) * inverse (x^k)) =
            inverse (f 0) + (\<Sum>k<pred_numeral n. inverse (f (k+1)) * inverse (x^k)) / x"
    by (simp add: numeral_eq_Suc)
qed simp_all

lemma arctan_diff_small:
  assumes "\<bar>x*y::real\<bar> < 1"
  shows   "arctan x - arctan y = arctan ((x - y) / (1 + x * y))"
proof -
  have "arctan x - arctan y = arctan x + arctan (-y)" by (simp add: arctan_minus)
  also from assms have "\<dots> = arctan ((x - y) / (1 + x * y))" by (subst arctan_add_small) simp_all
  finally show ?thesis .
qed

subsubsection \<open>Machin-like formulae for pi\<close>

text \<open>
  We first define a small proof method that can prove Machin-like formulae for @{term "pi"}
  automatically. Unfortunately, this takes far too much time for larger formulae because
  the numbers involved become too large.
\<close>

definition "MACHIN_TAG a b \<equiv> a * (b::real)"

lemma numeral_horner_MACHIN_TAG:
  "MACHIN_TAG Numeral1 x = x"
  "MACHIN_TAG (numeral (Num.Bit0 (Num.Bit0 n))) x =
     MACHIN_TAG 2 (MACHIN_TAG (numeral (Num.Bit0 n)) x)"
  "MACHIN_TAG (numeral (Num.Bit0 (Num.Bit1 n))) x =
     MACHIN_TAG 2 (MACHIN_TAG (numeral (Num.Bit1 n)) x)"
  "MACHIN_TAG (numeral (Num.Bit1 n)) x =
     MACHIN_TAG 2 (MACHIN_TAG (numeral n) x) + x"
  unfolding numeral_Bit0 numeral_Bit1 ring_distribs one_add_one[symmetric] MACHIN_TAG_def
     by (simp_all add: algebra_simps)

lemma tag_machin: "a * arctan b = MACHIN_TAG a (arctan b)" by (simp add: MACHIN_TAG_def)

lemma arctan_double': "\<bar>a::real\<bar> < 1 \<Longrightarrow> MACHIN_TAG 2 (arctan a) = arctan (2 * a / (1 - a*a))"
  unfolding MACHIN_TAG_def by (simp add: arctan_double power2_eq_square)

ML \<open>
  fun machin_term_conv ctxt ct =
    let
      val ctxt' = ctxt addsimps @{thms arctan_double' arctan_add_small}
    in
      case Thm.term_of ct of
        Const (@{const_name MACHIN_TAG}, _) $ _ $
          (Const (@{const_name "Transcendental.arctan"}, _) $ _) =>
          Simplifier.rewrite ctxt' ct
      |
        Const (@{const_name MACHIN_TAG}, _) $ _ $
          (Const (@{const_name "Groups.plus"}, _) $
            (Const (@{const_name "Transcendental.arctan"}, _) $ _) $
            (Const (@{const_name "Transcendental.arctan"}, _) $ _)) =>
          Simplifier.rewrite ctxt' ct
      | _ => raise CTERM ("machin_conv", [ct])
    end

  fun machin_tac ctxt =
    let val conv = Conv.top_conv (Conv.try_conv o machin_term_conv) ctxt
    in
      SELECT_GOAL (
        Local_Defs.unfold_tac ctxt
          @{thms tag_machin[THEN eq_reflection] numeral_horner_MACHIN_TAG[THEN eq_reflection]}
        THEN REPEAT (CHANGED (HEADGOAL (CONVERSION conv))))
      THEN' Simplifier.simp_tac (ctxt addsimps @{thms arctan_add_small arctan_diff_small})
    end
\<close>

method_setup machin = \<open>Scan.succeed (SIMPLE_METHOD' o machin_tac)\<close>

text \<open>
  We can now prove the ``standard'' Machin formula, which was already proven manually
  in Isabelle, automatically.
}\<close>
lemma "pi / 4 = (4::real) * arctan (1 / 5) - arctan (1 / 239)"
  by machin

text \<open>
  We can also prove the following more complicated formula:
\<close>
lemma machin': "pi/4 = (12::real) * arctan (1/18) + 8 * arctan (1/57) - 5 * arctan (1/239)"
  by machin

subsubsection \<open>Simple approximation of pi\<close>

text \<open>
  We can use the simple Machin formula and the Taylor series expansion of the arctangent
  to approximate pi. For a given even natural number $n$, we expand @{term "arctan (1/5)"}
  to $3n$ summands and @{term "arctan (1/239)"} to $n$ summands. This gives us at least
  $13n-2$ bits of precision.
\<close>

definition "pi_approx n = 16 * arctan_approx (3*n) (1/5) - 4 * arctan_approx n (1/239)"

lemma pi_approx:
  fixes n :: nat assumes n: "even n" and "n > 0"
  shows   "\<bar>pi - pi_approx n\<bar> \<le> inverse (2^(13*n - 2))"
proof -
  from n have n': "even (3*n)" by simp
  \<comment> \<open>We apply the Machin formula\<close>
  from machin have "pi = 16 * arctan (1/5) - 4 * arctan (1/239::real)" by simp
  \<comment> \<open>Taylor series expansion of the arctangent\<close>
  also from arctan_approx[OF _ _ n', of "1/5"] arctan_approx[OF _ _ n, of "1/239"]
    have "\<dots> - pi_approx n \<in> {-4*((1/239)^(2*n+1) / (1-(1/239)^4))..16*(1/5)^(6*n+1) / (1-(1/5)^4)}"
    by (simp add: pi_approx_def)
  \<comment> \<open>Coarsening the bounds to make them a bit nicer\<close>
  also have "-4*((1/239::real)^(2*n+1) / (1-(1/239)^4)) = -((13651919 / 815702160) / 57121^n)"
    by (simp add: power_mult power2_eq_square) (simp add: field_simps)
  also have "16*(1/5)^(6*n+1) / (1-(1/5::real)^4) = (125/39) / 15625^n"
    by (simp add: power_mult power2_eq_square) (simp add: field_simps)
  also have "{-((13651919 / 815702160) / 57121^n) .. (125 / 39) / 15625^n} \<subseteq>
               {- (4 / 2^(13*n)) .. 4 / (2^(13*n)::real)}"
    by (subst atLeastatMost_subset_iff, intro disjI2 conjI le_imp_neg_le)
       (rule frac_le; simp add: power_mult power_mono)+
  finally have "abs (pi - pi_approx n) \<le> 4 / 2^(13*n)" by auto
  also from \<open>n > 0\<close> have "4 / 2^(13*n) = 1 / (2^(13*n - 2) :: real)"
    by (cases n) (simp_all add: power_add)
  finally show ?thesis by (simp add: divide_inverse)
qed

lemma pi_approx':
  fixes n :: nat assumes n: "even n" and "n > 0" and "k \<le> 13*n - 2"
  shows   "\<bar>pi - pi_approx n\<bar> \<le> inverse (2^k)"
  using assms(3) by (intro order.trans[OF pi_approx[OF assms(1,2)]]) (simp_all add: field_simps)

text \<open>We can now approximate pi to 22 decimals within a fraction of a second.\<close>
lemma pi_approx_75: "abs (pi - 3.1415926535897932384626 :: real) \<le> inverse (10^22)"
proof -
  define a :: real
    where "a = 8295936325956147794769600190539918304 / 2626685325478320010006427764892578125"
  define b :: real
    where "b = 8428294561696506782041394632 / 503593538783547230635598424135"
  \<comment> \<open>The introduction of this constant prevents the simplifier from applying solvers that
      we don't want. We want it to simply evaluate the terms to rational constants.}\<close>
  define eq :: "real \<Rightarrow> real \<Rightarrow> bool" where "eq = op ="

  \<comment> \<open>Splitting the computation into several steps has the advantage that simplification can
      be done in parallel\<close>
  have "abs (pi - pi_approx 6) \<le> inverse (2^76)" by (rule pi_approx') simp_all
  also have "pi_approx 6 = 16 * arctan_approx (3 * 6) (1 / 5) - 4 * arctan_approx 6 (1 / 239)"
    unfolding pi_approx_def by simp
  also have [unfolded eq_def]: "eq (16 * arctan_approx (3 * 6) (1 / 5)) a"
    by (simp add: arctan_approx_def' power2_eq_square,
        simp add: expand_arctan_approx, unfold a_def eq_def, rule refl)
  also have [unfolded eq_def]: "eq (4 * arctan_approx 6 (1 / 239::real)) b"
    by (simp add: arctan_approx_def' power2_eq_square,
        simp add: expand_arctan_approx, unfold b_def eq_def, rule refl)
  also have [unfolded eq_def]:
    "eq (a - b) (171331331860120333586637094112743033554946184594977368554649608 /
                 54536456744112171868276045488779391002026386559009552001953125)"
    by (unfold a_def b_def, simp, unfold eq_def, rule refl)
  finally show ?thesis by (rule approx_coarsen) simp
qed

text \<open>
  The previous estimate of pi in this file was based on approximating the root of the
  $\sin(\pi/6)$ in the interval $[0;4]$ using the Taylor series expansion of the sine to
  verify that it is between two given bounds.
  This was much slower and much less precise. We can easily recover this coarser estimate from
  the newer, precise estimate:
\<close>
lemma pi_approx_32: "\<bar>pi - 13493037705/4294967296 :: real\<bar> \<le> inverse(2 ^ 32)"
  by (rule approx_coarsen[OF pi_approx_75]) simp

subsection \<open>A more complicated approximation of pi\<close>

text \<open>
  There are more complicated Machin-like formulae that have more terms with larger
  denominators. Although they have more terms, each term requires fewer summands of the
  Taylor series for the same precision, since it is evaluated closer to $0$.

  Using a good formula, one can therefore obtain the same precision with fewer operations.
  The big formulae used for computations of pi in practice are too complicated for us to
  prove here, but we can use the three-term Machin-like formula @{thm machin'}.
\<close>

definition "pi_approx2 n = 48 * arctan_approx (6*n) (1/18::real) +
                             32 * arctan_approx (4*n) (1/57) - 20 * arctan_approx (3*n) (1/239)"

lemma pi_approx2:
  fixes n :: nat assumes n: "even n" and "n > 0"
  shows   "\<bar>pi - pi_approx2 n\<bar> \<le> inverse (2^(46*n - 1))"
proof -
  from n have n': "even (6*n)" "even (4*n)" "even (3*n)" by simp_all
  from machin' have "pi = 48 * arctan (1/18) + 32 * arctan (1/57) - 20 * arctan (1/239::real)"
    by simp
  hence "pi - pi_approx2 n = 48 * (arctan (1/18) - arctan_approx (6*n) (1/18)) +
                                 32 * (arctan (1/57) - arctan_approx (4*n) (1/57)) -
                                 20 * (arctan (1/239) - arctan_approx (3*n) (1/239))"
    by (simp add: pi_approx2_def)
  also have "\<dots> \<in> {-((20/239/(1-(1/239)^4)) * (1/239)^(6*n))..
              (48/18 / (1-(1/18)^4))*(1/18)^(12*n) + (32/57/(1-(1/57)^4)) * (1/57)^(8*n)}"
    (is "_ \<in> {-?l..?u1 + ?u2}")
    apply ((rule combine_bounds(1,2))+; (rule combine_bounds(3); (rule arctan_approx)?)?)
    apply (simp_all add: n)
    apply (simp_all add: divide_simps)?
    done
  also {
    have "?l \<le> (1/8) * (1/2)^(46*n)"
      unfolding power_mult by (intro mult_mono power_mono) (simp_all add: divide_simps)
    also have "\<dots> \<le> (1/2) ^ (46 * n - 1)"
      by (cases n; simp_all add: power_add divide_simps)
    finally have "?l \<le> (1/2) ^ (46 * n - 1)" .
    moreover {
      have "?u1 + ?u2 \<le> 4 * (1/2)^(48*n) + 1 * (1/2)^(46*n)"
        unfolding power_mult by (intro add_mono mult_mono power_mono) (simp_all add: divide_simps)
      also from \<open>n > 0\<close> have "4 * (1/2::real)^(48*n) \<le> (1/2)^(46*n)"
        by (cases n) (simp_all add: field_simps power_add)
      also from \<open>n > 0\<close> have "(1/2::real) ^ (46 * n) + 1 * (1 / 2) ^ (46 * n) = (1/2) ^ (46 * n - 1)"
        by (cases n; simp_all add: power_add power_divide)
      finally have "?u1 + ?u2 \<le> (1/2) ^ (46 * n - 1)" by - simp
    }
    ultimately have "{-?l..?u1 + ?u2} \<subseteq> {-((1/2)^(46*n-1))..(1/2)^(46*n-1)}"
      by (subst atLeastatMost_subset_iff) simp_all
  }
  finally have "\<bar>pi - pi_approx2 n\<bar> \<le> ((1/2) ^ (46 * n - 1))" by auto
  thus ?thesis by (simp add: divide_simps)
qed

lemma pi_approx2':
  fixes n :: nat assumes n: "even n" and "n > 0" and "k \<le> 46*n - 1"
  shows   "\<bar>pi - pi_approx2 n\<bar> \<le> inverse (2^k)"
  using assms(3) by (intro order.trans[OF pi_approx2[OF assms(1,2)]]) (simp_all add: field_simps)

text \<open>
  We can now approximate pi to 54 decimals using this formula. The computations are much
  slower now; this is mostly because we use arbitrary-precision rational numbers, whose
  numerators and demoninators get very large. Using dyadic floating point numbers would be
  much more economical.
\<close>
lemma pi_approx_54_decimals:
  "abs (pi - 3.141592653589793238462643383279502884197169399375105821 :: real) \<le> inverse (10^54)"
  (is "abs (pi - ?pi') \<le> _")
proof -
  define a :: real
    where "a = 2829469759662002867886529831139137601191652261996513014734415222704732791803 /
           1062141879292765061960538947347721564047051545995266466660439319087625011200"
  define b :: real
    where "b = 13355545553549848714922837267299490903143206628621657811747118592 /
           23792006023392488526789546722992491355941103837356113731091180925"
  define c :: real
    where "c = 28274063397213534906669125255762067746830085389618481175335056 /
           337877029279505250241149903214554249587517250716358486542628059"
  let ?pi'' = "3882327391761098513316067116522233897127356523627918964967729040413954225768920394233198626889767468122598417405434625348404038165437924058179155035564590497837027530349 /
               1235783190199688165469648572769847552336447197542738425378629633275352407743112409829873464564018488572820294102599160968781449606552922108667790799771278860366957772800"
  define eq :: "real \<Rightarrow> real \<Rightarrow> bool" where "eq = op ="

  have "abs (pi - pi_approx2 4) \<le> inverse (2^183)" by (rule pi_approx2') simp_all
  also have "pi_approx2 4 = 48 * arctan_approx 24 (1 / 18) +
                            32 * arctan_approx 16 (1 / 57) -
                            20 * arctan_approx 12 (1 / 239)"
    unfolding pi_approx2_def by simp
  also have [unfolded eq_def]: "eq (48 * arctan_approx 24 (1 / 18)) a"
    by (simp add: arctan_approx_def' power2_eq_square,
        simp add: expand_arctan_approx, unfold a_def eq_def, rule refl)
  also have [unfolded eq_def]: "eq (32 * arctan_approx 16 (1 / 57::real)) b"
    by (simp add: arctan_approx_def' power2_eq_square,
        simp add: expand_arctan_approx, unfold b_def eq_def, rule refl)
  also have [unfolded eq_def]: "eq (20 * arctan_approx 12 (1 / 239::real)) c"
    by (simp add: arctan_approx_def' power2_eq_square,
        simp add: expand_arctan_approx, unfold c_def eq_def, rule refl)
  also have [unfolded eq_def]:
    "eq (a + b) (34326487387865555303797183505809267914709125998469664969258315922216638779011304447624792548723974104030355722677 /
                 10642967245546718617684989689985787964158885991018703366677373121531695267093031090059801733340658960857196134400)"
    by (unfold a_def b_def c_def, simp, unfold eq_def, rule refl)
  also have [unfolded eq_def]: "eq (\<dots> - c) ?pi''"
    by (unfold a_def b_def c_def, simp, unfold eq_def, rule refl)
  \<comment> \<open>This is incredibly slow because the numerators and denominators are huge.\<close>
  finally show ?thesis by (rule approx_coarsen) simp
qed

text \<open>A 128 bit approximation of pi:\<close>
lemma pi_approx_128:
  "abs (pi - 1069028584064966747859680373161870783301 / 2^128) \<le> inverse (2^128)"
  by (rule approx_coarsen[OF pi_approx_54_decimals]) simp

text \<open>A 64 bit approximation of pi:\<close>
lemma pi_approx_64:
  "abs (pi - 57952155664616982739 / 2^64 :: real) \<le> inverse (2^64)"
  by (rule approx_coarsen[OF pi_approx_54_decimals]) simp

text \<open>
  Again, going much farther with the simplifier takes a long time, but the code generator
  can handle even two thousand decimal digits in under 20 seconds.
\<close>

end