section \<open> Hybrid Reactive Designs \<close>

theory utp_hrd
  imports
    "UTP1-Reactive-Designs.utp_rea_designs"
    utp_differential
begin

subsection \<open> Constructs \<close>

text \<open> Lift an arbitrary hybrid relation to the peri condition of a reactive design. Usually used
  to specify constraints on continuous variables. \<close>

definition hrdPred :: "('d,'c::topological_space) hyrel \<Rightarrow> ('d,'c) hyrel" ("[_]\<^sub>H") where
[upred_defs, rdes_def]: "hrdPred P = \<^bold>R\<^sub>s(true\<^sub>r \<turnstile> P \<diamondop> false)"

definition hrdEvolve :: "('a::t2_space \<Longrightarrow> 'c::t2_space) \<Rightarrow> (real \<Rightarrow> ('a, 'c) hexpr) \<Rightarrow> ('d,'c) hyrel" where
[upred_defs, rdes_def]: "hrdEvolve x f = \<^bold>R\<^sub>s(true\<^sub>r \<turnstile> x \<leftarrow>\<^sub>h f(ti) \<diamondop> false)"

definition hrdEvolveBounds ::
  "('a::t2_space \<Longrightarrow> 'c::t2_space) \<Rightarrow>
   (real, 'd \<times> 'c) uexpr \<Rightarrow>
   (real, 'd \<times> 'c) uexpr \<Rightarrow>
   (real \<Rightarrow> ('a, 'c) hexpr) \<Rightarrow>
   ('d,'c) hyrel" where
[upred_defs, rdes_def]: "hrdEvolveBounds x l u f = \<^bold>R\<^sub>s(true\<^sub>r \<turnstile> (x \<leftarrow>\<^sub>h\<le>(u) f(ti)) \<diamondop> ((x \<leftarrow>[l,u]\<^sub>h f(ti)) \<triangleleft> (u >\<^sub>u 0) \<triangleright>\<^sub>R II\<^sub>r))"

text \<open> Evolve according to a continuous function for a definite time length. Currently this
  duplicates the state where t = l as the pre-emption operator does as well. \<close>

abbreviation hrdEvolveTil :: "('a::t2_space \<Longrightarrow> 'c::t2_space) \<Rightarrow> (real, 'd \<times> 'c) uexpr \<Rightarrow> (real \<Rightarrow> ('a, 'c) hexpr) \<Rightarrow> ('d,'c) hyrel" where
"hrdEvolveTil x t f \<equiv> hrdEvolveBounds x t t f"

definition hrdUntil :: "('d, 'c::t2_space) hyrel \<Rightarrow> (real \<Rightarrow> 'c hrel) \<Rightarrow> (real \<Rightarrow> 'c hrel) \<Rightarrow> ('d,'c) hyrel"
  where [upred_defs]:
"hrdUntil P b c = \<^bold>R\<^sub>s(pre\<^sub>R(P) \<turnstile> (peri\<^sub>R(P) \<and> \<lceil>b(ti)\<rceil>\<^sub>h) \<diamondop> (post\<^sub>R(P) \<or> hUntil (peri\<^sub>R(P)) b c))"

definition hrdPreempt_nz ::
    "('d, 'c::t2_space) hyrel \<Rightarrow> (real \<Rightarrow> 'c hrel) \<Rightarrow> (real \<Rightarrow> 'c hrel) \<Rightarrow>
    ('d,'c) hyrel \<Rightarrow> ('d,'c) hyrel" where
[upred_defs]: "hrdPreempt_nz P b c Q = (hrdUntil P b c) ;; Q"

definition hrdPreempt ::
    "('d, 'c::t2_space) hyrel \<Rightarrow> (real \<Rightarrow> 'c hrel) \<Rightarrow> (real \<Rightarrow> 'c hrel) \<Rightarrow>
    ('d,'c) hyrel \<Rightarrow> ('d,'c) hyrel" where
[upred_defs]: "hrdPreempt P b c Q = (Q \<triangleleft> (\<^bold>\<exists> l \<bullet> \<guillemotleft>l\<guillemotright> =\<^sub>u \<^bold>l \<and> \<lceil>b(l)\<lbrakk>$\<^bold>v/$\<^bold>v\<acute>\<rbrakk>\<rceil>\<^sub>C) \<triangleright> (hrdPreempt_nz P b c Q))"

definition hrdODE ::
  "('a::ordered_euclidean_space \<Longrightarrow> 'c::t2_space) \<Rightarrow>
   'a ODE \<Rightarrow> ('d, 'c) hyrel" where
[upred_defs, rdes_def]: "hrdODE x \<F>' = \<^bold>R\<^sub>s(true\<^sub>r \<turnstile> \<langle>x \<bullet> \<F>'(ti)\<rangle>\<^sub>h \<diamondop> false)"

subsection \<open> Syntax Translations \<close>

syntax
  "_hrdEvolve"       :: "salpha \<Rightarrow> logic \<Rightarrow> logic" ("_ \<leftarrow>\<^sub>H _" [90,91] 90)
  "_hrdEvolveBounds" :: "salpha \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic" ("_ \<leftarrow>[_,_]\<^sub>H _" [90,0,0,91] 90)
  "_hrdEvolveTil"    :: "salpha \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic" ("_ \<leftarrow>\<^sub>H'(_') _" [90,0,91] 90)
  "_hrdODE"          :: "salpha \<Rightarrow> logic \<Rightarrow> logic" ("\<langle>_ \<bullet> _\<rangle>\<^sub>H")
  "_hrdUntil_inv"  :: "logic \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic" ("_ inv _ until\<^sub>H _" [74,0,75] 74)
  "_hrdUntil"      :: "logic \<Rightarrow> logic \<Rightarrow> logic" ("_ until\<^sub>H _" [74,75] 74)
  "_hrdPreempt_nz" :: "logic \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic" ("_ [_|_]\<^sub>H\<^sup>+ _" [64,0,0,65] 64)
  "_hrdPreempt"    :: "logic \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic" ("_ [_|_]\<^sub>H _" [64,0,0,65] 64)

translations
  "_hrdEvolve a f" => "CONST hrdEvolve a (\<lambda> _time_var. f)"
  "_hrdEvolve a f" <= "CONST hrdEvolve a (\<lambda> ti. f)"
  "_hrdEvolveBounds a l u f" => "CONST hrdEvolveBounds a l u (\<lambda> _time_var. f)"
  "_hrdEvolveBounds a l u f" <= "CONST hrdEvolveBounds a l u (\<lambda> ti. f)"
  "_hrdEvolveTil a t f" => "CONST hrdEvolveTil a t (\<lambda> _time_var. f)"
  "_hrdEvolveTil a t f" <= "CONST hrdEvolveTil a t (\<lambda> ti. f)"
  "_hrdODE a P" => "CONST hrdODE a (\<lambda> _time_var. P)"
  "_hrdODE a P" <= "CONST hrdODE a (\<lambda> t. P)"
  "_hrdUntil_inv P b c" => "CONST hrdUntil P (\<lambda> _time_var. b) (\<lambda> _time_var. c)"
  "_hrdUntil_inv P b c" <= "CONST hrdUntil P (\<lambda> t. b) (\<lambda> t'. c)"
  "_hrdUntil P b"       => "CONST hrdUntil P (\<lambda> _time_var. \<not> b) (\<lambda> _time_var. b)"
  "_hrdPreempt_nz P b c Q" => "CONST hrdPreempt_nz P (\<lambda> _time_var. b) (\<lambda> _time_var. c) Q"
  "_hrdPreempt_nz P b c Q" <= "CONST hrdPreempt_nz P (\<lambda> t. b) (\<lambda> t'. c) Q"
  "_hrdPreempt P b c Q" => "CONST hrdPreempt P (\<lambda> _time_var. b) (\<lambda> _time_var. c) Q"
  "_hrdPreempt P b c Q" <= "CONST hrdPreempt P (\<lambda> t. b) (\<lambda> t'. c) Q"

subsection \<open> Contract Calculations \<close>

lemma preR_hrdPred [rdes]: "pre\<^sub>R([P]\<^sub>H) = true\<^sub>r"
  by (rel_auto)

lemma periR_hrdPred [rdes]:
  "P is RR \<Longrightarrow> peri\<^sub>R([P]\<^sub>H) = P"
  by (simp add: hrdPred_def rdes closure rpred)

lemma postR_hrdPred [rdes]:
  "P is RR \<Longrightarrow> post\<^sub>R([P]\<^sub>H) = false"
  by (simp add: hrdPred_def rdes closure rpred)

lemma preR_hrdEvolve [rdes]: "pre\<^sub>R(x \<leftarrow>\<^sub>H f(ti)) = true\<^sub>r"
  by (rel_auto)

lemma periR_hrdEvolve [rdes]: "peri\<^sub>R(x \<leftarrow>\<^sub>H f(ti)) = (x \<leftarrow>\<^sub>h f(ti))"
  by (rel_auto)

lemma postR_hrdEvolve [rdes]: "post\<^sub>R(x \<leftarrow>\<^sub>H f(ti)) = false"
  by (rel_auto)

lemma preR_hrdEvolveBounds [rdes]: "pre\<^sub>R(x \<leftarrow>[l,u]\<^sub>H f(ti)) = true\<^sub>r"
  by (rel_auto)

lemma periR_hrdEvolveBounds [rdes]: "peri\<^sub>R(x \<leftarrow>[l,u]\<^sub>H f(ti)) = (x \<leftarrow>\<^sub>h\<le>(u) f(ti)) "
  by (rel_auto)

declare minus_zero_eq [dest]

lemma postR_hrdEvolveBounds [rdes]:
  "post\<^sub>R(x \<leftarrow>[l,u]\<^sub>H f(ti)) = ((x \<leftarrow>[l,u]\<^sub>h f(ti)) \<triangleleft> (u >\<^sub>u 0) \<triangleright>\<^sub>R II\<^sub>r)"
  by (rel_auto)

lemma preR_hrdODE [rdes]:
  "pre\<^sub>R(\<langle>x \<bullet> \<F>'(ti)\<rangle>\<^sub>H) = true\<^sub>r"
  by (simp add: hrdODE_def rdes closure)

lemma periR_hrdODE [rdes]:
  "peri\<^sub>R(\<langle>x \<bullet> \<F>'(ti)\<rangle>\<^sub>H) = \<langle>x \<bullet> \<F>'(ti)\<rangle>\<^sub>h"
  by (simp add: hrdODE_def rdes closure rpred)

lemma postR_hrdODE [rdes]:
  "post\<^sub>R(\<langle>x \<bullet> \<F>'(ti)\<rangle>\<^sub>H) = false"
  by (simp add: hrdODE_def rdes closure rpred)

lemma hrdUntil_rdes_def [rdes_def]:
  assumes "P\<^sub>1 is RR" "P\<^sub>2 is RR" "P\<^sub>3 is RR"
  shows "\<^bold>R\<^sub>s(P\<^sub>1 \<turnstile> P\<^sub>2 \<diamondop> P\<^sub>3) inv b(ti) until\<^sub>H c(ti) =
         \<^bold>R\<^sub>s(P\<^sub>1 \<turnstile> (P\<^sub>2 \<and> \<lceil>b(ti)\<rceil>\<^sub>h) \<diamondop> (P\<^sub>3 \<or> P\<^sub>2 inv b(ti) until\<^sub>h c(ti)))"
  by (simp add: hrdUntil_def rdes assms, rel_auto)

lemma preR_hrdUntil [rdes]:
  "P is SRD \<Longrightarrow> pre\<^sub>R(P inv b(ti) until\<^sub>H c(ti)) = pre\<^sub>R(P)"
  by (simp add: hrdUntil_def rea_pre_RHS_design unrest usubst R1_R2c_is_R2 preR_R2_closed Healthy_if SRD_healths)

lemma periR_hrdUntil [rdes]:
  "P is NSRD \<Longrightarrow> peri\<^sub>R(P inv b(ti) until\<^sub>H c(ti)) = (pre\<^sub>R P \<Rightarrow>\<^sub>r peri\<^sub>R(P) \<and> \<lceil>b(ti)\<rceil>\<^sub>h)"
  by (simp add: hrdUntil_def rea_peri_RHS_design unrest usubst impl_alt_def
      NSRD_is_SRD R1_disj R1_extend_conj' R1_hInt  R2c_and R2c_disj
      R2c_not R2c_peri_SRD R2s_hInt  R1_rea_impl R2c_preR R2c_rea_impl)

lemma postR_hrdUntil [rdes]:
  "P is NSRD \<Longrightarrow>
   post\<^sub>R(P inv b(ti) until\<^sub>H c(ti)) =
  (pre\<^sub>R P \<Rightarrow>\<^sub>r (post\<^sub>R(P) \<or> (peri\<^sub>R(P) inv b(ti) until\<^sub>h c(ti))))"
  by (simp add: hrdUntil_def rdes closure unrest)

text \<open> It should be possible to simplify this surely. \<close>

lemma hrdPreempt_nz_rdes_def [rdes_def]:
  assumes "P\<^sub>1 is RC" "P\<^sub>2 is RR" "$st\<acute> \<sharp> P\<^sub>2" "P\<^sub>3 is RR" "Q\<^sub>1 is RR" "Q\<^sub>2 is RR" "Q\<^sub>3 is RR"
  shows "(\<^bold>R\<^sub>s(P\<^sub>1 \<turnstile> P\<^sub>2 \<diamondop> P\<^sub>3) [b(ti)|c(ti)]\<^sub>H\<^sup>+ \<^bold>R\<^sub>s(Q\<^sub>1 \<turnstile> Q\<^sub>2 \<diamondop> Q\<^sub>3)) =
          \<^bold>R\<^sub>s ( (P\<^sub>1 \<and> (P\<^sub>3 \<or> P\<^sub>2 inv b(ti) until\<^sub>h c(ti)) wp\<^sub>r Q\<^sub>1)
             \<turnstile> (P\<^sub>2 \<and> hInt b \<or> (P\<^sub>3 \<or> P\<^sub>2 inv b(ti) until\<^sub>h c(ti)) ;; Q\<^sub>2)
             \<diamondop> (P\<^sub>3 \<or> P\<^sub>2 inv b(ti) until\<^sub>h c(ti)) ;; Q\<^sub>3)"
  by (simp add: hrdPreempt_nz_def rdes_def assms closure unrest)

