(*  Title:       A Definitional Encoding of TLA in Isabelle/HOL
    Authors:     Gudmund Grov <ggrov at inf.ed.ac.uk>
                 Stephan Merz <Stephan.Merz at loria.fr>
    Year:        2011
    Maintainer:  Gudmund Grov <ggrov at inf.ed.ac.uk>
*)

section \<open>Lamport's Inc example\<close>

theory Inc
imports State
begin

text\<open>
  This example illustrates use of the embedding by mechanising
  the running example of Lamports original TLA paper \<^cite>\<open>"Lamport94"\<close>.
\<close>

datatype pcount = a | b | g

locale Firstprogram =
  fixes x :: "state \<Rightarrow> nat"
  and y :: "state \<Rightarrow> nat"
  and init :: "temporal"
  and m1  :: "temporal"
  and m2 :: "temporal"
  and phi :: "temporal"
  and Live :: "temporal"
  defines "init \<equiv> TEMP $x = # 0 \<and> $y = # 0"
  and "m1 \<equiv> TEMP x` = Suc<$x> \<and> y` = $y"
  and "m2 \<equiv> TEMP y` = Suc<$y> \<and> x` = $x"
  and "Live \<equiv> TEMP WF(m1)_(x,y) \<and> WF(m2)_(x,y)"
  and "phi \<equiv> TEMP (init \<and> \<box>[m1 \<or> m2]_(x,y) \<and> Live)"
  assumes bvar: "basevars (x,y)"

lemma (in Firstprogram) "STUTINV phi"
  by (auto simp: phi_def init_def m1_def m2_def Live_def stutinvs nstutinvs livestutinv)

lemma (in Firstprogram) enabled_m1: "\<turnstile> Enabled \<langle>m1\<rangle>_(x,y)"
proof (clarify)
  fix s
  show "s \<Turnstile> Enabled \<langle>m1\<rangle>_(x,y)"
    by (rule base_enabled[OF bvar]) (auto simp: m1_def tla_defs)
qed

lemma (in Firstprogram) enabled_m2: "\<turnstile> Enabled \<langle>m2\<rangle>_(x,y)"
proof (clarify)
  fix s
  show "s \<Turnstile> Enabled \<langle>m2\<rangle>_(x,y)"
    by (rule base_enabled[OF bvar]) (auto simp: m2_def tla_defs)
qed

