section\<open>Forcing notions\<close>
text\<open>This theory defines a locale for forcing notions, that is,
 preorders with a distinguished maximum element.\<close>

theory Forcing_Notions
  imports
    "ZF-Constructible.Relative"
    "Delta_System_Lemma.ZF_Library"
begin

hide_const (open) Order.pred

subsection\<open>Basic concepts\<close>
text\<open>We say that two elements $p,q$ are
  \<^emph>\<open>compatible\<close> if they have a lower bound in $P$\<close>
definition compat_in :: "i\<Rightarrow>i\<Rightarrow>i\<Rightarrow>i\<Rightarrow>o" where
  "compat_in(A,r,p,q) \<equiv> \<exists>d\<in>A . \<langle>d,p\<rangle>\<in>r \<and> \<langle>d,q\<rangle>\<in>r"

lemma compat_inI :
  "\<lbrakk> d\<in>A ; \<langle>d,p\<rangle>\<in>r ; \<langle>d,g\<rangle>\<in>r \<rbrakk> \<Longrightarrow> compat_in(A,r,p,g)"
  by (auto simp add: compat_in_def)

lemma refl_compat:
  "\<lbrakk> refl(A,r) ; \<langle>p,q\<rangle> \<in> r | p=q | \<langle>q,p\<rangle> \<in> r ; p\<in>A ; q\<in>A\<rbrakk> \<Longrightarrow> compat_in(A,r,p,q)"
  by (auto simp add: refl_def compat_inI)

lemma  chain_compat:
  "refl(A,r) \<Longrightarrow> linear(A,r) \<Longrightarrow>  (\<forall>p\<in>A.\<forall>q\<in>A. compat_in(A,r,p,q))"
  by (simp add: refl_compat linear_def)

lemma subset_fun_image: "f:N\<rightarrow>P \<Longrightarrow> f``N\<subseteq>P"
  by (auto simp add: image_fun apply_funtype)

lemma refl_monot_domain: "refl(B,r) \<Longrightarrow> A\<subseteq>B \<Longrightarrow> refl(A,r)"
  unfolding refl_def by blast

locale forcing_notion =
  fixes P (\<open>\<bbbP>\<close>) and leq and one (\<open>\<one>\<close>)
  assumes one_in_P:       "\<one> \<in> \<bbbP>"
    and leq_preord:       "preorder_on(\<bbbP>,leq)"
    and one_max:          "\<forall>p\<in>\<bbbP>. \<langle>p,\<one>\<rangle>\<in>leq"
begin

abbreviation Leq :: "[i, i] \<Rightarrow> o"  (infixl "\<preceq>" 50)
  where "x \<preceq> y \<equiv> \<langle>x,y\<rangle>\<in>leq"

lemma refl_leq:
  "r\<in>\<bbbP> \<Longrightarrow> r\<preceq>r"
  using leq_preord unfolding preorder_on_def refl_def by simp

text\<open>A set $D$ is \<^emph>\<open>dense\<close> if every element $p\in \mathbb{P}$ has a lower
bound in $D$.\<close>
definition
  dense :: "i\<Rightarrow>o" where
  "dense(D) \<equiv> \<forall>p\<in>\<bbbP>. \<exists>d\<in>D . d\<preceq>p"

text\<open>There is also a weaker definition which asks for
a lower bound in $D$ only for the elements below some fixed
element $q$.\<close>
definition
  dense_below :: "i\<Rightarrow>i\<Rightarrow>o" where
  "dense_below(D,q) \<equiv> \<forall>p\<in>\<bbbP>. p\<preceq>q \<longrightarrow> (\<exists>d\<in>D. d\<in>\<bbbP> \<and> d\<preceq>p)"

lemma P_dense: "dense(\<bbbP>)"
  by (insert leq_preord, auto simp add: preorder_on_def refl_def dense_def)

definition
  increasing :: "i\<Rightarrow>o" where
  "increasing(F) \<equiv> \<forall>x\<in>F. \<forall> p \<in> \<bbbP> . x\<preceq>p \<longrightarrow> p\<in>F"

definition
  compat :: "i\<Rightarrow>i\<Rightarrow>o" where
  "compat(p,q) \<equiv> compat_in(\<bbbP>,leq,p,q)"

lemma leq_transD:  "a\<preceq>b \<Longrightarrow> b\<preceq>c \<Longrightarrow> a \<in> \<bbbP>\<Longrightarrow> b \<in> \<bbbP>\<Longrightarrow> c \<in> \<bbbP>\<Longrightarrow> a\<preceq>c"
  using leq_preord trans_onD unfolding preorder_on_def by blast

lemma leq_transD':  "A\<subseteq>\<bbbP> \<Longrightarrow> a\<preceq>b \<Longrightarrow> b\<preceq>c \<Longrightarrow> a \<in> A \<Longrightarrow> b \<in> \<bbbP>\<Longrightarrow> c \<in> \<bbbP>\<Longrightarrow> a\<preceq>c"
  using leq_preord trans_onD subsetD unfolding preorder_on_def by blast

lemma compatD[dest!]: "compat(p,q) \<Longrightarrow> \<exists>d\<in>\<bbbP>. d\<preceq>p \<and> d\<preceq>q"
  unfolding compat_def compat_in_def .

abbreviation Incompatible :: "[i, i] \<Rightarrow> o"  (infixl "\<bottom>" 50)
  where "p \<bottom> q \<equiv> \<not> compat(p,q)"

lemma compatI[intro!]: "d\<in>\<bbbP> \<Longrightarrow> d\<preceq>p \<Longrightarrow> d\<preceq>q \<Longrightarrow> compat(p,q)"
  unfolding compat_def compat_in_def by blast

lemma Incompatible_imp_not_eq: "\<lbrakk> p \<bottom> q; p\<in>\<bbbP>; q\<in>\<bbbP> \<rbrakk>\<Longrightarrow> p \<noteq> q"
  using refl_leq by blast

lemma denseD [dest]: "dense(D) \<Longrightarrow> p\<in>\<bbbP> \<Longrightarrow>  \<exists>d\<in>D. d\<preceq> p"
  unfolding dense_def by blast

lemma denseI [intro!]: "\<lbrakk> \<And>p. p\<in>\<bbbP> \<Longrightarrow> \<exists>d\<in>D. d\<preceq> p \<rbrakk> \<Longrightarrow> dense(D)"
  unfolding dense_def by blast

lemma dense_belowD [dest]:
  assumes "dense_below(D,p)" "q\<in>\<bbbP>" "q\<preceq>p"
  shows "\<exists>d\<in>D. d\<in>\<bbbP> \<and> d\<preceq>q"
  using assms unfolding dense_below_def by simp

lemma dense_belowI [intro!]:
  assumes "\<And>q. q\<in>\<bbbP> \<Longrightarrow> q\<preceq>p \<Longrightarrow> \<exists>d\<in>D. d\<in>\<bbbP> \<and> d\<preceq>q"
  shows "dense_below(D,p)"
  using assms unfolding dense_below_def by simp

lemma dense_below_cong: "p\<in>\<bbbP> \<Longrightarrow> D = D' \<Longrightarrow> dense_below(D,p) \<longleftrightarrow> dense_below(D',p)"
  by blast

