theory SINVAR_Dependability_norefl_impl
imports SINVAR_Dependability_norefl "../TopoS_Interface_impl"
begin

code_identifier code_module SINVAR_Dependability_norefl_impl => (Scala) SINVAR_Dependability_norefl

subsubsection {* SecurityInvariant Dependability norefl List Implementation *}

fun sinvar :: "'v list_graph \<Rightarrow> ('v \<Rightarrow> dependability_level) \<Rightarrow> bool" where
  "sinvar G nP = (\<forall> (e1,e2) \<in> set (edgesL G). (num_reachable_norefl G e1) \<le> (nP e1))"

value "sinvar
    \<lparr> nodesL = [1::nat,2,3,4], edgesL = [(1,2), (2,3), (3,4), (8,9),(9,8)] \<rparr>
    (\<lambda>e. 3)"
value "sinvar
    \<lparr> nodesL = [1::nat,2,3,4,8,9,10], edgesL = [(1,2), (2,3), (3,4), (8,9),(9,8)] \<rparr>
    (\<lambda>e. 2)"

definition Dependability_norefl_offending_list:: "'v list_graph \<Rightarrow> ('v \<Rightarrow> dependability_level) \<Rightarrow> ('v \<times> 'v) list list" where
  "Dependability_norefl_offending_list = Generic_offending_list sinvar"

definition "NetModel_node_props P = (\<lambda> i. (case (node_properties P) i of Some property \<Rightarrow> property | None \<Rightarrow> SINVAR_Dependability_norefl.default_node_properties))"

definition "Dependability_norefl_eval G P = (wf_list_graph G \<and>
  sinvar G (SecurityInvariant.node_props SINVAR_Dependability_norefl.default_node_properties P))"

lemma sinvar_correct: "wf_list_graph G \<Longrightarrow> SINVAR_Dependability_norefl.sinvar (list_graph_to_graph G) nP = sinvar G nP"
   apply(simp)
   apply(rule all_edges_list_I)
   apply(simp add: fun_eq_iff)
   apply(clarify)
   apply(rename_tac x)
   apply(drule_tac v="x" in  num_reachable_norefl_correct)
   apply presburger
done

interpretation Dependability_norefl_impl:TopoS_List_Impl
  where default_node_properties=SINVAR_Dependability_norefl.default_node_properties
  and sinvar_spec=SINVAR_Dependability_norefl.sinvar
  and sinvar_impl=sinvar
  and receiver_violation=SINVAR_Dependability_norefl.receiver_violation
  and offending_flows_impl=Dependability_norefl_offending_list
  and node_props_impl=NetModel_node_props
  and eval_impl=Dependability_norefl_eval
 apply(unfold TopoS_List_Impl_def)
 apply(rule conjI)
  apply(rule conjI)
   apply(simp add: TopoS_Dependability_norefl; fail)
  apply(intro allI impI)
  apply(fact sinvar_correct)
 apply(rule conjI)
  apply(unfold Dependability_norefl_offending_list_def)
  apply(intro allI impI)
  apply(rule Generic_offending_list_correct)
   apply(assumption)
  apply(simp only: sinvar_correct)
 apply(rule conjI)
  apply(intro allI)
  apply(simp only: NetModel_node_props_def)
  apply(metis Dependability.node_props.simps Dependability.node_props_eq_node_props_formaldef)
 apply(simp only: Dependability_norefl_eval_def)
 apply(intro allI impI)
 apply(rule TopoS_eval_impl_proofrule[OF TopoS_Dependability_norefl])
 apply(simp only: sinvar_correct)
done

subsubsection {* packing *}
  definition SINVAR_LIB_Dependability_norefl :: "('v::vertex, SINVAR_Dependability_norefl.dependability_level) TopoS_packed" where
    "SINVAR_LIB_Dependability_norefl \<equiv>
    \<lparr> nm_name = ''Dependability_norefl'',
      nm_receiver_violation = SINVAR_Dependability_norefl.receiver_violation,
      nm_default = SINVAR_Dependability_norefl.default_node_properties,
      nm_sinvar = sinvar,
      nm_offending_flows = Dependability_norefl_offending_list,
      nm_node_props = NetModel_node_props,
      nm_eval = Dependability_norefl_eval
      \<rparr>"
  interpretation SINVAR_LIB_Dependability_norefl_interpretation: TopoS_modelLibrary SINVAR_LIB_Dependability_norefl
      SINVAR_Dependability_norefl.sinvar
    apply(unfold TopoS_modelLibrary_def SINVAR_LIB_Dependability_norefl_def)
    apply(rule conjI)
     apply(simp)
    apply(simp)
    by(unfold_locales)

hide_fact (open) sinvar_correct
hide_const (open) sinvar NetModel_node_props

end


(*<*)
(*
   Title: Gateway_proof.thy  (Gateway: Verification)
   Author: Maria Spichkova <maria.spichkova at rmit.edu.au>, 2013
*)
(*>*)

(* header {*Gateway: Verification *} *)

theory Gateway_proof
imports Gateway_proof_aux
begin

subsection {* Properties of the Gateway *}

lemma Gateway_L1:
  assumes h1:"Gateway req dt a stop lose d ack i vc"
      and h2:"msg (Suc 0) req"
      and h3:"msg (Suc 0) a"
      and h4:"msg (Suc 0) stop"
      and h5:"ts lose"
      and h6:"ack t = [init_state]"
      and h7:"req (Suc t) = [init]"
      and h8:"lose (Suc t) = [False]"
      and h9:"lose (Suc (Suc t)) = [False]"
  shows "ack (Suc (Suc t)) = [connection_ok]"
proof -
  from h1 obtain i1 i2 x y
    where a1:"Sample req dt x stop lose ack i1 vc"
      and a2:"Delay y i1 d x i2"
      and a3:"Loss lose a i2 y i"
    by (simp only: Gateway_def, auto)
  from a2 and a3 and h3 have sg1:"msg (Suc 0) x"
    by (simp add: Loss_Delay_msg_a)
  from a1 and h2 and h4 and sg1 obtain st buffer where a4:
    "tiTable_SampleT req x stop lose
        (fin_inf_append [init_state] st) (fin_inf_append [[]] buffer) ack
         i1 vc st"
     by (simp add: Sample_def Sample_L_def, auto)
  from a4 and h5 and sg1 and h4 have sg2:"st t =  hd (ack t)"
    by (simp add: tiTable_ack_st_hd)
  from h6 and sg1 and sg2 and h4 have sg3:
   "(fin_inf_append [init_state] st) (Suc t) = init_state"
    by (simp add: correct_fin_inf_append1)
  from a4 and h7 and sg3 have sg4:"st (Suc t) = call"
    by (simp add: tiTable_SampleT_def)
  from sg4 have sg5:"(fin_inf_append [init_state] st) (Suc (Suc t)) = call"
    by (simp add: correct_fin_inf_append1)
  from a4 and sg5 and assms show ?thesis
    by (simp add: tiTable_SampleT_def)
qed

lemma Gateway_L2:
  assumes h1:"Gateway req dt a stop lose d ack i vc"
      and h2:"msg (Suc 0) req"
      and h3:"msg (Suc 0) a"
      and h4:"msg (Suc 0) stop"
      and h5:"ts lose"
      and h6:"ack t = [connection_ok]"
      and h7:"req (Suc t) = [send]"
      and h8:"\<forall>k\<le>Suc d. lose (t + k) = [False]"
  shows "i (Suc (t + d))  = inf_last_ti dt t"
proof -
  from h1 obtain i1 i2 x y
    where a1:"Sample req dt x stop lose ack i1 vc"
      and a2:"Delay y i1 d x i2"
      and a3:"Loss lose a i2 y i"
    by (simp only: Gateway_def, auto)
  from a2 and a3 and h3 have sg1:"msg (Suc 0) x"
    by (simp add: Loss_Delay_msg_a)
  from a1 and h2 and h4 and sg1 obtain st buffer where a4:
    "Sample_L req dt x stop lose (fin_inf_append [init_state] st)
         (fin_inf_append [[]] buffer) ack i1 vc st buffer"
    by (simp add: Sample_def, auto)
  from a4 have sg2:"buffer t = inf_last_ti dt t"
    by (simp add: Sample_L_buffer)
  from assms and a1 and a4 and sg1 and sg2 have sg3:"i1 (Suc t) =  buffer t"
    by (simp add: Sample_L_i1_buffer)
  from a2 and sg1 have sg4:"i2 ((Suc t) + d)  =  i1 (Suc t)"
    by (simp add: Delay_def)
  from a3 and h8 have sg5:"i ((Suc t) + d)  =  i2 ((Suc t) + d)"
    by (simp add: Loss_def, auto)
  from sg5 and sg4 and sg3 and sg2 show ?thesis by simp
qed

lemma Gateway_L3:
  assumes h1:"Gateway req dt a stop lose d ack i vc"
      and h2:"msg (Suc 0) req"
      and h3:"msg (Suc 0) a"
      and h4:"msg (Suc 0) stop"
      and h5:"ts lose"
      and h6:"ack t = [connection_ok]"
      and h7:"req (Suc t) = [send]"
      and h8:"\<forall>k\<le>Suc d. lose (t + k) = [False]"
  shows "ack (Suc t) = [sending_data]"
proof -
  from h1 obtain i1 i2 x y
    where a1:"Sample req dt x stop lose ack i1 vc"
      and a2:"Delay y i1 d x i2"
      and a3:"Loss lose a i2 y i"
    by (simp only: Gateway_def, auto)
  from a2 and a3 and h3 have sg1:"msg (Suc 0) x"
    by (simp add: Loss_Delay_msg_a)
  from a1 and h2 and h4 and sg1 obtain st buffer where a4:
    "tiTable_SampleT req x stop lose
        (fin_inf_append [init_state] st) (fin_inf_append [[]] buffer) ack
         i1 vc st"
     by (simp add: Sample_def Sample_L_def, auto)
  from a4 and h5 and sg1 and h4 have sg2:"st t =  hd (ack t)"
    by (simp add: tiTable_ack_st_hd)
  from sg2 and h6 have sg3:"(fin_inf_append [init_state] st) (Suc t) = connection_ok"
    by (simp add: correct_fin_inf_append1)
  from h8 have sg4:"lose (Suc t) = [False]" by auto
  from a4 and sg3 and sg4 and h7 have sg5:"st (Suc t) = sending_data"
    by (simp add: tiTable_SampleT_def)
  from a4 and h2 and sg1 and h4 and h5 have sg6:"ack (Suc t) = [st (Suc t)]"
    by (simp add: tiTable_ack_st)
  from sg5 and sg6 show ?thesis by simp
qed

lemma Gateway_L4:
  assumes h1:"Gateway req dt a stop lose d ack i vc"
      and h2:"msg (Suc 0) req"
      and h3:"msg (Suc 0) a"
      and h4:"msg (Suc 0) stop"
      and h5:"ts lose"
      and h6:"ack (t + d) = [sending_data]"
      and h7:"a (Suc t) = [sc_ack]"
      and h8:"\<forall>k\<le>Suc d. lose (t + k) = [False]"
  shows "vc (Suc (t + d)) = [vc_com]"
proof -
  from h1 obtain i1 i2 x y
    where a1:"Sample req dt x stop lose ack i1 vc"
       and a2:"Delay y i1 d x i2"
       and a3:"Loss lose a i2 y i"
    by (simp only: Gateway_def, auto)
  from a2 and a3 and h3 have sg1:"msg (Suc 0) x"
    by (simp add: Loss_Delay_msg_a)
  from a1 and h2 and h4 and sg1 obtain st buffer where a4:
    "tiTable_SampleT req x stop lose
        (fin_inf_append [init_state] st) (fin_inf_append [[]] buffer) ack
         i1 vc st"
     by (simp add: Sample_def Sample_L_def, auto)
  from a4 and h5 and sg1 and h4 have sg2:"st (t+d) =  hd (ack (t+d))"
    by (simp add: tiTable_ack_st_hd)
  from sg2 and h6 have sg3:"(fin_inf_append [init_state] st) (Suc (t+d)) = sending_data"
    by (simp add: correct_fin_inf_append1)
  from a3 and h8 have sg4:"y (Suc t)  =  a (Suc t)"
    by (simp add: Loss_def, auto)
  from a2 and sg1 have sg5:"x ((Suc t) + d)  =  y (Suc t)"
    by (simp add: Delay_def)
  from sg5 and sg4 and h7 have sg6:" x (Suc (t + d)) = [sc_ack]" by simp
  from h8 have sg7:"lose (Suc (t + d)) = [False]" by auto
  from sg6 and a4 and h2 and sg1 and h4 and h5 and sg7 and sg3 show ?thesis
    by (simp add: tiTable_SampleT_def)