subsection \<open> Closure Laws \<close>

lemma hrdPred_NSRD [closure]:
  "\<lbrakk> P is RR; $st\<acute> \<sharp> P \<rbrakk> \<Longrightarrow> [P]\<^sub>H is NSRD"
  by (simp add: hrdPred_def closure unrest)

lemma hrdEvolve_SRD [closure]: "x \<leftarrow>\<^sub>H f(ti) is SRD"
  by (simp add: hrdEvolve_def init_cont_def closure unrest)

lemma hrdEvolve_NSRD [closure]: "x \<leftarrow>\<^sub>H f(ti) is NSRD"
  by (rule NSRD_intro, simp_all add: init_cont_def rdes closure unrest)

lemma hrdEvolveBounds_SRD [closure]: "x \<leftarrow>[l,u]\<^sub>H f(ti) is SRD"
  by (simp add: hrdEvolveBounds_def init_cont_def final_cont_def closure unrest)

lemma hrdEvolveBounds_NSRD [closure]: "x \<leftarrow>[l,u]\<^sub>H f(ti) is NSRD"
  by (rule NSRD_intro, simp_all add: init_cont_def final_cont_def rdes closure unrest)

lemma hrdODE_SRD [closure]: "\<langle>x \<bullet> \<F>'(ti)\<rangle>\<^sub>H is SRD"
  by (simp add: hrdODE_def closure unrest)

lemma hrdODE_NSRD [closure]: "\<langle>x \<bullet> \<F>'(ti)\<rangle>\<^sub>H is NSRD"
  by (simp add: hrdODE_def closure unrest)

lemma hrdUntil_SRD [closure]: "P is SRD \<Longrightarrow> P inv b(ti) until\<^sub>H c(ti) is SRD"
  by (simp add: hrdUntil_def closure unrest)

lemma hrdUntil_NSRD [closure]: "P is NSRD \<Longrightarrow> P inv b(ti) until\<^sub>H c(ti) is NSRD"
  by (rule NSRD_intro, simp_all add: closure rdes unrest NSRD_neg_pre_unit)

lemma hrdPreempt_nz_NSRD [closure]:
  assumes "P is NSRD" "Q is NSRD"
  shows "P [b|c]\<^sub>H\<^sup>+ Q is NSRD"
  by (simp add: hrdPreempt_nz_def closure assms)

subsection \<open> Algebraic Laws \<close>

lemma hrdPred_non_term:
  assumes "P is RR" "$st\<acute> \<sharp> P" "Q is SRD"
  shows "[P]\<^sub>H ;; Q = [P]\<^sub>H"
  by (simp add: NSRD_is_SRD NSRD_seq_post_false assms hrdPred_NSRD postR_hrdPred)

lemma hrdPred_conj: "([P]\<^sub>H \<and> [Q]\<^sub>H) = [P \<and> Q]\<^sub>H"
  by (rel_auto)

lemma hrdPred_hEvolve: "[x \<leftarrow>\<^sub>h f(ti)]\<^sub>H = x \<leftarrow>\<^sub>H f(ti)"
  by (simp add: hrdEvolve_def hrdPred_def)

lemma hrdEvolve_non_term [simp]:
  assumes "P is SRD"
  shows "(x \<leftarrow>\<^sub>H f(ti)) ;; P = (x \<leftarrow>\<^sub>H f(ti))"
  by (simp add: NSRD_is_SRD NSRD_seq_post_false assms hrdEvolve_NSRD postR_hrdEvolve)

lemma hrdEvolve_conj [simp]:
  "(x \<leftarrow>\<^sub>H f(ti) \<and> y \<leftarrow>\<^sub>H g(ti)) = {&x, &y} \<leftarrow>\<^sub>H (f ti, g ti)\<^sub>u"
  by (simp add: rdes_def rpred closure)

lemma hrdUntil_false:
  assumes "P is SRD"
  shows "P inv true until\<^sub>H false = P"