lemma dense_below_cong': "p\<in>\<bbbP> \<Longrightarrow> \<lbrakk>\<And>x. x\<in>\<bbbP> \<Longrightarrow> Q(x) \<longleftrightarrow> Q'(x)\<rbrakk> \<Longrightarrow>
           dense_below({q\<in>\<bbbP>. Q(q)},p) \<longleftrightarrow> dense_below({q\<in>\<bbbP>. Q'(q)},p)"
  by blast

lemma dense_below_mono: "p\<in>\<bbbP> \<Longrightarrow> D \<subseteq> D' \<Longrightarrow> dense_below(D,p) \<Longrightarrow> dense_below(D',p)"
  by blast

lemma dense_below_under:
  assumes "dense_below(D,p)" "p\<in>\<bbbP>" "q\<in>\<bbbP>" "q\<preceq>p"
  shows "dense_below(D,q)"
  using assms leq_transD by blast

lemma ideal_dense_below:
  assumes "\<And>q. q\<in>\<bbbP> \<Longrightarrow> q\<preceq>p \<Longrightarrow> q\<in>D"
  shows "dense_below(D,p)"
  using assms refl_leq by blast

lemma dense_below_dense_below:
  assumes "dense_below({q\<in>\<bbbP>. dense_below(D,q)},p)" "p\<in>\<bbbP>"
  shows "dense_below(D,p)"
  using assms leq_transD refl_leq  by blast

text\<open>A filter is an increasing set $G$ with all its elements
being compatible in $G$.\<close>
definition
  filter :: "i\<Rightarrow>o" where
  "filter(G) \<equiv> G\<subseteq>\<bbbP> \<and> increasing(G) \<and> (\<forall>p\<in>G. \<forall>q\<in>G. compat_in(G,leq,p,q))"

lemma filterD : "filter(G) \<Longrightarrow> x \<in> G \<Longrightarrow> x \<in> \<bbbP>"
  by (auto simp add : subsetD filter_def)

lemma filter_subset_notion[dest]: "filter(G) \<Longrightarrow> G \<subseteq> \<bbbP>"
  by (auto dest:filterD)

lemma filter_leqD : "filter(G) \<Longrightarrow> x \<in> G \<Longrightarrow> y \<in> \<bbbP> \<Longrightarrow> x\<preceq>y \<Longrightarrow> y \<in> G"
  by (simp add: filter_def increasing_def)

lemma filter_imp_compat: "filter(G) \<Longrightarrow> p\<in>G \<Longrightarrow> q\<in>G \<Longrightarrow> compat(p,q)"
  unfolding filter_def compat_in_def compat_def by blast

lemma low_bound_filter: \<comment> \<open>says the compatibility is attained inside G\<close>
  assumes "filter(G)" and "p\<in>G" and "q\<in>G"
  shows "\<exists>r\<in>G. r\<preceq>p \<and> r\<preceq>q"
  using assms
  unfolding compat_in_def filter_def by blast

text\<open>We finally introduce the upward closure of a set
and prove that the closure of $A$ is a filter if its elements are
compatible in $A$.\<close>
definition
  upclosure :: "i\<Rightarrow>i" where
  "upclosure(A) \<equiv> {p\<in>\<bbbP>.\<exists>a\<in>A. a\<preceq>p}"

lemma  upclosureI [intro] : "p\<in>\<bbbP> \<Longrightarrow> a\<in>A \<Longrightarrow> a\<preceq>p \<Longrightarrow> p\<in>upclosure(A)"
  by (simp add:upclosure_def, auto)

lemma  upclosureE [elim] :
  "p\<in>upclosure(A) \<Longrightarrow> (\<And>x a. x\<in>\<bbbP> \<Longrightarrow> a\<in>A \<Longrightarrow> a\<preceq>x \<Longrightarrow> R) \<Longrightarrow> R"
  by (auto simp add:upclosure_def)

lemma  upclosureD [dest] :
  "p\<in>upclosure(A) \<Longrightarrow> \<exists>a\<in>A.(a\<preceq>p) \<and> p\<in>\<bbbP>"
  by (simp add:upclosure_def)

lemma upclosure_increasing :
  assumes "A\<subseteq>\<bbbP>"
  shows "increasing(upclosure(A))"
  unfolding increasing_def upclosure_def
  using leq_transD'[OF \<open>A\<subseteq>\<bbbP>\<close>] by auto

lemma  upclosure_in_P: "A \<subseteq> \<bbbP> \<Longrightarrow> upclosure(A) \<subseteq> \<bbbP>"
  using subsetI upclosure_def by simp

lemma  A_sub_upclosure: "A \<subseteq> \<bbbP> \<Longrightarrow> A\<subseteq>upclosure(A)"
  using subsetI leq_preord
  unfolding upclosure_def preorder_on_def refl_def by auto

lemma  elem_upclosure: "A\<subseteq>\<bbbP> \<Longrightarrow> x\<in>A  \<Longrightarrow> x\<in>upclosure(A)"
  by (blast dest:A_sub_upclosure)

lemma  closure_compat_filter:
  assumes "A\<subseteq>\<bbbP>" "(\<forall>p\<in>A.\<forall>q\<in>A. compat_in(A,leq,p,q))"
  shows "filter(upclosure(A))"
  unfolding filter_def
proof(auto)
  show "increasing(upclosure(A))"
    using assms upclosure_increasing by simp
next
  let ?UA="upclosure(A)"
  show "compat_in(upclosure(A), leq, p, q)" if "p\<in>?UA" "q\<in>?UA" for p q
  proof -
    from that
    obtain a b where 1:"a\<in>A" "b\<in>A" "a\<preceq>p" "b\<preceq>q" "p\<in>\<bbbP>" "q\<in>\<bbbP>"
      using upclosureD[OF \<open>p\<in>?UA\<close>] upclosureD[OF \<open>q\<in>?UA\<close>] by auto
    with assms(2)
    obtain d where "d\<in>A" "d\<preceq>a" "d\<preceq>b"
      unfolding compat_in_def by auto
    with 1
    have "d\<preceq>p" "d\<preceq>q" "d\<in>?UA"
      using A_sub_upclosure[THEN subsetD] \<open>A\<subseteq>\<bbbP>\<close>
        leq_transD'[of A d a] leq_transD'[of A d b] by auto
    then
    show ?thesis unfolding compat_in_def by auto
  qed
qed

lemma  aux_RS1:  "f \<in> N \<rightarrow> \<bbbP> \<Longrightarrow> n\<in>N \<Longrightarrow> f`n \<in> upclosure(f ``N)"
  using elem_upclosure[OF subset_fun_image] image_fun
  by (simp, blast)

lemma decr_succ_decr:
  assumes "f \<in> nat \<rightarrow> \<bbbP>" "preorder_on(\<bbbP>,leq)"
    "\<forall>n\<in>nat.  \<langle>f ` succ(n), f ` n\<rangle> \<in> leq"
    "m\<in>nat"
  shows "n\<in>nat \<Longrightarrow> n\<le>m \<Longrightarrow> \<langle>f ` m, f ` n\<rangle> \<in> leq"
  using \<open>m\<in>_\<close>
proof(induct m)
  case 0
  then show ?case using assms refl_leq by simp
next
  case (succ x)
  then
  have 1:"f`succ(x) \<preceq> f`x" "f`n\<in>\<bbbP>" "f`x\<in>\<bbbP>" "f`succ(x)\<in>\<bbbP>"
    using assms by simp_all
  consider (lt) "n<succ(x)" | (eq) "n=succ(x)"
    using succ le_succ_iff by auto
  then
  show ?case
  proof(cases)
    case lt
    with 1 show ?thesis using leI succ leq_transD by auto
  next
    case eq
    with 1 show ?thesis using refl_leq by simp
  qed
qed

lemma decr_seq_linear:
  assumes "refl(\<bbbP>,leq)" "f \<in> nat \<rightarrow> \<bbbP>"
    "\<forall>n\<in>nat.  \<langle>f ` succ(n), f ` n\<rangle> \<in> leq"
    "trans[\<bbbP>](leq)"
  shows "linear(f `` nat, leq)"
proof -
  have "preorder_on(\<bbbP>,leq)"
    unfolding preorder_on_def using assms by simp
  {
    fix n m
    assume "n\<in>nat" "m\<in>nat"
    then
    have "f`m \<preceq> f`n \<or> f`n \<preceq> f`m"
    proof(cases "m\<le>n")
      case True
      with \<open>n\<in>_\<close> \<open>m\<in>_\<close>
      show ?thesis
        using decr_succ_decr[of f n m] assms leI \<open>preorder_on(\<bbbP>,leq)\<close> by simp
    next
      case False
      with \<open>n\<in>_\<close> \<open>m\<in>_\<close>
      show ?thesis
        using decr_succ_decr[of f m n] assms leI not_le_iff_lt \<open>preorder_on(\<bbbP>,leq)\<close> by simp
    qed
  }
  then
  show ?thesis
    unfolding linear_def using ball_image_simp assms by auto
qed

end \<comment> \<open>\<^locale>\<open>forcing_notion\<close>\<close>

subsection\<open>Towards Rasiowa-Sikorski Lemma (RSL)\<close>
locale countable_generic = forcing_notion +
  fixes \<D>
  assumes countable_subs_of_P:  "\<D> \<in> nat\<rightarrow>Pow(\<bbbP>)"
    and     seq_of_denses:        "\<forall>n \<in> nat. dense(\<D>`n)"

begin

definition
  D_generic :: "i\<Rightarrow>o" where
  "D_generic(G) \<equiv> filter(G) \<and> (\<forall>n\<in>nat.(\<D>`n)\<inter>G\<noteq>0)"

text\<open>The next lemma identifies a sufficient condition for obtaining
RSL.\<close>
lemma RS_sequence_imp_rasiowa_sikorski:
  assumes
    "p\<in>\<bbbP>" "f : nat\<rightarrow>\<bbbP>" "f ` 0 = p"
    "\<And>n. n\<in>nat \<Longrightarrow> f ` succ(n)\<preceq> f ` n \<and> f ` succ(n) \<in> \<D> ` n"
  shows
    "\<exists>G. p\<in>G \<and> D_generic(G)"
proof -
  note assms
  moreover from this
  have "f``nat  \<subseteq> \<bbbP>"
    by (simp add:subset_fun_image)
  moreover from calculation
  have "refl(f``nat, leq) \<and> trans[\<bbbP>](leq)"
    using leq_preord unfolding preorder_on_def by (blast intro:refl_monot_domain)
  moreover from calculation
  have "\<forall>n\<in>nat.  f ` succ(n)\<preceq> f ` n" by (simp)
  moreover from calculation
  have "linear(f``nat, leq)"
    using leq_preord and decr_seq_linear unfolding preorder_on_def by (blast)
  moreover from calculation
  have "(\<forall>p\<in>f``nat.\<forall>q\<in>f``nat. compat_in(f``nat,leq,p,q))"
    using chain_compat by (auto)
  ultimately
  have "filter(upclosure(f``nat))" (is "filter(?G)")
    using closure_compat_filter by simp
  moreover
  have "\<forall>n\<in>nat. \<D> ` n \<inter> ?G \<noteq> 0"
  proof
    fix n
    assume "n\<in>nat"
    with assms
    have "f`succ(n) \<in> ?G \<and> f`succ(n) \<in> \<D> ` n"
      using aux_RS1 by simp
    then
    show "\<D> ` n \<inter> ?G \<noteq> 0"  by blast
  qed
  moreover from assms
  have "p \<in> ?G"
    using aux_RS1 by auto
  ultimately
  show ?thesis unfolding D_generic_def by auto
qed

end \<comment> \<open>\<^locale>\<open>countable_generic\<close>\<close>

text\<open>Now, the following recursive definition will fulfill the
requirements of lemma \<^term>\<open>RS_sequence_imp_rasiowa_sikorski\<close> \<close>

consts RS_seq :: "[i,i,i,i,i,i] \<Rightarrow> i"
primrec
  "RS_seq(0,P,leq,p,enum,\<D>) = p"
  "RS_seq(succ(n),P,leq,p,enum,\<D>) =
    enum`(\<mu> m. \<langle>enum`m, RS_seq(n,P,leq,p,enum,\<D>)\<rangle> \<in> leq \<and> enum`m \<in> \<D> ` n)"

context countable_generic
begin

lemma countable_RS_sequence_aux:
  fixes p enum
  defines "f(n) \<equiv> RS_seq(n,\<bbbP>,leq,p,enum,\<D>)"
    and   "Q(q,k,m) \<equiv> enum`m\<preceq> q \<and> enum`m \<in> \<D> ` k"
  assumes "n\<in>nat" "p\<in>\<bbbP>" "\<bbbP> \<subseteq> range(enum)" "enum:nat\<rightarrow>M"
    "\<And>x k. x\<in>\<bbbP> \<Longrightarrow> k\<in>nat \<Longrightarrow>  \<exists>q\<in>\<bbbP>. q\<preceq> x \<and> q \<in> \<D> ` k"
  shows
    "f(succ(n)) \<in> \<bbbP> \<and> f(succ(n))\<preceq> f(n) \<and> f(succ(n)) \<in> \<D> ` n"
  using \<open>n\<in>nat\<close>
proof (induct)
  case 0
  from assms
  obtain q where "q\<in>\<bbbP>" "q\<preceq> p" "q \<in> \<D> ` 0" by blast
  moreover from this and \<open>\<bbbP> \<subseteq> range(enum)\<close>
  obtain m where "m\<in>nat" "enum`m = q"
    using Pi_rangeD[OF \<open>enum:nat\<rightarrow>M\<close>] by blast
  moreover
  have "\<D>`0 \<subseteq> \<bbbP>"
    using apply_funtype[OF countable_subs_of_P] by simp
  moreover note \<open>p\<in>\<bbbP>\<close>
  ultimately
  show ?case
    using LeastI[of "Q(p,0)" m] unfolding Q_def f_def by auto
next
  case (succ n)
  with assms
  obtain q where "q\<in>\<bbbP>" "q\<preceq> f(succ(n))" "q \<in> \<D> ` succ(n)" by blast
  moreover from this and \<open>\<bbbP> \<subseteq> range(enum)\<close>
  obtain m where "m\<in>nat" "enum`m\<preceq> f(succ(n))" "enum`m \<in> \<D> ` succ(n)"
    using Pi_rangeD[OF \<open>enum:nat\<rightarrow>M\<close>] by blast
  moreover note succ
  moreover from calculation
  have "\<D>`succ(n) \<subseteq> \<bbbP>"
    using apply_funtype[OF countable_subs_of_P] by auto
  ultimately
  show ?case
    using LeastI[of "Q(f(succ(n)),succ(n))" m] unfolding Q_def f_def by auto
qed

lemma countable_RS_sequence:
  fixes p enum
  defines "f \<equiv> \<lambda>n\<in>nat. RS_seq(n,\<bbbP>,leq,p,enum,\<D>)"
    and   "Q(q,k,m) \<equiv> enum`m\<preceq> q \<and> enum`m \<in> \<D> ` k"
  assumes "n\<in>nat" "p\<in>\<bbbP>" "\<bbbP> \<subseteq> range(enum)" "enum:nat\<rightarrow>M"
  shows
    "f`0 = p" "f`succ(n)\<preceq> f`n \<and> f`succ(n) \<in> \<D> ` n" "f`succ(n) \<in> \<bbbP>"
proof -
  from assms
  show "f`0 = p" by simp
  {
    fix x k
    assume "x\<in>\<bbbP>" "k\<in>nat"
    then
    have "\<exists>q\<in>\<bbbP>. q\<preceq> x \<and> q \<in> \<D> ` k"
      using seq_of_denses apply_funtype[OF countable_subs_of_P]
      unfolding dense_def by blast
  }
  with assms
  show "f`succ(n)\<preceq> f`n \<and> f`succ(n) \<in> \<D> ` n" "f`succ(n)\<in>\<bbbP>"
    unfolding f_def using countable_RS_sequence_aux by simp_all
qed

lemma RS_seq_type:
  assumes "n \<in> nat" "p\<in>\<bbbP>" "\<bbbP> \<subseteq> range(enum)" "enum:nat\<rightarrow>M"
  shows "RS_seq(n,\<bbbP>,leq,p,enum,\<D>) \<in> \<bbbP>"
  using assms countable_RS_sequence(1,3)
  by (induct;simp)

lemma RS_seq_funtype:
  assumes "p\<in>\<bbbP>" "\<bbbP> \<subseteq> range(enum)" "enum:nat\<rightarrow>M"
  shows "(\<lambda>n\<in>nat. RS_seq(n,\<bbbP>,leq,p,enum,\<D>)): nat \<rightarrow> \<bbbP>"
  using assms lam_type RS_seq_type by auto

lemmas countable_rasiowa_sikorski =
  RS_sequence_imp_rasiowa_sikorski[OF _ RS_seq_funtype countable_RS_sequence(1,2)]

end \<comment> \<open>\<^locale>\<open>countable_generic\<close>\<close>

end


theory EdmondsKarp_Algo
imports EdmondsKarp_Maxflow.EdmondsKarp_Termination_Abstract FordFulkerson_Algo
begin
text \<open>
  In this theory, we formalize an abstract version of
  Edmonds-Karp algorithm, which we obtain by refining the
  Ford-Fulkerson algorithm to always use shortest augmenting paths.

  Then, we show that the algorithm always terminates within $O(VE)$ iterations.
\<close>

subsection \<open>Algorithm\<close>

locale EdKa = Network c s t for c :: "'capacity::linordered_idom graph" and s t +
  fixes shortestpath_time :: nat
    and augment_with_path_time :: nat
     and init_graph :: "nat \<Rightarrow> nat"
  assumes augment_progress: "0 \<noteq> enat shortestpath_time"
begin

text \<open>First, we specify the refined procedure for finding augmenting paths\<close>
definition "find_shortest_augmenting_spec f \<equiv> ASSERT (NFlow c s t f) \<then>
  SELECT (\<lambda>p. Graph.isShortestPath (residualGraph c f) s p t) (shortestpath_time)"

definition edka_measure :: "(nat \<times> nat \<Rightarrow> 'capacity) \<Rightarrow> nat" where
  "edka_measure cf = ek_analysis_defs.ekMeasure (residualGraph c cf) s t"

definition info :: "(nat \<times> nat \<Rightarrow> 'capacity) \<Rightarrow> (nat \<times> nat) list \<Rightarrow> bool" where
  "info f p =  Graph.isShortestPath (residualGraph c f) s p t"

lemma  edka_measure_decreases:
  assumes "NFlow c s t a"
      "NPreflow.isAugmentingPath c s t a x"
      "info  a x"
  shows "edka_measure (NFlow.augment_with_path c a x) < edka_measure a"
proof -
  have 2: "Graph.isShortestPath (cf_of a) s x t"
    using assms(3) unfolding info_def  by simp

  show "edka_measure (NFlow.augment_with_path c a x) < edka_measure a"
  unfolding edka_measure_def
  using NFlow.shortest_path_decr_ek_measure[OF assms(1) 2]
    NFlow.augment_with_path_def[OF assms(1) ] by auto
qed

lemma augments: "\<And>f p. NFlow c s t f \<Longrightarrow> info f p \<Longrightarrow> NPreflow.isAugmentingPath c s t f p"
  unfolding info_def using  NFlow.shortest_is_augmenting by blast

print_locale FoFu

definition (in -) edka_time_aux   where
  "edka_time_aux shortestpath_time augment_with_path_time init_graph cE cV  = init_graph cV +  (shortestpath_time+augment_with_path_time) * (2 * cV * cE + cV + 1)"

interpretation edka: FoFu c s t "edka_measure:: (nat \<times> nat \<Rightarrow> 'capacity) \<Rightarrow> nat" shortestpath_time augment_with_path_time "init_graph (card V)" "info :: (nat \<times> nat \<Rightarrow> 'capacity) \<Rightarrow> (nat \<times> nat) list \<Rightarrow> bool"
  apply standard
  subgoal using NFlow.augmenting_path_imp_shortest info_def by blast
  subgoal using edka_measure_decreases info_def augments by simp
  subgoal using augment_progress by simp
  subgoal using augments by blast
  done

text \<open>We show that our refined procedure is actually a refinement\<close>
lemma find_shortest_augmenting_refine:
  "(f',f)\<in>Id \<Longrightarrow> find_shortest_augmenting_spec f' \<le> \<Down>(\<langle>Id\<rangle>option_rel) (edka.find_augmenting_spec f)"
  unfolding find_shortest_augmenting_spec_def edka.find_augmenting_spec_def
  apply(rule bindT_refine'[where R'=Id])
   apply auto
  apply(rule SELECT_refine)
  subgoal unfolding info_def by auto
  subgoal unfolding info_def by safe
  by simp

text \<open>Next, we specify the Edmonds-Karp algorithm.
  Our first specification still uses partial correctness,
  termination will be proved afterwards. \<close>
definition "edka_partial \<equiv> do {
  f \<leftarrow> SPECT [(\<lambda>_. 0) \<mapsto> init_graph (card V)];

  (f,_) \<leftarrow> whileT
    (\<lambda>(f,brk). \<not>brk)
    (\<lambda>(f,_). do {
      p \<leftarrow> find_shortest_augmenting_spec f;
      case p of
        None \<Rightarrow> RETURNT (f,True)
      | Some p \<Rightarrow> do {
          ASSERT (p\<noteq>[]);
          ASSERT (NPreflow.isAugmentingPath c s t f p);
          ASSERT (Graph.isShortestPath (residualGraph c f) s p t);
          f \<leftarrow> SPECT [NFlow.augment_with_path c f p \<mapsto> augment_with_path_time];
          ASSERT (NFlow c s t f);
          RETURNT (f, False)
        }
    })
    (f,False);
  ASSERT (NFlow c s t f);
  RETURNT f
}"