qed

lemma Gateway_L5:
  assumes h1:"Gateway req dt a stop lose d ack i vc"
      and h2:"msg (Suc 0) req"
      and h3:"msg (Suc 0) a"
      and h4:"msg (Suc 0) stop"
      and h5:"ts lose"
      and h6:"ack (t + d) = [sending_data]"
      and h7:"\<forall> j \<le> Suc d. a (t+j) = []"
      and h8:"\<forall>k\<le> (d + d). lose (t + k) = [False]"
  shows "j \<le> d \<longrightarrow> ack (t+d+j) = [sending_data]"
proof -
  from h1 obtain i1 i2 x y
    where a1:"Sample req dt x stop lose ack i1 vc"
       and a2:"Delay y i1 d x i2"
       and a3:"Loss lose a i2 y i"
    by (simp only: Gateway_def, auto)
  from a2 and a3 and h3 have sg1:"msg (Suc 0) x"
    by (simp add: Loss_Delay_msg_a)
  from a1 and h2 and h4 and sg1 obtain st buffer where a4:
    "tiTable_SampleT req x stop lose
        (fin_inf_append [init_state] st) (fin_inf_append [[]] buffer) ack
         i1 vc st"
     by (simp add: Sample_def Sample_L_def, auto)
  from assms and a2 and a3 and sg1 and a4 show ?thesis
  proof (induct j)
    case 0 then show ?case by simp
  next
    case (Suc j)
    then show ?case
    proof (cases "Suc j \<le> d")
      assume "\<not> Suc j \<le> d" then show ?thesis by simp
    next
      assume a0:"Suc j \<le> d"
      then have "d + Suc j \<le> d + d"   by arith
      then have sg3:"Suc (d + j) \<le> d + d" by arith
      from a4 and h2 and sg1 and h4 and h5 have sg4:
       "st (t+d+j) =  hd (ack (t+d+j))"
        by (simp add: tiTable_ack_st_hd)
      from Suc and a0 and sg4 have sg5:
       "(fin_inf_append [init_state] st) (Suc (t+d+j)) = sending_data"
        by (simp add: correct_fin_inf_append1)
      from h7 and a0  have sg6:"\<forall>j\<le> d. a (t + Suc j) = []" by auto
      from sg6 and a3 and a0 and h5 have sg7:"y (t + (Suc j)) = []"
        by (rule Loss_L5Suc)
      from sg7 and a2 have sg8a:"x (t + d + (Suc j)) = []"
        by (simp add: Delay_def)
      then  have sg8:"x (Suc (t + d + j)) = []" by simp
      have sg9:"Suc (t + d + j) = Suc (t + (d + j))" by arith
      from a4 have sg10:
        "fin_inf_append [init_state] st (Suc (t + d + j)) = sending_data \<and>
         x (Suc (t + d + j)) = [] \<and>
         lose (Suc (t + d + j)) = [False] \<longrightarrow>
         ack (Suc (t + d + j)) = [sending_data]"
        by (simp add: tiTable_SampleT_def)
      from h8 and sg3 have sg11:"lose (t + Suc (d + j)) = [False]" by blast
      have "Suc (t + d + j) = t + Suc (d + j)"  by arith
      from this and sg11 have "lose (Suc (t + d + j)) = [False]"
        by  (simp (no_asm_simp), simp)
     from sg10 and sg5 and sg8a and this show ?thesis by simp
    qed
  qed
qed

lemma Gateway_L6_induction:
 assumes h1:"msg (Suc 0) req"
     and h2:"msg (Suc 0) x"
     and h3:"msg (Suc 0) stop"
     and h4:"ts lose"
     and h5:"\<forall>j\<le> k. lose (t + j) = [False]"
     and h6:"\<forall>m \<le> k. req (t + m) \<noteq> [send]"
     and h7:"ack t = [connection_ok]"
     and h8:"Sample req dt x1 stop lose ack i1 vc"
     and h9:"Delay x2 i1 d x1 i2"
     and h10:"Loss lose x i2 x2 i"
     and h11:"m \<le> k"
 shows "ack (t + m) = [connection_ok]"
using assms
proof (induct m)
  case 0 then show ?case  by simp
next
  case (Suc m)
  then have sg1:"msg (Suc 0) x1" by (simp add:  Loss_Delay_msg_a)
  from Suc and this obtain st buffer where
    a1:"tiTable_SampleT req x1 stop lose (fin_inf_append [init_state] st)
         (fin_inf_append [[]] buffer) ack i1 vc st"  and
    a2:"\<forall> t. buffer t = (if dt t = [] then fin_inf_append [[]] buffer t else dt t)"
    by (simp add: Sample_def Sample_L_def, auto)
  from a1 and sg1 and h3 and h4 have sg2:"st (t + m) =  hd (ack (t + m))"
    by (simp add: tiTable_ack_st_hd)
  from Suc have sg3:"ack (t + m) = [connection_ok]" by simp
  from a1 and sg2 and sg3 have sg4:
  "(fin_inf_append [init_state] st) (Suc (t + m)) = connection_ok"
    by (simp add: fin_inf_append_def)
  from Suc have sg5:"Suc m \<le> k" by simp
  from sg5 and h5 have sg6:"lose (Suc (t + m)) = [False]" by auto
  from h6 and sg5 have sg7:"req (Suc (t + m)) \<noteq> [send]" by auto
  from a1 and sg3 and sg4 and sg5 and sg6 and sg7 show ?case
    by (simp add: tiTable_SampleT_def)
qed

lemma Gateway_L6:
 assumes "Gateway req dt a stop lose d ack i vc"
     and "\<forall>m\<le>k. req (t + m) \<noteq> [send]"
     and "\<forall>j\<le>k. lose (t + j) = [False]"
     and "ack t = [connection_ok]"
     and "msg (Suc 0) req"
     and "msg (Suc 0) stop"
     and "msg (Suc 0) a"
     and "ts lose"
 shows "\<forall>m\<le>k. ack (t + m) = [connection_ok]"
using assms
by (simp add: Gateway_def, clarify, simp add: Gateway_L6_induction)

lemma Gateway_L6a:
 assumes "Gateway req dt a stop lose d ack i vc"
     and "\<forall>m\<le>k. req (t + 2 + m) \<noteq> [send]"
     and "\<forall>j\<le>k. lose (t + 2 + j) = [False]"
     and "ack (t + 2) = [connection_ok]"
     and "msg (Suc 0) req"
     and "msg (Suc 0) stop"
     and "msg (Suc 0) a"
     and "ts lose"
 shows "\<forall>m\<le>k. ack (t + 2 + m) = [connection_ok]"
using assms by (rule Gateway_L6)

lemma aux_k3req:
assumes h1:"\<forall>m<k + 3. req (t + m) \<noteq> [send]"
       and h2:"m \<le> k"
shows "req (Suc (Suc (t + m))) \<noteq> [send]"
proof -
  from h2 have "m + 2 < k + 3" by arith
  from h1 and this have "req (t + (m + 2)) \<noteq> [send]" by blast
  then show ?thesis by simp
qed

lemma aux3lose:
assumes h1:"\<forall>j\<le>k + d + 3. lose (t + j) = [False]"
       and h2:"j \<le> k"
shows "lose (Suc (Suc (t + j))) = [False]"
proof -
  from h2 have "j + 2 \<le>k + d + 3" by arith
  from h1 and this have "lose (t + (j + 2)) = [False]" by blast
  then show ?thesis by simp
qed

lemma Gateway_L7:
assumes h1:"Gateway req dt a stop lose d ack i vc"
     and h2:"ts lose"
     and h3:"msg (Suc 0) a"
     and h4:"msg (Suc 0) stop"
     and h5:"msg (Suc 0) req"
     and h6:"req (Suc t) = [init]"
     and h7:"\<forall>m < (k + 3). req (t + m) \<noteq> [send]"
     and h8:"req (t + 3 + k) = [send]"
     and h9:"ack t = [init_state]"
     and h10:"\<forall>j\<le>k + d + 3. lose (t + j) = [False]"
     and h11:"\<forall> t1 \<le> t. req t1 = []"
shows "\<forall> t2 < (t + 3 + k + d). i t2 = []"
proof -
  have "Suc 0 \<le> k + d + 3" by arith
  from h10 and this have "lose (t + Suc 0) = [False]" by blast
  then have sg1:"lose (Suc t) = [False]" by simp
  have "Suc (Suc 0)\<le> k + d + 3" by arith
  from h10 and this have "lose (t + Suc (Suc 0)) = [False]" by blast
  then have sg2:"lose (Suc (Suc t)) = [False]" by simp
  from h1 and h2 and h3 and h4 and h5 and h6 and h9 and sg1 and sg2
     have sg3:"ack (t + 2) = [connection_ok]"
    by (simp add: Gateway_L1)
  from h7 and this have sg4:"\<forall>m\<le> k. req ((t + 2) + m) \<noteq> [send]"
    by (auto, simp add: aux_k3req)
  from h10 have sg5:"\<forall>j\<le> k. lose ((t + 2) + j) = [False]"
    by (auto, simp add: aux3lose)
  from h1 and sg4 and sg5 and sg3 and h5 and h4 and h3 and h2 have sg6:
   "\<forall>m \<le>  k. ack ((t + 2) + m) = [connection_ok]"
    by (rule Gateway_L6a)
  from sg6 have sg7:"ack (t + 2 + k) = [connection_ok]"  by auto
  from h1 obtain i1 i2 x y where
    a1:"Sample req dt x stop lose ack i1 vc" and
    a2:"Delay y i1 d x i2" and
    a3:"Loss lose a i2 y i"
    by (simp add: Gateway_def, auto)
  from h3 and a2 and a3  have sg8:"msg (Suc 0) x"
    by (simp add: Loss_Delay_msg_a)
  from a1 and sg8 and h4 and h5 obtain st buffer where
    a4:"tiTable_SampleT req x stop lose (fin_inf_append [init_state] st)
         (fin_inf_append [[]] buffer) ack i1 vc st"  and
    a5:"\<forall> t. buffer t = (if dt t = [] then fin_inf_append [[]] buffer t else dt t)"
    by (simp add: Sample_def Sample_L_def, auto)
  from a4 and h2 and sg8 and h4 and h11 and h6 and h7 and sg6 and h10
    have sg9:"\<forall> t1 < (t + 3 + k). i1 t1 = []"
    by (simp add: tiTable_i1_4)
  from sg9 and a2 have sg10:"\<forall> t2 < (t + 3 + k + d). i2 t2 = []"
    by (rule Delay_L2)
  from sg10 and a3 and h2 show ?thesis by (rule Loss_L2)
qed

lemma Gateway_L8a:
  assumes h1:"Gateway req dt a stop lose d ack i vc"
      and h2:"msg (Suc 0) req"
      and h3:"msg (Suc 0) stop"
      and h4:"msg (Suc 0) a"
      and h5:"ts lose"
      and h6:"\<forall>j\<le>2 * d. lose (t + j) = [False]"
      and h7:"ack t = [sending_data]"
      and h8:"\<forall>t3 \<le> t + d. a t3 = []"
      and h9:"x \<le> d + d"
  shows "ack (t + x) = [sending_data]"