proof -
  have "(peri\<^sub>R P \<and> \<lceil>true\<rceil>\<^sub>h) = peri\<^sub>R P"
    by (metis R1_extend_conj' R1_peri_SRD assms hInt_true utp_pred_laws.inf_top_right)
  thus ?thesis
    by (simp add: hUntil_false hrdUntil_def alpha SRD_reactive_tri_design assms)
qed

lemma hrdUntil_true:
  assumes "P is SRD"
  shows "P until\<^sub>H true = \<^bold>R\<^sub>s(pre\<^sub>R P \<turnstile> (peri\<^sub>R P \<and> $tr\<acute> =\<^sub>u $tr) \<diamondop> (post\<^sub>R P))"
  by (simp add: hrdUntil_def hInt_false alpha, rel_auto)

text \<open> This isn't quite right; if $P$ terminates $Q$ should not be enabled. However, since for
  what we do $P$ actually never terminates this is fine for now but should be fixed later. \<close>

lemma hrdPreempt_nz_false:
  assumes "P is NSRD" "Q is NSRD"
  shows "(P [true|false]\<^sub>H\<^sup>+ Q) = P ;; Q"
  by (simp add: hrdPreempt_nz_def hrdUntil_false assms closure)

lemma hrdIntF_zero: "x \<leftarrow>\<^sub>H(0) f(ti) = II\<^sub>R"
  by (simp add: hrdEvolveBounds_def alpha, rel_auto)

theorem hrdODE_solution:
  assumes
    "vwb_lens x" "\<forall> x. \<forall> l > 0. (\<F>(x) usolves_ode \<F>' from 0) {0..l} UNIV" "\<forall> x. \<F>(x)(0) = x"
  shows "\<langle>x \<bullet> \<F>'(ti)\<rangle>\<^sub>H = x \<leftarrow>\<^sub>H \<guillemotleft>\<F>\<guillemotright>($x)\<^sub>a(\<guillemotleft>ti\<guillemotright>)\<^sub>a"
  by (rule SRD_eq_intro, simp_all add: closure assms rdes rpred ode_solution)

theorem hrdUntil_inv_solve:
  assumes
    "vwb_lens x" "0 < k" "k \<le> l" "continuous_on {0..l} f" "continuous_on UNIV get\<^bsub>x\<^esub>"
    "\<forall> t \<in> {0..<l}. b\<lbrakk>\<guillemotleft>f(t)\<guillemotright>/$x\<acute>\<rbrakk> = true" "b\<lbrakk>\<guillemotleft>f(l)\<guillemotright>/$x\<acute>\<rbrakk> = false"
    "\<forall> t \<in> {0..<k}. c\<lbrakk>\<guillemotleft>f(t)\<guillemotright>/$x\<acute>\<rbrakk> = false" "\<forall> t \<in> {k..l}. c\<lbrakk>\<guillemotleft>f(t)\<guillemotright>/$x\<acute>\<rbrakk> = true"
  shows "(x \<leftarrow>\<^sub>H \<guillemotleft>f(ti)\<guillemotright>) inv b until\<^sub>H c = x \<leftarrow>[\<guillemotleft>k\<guillemotright>,\<guillemotleft>l\<guillemotright>]\<^sub>H \<guillemotleft>f(ti)\<guillemotright>"
proof (rule SRD_eq_intro, simp_all add: closure assms rdes rpred)
  from assms(6-9)
  have a:
    "\<forall>t\<in>{0..<l}. \<forall>s s'. \<lbrakk>b\<rbrakk>\<^sub>e (s, put\<^bsub>x\<^esub> s' (f t))"
    "\<forall>s s'. \<not> \<lbrakk>b\<rbrakk>\<^sub>e (s, put\<^bsub>x\<^esub> s' (f l))"
    "\<forall>t\<in>{0..<k}. \<forall>s s'. \<not> \<lbrakk>c\<rbrakk>\<^sub>e (s, put\<^bsub>x\<^esub> s' (f t))"
    "\<forall>t\<in>{k..l}. \<forall>s s'. \<lbrakk>c\<rbrakk>\<^sub>e (s, put\<^bsub>x\<^esub> s' (f t))"
    by (rel_auto)+
  show "(x \<leftarrow>\<^sub>h \<guillemotleft>f ti\<guillemotright> \<and> \<lceil>b\<rceil>\<^sub>h) = x \<leftarrow>\<^sub>h\<le>(\<guillemotleft>l\<guillemotright>) \<guillemotleft>f ti\<guillemotright>" (is "?lhs = ?rhs")
  proof (rule antisym)
    show "?lhs \<sqsubseteq> ?rhs"
    proof (rel_simp)
      fix tr tr' s t
      assume b:
        "tr < tr'"
        "end\<^sub>t (tr' - tr) \<le> l"
        "\<forall>t. 0 \<le> t \<and> t < end\<^sub>t (tr' - tr) \<longrightarrow> get\<^bsub>x\<^esub> (\<langle>tr'\<rangle>\<^sub>t(t + end\<^sub>t tr)) = f t"
        "0 \<le> t" "t < end\<^sub>t (tr' - tr)"
      from a(1) b(2,4-5) have "\<lbrakk>b\<rbrakk>\<^sub>e (s, put\<^bsub>x\<^esub> (\<langle>tr'\<rangle>\<^sub>t(t + end\<^sub>t tr)) (f t))"
        by (auto)
      moreover have "put\<^bsub>x\<^esub> (\<langle>tr'\<rangle>\<^sub>t(t + end\<^sub>t tr)) (f t) = (\<langle>tr'\<rangle>\<^sub>t(t + end\<^sub>t tr))"
        by (metis assms(1) b(3) b(4) b(5) vwb_lens.put_eq)
      ultimately show "\<lbrakk>b\<rbrakk>\<^sub>e (s, \<langle>tr'\<rangle>\<^sub>t(t + end\<^sub>t tr))"
        by simp
    qed
    show "?rhs \<sqsubseteq> ?lhs"
    proof (rel_simp)
      fix tr tr' s t
      assume b:
        "tr < tr'"
        "\<forall>t. 0 \<le> t \<and> t < end\<^sub>t (tr' - tr) \<longrightarrow> get\<^bsub>x\<^esub> (\<langle>tr'\<rangle>\<^sub>t(t + end\<^sub>t tr)) = f t"
        "\<forall>t. 0 \<le> t \<and> t < end\<^sub>t (tr' - tr) \<longrightarrow> \<lbrakk>b\<rbrakk>\<^sub>e (s, \<langle>tr'\<rangle>\<^sub>t(t + end\<^sub>t tr))"
      have 1:"\<not> \<lbrakk>b\<rbrakk>\<^sub>e (s, put\<^bsub>x\<^esub> (\<langle>tr'\<rangle>\<^sub>t(t + end\<^sub>t tr)) (f l))"
        using a(2) by auto
      show "end\<^sub>t (tr' - tr) \<le> l"
      proof (rule ccontr)
        assume l: "\<not> end\<^sub>t (tr' - tr) \<le> l"
        with assms(2-3) b(3) have 1:"\<lbrakk>b\<rbrakk>\<^sub>e (s, (\<langle>tr'\<rangle>\<^sub>t(l + end\<^sub>t tr)))"
          by (auto)
        have "get\<^bsub>x\<^esub> (\<langle>tr'\<rangle>\<^sub>t (l + end\<^sub>t tr)) = f l"
          using assms(2) assms(3) b(2) l by auto
        hence "put\<^bsub>x\<^esub> (\<langle>tr'\<rangle>\<^sub>t (l + end\<^sub>t tr)) (f l) = (\<langle>tr'\<rangle>\<^sub>t (l + end\<^sub>t tr))"
          by (metis assms(1) vwb_lens.put_eq)
        hence "\<not> \<lbrakk>b\<rbrakk>\<^sub>e (s, (\<langle>tr'\<rangle>\<^sub>t (l + end\<^sub>t tr)))"
          by (metis a(2))
        with 1 show False
          by auto
      qed
    qed
  qed
  show "x \<leftarrow>\<^sub>h \<guillemotleft>f ti\<guillemotright> inv b until\<^sub>h c = x \<leftarrow>[\<guillemotleft>k\<guillemotright>,\<guillemotleft>l\<guillemotright>]\<^sub>h \<guillemotleft>f ti\<guillemotright> \<triangleleft> (0 <\<^sub>u \<guillemotleft>l\<guillemotright>) \<triangleright>\<^sub>R II\<^sub>r" (is "?lhs = ?rhs")
  proof -
    have "?lhs = x \<leftarrow>[\<guillemotleft>k\<guillemotright>,\<guillemotleft>l\<guillemotright>]\<^sub>h \<guillemotleft>f ti\<guillemotright>"
      by (rule hUntil_inv_solve, simp_all add: assms)
    with assms(2-3) show ?thesis
      by (simp, rel_auto)
  qed
qed

lemma hrdUntil_solve:
  assumes
    "vwb_lens x" "k > 0" "continuous_on {0..k} f" "continuous_on UNIV get\<^bsub>x\<^esub>"
    "\<forall> t \<in> {0..<k}. c\<lbrakk>\<guillemotleft>f(t)\<guillemotright>/$x\<acute>\<rbrakk> = false" "c\<lbrakk>\<guillemotleft>f(k)\<guillemotright>/$x\<acute>\<rbrakk> = true"
  shows "(x \<leftarrow>\<^sub>H \<guillemotleft>f(ti)\<guillemotright>) until\<^sub>H c = x \<leftarrow>\<^sub>H(\<guillemotleft>k\<guillemotright>) \<guillemotleft>f(ti)\<guillemotright>"
  using assms
  by (rule_tac hrdUntil_inv_solve, simp_all, rel_auto+)

subsection \<open> Stepping a Hybrid Reactive Design \<close>

definition hrdStepRel :: "real \<Rightarrow> ('d, 'c::t2_space) hyrel \<Rightarrow> 'c hrel" ("Step[_]\<^sub>H") where
[upred_defs]: "Step[t]\<^sub>H P = HyStep[t](peri\<^sub>R(P))"

lemma hrdStep_hrdEvolve:
  assumes "n > 0" "continuous_on {0..n} f"
  shows "Step[n]\<^sub>H(&\<^bold>v \<leftarrow>\<^sub>H \<guillemotleft>f(ti)\<guillemotright>) = (\<^bold>v := \<guillemotleft>f n\<guillemotright>)"
  by (simp add: hrdStepRel_def rdes assms HyStep_hEvolve)

(*
lemma tt_eq_iff_end_same:
  "\<lbrakk> s \<le> t; end\<^sub>t(s) = end\<^sub>t(t) \<rbrakk> \<Longrightarrow> s = t"
  using tt_end_minus by fastforce

lemma hrdStep_hrdEvolveAt_le:
  fixes P :: "('d, 'c::t2_space) hyrel"
  assumes "n > 0" "l \<ge> n" "continuous_on {0..n} f" "P is NSRD" "pre\<^sub>R(P) = true\<^sub>r"
  shows "Step[n]\<^sub>H(&\<^bold>v \<leftarrow>\<^sub>H(\<guillemotleft>l\<guillemotright>) \<guillemotleft>f(ti)\<guillemotright> ;; P) = (\<^bold>v := \<guillemotleft>f n\<guillemotright>)"
proof -
  from assms(1,2)
  have 1:"peri\<^sub>R(&\<^bold>v \<leftarrow>\<^sub>H(\<guillemotleft>l\<guillemotright>) \<guillemotleft>f(ti)\<guillemotright> ;; P) = (&\<^bold>v \<leftarrow>\<^sub>h\<le>(\<guillemotleft>l\<guillemotright>) \<guillemotleft>f ti\<guillemotright> \<or> &\<^bold>v \<leftarrow>\<^sub>h(\<guillemotleft>l\<guillemotright>) \<guillemotleft>f ti\<guillemotright> ;; RR(peri\<^sub>R P))"
    (is "?lhs = ?rhs")
    by (simp add: hrdStepRel_def hStepRel_def rdes closure assms rpred wp Healthy_if, rel_auto)
  from assms(1,2) have "(?lhs \<and> \<^bold>l =\<^sub>u \<guillemotleft>n\<guillemotright> \<and> rl(&\<^bold>v) \<and> $st:\<^bold>d\<acute> =\<^sub>u $st:\<^bold>d) = (&\<^bold>v \<leftarrow>\<^sub>h\<le>(\<guillemotleft>l\<guillemotright>) \<guillemotleft>f ti\<guillemotright> \<and> \<^bold>l =\<^sub>u \<guillemotleft>n\<guillemotright> \<and> rl(&\<^bold>v) \<and> $st:\<^bold>d\<acute> =\<^sub>u $st:\<^bold>d)"
    by (simp add: 1, rel_auto, simp add: tt_end_minus, metis eq_iff tt_eq_iff_end_same tt_sub_end)
  also from assms(1,2) have "... = &\<^bold>v \<leftarrow>\<^sub>h(\<guillemotleft>n\<guillemotright>) \<guillemotleft>f ti\<guillemotright>"
    by (rel_auto)
  finally have "HyStep[n](?lhs) = HyStep[n](&\<^bold>v \<leftarrow>\<^sub>h \<guillemotleft>f ti\<guillemotright> :: ('d, 'c) hyrel)"
    using assms(1,2) by (simp add: hStepRel_def, rel_auto)
  thus ?thesis
    by (simp add: hrdStepRel_def HyStep_hEvolve assms)
qed

lemma time_length_conj_seq:
  assumes "m < n" "P is R1" "Q is R1"
  shows  "((\<^bold>l =\<^sub>u \<guillemotleft>m\<guillemotright> \<and> P) ;; Q \<and> \<^bold>l =\<^sub>u \<guillemotleft>n\<guillemotright>) = ((\<^bold>l =\<^sub>u \<guillemotleft>m\<guillemotright> \<and> P) ;; (\<^bold>l =\<^sub>u \<guillemotleft>n-m\<guillemotright> \<and> Q))"
proof -
  from assms(1) have "((\<^bold>l =\<^sub>u \<guillemotleft>m\<guillemotright> \<and> R1(P)) ;; R1(Q) \<and> \<^bold>l =\<^sub>u \<guillemotleft>n\<guillemotright>) = ((\<^bold>l =\<^sub>u \<guillemotleft>m\<guillemotright> \<and> R1(P)) ;; (\<^bold>l =\<^sub>u \<guillemotleft>n-m\<guillemotright> \<and> R1(Q)))"
    apply (rel_auto, simp_all add: tt_end_minus)
    using tt_end_minus apply blast+
  done
  thus ?thesis
    by (simp add: Healthy_if assms)
qed

lemma lim_tt_minus:
  "g < f \<Longrightarrow> lim\<^sub>t(f - g) = lim\<^sub>t f"
  by (metis diff_add_cancel_left' less_imp_le lim_tt_cat tt_end_gr_zero_iff)

lemma final_cont_seq_right:
  assumes "P is RR" "Q is RR"
  shows "(P ;; ($tr <\<^sub>u $tr\<acute> \<and> Q) \<and> rl(&\<^bold>v)) = P ;; ($tr <\<^sub>u $tr\<acute> \<and> Q \<and> rl(&\<^bold>v))" (is "?lhs = ?rhs")
proof -
  have "(RR(P) ;; ($tr <\<^sub>u $tr\<acute> \<and> RR(Q)) \<and> rl(&\<^bold>v)) = RR(P) ;; ($tr <\<^sub>u $tr\<acute> \<and> RR(Q) \<and> rl(&\<^bold>v))"
    apply (rel_auto)
    apply (metis lim_tt_minus)
    apply blast
    apply (simp_all add: lim_tt_minus)
    apply (metis less_iff minus_gr_zero_iff minus_zero_eq neq_zero_impl_greater)
    apply blast
    apply (metis le_zero_iff minus_cancel_le minus_gr_zero_iff minus_zero_eq neq_zero_impl_greater)
  done
  thus ?thesis
    by (simp add: Healthy_if assms)
qed

lemma final_cont_seq_right_length_eq:
  assumes "P is RR" "Q is RR" "n > 0"
  shows "(P ;; (\<^bold>l =\<^sub>u \<guillemotleft>n\<guillemotright> \<and> Q) \<and> rl(&\<^bold>v)) = P ;; (\<^bold>l =\<^sub>u \<guillemotleft>n\<guillemotright> \<and> Q \<and> rl(&\<^bold>v))" (is "?lhs = ?rhs")
proof -
  from assms(3) have "(RR(P) ;; (\<^bold>l =\<^sub>u \<guillemotleft>n\<guillemotright> \<and> RR(Q)) \<and> rl(&\<^bold>v)) = RR(P) ;; (\<^bold>l =\<^sub>u \<guillemotleft>n\<guillemotright> \<and> RR(Q) \<and> rl(&\<^bold>v))"
    apply (rel_auto)
    apply (metis lim_tt_minus)
    apply blast
    apply (simp add: lim_tt_minus)
    apply (simp add: lim_tt_minus)
    apply (metis less_iff minus_gr_zero_iff minus_zero_eq neq_zero_impl_greater)
    apply blast
    apply (metis le_zero_iff minus_cancel_le minus_gr_zero_iff minus_zero_eq neq_zero_impl_greater)
  done
  thus ?thesis
    by (simp add: Healthy_if assms)
qed

lemma hrdStep_hrdEvolveAt_lemma1:
  assumes "0 < l" "l < n"
  shows "(\<^bold>l =\<^sub>u \<guillemotleft>n-l\<guillemotright> \<and> rl(&\<^bold>v)) = (\<^bold>l =\<^sub>u \<guillemotleft>n-l\<guillemotright> \<and> $st:\<^bold>c\<acute> =\<^sub>u lim\<^sub>u(t \<rightarrow> \<^bold>l\<^sup>-)(&tt(\<guillemotleft>t\<guillemotright>)\<^sub>a))"
  using assms
  by (rel_auto)

lemma hrdStep_hrdEvolveAt_greater:
  fixes P :: "('d, 'c::t2_space) hyrel"
  assumes "0 < l" "l < n" "continuous_on {0..n} f" "P is NSRD" "pre\<^sub>R(P) = true\<^sub>r"
  shows "Step[n]\<^sub>H(&\<^bold>v \<leftarrow>\<^sub>H(\<guillemotleft>l\<guillemotright>) \<guillemotleft>f(ti)\<guillemotright> ;; P) = (\<^bold>v := \<guillemotleft>f n\<guillemotright> ;; Step[n-l]\<^sub>H(P))"
proof -
  from assms(1,2)
  have 1:"peri\<^sub>R(&\<^bold>v \<leftarrow>\<^sub>H(\<guillemotleft>l\<guillemotright>) \<guillemotleft>f(ti)\<guillemotright> ;; P) = (&\<^bold>v \<leftarrow>\<^sub>h\<le>(\<guillemotleft>l\<guillemotright>) \<guillemotleft>f ti\<guillemotright> \<or> &\<^bold>v \<leftarrow>\<^sub>h(\<guillemotleft>l\<guillemotright>) \<guillemotleft>f ti\<guillemotright> ;; RR(peri\<^sub>R P))"
    (is "?lhs = ?rhs")
    by (simp add: hrdStepRel_def hStepRel_def rdes closure assms rpred wp Healthy_if, rel_auto)
  from assms(1,2)
  have "(?lhs \<and> \<^bold>l =\<^sub>u \<guillemotleft>n\<guillemotright> \<and> rl(&\<^bold>v) \<and> $st:\<^bold>d\<acute> =\<^sub>u $st:\<^bold>d) =
        (((\<^bold>l =\<^sub>u \<guillemotleft>l\<guillemotright> \<and> &\<^bold>v \<leftarrow>\<^sub>h(\<guillemotleft>l\<guillemotright>) \<guillemotleft>f ti\<guillemotright>) ;; RR(peri\<^sub>R P) \<and> \<^bold>l =\<^sub>u \<guillemotleft>n\<guillemotright>) \<and> rl(&\<^bold>v) \<and> $st:\<^bold>d\<acute> =\<^sub>u $st:\<^bold>d)"
    by (simp add: 1, rel_auto)
  also from assms(1,2)
  have "... = ((\<^bold>l =\<^sub>u \<guillemotleft>l\<guillemotright> \<and> &\<^bold>v \<leftarrow>\<^sub>h(\<guillemotleft>l\<guillemotright>) \<guillemotleft>f ti\<guillemotright>) ;; (\<^bold>l =\<^sub>u \<guillemotleft>n-l\<guillemotright> \<and> RR(peri\<^sub>R P)) \<and> rl(&\<^bold>v) \<and> $st:\<^bold>d\<acute> =\<^sub>u $st:\<^bold>d)"
    by (subst time_length_conj_seq, simp_all add: assms closure)
  also
  have "... = (((\<^bold>l =\<^sub>u \<guillemotleft>l\<guillemotright> \<and> &\<^bold>v \<leftarrow>\<^sub>h(\<guillemotleft>l\<guillemotright>) \<guillemotleft>f ti\<guillemotright>) ;; (\<^bold>l =\<^sub>u \<guillemotleft>n-l\<guillemotright> \<and> RR(peri\<^sub>R P)) \<and> rl(&\<^bold>v)) \<and> $st:\<^bold>d\<acute> =\<^sub>u $st:\<^bold>d)"
    by (simp add: conj_assoc)
  also from assms(1-2)
  have "... = ((\<^bold>l =\<^sub>u \<guillemotleft>l\<guillemotright> \<and> &\<^bold>v \<leftarrow>\<^sub>h(\<guillemotleft>l\<guillemotright>) \<guillemotleft>f ti\<guillemotright>) ;; (\<^bold>l =\<^sub>u \<guillemotleft>n-l\<guillemotright> \<and> RR(peri\<^sub>R P) \<and> rl(&\<^bold>v)) \<and> $st:\<^bold>d\<acute> =\<^sub>u $st:\<^bold>d)"
    by (subst final_cont_seq_right_length_eq, (rel_auto)+)
  also
  have "... = ((&\<^bold>v \<leftarrow>\<^sub>h(\<guillemotleft>l\<guillemotright>) \<guillemotleft>f ti\<guillemotright>) ;; ((\<^bold>l =\<^sub>u \<guillemotleft>n-l\<guillemotright> \<and> rl(&\<^bold>v)) \<and> RR(peri\<^sub>R P) \<and> $st:\<^bold>d\<acute> =\<^sub>u $st:\<^bold>d))"
    by (rel_auto)
  also
  have "... = ((&\<^bold>v \<leftarrow>\<^sub>h(\<guillemotleft>l\<guillemotright>) \<guillemotleft>f ti\<guillemotright>) ;; ((\<^bold>l =\<^sub>u \<guillemotleft>n-l\<guillemotright> \<and> $st:\<^bold>c\<acute> =\<^sub>u lim\<^sub>u(t \<rightarrow> \<^bold>l\<^sup>-)(&tt(\<guillemotleft>t\<guillemotright>)\<^sub>a)) \<and> RR(peri\<^sub>R P) \<and> $st:\<^bold>d\<acute> =\<^sub>u $st:\<^bold>d))"
    by (simp add: hrdStep_hrdEvolveAt_lemma1 assms)
  also
  have "... = ((&\<^bold>v \<leftarrow>\<^sub>h(\<guillemotleft>l\<guillemotright>) \<guillemotleft>f ti\<guillemotright>) ;; (\<^bold>l =\<^sub>u \<guillemotleft>n-l\<guillemotright> \<and> RR(peri\<^sub>R P) \<and> $st:\<^bold>c\<acute> =\<^sub>u lim\<^sub>u(t \<rightarrow> \<^bold>l\<^sup>-)(&tt(\<guillemotleft>t\<guillemotright>)\<^sub>a) \<and> $st:\<^bold>d\<acute> =\<^sub>u $st:\<^bold>d))"
    by (rel_auto)
  finally
  have "Step[n]\<^sub>H(&\<^bold>v \<leftarrow>\<^sub>H(\<guillemotleft>l\<guillemotright>) \<guillemotleft>f(ti)\<guillemotright> ;; P) =
        \<lfloor>((&\<^bold>v \<leftarrow>\<^sub>h(\<guillemotleft>l\<guillemotright>) \<guillemotleft>f ti\<guillemotright>) ;; (\<^bold>l =\<^sub>u \<guillemotleft>n - l\<guillemotright> \<and> RR(peri\<^sub>R P) \<and> $st:\<^bold>c\<acute> =\<^sub>u lim\<^sub>u(t \<rightarrow> \<^bold>l\<^sup>-)(&tt(\<guillemotleft>t\<guillemotright>)\<^sub>a) \<and> $st:\<^bold>d\<acute> =\<^sub>u $st:\<^bold>d)) \<restriction>\<^sub>v (&st:\<^bold>c \<times> &st:\<^bold>c)\<rfloor>\<^sub>C"
    using assms(1-2)
    by (simp add: hrdStepRel_def hStepRel_def 1 Healthy_if closure assms, rel_auto)
  also have "... = (\<lfloor>(&\<^bold>v \<leftarrow>\<^sub>h(\<guillemotleft>l\<guillemotright>) \<guillemotleft>f ti\<guillemotright> :: ('d, 'c::t2_space) hyrel) \<restriction>\<^sub>v (&st:\<^bold>c \<times> &st:\<^bold>c)\<rfloor>\<^sub>C) ;;\<^sub>h \<lfloor>(\<^bold>l =\<^sub>u \<guillemotleft>n - l\<guillemotright> \<and> RR(peri\<^sub>R P) \<and> $st:\<^bold>c\<acute> =\<^sub>u lim\<^sub>u(t \<rightarrow> \<^bold>l\<^sup>-)(&tt(\<guillemotleft>t\<guillemotright>)\<^sub>a) \<and> $st:\<^bold>d\<acute> =\<^sub>u $st:\<^bold>d) \<restriction>\<^sub>v (&st:\<^bold>c \<times> &st:\<^bold>c)\<rfloor>\<^sub>C"
    apply (rel_auto)
    apply (rename_tac tr tr' tr'' d tr''')
    apply (rule_tac x="tr" in exI)
    apply (rule_tac x="d" in exI)
    apply (rule_tac x="tr'' + (tr''' - tr')" in exI)
    apply (rule_tac x="d" in exI)
    apply (rule_tac x="tr''" in exI)
    apply (auto)
  done
  also have "... = \<^bold>v := \<guillemotleft>f n\<guillemotright> ;;\<^sub>h \<lfloor>(\<^bold>l =\<^sub>u \<guillemotleft>n - l\<guillemotright> \<and> RR(peri\<^sub>R P) \<and> rl(&\<^bold>v) \<and> $st:\<^bold>d\<acute> =\<^sub>u $st:\<^bold>d) \<restriction>\<^sub>v (&st:\<^bold>c \<times> &st:\<^bold>c)\<rfloor>\<^sub>C"
oops
*)

end


(*<*)
theory OneThirdRule_Proofs
imports Heard_Of.Majorities
  "../HO_Transition_System" "../Voting_Opt" OneThirdRule_Defs
begin
(*>*)

subsection \<open>Proofs\<close>

definition majs :: "(process set) set" where
  "majs \<equiv> {S. card S > (2 * N) div 3}"

lemma card_Compl:
  fixes S :: "('a :: finite) set"
  shows "card (-S) = card (UNIV :: 'a set) - card S"
proof-
  have "card S + card (-S) = card (UNIV :: 'a set)"
    by(rule card_Un_disjoint[of S "-S", simplified Compl_partition, symmetric])
      (auto)
  thus ?thesis
    by simp
qed

lemma m_mult_div_Suc_m:
  "n > 0 \<Longrightarrow> m * n div Suc m < n"
  by (simp add: less_mult_imp_div_less)

interpretation majorities: quorum_process majs
proof
  fix Q Q' assume "Q \<in> majs" "Q' \<in> majs"
  hence "(4 * N) div 3 < card Q + card Q'"
    by(auto simp add: majs_def)
  thus "Q \<inter> Q' \<noteq> {}"
    apply (intro majorities_intersect)
    apply(auto)
    done
next
  have "N > 0"
    by auto
  have "2 * N div 3 < N"
    by(simp only: eval_nat_numeral m_mult_div_Suc_m[OF \<open>N > 0\<close>])
  thus "\<exists>Q. Q \<in> majs"
    apply(rule_tac x=UNIV in exI)
    apply(auto simp add: majs_def intro!: div_less_dividend)
    done
qed

lemma card_Un_le:
  "\<lbrakk> finite A; finite B \<rbrakk> \<Longrightarrow> card (A \<union> B) \<le> card A + card B"
  by(simp only: card_Un_Int)

lemma qintersect_card:
  assumes "Q \<in> majs" "Q' \<in> majs"
  shows "card (Q \<inter> Q') > card (Q \<inter> -Q')"
proof-
  have "card (Q \<inter> -Q') \<le> card (-Q')"
    by(auto intro!: card_mono)
  also have "... < N - (card (-Q) + card (-Q'))"
  proof-
    have sum: "N < card Q + card Q'" using assms
      by(auto simp add: majs_def)
    have le_N: "card Q \<le> N" "card Q' \<le> N" by (auto intro!: card_mono)
    show ?thesis using assms sum
      apply(simp add: card_Compl)
      apply(intro diff_less_mono2)
      apply(auto simp add: majs_def card_Compl)
       apply(simp add: diff_add_assoc2[symmetric, OF le_N(1)] add_diff_assoc[OF le_N(2)])
      by (metis add_mono le_N(1) le_N(2) less_diff_conv2 nat_add_left_cancel_less)
  qed
  also have "... \<le> card (Q \<inter> Q')"
  proof-
    have "N - (card (-Q) + card (-Q')) \<le> card (-(-Q \<union> -Q'))"
      apply(simp only: card_Compl[where S="-Q \<union> -Q'"])
      apply(auto intro!: diff_le_mono2 card_Un_le)
      done
    thus ?thesis
      by(auto)
  qed
  finally show ?thesis .
qed

axiomatization where val_linorder:
  (* "class.finite TYPE(process)" *)
  "OFCLASS(val, linorder_class)"

instance val :: linorder by (rule val_linorder)

type_synonym p_TS_state = "(nat \<times> (process \<Rightarrow> (val pstate)))"

definition K where
  "K y \<equiv> \<lambda>x. y"

definition OTR_Alg where
  "OTR_Alg =
    \<lparr> CinitState =  (\<lambda> p st crd. OTR_initState p st),
     sendMsg =  OTR_sendMsg,
     CnextState = (\<lambda> r p st msgs crd st'. OTR_nextState r p st msgs st')
   \<rparr>"

definition OTR_TS ::
  "(round \<Rightarrow> process HO)
  \<Rightarrow> (round \<Rightarrow> process HO)
  \<Rightarrow> (round \<Rightarrow> process)
  \<Rightarrow> p_TS_state TS"
where
  "OTR_TS HOs SHOs crds = CHO_to_TS OTR_Alg HOs SHOs (K o crds)"

lemmas OTR_TS_defs = OTR_TS_def CHO_to_TS_def OTR_Alg_def CHOinitConfig_def
  OTR_initState_def

definition
  "OTR_trans_step HOs \<equiv> \<Union>r \<mu>.
   {((r, cfg), Suc r, cfg')|cfg cfg'.
    (\<forall>p. \<mu> p \<in> get_msgs (OTR_sendMsg r) cfg (HOs r) (HOs r) p) \<and>
    (\<forall>p. OTR_nextState r p (cfg p) (\<mu> p) (cfg' p))}"

definition CSHOnextConfig where
  "CSHOnextConfig A r cfg HO SHO coord cfg' \<equiv>
   \<forall>p. \<exists>\<mu> \<in> SHOmsgVectors A r p cfg (HO p) (SHO p).
          CnextState A r p (cfg p) \<mu> (coord p) (cfg' p)"

type_synonym rHO = "nat \<Rightarrow> process HO"

subsubsection \<open>Refinement\<close>
(******************************************************************************)

definition otr_ref_rel :: "(opt_v_state \<times> p_TS_state)set" where
  "otr_ref_rel =  {(sa, (r, sc)).
    r = next_round sa
    \<and> (\<forall>p. decisions sa p = decision (sc p))
    \<and> majorities.opt_no_defection sa (Some o last_vote o sc)
  }"

lemma decide_origin:
  assumes
    send: "\<mu> p \<in> get_msgs (OTR_sendMsg r) sc (HOs r) (HOs r) p"
    and nxt: "OTR_nextState r p (sc p) (\<mu> p) (sc' p)"
    and new_dec: "decision (sc' p) \<noteq> decision (sc p)"
  shows
    "\<exists>v. decision (sc' p) = Some v \<and> {q. last_vote (sc q) = v} \<in> majs"
proof-
  from new_dec and nxt obtain v where
    p_dec_v: "decision (sc' p) = Some v"
    and two_thirds_v: "TwoThirds (\<mu> p) v"
    apply(auto simp add: OTR_nextState_def split: if_split_asm)
    by (metis exE_some)
  then have "2 * N div 3 < card {q. last_vote (sc q) = v}" using send
    by(auto simp add: get_msgs_benign OTR_sendMsg_def TwoThirds_def HOV_def
      restrict_map_def elim!: less_le_trans intro!: card_mono)
  with p_dec_v show ?thesis by (auto simp add: majs_def)
qed

lemma MFR_in_msgs:
  assumes HO:"dom msgs \<noteq> {}"
      and v: "MFR msgs v"
  shows "\<exists>q \<in> dom msgs. v = the (msgs q)"
proof -
  from HO obtain q where q: "q \<in> dom msgs"
    by auto
  with v have "HOV msgs (the (msgs q)) \<noteq> {}"
    by (auto simp: HOV_def )
  hence HOp: "0 < card (HOV msgs (the (msgs q)))"
    by auto
  also from v have "\<dots> \<le> card (HOV msgs v)"
    by (simp add: MFR_def)
  finally have "HOV msgs v \<noteq> {}"
    by auto
  thus ?thesis
    by (force simp: HOV_def)
qed

lemma step_ref:
  "{otr_ref_rel}
      (\<Union>r v_f d_f. majorities.flv_round r v_f d_f),
      OTR_trans_step HOs
    {> otr_ref_rel}"
proof(simp add: PO_rhoare_defs OTR_trans_step_def, safe)
  fix sa r sc sc' \<mu>
  assume
    R: "(sa, r, sc) \<in> otr_ref_rel"
    and send: "\<forall>p. \<mu> p \<in> get_msgs (OTR_sendMsg r) sc (HOs r) (HOs r) p"
    and nxt: "\<forall>p. OTR_nextState r p (sc p) (\<mu> p) (sc' p)"
  note step=send nxt
  define d_f
    where "d_f p = (if decision (sc' p) \<noteq> decision (sc p) then decision (sc' p) else None)" for p

  define sa' where "sa' = \<lparr>
    opt_v_state.next_round = Suc r
    , opt_v_state.last_vote = opt_v_state.last_vote sa ++ (Some o last_vote o sc)
    , opt_v_state.decisions = opt_v_state.decisions sa ++ d_f
    \<rparr>"

  have "majorities.d_guard d_f (Some o last_vote o sc)"
  proof(clarsimp simp add: majorities.d_guard_def d_f_def)
    fix p v
    assume
      "Some v \<noteq> decision (sc p)"
      "decision (sc' p) = Some v"
    from this and
      decide_origin[where \<mu>=\<mu> and HOs=HOs and sc'=sc', OF send[THEN spec, of p] nxt[THEN spec, of p]]
    show "quorum_process.locked_in_vf majs (Some \<circ> last_vote \<circ> sc) v"
      by(auto simp add: majorities.locked_in_vf_def majorities.quorum_for_def)
  qed
  hence
    "(sa, sa') \<in> majorities.flv_round r (Some o last_vote o sc) d_f" using R
    by(auto simp add: majorities.flv_round_def otr_ref_rel_def sa'_def)
  moreover have "(sa', Suc r, sc') \<in> otr_ref_rel"
  proof(unfold otr_ref_rel_def, safe)
    fix p
    show "opt_v_state.decisions sa' p = decision (sc' p)" using R nxt[THEN spec, of p]
      by(auto simp add: otr_ref_rel_def sa'_def map_add_def d_f_def OTR_nextState_def
        split: option.split)
  next
    show "quorum_process.opt_no_defection majs sa' (Some \<circ> last_vote \<circ> sc')"
    proof(clarsimp simp add: sa'_def majorities.opt_no_defection_def map_add_def majorities.quorum_for_def)
      fix Q p v
      assume Q: "Q \<in> majs" and Q_v: "\<forall>q \<in> Q. last_vote (sc q) = v" and p_Q: "p \<in> Q"
      hence old: "last_vote (sc p) = v" by simp
      have v_maj: "{q. last_vote (sc q) = v} \<in> majs" using Q Q_v
        apply(simp add: majs_def)
        apply(erule less_le_trans, rule card_mono, auto)
        done
      show "last_vote (sc' p) = v"
      proof(rule ccontr)
        assume new: "last_vote (sc' p) \<noteq> v"
        let ?w = "last_vote (sc' p)"
        have
          w_MFR: "?w = Min {z. MFR (\<mu> p) z}" (is "?w = Min ?MFRs") and dom_maj: "dom (\<mu> p) \<in> majs"
          using old new nxt[THEN spec, where x=p]
          by(auto simp add: OTR_nextState_def majs_def dom_def split: if_split_asm)
        from dom_maj have not_empty: "dom (\<mu> p) \<noteq> {}" by(elim majorities.quorum_non_empty)
        from MFR_exists obtain mfr_v where mfr_v: "mfr_v \<in> ?MFRs"
          by fastforce
        from not_empty obtain q z where "\<mu> p q = Some z" by(fastforce)
        hence "0 < card (HOV (\<mu> p) (the (\<mu> p q)))"
          by(auto simp add: HOV_def)
        have "?w \<in> {z. MFR (\<mu> p) z}"
        proof(unfold w_MFR, rule Min_in)
          have "?MFRs \<subseteq> (the o (\<mu> p)) ` (dom (\<mu> p))" using not_empty
            by(auto simp: image_def intro: MFR_in_msgs)
          thus "finite ?MFRs" by (auto elim: finite_subset)
        qed(auto simp add: MFR_exists)
        hence card_HOV: "card (HOV (\<mu> p) v) \<le> card (HOV (\<mu> p) ?w)"
          by(auto simp add: MFR_def)
        have "dom (\<mu> p) = HOs r p" using send[THEN spec, where x=p]
          by(auto simp add: get_msgs_def)
        from this[symmetric] have "\<forall>v'. HOV (\<mu> p) v' = {q. last_vote (sc q) = v'} \<inter> dom (\<mu> p)"
          using send[THEN spec, where x=p]
          by(fastforce simp add: HOV_def get_msgs_benign OTR_sendMsg_def restrict_map_def)
        hence card_le1: "card ({q. last_vote (sc q) = v} \<inter> dom (\<mu> p)) \<le> card ({q. last_vote (sc q) = ?w} \<inter> dom (\<mu> p))"
          using card_HOV
          by(simp)
        have
          "card ({q. last_vote (sc q) = v} \<inter> dom (\<mu> p)) \<le> card ({q. last_vote (sc q) \<noteq> v} \<inter> dom (\<mu> p))"
          apply(rule le_trans[OF card_le1], rule card_mono)
           apply(auto simp add: new[symmetric])
          done
        thus False using qintersect_card[OF dom_maj v_maj]
          by(simp add: Int_commute Collect_neg_eq)
      qed
    qed
  qed(auto simp add: sa'_def)

  ultimately show
    "\<exists>sa'. (\<exists>ra v_f d_f. (sa, sa') \<in> quorum_process.flv_round majs ra v_f d_f)
    \<and> (sa', Suc r, sc') \<in> otr_ref_rel"
    by blast
qed

lemma OTR_Refines_LV_VOting:
  "PO_refines (otr_ref_rel)
    majorities.flv_TS (OTR_TS HOs HOs crds)"
proof(rule refine_basic)
  show "init (OTR_TS HOs HOs crds) \<subseteq> otr_ref_rel `` init (quorum_process.flv_TS majs)"
    by(auto simp add: OTR_TS_def CHO_to_TS_def OTR_Alg_def CHOinitConfig_def OTR_initState_def
      majorities.flv_TS_def flv_init_def majorities.opt_no_defection_def majorities.quorum_for_def'
      otr_ref_rel_def)
next
  show
    "{otr_ref_rel} TS.trans (quorum_process.flv_TS majs), TS.trans (OTR_TS HOs HOs crds) {> otr_ref_rel}"
    using step_ref
    by(simp add: majorities.flv_TS_defs OTR_TS_def CHO_to_TS_def OTR_Alg_def
      CSHO_trans_alt_def CHO_trans_alt OTR_trans_step_def)
qed

subsubsection \<open>Termination\<close>
(******************************************************************************)

text \<open>The termination proof for the algorithm is already given in the Heard-Of Model AFP
  entry, and we do not repeat it here.\<close>

end


theory Lang
imports Main VHelper
begin

text {* This file defines the syntax and semantics of the programming language
  used by O'Hearn and Brookes. For simplicity, we do not allow resource-owned
  variables. *}

text {* (Adapted to Isabelle 2016-1 by Qin Yu and James Brotherston) *}

subsection {* Language syntax and semantics *}

text {* We define the syntax and the operational semantics of the programming
language of O'Hearn and Brookes. *}

type_synonym  var   = string                (*r Variables *)
type_synonym  rname = string                (*r Resource names *)
type_synonym  heap  = "(nat \<rightharpoonup> nat)"        (*r Heaps *)
type_synonym  stack = "(var \<Rightarrow> nat)"        (*r Stacks *)
type_synonym  state = "stack \<times> heap"        (*r States *)

datatype exp =                  (*r Arithmetic expressions *)
    Evar var                    (*r Variable *)
  | Enum nat                    (*r Constant *)
  | Eplus exp exp               (*r Addition *)

datatype bexp =                 (*r Boolean expressions *)
    Beq exp exp                 (*r Equality of expressions *)
  | Band bexp bexp              (*r Conjunction *)
  | Bnot bexp                   (*r Negation *)

datatype cmd =                  (*r Commands *)
    Cskip                       (*r Empty command *)
  | Cassign var exp             (*r Assignment *)
  | Cread   var exp             (*r Memory load *)
  | Cwrite  exp exp             (*r Memory store *)
  | Calloc  var exp             (*r Memory allocation *)
  | Cdispose exp                (*r Memory de-allocation *)
  | Cseq   cmd cmd              (*r Sequential composition *)
  | Cpar   cmd cmd              (*r Parallel composition *)
  | Cif    bexp cmd cmd         (*r If-then-else *)
  | Cwhile bexp cmd             (*r While loops *)
  | Clocal var exp cmd          (*r Local variable declaration *)
  | Cinlocal var nat cmd        (*r Local variable declaration (runtime) *)
  | Cresource rname cmd         (*r Resource declaration *)
  | Cwith     rname bexp cmd    (*r Conditional critical region *)
  | Cinwith   rname cmd         (*r Conditional critical region (runtime) *)

text {* Arithmetic expressions (@{text exp}) consist of variables, constants, and
arithmetic operations. Boolean expressions (@{text bexp}) consist of comparisons
between arithmetic expressions.  Commands (@{text cmd}) include the empty command,
variable assignments, memory reads, writes, allocations and deallocations,
sequential and parallel composition, conditionals, while loops, local variable
declarations, resource declarations and conditional critical regions (CCRs).
There are two command forms (@{text Cinlocal}, @{text Cinwith}) that represent
partially executed local variable declarations and CCRs and do not appear
in user programs. This restriction is captured by the following definition: *}

primrec
  user_cmd :: "cmd \<Rightarrow> bool"
where
    "user_cmd Cskip            = True"
  | "user_cmd (Cassign x E)    = True"
  | "user_cmd (Cread x E)      = True"
  | "user_cmd (Cwrite E E')    = True"
  | "user_cmd (Calloc x E)     = True"
  | "user_cmd (Cdispose E)     = True"
  | "user_cmd (Cseq C1 C2)     = (user_cmd C1 \<and> user_cmd C2)"
  | "user_cmd (Cpar C1 C2)     = (user_cmd C1 \<and> user_cmd C2)"
  | "user_cmd (Cif B C1 C2)    = (user_cmd C1 \<and> user_cmd C2)"
  | "user_cmd (Cwhile B C)     = user_cmd C"
  | "user_cmd (Clocal x E C)   = user_cmd C"
  | "user_cmd (Cinlocal x v C) = False"
  | "user_cmd (Cresource r C)  = user_cmd C"
  | "user_cmd (Cwith r B C)    = user_cmd C"
  | "user_cmd (Cinwith r C)    = False"

text {* The following function returns the set of locks that a command is
currently holding. *}

primrec
  locked :: "cmd \<Rightarrow> rname set"
where
    "locked Cskip            = {}"
  | "locked (Cassign x E)    = {}"
  | "locked (Cread x E)      = {}"
  | "locked (Cwrite E E')    = {}"
  | "locked (Calloc x E)     = {}"
  | "locked (Cdispose E)     = {}"
  | "locked (Cseq C1 C2)     = (locked C1)"
  | "locked (Cpar C1 C2)     = (locked C1 \<union> locked C2)"
  | "locked (Cif B C1 C2)    = {}"
  | "locked (Cwhile B C)     = {}"
  | "locked (Clocal x E C)   = {}"
  | "locked (Cinlocal x v C) = (locked C)"
  | "locked (Cresource r C)  = (locked C - {r})"
  | "locked (Cwith r B C)    = {}"
  | "locked (Cinwith r C)    = ({r} \<union> locked C)"

text {* Now the same definition, but return a list of locks that the
  command is currently holding in some fixed order. This defnition
  is needed to work around the deep embedding of assertions. *}

primrec
  llocked :: "cmd \<Rightarrow> rname list"
where
    "llocked Cskip            = []"
  | "llocked (Cassign x E)    = []"
  | "llocked (Cread x E)      = []"
  | "llocked (Cwrite E E')    = []"
  | "llocked (Calloc x E)     = []"
  | "llocked (Cdispose E)     = []"
  | "llocked (Cseq C1 C2)     = llocked C1"
  | "llocked (Cpar C1 C2)     = (llocked C1 @ llocked C2)"
  | "llocked (Cif B C1 C2)    = []"
  | "llocked (Cwhile B C)     = []"
  | "llocked (Clocal x E C)   = []"
  | "llocked (Cinlocal x v C) = llocked C"
  | "llocked (Cresource r C)  = (removeAll r (llocked C))"
  | "llocked (Cwith r B C)    = []"
  | "llocked (Cinwith r C)    = (r # llocked C)"

lemma locked_eq: "locked C = set (llocked C)"
by (induct C, simp_all)

subsubsection {* Semantics of expressions *}

text {* Denotational semantics for arithmetic and boolean expressions. *}

primrec
  edenot :: "exp \<Rightarrow> stack \<Rightarrow> nat"
where
    "edenot (Evar v) s      = s v"
  | "edenot (Enum n) s      = n"
  | "edenot (Eplus e1 e2) s = edenot e1 s + edenot e2 s"

primrec
  bdenot :: "bexp \<Rightarrow> stack \<Rightarrow> bool"
where
    "bdenot (Beq e1 e2) s   = (edenot e1 s = edenot e2 s)"
  | "bdenot (Band b1 b2) s  = (bdenot b1 s \<and> bdenot b2 s)"
  | "bdenot (Bnot b) s      = (\<not> bdenot b s)"

subsubsection {* Semantics of commands *}

text {* We give a standard small-step operational semantics to commands
  with configurations being command-state pairs. *}

text {*
  For illustration purposes, our semantics for @{term "Cwrite E E'"} is unusual
  in that if @{term "E"} is not allocated, then the command will allocate @{term "E"}
  and do the assignment.  Requiring that @{term "(edenot E s) \<in> dom h"} does
  not change the proof. *}

inductive
  red :: "cmd \<Rightarrow> state \<Rightarrow> cmd \<Rightarrow> state \<Rightarrow> bool"
where
  red_Seq1[intro]: "red (Cseq Cskip C) \<sigma> C \<sigma>"
| red_Seq2[elim]: "red C1 \<sigma> C1' \<sigma>' \<Longrightarrow> red (Cseq C1 C2) \<sigma> (Cseq C1' C2) \<sigma>'"
| red_If1[intro]: "bdenot B (fst \<sigma>) \<Longrightarrow> red (Cif B C1 C2) \<sigma> C1 \<sigma>"
| red_If2[intro]: "\<not> bdenot B (fst \<sigma>) \<Longrightarrow> red (Cif B C1 C2) \<sigma> C2 \<sigma>"
| red_Par1[elim]: "\<lbrakk> red C1 \<sigma> C1' \<sigma>'; disjoint (locked C1') (locked C2) \<rbrakk> \<Longrightarrow> red (Cpar C1 C2) \<sigma> (Cpar C1' C2) \<sigma>'"
| red_Par2[elim]: "\<lbrakk> red C2 \<sigma> C2' \<sigma>'; disjoint (locked C1) (locked C2') \<rbrakk> \<Longrightarrow> red (Cpar C1 C2) \<sigma> (Cpar C1 C2') \<sigma>'"
| red_Par3[intro]: "red (Cpar Cskip Cskip) \<sigma> (Cskip) \<sigma>"
| red_Loop[intro]: "red (Cwhile B C) \<sigma> (Cif B (Cseq C (Cwhile B C)) Cskip) \<sigma>"
| red_Local1[intro]: "v = edenot E (fst \<sigma>) \<Longrightarrow> red (Clocal x E C) \<sigma> (Cinlocal x v C) \<sigma>"
| red_Local2[intro]:"\<lbrakk> \<sigma> = (s,h); red C (s(x:=v),h) C' (s',h'); v' = s' x; \<sigma>' = (s'(x := s x), h') \<rbrakk> \<Longrightarrow> red (Cinlocal x v C) \<sigma> (Cinlocal x v' C') \<sigma>'"
| red_Local3[intro]: "red (Cinlocal x v Cskip) \<sigma> Cskip \<sigma>"
| red_Res1[intro]:  "red C \<sigma> C' \<sigma>' \<Longrightarrow> red (Cresource r C) \<sigma> (Cresource r C') \<sigma>'"
| red_Res2[intro]:  "red (Cresource r Cskip) \<sigma> Cskip \<sigma>"
| red_With1[intro]: "bdenot B (fst \<sigma>) \<Longrightarrow> red (Cwith r B C) \<sigma> (Cinwith r C) \<sigma>"
| red_With2[elim]:  "\<lbrakk> red C \<sigma> C' \<sigma>'; r \<notin> locked C' \<rbrakk> \<Longrightarrow> red (Cinwith r C) \<sigma> (Cinwith r C') \<sigma>'"
| red_With3[intro]: "red (Cinwith r Cskip) \<sigma> Cskip \<sigma>"
| red_Assign[intro]:"\<lbrakk> \<sigma> = (s,h); \<sigma>' = (s(x := edenot E s), h) \<rbrakk> \<Longrightarrow> red (Cassign x E) \<sigma> Cskip \<sigma>'"
| red_Read[intro]:  "\<lbrakk> \<sigma> = (s,h); h(edenot E s) = Some v; \<sigma>' = (s(x := v), h) \<rbrakk> \<Longrightarrow> red (Cread x E) \<sigma> Cskip \<sigma>'"
| red_Write[intro]: "\<lbrakk> \<sigma> = (s,h); (*(edenot E s) \<in> dom h;*) \<sigma>' = (s, h(edenot E s \<mapsto> edenot E' s)) \<rbrakk>  \<Longrightarrow> red (Cwrite E E') \<sigma> Cskip \<sigma>'"
| red_Alloc[intro]: "\<lbrakk> \<sigma> = (s,h); v \<notin> dom h; \<sigma>' = (s(x := v), h(v \<mapsto> edenot E s)) \<rbrakk>  \<Longrightarrow> red (Calloc x E) \<sigma> Cskip \<sigma>'"
| red_Free[intro]:  "\<lbrakk> \<sigma> = (s,h); \<sigma>' = (s, h(edenot E s := None)) \<rbrakk> \<Longrightarrow> red (Cdispose E) \<sigma> Cskip \<sigma>'"

inductive_cases red_par_cases: "red (Cpar C1 C2) \<sigma> C' \<sigma>'"

subsubsection {* Abort semantics *}

text {* Below, we define the sets of memory accesses and memory writes
  that a command performs in one step. These are used to define what a
  race condition is.  We do not count memory allocation as a memory
  access because the memory cell allocated is fresh. *}

primrec
  accesses :: "cmd \<Rightarrow> stack \<Rightarrow> nat set"
where
    "accesses Cskip            s = {}"
  | "accesses (Cassign x E)    s = {}"
  | "accesses (Cread x E)      s = {edenot E s}"
  | "accesses (Cwrite E E')    s = {edenot E s}"
  | "accesses (Calloc x E)     s = {}"
  | "accesses (Cdispose E)     s = {edenot E s}"
  | "accesses (Cseq C1 C2)     s = accesses C1 s"
  | "accesses (Cpar C1 C2)     s = accesses C1 s \<union> accesses C2 s"
  | "accesses (Cif B C1 C2)    s = {}"
  | "accesses (Cwhile B C)     s = {}"
  | "accesses (Clocal x E C)   s = {}"
  | "accesses (Cinlocal x v C) s = accesses C (s(x:=v))"
  | "accesses (Cresource r C)  s = accesses C s"
  | "accesses (Cwith r B C)    s = {}"
  | "accesses (Cinwith r C)    s = accesses C s"

primrec
  writes :: "cmd \<Rightarrow> stack \<Rightarrow> nat set "
where
    "writes Cskip            s = {}"
  | "writes (Cassign x E)    s = {}"
  | "writes (Cread x E)      s = {}"
  | "writes (Cwrite E E')    s = {edenot E s}"
  | "writes (Calloc x E)     s = {}"
  | "writes (Cdispose E)     s = {edenot E s}"
  | "writes (Cseq C1 C2)     s = writes C1 s"
  | "writes (Cpar C1 C2)     s = writes C1 s \<union> writes C2 s"
  | "writes (Cif B C1 C2)    s = {}"
  | "writes (Clocal x E C)   s = {}"
  | "writes (Cinlocal x v C) s = writes C (s(x:=v))"
  | "writes (Cwhile B C)     s = {}"
  | "writes (Cresource r C)  s = writes C s"
  | "writes (Cwith r B C)    s = {}"
  | "writes (Cinwith r C)    s = writes C s"

text {* A command aborts in a given state whenever it can access
  unallocated memory or has a race condition in its first execution
  step. The soundness statement of the logic asserts that these
  transitions never occur. *}

inductive
  aborts :: "cmd \<Rightarrow> state \<Rightarrow> bool"
where
  aborts_Seq[intro]:   "aborts C1 \<sigma> \<Longrightarrow> aborts (Cseq C1 C2) \<sigma>"
| aborts_Par1[intro]:  "aborts C1 \<sigma> \<Longrightarrow> aborts (Cpar C1 C2) \<sigma>"
| aborts_Par2[intro]:  "aborts C2 \<sigma> \<Longrightarrow> aborts (Cpar C1 C2) \<sigma>"
| aborts_Race1[intro]:  "\<not> disjoint (accesses C1 (fst \<sigma>)) (writes C2 (fst \<sigma>)) \<Longrightarrow> aborts (Cpar C1 C2) \<sigma>"
| aborts_Race2[intro]:  "\<not> disjoint (writes C1 (fst \<sigma>)) (accesses C2 (fst \<sigma>)) \<Longrightarrow> aborts (Cpar C1 C2) \<sigma>"
| aborts_Local[intro]:  "aborts C ((fst \<sigma>)(x:=v), snd \<sigma>)  \<Longrightarrow> aborts (Cinlocal x v C) \<sigma>"
| aborts_Res[intro]:   "aborts C \<sigma>  \<Longrightarrow> aborts (Cresource r C) \<sigma>"
| aborts_With[intro]:  "aborts C \<sigma>  \<Longrightarrow> aborts (Cinwith r C) \<sigma>"
| aborts_Read[intro]:  "edenot E (fst \<sigma>) \<notin> dom (snd \<sigma>) \<Longrightarrow> aborts (Cread x E) \<sigma>"
| aborts_Write[intro]: "edenot E (fst \<sigma>) \<notin> dom (snd \<sigma>) \<Longrightarrow> aborts (Cwrite E E') \<sigma>"
| aborts_Free[intro]:  "edenot E (fst \<sigma>) \<notin> dom (snd \<sigma>) \<Longrightarrow> aborts (Cdispose E) \<sigma>"

subsubsection {* Well-formed commands *}

text {* Well-formed commands are those that can arise from a user
command by a reduction sequence.  In particular, they can have
partially executed CCRs only at reduction positions and their
partially executed CCRs must satisfy mutual exclusion.  *}

primrec
  wf_cmd :: "cmd \<Rightarrow> bool"
where
    "wf_cmd Cskip           = True"
  | "wf_cmd (Cassign x E)   = True"
  | "wf_cmd (Cread x E)     = True"
  | "wf_cmd (Cwrite E E')   = True"
  | "wf_cmd (Calloc x E)    = True"
  | "wf_cmd (Cdispose E)    = True"
  | "wf_cmd (Cseq C1 C2)    = (wf_cmd C1 \<and> user_cmd C2)"
  | "wf_cmd (Cpar C1 C2)    = (wf_cmd C1 \<and> wf_cmd C2 \<and> disjoint (locked C1) (locked C2))"
  | "wf_cmd (Cif B C1 C2)   = (user_cmd C1 \<and> user_cmd C2 )"
  | "wf_cmd (Cwhile B C)    = (user_cmd C)"
  | "wf_cmd (Clocal x E C)  = (user_cmd C)"
  | "wf_cmd (Cinlocal x v C)= (wf_cmd C)"
  | "wf_cmd (Cresource r C) = (wf_cmd C)"
  | "wf_cmd (Cwith r B C)   = (user_cmd C)"
  | "wf_cmd (Cinwith r C)   = (wf_cmd C \<and> r \<notin> locked C)"

text {* Now, we establish some basic properties of well-formed commands: *}

text {* (1) User commands are well-formed and have no locks acquired. *}

lemma user_cmdD:
  "user_cmd C \<Longrightarrow> (wf_cmd C \<and> locked C = {})"
by (induct C, auto)

corollary user_cmd_wf[intro]:
  "user_cmd C \<Longrightarrow> wf_cmd C"
by (drule user_cmdD, simp)

corollary user_cmd_llocked[simp]:
  "user_cmd C \<Longrightarrow> llocked C = []"
by (drule user_cmdD, simp add: locked_eq)

text {* (2) Well-formedness is preserved under reduction. *}

lemma red_wf_cmd:
  "\<lbrakk> red C \<sigma> C' \<sigma>' ; wf_cmd C\<rbrakk> \<Longrightarrow> wf_cmd C'"
by (subgoal_tac "wf_cmd C \<longrightarrow> wf_cmd C'", erule_tac[2] red.induct, auto dest: user_cmdD)

text {* (3) Well-formed commands satisfy mutual-exclusion. *}

lemma wf_cmd_distinct_locked: "wf_cmd C \<Longrightarrow> distinct (llocked C)"
by (induct C, auto simp add: distinct_removeAll locked_eq disjoint_def)

subsection {* Free variables, updated variables and substitutions *}

text {* The free variables of expressions, boolean expressions, and
commands are defined as expected: *}

primrec
  fvE :: "exp \<Rightarrow> var set"
where
  "fvE (Evar v) = {v}"
| "fvE (Enum n) = {}"
| "fvE (Eplus e1 e2) = (fvE e1 \<union> fvE e2)"

primrec
  fvB :: "bexp \<Rightarrow> var set"
where
  "fvB (Beq e1 e2)  = (fvE e1 \<union> fvE e2)"
| "fvB (Band b1 b2) = (fvB b1 \<union> fvB b2)"
| "fvB (Bnot b)     = (fvB b)"

primrec
  fvC :: "cmd \<Rightarrow> var set"
where
  "fvC (Cskip)         = {}"
| "fvC (Cassign v E)   = ({v} \<union> fvE E)"
| "fvC (Cread v E)     = ({v} \<union> fvE E)"
| "fvC (Cwrite E1 E2)  = (fvE E1 \<union> fvE E2)"
| "fvC (Calloc v E)    = ({v} \<union> fvE E)"
| "fvC (Cdispose E)    = (fvE E)"
| "fvC (Cseq C1 C2)    = (fvC C1 \<union> fvC C2)"
| "fvC (Cpar C1 C2)    = (fvC C1 \<union> fvC C2)"
| "fvC (Cif B C1 C2)   = (fvB B \<union> fvC C1 \<union> fvC C2)"
| "fvC (Cwhile B C)    = (fvB B \<union> fvC C)"
| "fvC (Clocal x E C)  = (fvE E \<union> (fvC C - {x}))"
| "fvC (Cinlocal x v C)= (fvC C - {x})"
| "fvC (Cresource r C) = (fvC C)"
| "fvC (Cwith r B C)   = (fvB B \<union> fvC C)"
| "fvC (Cinwith r C)   = (fvC C)"

text {* Below, we define the set of syntactically updated variables
  of a command. This set overapproximates the set of variables that
  are actually updated during the command's execution. *}

primrec
  wrC :: "cmd \<Rightarrow> var set"
where
  "wrC (Cskip)         = {}"
| "wrC (Cassign v E)   = {v}"
| "wrC (Cread v E)     = {v}"
| "wrC (Cwrite E1 E2)  = {}"
| "wrC (Calloc v E)    = {v}"
| "wrC (Cdispose E)    = {}"
| "wrC (Cseq C1 C2)    = (wrC C1 \<union> wrC C2)"
| "wrC (Cpar C1 C2)    = (wrC C1 \<union> wrC C2)"
| "wrC (Cif B C1 C2)   = (wrC C1 \<union> wrC C2)"
| "wrC (Cwhile B C)    = (wrC C)"
| "wrC (Clocal x E C)  = (wrC C - {x})"
| "wrC (Cinlocal x v C)= (wrC C - {x})"
| "wrC (Cresource r C) = (wrC C)"
| "wrC (Cwith r B C)   = (wrC C)"
| "wrC (Cinwith r C)   = (wrC C)"

text {* We also define the operation of substituting an expression for
a variable in expressions. *}

primrec
  subE :: "var \<Rightarrow> exp \<Rightarrow> exp \<Rightarrow> exp"
where
  "subE x E (Evar y)      = (if x = y then E else Evar y)"
| "subE x E (Enum n)      = Enum n"
| "subE x E (Eplus e1 e2) = Eplus (subE x E e1) (subE x E e2)"

primrec
  subB :: "var \<Rightarrow> exp \<Rightarrow> bexp \<Rightarrow> bexp"
where
  "subB x E (Beq e1 e2)  = Beq (subE x E e1) (subE x E e2)"
| "subB x E (Band b1 b2) = Band (subB x E b1) (subB x E b2)"
| "subB x E (Bnot b)     = Bnot (subB x E b)"

text {* Basic properties of substitutions: *}

lemma subE_assign:
 "edenot (subE x E e) s = edenot e (s(x := edenot E s))"
by (induct e, simp_all)

lemma subB_assign:
 "bdenot (subB x E b) s = bdenot b (s(x := edenot E s))"
by (induct b, simp_all add: subE_assign fun_upd_def)

subsection {* Variable erasure *}

text {* The following function erases all assignments and reads to
  variables in the set @{term X}. *}

primrec
  rem_vars :: "var set \<Rightarrow> cmd \<Rightarrow> cmd"
where
    "rem_vars X Cskip          = Cskip"
  | "rem_vars X (Cassign x E)  = (if x \<in> X then Cseq Cskip Cskip else Cassign x E)"
  | "rem_vars X (Cread x E)    = (if x \<in> X then Cseq Cskip Cskip else Cread x E)"
  | "rem_vars X (Cwrite E E')  = Cwrite E E'"
  | "rem_vars X (Calloc x E)   = Calloc x E"
  | "rem_vars X (Cdispose E)   = Cdispose E"
  | "rem_vars X (Cseq C1 C2)   = Cseq (rem_vars X C1) (rem_vars X C2)"
  | "rem_vars X (Cpar C1 C2)   = Cpar (rem_vars X C1) (rem_vars X C2)"
  | "rem_vars X (Cif B C1 C2)  = Cif B (rem_vars X C1) (rem_vars X C2)"
  | "rem_vars X (Cwhile B C)   = Cwhile B (rem_vars X C)"
  | "rem_vars X (Clocal x E C) = Clocal x E (rem_vars (X - {x}) C)"
  | "rem_vars X (Cinlocal x v C) = Cinlocal x v (rem_vars (X - {x}) C)"
  | "rem_vars X (Cresource r C)  = Cresource r (rem_vars X C)"
  | "rem_vars X (Cwith r B C) = Cwith r B (rem_vars X C)"
  | "rem_vars X (Cinwith r C) = Cinwith r (rem_vars X C)"

text {* Properties of variable erasure: *}

lemma remvars_simps[simp]:
  "locked (rem_vars X C) = locked C"
  "llocked (rem_vars X C) = llocked C"
  "user_cmd (rem_vars X C) = user_cmd C"
  "rem_vars X (rem_vars X C) = rem_vars X C"
by (induct C arbitrary: X, simp_all)+

lemma accesses_remvars: "accesses (rem_vars X C) s \<subseteq> accesses C s"
by (induct C arbitrary: X s, simp_all, fast)

lemma writes_remvars[simp]:
  "writes (rem_vars X C) = writes C"
by (rule ext, induct C arbitrary: X, simp_all)

lemma skip_simps[simp]:
  "\<not> red Cskip \<sigma> C' \<sigma>'"
  "\<not> aborts Cskip \<sigma>"
  "(rem_vars X C = Cskip) \<longleftrightarrow> (C = Cskip)"
  "(Cskip = rem_vars X C) \<longleftrightarrow> (C = Cskip)"
by (auto elim: aborts.cases red.cases)
   (induct C, auto split: if_split_asm)+

lemma disjoint_minus: "disjoint (X - Z) Y = disjoint X (Y - Z)"
by (auto simp add: disjoint_def)

lemma aux_red[rule_format]:
  "red C \<sigma> C' \<sigma>' \<Longrightarrow> \<forall>X C1. C = rem_vars X C1 \<longrightarrow> disjoint X (fvC C) \<longrightarrow> \<not> aborts C1 \<sigma> \<longrightarrow>
   (\<exists>C2 s2. red C1 \<sigma> C2 (s2,snd \<sigma>') \<and> rem_vars X C2 = C' \<and> agrees (-X) (fst \<sigma>') s2)"
apply (erule_tac red.induct, simp_all, tactic {* ALLGOALS (clarify_tac @{context}) *})
apply (case_tac C1, simp_all split: if_split_asm, (fastforce simp add: agrees_def)+)
apply (case_tac[1-5] C1a, simp_all split: if_split_asm, (fastforce intro: agrees_refl)+)
apply (case_tac[!] C1, simp_all split: if_split_asm)
apply (tactic {* TRYALL (clarify_tac @{context}) *}, simp_all add: disjoint_minus [THEN sym])
apply (fastforce simp add: agrees_def)+
apply (intro exI conjI, rule_tac v=v in red_Alloc, (fastforce simp add: agrees_def)+)
done

lemma aborts_remvars:
  "aborts (rem_vars X C) \<sigma> \<Longrightarrow> aborts C \<sigma>"
apply (induct C arbitrary: X \<sigma>, erule_tac[!] aborts.cases, simp_all split: if_split_asm)
apply (tactic {* TRYALL (fast_tac @{context}) *})
apply (clarsimp, rule, erule contrapos_nn, simp, erule disjoint_search, rule accesses_remvars)+
done

subsection {* Basic properties of the semantics *}

lemma writes_accesses: "writes C s \<subseteq> accesses C s"
by (induct C arbitrary: s, auto)

text {* Proposition 4.1: Properties of basic properties of @{term red}. *}

lemma red_properties:
  "red C \<sigma> C' \<sigma>' \<Longrightarrow>
     fvC C' \<subseteq> fvC C
   \<and> wrC C' \<subseteq> wrC C
   \<and> agrees (- wrC C) (fst \<sigma>') (fst \<sigma>)"
by (erule red.induct, auto simp add: agrees_def)

text {* Proposition 4.2: Semantics does not depend on variables not free in the term *}

lemma exp_agrees: "agrees (fvE E) s s' \<Longrightarrow> edenot E s = edenot E s'"
by (simp add: agrees_def, induct E, auto)

lemma bexp_agrees: "agrees (fvB B) s s' \<Longrightarrow> bdenot B s = bdenot B s'"
by (induct B, auto simp add: exp_agrees)

lemma accesses_agrees: "agrees (fvC C) s s' \<Longrightarrow> accesses C s = accesses C s'"
apply (induct C arbitrary: s s', simp_all add: exp_agrees, clarsimp)
apply (erule mall2_impD, simp add: agrees_def)
done

lemma writes_agrees: "agrees (fvC C) s s' \<Longrightarrow> writes C s = writes C s'"
apply (induct C arbitrary: s s', simp_all add: exp_agrees, clarsimp)
apply (erule mall2_impD, simp add: agrees_def)
done

lemma red_agrees[rule_format]:
  "red C \<sigma> C' \<sigma>' \<Longrightarrow> \<forall>X s. agrees X (fst \<sigma>) s \<longrightarrow> snd \<sigma> = h \<longrightarrow> fvC C \<subseteq> X \<longrightarrow>
   (\<exists>s' h'. red C (s, h) C' (s', h') \<and> agrees X (fst \<sigma>') s' \<and> snd \<sigma>' = h')"
apply (erule red.induct, simp_all)
apply (tactic {* TRYALL (fast_tac @{context}) *}, auto)
apply (rule, rule conjI, rule red_If1, simp, subst bexp_agrees, fast+)
apply (rule, rule conjI, rule red_If2, simp, subst bexp_agrees, fast+)
apply (rule, rule conjI, rule, simp, subst exp_agrees, fast+)
apply (drule_tac a="X \<union> {x}" and b="sa(x:=v)" in all2_imp2D, fastforce simp add: agrees_def, fast)
 apply (clarsimp, rule, rule conjI, rule, fast+, fastforce simp add: agrees_def)
apply (rule, rule conjI, rule, simp, subst bexp_agrees, fast+)
apply (rule, rule, rule, fast, simp_all, subst exp_agrees, fast)
 apply (clarsimp simp add: agrees_def)
apply (rule, rule, rule, fast, simp_all, subst exp_agrees, fast, fast)
 apply (clarsimp simp add: agrees_def)
apply (rule, rule, rule, fast, simp_all, subst exp_agrees, fast, clarsimp?)
 apply (rule ext, clarsimp, fast intro: exp_agrees)
apply (rule, rule, rule_tac v=v in red_Alloc, simp_all, fast, auto)
 apply (rule ext, clarsimp, fast intro: exp_agrees)
 apply (clarsimp simp add: agrees_def)
apply (auto)
apply (rule, rule, rule, fast, simp_all)
 apply (rule ext, clarsimp, fast intro: exp_agrees)
done

lemma aborts_agrees[rule_format]:
  "aborts C \<sigma> \<Longrightarrow> \<forall>s'. agrees (fvC C) (fst \<sigma>) s' \<longrightarrow> snd \<sigma> = h' \<longrightarrow> aborts C (s', h')"
by (erule aborts.induct, simp_all, auto simp add: writes_agrees accesses_agrees exp_agrees,
    auto simp add: agrees_def)

text {* Corollaries of Proposition 4.2, useful for automation. *}

corollary exp_agrees2[simp]:
  "x \<notin> fvE E \<Longrightarrow> edenot E (s(x := v)) = edenot E s"
by (rule exp_agrees, simp add: agrees_def)

corollary bexp_agrees2[simp]:
  "x \<notin> fvB B \<Longrightarrow> bdenot B (s(x := v)) = bdenot B s"
by (rule bexp_agrees, simp add: agrees_def)

end


theory Proof_1_3
  imports HandDryer VCTheoryLemmas Extra
begin

theorem proof_1_3:
"VC3 inv1 s0 hands_value"
  apply(simp only: VC3_def inv1_def R1_def dryer_def)
  apply(rule impI; rule conjI)
proof -
  assume VC: " ((toEnvP s0 \<and>
      (\<forall>s1 s2.
          substate s1 s2 \<and>
          substate s2 s0 \<and>
          toEnvP s1 \<and>
          toEnvP s2 \<and>
          toEnvNum s1 s2 = hands \<and>
          getVarBool s1 hands = OFF \<and>
          getVarBool s1 (Suc (Suc 0)) = OFF \<and>
          getVarBool s2 hands = ON \<longrightarrow>
          (\<exists>s4. toEnvP s4 \<and>
                substate s2 s4 \<and>
                substate s4 s0 \<and>
                toEnvNum s2 s4 \<le> hands \<and>
                getVarBool s4 (Suc (Suc 0)) = ON \<and>
                (\<forall>s3. toEnvP s3 \<and>
                      substate s2 s3 \<and>
                      substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow>
                      getVarBool s3 hands = ON)))) \<and>
     extraInv s0) \<and>
    env (setVarAny s0 hands_value) hands_value \<and>
    getPstate (setVarAny s0 hands_value) Ctrl =
    waiting \<and>
    getVarBool (setVarAny s0 hands_value) hands \<noteq>
    ON "
  show "toEnvP
     (toEnv
       (setVarBool (setVarAny s0 hands_value)
         (Suc (Suc 0)) OFF)) \<and>
    (\<forall>s1 s2.
        substate s1 s2 \<and>
        substate s2
         (toEnv
           (setVarBool (setVarAny s0 hands_value)
             (Suc (Suc 0)) OFF)) \<and>
        toEnvP s1 \<and>
        toEnvP s2 \<and>
        toEnvNum s1 s2 = hands \<and>
        getVarBool s1 hands = OFF \<and>
        getVarBool s1 (Suc (Suc 0)) = OFF \<and>
        getVarBool s2 hands = ON \<longrightarrow>
        (\<exists>s4. toEnvP s4 \<and>
              substate s2 s4 \<and>
              substate s4
               (toEnv
                 (setVarBool
                   (setVarAny s0 hands_value)
                   (Suc (Suc 0)) OFF)) \<and>
              toEnvNum s2 s4 \<le> hands \<and>
              getVarBool s4 (Suc (Suc 0)) = ON \<and>
              (\<forall>s3. toEnvP s3 \<and>
                    substate s2 s3 \<and>
                    substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow>
                    getVarBool s3 hands = ON)))"
    apply(rule conjI)
     apply(simp)
  proof(rule allI; rule allI; rule impI)
    fix s1 s2
    assume req_prems: " substate s1 s2 \<and>
       substate s2
        (toEnv
                 (setVarBool
                   (setVarAny s0 hands_value)
                   (Suc (Suc 0)) OFF)) \<and>
       toEnvP s1 \<and>
       toEnvP s2 \<and>
       toEnvNum s1 s2 = hands \<and>
       getVarBool s1 hands = OFF \<and>
       getVarBool s1 (Suc (Suc 0)) = OFF \<and>
       getVarBool s2 hands = ON "
    show " \<exists>s4. toEnvP s4 \<and>
            substate s2 s4 \<and>
            substate s4
            (toEnv
                 (setVarBool
                   (setVarAny s0 hands_value)
                   (Suc (Suc 0)) OFF)) \<and>
            toEnvNum s2 s4 \<le> hands \<and>
            getVarBool s4 (Suc (Suc 0)) = ON \<and>
            (\<forall>s3. toEnvP s3 \<and>
                  substate s2 s3 \<and>
                  substate s3 s4 \<and>
                  s3 \<noteq> s4 \<longrightarrow>
                  getVarBool s3 hands = ON)"
    proof cases
      assume 1: "s2 = (toEnv
                 (setVarBool
                   (setVarAny s0 hands_value)
                   (Suc (Suc 0)) OFF))"
      have " (toEnvP s2 \<and>
         substate s2 s2 \<and>
         substate s2
         (toEnv
                 (setVarBool
                   (setVarAny s0 hands_value)
                   (Suc (Suc 0)) OFF)) \<and>
         toEnvNum s2 s2 \<le> hands \<and>
         getVarBool s2 (Suc (Suc 0)) = ON) \<and>
         (\<forall>s3. toEnvP s3 \<and>
               substate s2 s3 \<and>
               substate s3 s2 \<and>
               s3 \<noteq> s2 \<longrightarrow>
               getVarBool s3 hands = ON)"
      proof
        from 1  VC req_prems show "toEnvP s2 \<and>
    substate s2 s2 \<and>
    substate s2
    (toEnv
                 (setVarBool
                   (setVarAny s0 hands_value)
                   (Suc (Suc 0)) OFF)) \<and>
    toEnvNum s2 s2 \<le> hands \<and>
    getVarBool s2 (Suc (Suc 0)) = ON" by auto
      next
        from substate_asym show " \<forall>s3. toEnvP s3 \<and>
         substate s2 s3 \<and>
         substate s3 s2 \<and> s3 \<noteq> s2 \<longrightarrow>
         getVarBool s3 hands = ON"
          by auto
      qed
      thus ?thesis by blast
    next
       assume 1: "s2 \<noteq> (toEnv
                 (setVarBool
                   (setVarAny s0 hands_value)
                   (Suc (Suc 0)) OFF))"
       with req_prems have 2: "substate s2 s0"
         by (simp split: if_splits)
       from VC req_prems 2 obtain "\<exists>s4. toEnvP s4 \<and>
           substate s2 s4 \<and>
           substate s4 s0 \<and>
           toEnvNum s2 s4 \<le> hands \<and>
           getVarBool s4 (Suc (Suc 0)) = ON \<and>
           (\<forall>s3. toEnvP s3 \<and>
                 substate s2 s3 \<and>
                 substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow>
                 getVarBool s3 hands = ON)"by auto
       then obtain s4 where 3: "toEnvP s4 \<and>
           substate s2 s4 \<and>
           substate s4 s0 \<and>
           toEnvNum s2 s4 \<le> hands \<and>
           getVarBool s4 (Suc (Suc 0)) = ON \<and>
           (\<forall>s3. toEnvP s3 \<and>
                 substate s2 s3 \<and>
                 substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow>
                 getVarBool s3 hands = ON)" ..
       have "toEnvP s4 \<and>
      substate s2 s4 \<and>
      substate s4
       (toEnv
                 (setVarBool
                   (setVarAny s0 hands_value)
                   (Suc (Suc 0)) OFF)) \<and>
      toEnvNum s2 s4 \<le> hands \<and>
      getVarBool s4 (Suc (Suc 0)) = ON \<and>
      (\<forall>s3. toEnvP s3 \<and>
            substate s2 s3 \<and>
            substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow>
            getVarBool s3 hands = ON)"
         using 3 by auto
       thus ?thesis ..
     qed
   qed
 next
   assume VC: " ((toEnvP s0 \<and>
      (\<forall>s1 s2.
          substate s1 s2 \<and>
          substate s2 s0 \<and>
          toEnvP s1 \<and>
          toEnvP s2 \<and>
          toEnvNum s1 s2 = hands \<and>
          getVarBool s1 hands = OFF \<and>
          getVarBool s1 (Suc (Suc 0)) = OFF \<and>
          getVarBool s2 hands = ON \<longrightarrow>
          (\<exists>s4. toEnvP s4 \<and>
                substate s2 s4 \<and>
                substate s4 s0 \<and>
                toEnvNum s2 s4 \<le> hands \<and>
                getVarBool s4 (Suc (Suc 0)) = ON \<and>
                (\<forall>s3. toEnvP s3 \<and>
                      substate s2 s3 \<and>
                      substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow>
                      getVarBool s3 hands = ON)))) \<and>
     extraInv s0) \<and>
    env (setVarAny s0 hands_value) hands_value \<and>
    getPstate (setVarAny s0 hands_value) Ctrl =
    waiting \<and>
    getVarBool (setVarAny s0 hands_value) hands \<noteq>
    ON "
   print_state
   with extra3 show "extraInv
     (toEnv
       (setVarBool (setVarAny s0 hands_value)
         (Suc (Suc 0)) OFF))"
     by (auto simp add: VC3_def dryer_def)
 qed

end


(*  Title:      Containers/AssocList.thy
    Author:     Andreas Lochbihler, KIT *)

theory AssocList imports
  "HOL-Library.DAList"
begin

section \<open>Additional operations for associative lists\<close>

subsection \<open>Operations on the raw type\<close>

primrec update_with_aux :: "'val \<Rightarrow> 'key \<Rightarrow> ('val \<Rightarrow> 'val) \<Rightarrow> ('key \<times> 'val) list \<Rightarrow> ('key \<times> 'val) list"
where
  "update_with_aux v k f [] = [(k, f v)]"
| "update_with_aux v k f (p # ps) = (if (fst p = k) then (k, f (snd p)) # ps else p # update_with_aux v k f ps)"

text \<open>
  Do not use @{term "AList.delete"} because this traverses all the list even if it has found the key.
  We do not have to keep going because we use the invariant that keys are distinct.
\<close>
fun delete_aux :: "'key \<Rightarrow> ('key \<times> 'val) list \<Rightarrow> ('key \<times> 'val) list"
where
  "delete_aux k [] = []"
| "delete_aux k ((k', v) # xs) = (if k = k' then xs else (k', v) # delete_aux k xs)"

definition zip_with_index_from :: "nat \<Rightarrow> 'a list \<Rightarrow> (nat \<times> 'a) list" where
  "zip_with_index_from n xs = zip [n..<n + length xs] xs"

abbreviation zip_with_index :: "'a list \<Rightarrow> (nat \<times> 'a) list" where
  "zip_with_index \<equiv> zip_with_index_from 0"

lemma update_conv_update_with_aux:
  "AList.update k v xs = update_with_aux v k (\<lambda>_. v) xs"
by(induct xs) simp_all

lemma map_of_update_with_aux':
  "map_of (update_with_aux v k f ps) k' = ((map_of ps)(k \<mapsto> (case map_of ps k of None \<Rightarrow> f v | Some v \<Rightarrow> f v))) k'"
by(induct ps) auto

lemma map_of_update_with_aux:
  "map_of (update_with_aux v k f ps) = (map_of ps)(k \<mapsto> (case map_of ps k of None \<Rightarrow> f v | Some v \<Rightarrow> f v))"
by(simp add: fun_eq_iff map_of_update_with_aux')

lemma dom_update_with_aux: "fst ` set (update_with_aux v k f ps) = {k} \<union> fst ` set ps"
  by (induct ps) auto

lemma distinct_update_with_aux [simp]:
  "distinct (map fst (update_with_aux v k f ps)) = distinct (map fst ps)"
by(induct ps)(auto simp add: dom_update_with_aux)

lemma set_update_with_aux:
  "distinct (map fst xs)
  \<Longrightarrow> set (update_with_aux v k f xs) = (set xs - {k} \<times> UNIV \<union> {(k, f (case map_of xs k of None \<Rightarrow> v | Some v \<Rightarrow> v))})"
by(induct xs)(auto intro: rev_image_eqI)

lemma set_delete_aux: "distinct (map fst xs) \<Longrightarrow> set (delete_aux k xs) = set xs - {k} \<times> UNIV"
apply(induct xs)
apply simp_all
apply clarsimp
apply(fastforce intro: rev_image_eqI)
done

lemma dom_delete_aux: "distinct (map fst ps) \<Longrightarrow> fst ` set (delete_aux k ps) = fst ` set ps - {k}"
by(auto simp add: set_delete_aux)

lemma distinct_delete_aux [simp]:
  "distinct (map fst ps) \<Longrightarrow> distinct (map fst (delete_aux k ps))"
proof(induct ps)
  case Nil thus ?case by simp
next
  case (Cons a ps)
  obtain k' v where a: "a = (k', v)" by(cases a)
  show ?case
  proof(cases "k' = k")
    case True with Cons a show ?thesis by simp
  next
    case False
    with Cons a have "k' \<notin> fst ` set ps" "distinct (map fst ps)" by simp_all
    with False a have "k' \<notin> fst ` set (delete_aux k ps)"
      by(auto dest!: dom_delete_aux[where k=k])
    with Cons a show ?thesis by simp
  qed
qed

lemma map_of_delete_aux':
  "distinct (map fst xs) \<Longrightarrow> map_of (delete_aux k xs) = (map_of xs)(k := None)"
by(induct xs)(fastforce simp add: map_of_eq_None_iff fun_upd_twist)+

lemma map_of_delete_aux:
  "distinct (map fst xs) \<Longrightarrow> map_of (delete_aux k xs) k' = ((map_of xs)(k := None)) k'"
by(simp add: map_of_delete_aux')

lemma delete_aux_eq_Nil_conv: "delete_aux k ts = [] \<longleftrightarrow> ts = [] \<or> (\<exists>v. ts = [(k, v)])"
by(cases ts)(auto split: if_split_asm)

lemma zip_with_index_from_simps [simp, code]:
  "zip_with_index_from n [] = []"
  "zip_with_index_from n (x # xs) = (n, x) # zip_with_index_from (Suc n) xs"
  by(simp_all add: zip_with_index_from_def upt_rec del: upt.upt_Suc)

lemma zip_with_index_from_append [simp]:
  "zip_with_index_from n (xs @ ys) = zip_with_index_from n xs @ zip_with_index_from (n + length xs) ys"
  by(simp add: zip_with_index_from_def zip_append[symmetric] upt_add_eq_append[symmetric] del: zip_append)
    (simp add: add.assoc)

lemma zip_with_index_from_conv_nth:
  "zip_with_index_from n xs = map (\<lambda>i. (n + i, xs ! i)) [0..<length xs]"
  by(induction xs rule: rev_induct)(auto simp add: nth_append)

lemma map_of_zip_with_index_from [simp]:
  "map_of (zip_with_index_from n xs) i = (if i \<ge> n \<and> i < n + length xs then Some (xs ! (i - n)) else None)"
  by(auto simp add: zip_with_index_from_def set_zip intro: exI[where x="i - n"])

lemma map_of_map': "map_of (map (\<lambda>(k, v). (k, f k v)) xs) x = map_option (f x) (map_of xs x)"
  by (induct xs)(auto)

subsection \<open>Operations on the abstract type @{typ "('a, 'b) alist"}\<close>

lift_definition update_with :: "'v \<Rightarrow> 'k \<Rightarrow> ('v \<Rightarrow> 'v) \<Rightarrow> ('k, 'v) alist \<Rightarrow> ('k, 'v) alist"
  is "update_with_aux" by simp

lift_definition delete :: "'k \<Rightarrow> ('k, 'v) alist \<Rightarrow> ('k, 'v) alist" is "delete_aux"
by simp

lift_definition keys :: "('k, 'v) alist \<Rightarrow> 'k set" is "set \<circ> map fst" .

lift_definition set :: "('key, 'val) alist \<Rightarrow> ('key \<times> 'val) set"
is "List.set" .

lift_definition map_values :: "('key \<Rightarrow> 'val \<Rightarrow> 'val') \<Rightarrow> ('key, 'val) alist \<Rightarrow> ('key, 'val') alist" is
  "\<lambda>f. map (\<lambda>(x,y). (x, f x y))"
  by(simp add: o_def split_def)

lemma lookup_update_with [simp]:
  "DAList.lookup (update_with v k f al) = (DAList.lookup al)(k \<mapsto> case DAList.lookup al k of None \<Rightarrow> f v | Some v \<Rightarrow> f v)"
by transfer(simp add: map_of_update_with_aux)

lemma lookup_delete [simp]: "DAList.lookup (delete k al) = (DAList.lookup al)(k := None)"
by transfer(simp add: map_of_delete_aux')

lemma finite_dom_lookup [simp, intro!]: "finite (dom (DAList.lookup m))"
by transfer(simp add: finite_dom_map_of)

lemma update_conv_update_with: "DAList.update k v = update_with v k (\<lambda>_. v)"
by(rule ext)(transfer, simp add: update_conv_update_with_aux)

lemma lookup_update [simp]: "DAList.lookup (DAList.update k v al) = (DAList.lookup al)(k \<mapsto> v)"
by(simp add: update_conv_update_with split: option.split)

lemma dom_lookup_keys: "dom (DAList.lookup al) = keys al"
by transfer(simp add: dom_map_of_conv_image_fst)

lemma keys_empty [simp]: "keys DAList.empty = {}"
by transfer simp

lemma keys_update_with [simp]: "keys (update_with v k f al) = insert k (keys al)"
by(simp add: dom_lookup_keys[symmetric])

lemma keys_update [simp]: "keys (DAList.update k v al) = insert k (keys al)"
by(simp add: update_conv_update_with)

lemma keys_delete [simp]: "keys (delete k al) = keys al - {k}"
by(simp add: dom_lookup_keys[symmetric])

lemma set_empty [simp]: "set DAList.empty = {}"
by transfer simp

lemma set_update_with:
  "set (update_with v k f al) =
  (set al - {k} \<times> UNIV \<union> {(k, f (case DAList.lookup al k of None \<Rightarrow> v | Some v \<Rightarrow> v))})"
by transfer(simp add: set_update_with_aux)

lemma set_update: "set (DAList.update k v al) = (set al - {k} \<times> UNIV \<union> {(k, v)})"
by(simp add: update_conv_update_with set_update_with)

lemma set_delete: "set (delete k al) = set al - {k} \<times> UNIV"
by transfer(simp add: set_delete_aux)

lemma size_dalist_transfer [transfer_rule]:
  includes lifting_syntax
  shows "(pcr_alist (=) (=) ===> (=)) length size"
unfolding size_alist_def[abs_def]
by transfer_prover

lemma size_eq_card_dom_lookup: "size al = card (dom (DAList.lookup al))"
by transfer (metis comp_apply distinct_card dom_map_of_conv_image_fst image_set length_map)

hide_const (open) update_with keys set delete

end