lemma edka_partial_refine : "edka_partial \<le> \<Down>Id edka.fofu"
  unfolding edka_partial_def edka.fofu_def
  apply(rule bindT_refine'[where R'=Id])
  apply simp
  apply(rule bindT_refine'[where R'="Id"])
   apply simp unfolding whileIET_def
   apply(rule whileT_mono)
   apply(rule case_prod_refine)
   apply auto
  apply(rule bindT_mono) apply auto
  subgoal
    using find_shortest_augmenting_refine[simplified option_rel_id_simp, simplified] by simp
  subgoal
    apply(rule case_option_mono) apply simp
    apply(rule le_ASSERTI)+
    apply(rule ASSERT_leI | simp)+
    unfolding find_shortest_augmenting_spec_def
    subgoal apply(simp only: inresT_ASSERT inresT_SELECT_Some)  apply safe
      unfolding edka.find_augmenting_spec_def (* WHY DO I NEED TO RECOVER ALL THIS INFORMATION FROM THE
          inresT and nofailT predicate?! *)
      by(simp add: nofailT_ASSERT_bind)
    by (rule ASSERT_leI | simp)+
  done

subsubsection \<open>Total Correctness\<close>

text \<open>We specify the total correct version of Edmonds-Karp algorithm.\<close>
definition "edka \<equiv> do {
  f \<leftarrow> SPECT [(\<lambda>_. 0) \<mapsto> init_graph (card V)];

  (f,_) \<leftarrow> whileT
    (\<lambda>(f,brk). \<not>brk)
    (\<lambda>(f,_). do {
      p \<leftarrow> find_shortest_augmenting_spec f;
      case p of
        None \<Rightarrow> RETURNT (f,True)
      | Some p \<Rightarrow> do {
          ASSERT (p\<noteq>[]);
          ASSERT (NPreflow.isAugmentingPath c s t f p);
          ASSERT (Graph.isShortestPath (residualGraph c f) s p t);
          f \<leftarrow> SPECT [NFlow.augment_with_path c f p \<mapsto> augment_with_path_time];
          ASSERT (NFlow c s t f);
          RETURNT (f, False)
        }
    })
    (f,False);
  ASSERT (NFlow c s t f);
  RETURNT f
}"

text \<open>Based on the measure function, it is easy to obtain a well-founded
  relation that proves termination of the loop in the Edmonds-Karp algorithm:\<close>
definition "edka_wf_rel \<equiv> inv_image
  (less_than_bool <*lex*> measure (\<lambda>cf. ek_analysis_defs.ekMeasure cf s t))
  (\<lambda>(f,brk). (\<not>brk,residualGraph c f))"

text \<open>The following theorem states that the total correct
  version of Edmonds-Karp algorithm refines the partial correct one.\<close>
theorem edka_refine: "edka \<le> \<Down>Id edka_partial"
  unfolding edka_def edka_partial_def
  by simp

thm edka_refine edka_partial_refine edka.fofu_partial_correct

lemma edka_correct_time: "edka \<le> SPECT (emb isMaxFlow edka.maxFlow_time)"
  using edka_refine edka_partial_refine edka.fofu_partial_correct
  by simp

subsubsection \<open>Complexity Analysis\<close>