proof -
  from h1 obtain i1 i2 x y where
    a1:"Sample req dt x stop lose ack i1 vc" and
    a2:"Delay y i1 d x i2" and
    a3:"Loss lose a i2 y i"
    by (simp add: Gateway_def, auto)
  from h8 and a3 and h5 have sg1:"\<forall>t3 \<le> t + d. y t3 = []" by (rule Loss_L6)
  from sg1 and a2 have sg2:"\<forall>t4 \<le> t + d + d. x t4 = []"   by (rule Delay_L4)
  from h4 and a2 and a3 have sg3:"msg (Suc 0) x" by (simp add:  Loss_Delay_msg_a)
  from h3 and h5 and h2 and sg3 and h6 and h7 and a1 and h9 and sg2 show ?thesis
    by (simp add: Sample_sending_data)
qed

lemma Gateway_L8:
assumes "Gateway req dt a stop lose d ack i vc"
       and "msg (Suc 0) req"
       and "msg (Suc 0) stop"
       and "msg (Suc 0) a"
       and "ts lose"
       and "\<forall>j\<le>2 * d. lose (t + j) = [False]"
       and "ack t = [sending_data]"
       and "\<forall>t3 \<le> t + d. a t3 = []"
shows "\<forall>x \<le> d + d. ack (t + x) = [sending_data]"
using assms
by (simp add: Gateway_L8a)

subsection {* Proof of the Refinement Relation for the Gateway Requirements *}

lemma Gateway_L0:
 assumes "Gateway req dt a stop lose d ack i vc"
 shows     "GatewayReq req dt a stop lose d ack i vc"
using assms
by (simp add: GatewayReq_def Gateway_L1 Gateway_L2 Gateway_L3 Gateway_L4)

subsection {* Lemmas about Gateway Requirements *}

lemma GatewayReq_L1:
  assumes h1:"msg (Suc 0) req"
      and h2:"msg (Suc 0) stop"
      and h3:"msg (Suc 0) a"
      and h4:"ts lose"
      and h6:"req (t + 3 + k) = [send]"
      and h7:"\<forall>j\<le>2 * d + (4 + k). lose (t + j) = [False]"
      and h9:"\<forall>m\<le> k. ack (t + 2 + m) = [connection_ok]"
      and h10:"GatewayReq req dt a stop lose d ack i vc"
 shows "ack (t + 3 + k) = [sending_data]"
proof -
  from h9 have sg1:"ack (Suc (Suc (t + k))) = [connection_ok]" by auto
  from h7 have sg2:
   "\<forall>ka\<le>Suc d. lose (Suc (Suc (t + k + ka))) = [False]"
    by (simp add: aux_lemma_lose_1)
  from h1 and h2 and h3 and h4 and h6 and h10 and sg1 and sg2 have sg3:
   "ack (t + 2 + k) = [connection_ok] \<and>
    req (Suc (t + 2 + k)) = [send] \<and> (\<forall>k\<le>Suc d. lose (t + k) = [False]) \<longrightarrow>
    ack (Suc (t + 2 + k)) = [sending_data]"
    by (simp add: GatewayReq_def)
  have "t + 3 + k = Suc (Suc (Suc (t + k)))" by arith
  from sg3 and sg1 and h6 and h7 and this show ?thesis
    by (simp add: eval_nat_numeral)
qed

lemma GatewayReq_L2:
 assumes  h1:"msg (Suc 0) req"
      and h2:"msg (Suc 0) stop"
      and h3:"msg (Suc 0) a"
      and h4:"ts lose"
      and h5:"GatewayReq req dt a stop lose d ack i vc"
      and h6:"req (t + 3 + k) = [send]"
      and h7:"inf_last_ti dt t \<noteq> []"
      and h8:"\<forall>j\<le>2 * d + (4 + k). lose (t + j) = [False]"
      and h9:"\<forall>m\<le>k. ack (t + 2 + m) = [connection_ok]"
  shows "i (t + 3 + k + d) \<noteq> []"
proof -
  from h8 have sg1:"(\<forall> (x::nat). x \<le> (d+1) \<longrightarrow> lose (t+x) = [False])"
    by (simp add: aux_lemma_lose_2)
  from h8 have sg2:"\<forall>ka\<le>Suc d. lose (Suc (Suc (t + k + ka))) = [False]"
    by (simp add: aux_lemma_lose_1)
  from h9 have sg3:"ack (t + 2 + k) = [connection_ok]" by simp
  from h1 and h2 and h3 and h4 and h5 and h6 and sg2 and sg3 have sg4:
   "ack (t + 2 + k) = [connection_ok] \<and>
    req (Suc (t + 2 + k)) = [send] \<and> (\<forall>k\<le>Suc d. lose (t + k) = [False]) \<longrightarrow>
    i (Suc (t + 2 + k + d)) = inf_last_ti dt (t + 2 + k)"
    by (simp add: GatewayReq_def, auto)
  from h7 have sg5:"inf_last_ti dt (t + 2 + k) \<noteq> []"
    by (simp add: inf_last_ti_nonempty_k)
  have sg6:"t + 3 + k = Suc (Suc (Suc (t + k)))" by arith
  have "t + 2 + k = Suc (Suc (t + k))" by arith
  from sg1 and sg2 and sg3 and sg4 and sg5 and sg6 and this and h6 show ?thesis
    by (simp add: eval_nat_numeral)
qed

subsection {* Properties of the Gateway System *}

lemma GatewaySystem_L1aux:
assumes "msg (Suc 0) req"
       and "msg (Suc 0) stop"
       and "msg (Suc 0) a"
       and "ts lose"
       and "msg (Suc 0) req \<and> msg (Suc 0) a \<and> msg (Suc 0) stop \<and> ts lose \<longrightarrow>
        (\<forall>t. (ack t = [init_state] \<and>
          req (Suc t) = [init] \<and> lose (Suc t) = [False] \<and>
          lose (Suc (Suc t)) = [False] \<longrightarrow>
          ack (Suc (Suc t)) = [connection_ok]) \<and>
         (ack t = [connection_ok] \<and> req (Suc t) = [send] \<and>
         (\<forall>k\<le>Suc d. lose (t + k) = [False]) \<longrightarrow>
          i (Suc (t + d)) = inf_last_ti dt t \<and> ack (Suc t) = [sending_data]) \<and>
         (ack (t + d) = [sending_data] \<and> a (Suc t) = [sc_ack] \<and>
          (\<forall>k\<le>Suc d. lose (t + k) = [False]) \<longrightarrow>
          vc (Suc (t + d)) = [vc_com]))"
shows  "ack (t + 3 + k + d + d) = [sending_data] \<and>
          a (Suc (t + 3 + k + d)) = [sc_ack] \<and>
         (\<forall>ka\<le>Suc d. lose (t + 3 + k + d + ka) = [False]) \<longrightarrow>
         vc (Suc (t + 3 + k + d + d)) = [vc_com]"
using assms  by blast

lemma GatewaySystem_L3aux:
assumes "msg (Suc 0) req"
       and "msg (Suc 0) stop"
       and "msg (Suc 0) a"
       and "ts lose"
       and "msg (Suc 0) req \<and> msg (Suc 0) a \<and> msg (Suc 0) stop \<and> ts lose \<longrightarrow>
        (\<forall>t. (ack t = [init_state] \<and>
          req (Suc t) = [init] \<and> lose (Suc t) = [False] \<and>
          lose (Suc (Suc t)) = [False] \<longrightarrow>
          ack (Suc (Suc t)) = [connection_ok]) \<and>
         (ack t = [connection_ok] \<and> req (Suc t) = [send] \<and>
         (\<forall>k\<le>Suc d. lose (t + k) = [False]) \<longrightarrow>
          i (Suc (t + d)) = inf_last_ti dt t \<and> ack (Suc t) = [sending_data]) \<and>
         (ack (t + d) = [sending_data] \<and> a (Suc t) = [sc_ack] \<and>
          (\<forall>k\<le>Suc d. lose (t + k) = [False]) \<longrightarrow>
          vc (Suc (t + d)) = [vc_com]))"
shows "ack (t + 2 + k) = [connection_ok] \<and>
         req (Suc (t + 2 + k)) = [send] \<and>
         (\<forall>j\<le>Suc d. lose (t + 2 + k + j) = [False]) \<longrightarrow>
         i (Suc (t + 2 + k + d)) = inf_last_ti dt (t + 2 + k)"
using assms  by blast

lemma GatewaySystem_L1:
 assumes  h2:"ServiceCenter i a"
     and h3:"GatewayReq req dt a stop lose d ack i vc"
     and h4:"msg (Suc 0) req"
     and h5:"msg (Suc 0) stop"
     and h6:"msg (Suc 0) a"
     and h7:"ts lose"
     and h9:"\<forall>j\<le>2 * d + (4 + k). lose (t + j) = [False]"
     and h11:"i (t + 3 + k + d) \<noteq> []"
     and h14:"\<forall>x \<le> d + d. ack (t + 3 + k + x) = [sending_data]"
 shows "vc (2 * d + (t + (4 + k))) = [vc_com]"
proof -
  from h2 have "\<forall>t. a (Suc t) = (if i t = [] then [] else [sc_ack])"
    by (simp add:ServiceCenter_def)
  then have sg1:
    "a (Suc (t + 3 + k + d)) = (if i (t + 3 + k + d) = [] then [] else [sc_ack])"
     by blast
  from sg1 and h11 have sg2:"a (Suc (t + 3 + k + d)) = [sc_ack]" by auto
  from h14 have sg3:"ack (t + 3 + k + 2*d) = [sending_data]" by simp
  from h4 and h5 and h6 and h7 and h3 have sg4:
    "ack (t + 3 + k + d + d) = [sending_data] \<and> a (Suc (t + 3 + k + d)) = [sc_ack] \<and>
     (\<forall>ka\<le>Suc d. lose (t + 3 + k + d + ka) = [False]) \<longrightarrow>
     vc (Suc (t + 3 + k + d + d)) = [vc_com]"
    apply (simp only: GatewayReq_def)
    by (rule GatewaySystem_L1aux, auto)
  from h9 have sg5:"\<forall>ka\<le>Suc d. lose (d + (t + (3 + k)) + ka) = [False]"
    by (simp add: aux_lemma_lose_3)
  have sg5a:"d + (t + (3 + k)) = t + 3 + k + d" by arith
  from sg5 and sg5a have sg5b:"\<forall>ka\<le>Suc d. lose (t + 3 + k + d + ka) = [False]"
    by auto
  have sg6:"(t + 3 + k + 2 * d)  = (2 * d + (t + (3 + k)))" by arith
  have sg7:"Suc (Suc (Suc (t + k + (d + d)))) = Suc (Suc (Suc (t + k + d + d)))"
    by arith
  have "Suc (Suc (Suc (Suc (t + k + d + d)))) =
            Suc (Suc (Suc (Suc (d + d + (t + k)))))" by arith
  from sg4 and sg3 and sg2 and sg5b and sg6 and sg7 and this show ?thesis
    by (simp add: eval_nat_numeral)
qed

lemma aux4lose2:
assumes "\<forall>j\<le>2 * d + (4 + k). lose (t + j) = [False]"
       and "3 + k + d \<le> 2 * d + (4 + k)"
shows "lose (t + (3::nat) + k + d) = [False]"
proof -
  from assms have "lose (t + ((3::nat) + k + d)) = [False]" by blast
  then show ?thesis by (simp add: arith_sum1)
qed

lemma aux4req:
assumes h1:"\<forall> (m::nat) \<le> k + 2. req (t + m) \<noteq> [send]"
      and h2:"m \<le> k"
      and h3:"req (t + 2 + m) = [send]" shows "False"
proof -
  from h2 have "(2::nat) + m \<le> k + (2::nat)" by arith
  from h1 and this have "req (t + (2 + m)) \<noteq> [send]" by blast
  from this and h3 show ?thesis by simp
qed

lemma GatewaySystem_L2:
 assumes h1:"Gateway req dt a stop lose d ack i vc"
     and h2:"ServiceCenter i a"
     and h3:"GatewayReq req dt a stop lose d ack i vc"
     and h4:"msg (Suc 0) req"
     and h5:"msg (Suc 0) stop"
     and h6:"msg (Suc 0) a"
     and h7:"ts lose"
     and h8:"ack t = [init_state]"
     and h9:"req (Suc t) = [init]"
     and h10:"\<forall>t1\<le>t. req t1 = []"
     and h11:"\<forall>m \<le> k + 2. req (t + m) \<noteq> [send]"
     and h12:"req (t + 3 + k) = [send]"
     and h13:"inf_last_ti dt t \<noteq> []"
     and h14:"\<forall>j\<le>2 * d + (4 + k). lose (t + j) = [False]"
 shows "vc (2 * d + (t + (4 + k))) = [vc_com]"
