section \<open>Simulations Between Dynamic Executions\<close>

theory Simulation
  imports Semantics Inf Well_founded
begin

locale backward_simulation =
  L1: semantics step1 final1 +
  L2: semantics step2 final2 +
  well_founded "(\<sqsubset>)"
  for
    step1 :: "'state1 \<Rightarrow> 'state1 \<Rightarrow> bool" and
    step2 :: "'state2 \<Rightarrow> 'state2 \<Rightarrow> bool" and
    final1 :: "'state1 \<Rightarrow> bool" and
    final2 :: "'state2 \<Rightarrow> bool" and
    order :: "'index \<Rightarrow> 'index \<Rightarrow> bool" (infix "\<sqsubset>" 70) +
  fixes
    match :: "'index \<Rightarrow> 'state1 \<Rightarrow> 'state2 \<Rightarrow> bool"
  assumes
    match_final:
      "match i s1 s2 \<Longrightarrow> final2 s2 \<Longrightarrow> final1 s1" and
    simulation:
      "match i1 s1 s2 \<Longrightarrow> step2 s2 s2' \<Longrightarrow>
        (\<exists>i2 s1'. step1\<^sup>+\<^sup>+ s1 s1' \<and> match i2 s1' s2') \<or> (\<exists>i2. match i2 s1 s2' \<and> i2 \<sqsubset> i1)"
begin

text \<open>
A simulation is defined between two @{locale semantics} L1 and L2.
A @{term match} predicate expresses that two states from L1 and L2 are equivalent.
The @{term match} predicate is also parameterized with an ordering used to avoid stuttering.
The only two assumptions of a backward simulation are that a final state in L2 will also be a final in L1,and that a step in L2 will either represent a non-empty sequence of steps in L1 or will result in an equivalent state.
Stuttering is ruled out by the requirement that the index on the @{term match} predicate decreases with respect to the well-founded @{term order} ordering.
\<close>

end

locale forward_simulation =
  L1: semantics step1 final1 +
  L2: semantics step2 final2 +
  well_founded "(\<sqsubset>)"
  for
    step1 :: "'state1 \<Rightarrow> 'state1 \<Rightarrow> bool" and
    step2 :: "'state2 \<Rightarrow> 'state2 \<Rightarrow> bool" and
    final1 :: "'state1 \<Rightarrow> bool" and
    final2 :: "'state2 \<Rightarrow> bool" and
    order :: "'index \<Rightarrow> 'index \<Rightarrow> bool" (infix "\<sqsubset>" 70) +
  fixes
    match :: "'index \<Rightarrow> 'state1 \<Rightarrow> 'state2 \<Rightarrow> bool"
  assumes
    match_final:
      "match i s1 s2 \<Longrightarrow> final1 s1 \<Longrightarrow> final2 s2" and
    simulation:
      "match i1 s1 s2 \<Longrightarrow> step1 s1 s1' \<Longrightarrow>
        (\<exists>i' s2'. step2\<^sup>+\<^sup>+ s2 s2' \<and> match i' s1' s2') \<or> (\<exists>i'. match i' s1 s2' \<and> i' \<sqsubset> i1)"

locale bisimulation =
  forward_simulation step1 step2 final1 final2 order match +
  backward_simulation step1 step2 final1 final2 order match
  for
    step1 :: "'state1 \<Rightarrow> 'state1 \<Rightarrow> bool" and
    step2 :: "'state2 \<Rightarrow> 'state2 \<Rightarrow> bool" and
    final1 :: "'state1 \<Rightarrow> bool" and
    final2 :: "'state2 \<Rightarrow> bool" and
    order :: "'index \<Rightarrow> 'index \<Rightarrow> bool" and
    match :: "'index \<Rightarrow> 'state1 \<Rightarrow> 'state2 \<Rightarrow> bool"

context backward_simulation begin

lemma lift_simulation_plus:
  "step2\<^sup>+\<^sup>+ s2 s2' \<Longrightarrow> match i1 s1 s2 \<Longrightarrow>
    (\<exists>i2 s1'. step1\<^sup>+\<^sup>+ s1 s1' \<and> match i2 s1' s2') \<or>
    (\<exists>i2. match i2 s1 s2' \<and> order\<^sup>+\<^sup>+ i2 i1)"
  thm tranclp_induct
proof(induction s2' arbitrary: i1 s1 rule: tranclp_induct)
  case (base s2')
  from simulation[OF base.prems(1) base.hyps(1)] show ?case
    by auto
next
  case (step s2' s2'')
  show ?case
    using step.IH[OF \<open>match i1 s1 s2\<close>]
  proof
    assume "\<exists>i2 s1'. step1\<^sup>+\<^sup>+ s1 s1' \<and> match i2 s1' s2'"
    then obtain i2 s1' where "step1\<^sup>+\<^sup>+ s1 s1'" and "match i2 s1' s2'" by auto
    from simulation[OF \<open>match i2 s1' s2'\<close> \<open>step2 s2' s2''\<close>] show ?thesis
    proof
      assume "\<exists>i3 s1''. step1\<^sup>+\<^sup>+ s1' s1'' \<and> match i3 s1'' s2''"
      then obtain i3 s1'' where "step1\<^sup>+\<^sup>+ s1' s1''" and "match i3 s1'' s2''" by auto
      then show ?thesis
        using tranclp_trans[OF \<open>step1\<^sup>+\<^sup>+ s1 s1'\<close>] by auto
    next
      assume "\<exists>i3. match i3 s1' s2'' \<and> i3 \<sqsubset> i2"
      then obtain i3 where "match i3 s1' s2''" and "i3 \<sqsubset> i2" by auto
      then show ?thesis
        using \<open>step1\<^sup>+\<^sup>+ s1 s1'\<close> by auto
    qed
  next
    assume "\<exists>i2. match i2 s1 s2' \<and> (\<sqsubset>)\<^sup>+\<^sup>+ i2 i1"
    then obtain i3 where "match i3 s1 s2'" and "(\<sqsubset>)\<^sup>+\<^sup>+ i3 i1" by auto
    then show ?thesis
      using simulation[OF \<open>match i3 s1 s2'\<close> \<open>step2 s2' s2''\<close>] by auto
  qed
qed

lemma lift_simulation_eval:
  "L2.eval s2 s2' \<Longrightarrow> match i1 s1 s2 \<Longrightarrow> \<exists>i2 s1'. L1.eval s1 s1' \<and> match i2 s1' s2'"
proof(induction s2 arbitrary: i1 s1 rule: converse_rtranclp_induct)
  case (base s2)
  thus ?case by auto
next
  case (step s2 s2'')
  from simulation[OF \<open>match i1 s1 s2\<close> \<open>step2 s2 s2''\<close>] show ?case
  proof
    assume "\<exists>i2 s1'. step1\<^sup>+\<^sup>+ s1 s1' \<and> match i2 s1' s2''"
    thus ?thesis
      by (meson rtranclp_trans step.IH tranclp_into_rtranclp)
  next
    assume "\<exists>i2. match i2 s1 s2'' \<and> i2 \<sqsubset> i1"
    thus ?thesis
      by (auto intro: step.IH)
  qed
qed

lemma backward_simulation_inf:
  assumes
    "match i s1 s2" and
    "inf step2 s2"
  shows "inf step1 s1"
proof -
  from assms have "inf_wf step1 order i s1"
  proof (coinduction arbitrary: i s1 s2)
    case inf_wf
    obtain s2' where "step2 s2 s2'" and "inf step2 s2'"
      using inf_wf(2) by (auto elim: inf.cases)
    from simulation[OF \<open>match i s1 s2\<close> \<open>step2 s2 s2'\<close>] show ?case
      using \<open>inf step2 s2'\<close> by auto
  qed
  thus ?thesis using inf_wf_to_inf
    by (auto intro: inf_wf_to_inf well_founded_axioms)
qed

subsection \<open>Preservation of behaviour\<close>

text \<open>
The main correctness theorem states that, for any two matching programs, any not wrong behaviour of the later is also a behaviour of the former.
In other words, if the compiled program does not crash, then its behaviour, whether it terminates or not, is a also a valid behaviour of the source program.
\<close>

lemma simulation_behaviour :
  "L2.behaves s\<^sub>2 b\<^sub>2 \<Longrightarrow> \<not>is_wrong b\<^sub>2 \<Longrightarrow> match i s\<^sub>1 s\<^sub>2 \<Longrightarrow>
    \<exists>b\<^sub>1 i'. L1.behaves s\<^sub>1 b\<^sub>1 \<and> rel_behaviour (match i') b\<^sub>1 b\<^sub>2"
proof(induction rule: L2.behaves.cases)
  case (state_terminates s2 s2')
  then obtain i' s1' where "L1.eval s\<^sub>1 s1'" and "match i' s1' s2'"
    using lift_simulation_eval by blast
  hence "final1 s1'"
    by (auto intro: state_terminates.hyps match_final)
  hence "L1.behaves s\<^sub>1 (Terminates s1')"
    using L1.final_finished
    by (simp add: L1.state_terminates \<open>L1.eval s\<^sub>1 s1'\<close>)
  moreover have "rel_behaviour (match i') (Terminates s1') b\<^sub>2"
    by (simp add: \<open>match i' s1' s2'\<close> state_terminates.hyps)
  ultimately show ?case by blast
next
  case (state_diverges s2)
  then show ?case
    using backward_simulation_inf L1.state_diverges by fastforce
next
  case (state_goes_wrong s2 s2')
  then show ?case using \<open>\<not>is_wrong b\<^sub>2\<close> by simp
qed

end

subsection \<open>Composition of backward simulations\<close>

definition rel_comp ::
  "('a \<Rightarrow> 'b \<Rightarrow> 'c \<Rightarrow> bool) \<Rightarrow> ('d \<Rightarrow> 'c \<Rightarrow> 'e \<Rightarrow> bool) \<Rightarrow> ('a \<times> 'd) \<Rightarrow> 'b \<Rightarrow> 'e \<Rightarrow> bool" where
  "rel_comp r1 r2 i \<equiv> (r1 (fst i) OO r2 (snd i))"

lemma backward_simulation_composition:
  assumes
    "backward_simulation step1 step2 final1 final2 order1 match1"
    "backward_simulation step2 step3 final2 final3 order2 match2"
  shows
    "backward_simulation step1 step3 final1 final3
      (lex_prodp order1\<^sup>+\<^sup>+ order2) (rel_comp match1 match2)"
proof intro_locales
  show "semantics step1 final1"
    by (auto intro: backward_simulation.axioms assms)
next
  show "semantics step3 final3"
    by (auto intro: backward_simulation.axioms assms)
next
  show "well_founded (lex_prodp order1\<^sup>+\<^sup>+ order2)"
    using assms[THEN backward_simulation.axioms(3)]
    by (simp add: lex_prodp_well_founded well_founded.intro well_founded.wf wfP_trancl)
next
  show "backward_simulation_axioms step1 step3 final1 final3
    (lex_prodp order1\<^sup>+\<^sup>+ order2) (rel_comp match1 match2)"
  proof
    fix i s1 s3
    assume
      match: "rel_comp match1 match2 i s1 s3" and
      final: "final3 s3"
    obtain i1 i2 s2 where "match1 i1 s1 s2" and "match2 i2 s2 s3" and "i = (i1, i2)"
      using match unfolding rel_comp_def by auto
    thus "final1 s1"
      using final assms[THEN backward_simulation.match_final]
      by simp
  next
    fix i s1 s3 s3'
    assume
      match: "rel_comp match1 match2 i s1 s3" and
      step: "step3 s3 s3'"
    obtain i1 i2 s2 where "match1 i1 s1 s2" and "match2 i2 s2 s3" and i_def: "i = (i1, i2)"
      using match unfolding rel_comp_def by auto
    from backward_simulation.simulation[OF assms(2) \<open>match2 i2 s2 s3\<close> step]
    show "(\<exists>i' s1'. step1\<^sup>+\<^sup>+ s1 s1' \<and> rel_comp match1 match2 i' s1' s3') \<or>
       (\<exists>i'. rel_comp match1 match2 i' s1 s3' \<and> lex_prodp order1\<^sup>+\<^sup>+ order2 i' i)"
      (is "(\<exists>i' s1'. ?STEPS i' s1') \<or> ?STALL")
    proof
      assume "\<exists>i2' s2'. step2\<^sup>+\<^sup>+ s2 s2' \<and> match2 i2' s2' s3'"
      then obtain i2' s2' where "step2\<^sup>+\<^sup>+ s2 s2'" and "match2 i2' s2' s3'" by auto
      from backward_simulation.lift_simulation_plus[OF assms(1) \<open>step2\<^sup>+\<^sup>+ s2 s2'\<close> \<open>match1 i1 s1 s2\<close>]
      show ?thesis
      proof
        assume "\<exists>i2 s1'. step1\<^sup>+\<^sup>+ s1 s1' \<and> match1 i2 s1' s2'"
        then obtain i2 s1' where "step1\<^sup>+\<^sup>+ s1 s1'" and "match1 i2 s1' s2'" by auto
        hence "?STEPS (i2, i2') s1'"
          by (auto intro: \<open>match2 i2' s2' s3'\<close> simp: rel_comp_def)
        thus ?thesis by auto
      next
        assume "\<exists>i2. match1 i2 s1 s2' \<and> order1\<^sup>+\<^sup>+ i2 i1"
        then obtain i2'' where "match1 i2'' s1 s2'" and "order1\<^sup>+\<^sup>+ i2'' i1" by auto
        hence ?STALL
          unfolding rel_comp_def i_def lex_prodp_def
          using \<open>match2 i2' s2' s3'\<close> by auto
        thus ?thesis by simp
      qed
    next
      assume "\<exists>i2'. match2 i2' s2 s3' \<and> order2 i2' i2"
      then obtain i2' where "match2 i2' s2 s3'" and "order2 i2' i2" by auto
      hence ?STALL
        unfolding rel_comp_def i_def lex_prodp_def
        using \<open>match1 i1 s1 s2\<close> by auto
      thus ?thesis by simp
    qed
  qed
qed

context
  fixes r :: "'i \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"
begin

fun rel_comp_pow where
  "rel_comp_pow [] x y = False" |
  "rel_comp_pow [i] x y = r i x y" |
  "rel_comp_pow (i # is) x z = (\<exists>y. r i x y \<and> rel_comp_pow is y z)"

end

lemma backward_simulation_pow:
  assumes
    "backward_simulation step step final final order match"
  shows
    "backward_simulation step step final final (lexp order\<^sup>+\<^sup>+) (rel_comp_pow match)"
proof intro_locales
  show "semantics step final"
    by (auto intro: backward_simulation.axioms assms)
next
  show "well_founded (lexp order\<^sup>+\<^sup>+)"
    using backward_simulation.axioms(3)[OF assms] lex_list_well_founded
    using well_founded.intro well_founded.wf wfP_trancl by blast
next
  show "backward_simulation_axioms step step final final (lexp order\<^sup>+\<^sup>+) (rel_comp_pow match)"
  proof unfold_locales
    fix "is" s1 s2
    assume "rel_comp_pow match is s1 s2" and "final s2"
    thus "final s1" thm rel_comp_pow.induct
    proof (induction "is" s1 s2 rule: rel_comp_pow.induct)
      case (1 x y)
      then show ?case by simp
    next
      case (2 i x y)
      then show ?case
        using backward_simulation.match_final[OF assms(1)] by simp
    next
      case (3 i1 i2 "is" x z)
      from "3.prems"[simplified] obtain y where
        match: "match i1 x y" and "rel_comp_pow match (i2 # is) y z"
        by auto
      hence "final y" using "3.IH" "3.prems" by simp
      thus ?case
        using "3.prems" match backward_simulation.match_final[OF assms(1)] by auto
    qed
  next
    fix "is" s1 s3 s3'
    assume "rel_comp_pow match is s1 s3" and "step s3 s3'"
    hence "(\<exists>is' s1'. step\<^sup>+\<^sup>+ s1 s1' \<and> length is' = length is \<and> rel_comp_pow match is' s1' s3') \<or>
      (\<exists>is'. rel_comp_pow match is' s1 s3' \<and> lexp order\<^sup>+\<^sup>+ is' is)"
    proof (induction "is" s1 s3 arbitrary: s3' rule: rel_comp_pow.induct)
      case 1
      then show ?case by simp
    next
      case (2 i s1 s3)
      from backward_simulation.simulation[OF assms(1) "2.prems"[simplified]] show ?case
      proof
        assume "\<exists>i' s1'. step\<^sup>+\<^sup>+ s1 s1' \<and> match i' s1' s3'"
        then obtain i' s1' where "step\<^sup>+\<^sup>+ s1 s1'" and "match i' s1' s3'" by auto
        hence "step\<^sup>+\<^sup>+ s1 s1' \<and> rel_comp_pow match [i'] s1' s3'" by simp
        thus ?thesis
          by (metis length_Cons)
      next
        assume "\<exists>i'. match i' s1 s3' \<and> order i' i"
        then obtain i' where "match i' s1 s3'" and "order i' i" by auto
        hence "rel_comp_pow match [i'] s1 s3' \<and> lexp order\<^sup>+\<^sup>+ [i'] [i]"
          by (simp add: lexp_head tranclp.r_into_trancl)
        thus ?thesis by blast
      qed
    next
      case (3 i1 i2 "is" s1 s3)
      from "3.prems"[simplified] obtain s2 where
        "match i1 s1 s2" and 0: "rel_comp_pow match (i2 # is) s2 s3"
        by auto
      from "3.IH"[OF 0 "3.prems"(2)] show ?case
      proof
        assume "\<exists>is' s2'. step\<^sup>+\<^sup>+ s2 s2' \<and> length is' = length (i2 # is) \<and>
          rel_comp_pow match is' s2' s3'"
        then obtain i2' is' s2' where
          "step\<^sup>+\<^sup>+ s2 s2'" and "length is' = length is" and "rel_comp_pow match (i2' # is') s2' s3'"
          by (metis Suc_length_conv)
        from backward_simulation.lift_simulation_plus[OF assms(1) \<open>step\<^sup>+\<^sup>+ s2 s2'\<close> \<open>match i1 s1 s2\<close>]
        show ?thesis
        proof
          assume "\<exists>i2 s1'. step\<^sup>+\<^sup>+ s1 s1' \<and> match i2 s1' s2'"
          thus ?thesis
            using \<open>rel_comp_pow match (i2' # is') s2' s3'\<close>
            by (metis \<open>length is' = length is\<close> length_Cons rel_comp_pow.simps(3))
        next
          assume "\<exists>i2. match i2 s1 s2' \<and> order\<^sup>+\<^sup>+ i2 i1"
          then obtain i1' where "match i1' s1 s2'" and "order\<^sup>+\<^sup>+ i1' i1" by auto
          hence "rel_comp_pow match (i1' # i2' # is') s1 s3'"
            using \<open>rel_comp_pow match (i2' # is') s2' s3'\<close> by auto
          moreover have "lexp order\<^sup>+\<^sup>+ (i1' # i2' # is') (i1 # i2 # is)"
            using \<open>order\<^sup>+\<^sup>+ i1' i1\<close> \<open>length is' = length is\<close>
            by (auto intro: lexp_head)
          ultimately show ?thesis by fast
        qed
      next
        assume "\<exists>i'. rel_comp_pow match i' s2 s3' \<and> lexp order\<^sup>+\<^sup>+ i' (i2 # is)"
        then obtain i2' is' where
          "rel_comp_pow match (i2' # is') s2 s3'" and "lexp order\<^sup>+\<^sup>+ (i2' # is') (i2 # is)"
          by (metis lexp.simps)
        thus ?thesis
          by (metis \<open>match i1 s1 s2\<close> lexp.simps(1) rel_comp_pow.simps(3))
      qed
    qed
    thus "(\<exists>is' s1'. step\<^sup>+\<^sup>+ s1 s1' \<and> rel_comp_pow match is' s1' s3') \<or>
      (\<exists>is'. rel_comp_pow match is' s1 s3' \<and> lexp order\<^sup>+\<^sup>+ is' is)"
      by auto
  qed
qed

definition lockstep_backward_simulation where
  "lockstep_backward_simulation step1 step2 match \<equiv>
    \<forall>s1 s2 s2'. match s1 s2 \<longrightarrow> step2 s2 s2' \<longrightarrow> (\<exists>s1'. step1 s1 s1' \<and> match s1' s2')"

definition plus_backward_simulation where
  "plus_backward_simulation step1 step2 match \<equiv>
    \<forall>s1 s2 s2'. match s1 s2 \<longrightarrow> step2 s2 s2' \<longrightarrow> (\<exists>s1'. step1\<^sup>+\<^sup>+ s1 s1' \<and> match s1' s2')"

lemma
  assumes "lockstep_backward_simulation step1 step2 match"
  shows "plus_backward_simulation step1 step2 match"
unfolding plus_backward_simulation_def
proof safe
  fix s1 s2 s2'
  assume "match s1 s2" and "step2 s2 s2'"
  then obtain s1' where "step1 s1 s1'" and "match s1' s2'"
    using assms(1) unfolding lockstep_backward_simulation_def by blast
  then show "\<exists>s1'. step1\<^sup>+\<^sup>+ s1 s1' \<and> match s1' s2'"
    by auto
qed

lemma lockstep_to_plus_backward_simulation:
  fixes
    match :: "'state1 \<Rightarrow> 'state2 \<Rightarrow> bool" and
    step1 :: "'state1 \<Rightarrow> 'state1 \<Rightarrow> bool" and
    step2 :: "'state2 \<Rightarrow> 'state2 \<Rightarrow> bool"
  assumes
    lockstep_simulation: "\<And>s1 s2 s2'. match s1 s2 \<Longrightarrow> step2 s2 s2' \<Longrightarrow> (\<exists>s1'. step1 s1 s1' \<and> match s1' s2')" and
    match: "match s1 s2" and
    step: "step2 s2 s2'"
  shows "\<exists>s1'. step1\<^sup>+\<^sup>+ s1 s1' \<and> match s1' s2'"
proof -
  obtain s1' where "step1 s1 s1'" and "match s1' s2'"
    using lockstep_simulation[OF match step] by auto
  thus ?thesis by auto
qed

lemma lockstep_to_option_backward_simulation:
  fixes
    match :: "'state1 \<Rightarrow> 'state2 \<Rightarrow> bool" and
    step1 :: "'state1 \<Rightarrow> 'state1 \<Rightarrow> bool" and
    step2 :: "'state2 \<Rightarrow> 'state2 \<Rightarrow> bool" and
    measure :: "'state2 \<Rightarrow> nat"
  assumes
    lockstep_simulation: "\<And>s1 s2 s2'. match s1 s2 \<Longrightarrow> step2 s2 s2' \<Longrightarrow> (\<exists>s1'. step1 s1 s1' \<and> match s1' s2')" and
    match: "match s1 s2" and
    step: "step2 s2 s2'"
  shows "(\<exists>s1'. step1 s1 s1' \<and> match s1' s2') \<or> match s1 s2' \<and> measure s2' < measure s2"
  using lockstep_simulation[OF match step] ..

lemma plus_to_star_backward_simulation:
  fixes
    match :: "'state1 \<Rightarrow> 'state2 \<Rightarrow> bool" and
    step1 :: "'state1 \<Rightarrow> 'state1 \<Rightarrow> bool" and
    step2 :: "'state2 \<Rightarrow> 'state2 \<Rightarrow> bool" and
    measure :: "'state2 \<Rightarrow> nat"
  assumes
    star_simulation: "\<And>s1 s2 s2'. match s1 s2 \<Longrightarrow> step2 s2 s2' \<Longrightarrow> (\<exists>s1'. step1\<^sup>+\<^sup>+ s1 s1' \<and> match s1' s2')" and
    match: "match s1 s2" and
    step: "step2 s2 s2'"
  shows "(\<exists>s1'. step1\<^sup>+\<^sup>+ s1 s1' \<and> match s1' s2') \<or> match s1 s2' \<and> measure s2' < measure s2"
  using star_simulation[OF match step] ..

lemma lockstep_to_plus_forward_simulation:
  fixes
    match :: "'state1 \<Rightarrow> 'state2 \<Rightarrow> bool" and
    step1 :: "'state1 \<Rightarrow> 'state1 \<Rightarrow> bool" and
    step2 :: "'state2 \<Rightarrow> 'state2 \<Rightarrow> bool"
  assumes
    lockstep_simulation: "\<And>s1 s2 s2'. match s1 s2 \<Longrightarrow> step1 s1 s1' \<Longrightarrow> (\<exists>s2'. step2 s2 s2' \<and> match s1' s2')" and
    match: "match s1 s2" and
    step: "step1 s1 s1'"
  shows "\<exists>s2'. step2\<^sup>+\<^sup>+ s2 s2' \<and> match s1' s2'"
proof -
  obtain s2' where "step2 s2 s2'" and "match s1' s2'"
    using lockstep_simulation[OF match step] by auto
  thus ?thesis by auto
qed

end


theory Quantale
  imports Abstract_Quantales "$AFP/Kleene_Algebra/Kleene_Algebra"
begin

no_notation
  times (infixl "*" 70) and
  plus (infixl "+" 65)

notation
  sup (infixl "+" 65) and
  inf (infixl "\<sqinter>" 70) and
  Sup ("\<Squnion>_" [900] 900) and
  Inf ("\<Sqinter>_" [900] 900) and
  top ("\<top>") and
  bot ("\<bottom>") and
  times (infixl "\<cdot>" 70) and
  one_class.one ("1")

sublocale complete_lattice \<subseteq> Sup!: abs_complete_lattice Sup
  where [simp]: "abs_complete_lattice.join Sup = op +"
    and [simp]: "abs_complete_lattice.less_eq Sup = op \<le>"
    and [simp]: "abs_complete_lattice.less Sup = op <"
    and [simp]: "abs_complete_lattice.Meet Sup = Inf"
    and [simp]: "abs_complete_lattice.meet Sup = op \<sqinter>"
    and [simp]: "abs_complete_lattice.top Sup = \<top>"
    and [simp]: "abs_complete_lattice.bot Sup = \<bottom>"
proof -
  show "abs_complete_lattice Sup"
    apply unfold_locales
    apply (metis Sup_atLeastAtMost atLeastAtMost_singleton order_refl)
    apply (auto simp: Sup_le_iff intro!: Sup_eqI Sup_least)
    apply (metis (no_types) Sup_upper UnionI)
    by (metis Sup_least le_iff_sup sup.orderE)
  then interpret cl: abs_complete_lattice Sup .
  show "cl.join = op +"
    by (default, default) (simp add: cl.join_def)
  show [simp]: "cl.less_eq = op \<le>"
    apply (default, default)
    by (auto simp add: cl.less_eq_def cl.join_def le_iff_sup)
  show "cl.less = op <"
    apply (default, default)
    by (auto simp add: less_le_not_le cl.less_def)
  show [simp]: "cl.Meet = Inf"
    by default (auto simp add: cl.Meet_def Inf_Sup)
  show "cl.meet = op \<sqinter>"
    by (default, default) (simp add: cl.meet_def)
  show "cl.top = \<top>"
    by (simp add: cl.top_def)
  show "cl.bot = \<bottom>"
    by (simp add: cl.bot_def)
qed

class near_quantale = complete_lattice + semigroup_mult +
  assumes qSup_distr: "\<Squnion> Y \<cdot> x = \<Squnion> ((\<lambda>y. y \<cdot> x) ` Y)"
begin

lemma qSup_distr': "\<Squnion>{x. P(x)} \<cdot> y = \<Squnion>{x \<cdot> y |x. P(x)}"
  using qSup_distr[of "{x. P(x)}"]
  by (metis image_Collect)

end

class near_quantale_unital = near_quantale + monoid_mult

class pre_quantale = near_quantale +
  assumes qSup_subdistl: "\<Squnion> ((\<lambda>y. x \<cdot> y) ` Y) \<le> x \<cdot> \<Squnion> Y"

class quantale = pre_quantale +
  assumes qSup_supdistl: "x \<cdot> \<Squnion> Y \<le> \<Squnion> ((\<lambda>y. x \<cdot> y) ` Y)"

class quantale_unital = quantale + monoid_mult

(* Instantiation of quantales *)

sublocale near_quantale \<subseteq> Sup!: abs_near_quantale Sup "op \<cdot>"
  where "abs_complete_lattice.join Sup = op +"
    and "abs_complete_lattice.less_eq Sup = op \<le>"
    and "abs_complete_lattice.less Sup = op <"
    and "abs_complete_lattice.Meet Sup = Inf"
    and "abs_complete_lattice.meet Sup = op \<sqinter>"
    and "abs_complete_lattice.top Sup = \<top>"
    and "abs_complete_lattice.bot Sup = \<bottom>"
  by (unfold_locales, auto) (metis qSup_distr Sup_image_eq)

sublocale near_quantale_unital \<subseteq> Sup!: abs_near_quantale_unital Sup "op \<cdot>" one
  where "abs_complete_lattice.join Sup = op +"
    and "abs_complete_lattice.less_eq Sup = op \<le>"
    and "abs_complete_lattice.less Sup = op <"
    and "abs_complete_lattice.Meet Sup = Inf"
    and "abs_complete_lattice.meet Sup = op \<sqinter>"
    and "abs_complete_lattice.top Sup = \<top>"
    and "abs_complete_lattice.bot Sup = \<bottom>"
  by unfold_locales auto

sublocale pre_quantale \<subseteq> Sup!: abs_pre_quantale Sup "op \<cdot>"
  where "abs_complete_lattice.join Sup = op +"
    and "abs_complete_lattice.less_eq Sup = op \<le>"
    and "abs_complete_lattice.less Sup = op <"
    and "abs_complete_lattice.Meet Sup = Inf"
    and "abs_complete_lattice.meet Sup = op \<sqinter>"
    and "abs_complete_lattice.top Sup = \<top>"
    and "abs_complete_lattice.bot Sup = \<bottom>"
  apply unfold_locales
  apply (auto intro: Sup_eqI Sup_least)
  by (metis Sup.Sup_image_eq local.Sup.less_eq_def local.qSup_subdistl)

sublocale quantale \<subseteq> Sup!: abs_quantale Sup "op \<cdot>"
  where "abs_complete_lattice.join Sup = op +"
    and "abs_complete_lattice.less_eq Sup = op \<le>"
    and "abs_complete_lattice.less Sup = op <"
    and "abs_complete_lattice.Meet Sup = Inf"
    and "abs_complete_lattice.meet Sup = op \<sqinter>"
    and "abs_complete_lattice.top Sup = \<top>"
    and "abs_complete_lattice.bot Sup = \<bottom>"
  apply unfold_locales
  apply (auto intro: Sup_eqI Sup_least)
  by (metis qSup_supdistl le_iff_sup sup_commute Sup.Sup_image_eq)

sublocale quantale_unital \<subseteq> Sup!: abs_quantale_unital Sup "op \<cdot>" one
  where "abs_complete_lattice.join Sup = op +"
    and "abs_complete_lattice.less_eq Sup = op \<le>"
    and "abs_complete_lattice.less Sup = op <"
    and "abs_complete_lattice.Meet Sup = Inf"
    and "abs_complete_lattice.meet Sup = op \<sqinter>"
    and "abs_complete_lattice.top Sup = \<top>"
    and "abs_complete_lattice.bot Sup = \<bottom>"
  by unfold_locales auto

context near_quantale begin

lemma qSUP_distr: "(SUP y:Y. f y) \<cdot> x = (SUP y: Y. f y \<cdot> x)"
  by (unfold SUP_def qSup_distr image_image) simp

end

context quantale begin

lemma qSUP_distl: "x \<cdot> (SUP y:Y. f y) = (SUP y: Y. x \<cdot> f y)"
  by (unfold SUP_def Sup.Join_distl image_image) simp

lemma qSUP_distl': "y \<cdot> \<Squnion>{x. P(x)} = \<Squnion>{y \<cdot> x | x. P(x)}"
  using qSUP_distl[of _ "{x. P(x)}"]
  by (simp add: image_Collect local.Sup.Join_distl)

lemma qSUP_distl2': "x \<cdot> \<Squnion>{y \<cdot> z | y z. P y z} = \<Squnion>{x \<cdot> (y \<cdot> z) | y z. P y z}"
  using qSUP_distl[of _ "{y \<cdot> z | y z. P y z}"]
  apply (simp add: image_Collect local.Sup.Join_distl)
  by (metis (full_types))

lemma qSUP_merge_ineq: "\<Squnion> {f x \<cdot> g y | x y. P x \<and> Q y} \<le> \<Squnion> {\<Squnion> {f x \<cdot> g y | x. P x} | y. Q y}"
proof (rule Sup_least, auto)
  fix xa y assume "P xa" "Q y"
  hence "\<exists>u. (\<exists>x. f xa \<cdot> g y = f x \<cdot> g u \<and> P x) \<and> Q u" by blast
  hence "\<exists>u. Q u \<and> f xa \<cdot> g y \<in> {f x \<cdot> g u |x. P x}" by blast
  hence "\<exists>B. (\<exists>y. \<Squnion>B = \<Squnion>{f x \<cdot> g y |x. P x} \<and> Q y) \<and> f xa \<cdot> g y \<in> B" by blast
  hence "\<exists>B. \<Squnion>B \<le> \<Squnion>{\<Squnion>{f x \<cdot> g y |x. P x} |y. Q y} \<and> f xa \<cdot> g y \<in> B"
    using Sup.Join_Collect_upper by (metis (lifting, mono_tags))
  thus "f xa \<cdot> g y \<le> \<Squnion>{\<Squnion>{f x \<cdot> g y |x. P x} |y. Q y}"
    using Sup_le_iff by blast
qed

lemma qSUP_merge: "\<Squnion> {\<Squnion> {f x \<cdot> g y | x. P x} | y. Q y} = \<Squnion> {f x \<cdot> g y | x y. P x \<and> Q y}"
  apply (rule antisym, rule Sup_least, safe)
  by (rule Sup_mono, auto simp add: qSUP_merge_ineq)

lemma Sup_sum_le1: "\<Squnion> {f a b + g a b | a b. P a b} \<le> \<Squnion>{f a b | a b. P a b} + \<Squnion>{g a b | a b. P a b}"
proof (rule Sup_least, safe)
  fix a b assume assm: "P a b"
  have "f a b \<le> \<Squnion>{f a b | a b. P a b}" and "g a b \<le> \<Squnion>{g a b | a b. P a b}"
    apply (rule Sup_upper) using assm apply blast
    apply (rule Sup_upper) using assm by blast
  thus "f a b + g a b \<le> \<Squnion>{f a b |a b. P a b} + \<Squnion>{g a b |a b. P a b}"
    by (metis (lifting, no_types) sup_mono)
qed

lemma Sup_sum_le2: "\<Squnion>{f a b | a b. P a b} + \<Squnion>{g a b | a b. P a b} \<le> \<Squnion> {f a b + g a b | a b. P a b}"
proof (subst Sup_union_distrib[symmetric], rule Sup_least, auto)
  fix a b assume assm: "P a b"
  have "f a b + g a b \<le> \<Squnion> {f a b + g a b | a b. P a b}"
    apply (rule Sup_upper) using assm by blast
  thus "f a b \<le> \<Squnion> {f a b + g a b | a b. P a b}" and "g a b \<le> \<Squnion> {f a b + g a b | a b. P a b}"
    by auto
qed

lemma Sup_sum [iff]: "\<Squnion> {f a b + g a b | a b. P a b} = \<Squnion>{f a b | a b. P a b} + \<Squnion>{g a b | a b. P a b}"
  by (rule antisym) (metis Sup_sum_le1, metis Sup_sum_le2)

lemma Sup_sum_same_set[iff]:" \<Squnion> {a + b | a b. a \<in> A \<and> b \<in> A} = \<Squnion>A + \<Squnion>A"
proof -
  have "\<Squnion> {a + b | a b. a \<in> A \<and> b \<in> A} = \<Squnion>{a | a b. a \<in> A \<and> b \<in> A} + \<Squnion>{b | a b. a \<in> A \<and> b \<in> A}"
    by simp
  also have "... = \<Squnion>A + \<Squnion>A"
    by (rule antisym) (rule sup.mono, (rule Sup_subset_mono, force)+)+
  finally show ?thesis .
qed

end

class comm_quantale = quantale + ab_semigroup_mult
class comm_quantale_unital = comm_quantale + comm_monoid_mult
begin
subclass quantale_unital ..
end
class distrib_quantale = quantale + complete_distrib_lattice
class distrib_quantale_unital = distrib_quantale + quantale_unital
class distrib_comm_quantale = comm_quantale + distrib_quantale
class distrib_comm_quantale_unital = comm_quantale_unital + distrib_quantale

end


(* The state equivalence used for the unwinding proofs for the friendship confidentiality
   properties *)
theory Friend_State_Indistinguishability
  imports "Friend_Observation_Setup"
begin

subsection \<open>Unwinding helper definitions and lemmas\<close>

(* The secret: One will be interested in the friendship information of two arbitary,
   but fixed users UID1 and UID2 *)
locale Friend = FriendObservationSetup +
fixes
  UID1 :: userID
and
  UID2 :: userID
assumes
  UID1_UID2_UIDs: "{UID1,UID2} \<inter> UIDs = {}"
and
  UID1_UID2: "UID1 \<noteq> UID2"
begin

(* The notion of two userID lists being equal save for at most one occurrence of uid: *)
fun eqButUIDl :: "userID \<Rightarrow> userID list \<Rightarrow> userID list \<Rightarrow> bool" where
"eqButUIDl uid uidl uidl1 = (remove1 uid uidl = remove1 uid uidl1)"

lemma eqButUIDl_eq[simp,intro!]: "eqButUIDl uid uidl uidl"
by auto

lemma eqButUIDl_sym:
assumes "eqButUIDl uid uidl uidl1"
shows "eqButUIDl uid uidl1 uidl"
using assms by auto

lemma eqButUIDl_trans:
assumes "eqButUIDl uid uidl uidl1" and "eqButUIDl uid uidl1 uidl2"
shows "eqButUIDl uid uidl uidl2"
using assms by auto

lemma eqButUIDl_remove1_cong:
assumes "eqButUIDl uid uidl uidl1"
shows "eqButUIDl uid (remove1 uid' uidl) (remove1 uid' uidl1)"
proof -
  have "remove1 uid (remove1 uid' uidl) = remove1 uid' (remove1 uid uidl)" by (simp add: remove1_commute)
  also have "\<dots> = remove1 uid' (remove1 uid uidl1)" using assms by simp
  also have "\<dots> = remove1 uid (remove1 uid' uidl1)" by (simp add: remove1_commute)
  finally show ?thesis by simp
qed

lemma eqButUIDl_snoc_cong:
assumes "eqButUIDl uid uidl uidl1"
and "uid' \<in>\<in> uidl \<longleftrightarrow> uid' \<in>\<in> uidl1"
shows "eqButUIDl uid (uidl ## uid') (uidl1 ## uid')"
using assms by (auto simp add: remove1_append remove1_idem)

(* The notion of two functions each taking a userID and returning a list of user IDs
  being equal everywhere but on UID1 and UID2, where their return results are allowed
  to be eqButUIDl : *)
definition eqButUIDf where
"eqButUIDf frds frds1 \<equiv>
  eqButUIDl UID2 (frds UID1) (frds1 UID1)
\<and> eqButUIDl UID1 (frds UID2) (frds1 UID2)
\<and> (\<forall>uid. uid \<noteq> UID1 \<and> uid \<noteq> UID2 \<longrightarrow> frds uid = frds1 uid)"

lemmas eqButUIDf_intro = eqButUIDf_def[THEN meta_eq_to_obj_eq, THEN iffD2]

lemma eqButUIDf_eeq[simp,intro!]: "eqButUIDf frds frds"
unfolding eqButUIDf_def by auto

lemma eqButUIDf_sym:
assumes "eqButUIDf frds frds1" shows "eqButUIDf frds1 frds"
using assms eqButUIDl_sym unfolding eqButUIDf_def
by presburger

lemma eqButUIDf_trans:
assumes "eqButUIDf frds frds1" and "eqButUIDf frds1 frds2"
shows "eqButUIDf frds frds2"
using assms eqButUIDl_trans unfolding eqButUIDf_def by (auto split: if_splits)

lemma eqButUIDf_cong:
assumes "eqButUIDf frds frds1"
and "uid = UID1 \<Longrightarrow> eqButUIDl UID2 uu uu1"
and "uid = UID2 \<Longrightarrow> eqButUIDl UID1 uu uu1"
and "uid \<noteq> UID1 \<Longrightarrow> uid \<noteq> UID2 \<Longrightarrow> uu = uu1"
shows "eqButUIDf (frds (uid := uu)) (frds1(uid := uu1))"
using assms unfolding eqButUIDf_def by (auto split: if_splits)

lemma eqButUIDf_eqButUIDl:
assumes "eqButUIDf frds frds1"
shows "eqButUIDl UID2 (frds UID1) (frds1 UID1)"
  and "eqButUIDl UID1 (frds UID2) (frds1 UID2)"
using assms unfolding eqButUIDf_def by (auto split: if_splits)

lemma eqButUIDf_not_UID:
"\<lbrakk>eqButUIDf frds frds1; uid \<noteq> UID1; uid \<noteq> UID2\<rbrakk> \<Longrightarrow> frds uid = frds1 uid"
unfolding eqButUIDf_def by (auto split: if_splits)

lemma eqButUIDf_not_UID':
assumes eq1: "eqButUIDf frds frds1"
and uid: "(uid,uid') \<notin> {(UID1,UID2), (UID2,UID1)}"
shows "uid \<in>\<in> frds uid' \<longleftrightarrow> uid \<in>\<in> frds1 uid'"
proof -
  from uid have "(uid' = UID1 \<and> uid \<noteq> UID2)
               \<or> (uid' = UID2 \<and> uid \<noteq> UID1)
               \<or> (uid' \<notin> {UID1,UID2})" (is "?u1 \<or> ?u2 \<or> ?n12")
    by auto
  then show ?thesis proof (elim disjE)
    assume "?u1"
    moreover then have "uid \<in>\<in> remove1 UID2 (frds uid') \<longleftrightarrow> uid \<in>\<in> remove1 UID2 (frds1 uid')"
      using eq1 unfolding eqButUIDf_def by auto
    ultimately show ?thesis by auto
  next
    assume "?u2"
    moreover then have "uid \<in>\<in> remove1 UID1 (frds uid') \<longleftrightarrow> uid \<in>\<in> remove1 UID1 (frds1 uid')"
      using eq1 unfolding eqButUIDf_def by auto
    ultimately show ?thesis by auto
  next
    assume "?n12"
    then show ?thesis using eq1 unfolding eqButUIDf_def by auto
  qed
qed

(* The notion of two functions each taking two userID arguments being
  equal everywhere but on the values (UID1,UID2) and (UID2,UID1): *)
definition eqButUID12 where
"eqButUID12 freq freq1 \<equiv>
 \<forall> uid uid'. if (uid,uid') \<in> {(UID1,UID2), (UID2,UID1)} then True else freq uid uid' = freq1 uid uid'"

lemmas eqButUID12_intro = eqButUID12_def[THEN meta_eq_to_obj_eq, THEN iffD2]

lemma eqButUID12_eeq[simp,intro!]: "eqButUID12 freq freq"
unfolding eqButUID12_def by auto

lemma eqButUID12_sym:
assumes "eqButUID12 freq freq1" shows "eqButUID12 freq1 freq"
using assms unfolding eqButUID12_def
by presburger

lemma eqButUID12_trans:
assumes "eqButUID12 freq freq1" and "eqButUID12 freq1 freq2"
shows "eqButUID12 freq freq2"
using assms unfolding eqButUID12_def by (auto split: if_splits)

lemma eqButUID12_cong:
assumes "eqButUID12 freq freq1"
(*and "uid = UID1 \<Longrightarrow> eqButUID2 uu uu1"*)
and "\<not> (uid,uid') \<in> {(UID1,UID2), (UID2,UID1)} \<Longrightarrow> uu = uu1"
shows "eqButUID12 (fun_upd2 freq uid uid' uu) (fun_upd2 freq1 uid uid' uu1)"
using assms unfolding eqButUID12_def fun_upd2_def by (auto split: if_splits)

lemma eqButUID12_not_UID:
"\<lbrakk>eqButUID12 freq freq1; \<not> (uid,uid') \<in> {(UID1,UID2), (UID2,UID1)}\<rbrakk> \<Longrightarrow> freq uid uid' = freq1 uid uid'"
unfolding eqButUID12_def by (auto split: if_splits)

(* The notion of two states being equal everywhere but on the friendship requests or status of users UID1 and UID2: *)
definition eqButUID :: "state \<Rightarrow> state \<Rightarrow> bool" where
"eqButUID s s1 \<equiv>
 admin s = admin s1 \<and>

 pendingUReqs s = pendingUReqs s1 \<and> userReq s = userReq s1 \<and>
 userIDs s = userIDs s1 \<and> user s = user s1 \<and> pass s = pass s1 \<and>

 eqButUIDf (pendingFReqs s) (pendingFReqs s1) \<and>
 eqButUID12 (friendReq s) (friendReq s1) \<and>
 eqButUIDf (friendIDs s) (friendIDs s1) \<and>

 postIDs s = postIDs s1 \<and> admin s = admin s1 \<and>
 post s = post s1 \<and> vis s = vis s1 \<and>
 owner s = owner s1 \<and>

 pendingSApiReqs s = pendingSApiReqs s1 \<and> sApiReq s = sApiReq s1 \<and>
 serverApiIDs s = serverApiIDs s1 \<and> serverPass s = serverPass s1 \<and>
 outerPostIDs s = outerPostIDs s1 \<and> outerPost s = outerPost s1 \<and> outerVis s = outerVis s1 \<and>
 outerOwner s = outerOwner s1 \<and>
 sentOuterFriendIDs s = sentOuterFriendIDs s1 \<and>
 recvOuterFriendIDs s = recvOuterFriendIDs s1 \<and>

 pendingCApiReqs s = pendingCApiReqs s1 \<and> cApiReq s = cApiReq s1 \<and>
 clientApiIDs s = clientApiIDs s1 \<and> clientPass s = clientPass s1 \<and>
 sharedWith s = sharedWith s1"

lemmas eqButUID_intro = eqButUID_def[THEN meta_eq_to_obj_eq, THEN iffD2]

lemma eqButUID_refl[simp,intro!]: "eqButUID s s"
unfolding eqButUID_def by auto

lemma eqButUID_sym[sym]:
assumes "eqButUID s s1" shows "eqButUID s1 s"
using assms eqButUIDf_sym eqButUID12_sym unfolding eqButUID_def by auto

lemma eqButUID_trans[trans]:
assumes "eqButUID s s1" and "eqButUID s1 s2" shows "eqButUID s s2"
using assms eqButUIDf_trans eqButUID12_trans unfolding eqButUID_def by metis

(* Implications from eqButUID, including w.r.t. auxiliary operations: *)
lemma eqButUID_stateSelectors:
assumes "eqButUID s s1"
shows "admin s = admin s1"
"pendingUReqs s = pendingUReqs s1" "userReq s = userReq s1"
"userIDs s = userIDs s1" "user s = user s1" "pass s = pass s1"
"eqButUIDf (pendingFReqs s) (pendingFReqs s1)"
"eqButUID12 (friendReq s) (friendReq s1)"
"eqButUIDf (friendIDs s) (friendIDs s1)"

"postIDs s = postIDs s1"
"post s = post s1" "vis s = vis s1"
"owner s = owner s1"

"pendingSApiReqs s = pendingSApiReqs s1" "sApiReq s = sApiReq s1"
"serverApiIDs s = serverApiIDs s1" "serverPass s = serverPass s1"
"outerPostIDs s = outerPostIDs s1" "outerPost s = outerPost s1" "outerVis s = outerVis s1"
"outerOwner s = outerOwner s1"
"sentOuterFriendIDs s = sentOuterFriendIDs s1"
"recvOuterFriendIDs s = recvOuterFriendIDs s1"

"pendingCApiReqs s = pendingCApiReqs s1" "cApiReq s = cApiReq s1"
"clientApiIDs s = clientApiIDs s1" "clientPass s = clientPass s1"
"sharedWith s = sharedWith s1"

"IDsOK s = IDsOK s1"
using assms unfolding eqButUID_def IDsOK_def[abs_def] by auto

lemma eqButUID_eqButUID2:
"eqButUID s s1 \<Longrightarrow> eqButUIDl UID2 (friendIDs s UID1) (friendIDs s1 UID1)"
unfolding eqButUID_def using eqButUIDf_eqButUIDl
by (smt eqButUIDf_eqButUIDl eqButUIDl.simps)

lemma eqButUID_not_UID:
"eqButUID s s1 \<Longrightarrow> uid \<noteq> UID \<Longrightarrow> post s uid = post s1 uid"
unfolding eqButUID_def by auto

lemma eqButUID_cong[simp, intro]:
"\<And> uu1 uu2. eqButUID s s1 \<Longrightarrow> uu1 = uu2 \<Longrightarrow> eqButUID (s \<lparr>admin := uu1\<rparr>) (s1 \<lparr>admin := uu2\<rparr>)"

"\<And> uu1 uu2. eqButUID s s1 \<Longrightarrow> uu1 = uu2 \<Longrightarrow> eqButUID (s \<lparr>pendingUReqs := uu1\<rparr>) (s1 \<lparr>pendingUReqs := uu2\<rparr>)"
"\<And> uu1 uu2. eqButUID s s1 \<Longrightarrow> uu1 = uu2 \<Longrightarrow> eqButUID (s \<lparr>userReq := uu1\<rparr>) (s1 \<lparr>userReq := uu2\<rparr>)"
"\<And> uu1 uu2. eqButUID s s1 \<Longrightarrow> uu1 = uu2 \<Longrightarrow> eqButUID (s \<lparr>userIDs := uu1\<rparr>) (s1 \<lparr>userIDs := uu2\<rparr>)"
"\<And> uu1 uu2. eqButUID s s1 \<Longrightarrow> uu1 = uu2 \<Longrightarrow> eqButUID (s \<lparr>user := uu1\<rparr>) (s1 \<lparr>user := uu2\<rparr>)"
"\<And> uu1 uu2. eqButUID s s1 \<Longrightarrow> uu1 = uu2 \<Longrightarrow> eqButUID (s \<lparr>pass := uu1\<rparr>) (s1 \<lparr>pass := uu2\<rparr>)"

"\<And> uu1 uu2. eqButUID s s1 \<Longrightarrow> uu1 = uu2 \<Longrightarrow> eqButUID (s \<lparr>postIDs := uu1\<rparr>) (s1 \<lparr>postIDs := uu2\<rparr>)"
"\<And> uu1 uu2. eqButUID s s1 \<Longrightarrow> uu1 = uu2 \<Longrightarrow> eqButUID (s \<lparr>owner := uu1\<rparr>) (s1 \<lparr>owner := uu2\<rparr>)"
"\<And> uu1 uu2. eqButUID s s1 \<Longrightarrow> uu1 = uu2 \<Longrightarrow> eqButUID (s \<lparr>post := uu1\<rparr>) (s1 \<lparr>post := uu2\<rparr>)"
"\<And> uu1 uu2. eqButUID s s1 \<Longrightarrow> uu1 = uu2 \<Longrightarrow> eqButUID (s \<lparr>vis := uu1\<rparr>) (s1 \<lparr>vis := uu2\<rparr>)"

"\<And> uu1 uu2. eqButUID s s1 \<Longrightarrow> eqButUIDf uu1 uu2 \<Longrightarrow> eqButUID (s \<lparr>pendingFReqs := uu1\<rparr>) (s1 \<lparr>pendingFReqs := uu2\<rparr>)"
"\<And> uu1 uu2. eqButUID s s1 \<Longrightarrow> eqButUID12 uu1 uu2 \<Longrightarrow> eqButUID (s \<lparr>friendReq := uu1\<rparr>) (s1 \<lparr>friendReq := uu2\<rparr>)"
"\<And> uu1 uu2. eqButUID s s1 \<Longrightarrow> eqButUIDf uu1 uu2 \<Longrightarrow> eqButUID (s \<lparr>friendIDs := uu1\<rparr>) (s1 \<lparr>friendIDs := uu2\<rparr>)"

"\<And> uu1 uu2. eqButUID s s1 \<Longrightarrow> uu1 = uu2 \<Longrightarrow> eqButUID (s \<lparr>pendingSApiReqs := uu1\<rparr>) (s1 \<lparr>pendingSApiReqs := uu2\<rparr>)"
"\<And> uu1 uu2. eqButUID s s1 \<Longrightarrow> uu1 = uu2 \<Longrightarrow> eqButUID (s \<lparr>sApiReq := uu1\<rparr>) (s1 \<lparr>sApiReq := uu2\<rparr>)"
"\<And> uu1 uu2. eqButUID s s1 \<Longrightarrow> uu1 = uu2 \<Longrightarrow> eqButUID (s \<lparr>serverApiIDs := uu1\<rparr>) (s1 \<lparr>serverApiIDs := uu2\<rparr>)"
"\<And> uu1 uu2. eqButUID s s1 \<Longrightarrow> uu1 = uu2 \<Longrightarrow> eqButUID (s \<lparr>serverPass := uu1\<rparr>) (s1 \<lparr>serverPass := uu2\<rparr>)"
"\<And> uu1 uu2. eqButUID s s1 \<Longrightarrow> uu1 = uu2 \<Longrightarrow> eqButUID (s \<lparr>outerPostIDs := uu1\<rparr>) (s1 \<lparr>outerPostIDs := uu2\<rparr>)"
"\<And> uu1 uu2. eqButUID s s1 \<Longrightarrow> uu1 = uu2 \<Longrightarrow> eqButUID (s \<lparr>outerPost := uu1\<rparr>) (s1 \<lparr>outerPost := uu2\<rparr>)"
"\<And> uu1 uu2. eqButUID s s1 \<Longrightarrow> uu1 = uu2 \<Longrightarrow> eqButUID (s \<lparr>outerVis := uu1\<rparr>) (s1 \<lparr>outerVis := uu2\<rparr>)"
"\<And> uu1 uu2. eqButUID s s1 \<Longrightarrow> uu1 = uu2 \<Longrightarrow> eqButUID (s \<lparr>outerOwner := uu1\<rparr>) (s1 \<lparr>outerOwner := uu2\<rparr>)"
"\<And> uu1 uu2. eqButUID s s1 \<Longrightarrow> uu1 = uu2 \<Longrightarrow> eqButUID (s \<lparr>sentOuterFriendIDs := uu1\<rparr>) (s1 \<lparr>sentOuterFriendIDs := uu2\<rparr>)"
"\<And> uu1 uu2. eqButUID s s1 \<Longrightarrow> uu1 = uu2 \<Longrightarrow> eqButUID (s \<lparr>recvOuterFriendIDs := uu1\<rparr>) (s1 \<lparr>recvOuterFriendIDs := uu2\<rparr>)"

"\<And> uu1 uu2. eqButUID s s1 \<Longrightarrow> uu1 = uu2 \<Longrightarrow> eqButUID (s \<lparr>pendingCApiReqs := uu1\<rparr>) (s1 \<lparr>pendingCApiReqs := uu2\<rparr>)"
"\<And> uu1 uu2. eqButUID s s1 \<Longrightarrow> uu1 = uu2 \<Longrightarrow> eqButUID (s \<lparr>cApiReq := uu1\<rparr>) (s1 \<lparr>cApiReq := uu2\<rparr>)"
"\<And> uu1 uu2. eqButUID s s1 \<Longrightarrow> uu1 = uu2 \<Longrightarrow> eqButUID (s \<lparr>clientApiIDs := uu1\<rparr>) (s1 \<lparr>clientApiIDs := uu2\<rparr>)"
"\<And> uu1 uu2. eqButUID s s1 \<Longrightarrow> uu1 = uu2 \<Longrightarrow> eqButUID (s \<lparr>clientPass := uu1\<rparr>) (s1 \<lparr>clientPass := uu2\<rparr>)"
"\<And> uu1 uu2. eqButUID s s1 \<Longrightarrow> uu1 = uu2 \<Longrightarrow> eqButUID (s \<lparr>sharedWith := uu1\<rparr>) (s1 \<lparr>sharedWith:= uu2\<rparr>)"
unfolding eqButUID_def by auto

definition "friends12" :: "state \<Rightarrow> bool"
where "friends12 s \<equiv> UID1 \<in>\<in> friendIDs s UID2 \<and> UID2 \<in>\<in> friendIDs s UID1"

lemma step_friendIDs:
assumes "step s a = (ou, s')"
and "a \<noteq> Cact (cFriend uid (pass s uid) uid') \<and> a \<noteq> Cact (cFriend uid' (pass s uid') uid) \<and>
     a \<noteq> Dact (dFriend uid (pass s uid) uid') \<and> a \<noteq> Dact (dFriend uid' (pass s uid') uid)"
shows "uid \<in>\<in> friendIDs s' uid' \<longleftrightarrow> uid \<in>\<in> friendIDs s uid'" (is ?uid)
  and "uid' \<in>\<in> friendIDs s' uid \<longleftrightarrow> uid' \<in>\<in> friendIDs s uid" (is ?uid')
proof -
  from assms have "?uid \<and> ?uid'"
  proof (cases a)
    case (Sact sa) then show ?thesis using assms by (cases sa) (auto simp: s_defs) next
    case (Uact ua) then show ?thesis using assms by (cases ua) (auto simp: u_defs) next
    case (COMact ca) then show ?thesis using assms by (cases ca) (auto simp: com_defs) next
    case (Cact ca) then show ?thesis using assms by (cases ca) (auto simp: c_defs) next
    case (Dact da) then show ?thesis using assms by (cases da) (auto simp: d_defs)
  qed auto
  then show ?uid and ?uid' by auto
qed

lemma step_friends12:
assumes "step s a = (ou, s')"
and "a \<noteq> Cact (cFriend UID1 (pass s UID1) UID2) \<and> a \<noteq> Cact (cFriend UID2 (pass s UID2) UID1) \<and>
     a \<noteq> Dact (dFriend UID1 (pass s UID1) UID2) \<and> a \<noteq> Dact (dFriend UID2 (pass s UID2) UID1)"
shows "friends12 s' \<longleftrightarrow> friends12 s"
using step_friendIDs[OF assms] unfolding friends12_def by auto

lemma step_pendingFReqs:
assumes step: "step s a = (ou, s')"
and "\<forall>req. a \<noteq> Cact (cFriend uid (pass s uid) uid') \<and> a \<noteq> Cact (cFriend uid' (pass s uid') uid) \<and>
           a \<noteq> Dact (dFriend uid (pass s uid) uid') \<and> a \<noteq> Dact (dFriend uid' (pass s uid') uid) \<and>
           a \<noteq> Cact (cFriendReq uid (pass s uid) uid' req) \<and>
           a \<noteq> Cact (cFriendReq uid' (pass s uid') uid req)"
shows "uid \<in>\<in> pendingFReqs s' uid' \<longleftrightarrow> uid \<in>\<in> pendingFReqs s uid'" (is ?uid)
  and "uid' \<in>\<in> pendingFReqs s' uid \<longleftrightarrow> uid' \<in>\<in> pendingFReqs s uid" (is ?uid')
proof -
  from assms have "?uid \<and> ?uid'"
  proof (cases a)
    case (Sact sa) then show ?thesis using assms by (cases sa) (auto simp: s_defs) next
    case (Uact ua) then show ?thesis using assms by (cases ua) (auto simp: u_defs) next
    case (COMact ca) then show ?thesis using assms by (cases ca) (auto simp: com_defs) next
    case (Cact ca) then show ?thesis using assms proof (cases ca)
      case (cFriend uid1 p uid1')
        then have "((uid1 = uid \<longrightarrow> uid1' \<noteq> uid') \<and> (uid1 = uid' \<longrightarrow> uid1' \<noteq> uid)) \<or> ou = outErr"
          using Cact assms by (auto simp: c_defs)
        then show ?thesis using step Cact cFriend by (auto simp: c_defs)
    qed (auto simp: c_defs) next
    case (Dact da) then show ?thesis using assms by (cases da) (auto simp: d_defs)
  qed auto
  then show ?uid and ?uid' by auto
qed

lemma eqButUID_friends12_set_friendIDs_eq:
assumes ss1: "eqButUID s s1"
and f12: "friends12 s = friends12 s1"
and rs: "reach s" and rs1: "reach s1"
shows "set (friendIDs s uid) = set (friendIDs s1 uid)"
proof -
  have dfIDs: "distinct (friendIDs s uid)" "distinct (friendIDs s1 uid)"
    using reach_distinct_friends_reqs[OF rs] reach_distinct_friends_reqs[OF rs1] by auto
  from f12 have uid12: "UID1 \<in>\<in> friendIDs s UID2 \<longleftrightarrow> UID1 \<in>\<in> friendIDs s1 UID2"
                       "UID2 \<in>\<in> friendIDs s UID1 \<longleftrightarrow> UID2 \<in>\<in> friendIDs s1 UID1"
    using reach_friendIDs_symmetric[OF rs] reach_friendIDs_symmetric[OF rs1]
    unfolding friends12_def by auto
  from ss1 have fIDs: "eqButUIDf (friendIDs s) (friendIDs s1)" unfolding eqButUID_def by simp
  show "set (friendIDs s uid) = set (friendIDs s1 uid)"
  proof (intro equalityI subsetI)
    fix uid'
    assume "uid' \<in>\<in> friendIDs s uid"
    then show "uid' \<in>\<in> friendIDs s1 uid"
      using fIDs dfIDs uid12 eqButUIDf_not_UID' unfolding eqButUIDf_def
      by (metis (no_types, lifting) insert_iff prod.inject singletonD)
  next
    fix uid'
    assume "uid' \<in>\<in> friendIDs s1 uid"
    then show "uid' \<in>\<in> friendIDs s uid"
      using fIDs dfIDs uid12 eqButUIDf_not_UID' unfolding eqButUIDf_def
      by (metis (no_types, lifting) insert_iff prod.inject singletonD)
  qed
qed

lemma distinct_remove1_idem: "distinct xs \<Longrightarrow> remove1 y (remove1 y xs) = remove1 y xs"
by (induction xs) (auto simp add: remove1_idem)

lemma Cact_cFriend_step_eqButUID:
assumes step: "step s (Cact (cFriend uid p uid')) = (ou,s')"
and s: "reach s"
and uids: "(uid = UID1 \<and> uid' = UID2) \<or> (uid = UID2 \<and> uid' = UID1)" (is "?u12 \<or> ?u21")
shows "eqButUID s s'"
using assms proof (cases)
  assume ou: "ou = outOK"
  then have "uid' \<in>\<in> pendingFReqs s uid" using step by (auto simp add: c_defs)
  then have fIDs: "uid' \<notin> set (friendIDs s uid)" "uid \<notin> set (friendIDs s uid')"
        and fRs: "distinct (pendingFReqs s uid)" "distinct (pendingFReqs s uid')"
    using reach_distinct_friends_reqs[OF s] by auto
  have "eqButUIDf (friendIDs s) (friendIDs (createFriend s uid p uid'))"
    using fIDs uids UID1_UID2 unfolding eqButUIDf_def
    by (cases "?u12") (auto simp add: c_defs remove1_idem remove1_append)
  moreover have "eqButUIDf (pendingFReqs s) (pendingFReqs (createFriend s uid p uid'))"
    using fRs uids UID1_UID2 unfolding eqButUIDf_def
    by (cases "?u12") (auto simp add: c_defs distinct_remove1_idem)
  moreover have "eqButUID12 (friendReq s) (friendReq (createFriend s uid p uid'))"
    using uids unfolding eqButUID12_def
    by (auto simp add: c_defs fun_upd2_eq_but_a_b)
  ultimately show "eqButUID s s'" using step ou unfolding eqButUID_def by (auto simp add: c_defs)
qed (auto)

lemma Cact_cFriendReq_step_eqButUID:
assumes step: "step s (Cact (cFriendReq uid p uid' req)) = (ou,s')"
and uids: "(uid = UID1 \<and> uid' = UID2) \<or> (uid = UID2 \<and> uid' = UID1)" (is "?u12 \<or> ?u21")
shows "eqButUID s s'"
using assms proof (cases)
  assume ou: "ou = outOK"
  then have "uid \<notin> set (pendingFReqs s uid')" "uid \<notin> set (friendIDs s uid')"
    using step by (auto simp add: c_defs)
  then have "eqButUIDf (pendingFReqs s) (pendingFReqs (createFriendReq s uid p uid' req))"
    using uids UID1_UID2 unfolding eqButUIDf_def
    by (cases "?u12") (auto simp add: c_defs remove1_idem remove1_append)
  moreover have "eqButUID12 (friendReq s) (friendReq (createFriendReq s uid p uid' req))"
    using uids unfolding eqButUID12_def
    by (auto simp add: c_defs fun_upd2_eq_but_a_b)
  ultimately show "eqButUID s s'" using step ou unfolding eqButUID_def by (auto simp add: c_defs)
qed (auto)

lemma Dact_dFriend_step_eqButUID:
assumes step: "step s (Dact (dFriend uid p uid')) = (ou,s')"
and s: "reach s"
and uids: "(uid = UID1 \<and> uid' = UID2) \<or> (uid = UID2 \<and> uid' = UID1)" (is "?u12 \<or> ?u21")
shows "eqButUID s s'"
using assms proof (cases)
  assume ou: "ou = outOK"
  then have "uid' \<in>\<in> friendIDs s uid" using step by (auto simp add: d_defs)
  then have fRs: "distinct (friendIDs s uid)" "distinct (friendIDs s uid')"
    using reach_distinct_friends_reqs[OF s] by auto
  have "eqButUIDf (friendIDs s) (friendIDs (deleteFriend s uid p uid'))"
    using fRs uids UID1_UID2 unfolding eqButUIDf_def
    by (cases "?u12") (auto simp add: d_defs remove1_idem distinct_remove1_removeAll)
  then show "eqButUID s s'" using step ou unfolding eqButUID_def by (auto simp add: d_defs)
qed (auto)

(* major *) lemma eqButUID_step:
assumes ss1: "eqButUID s s1"
and step: "step s a = (ou,s')"
and step1: "step s1 a = (ou1,s1')"
and rs: "reach s"
and rs1: "reach s1"
shows "eqButUID s' s1'"
proof -
  note simps = eqButUID_stateSelectors s_defs c_defs u_defs r_defs l_defs com_defs
  from assms show ?thesis proof (cases a)
    case (Sact sa) with assms show ?thesis by (cases sa) (auto simp add: simps)
  next
    case (Cact ca) note a = this
      with assms show ?thesis proof (cases ca)
        case (cFriendReq uid p uid' req) note ca = this
          then show ?thesis
          proof (cases "(uid = UID1 \<and> uid' = UID2) \<or> (uid = UID2 \<and> uid' = UID1)")
            case True
              then have "eqButUID s s'" and "eqButUID s1 s1'"
                using step step1 unfolding a ca
                by (auto intro: Cact_cFriendReq_step_eqButUID)
              with ss1 show "eqButUID s' s1'" by (auto intro: eqButUID_sym eqButUID_trans)
          next
            case False
              have fRs: "eqButUIDf (pendingFReqs s) (pendingFReqs s1)"
               and fIDs: "eqButUIDf (friendIDs s) (friendIDs s1)" using ss1 by (auto simp: simps)
              then have uid_uid': "uid \<in>\<in> pendingFReqs s uid' \<longleftrightarrow> uid \<in>\<in> pendingFReqs s1 uid'"
                                  "uid \<in>\<in> friendIDs s uid' \<longleftrightarrow> uid \<in>\<in> friendIDs s1 uid'"
                using False by (auto intro!: eqButUIDf_not_UID')
              have "eqButUIDf ((pendingFReqs s)(uid' := pendingFReqs s uid' ## uid))
                              ((pendingFReqs s1)(uid' := pendingFReqs s1 uid' ## uid))"
                using fRs False
                by (intro eqButUIDf_cong) (auto simp add: remove1_append remove1_idem eqButUIDf_def)
              moreover have "eqButUID12 (fun_upd2 (friendReq s) uid uid' req)
                                        (fun_upd2 (friendReq s1) uid uid' req)"
                using ss1 by (intro eqButUID12_cong) (auto simp: simps)
              moreover have "e_createFriendReq s uid p uid' req
                         \<longleftrightarrow> e_createFriendReq s1 uid p uid' req"
                using uid_uid' ss1 by (auto simp: simps)
              ultimately show ?thesis using assms unfolding a ca by (auto simp: simps)
          qed
      next
        case (cFriend uid p uid') note ca = this
          then show ?thesis
          proof (cases "(uid = UID1 \<and> uid' = UID2) \<or> (uid = UID2 \<and> uid' = UID1)")
            case True
              then have "eqButUID s s'" and "eqButUID s1 s1'"
                using step step1 rs rs1 unfolding a ca
                by (auto intro!: Cact_cFriend_step_eqButUID)+
              with ss1 show "eqButUID s' s1'" by (auto intro: eqButUID_sym eqButUID_trans)
          next
            case False
              have fRs: "eqButUIDf (pendingFReqs s) (pendingFReqs s1)"
                    (is "eqButUIDf (?pfr s) (?pfr s1)")
               and fIDs: "eqButUIDf (friendIDs s) (friendIDs s1)" using ss1 by (auto simp: simps)
              then have uid_uid': "uid \<in>\<in> pendingFReqs s uid' \<longleftrightarrow> uid \<in>\<in> pendingFReqs s1 uid'"
                                  "uid' \<in>\<in> pendingFReqs s uid \<longleftrightarrow> uid' \<in>\<in> pendingFReqs s1 uid"
                                  "uid \<in>\<in> friendIDs s uid' \<longleftrightarrow> uid \<in>\<in> friendIDs s1 uid'"
                                  "uid' \<in>\<in> friendIDs s uid \<longleftrightarrow> uid' \<in>\<in> friendIDs s1 uid"
                using False by (auto intro!: eqButUIDf_not_UID')
              have "eqButUIDl UID1 (remove1 uid' (?pfr s UID2)) (remove1 uid' (?pfr s1 UID2))"
               and "eqButUIDl UID2 (remove1 uid' (?pfr s UID1)) (remove1 uid' (?pfr s1 UID1))"
               and "eqButUIDl UID1 (remove1 uid (?pfr s UID2)) (remove1 uid (?pfr s1 UID2))"
               and "eqButUIDl UID2 (remove1 uid (?pfr s UID1)) (remove1 uid (?pfr s1 UID1))"
               using fRs unfolding eqButUIDf_def
               by (auto intro!: eqButUIDl_remove1_cong simp del: eqButUIDl.simps)
              then have 1: "eqButUIDf ((?pfr s)(uid := remove1 uid' (?pfr s uid),
                                                uid' := remove1 uid (?pfr s uid')))
                                     ((?pfr s1)(uid := remove1 uid' (?pfr s1 uid),
                                                uid' := remove1 uid (?pfr s1 uid')))"
                using fRs False
                by (intro eqButUIDf_cong) (auto simp add: eqButUIDf_def)
              have "uid = UID1 \<Longrightarrow> eqButUIDl UID2 (friendIDs s UID1 ## uid') (friendIDs s1 UID1 ## uid')"
               and "uid = UID2 \<Longrightarrow> eqButUIDl UID1 (friendIDs s UID2 ## uid') (friendIDs s1 UID2 ## uid')"
               and "uid' = UID1 \<Longrightarrow> eqButUIDl UID2 (friendIDs s UID1 ## uid) (friendIDs s1 UID1 ## uid)"
               and "uid' = UID2 \<Longrightarrow> eqButUIDl UID1 (friendIDs s UID2 ## uid) (friendIDs s1 UID2 ## uid)"
                using fIDs uid_uid' by - (intro eqButUIDl_snoc_cong; simp add: eqButUIDf_def)+
              then have 2: "eqButUIDf ((friendIDs s)(uid := friendIDs s uid ## uid',
                                                      uid' := friendIDs s uid' ## uid))
                                       ((friendIDs s1)(uid := friendIDs s1 uid ## uid',
                                                       uid' := friendIDs s1 uid' ## uid))"
                using fIDs by (intro eqButUIDf_cong) (auto simp add: eqButUIDf_def)
              have 3: "eqButUID12 (fun_upd2 (fun_upd2 (friendReq s) uid' uid emptyRequestInfo)
                                                                    uid uid' emptyRequestInfo)
                                  (fun_upd2 (fun_upd2 (friendReq s1) uid' uid emptyRequestInfo)
                                                                     uid uid' emptyRequestInfo)"
                using ss1 by (intro eqButUID12_cong) (auto simp: simps)
              have "e_createFriend s uid p uid'
                \<longleftrightarrow> e_createFriend s1 uid p uid'"
                using uid_uid' ss1 by (auto simp: simps)
              with 1 2 3 show ?thesis using assms unfolding a ca by (auto simp: simps)
          qed
      qed (auto simp: simps)
  next
    case (Uact ua) with assms show ?thesis by (cases ua) (auto simp add: simps)
  next
    case (Ract ra) with assms show ?thesis by (cases ra) (auto simp add: simps)
  next
    case (Lact la) with assms show ?thesis by (cases la) (auto simp add: simps)
  next
    case (COMact ca) with assms show ?thesis by (cases ca) (auto simp add: simps)
  next
    case (Dact da) note a = this
      with assms show ?thesis proof (cases da)
        case (dFriend uid p uid') note ca = this
          then show ?thesis
          proof (cases "(uid = UID1 \<and> uid' = UID2) \<or> (uid = UID2 \<and> uid' = UID1)")
            case True
              then have "eqButUID s s'" and "eqButUID s1 s1'"
                using step step1 rs rs1 unfolding a ca
                by (auto intro!: Dact_dFriend_step_eqButUID)+
              with ss1 show "eqButUID s' s1'" by (auto intro: eqButUID_sym eqButUID_trans)
          next
            case False
              have fIDs: "eqButUIDf (friendIDs s) (friendIDs s1)" using ss1 by (auto simp: simps)
              then have uid_uid': "uid \<in>\<in> friendIDs s uid' \<longleftrightarrow> uid \<in>\<in> friendIDs s1 uid'"
                                  "uid' \<in>\<in> friendIDs s uid \<longleftrightarrow> uid' \<in>\<in> friendIDs s1 uid"
                using False by (auto intro!: eqButUIDf_not_UID')
              have dfIDs: "distinct (friendIDs s uid)" "distinct (friendIDs s uid')"
                          "distinct (friendIDs s1 uid)" "distinct (friendIDs s1 uid')"
                using reach_distinct_friends_reqs[OF rs] reach_distinct_friends_reqs[OF rs1] by auto
              have "uid = UID1 \<Longrightarrow> eqButUIDl UID2 (remove1 uid' (friendIDs s UID1)) (remove1 uid' (friendIDs s1 UID1))"
               and "uid = UID2 \<Longrightarrow> eqButUIDl UID1 (remove1 uid' (friendIDs s UID2)) (remove1 uid' (friendIDs s1 UID2))"
               and "uid' = UID1 \<Longrightarrow> eqButUIDl UID2 (remove1 uid (friendIDs s UID1)) (remove1 uid (friendIDs s1 UID1))"
               and "uid' = UID2 \<Longrightarrow> eqButUIDl UID1 (remove1 uid (friendIDs s UID2)) (remove1 uid (friendIDs s1 UID2))"
                using fIDs uid_uid' by - (intro eqButUIDl_remove1_cong; simp add: eqButUIDf_def)+
              then have 1: "eqButUIDf ((friendIDs s)(uid := remove1 uid' (friendIDs s uid),
                                                      uid' := remove1 uid (friendIDs s uid')))
                                       ((friendIDs s1)(uid := remove1 uid' (friendIDs s1 uid),
                                                       uid' := remove1 uid (friendIDs s1 uid')))"
                using fIDs by (intro eqButUIDf_cong) (auto simp add: eqButUIDf_def)
              have "e_deleteFriend s uid p uid'
                \<longleftrightarrow> e_deleteFriend s1 uid p uid'"
                using uid_uid' ss1 by (auto simp: simps d_defs)
              with 1 show ?thesis using assms dfIDs unfolding a ca
                by (auto simp: simps d_defs distinct_remove1_removeAll)
          qed
      qed
  qed
qed

lemma eqButUID_step_friendIDs_eq:
assumes ss1: "eqButUID s s1"
and rs: "reach s" and rs1: "reach s1"
and step: "step s a = (ou,s')" and step1: "step s1 a = (ou1,s1')"
and a: "a \<noteq> Cact (cFriend UID1 (pass s UID1) UID2) \<and> a \<noteq> Cact (cFriend UID2 (pass s UID2) UID1) \<and>
        a \<noteq> Dact (dFriend UID1 (pass s UID1) UID2) \<and> a \<noteq> Dact (dFriend UID2 (pass s UID2) UID1)"
and "friendIDs s = friendIDs s1"
shows "friendIDs s' = friendIDs s1'"
using assms proof (cases a)
  case (Sact sa) then show ?thesis using assms by (cases sa) (auto simp: s_defs) next
  case (Uact ua) then show ?thesis using assms by (cases ua) (auto simp: u_defs) next
  case (COMact ca) then show ?thesis using assms by (cases ca) (auto simp: com_defs) next
  case (Dact da) then show ?thesis using assms proof (cases da)
    case (dFriend uid p uid')
      with Dact assms show ?thesis
        by (cases "(uid,uid') \<in> {(UID1,UID2), (UID2,UID1)}")
           (auto simp: d_defs eqButUID_stateSelectors eqButUIDf_not_UID')
    qed
next
  case (Cact ca) then show ?thesis using assms proof (cases ca)
    case (cFriend uid p uid')
      { assume "p = pass s uid"
        then have "uid' \<in>\<in> pendingFReqs s uid \<longleftrightarrow> uid' \<in>\<in> pendingFReqs s1 uid"
          using Cact cFriend ss1 a by (intro eqButUIDf_not_UID') (auto simp: eqButUID_stateSelectors)
      }
      with Cact cFriend assms show ?thesis
        by (auto simp: c_defs eqButUID_stateSelectors)
    qed (auto simp: c_defs)
qed auto

lemma createFriend_sym: "createFriend s uid p uid' = createFriend s uid' p' uid"
unfolding c_defs by (cases "uid = uid'") (auto simp: fun_upd2_comm fun_upd_twist)

lemma deleteFriend_sym: "deleteFriend s uid p uid' = deleteFriend s uid' p' uid"
unfolding d_defs by (cases "uid = uid'") (auto simp: fun_upd_twist)

lemma createFriendReq_createFriend_absorb:
assumes "e_createFriendReq s uid' p uid req"
shows "createFriend (createFriendReq s uid' p1 uid req) uid p2 uid' = createFriend s uid p3 uid'"
using assms unfolding c_defs by (auto simp: remove1_idem remove1_append fun_upd2_absorb)

lemma eqButUID_deleteFriend12_friendIDs_eq:
assumes ss1: "eqButUID s s1"
and rs: "reach s" and rs1: "reach s1"
shows "friendIDs (deleteFriend s UID1 p UID2) = friendIDs (deleteFriend s1 UID1 p' UID2)"
proof -
  have "distinct (friendIDs s UID1)" "distinct (friendIDs s UID2)"
       "distinct (friendIDs s1 UID1)" "distinct (friendIDs s1 UID2)"
    using rs rs1 by (auto intro: reach_distinct_friends_reqs)
  then show ?thesis
    using ss1 unfolding eqButUID_def eqButUIDf_def unfolding d_defs
    by (auto simp: distinct_remove1_removeAll)
qed

lemma eqButUID_createFriend12_friendIDs_eq:
assumes ss1: "eqButUID s s1"
and rs: "reach s" and rs1: "reach s1"
and f12: "\<not>friends12 s" "\<not>friends12 s1"
shows "friendIDs (createFriend s UID1 p UID2) = friendIDs (createFriend s1 UID1 p' UID2)"
proof -
  have f12': "UID1 \<notin> set (friendIDs s UID2)" "UID2 \<notin> set (friendIDs s UID1)"
             "UID1 \<notin> set (friendIDs s1 UID2)" "UID2 \<notin> set (friendIDs s1 UID1)"
    using f12 rs rs1 reach_friendIDs_symmetric unfolding friends12_def by auto
  have "friendIDs s = friendIDs s1"
  proof (intro ext)
    fix uid
    show "friendIDs s uid = friendIDs s1 uid"
      using ss1 f12' unfolding eqButUID_def eqButUIDf_def
      by (cases "uid = UID1 \<or> uid = UID2") (auto simp: remove1_idem)
  qed
  then show ?thesis by (auto simp: c_defs)
qed

end

end


theory CoCallAnalysisBinds
imports CoCallAnalysisSig AEnv  "AList-Utils-HOLCF" "Arity-Nominal" "CoCallGraph-Nominal"
begin

context CoCallAnalysis
begin
definition ccBind :: "var \<Rightarrow> exp \<Rightarrow> ((AEnv \<times> CoCalls) \<rightarrow> CoCalls)"
  where "ccBind v e = (\<Lambda> (ae, G).  if (v--v\<notin>G) \<or> \<not> isVal e then cc_restr (fv e) (fup\<cdot>(ccExp e)\<cdot>(ae v)) else ccSquare (fv e))"
(* paper has:  \<or> ae v = up\<cdot>0, but that is not monotone! But should give the same result. *)

lemma ccBind_eq:
  "ccBind v e\<cdot>(ae, G) = (if v--v\<notin>G \<or> \<not> isVal e then \<G>\<^sup>\<bottom>\<^bsub>ae v\<^esub> e G|` fv e else (fv e)\<^sup>2)"
  unfolding ccBind_def
  apply (rule cfun_beta_Pair)
  apply (rule cont_if_else_above)
  apply simp
  apply simp
  apply (auto dest: subsetD[OF ccField_cc_restr])[1]
  (* Abstraction broken! Fix this. *)
  apply (case_tac p, auto, transfer, auto)[1]
  apply (rule adm_subst[OF cont_snd])
  apply (rule admI, thin_tac "chain _", transfer, auto)
  done

lemma ccBind_strict[simp]: "ccBind v e \<cdot> \<bottom> = \<bottom>"
  by (auto simp add: inst_prod_pcpo ccBind_eq simp del: Pair_strict)

lemma ccField_ccBind: "ccField (ccBind v e\<cdot>(ae,G)) \<subseteq> fv e"
  by (auto simp add: ccBind_eq dest: subsetD[OF ccField_cc_restr])

definition ccBinds :: "heap \<Rightarrow> ((AEnv \<times> CoCalls) \<rightarrow> CoCalls)"
  where "ccBinds \<Gamma> = (\<Lambda> i. (\<Squnion>v\<mapsto>e\<in>map_of \<Gamma>. ccBind v e\<cdot>i))"

lemma ccBinds_eq:
  "ccBinds \<Gamma>\<cdot>i = (\<Squnion>v\<mapsto>e\<in>map_of \<Gamma>. ccBind v e\<cdot>i)"
  unfolding ccBinds_def
  by simp

lemma ccBinds_strict[simp]: "ccBinds \<Gamma>\<cdot>\<bottom>=\<bottom>"
  unfolding ccBinds_eq
  by (cases "\<Gamma> = []") simp_all

lemma ccBinds_strict'[simp]: "ccBinds \<Gamma>\<cdot>(\<bottom>,\<bottom>)=\<bottom>"
  by (metis CoCallAnalysis.ccBinds_strict Pair_bottom_iff)

lemma ccBinds_reorder1:
  assumes "map_of \<Gamma> v = Some e"
  shows "ccBinds \<Gamma> = ccBind v e \<squnion> ccBinds (delete v \<Gamma>)"
proof-
  from assms
  have "map_of \<Gamma> = map_of ((v,e) # delete v \<Gamma>)" by (metis map_of_delete_insert)
  thus ?thesis
    by (auto intro: cfun_eqI simp add: ccBinds_eq delete_set_none)
qed

lemma ccBinds_Nil[simp]:
  "ccBinds [] = \<bottom>"
  unfolding ccBinds_def by simp

lemma ccBinds_Cons[simp]:
   "ccBinds ((x,e)#\<Gamma>) = ccBind x e \<squnion> ccBinds (delete x \<Gamma>)"
   by (subst ccBinds_reorder1[where v = x and e = e]) auto

lemma ccBind_below_ccBinds: "map_of \<Gamma> x = Some e \<Longrightarrow> ccBind x e\<cdot>ae \<sqsubseteq> (ccBinds \<Gamma>\<cdot>ae)"
  by (auto simp add: ccBinds_eq)

lemma ccField_ccBinds: "ccField (ccBinds \<Gamma>\<cdot>(ae,G)) \<subseteq> fv \<Gamma>"
  by (auto simp add: ccBinds_eq dest: subsetD[OF ccField_ccBind] intro: subsetD[OF map_of_Some_fv_subset])

definition ccBindsExtra :: "heap \<Rightarrow> ((AEnv \<times> CoCalls) \<rightarrow> CoCalls)"
  where "ccBindsExtra \<Gamma> = (\<Lambda> i.  snd i \<squnion> ccBinds \<Gamma> \<cdot> i  \<squnion> (\<Squnion>x\<mapsto>e\<in>map_of \<Gamma>. ccProd (fv e) (ccNeighbors x (snd i))))"

lemma ccBindsExtra_simp: "ccBindsExtra \<Gamma> \<cdot> i =snd i \<squnion> ccBinds \<Gamma> \<cdot> i \<squnion> (\<Squnion>x\<mapsto>e\<in>map_of \<Gamma>. ccProd (fv e) (ccNeighbors x (snd i)))"
  unfolding ccBindsExtra_def by simp

lemma ccBindsExtra_eq: "ccBindsExtra \<Gamma>\<cdot>(ae,G) =
  G \<squnion> ccBinds \<Gamma>\<cdot>(ae,G) \<squnion> (\<Squnion>x\<mapsto>e\<in>map_of \<Gamma>. fv e G\<times> ccNeighbors x G)"
  unfolding ccBindsExtra_def by simp

lemma ccBindsExtra_strict[simp]: "ccBindsExtra \<Gamma> \<cdot> \<bottom> = \<bottom>"
  by (auto simp add: ccBindsExtra_simp inst_prod_pcpo simp del: Pair_strict)

lemma ccField_ccBindsExtra:
  "ccField (ccBindsExtra \<Gamma>\<cdot>(ae,G)) \<subseteq> fv \<Gamma> \<union> ccField G"
  by (auto simp add: ccBindsExtra_simp elem_to_ccField
      dest!:  subsetD[OF ccField_ccBinds]  subsetD[OF ccField_ccProd_subset] map_of_Some_fv_subset)

end

lemma ccBind_eqvt[eqvt]: "\<pi> \<bullet> (CoCallAnalysis.ccBind cccExp x e) = CoCallAnalysis.ccBind (\<pi> \<bullet> cccExp) (\<pi> \<bullet> x) (\<pi> \<bullet> e)"
proof-
  {
  fix \<pi> ae G
  have "\<pi> \<bullet> ((CoCallAnalysis.ccBind cccExp x e) \<cdot> (ae,G)) = CoCallAnalysis.ccBind (\<pi> \<bullet> cccExp) (\<pi> \<bullet> x) (\<pi> \<bullet> e) \<cdot> (\<pi> \<bullet> ae, \<pi> \<bullet> G)"
    unfolding CoCallAnalysis.ccBind_eq
    by perm_simp (simp add: Abs_cfun_eqvt)
  }
  thus ?thesis by (auto intro: cfun_eqvtI)
qed

lemma ccBinds_eqvt[eqvt]: "\<pi> \<bullet> (CoCallAnalysis.ccBinds cccExp \<Gamma>) = CoCallAnalysis.ccBinds (\<pi> \<bullet> cccExp) (\<pi> \<bullet> \<Gamma>)"
  apply (rule cfun_eqvtI)
  unfolding CoCallAnalysis.ccBinds_eq
  apply (perm_simp)
  apply rule
  done

lemma ccBindsExtra_eqvt[eqvt]: "\<pi> \<bullet> (CoCallAnalysis.ccBindsExtra cccExp \<Gamma>) = CoCallAnalysis.ccBindsExtra (\<pi> \<bullet> cccExp) (\<pi> \<bullet> \<Gamma>)"
  by (rule cfun_eqvtI) (simp add: CoCallAnalysis.ccBindsExtra_def)

lemma ccBind_cong[fundef_cong]:
  "cccexp1 e = cccexp2 e \<Longrightarrow> CoCallAnalysis.ccBind cccexp1 x e = CoCallAnalysis.ccBind cccexp2 x e "
  apply (rule cfun_eqI)
  apply (case_tac xa)
  apply (auto simp add: CoCallAnalysis.ccBind_eq)
  done

lemma ccBinds_cong[fundef_cong]:
  "\<lbrakk> (\<And> e. e \<in> snd ` set heap2 \<Longrightarrow> cccexp1 e = cccexp2 e); heap1 = heap2 \<rbrakk>
      \<Longrightarrow> CoCallAnalysis.ccBinds cccexp1 heap1 = CoCallAnalysis.ccBinds cccexp2 heap2"
  apply (rule cfun_eqI)
  unfolding CoCallAnalysis.ccBinds_eq
  apply (rule arg_cong[OF mapCollect_cong])
  apply (rule arg_cong[OF ccBind_cong])
  apply auto
  by (metis imageI map_of_SomeD snd_conv)

lemma ccBindsExtra_cong[fundef_cong]:
  "\<lbrakk> (\<And> e. e \<in> snd ` set heap2 \<Longrightarrow> cccexp1 e = cccexp2 e); heap1 = heap2 \<rbrakk>
      \<Longrightarrow> CoCallAnalysis.ccBindsExtra cccexp1 heap1 = CoCallAnalysis.ccBindsExtra cccexp2 heap2"
  apply (rule cfun_eqI)
  unfolding CoCallAnalysis.ccBindsExtra_simp
  apply (rule arg_cong2[OF ccBinds_cong mapCollect_cong])
  apply simp+
  done

end


(*  Title:      JinjaThreads/J/WWellForm.thy
    Author:     Tobias Nipkow, Andreas Lochbihler
*)

header {* \isaheader{Weak well-formedness of Jinja programs} *}

theory WWellForm
imports
  "../Common/WellForm"
  Expr
begin

definition
  wwf_J_mdecl :: "'addr J_prog \<Rightarrow> cname \<Rightarrow> 'addr J_mb mdecl \<Rightarrow> bool"
where
  "wwf_J_mdecl P C  \<equiv>  \<lambda>(M,Ts,T,(pns,body)).
  length Ts = length pns \<and> distinct pns \<and> this \<notin> set pns \<and> fv body \<subseteq> {this} \<union> set pns"

lemma wwf_J_mdecl[simp]:
  "wwf_J_mdecl P C (M,Ts,T,pns,body) =
  (length Ts = length pns \<and> distinct pns \<and> this \<notin> set pns \<and> fv body \<subseteq> {this} \<union> set pns)"
(*<*)by(simp add:wwf_J_mdecl_def)(*>*)

abbreviation wwf_J_prog :: "'addr J_prog \<Rightarrow> bool"
where "wwf_J_prog == wf_prog wwf_J_mdecl"

end


(*
 * Copyright 2014, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(NICTA_BSD)
 *)

(* A theory of guarded monadic bisimulation. *)

theory Bisim_UL
imports
  "Monad_WP/NonDetMonadVCG"
  Corres_UL
  EmptyFailLib
begin

(* This still looks a bit wrong to me, although it is more or less what I want \<emdash> we want to be
   able to move hoare triples across bisimulations, and this allows guards to be left behind, more or less
definition
  "bisim_underlying SR R P P' m m' \<equiv>
    \<forall>s s'. SR s s' \<longrightarrow> (P s \<longrightarrow> (\<forall>(r, t) \<in> fst (m s). \<exists>(r', t') \<in> fst (m' s'). R r r' \<and> SR t t')) \<and>
                       (P' s' \<longrightarrow> (\<forall>(r', t') \<in> fst (m' s'). \<exists>(r, t) \<in> fst (m s). R r r' \<and> SR t t'))"
*)

definition
  bisim_underlying :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('c \<Rightarrow> 'd \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> (('c \<times> 'a) set) \<times> bool) \<Rightarrow> ('b \<Rightarrow> (('d \<times> 'b) set) \<times> bool) \<Rightarrow> bool"
where
  "bisim_underlying SR R P P' m m' \<equiv>
    \<forall>s s'. SR s  s' \<and> P s \<and> P' s' \<longrightarrow> ((\<forall>(r, t) \<in> fst (m s). \<exists>(r', t') \<in> fst (m' s'). R r r' \<and> SR t t') \<and>
                                      (\<forall>(r', t') \<in> fst (m' s'). \<exists>(r, t) \<in> fst (m s). R r r' \<and> SR t t'))"

(*
lemma bisim_is_corres_both_ways:
  "bisim_underlying SR R P P' m m' = (corres_underlying SR False R P P' m m' \<and> corres_underlying (converse SR) False (swp R) P' P m' m)"
  unfolding bisim_underlying_def corres_underlying_def
  by (fastforce simp: swp_def Ball_def Bex_def)
*)

lemma bisim_valid:
  assumes ac: "bisim_underlying (=)  (=) P P' a a'"
  and     rl: "\<lbrace>Q\<rbrace> a \<lbrace>S\<rbrace>"
  shows   "\<lbrace>P and P' and Q\<rbrace> a' \<lbrace>S\<rbrace>"
  using ac rl
  unfolding bisim_underlying_def valid_def
  by (fastforce simp: split_def)

lemma bisim_valid2:
  assumes ac: "bisim_underlying (=) (=) P P' a a'"
  and     rl: "\<lbrace>Q\<rbrace> a' \<lbrace>S\<rbrace>"
  shows   "\<lbrace>P and P' and Q\<rbrace> a \<lbrace>S\<rbrace>"
  using ac rl
  unfolding bisim_underlying_def valid_def
  by (fastforce simp: split_def)

lemma bisim_underlyingI [consumes 0, case_names Left Right]:
  assumes r1: "\<And>s s' r t. \<lbrakk>SR s s'; P s; P' s'; (r, t) \<in> fst (m s) \<rbrakk> \<Longrightarrow> \<exists>(r', t') \<in> fst (m' s'). R r r' \<and> SR t t'"
  and     r2: "\<And>s s' r' t'. \<lbrakk>SR s s'; P s; P' s'; (r', t') \<in> fst (m' s') \<rbrakk> \<Longrightarrow> \<exists>(r, t) \<in> fst (m s). R r r' \<and> SR t t'"
  shows   "bisim_underlying SR R P P' m m'"
  unfolding bisim_underlying_def
  by (fastforce dest: r1 r2 simp: split_def)

lemma bisim_underlyingE1:
  assumes bs: "bisim_underlying SR R P P' m m'"
  and     sr: "SR s s'"
  and     ps: "P s" "P' s'"
  and     ms: "(r, t) \<in> fst (m s)"
  and     rl: "\<And>r' t'. \<lbrakk> (r', t') \<in> fst (m' s'); R r r'; SR t t' \<rbrakk> \<Longrightarrow> X"
  shows X
  using bs sr ps ms unfolding bisim_underlying_def
  by (fastforce intro: rl)

lemma bisim_underlyingE2:
  assumes bs: "bisim_underlying SR R P P' m m'"
  and     sr: "SR s s'"
  and     ps: "P s" "P' s'"
  and     ms: "(r', t') \<in> fst (m' s')"
  and     rl: "\<And>r t. \<lbrakk> (r, t) \<in> fst (m s); R r r'; SR t t' \<rbrakk> \<Longrightarrow> X"
  shows X
  using bs sr ps ms unfolding bisim_underlying_def
  by (fastforce intro: rl)

lemma bisim_split:
  assumes ac: "bisim_underlying SR R' P P' a c"
  and     bd: "\<And>r r'. R' r r' \<Longrightarrow> bisim_underlying SR R (Q r) (Q' r') (b r) (d r')"
  and     v1: "\<lbrace>S\<rbrace> a \<lbrace>Q\<rbrace>"
  and     v2: "\<lbrace>S'\<rbrace> c \<lbrace>Q'\<rbrace>"
  shows "bisim_underlying SR R (P and S) (P' and S') (a >>= b) (c >>= d)"
  using ac
  apply -
  apply (rule bisim_underlyingI)
   apply (clarsimp simp: in_monad split_def)
   apply (erule (4) bisim_underlyingE1)
   apply (frule (1) use_valid [OF _ v1])
   apply (frule (1) use_valid [OF _ v2])
   apply (erule (4) bisim_underlyingE1 [OF bd])
   apply (rename_tac r'' t'')
   apply (rule_tac x = "(r'', t'')" in bexI)
    apply clarsimp
   apply (fastforce simp: in_monad)
  apply (clarsimp simp: in_monad split_def)
  apply (erule (4) bisim_underlyingE2)
  apply (frule (1) use_valid [OF _ v1])
  apply (frule (1) use_valid [OF _ v2])
  apply (erule (4) bisim_underlyingE2 [OF bd])
  apply (rename_tac r'' t'')
   apply (rule_tac x = "(r'', t'')" in bexI)
    apply clarsimp
   apply (fastforce simp: in_monad)
  done

abbreviation
  "bisim \<equiv> bisim_underlying (=)"

lemma bisim_refl:
  assumes rrefl: "\<And>r. R r r"
  shows "bisim R P P' m m"
  apply (rule bisim_underlyingI)
   apply (clarsimp simp: split_def)
   apply (erule bexI [rotated])
   apply (simp add: rrefl)
  apply (clarsimp simp: split_def)
  apply (erule bexI [rotated])
  apply (simp add: rrefl)
  done

lemma bisim_guard_imp:
  assumes bs: "bisim_underlying SR R Q Q' m m'"
  and   rls: "\<And>s. P s \<Longrightarrow> Q s" "\<And>s. P' s \<Longrightarrow> Q' s"
  shows "bisim_underlying SR R P P' m m'"
  using bs rls
  by (fastforce intro!: bisim_underlyingI elim: bisim_underlyingE1  bisim_underlyingE2)

lemma bisim_return':
  assumes Rxx: "R x x'"
  shows "bisim_underlying SR R P P' (return x) (return x')"
  apply (rule bisim_underlyingI)
  apply (clarsimp simp: in_monad split_def Bex_def Rxx)
  apply (clarsimp simp: in_monad split_def Bex_def Rxx)
  done

lemmas bisim_return = bisim_return' [where P = \<top> and P' = \<top>]

lemma bisim_split_handle:
  assumes bm: "bisim (f' \<oplus> r) Pn Pn' m m'"
  and     bc: "\<And>x x'. f' x x' \<Longrightarrow> bisim (f \<oplus> r) (Pf x) (Pf' x') (c x) (c' x')"
  and     v1: "\<lbrace>P\<rbrace> m \<lbrace>\<lambda>_ _. True\<rbrace>, \<lbrace>Pf\<rbrace>"
  and     v2: "\<lbrace>P'\<rbrace> m' \<lbrace>\<lambda>_ _. True\<rbrace>, \<lbrace>Pf'\<rbrace>"
  shows "bisim (f \<oplus> r) (Pn and P) (Pn' and P') (m <handle> c) (m' <handle> c')"
  unfolding handleE_def handleE'_def
  apply (rule bisim_split [where Q = "\<lambda>r s. case_sum (\<lambda>l. Pf l s) (\<lambda>_. True) r" and Q' = "\<lambda>r s. case_sum (\<lambda>l. Pf' l s) (\<lambda>_. True) r", OF bm, folded validE_def])
  apply (case_tac ra)
   apply clarsimp
   apply (erule bc)
  apply clarsimp
  apply (rule bisim_return')
  apply simp
  apply (rule v1)
  apply (rule v2)
  done

(* Set up wpc *)
lemma wpc_helper_bisim:
  "bisim_underlying SR r Q Q' f f' \<Longrightarrow> wpc_helper (P, P') (Q, {s. Q' s}) (bisim_underlying SR r P (\<lambda>s. s \<in> P') f f')"
  apply (clarsimp simp: wpc_helper_def)
  apply (erule bisim_guard_imp)
   apply simp
  apply fastforce
  done

wpc_setup "\<lambda>m. bisim_underlying SR r P P' a m" wpc_helper_bisim
wpc_setup "\<lambda>m. bisim_underlying SR r P P' a (m >>= c)" wpc_helper_bisim

lemma bisim_split_refl:
  assumes bs: "\<And>r. bisim R (Q r) (Q' r) (b r) (d r)"
  and    v1: "\<lbrace>S\<rbrace> a \<lbrace>Q\<rbrace>"
  and   v2: "\<lbrace>S'\<rbrace> a \<lbrace>Q'\<rbrace>"
  shows "bisim R S S' (a >>= b) (a >>= d)"
  apply (rule bisim_guard_imp)
  apply (rule bisim_split [OF _ _ v1 v2])
   apply (rule bisim_refl [where P = \<top> and P' = \<top> and R = "(=)", OF refl])
  apply simp
  apply (rule bs)
  apply simp_all
  done

lemma bisim_throwError':
  "f e e' \<Longrightarrow> bisim_underlying SR (f \<oplus> R') P P' (throwError e) (throwError e')"
  apply (rule bisim_underlyingI)
  apply (clarsimp simp: in_monad Bex_def)+
  done

lemmas bisim_throwError = bisim_throwError' [where P = \<top> and P' = \<top>]

lemma bisim_splitE:
  assumes ac: "bisim_underlying SR (f \<oplus> R') P P' a c"
  and     bd: "\<And>r r'. R' r r' \<Longrightarrow> bisim_underlying SR (f \<oplus> R) (Q r) (Q' r') (b r) (d r')"
  and     v1: "\<lbrace>S\<rbrace> a \<lbrace>Q\<rbrace>, -"
  and     v2: "\<lbrace>S'\<rbrace> c \<lbrace>Q'\<rbrace>, -"
  shows "bisim_underlying SR (f \<oplus> R) (P and S) (P' and S') (a >>=E b) (c >>=E d)"
  apply (simp add: bindE_def lift_def[abs_def])
  apply (rule bisim_split [where Q = "\<lambda>r s. case_sum  (\<lambda>_. True) (\<lambda>l. Q l s) r" and Q' = "\<lambda>r s. case_sum  (\<lambda>_. True) (\<lambda>l. Q' l s) r", OF ac, folded validE_def, folded validE_R_def])
  apply (case_tac r')
   apply clarsimp
   apply (erule bisim_throwError')
  apply clarsimp
  apply (erule bd)
  apply (rule v1)
  apply (rule v2)
  done

lemma bisim_split_reflE:
  assumes ab: "\<And>r. bisim (f \<oplus> R) (Q r) (Q' r) (a r) (b r)"
  and     v1: "\<lbrace>S\<rbrace> m \<lbrace>Q\<rbrace>, -"
  and     v2: "\<lbrace>S'\<rbrace> m \<lbrace>Q'\<rbrace>, -"
  and  refls: "\<And>e. f e e" "\<And>r. R r r"
  shows "bisim (f \<oplus> R) S S' (m >>=E a) (m >>=E b)"
  using refls
  apply -
  apply (rule bisim_guard_imp)
  apply (rule bisim_splitE [where R' = "(=)", OF _ _ v1 v2])
  apply (rule bisim_refl)
  apply (case_tac r, simp_all)[1]
  apply simp
  apply (rule ab)
  apply simp+
  done

lemma bisim_split_bind_case_sum:
  "\<lbrakk>bisim_underlying sr (lr \<oplus> rr) P P' a d;
   \<And>rv rv'. lr rv rv' \<Longrightarrow> bisim_underlying sr r (R rv) (R' rv') (b rv) (e rv');
   \<And>rv rv'. rr rv rv' \<Longrightarrow> bisim_underlying sr r (S rv) (S' rv') (c rv) (f rv'); \<lbrace>Q\<rbrace> a \<lbrace>S\<rbrace>, \<lbrace>R\<rbrace>; \<lbrace>Q'\<rbrace> d \<lbrace>S'\<rbrace>, \<lbrace>R'\<rbrace>\<rbrakk>
  \<Longrightarrow> bisim_underlying sr r (P and Q) (P' and Q') (a >>= case_sum b c) (d >>= case_sum e f)"
  apply (erule bisim_split [where Q = "\<lambda>rv s. case_sum (\<lambda>l. R l s) (\<lambda>r. S r s) rv" and Q' = "\<lambda>rv s. case_sum (\<lambda>l. R' l s) (\<lambda>r. S' r s) rv", folded validE_def])
   apply (case_tac r')
    apply clarsimp
   apply clarsimp
  apply assumption+
  done

lemma bisim_liftE [simp]:
  "bisim_underlying SR (f \<oplus> R) P P' (liftE a) (liftE b) = bisim_underlying SR R P P' a b"
  by (fastforce simp: in_monad intro: bisim_underlyingI elim: bisim_underlyingE1  bisim_underlyingE2)

lemma bisim_when:
  assumes bs:  "b \<Longrightarrow> bisim_underlying SR R P P' m m'"
  and     rr: "R () ()"
  shows   "bisim_underlying SR R (\<lambda>s. b \<longrightarrow> P s) (\<lambda>s. b \<longrightarrow> P' s) (when b m) (when b m')"
  using assms
  apply (cases b, simp_all add: when_def)
  apply (erule bisim_return)
  done

(* not really used *)
definition
  "det_on P f \<equiv> \<forall>s. P s \<longrightarrow> (\<exists>r. f s = ({r}, False))"

lemma det_onE:
  "\<lbrakk>det_on P f; P s; \<And>r s'. \<lbrakk> (r, s') \<in> fst (f s); \<not> snd (f s)\<rbrakk> \<Longrightarrow> R \<rbrakk> \<Longrightarrow> R"
  unfolding det_on_def by fastforce

lemma bisim_noop_det_on:
  assumes a: "\<And>s. \<lbrace>Pa and (=) s\<rbrace> a \<lbrace>\<lambda>_. (=) s\<rbrace>"
  and     b: "\<And>s. \<lbrace>Pb and (=) s\<rbrace> b \<lbrace>\<lambda>_. (=) s\<rbrace>"
  and    da: "det_on P a"
  and    db: "det_on P' b"
  shows   "bisim_underlying sr dc (Pa and P) (Pb and P') a b"
  using da db
  apply -
  apply (rule bisim_underlyingI)
  apply clarsimp
  apply (erule (1) det_onE)+
  apply (frule use_valid [OF _ a], fastforce)
  apply (frule use_valid [OF _ b], fastforce)
  apply fastforce

  apply clarsimp
  apply (erule (1) det_onE)+
  apply (frule use_valid [OF _ a], fastforce)
  apply (frule use_valid [OF _ b], fastforce)
  apply fastforce
  done

lemma det_on_gets:
  "det_on \<top> (gets f)" unfolding det_on_def
  by (clarsimp simp: gets_def return_def bind_def get_def)

lemma hoare_gen_asmE':
  "(P \<Longrightarrow> \<lbrace>P'\<rbrace> f \<lbrace>Q\<rbrace>, \<lbrace>R\<rbrace>) \<Longrightarrow> \<lbrace>P' and K P\<rbrace> f \<lbrace>Q\<rbrace>, \<lbrace>R\<rbrace>"
  unfolding validE_def
  by (erule hoare_gen_asm)

lemma det_onE':
  "\<lbrakk>det_on P f; P s; \<And>r s'. \<lbrakk> f s = ({(r, s')}, False)\<rbrakk> \<Longrightarrow> R \<rbrakk> \<Longrightarrow> R"
  unfolding det_on_def by fastforce

(* ugh *)
lemma det_on_guard_imp [wp_comb]:
  assumes da: "det_on P' a"
  and   "\<And>s. P s \<Longrightarrow> P' s"
  shows "det_on P a"
  using assms unfolding det_on_def by auto

lemma det_on_split [wp_split]:
  assumes da: "det_on Pa a"
  and     db: "\<And>x. det_on (Pb x) (b x)"
  and      v: "\<lbrace>Pb'\<rbrace> a \<lbrace>Pb\<rbrace>"
  shows "det_on (Pa and Pb') (a >>= b)"
  unfolding det_on_def using da
  apply -
  apply clarsimp
  apply (erule (1) det_onE)
  apply (frule (1) use_valid [OF _ v])
  apply (erule det_onE' [OF da])
  apply (erule det_onE' [OF db])
  apply (clarsimp simp: bind_def split_def)
  done

lemma det_det_on:
  "det m \<Longrightarrow> det_on \<top> m"
  unfolding det_def det_on_def by auto

lemma det_on_liftE [wp]:
  "det_on P m \<Longrightarrow> det_on P (liftE m)"
  unfolding liftE_def
  apply (rule det_on_guard_imp)
  apply (erule det_on_split [OF _ det_det_on])
   apply simp
  apply wp
  apply simp
  done

lemma det_on_lift [wp]:
  "(\<And>y. det_on (P y) (m y)) \<Longrightarrow> det_on (case_sum (\<lambda>_. \<top>) P x) (lift m x)"
  unfolding lift_def
  by (auto simp: det_on_def throwError_def return_def split: sum.splits)

lemma det_on_assert_opt [wp]:
  "det_on (\<lambda>_. x \<noteq> None) (assert_opt x)"
  unfolding det_on_def assert_opt_def by (fastforce split: option.splits simp: fail_def return_def)

lemmas dets_to_det_on [wp] = det_det_on [OF det_gets] det_det_on [OF return_det]

(* Set up wpc *)
lemma wpc_helper_det_on:
  "det_on Q f \<Longrightarrow> wpc_helper (P, P') (Q, Q') (det_on P f)"
  apply (clarsimp simp: wpc_helper_def det_on_def)
  done

wpc_setup "\<lambda>m. det_on P m" wpc_helper_det_on
wpc_setup "\<lambda>m. det_on P (m >>= c)" wpc_helper_det_on

lemma bisim_symb_exec_r_det_on:
  assumes z: "\<And>rv. bisim_underlying sr r P (Q' rv) x (y rv)"
  assumes y: "\<lbrace>P'\<rbrace> m \<lbrace>Q'\<rbrace>"
  assumes x: "\<And>s. \<lbrace>Pe and (=) s\<rbrace> m \<lbrace>\<lambda>r. (=) s\<rbrace>"
  assumes nf: "det_on Pd m"
  shows      "bisim_underlying sr r P (P' and Pe and Pd) x (m >>= (\<lambda>rv. y rv))"
  apply (rule bisim_guard_imp)
    apply (subst gets_bind_ign [symmetric], rule bisim_split)
      apply (rule bisim_noop_det_on [OF _ x det_on_gets])
      apply (rule hoare_pre, wp)
      apply fastforce
     apply (rule nf)
    apply (rule z)
   apply (wp y)+
  apply simp+
  done

definition
  not_empty :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'b set \<times> bool) \<Rightarrow> bool"
where
  "not_empty P f \<equiv> \<forall>s. P s \<longrightarrow> (fst (f s) \<noteq> {})"

lemma not_emptyE:
  "\<lbrakk> not_empty P f; P s; \<And>r s'. \<lbrakk> (r, s') \<in> fst (f s)\<rbrakk> \<Longrightarrow> R \<rbrakk> \<Longrightarrow> R"
  unfolding not_empty_def by fastforce

(* ugh *)
lemma not_empty_guard_imp [wp_comb]:
  assumes da: "not_empty P' a"
  and   "\<And>s. P s \<Longrightarrow> P' s"
  shows "not_empty P a"
  using assms unfolding not_empty_def by auto

lemma not_empty_split [wp_split]:
  assumes da: "not_empty Pa a"
  and     db: "\<And>x. not_empty (Pb x) (b x)"
  and      v: "\<lbrace>Pb'\<rbrace> a \<lbrace>Pb\<rbrace>"
  shows "not_empty (Pa and Pb') (a >>= b)"
  unfolding not_empty_def using da
  apply -
  apply clarsimp
  apply (erule (1) not_emptyE)
  apply (frule (1) use_valid [OF _ v])
  apply (erule not_emptyE [OF da])
  apply (erule not_emptyE [OF db])
  apply (fastforce simp: bind_def split_def)
  done

lemma not_empty_return [wp]:
  "not_empty \<top> (return x)"
  unfolding not_empty_def
  by (simp add: return_def)

lemma not_empty_liftE [wp]:
  assumes ne: "not_empty P m"
  shows "not_empty P (liftE m)"
  unfolding liftE_def
  apply (rule not_empty_guard_imp)
  apply (wp ne)
  apply simp
  done

lemma not_empty_lift [wp]:
  "(\<And>y. not_empty (P y) (m y)) \<Longrightarrow> not_empty (case_sum (\<lambda>_. \<top>) P x) (lift m x)"
  unfolding lift_def
  by (auto simp: not_empty_def throwError_def return_def split: sum.splits)

lemma not_empty_assert_opt [wp]:
  "not_empty (\<lambda>_. x \<noteq> None) (assert_opt x)"
  unfolding not_empty_def assert_opt_def by (fastforce split: option.splits simp: fail_def return_def)

lemma not_empty_gets [wp]:
  "not_empty \<top> (gets f)" unfolding not_empty_def
  by (clarsimp simp: gets_def return_def bind_def get_def)

(* Set up wpc *)
lemma wpc_helper_not_empty:
  "not_empty Q f \<Longrightarrow> wpc_helper (P, P') (Q, Q') (not_empty P f)"
  apply (clarsimp simp: wpc_helper_def not_empty_def)
  done

wpc_setup "\<lambda>m. not_empty P m" wpc_helper_not_empty
wpc_setup "\<lambda>m. not_empty P (m >>= c)" wpc_helper_not_empty

lemma bisim_noop:
  assumes a: "\<And>s. \<lbrace>Pa and (=) s\<rbrace> a \<lbrace>\<lambda>_. (=) s\<rbrace>"
  and     b: "\<And>s. \<lbrace>Pb and (=) s\<rbrace> b \<lbrace>\<lambda>_. (=) s\<rbrace>"
  and    da: "not_empty P a"
  and    db: "not_empty P' b"
  shows   "bisim_underlying sr dc (Pa and P) (Pb and P') a b"
  using da db
  apply -
  apply (rule bisim_underlyingI)
  apply clarsimp
  apply (erule (1) not_emptyE)+
  apply (frule use_valid [OF _ a], fastforce)
  apply (frule use_valid [OF _ b], fastforce)
  apply fastforce

  apply clarsimp
  apply (erule (1) not_emptyE)+
  apply (frule use_valid [OF _ a], fastforce)
  apply (frule use_valid [OF _ b], fastforce)
  apply fastforce
  done

lemma bisim_symb_exec_r:
  assumes  z: "\<And>rv. bisim_underlying sr r P (Q' rv) x (y rv)"
  assumes  y: "\<lbrace>P'\<rbrace> m \<lbrace>Q'\<rbrace>"
  assumes  x: "\<And>s. \<lbrace>Pe and (=) s\<rbrace> m \<lbrace>\<lambda>r. (=) s\<rbrace>"
  assumes ne: "not_empty Pd m"
  shows      "bisim_underlying sr r P (P' and Pe and Pd) x (m >>= (\<lambda>rv. y rv))"
  apply (rule bisim_guard_imp)
    apply (subst gets_bind_ign [symmetric], rule bisim_split)
      apply (rule bisim_noop [OF _ x not_empty_gets])
      apply (rule hoare_pre, wp)
      apply fastforce
     apply (rule ne)
    apply (rule z)
   apply (wp y)+
  apply simp+
  done

lemma bisim_not_empty:
  assumes bs: "bisim r P P' m m'"
  and     ne: "not_empty R m"
  shows   "not_empty (P and P' and R) m'"
  unfolding not_empty_def using bs ne
  apply clarsimp
  apply (erule (1) not_emptyE)
  apply (erule_tac s=s and s'=s in bisim_underlyingE1 [where SR = "(=)"])
      apply simp+
  done

lemma bisim_split_req:
  assumes ac: "bisim (=) P P' a c"
  and     bd: "\<And>r. bisim R (Q r) (Q' r) (b r) (d r)"
  and     v1: "\<lbrace>S\<rbrace> a \<lbrace>\<lambda>r. Q r and Q' r\<rbrace>"
  shows "bisim R (P and S) P' (a >>= b) (c >>= d)"
  using ac
  apply -
  apply (rule bisim_underlyingI)
   apply (clarsimp simp: in_monad split_def)
   apply (erule bisim_underlyingE1)
    apply simp
    apply assumption+
   apply (frule (1) use_valid [OF _ v1])
   apply clarsimp
   apply (rule bisim_underlyingE1 [OF bd])
    apply simp
    apply assumption+
   apply (rename_tac r'' t'')
   apply (rule_tac x = "(r'', t'')" in bexI)
    apply clarsimp
   apply (fastforce simp: in_monad)

   apply (clarsimp simp: in_monad split_def)
   apply (erule bisim_underlyingE2)
    apply simp
    apply assumption+
   apply (frule (1) use_valid [OF _ v1])
   apply clarsimp
   apply (rule bisim_underlyingE2 [OF bd])
    apply simp
    apply assumption+
   apply (rename_tac r'' t'')
   apply (rule_tac x = "(r'', t'')" in bexI)
    apply clarsimp
   apply (fastforce simp: in_monad)
  done

lemma bisim_splitE_req:
  assumes ac: "bisim (f \<oplus> (=)) P P' a c"
  and     bd: "\<And>r. bisim (f \<oplus> R) (Q r) (Q' r) (b r) (d r)"
  and     v1: "\<lbrace>S\<rbrace> a \<lbrace>\<lambda>r. Q r and Q' r\<rbrace>, -"
  shows "bisim (f \<oplus> R) (P and S) P' (a >>=E b) (c >>=E d)"
  using ac
  apply -
  apply (simp add: bindE_def lift_def[abs_def])
  apply (rule bisim_underlyingI)
   apply (clarsimp simp: in_monad split_def)
   apply (erule bisim_underlyingE1)
    apply simp
    apply assumption+
   apply (frule (1) use_valid [OF _ v1 [unfolded validE_R_def validE_def]])
   apply clarsimp
   apply (case_tac x)
    apply (clarsimp simp: in_monad)
    apply (rule_tac x = "(Inl y', t')" in bexI)
    apply fastforce
   apply (fastforce simp: in_monad)
   apply clarsimp
   apply (rule bisim_underlyingE1 [OF bd])
    apply simp
    apply assumption+
   apply (rename_tac r'' t'')
   apply (rule_tac x = "(r'', t'')" in bexI)
    apply clarsimp
   apply (fastforce simp: in_monad)

   apply (clarsimp simp: in_monad split_def)
   apply (erule bisim_underlyingE2)
    apply simp
    apply assumption+
   apply (frule (1) use_valid [OF _ v1 [unfolded validE_R_def validE_def]])
   apply clarsimp
   apply (case_tac r)
    apply (clarsimp simp: in_monad)
    apply (rule_tac x = "(Inl aa, s'')" in bexI)
    apply fastforce
   apply (fastforce simp: in_monad)
   apply clarsimp
   apply (rule bisim_underlyingE2 [OF bd])
    apply simp
    apply assumption+
   apply (rename_tac r'' t'')
   apply (rule_tac x = "(r'', t'')" in bexI)
    apply clarsimp
   apply (fastforce simp: in_monad)
  done

lemma bisim_symb_exec_r_bs:
  assumes bs: "bisim (=) R R' (return ()) m"
  and      z: "\<And>rv. bisim r P P' x (y rv)"
  shows      "bisim r (P and R and P') R' x (m >>= (\<lambda>rv. y rv))"
  apply (rule bisim_guard_imp)
    apply (subst return_bind [symmetric, where f = "\<lambda>(_ :: unit).x"],  rule bisim_split_req)
    apply (rule bs)
     apply (rule z)
     apply wp
   apply simp
  apply simp+
  done

end