text \<open>For the complexity analysis, we additionally show that the measure
  function is bounded by $O(VE)$. Note that our absolute bound is not as
  precise as possible, but clearly $O(VE)$.\<close>
  (* TODO: #edgesSp even bound by |E|, as either e or swap e lays on shortest path! *)

  interpret ek: ek_analysis cf
    by unfold_locales auto

  have cardV_positive: "card V > 0" and cardE_positive: "card E > 0"
    using card_0_eq[OF finite_V] V_not_empty apply blast
    using card_0_eq[OF finite_E] E_not_empty apply blast
    done

  show ?thesis proof (cases "cf.connected s t")
    case False hence "ek.ekMeasure = 0" by (auto simp: ek.ekMeasure_def)
    with cardV_positive cardE_positive show ?thesis
      by auto
  next
    case True

    have "cf.min_dist s t > 0"
      apply (rule ccontr)
      apply (auto simp: Graph.min_dist_z_iff True s_not_t[symmetric])
      done

    have "cf = c"
      unfolding residualGraph_def E_def
      by auto
    hence "ek.uE = E\<union>E\<inverse>" unfolding ek.uE_def by simp

    from True have "ek.ekMeasure
      = (card cf.V - cf.min_dist s t) * (card ek.uE + 1) + (card (ek.spEdges))"
      unfolding ek.ekMeasure_def by simp
    also from
      mlex_bound[of "card cf.V - cf.min_dist s t" "card V",
                 OF _ ek.card_spEdges_less]
    have "\<dots> < card V * (card ek.uE+1)"
      using \<open>cf.min_dist s t > 0\<close> \<open>card V > 0\<close>
      by (auto simp: resV_netV)
    also have "card ek.uE \<le> 2*card E" unfolding \<open>ek.uE = E\<union>E\<inverse>\<close>
      apply (rule order_trans)
      apply (rule card_Un_le)
      by auto
    finally show ?thesis by (auto simp: algebra_simps)
  qed
qed

text \<open>Finally, we present a version of the Edmonds-Karp algorithm
  which is instrumented with a loop counter, and asserts that
  there are less than $2|V||E|+|V| = O(|V||E|)$ iterations.

  Note that we only count the non-breaking loop iterations.
  \<close>

abbreviation "edka_time \<equiv> edka_time_aux shortestpath_time augment_with_path_time init_graph (card E) (card V)"

lemma maxFlow_time_ub: "edka.maxFlow_time \<le>  edka_time"
  unfolding edka.maxFlow_time_def edka_measure_def unfolding edka_time_aux_def
  using ekMeasure_upper_bound by auto

lemma edka_correct: "edka \<le> (SPECT (emb isMaxFlow (edka_time)))"
  apply(rule order_trans[OF edka_correct_time])
  apply(rule SPECT_ub)
  apply (simp only: le_fun_def)
    using  maxFlow_time_ub by simp

end \<comment> \<open>EdKa\<close>
end \<comment> \<open>Theory\<close>


theory ShortestPathNeg

(*
  This theory uses the graph library and
  several lemmas that were proven in the
  shortest path theory
*)
imports
  "../Graph_Theory/Graph_Theory"
  ShortestPath

begin
section {*Shortest Path (with general edge costs)*}
(*
  In this locale we assume we are given a
  wellformed directed graph $G = (V,E)$ with
  fitnite $V$ and $E$ (this is the assumption
  $graphG$). Moreover, a source vertex $s$ in
  $V$ . In addition, a cost function c, a function
 $num:V\to \Nat$, $parent\dash edge:V\to E \cup $*)
locale shortest_paths_locale_step1 =
  fixes G :: "('a, 'b) pre_digraph" (structure)
  fixes s :: "'a"
  fixes c :: "'b \<Rightarrow> real"
  fixes num :: "'a \<Rightarrow> nat"
  fixes parent_edge :: "'a \<Rightarrow> 'b option"
  fixes dist :: "'a  \<Rightarrow> ereal"
  assumes graphG: "fin_digraph G"
  assumes s_assms:
    "s \<in> verts G"
    "dist s \<noteq> \<infinity>"
    "parent_edge s = None"
    "num s = 0"
  assumes  parent_num_assms:
    "\<And>v.  \<lbrakk>v \<in> verts G; v \<noteq> s; dist v \<noteq> \<infinity>\<rbrakk> \<Longrightarrow>
    (\<exists>e \<in> arcs G. parent_edge v = Some e \<and>
    head G e = v \<and> dist (tail G e) \<noteq> \<infinity> \<and>
    num v  = num (tail G e) + 1)"
  assumes noPedge: "\<And>e. e\<in>arcs G \<Longrightarrow>
    dist (tail G e) \<noteq> \<infinity> \<Longrightarrow> dist (head G e) \<noteq> \<infinity>"

sublocale shortest_paths_locale_step1 \<subseteq> fin_digraph G
  using graphG by auto

definition (in shortest_paths_locale_step1) enum :: "'a \<Rightarrow> enat" where
  "enum v = (if (dist v = \<infinity> \<or> dist v = - \<infinity>) then \<infinity> else num v)"

locale shortest_paths_locale_step2 =
  shortest_paths_locale_step1 +
  basic_just_sp G dist c s enum +
  assumes source_val: "(\<exists>v \<in> verts G. enum v \<noteq> \<infinity>) \<Longrightarrow> dist s = 0"
  assumes no_edge_Vm_Vf:
    "\<And>e. e \<in> arcs G \<Longrightarrow> dist (tail G e) = - \<infinity> \<Longrightarrow> \<forall> r. dist (head G e) \<noteq> ereal r"

function (in shortest_paths_locale_step1) pwalk :: "'a \<Rightarrow> 'b list"
where
  "pwalk v =
    (if (v = s \<or> dist v = \<infinity> \<or> v \<notin> verts G)
      then []
      else pwalk (tail G (the (parent_edge v))) @ [the (parent_edge v)]
    )"
by auto
termination (in shortest_paths_locale_step1)
  using parent_num_assms
  by (relation "measure num", auto, fastforce)

lemma (in shortest_paths_locale_step1) pwalk_simps:
  "v = s \<or> dist v = \<infinity> \<or> v \<notin> verts G \<Longrightarrow> pwalk v = []"
  "v \<noteq> s \<Longrightarrow> dist v \<noteq> \<infinity> \<Longrightarrow> v \<in> verts G \<Longrightarrow>
    pwalk v = pwalk (tail G (the (parent_edge v))) @ [the (parent_edge v)]"
by auto

definition (in shortest_paths_locale_step1) pwalk_verts :: "'a  \<Rightarrow> 'a set" where
  "pwalk_verts v = {u. u \<in> set (awalk_verts s (pwalk v))}"

locale shortest_paths_locale_step3 =
  shortest_paths_locale_step2 +
  fixes C :: "('a \<times>('b awalk)) set"
  assumes C_se:
    "C \<subseteq> {(u, p). dist u \<noteq> \<infinity> \<and> awalk u p u \<and> awalk_cost c p < 0}"
  assumes int_neg_cyc:
    "\<And>v. v \<in> verts G \<Longrightarrow> dist v = -\<infinity> \<Longrightarrow>
      (fst ` C) \<inter> pwalk_verts v \<noteq> {}"

locale shortest_paths_locale_step2_pred =
  shortest_paths_locale_step1 +
  fixes pred :: "'a \<Rightarrow> 'b option"
  assumes bj: "basic_just_sp_pred G dist c s enum pred"
  assumes source_val: "(\<exists>v \<in> verts G. enum v \<noteq> \<infinity>) \<Longrightarrow> dist s = 0"
  assumes no_edge_Vm_Vf:
    "\<And>e. e \<in> arcs G \<Longrightarrow> dist (tail G e) = - \<infinity> \<Longrightarrow> \<forall> r. dist (head G e) \<noteq> ereal r"

lemma (in shortest_paths_locale_step1) num_s_is_min:
  assumes "v \<in> verts G"
  assumes "v \<noteq> s"
  assumes "dist v \<noteq> \<infinity>"
  shows "num v > 0"
     using parent_num_assms[OF assms] by fastforce

lemma (in shortest_paths_locale_step1) path_from_root_Vr_ex:
  fixes v :: 'a
  assumes "v \<in> verts G"
  assumes "v \<noteq> s"
  assumes "dist v \<noteq> \<infinity>"
  shows  "\<exists>e. s \<rightarrow>\<^sup>* tail G e \<and>
          e \<in> arcs G \<and> head G e = v \<and> dist (tail G e) \<noteq> \<infinity> \<and>
          parent_edge v = Some e \<and> num v = num (tail G e) + 1"
using assms
proof(induct "num v - 1" arbitrary : v)
case 0
  obtain e where ee:
    "e \<in> arcs G" "head G e = v" "dist (tail G e) \<noteq> \<infinity>"
    "parent_edge v = Some e" "num v = num (tail G e) + 1"
    using parent_num_assms[OF 0(2-4)] by fast
  have "tail G e = s"
    using num_s_is_min[OF tail_in_verts [OF ee(1)] _ ee(3)]
    ee(5) 0(1) by auto
  then show ?case using ee by auto
next
case (Suc n')
  obtain e where ee:
    "e \<in> arcs G" "head G e = v" "dist (tail G e) \<noteq> \<infinity>"
    "parent_edge v = Some e" "num v = num (tail G e) + 1"
    using parent_num_assms[OF Suc(3-5)] by fast
  then have ss: "tail G e \<noteq> s"
    using num_s_is_min tail_in_verts
    Suc(2) s_assms(4) by force
  have nst: "n' = num (tail G e) - 1"
    using ee(5) Suc(2) by presburger
  obtain e' where reach: "s \<rightarrow>\<^sup>* tail G e'" and
    e': "e' \<in> arcs G" "head G e' = tail G e" "dist (tail G e') \<noteq> \<infinity>"
    using Suc(1)[OF nst tail_in_verts[OF ee(1)] ss ee(3)] by blast
  then have "s \<rightarrow>\<^sup>* tail G e"
    by (metis arc_implies_awalk reachable_awalk reachable_trans)
  then show ?case using e' ee by auto
qed

lemma (in shortest_paths_locale_step1) path_from_root_Vr:
  fixes v :: 'a
  assumes "v \<in> verts G"
  assumes "dist v \<noteq> \<infinity>"
  shows "s \<rightarrow>\<^sup>* v"
proof(cases "v = s")
case True thus ?thesis using assms by simp
next
case False
  obtain e where "s \<rightarrow>\<^sup>* tail G e" "e \<in> arcs G" "head G e = v"
      using path_from_root_Vr_ex[OF assms(1) False assms(2)] by blast
  then have "s \<rightarrow>\<^sup>* tail G e" "tail G e \<rightarrow> v"
    by (auto intro: in_arcs_imp_in_arcs_ends)
  then show ?thesis by (rule reachable_adj_trans)
qed

lemma (in shortest_paths_locale_step1) \<mu>_V_less_inf:
  fixes v :: 'a
  assumes "v \<in> verts G"
  assumes "dist v \<noteq> \<infinity>"
  shows "\<mu> c s v \<noteq> \<infinity>"
  using assms path_from_root_Vr \<mu>_reach_conv by force

lemma (in shortest_paths_locale_step2) enum_not0:
  assumes "v \<in> verts G"
  assumes "v \<noteq> s"
  assumes "enum v \<noteq> \<infinity>"
  shows "enum v \<noteq> enat 0"
     using parent_num_assms[OF assms(1,2)] assms unfolding enum_def by auto

lemma (in shortest_paths_locale_step2) dist_Vf_\<mu>:
  fixes v :: 'a
  assumes vG: "v \<in> verts G"
  assumes "\<exists>r. dist v = ereal r"
  shows "dist v = \<mu> c s v"
proof -
  have ds: "dist s =  0"
    using assms source_val unfolding enum_def by force
  have ews:"awalk s [] s"
    using s_assms(1) unfolding awalk_def by simp
  have mu: "\<mu> c s s = ereal 0"
    using min_cost_le_walk_cost[OF ews, where c=c]
    awalk_cost_Nil ds  dist_le_\<mu>[OF s_assms(1)] zero_ereal_def
    by simp
  thus ?thesis
    using ds assms dist_le_\<mu>[OF vG]
    dist_ge_\<mu>[OF vG _ _ mu ds enum_not0]
    unfolding enum_def by fastforce
qed

lemma (in shortest_paths_locale_step1) pwalk_awalk:
  fixes v :: 'a
  assumes "v \<in> verts G"
  assumes "dist v \<noteq> \<infinity>"
  shows "awalk s (pwalk v) v"
proof (cases "v=s")
case True
  thus ?thesis
    using assms pwalk.simps[where v=v]
    awalk_Nil_iff by presburger
next
case False
  from assms show ?thesis
  proof (induct rule: pwalk.induct)
    fix v
    let ?e = "the (parent_edge v)"
    let ?u = "tail G ?e"
    assume ewu: "\<not> (v = s \<or> dist v = \<infinity> \<or> v \<notin> verts G) \<Longrightarrow>
                 ?u \<in> verts G \<Longrightarrow> dist ?u \<noteq> \<infinity> \<Longrightarrow>
                 awalk s (pwalk ?u) ?u"
    assume vG: "v \<in> verts G"
    assume dv: "dist v \<noteq> \<infinity>"
    thus "awalk s (pwalk v) v "
    proof (cases "v = s \<or> dist v = \<infinity> \<or> v \<notin> verts G")
    case True
      thus ?thesis
        using pwalk.simps vG dv
        awalk_Nil_iff by fastforce
    next
    case False
      obtain e  where ee:
        "e \<in>arcs G"
        "parent_edge v = Some e"
        "head G e = v"
        "dist (tail G e) \<noteq> \<infinity>"
        using parent_num_assms False by blast
      hence "awalk s (pwalk ?u) ?u"
        using ewu[OF False] tail_in_verts by simp
      hence "awalk s (pwalk (tail G e) @ [e]) v"
        using ee(1-3) vG
        by (auto simp: awalk_simps simp del: pwalk.simps)
      also have "pwalk (tail G e) @ [e] = pwalk v"
        using False ee(2) unfolding pwalk.simps[where v=v] by auto
      finally show ?thesis .
    qed
  qed
qed

lemma (in shortest_paths_locale_step3) \<mu>_ninf:
  fixes v :: 'a
  assumes "v \<in> verts G"
  assumes "dist v = - \<infinity>"
  shows "\<mu> c s v = - \<infinity>"
proof -
  have "awalk s (pwalk v) v"
    using pwalk_awalk assms by force
moreover
  obtain w where ww: "w \<in> fst ` C \<inter> pwalk_verts v"
    using int_neg_cyc[OF assms] by blast
  then obtain q where
     "awalk w q w"
     "awalk_cost c q < 0"
     using C_se by auto
moreover
  have "w \<in> set (awalk_verts s (pwalk v))"
    using ww unfolding pwalk_verts_def by fast
ultimately
  show ?thesis using  neg_cycle_imp_inf_\<mu> by force
qed

lemma (in shortest_paths_locale_step3) correct_shortest_path:
  fixes v :: 'a
  assumes "v \<in> verts G"
  shows "dist v = \<mu> c s v"
proof(cases "dist v")
show " \<And>r. dist v = ereal r \<Longrightarrow> dist v = \<mu> c s v"
  using dist_Vf_\<mu>[OF assms] by simp
next
show "dist v = \<infinity> \<Longrightarrow> dist v = \<mu> c s v"
  using \<mu>_V_less_inf[OF assms]
  dist_le_\<mu>[OF assms] by simp
next
show "dist v = -\<infinity> \<Longrightarrow> dist v = \<mu> c s v"
  using \<mu>_ninf[OF assms] by simp
qed

end


(*<*)theory WFrec imports Main begin(*>*)

text{*\noindent
So far, all recursive definitions were shown to terminate via measure
functions. Sometimes this can be inconvenient or
impossible. Fortunately, \isacommand{recdef} supports much more
general definitions. For example, termination of Ackermann's function
can be shown by means of the \rmindex{lexicographic product} @{text"<*lex*>"}:
*}

consts ack :: "nat\<times>nat \<Rightarrow> nat"
recdef ack "measure(\<lambda>m. m) <*lex*> measure(\<lambda>n. n)"
  "ack(0,n)         = Suc n"
  "ack(Suc m,0)     = ack(m, 1)"
  "ack(Suc m,Suc n) = ack(m,ack(Suc m,n))"

text{*\noindent
The lexicographic product decreases if either its first component
decreases (as in the second equation and in the outer call in the
third equation) or its first component stays the same and the second
component decreases (as in the inner call in the third equation).

In general, \isacommand{recdef} supports termination proofs based on
arbitrary well-founded relations as introduced in \S\ref{sec:Well-founded}.
This is called \textbf{well-founded
recursion}\indexbold{recursion!well-founded}.  A function definition
is total if and only if the set of
all pairs $(r,l)$, where $l$ is the argument on the
left-hand side of an equation and $r$ the argument of some recursive call on
the corresponding right-hand side, induces a well-founded relation.  For a
systematic account of termination proofs via well-founded relations see, for
example, Baader and Nipkow~@{cite "Baader-Nipkow"}.

Each \isacommand{recdef} definition should be accompanied (after the function's
name) by a well-founded relation on the function's argument type.
Isabelle/HOL formalizes some of the most important
constructions of well-founded relations (see \S\ref{sec:Well-founded}). For
example, @{term"measure f"} is always well-founded.   The lexicographic
product of two well-founded relations is again well-founded, which we relied
on when defining Ackermann's function above.
Of course the lexicographic product can also be iterated:
*}

consts contrived :: "nat \<times> nat \<times> nat \<Rightarrow> nat"
recdef contrived
  "measure(\<lambda>i. i) <*lex*> measure(\<lambda>j. j) <*lex*> measure(\<lambda>k. k)"
"contrived(i,j,Suc k) = contrived(i,j,k)"
"contrived(i,Suc j,0) = contrived(i,j,j)"
"contrived(Suc i,0,0) = contrived(i,i,i)"
"contrived(0,0,0)     = 0"

text{*
Lexicographic products of measure functions already go a long
way. Furthermore, you may embed a type in an
existing well-founded relation via the inverse image construction @{term
inv_image}. All these constructions are known to \isacommand{recdef}. Thus you
will never have to prove well-foundedness of any relation composed
solely of these building blocks. But of course the proof of
termination of your function definition --- that the arguments
decrease with every recursive call --- may still require you to provide
additional lemmas.

It is also possible to use your own well-founded relations with
\isacommand{recdef}.  For example, the greater-than relation can be made
well-founded by cutting it off at a certain point.  Here is an example
of a recursive function that calls itself with increasing values up to ten:
*}

consts f :: "nat \<Rightarrow> nat"
recdef (*<*)(permissive)(*>*)f "{(i,j). j<i \<and> i \<le> (10::nat)}"
"f i = (if 10 \<le> i then 0 else i * f(Suc i))"

text{*\noindent
Since \isacommand{recdef} is not prepared for the relation supplied above,
Isabelle rejects the definition.  We should first have proved that
our relation was well-founded:
*}

lemma wf_greater: "wf {(i,j). j<i \<and> i \<le> (N::nat)}"

txt{*\noindent
The proof is by showing that our relation is a subset of another well-founded
relation: one given by a measure function.\index{*wf_subset (theorem)}
*}

apply (rule wf_subset [of "measure (\<lambda>k::nat. N-k)"], blast)

txt{*
@{subgoals[display,indent=0,margin=65]}

\noindent
The inclusion remains to be proved. After unfolding some definitions,
we are left with simple arithmetic that is dispatched automatically.
*}

by (clarify, simp add: measure_def inv_image_def)

text{*\noindent

Armed with this lemma, we use the \attrdx{recdef_wf} attribute to attach a
crucial hint\cmmdx{hints} to our definition:
*}
(*<*)
consts g :: "nat \<Rightarrow> nat"
recdef g "{(i,j). j<i \<and> i \<le> (10::nat)}"
"g i = (if 10 \<le> i then 0 else i * g(Suc i))"
(*>*)
(hints recdef_wf: wf_greater)

text{*\noindent
Alternatively, we could have given @{text "measure (\<lambda>k::nat. 10-k)"} for the
well-founded relation in our \isacommand{recdef}.  However, the arithmetic
goal in the lemma above would have arisen instead in the \isacommand{recdef}
termination proof, where we have less control.  A tailor-made termination
relation makes even more sense when it can be used in several function
declarations.
*}

(*<*)end(*>*)


(*  Title:       Safe OCL
    Author:      Denis Nikiforov, March 2019
    Maintainer:  Denis Nikiforov <denis.nikif at gmail.com>
    License:     LGPL
*)
section \<open>Transitive Closures\<close>
theory Transitive_Closure_Ext
  imports "HOL-Library.FuncSet"
begin

(*** Basic Properties *******************************************************)

subsection \<open>Basic Properties\<close>

text \<open>
  @{text "R\<^sup>+\<^sup>+"} is a transitive closure of a relation @{text R}.
  @{text "R\<^sup>*\<^sup>*"} is a reflexive transitive closure of a relation @{text R}.\<close>

text \<open>
  A function @{text f} is surjective on @{text "R\<^sup>+\<^sup>+"} iff for any
  two elements in the range of @{text f}, related through @{text "R\<^sup>+\<^sup>+"},
  all their intermediate elements belong to the range of @{text f}.\<close>

abbreviation "surj_on_trancl R f \<equiv>
  (\<forall>x y z. R\<^sup>+\<^sup>+ (f x) y \<longrightarrow> R y (f z) \<longrightarrow> y \<in> range f)"

text \<open>
  A function @{text f} is bijective on @{text "R\<^sup>+\<^sup>+"} iff
  it is injective and surjective on @{text "R\<^sup>+\<^sup>+"}.\<close>

abbreviation "bij_on_trancl R f \<equiv> inj f \<and> surj_on_trancl R f"

(*** Helper Lemmas **********************************************************)

subsection \<open>Helper Lemmas\<close>

lemma rtranclp_eq_rtranclp [iff]:
  "(\<lambda>x y. P x y \<or> x = y)\<^sup>*\<^sup>* = P\<^sup>*\<^sup>*"
proof (intro ext iffI)
  fix x y
  have "(\<lambda>x y. P x y \<or> x = y)\<^sup>*\<^sup>* x y \<longrightarrow> P\<^sup>=\<^sup>=\<^sup>*\<^sup>* x y"
    by (rule mono_rtranclp) simp
  thus "(\<lambda>x y. P x y \<or> x = y)\<^sup>*\<^sup>* x y \<Longrightarrow> P\<^sup>*\<^sup>* x y"
    by simp
  show "P\<^sup>*\<^sup>* x y \<Longrightarrow> (\<lambda>x y. P x y \<or> x = y)\<^sup>*\<^sup>* x y"
    by (metis (no_types, lifting) mono_rtranclp)
qed

lemma tranclp_eq_rtranclp [iff]:
  "(\<lambda>x y. P x y \<or> x = y)\<^sup>+\<^sup>+ = P\<^sup>*\<^sup>*"
proof (intro ext iffI)
  fix x y
  have "(\<lambda>x y. P x y \<or> x = y)\<^sup>*\<^sup>* x y \<longrightarrow> P\<^sup>=\<^sup>=\<^sup>*\<^sup>* x y"
    by (rule mono_rtranclp) simp
  thus "(\<lambda>x y. P x y \<or> x = y)\<^sup>+\<^sup>+ x y \<Longrightarrow> P\<^sup>*\<^sup>* x y"
    using tranclp_into_rtranclp by force
  show "P\<^sup>*\<^sup>* x y \<Longrightarrow> (\<lambda>x y. P x y \<or> x = y)\<^sup>+\<^sup>+ x y"
    by (metis (mono_tags, lifting) mono_rtranclp rtranclpD tranclp.r_into_trancl)
qed

lemma rtranclp_eq_rtranclp' [iff]:
  "(\<lambda>x y. P x y \<and> x \<noteq> y)\<^sup>*\<^sup>* = P\<^sup>*\<^sup>*"
proof (intro ext iffI)
  fix x y
  show "(\<lambda>x y. P x y \<and> x \<noteq> y)\<^sup>*\<^sup>* x y \<Longrightarrow> P\<^sup>*\<^sup>* x y"
    by (metis (no_types, lifting) mono_rtranclp)
  assume "P\<^sup>*\<^sup>* x y"
  hence "(inf P (\<noteq>))\<^sup>*\<^sup>* x y"
    by (simp add: rtranclp_r_diff_Id)
  also have "(inf P (\<noteq>))\<^sup>*\<^sup>* x y \<longrightarrow> (\<lambda>x y. P x y \<and> x \<noteq> y)\<^sup>*\<^sup>* x y"
    by (rule mono_rtranclp) simp
  finally show "P\<^sup>*\<^sup>* x y \<Longrightarrow> (\<lambda>x y. P x y \<and> x \<noteq> y)\<^sup>*\<^sup>* x y" by simp
qed

lemma tranclp_tranclp_to_tranclp_r:
  assumes "(\<And>x y z. R\<^sup>+\<^sup>+ x y \<Longrightarrow> R y z \<Longrightarrow> P x \<Longrightarrow> P z \<Longrightarrow> P y)"
  assumes "R\<^sup>+\<^sup>+ x y" and "R\<^sup>+\<^sup>+ y z"
  assumes "P x" and "P z"
  shows "P y"
proof -
  have "(\<And>x y z. R\<^sup>+\<^sup>+ x y \<Longrightarrow> R y z \<Longrightarrow> P x \<Longrightarrow> P z \<Longrightarrow> P y) \<Longrightarrow>
         R\<^sup>+\<^sup>+ y z \<Longrightarrow> R\<^sup>+\<^sup>+ x y \<Longrightarrow> P x \<longrightarrow> P z \<longrightarrow> P y"
    by (erule tranclp_induct, auto) (meson tranclp_trans)
  thus ?thesis using assms by auto
qed

(*** Transitive Closure Preservation & Reflection ***************************)

subsection \<open>Transitive Closure Preservation\<close>

text \<open>
  A function @{text f} preserves @{text "R\<^sup>+\<^sup>+"} if it preserves @{text R}.\<close>

text \<open>
  The proof was derived from the accepted answer on the website
  Stack Overflow that is available at
  @{url "https://stackoverflow.com/a/52573551/632199"}
  and provided with the permission of the author of the answer.\<close>

lemma preserve_tranclp:
  assumes "\<And>x y. R x y \<Longrightarrow> S (f x) (f y)"
  assumes "R\<^sup>+\<^sup>+ x y"
  shows "S\<^sup>+\<^sup>+ (f x) (f y)"
proof -
  define P where P: "P = (\<lambda>x y. S\<^sup>+\<^sup>+ (f x) (f y))"
  define r where r: "r = (\<lambda>x y. S (f x) (f y))"
  have "r\<^sup>+\<^sup>+ x y" by (insert assms r; erule tranclp_trans_induct; auto)
  moreover have "\<And>x y. r x y \<Longrightarrow> P x y" unfolding P r by simp
  moreover have "\<And>x y z. r\<^sup>+\<^sup>+ x y \<Longrightarrow> P x y \<Longrightarrow> r\<^sup>+\<^sup>+ y z \<Longrightarrow> P y z \<Longrightarrow> P x z"
    unfolding P by auto
  ultimately have "P x y" by (rule tranclp_trans_induct)
  with P show ?thesis by simp
qed

text \<open>
  A function @{text f} preserves @{text "R\<^sup>*\<^sup>*"} if it preserves @{text R}.\<close>

lemma preserve_rtranclp:
  "(\<And>x y. R x y \<Longrightarrow> S (f x) (f y)) \<Longrightarrow>
   R\<^sup>*\<^sup>* x y \<Longrightarrow> S\<^sup>*\<^sup>* (f x) (f y)"
  unfolding Nitpick.rtranclp_unfold
  by (metis preserve_tranclp)

text \<open>
  If one needs to prove that @{text "(f x)"} and @{text "(g y)"}
  are related through @{text "S\<^sup>*\<^sup>*"} then one can use the previous
  lemma and add a one more step from @{text "(f y)"} to @{text "(g y)"}.\<close>

lemma preserve_rtranclp':
  "(\<And>x y. R x y \<Longrightarrow> S (f x) (f y)) \<Longrightarrow>
   (\<And>y. S (f y) (g y)) \<Longrightarrow>
   R\<^sup>*\<^sup>* x y \<Longrightarrow> S\<^sup>*\<^sup>* (f x) (g y)"
  by (metis preserve_rtranclp rtranclp.rtrancl_into_rtrancl)

lemma preserve_rtranclp'':
  "(\<And>x y. R x y \<Longrightarrow> S (f x) (f y)) \<Longrightarrow>
   (\<And>y. S (f y) (g y)) \<Longrightarrow>
   R\<^sup>*\<^sup>* x y \<Longrightarrow> S\<^sup>+\<^sup>+ (f x) (g y)"
  apply (rule_tac ?b="f y" in rtranclp_into_tranclp1, auto)
  by (rule preserve_rtranclp, auto)

subsection \<open>Transitive Closure Reflection\<close>

text \<open>
  A function @{text f} reflects @{text "S\<^sup>+\<^sup>+"} if it reflects
  @{text S} and is bijective on @{text "S\<^sup>+\<^sup>+"}.\<close>

text \<open>
  The proof was derived from the accepted answer on the website
  Stack Overflow that is available at
  @{url "https://stackoverflow.com/a/52573551/632199"}
  and provided with the permission of the author of the answer.\<close>

lemma reflect_tranclp:
  assumes refl_f: "\<And>x y. S (f x) (f y) \<Longrightarrow> R x y"
  assumes bij_f: "bij_on_trancl S f"
  assumes prem: "S\<^sup>+\<^sup>+ (f x) (f y)"
  shows "R\<^sup>+\<^sup>+ x y"
proof -
  define B where B: "B = range f"
  define g where g: "g = the_inv_into UNIV f"
  define gr where gr: "gr = restrict g B"
  define P where P: "P = (\<lambda>x y. x \<in> B \<longrightarrow> y \<in> B \<longrightarrow> R\<^sup>+\<^sup>+ (gr x) (gr y))"
  from prem have major: "S\<^sup>+\<^sup>+ (f x) (f y)" by blast
  from refl_f bij_f have cases_1: "\<And>x y. S x y \<Longrightarrow> P x y"
    unfolding B P g gr
    by (simp add: f_the_inv_into_f tranclp.r_into_trancl)
  from refl_f bij_f
  have "(\<And>x y z. S\<^sup>+\<^sup>+ x y \<Longrightarrow> S\<^sup>+\<^sup>+ y z \<Longrightarrow> x \<in> B \<Longrightarrow> z \<in> B \<Longrightarrow> y \<in> B)"
    unfolding B
    by (rule_tac ?z="z" in tranclp_tranclp_to_tranclp_r, auto, blast)
  with P have cases_2:
    "\<And>x y z. S\<^sup>+\<^sup>+ x y \<Longrightarrow> P x y \<Longrightarrow> S\<^sup>+\<^sup>+ y z \<Longrightarrow> P y z \<Longrightarrow> P x z"
    unfolding B
    by auto
  from major cases_1 cases_2 have "P (f x) (f y)"
    by (rule tranclp_trans_induct)
  with bij_f show ?thesis unfolding P B g gr by (simp add: the_inv_f_f)
qed

text \<open>
  A function @{text f} reflects @{text "S\<^sup>*\<^sup>*"} if it reflects
  @{text S} and is bijective on @{text "S\<^sup>+\<^sup>+"}.\<close>

lemma reflect_rtranclp:
  "(\<And>x y. S (f x) (f y) \<Longrightarrow> R x y) \<Longrightarrow>
   bij_on_trancl S f \<Longrightarrow>
   S\<^sup>*\<^sup>* (f x) (f y) \<Longrightarrow> R\<^sup>*\<^sup>* x y"
  unfolding Nitpick.rtranclp_unfold
  by (metis (full_types) injD reflect_tranclp)

end


header {* \isaheader{Hashable Interface} *}
theory Intf_Hash
imports
    Main
    "../../Lib/HashCode"
    "../../../Automatic_Refinement/Automatic_Refinement"
begin

type_synonym 'a eq = "'a \<Rightarrow> 'a \<Rightarrow> bool"
type_synonym 'k bhc = "nat \<Rightarrow> 'k \<Rightarrow> nat"

subsection {* Abstract and concrete hash functions *}

definition is_bounded_hashcode :: "('c\<times>'a) set \<Rightarrow> 'c eq \<Rightarrow> 'c bhc \<Rightarrow> bool"
  where "is_bounded_hashcode R eq bhc \<equiv>
             ((eq,op =) \<in> R \<rightarrow> R \<rightarrow> bool_rel) \<and>
             (\<forall>n x y. eq x y \<longrightarrow> bhc n x = bhc n y) \<and>
             (\<forall>n x. 1 < n \<longrightarrow> bhc n x < n)"
definition abstract_bounded_hashcode :: "('c\<times>'a) set \<Rightarrow> 'c bhc \<Rightarrow> 'a bhc"
  where "abstract_bounded_hashcode Rk bhc n x' \<equiv>
             if x' \<in> Range Rk
                 then THE c. \<exists>x. (x,x') \<in> Rk \<and> bhc n x = c
                 else 0"

lemma is_bounded_hashcodeI[intro]:
  "((eq,op =) \<in> R \<rightarrow> R \<rightarrow> bool_rel) \<Longrightarrow>
   (\<And>x y n. eq x y \<Longrightarrow> bhc n x = bhc n y) \<Longrightarrow>
   (\<And>x n. 1 < n \<Longrightarrow> bhc n x < n) \<Longrightarrow> is_bounded_hashcode R eq bhc"
  unfolding is_bounded_hashcode_def by force

lemma is_bounded_hashcodeD[dest]:
  assumes "is_bounded_hashcode R eq bhc"
  shows "(eq,op =) \<in> R \<rightarrow> R \<rightarrow> bool_rel" and
        "\<And>n x y. eq x y \<Longrightarrow> bhc n x = bhc n y" and
        "\<And>n x. 1 < n \<Longrightarrow> bhc n x < n"
  using assms unfolding is_bounded_hashcode_def by simp_all

lemma bounded_hashcode_welldefined:
  assumes BHC: "is_bounded_hashcode Rk eq bhc" and
          R1: "(x1,x') \<in> Rk" and R2: "(x2,x') \<in> Rk"
  shows "bhc n x1 = bhc n x2"
proof-
  from is_bounded_hashcodeD[OF BHC] have "(eq,op =) \<in> Rk \<rightarrow> Rk \<rightarrow> bool_rel" by simp
  with R1 R2 have "eq x1 x2" by (force dest: fun_relD)
  thus ?thesis using BHC by blast
qed

lemma abstract_bhc_correct[intro]:
  assumes "is_bounded_hashcode Rk eq bhc"
  shows "(bhc, abstract_bounded_hashcode Rk bhc) \<in>
      nat_rel \<rightarrow> Rk \<rightarrow> nat_rel" (is "(bhc, ?bhc') \<in> _")
proof (intro fun_relI)
  fix n n' x x'
  assume A: "(n,n') \<in> nat_rel" and B: "(x,x') \<in> Rk"
  hence C: "n = n'" and D: "x' \<in> Range Rk" by auto
  have "?bhc' n' x' = bhc n x"
      unfolding abstract_bounded_hashcode_def
      apply (simp add: C D, rule)
      apply (intro exI conjI, fact B, rule refl)
      apply (elim exE conjE, hypsubst,
          erule bounded_hashcode_welldefined[OF assms _ B])
      done
  thus "(bhc n x, ?bhc' n' x') \<in> nat_rel" by simp
qed

lemma abstract_bhc_is_bhc[intro]:
  fixes Rk :: "('c\<times>'a) set"
  assumes bhc: "is_bounded_hashcode Rk eq bhc"
  shows "is_bounded_hashcode Id op= (abstract_bounded_hashcode Rk bhc)"
      (is "is_bounded_hashcode _ op= ?bhc'")
proof
  fix x'::'a and y'::'a and n'::nat assume "x' = y'"
  thus "?bhc' n' x' = ?bhc' n' y'" by simp
next
  fix x'::'a and n'::nat assume "1 < n'"
  from abstract_bhc_correct[OF bhc] show "?bhc' n' x' < n'"
  proof (cases "x' \<in> Range Rk")
    case False
      with `1 < n'` show ?thesis
          unfolding abstract_bounded_hashcode_def by simp
  next
    case True
      then obtain x where "(x,x') \<in> Rk" ..
      have "(n',n') \<in> nat_rel" ..
      from abstract_bhc_correct[OF assms] have "?bhc' n' x' = bhc n' x"
        apply -
        apply (drule fun_relD[OF _ `(n',n') \<in> nat_rel`],
               drule fun_relD[OF _ `(x,x') \<in> Rk`], simp)
        done
      also from `1 < n'` and bhc have "... < n'" by blast
      finally show "?bhc' n' x' < n'" .
  qed
qed simp

(*lemma hashable_bhc_is_bhc[autoref_ga_rules]:
  "\<lbrakk>STRUCT_EQ_tag eq op=; REL_IS_ID R\<rbrakk> \<Longrightarrow> is_bounded_hashcode R eq bounded_hashcode"
  unfolding is_bounded_hashcode_def
  by (simp add: bounded_hashcode_bounds)*)

(* TODO: This is a hack that causes the relation to be instantiated to Id, if it is not
    yet fixed! *)
lemma hashable_bhc_is_bhc[autoref_ga_rules]:
  "\<lbrakk>STRUCT_EQ_tag eq op=; REL_FORCE_ID R\<rbrakk> \<Longrightarrow> is_bounded_hashcode R eq bounded_hashcode_nat"
  unfolding is_bounded_hashcode_def
  by (simp add: bounded_hashcode_nat_bounds)

subsection {* Default hash map size *}

definition is_valid_def_hm_size :: "'k itself \<Rightarrow> nat \<Rightarrow> bool"
    where "is_valid_def_hm_size type n \<equiv> n > 1"

lemma hashable_def_size_is_def_size[autoref_ga_rules]:
  shows "is_valid_def_hm_size TYPE('k::hashable) (def_hashmap_size TYPE('k))"
    unfolding is_valid_def_hm_size_def by (fact def_hashmap_size)

end


(*
  File:     KD_Tree.thy
  Author:   Martin Rau, TU München
*)

section "Definition of the \<open>k\<close>-d Tree"

theory KD_Tree
  imports
  Complex_Main
  "HOL-Analysis.Finite_Cartesian_Product"
  "HOL-Analysis.Topology_Euclidean_Space"
  "Eval_Base.Eval_Base"
begin

text \<open>
  A \<open>k\<close>-d tree is a space-partitioning data structure for organizing points in a \<open>k\<close>-dimensional space.
  In principle the \<open>k\<close>-d tree is a binary tree. The leafs hold the \<open>k\<close>-dimensional points and the nodes
  contain left and right subtrees as well as a discriminator \<open>v\<close> at a particular axis \<open>k\<close>.
  Every node divides the space into two parts by splitting along a hyperplane.
  Consider a node \<open>n\<close> with associated discriminator \<open>v\<close> at axis \<open>k\<close>.
  All points in the left subtree must have a value at axis \<open>k\<close> that is less than or
  equal to \<open>v\<close> and all points in the right subtree must have a value at axis \<open>k\<close> that is
  greater than \<open>v\<close>.

  Deviations from the papers:

  The chosen tree representation is taken from @{cite "DBLP:journals/toms/FriedmanBF77"} with one minor
  adjustment. Originally the leafs hold buckets of points of size \<open>b\<close>. This representation fixes the
  bucket size to \<open>b = 1\<close>, a single point per Leaf. This is only a minor adjustment since the paper
  proves that \<open>b = 1\<close> is the optimal bucket size for minimizing the running time of the nearest neighbor
  algorithm @{cite "DBLP:journals/toms/FriedmanBF77"}, only simplifies building the optimized
  \<open>k\<close>-d trees @{cite "DBLP:journals/toms/FriedmanBF77"} and has little influence on the
  search algorithm @{cite "DBLP:journals/cacm/Bentley75"}.
\<close>

type_synonym 'k point = "(real, 'k) vec"

lemma dist_point_def:
  fixes p\<^sub>0 :: "('k::finite) point"
  shows "dist p\<^sub>0 p\<^sub>1 = sqrt (\<Sum>k \<in> UNIV. (p\<^sub>0$k - p\<^sub>1$k)\<^sup>2)"
  unfolding dist_vec_def L2_set_def dist_real_def by simp

datatype 'k kdt =
  Leaf "'k point"
| Node 'k real "'k kdt" "'k kdt"

subsection \<open>Definition of the \<open>k\<close>-d Tree Invariant and Related Functions\<close>

fun set_kdt :: "'k kdt \<Rightarrow> ('k point) set" where
  "set_kdt (Leaf p) = { p }"
| "set_kdt (Node _ _ l r) = set_kdt l \<union> set_kdt r"

definition spread :: "('k::finite) \<Rightarrow> 'k point set \<Rightarrow> real" where
  "spread k P = (if P = {} then 0 else let V = (\<lambda>p. p$k) ` P in Max V - Min V)"

definition widest_spread_axis :: "('k::finite) \<Rightarrow> 'k set \<Rightarrow> 'k point set \<Rightarrow> bool" where
  "widest_spread_axis k K ps \<longleftrightarrow> (\<forall>k' \<in> K. spread k' ps \<le> spread k ps)"

fun invar :: "('k::finite) kdt \<Rightarrow> bool" where
  "invar (Leaf p) \<longleftrightarrow> True"
| "invar (Node k v l r) \<longleftrightarrow> (\<forall>p \<in> set_kdt l. p$k \<le> v) \<and> (\<forall>p \<in> set_kdt r. v < p$k) \<and>
    widest_spread_axis k UNIV (set_kdt l \<union> set_kdt r) \<and> invar l \<and> invar r"

fun size_kdt :: "'k kdt \<Rightarrow> nat" where
  "size_kdt (Leaf _) = 1"
| "size_kdt (Node _ _ l r) = size_kdt l + size_kdt r"

fun height :: "'k kdt \<Rightarrow> nat" where
  "height (Leaf _) = 0"
| "height (Node _ _ l r) = max (height l) (height r) + 1"

fun min_height :: "'k kdt \<Rightarrow> nat" where
  "min_height (Leaf _) = 0"
| "min_height (Node _ _ l r) = min (min_height l) (min_height r) + 1"

definition balanced :: "'k kdt \<Rightarrow> bool" where
  "balanced kdt \<longleftrightarrow> height kdt - min_height kdt \<le> 1"

fun complete :: "'k kdt \<Rightarrow> bool" where
  "complete (Leaf _) = True"
| "complete (Node _ _ l r) \<longleftrightarrow> complete l \<and> complete r \<and> height l = height r"

lemma invar_r:
  "invar (Node k v l r) \<Longrightarrow> invar r"
  by simp

lemma invar_l_le_k:
  "invar (Node k v l r) \<Longrightarrow> \<forall>p \<in> set_kdt l. p$k \<le> v"
  by simp

lemma invar_r_ge_k:
  "invar (Node k v l r) \<Longrightarrow> \<forall>p \<in> set_kdt r. v < p$k"
  by simp

lemma invar_set:
  "set_kdt (Node k v l r) = set_kdt l \<union> set_kdt r"
  by simp

subsection \<open>Lemmas adapted from \<open>HOL-Library.Tree\<close> to \<open>k\<close>-d Tree\<close>

lemma size_ge0[simp]:
  "0 < size_kdt kdt"
  apply2 (induction kdt) by auto

lemma eq_size_1[simp]:
  "size_kdt kdt = 1 \<longleftrightarrow> (\<exists>p. kdt = Leaf p)"
  apply2 (induction kdt)
  apply (auto)
  using size_ge0 nat_less_le apply blast+
  done

lemma eq_1_size[simp]:
  "1 = size_kdt kdt \<longleftrightarrow> (\<exists>p. kdt = Leaf p)"
  using eq_size_1 by metis

lemma neq_Leaf_iff:
  "(\<nexists>p. kdt = Leaf p) = (\<exists>k v l r. kdt = Node k v l r)"
  by (cases kdt) auto

lemma eq_height_0[simp]:
  "height kdt = 0 \<longleftrightarrow> (\<exists>p. kdt = Leaf p)"
  by (cases kdt) auto

lemma eq_0_height[simp]:
  "0 = height kdt \<longleftrightarrow> (\<exists>p. kdt = Leaf p)"
  by (cases kdt) auto

lemma eq_min_height_0[simp]:
  "min_height kdt = 0 \<longleftrightarrow> (\<exists>p. kdt = Leaf p)"
  by (cases kdt) auto

lemma eq_0_min_height[simp]:
  "0 = min_height kdt \<longleftrightarrow> (\<exists>p. kdt = Leaf p)"
  by (cases kdt) auto

lemma size_height:
  "size_kdt kdt \<le> 2 ^ height kdt"
proof2(induction kdt)
  case (Node k v l r)
  show ?case
  proof (cases "height l \<le> height r")
    case True
    have "size_kdt (Node k v l r) = size_kdt l + size_kdt r" by simp
    also have "\<dots> \<le> 2 ^ height l + 2 ^ height r" using Node.IH by arith
    also have "\<dots> \<le> 2 ^ height r + 2 ^ height r" using True by simp
    also have "\<dots> = 2 ^ height (Node k v l r)"
      using True by (auto simp: max_def mult_2)
    finally show ?thesis .
  next
    case False
    have "size_kdt (Node k v l r) = size_kdt l + size_kdt r" by simp
    also have "\<dots> \<le> 2 ^ height l + 2 ^ height r" using Node.IH by arith
    also have "\<dots> \<le> 2 ^ height l + 2 ^ height l" using False by simp
    finally show ?thesis using False by (auto simp: max_def mult_2)
  qed
qed simp

lemma min_height_le_height:
  "min_height kdt \<le> height kdt"
  apply2 (induction kdt) by auto

lemma min_height_size:
  "2 ^ min_height kdt \<le> size_kdt kdt"
proof2(induction kdt)
  case (Node k v l r)
  have "(2::nat) ^ min_height (Node k v l r) \<le> 2 ^ min_height l + 2 ^ min_height r"
    by (simp add: min_def)
  also have "\<dots> \<le> size_kdt (Node k v l r)" using Node.IH by simp
  finally show ?case .
qed simp

lemma complete_iff_height:
  "complete kdt \<longleftrightarrow> (min_height kdt = height kdt)"
  apply2 (induction kdt)
  apply simp
  apply (simp add: min_def max_def)
  by (metis le_antisym le_trans min_height_le_height)

lemma size_if_complete:
  "complete kdt \<Longrightarrow> size_kdt kdt = 2 ^ height kdt"
  apply2 (induction kdt) by auto

lemma complete_if_size_height:
  "size_kdt kdt = 2 ^ height kdt \<Longrightarrow> complete kdt"
proof2 (induction "height kdt" arbitrary: kdt)
  case 0 thus ?case by auto
next
  case (Suc h)
  hence "\<nexists>p. kdt = Leaf p"
    by auto
  then obtain k v l r where [simp]: "kdt = Node k v l r"
    using neq_Leaf_iff by metis
  have 1: "height l \<le> h" and 2: "height r \<le> h" using Suc(2) by(auto)
  have 3: "\<not> height l < h"
  proof
    assume 0: "height l < h"
    have "size_kdt kdt = size_kdt l + size_kdt r" by simp
    also have "\<dots> \<le> 2 ^ height l + 2 ^ height r"
      using size_height[of l] size_height[of r] by arith
    also have " \<dots> < 2 ^ h + 2 ^ height r" using 0 by (simp)
    also have " \<dots> \<le> 2 ^ h + 2 ^ h" using 2 by (simp)
    also have "\<dots> = 2 ^ (Suc h)" by (simp)
    also have "\<dots> = size_kdt kdt" using Suc(2,3) by simp
    finally have "size_kdt kdt < size_kdt kdt" .
    thus False by (simp)
  qed
  have 4: "\<not> height r < h"
  proof
    assume 0: "height r < h"
    have "size_kdt kdt = size_kdt l + size_kdt r" by simp
    also have "\<dots> \<le> 2 ^ height l + 2 ^ height r"
      using size_height[of l] size_height[of r] by arith
    also have " \<dots> < 2 ^ height l + 2 ^ h" using 0 by (simp)
    also have " \<dots> \<le> 2 ^ h + 2 ^ h" using 1 by (simp)
    also have "\<dots> = 2 ^ (Suc h)" by (simp)
    also have "\<dots> = size_kdt kdt" using Suc(2,3) by simp
    finally have "size_kdt kdt < size_kdt kdt" .
    thus False by (simp)
  qed
  from 1 2 3 4 have *: "height l = h" "height r = h" by linarith+
  hence "size_kdt l = 2 ^ height l" "size_kdt r = 2 ^ height r"
    using Suc(3) size_height[of l] size_height[of r] by (auto)
  with * Suc(1) show ?case by simp
qed

lemma complete_if_size_min_height:
  "size_kdt kdt = 2 ^ min_height kdt \<Longrightarrow> complete kdt"
proof2 (induct "min_height kdt" arbitrary: kdt)
  case 0 thus ?case by auto
next
  case (Suc h)
  hence "\<nexists>p. kdt = Leaf p"
    by auto
  then obtain k v l r where [simp]: "kdt = Node k v l r"
    using neq_Leaf_iff by metis
  have 1: "h \<le> min_height l" and 2: "h \<le> min_height r" using Suc(2) by (auto)
  have 3: "\<not> h < min_height l"
  proof
    assume 0: "h < min_height l"
    have "size_kdt kdt = size_kdt l + size_kdt r" by simp
    also note min_height_size[of l]
    also(xtrans) note min_height_size[of r]
    also(xtrans) have "(2::nat) ^ min_height l > 2 ^ h"
        using 0 by (simp add: diff_less_mono)
    also(xtrans) have "(2::nat) ^ min_height r \<ge> 2 ^ h" using 2 by simp
    also(xtrans) have "(2::nat) ^ h + 2 ^ h = 2 ^ (Suc h)" by (simp)
    also have "\<dots> = size_kdt kdt" using Suc(2,3) by simp
    finally show False by (simp add: diff_le_mono)
  qed
  have 4: "\<not> h < min_height r"
  proof
    assume 0: "h < min_height r"
    have "size_kdt kdt = size_kdt l + size_kdt r" by simp
    also note min_height_size[of l]
    also(xtrans) note min_height_size[of r]
    also(xtrans) have "(2::nat) ^ min_height r > 2 ^ h"
        using 0 by (simp add: diff_less_mono)
    also(xtrans) have "(2::nat) ^ min_height l \<ge> 2 ^ h" using 1 by simp
    also(xtrans) have "(2::nat) ^ h + 2 ^ h = 2 ^ (Suc h)" by (simp)
    also have "\<dots> = size_kdt kdt" using Suc(2,3) by simp
    finally show False by (simp add: diff_le_mono)
  qed
  from 1 2 3 4 have *: "min_height l = h" "min_height r = h" by linarith+
  hence "size_kdt l = 2 ^ min_height l" "size_kdt r = 2 ^ min_height r"
    using Suc(3) min_height_size[of l] min_height_size[of r] by (auto)
  with * Suc(1) show ?case
    by (simp add: complete_iff_height)
qed

lemma complete_iff_size:
  "complete kdt \<longleftrightarrow> size_kdt kdt = 2 ^ height kdt"
  using complete_if_size_height size_if_complete by blast

lemma size_height_if_incomplete:
  "\<not> complete kdt \<Longrightarrow> size_kdt kdt < 2 ^ height kdt"
  by (meson antisym_conv complete_iff_size not_le size_height)

lemma min_height_size_if_incomplete:
  "\<not> complete kdt \<Longrightarrow> 2 ^ min_height kdt < size_kdt kdt"
  by (metis complete_if_size_min_height le_less min_height_size)

lemma balanced_subtreeL:
  "balanced (Node k v l r) \<Longrightarrow> balanced l"
  by (simp add: balanced_def)

lemma balanced_subtreeR:
  "balanced (Node k v l r) \<Longrightarrow> balanced r"
  by (simp add: balanced_def)

lemma balanced_optimal:
  assumes "balanced kdt" "size_kdt kdt \<le> size_kdt kdt'"
  shows "height kdt \<le> height kdt'"
proof (cases "complete kdt")
  case True
  have "(2::nat) ^ height kdt \<le> 2 ^ height kdt'"
  proof -
    have "2 ^ height kdt = size_kdt kdt"
      using True by (simp add: complete_iff_height size_if_complete)
    also have "\<dots> \<le> size_kdt kdt'" using assms(2) by simp
    also have "\<dots> \<le> 2 ^ height kdt'" by (rule size_height)
    finally show ?thesis .
  qed
  thus ?thesis by (simp)
next
  case False
  have "(2::nat) ^ min_height kdt < 2 ^ height kdt'"
  proof -
    have "(2::nat) ^ min_height kdt < size_kdt kdt"
      by(rule min_height_size_if_incomplete[OF False])
    also have "\<dots> \<le> size_kdt kdt'" using assms(2) by simp
    also have "\<dots> \<le> 2 ^ height kdt'"  by(rule size_height)
    finally have "(2::nat) ^ min_height kdt < (2::nat) ^ height kdt'" .
    thus ?thesis .
  qed
  hence *: "min_height kdt < height kdt'" by simp
  have "min_height kdt + 1 = height kdt"
    using min_height_le_height[of kdt] assms(1) False
    by (simp add: complete_iff_height balanced_def)
  with * show ?thesis by arith
qed

subsection \<open>Lemmas adapted from \<open>HOL-Library.Tree_Real\<close> to \<open>k\<close>-d Tree\<close>

lemma size_height_log:
  "log 2 (size_kdt kdt) \<le> height kdt"
  by (simp add: log2_of_power_le size_height)

lemma min_height_size_log:
  "min_height kdt \<le> log 2 (size_kdt kdt)"
  by (simp add: le_log2_of_power min_height_size)

lemma size_log_if_complete:
  "complete kdt \<Longrightarrow> height kdt = log 2 (size_kdt kdt)"
  using complete_iff_size log2_of_power_eq by blast

lemma min_height_size_log_if_incomplete:
  "\<not> complete kdt \<Longrightarrow> min_height kdt < log 2 (size_kdt kdt)"
  by (simp add: less_log2_of_power min_height_size_if_incomplete)

lemma min_height_balanced:
  assumes "balanced kdt"
  shows "min_height kdt = nat(floor(log 2 (size_kdt kdt)))"
proof cases
  assume *: "complete kdt"
  hence "size_kdt kdt = 2 ^ min_height kdt"
    by (simp add: complete_iff_height size_if_complete)
  from log2_of_power_eq[OF this] show ?thesis by linarith
next
  assume *: "\<not> complete kdt"
  hence "height kdt = min_height kdt + 1"
    using assms min_height_le_height[of kdt]
    by(auto simp add: balanced_def complete_iff_height)
  hence "size_kdt kdt < 2 ^ (min_height kdt + 1)"
    by (metis * size_height_if_incomplete)
  hence "log 2 (size_kdt kdt) < min_height kdt + 1"
    using log2_of_power_less size_ge0 by blast
  thus ?thesis using min_height_size_log[of kdt] by linarith
qed

lemma height_balanced:
  assumes "balanced kdt"
  shows "height kdt = nat(ceiling(log 2 (size_kdt kdt)))"
proof cases
  assume *: "complete kdt"
  hence "size_kdt kdt = 2 ^ height kdt"
    by (simp add: size_if_complete)
  from log2_of_power_eq[OF this] show ?thesis
    by linarith
next
  assume *: "\<not> complete kdt"
  hence **: "height kdt = min_height kdt + 1"
    using assms min_height_le_height[of kdt]
    by(auto simp add: balanced_def complete_iff_height)
  hence "size_kdt kdt \<le> 2 ^ (min_height kdt + 1)" by (metis size_height)
  from  log2_of_power_le[OF this size_ge0] min_height_size_log_if_incomplete[OF *] **
  show ?thesis by linarith
qed

lemma balanced_Node_if_wbal1:
  assumes "balanced l" "balanced r" "size_kdt l = size_kdt r + 1"
  shows "balanced (Node k v l r)"
proof -
  from assms(3) have [simp]: "size_kdt l = size_kdt r + 1" by simp
  have "nat \<lceil>log 2 (1 + size_kdt r)\<rceil> \<ge> nat \<lceil>log 2 (size_kdt r)\<rceil>"
    by(rule nat_mono[OF ceiling_mono]) simp
  hence 1: "height(Node k v l r) = nat \<lceil>log 2 (1 + size_kdt r)\<rceil> + 1"
    using height_balanced[OF assms(1)] height_balanced[OF assms(2)]
    by (simp del: nat_ceiling_le_eq add: max_def)
  have "nat \<lfloor>log 2 (1 + size_kdt r)\<rfloor> \<ge> nat \<lfloor>log 2 (size_kdt r)\<rfloor>"
    by(rule nat_mono[OF floor_mono]) simp
  hence 2: "min_height(Node k v l r) = nat \<lfloor>log 2 (size_kdt r)\<rfloor> + 1"
    using min_height_balanced[OF assms(1)] min_height_balanced[OF assms(2)]
    by (simp)
  have "size_kdt r \<ge> 1" by (simp add: Suc_leI)
  then obtain i where i: "2 ^ i \<le> size_kdt r" "size_kdt r < 2 ^ (i + 1)"
    using ex_power_ivl1[of 2 "size_kdt r"] by auto
  hence i1: "2 ^ i < size_kdt r + 1" "size_kdt r + 1 \<le> 2 ^ (i + 1)" by auto
  from 1 2 floor_log_nat_eq_if[OF i] ceiling_log_nat_eq_if[OF i1]
  show ?thesis by(simp add:balanced_def)
qed

lemma balanced_sym:
  "balanced (Node k v l r) \<Longrightarrow> balanced (Node k' v' r l)"
  by (auto simp: balanced_def)

lemma balanced_Node_if_wbal2:
  assumes "balanced l" "balanced r" "abs(int(size_kdt l) - int(size_kdt r)) \<le> 1"
  shows "balanced (Node k v l r)"
proof -
  have "size_kdt l = size_kdt r \<or> (size_kdt l = size_kdt r + 1 \<or> size_kdt r = size_kdt l + 1)" (is "?A \<or> ?B")
    using assms(3) by linarith
  thus ?thesis
  proof
    assume "?A"
    thus ?thesis using assms(1,2)
      apply(simp add: balanced_def min_def max_def)
      by (metis assms(1,2) balanced_optimal le_antisym le_less)
  next
    assume "?B"
    thus ?thesis
      by (meson assms(1,2) balanced_sym balanced_Node_if_wbal1)
  qed
qed

end


section \<open>Fixed point transformations\<close>

theory FixTransform
imports HOLCF
begin

default_sort type

text \<open>
In his treatment of the computabily, Shivers gives proofs only for a generic example and leaves it to the reader to apply this to the mutually recursive functions used for the semantics. As we carry this out, we need to transform a fixed point for two functions (implemented in @{theory HOLCF} as a fixed point over a tuple) to a simple fixed point equation. The approach here works as long as both functions in the tuple have the same return type, using the equation
\[
X^A\cdot X^B = X^{A+B}.
\]

Generally, a fixed point can be transformed using any retractable continuous function:
\<close>

lemma fix_transform:
  assumes "\<And>x. g\<cdot>(f\<cdot>x)=x"
  shows "fix\<cdot>F = g\<cdot>(fix\<cdot>(f oo F oo g))"
using assms apply -
apply (rule parallel_fix_ind)
apply (rule adm_eq)
apply auto
apply (erule retraction_strict[of g f,rule_format])
done

text \<open>
The functions we use here convert a tuple of functions to a function taking a direct sum as parameters and back. We only care about discrete arguments here.
\<close>

definition tup_to_sum :: "('a discr \<rightarrow> 'c) \<times> ('b discr \<rightarrow> 'c) \<rightarrow> ('a + 'b) discr \<rightarrow> 'c::cpo"
 where "tup_to_sum = (\<Lambda> p s. (\<lambda>(f,g).
          case undiscr s of Inl x \<Rightarrow> f\<cdot>(Discr x)
                          | Inr x \<Rightarrow> g\<cdot>(Discr x)) p)"

definition sum_to_tup :: "(('a + 'b) discr \<rightarrow> 'c) \<rightarrow> ('a discr \<rightarrow> 'c) \<times> ('b discr \<rightarrow> 'c::cpo)"
 where "sum_to_tup = (\<Lambda> f. (\<Lambda> x. f\<cdot>(Discr (Inl (undiscr x))),
                             \<Lambda> x. f\<cdot>(Discr (Inr (undiscr x)))))"