proof -
  have "Suc 0 \<le> 2 * d + (4 + k)" by arith
  from h14 and this have "lose (t + Suc 0) = [False]" by blast
  then have sg1:"lose (Suc t) = [False]" by simp
  have "Suc (Suc 0) \<le> 2 * d + (4 + k)" by arith
  from h14 and this have "lose (t + Suc (Suc 0)) = [False]" by blast
  then have sg2:"lose (Suc (Suc t)) = [False]" by simp
  from h3 and h4 and h5 and h6 and h7 and h8 and h9 and sg1 and sg2 have sg3:
   "ack (t + 2) = [connection_ok]"
    by (simp add: GatewayReq_def)
  from h14 have sg4:" \<forall>j\<le>k. lose (t + 2 + j) = [False]"
    by (clarify, rule aux4lose1, simp)
  from h11 have sg5:"\<forall>m \<le> k. req (t + 2 + m) \<noteq> [send]"
    by (clarify, rule aux4req, auto)
  (* stable connection *)
  from h1 and sg5 and sg4 and sg3 and h4 and h5 and h6 and h7 have sg6:
   "\<forall>m \<le> k. ack (t + 2 + m) = [connection_ok]"
    by (rule Gateway_L6)
  (* sending data*)
  from h3 and h4 and h5 and h6 and h7 and h12 and h14 and sg6 have sg10:
   "ack (t + 3 + k) = [sending_data]"
    by (simp add: GatewayReq_L1)
  from h3 and h4 and h5 and h6 and h7 and h12 and h13 and h14 and sg6 have sg11:
   "i (t + 3 + k + d) \<noteq> []"
    by (simp add: GatewayReq_L2)
  (* waiting for sc-ack *)
  from h11 have sg12:"\<forall>m < k + 3. req (t + m) \<noteq> [send]" by auto
  from h14 have sg13:"\<forall>j\<le>k + d + 3. lose (t + j) = [False]" by auto
  from h1 and h7 and h6 and h5 and h4 and h9 and sg12
          and h12 and h8 and sg13 and h10
    have sg14:"\<forall> t2 < (t + 3 + k + d). i t2 = []"
    by (simp add: Gateway_L7)
  from sg14 and h2 have sg15:"\<forall> t3 \<le> (t + 3 + k + d). a t3 = []"
    by (simp add: ServiceCenter_L2)
  from h14 have sg18:"\<forall>j\<le>2 * d. lose ((t + 3 + k) + j) = [False]"
    by (simp add: streamValue43)
  from h14  have sg16a:"\<forall>j\<le>2 * d. lose (t + j + (4 + k)) = [False]"
    by (simp add: streamValue2)
  have sg16b:"Suc (3 + k) = (4 + k)" by arith
  from sg16a and sg16b have sg16:"\<forall>j\<le>2 * d. lose (t + j + Suc (3 + k)) = [False]"
    by (simp (no_asm_simp))
  from h1 and h4 and h5 and h6 and h7 and sg18 and sg10 and sg15 have sg19:
    "\<forall>x \<le> d + d. ack (t + 3 + k + x) = [sending_data]"
     by (simp add: Gateway_L8)
  from sg19 have sg19a:"ack (t + 3 + k + d + d) = [sending_data]" by auto
  from sg16 have sg20a:"\<forall>j\<le> d. lose (t + 3 + k + d + (Suc j)) = [False]"
    by (rule streamValue10)
  have sg20b:"3 + k + d \<le> 2 * d + (4 + k)" by arith
  from h14 and sg20b have sg20c:"lose (t + 3 + k + d) = [False]"
    by (rule aux4lose2)
  from sg20a and sg20c have sg20:"\<forall>j\<le>Suc d. lose (t + 3 + k + d + j) = [False]"
    by (rule streamValue8)
  from h4 and h5 and h6 and h7 and h3 have sg21:
     "ack (t + 3 + k + d + d) = [sending_data] \<and>
      a (Suc (t + 3 + k + d)) = [sc_ack] \<and>
      (\<forall>j\<le>Suc d. lose (t + 3 + k + d + j) = [False]) \<longrightarrow>
      vc (Suc (t + 3 + k + d + d)) = [vc_com]"
     apply (simp only: GatewayReq_def)
     by (rule GatewaySystem_L1aux, auto)
   from h2 and sg11 have sg22:"a (Suc (t + 3 + k + d)) = [sc_ack]"
     by (simp only: ServiceCenter_def, auto)
   from sg21 and sg19a and sg22 and sg20 have sg23:
     "vc (Suc (t + 3 + k + d + d)) = [vc_com]" by simp
   have "2 * d + (t + (4 + k)) = (Suc (t + 3 + k + d + d))" by arith
   from sg23 and this show ?thesis
     by (simp (no_asm_simp), simp)
qed

lemma GatewaySystem_L3:
 assumes h1:"Gateway req dt a stop lose d ack i vc"
     and h2:"ServiceCenter i a"
     and h3:"GatewayReq req dt a stop lose d ack i vc"
     and h4:"msg (Suc 0) req"
     and h5:"msg (Suc 0) stop"
     and h6:"msg (Suc 0) a"
     and h7:"ts lose"
     and h8: "dt (Suc t) \<noteq> [] \<or> dt (Suc (Suc t)) \<noteq> []"
     and h9: "ack t = [init_state]"
     and h10:"req (Suc t) = [init]"
     and h11:"\<forall>t1\<le>t. req t1 = []"
     and h12:"\<forall>m \<le> k + 2. req (t + m) \<noteq> [send]"
     and h13:"req (t + 3 + k) = [send]"
     and h14:"\<forall>j\<le>2 * d + (4 + k). lose (t + j) = [False]"
 shows "vc (2 * d + (t + (4 + k))) = [vc_com]"
proof -
  have "Suc 0 \<le> 2 * d + (4 + k)" by arith
  from h14 and this have "lose (t + Suc 0) = [False]" by blast
  then have sg1:"lose (Suc t) = [False]" by simp
  have "Suc (Suc 0) \<le> 2 * d + (4 + k)" by arith
  from h14 and this have "lose (t + Suc (Suc 0)) = [False]" by blast
  then have sg2:"lose (Suc (Suc t)) = [False]" by simp
  from h3 and h4 and h5 and h6 and h7 and h10 and h9 and sg1 and sg2 have sg3:
   "ack (t + 2) = [connection_ok]"
    by (simp add: GatewayReq_def)
  from h14 have sg4:" \<forall>j\<le>k. lose (t + 2 + j) = [False]"
    by (clarify, rule aux4lose1, simp)
  from h12 have sg5:"\<forall>m \<le> k. req (t + 2 + m) \<noteq> [send]"
    by (clarify, rule aux4req, auto)
  (* stable connection *)
  from h1 and sg5 and sg4 and sg3 and h4 and h5 and h6 and h7 have sg6:
   "\<forall>m \<le> k. ack (t + 2 + m) = [connection_ok]"
    by (rule Gateway_L6)
  from sg6 have sg6a:"ack (t + 2 + k) = [connection_ok]" by simp
  (* sending data*)
  from h3 and h4 and h5 and h6 and h7 and h13 and h14 and sg6 have sg10:
   "ack (t + 3 + k) = [sending_data]"
    by (simp add: GatewayReq_L1)
  from h3 and h4 and h5 and h6 and h7 have sg11a:
   "ack (t + 2 + k) = [connection_ok] \<and>
    req (Suc (t + 2 + k)) = [send] \<and>
    (\<forall>j\<le>Suc d. lose ((t + 2 + k) + j) = [False]) \<longrightarrow>
    i (Suc (t + (2::nat) + k + d)) = inf_last_ti dt (t + 2 + k)"
    apply (simp only: GatewayReq_def)
    by (rule GatewaySystem_L3aux, auto)
  have sg12:"Suc (t + 2 + k) = t + 3 + k" by arith
  from h13 and sg12 have sg12a:"req (Suc (t + 2 + k)) = [send]"
    by (simp add: eval_nat_numeral)
  from h14 have sg13:"\<forall>j\<le>Suc d. lose ((t + 2 + k) + j) = [False]"
    by (rule streamValue12)
  from sg11a and sg6a and h13 and sg12a and sg13 have sg14:
    "i (Suc (t + (2::nat) + k + d)) = inf_last_ti dt (t + 2 + k)" by simp
  from h8 have sg15:"inf_last_ti dt (t + 2 + k) \<noteq> []"
    by (rule inf_last_ti_Suc2)
  from sg14 and sg15 have sg16: "i (t + 3 + k + d) \<noteq> []"
    by (simp add: arith_sum4)
  (* waiting for sc-ack *)
  from h14 have sg17:"\<forall>j\<le>k + d + 3. lose (t + j) = [False]" by auto
  from h12 have sg18:"\<forall>m < (k + 3). req (t + m) \<noteq> [send]"   by auto
  from h1 and h4 and h5 and h6 and h7 and h10 and sg18 and h13 and h9 and sg17 and h11
    have sg19:"\<forall> t2 < (t + 3 + k + d). i t2 = []"
    by (simp add: Gateway_L7)
  from h2 and sg19 have sg20:"\<forall> t3 \<le> (t + 3 + k + d). a t3 = []"
    by (simp add: ServiceCenter_L2)
  from h14 have sg21:"\<forall>j\<le>2 * d. lose (t + 3 + k + j) = [False]"
    by (simp add: streamValue43)
  from h1 and h4 and h5 and h6 and h7 and sg21 and sg10 and sg20 have
    "\<forall>x \<le> d + d. ack (t + 3 + k + x) = [sending_data]"
    by (simp add: Gateway_L8)
  from h2 and h3 and h4 and h5 and h6 and h7 and h14 and sg16 and this show ?thesis
    by (simp add: GatewaySystem_L1)
qed

subsection {* Proof of the Refinement for the Gateway System *}

lemma GatewaySystem_L0:
 assumes "GatewaySystem req dt stop lose d ack vc"
 shows    "GatewaySystemReq req dt stop lose d ack vc"
proof -
  from assms obtain x i where
    a1:"Gateway req dt x stop lose d ack i vc" and
    a2:"ServiceCenter i x"
    by (simp add: GatewaySystem_def, auto)
  from a1 have sg1:"GatewayReq req dt x stop lose d ack i vc"
    by (simp add: Gateway_L0)
  from a2 have sg2:"msg (Suc 0) x"
    by (simp add: ServiceCenter_a_msg)
  from assms and a1 and a2 and sg1 and sg2 show ?thesis
    apply (simp add: GatewaySystemReq_def, auto)
    apply (simp add: GatewaySystem_L3)
    apply (simp add: GatewaySystem_L3)
    apply (simp add: GatewaySystem_L3)
    by (simp add: GatewaySystem_L2)
qed

end


(*
    File:        dTermDef.thy
    Time-stamp:  <2020-06-22T04:14:01Z>
    Author:      JRF
    Web:         http://jrf.cocolog-nifty.com/software/2016/01/post.html
    Logic Image: Logics_ZF (of Isabelle2020)
*)

theory dTermDef imports ZF.Sum ZF.Nat Nth SubOcc LVariable begin

consts
  dTerm :: i
  dTag :: i

datatype
  dTerm = dVar( "x: LVariable" )
        | dBound( "n: nat" )
        | dLam( "M: dTerm" )
        | dApp( "M: dTerm", "N: dTerm")

datatype
  dTag = TdVar( "x: LVariable" )
       | TdBound( "n: nat" )
       | TdLam
       | TdApp

definition dArity :: "i=>i" where
"dArity(T) == dTag_case(%z. 0, %z. 0, 1, 2, T)"

definition dTerm_cons :: "[i, i]=>i" where
"dTerm_cons(T, l) = dTag_case(%z. dVar(z), %z. dBound(z),
                      dLam(nth(0, l)), dApp(nth(0, l), nth(1, l)), T)"

