(*  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>
*)

header {* Lamport's Inc example  *}

theory Inc
imports State
begin

text{*
  This example illustrates use of the embedding by mechanising
  the running example of Lamports original TLA paper \cite{Lamport94}.
*}

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 {*
  Proving invariants is the basis of every effort of system verification.
  We show that @{text I} is an inductive invariant of specification @{text psi}.
*}
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> \<circ>I" by (auto simp: I_def vars_def tla_defs)
  moreover
  have "|~ I \<and> n1 \<longrightarrow> \<circ>I" by (auto simp: I_def Sact2_defs tla_defs)
  moreover
  have "|~ I \<and> n2 \<longrightarrow> \<circ>I" by (auto simp: I_def Sact2_defs tla_defs)
  ultimately have step: "|~ I \<and> [n1 \<or> n2]_vars \<longrightarrow> \<circ>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 {*
  Using this invariant we now prove step simulation, i.e. the safety part of
  the refinement proof.
*}

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> \<circ>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 {*
  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.
*}
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 {*
  The analogous properties for the second process are obtained by copy and paste.
*}
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 {*
  We use rule @{text SF2} to prove that @{text psi} implements strong fairness
  for the abstract action @{text m1}. Since strong fairness implies weak fairness,
  it follows that @{text psi} refines the liveness condition of @{text phi}.
*}

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 {*
      Rule @{text SF2} requires us to choose a helpful action (whose effect implies
      @{text "\<langle>m1\<rangle>_(x,y)"}) and a persistent condition, which will eventually remain
      true if the helpful action is never executed. In our case, the helpful action
      is @{text beta1} and the persistent condition is @{text "pc1 = b"}.
    *}
    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> \<circ>($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 {*
      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.
    *}
    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> \<circ>($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 {*
          The plan of the proof is to show that from any state where @{text "pc1 = g"}
          one eventually reaches @{text "pc1 = a"}, from where one eventually reaches
          @{text "pc1 = b"}. The result follows by combining leadsto properties.
        *}
        let ?F = "LIFT (\<box>[(n1 \<or> n2) \<and> \<not> beta1]_vars \<and> SF(n1)_vars \<and> \<box>(I \<and> SF(n2)_vars))"
        txt {*
          Showing that @{text "pc1 = g"} leads to @{text "pc1 = a"} is a simple
          application of rule @{text SF1} because the first process completely
          controls this transition.
        *}
        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> \<circ>($pc1 = #g) \<or> \<circ>($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> \<circ>($pc1 = #a)"
            by (auto simp: Sact2_defs vars_def tla_defs)
        next
          show "|~ $pc1 = #g \<and> Unchanged vars \<longrightarrow> \<circ>($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 {*
          The proof that @{text "pc1 = a"} leads to @{text "pc1 = b"} follows
          the same basic schema. However, showing that @{text n1} is eventually
          enabled requires reasoning about the second process, which must liberate
          the critical section.
        *}
        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> \<circ>($pc1 = #a) \<or> \<circ>($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> \<circ>($pc1 = #b)"
            by (auto simp: Sact2_defs vars_def tla_defs)
        next
          show "|~ $pc1 = #a \<and> Unchanged vars \<longrightarrow> \<circ>($pc1 = #a)"
            by (auto simp: vars_def tla_defs)
        next
          txt {* We establish a suitable leadsto-chain. *}
          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 {* Rule @{text SF1} takes us from @{text "pc2 = b"} to @{text "pc2 = g"}. *}
            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> \<circ>($pc2 = #b) \<or> \<circ>($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> \<circ>($pc2 = #g)"
                by (auto simp: Sact2_defs vars_def tla_defs)
            next
              show "|~ $pc2 = #b \<and> Unchanged vars \<longrightarrow> \<circ>($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 {* Similarly, @{text "pc2 = b"} leads to @{text "pc2 = g"}. *}
            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> \<circ>($pc2 = #g) \<or> \<circ>($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> \<circ>($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> \<circ>($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 {*
  In the same way we prove that @{text psi} implements strong fairness
  for the abstract action @{text m1}. The proof is obtained by copy and paste
  from the previous one.
*}

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 {*
      Rule @{text SF2} requires us to choose a helpful action (whose effect implies
      @{text "\<langle>m2\<rangle>_(x,y)"}) and a persistent condition, which will eventually remain
      true if the helpful action is never executed. In our case, the helpful action
      is @{text beta2} and the persistent condition is @{text "pc2 = b"}.
    *}
    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> \<circ>($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 {*
      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.
    *}
    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> \<circ>($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 {*
          The plan of the proof is to show that from any state where @{text "pc2 = g"}
          one eventually reaches @{text "pc2 = a"}, from where one eventually reaches
          @{text "pc2 = b"}. The result follows by combining leadsto properties.
        *}
        let ?F = "LIFT (\<box>[(n1 \<or> n2) \<and> \<not> beta2]_vars \<and> SF(n2)_vars \<and> \<box>(I \<and> SF(n1)_vars))"
        txt {*
          Showing that @{text "pc2 = g"} leads to @{text "pc2 = a"} is a simple
          application of rule @{text SF1} because the second process completely
          controls this transition.
        *}
        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> \<circ>($pc2 = #g) \<or> \<circ>($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> \<circ>($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> \<circ>($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 {*
          The proof that @{text "pc2 = a"} leads to @{text "pc2 = b"} follows
          the same basic schema. However, showing that @{text n2} is eventually
          enabled requires reasoning about the second process, which must liberate
          the critical section.
        *}
        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> \<circ>($pc2 = #a) \<or> \<circ>($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> \<circ>($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> \<circ>($pc2 = #a)"
            by (auto simp: vars_def tla_defs)
        next
          txt {* We establish a suitable leadsto-chain. *}
          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 {* Rule @{text SF1} takes us from @{text "pc1 = b"} to @{text "pc1 = g"}. *}
            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> \<circ>($pc1 = #b) \<or> \<circ>($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> \<circ>($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> \<circ>($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 {* Similarly, @{text "pc1 = b"} leads to @{text "pc1 = g"}. *}
            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> \<circ>($pc1 = #g) \<or> \<circ>($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> \<circ>($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> \<circ>($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 {*
  We can now prove the main theorem, which states that @{text psi}
  implements @{text phi}.
*}

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


subsection \<open>Code setup for sets with cardinality type information\<close>

theory Code_Cardinality imports Cardinality begin

text \<open>
  Implement \<^term>\<open>CARD('a)\<close> via \<^term>\<open>card_UNIV\<close> and provide
  implementations for \<^term>\<open>finite\<close>, \<^term>\<open>card\<close>, \<^term>\<open>(\<subseteq>)\<close>,
  and \<^term>\<open>(=)\<close>if the calling context already provides \<^class>\<open>finite_UNIV\<close>
  and \<^class>\<open>card_UNIV\<close> instances. If we implemented the latter
  always via \<^term>\<open>card_UNIV\<close>, we would require instances of essentially all
  element types, i.e., a lot of instantiation proofs and -- at run time --
  possibly slow dictionary constructions.
\<close>

context
begin

qualified definition card_UNIV' :: "'a card_UNIV"
where [code del]: "card_UNIV' = Phantom('a) CARD('a)"

lemma CARD_code [code_unfold]:
  "CARD('a) = of_phantom (card_UNIV' :: 'a card_UNIV)"
by(simp add: card_UNIV'_def)

lemma card_UNIV'_code [code]:
  "card_UNIV' = card_UNIV"
by(simp add: card_UNIV card_UNIV'_def)

end

lemma card_Compl:
  "finite A \<Longrightarrow> card (- A) = card (UNIV :: 'a set) - card (A :: 'a set)"
by (metis Compl_eq_Diff_UNIV card_Diff_subset top_greatest)

context fixes xs :: "'a :: finite_UNIV list"
begin

qualified definition finite' :: "'a set \<Rightarrow> bool"
where [simp, code del, code_abbrev]: "finite' = finite"

lemma finite'_code [code]:
  "finite' (set xs) \<longleftrightarrow> True"
  "finite' (List.coset xs) \<longleftrightarrow> of_phantom (finite_UNIV :: 'a finite_UNIV)"
by(simp_all add: card_gt_0_iff finite_UNIV)

end

context fixes xs :: "'a :: card_UNIV list"
begin

qualified definition card' :: "'a set \<Rightarrow> nat"
where [simp, code del, code_abbrev]: "card' = card"

lemma card'_code [code]:
  "card' (set xs) = length (remdups xs)"
  "card' (List.coset xs) = of_phantom (card_UNIV :: 'a card_UNIV) - length (remdups xs)"
by(simp_all add: List.card_set card_Compl card_UNIV)

qualified definition subset' :: "'a set \<Rightarrow> 'a set \<Rightarrow> bool"
where [simp, code del, code_abbrev]: "subset' = (\<subseteq>)"

lemma subset'_code [code]:
  "subset' A (List.coset ys) \<longleftrightarrow> (\<forall>y \<in> set ys. y \<notin> A)"
  "subset' (set ys) B \<longleftrightarrow> (\<forall>y \<in> set ys. y \<in> B)"
  "subset' (List.coset xs) (set ys) \<longleftrightarrow> (let n = CARD('a) in n > 0 \<and> card(set (xs @ ys)) = n)"
by(auto simp add: Let_def card_gt_0_iff dest: card_eq_UNIV_imp_eq_UNIV intro: arg_cong[where f=card])
  (metis finite_compl finite_set rev_finite_subset)

qualified definition eq_set :: "'a set \<Rightarrow> 'a set \<Rightarrow> bool"
where [simp, code del, code_abbrev]: "eq_set = (=)"

lemma eq_set_code [code]:
  fixes ys
  defines "rhs \<equiv>
  let n = CARD('a)
  in if n = 0 then False else
        let xs' = remdups xs; ys' = remdups ys
        in length xs' + length ys' = n \<and> (\<forall>x \<in> set xs'. x \<notin> set ys') \<and> (\<forall>y \<in> set ys'. y \<notin> set xs')"
  shows "eq_set (List.coset xs) (set ys) \<longleftrightarrow> rhs"
  and "eq_set (set ys) (List.coset xs) \<longleftrightarrow> rhs"
  and "eq_set (set xs) (set ys) \<longleftrightarrow> (\<forall>x \<in> set xs. x \<in> set ys) \<and> (\<forall>y \<in> set ys. y \<in> set xs)"
  and "eq_set (List.coset xs) (List.coset ys) \<longleftrightarrow> (\<forall>x \<in> set xs. x \<in> set ys) \<and> (\<forall>y \<in> set ys. y \<in> set xs)"
proof goal_cases
  {
    case 1
    show ?case (is "?lhs \<longleftrightarrow> ?rhs")
    proof
      show ?rhs if ?lhs
        using that
        by (auto simp add: rhs_def Let_def List.card_set[symmetric]
          card_Un_Int[where A="set xs" and B="- set xs"] card_UNIV
          Compl_partition card_gt_0_iff dest: sym)(metis finite_compl finite_set)
      show ?lhs if ?rhs
      proof -
        have "\<lbrakk> \<forall>y\<in>set xs. y \<notin> set ys; \<forall>x\<in>set ys. x \<notin> set xs \<rbrakk> \<Longrightarrow> set xs \<inter> set ys = {}" by blast
        with that show ?thesis
          by (auto simp add: rhs_def Let_def List.card_set[symmetric]
            card_UNIV card_gt_0_iff card_Un_Int[where A="set xs" and B="set ys"]
            dest: card_eq_UNIV_imp_eq_UNIV split: if_split_asm)
      qed
    qed
  }
  moreover
  case 2
  ultimately show ?case unfolding eq_set_def by blast
next
  case 3
  show ?case unfolding eq_set_def List.coset_def by blast
next
  case 4
  show ?case unfolding eq_set_def List.coset_def by blast
qed

end

text \<open>
  Provide more informative exceptions than Match for non-rewritten cases.
  If generated code raises one these exceptions, then a code equation calls
  the mentioned operator for an element type that is not an instance of
  \<^class>\<open>card_UNIV\<close> and is therefore not implemented via \<^term>\<open>card_UNIV\<close>.
  Constrain the element type with sort \<^class>\<open>card_UNIV\<close> to change this.
\<close>

lemma card_coset_error [code]:
  "card (List.coset xs) =
   Code.abort (STR ''card (List.coset _) requires type class instance card_UNIV'')
     (\<lambda>_. card (List.coset xs))"
by(simp)

lemma coset_subseteq_set_code [code]:
  "List.coset xs \<subseteq> set ys \<longleftrightarrow>
  (if xs = [] \<and> ys = [] then False
   else Code.abort
     (STR ''subset_eq (List.coset _) (List.set _) requires type class instance card_UNIV'')
     (\<lambda>_. List.coset xs \<subseteq> set ys))"
by simp

notepad begin \<comment> \<open>test code setup\<close>
have "List.coset [True] = set [False] \<and>
      List.coset [] \<subseteq> List.set [True, False] \<and>
      finite (List.coset [True])"
  by eval

end

end


header {* Implementation of Safety Property Model Checker \label{sec:find_path_impl}*}
theory Find_Path_Impl
imports
  Find_Path
  "../CAVA_Automata/Digraph_Impl"
begin

  section {* Workset Algorithm *}
  text {* A simple implementation is by a workset algorithm. *}
  definition "ws_update E u p V ws \<equiv> RETURN (
             V \<union> E``{u},
             ws ++ (\<lambda>v. if (u,v)\<in>E \<and> v\<notin>V then Some (u#p) else None))"

  definition "s_init U0 \<equiv> RETURN (None,U0,\<lambda>u. if u\<in>U0 then Some [] else None)"

  definition "wset_find_path E U0 P \<equiv> do {
    ASSERT (finite U0);
    s0 \<leftarrow> s_init U0;
    (res,_,_) \<leftarrow> WHILET
      (\<lambda>(res,V,ws). res=None \<and> ws\<noteq>Map.empty)
      (\<lambda>(res,V,ws). do {
        ASSERT (ws\<noteq>Map.empty);
        (u,p) \<leftarrow> SPEC (\<lambda>(u,p). ws u = Some p);
        let ws=ws |` (-{u});

        if P u then
          RETURN (Some (rev p,u),V,ws)
        else do {
          ASSERT (finite (E``{u}));
          ASSERT (dom ws \<subseteq> V);
          (V,ws) \<leftarrow> ws_update E u p V ws;
          RETURN (None,V,ws)
        }
      }) s0;
      RETURN res
    }"

  lemma wset_find_path_correct:
    fixes E :: "('v\<times>'v) set"
    shows "wset_find_path E U0 P \<le> find_path E U0 P"
  proof -

    def inv \<equiv> "\<lambda>(res,V,ws). case res of
        None \<Rightarrow>
          dom ws\<subseteq>V
        \<and> finite (dom ws)  (* Derived *)
        \<and> V\<subseteq>E\<^sup>*``U0
        \<and> E``(V-dom ws) \<subseteq> V
        \<and> (\<forall>v\<in>V-dom ws. \<not> P v)
        \<and> U0 \<subseteq> V
        \<and> (\<forall>v p. ws v = Some p
          \<longrightarrow> ((\<forall>v\<in>set p. \<not>P v) \<and> (\<exists>u0\<in>U0. path E u0 (rev p) v)))
      | Some (p,v) \<Rightarrow> (\<exists>u0\<in>U0. path E u0 p v \<and> P v \<and> (\<forall>v\<in>set p. \<not>P v))"

    def var\<equiv>"inv_image
        (brk_rel (finite_psupset (E\<^sup>*``U0) <*lex*> measure (card o dom)))
        (\<lambda>(res::('v list \<times> 'v) option,V::'v set,ws::'v\<rightharpoonup>'v list).
            (res\<noteq>None,V,ws))"

    (*have [simp, intro!]: "wf var"
      unfolding var_def
      by (auto intro: FIN)*)

    have [simp]: "\<And>u p V. dom (\<lambda>v. if (u, v) \<in> E \<and> v \<notin> V then Some (u # p)
                     else None) = E``{u} - V"
      by (auto split: split_if_asm)

    {
      fix V ws u p
      assume INV: "inv (None,V,ws)"
      assume WSU: "ws u = Some p"

      from INV WSU have
        [simp]: "V \<subseteq> E\<^sup>*``U0"
        and [simp]: "u \<in> V"
        and UREACH: "\<exists>u0\<in>U0. (u0,u)\<in>E\<^sup>*"
        and [simp]: "finite (dom ws)"
        unfolding inv_def
        apply simp_all
        apply auto []
        apply clarsimp
        apply blast
        done
      have "(V \<union> E `` {u}, V) \<in> finite_psupset (E\<^sup>* `` U0) \<or>
          V \<union> E `` {u} = V \<and>
          card (E `` {u} - V \<union> (dom ws - {u})) < card (dom ws)"
      proof (subst disj_commute, intro disjCI conjI)
        assume "(V \<union> E `` {u}, V) \<notin> finite_psupset (E\<^sup>* `` U0)"
        thus "V \<union> E `` {u} = V" using UREACH
          by (auto simp: finite_psupset_def intro: rev_ImageI)

        hence [simp]: "E``{u} - V = {}" by force
        show "card (E `` {u} - V \<union> (dom ws - {u})) < card (dom ws)"
          using WSU
          by (auto intro: card_Diff1_less)
      qed
    } note wf_aux=this

    {
      fix V ws u p
      assume FIN: "finite (E\<^sup>*``U0)"
      assume "inv (None,V,ws)" "ws u = Some p"
      then obtain u0 where "u0\<in>U0" "(u0,u)\<in>E\<^sup>*" unfolding inv_def
        by clarsimp blast
      hence "E``{u} \<subseteq> E\<^sup>*``U0" by (auto intro: rev_ImageI)
      hence "finite (E``{u})" using FIN(1) by (rule finite_subset)
    } note succs_finite=this

    {
      fix V ws u p
      assume FIN: "finite (E\<^sup>*``U0)"
      assume INV: "inv (None,V,ws)"
      assume WSU: "ws u = Some p"
      assume NVD: "\<not> P u"

      have "inv (None, V \<union> E `` {u},
               ws |` (- {u}) ++
               (\<lambda>v. if (u, v) \<in> E \<and> v \<notin> V then Some (u # p)
                    else None))"
        unfolding inv_def

        apply (simp, intro conjI)
        using INV WSU apply (auto simp: inv_def) []
        using INV WSU apply (auto simp: inv_def) []
        using INV WSU apply (auto simp: succs_finite FIN) []
        using INV apply (auto simp: inv_def) []
        using INV apply (auto simp: inv_def) []

        using INV WSU apply (auto
          simp: inv_def
          intro: rtrancl_image_advance
        ) []

        using INV WSU apply (auto simp: inv_def) []

        using INV NVD apply (auto simp: inv_def) []
        using INV NVD apply (auto simp: inv_def) []

        using INV WSU NVD apply (fastforce
          simp: inv_def restrict_map_def
          intro!: path_conc path1
          split: split_if_asm
        ) []
        done
    } note ip_aux=this

    show ?thesis
      unfolding wset_find_path_def find_path_def ws_update_def s_init_def

      apply (refine_rcg refine_vcg le_ASSERTI
        WHILET_rule[where
          R = var and I = inv]
      )

      using [[goals_limit = 1]]

      apply (auto simp: var_def) []

      apply (auto
        simp: inv_def dom_def
        split: split_if_asm) []
      apply simp
      apply (auto simp: inv_def) []
      apply (auto simp: var_def brk_rel_def) []

      apply (simp add: succs_finite)

      apply (auto simp: inv_def) []

      apply clarsimp
      apply (simp add: ip_aux)

      apply clarsimp
      apply (simp add: var_def brk_rel_def wf_aux) []

      apply (fastforce
        simp: inv_def
        split: option.splits
        intro: rev_ImageI
        dest: Image_closed_trancl) []
      done
  qed

  text {* We refine the algorithm to use a foreach-loop*}
  definition "ws_update_foreach E u p V ws \<equiv>
    FOREACH (LIST_SET_REV_TAG (E``{u})) (\<lambda>v (V,ws).
      if v\<in>V then
        RETURN (V,ws)
      else do {
        ASSERT (v\<notin>dom ws);
        RETURN (insert v V,ws( v \<mapsto> u#p))
      }
    ) (V,ws)"

  lemma ws_update_foreach_refine[refine]:
    assumes FIN: "finite (E``{u})"
    assumes WSS: "dom ws \<subseteq> V"
    assumes ID: "(E',E)\<in>Id" "(u',u)\<in>Id" "(p',p)\<in>Id" "(V',V)\<in>Id" "(ws',ws)\<in>Id"
    shows "ws_update_foreach E' u' p' V' ws' \<le> \<Down>Id (ws_update E u p V ws)"
    unfolding ID[simplified]
    unfolding ws_update_foreach_def ws_update_def LIST_SET_REV_TAG_def
    apply (refine_rcg refine_vcg FIN
      FOREACH_rule[where I="\<lambda>it (V',ws').
        V'=V \<union> (E``{u}-it)
      \<and> dom ws' \<subseteq> V'
      \<and> ws' = ws ++ (\<lambda>v. if (u,v)\<in>E \<and> v\<notin>it \<and> v\<notin>V then Some (u#p) else None)"]
    )
    using WSS
    apply (auto
      simp: Map.map_add_def
      split: option.splits split_if_asm
      intro!: ext[where 'a='a and 'b="'b list option"])

    apply fastforce+
    done

  definition "s_init_foreach U0 \<equiv> do {
      (U0,ws) \<leftarrow> FOREACH U0 (\<lambda>x (U0,ws).
        RETURN (insert x U0,ws(x\<mapsto>[]))) ({},Map.empty);
      RETURN (None,U0,ws)
    }"

  lemma s_init_foreach_refine[refine]:
    assumes FIN: "finite U0"
    assumes ID: "(U0',U0)\<in>Id"
    shows "s_init_foreach U0' \<le>\<Down>Id (s_init U0)"
    unfolding s_init_foreach_def s_init_def ID[simplified]

    apply (refine_rcg refine_vcg
      FOREACH_rule[where
        I = "\<lambda>it (U,ws).
          U = U0-it
        \<and> ws = (\<lambda>x. if x\<in>U0-it then Some [] else None)"]
    )

    apply (auto
      simp: FIN
      intro!: ext
    )
    done

  definition "wset_find_path' E U0 P \<equiv> do {
    ASSERT (finite U0);
    s0\<leftarrow>s_init_foreach U0;
    (res,_,_) \<leftarrow> WHILET
      (\<lambda>(res,V,ws). res=None \<and> ws\<noteq>Map.empty)
      (\<lambda>(res,V,ws). do {
        ASSERT (ws\<noteq>Map.empty);
        ((u,p),ws) \<leftarrow> op_map_pick_remove ws;

        if P u then
          RETURN (Some (rev p,u),V,ws)
        else do {
          (V,ws) \<leftarrow> ws_update_foreach E u p V ws;
          RETURN (None,V,ws)
        }
      })
      s0;
      RETURN res
    }"

  lemma wset_find_path'_refine:
    "wset_find_path' E U0 P \<le> \<Down>Id (wset_find_path E U0 P)"
    unfolding wset_find_path'_def wset_find_path_def
    unfolding op_map_pick_remove_alt
    apply (refine_rcg IdI single_valued_Id)
    apply simp_all
    done

  section {* Refinement to efficient data structures *}
  schematic_lemma wset_find_path'_refine_aux:
    fixes U0::"'a::hashable set" and P::"'a \<Rightarrow> bool" and E::"('a\<times>'a) set"
    assumes [autoref_rules]:
      "(succi,E)\<in>\<langle>Id\<rangle>slg_rel"
      "(U0',U0)\<in>\<langle>Id\<rangle>list_set_rel"
    notes [autoref_tyrel] =
      TYRELI[where
        R="\<langle>Id::(('a\<times>'a) set),\<langle>Id::(('a\<times>'a) set)\<rangle>list_rel\<rangle>list_map_rel"]
      TYRELI[where R="\<langle>Id::(('a\<times>'a) set)\<rangle>map2set_rel dflt_ahm_rel"]

    notes [autoref_rules] =
      IdI[of P, unfolded fun_rel_id_simp[symmetric]]

    shows "(?c::?'c,wset_find_path' E U0 P) \<in> ?R"
    unfolding wset_find_path'_def ws_update_foreach_def s_init_foreach_def
    using [[autoref_trace_failed_id]]
    using [[autoref_trace_intf_unif]]
    using [[autoref_trace_pat]]
    apply (autoref (keep_goal))
    done

  concrete_definition wset_find_path_impl for succi U0' P
    uses wset_find_path'_refine_aux

  section {* Autoref Setup *}
  context begin interpretation autoref_syn .
    lemma [autoref_itype]:
      "find_path ::\<^sub>i \<langle>I\<rangle>\<^sub>ii_slg \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i (I\<rightarrow>\<^sub>ii_bool)
        \<rightarrow>\<^sub>i \<langle>\<langle>\<langle>\<langle>I\<rangle>\<^sub>ii_list, I\<rangle>\<^sub>ii_prod\<rangle>\<^sub>ii_option\<rangle>\<^sub>ii_nres" by simp

    lemma wset_find_path_autoref[autoref_rules]:
      shows "(
        wset_find_path_impl,
        find_path)
        \<in> \<langle>Id\<rangle>slg_rel \<rightarrow> \<langle>Id\<rangle>list_set_rel \<rightarrow> (Id\<rightarrow>bool_rel)
          \<rightarrow> \<langle>\<langle>\<langle>Id\<rangle>list_rel\<times>\<^sub>rId\<rangle>option_rel\<rangle>nres_rel"
    proof -
      note wset_find_path_impl.refine[THEN nres_relD]
      also note wset_find_path'_refine
      also note wset_find_path_correct
      finally show ?thesis
        by (fastforce intro!: nres_relI)
    qed
  end

  schematic_lemma wset_find_path_transfer_aux:
    "RETURN ?c \<le> wset_find_path_impl E U0 P"
    unfolding wset_find_path_impl_def
    by (refine_transfer (post))
  concrete_definition wset_find_path_code
    for E ?U0.0 P uses wset_find_path_transfer_aux
  lemmas [refine_transfer] = wset_find_path_code.refine

  export_code wset_find_path_code checking SML

section {* Nontrivial paths *}

definition "find_path1_gen E u0 P \<equiv> do {
  res \<leftarrow> find_path E (E``{u0}) P;
  case res of None \<Rightarrow> RETURN None
    | Some (p,v) \<Rightarrow> RETURN (Some (u0#p,v))
  }"

lemma find_path1_gen_correct: "find_path1_gen E u0 P \<le> find_path1 E u0 P"
  unfolding find_path1_gen_def find_path_def find_path1_def
  apply (refine_rcg refine_vcg le_ASSERTI)
  apply (auto
    intro: path_prepend
    dest: tranclD
    elim: finite_subset[rotated]
  )
  done

schematic_lemma find_path1_impl_aux:
  shows "(?c::?'c,find_path1_gen::(_\<times>_::hashable) set \<Rightarrow> _)\<in>?R"
  unfolding find_path1_gen_def[abs_def]
  apply (autoref (keep_goal))
  done

lemma [autoref_itype]:
  "find_path1 ::\<^sub>i \<langle>I\<rangle>\<^sub>ii_slg \<rightarrow>\<^sub>i I \<rightarrow>\<^sub>i (I\<rightarrow>\<^sub>ii_bool)
    \<rightarrow>\<^sub>i \<langle>\<langle>\<langle>\<langle>I\<rangle>\<^sub>ii_list, I\<rangle>\<^sub>ii_prod\<rangle>\<^sub>ii_option\<rangle>\<^sub>ii_nres" by simp

concrete_definition find_path1_impl uses find_path1_impl_aux

lemma find_path1_autoref[autoref_rules]:
  "(find_path1_impl,find_path1)
    \<in> \<langle>Id\<rangle>slg_rel \<rightarrow>Id \<rightarrow> (Id \<rightarrow> bool_rel) \<rightarrow>
      \<langle>\<langle>\<langle>Id\<rangle>list_rel \<times>\<^sub>r Id\<rangle>Relators.option_rel\<rangle>nres_rel"
  apply (rule fun_relI nres_relI)+
  apply (rule order_trans)
  apply (erule (2) find_path1_impl.refine[param_fo, THEN nres_relD])
  apply (simp add: find_path1_gen_correct)
  done

schematic_lemma find_path1_transfer_aux:
  "RETURN ?c \<le> find_path1_impl E u P"
  unfolding find_path1_impl_def
  by refine_transfer
concrete_definition find_path1_code for E u P uses find_path1_transfer_aux
lemmas [refine_transfer] = find_path1_code.refine

end


theory LaunchburyStacked
imports Terms Heap
begin

subsubsection {* The stackful natural semantics *}

text {* This semantics is a slight modification of the original semantics:
\begin{itemize}
\item The expression to be evaluated is the first element in the second associative list (the ``stack'').
\item To evaluate a variable its binding is moved on top of the stack.
\item When an application @{term "f x"} is evaluated, a new name @{term n} is created, the expression to be
evaluated is remembered as @{term "n x"} and @{term "(n, f)"} is put on top of the stack.
\end{itemize}
*}

inductive reds :: "heap \<Rightarrow> heap \<Rightarrow> heap \<Rightarrow> heap \<Rightarrow> bool" ("_ : _ \<Down> _ : _" [50,50,50,50] 50)
where
  Lambda:
    "\<Gamma> : (x, (Lam [y]. e)) # \<Gamma>' \<Down> \<Gamma> : (x, (Lam [y]. e)) # \<Gamma>'"
 | Application: "\<lbrakk>
      atom n \<sharp> (\<Gamma>,\<Gamma>',\<Delta>,\<Delta>',x,e,y,\<Theta>,\<Theta>',z);
      atom z \<sharp> (\<Gamma>,\<Gamma>',\<Delta>,\<Delta>',x,e,y,\<Theta>,\<Theta>');
      \<Gamma> : (n, e) # (x, App (Var n) y) # \<Gamma>' \<Down> \<Delta> : (n, Lam [z]. e') # (x, App (Var n) y) # \<Delta>';
      \<Delta> : (x, e'[z ::= y]) # \<Delta>' \<Down> \<Theta> : \<Theta>'
    \<rbrakk> \<Longrightarrow>
      \<Gamma> : (x, App e y) # \<Gamma>' \<Down> \<Theta> : \<Theta>'"
 | Variable: "\<lbrakk>
      (y, e) \<in> set \<Gamma>;
      delete y \<Gamma> : (y, e) # (x,Var y) # \<Gamma>' \<Down> \<Delta> : (y, z) # (x, Var y) # \<Delta>'
   \<rbrakk> \<Longrightarrow>
      \<Gamma> : (x, Var y) # \<Gamma>' \<Down> (y, z) # \<Delta> : (x, z) # \<Delta>'"
 | Let: "\<lbrakk>
      set (bn as) \<sharp>* (\<Gamma>, x, \<Gamma>');
      distinctVars (asToHeap as);
      asToHeap as @ \<Gamma> : (x, body) # \<Gamma>' \<Down> \<Delta> : \<Delta>'
   \<rbrakk> \<Longrightarrow>
      \<Gamma> : (x, Let as body) # \<Gamma>' \<Down> \<Delta> : \<Delta>'"

equivariance reds

nominal_inductive reds
  avoids Application: "n" and "z"
  by (auto simp add: fresh_star_def fresh_Cons fresh_Pair)

subsubsection {* Example evaluations *}

lemma eval_test:
  "y \<noteq> x \<Longrightarrow> [] : [(x, Let (ACons y (Lam [z]. Var z) ANil) (Var y))] \<Down> [(y, Lam [z]. Var z)] : [(x, (Lam [z]. Var z))]"
by (auto intro!: Lambda Application Variable Let
 simp add: fresh_Pair fresh_Cons fresh_Nil fresh_star_def exp_assn.bn_defs fresh_at_base)

lemma eval_test2:
  "y \<noteq> x \<Longrightarrow> z \<noteq> y \<Longrightarrow> z \<noteq> x \<Longrightarrow> [] : [(x,  Let (ACons y (Lam [z]. Var z) ANil) (App (Var y) y))] \<Down> [(y, Lam [z]. Var z)] : [(x, (Lam [z]. Var z))]"
  apply (rule Let)
  apply (simp add: fresh_Pair fresh_Cons fresh_at_base  fresh_Nil fresh_star_def exp_assn.bn_defs)
  apply simp
  apply (rule obtain_fresh)
  apply (erule Application[where z = z])
  defer
    apply (rule Variable, simp)
    apply (rule Lambda)
    apply simp
    apply (rule Variable, simp)
    apply simp
    apply (rule Lambda)
  apply (simp add: fresh_Pair fresh_Cons fresh_at_base fresh_Nil fresh_star_def)
  done

subsubsection {* Properties of the semantics *}

text {*
This is the same semantics with additional distinctiveness requirements. This is defined in order to
obtain a more convenient induction rule.
*}

inductive distinct_reds :: "heap \<Rightarrow> heap \<Rightarrow> heap \<Rightarrow> heap \<Rightarrow> bool" ("_ : _ \<Down>d _ : _" [50,50,50,50] 50)
where
  DLambda: "\<lbrakk>
      distinctVars ((x, (Lam [y]. e)) # \<Gamma>' @ \<Gamma>)
    \<rbrakk> \<Longrightarrow>
      \<Gamma> : (x, (Lam [y]. e)) # \<Gamma>' \<Down>d \<Gamma> : (x, (Lam [y]. e)) # \<Gamma>'"
 | DApplication: "\<lbrakk>
      atom n \<sharp> (\<Gamma>,\<Gamma>',\<Delta>,\<Delta>',x,e,y,\<Theta>,\<Theta>',z);
      atom z \<sharp> (\<Gamma>,\<Gamma>',\<Delta>,\<Delta>',x,e,y,\<Theta>,\<Theta>');
      distinctVars (((x, App e y) # \<Gamma>') @ \<Gamma>);
      distinctVars (((n, e) # (x, App (Var n) y) # \<Gamma>') @ \<Gamma>);
      distinctVars (((n, Lam [z]. e') # (x, App (Var n) y) # \<Delta>') @ \<Delta>);
      distinctVars (((x, e'[z ::= y]) # \<Delta>') @ \<Delta>);
      distinctVars (\<Theta>' @ \<Theta>);
      \<Gamma> : (n, e) # (x, App (Var n) y) # \<Gamma>' \<Down>d \<Delta> : (n, Lam [z]. e') # (x, App (Var n) y) # \<Delta>';
      \<Delta> : (x, e'[z ::= y]) # \<Delta>' \<Down>d \<Theta> : \<Theta>'
    \<rbrakk> \<Longrightarrow>
      \<Gamma> : (x, App e y) # \<Gamma>' \<Down>d \<Theta> : \<Theta>'"
 | DVariable: "\<lbrakk>
      (y, e) \<in> set \<Gamma>;
      distinctVars (((x, Var y) # \<Gamma>') @ \<Gamma>);
      distinctVars (((y, e) # (x,Var y) # \<Gamma>') @ delete y \<Gamma>);
      distinctVars (((y, z) # (x, Var y) # \<Delta>') @ \<Delta>);
      distinctVars (((x, z) # \<Delta>') @ (y, z) # \<Delta>);
      delete y \<Gamma> : (y, e) # (x,Var y) # \<Gamma>' \<Down>d \<Delta> : (y, z) # (x, Var y) # \<Delta>'
   \<rbrakk> \<Longrightarrow>
      \<Gamma> : (x, Var y) # \<Gamma>' \<Down>d (y, z) # \<Delta> : (x, z) # \<Delta>'"
 | DLet: "\<lbrakk>
      set (bn as) \<sharp>* (\<Gamma>, x, \<Gamma>');
      distinctVars (asToHeap as);
      distinctVars (((x, Let as body) # \<Gamma>') @ \<Gamma>);
      distinctVars (((x, body) # \<Gamma>') @ asToHeap as @ \<Gamma>);
      distinctVars (\<Delta>' @ \<Delta>);
      asToHeap as @ \<Gamma> : (x, body) # \<Gamma>' \<Down>d \<Delta> : \<Delta>'
   \<rbrakk> \<Longrightarrow>
      \<Gamma> : (x, Let as body) # \<Gamma>' \<Down>d \<Delta> : \<Delta>'"

equivariance distinct_reds

nominal_inductive distinct_reds
  avoids DApplication: "n" and "z"
  apply (auto simp add: fresh_star_def fresh_Cons fresh_Pair)
  done

lemma distinct_redsD1:
  "\<Gamma> : \<Gamma>' \<Down>d \<Delta> : \<Delta>' \<Longrightarrow> \<Gamma> : \<Gamma>' \<Down> \<Delta> : \<Delta>'"
  apply (nominal_induct rule: distinct_reds.strong_induct)
  apply (auto intro:reds.intros simp add: fresh_star_Pair fresh_Pair)
  done

lemma distinct_redsD2:
  "\<Gamma> : \<Gamma>' \<Down>d \<Delta> : \<Delta>' \<Longrightarrow> distinctVars (\<Gamma>'@\<Gamma>)"
  apply (nominal_induct rule: distinct_reds.strong_induct)
  apply (auto)
  done

lemma distinct_redsD3:
  "\<Gamma> : \<Gamma>' \<Down>d \<Delta> : \<Delta>' \<Longrightarrow> distinctVars (\<Delta>'@\<Delta>)"
  apply (nominal_induct rule: distinct_reds.strong_induct)
  apply (auto)
  done

lemma distinct_redsI:
  "\<Gamma> : \<Gamma>' \<Down> \<Delta> : \<Delta>' \<Longrightarrow> distinctVars (\<Gamma>'@\<Gamma>) \<Longrightarrow> \<Gamma> : \<Gamma>' \<Down>d \<Delta> : \<Delta>'"
proof (nominal_induct rule: reds.strong_induct)
case Lambda thus ?case by (auto intro: distinct_reds.intros)
next
case (Application n \<Gamma> \<Gamma>' \<Delta> \<Delta>' x e y \<Theta> \<Theta>' z e')
  have "atom n \<sharp> (\<Gamma>, \<Gamma>',\<Delta>,\<Delta>',x, e, y, \<Theta>, \<Theta>',z)"
    using Application by simp
  moreover
  have "atom z \<sharp> (\<Gamma>, \<Gamma>', \<Delta>, \<Delta>', x, e, y, \<Theta>, \<Theta>')"
    using Application by simp
  moreover
  assume "distinctVars (((x, App e y) # \<Gamma>') @ \<Gamma>)"
  moreover
  have "atom n \<sharp> (((x, App e y) # \<Gamma>') @ \<Gamma>)"
    using Application
    by (simp add: fresh_Cons fresh_Pair fresh_append)
  hence "n \<notin> heapVars (((x, App e y) # \<Gamma>') @ \<Gamma>)"
    by (metis heapVars_not_fresh)
  with `distinctVars (((x, App e y) # \<Gamma>') @ \<Gamma>)`
  have "distinctVars (((n, e) # (x, App (Var n) y) # \<Gamma>') @ \<Gamma>)"
    by (simp add: distinctVars_append distinctVars_Cons)
  moreover
  note hyp1 = Application.hyps(21)[OF this]
  note distinct_redsD3[OF hyp1]
  moreover
  hence "distinctVars (((x, e'[z::=y]) # \<Delta>') @ \<Delta>)"
    by (simp add: distinctVars_append distinctVars_Cons)
  moreover
  note hyp2 = Application.hyps(23)[OF this]
  note distinct_redsD3[OF hyp2]
  moreover
  note hyp1
  moreover
  note hyp2
  ultimately
  show ?case
    by (rule DApplication[where n = n and z = z])
next

case (Variable y e \<Gamma> x \<Gamma>' \<Delta> z \<Delta>')
  assume "(y, e) \<in> set \<Gamma>"
  moreover
  assume "distinctVars (((x, Var y) # \<Gamma>') @ \<Gamma>)"
  moreover
  have "distinctVars (((y, e) # (x, Var y) # \<Gamma>') @ delete y \<Gamma>)"
    using Variable(1,4)
    by (auto simp add: distinctVars_append distinctVars_Cons intro: distinctVars_delete heapVars_from_set)
  moreover
  note hyp = Variable.hyps(3)[OF this]
  note distinct_redsD3[OF hyp]
  moreover
  hence "distinctVars (((x, z) # \<Delta>') @ (y, z) # \<Delta>)"
    by (auto simp add: distinctVars_append distinctVars_Cons)
  moreover
  note hyp
  ultimately
  show ?case
    by (rule DVariable)
next
case (Let as \<Gamma> x \<Gamma>' body \<Delta> \<Delta>')
  hence "set (bn as) \<sharp>* (((x, Let as body) # \<Gamma>') @ \<Gamma>)"
    by (auto simp add: fresh_star_Pair fresh_star_list)
  hence "heapVars (asToHeap as) \<inter> heapVars (((x, Terms.Let as body) # \<Gamma>') @ \<Gamma>) = {}"
    by (rule fresh_assn_distinct)

  have "set (bn as) \<sharp>* (\<Gamma>, x, \<Gamma>')"
    using Let by (simp add: fresh_star_Pair fresh_star_list)
  moreover
  assume "distinctVars (asToHeap as)"
  moreover
  assume "distinctVars (((x, Terms.Let as body) # \<Gamma>') @ \<Gamma>)"
  moreover
  hence "distinctVars (((x, body) # \<Gamma>') @ asToHeap as @ \<Gamma>)"
    using `distinctVars (asToHeap as)` `_ = {}`
    by (auto simp add: distinctVars_append distinctVars_Cons)
  moreover
  note hyp = Let.hyps(6)[OF this]
  note distinct_redsD3[OF hyp]
  moreover
  note hyp
  ultimately
  show ?case
    by (rule DLet)
qed

lemma reds_pres_distinctVars:
  "\<Gamma> : \<Gamma>' \<Down> \<Delta> : \<Delta>' \<Longrightarrow> distinctVars (\<Gamma>'@\<Gamma>) \<Longrightarrow> distinctVars (\<Delta>'@\<Delta>)"
by (metis distinct_redsD3 distinct_redsI)

lemmas reds_distinct_ind = distinct_reds.induct[OF distinct_redsI, consumes 2, case_names Lambda Application Variable Let]
lemmas reds_distinct_strong_ind = distinct_reds.strong_induct[OF distinct_redsI, consumes 2, case_names Lambda Application Variable Let]

lemma reds_doesnt_forget':
  assumes "\<Gamma> : \<Gamma>' \<Down>d \<Delta> : \<Delta>'"
  shows "heapVars \<Gamma> \<subseteq> heapVars \<Delta>" and "heapVars \<Gamma>' \<subseteq> heapVars \<Delta>'"
using assms
proof(induct rule: distinct_reds.induct)
case DLambda
  case 1 show ?case by simp
  case 2 show ?case by simp
next
case (DApplication n \<Gamma> \<Gamma>' \<Delta> \<Delta>' x e y \<Theta> \<Theta>' z e')
  case 1
  show ?case
    using DApplication by simp
  case 2
  show ?case
  proof
    fix v
    assume "v \<in> heapVars ((x, App e y) # \<Gamma>')"
    hence "\<not>( atom v \<sharp> (x, App e y) # \<Gamma>')"
      by (rule heapVars_not_fresh)
    hence "v \<noteq> n"
      by (metis DApplication(1) exp_assn.fresh(2) fresh_Cons fresh_Pair)

    assume "v \<in> heapVars ((x, App e y) # \<Gamma>')"
    hence "v \<in> heapVars ((n, e) # (x, App (Var n) y) # \<Gamma>')" by simp
    hence "v \<in> heapVars ((n, Lam [z]. e') # (x, App (Var n) y) # \<Delta>')"
      by (rule set_mp[OF DApplication(10)])
    hence "v \<in> heapVars ((x, e'[z::=y]) # \<Delta>')"
      using `v \<noteq> n` by simp
    thus "v \<in> heapVars \<Theta>'"
      by (rule set_mp[OF DApplication(13)])
  qed
next
case (DVariable y e \<Gamma> x \<Gamma>' z \<Delta>' \<Delta>)
  case 1
  from DVariable(7)
  show ?case  by auto
  case 2
  from DVariable(3)
  have "y \<notin> heapVars ((x, Var y) # \<Gamma>')"
    by (metis distinctVars_ConsD(1) distinctVars_appendD1)
  with DVariable(8)
  show ?case
    by auto
next
case (DLet as \<Gamma> x body \<Gamma>' \<Delta>' \<Delta>)
  case 1 show ?case using DLet by simp
  case 2 show ?case using DLet by simp
qed

text {* Heap entries are never removed. *}

lemma reds_doesnt_forget:
 assumes "\<Gamma> : \<Gamma>' \<Down> \<Delta> : \<Delta>'"
 assumes "distinctVars (\<Gamma>'@\<Gamma>)"
 shows "heapVars \<Gamma> \<subseteq> heapVars \<Delta>" and "heapVars \<Gamma>' \<subseteq> heapVars \<Delta>'"
by (rule reds_doesnt_forget'[OF distinct_redsI[OF assms]])+

text {* The stack is never empty. *}

lemma stack_not_empty:
  assumes "\<Gamma> : \<Gamma>' \<Down> \<Delta> : \<Delta>'"
  shows "\<Delta>' \<noteq> []"
  using assms
  by (induct rule:reds.induct, simp_all)

text {* Evaluation does not change the name of the evaluation variable. *}

lemma stack_same_head:
  assumes "\<Gamma> : \<Gamma>' \<Down> \<Delta> : \<Delta>'"
  shows "fst (hd \<Delta>') = fst (hd \<Gamma>')"
  using assms
  by (induct rule:reds.induct, simp_all)

text {* Evaluation does not touch the tail of the stack. *}

lemma stack_unchanged:
  assumes "\<Gamma> : (x, e) # \<Gamma>' \<Down> \<Delta> : (x, e') # \<Delta>'"
  shows "\<Delta>' = \<Gamma>'"
proof-
  {fix \<Gamma>' \<Delta>'
  have "\<Gamma> : \<Gamma>' \<Down> \<Delta> : \<Delta>' \<Longrightarrow> tl \<Delta>' = tl \<Gamma>'"
    by (induct rule:reds.induct, simp_all)
  }
  from this[OF assms]
  show ?thesis by simp
qed

text {*
Fresh variables either stay fresh or are added to the heap.
*}

lemma reds_fresh':" \<lbrakk> \<Gamma> : \<Gamma>' \<Down>d \<Delta> : \<Delta>';
   atom (x::var) \<sharp> (\<Gamma> , snd (hd \<Gamma>'))
  \<rbrakk> \<Longrightarrow> atom x \<sharp> (\<Delta>, snd (hd \<Delta>')) \<or> x \<in> heapVars \<Delta>"
proof(nominal_induct avoiding: x rule: distinct_reds.strong_induct)
case (DLambda \<Gamma> x e) thus ?case by auto
next
case (DApplication n \<Gamma> \<Gamma>' \<Delta> \<Delta>' xa e y \<Theta> \<Theta>' z e' x)
  from DApplication have [simp]:"atom x \<sharp> \<Gamma>" "atom x \<sharp> e" "atom x \<sharp> y" by (simp add: fresh_Pair)+
  from `atom n \<sharp> x` have [simp]:"atom x \<sharp> n" by (metis fresh_at_base(2))
  have [simp]:"atom z \<sharp> y" by fact

  have "atom x \<sharp> (\<Gamma>, snd (hd ((n, e) # (xa, App (Var n) y) # \<Gamma>')))"
    by simp
  from DApplication.hyps(28)[OF this, simplified]
  have "atom x \<sharp> (\<Delta>, Lam [z]. e') \<or> x \<in> heapVars \<Delta>".
  thus ?case
  proof
    assume "atom x \<sharp> (\<Delta>, Lam [z]. e')"
    hence [simp]:"atom x \<sharp> \<Delta>" by simp
    assume "atom x \<sharp> (\<Delta>, Lam [z]. e')"
    hence "atom x \<sharp> e' \<or> x = z"
      by (simp add: fresh_Pair)+
    hence "atom x \<sharp> (\<Delta>, snd (hd ((xa, e'[z::=y]) # \<Delta>')))"
    proof
      assume "atom x \<sharp> e'"
      thus ?thesis
        by (simp add: fresh_Pair subst_pres_fresh[rule_format])
    next
      assume "x = z"
      hence "z = x" by (rule sym)
      thus ?thesis
        by (auto intro!:subst_is_fresh simp add: fresh_Pair)
    qed
    thus ?thesis
      by (rule DApplication)
  next
    assume "x \<in> heapVars \<Delta>"
    thus ?thesis
    using reds_doesnt_forget'(1)[OF DApplication.hyps(29)]
    by auto
  qed
next
case(DVariable y e \<Gamma> xa \<Gamma>' z \<Delta>' \<Delta> x)
  from `atom x \<sharp> _` ` (y, e) \<in> set \<Gamma>`
  have "atom x \<sharp> delete y \<Gamma>" and "atom x \<sharp> e"
    by (auto intro: fresh_delete dest:fresh_list_elem simp add: fresh_Pair)
  hence "atom x \<sharp> (\<Delta>, snd (hd ((y, z) # (xa, Var y) # \<Delta>'))) \<or> x \<in> heapVars \<Delta>"
    by -(rule DVariable, simp add: fresh_Pair)
  thus ?case
    by (auto simp add: fresh_Pair fresh_Cons fresh_at_base)
next
case (DLet as \<Gamma> xa body \<Gamma>' \<Delta>' \<Delta> x)
  show ?case
    proof (cases "atom x \<in> set (bn as)")
    case False
      hence "atom x \<sharp> as" using DLet.prems by(auto simp add: fresh_Pair)
      hence "atom x \<sharp> asToHeap as"
        by(induct as rule:asToHeap.induct)(auto simp add: fresh_Nil fresh_Cons fresh_Pair)
      show ?thesis
        apply(rule DLet.hyps(9))
        using DLet.prems `atom x \<sharp> asToHeap as` False
        by (auto simp add: fresh_Pair exp_assn.fresh fresh_append)
    next
    case True
      hence "x \<in> heapVars (asToHeap as)"
        by(induct as rule:asToHeap.induct)(auto simp add: exp_assn.bn_defs)
      thus ?thesis using reds_doesnt_forget'[OF DLet.hyps(8)] by auto
    qed
qed

lemma reds_fresh: " \<lbrakk> \<Gamma> : (y, e) # \<Gamma>' \<Down>d \<Delta> : (y, z) # \<Delta>';
   atom (x::var) \<sharp> (\<Gamma> , e)
  \<rbrakk> \<Longrightarrow> atom x \<sharp> (\<Delta>, z) \<or> x \<in> heapVars \<Delta>"
by (metis (hide_lams, no_types) list.sel(1) reds_fresh' snd_conv)

end