locale Secondprogram = Firstprogram +
  fixes sem :: "state \<Rightarrow> nat"
  and pc1 :: "state \<Rightarrow> pcount"
  and pc2 :: "state \<Rightarrow> pcount"
  and vars
  and initPsi :: "temporal"
  and alpha1 :: "temporal"
  and alpha2 :: "temporal"
  and beta1 :: "temporal"
  and beta2 :: "temporal"
  and gamma1 :: "temporal"
  and gamma2 :: "temporal"
  and n1 :: "temporal"
  and n2 :: "temporal"
  and Live2 :: "temporal"
  and psi :: "temporal"
  and I :: "temporal"
  defines "vars \<equiv> LIFT (x,y,sem,pc1,pc2)"
  and "initPsi \<equiv> TEMP $pc1 = # a \<and> $pc2 = # a \<and> $x = # 0 \<and> $y = # 0 \<and> $sem = # 1"
  and "alpha1 \<equiv> TEMP $pc1 =#a \<and> # 0 < $sem \<and> pc1$ = #b \<and> sem$ = $sem - # 1 \<and> Unchanged (x,y,pc2)"
  and "alpha2 \<equiv> TEMP $pc2 =#a \<and> # 0 < $sem \<and> pc2` = #b \<and> sem$ = $sem - # 1 \<and> Unchanged (x,y,pc1)"
  and "beta1 \<equiv> TEMP $pc1 =#b \<and> pc1` = #g \<and> x` = Suc<$x> \<and> Unchanged (y,sem,pc2)"
  and "beta2 \<equiv> TEMP $pc2 =#b \<and> pc2` = #g \<and> y` = Suc<$y> \<and> Unchanged (x,sem,pc1)"
  and "gamma1 \<equiv> TEMP $pc1 =#g \<and> pc1` = #a \<and> sem` = Suc<$sem> \<and> Unchanged (x,y,pc2)"
  and "gamma2 \<equiv> TEMP $pc2 =#g \<and> pc2` = #a \<and> sem` = Suc<$sem> \<and> Unchanged (x,y,pc1)"
  and "n1 \<equiv> TEMP (alpha1 \<or> beta1 \<or> gamma1)"
  and "n2 \<equiv> TEMP (alpha2 \<or> beta2 \<or> gamma2)"
  and "Live2 \<equiv> TEMP SF(n1)_vars \<and> SF(n2)_vars"
  and "psi \<equiv> TEMP (initPsi \<and> \<box>[n1 \<or> n2]_vars \<and> Live2)"
  and "I \<equiv> TEMP ($sem = # 1 \<and> $pc1 = #a \<and> $pc2 = # a)
               \<or>   ($sem = # 0 \<and> (($pc1 = #a \<and> $pc2 \<in> {#b , #g})
                                \<or> ($pc2 = #a \<and> $pc1 \<in> {#b , #g})))"
  assumes bvar2: "basevars vars"

lemmas  (in Secondprogram) Sact2_defs = n1_def n2_def alpha1_def beta1_def gamma1_def alpha2_def beta2_def gamma2_def

text \<open>
  Proving invariants is the basis of every effort of system verification.
  We show that \<open>I\<close> is an inductive invariant of specification \<open>psi\<close>.
\<close>
lemma (in Secondprogram) psiI: "\<turnstile> psi \<longrightarrow> \<box>I"
proof -
  have init: "\<turnstile> initPsi \<longrightarrow> I" by (auto simp: initPsi_def I_def)
  have "|~ I \<and> Unchanged vars \<longrightarrow> \<circle>I" by (auto simp: I_def vars_def tla_defs)
  moreover
  have "|~ I \<and> n1 \<longrightarrow> \<circle>I" by (auto simp: I_def Sact2_defs tla_defs)
  moreover
  have "|~ I \<and> n2 \<longrightarrow> \<circle>I" by (auto simp: I_def Sact2_defs tla_defs)
  ultimately have step: "|~ I \<and> [n1 \<or> n2]_vars \<longrightarrow> \<circle>I" by (force simp: actrans_def)
  from init step have goal: "\<turnstile> initPsi \<and> \<box>[n1 \<or> n2]_vars \<longrightarrow> \<box>I" by (rule invmono)
  have "\<turnstile> initPsi \<and> \<box>[n1 \<or> n2]_vars \<and> Live2 ==> \<turnstile> initPsi \<and> \<box>[n1 \<or> n2]_vars"
   by auto
  with goal show ?thesis unfolding psi_def by auto
qed

text \<open>
  Using this invariant we now prove step simulation, i.e. the safety part of
  the refinement proof.
\<close>

theorem (in Secondprogram) step_simulation: "\<turnstile> psi \<longrightarrow> init \<and> \<box>[m1 \<or> m2]_(x,y)"
proof -
  have "\<turnstile> initPsi \<and> \<box>I \<and> \<box>[n1 \<or> n2]_vars \<longrightarrow> init \<and> \<box>[m1 \<or> m2]_(x,y)"
  proof (rule refinement1)
    show "\<turnstile> initPsi \<longrightarrow> init" by (auto simp: initPsi_def init_def)
  next
    show "|~ I \<and> \<circle>I \<and> [n1 \<or> n2]_vars \<longrightarrow> [m1 \<or> m2]_(x,y)"
      by (auto simp: I_def m1_def m2_def vars_def Sact2_defs tla_defs)
  qed
  with psiI show ?thesis unfolding psi_def by force
qed

text \<open>
  Liveness proofs require computing the enabledness conditions of actions.
  The first lemma below shows that all steps are visible, i.e. they change
  at least one variable.
\<close>
lemma  (in Secondprogram) n1_ch: "|~ \<langle>n1\<rangle>_vars = n1"
proof -
  have "|~ n1 \<longrightarrow> \<langle>n1\<rangle>_vars" by (auto simp: Sact2_defs tla_defs vars_def)
  thus ?thesis by (auto simp: angle_actrans_sem[int_rewrite])
qed

lemma (in Secondprogram) enab_alpha1: "\<turnstile> $pc1 = #a \<longrightarrow> # 0 < $sem \<longrightarrow> Enabled alpha1"
proof (clarsimp simp: tla_defs)
  fix s :: "state seq"
  assume "pc1 (s 0) = a" and "0 < sem (s 0)"
  thus "s \<Turnstile> Enabled alpha1"
    by (intro base_enabled[OF bvar2]) (auto simp: Sact2_defs tla_defs vars_def)
qed

lemma (in Secondprogram) enab_beta1: "\<turnstile> $pc1 = #b \<longrightarrow> Enabled beta1"
proof (clarsimp simp: tla_defs)
  fix s :: "state seq"
  assume "pc1 (s 0) = b"
  thus "s \<Turnstile> Enabled beta1"
    by (intro base_enabled[OF bvar2]) (auto simp: Sact2_defs tla_defs vars_def)
qed

lemma (in Secondprogram) enab_gamma1: "\<turnstile> $pc1 = #g \<longrightarrow> Enabled gamma1"
proof (clarsimp simp: tla_defs)
  fix s :: "state seq"
  assume "pc1 (s 0) = g"
  thus "s \<Turnstile> Enabled gamma1"
    by (intro base_enabled[OF bvar2]) (auto simp: Sact2_defs tla_defs vars_def)
qed

lemma (in Secondprogram) enab_n1:
  "\<turnstile> Enabled \<langle>n1\<rangle>_vars = ($pc1 = #a \<longrightarrow> # 0 < $sem)"
unfolding n1_ch[int_rewrite] proof (rule int_iffI)
  show "\<turnstile> Enabled n1 \<longrightarrow> $pc1 = #a \<longrightarrow> # 0 < $sem"
    by (auto elim!: enabledE simp: Sact2_defs tla_defs)
next
  show "\<turnstile> ($pc1 = #a \<longrightarrow> # 0 < $sem) \<longrightarrow> Enabled n1"
  proof (clarsimp simp: tla_defs)
    fix s :: "state seq"
    assume "pc1 (s 0) = a \<longrightarrow> 0 < sem (s 0)"
    thus "s \<Turnstile> Enabled n1"
      using enab_alpha1[unlift_rule]
            enab_beta1[unlift_rule]
            enab_gamma1[unlift_rule]
      by (cases "pc1 (s 0)") (force simp: n1_def Enabled_disj[int_rewrite] tla_defs)+
  qed
qed

text \<open>
  The analogous properties for the second process are obtained by copy and paste.
\<close>
lemma  (in Secondprogram) n2_ch: "|~ \<langle>n2\<rangle>_vars = n2"
proof -
  have "|~ n2 \<longrightarrow> \<langle>n2\<rangle>_vars" by (auto simp: Sact2_defs tla_defs vars_def)
  thus ?thesis by (auto simp: angle_actrans_sem[int_rewrite])
qed

lemma (in Secondprogram) enab_alpha2: "\<turnstile> $pc2 = #a \<longrightarrow> # 0 < $sem \<longrightarrow> Enabled alpha2"
proof (clarsimp simp: tla_defs)
  fix s :: "state seq"
  assume "pc2 (s 0) = a" and "0 < sem (s 0)"
  thus "s \<Turnstile> Enabled alpha2"
    by (intro base_enabled[OF bvar2]) (auto simp: Sact2_defs tla_defs vars_def)
qed

lemma (in Secondprogram) enab_beta2: "\<turnstile> $pc2 = #b \<longrightarrow> Enabled beta2"
proof (clarsimp simp: tla_defs)
  fix s :: "state seq"
  assume "pc2 (s 0) = b"
  thus "s \<Turnstile> Enabled beta2"
    by (intro base_enabled[OF bvar2]) (auto simp: Sact2_defs tla_defs vars_def)
qed

lemma (in Secondprogram) enab_gamma2: "\<turnstile> $pc2 = #g \<longrightarrow> Enabled gamma2"
proof (clarsimp simp: tla_defs)
  fix s :: "state seq"
  assume "pc2 (s 0) = g"
  thus "s \<Turnstile> Enabled gamma2"
    by (intro base_enabled[OF bvar2]) (auto simp: Sact2_defs tla_defs vars_def)
qed

lemma (in Secondprogram) enab_n2:
  "\<turnstile> Enabled \<langle>n2\<rangle>_vars = ($pc2 = #a \<longrightarrow> # 0 < $sem)"
unfolding n2_ch[int_rewrite] proof (rule int_iffI)
  show "\<turnstile> Enabled n2 \<longrightarrow> $pc2 = #a \<longrightarrow> # 0 < $sem"
    by (auto elim!: enabledE simp: Sact2_defs tla_defs)
next
  show "\<turnstile> ($pc2 = #a \<longrightarrow> # 0 < $sem) \<longrightarrow> Enabled n2"
  proof (clarsimp simp: tla_defs)
    fix s :: "state seq"
    assume "pc2 (s 0) = a \<longrightarrow> 0 < sem (s 0)"
    thus "s \<Turnstile> Enabled n2"
      using enab_alpha2[unlift_rule]
            enab_beta2[unlift_rule]
            enab_gamma2[unlift_rule]
      by (cases "pc2 (s 0)") (force simp: n2_def Enabled_disj[int_rewrite] tla_defs)+
  qed
qed

text \<open>
  We use rule \<open>SF2\<close> to prove that \<open>psi\<close> implements strong fairness
  for the abstract action \<open>m1\<close>. Since strong fairness implies weak fairness,
  it follows that \<open>psi\<close> refines the liveness condition of \<open>phi\<close>.
\<close>

lemma (in Secondprogram) psi_fair_m1: "\<turnstile> psi \<longrightarrow> SF(m1)_(x,y)"
proof -
  have "\<turnstile> \<box>[n1 \<or> n2]_vars \<and> SF(n1)_vars \<and> \<box>(I \<and> SF(n2)_vars) \<longrightarrow> SF(m1)_(x,y)"
  proof (rule SF2)
    txt \<open>
      Rule \<open>SF2\<close> requires us to choose a helpful action (whose effect implies
      \<open>\<langle>m1\<rangle>_(x,y)\<close>) and a persistent condition, which will eventually remain
      true if the helpful action is never executed. In our case, the helpful action
      is \<open>beta1\<close> and the persistent condition is \<open>pc1 = b\<close>.
\<close>
    show "|~ \<langle>(n1 \<or> n2) \<and> beta1\<rangle>_vars \<longrightarrow> \<langle>m1\<rangle>_(x,y)"
      by (auto simp: beta1_def m1_def vars_def tla_defs)
  next
    show "|~ $pc1 = #b \<and> \<circle>($pc1 = #b) \<and> \<langle>(n1 \<or> n2) \<and> n1\<rangle>_vars \<longrightarrow> beta1"
      by (auto simp: n1_def alpha1_def beta1_def gamma1_def tla_defs)
  next
    show "\<turnstile> $pc1 = #b \<and> Enabled \<langle>m1\<rangle>_(x, y) \<longrightarrow> Enabled \<langle>n1\<rangle>_vars"
      unfolding enab_n1[int_rewrite] by auto
  next
    txt \<open>
      The difficult part of the proof is showing that the persistent condition
      will eventually always be true if the helpful action is never executed.
      We show that (1) whenever the condition becomes true it remains so and
      (2) eventually the condition must be true.
\<close>
    show "\<turnstile> \<box>[(n1 \<or> n2) \<and> \<not> beta1]_vars
            \<and> SF(n1)_vars \<and> \<box>(I \<and> SF(n2)_vars) \<and> \<box>\<diamond>Enabled \<langle>m1\<rangle>_(x, y)
            \<longrightarrow> \<diamond>\<box>($pc1 = #b)"
    proof -
      have "\<turnstile> \<box>\<box>[(n1 \<or> n2) \<and> \<not> beta1]_vars \<longrightarrow> \<box>($pc1 = #b \<longrightarrow> \<box>($pc1 = #b))"
      proof (rule STL4)
        have "|~ $pc1 = #b \<and> [(n1 \<or> n2) \<and> \<not> beta1]_vars \<longrightarrow> \<circle>($pc1 = #b)"
          by (auto simp: Sact2_defs vars_def tla_defs)
        from this[THEN INV1]
        show "\<turnstile> \<box>[(n1 \<or> n2) \<and> \<not> beta1]_vars \<longrightarrow> $pc1 = #b \<longrightarrow> \<box>($pc1 = #b)" by auto
      qed
      hence 1: "\<turnstile> \<box>[(n1 \<or> n2) \<and> \<not> beta1]_vars \<longrightarrow> \<diamond>($pc1 = #b) \<longrightarrow> \<diamond>\<box>($pc1 = #b)"
        by (force intro: E31[unlift_rule])
      have "\<turnstile> \<box>[(n1 \<or> n2) \<and> \<not> beta1]_vars \<and> SF(n1)_vars \<and> \<box>(I \<and> SF(n2)_vars)
              \<longrightarrow> \<diamond>($pc1 = #b)"
      proof -
        txt \<open>
          The plan of the proof is to show that from any state where \<open>pc1 = g\<close>
          one eventually reaches \<open>pc1 = a\<close>, from where one eventually reaches
          \<open>pc1 = b\<close>. The result follows by combining leadsto properties.
\<close>
        let ?F = "LIFT (\<box>[(n1 \<or> n2) \<and> \<not> beta1]_vars \<and> SF(n1)_vars \<and> \<box>(I \<and> SF(n2)_vars))"
        txt \<open>
          Showing that \<open>pc1 = g\<close> leads to \<open>pc1 = a\<close> is a simple
          application of rule \<open>SF1\<close> because the first process completely
          controls this transition.
\<close>
        have ga: "\<turnstile> ?F \<longrightarrow> ($pc1 = #g \<leadsto> $pc1 = #a)"
        proof (rule SF1)
          show "|~ $pc1 = #g \<and> [(n1 \<or> n2) \<and> \<not> beta1]_vars \<longrightarrow> \<circle>($pc1 = #g) \<or> \<circle>($pc1 = #a)"
            by (auto simp: Sact2_defs vars_def tla_defs)
        next
          show "|~ $pc1 = #g \<and> \<langle>((n1 \<or> n2) \<and> \<not> beta1) \<and> n1\<rangle>_vars \<longrightarrow> \<circle>($pc1 = #a)"
            by (auto simp: Sact2_defs vars_def tla_defs)
        next
          show "|~ $pc1 = #g \<and> Unchanged vars \<longrightarrow> \<circle>($pc1 = #g)"
            by (auto simp: vars_def tla_defs)
        next
          have "\<turnstile> $pc1 = #g \<longrightarrow> Enabled \<langle>n1\<rangle>_vars"
            unfolding enab_n1[int_rewrite] by (auto simp: tla_defs)
          hence "\<turnstile> \<box>($pc1 = #g) \<longrightarrow> Enabled \<langle>n1\<rangle>_vars"
            by (rule lift_imp_trans[OF ax1])
          hence "\<turnstile> \<box>($pc1 = #g) \<longrightarrow> \<diamond>Enabled \<langle>n1\<rangle>_vars"
            by (rule lift_imp_trans[OF _ E3])
          thus "\<turnstile> \<box>($pc1 = #g) \<and> \<box>[(n1 \<or> n2) \<and> \<not> beta1]_vars \<and> \<box>(I \<and> SF(n2)_vars)
                  \<longrightarrow> \<diamond>Enabled \<langle>n1\<rangle>_vars"
            by auto
        qed
        txt \<open>
          The proof that \<open>pc1 = a\<close> leads to \<open>pc1 = b\<close> follows
          the same basic schema. However, showing that \<open>n1\<close> is eventually
          enabled requires reasoning about the second process, which must liberate
          the critical section.
\<close>
        have ab: "\<turnstile> ?F \<longrightarrow> ($pc1 = #a \<leadsto> $pc1 = #b)"
        proof (rule SF1)
          show "|~ $pc1 = #a \<and> [(n1 \<or> n2) \<and> \<not> beta1]_vars \<longrightarrow> \<circle>($pc1 = #a) \<or> \<circle>($pc1 = #b)"
            by (auto simp: Sact2_defs vars_def tla_defs)
        next
          show "|~ $pc1 = #a \<and> \<langle>((n1 \<or> n2) \<and> \<not> beta1) \<and> n1\<rangle>_vars \<longrightarrow> \<circle>($pc1 = #b)"
            by (auto simp: Sact2_defs vars_def tla_defs)
        next
          show "|~ $pc1 = #a \<and> Unchanged vars \<longrightarrow> \<circle>($pc1 = #a)"
            by (auto simp: vars_def tla_defs)
        next
          txt \<open>We establish a suitable leadsto-chain.\<close>
          let ?G = "LIFT \<box>[(n1 \<or> n2) \<and> \<not> beta1]_vars \<and> SF(n2)_vars \<and> \<box>($pc1 = #a \<and> I)"
          have "\<turnstile> ?G \<longrightarrow> \<diamond>($pc2 = #a \<and> $pc1 = #a \<and> I)"
          proof -
            txt \<open>Rule \<open>SF1\<close> takes us from \<open>pc2 = b\<close> to \<open>pc2 = g\<close>.\<close>
            have bg2: "\<turnstile> ?G \<longrightarrow> ($pc2 = #b \<leadsto> $pc2 = #g)"
            proof (rule SF1)
              show "|~ $pc2 = #b \<and> [(n1 \<or> n2) \<and> \<not>beta1]_vars \<longrightarrow> \<circle>($pc2 = #b) \<or> \<circle>($pc2 = #g)"
                by (auto simp: Sact2_defs vars_def tla_defs)
            next
              show "|~ $pc2 = #b \<and> \<langle>((n1 \<or> n2) \<and> \<not>beta1) \<and> n2\<rangle>_vars \<longrightarrow> \<circle>($pc2 = #g)"
                by (auto simp: Sact2_defs vars_def tla_defs)
            next
              show "|~ $pc2 = #b \<and> Unchanged vars \<longrightarrow> \<circle>($pc2 = #b)"
                by (auto simp: vars_def tla_defs)
            next
              have "\<turnstile> $pc2 = #b \<longrightarrow> Enabled \<langle>n2\<rangle>_vars"
                unfolding enab_n2[int_rewrite] by (auto simp: tla_defs)
              hence "\<turnstile> \<box>($pc2 = #b) \<longrightarrow> Enabled \<langle>n2\<rangle>_vars"
                by (rule lift_imp_trans[OF ax1])
              hence "\<turnstile> \<box>($pc2 = #b) \<longrightarrow> \<diamond>Enabled \<langle>n2\<rangle>_vars"
                by (rule lift_imp_trans[OF _ E3])
              thus "\<turnstile> \<box>($pc2 = #b) \<and> \<box>[(n1 \<or> n2) \<and> \<not>beta1]_vars \<and> \<box>($pc1 = #a \<and> I)
                      \<longrightarrow> \<diamond>Enabled \<langle>n2\<rangle>_vars"
                by auto
            qed
            txt \<open>Similarly, \<open>pc2 = b\<close> leads to \<open>pc2 = g\<close>.\<close>
            have ga2: "\<turnstile> ?G \<longrightarrow> ($pc2 = #g \<leadsto> $pc2 = #a)"
            proof (rule SF1)
              show "|~ $pc2 = #g \<and> [(n1 \<or> n2) \<and> \<not>beta1]_vars \<longrightarrow> \<circle>($pc2 = #g) \<or> \<circle>($pc2 = #a)"
                by (auto simp: Sact2_defs vars_def tla_defs)
            next
              show "|~ $pc2 = #g \<and> \<langle>((n1 \<or> n2) \<and> \<not>beta1) \<and> n2\<rangle>_vars \<longrightarrow> \<circle>($pc2 = #a)"
                by (auto simp: n2_def alpha2_def beta2_def gamma2_def vars_def tla_defs)
            next
              show "|~ $pc2 = #g \<and> Unchanged vars \<longrightarrow> \<circle>($pc2 = #g)"
                by (auto simp: vars_def tla_defs)
            next
              have "\<turnstile> $pc2 = #g \<longrightarrow> Enabled \<langle>n2\<rangle>_vars"
                unfolding enab_n2[int_rewrite] by (auto simp: tla_defs)
              hence "\<turnstile> \<box>($pc2 = #g) \<longrightarrow> Enabled \<langle>n2\<rangle>_vars"
                by (rule lift_imp_trans[OF ax1])
              hence "\<turnstile> \<box>($pc2 = #g) \<longrightarrow> \<diamond>Enabled \<langle>n2\<rangle>_vars"
                by (rule lift_imp_trans[OF _ E3])
              thus "\<turnstile> \<box>($pc2 = #g) \<and> \<box>[(n1 \<or> n2) \<and> \<not>beta1]_vars \<and> \<box>($pc1 = #a \<and> I)
                      \<longrightarrow> \<diamond>Enabled \<langle>n2\<rangle>_vars"
                by auto
            qed
            with bg2 have "\<turnstile> ?G \<longrightarrow> ($pc2 = #b \<leadsto> $pc2 = #a)"
              by (force elim: LT13[unlift_rule])
            with ga2 have "\<turnstile> ?G \<longrightarrow> ($pc2 = #a \<or> $pc2 = #b \<or> $pc2 = #g) \<leadsto> ($pc2 = #a)"
              unfolding LT17[int_rewrite] LT1[int_rewrite] by force
            moreover
            have "\<turnstile> $pc2 = #a \<or> $pc2 = #b \<or> $pc2 = #g"
            proof (clarsimp simp: tla_defs)
              fix s :: "state seq"
              assume "pc2 (s 0) \<noteq> a" and "pc2 (s 0) \<noteq> g"
              thus "pc2 (s 0) = b" by (cases "pc2 (s 0)") auto
            qed
            hence "\<turnstile> (($pc2 = #a \<or> $pc2 = #b \<or> $pc2 = #g) \<leadsto> $pc2 = #a) \<longrightarrow> \<diamond>($pc2 = #a)"
              by (rule fmp[OF _ LT4])
            ultimately
            have "\<turnstile> ?G \<longrightarrow> \<diamond>($pc2 = #a)" by force
            thus ?thesis by (auto intro!: SE3[unlift_rule])
          qed
          moreover
          have "\<turnstile> \<diamond>($pc2 = #a \<and> $pc1 = #a \<and> I) \<longrightarrow> \<diamond>Enabled \<langle>n1\<rangle>_vars"
            unfolding enab_n1[int_rewrite] by (rule STL4_eve) (auto simp: I_def tla_defs)
          ultimately
          show "\<turnstile> \<box>($pc1 = #a) \<and> \<box>[(n1 \<or> n2) \<and> \<not> beta1]_vars \<and> \<box>(I \<and> SF(n2)_vars)
                  \<longrightarrow> \<diamond>Enabled \<langle>n1\<rangle>_vars"
            by (force simp: STL5[int_rewrite])
        qed
        from ga ab have "\<turnstile> ?F \<longrightarrow> ($pc1 = #g \<leadsto> $pc1 = #b)"
          by (force elim: LT13[unlift_rule])
        with ab have "\<turnstile> ?F \<longrightarrow> (($pc1 = #a \<or> $pc1 = #b \<or> $pc1 = #g) \<leadsto> $pc1 = #b)"
          unfolding LT17[int_rewrite] LT1[int_rewrite] by force
        moreover
        have "\<turnstile> $pc1 = #a \<or> $pc1 = #b \<or> $pc1 = #g"
        proof (clarsimp simp: tla_defs)
          fix s :: "state seq"
          assume "pc1 (s 0) \<noteq> a" and "pc1 (s 0) \<noteq> g"
          thus "pc1 (s 0) = b" by (cases "pc1 (s 0)", auto)
        qed
        hence "\<turnstile> (($pc1 = #a \<or> $pc1 = #b \<or> $pc1 = #g) \<leadsto> $pc1 = #b) \<longrightarrow> \<diamond>($pc1 = #b)"
          by (rule fmp[OF _ LT4])
        ultimately show ?thesis by (rule lift_imp_trans)
      qed
      with 1 show ?thesis by force
    qed
  qed
  with psiI show ?thesis unfolding psi_def Live2_def STL5[int_rewrite] by force
qed

text \<open>
  In the same way we prove that \<open>psi\<close> implements strong fairness
  for the abstract action \<open>m1\<close>. The proof is obtained by copy and paste
  from the previous one.
\<close>

lemma (in Secondprogram) psi_fair_m2: "\<turnstile> psi \<longrightarrow> SF(m2)_(x,y)"
proof -
  have "\<turnstile> \<box>[n1 \<or> n2]_vars \<and> SF(n2)_vars \<and> \<box>(I \<and> SF(n1)_vars) \<longrightarrow> SF(m2)_(x,y)"
  proof (rule SF2)
    txt \<open>
      Rule \<open>SF2\<close> requires us to choose a helpful action (whose effect implies
      \<open>\<langle>m2\<rangle>_(x,y)\<close>) and a persistent condition, which will eventually remain
      true if the helpful action is never executed. In our case, the helpful action
      is \<open>beta2\<close> and the persistent condition is \<open>pc2 = b\<close>.
\<close>
    show "|~ \<langle>(n1 \<or> n2) \<and> beta2\<rangle>_vars \<longrightarrow> \<langle>m2\<rangle>_(x,y)"
      by (auto simp: beta2_def m2_def vars_def tla_defs)
  next
    show "|~ $pc2 = #b \<and> \<circle>($pc2 = #b) \<and> \<langle>(n1 \<or> n2) \<and> n2\<rangle>_vars \<longrightarrow> beta2"
      by (auto simp: n2_def alpha2_def beta2_def gamma2_def tla_defs)
  next
    show "\<turnstile> $pc2 = #b \<and> Enabled \<langle>m2\<rangle>_(x, y) \<longrightarrow> Enabled \<langle>n2\<rangle>_vars"
      unfolding enab_n2[int_rewrite] by auto
  next
    txt \<open>
      The difficult part of the proof is showing that the persistent condition
      will eventually always be true if the helpful action is never executed.
      We show that (1) whenever the condition becomes true it remains so and
      (2) eventually the condition must be true.
\<close>
    show "\<turnstile> \<box>[(n1 \<or> n2) \<and> \<not> beta2]_vars
            \<and> SF(n2)_vars \<and> \<box>(I \<and> SF(n1)_vars) \<and> \<box>\<diamond>Enabled \<langle>m2\<rangle>_(x, y)
            \<longrightarrow> \<diamond>\<box>($pc2 = #b)"
    proof -
      have "\<turnstile> \<box>\<box>[(n1 \<or> n2) \<and> \<not> beta2]_vars \<longrightarrow> \<box>($pc2 = #b \<longrightarrow> \<box>($pc2 = #b))"
      proof (rule STL4)
        have "|~ $pc2 = #b \<and> [(n1 \<or> n2) \<and> \<not> beta2]_vars \<longrightarrow> \<circle>($pc2 = #b)"
          by (auto simp: Sact2_defs vars_def tla_defs)
        from this[THEN INV1]
        show "\<turnstile> \<box>[(n1 \<or> n2) \<and> \<not> beta2]_vars \<longrightarrow> $pc2 = #b \<longrightarrow> \<box>($pc2 = #b)" by auto
      qed
      hence 1: "\<turnstile> \<box>[(n1 \<or> n2) \<and> \<not> beta2]_vars \<longrightarrow> \<diamond>($pc2 = #b) \<longrightarrow> \<diamond>\<box>($pc2 = #b)"
        by (force intro: E31[unlift_rule])
      have "\<turnstile> \<box>[(n1 \<or> n2) \<and> \<not> beta2]_vars \<and> SF(n2)_vars \<and> \<box>(I \<and> SF(n1)_vars)
              \<longrightarrow> \<diamond>($pc2 = #b)"
      proof -
        txt \<open>
          The plan of the proof is to show that from any state where \<open>pc2 = g\<close>
          one eventually reaches \<open>pc2 = a\<close>, from where one eventually reaches
          \<open>pc2 = b\<close>. The result follows by combining leadsto properties.
\<close>
        let ?F = "LIFT (\<box>[(n1 \<or> n2) \<and> \<not> beta2]_vars \<and> SF(n2)_vars \<and> \<box>(I \<and> SF(n1)_vars))"
        txt \<open>
          Showing that \<open>pc2 = g\<close> leads to \<open>pc2 = a\<close> is a simple
          application of rule \<open>SF1\<close> because the second process completely
          controls this transition.
\<close>
        have ga: "\<turnstile> ?F \<longrightarrow> ($pc2 = #g \<leadsto> $pc2 = #a)"
        proof (rule SF1)
          show "|~ $pc2 = #g \<and> [(n1 \<or> n2) \<and> \<not> beta2]_vars \<longrightarrow> \<circle>($pc2 = #g) \<or> \<circle>($pc2 = #a)"
            by (auto simp: Sact2_defs vars_def tla_defs)
        next
          show "|~ $pc2 = #g \<and> \<langle>((n1 \<or> n2) \<and> \<not> beta2) \<and> n2\<rangle>_vars \<longrightarrow> \<circle>($pc2 = #a)"
            by (auto simp: n2_def alpha2_def beta2_def gamma2_def vars_def tla_defs)
        next
          show "|~ $pc2 = #g \<and> Unchanged vars \<longrightarrow> \<circle>($pc2 = #g)"
            by (auto simp: vars_def tla_defs)
        next
          have "\<turnstile> $pc2 = #g \<longrightarrow> Enabled \<langle>n2\<rangle>_vars"
            unfolding enab_n2[int_rewrite] by (auto simp: tla_defs)
          hence "\<turnstile> \<box>($pc2 = #g) \<longrightarrow> Enabled \<langle>n2\<rangle>_vars"
            by (rule lift_imp_trans[OF ax1])
          hence "\<turnstile> \<box>($pc2 = #g) \<longrightarrow> \<diamond>Enabled \<langle>n2\<rangle>_vars"
            by (rule lift_imp_trans[OF _ E3])
          thus "\<turnstile> \<box>($pc2 = #g) \<and> \<box>[(n1 \<or> n2) \<and> \<not> beta2]_vars \<and> \<box>(I \<and> SF(n1)_vars)
                  \<longrightarrow> \<diamond>Enabled \<langle>n2\<rangle>_vars"
            by auto
        qed
        txt \<open>
          The proof that \<open>pc2 = a\<close> leads to \<open>pc2 = b\<close> follows
          the same basic schema. However, showing that \<open>n2\<close> is eventually
          enabled requires reasoning about the second process, which must liberate
          the critical section.
\<close>
        have ab: "\<turnstile> ?F \<longrightarrow> ($pc2 = #a \<leadsto> $pc2 = #b)"
        proof (rule SF1)
          show "|~ $pc2 = #a \<and> [(n1 \<or> n2) \<and> \<not> beta2]_vars \<longrightarrow> \<circle>($pc2 = #a) \<or> \<circle>($pc2 = #b)"
            by (auto simp: Sact2_defs vars_def tla_defs)
        next
          show "|~ $pc2 = #a \<and> \<langle>((n1 \<or> n2) \<and> \<not> beta2) \<and> n2\<rangle>_vars \<longrightarrow> \<circle>($pc2 = #b)"
            by (auto simp: n2_def alpha2_def beta2_def gamma2_def vars_def tla_defs)
        next
          show "|~ $pc2 = #a \<and> Unchanged vars \<longrightarrow> \<circle>($pc2 = #a)"
            by (auto simp: vars_def tla_defs)
        next
          txt \<open>We establish a suitable leadsto-chain.\<close>
          let ?G = "LIFT \<box>[(n1 \<or> n2) \<and> \<not> beta2]_vars \<and> SF(n1)_vars \<and> \<box>($pc2 = #a \<and> I)"
          have "\<turnstile> ?G \<longrightarrow> \<diamond>($pc1 = #a \<and> $pc2 = #a \<and> I)"
          proof -
            txt \<open>Rule \<open>SF1\<close> takes us from \<open>pc1 = b\<close> to \<open>pc1 = g\<close>.\<close>
            have bg1: "\<turnstile> ?G \<longrightarrow> ($pc1 = #b \<leadsto> $pc1 = #g)"
            proof (rule SF1)
              show "|~ $pc1 = #b \<and> [(n1 \<or> n2) \<and> \<not>beta2]_vars \<longrightarrow> \<circle>($pc1 = #b) \<or> \<circle>($pc1 = #g)"
                by (auto simp: Sact2_defs vars_def tla_defs)
            next
              show "|~ $pc1 = #b \<and> \<langle>((n1 \<or> n2) \<and> \<not>beta2) \<and> n1\<rangle>_vars \<longrightarrow> \<circle>($pc1 = #g)"
                by (auto simp: n1_def alpha1_def beta1_def gamma1_def vars_def tla_defs)
            next
              show "|~ $pc1 = #b \<and> Unchanged vars \<longrightarrow> \<circle>($pc1 = #b)"
                by (auto simp: vars_def tla_defs)
            next
              have "\<turnstile> $pc1 = #b \<longrightarrow> Enabled \<langle>n1\<rangle>_vars"
                unfolding enab_n1[int_rewrite] by (auto simp: tla_defs)
              hence "\<turnstile> \<box>($pc1 = #b) \<longrightarrow> Enabled \<langle>n1\<rangle>_vars"
                by (rule lift_imp_trans[OF ax1])
              hence "\<turnstile> \<box>($pc1 = #b) \<longrightarrow> \<diamond>Enabled \<langle>n1\<rangle>_vars"
                by (rule lift_imp_trans[OF _ E3])
              thus "\<turnstile> \<box>($pc1 = #b) \<and> \<box>[(n1 \<or> n2) \<and> \<not>beta2]_vars \<and> \<box>($pc2 = #a \<and> I)
                      \<longrightarrow> \<diamond>Enabled \<langle>n1\<rangle>_vars"
                by auto
            qed
            txt \<open>Similarly, \<open>pc1 = b\<close> leads to \<open>pc1 = g\<close>.\<close>
            have ga1: "\<turnstile> ?G \<longrightarrow> ($pc1 = #g \<leadsto> $pc1 = #a)"
            proof (rule SF1)
              show "|~ $pc1 = #g \<and> [(n1 \<or> n2) \<and> \<not>beta2]_vars \<longrightarrow> \<circle>($pc1 = #g) \<or> \<circle>($pc1 = #a)"
                by (auto simp: Sact2_defs vars_def tla_defs)
            next
              show "|~ $pc1 = #g \<and> \<langle>((n1 \<or> n2) \<and> \<not>beta2) \<and> n1\<rangle>_vars \<longrightarrow> \<circle>($pc1 = #a)"
                by (auto simp: n1_def alpha1_def beta1_def gamma1_def vars_def tla_defs)
            next
              show "|~ $pc1 = #g \<and> Unchanged vars \<longrightarrow> \<circle>($pc1 = #g)"
                by (auto simp: vars_def tla_defs)
            next
              have "\<turnstile> $pc1 = #g \<longrightarrow> Enabled \<langle>n1\<rangle>_vars"
                unfolding enab_n1[int_rewrite] by (auto simp: tla_defs)
              hence "\<turnstile> \<box>($pc1 = #g) \<longrightarrow> Enabled \<langle>n1\<rangle>_vars"
                by (rule lift_imp_trans[OF ax1])
              hence "\<turnstile> \<box>($pc1 = #g) \<longrightarrow> \<diamond>Enabled \<langle>n1\<rangle>_vars"
                by (rule lift_imp_trans[OF _ E3])
              thus "\<turnstile> \<box>($pc1 = #g) \<and> \<box>[(n1 \<or> n2) \<and> \<not>beta2]_vars \<and> \<box>($pc2 = #a \<and> I)
                      \<longrightarrow> \<diamond>Enabled \<langle>n1\<rangle>_vars"
                by auto
            qed
            with bg1 have "\<turnstile> ?G \<longrightarrow> ($pc1 = #b \<leadsto> $pc1 = #a)"
              by (force elim: LT13[unlift_rule])
            with ga1 have "\<turnstile> ?G \<longrightarrow> ($pc1 = #a \<or> $pc1 = #b \<or> $pc1 = #g) \<leadsto> ($pc1 = #a)"
              unfolding LT17[int_rewrite] LT1[int_rewrite] by force
            moreover
            have "\<turnstile> $pc1 = #a \<or> $pc1 = #b \<or> $pc1 = #g"
            proof (clarsimp simp: tla_defs)
              fix s :: "state seq"
              assume "pc1 (s 0) \<noteq> a" and "pc1 (s 0) \<noteq> g"
              thus "pc1 (s 0) = b" by (cases "pc1 (s 0)") auto
            qed
            hence "\<turnstile> (($pc1 = #a \<or> $pc1 = #b \<or> $pc1 = #g) \<leadsto> $pc1 = #a) \<longrightarrow> \<diamond>($pc1 = #a)"
              by (rule fmp[OF _ LT4])
            ultimately
            have "\<turnstile> ?G \<longrightarrow> \<diamond>($pc1 = #a)" by force
            thus ?thesis by (auto intro!: SE3[unlift_rule])
          qed
          moreover
          have "\<turnstile> \<diamond>($pc1 = #a \<and> $pc2 = #a \<and> I) \<longrightarrow> \<diamond>Enabled \<langle>n2\<rangle>_vars"
            unfolding enab_n2[int_rewrite] by (rule STL4_eve) (auto simp: I_def tla_defs)
          ultimately
          show "\<turnstile> \<box>($pc2 = #a) \<and> \<box>[(n1 \<or> n2) \<and> \<not> beta2]_vars \<and> \<box>(I \<and> SF(n1)_vars)
                  \<longrightarrow> \<diamond>Enabled \<langle>n2\<rangle>_vars"
            by (force simp: STL5[int_rewrite])
        qed
        from ga ab have "\<turnstile> ?F \<longrightarrow> ($pc2 = #g \<leadsto> $pc2 = #b)"
          by (force elim: LT13[unlift_rule])
        with ab have "\<turnstile> ?F \<longrightarrow> (($pc2 = #a \<or> $pc2 = #b \<or> $pc2 = #g) \<leadsto> $pc2 = #b)"
          unfolding LT17[int_rewrite] LT1[int_rewrite] by force
        moreover
        have "\<turnstile> $pc2 = #a \<or> $pc2 = #b \<or> $pc2 = #g"
        proof (clarsimp simp: tla_defs)
          fix s :: "state seq"
          assume "pc2 (s 0) \<noteq> a" and "pc2 (s 0) \<noteq> g"
          thus "pc2 (s 0) = b" by (cases "pc2 (s 0)") auto
        qed
        hence "\<turnstile> (($pc2 = #a \<or> $pc2 = #b \<or> $pc2 = #g) \<leadsto> $pc2 = #b) \<longrightarrow> \<diamond>($pc2 = #b)"
          by (rule fmp[OF _ LT4])
        ultimately show ?thesis by (rule lift_imp_trans)
      qed
      with 1 show ?thesis by force
    qed
  qed
  with psiI show ?thesis unfolding psi_def Live2_def STL5[int_rewrite] by force
qed

text \<open>
  We can now prove the main theorem, which states that \<open>psi\<close>
  implements \<open>phi\<close>.
\<close>

theorem (in Secondprogram) impl: "\<turnstile> psi \<longrightarrow> phi"
  unfolding phi_def Live_def
  by (auto dest: step_simulation[unlift_rule]
                 lift_imp_trans[OF psi_fair_m1 SF_imp_WF, unlift_rule]
                 lift_imp_trans[OF psi_fair_m2 SF_imp_WF, unlift_rule])

end


(*
    This file is a part of IsarMathLib -
    a library of formalized mathematics written for Isabelle/Isar.

    Copyright (C) 2005-2012  Slawomir Kolodynski

    This program is free software; Redistribution and use in source and binary forms,
    with or without modification, are permitted provided that the following conditions are met:

   1. Redistributions of source code must retain the above copyright notice,
   this list of conditions and the following disclaimer.
   2. Redistributions in binary form must reproduce the above copyright notice,
   this list of conditions and the following disclaimer in the documentation and/or
   other materials provided with the distribution.
   3. The name of the author may not be used to endorse or promote products
   derived from this software without specific prior written permission.

THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT,
INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES LOSS OF USE, DATA, OR PROFITS OR
BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE
USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

*)

section \<open>Topology - introduction\<close>

theory Topology_ZF imports ZF1 Finite_ZF Fol1

begin

text\<open>This theory file provides basic definitions and properties of topology,
  open and closed sets, closure and boundary.\<close>

subsection\<open>Basic definitions and properties\<close>

text\<open>A typical textbook defines a topology on a set $X$ as a
  collection $T$ of subsets
  of $X$ such that $X\in T$, $\emptyset \in T$ and $T$ is closed
  with respect to arbitrary unions and  intersection of two sets. One can
  notice here that since we always have $\bigcup T = X$, the set
  on which the topology
  is defined (the "carrier" of the topology) can always be constructed
  from the topology itself and is
  superfluous in the definition. Moreover, as Marnix Klooster pointed out to me,
  the fact that the empty set is open can also be proven from other axioms.
  Hence, we define a topology as
  a collection of sets that is closed under
  arbitrary unions and intersections of two sets, without any mention of the
  set on which the topology is defined. Recall that \<open>Pow(T)\<close>
  is the powerset of $T$, so that if $M\in$ \<open> Pow(T)\<close> then $M$
  is a subset of $T$. The sets that belong to a topology $T$ will be sometimes called
  ''open in'' $T$ or just ''open'' if the topology is clear from the context.
\<close>

text\<open>Topology is a collection of sets that is closed under arbitrary unions and intersections
  of two sets.\<close>

definition
  IsATopology ("_ {is a topology}" [90] 91) where
  "T {is a topology} \<equiv> ( \<forall>M \<in> Pow(T). \<Union>M \<in> T ) \<and>
  ( \<forall>U\<in>T. \<forall> V\<in>T. U\<inter>V \<in> T)"

text\<open>We define interior of a set $A$ as the union of all open sets
  contained in $A$. We use \<open>Interior(A,T)\<close> to denote the
  interior of A.\<close>

definition
  "Interior(A,T) \<equiv> \<Union> {U\<in>T. U \<subseteq> A}"

text\<open>A set is closed if it is contained in the carrier of topology
  and its complement is open.\<close>

definition
  IsClosed (infixl "{is closed in}" 90) where
  "D {is closed in} T \<equiv> (D \<subseteq> \<Union>T \<and> \<Union>T - D \<in> T)"

text\<open>To prove various properties of closure we will often use
  the collection of  closed sets that contain a given set $A$.
  Such collection does not have a separate
  name in informal math. We will call it \<open>ClosedCovers(A,T)\<close>.
\<close>

definition
  "ClosedCovers(A,T) \<equiv> {D \<in> Pow(\<Union>T). D {is closed in} T \<and> A\<subseteq>D}"

text\<open>The closure of a set $A$ is defined as the intersection of the collection
  of closed sets that contain $A$.\<close>

definition
  "Closure(A,T) \<equiv> \<Inter> ClosedCovers(A,T)"

text\<open>We also define boundary  of a set as the intersection of
  its closure with the closure of the complement (with respect to the
  carrier).\<close>

definition
  "Boundary(A,T) \<equiv> Closure(A,T) \<inter> Closure(\<Union>T - A,T)"

text\<open>A set $K$ is compact if for every collection of open
  sets that covers $K$ we can choose a finite one that still covers the set.
  Recall that \<open>FinPow(M)\<close> is the collection of finite subsets of $M$
  (finite powerset of $M$), defined in IsarMathLib's \<open>Finite_ZF\<close>
  theory.\<close>

definition
  IsCompact (infixl "{is compact in}" 90) where
  "K {is compact in} T \<equiv> (K \<subseteq> \<Union>T \<and>
  (\<forall> M\<in>Pow(T). K \<subseteq> \<Union>M \<longrightarrow> (\<exists> N \<in> FinPow(M). K \<subseteq> \<Union>N)))"

text\<open>A basic example of a topology: the powerset of any set is a topology.\<close>

lemma Pow_is_top: shows "Pow(X) {is a topology}"
proof -
  have "\<forall>A\<in>Pow(Pow(X)). \<Union>A \<in> Pow(X)" by fast
  moreover have "\<forall>U\<in>Pow(X). \<forall>V\<in>Pow(X). U\<inter>V \<in> Pow(X)" by fast
  ultimately show "Pow(X) {is a topology}" using IsATopology_def
    by auto
qed

text\<open>Empty set is open.\<close>

lemma empty_open:
  assumes "T {is a topology}" shows "0 \<in> T"
proof -
  have "0 \<in> Pow(T)" by simp
  with assms have "\<Union>0 \<in> T" using IsATopology_def by blast
  thus "0 \<in> T" by simp
qed

text\<open>The carrier is open.\<close>
lemma carr_open: assumes "T {is a topology}" shows "(\<Union>T) \<in> T"
  using assms IsATopology_def by auto

text\<open>Union of a collection of open sets is open.\<close>
lemma union_open: assumes "T {is a topology}" and "\<forall>A\<in>\<A>. A \<in> T"
  shows "(\<Union>\<A>) \<in> T" using assms IsATopology_def by auto

text\<open>Union of a indexed family of open sets is open.\<close>
lemma union_indexed_open: assumes A1: "T {is a topology}" and A2: "\<forall>i\<in>I. P(i) \<in> T"
  shows "(\<Union>i\<in>I. P(i)) \<in> T"  using assms union_open by simp

text\<open>The intersection of any nonempty collection of topologies on a set $X$ is a topology.\<close>
lemma Inter_tops_is_top:
  assumes A1: "\<M> \<noteq> 0" and A2: "\<forall>T\<in>\<M>. T {is a topology}"
  shows "(\<Inter>\<M>) {is a topology}"
proof -
  { fix A assume "A\<in>Pow(\<Inter>\<M>)"
    with A1 have "\<forall>T\<in>\<M>. A\<in>Pow(T)" by auto
    with A1 A2 have "\<Union>A \<in> \<Inter>\<M>" using IsATopology_def
      by auto
  } then have "\<forall>A. A\<in>Pow(\<Inter>\<M>) \<longrightarrow> \<Union>A \<in> \<Inter>\<M>" by simp
  hence "\<forall>A\<in>Pow(\<Inter>\<M>). \<Union>A \<in> \<Inter>\<M>" by auto
  moreover
  { fix U V assume "U \<in> \<Inter>\<M>" and "V \<in> \<Inter>\<M>"
    then have "\<forall>T\<in>\<M>. U \<in> T \<and> V \<in> T" by auto
    with A1 A2 have "\<forall>T\<in>\<M>. U\<inter>V \<in> T" using IsATopology_def
      by simp
  } then have "\<forall> U \<in> \<Inter>\<M>. \<forall> V \<in> \<Inter>\<M>. U\<inter>V \<in> \<Inter>\<M>"
    by auto
  ultimately show "(\<Inter>\<M>) {is a topology}"
    using IsATopology_def by simp
qed

text\<open>Singletons are compact. Interestingly we do not have
  to assume that $T$ is a topology for this.
  Note singletons do not have to be closed, we need the
  the space to be $T_1$ for that (see \<open>Topology_ZF_1)\<close>. \<close>

lemma singl_compact:
  assumes "x\<in>\<Union>T" shows "{x} {is compact in} T"
  using assms singleton_in_finpow unfolding IsCompact_def
  by auto

text\<open>We will now introduce some notation. In Isar, this is done by definining
  a "locale". Locale is kind of a context that holds some assumptions and
  notation used in all theorems proven in it. In the locale (context)
  below called \<open>topology0\<close> we assume that $T$ is a topology.
  The interior of the set $A$ (with respect to the topology in the context)
  is denoted \<open>int(A)\<close>. The closure of a set $A\subseteq \bigcup T$ is
  denoted \<open>cl(A)\<close> and the boundary is \<open>\<partial>A\<close>.\<close>

locale topology0 =
  fixes T
  assumes topSpaceAssum: "T {is a topology}"

  fixes int
  defines int_def [simp]: "int(A) \<equiv> Interior(A,T)"

  fixes cl
  defines cl_def [simp]: "cl(A) \<equiv> Closure(A,T)"

  fixes boundary ("\<partial>_" [91] 92)
  defines boundary_def [simp]: "\<partial>A \<equiv> Boundary(A,T)"

text\<open>Intersection of a finite nonempty collection of open sets is open.\<close>

lemma (in topology0) fin_inter_open_open: assumes "N\<noteq>0" "N \<in> FinPow(T)"
  shows "\<Inter>N \<in> T"
  using topSpaceAssum assms IsATopology_def inter_two_inter_fin
  by simp

text\<open>Having a topology $T$ and a set $X$ we can
  define the induced topology
  as the one consisting of the intersections of $X$ with sets from $T$.
  The notion of a collection restricted to a set is defined in ZF1.thy.\<close>

lemma (in topology0) Top_1_L4:
  shows "(T {restricted to} X) {is a topology}"
proof -
  let ?S = "T {restricted to} X"
  have "\<forall>A\<in>Pow(?S). \<Union>A \<in> ?S"
  proof
    fix A assume A1: "A\<in>Pow(?S)"
    have "\<forall>V\<in>A. \<Union> {U \<in> T. V = U\<inter>X} \<in> T"
    proof -
      { fix V
	let ?M = "{U \<in> T. V = U\<inter>X}"
	have "?M \<in> Pow(T)" by auto
	with topSpaceAssum have "\<Union>?M \<in> T" using IsATopology_def by simp
      } thus ?thesis by simp
    qed
    hence "{\<Union>{U\<in>T. V = U\<inter>X}.V\<in> A} \<subseteq> T" by auto
    with topSpaceAssum have "(\<Union>V\<in>A. \<Union>{U\<in>T. V = U\<inter>X}) \<in> T"
      using IsATopology_def by auto
    then have "(\<Union>V\<in>A. \<Union>{U\<in>T. V = U\<inter>X})\<inter> X \<in> ?S"
      using RestrictedTo_def by auto
    moreover
    from A1 have "\<forall>V\<in>A. \<exists>U\<in>T. V = U\<inter>X"
      using RestrictedTo_def by auto
    hence "(\<Union>V\<in>A. \<Union>{U\<in>T. V = U\<inter>X})\<inter>X = \<Union>A" by blast
    ultimately show "\<Union>A \<in> ?S" by simp
  qed
  moreover have  "\<forall>U\<in>?S. \<forall>V\<in>?S. U\<inter>V \<in> ?S"
  proof -
    { fix U V assume "U\<in>?S"  "V\<in>?S"
      then obtain U\<^sub>1 V\<^sub>1 where
	"U\<^sub>1 \<in> T \<and> U = U\<^sub>1\<inter>X" and "V\<^sub>1 \<in> T \<and> V = V\<^sub>1\<inter>X"
	using RestrictedTo_def by auto
      with topSpaceAssum have "U\<^sub>1\<inter>V\<^sub>1 \<in> T" and "U\<inter>V = (U\<^sub>1\<inter>V\<^sub>1)\<inter>X"
	using IsATopology_def by auto
      then have " U\<inter>V \<in> ?S" using RestrictedTo_def by auto
    } thus "\<forall>U\<in>?S. \<forall> V\<in>?S. U\<inter>V \<in> ?S"
      by simp
  qed
  ultimately show "?S {is a topology}" using IsATopology_def
    by simp
qed

subsection\<open>Interior of a set\<close>

text\<open>In this section we show basic properties of the interior of a set.\<close>

text\<open>Interior of a set $A$ is contained in $A$.\<close>

lemma (in topology0) Top_2_L1: shows "int(A) \<subseteq> A"
  using Interior_def by auto

text\<open>Interior is open.\<close>

lemma (in topology0) Top_2_L2: shows "int(A) \<in> T"
proof -
  have "{U\<in>T. U\<subseteq>A} \<in> Pow(T)" by auto
  with topSpaceAssum show "int(A) \<in> T"
    using IsATopology_def Interior_def by auto
qed

text\<open>A set is open iff it is equal to its interior.\<close>

lemma (in topology0) Top_2_L3: shows "U\<in>T \<longleftrightarrow> int(U) = U"
proof
  assume "U\<in>T" then show "int(U) = U"
    using Interior_def by auto
next assume A1: "int(U) = U"
  have "int(U) \<in> T" using Top_2_L2 by simp
  with A1 show "U\<in>T" by simp
qed

text\<open>Interior of the interior is the interior.\<close>

lemma (in topology0) Top_2_L4: shows "int(int(A)) = int(A)"
proof -
  let ?U = "int(A)"
  from topSpaceAssum have "?U\<in>T" using Top_2_L2 by simp
  then show "int(int(A)) = int(A)" using Top_2_L3 by simp
qed

text\<open>Interior of a bigger set is bigger.\<close>

lemma (in topology0) interior_mono:
  assumes A1: "A\<subseteq>B" shows "int(A) \<subseteq> int(B)"
proof -
  from A1 have "\<forall> U\<in>T. (U\<subseteq>A \<longrightarrow> U\<subseteq>B)" by auto
  then show "int(A) \<subseteq> int(B)" using Interior_def by auto
qed

text\<open>An open subset of any set is a subset of the interior of that set.\<close>

lemma (in topology0) Top_2_L5: assumes "U\<subseteq>A" and "U\<in>T"
  shows "U \<subseteq> int(A)"
  using assms Interior_def by auto

text\<open>If a point of a set has an open neighboorhood contained in the set,
  then the point belongs to the interior of the set.\<close>

lemma (in topology0) Top_2_L6:  assumes "\<exists>U\<in>T. (x\<in>U \<and> U\<subseteq>A)"
  shows "x \<in> int(A)"
  using assms Interior_def by auto

text\<open>A set is open iff its every point has a an open neighbourhood
  contained in the set. We will formulate this statement as two lemmas
  (implication one way and the other way).
  The lemma below shows that if a set is open then every point has a
  an open neighbourhood contained in the set.\<close>

lemma (in topology0) open_open_neigh:
  assumes A1: "V\<in>T"
  shows "\<forall>x\<in>V. \<exists>U\<in>T. (x\<in>U \<and> U\<subseteq>V)"
proof -
  from A1 have "\<forall>x\<in>V. V\<in>T \<and> x \<in> V \<and> V \<subseteq> V" by simp
  thus ?thesis by auto
qed

text\<open>If every point of a set has a an open neighbourhood
  contained in the set then the set is open.\<close>

lemma (in topology0) open_neigh_open:
  assumes A1: "\<forall>x\<in>V. \<exists>U\<in>T. (x\<in>U \<and> U\<subseteq>V)"
  shows "V\<in>T"
proof -
  from A1 have "V = int(V)" using Top_2_L1 Top_2_L6
    by blast
  then show "V\<in>T" using Top_2_L3 by simp
qed

text\<open>The intersection of interiors is a equal to the interior of intersections.\<close>

lemma (in topology0) int_inter_int: shows "int(A) \<inter> int(B) = int(A\<inter>B)"
proof
  have "int(A) \<inter> int(B) \<subseteq> A\<inter>B" using Top_2_L1 by auto
  moreover have "int(A) \<inter> int(B) \<in> T" using Top_2_L2 IsATopology_def topSpaceAssum
    by auto
  ultimately show "int(A) \<inter> int(B) \<subseteq> int(A\<inter>B)" using Top_2_L5 by simp
  have "A\<inter>B \<subseteq> A" and "A\<inter>B \<subseteq> B" by auto
  then have "int(A\<inter>B) \<subseteq> int(A)" and "int(A\<inter>B) \<subseteq> int(B)" using interior_mono by auto
  thus "int(A\<inter>B) \<subseteq> int(A) \<inter> int(B)" by auto
qed

subsection\<open>Closed sets, closure, boundary.\<close>

text\<open>This section is devoted to closed sets and properties
  of the closure and boundary operators.\<close>

text\<open>The carrier of the space is closed.\<close>

lemma (in topology0) Top_3_L1: shows "(\<Union>T) {is closed in} T"
proof -
  have "\<Union>T - \<Union>T = 0" by auto
  with topSpaceAssum have "\<Union>T - \<Union>T \<in> T" using IsATopology_def by auto
  then show ?thesis using IsClosed_def by simp
qed

text\<open>Empty set is closed.\<close>

lemma (in topology0) Top_3_L2: shows "0 {is closed in} T"
  using topSpaceAssum  IsATopology_def IsClosed_def by simp

text\<open>The collection of closed covers of a subset of the carrier of topology
  is never empty. This is good to know, as we want to intersect this collection
  to get the closure.\<close>

lemma (in topology0) Top_3_L3:
  assumes A1: "A \<subseteq> \<Union>T" shows "ClosedCovers(A,T) \<noteq> 0"
proof -
  from A1 have "\<Union>T \<in> ClosedCovers(A,T)" using ClosedCovers_def Top_3_L1
    by auto
  thus ?thesis by auto
qed

text\<open>Intersection of a nonempty family of closed sets is closed.\<close>

lemma (in topology0) Top_3_L4: assumes A1: "K\<noteq>0" and
  A2: "\<forall>D\<in>K. D {is closed in} T"
  shows "(\<Inter>K) {is closed in} T"
proof -
  from A2 have I: "\<forall>D\<in>K. (D \<subseteq> \<Union>T \<and> (\<Union>T - D)\<in> T)"
    using IsClosed_def by simp
  then have "{\<Union>T - D. D\<in> K} \<subseteq> T" by auto
  with topSpaceAssum have "(\<Union> {\<Union>T - D. D\<in> K}) \<in> T"
    using IsATopology_def by auto
  moreover from A1 have "\<Union> {\<Union>T - D. D\<in> K} = \<Union>T - \<Inter>K" by fast
  moreover from A1 I have "\<Inter>K \<subseteq> \<Union>T" by blast
  ultimately show "(\<Inter>K) {is closed in} T" using  IsClosed_def
    by simp
qed

text\<open>The union and intersection of two closed sets are closed.\<close>

lemma (in topology0) Top_3_L5:
  assumes A1: "D\<^sub>1 {is closed in} T"   "D\<^sub>2 {is closed in} T"
  shows
  "(D\<^sub>1\<inter>D\<^sub>2) {is closed in} T"
  "(D\<^sub>1\<union>D\<^sub>2) {is closed in} T"
proof -
  have "{D\<^sub>1,D\<^sub>2} \<noteq> 0" by simp
  with A1 have "(\<Inter> {D\<^sub>1,D\<^sub>2}) {is closed in} T" using Top_3_L4
    by fast
  thus "(D\<^sub>1\<inter>D\<^sub>2) {is closed in} T" by simp
  from topSpaceAssum A1 have "(\<Union>T - D\<^sub>1) \<inter> (\<Union>T - D\<^sub>2) \<in> T"
    using IsClosed_def IsATopology_def by simp
  moreover have "(\<Union>T - D\<^sub>1) \<inter> (\<Union>T - D\<^sub>2) = \<Union>T - (D\<^sub>1 \<union> D\<^sub>2)"
    by auto
  moreover from A1 have "D\<^sub>1 \<union> D\<^sub>2 \<subseteq> \<Union>T" using IsClosed_def
    by auto
  ultimately show "(D\<^sub>1\<union>D\<^sub>2) {is closed in} T" using IsClosed_def
    by simp
qed

text\<open>Finite union of closed sets is closed. To understand the proof
  recall that $D\in$\<open>Pow(\<Union>T)\<close> means
  that $D$ is a subset of the carrier of the topology.\<close>

lemma (in topology0) fin_union_cl_is_cl:
  assumes
  A1: "N \<in> FinPow({D\<in>Pow(\<Union>T). D {is closed in} T})"
  shows "(\<Union>N) {is closed in} T"
proof -
  let ?C = "{D\<in>Pow(\<Union>T). D {is closed in} T}"
  have "0\<in>?C" using Top_3_L2 by simp
  moreover have "\<forall>A\<in>?C. \<forall>B\<in>?C. A\<union>B \<in> ?C"
    using Top_3_L5 by auto
  moreover note A1
  ultimately have "\<Union>N \<in> ?C" by (rule union_two_union_fin)
  thus "(\<Union>N) {is closed in} T" by simp
qed

text\<open>Closure of a set is closed, hence the complement of the closure is open.\<close>

lemma (in topology0) cl_is_closed: assumes "A \<subseteq> \<Union>T"
  shows "cl(A) {is closed in} T" and "\<Union>T - cl(A) \<in> T"
  using assms Top_3_L3 Top_3_L4 Closure_def ClosedCovers_def IsClosed_def
  by auto

text\<open>Closure of a bigger sets is bigger.\<close>

lemma (in topology0) top_closure_mono:
  assumes A1: "B \<subseteq> \<Union>T"  and A2:"A\<subseteq>B"
  shows "cl(A) \<subseteq> cl(B)"
proof -
  from A2 have "ClosedCovers(B,T)\<subseteq> ClosedCovers(A,T)"
    using ClosedCovers_def by auto
  with A1 show ?thesis using Top_3_L3 Closure_def by auto
qed

text\<open>Boundary of a set is closed.\<close>

lemma (in topology0) boundary_closed:
  assumes A1: "A \<subseteq> \<Union>T" shows "\<partial>A {is closed in} T"
proof -
  from A1 have "\<Union>T - A \<subseteq> \<Union>T" by fast
  with A1 show "\<partial>A {is closed in} T"
    using cl_is_closed Top_3_L5 Boundary_def by auto
qed

text\<open>A set is closed iff it is equal to its closure.\<close>

lemma (in topology0) Top_3_L8: assumes A1: "A \<subseteq> \<Union>T"
  shows "A {is closed in} T \<longleftrightarrow> cl(A) = A"
proof
  assume "A {is closed in} T"
  with A1 show "cl(A) = A"
    using Closure_def ClosedCovers_def by auto
next assume "cl(A) = A"
  then have "\<Union>T - A = \<Union>T - cl(A)" by simp
  with A1 show "A {is closed in} T" using cl_is_closed IsClosed_def
    by simp
qed

text\<open>Complement of an open set is closed.\<close>

lemma (in topology0) Top_3_L9: assumes A1: "A\<in>T"
  shows "(\<Union>T - A) {is closed in} T"
proof -
  from topSpaceAssum A1 have "\<Union>T - (\<Union>T - A) = A" and "\<Union>T - A \<subseteq> \<Union>T"
    using IsATopology_def by auto
  with A1 show "(\<Union>T - A) {is closed in} T" using IsClosed_def by simp
qed

text\<open>A set is contained in its closure.\<close>

lemma (in topology0) cl_contains_set: assumes "A \<subseteq> \<Union>T" shows "A \<subseteq> cl(A)"
  using assms Top_3_L1 ClosedCovers_def Top_3_L3 Closure_def by auto

text\<open>Closure of a subset of the carrier is a subset of the carrier and closure
  of the complement is the complement of the interior.\<close>

lemma (in topology0) Top_3_L11: assumes A1: "A \<subseteq> \<Union>T"
  shows
  "cl(A) \<subseteq> \<Union>T"
  "cl(\<Union>T - A) = \<Union>T - int(A)"
proof -
  from A1 show "cl(A) \<subseteq> \<Union>T" using Top_3_L1 Closure_def ClosedCovers_def
    by auto
  from A1 have "\<Union>T - A \<subseteq> \<Union>T - int(A)" using Top_2_L1
    by auto
  moreover have I: "\<Union>T - int(A) \<subseteq> \<Union>T"   "\<Union>T - A \<subseteq> \<Union>T" by auto
  ultimately have "cl(\<Union>T - A) \<subseteq> cl(\<Union>T - int(A))"
    using top_closure_mono by simp
  moreover
  from I have "(\<Union>T - int(A)) {is closed in} T"
    using Top_2_L2 Top_3_L9 by simp
  with I have "cl((\<Union>T) - int(A)) = \<Union>T - int(A)"
    using Top_3_L8 by simp
  ultimately have "cl(\<Union>T - A) \<subseteq> \<Union>T - int(A)" by simp
  moreover
  from I have "\<Union>T - A \<subseteq> cl(\<Union>T - A)" using cl_contains_set by simp
  hence "\<Union>T - cl(\<Union>T - A) \<subseteq> A" and "\<Union>T - A \<subseteq> \<Union>T"  by auto
  then have "\<Union>T - cl(\<Union>T - A) \<subseteq> int(A)"
    using cl_is_closed IsClosed_def Top_2_L5 by simp
  hence "\<Union>T - int(A) \<subseteq>  cl(\<Union>T - A)" by auto
  ultimately show "cl(\<Union>T - A) = \<Union>T - int(A)" by auto
qed

text\<open>Boundary of a set is the closure of the set
  minus the interior of the set.\<close>

lemma (in topology0) Top_3_L12: assumes A1: "A \<subseteq> \<Union>T"
  shows "\<partial>A = cl(A) - int(A)"
proof -
  from A1 have "\<partial>A = cl(A) \<inter> (\<Union>T - int(A))"
    using Boundary_def Top_3_L11 by simp
  moreover from A1 have
    "cl(A) \<inter> (\<Union>T - int(A)) = cl(A) - int(A)"
    using Top_3_L11 by blast
  ultimately show "\<partial>A = cl(A) - int(A)" by simp
qed

text\<open>If a set $A$ is contained in a closed set $B$, then the closure of $A$
  is contained in $B$.\<close>

lemma (in topology0) Top_3_L13:
  assumes A1: "B {is closed in} T"   "A\<subseteq>B"
  shows "cl(A) \<subseteq> B"
proof -
  from A1 have "B \<subseteq> \<Union>T" using IsClosed_def by simp
  with A1 show "cl(A) \<subseteq> B" using ClosedCovers_def Closure_def by auto
qed

(*text{*If two open sets are disjoint, then we can close one of them
  and they will still be disjoint.*}

lemma (in topology0) open_disj_cl_disj:
  assumes A1: "U\<in>T"  "V\<in>T" and  A2: "U\<inter>V = 0"
  shows "cl(U) \<inter> V = 0"
proof -
  from topSpaceAssum A1 have I: "U \<subseteq> \<Union>T" using IsATopology_def
    by auto
  with A2 have  "U \<subseteq> \<Union>T - V" by auto
  moreover from A1 have "(\<Union>T - V) {is closed in} T" using Top_3_L9
    by simp
  ultimately have "cl(U) - (\<Union>T - V) = 0"
    using Top_3_L13 by blast
  moreover
  from I have "cl(U) \<subseteq> \<Union>T" using cl_is_closed IsClosed_def by simp
  then have "cl(U) -(\<Union>T - V) = cl(U) \<inter> V" by auto
  ultimately show "cl(U) \<inter> V = 0" by simp
qed;*)

text\<open>If a set is disjoint with an open set, then we can close it
  and it will still be disjoint.\<close>

lemma (in topology0) disj_open_cl_disj:
  assumes A1: "A \<subseteq> \<Union>T"  "V\<in>T" and  A2: "A\<inter>V = 0"
  shows "cl(A) \<inter> V = 0"
proof -
  from assms have "A \<subseteq> \<Union>T - V" by auto
  moreover from A1 have "(\<Union>T - V) {is closed in} T" using Top_3_L9 by simp
  ultimately have "cl(A) - (\<Union>T - V) = 0"
    using Top_3_L13 by blast
  moreover from A1 have "cl(A) \<subseteq> \<Union>T" using cl_is_closed IsClosed_def by simp
  then have "cl(A) -(\<Union>T - V) = cl(A) \<inter> V" by auto
  ultimately show ?thesis by simp
qed

text\<open>A reformulation of \<open>disj_open_cl_disj\<close>:
  If a point belongs to the closure of a set, then we can find a point
  from the set in any open neighboorhood of the point.\<close>

lemma (in topology0) cl_inter_neigh:
  assumes "A \<subseteq> \<Union>T" and "U\<in>T" and "x \<in> cl(A) \<inter> U"
  shows "A\<inter>U \<noteq> 0" using assms disj_open_cl_disj by auto

text\<open>A reverse of  \<open>cl_inter_neigh\<close>: if every open neiboorhood of a point
  has a nonempty intersection with a set, then that point belongs to the closure
  of the set.\<close>

lemma (in topology0) inter_neigh_cl:
  assumes A1: "A \<subseteq> \<Union>T" and A2: "x\<in>\<Union>T" and A3: "\<forall>U\<in>T. x\<in>U \<longrightarrow> U\<inter>A \<noteq> 0"
  shows "x \<in> cl(A)"
proof -
  { assume "x \<notin> cl(A)"
    with A1 obtain D where "D {is closed in} T" and "A\<subseteq>D" and "x\<notin>D"
      using Top_3_L3 Closure_def ClosedCovers_def by auto
    let ?U = "(\<Union>T) - D"
    from A2 \<open>D {is closed in} T\<close> \<open>x\<notin>D\<close> \<open>A\<subseteq>D\<close> have "?U\<in>T" "x\<in>?U" and "?U\<inter>A = 0"
      unfolding IsClosed_def by auto
    with A3 have False by auto
  } thus ?thesis by auto
qed

end


(* Author: Andreas Lochbihler, Digital Asset *)

theory Rel_PMF_Characterisation_MFMC
imports
  MFMC_Bounded
  MFMC_Unbounded
  "HOL-Library.Simps_Case_Conv"
begin

section \<open>Characterisation of @{const rel_pmf} proved via MFMC\<close>

context begin

private datatype ('a, 'b) vertex = Source | Sink | Left 'a | Right 'b

private lemma inj_Left [simp]: "inj_on Left X"
by(simp add: inj_on_def)

private lemma inj_Right [simp]: "inj_on Right X"
by(simp add: inj_on_def)

context fixes p :: "'a pmf" and q :: "'b pmf" and R :: "'a \<Rightarrow> 'b \<Rightarrow> bool" begin

private inductive edge' :: "('a, 'b) vertex \<Rightarrow> ('a, 'b) vertex \<Rightarrow> bool" where
  "edge' Source (Left x)" if "x \<in> set_pmf p"
| "edge' (Left x) (Right y)" if "R x y" "x \<in> set_pmf p" "y \<in> set_pmf q"
| "edge' (Right y) Sink" if "y \<in> set_pmf q"

private inductive_simps edge'_simps [simp]:
  "edge' xv (Left x)"
  "edge' (Left x) (Right y)"
  "edge' (Right y) yv"
  "edge' Source (Right y)"
  "edge' Source Sink"
  "edge' xv Source"
  "edge' Sink yv"
  "edge' (Left x) Sink"

private inductive_cases edge'_SourceE [elim!]: "edge' Source yv"
private inductive_cases edge'_LeftE [elim!]: "edge' (Left x) yv"
private inductive_cases edge'_RightE [elim!]: "edge' xv (Right y)"
private inductive_cases edge'_SinkE [elim!]: "edge' xv Sink"

private function cap :: "('a, 'b) vertex flow" where
  "cap (xv, Left x) = (if xv = Source then ennreal (pmf p x) else 0)"
| "cap (Left x, Right y) =
  (if R x y \<and> x \<in> set_pmf p \<and> y \<in> set_pmf q
   then pmf q y \<comment> \<open>Return @{term \<open>pmf q y\<close>} so that total weight of @{text \<open>x\<close>}'s neighbours is finite,
                    i.e., the network satisfies @{locale bounded_countable_network}.\<close>
   else 0)"
| "cap (Right y, yv) = (if yv = Sink then ennreal (pmf q y) else 0)"
| "cap (Source, Right y) = 0"
| "cap (Source, Sink) = 0"
| "cap (xv, Source) = 0"
| "cap (Sink, yv) = 0"
| "cap (Left x, Sink) = 0"
  by pat_completeness auto
termination by lexicographic_order

private definition \<Delta> :: "('a, 'b) vertex network"
  where "\<Delta> = \<lparr>edge = edge', capacity = cap, source = Source, sink = Sink\<rparr>"

private lemma \<Delta>_sel [simp]:
  "edge \<Delta> = edge'"
  "capacity \<Delta> = cap"
  "source \<Delta> = Source"
  "sink \<Delta> = Sink"
  by(simp_all add: \<Delta>_def)

private lemma IN_Left [simp]: "\<^bold>I\<^bold>N\<^bsub>\<Delta>\<^esub> (Left x) = (if x \<in> set_pmf p then {Source} else {})"
  by(auto simp add: incoming_def)
private lemma OUT_Right [simp]: "\<^bold>O\<^bold>U\<^bold>T\<^bsub>\<Delta>\<^esub> (Right y) = (if y \<in> set_pmf q then {Sink} else {})"
  by(auto simp add: outgoing_def)

interpretation network: countable_network \<Delta>
proof
  show "source \<Delta> \<noteq> sink \<Delta>" by simp
  show "capacity \<Delta> e = 0" if "e \<notin> \<^bold>E\<^bsub>\<Delta>\<^esub>" for e using that
    by(cases e; cases "fst e"; cases "snd e")(auto simp add: pmf_eq_0_set_pmf)
  show "capacity \<Delta> e \<noteq> top" for e by(cases e rule: cap.cases)(auto)
  have "\<^bold>E\<^bsub>\<Delta>\<^esub> \<subseteq> ((Pair Source \<circ> Left) ` set_pmf p) \<union> (map_prod Left Right ` (set_pmf p \<times> set_pmf q)) \<union> ((\<lambda>y. (Right y, Sink)) ` set_pmf q)"
    by(auto elim: edge'.cases)
  thus "countable \<^bold>E\<^bsub>\<Delta>\<^esub>" by(rule countable_subset) auto
qed

private lemma OUT_cap_Source: "d_OUT cap Source = 1"
proof -
  have "d_OUT cap Source = (\<Sum>\<^sup>+ y\<in>range Left. cap (Source, y))"
    by(auto 4 4 simp add: d_OUT_def nn_integral_count_space_indicator intro!: nn_integral_cong network.capacity_outside[simplified] split: split_indicator)
  also have "\<dots> = (\<Sum>\<^sup>+ y. pmf p y)" by(simp add: nn_integral_count_space_reindex)
  also have "\<dots> = 1" by(simp add: nn_integral_pmf)
  finally show ?thesis .
qed
private lemma IN_cap_Left: "d_IN cap (Left x) = pmf p x"
  by(subst d_IN_alt_def[of _ \<Delta>])(simp_all add: pmf_eq_0_set_pmf nn_integral_count_space_indicator max_def)
private lemma OUT_cap_Right: "d_OUT cap (Right y) = pmf q y"
  by(subst d_OUT_alt_def[of _ \<Delta>])(simp_all add: pmf_eq_0_set_pmf nn_integral_count_space_indicator max_def)

private lemma rel_pmf_measureI_aux:
  assumes ex_flow: "\<exists>f S. flow \<Delta> f \<and> cut \<Delta> S \<and> orthogonal \<Delta> f S"
    and le: "\<And>A. measure (measure_pmf p) A \<le> measure (measure_pmf q) {y. \<exists>x\<in>A. R x y}"
  shows "rel_pmf R p q"
proof -
  from ex_flow obtain f S
    where f: "flow \<Delta> f" and cut: "cut \<Delta> S" and ortho: "orthogonal \<Delta> f S" by blast
  from cut obtain Source: "Source \<in> S" and Sink: "Sink \<notin> S" by cases simp

  have f_finite [simp]: "f e < top" for e
    using network.flowD_finite[OF f, of e] by (simp_all add: less_top)

  have IN_f_Left: "d_IN f (Left x) = f (Source, Left x)" for x
    by(subst d_IN_alt_def[of _ \<Delta>])(simp_all add: nn_integral_count_space_indicator max_def network.flowD_outside[OF f])
  have OUT_f_Right: "d_OUT f (Right y) = f (Right y, Sink)" for y
    by(subst d_OUT_alt_def[of _ \<Delta>])(simp_all add: nn_integral_count_space_indicator max_def network.flowD_outside[OF f])

  have "value_flow \<Delta> f \<le> 1" using flowD_capacity_OUT[OF f, of Source] by(simp add: OUT_cap_Source)
  moreover have "1 \<le> value_flow \<Delta> f"
  proof -
    let ?L = "Left -` S \<inter> set_pmf p"
    let ?R' = "{y|y x. x \<in> set_pmf p \<and> Left x \<in> S \<and> R x y \<and> y \<in> set_pmf q \<and> Right y \<in> S}"
    let ?R'' = "{y|y x. x \<in> set_pmf p \<and> Left x \<in> S \<and> R x y \<and> y \<in> set_pmf q \<and> \<not> Right y \<in> S}"
    have "value_flow \<Delta> f = (\<Sum>\<^sup>+ x\<in>range Left. f (Source, x))" unfolding d_OUT_def
      by(auto simp add: nn_integral_count_space_indicator intro!: nn_integral_cong network.flowD_outside[OF f] split: split_indicator)
    also have "\<dots> = (\<Sum>\<^sup>+ x. f (Source, Left x) * indicator ?L x) + (\<Sum>\<^sup>+ x. f (Source, Left x) * indicator (- ?L) x)"
      by(subst nn_integral_add[symmetric])(auto simp add: nn_integral_count_space_reindex intro!: nn_integral_cong split: split_indicator)
    also have "(\<Sum>\<^sup>+ x. f (Source, Left x) * indicator (- ?L) x) = (\<Sum>\<^sup>+ x\<in>- ?L. cap (Source, Left x))"
      using orthogonalD_out[OF ortho _ Source]
      apply(auto simp add: set_pmf_iff network.flowD_outside[OF f] nn_integral_count_space_indicator intro!: nn_integral_cong split: split_indicator)
      subgoal for x by(cases "x \<in> set_pmf p")(auto simp add: set_pmf_iff network.flowD_outside[OF f])
      done
    also have "\<dots> = (\<Sum>\<^sup>+ x\<in>- ?L. pmf p x)" by simp
    also have "\<dots> = emeasure p (- ?L)" by(simp add: nn_integral_pmf)
    also have "(\<Sum>\<^sup>+ x. f (Source, Left x) * indicator ?L x) = (\<Sum>\<^sup>+ x\<in>?L. d_IN f (Left x))"
      by(subst d_IN_alt_def[of _ \<Delta>])(auto simp add: network.flowD_outside[OF f] nn_integral_count_space_indicator intro!: nn_integral_cong)
    also have "\<dots> = (\<Sum>\<^sup>+ x\<in>?L. d_OUT f (Left x))"
      by(rule nn_integral_cong flowD_KIR[OF f, symmetric])+ simp_all
    also have "\<dots> = (\<Sum>\<^sup>+ x. \<Sum>\<^sup>+ y. f (Left x, y) * indicator (range Right) y * indicator ?L x)"
      by(auto simp add: d_OUT_def nn_integral_count_space_indicator intro!: nn_integral_cong network.flowD_outside[OF f] split: split_indicator)
    also have "\<dots> = (\<Sum>\<^sup>+ y\<in>range Right. \<Sum>\<^sup>+ x. f (Left x, y) * indicator ?L x)"
      by(subst nn_integral_fst_count_space[where f="case_prod _", simplified])
        (simp add: nn_integral_snd_count_space[where f="case_prod _", simplified] nn_integral_count_space_indicator nn_integral_cmult[symmetric] mult_ac)
    also have "\<dots> = (\<Sum>\<^sup>+ y. \<Sum>\<^sup>+ x. f (Left x, Right y) * indicator ?L x)"
      by(simp add: nn_integral_count_space_reindex)
    also have "\<dots> = (\<Sum>\<^sup>+ y. \<Sum>\<^sup>+ x. f (Left x, Right y) * indicator ?L x * indicator ?R' y) +
      (\<Sum>\<^sup>+ y. \<Sum>\<^sup>+ x. f (Left x, Right y) * indicator ?L x * indicator ?R'' y)"
      by(subst nn_integral_add[symmetric]; simp)
        (subst nn_integral_add[symmetric]; auto intro!: nn_integral_cong split: split_indicator intro!: network.flowD_outside[OF f])
    also have "(\<Sum>\<^sup>+ y. \<Sum>\<^sup>+ x. f (Left x, Right y) * indicator ?L x * indicator ?R' y) =
       (\<Sum>\<^sup>+ y. \<Sum>\<^sup>+ x. f (Left x, Right y) * indicator ?R' y)"
      apply(clarsimp simp add: network.flowD_outside[OF f] intro!: nn_integral_cong split: split_indicator)
      subgoal for y x by(cases "edge \<Delta> (Left x) (Right y)")(auto intro: orthogonalD_in[OF ortho] network.flowD_outside[OF f])
      done
    also have "\<dots> = (\<Sum>\<^sup>+ y. \<Sum>\<^sup>+ x\<in>range Left. f (x, Right y) * indicator ?R' y)"
      by(simp add: nn_integral_count_space_reindex)
    also have "\<dots> = (\<Sum>\<^sup>+ y\<in>?R'. d_IN f (Right y))"
      by(subst d_IN_alt_def[of _ \<Delta>])(auto simp add: network.flowD_outside[OF f] nn_integral_count_space_indicator incoming_def intro!: nn_integral_cong split: split_indicator)
    also have "\<dots> = (\<Sum>\<^sup>+ y\<in>?R'. d_OUT f (Right y))" using flowD_KIR[OF f] by simp
    also have "\<dots> = (\<Sum>\<^sup>+ y\<in>?R'. d_OUT cap (Right y))"
      by(auto 4 3 intro!: nn_integral_cong simp add: d_OUT_def network.flowD_outside[OF f] Sink dest: intro: orthogonalD_out[OF ortho, of "Right _" Sink, simplified])
    also have "\<dots> = (\<Sum>\<^sup>+ y\<in>?R'. pmf q y)" by(simp add: OUT_cap_Right)
    also have "\<dots> = emeasure q ?R'" by(simp add: nn_integral_pmf)
    also have "(\<Sum>\<^sup>+ y. \<Sum>\<^sup>+ x. f (Left x, Right y) * indicator ?L x * indicator ?R'' y) \<ge> emeasure q ?R''" (is "?lhs \<ge> _")
    proof -
      have "?lhs = (\<Sum>\<^sup>+ y. \<Sum>\<^sup>+ x. (if R x y then pmf q y else 0) * indicator ?L x * indicator ?R'' y)"
        by(rule nn_integral_cong)+(auto split: split_indicator simp add: network.flowD_outside[OF f] simp add: orthogonalD_out[OF ortho, of "Left _" "Right _", simplified])
      also have "\<dots> \<ge> (\<Sum>\<^sup>+ y. pmf q y * indicator ?R'' y)"
        by(rule nn_integral_mono)(auto split: split_indicator intro: order_trans[OF _ nn_integral_ge_point])
      also have "(\<Sum>\<^sup>+ y. pmf q y * indicator ?R'' y) = (\<Sum>\<^sup>+ y\<in>?R''. pmf q y)"
        by(auto simp add: nn_integral_count_space_indicator intro!: nn_integral_cong split: split_indicator)
      finally show ?thesis by(simp add: nn_integral_pmf)
    qed
    ultimately have "value_flow \<Delta> f \<ge> emeasure q ?R' + emeasure q ?R'' + emeasure p (- ?L)"
      by(simp add: add_right_mono)
    also have "emeasure q ?R' + emeasure q ?R'' = emeasure q {y|y x. x \<in> set_pmf p \<and> Left x \<in> S \<and> R x y \<and> y \<in> set_pmf q}"
      by(subst plus_emeasure)(auto intro!: arg_cong2[where f=emeasure])
    also have "\<dots> \<ge> emeasure p ?L" using le[of ?L]
      by(auto elim!: order_trans simp add: measure_pmf.emeasure_eq_measure AE_measure_pmf_iff intro!: measure_pmf.finite_measure_mono_AE)
    ultimately have "value_flow \<Delta> f \<ge> emeasure (measure_pmf p) ?L + emeasure (measure_pmf p) (- ?L)"
      by (smt (verit, best) add_right_mono inf.absorb_iff2 le_inf_iff)
    also have "emeasure (measure_pmf p) ?L + emeasure (measure_pmf p) (- ?L) = emeasure (measure_pmf p) (?L \<union> - ?L)"
      by(subst plus_emeasure) auto
    also have "?L \<union> -?L = UNIV" by blast
    finally show ?thesis by simp
  qed
  ultimately have val: "value_flow \<Delta> f = 1" by simp

  have SAT_p: "f (Source, Left x) = pmf p x" for x
  proof(rule antisym)
    show "f (Source, Left x) \<le> pmf p x" using flowD_capacity[OF f, of "(Source, Left x)"] by simp
    show "pmf p x \<le> f (Source, Left x)"
    proof(rule ccontr)
      assume *: "\<not> ?thesis"
      have finite: "(\<Sum>\<^sup>+ y. f (Source, Left y) * indicator (- {x}) y) \<noteq> \<infinity>"
      proof -
        have "(\<Sum>\<^sup>+ y. f (Source, Left y) * indicator (- {x}) y) \<le> (\<Sum>\<^sup>+ y\<in>range Left. f (Source, y))"
          by(auto simp add: nn_integral_count_space_reindex intro!: nn_integral_mono split: split_indicator)
        also have "\<dots> = value_flow \<Delta> f"
          by(auto simp add: d_OUT_def nn_integral_count_space_indicator intro!: nn_integral_cong network.flowD_outside[OF f] split: split_indicator)
        finally show ?thesis using val by (auto simp: top_unique)
      qed
      have "value_flow \<Delta> f = (\<Sum>\<^sup>+ y\<in>range Left. f (Source, y))"
        by(auto simp add: d_OUT_def nn_integral_count_space_indicator intro!: nn_integral_cong network.flowD_outside[OF f] split: split_indicator)
      also have "\<dots> = (\<Sum>\<^sup>+ y. f (Source, Left y) * indicator (- {x}) y) + (\<Sum>\<^sup>+ y. f (Source, Left y) * indicator {x} y)"
        by(subst nn_integral_add[symmetric])(auto simp add: nn_integral_count_space_reindex intro!: nn_integral_cong split: split_indicator)
      also have "\<dots> < (\<Sum>\<^sup>+ y. f (Source, Left y) * indicator (- {x}) y) + (\<Sum>\<^sup>+ y. pmf p y * indicator {x} y)" using * finite
        by(auto simp add:)
      also have "\<dots> \<le> (\<Sum>\<^sup>+ y. pmf p y * indicator (- {x}) y) + (\<Sum>\<^sup>+ y. pmf p y * indicator {x} y)"
        using flowD_capacity[OF f, of "(Source, Left _)"]
        by(auto intro!: nn_integral_mono split: split_indicator)
      also have "\<dots> = (\<Sum>\<^sup>+ y. pmf p y)"
        by(subst nn_integral_add[symmetric])(auto intro!: nn_integral_cong split: split_indicator)
      also have "\<dots> = 1" unfolding nn_integral_pmf by simp
      finally show False using val by simp
    qed
  qed

  have IN_Sink: "d_IN f Sink = 1"
  proof -
    have "d_IN f Sink = (\<Sum>\<^sup>+ x\<in>range Right. f (x, Sink))" unfolding d_IN_def
      by(auto intro!: nn_integral_cong network.flowD_outside[OF f] simp add: nn_integral_count_space_indicator split: split_indicator)
    also have "\<dots> = (\<Sum>\<^sup>+ y. d_OUT f (Right y))" by(simp add: nn_integral_count_space_reindex OUT_f_Right)
    also have "\<dots> = (\<Sum>\<^sup>+ y. d_IN f (Right y))" by(simp add: flowD_KIR[OF f])
    also have "\<dots> = (\<Sum>\<^sup>+ y. (\<Sum>\<^sup>+ x\<in>range Left. f (x, Right y)))"
      by(auto simp add: d_IN_def nn_integral_count_space_indicator intro!: nn_integral_cong network.flowD_outside[OF f] split: split_indicator)
    also have "\<dots> = (\<Sum>\<^sup>+ y. \<Sum>\<^sup>+ x. f (Left x, Right y))" by(simp add: nn_integral_count_space_reindex)
    also have "\<dots> = (\<Sum>\<^sup>+ x. \<Sum>\<^sup>+ y. f (Left x, Right y))"
      by(subst nn_integral_fst_count_space[where f="case_prod _", simplified])(simp add: nn_integral_snd_count_space[where f="case_prod _", simplified])
    also have "\<dots> = (\<Sum>\<^sup>+ x. (\<Sum>\<^sup>+ y\<in>range Right. f (Left x, y)))"
      by(simp add: nn_integral_count_space_reindex)
    also have "\<dots> = (\<Sum>\<^sup>+ x. d_OUT f (Left x))" unfolding d_OUT_def
      by(auto intro!: nn_integral_cong network.flowD_outside[OF f] simp add: nn_integral_count_space_indicator split: split_indicator)
    also have "\<dots> = (\<Sum>\<^sup>+ x. d_IN f (Left x))" by(simp add: flowD_KIR[OF f])
    also have "\<dots> = (\<Sum>\<^sup>+ x. pmf p x)" by(simp add: IN_f_Left SAT_p)
    also have "\<dots> = 1" unfolding nn_integral_pmf by simp
    finally show ?thesis .
  qed

  have SAT_q: "f (Right y, Sink) = pmf q y" for y
  proof(rule antisym)
    show "f (Right y, Sink) \<le> pmf q y" using flowD_capacity[OF f, of "(Right y, Sink)"] by simp
    show "pmf q y \<le> f (Right y, Sink)"
    proof(rule ccontr)
      assume *: "\<not> ?thesis"
      have finite: "(\<Sum>\<^sup>+ x. f (Right x, Sink) * indicator (- {y}) x) \<noteq> \<infinity>"
      proof -
        have "(\<Sum>\<^sup>+ x. f (Right x, Sink) * indicator (- {y}) x) \<le> (\<Sum>\<^sup>+ x\<in>range Right. f (x, Sink))"
          by(auto simp add: nn_integral_count_space_reindex intro!: nn_integral_mono split: split_indicator)
        also have "\<dots> = d_IN f Sink"
          by(auto simp add: d_IN_def nn_integral_count_space_indicator intro!: nn_integral_cong network.flowD_outside[OF f] split: split_indicator)
        finally show ?thesis using IN_Sink by (auto simp: top_unique)
      qed
      have "d_IN f Sink = (\<Sum>\<^sup>+ x\<in>range Right. f (x, Sink))"
        by(auto simp add: d_IN_def nn_integral_count_space_indicator intro!: nn_integral_cong network.flowD_outside[OF f] split: split_indicator)
      also have "\<dots> = (\<Sum>\<^sup>+ x. f (Right x, Sink) * indicator (- {y}) x) + (\<Sum>\<^sup>+ x. f (Right x, Sink) * indicator {y} x)"
        by(subst nn_integral_add[symmetric])(auto simp add: nn_integral_count_space_reindex intro!: nn_integral_cong split: split_indicator)
      also have "\<dots> < (\<Sum>\<^sup>+ x. f (Right x, Sink) * indicator (- {y}) x) + (\<Sum>\<^sup>+ x. pmf q x * indicator {y} x)" using * finite
        by auto
      also have "\<dots> \<le> (\<Sum>\<^sup>+ x. pmf q x * indicator (- {y}) x) + (\<Sum>\<^sup>+ x. pmf q x * indicator {y} x)"
        using flowD_capacity[OF f, of "(Right _, Sink)"]
        by(auto intro!: nn_integral_mono split: split_indicator)
      also have "\<dots> = (\<Sum>\<^sup>+ x. pmf q x)"
        by(subst nn_integral_add[symmetric])(auto intro!: nn_integral_cong split: split_indicator)
      also have "\<dots> = 1" unfolding nn_integral_pmf by simp
      finally show False using IN_Sink by simp
    qed
  qed

  let ?z = "\<lambda>(x, y). enn2real (f (Left x, Right y))"
  have nonneg: "\<And>xy. 0 \<le> ?z xy" by clarsimp
  have prob: "(\<Sum>\<^sup>+ xy. ?z xy) = 1"
  proof -
    have "(\<Sum>\<^sup>+ xy. ?z xy) = (\<Sum>\<^sup>+ x. \<Sum>\<^sup>+ y. (ennreal \<circ> ?z) (x, y))"
      unfolding nn_integral_fst_count_space by(simp add: split_def o_def)
    also have "\<dots> = (\<Sum>\<^sup>+ x. (\<Sum>\<^sup>+y\<in>range Right. f (Left x, y)))"
      by(auto simp add: nn_integral_count_space_reindex intro!: nn_integral_cong)
    also have "\<dots> = (\<Sum>\<^sup>+ x. d_OUT f (Left x))"
      by(auto simp add: d_OUT_def nn_integral_count_space_indicator split: split_indicator intro!: nn_integral_cong network.flowD_outside[OF f])
    also have "\<dots> = (\<Sum>\<^sup>+ x. d_IN f (Left x))" using flowD_KIR[OF f] by simp
    also have "\<dots> = (\<Sum>\<^sup>+ x\<in>range Left. f (Source, x))" by(simp add: nn_integral_count_space_reindex IN_f_Left)
    also have "\<dots> = value_flow \<Delta> f"
      by(auto simp add: d_OUT_def nn_integral_count_space_indicator intro!: nn_integral_cong network.flowD_outside[OF f] split: split_indicator)
    finally show ?thesis using val by(simp)
  qed
  note z = nonneg prob
  define z where "z = embed_pmf ?z"
  have z_sel [simp]: "pmf z (x, y) = enn2real (f (Left x, Right y))" for x y
    by(simp add: z_def pmf_embed_pmf[OF z])

  show ?thesis
  proof
    show "R x y" if "(x, y) \<in> set_pmf z" for x y
      using that network.flowD_outside[OF f, of "(Left x, Right y)"] unfolding set_pmf_iff
      by(auto simp add: enn2real_eq_0_iff)

    show "map_pmf fst z = p"
    proof(rule pmf_eqI)
      fix x
      have "pmf (map_pmf fst z) x = (\<Sum>\<^sup>+ e\<in>range (Pair x). pmf z e)"
        by(auto simp add: ennreal_pmf_map nn_integral_measure_pmf nn_integral_count_space_indicator intro!: nn_integral_cong split: split_indicator)
      also have "\<dots> = (\<Sum>\<^sup>+ y\<in>range Right. f (Left x, y))" by(simp add: nn_integral_count_space_reindex)
      also have "\<dots> = d_OUT f (Left x)"
        by(auto simp add: d_OUT_def nn_integral_count_space_indicator intro!: nn_integral_cong network.flowD_outside[OF f] split: split_indicator)
      also have "\<dots> = d_IN f (Left x)" by(rule flowD_KIR[OF f]) simp_all
      also have "\<dots> = f (Source, Left x)" by(simp add: IN_f_Left)
      also have "\<dots> = pmf p x" by(simp add: SAT_p)
      finally show "pmf (map_pmf fst z) x = pmf p x" by simp
    qed

    show "map_pmf snd z = q"
    proof(rule pmf_eqI)
      fix y
      have "pmf (map_pmf snd z) y = (\<Sum>\<^sup>+ e\<in>range (\<lambda>x. (x, y)). pmf z e)"
        by(auto simp add: ennreal_pmf_map nn_integral_measure_pmf nn_integral_count_space_indicator intro!: nn_integral_cong split: split_indicator)
      also have "\<dots> = (\<Sum>\<^sup>+ x\<in>range Left. f (x, Right y))" by(simp add: nn_integral_count_space_reindex)
      also have "\<dots> = d_IN f (Right y)"
        by(auto simp add: d_IN_def nn_integral_count_space_indicator intro!: nn_integral_cong network.flowD_outside[OF f] split: split_indicator)
      also have "\<dots> = d_OUT f (Right y)" by(simp add: flowD_KIR[OF f])
      also have "\<dots> = f (Right y, Sink)" by(simp add: OUT_f_Right)
      also have "\<dots> = pmf q y" by(simp add: SAT_q)
      finally show "pmf (map_pmf snd z) y = pmf q y" by simp
    qed
  qed
qed

proposition rel_pmf_measureI_unbounded: \<comment> \<open>Proof uses the unbounded max-flow min-cut theorem\<close>
  assumes le: "\<And>A. measure (measure_pmf p) A \<le> measure (measure_pmf q) {y. \<exists>x\<in>A. R x y}"
  shows "rel_pmf R p q"
  using assms by(rule rel_pmf_measureI_aux[OF network.max_flow_min_cut])

interpretation network: bounded_countable_network \<Delta>
proof
  have OUT_Left: "d_OUT cap (Left x) \<le> 1" for x
  proof -
    have "d_OUT cap (Left x) \<le> (\<Sum>\<^sup>+ y\<in>range Right. cap (Left x, y))"
      by(subst d_OUT_alt_def[of _ \<Delta>])(auto intro: network.capacity_outside[simplified] intro!: nn_integral_mono simp add: nn_integral_count_space_indicator outgoing_def split: split_indicator)
    also have "\<dots> = (\<Sum>\<^sup>+ y. cap (Left x, Right y))" by(simp add: nn_integral_count_space_reindex)
    also have "\<dots> \<le> (\<Sum>\<^sup>+ y. pmf q y)" by(rule nn_integral_mono)(simp)
    also have "\<dots> = 1" by(simp add: nn_integral_pmf)
    finally show ?thesis .
  qed
  show "d_OUT (capacity \<Delta>) x < \<top>" if "x \<in> \<^bold>V\<^bsub>\<Delta>\<^esub>" "x \<noteq> source \<Delta>" "x \<noteq> sink \<Delta>" for x
    using that by(cases x)(auto simp add: OUT_cap_Right intro: le_less_trans[OF OUT_Left])
qed

proposition rel_pmf_measureI_bounded: \<comment> \<open>Proof uses the bounded max-flow min-cut theorem\<close>
  assumes le: "\<And>A. measure (measure_pmf p) A \<le> measure (measure_pmf q) {y. \<exists>x\<in>A. R x y}"
  shows "rel_pmf R p q"
  using assms by(rule rel_pmf_measureI_aux[OF network.max_flow_min_cut_bounded])

end

end

interpretation rel_spmf_characterisation by unfold_locales(rule rel_pmf_measureI_bounded)

corollary rel_pmf_distr_mono: "rel_pmf R OO rel_pmf S \<le> rel_pmf (R OO S)"
\<comment> \<open>This fact has already been proven for the registration of @{typ "'a pmf"} as a BNF,
  but this proof is much shorter and more elegant. See \<^cite>\<open>HoelzlLochbihlerTraytel2015ITP\<close> for a
  comparison of formalisations.\<close>
proof(intro le_funI le_boolI rel_pmf_measureI_bounded, elim relcomppE)
  fix p q r A
  assume pq: "rel_pmf R p q" and qr: "rel_pmf S q r"
  have "measure (measure_pmf p) A \<le> measure (measure_pmf q) {y. \<exists>x\<in>A. R x y}"
    (is "_ \<le> measure _ ?B") using pq by(rule rel_pmf_measureD)
  also have "\<dots> \<le> measure (measure_pmf r) {z. \<exists>y\<in>?B. S y z}"
    using qr by(rule rel_pmf_measureD)
  also have "{z. \<exists>y\<in>?B. S y z} = {z. \<exists>x\<in>A. (R OO S) x z}" by auto
  finally show "measure (measure_pmf p) A \<le> measure (measure_pmf r) \<dots>" .
qed

end


section {* Properties of ballot arrays. *}

theory BallotArrayProperties
imports BallotArrays Quorums "~~/src/HOL/Library/Monad_Syntax"
begin

text {*
In this theory we show the two main properties of ballot-arrays:
1) If a value v is @{term "ballot_array.proved_safe_at_abs q b v"}, then it is @{term "ballot_array.safe_at v b"}}
2) If a ballot array increases, according to the prefix definition below, then every
value that was @{term "ballot_array.safe_at v b"} before is still @{term "ballot_array.safe_at v b"}}}
*}

subsection {* Correctness of the @{term proved_safe_at} computation *}

context ballot_array
begin

definition a_votes where "a_votes a bound \<equiv> {(v,b) . b < bound \<and> vote a b = Some v}"

lemma a_votes_finite:
  shows "finite (a_votes a bound)"
proof -
  have 1:"finite (S \<bind> f)" if "finite S" and "\<And> x . x \<in> S \<Longrightarrow> finite (f x)" for S f
    by (simp add: bind_UNION that)
  have 2:"a_votes a bound = {b . b < bound} \<bind> (\<lambda> b . case vote a b of Some v \<Rightarrow> {(v,b)} | None  \<Rightarrow> {})"
    (is "?votes = Set.bind ?bals ?f")
    by (auto simp add: Set.bind_def a_votes_def split!:option.split)
  have 3:"finite ?bals"
    by simp
  have 4:"finite (?f b)" for b by (simp split!:option.split)
  show ?thesis
    by (metis (no_types, lifting) 2 3 1 4)
qed

definition q_votes where "q_votes q bound \<equiv> {(v,b) . b < bound \<and> (\<exists> a \<in> q . vote a b = Some v)}"

end

locale ballot_array_props = ballot_array quorums + quorums quorums for quorums
begin

lemma q_votes_q_votes:
  "q_votes q bound = (\<Union> a\<in>q . a_votes a bound)"
    by (auto simp add:q_votes_def a_votes_def)

lemma q_votes_finite:
  assumes "q \<in> quorums"
  shows "finite (q_votes q bound)" using assms(1) a_votes_finite quorums_axioms
  by (auto simp add:a_votes_def q_votes_q_votes quorums_def)

context
begin

lemma safe_at_0:"safe_at v (0::nat)"
by (auto simp add:safe_at_def)

(* Only used in safe \<Rightarrow> agreement *)
private lemma chosen_at_is_choosable:
  assumes "chosen_at v b"
  shows "choosable v b" using assms
  by (auto simp add:chosen_at_def choosable_def)

(*<*)
(* Not used *)
private lemma safe_at_prec:
  assumes "safe_at v b" and "b2 < b"
  shows "safe_at v b2"
  using assms by (meson order.strict_trans safe_at_def)
(*>*)

(* Only used in safe \<Rightarrow> agreement *)
private lemma chosen_at_same:
  assumes "chosen_at v1 b1" and "chosen_at v2 b1"
  shows "v1 = v2"
by (metis assms chosen_at_def option.inject quorum_inter_witness)

(*<*)
(* Not used *)
private lemma all_choosable_no_safe:
  assumes "\<And> (v::'b) . choosable v b"
  and "safe_at v (Suc b)" and "(v1::'b) \<noteq> v2"
  shows False
  by (metis assms(1) assms(2) assms(3) lessI safe_at_def)
(*>*)

lemma safe_imp_agreement:
  assumes "safe" and "chosen v\<^sub>1" and "chosen v\<^sub>2"
  shows "v\<^sub>1 = v\<^sub>2"
  -- {* This follows the proof of Proposition 1 from the paper "Generalized Consensus and Paxos" *}
proof -
  { text {* The main argument as a lemma, to avoid repetitions*}
    fix b\<^sub>1 b\<^sub>2 v\<^sub>1 v\<^sub>2
    assume 1:"chosen_at v\<^sub>1 b\<^sub>1" and 2:"chosen_at v\<^sub>2 b\<^sub>2"
    with this obtain q\<^sub>1 and q\<^sub>2 where 3:"\<And> a . a \<in> q\<^sub>1 \<Longrightarrow> (vote) a b\<^sub>1 = (Some v\<^sub>1)"
    and 4:"\<And> a . a \<in> q\<^sub>2 \<Longrightarrow> (vote) a b\<^sub>2 = (Some v\<^sub>2)" and 5:"q\<^sub>1 \<in> quorums" and 6:"q\<^sub>2 \<in> quorums"
      by (fastforce simp add:chosen_at_def)
    have "v\<^sub>1 = v\<^sub>2" if "b\<^sub>1 < b\<^sub>2"
    proof -
      have 9:"choosable v\<^sub>1 b\<^sub>1" using 1 chosen_at_is_choosable by fast
      have 10:"safe_at v\<^sub>2 b\<^sub>2"
      proof -
        obtain a where "a \<in> q\<^sub>2" using 6 by (metis quorum_inter_witness)
        with this assms(1) 4 6 have "safe_at (the (vote a b\<^sub>2)) b\<^sub>2"
          by (metis option.case_eq_if option.distinct(1) safe_def)
        moreover have "the (vote a b\<^sub>2) = v\<^sub>2" using `a \<in> q\<^sub>2` 4 by force
        ultimately show ?thesis by auto
      qed
      thus ?thesis using 9 10 assms(1) that by (metis safe_at_def)
    qed }
  moreover
  obtain b\<^sub>1 and b\<^sub>2 where 1:"chosen_at v\<^sub>1 b\<^sub>1" and 2:"chosen_at v\<^sub>2 b\<^sub>2" using assms(2,3)
    by (auto simp add:chosen_def)
  ultimately
  show ?thesis using chosen_at_same 1 2 by (metis linorder_neqE_nat)
qed

subsection {* Proof that the proved_safe_at computation is correct. *}

lemma proved_safe_at_cases:
  assumes "proved_safe_at_abs q i v"
    -- {* There are two cases:
    (a) an acceptor a in the quorum q voted in round k < i,
    and k is the maximum round smaller than i in which an acceptor in q voted;
    (b) no acceptor in the quorum q voted in any round k < i *}
  obtains
    (a) k a
  where "a \<in> q" and "vote a k = Some v" and "k < i"
    and "\<And> a\<^sub>2 l . \<lbrakk>a\<^sub>2 \<in> q; k < l; l < i\<rbrakk> \<Longrightarrow> vote a\<^sub>2 l = None"
  | (b) "\<And> a k . \<lbrakk>a \<in> q; k < i\<rbrakk>  \<Longrightarrow> vote a k = None"
proof -
  have "q \<in> quorums" and ballot_q:"\<And> a . a \<in> q \<Longrightarrow> ballot a \<ge> i"
    using \<open>proved_safe_at_abs q i v\<close> by (auto simp add:proved_safe_at_abs_def)
  show ?thesis
  proof (cases "\<exists> a \<in> q . \<exists> l . l < i \<and> vote a l \<noteq> None")
    case False thus ?thesis using that by blast
  next
    case True
    let ?votes="{(w,m) . m < i \<and> (\<exists> a \<in> q . vote a m = Some w)}"
    have 1:"v \<in> (fst ` (max_by_key ?votes snd))"  using True \<open>proved_safe_at_abs q i v\<close>
      by (simp add:proved_safe_at_abs_def)
    with this obtain x where 4:"x \<in> max_by_key ?votes snd" and 5:"fst x = v" by blast
    have 2:"finite ?votes" using \<open>q \<in> quorums\<close> q_votes_finite
      by (simp add: q_votes_def)
    have 3:"?votes \<noteq> {}" using True by auto
    have 6:"\<And> a\<^sub>2 l . \<lbrakk>a\<^sub>2 \<in> q; snd x < l; l < i\<rbrakk> \<Longrightarrow> vote a\<^sub>2 l = None" and 9:"snd x < i"
      using 4 3 apply (auto simp add:max_by_key[OF 2, of snd]) by (meson not_le option.exhaust)
    obtain a where 7:"a \<in> q" and 8:"vote a (snd x) = Some v" using \<open>x \<in> max_by_key ?votes snd\<close> 5
      by (auto simp add:max_by_key[OF 2, of snd])
    show ?thesis using that using 5 7 8 9 6 by auto
  qed
qed

text {* The main lemma. Inspired by section 2.2.2 of the paper "Fast Paxos", by Leslie Lamport. *}

lemma proved_safe_at_abs_imp_safe_at:
  assumes "\<And> a j w . \<lbrakk>j < i; vote a j = Some w\<rbrakk> \<Longrightarrow> safe_at w j"
  and "proved_safe_at_abs q i v" and "conservative_array"
  shows "safe_at v (i::nat)"
proof (cases "i = 0")
  case True thus ?thesis
    by (metis not_less0 safe_at_def)
next
  case False
  have "q \<in> quorums" and ballot_q:"\<And> a . a \<in> q \<Longrightarrow> ballot a \<ge> i"
    using \<open>proved_safe_at_abs q i v\<close> by (auto simp add:proved_safe_at_abs_def)
  show ?thesis using \<open>proved_safe_at_abs q i v\<close>
  proof (cases rule:proved_safe_at_cases)
    case b
    text {* We prove that no value is choosable at any @{text "j < i"};
      therefore, anything is safe at i *}
    { fix j w
      assume "j < i"  and "choosable w j"
      from \<open>choosable w j\<close> obtain q2 where "q2 \<in> quorums" and q2_votes:"\<And> a . a \<in> q2 \<Longrightarrow>
        (ballot a) > j \<Longrightarrow> vote a j = Some w" by (auto simp add:choosable_def)
      from \<open>q2 \<in> quorums\<close> b \<open>j < i\<close> quorum_inter_witness \<open>q \<in> quorums\<close> ballot_q
      obtain a where "a \<in> q" and "a \<in> q2" and "ballot a > j"
        by (metis dual_order.strict_trans1)
      from \<open>a \<in> q\<close> b \<open>j < i\<close> have "vote a j = None" by metis
      moreover from \<open>ballot a > j\<close> q2_votes \<open>a \<in> q2\<close>  have "vote a j = Some w" by metis
      ultimately have False by auto }
    thus "safe_at v i" by (auto simp add:safe_at_def)
  next
    case (a k a)
    have "v' = v" if "choosable v' j" and "j < i" for j v'
    proof -
      text {* First obtain an acceptor that has voted for v' in j *}
      obtain a2 where "a2 \<in> q" and "vote a2 j = Some v'"
      proof -
        from \<open>choosable v' j\<close> obtain q2 where "q2 \<in> quorums" and q2_votes:"\<And> a . a \<in> q2 \<Longrightarrow>
          (ballot a) > j \<Longrightarrow> vote a j = Some v'" by (auto simp add:choosable_def)
        from \<open>q2 \<in> quorums\<close> \<open>q \<in> quorums\<close> ballot_q quorum_inter_witness \<open>j < i\<close>
          obtain a2 where "a2 \<in> q" and "a2 \<in> q2" and "ballot a2 > j" by (metis dual_order.strict_trans1)
        have "vote a2 j = Some v'" by (metis \<open>a2 \<in> q2\<close> \<open>j < ballot a2\<close> q2_votes)
        from that \<open>vote a2 j = Some v'\<close> \<open>a2 \<in> q\<close> show ?thesis by simp
      qed
      text {* We consider the following three cases. *}
      consider (aa) "j < k" | (bb) "j = k" | (cc) "k < j" by fastforce
      thus ?thesis
      proof cases
        case aa
        text {* v' is choosable at j < k. Since there is a vote for v at k and the ballot array
          before i is safe by assumption, we get that v' = v *}
        have "safe_at v k" using assms(1) \<open>vote a k = Some v\<close> \<open>k < i\<close> by metis
        with aa show ?thesis using that by (metis safe_at_def)
      next
        case cc
        text {* In this case we reach a contradiction because we can find a quorum which passed j
          and did note vote at j, thus no value can be choosable at j. *}
        from cc and a(4) \<open>j < i\<close> \<open>a2 \<in> q\<close> have "vote a2 j = None" by metis
        with \<open>vote a2 j = Some v'\<close> have False by auto
        thus ?thesis by auto
      next
        case bb
        with \<open>conservative_array\<close> \<open>vote a2 j = Some v'\<close> \<open>vote a k = Some v\<close> show ?thesis
          by (simp add:conservative_def conservative_array_def split: option.splits)
      qed
    qed
    thus ?thesis by (metis safe_at_def)
  qed
qed

end

end

subsection {* Monotonicity *}

text {* We define a prefix relation on ballot arrays and show that a value safe b remains
  safe at be when the ballot array grows *}

definition is_prefix where
  "is_prefix b1 b2 v1 v2 \<equiv> \<forall> a . b1 a \<le> b2 a
    \<and> (\<forall> b . (b < b1 a \<or> (b = b1 a \<and> v1 a b \<noteq> None)) \<longrightarrow> v1 a b = v2 a b)"

locale ballot_array_prefix = quorums quorums for  quorums :: "'a set set" +
  -- {* @{typ 'a} is the type of acceptors *}
  fixes ballot1 :: "'a \<Rightarrow> nat"
  and vote1 :: "'a \<Rightarrow> nat \<Rightarrow> 'v option"
  and ballot2 :: "'a \<Rightarrow> nat"
  and vote2 :: "'a \<Rightarrow> nat \<Rightarrow> 'v option"
  assumes "is_prefix ballot1 ballot2 vote1 vote2"
begin

interpretation ba_1:ballot_array quorums ballot1 vote1
using quorums_axioms by (unfold_locales)
interpretation ba_2:ballot_array quorums ballot2 vote2
using quorums_axioms by (unfold_locales)

lemma choosable_decreases:
  assumes "ba_2.choosable v b"
  shows "ba_1.choosable v b"
  using assms ballot_array_prefix_axioms
  nitpick[card 'v = 1, card 'a = 1, verbose, card nat = 2, card "'v option" = 2, card "nat option" = 3, expect=none]
  by (auto simp add: is_prefix_def ba_2.choosable_def ba_1.choosable_def ballot_array_prefix_def ballot_array_prefix_axioms_def quorums_def)
    (meson dual_order.strict_trans1)

lemma safe_at_mono:
  assumes "ba_1.safe_at v b"
  shows "ba_2.safe_at v b"
  by (metis assms ba_1.safe_at_def ba_2.safe_at_def choosable_decreases)

lemma chosen_mono:
  assumes "ba_1.chosen v" and "ba_1.well_formed"
  shows "ba_2.chosen v" using assms ballot_array_prefix_axioms
  unfolding ba_1.chosen_def ba_2.chosen_def ballot_array_prefix_def quorums_def ballot_array_prefix_axioms_def
    is_prefix_def ba_2.chosen_at_def ba_1.chosen_at_def ba_1.well_formed_def apply auto
  by (metis not_less_iff_gr_or_eq option.distinct(1))

lemma safe_votes:
  assumes ba_1.safe and "\<And> b a v . \<lbrakk>vote1 a b \<noteq> vote2 a b; vote2 a b = Some v\<rbrakk> \<Longrightarrow> ba_1.safe_at v b"
  and "\<And> b a . b > ballot1 a \<Longrightarrow> vote1 a b = vote2 a b"
  shows ba_2.safe
proof (auto simp add:ballot_array.safe_def split:option.splits)
  fix a b v
  assume "vote2 a b = Some v"
  show "ba_2.safe_at v b"
  proof (cases "vote1 a b = Some v")
    case True
    with assms(1) and safe_at_mono show ?thesis by (metis ba_1.safe_def option.simps(5))
  next
    case False
    with ballot_array_prefix_axioms assms(3) have "vote1 a b = None"
      apply (auto simp add:ballot_array_prefix_def ballot_array_prefix_axioms_def is_prefix_def)
      by (metis \<open>vote2 a b = Some v\<close> antisym_conv3 assms(1) ba_1.safe_def case_optionE)
    with assms(2) have "ba_1.safe_at v b" using \<open>vote2 a b = Some v\<close> by (metis option.distinct(1))
    thus ?thesis using safe_at_mono by blast
  qed
qed

lemma safe_mono:
  -- {* Does not hold. *}
  assumes "ba_2.safe" and "ba_2.well_formed" and "ba_1.well_formed"
  shows "ba_1.safe"
nitpick[verbose, card 'v = 2, card 'a = 2, verbose,  card nat = 2, card "'v option" = 3, expect=potential]
oops

end

end