definition dOcc :: "i=>i" where
"dOcc(M) == dTerm_rec(
            %x. Occ_cons(TdVar(x), []),
            %n. Occ_cons(TdBound(n), []),
            %N r. Occ_cons(TdLam, [r]),
            %M N rm rn. Occ_cons(TdApp, [rm, rn]), M)"

definition dOccinv :: "i=>i" where
"dOccinv(x) == THE M. M: dTerm & x = dOcc(M)"

definition dSub :: "i=>i" where
"dSub(M) == {<l, dOccinv(Occ_Subtree(l, dOcc(M)))>. <l, T>: dOcc(M)}"

definition dsubterm :: "[i, i]=>i" where
"dsubterm(M, l) == THE N. <l, N>: dSub(M)"

lemma dTerm_rec_type:
  assumes "M: dTerm"
  and "!!x. [| x: LVariable |] ==> c(x): C(dVar(x))"
  and "!!n. [| n: nat |] ==> b(n): C(dBound(n))"
  and "!!M r. [| M: dTerm;  r: C(M) |] ==>
                   h(M,r): C(dLam(M))"
  and "!!M N rm rn. [| M: dTerm;  N: dTerm;
           rm: C(M); rn: C(N) |] ==> k(M,N,rm,rn): C(dApp(M,N))"
  shows "dTerm_rec(c,b,h,k,M) : C(M)"
apply (rule assms(1) [THEN dTerm.induct])
apply (simp_all add: assms)
done

lemma dTerm_cons_eqns:
  "dTerm_cons(TdVar(x), []) = dVar(x)"
  "dTerm_cons(TdBound(n), []) = dBound(n)"
  "dTerm_cons(TdLam, [M]) = dLam(M)"
  "dTerm_cons(TdApp, [M, N]) = dApp(M, N)"
apply (simp_all add: dTerm_cons_def)
done

lemma dArity_eqns:
  "dArity(TdVar(x)) = 0"
  "dArity(TdBound(n)) = 0"
  "dArity(TdLam) = 1"
  "dArity(TdApp) = 2"
apply (simp_all add: dArity_def)
done

lemma dOcc_eqns:
  "dOcc(dVar(x)) = Occ_cons(TdVar(x), [])"
  "dOcc(dBound(n)) = Occ_cons(TdBound(n), [])"
  "dOcc(dLam(M)) = Occ_cons(TdLam, [dOcc(M)])"
  "dOcc(dApp(M, N)) = Occ_cons(TdApp, [dOcc(M), dOcc(N)])"
apply (simp_all add: dOcc_def)
done

lemma dTerm_Term_cons_intrs:
  "x: LVariable ==> dTerm_cons(TdVar(x), []): dTerm"
  "n: nat ==> dTerm_cons(TdBound(n), []): dTerm"
  "[| M: dTerm |] ==> dTerm_cons(TdLam, [M]): dTerm"
  "[| M: dTerm; N: dTerm |] ==> dTerm_cons(TdApp, [M, N]): dTerm"
apply (simp_all add: dTerm_cons_eqns)
apply (assumption | rule dTerm.intros)+
done

lemma dArity_type:
  "T: dTag ==> dArity(T): nat"
apply (erule dTag.cases)
apply (simp_all add: dArity_eqns)
done

lemma dTerm_Occ_cons_cond:
  "Occ_cons_cond(dTerm, dOcc, dTag, dArity)"
apply (rule Occ_cons_condI)
apply (elim dTag.cases)
apply (simp_all add: dArity_eqns)
apply (elim dTag.cases)
apply (simp_all add: dArity_eqns)

apply (rule bexI)
apply (rule dOcc_eqns)
apply (typecheck add: dTerm.intros)

apply (rule bexI)
apply (rule dOcc_eqns)
apply (typecheck add: dTerm.intros)

apply (elim bexE conjE)
apply (erule nth_0E)
apply assumption
apply simp
apply simp
apply (rule bexI)
apply (rule dOcc_eqns)
apply (typecheck add: dTerm.intros)

apply (elim bexE conjE)
apply (erule nth_0E)
apply assumption
apply simp
apply simp
apply (erule nth_0E)
apply assumption
apply simp
apply simp
apply (rule bexI)
apply (rule dOcc_eqns)
apply (typecheck add: dTerm.intros)
done

lemma dTerm_Occ_ind_cond:
  "Occ_ind_cond(dTerm, dOcc, dTag, dArity, dTerm_cons)"
apply (rule Occ_ind_condI)
apply (erule dTerm.induct)

apply (drule bspec)
apply (drule_tac [2] bspec)
apply (drule_tac [3] mp)
apply (erule_tac [4] dTerm_cons_eqns [THEN subst])
apply (typecheck add: dTag.intros)
apply (simp add: dTerm_cons_eqns dArity_eqns dOcc_eqns)
apply (typecheck add: dTerm.intros)

apply (drule bspec)
apply (drule_tac [2] bspec)
apply (drule_tac [3] mp)
apply (erule_tac [4] dTerm_cons_eqns [THEN subst])
apply (typecheck add: dTag.intros)
apply (simp add: dTerm_cons_eqns dArity_eqns dOcc_eqns)
apply (typecheck add: dTerm.intros)

apply (drule bspec)
apply (drule_tac [2] bspec)
apply (drule_tac [3] mp)
apply (erule_tac [4] dTerm_cons_eqns [THEN subst])
apply (typecheck add: dTag.intros)
apply (simp add: dTerm_cons_eqns dArity_eqns dOcc_eqns)
apply (typecheck add: dTerm.intros)

apply (drule bspec)
apply (drule_tac [2] bspec)
apply (drule_tac [3] mp)
apply (erule_tac [4] dTerm_cons_eqns [THEN subst])
apply (typecheck add: dTag.intros)
apply (simp add: dTerm_cons_eqns dArity_eqns dOcc_eqns)
apply (typecheck add: dTerm.intros)

done

lemma dTerm_Term_cons_inj_cond:
  "Term_cons_inj_cond(dTerm, dTag, dArity, dTerm_cons)"
apply (rule Term_cons_inj_condI)
apply (rule iffI)
apply (elim dTag.cases)
prefer 17
apply (elim dTag.cases)
apply (simp_all add: dTerm_cons_def dArity_def)
done

lemmas dTerm_Term_cons_typechecks = (* nth_typechecks *)
    dTerm_Term_cons_intrs dTag.intros
    dArity_type Occ_ind_cond_Occ_domain [OF dTerm_Occ_ind_cond]
    Occ_ind_cond_Occ_in_Occ_range [OF dTerm_Occ_ind_cond]
    PowI succI1 succI2 (* consI1 *)consI2 (* nat_0I nat_succI *)

declare dTerm_Term_cons_typechecks [TC]

lemmas dTerm_Term_cons_simps = dArity_eqns (* dTerm_cons_eqns [THEN sym] *)

declare dTerm_Term_cons_simps [simp]

lemmas dTerm_cons_eqns_sym = dTerm_cons_eqns [THEN sym]

end


(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)
theory Peterson_Atomicity
imports
  "../Atomicity_Lib"
begin

text \<open>
 Preliminaries, a type of identities.
\<close>

datatype ident = A | B

primrec other_ident
where
    "other_ident A = B"
  | "other_ident B = A"

lemma other_ident_split:
  "P (other_ident x) = ((x = A \<longrightarrow> P B) \<and> (x = B \<longrightarrow> P A))"
  by (cases x, simp_all)

lemma neq_A_B[simp]:
  "(x \<noteq> A) = (x = B)"
  "(A \<noteq> x) = (x = B)"
  "(x \<noteq> B) = (x = A)"
  "(B \<noteq> x) = (x = A)"
  by (simp | cases x)+

lemma forall_ident_eq:
  "(\<forall>ident. P ident) = (P A \<and> P B)"
  using ident.nchotomy
  by metis

lemma other_other_ident_simps[simp]:
  "other_ident (other_ident x) = x"
  "(other_ident x = y) = (x \<noteq> y)"
  "(x = other_ident y) = (x \<noteq> y)"
  by (simp_all split: other_ident_split add: eq_commute)

text \<open>
The state of the algorithm. The variables A/B are condensed into
an ab_v variable, so we can parametrise by thread A/B. The priority
variable is t_v, and the critical section cs has two variable to
operate on, cs1_v and cs2_v.

Labels are needed to track where we're up to for the preconditions,
relies and guarantees.
\<close>

datatype label = Awaiting | Critical | Exited

record ('a, 'b) p_state =
  ab_v :: "ident \<Rightarrow> bool"
  ab_label :: "ident \<Rightarrow> label"
  t_v :: "ident"
  cs1_v :: "'a"
  cs2_v :: "'b"

locale mx_locale =
  fixes cs1 :: "'b \<Rightarrow> 'a"
    and cs2 :: "(('a, 'b) p_state, unit) tmonad"
    and csI :: "'b \<Rightarrow> bool"
begin

definition
  set_ab :: "ident \<Rightarrow> bool \<Rightarrow> ('a, 'b) p_state \<Rightarrow> ('a, 'b) p_state"
where
  "set_ab ident trying s = (s \<lparr> ab_v := (ab_v s) (ident := trying) \<rparr>)"

definition
  set_label :: "ident \<Rightarrow> label \<Rightarrow> ('a, 'b) p_state \<Rightarrow> ('a, 'b) p_state"
where
  "set_label ident label s = (s \<lparr> ab_label := (ab_label s) (ident := label) \<rparr>)"

definition
  locked :: "ident \<Rightarrow> ('a, 'b) p_state \<Rightarrow> bool"
where
  "locked ident s = (ab_v s (other_ident ident) \<longrightarrow> t_v s = ident)"

definition
  acquire_lock :: "ident \<Rightarrow> (('a, 'b) p_state, unit) tmonad"
where
  "acquire_lock ident = do
    interference;
    modify (set_ab ident True);
    modify (\<lambda>s. s \<lparr> t_v := other_ident ident \<rparr>);
    modify (set_label ident Awaiting);
    interference;
    Await (locked ident);
    modify (set_label ident Critical)
   od"

definition
  release_lock :: "ident \<Rightarrow> (('a, 'b) p_state, unit) tmonad"
where
  "release_lock ident = do
    modify (set_ab ident False);
    modify (set_label ident Exited);
    interference;
    return ()
   od"

definition
  abs_critical_section :: "(('a, 'b) p_state, unit) tmonad"
where
  "abs_critical_section = do
    interferences;
    modify (\<lambda>s. s \<lparr> cs1_v := cs1 (cs2_v s) \<rparr>);
    cs2;
    interference
  od"

definition
  abs_peterson_proc ::
    "ident \<Rightarrow> (('a, 'b) p_state, unit) tmonad"
where
  "abs_peterson_proc ident = do
    acquire_lock ident;
    abs_critical_section;
    release_lock ident
  od"

definition
  critical_section :: "(('a, 'b) p_state, unit) tmonad"
where
  "critical_section = do
    interference;
    modify (\<lambda>s. s \<lparr> cs1_v := cs1 (cs2_v s) \<rparr>);
    interference;
    cs2;
    interference
  od"

definition
  peterson_proc :: "ident \<Rightarrow> (('a, 'b) p_state, unit) tmonad"
where
  "peterson_proc ident = do
    acquire_lock ident;
    critical_section;
    release_lock ident
  od"

abbreviation "critical label \<equiv> label = Critical"

text \<open>The required invariant. We can't both be in the critical section.
Whenever neither of us is in the critical section, its invariant holds.\<close>
definition
  req_peterson_inv :: "('a, 'b) p_state \<Rightarrow> bool"
where
  "req_peterson_inv s = (\<not> (critical (ab_label s A) \<and> critical (ab_label s B))
    \<and> (critical (ab_label s A) \<or> critical (ab_label s B) \<or> csI (cs2_v s)))"

text \<open>The key invariant. We can't both be enabled, where that means
either we're in the critical section or waiting to enter with priority.
\<close>
abbreviation(input)
  enabled :: "ident \<Rightarrow> ('a, 'b) p_state \<Rightarrow> bool"
where
  "enabled ident s \<equiv> (critical (ab_label s ident)
    \<or> (ab_label s ident = Awaiting \<and> t_v s = ident))"