text \<open>
As so often when working with @{theory HOLCF}, some continuity lemmas are required.
\<close>

lemma cont2cont_case_sum[simp,cont2cont]:
  assumes "cont f" and "cont g"
  shows "cont (\<lambda>x. case_sum (f x) (g x) s)"
using assms
by (cases s, auto intro:cont2cont_fun)

lemma cont2cont_circ[simp,cont2cont]:
 "cont (\<lambda>f. f \<circ> g)"
apply (rule cont2cont_lambda)
apply (subst comp_def)
apply (rule  cont2cont_fun[of "\<lambda>x. x", OF "cont_id"])
done

lemma cont2cont_split_pair[cont2cont,simp]:
 assumes f1: "cont f"
     and f2: "\<And> x. cont (f x)"
     and g1: "cont g"
     and g2: "\<And> x. cont (g x)"
 shows "cont (\<lambda>(a, b). (f a b, g a b))"
apply (intro cont2cont)
apply (rule cont_apply[OF cont_snd _ cont_const])
apply (rule cont_apply[OF cont_snd f2])
apply (rule cont_apply[OF cont_fst cont2cont_fun[OF f1] cont_const])

apply (rule cont_apply[OF cont_snd _ cont_const])
apply (rule cont_apply[OF cont_snd g2])
apply (rule cont_apply[OF cont_fst cont2cont_fun[OF g1] cont_const])
done