definition
  key_peterson_inv :: "('a, 'b) p_state \<Rightarrow> bool"
where
  "key_peterson_inv s = (\<not> (enabled A s \<and> enabled B s))"

text \<open>Some trivia about labels and variables.\<close>
definition
  local_peterson_inv :: "('a, 'b) p_state \<Rightarrow> bool"
where
  "local_peterson_inv s
    = (\<forall>ident. ab_label s ident \<noteq> Exited \<longrightarrow> ab_v s ident)"

definition
  "invs s = (req_peterson_inv s
    \<and> key_peterson_inv s \<and> local_peterson_inv s)"

lemmas invs_defs = req_peterson_inv_def key_peterson_inv_def local_peterson_inv_def

definition
  peterson_rel :: "ident \<Rightarrow> ('a, 'b) p_state \<Rightarrow> ('a, 'b) p_state \<Rightarrow> bool"
where
  "peterson_rel ident s_prior s = (\<comment> \<open>assume invs\<close> invs s_prior \<longrightarrow>
            \<comment> \<open>invariants are preserved\<close>
        (invs s
            \<comment> \<open>I won't adjust your variables\<close>
        \<and> (ab_v s (other_ident ident) = ab_v s_prior (other_ident ident))
        \<and> (ab_label s (other_ident ident) = ab_label s_prior (other_ident ident))
            \<comment> \<open>I will only ever give you priority\<close>
        \<and> (t_v s_prior = other_ident ident \<longrightarrow> t_v s = other_ident ident)
            \<comment> \<open>If you're in the critical section, I won't change cs2_v and cs1_v\<close>
        \<and> (critical (ab_label s_prior (other_ident ident))
                \<longrightarrow> cs2_v s = cs2_v s_prior \<and> cs1_v s = cs1_v s_prior)
  ))"

lemma peterson_rel_rtranclp[simp]:
  "rtranclp (peterson_rel ident) = (peterson_rel ident)"
  apply (rule rtranclp_id2)
   apply (clarsimp simp: peterson_rel_def)
  apply (clarsimp simp: peterson_rel_def)
  done

lemma reflp_peterson_rel[simp]:
 "reflp (peterson_rel x)"
  apply (rule reflpI)
  apply (clarsimp simp add: peterson_rel_def)
  done
declare reflp_peterson_rel[THEN reflpD, simp]

lemma peterson_rel_imp_assume_invs:
  "invs x \<Longrightarrow> (peterson_rel ident x y \<and> invs x \<and> invs y \<longrightarrow> P x y)
    \<Longrightarrow> (peterson_rel ident x y \<longrightarrow> P x y)"
  by (simp add: peterson_rel_def)

end

text \<open>
We assume validity for the underspecified critical section code represented by
@{text cs2}.

We also assume some basic sanity properties about the structure of @{text cs2}.
\<close>
locale mx_locale_wp = mx_locale cs1 cs2 csI for cs1 :: "'b \<Rightarrow> 'a" and cs2 and csI +
  assumes
    cs_wp: "\<forall>s c. I s \<and> lockf s \<longrightarrow> I s \<and> lockf (s \<lparr> cs2_v := c \<rparr>)
      \<Longrightarrow>
      \<lbrace> \<lambda>s0' s'. csI (cs2_v s') \<and> s0' = s0 \<and> s' = s \<and> I s \<and> lockf s
                 \<and> cs1_v s' = cs1 (cs2_v s') \<rbrace>,
      \<lbrace> \<lambda>s0 s. I s0 \<and> lockf s0 \<longrightarrow> cs2_v s = cs2_v s0 \<and> I s \<and> lockf s
                                    \<and> cs1_v s = cs1_v s0 \<rbrace>
        cs2
      \<lbrace> \<lambda>s0 s. I s0 \<longrightarrow> (\<exists>c. s = s0 \<lparr> cs2_v := c \<rparr>) \<and> I s \<and> lockf s \<rbrace>,
      \<lbrace> \<lambda>_ s0' s'. \<exists>c. csI c \<and> s' = s \<lparr> cs2_v := c \<rparr>
                       \<and> (\<exists>c'. s0' = s0 \<or> s0' = s \<lparr> cs2_v := c' \<rparr>)
                       \<and> I s' \<and> lockf s' \<rbrace>"
    and cs_closed: "prefix_closed cs2"
    and cs_not_env_steps_first: "not_env_steps_first cs2"
begin

method_setup rev_drule = \<open>
  Attrib.thms >> curry (fn (thms, ctxt)
    => SIMPLE_METHOD (dresolve_tac ctxt thms 1 #> Seq.list_of #> rev #> Seq.of_list))
\<close>

lemma cs2_wp_apply_peterson[wp]:
 "\<lbrace> (\<lambda>s0 s. csI (cs2_v s)
      \<and> invs s0 \<and> invs s \<and> critical (ab_label s ident)
      \<and> cs1_v s = cs1 (cs2_v s)
      \<and> (\<forall>s0' c' c. csI c \<longrightarrow> (\<exists>c'. s0' = s0 \<or> s0' = s \<lparr> cs2_v := c' \<rparr>)
              \<longrightarrow>  Q () s0' (s \<lparr> cs2_v := c\<rparr>))) \<rbrace>,
  \<lbrace> peterson_rel (other_ident ident) \<rbrace>
    cs2
  \<lbrace> peterson_rel ident \<rbrace>,
  \<lbrace> Q \<rbrace>"
  apply (rule validI_name_pre[OF cs_closed], clarsimp simp del: imp_disjL)
  apply (rule validI_weaken_pre)
   apply (rule validI_well_behaved[OF cs_closed])
     apply (rule validI_strengthen_post)
      apply (rule_tac s=s and ?s0.0=s0
         and lockf="\<lambda>s. critical (ab_label s ident)"
         and I="invs" in cs_wp)
      apply (clarsimp simp: invs_defs invs_def)
     apply (clarsimp simp del: imp_disjL)
    apply (simp only: imp_conjL[symmetric])
    apply (thin_tac "\<forall>x. P x" for P)
    apply (clarsimp simp: peterson_rel_def)
   apply (thin_tac "\<forall>x. P x" for P)
   apply (clarsimp simp: peterson_rel_def)
   apply (cases ident; fastforce simp: invs_def key_peterson_inv_def)
  apply clarsimp
  done

lemma release_lock_mutual_excl:
  "\<lbrace> \<lambda>s0 s. peterson_rel ident s0 s \<and> invs s
            \<and> ab_label s ident = Critical \<and> csI (cs2_v s) \<rbrace>,
   \<lbrace> peterson_rel (other_ident ident) \<rbrace>
     release_lock ident
   \<lbrace> peterson_rel ident \<rbrace>,
   \<lbrace> \<lambda>rv s0 s. peterson_rel ident s0 s \<and> invs s
               \<and> ab_label s ident = Exited \<rbrace>"
  apply (simp add: release_lock_def)
  apply (rule validI_weaken_pre)
   apply wpsimp+
  apply (strengthen peterson_rel_imp_assume_invs | simp)+
  apply (cases ident)
  apply (safe, simp_all)
  by ((clarsimp simp: peterson_rel_def set_label_def
                      set_ab_def invs_defs
    | rule invs_def[THEN iffD2] conjI
    | rev_drule invs_def[THEN iffD1])+)

lemma abs_critical_section_mutual_excl:
  "\<lbrace> \<lambda>s0 s. peterson_rel ident s0 s \<and> invs s \<and> invs s0
            \<and> ab_label s ident = Critical \<and> csI (cs2_v s) \<rbrace>,
   \<lbrace> peterson_rel (other_ident ident) \<rbrace>
     abs_critical_section
   \<lbrace> peterson_rel ident \<rbrace>,
   \<lbrace> \<lambda>rv s0 s. peterson_rel ident s0 s \<and> invs s
               \<and> ab_label s ident = Critical \<and> csI (cs2_v s) \<rbrace>"
  apply (simp add: abs_critical_section_def)
  apply (rule validI_weaken_pre)
   apply wpsimp+
  apply (strengthen peterson_rel_imp_assume_invs | simp)+
  apply (cases ident)
  apply (safe, simp_all)
  by ((clarsimp simp: peterson_rel_def invs_defs
    | rule invs_def[THEN iffD2] conjI
    | rev_drule invs_def[THEN iffD1])+)

lemma acquire_lock_mutual_excl:
  "\<lbrace> \<lambda>s0 s. peterson_rel ident s0 s \<and> invs s
            \<and> ab_label s ident = Exited \<rbrace>,
   \<lbrace> peterson_rel (other_ident ident) \<rbrace>
     acquire_lock ident
   \<lbrace> peterson_rel ident \<rbrace>,
   \<lbrace> \<lambda>rv s0 s. peterson_rel ident s0 s \<and> invs s \<and> invs s0
               \<and> ab_label s ident = Critical \<and> csI (cs2_v s) \<rbrace>"
  apply (simp add: acquire_lock_def)
  apply (rule validI_weaken_pre)
   apply (wpsimp wp: Await_sync_twp)+
  apply (strengthen peterson_rel_imp_assume_invs | simp)+
  apply (cases ident)
  apply (safe, simp_all)
  by ((clarsimp simp: peterson_rel_def set_label_def set_ab_def
                      locked_def invs_defs
    | rule invs_def[THEN iffD2] conjI
    | rev_drule invs_def[THEN iffD1])+)

theorem abs_peterson_proc_mutual_excl:
  "\<lbrace> \<lambda>s0 s. peterson_rel ident s0 s \<and> invs s
            \<and> ab_label s ident = Exited \<rbrace>,
   \<lbrace> peterson_rel (other_ident ident) \<rbrace>
     abs_peterson_proc ident
   \<lbrace> peterson_rel ident \<rbrace>,
   \<lbrace> \<lambda>rv s0 s. peterson_rel ident s0 s \<and> invs s
               \<and> ab_label s ident = Exited \<rbrace>"
  apply (simp add: abs_peterson_proc_def bind_assoc)
  apply (rule validI_weaken_pre)
   apply (wpsimp wp: release_lock_mutual_excl acquire_lock_mutual_excl
                     abs_critical_section_mutual_excl)+
  done

definition
  peterson_sr :: "(('a, 'b) p_state \<Rightarrow> ('a, 'b) p_state  \<Rightarrow> bool)"
where
  "peterson_sr sa sc \<equiv>
    t_v sa = t_v sc \<and> ab_v sa = ab_v sc
    \<and> ab_label sa = ab_label sc \<and> cs2_v sa = cs2_v sc"

definition
  peterson_sr' :: "(('a, 'b) p_state \<Rightarrow> ('a, 'b) p_state  \<Rightarrow> bool)"
where
  "peterson_sr' sa sc \<equiv> sa = sc \<lparr> cs1_v := cs1_v sa \<rparr>"

definition
  peterson_sr_cs1 :: "(('a, 'b) p_state \<Rightarrow> ('a, 'b) p_state  \<Rightarrow> bool)"
where
  "peterson_sr_cs1 sa sc \<equiv> peterson_sr sa sc \<and> cs1_v sa = cs1_v sc"

end
text \<open>
Finally we assume that we can prove refinement for @{text cs2}, although this
may depend on being in a state where @{term cs1_v} has been correctly
initialised.
\<close>
locale mx_locale_refine = mx_locale_wp cs1 cs2 csI for cs1 :: "'b \<Rightarrow> 'a" and cs2 and csI +
  assumes
    cs_refine:
          "prefix_refinement peterson_sr peterson_sr_cs1 peterson_sr \<top>\<top>
                             (\<lambda>_ s. cs1_v s = cs1 (cs2_v s)) \<top>\<top>
                             (peterson_rel (other_ident ident)) (peterson_rel (other_ident ident))
                             cs2 cs2"
begin

lemma
  "peterson_sr = peterson_sr'"
  by (auto simp: p_state.splits peterson_sr_def peterson_sr'_def intro!: ext)

lemma peterson_sr_set_ab[simp]:
 "peterson_sr s t \<Longrightarrow> peterson_sr (set_ab ident v s) (set_ab ident v t)"
  by (simp add: peterson_sr_def set_ab_def)

lemma env_stable_peterson_sr:
  "env_stable AR R peterson_sr peterson_sr \<top>"
  by (fastforce simp: env_stable_def rely_stable_def env_rely_stable_iosr_def peterson_sr_def)

lemmas prefix_refinement_interference_peterson =
  prefix_refinement_interference[OF env_stable_peterson_sr]

lemma peterson_sr_reflp[simp]:
  "reflp peterson_sr"
  by (simp add: peterson_sr_def reflpI)

lemma peterson_sr_equivp[simp]:
  "equivp peterson_sr"
  by (auto simp: peterson_sr_def intro!: sympI equivpI transpI)

lemma peterson_sr_cs1_invs: "peterson_sr_cs1 s t \<Longrightarrow> invs s = invs t"
   apply (auto simp: peterson_sr_def peterson_sr_cs1_def invs_def
                     req_peterson_inv_def key_peterson_inv_def
                     local_peterson_inv_def)[1]
  done

lemma env_stable_peterson_sr_cs1:
  "env_stable (peterson_rel (other_ident ident)) (peterson_rel (other_ident ident))
               peterson_sr peterson_sr_cs1 (\<lambda>s. invs s \<and> critical (ab_label s ident))"
  apply (simp add: env_stable_def rely_stable_def env_rely_stable_iosr_def
                 peterson_rel_def)
  apply (rule conjI)
   apply (auto simp: peterson_sr_def peterson_sr_cs1_def)[1]
  apply (rule conjI)
   apply clarsimp
   apply (clarsimp simp: peterson_sr_cs1_invs)
   apply (auto simp: peterson_sr_cs1_def peterson_sr_def)[1]
  apply (auto simp: peterson_sr_cs1_def peterson_sr_def)[1]
  done

lemmas prefix_refinement_interference_peterson_cs1 =
  prefix_refinement_interference[OF env_stable_peterson_sr_cs1]

lemmas prefix_refinement_bind_2left_2right
      = prefix_refinement_bind[where a="bind a a'" and c="bind c c'" for a a' c c', simplified bind_assoc]
lemmas rel_tr_refinement_bind_left_general_2left_2right
       = rel_tr_refinement_bind_left_general[where f="bind f f'" and g="bind g g'" for f f' g g', simplified bind_assoc]

lemma peterson_rel_imp_invs:
  "peterson_rel ident x y \<Longrightarrow> invs x \<Longrightarrow> invs y"
  by (simp add: peterson_rel_def)

lemma peterson_rel_imp_label:
  "peterson_rel (other_ident ident) x y \<Longrightarrow> invs x
   \<Longrightarrow> ab_label x ident = ab_label y ident"
  by (simp add: peterson_rel_def)

lemma peterson_rel_set_label:
  "peterson_rel (other_ident ident) (set_label ident label s) s'
   \<Longrightarrow> invs (set_label ident label s)
   \<Longrightarrow> ab_label s' ident = label"
  by (simp add: peterson_rel_def set_label_def)

lemma acquire_lock_refinement:
  "prefix_refinement peterson_sr peterson_sr peterson_sr \<top>\<top>
    \<top>\<top> \<top>\<top>
    (peterson_rel (other_ident ident)) (peterson_rel (other_ident ident))
    (acquire_lock ident) (acquire_lock ident)"
  apply (unfold acquire_lock_def)
  apply (rule prefix_refinement_weaken_pre)
    apply (rule prefix_refinement_bind_sr)
       apply (rule prefix_refinement_interference_peterson)
      apply (simp add: modify_modify_bind)
      apply (rule prefix_refinement_bind_sr)
         apply (rule pfx_refn_modifyT)
         apply (clarsimp simp add: peterson_sr_def set_label_def set_ab_def forall_ident_eq)
        apply (rule prefix_refinement_bind_sr)
           apply (rule prefix_refinement_interference_peterson)
          apply (rule prefix_refinement_bind_sr)
             apply (rule prefix_refinement_Await[OF env_stable_peterson_sr abs_rely_stableT])
              apply (clarsimp simp add: peterson_sr_def locked_def)
             apply (clarsimp simp add: peterson_sr_def locked_def)
            apply (rule pfx_refn_modifyT)
            apply (clarsimp simp add: peterson_sr_def set_label_def)
           apply (wpsimp wp: Await_sync_twp)+
  done

lemma peterson_sr_invs[simp]:
  "peterson_sr as cs \<Longrightarrow> invs as \<Longrightarrow> invs cs"
  by (simp add: peterson_sr_def invs_def invs_defs)

lemma peterson_sr_invs_sym:
  "peterson_sr as cs \<Longrightarrow> invs cs \<Longrightarrow> invs as"
  by (simp add: peterson_sr_def invs_def invs_defs)

lemma peterson_sr_ab_label:
  "peterson_sr as cs \<Longrightarrow> ab_label as = ab_label cs"
  by (simp add: peterson_sr_def)

lemma critical_section_refinement:
  "prefix_refinement peterson_sr peterson_sr peterson_sr \<top>\<top>
    (\<lambda>_ s. invs s \<and> ab_label s ident = Critical) \<top>\<top>
    (peterson_rel (other_ident ident)) (peterson_rel (other_ident ident))
    abs_critical_section critical_section"
  apply (simp add: abs_critical_section_def critical_section_def)
  apply (rule prefix_refinement_weaken_pre)
    apply (rule prefix_refinement_interferences_split)
    apply (rule prefix_refinement_bind_sr)
       apply (rule prefix_refinement_interference_peterson)

      (* reorder the interference and modify*)
      apply (rule pfx_refinement_use_rel_tr_refinement_equivp
                  [where Q="\<lambda>s. invs s \<and> ab_label s (ident) = Critical"])
        apply (rule rel_tr_refinement_bind_left_general_2left_2right)
          apply simp
         apply (rule disjI1,
                     clarsimp simp: not_env_steps_first_all
                                    cs_not_env_steps_first release_lock_def)
        apply (rule rshuttle_modify_interference)
          apply (simp add: peterson_sr_def peterson_rel_def)
         apply (clarsimp simp: peterson_rel_def)
        apply (clarsimp simp: p_state.splits)
        apply (clarsimp simp: peterson_rel_def invs_def invs_defs)
       apply simp

      apply (rule prefix_refinement_bind_sr)
         apply (rule prefix_refinement_interference_peterson)
        apply (rule prefix_refinement_bind[where intsr=peterson_sr_cs1])
           apply (rule pfx_refn_modifyT)
           apply (clarsimp simp add: peterson_sr_def peterson_sr_cs1_def)
          apply (rule prefix_refinement_bind_sr)
             apply (rule cs_refine)
            apply (rule prefix_refinement_interference_peterson)

           apply (wpsimp wp: validI_triv[OF cs_closed])+
  apply (subst peterson_rel_imp_label[symmetric], assumption, simp)
  apply (drule peterson_rel_imp_invs, simp)
  apply (simp add: peterson_sr_ab_label)
  done

lemma release_lock_refinement:
  "prefix_refinement peterson_sr peterson_sr peterson_sr \<top>\<top>
    \<top>\<top> \<top>\<top>
    (peterson_rel (other_ident ident)) (peterson_rel (other_ident ident))
    (release_lock ident) (release_lock ident)"
  apply (unfold release_lock_def)
  apply (rule prefix_refinement_weaken_pre)
    apply (simp add: modify_modify_bind)
    apply (rule prefix_refinement_bind_sr)
       apply (rule pfx_refn_modifyT)
       apply (clarsimp simp add: peterson_sr_def peterson_sr_cs1_def set_label_def set_ab_def)
      apply (rule prefix_refinement_interference_peterson)
     apply wpsimp+
  done

lemma critical_section_prefix_closed[simp]:
  "prefix_closed critical_section"
  by (auto intro!: prefix_closed_bind
           simp: cs_closed critical_section_def)

lemma abs_critical_section_prefix_closed[simp]:
  "prefix_closed abs_critical_section"
  by (auto intro!: prefix_closed_bind
           simp: cs_closed abs_critical_section_def)

lemma peterson_rel_trans:
 "peterson_rel ident x y \<Longrightarrow> peterson_rel ident y z \<Longrightarrow>
  peterson_rel ident x z"
 by (clarsimp simp: peterson_rel_def)

lemma invs_set_label_Critical:
  "invs s \<Longrightarrow> locked ident s \<Longrightarrow> ab_label s ident = Awaiting
   \<Longrightarrow> invs (set_label ident Critical s)"
  by (auto simp: invs_def invs_defs set_label_def locked_def)

lemma acquire_lock_wp:
  "\<lbrace> \<lambda>s0 s. invs s \<and> ab_label s ident = Exited \<rbrace>,
   \<lbrace> peterson_rel (other_ident ident) \<rbrace>
     acquire_lock ident
   \<lbrace> \<top>\<top> \<rbrace>,
   \<lbrace> \<lambda>rv s0 s. invs s \<and> ab_label s ident = Critical \<rbrace>"
  apply (simp add: acquire_lock_def)
  apply (rule validI_weaken_pre)
   apply (wpsimp wp: Await_sync_twp)+
  apply (subst (asm) peterson_rel_imp_label, assumption+)
  apply (drule(1) peterson_rel_imp_invs)
  apply (drule(1) peterson_rel_trans)
  apply (thin_tac "peterson_rel (other_ident ident) s'a x")
  apply (frule peterson_rel_set_label)
   apply (fastforce simp: set_label_def set_ab_def
                          locked_def invs_def invs_defs)
  apply (drule peterson_rel_imp_invs)
   apply (fastforce simp: set_label_def set_ab_def
                          locked_def invs_def invs_defs)
  apply (clarsimp simp: invs_set_label_Critical)
  apply (clarsimp simp: set_label_def set_ab_def)
  done

lemma acquire_lock_prefix_closed[simp]:
  "prefix_closed (acquire_lock ident)"
  by (auto intro!: prefix_closed_bind
           simp: cs_closed acquire_lock_def)

theorem peterson_proc_refinement:
  "prefix_refinement peterson_sr peterson_sr peterson_sr \<top>\<top>
    (\<lambda>_ s. invs s \<and> ab_label s ident = Exited)
    (\<lambda>_ s. invs s \<and> ab_label s ident = Exited)
    (peterson_rel (other_ident ident)) (peterson_rel (other_ident ident))
    (abs_peterson_proc ident)
    (peterson_proc ident)"
 apply (simp add: abs_peterson_proc_def peterson_proc_def)
   apply (rule prefix_refinement_weaken_pre)
   apply (rule prefix_refinement_bind_sr)
       apply (rule acquire_lock_refinement)
      apply (rule prefix_refinement_bind_sr)
         apply (rule critical_section_refinement)
        apply (rule release_lock_refinement)
       apply (wpsimp wp: validI_triv acquire_lock_wp
                     simp: bipred_conj_def)+
  done

definition
  peterson_rel2 :: "ident \<Rightarrow> ('a, 'b) p_state \<Rightarrow> ('a, 'b) p_state \<Rightarrow> bool"
where
  "peterson_rel2 ident s_prior s = (\<comment> \<open>assume invs\<close> invs s_prior \<longrightarrow>
            \<comment> \<open>If you're in the critical section, I won't change cs1_v\<close>
        (critical (ab_label s_prior (other_ident ident))
                \<longrightarrow> cs1_v s = cs1_v s_prior))"

definition
  peterson_rel3 :: "ident \<Rightarrow> ('a, 'b) p_state \<Rightarrow> ('a, 'b) p_state \<Rightarrow> bool"
where
  "peterson_rel3 ident s_prior s = (\<comment> \<open>assume invs\<close> invs s_prior \<longrightarrow>
            \<comment> \<open>invariants are preserved\<close>
        (invs s
            \<comment> \<open>I won't adjust your variables\<close>
        \<and> (ab_v s (other_ident ident) = ab_v s_prior (other_ident ident))
        \<and> (ab_label s (other_ident ident) = ab_label s_prior (other_ident ident))
            \<comment> \<open>I will only ever give you priority\<close>
        \<and> (t_v s_prior = other_ident ident \<longrightarrow> t_v s = other_ident ident)
            \<comment> \<open>If you're in the critical section, I won't change cs2_v\<close>
        \<and> (critical (ab_label s_prior (other_ident ident))
                \<longrightarrow> cs2_v s = cs2_v s_prior)))"

lemma peterson_rel_helpers:
  "peterson_rel2 ident s0 s \<and> peterson_rel3 ident s0 s
   \<longrightarrow> peterson_rel ident s0 s"
  by (clarsimp simp: peterson_rel_def peterson_rel2_def peterson_rel3_def)

lemma peterson_rel_peterson_rel2:
  "peterson_rel ident s0 s \<longrightarrow> peterson_rel2 ident s0 s"
  by (clarsimp simp: peterson_rel_def peterson_rel2_def)

lemma peterson_sr_peterson_rel3:
  "peterson_sr as0 cs0 \<Longrightarrow> peterson_sr as cs
   \<Longrightarrow> peterson_rel ident as0 as \<Longrightarrow> peterson_rel3 ident cs0 cs"
  apply (clarsimp simp: peterson_rel_def peterson_rel3_def invs_def
                        invs_defs peterson_sr_ab_label)
  apply (clarsimp simp: peterson_sr_def)
  done

lemma peterson_proc_prefix_closed[simp]:
  "prefix_closed (peterson_proc ident)"
  by (auto intro!: prefix_closed_bind
           simp: cs_closed peterson_proc_def acquire_lock_def release_lock_def)

lemma peterson_proc_mutual_excl_helper:
  "\<lbrace> \<lambda>s0 s. peterson_rel ident s0 s \<and> invs s
            \<and> ab_label s ident = Exited \<rbrace>,
   \<lbrace> peterson_rel (other_ident ident) \<rbrace>
     peterson_proc ident
   \<lbrace> peterson_rel3 ident \<rbrace>,
   \<lbrace> \<lambda>rv s0 s. peterson_rel3 ident s0 s \<and> invs s
               \<and> ab_label s ident = Exited \<rbrace>"
  apply (rule prefix_refinement_validI')
        apply (rule peterson_proc_refinement)
       apply (rule abs_peterson_proc_mutual_excl)
      apply (clarsimp simp: peterson_sr_peterson_rel3 peterson_sr_ab_label)
     apply (clarsimp simp: peterson_sr_peterson_rel3)
    apply clarsimp
    apply (rule_tac x=t0 in exI)
    apply (rule_tac x="t \<lparr>cs1_v := cs1_v t0\<rparr>" in exI)
    apply (clarsimp simp: peterson_rel_def peterson_sr_def)
   apply clarsimp
   apply (rule_tac x="t \<lparr>cs1_v := cs1_v s0\<rparr>" in exI)
   apply (clarsimp simp: peterson_rel_def peterson_sr_def invs_def invs_defs)
  apply clarsimp
  done

lemma peterson_proc_mutual_excl_helper':
  "\<lbrace> \<lambda>s0 s. peterson_rel ident s0 s \<and> invs s
            \<and> ab_label s ident = Exited \<rbrace>,
   \<lbrace> peterson_rel (other_ident ident) \<rbrace>
     peterson_proc ident
   \<lbrace> peterson_rel2 ident \<rbrace>,
   \<lbrace> \<lambda>rv s0 s. peterson_rel2 ident s0 s \<and> invs s
               \<and> ab_label s ident = Exited \<rbrace>"
  apply (simp add: peterson_proc_def acquire_lock_def release_lock_def
                   critical_section_def)
  apply (rule validI_weaken_pre)
   apply (wp Await_sync_twp | simp add: split_def
          | rule validI_strengthen_guar[OF _ allI[OF allI[OF peterson_rel_peterson_rel2]]])+
  apply (clarsimp simp: imp_conjL)
  apply (strengthen peterson_rel_imp_assume_invs | simp)+
  apply (cases ident)
  apply (safe, simp_all)
  by ((clarsimp simp: peterson_rel_def peterson_rel2_def forall_ident_eq
                      set_label_def set_ab_def locked_def invs_defs cs_closed
    | rule invs_def[THEN iffD2] conjI
    | rev_drule invs_def[THEN iffD1])+)

lemma peterson_proc_mutual_excl:
  "\<lbrace> \<lambda>s0 s. peterson_rel ident s0 s \<and> invs s
            \<and> ab_label s ident = Exited \<rbrace>,
   \<lbrace> peterson_rel (other_ident ident) \<rbrace>
     peterson_proc ident
   \<lbrace> peterson_rel ident \<rbrace>,
   \<lbrace> \<lambda>rv s0 s. peterson_rel ident s0 s \<and> invs s
               \<and> ab_label s ident = Exited \<rbrace>"
  apply (rule validI_strengthen_guar, rule validI_strengthen_post, rule validI_guar_post_conj_lift)
     apply (rule peterson_proc_mutual_excl_helper)
    apply (rule peterson_proc_mutual_excl_helper')
   apply (clarsimp simp: peterson_rel_helpers)+
  done

definition "abs_peterson_proc_system \<equiv>
     parallel (do repeat (abs_peterson_proc A); interference od)
              (do repeat (abs_peterson_proc B); interference od)"

lemma validI_repeat_interference:
  "\<lbrace>P\<rbrace>, \<lbrace>R\<rbrace> f \<lbrace>G\<rbrace>, \<lbrace>\<lambda>_. P\<rbrace>
   \<Longrightarrow> \<forall>s0 s. P s0 s \<longrightarrow> (\<forall>s'. R\<^sup>*\<^sup>* s s' \<longrightarrow> Q () s' s') \<and> G s0 s
   \<Longrightarrow> \<lbrace>P\<rbrace>, \<lbrace>R\<rbrace> do repeat f; interference od \<lbrace>G\<rbrace>, \<lbrace>Q\<rbrace>"
  apply (rule bind_twp)
   apply simp
   apply (rule interference_twp)
  apply (rule validI_strengthen_post)
   apply (rule repeat_validI, assumption)
  apply simp
  done

lemma abs_peterson_proc_system_mutual_excl:
  "\<lbrace> \<lambda>s0 s. s0 = s \<and> invs s \<and> ab_label s = (\<lambda>_. Exited) \<rbrace>,
   \<lbrace> \<lambda>s0 s. s0 = s \<rbrace>
     abs_peterson_proc_system
   \<lbrace> \<lambda>s0 s. invs s0 \<longrightarrow> invs s \<rbrace>,
   \<lbrace> \<lambda>rv s0 s. invs s \<rbrace>"
  apply (rule validI_weaken_pre, rule validI_strengthen_post)
    apply (unfold abs_peterson_proc_system_def)
    apply (rule rg_validI[where Qf="\<lambda>_ _. invs" and Qg="\<lambda>_ _. invs"])
           apply (rule validI_repeat_interference[OF abs_peterson_proc_mutual_excl])
           apply (clarsimp simp: peterson_rel_imp_invs)
          apply (rule validI_repeat_interference[OF abs_peterson_proc_mutual_excl])
          apply (clarsimp simp: peterson_rel_imp_invs)
         apply (simp add: reflp_ge_eq)+
  apply (clarsimp simp: peterson_rel_def)+
  done

definition "peterson_proc_system \<equiv>
     parallel (do repeat (peterson_proc A); interference od)
              (do repeat (peterson_proc B); interference od)"

lemma abs_peterson_proc_prefix_closed[simp]:
  "prefix_closed (abs_peterson_proc ident)"
  by (auto intro!: prefix_closed_bind
           simp: cs_closed abs_peterson_proc_def acquire_lock_def release_lock_def)

lemma peterson_repeat_refinement:
  "prefix_refinement peterson_sr peterson_sr peterson_sr \<top>\<top>
    (\<lambda>s0 s. peterson_rel ident s0 s \<and> invs s \<and> ab_label s ident = Exited)
    (\<lambda>s0 s. peterson_rel ident s0 s \<and> invs s \<and> ab_label s ident = Exited)
    (peterson_rel (other_ident ident)) (peterson_rel (other_ident ident))
    (do repeat (abs_peterson_proc ident);
        interference
     od)
    (do repeat (peterson_proc ident);
        interference
     od)"
  apply (rule prefix_refinement_weaken_pre)
    apply (rule prefix_refinement_bind_sr)
       apply (rule prefix_refinement_repeat[rotated])
         apply (rule abs_peterson_proc_mutual_excl[THEN validI_strengthen_guar])
         apply simp
        apply (rule peterson_proc_mutual_excl[THEN validI_strengthen_guar, THEN validI_weaken_pre])
         apply simp+
       apply (rule peterson_proc_refinement[THEN prefix_refinement_weaken_pre])
        apply simp+
      apply (rule prefix_refinement_interference_peterson)
     apply (wpsimp wp: validI_triv)+
  done

theorem peterson_proc_system_refinement:
  "prefix_refinement peterson_sr peterson_sr peterson_sr \<top>\<top>
    (\<lambda>s0 s. s0 = s \<and> invs s \<and> ab_label s = (\<lambda>_. Exited))
    (\<lambda>t0 t. t0 = t \<and> invs t \<and> ab_label t = (\<lambda>_. Exited))
    (\<lambda>s0 s. s0 = s) (\<lambda>t0 t. t0 = t)
    abs_peterson_proc_system peterson_proc_system"
  apply (unfold abs_peterson_proc_system_def peterson_proc_system_def)
  apply (rule prefix_refinement_parallel')
         apply (rule prefix_refinement_weaken_rely, rule prefix_refinement_weaken_pre)
             apply (rule peterson_repeat_refinement)
            apply simp
           apply simp
          apply (rule eq_refl, rule bipred_disj_op_eq, simp)
         apply (rule eq_refl, rule bipred_disj_op_eq, simp)
        apply (rule prefix_refinement_weaken_rely, rule prefix_refinement_weaken_pre)
            apply (rule peterson_repeat_refinement)
           apply simp
          apply simp
         apply (rule eq_refl, rule bipred_disj_op_eq, simp)
        apply (rule eq_refl, rule bipred_disj_op_eq, simp)
       apply (clarsimp intro!: par_tr_fin_bind par_tr_fin_interference)
      apply (clarsimp intro!: par_tr_fin_bind par_tr_fin_interference)
     apply (rule validI_weaken_pre, rule validI_weaken_rely)
       apply (rule validI_repeat_interference; simp)
        apply (rule peterson_proc_mutual_excl)
       apply (simp+)[3]
    apply (rule validI_weaken_pre, rule validI_weaken_rely)
      apply (rule validI_repeat_interference; simp)
       apply (rule peterson_proc_mutual_excl)
      apply (simp+)[3]
  apply (rule validI_weaken_pre, rule validI_weaken_rely)
     apply (rule validI_repeat_interference; simp)
      apply (rule abs_peterson_proc_mutual_excl)
     apply (simp+)[3]
  apply (rule validI_weaken_pre, rule validI_weaken_rely)
    apply (rule validI_repeat_interference; simp)
     apply (rule abs_peterson_proc_mutual_excl)
    apply (simp+)[3]
  done

lemma peterson_proc_system_prefix_closed[simp]:
  "prefix_closed (peterson_proc_system)"
  by (auto intro!: prefix_closed_bind parallel_prefix_closed
             simp: cs_closed peterson_proc_system_def)

theorem peterson_proc_system_mutual_excl:
  "\<lbrace> \<lambda>s0 s. s0 = s \<and> invs s \<and> ab_label s = (\<lambda>_. Exited) \<rbrace>,
   \<lbrace> \<lambda>s0 s. s0 = s \<rbrace>
     peterson_proc_system
   \<lbrace> \<lambda>s0 s. invs s0 \<longrightarrow> invs s \<rbrace>,
   \<lbrace> \<lambda>rv s0 s. invs s \<rbrace>"
  apply (rule prefix_refinement_validI')
        apply (rule peterson_proc_system_refinement)
       apply (rule abs_peterson_proc_system_mutual_excl)
      apply clarsimp
     apply (clarsimp simp: peterson_sr_invs_sym )
    apply (fastforce simp: peterson_rel_def peterson_sr_def)
   apply clarsimp
  apply (fastforce simp: peterson_sr_def)
  done

end
end