text \<open>
Using these continuity lemmas, we can show that our function are actually continuous and thus allow us to apply them to a value.
\<close>

lemma sum_to_tup_app:
 "sum_to_tup\<cdot>f = (\<Lambda> x. f\<cdot>(Discr (Inl (undiscr x))), \<Lambda> x. f\<cdot>(Discr (Inr (undiscr x))))"
unfolding sum_to_tup_def by simp

lemma tup_to_sum_app:
  "tup_to_sum\<cdot>p = (\<Lambda> s. (\<lambda>(f,g).
          case undiscr s of Inl x \<Rightarrow> f\<cdot>(Discr x)
                          | Inr x \<Rightarrow> g\<cdot>(Discr x)) p)"
unfolding tup_to_sum_def by simp

text \<open>
Generally, lambda abstractions with discrete domain are continuous and can be resolved immediately.
\<close>

lemma discr_app[simp]:
  "(\<Lambda> s. f s)\<cdot>(Discr x) = f (Discr x)"
by simp

text \<open>
Our transformation functions are inverse to each other, so we can use them to transform a fixed point.
\<close>

lemma tup_to_sum_to_tup[simp]:
  shows   "sum_to_tup\<cdot>(tup_to_sum\<cdot>F) = F"
unfolding sum_to_tup_app and tup_to_sum_app
by (cases F, auto intro:cfun_eqI)

lemma fix_transform_pair_sum:
  shows "fix\<cdot>F = sum_to_tup\<cdot>(fix\<cdot>(tup_to_sum oo F oo sum_to_tup))"
by (rule fix_transform[OF tup_to_sum_to_tup])

text \<open>
After such a transformation, we want to get rid of these helper functions again. This is done by the next two simplification lemmas.
\<close>

lemma tup_sum_oo[simp]:
 assumes f1: "cont F"
     and f2: "\<And> x. cont (F x)"
     and g1: "cont G"
     and g2: "\<And> x. cont (G x)"
shows  "tup_to_sum oo (\<Lambda> p. (\<lambda>(a, b). (F a b, G a b)) p) oo sum_to_tup
  = (\<Lambda> f s. (case undiscr s of
        Inl x \<Rightarrow>
          F (\<Lambda> s. f\<cdot>(Discr (Inl (undiscr s))))
           (\<Lambda> s. f\<cdot>(Discr (Inr (undiscr s))))\<cdot>
          (Discr x)
        | Inr x \<Rightarrow>
            G (\<Lambda> s. f\<cdot>(Discr (Inl (undiscr s))))
             (\<Lambda> s. f\<cdot>(Discr (Inr (undiscr s))))\<cdot>
            (Discr x)))"
by (rule cfun_eqI, rule cfun_eqI,
    simp add: sum_to_tup_app tup_to_sum_app
       cont2cont_split_pair[OF f1 f2 g1 g2]
       cont2cont_lambda
       cont_apply[OF _ f2 cont2cont_fun[OF cont_compose[OF f1]]]
       cont_apply[OF _ g2 cont2cont_fun[OF cont_compose[OF g1]]])

lemma fst_sum_to_tup[simp]:
  "fst (sum_to_tup\<cdot>x) = (\<Lambda> xa. x\<cdot>(Discr (Inl (undiscr xa))))"
by (simp add: sum_to_tup_app)

end


(*  Title:      HOL/Isar_Examples/Higher_Order_Logic.thy
    Author:     Makarius
*)

section \<open>Foundations of HOL\<close>

theory Higher_Order_Logic
  imports Pure
begin

text \<open>
  The following theory development illustrates the foundations of Higher-Order
  Logic. The ``HOL'' logic that is given here resembles @{cite
  "Gordon:1985:HOL"} and its predecessor @{cite "church40"}, but the order of
  axiomatizations and defined connectives has be adapted to modern
  presentations of \<open>\<lambda>\<close>-calculus and Constructive Type Theory. Thus it fits
  nicely to the underlying Natural Deduction framework of Isabelle/Pure and
  Isabelle/Isar.
\<close>

section \<open>HOL syntax within Pure\<close>

class type
default_sort type

typedecl o
instance o :: type ..
instance "fun" :: (type, type) type ..

judgment Trueprop :: "o \<Rightarrow> prop"  ("_" 5)

section \<open>Minimal logic (axiomatization)\<close>

axiomatization imp :: "o \<Rightarrow> o \<Rightarrow> o"  (infixr "\<longrightarrow>" 25)
  where impI [intro]: "(A \<Longrightarrow> B) \<Longrightarrow> A \<longrightarrow> B"
    and impE [dest, trans]: "A \<longrightarrow> B \<Longrightarrow> A \<Longrightarrow> B"

axiomatization All :: "('a \<Rightarrow> o) \<Rightarrow> o"  (binder "\<forall>" 10)
  where allI [intro]: "(\<And>x. P x) \<Longrightarrow> \<forall>x. P x"
    and allE [dest]: "\<forall>x. P x \<Longrightarrow> P a"

lemma atomize_imp [atomize]: "(A \<Longrightarrow> B) \<equiv> Trueprop (A \<longrightarrow> B)"
  by standard (fact impI, fact impE)

lemma atomize_all [atomize]: "(\<And>x. P x) \<equiv> Trueprop (\<forall>x. P x)"
  by standard (fact allI, fact allE)

subsubsection \<open>Derived connectives\<close>

definition False :: o
  where "False \<equiv> \<forall>A. A"

lemma FalseE [elim]:
  assumes "False"
  shows A
proof -
  from \<open>False\<close> have "\<forall>A. A" by (simp only: False_def)
  then show A ..
qed

definition True :: o
  where "True \<equiv> False \<longrightarrow> False"

lemma TrueI [intro]: True
  unfolding True_def ..

definition not :: "o \<Rightarrow> o"  ("\<not> _" [40] 40)
  where "not \<equiv> \<lambda>A. A \<longrightarrow> False"

lemma notI [intro]:
  assumes "A \<Longrightarrow> False"
  shows "\<not> A"
  using assms unfolding not_def ..

lemma notE [elim]:
  assumes "\<not> A" and A
  shows B
proof -
  from \<open>\<not> A\<close> have "A \<longrightarrow> False" by (simp only: not_def)
  from this and \<open>A\<close> have "False" ..
  then show B ..
qed

lemma notE': "A \<Longrightarrow> \<not> A \<Longrightarrow> B"
  by (rule notE)

lemmas contradiction = notE notE'  \<comment> \<open>proof by contradiction in any order\<close>

definition conj :: "o \<Rightarrow> o \<Rightarrow> o"  (infixr "\<and>" 35)
  where "A \<and> B \<equiv> \<forall>C. (A \<longrightarrow> B \<longrightarrow> C) \<longrightarrow> C"

lemma conjI [intro]:
  assumes A and B
  shows "A \<and> B"
  unfolding conj_def
proof
  fix C
  show "(A \<longrightarrow> B \<longrightarrow> C) \<longrightarrow> C"
  proof
    assume "A \<longrightarrow> B \<longrightarrow> C"
    also note \<open>A\<close>
    also note \<open>B\<close>
    finally show C .
  qed
qed

lemma conjE [elim]:
  assumes "A \<and> B"
  obtains A and B
proof
  from \<open>A \<and> B\<close> have *: "(A \<longrightarrow> B \<longrightarrow> C) \<longrightarrow> C" for C
    unfolding conj_def ..
  show A
  proof -
    note * [of A]
    also have "A \<longrightarrow> B \<longrightarrow> A"
    proof
      assume A
      then show "B \<longrightarrow> A" ..
    qed
    finally show ?thesis .
  qed
  show B
  proof -
    note * [of B]
    also have "A \<longrightarrow> B \<longrightarrow> B"
    proof
      show "B \<longrightarrow> B" ..
    qed
    finally show ?thesis .
  qed
qed

definition disj :: "o \<Rightarrow> o \<Rightarrow> o"  (infixr "\<or>" 30)
  where "A \<or> B \<equiv> \<forall>C. (A \<longrightarrow> C) \<longrightarrow> (B \<longrightarrow> C) \<longrightarrow> C"

lemma disjI1 [intro]:
  assumes A
  shows "A \<or> B"
  unfolding disj_def
proof
  fix C
  show "(A \<longrightarrow> C) \<longrightarrow> (B \<longrightarrow> C) \<longrightarrow> C"
  proof
    assume "A \<longrightarrow> C"
    from this and \<open>A\<close> have C ..
    then show "(B \<longrightarrow> C) \<longrightarrow> C" ..
  qed
qed

lemma disjI2 [intro]:
  assumes B
  shows "A \<or> B"
  unfolding disj_def
proof
  fix C
  show "(A \<longrightarrow> C) \<longrightarrow> (B \<longrightarrow> C) \<longrightarrow> C"
  proof
    show "(B \<longrightarrow> C) \<longrightarrow> C"
    proof
      assume "B \<longrightarrow> C"
      from this and \<open>B\<close> show C ..
    qed
  qed
qed

lemma disjE [elim]:
  assumes "A \<or> B"
  obtains (a) A | (b) B
proof -
  from \<open>A \<or> B\<close> have "(A \<longrightarrow> thesis) \<longrightarrow> (B \<longrightarrow> thesis) \<longrightarrow> thesis"
    unfolding disj_def ..
  also have "A \<longrightarrow> thesis"
  proof
    assume A
    then show thesis by (rule a)
  qed
  also have "B \<longrightarrow> thesis"
  proof
    assume B
    then show thesis by (rule b)
  qed
  finally show thesis .
qed

definition Ex :: "('a \<Rightarrow> o) \<Rightarrow> o"  (binder "\<exists>" 10)
  where "\<exists>x. P x \<equiv> \<forall>C. (\<forall>x. P x \<longrightarrow> C) \<longrightarrow> C"

lemma exI [intro]: "P a \<Longrightarrow> \<exists>x. P x"
  unfolding Ex_def
proof
  fix C
  assume "P a"
  show "(\<forall>x. P x \<longrightarrow> C) \<longrightarrow> C"
  proof
    assume "\<forall>x. P x \<longrightarrow> C"
    then have "P a \<longrightarrow> C" ..
    from this and \<open>P a\<close> show C ..
  qed
qed

lemma exE [elim]:
  assumes "\<exists>x. P x"
  obtains (that) x where "P x"
proof -
  from \<open>\<exists>x. P x\<close> have "(\<forall>x. P x \<longrightarrow> thesis) \<longrightarrow> thesis"
    unfolding Ex_def ..
  also have "\<forall>x. P x \<longrightarrow> thesis"
  proof
    fix x
    show "P x \<longrightarrow> thesis"
    proof
      assume "P x"
      then show thesis by (rule that)
    qed
  qed
  finally show thesis .
qed

subsubsection \<open>Extensional equality\<close>

axiomatization equal :: "'a \<Rightarrow> 'a \<Rightarrow> o"  (infixl "=" 50)
  where refl [intro]: "x = x"
    and subst: "x = y \<Longrightarrow> P x \<Longrightarrow> P y"

abbreviation not_equal :: "'a \<Rightarrow> 'a \<Rightarrow> o"  (infixl "\<noteq>" 50)
  where "x \<noteq> y \<equiv> \<not> (x = y)"

abbreviation iff :: "o \<Rightarrow> o \<Rightarrow> o"  (infixr "\<longleftrightarrow>" 25)
  where "A \<longleftrightarrow> B \<equiv> A = B"

axiomatization
  where ext [intro]: "(\<And>x. f x = g x) \<Longrightarrow> f = g"
    and iff [intro]: "(A \<Longrightarrow> B) \<Longrightarrow> (B \<Longrightarrow> A) \<Longrightarrow> A \<longleftrightarrow> B"
  for f g :: "'a \<Rightarrow> 'b"

lemma sym [sym]: "y = x" if "x = y"
  using that by (rule subst) (rule refl)

lemma [trans]: "x = y \<Longrightarrow> P y \<Longrightarrow> P x"
  by (rule subst) (rule sym)

lemma [trans]: "P x \<Longrightarrow> x = y \<Longrightarrow> P y"
  by (rule subst)

lemma arg_cong: "f x = f y" if "x = y"
  using that by (rule subst) (rule refl)

lemma fun_cong: "f x = g x" if "f = g"
  using that by (rule subst) (rule refl)

lemma trans [trans]: "x = y \<Longrightarrow> y = z \<Longrightarrow> x = z"
  by (rule subst)

lemma iff1 [elim]: "A \<longleftrightarrow> B \<Longrightarrow> A \<Longrightarrow> B"
  by (rule subst)

lemma iff2 [elim]: "A \<longleftrightarrow> B \<Longrightarrow> B \<Longrightarrow> A"
  by (rule subst) (rule sym)

subsection \<open>Cantor's Theorem\<close>

text \<open>
  Cantor's Theorem states that there is no surjection from a set to its
  powerset. The subsequent formulation uses elementary \<open>\<lambda>\<close>-calculus and
  predicate logic, with standard introduction and elimination rules.
\<close>

lemma iff_contradiction:
  assumes *: "\<not> A \<longleftrightarrow> A"
  shows C
proof (rule notE)
  show "\<not> A"
  proof
    assume A
    with * have "\<not> A" ..
    from this and \<open>A\<close> show False ..
  qed
  with * show A ..
qed

theorem Cantor: "\<not> (\<exists>f :: 'a \<Rightarrow> 'a \<Rightarrow> o. \<forall>A. \<exists>x. A = f x)"
proof
  assume "\<exists>f :: 'a \<Rightarrow> 'a \<Rightarrow> o. \<forall>A. \<exists>x. A = f x"
  then obtain f :: "'a \<Rightarrow> 'a \<Rightarrow> o" where *: "\<forall>A. \<exists>x. A = f x" ..
  let ?D = "\<lambda>x. \<not> f x x"
  from * have "\<exists>x. ?D = f x" ..
  then obtain a where "?D = f a" ..
  then have "?D a \<longleftrightarrow> f a a" using refl by (rule subst)
  then have "\<not> f a a \<longleftrightarrow> f a a" .
  then show False by (rule iff_contradiction)
qed

subsection \<open>Characterization of Classical Logic\<close>

text \<open>
  The subsequent rules of classical reasoning are all equivalent.
\<close>

locale classical =
  assumes classical: "(\<not> A \<Longrightarrow> A) \<Longrightarrow> A"
  \<comment> \<open>predicate definition and hypothetical context\<close>
begin

lemma classical_contradiction:
  assumes "\<not> A \<Longrightarrow> False"
  shows A
proof (rule classical)
  assume "\<not> A"
  then have False by (rule assms)
  then show A ..
qed

lemma double_negation:
  assumes "\<not> \<not> A"
  shows A
proof (rule classical_contradiction)
  assume "\<not> A"
  with \<open>\<not> \<not> A\<close> show False by (rule contradiction)
qed

lemma tertium_non_datur: "A \<or> \<not> A"
proof (rule double_negation)
  show "\<not> \<not> (A \<or> \<not> A)"
  proof
    assume "\<not> (A \<or> \<not> A)"
    have "\<not> A"
    proof
      assume A then have "A \<or> \<not> A" ..
      with \<open>\<not> (A \<or> \<not> A)\<close> show False by (rule contradiction)
    qed
    then have "A \<or> \<not> A" ..
    with \<open>\<not> (A \<or> \<not> A)\<close> show False by (rule contradiction)
  qed
qed

lemma classical_cases:
  obtains A | "\<not> A"
  using tertium_non_datur
proof
  assume A
  then show thesis ..
next
  assume "\<not> A"
  then show thesis ..
qed

end

lemma classical_if_cases: classical
  if cases: "\<And>A C. (A \<Longrightarrow> C) \<Longrightarrow> (\<not> A \<Longrightarrow> C) \<Longrightarrow> C"
proof
  fix A
  assume *: "\<not> A \<Longrightarrow> A"
  show A
  proof (rule cases)
    assume A
    then show A .
  next
    assume "\<not> A"
    then show A by (rule *)
  qed
qed

section \<open>Peirce's Law\<close>

text \<open>
  Peirce's Law is another characterization of classical reasoning. Its
  statement only requires implication.
\<close>

theorem (in classical) Peirce's_Law: "((A \<longrightarrow> B) \<longrightarrow> A) \<longrightarrow> A"
proof
  assume *: "(A \<longrightarrow> B) \<longrightarrow> A"
  show A
  proof (rule classical)
    assume "\<not> A"
    have "A \<longrightarrow> B"
    proof
      assume A
      with \<open>\<not> A\<close> show B by (rule contradiction)
    qed
    with * show A ..
  qed
qed

section \<open>Hilbert's choice operator (axiomatization)\<close>

axiomatization Eps :: "('a \<Rightarrow> o) \<Rightarrow> 'a"
  where someI: "P x \<Longrightarrow> P (Eps P)"

syntax "_Eps" :: "pttrn \<Rightarrow> o \<Rightarrow> 'a"  ("(3SOME _./ _)" [0, 10] 10)
translations "SOME x. P" \<rightleftharpoons> "CONST Eps (\<lambda>x. P)"

text \<open>
  \<^medskip>
  It follows a derivation of the classical law of tertium-non-datur by
  means of Hilbert's choice operator (due to Berghofer, Beeson, Harrison,
  based on a proof by Diaconescu).
  \<^medskip>
\<close>

theorem Diaconescu: "A \<or> \<not> A"
proof -
  let ?P = "\<lambda>x. (A \<and> x) \<or> \<not> x"
  let ?Q = "\<lambda>x. (A \<and> \<not> x) \<or> x"

  have a: "?P (Eps ?P)"
  proof (rule someI)
    have "\<not> False" ..
    then show "?P False" ..
  qed
  have b: "?Q (Eps ?Q)"
  proof (rule someI)
    have True ..
    then show "?Q True" ..
  qed

  from a show ?thesis
  proof
    assume "A \<and> Eps ?P"
    then have A ..
    then show ?thesis ..
  next
    assume "\<not> Eps ?P"
    from b show ?thesis
    proof
      assume "A \<and> \<not> Eps ?Q"
      then have A ..
      then show ?thesis ..
    next
      assume "Eps ?Q"
      have neq: "?P \<noteq> ?Q"
      proof
        assume "?P = ?Q"
        then have "Eps ?P \<longleftrightarrow> Eps ?Q" by (rule arg_cong)
        also note \<open>Eps ?Q\<close>
        finally have "Eps ?P" .
        with \<open>\<not> Eps ?P\<close> show False by (rule contradiction)
      qed
      have "\<not> A"
      proof
        assume A
        have "?P = ?Q"
        proof (rule ext)
          show "?P x \<longleftrightarrow> ?Q x" for x
          proof
            assume "?P x"
            then show "?Q x"
            proof
              assume "\<not> x"
              with \<open>A\<close> have "A \<and> \<not> x" ..
              then show ?thesis ..
            next
              assume "A \<and> x"
              then have x ..
              then show ?thesis ..
            qed
          next
            assume "?Q x"
            then show "?P x"
            proof
              assume "A \<and> \<not> x"
              then have "\<not> x" ..
              then show ?thesis ..
            next
              assume x
              with \<open>A\<close> have "A \<and> x" ..
              then show ?thesis ..
            qed
          qed
        qed
        with neq show False by (rule contradiction)
      qed
      then show ?thesis ..
    qed
  qed
qed

text \<open>
  This means, the hypothetical predicate \<^const>\<open>classical\<close> always holds
  unconditionally (with all consequences).
\<close>

interpretation classical
proof (rule classical_if_cases)
  fix A C
  assume *: "A \<Longrightarrow> C"
    and **: "\<not> A \<Longrightarrow> C"
  from Diaconescu [of A] show C
  proof
    assume A
    then show C by (rule *)
  next
    assume "\<not> A"
    then show C by (rule **)
  qed
qed

thm classical
  classical_contradiction
  double_negation
  tertium_non_datur
  classical_cases
  Peirce's_Law

end