(*
 * Copyright 2016, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the GNU General Public License version 2. Note that NO WARRANTY is provided.
 * See "LICENSE_GPLv2.txt" for details.
 *
 * @TAG(NICTA_GPL)
 *)

theory BufferT
imports
  "../impl/BilbyFs_Shallow_Desugar_Tuples"
  "../impl/BilbyFs_ShallowConsts_Desugar_Tuples"
  "../adt/WordArrayT"
begin

definition
  buf_slice :: "Buffer\<^sub>T \<Rightarrow> U32 \<Rightarrow> U32 \<Rightarrow> U8 list"
where
 "buf_slice buf frm to \<equiv> slice (unat frm) (unat to) (\<alpha>wa $ data\<^sub>f buf)"

definition
  buf_sub_slice :: "Buffer\<^sub>T \<Rightarrow> U32 \<Rightarrow> U32 \<Rightarrow> U8 list \<Rightarrow> U8 list"
where
 "buf_sub_slice buf frm to xs \<equiv>
 take (length (\<alpha>wa $ data\<^sub>f buf)) (take (unat frm) (\<alpha>wa $ data\<^sub>f buf) @
 (take (unat to - unat frm) (xs@replicate (unat to - unat frm) 0)) @
  drop (max (unat to) (unat frm)) (\<alpha>wa $ data\<^sub>f buf))"

lemma buf_sub_slice_length:
  "length (buf_sub_slice buf frm to xs) = length (\<alpha>wa (data\<^sub>f buf))"
  apply (simp add: buf_sub_slice_def)
  apply(subst min_def)+
using [[linarith_split_limit=20]]
apply clarsimp (* take a while *)
apply safe
apply unat_arith+
done

definition
  buf_drop :: "Buffer\<^sub>T \<Rightarrow> U32 \<Rightarrow> U8 list"
where
 "buf_drop buf offs \<equiv> drop (unat offs) (\<alpha>wa $ data\<^sub>f buf)"

definition
  buf_take :: "Buffer\<^sub>T \<Rightarrow> U32 \<Rightarrow> U8 list"
where
 "buf_take buf offs \<equiv> take (unat offs) (\<alpha>wa $ data\<^sub>f buf)"

definition
  buf_update_bounded :: "Buffer\<^sub>T \<Rightarrow> U8 list \<Rightarrow> U8 list"
where
 "buf_update_bounded buf buf_updated \<equiv>
    take (min (unat $ bound\<^sub>f buf) (length $ \<alpha>wa $ data\<^sub>f buf)) buf_updated @
    drop (min (unat $ bound\<^sub>f buf) (length buf_updated)) (\<alpha>wa $ data\<^sub>f buf) "

definition
  buf_memset' :: "Buffer\<^sub>T \<Rightarrow> U32 \<Rightarrow> U32 \<Rightarrow> U8 \<Rightarrow> U8 list"
where
 "buf_memset' buf offs len v \<equiv>
   buf_update_bounded buf $ buf_take buf offs @ replicate (min (unat len) (unat (bound\<^sub>f buf) - unat offs)) v @ buf_drop buf (offs+len)"

lemma buf_update_bounded_length:
 "length (buf_update_bounded buf upd) = length (\<alpha>wa $ data\<^sub>f buf)"
  by (simp add: buf_bound_def buf_update_bounded_def buf_length_def)

lemmas buf_simps = buf_take_def buf_drop_def buf_slice_def
    buf_bound_def buf_update_bounded_def buf_length_def
    buf_memset'_def buf_update_bounded_length
    slice_def

lemma drop_take_drop:
  "n \<le> m \<Longrightarrow> drop n (take m xs) @ drop m xs = drop n xs"
 by (metis Nat.le_iff_add add.commute take_drop take_drop_append)

lemma buf_memset_bound_assm_eq:
  "unat (bound\<^sub>f buf) \<le>  length (\<alpha>wa (data\<^sub>f buf)) \<Longrightarrow>
  offs \<le> offs + len \<Longrightarrow>
  unat offs \<le> unat (bound\<^sub>f buf) \<Longrightarrow>
  offs + len \<le> bound\<^sub>f buf \<Longrightarrow>
  wordarray_set (data\<^sub>f buf, offs, len, v) = WordArrayT.make (buf_memset' buf offs len v)"
 unfolding buf_memset_def[unfolded tuple_simps sanitizers]
   apply (simp add: Let_def wordarray_set_ret buf_simps min_absorb1)
   apply (rule arg_cong[where f=WordArrayT.make])
   apply (subgoal_tac "(unat (bound\<^sub>f buf) - unat offs) \<ge> (unat len)")
    prefer 2
    apply unat_arith
   apply (simp add: min_absorb1 )
   apply (subgoal_tac "(unat (bound\<^sub>f buf)) \<le>
            (unat offs + (unat len + (length (\<alpha>wa (data\<^sub>f buf)) - unat (offs + len))))")
   prefer 2
   apply (unat_arith)
  apply (simp add: min_absorb1 take_drop)
  apply (subgoal_tac " (unat offs + unat len) =  unat (offs + len)")
   apply (simp add: drop_take_drop)
  apply unat_arith
 done

lemma take_prefix_length:
 "take n xs = take n ys \<Longrightarrow>
   n \<le> length xs \<Longrightarrow> n \<le> length ys"
by (metis length_take min.absorb_iff2)

lemma buf_bounded_update_bounded_prefix:
 "unat (bound\<^sub>f buf) \<le> length (\<alpha>wa (data\<^sub>f buf)) \<Longrightarrow>
 take (unat (bound\<^sub>f buf)) xs = take (unat (bound\<^sub>f buf)) ys \<Longrightarrow>
  buf_update_bounded buf xs = buf_update_bounded buf ys"
 apply (simp add: buf_simps)
 apply (case_tac "(unat (bound\<^sub>f buf)) \<le> (length xs)")
  apply (frule (1) take_prefix_length)
  apply (simp add: min_absorb1)
 apply simp
done

lemma buf_memset_bound:
 "unat (bound\<^sub>f buf) \<le> length (\<alpha>wa (data\<^sub>f buf)) \<Longrightarrow>
    offs \<le> offs + len \<Longrightarrow>
    offs < bound\<^sub>f buf \<Longrightarrow>
    \<not> offs + len < bound\<^sub>f buf \<Longrightarrow>
    buf_memset' buf offs (bound\<^sub>f buf - offs) v = buf_memset' buf offs len v"
  apply (simp add: buf_memset'_def)
  apply (subgoal_tac "unat (bound\<^sub>f buf - offs) = unat (bound\<^sub>f buf) - unat offs")
   prefer 2
   apply unat_arith
  apply (simp add: min_absorb2)
  apply (subgoal_tac "(unat len) \<ge> (unat (bound\<^sub>f buf) - unat offs)")
   prefer 2
   apply unat_arith
  apply simp
  apply (rule buf_bounded_update_bounded_prefix)
   apply (simp add: buf_simps)+
 done

lemma take_n_m_double_append:
 "n \<le> m \<Longrightarrow> n \<le> length xs \<Longrightarrow>
    take n (take m xs @ ys ) = take n xs"
 by simp

lemma buf_memset_offs_bound:
 "unat (bound\<^sub>f buf) \<le> length (\<alpha>wa (data\<^sub>f buf)) \<Longrightarrow>
   offs \<le> offs + len \<Longrightarrow>
   \<not> offs < bound\<^sub>f buf \<Longrightarrow>
   buf_memset' buf (bound\<^sub>f buf) len' v =
   buf_memset' buf offs len v"
  apply (simp add: buf_memset'_def)
  apply (rule buf_bounded_update_bounded_prefix)
   apply simp
  apply (simp only: buf_take_def )
  apply (subst take_n_m_double_append)
     apply simp
    apply unat_arith
   apply unat_arith
  apply simp
 done

lemma buf_memset_eq:
  "unat (bound\<^sub>f buf) \<le>  length (\<alpha>wa (data\<^sub>f buf)) \<Longrightarrow>
  offs \<le> offs + len \<Longrightarrow>
  buf_memset (buf, offs, len, v) = buf\<lparr>data\<^sub>f:=WordArrayT.make (buf_memset' buf offs len v)\<rparr>"
 unfolding buf_memset_def[unfolded tuple_simps sanitizers]
  apply (simp only: Let_def prod.case_eq_if prod.sel take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t_def)
  apply (subst buf_memset_bound_assm_eq)
      apply simp
     apply ((case_tac " offs < bound\<^sub>f buf", ((simp, unat_arith)+)[2])+)[3]
  apply (rule arg_cong[where f="\<lambda>v. data\<^sub>f_update v buf"])
  apply (rule ext)
  apply (rule arg_cong[where f=WordArrayT.make])
  apply (case_tac "offs < bound\<^sub>f buf")
   apply (simp add: buf_memset_bound)
  apply (simp add: buf_memset_offs_bound)
 done

lemma buf_memset_length_eq:
  "unat (bound\<^sub>f buf) \<le> length (\<alpha>wa (data\<^sub>f buf)) \<Longrightarrow>
 offs \<le> offs + len \<Longrightarrow>
buf_length (buf_memset (buf, offs, len, v)) = buf_length buf"
 by (simp add: buf_length_def wordarray_length_ofnat[OF wordarray_length_ret]
      buf_memset_eq wordarray_make buf_update_bounded_length buf_memset'_def)

lemma buf_take_buf_slice_adjacent:
 "st \<le>  end \<Longrightarrow> buf_take b st @ buf_slice b st end = buf_take b end"
by (simp add: buf_simps word_le_nat_alt)
  (metis (no_types, lifting) append_take_drop_id min_def take_take)

lemma length_buf_memset:
  "unat (bound\<^sub>f wbuf) \<le>  length (\<alpha>wa (data\<^sub>f wbuf)) \<Longrightarrow>
 n < n + m \<Longrightarrow>
length (\<alpha>wa (data\<^sub>f (buf_memset (wbuf, n, m, v)))) = length (\<alpha>wa (data\<^sub>f wbuf))"
 by (simp add: buf_memset_eq buf_memset'_def wordarray_make buf_update_bounded_length)

lemma buf_slice_n_n:
  "buf_slice buf n n = []"
  by (simp add: buf_simps)

lemma buf_slice_0_eq_buf_take:
 "buf_slice buf 0 n = buf_take buf n"
 by (simp add: buf_simps)

lemma buf_slice_out_of_buf_memset:
 "frm \<le> to \<Longrightarrow> to \<le> st \<Longrightarrow> st \<le> st + len \<Longrightarrow> st \<le> bound\<^sub>f b \<Longrightarrow> unat (bound\<^sub>f b) = length (\<alpha>wa (data\<^sub>f b)) \<Longrightarrow>
  buf_slice (buf_memset (b, st, len, v)) frm to = buf_slice b frm to"
  apply (subst buf_memset_eq)
   apply simp+
  apply (simp add:  buf_simps wordarray_make min_absorb1 min_absorb2)
  apply (simp only: unat_arith_simps)
  apply (simp add: min_absorb1 min_absorb2)
 done

lemma buf_update_boundedI:
 "unat (buf_bound wbuf) \<le> length (\<alpha>wa (data\<^sub>f wbuf)) \<Longrightarrow>
  length xs = length (\<alpha>wa (data\<^sub>f wbuf)) \<Longrightarrow>
  drop (unat (bound\<^sub>f wbuf)) (\<alpha>wa (data\<^sub>f wbuf)) = drop (unat (bound\<^sub>f wbuf)) xs \<Longrightarrow>
  P xs \<Longrightarrow>
  P (buf_update_bounded wbuf xs)"
by (simp add: buf_bound_def buf_update_bounded_def min_absorb1)

lemma take_n_buf_sub_slice_n:
 "unat n \<le> length (\<alpha>wa (data\<^sub>f b)) \<Longrightarrow> take (unat n) (buf_sub_slice b n t xs) = take (unat n) (\<alpha>wa (data\<^sub>f b))"
 by (simp add: buf_sub_slice_def min_absorb1)

 lemma take_n_buf_sub_slice_m:
 "unat m \<le> length (\<alpha>wa (data\<^sub>f b)) \<Longrightarrow> n \<le> m \<Longrightarrow>  take (unat n) (buf_sub_slice b m t xs) = take (unat n) (\<alpha>wa (data\<^sub>f b))"
 by (simp add: buf_sub_slice_def min_absorb1 word_le_nat_alt)

lemma slice_buf_sub_slice:
 "frm \<le> mid \<Longrightarrow> mid \<le> to \<Longrightarrow> unat to \<le> length (\<alpha>wa (data\<^sub>f b)) \<Longrightarrow>
  unat (to - mid) = length xs \<Longrightarrow>
 slice (unat frm) (unat to) (buf_sub_slice b mid to xs) = buf_slice b frm mid @ take (unat to - unat mid) xs"
  apply (simp add: buf_simps buf_sub_slice_def min_absorb1 min_absorb2)
  apply (subgoal_tac "unat mid \<le> length (\<alpha>wa (data\<^sub>f b))")
   apply (subgoal_tac "unat frm \<le> length (\<alpha>wa (data\<^sub>f b))")
    apply (subgoal_tac "unat frm \<le> unat mid")
  apply (simp add: buf_simps buf_sub_slice_def min_absorb1 min_absorb2 word_le_nat_alt)
  apply unat_arith+
 done

end


theory Proof_3_4
  imports Proofs_3
begin

thm VC4_def

context
  fixes s2 s0:: state
fixes user_value pressure_value:: bool
assumes toEnvPs2:  "toEnvP s2 \<and> toEnvP s0" and extraInvs0: "extraInv s0"
and vc: " env (setVarAny s0 user_value pressure_value) \<and>
         getPstate (setVarAny s0 user_value pressure_value) ERROR = Controller'motionless \<and>
        \<not>getVarBool (setVarAny s0 user_value pressure_value) user"
begin

lemma VC4_R3_ind_step_aux1: " toEnvP s2a \<Longrightarrow>
         substate s2 s2a \<and>
         substate s2a
         (toEnv (setVarAny s0 user'value pressure'value)) \<and>
         s2 \<noteq> s2a \<Longrightarrow>
         substate s1 s2 \<and>
         substate s2
          (toEnv (setVarAny s0 user'value pressure'value)) \<and>
         toEnvP s1 \<and>
         toEnvP s2 \<and>
         toEnvNum s1 s2 = ERROR \<and>
         DELAY'TIMEOUT =
         toEnvNum s2
          (toEnv (setVarAny s0 user'value pressure'value)) \<and>
         getVarBool s1 rotation = True \<and>
         \<not> getVarBool s2 user \<and>
         (\<forall>s4. toEnvP s4 \<and> substate s2 s4 \<and> substate s4 s2a \<and> s4 \<noteq> s2a \<longrightarrow>
               getVarBool s4 rotation = True \<and> \<not> getVarBool s4 user) \<longrightarrow>
         (\<exists>s4. toEnvP s4 \<and>
               substate s2a s4 \<and>
               substate s4
                (toEnv (setVarAny s0 user'value pressure'value)) \<and>
               toEnvNum s2 s4 \<le> DELAY'TIMEOUT \<and>
               (getVarBool s4 rotation = False \<or> getVarBool s4 user) \<and>
               (\<forall>s3. toEnvP s3 \<and> substate s2a s3 \<and> substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow>
                     getVarBool s3 rotation = True \<and> \<not> getVarBool s3 user)) \<Longrightarrow>
         substate s1 s2 \<and>
         substate s2
          (toEnv (setVarAny s0 user'value pressure'value)) \<and>
         toEnvP s1 \<and>
         toEnvP s2 \<and>
         toEnvNum s1 s2 = ERROR \<and>
         DELAY'TIMEOUT =
         toEnvNum s2
          (toEnv (setVarAny s0 user'value pressure'value)) \<and>
         getVarBool s1 rotation = True \<and>
         \<not> getVarBool s2 user \<and>
         (\<forall>s4. toEnvP s4 \<and> substate s2 s4 \<and> substate s4 (predEnv s2a) \<and> s4 \<noteq> predEnv s2a \<longrightarrow>
               getVarBool s4 rotation = True \<and> \<not> getVarBool s4 user) \<Longrightarrow>
         \<not> (getVarBool (predEnv s2a) rotation = False \<or> getVarBool (predEnv s2a) user) \<Longrightarrow>
         toEnvP x \<and>
         substate s2a x \<and>
         substate x
          (toEnv (setVarAny s0 user'value pressure'value)) \<and>
         toEnvNum s2 x \<le> DELAY'TIMEOUT \<and>
         (getVarBool x rotation = False \<or> getVarBool x user) \<and>
         (\<forall>s3. toEnvP s3 \<and> substate s2a s3 \<and> substate s3 x \<and> s3 \<noteq> x \<longrightarrow>
               getVarBool s3 rotation = True \<and> \<not> getVarBool s3 user) \<Longrightarrow>
         \<exists>s4. toEnvP s4 \<and>
              substate (predEnv s2a) s4 \<and>
              substate s4
               (toEnv (setVarAny s0 user'value pressure'value)) \<and>
              toEnvNum s2 s4 \<le> DELAY'TIMEOUT \<and>
              (getVarBool s4 rotation = False \<or> getVarBool s4 user) \<and>
              (\<forall>s3. toEnvP s3 \<and> substate (predEnv s2a) s3 \<and> substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow>
                    getVarBool s3 rotation = True \<and> \<not> getVarBool s3 user)"
  apply(rule exI[of _ x])
  by (smt (z3) predEnv_substate predEnv_substate_imp_eq_or_substate substate_trans)

lemma VC4_R3_ind_step: " toEnvP s2a \<Longrightarrow>
           substate s2 s2a \<and>
           substate s2a
            (toEnv (setVarAny s0 user'value pressure'value)) \<and>
           s2 \<noteq> s2a \<Longrightarrow>
           substate s1 s2 \<and>
           substate s2
           (toEnv (setVarAny s0 user'value pressure'value)) \<and>
           toEnvP s1 \<and>
           toEnvP s2 \<and>
           toEnvNum s1 s2 = ERROR \<and>
           DELAY'TIMEOUT =
           toEnvNum s2
            (toEnv (setVarAny s0 user'value pressure'value)) \<and>
           getVarBool s1 rotation = True \<and>
           \<not> getVarBool s2 user \<and>
           (\<forall>s4. toEnvP s4 \<and> substate s2 s4 \<and> substate s4 s2a \<and> s4 \<noteq> s2a \<longrightarrow>
                 getVarBool s4 rotation = True \<and> \<not> getVarBool s4 user) \<longrightarrow>
           (\<exists>s4. toEnvP s4 \<and>
                 substate s2a s4 \<and>
                 substate s4
                 (toEnv (setVarAny s0 user'value pressure'value)) \<and>
                 toEnvNum s2 s4 \<le> DELAY'TIMEOUT \<and>
                 (getVarBool s4 rotation = False \<or> getVarBool s4 user) \<and>
                 (\<forall>s3. toEnvP s3 \<and> substate s2a s3 \<and> substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow>
                       getVarBool s3 rotation = True \<and> \<not> getVarBool s3 user)) \<Longrightarrow>
           substate s1 s2 \<and>
           substate s2
            (toEnv (setVarAny s0 user'value pressure'value)) \<and>
           toEnvP s1 \<and>
           toEnvP s2 \<and>
           toEnvNum s1 s2 = ERROR \<and>
           DELAY'TIMEOUT =
           toEnvNum s2
            (toEnv (setVarAny s0 user'value pressure'value)) \<and>
           getVarBool s1 rotation = True \<and>
           \<not> getVarBool s2 user \<and>
           (\<forall>s4. toEnvP s4 \<and> substate s2 s4 \<and> substate s4 (predEnv s2a) \<and> s4 \<noteq> predEnv s2a \<longrightarrow>
                 getVarBool s4 rotation = True \<and> \<not> getVarBool s4 user) \<longrightarrow>
           (\<exists>s4. toEnvP s4 \<and>
                 substate (predEnv s2a) s4 \<and>
                 substate s4
                  (toEnv (setVarAny s0 user'value pressure'value)) \<and>
                 toEnvNum s2 s4 \<le> DELAY'TIMEOUT \<and>
                 (getVarBool s4 rotation = False \<or> getVarBool s4 user) \<and>
                 (\<forall>s3. toEnvP s3 \<and> substate (predEnv s2a) s3 \<and> substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow>
                       getVarBool s3 rotation = True \<and> \<not> getVarBool s3 user))"
  apply(rule impI)
  apply(cases "(getVarBool (predEnv s2a) rotation = False \<or> getVarBool (predEnv s2a) user)")
   apply(rule exI[of _ "predEnv s2a"])
   apply(rule conjI)
    apply(rule toEnvP_substate_pred_imp_toEnvP_pred[of s2])
  using toEnvPs2 substate_eq_or_predEnv apply fast
   apply(rule conjI)
  using substate_refl apply fast
   apply(rule conjI)
  using predEnv_substate substate_trans apply fast
   apply(rule conjI)
    apply(rule cut_rl[of "substate s2 (predEnv s2a) \<and>
 substate (predEnv s2a)
 (toEnv (setVarAny s0 user'value pressure'value))"])
  using toEnvNum3[of s2 "predEnv s2a"
"(toEnv (setVarAny s0 user'value pressure'value))"]
     apply arith
  using substate_eq_or_predEnv predEnv_substate substate_trans apply fast
   apply(rule conjI)
    apply assumption
  using substate_asym apply fast
  apply(rule exE[of "\<lambda> s4. toEnvP s4 \<and>
          substate s2a s4 \<and>
          substate s4
          (toEnv (setVarAny s0 user'value pressure'value)) \<and>
          toEnvNum s2 s4 \<le> DELAY'TIMEOUT \<and>
          (getVarBool s4 rotation = False \<or> getVarBool s4 user) \<and>
          (\<forall>s3. toEnvP s3 \<and> substate s2a s3 \<and> substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow>
                getVarBool s3 rotation = True \<and> \<not> getVarBool s3 user)"])
  using substate_eq_or_predEnv apply blast
  by ((rule VC4_R3_ind_step_aux1);blast)

lemma VC4_R3_ind_proof:   "toEnvP s5 \<and>  substate s2 s5 \<and>
 substate s5 (toEnv (setVarAny s0 user'value pressure'value))
 \<longrightarrow> pred3 s1 s2 (toEnv (setVarAny s0 user'value pressure'value))
 s5"
  apply(induction rule: state_down_ind)
  using toEnvPs2 apply simp
   apply(simp only: pred3_def)
   apply(rule impI)
  apply(rule cut_rl[of "getVarBool s0 rotation = False"])
    apply(rule cut_rl[of "getVarBool s0 rotation = True \<and> \<not> getVarBool s0 user"])
     apply fast
  apply(rule cut_rl[of "substate s2 s0 \<and>
          substate s0
           (toEnv (setVarAny s0 user'value pressure'value))\<and>
          s0 \<noteq>
          (toEnv (setVarAny s0 user'value pressure'value)) "])
  using toEnvPs2  apply fast
  using substate_refl toEnvNum_id apply((simp split: if_splits);auto)
  using extraInvs0 extraInv_def vc
   apply (smt (verit) getPstate.simps(9) predEnv.simps(9) predEnv_substate substate_eq_or_predEnv toEnvPs2)
 apply(simp only: pred3_def)
  by ((rule VC4_R3_ind_step);fast)
end

lemma VC4_R3: " (((((toEnvP s0 \<and>
            (\<forall>s1 s2.
                substate s1 s2 \<and>
                substate s2 s0 \<and>
                toEnvP s1 \<and>
                toEnvP s2 \<and>
                toEnvNum s1 s2 = ERROR \<and>
                DELAY'TIMEOUT \<le> toEnvNum s2 s0 \<and> getVarBool s1 rotation = True \<and> \<not> getVarBool s2 user \<longrightarrow>
                (\<exists>s4. toEnvP s4 \<and>
                      substate s2 s4 \<and>
                      substate s4 s0 \<and>
                      toEnvNum s2 s4 \<le> DELAY'TIMEOUT \<and>
                      (getVarBool s4 rotation = False \<or> getVarBool s4 user) \<and>
                      (\<forall>s3. toEnvP s3 \<and> substate s2 s3 \<and> substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow>
                            getVarBool s3 rotation = True \<and> \<not> getVarBool s3 user)))) \<and>
           extraInv s0) \<and>
          env (setVarAny s0 user_value pressure_value)) \<and>
         getPstate (setVarAny s0 user_value pressure_value) ERROR = Controller'motionless) \<and>
        \<not>getVarBool (setVarAny s0 user_value pressure_value) user)  \<Longrightarrow>
       substate s1 s2 \<and>
       substate s2
       (toEnv (setVarAny s0 user'value pressure'value)) \<and>
       toEnvP s1 \<and>
       toEnvP s2 \<and>
       toEnvNum s1 s2 = ERROR \<and>
       DELAY'TIMEOUT
       \<le> toEnvNum s2
           (toEnv (setVarAny s0 user'value pressure'value)) \<and>
       getVarBool s1 rotation = True \<and> \<not> getVarBool s2 user \<longrightarrow>
       (\<exists>s4. toEnvP s4 \<and>
             substate s2 s4 \<and>
             substate s4
              (toEnv (setVarAny s0 user'value pressure'value)) \<and>
             toEnvNum s2 s4 \<le> DELAY'TIMEOUT \<and>
             (getVarBool s4 rotation = False \<or> getVarBool s4 user) \<and>
             (\<forall>s3. toEnvP s3 \<and> substate s2 s3 \<and> substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow>
                   getVarBool s3 rotation = True \<and> \<not> getVarBool s3 user))"
  apply(rule impI)
  apply(rule disjE[of "DELAY'TIMEOUT < toEnvNum s2 (toEnv (setVarAny s0 user'value pressure'value))"
"DELAY'TIMEOUT = toEnvNum s2 (toEnv (setVarAny s0 user'value pressure'value))"])
  using le_imp_less_or_eq apply fast
   apply(rule cut_rl[of "substate s2 s0 \<and> toEnvNum s2 s0 \<ge> DELAY'TIMEOUT"])
  apply(rule cut_rl[of "(\<exists>s4. toEnvP s4 \<and>
                   substate s2 s4 \<and>
                   substate s4 s0 \<and>
                   toEnvNum s2 s4 \<le> DELAY'TIMEOUT \<and>
                   (getVarBool s4 rotation = False \<or> getVarBool s4 user) \<and>
                   (\<forall>s3. toEnvP s3 \<and> substate s2 s3 \<and> substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow>
                         getVarBool s3 rotation = True \<and> \<not> getVarBool s3 user))"])
  apply (metis substate.simps(10) substate.simps(2) substate.simps(3) substate.simps(9))
    apply blast
   apply(simp split: if_splits)
  apply(rule cut_rl[of "pred3 s1 s2
 (toEnv (setVarAny s0 user'value pressure'value))
s2"])
   apply(simp only: pred3_def)
   apply (smt (z3) substate_asym)
   apply(rule mp[of "toEnvP s2 \<and>  substate s2 s2 \<and>
 substate s2 (toEnv (setVarAny s0 user'value pressure'value))"])
   apply((rule VC4_R3_ind_proof);blast)
  using substate_refl by fast

theorem proof_3_4: "VC4 inv3 env s0 user_value pressure_value"
  apply(simp only: VC4_def inv3_def R3_def)
  apply(rule impI)
  apply(rule conjI)
  apply(rule conjI)
   apply(simp)
   apply((rule allI);(rule allI))
   apply((rule VC4_R3);blast)


theory ProcLemma
  imports ProcSendCase
begin

    (* ##### 3. process reduction validity for thread case ##### *)

definition dsub_env :: "'a state_env \<Rightarrow> 'b state_env \<Rightarrow> bool" where
  "dsub_env s env = (\<forall> x. env x \<noteq> None \<longrightarrow> s x \<noteq> None)"

lemma id_dsub_env: "dsub_env s s"
  apply (simp add: dsub_env_def)
  done

lemma add_dsub_env: "\<lbrakk> dsub_env s env \<rbrakk> \<Longrightarrow> dsub_env (add_env s x v) env"
  apply (simp add: dsub_env_def)
  apply (simp add: add_env_def)
  done

lemma super_sub_use_env: "\<lbrakk> dsub_env s' s; sub_use_env s r_s \<rbrakk> \<Longrightarrow> sub_use_env s' r_s"
  apply (simp add: dsub_env_def)
  apply (simp add: sub_use_env_def)
  apply (auto)
  done

lemma app_red_exp_dsub_env: "\<lbrakk> app_red_exp are (s1, e1) ax (s2, e2) \<rbrakk> \<Longrightarrow> dsub_env s2 s1"
  apply (case_tac are)
        apply (auto)
        apply (rule_tac id_dsub_env)
       apply (rule_tac id_dsub_env)
      apply (case_tac c)
                  apply (auto)
        apply (rule_tac add_dsub_env)
        apply (rule_tac id_dsub_env)
       apply (rule_tac id_dsub_env)
      apply (rule_tac add_dsub_env)
      apply (rule_tac add_dsub_env)
      apply (rule_tac id_dsub_env)
     apply (rule_tac id_dsub_env)
    apply (rule_tac id_dsub_env)
   apply (rule_tac id_dsub_env)
  apply (case_tac c)
              apply (auto)
    apply (rule_tac id_dsub_env)
   apply (rule_tac add_dsub_env)
   apply (rule_tac id_dsub_env)
  done

    (* MAIN PROCESS REDUCTION LEMMA *)

lemma srps_thread_case: "\<lbrakk>well_typed_system env delta p_map s1 ps1; valid_reduct app_red_exp; r_ax = ThreadAct; ps1 u = Some (app_hole h e1); wf_hole h;
        ps2 = add_env ps1 u (app_hole h e2); app_red_exp are (s1, e1) ax (s2, e2)\<rbrakk>
       \<Longrightarrow> \<exists>r_s g_ax. (\<exists>p_map'. well_typed_system (red_env env g_ax) (red_delta delta g_ax) p_map' s2 (add_env ps1 u (app_hole h e2))) \<and> safe_act s1 r_s g_ax"
    (* prelim: well_formed_delta / mem_val_env *)
  apply (cut_tac delta="delta" in wts_well_formed_delta)
   apply (simp add: well_typed_system_def)
   apply (auto)
  apply (cut_tac env="env" in wts_mem_val_env)
   apply (simp add: well_typed_system_def)
   apply (auto)
    (* case where action is performed on single thread 'u'. *)
  apply (case_tac "\<not> (well_typed_state s1 env delta \<and> well_typed_proc_set env delta p_map ps1 \<and> sub_nres_map s1 p_map)")
   apply (simp add: well_typed_system_def)
  apply (auto)
    (* we start by obtaining the well-typedness and validity for thread 'u' *)
  apply (simp add: well_typed_proc_set_def)
  apply (auto)
  apply (erule_tac x="u" in allE)
  apply (auto)
  apply (case_tac "p_map u")
   apply (auto)
    (* using the gsre lemma, we know that the resulting expression will be well-typed. *)
  apply (cut_tac env="env" and ?r_s1.0="a" and ?e1.0="app_hole h e1" and tau="UnitTy" and ?r_s2.0="r_s2" and rx="rx" and ?s1.0="s1" and
        delta="delta" and ?e2.0="app_hole h e2" and ax="ax" and ?s2.0="s2" and r_f="a" in safe_full_red_exp)
         apply (auto)
    apply (simp add: sub_nres_map_def)
    apply (simp add: nres_lookup_def)
    apply (erule_tac x="u" in allE)
    apply (auto)
   apply (rule_tac id_leq_use_env)
  apply (rule_tac x="a" in exI)
  apply (rule_tac x="g_ax" in exI)
  apply (auto)
  apply (rule_tac x="add_env p_map u (exp_red_use_env a g_ax)" in exI)
    (* prove that the resulting system is well-typed overall *)
  apply (simp add: well_typed_system_def)
    (* prove that the process set in particular remains well-typed *)
  apply (simp add: well_typed_proc_set_def)
  apply (auto)
    (* prove that the new map still covers the state *)(*
       apply (rule_tac add_full_nres_map)
       apply (simp)*)
    (* prove that it is still disjoint *)
     apply (rule_tac disj_add_nres_map)
      apply (simp)
     apply (rule_tac ?s1.0="s1" in red_sep_nres_map)
         apply (auto)
      apply (rule_tac r_x="infl_use_env a r_s2" in leq_safe_act)
       apply (simp)
      apply (rule_tac lhs_infl_leq_use_env)
      apply (rule_tac id_leq_use_env)
     apply (simp add: sub_nres_map_def)
     apply (erule_tac x="u" in allE)
     apply (erule_tac x="u" in allE)
     apply (simp add: nres_lookup_def)
    (* prove that everything is still well-typed. we start with the original expressions from ps1 *)
    apply (case_tac "u \<noteq> ua")
     apply (case_tac "add_env ps1 u (app_hole h e2) ua")
      apply (auto)
     apply (erule_tac x="ua" in allE)
     apply (simp add: add_env_def)
     apply (case_tac "p_map ua")
      apply (auto)
     apply (rule_tac x="rxa" in exI)
     apply (rule_tac x="r_s2a" in exI)
     apply (rule_tac env'="env" in well_typed_contain_env)
      apply (rule_tac s="s1" in red_contain_env)
       apply (simp_all)
      apply (simp add: well_typed_state_def)
     apply (rule_tac s="s1" and r_f="a" in well_typed_red_deltax)
         apply (auto)
      apply (simp add: disj_nres_map_def)
      apply (erule_tac x="u" in allE)
      apply (erule_tac x="ua" in allE)
      apply (auto)
      apply (simp add: nres_lookup_def)
     apply (simp add: well_typed_state_def)
    (* - proving that it's still proper as well *)(*
      apply (rule_tac s="s1" in red_proper_exp)
        apply (auto)
      apply (simp add: well_typed_state_def)*)
    (* - it's true for the modified res map by valid_reduct's def *)
    apply (simp add: add_env_def)
    apply (erule_tac x="u" in allE)
    apply (auto)
    (* prove that each res map in p_map is still contained in s2. this is true for the original
        res maps since s1 <: s2 *)
   apply (simp add: sub_nres_map_def)
   apply (auto)
   apply (case_tac "u \<noteq> x")
    apply (rule_tac s="s1" in super_sub_use_env)
     apply (simp add: nres_lookup_def)
     apply (simp add: add_env_def)
     apply (rule_tac are="are" in app_red_exp_dsub_env)
     apply (auto)
    (* - it's true for the modified res map by valid_exp *)
    apply (simp add: nres_lookup_def)
    apply (simp add: add_env_def)
   apply (simp add: nres_lookup_def)
   apply (simp add: add_env_def)
    (* prove that each res map in p_map is disjoint from the new rs_map. this is true for the original
        res maps by lemma *)(*
   apply (case_tac "u \<noteq> ua")
    apply (simp add: add_env_def)
    apply (auto)
    apply (erule_tac x="ua" in allE)
    apply (erule_tac x="ua" in allE)
    apply (case_tac "p_map ua")
     apply (auto)
    apply (simp add: valid_exp_use_env_def)
     apply (rule_tac p_map="p_map" and u="u" and v="ua" and r_p="aa" and r_s="a" and ?s1.0="s1" in red_sep_nres_map2)
           apply (auto)
      apply (rule_tac r_x="infl_use_env a r_s2" in leq_safe_act)
       apply (simp)
      apply (rule_tac lhs_infl_leq_use_env)
      apply (rule_tac id_leq_use_env)
    (* - it's true for the modified res map by valid_reduct's def *)
   apply (simp add: add_env_def)
   apply (simp add: valid_exp_use_env_def)*)
    (* - action safety *)
  apply (rule_tac r_x="infl_use_env a r_s2" in leq_safe_act)
   apply (simp)
  apply (rule_tac lhs_infl_leq_use_env)
  apply (rule_tac id_leq_use_env)
  done

    (* ##### 4a. fork lemma: proves well-typedness of new thread ##### *)

definition unit_app_abbrev where
  "unit_app_abbrev e = (AppExp e (ConstExp UnitConst))"

    (* this lemma allows us to type the expression passed into a fork so that it can be moved into another thread. since it will be
        stored in another thread, the requirements must be contained by r_s1, yet completely removable from it.
        from the previous lemma, we know that this can be taken from just the non-prim vars in e *)

lemma safe_fork_lam: "\<lbrakk> well_typed env delta r_s1 (app_hole h (AppExp (ConstExp ForkConst) e)) tau r_s2 rx; well_formed_delta env delta; is_value e; is_own r \<rbrakk> \<Longrightarrow>
  well_typed env delta (np_dom_use_env env delta e) (unit_app_abbrev e) UnitTy empty_use_env empty_use_env"
  apply (induct h arbitrary: env r_s1 r_s2 tau rx)
    apply (auto)
  apply (simp add: unit_app_abbrev_def)
    (* base case *)
  apply (cut_tac env="env" and delta="delta" and ?r_s1.0="r_s2a" and e="e" and tau="FunTy UnitTy UnitTy UsePerm a" and ?r_s2.0="r_s3" and rx="rx2" in infl_sexp_wp)
     apply (simp_all)
   apply (rule_tac value_is_sexp)
   apply (auto)
  apply (rule_tac x="UsePerm" in exI)
  apply (rule_tac x="a" in exI)
  apply (rule_tac x="np_dom_use_env env delta e" in exI)
  apply (rule_tac x="np_dom_use_env env delta e" in exI)
  apply (auto)
    (* the idea is that the infl_sexp_wp requirements are strictly greater than np_dom, and since np_dom is strong, there is an exact way of
        subtracting to get to np_dom. (we do cheat a little by lifting rx2). *)
   apply (rule_tac t="np_dom_use_env env delta e" and s="diff_use_env (comp_use_env (lift_use_env rx2 ra) (infl_use_env r_s2a r_s3))
    (diff_use_env (lift_use_env (comp_use_env (lift_use_env rx2 ra) (infl_use_env r_s2a r_s3)) r) (np_dom_use_env env delta e))" in subst)
    apply (rule_tac sfl_diff_use_env)
      apply (simp add: np_dom_use_env_def)
      apply (rule_tac strong_dom_use_env)
     apply (simp add: leq_use_env_def)
     apply (auto)
    (* to prove that the infl_sexp_wp reqs are greater than np_dom, we use the fact that any npv must have a permission *)
    apply (simp add: np_dom_use_env_def)
    apply (simp add: dom_use_env_def)
    apply (auto)
    apply (case_tac "comp_use_env (lift_use_env rx2 ra) (infl_use_env r_s2a r_s3) x \<noteq> OwnPerm")
     apply (case_tac "comp_use_env rx2 (infl_use_env r_s2a r_s3) x = NoPerm")
      apply (cut_tac x="x" and env="env" and e="e" and ?r_s1.0="comp_use_env rx2 (infl_use_env r_s2a r_s3)" in well_typed_no_npv_use)
        apply (auto)
    apply (cut_tac r_sa="lift_use_env rx2 ra" and r_sb="infl_use_env r_s2a r_s3" and x="x" in comp_use_no_own_both)
     apply (auto)
    apply (case_tac "rx2 x \<noteq> NoPerm")
     apply (simp add: is_own_def)
    apply (case_tac "rx2 x")
      apply (auto)
    apply (case_tac "infl_use_env r_s2a r_s3 x \<noteq> NoPerm")
     apply (simp add: infl_use_env_def)
     apply (case_tac "r_s2a x = OwnPerm \<and> r_s3 x = NoPerm")
      apply (auto)
    apply (cut_tac r_sa="rx2" and r_sb="infl_use_env r_s2a r_s3" and x="x" in comp_use_none)
      apply (auto)
    (* with that in mind, we manipulate until we match the infl sexp lemma *)
   apply (rule_tac well_typed_diff_perms)
    apply (rule_tac rx="comp_use_env rx2 (infl_use_env r_s2a r_s3)" in well_typed_incr_req)
      apply (rule_tac r_s="comp_use_env rx2 (infl_use_env r_s2a r_s3)" in well_typed_incr_simul_perm)
       apply (rule_tac dist_comp_leq_use_env)
        apply (rule_tac comp_leq_use_env1)
        apply (rule_tac self_lift_leq_use_env)
       apply (rule_tac self_comp_leq_use_env2)
      apply (simp)
     apply (rule_tac dist_comp_leq_use_env)
      apply (rule_tac comp_leq_use_env1)
      apply (rule_tac self_lift_leq_use_env)
     apply (rule_tac self_comp_leq_use_env2)
    apply (rule_tac id_leq_use_env)
    (* next, we must show that the differential is actually subtractible, which is true since it removes all non-prim vars *)
  apply (auto)
   apply (case_tac "np_dom_use_env env delta e x \<noteq> OwnPerm")
    apply (simp add: np_dom_use_env_def)
    apply (simp add: dom_use_env_def)
   apply (cut_tac r_s="lift_use_env (comp_use_env (lift_use_env rx2 ra) (infl_use_env r_s2a r_s3)) r" and
       r_ex="np_dom_use_env env delta e" and x="x" in diff_use_none_ex)
    apply (simp)
   apply (simp add: own_env_vars_def)
    (* lastly, we prove the various inequalities for application to a unit const *)
  apply (rule_tac x="empty_use_env" in exI)
  apply (rule_tac x="np_dom_use_env env delta e" in exI)
  apply (auto)
    apply (rule_tac id_leq_use_env)
   apply (rule_tac leq_empty_use_env)
  apply (rule_tac x="empty_use_env" in exI)
  apply (auto)
         apply (rule_tac leq_empty_use_env)(*
        apply (simp add: empty_use_env_def)
       apply (simp add: unlim_def)*)
      apply (rule_tac dist_comp_leq_use_env)
       apply (rule_tac id_leq_use_env)
      apply (rule_tac leq_empty_use_env)
     apply (rule_tac disj_empty_use_env1)
    apply (rule_tac leq_empty_use_env)
   apply (rule_tac leq_empty_use_env)
  apply (simp add: app_req_def)
  apply (rule_tac leq_empty_use_env)
  done

    (* ##### 4b. fork lemma: if x is an npv in 'e', then we have ownership permissions for 'h (fork e)' ##### *)

lemma safe_fork_own_npv_use: "\<lbrakk> well_typed env delta r_s1 (app_hole h (AppExp (ConstExp ForkConst) e)) tau r_s2 rx; well_formed_delta env delta;
 is_value e; x \<in> non_prim_vars env delta e \<rbrakk> \<Longrightarrow> r_s1 x = OwnPerm"
  apply (induct h arbitrary: env r_s1 r_s2 tau rx)
        apply (auto)
    (* base case *)
     apply (cut_tac env="env" and ?r_s1.0="r_s2a" and e="e" and ?r_s2.0="r_s3" and rx="rx2" in infl_sexp_wp)
       apply (auto)
      apply (rule_tac value_is_sexp)
      apply (simp)
     apply (case_tac "comp_use_env rx2 (infl_use_env r_s2a r_s3) x = NoPerm")
      apply (cut_tac env="env" and x="x" and e="e" and ?r_s1.0="comp_use_env rx2 (infl_use_env r_s2a r_s3)" in well_typed_no_npv_use)
        apply (auto)
     apply (case_tac "rx2 x \<noteq> NoPerm")
      apply (cut_tac r_x="lift_use_env rx2 r" and r_s="r_s1" and x="x" in leq_use_own)
        apply (simp add: is_own_def)
       apply (rule_tac r_sb="comp_use_env rx1 (lift_use_env rx2 r)" in trans_leq_use_env)
        apply (rule_tac r_sb="r_s3" in trans_leq_use_env)
         apply (rule_tac r_sb="r_s2a" in trans_leq_use_env)
          apply (auto)
       apply (rule_tac well_typed_perm_leq)
       apply (auto)
      apply (rule_tac self_comp_leq_use_env2)
     apply (case_tac "infl_use_env r_s2a r_s3 x \<noteq> NoPerm")
      apply (simp add: infl_use_env_def)
      apply (case_tac "r_s2a x = OwnPerm \<and> r_s3 x = NoPerm")
       apply (auto)
      apply (rule_tac r_x="r_s2a" in leq_use_own)
       apply (auto)
     apply (cut_tac r_sa="rx2" and r_sb="infl_use_env r_s2a r_s3" and x="x" in comp_use_none)
       apply (auto)
    (* rhs induct *)
    apply (rule_tac r_x="r_s2a" in leq_use_own)
     apply (simp)
    apply (rule_tac well_typed_perm_leq)
    apply (auto)
    (* rhs pair *)
    apply (rule_tac r_x="r_s2a" in leq_use_own)
    apply (simp)
   apply (rule_tac well_typed_perm_leq)
   apply (auto)
  done

    (* ##### 4c. fork lemma: proves well-typedness of original thread post-fork ##### *)

    (* this lemma proves that e should be removable from the fork. combined with the previous lemmas, we can also remove the
      permissions of e, and type the two resultant expressions disjointly. *)

lemma safe_fork_exp_ih: "\<lbrakk> well_typed env delta r_s1 (app_hole h (AppExp (ConstExp ForkConst) e)) tau r_s2 rx; well_formed_delta env delta; is_value e \<rbrakk> \<Longrightarrow>
  well_typed env delta r_s1 (app_hole h (ConstExp UnitConst)) tau r_s2 rx"
  apply (induct h arbitrary: env r_s1 e tau r_s2 rx)
        apply (auto)
    (* base case *)
        apply (rule_tac r_sb="diff_use_env r_s3 (comp_use_env (comp_use_env rx1 (lift_use_env rx2 r)) r_ex)" in trans_leq_use_env)
         apply (rule_tac r_sb="r_s2a" in trans_leq_use_env)
          apply (simp)
         apply (rule_tac diff_leq_use_env)
         apply (rule_tac well_typed_perm_leq)
         apply (auto)
    (* lhs induct *)
       apply (rule_tac x="t1" in exI)
       apply (rule_tac x="r" in exI)
       apply (rule_tac x="a" in exI)
       apply (rule_tac x="r_s2a" in exI)
       apply (rule_tac x="rx1" in exI)
       apply (auto)
    (* rhs induct *)
      apply (rule_tac x="t1" in exI)
      apply (rule_tac x="r" in exI)
      apply (rule_tac x="a" in exI)
      apply (rule_tac x="r_s2a" in exI)
      apply (rule_tac x="rx1" in exI)
      apply (auto)
      apply (rule_tac x="rx2" in exI)
      apply (rule_tac x="r_s3" in exI)
      apply (auto)
    (* if case *)
     apply (rule_tac x="rx'" in exI)
     apply (rule_tac x="r_s2a" in exI)
     apply (auto)
    (* lhs pair case *)
    apply (rule_tac x="r_s2a" in exI)
    apply (rule_tac x="r_s3" in exI)
    apply (rule_tac x="rx1" in exI)
    apply (auto)
    (* rhs pair case *)
   apply (rule_tac x="r_s2a" in exI)
   apply (rule_tac x="r_s3" in exI)
   apply (rule_tac x="rx1" in exI)
   apply (auto)
   apply (rule_tac x="rx2" in exI)
   apply (auto)
  done

    (* uses:
        - safe_fork_hole_npv_use: to determine that if x is an np-var, it is not in h
        - 4b (safe_fork_own_npv_use) to determine that if x is an np-var, we own it
    *)

lemma safe_fork_exp: "\<lbrakk> well_typed env delta r_s1 (app_hole h (AppExp (ConstExp ForkConst) e)) tau r_s2 rx;
  well_formed_delta env delta; sub_use_env s r_s1; wf_hole h; is_value e \<rbrakk> \<Longrightarrow>
  well_typed env delta (diff_use_env r_s1 (np_dom_use_env env delta e)) (app_hole h (ConstExp UnitConst)) tau
  (diff_use_env r_s2 (np_dom_use_env env delta e)) (diff_use_env rx (np_dom_use_env env delta e))"
  apply (rule_tac well_typed_diff_perms)
   apply (rule_tac safe_fork_exp_ih)
    apply (auto)
  apply (simp add: non_prim_vars_def)
  apply (auto)
    (* we want to show that if x is in the dominator, it is not an np-var in h.
        > if x is an np-var itself, it cannot be in e by lemma *)
  apply (case_tac "x \<in> non_prim_vars env delta e")
   apply (cut_tac h="h" and x="x" and e="ConstExp UnitConst" in app_hole_res_vars_rev)
    apply (auto)
   apply (cut_tac h="h" and x="x" and env="env" and ?r_s1.0="r_s1" and e="e" in safe_fork_hole_npv_use)
        apply (auto)
  apply (simp add: own_env_vars_def)
  apply (simp add: np_dom_use_env_def)
  apply (simp add: dom_use_env_def)(*
    (* otherwise, x is in the completion. we identify its ancestor z. *)
  apply (case_tac "\<exists>xa. x = Loc xa \<and> (\<exists>l z. Loc z \<in> non_prim_vars env e \<and> path_lookup rs_map z l xa)")
   apply (auto)
    (* we note that z is a np-var of e therefore r_s1 z = Own *)
  apply (cut_tac x="Loc z" and env="env" in safe_fork_own_npv_use)
     apply (auto)
    (* x then is in the lookup map of some parent y. *)
  apply (cut_tac rs_map="rs_map" and z="z" and x="xa" in path_lookup_parent)
     apply (auto)
    (* with that in mind, by separation, x is disjoint from r_s1. *)
  apply (case_tac "r_s1 (Loc xa) \<noteq> NoPerm")
   apply (simp add: valid_exp_use_env_def)
   apply (simp add: sep_nres_map_def)
   apply (auto)
   apply (erule_tac x="y" in allE)
   apply (simp add: nres_lookup_def)
   apply (simp add: strong_disj_use_env_def)
   apply (erule_tac x="Loc xa" in allE)
   apply (auto)
    (* by extension, x is not in 'h (fork e)' *)
  apply (cut_tac env="env" and ?r_s1.0="r_s1" and x="Loc xa" in well_typed_no_npv_use)
    apply (auto)
  apply (simp add: non_prim_vars_def)
    (* the very last part is showing that x not in 'h (fork e)' implies x not in 'h ()'. *)
  apply (cut_tac x="Loc xa" and h="h" and e="ConstExp UnitConst" in app_hole_res_vars_rev)
   apply (auto)
  apply (cut_tac x="Loc xa" and h="h" and e="AppExp (ConstExp ForkConst) e" in app_hole_res_vars2)
   apply (auto)*)
  done

    (* ##### 4d. fork lemma: structural lemma for thread-disjointness in fork case ###### *)

lemma alift_strong_disj_use_env1: "\<lbrakk> strong_disj_use_env r_x r_s \<rbrakk> \<Longrightarrow> strong_disj_use_env (lift_use_env r_x r) r_s"
  apply (simp add: strong_disj_use_env_def)
  apply (auto)
  apply (case_tac r)
    apply (auto)
  done

    (* a special lemma that makes it easier to comprehend our strategy for proving the disjointness of the fork *)
lemma fork_disj_nres_map: "\<lbrakk> disj_nres_map p_map; p_map u = Some r_s; is_own r;
  leq_use_env r_xa (lift_use_env r_s r); leq_use_env r_xb (lift_use_env r_s r);
  strong_disj_use_env r_xa r_xb \<rbrakk> \<Longrightarrow> disj_nres_map (add_env (add_env p_map u r_xa) v r_xb)"
  apply (rule_tac disj_add_nres_map)
   apply (rule_tac disj_add_nres_map)
    apply (simp)
    (* first we must prove the disjointness of the new assignment to u *)
   apply (simp add: sep_nres_map_def)
   apply (auto)
   apply (case_tac "u = x")
    apply (cut_tac rs_map="p_map" and x="u" in nres_rem_same)
    apply (auto)
    apply (rule_tac empty_strong_disj_use_env2)
   apply (cut_tac rs_map="p_map" and x="u" and y="x" in nres_rem_diff)
    apply (auto)
   apply (simp add: disj_nres_map_def)
   apply (erule_tac x="u" in allE)
   apply (erule_tac x="x" in allE)
   apply (auto)
   apply (rule_tac r_s="lift_use_env r_s r" in strong_disj_leq_use_env1)
    apply (rule_tac alift_strong_disj_use_env1)
    apply (simp add: nres_lookup_def)
   apply (simp)
    (* next we prove the disjointness of v, starting with its disjointness to u *)
  apply (simp add: sep_nres_map_def)
  apply (auto)
  apply (case_tac "x = v")
   apply (cut_tac rs_map="add_env p_map u r_xa" and x="v" in nres_rem_same)
   apply (auto)
   apply (rule_tac empty_strong_disj_use_env2)
  apply (case_tac "x = u")
   apply (auto)
   apply (case_tac "\<not> nres_lookup (add_env p_map u r_xa) u = r_xa")
    apply (simp add: nres_lookup_def)
    apply (simp add: add_env_def)
   apply (cut_tac rs_map="add_env p_map u r_xa" and x="v" and y="u" in nres_rem_diff)
    apply (auto)
   apply (rule_tac comm_strong_disj_use_env)
   apply (simp)
    (* next we prove its disjointess to the rest of the map *)
  apply (cut_tac rs_map="add_env p_map u r_xa" and x="v" and y="x" in nres_rem_diff)
   apply (auto)
  apply (cut_tac rs_map="p_map" and x="u" and y="x" and r_s="r_xa" in nres_add_diff)
   apply (auto)
  apply (simp add: disj_nres_map_def)
  apply (erule_tac x="u" in allE)
  apply (erule_tac x="x" in allE)
  apply (auto)
  apply (rule_tac r_s="lift_use_env r_s r" in strong_disj_leq_use_env1)
   apply (rule_tac alift_strong_disj_use_env1)
   apply (simp add: nres_lookup_def)
  apply (simp)
  done

    (* ##### 4_X. process reduction validity for fork case ##### *)

lemma lift_sep_nres_map: "\<lbrakk> sep_nres_map r_s rs_map \<rbrakk> \<Longrightarrow> sep_nres_map (lift_use_env r_s r) rs_map"
  apply (simp add: sep_nres_map_def)
  apply (auto)
  apply (rule_tac alift_strong_disj_use_env1)
  apply (auto)
  done

lemma srps_fork_case: "\<lbrakk>well_typed_system env delta p_map s2 ps1; r_ax = ForkAct; ps1 u = Some (app_hole h (AppExp (ConstExp ForkConst) e));
                wf_hole h; is_value e; ps2 = add_env (add_env ps1 u (app_hole h (ConstExp UnitConst))) v (AppExp e (ConstExp UnitConst)); fresh_var ps1 v;
                s1 = s2\<rbrakk>
               \<Longrightarrow> \<exists>r_s g_ax. (\<exists>p_map'. well_typed_system (red_env env g_ax) (red_delta delta g_ax) p_map' s2
                                     (add_env (add_env ps1 u (app_hole h (ConstExp UnitConst))) v (AppExp e (ConstExp UnitConst)))) \<and>
                          safe_act s2 r_s g_ax"
    (* prelim: well_formed_delta / mem_val_env *)
  apply (cut_tac delta="delta" in wts_well_formed_delta)
   apply (simp add: well_typed_system_def)
   apply (auto)
  apply (cut_tac env="env" in wts_mem_val_env)
   apply (simp add: well_typed_system_def)
   apply (auto)
    (* fork case. no resources are generated in this step *)
  apply (rule_tac x="empty_use_env" in exI)
  apply (rule_tac x="NoResAct" in exI)
  apply (auto)
  apply (simp add: well_typed_system_def)
  apply (auto)
    (* before we can give the new process map types, we have to get the well-typedness statement for h (fork e) *)
  (*apply (case_tac "\<not> (case ps1 u of None \<Rightarrow> True
                     | Some e \<Rightarrow> (case lookup_mem p_map u of None \<Rightarrow> False
                                 | Some (r_c, s') \<Rightarrow> \<exists>rx r_s r_s2. well_typed env r_s e UnitTy r_s2 rx \<and> valid_use_env s2 rs_map r_c r_s))")*)
  apply (case_tac "\<not> (
     disj_nres_map p_map \<and> (\<forall>u. case ps1 u of None \<Rightarrow> True | Some e \<Rightarrow>
      (case p_map u of None \<Rightarrow> False | Some r_s \<Rightarrow> \<exists>rx r_s2. well_typed env delta r_s e UnitTy r_s2 rx)))")
   apply (simp add: well_typed_proc_set_def)
  apply (auto)
  apply (case_tac "\<not> (case ps1 u of None \<Rightarrow> True | Some e \<Rightarrow> (case p_map u of None \<Rightarrow> False | Some r_s \<Rightarrow> \<exists>rx r_s2. well_typed env delta r_s e UnitTy r_s2 rx))")
   apply (erule_tac x="u" in allE)
   apply (auto)
  apply (case_tac "p_map u")
   apply (auto)
    (* using the fork lemmas, we can generate a type for e + a type for h () *)
  apply (cut_tac eq_own)
  apply (auto)
  apply (cut_tac env="env" and e="e" and ?r_s1.0="a" and tau="UnitTy" and h="h" and ?r_s2.0="r_s2" and rx="rx" and r="r" in safe_fork_lam)
     apply (auto)
  apply (cut_tac env="env" and e="e" and ?r_s1.0="a" and tau="UnitTy" and h="h" and ?r_s2.0="r_s2" and rx="rx" and s="s2" in safe_fork_exp)
       apply (auto)
    apply (simp add: well_typed_state_def)
    (* - complete proof that a is still valid *)
   apply (simp add: well_typed_proc_set_def)
   apply (simp add: sub_nres_map_def)
   apply (erule_tac x="u" in allE)
   apply (erule_tac x="u" in allE)
   apply (simp add: nres_lookup_def)
    (* - prelim: prove that (full_dom_use_env env rs_map e) \<le> a (old complete map) *)(*
  apply (cut_tac rs_map="rs_map" and e="e" and r_c="a" and h="h" and env="env" in valid_full_dom_leq_use_env)
      apply (auto)
   apply (simp add: well_typed_state_def)*)
    (* - prelim: np_dom_use_env env e \<le> lift_use_env a r *)
  apply (cut_tac r_sc="np_dom_use_env env delta e" and r_sb="np_dom_use_env env delta (app_hole h (AppExp (ConstExp ForkConst) e))"
      and r_sa="lift_use_env a r" in trans_leq_use_env)
    apply (rule_tac wt_np_leq_use_env)
     apply (auto)
   apply (simp add: np_dom_use_env_def)
   apply (rule_tac dist_dom_leq_use_env)
   apply (auto)
   apply (simp add: non_prim_vars_def)
   apply (cut_tac x="x" and e="AppExp (ConstExp ForkConst) e" in app_hole_res_vars)
    apply (auto)
    (* we fill in the  new process map, by taking perms from 'u' [[ h () ]] and giving them to 'v' [[ e () ]] *)
  apply (rule_tac x="add_env (add_env p_map u (diff_use_env a (np_dom_use_env env delta e))) v (np_dom_use_env env delta e)" in exI)
  apply (simp add: well_typed_proc_set_def)
  apply (auto)
    (* completeness of the new process map *)(*
      apply (rule_tac add_full_nres_map)
      apply (rule_tac add_full_nres_map)
      apply (simp)*)
    (* disjointness of the new process map *)
     apply (rule_tac r_s="a" and r="r" in fork_disj_nres_map)
          apply (auto)
      apply (rule_tac lift_leq_use_env)
      apply (rule_tac self_diff_leq_use_env)
     apply (rule_tac r_s="np_dom_use_env env delta e" in strong_disj_leq_use_env2)
      apply (rule_tac reduce_strong_disj_use_env)
       apply (simp add: disj_use_env_def)
       apply (auto)
        apply (rule_tac r_s="a" in mini_disj_strong_use_env)
         apply (rule_tac id_leq_use_env)
        apply (simp add: np_dom_use_env_def)
        apply (rule_tac strong_dom_use_env)
       apply (rule_tac mini_disj_diff_use_env)
      apply (simp add: np_dom_use_env_def)
      apply (rule_tac strong_dom_use_env)
     apply (rule_tac id_leq_use_env)
    (* proving everything is still well-typed. we start with ua = v, ie the 'e ()' thread. *)
    apply (case_tac "ua = v")
     apply (case_tac "\<not> add_env (add_env ps1 u (app_hole h (ConstExp UnitConst))) v (AppExp e (ConstExp UnitConst)) ua =
      Some (unit_app_abbrev e)")
      apply (simp add: add_env_def)
      apply (simp add: unit_app_abbrev_def)
     apply (auto)
     apply (case_tac "\<not> (add_env (add_env p_map u (diff_use_env a (np_dom_use_env env delta e))) v (np_dom_use_env env delta e)) v =
      Some (np_dom_use_env env delta e)")
      apply (simp add: add_env_def)
     apply (auto)
    (* - properness *)(*
     apply (cut_tac rs_map="rs_map" and h="h" and e="AppExp (ConstExp ForkConst) e" in proper_app_hole_split2)
      apply (simp)
     apply (simp add: unit_app_abbrev_def)
     apply (simp add: proper_exp_def)*)
    (* - well-typedness for ua = u, the 'h ()' thread*)
    apply (case_tac "ua = u")
     apply (case_tac "\<not> add_env (add_env ps1 u (app_hole h (ConstExp UnitConst))) v (AppExp e (ConstExp UnitConst)) ua =
        Some (app_hole h (ConstExp UnitConst))")
      apply (simp add: add_env_def)
     apply (auto)
     apply (case_tac "\<not> (add_env (add_env p_map u (diff_use_env a (np_dom_use_env env delta e))) v (np_dom_use_env env delta e)) u =
        Some (diff_use_env a (np_dom_use_env env delta e))")
      apply (simp add: add_env_def)
     apply (auto)
    (* - properness *)(*
     apply (cut_tac rs_map="rs_map" and h="h" in proper_app_hole_split1)
      apply (simp)
     apply (rule_tac proper_app_hole_recon)
      apply (simp)
     apply (simp add: proper_exp_def)*)
    (* - well-typedness for unaltered threads *)
    apply (erule_tac x="ua" in allE)
    apply (case_tac "\<not> add_env (add_env ps1 u (app_hole h (ConstExp UnitConst))) v (AppExp e (ConstExp UnitConst)) ua = ps1 ua")
     apply (simp add: add_env_def)
    apply (case_tac "ps1 ua")
     apply (auto)
    apply (case_tac "\<not> (add_env (add_env p_map u (diff_use_env a (np_dom_use_env env delta e))) v (np_dom_use_env env delta e)) ua =
      p_map ua")
     apply (simp add: add_env_def)
    apply (auto)(*
    apply (erule_tac x="ua" in allE)
    apply (auto)*)
    (* proving the new process map is contained in the state *)
   apply (rule_tac add_sub_nres_map1)
    apply (rule_tac add_sub_nres_map1)
     apply (simp)
    apply (rule_tac r_s="a" in trans_sub_use_env)
     apply (simp add: sub_nres_map_def)
     apply (erule_tac x="u" in allE)
     apply (erule_tac x="u" in allE)
     apply (simp add: nres_lookup_def)
    apply (rule_tac self_diff_leq_use_env)
   apply (rule_tac r_s="lift_use_env a r" in trans_sub_use_env)
    apply (rule_tac lift_sub_use_env)
    apply (simp add: sub_nres_map_def)
    apply (erule_tac x="u" in allE)
    apply (erule_tac x="u" in allE)
    apply (simp add: nres_lookup_def)
   apply (simp)
    (* proving that separation still holds. we again start with ua = v, the 'e ()' thread *)(*
  apply (case_tac "ua = v")
   apply (simp add: add_env_def)
   apply (rule_tac r_s="lift_use_env a r" in leq_sep_nres_map)
    apply (simp)
   apply (rule_tac lift_sep_nres_map)
   apply (erule_tac x="u" in allE)
   apply (simp)
    (* - same for ua = u, ie the 'h ()' thread *)
  apply (case_tac "ua = u")
   apply (simp add: add_env_def)
   apply (rule_tac r_s="a" in leq_sep_nres_map)
    apply (rule_tac self_diff_leq_use_env)
   apply (erule_tac x="u" in allE)
   apply (simp)
    (* - lastly prove separation for original threads *)
  apply (simp add: add_env_def)*)
  done

    (* ##### 5. final proof composition ##### *)

lemma safe_red_proc_set: "\<lbrakk> well_typed_system env delta p_map s1 ps1; red_proc_set (s1, ps1) r_ax (s2, ps2); valid_reduct app_red_exp \<rbrakk> \<Longrightarrow>
  (\<exists> r_s g_ax p_map'. well_typed_system (red_env env g_ax) (red_delta delta g_ax) p_map' s2 ps2 \<and> safe_act s1 r_s g_ax)"
    (* split over process reduction type. *)
  apply (case_tac "r_ax")
    apply (auto)
    (* single thread action case. *)
    apply (rule_tac srps_thread_case)
          apply (auto)
    (* fork case. *)
   apply (rule_tac srps_fork_case)
          apply (auto)
    (* send case. *)
  apply (rule_tac srps_send_case)
                apply (auto)
done

end


theory Refine_C_AC
imports
  "../lib/ComCorres"
  "../AutoCorres/Impl"
begin

lemma refines: "C_minimal \<sqsubseteq> AC_minimal"
proof -
  let ?m\<^sub>A = "minimalAC" and ?m\<^sub>C = "Call minimal_'proc"
    and ?\<Gamma> = "minimal_global_addresses.\<Gamma>" and ?P = "(\<lambda>s. True)"
    and ?st = "minimal.lift_global_heap \<circ> globals"
    and ?rx = "sint \<circ> ret__int_'"
  have "Run AC_minimal = lift_nd ?m\<^sub>A" unfolding AC_minimal_def by simp
  moreover have "Run C_minimal = lift_com ?m\<^sub>C ?\<Gamma>" unfolding C_minimal_def by simp
  moreover have "\<forall>s s\<^sub>C. s\<^sub>C \<in> Init C_minimal s \<longrightarrow>
       ?P s\<^sub>C \<and> \<not> snd (minimal.minimal' (?st s\<^sub>C)) \<and> ?st s\<^sub>C \<in> Init AC_minimal s"
    unfolding C_minimal_def AC_minimal_def minimal.minimal'_def
    by (simp add: snd_return)
  moreover have "ac_corres ?st ?\<Gamma> ?rx ?P ?m\<^sub>A ?m\<^sub>C" using minimal.minimal'_ac_corres .
  moreover have "\<forall>s\<^sub>C'. Fin AC_minimal (?st s\<^sub>C') = Fin C_minimal s\<^sub>C'"
    unfolding AC_minimal_def C_minimal_def by simp
  ultimately show ?thesis by (metis corres_refines snd_liftE)
qed

end


(*  Title:       Aodv_Loop_Freedom.thy
    License:     BSD 2-Clause. See LICENSE.
    Author:      Timothy Bourke, Inria
*)

section "Lift and transfer invariants to show loop freedom"

theory Aodv_Loop_Freedom
imports AWN.OClosed_Transfer AWN.Qmsg_Lifting Global_Invariants Loop_Freedom
begin

subsection \<open>Lift to parallel processes with queues\<close>

lemma par_step_no_change_on_send_or_receive:
    fixes \<sigma> s a \<sigma>' s'
  assumes "((\<sigma>, s), a, (\<sigma>', s')) \<in> oparp_sos i (oseqp_sos \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V i) (seqp_sos \<Gamma>\<^sub>Q\<^sub>M\<^sub>S\<^sub>G)"
      and "a \<noteq> \<tau>"
    shows "\<sigma>' i = \<sigma> i"
  using assms by (rule qmsg_no_change_on_send_or_receive)

lemma par_nhop_quality_increases:
  shows "opaodv i \<langle>\<langle>\<^bsub>i\<^esub> qmsg \<Turnstile> (otherwith ((=)) {i} (orecvmsg (\<lambda>\<sigma> m.
                                    msg_fresh \<sigma> m \<and> msg_zhops m)),
                                  other quality_increases {i} \<rightarrow>)
                        global (\<lambda>\<sigma>. \<forall>dip. let nhip = the (nhop (rt (\<sigma> i)) dip)
                                          in dip \<in> vD (rt (\<sigma> i)) \<inter> vD (rt (\<sigma> nhip)) \<and> nhip \<noteq> dip
                                             \<longrightarrow> (rt (\<sigma> i)) \<sqsubset>\<^bsub>dip\<^esub> (rt (\<sigma> nhip)))"
    proof (rule lift_into_qmsg [OF seq_nhop_quality_increases])
    show "opaodv i \<Turnstile>\<^sub>A (otherwith ((=)) {i}
                         (orecvmsg (\<lambda>\<sigma> m. msg_fresh \<sigma> m \<and> msg_zhops m)),
                        other quality_increases {i} \<rightarrow>)
                       globala (\<lambda>(\<sigma>, _, \<sigma>'). quality_increases (\<sigma> i) (\<sigma>' i))"
    proof (rule ostep_invariant_weakenE [OF oquality_increases], simp_all)
      fix t :: "(((nat \<Rightarrow> state) \<times> (state, msg, pseqp, pseqp label) seqp), msg seq_action) transition"
      assume "onll \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V (\<lambda>((\<sigma>, _), _, (\<sigma>', _)). \<forall>j. quality_increases (\<sigma> j) (\<sigma>' j)) t"
      thus "quality_increases (fst (fst t) i) (fst (snd (snd t)) i)"
        by (cases t) (clarsimp dest!: onllD, metis aodv_ex_label)
    next
      fix \<sigma> \<sigma>' a
      assume "otherwith ((=)) {i}
                (orecvmsg (\<lambda>\<sigma> m. msg_fresh \<sigma> m \<and> msg_zhops m)) \<sigma> \<sigma>' a"
      thus "otherwith quality_increases {i} (orecvmsg (\<lambda>_. rreq_rrep_sn)) \<sigma> \<sigma>' a"
        by - (erule weaken_otherwith, auto)
    qed
  qed auto

lemma par_rreq_rrep_sn_quality_increases:
  "opaodv i \<langle>\<langle>\<^bsub>i\<^esub> qmsg \<Turnstile>\<^sub>A (\<lambda>\<sigma> _. orecvmsg (\<lambda>_. rreq_rrep_sn) \<sigma>, other (\<lambda>_ _. True) {i} \<rightarrow>)
                            globala (\<lambda>(\<sigma>, _, \<sigma>'). quality_increases (\<sigma> i) (\<sigma>' i))"
  proof -
    have "opaodv i \<Turnstile>\<^sub>A (\<lambda>\<sigma> _. orecvmsg (\<lambda>_. rreq_rrep_sn) \<sigma>, other (\<lambda>_ _. True) {i} \<rightarrow>)
                globala (\<lambda>(\<sigma>, _, \<sigma>'). quality_increases (\<sigma> i) (\<sigma>' i))"
      by (rule ostep_invariant_weakenE [OF olocal_quality_increases])
         (auto dest!: onllD seqllD elim!: aodv_ex_labelE)
    hence "opaodv i \<langle>\<langle>\<^bsub>i\<^esub> qmsg \<Turnstile>\<^sub>A (\<lambda>\<sigma> _. orecvmsg (\<lambda>_. rreq_rrep_sn) \<sigma>, other (\<lambda>_ _. True) {i} \<rightarrow>)
                                   globala (\<lambda>(\<sigma>, _, \<sigma>'). quality_increases (\<sigma> i) (\<sigma>' i))"
      by (rule lift_step_into_qmsg_statelessassm) simp_all
    thus ?thesis by rule auto
  qed

lemma par_rreq_rrep_nsqn_fresh_any_step:
  shows "opaodv i \<langle>\<langle>\<^bsub>i\<^esub> qmsg \<Turnstile>\<^sub>A (\<lambda>\<sigma> _. orecvmsg (\<lambda>_. rreq_rrep_sn) \<sigma>,
                                   other (\<lambda>_ _. True) {i} \<rightarrow>)
                                  globala (\<lambda>(\<sigma>, a, \<sigma>'). anycast (msg_fresh \<sigma>) a)"
  proof -
    have "opaodv i \<Turnstile>\<^sub>A (\<lambda>\<sigma> _. (orecvmsg (\<lambda>_. rreq_rrep_sn)) \<sigma>, other (\<lambda>_ _. True) {i} \<rightarrow>)
                       globala (\<lambda>(\<sigma>, a, \<sigma>'). anycast (msg_fresh \<sigma>) a)"
    proof (rule ostep_invariant_weakenE [OF rreq_rrep_nsqn_fresh_any_step_invariant])
      fix t
      assume "onll \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V (\<lambda>((\<sigma>, _), a, _). anycast (msg_fresh \<sigma>) a) t"
      thus "globala (\<lambda>(\<sigma>, a, \<sigma>'). anycast (msg_fresh \<sigma>) a) t"
        by (cases t) (clarsimp dest!: onllD, metis aodv_ex_label)
    qed auto
    hence "opaodv i \<langle>\<langle>\<^bsub>i\<^esub> qmsg \<Turnstile>\<^sub>A (\<lambda>\<sigma> _. (orecvmsg (\<lambda>_. rreq_rrep_sn)) \<sigma>, other (\<lambda>_ _. True) {i} \<rightarrow>)
                                    globala (\<lambda>(\<sigma>, a, \<sigma>'). anycast (msg_fresh \<sigma>) a)"
      by (rule lift_step_into_qmsg_statelessassm) simp_all
    thus ?thesis by rule auto
  qed

lemma par_anycast_msg_zhops:
  shows "opaodv i \<langle>\<langle>\<^bsub>i\<^esub> qmsg \<Turnstile>\<^sub>A (\<lambda>\<sigma> _. orecvmsg (\<lambda>_. rreq_rrep_sn) \<sigma>, other (\<lambda>_ _. True) {i} \<rightarrow>)
                                  globala (\<lambda>(_, a, _). anycast msg_zhops a)"
  proof -
    from anycast_msg_zhops initiali_aodv oaodv_trans aodv_trans
      have "opaodv i \<Turnstile>\<^sub>A (act TT, other (\<lambda>_ _. True) {i} \<rightarrow>)
                         seqll i (onll \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V (\<lambda>(_, a, _). anycast msg_zhops a))"
        by (rule open_seq_step_invariant)
    hence "opaodv i \<Turnstile>\<^sub>A (\<lambda>\<sigma> _. orecvmsg (\<lambda>_. rreq_rrep_sn) \<sigma>, other (\<lambda>_ _. True) {i} \<rightarrow>)
                            globala (\<lambda>(_, a, _). anycast msg_zhops a)"
    proof (rule ostep_invariant_weakenE)
      fix t :: "(((nat \<Rightarrow> state) \<times> (state, msg, pseqp, pseqp label) seqp), msg seq_action) transition"
      assume "seqll i (onll \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V (\<lambda>(_, a, _). anycast msg_zhops a)) t"
      thus "globala (\<lambda>(_, a, _). anycast msg_zhops a) t"
        by (cases t) (clarsimp dest!: seqllD onllD, metis aodv_ex_label)
    qed simp_all
    hence "opaodv i \<langle>\<langle>\<^bsub>i\<^esub> qmsg \<Turnstile>\<^sub>A (\<lambda>\<sigma> _. orecvmsg (\<lambda>_. rreq_rrep_sn) \<sigma>, other (\<lambda>_ _. True) {i} \<rightarrow>)
                                     globala (\<lambda>(_, a, _). anycast msg_zhops a)"
      by (rule lift_step_into_qmsg_statelessassm) simp_all
    thus ?thesis by rule auto
  qed

subsection \<open>Lift to nodes\<close>

lemma node_step_no_change_on_send_or_receive:
  assumes "((\<sigma>, NodeS i P R), a, (\<sigma>', NodeS i' P' R')) \<in> onode_sos
                                      (oparp_sos i (oseqp_sos \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V i) (seqp_sos \<Gamma>\<^sub>Q\<^sub>M\<^sub>S\<^sub>G))"
      and "a \<noteq> \<tau>"
    shows "\<sigma>' i = \<sigma> i"
  using assms
  by (cases a) (auto elim!: par_step_no_change_on_send_or_receive)

lemma node_nhop_quality_increases:
  shows "\<langle> i : opaodv i \<langle>\<langle>\<^bsub>i\<^esub> qmsg : R \<rangle>\<^sub>o \<Turnstile>
           (otherwith ((=)) {i}
              (oarrivemsg (\<lambda>\<sigma> m. msg_fresh \<sigma> m \<and> msg_zhops m)),
              other quality_increases {i}
            \<rightarrow>) global (\<lambda>\<sigma>. \<forall>dip. let nhip = the (nhop (rt (\<sigma> i)) dip)
                                  in dip \<in> vD (rt (\<sigma> i)) \<inter> vD (rt (\<sigma> nhip)) \<and> nhip \<noteq> dip
                                     \<longrightarrow> (rt (\<sigma> i)) \<sqsubset>\<^bsub>dip\<^esub> (rt (\<sigma> nhip)))"
  by (rule node_lift [OF par_nhop_quality_increases]) auto

lemma node_quality_increases:
  "\<langle> i : opaodv i \<langle>\<langle>\<^bsub>i\<^esub> qmsg : R \<rangle>\<^sub>o \<Turnstile>\<^sub>A (\<lambda>\<sigma> _. oarrivemsg (\<lambda>_. rreq_rrep_sn) \<sigma>,
                                         other (\<lambda>_ _. True) {i} \<rightarrow>)
                            globala (\<lambda>(\<sigma>, _, \<sigma>'). quality_increases (\<sigma> i) (\<sigma>' i))"
  by (rule node_lift_step_statelessassm [OF par_rreq_rrep_sn_quality_increases]) simp

lemma node_rreq_rrep_nsqn_fresh_any_step:
  shows "\<langle> i : opaodv i \<langle>\<langle>\<^bsub>i\<^esub> qmsg : R \<rangle>\<^sub>o \<Turnstile>\<^sub>A
          (\<lambda>\<sigma> _. oarrivemsg (\<lambda>_. rreq_rrep_sn) \<sigma>, other (\<lambda>_ _. True) {i} \<rightarrow>)
          globala (\<lambda>(\<sigma>, a, \<sigma>'). castmsg (msg_fresh \<sigma>) a)"
  by (rule node_lift_anycast_statelessassm [OF par_rreq_rrep_nsqn_fresh_any_step])

lemma node_anycast_msg_zhops:
  shows "\<langle> i : opaodv i \<langle>\<langle>\<^bsub>i\<^esub> qmsg : R \<rangle>\<^sub>o \<Turnstile>\<^sub>A
          (\<lambda>\<sigma> _. oarrivemsg (\<lambda>_. rreq_rrep_sn) \<sigma>, other (\<lambda>_ _. True) {i} \<rightarrow>)
          globala (\<lambda>(_, a, _). castmsg msg_zhops a)"
  by (rule node_lift_anycast_statelessassm [OF par_anycast_msg_zhops])

lemma node_silent_change_only:
  shows "\<langle> i : opaodv i \<langle>\<langle>\<^bsub>i\<^esub> qmsg : R\<^sub>i \<rangle>\<^sub>o \<Turnstile>\<^sub>A (\<lambda>\<sigma> _. oarrivemsg (\<lambda>_ _. True) \<sigma>,
                                               other (\<lambda>_ _. True) {i} \<rightarrow>)
          globala (\<lambda>(\<sigma>, a, \<sigma>'). a \<noteq> \<tau> \<longrightarrow> \<sigma>' i = \<sigma> i)"
  proof (rule ostep_invariantI, simp (no_asm), rule impI)
    fix \<sigma> \<zeta> a \<sigma>' \<zeta>'
    assume or: "(\<sigma>, \<zeta>) \<in> oreachable (\<langle>i : opaodv i \<langle>\<langle>\<^bsub>i\<^esub> qmsg : R\<^sub>i\<rangle>\<^sub>o)
                                    (\<lambda>\<sigma> _. oarrivemsg (\<lambda>_ _. True) \<sigma>)
                                    (other (\<lambda>_ _. True) {i})"
      and tr: "((\<sigma>, \<zeta>), a, (\<sigma>', \<zeta>')) \<in> trans (\<langle>i : opaodv i \<langle>\<langle>\<^bsub>i\<^esub> qmsg : R\<^sub>i\<rangle>\<^sub>o)"
      and "a \<noteq> \<tau>\<^sub>n"
    from or obtain p R where "\<zeta> = NodeS i p R"
      by - (drule node_net_state, metis)
    with tr have "((\<sigma>, NodeS i p R), a, (\<sigma>', \<zeta>'))
                     \<in> onode_sos (oparp_sos i (trans (opaodv i)) (trans qmsg))"
      by simp
    thus "\<sigma>' i = \<sigma> i" using \<open>a \<noteq> \<tau>\<^sub>n\<close>
      by (cases rule: onode_sos.cases)
         (auto elim: qmsg_no_change_on_send_or_receive)
  qed

subsection \<open>Lift to partial networks\<close>

lemma arrive_rreq_rrep_nsqn_fresh_inc_sn [simp]:
  assumes "oarrivemsg (\<lambda>\<sigma> m. msg_fresh \<sigma> m \<and> P \<sigma> m) \<sigma> m"
    shows "oarrivemsg (\<lambda>_. rreq_rrep_sn) \<sigma> m"
  using assms by (cases m) auto

lemma opnet_nhop_quality_increases:
  shows "opnet (\<lambda>i. opaodv i \<langle>\<langle>\<^bsub>i\<^esub> qmsg) p \<Turnstile>
           (otherwith ((=)) (net_tree_ips p)
              (oarrivemsg (\<lambda>\<sigma> m. msg_fresh \<sigma> m \<and> msg_zhops m)),
               other quality_increases (net_tree_ips p) \<rightarrow>)
              global (\<lambda>\<sigma>. \<forall>i\<in>net_tree_ips p. \<forall>dip.
                          let nhip = the (nhop (rt (\<sigma> i)) dip)
                          in dip \<in> vD (rt (\<sigma> i)) \<inter> vD (rt (\<sigma> nhip)) \<and> nhip \<noteq> dip
                             \<longrightarrow> (rt (\<sigma> i)) \<sqsubset>\<^bsub>dip\<^esub> (rt (\<sigma> nhip)))"
  proof (rule pnet_lift [OF node_nhop_quality_increases])
    fix i R
    have "\<langle>i : opaodv i \<langle>\<langle>\<^bsub>i\<^esub> qmsg : R\<rangle>\<^sub>o \<Turnstile>\<^sub>A (\<lambda>\<sigma> _. oarrivemsg (\<lambda>_. rreq_rrep_sn) \<sigma>,
                                              other (\<lambda>_ _. True) {i} \<rightarrow>) globala (\<lambda>(\<sigma>, a, \<sigma>').
            castmsg (\<lambda>m. msg_fresh \<sigma> m \<and> msg_zhops m) a)"
    proof (rule ostep_invariantI, simp (no_asm))
      fix \<sigma> s a \<sigma>' s'
      assume or: "(\<sigma>, s) \<in> oreachable (\<langle>i : opaodv i \<langle>\<langle>\<^bsub>i\<^esub> qmsg : R\<rangle>\<^sub>o)
                                      (\<lambda>\<sigma> _. oarrivemsg (\<lambda>_. rreq_rrep_sn) \<sigma>)
                                      (other (\<lambda>_ _. True) {i})"
         and tr: "((\<sigma>, s), a, (\<sigma>', s')) \<in> trans (\<langle>i : opaodv i \<langle>\<langle>\<^bsub>i\<^esub> qmsg : R\<rangle>\<^sub>o)"
         and am: "oarrivemsg (\<lambda>_. rreq_rrep_sn) \<sigma> a"
      from or tr am have "castmsg (msg_fresh \<sigma>) a"
        by (auto dest!: ostep_invariantD [OF node_rreq_rrep_nsqn_fresh_any_step])
      moreover from or tr am have "castmsg (msg_zhops) a"
        by (auto dest!: ostep_invariantD [OF node_anycast_msg_zhops])
      ultimately show "castmsg (\<lambda>m. msg_fresh \<sigma> m \<and> msg_zhops m) a"
        by (case_tac a) auto
    qed
    thus "\<langle>i : opaodv i \<langle>\<langle>\<^bsub>i\<^esub> qmsg : R\<rangle>\<^sub>o \<Turnstile>\<^sub>A
            (\<lambda>\<sigma> _. oarrivemsg (\<lambda>\<sigma> m. msg_fresh \<sigma> m \<and> msg_zhops m) \<sigma>,
             other quality_increases {i} \<rightarrow>) globala (\<lambda>(\<sigma>, a, _).
               castmsg (\<lambda>m. msg_fresh \<sigma> m \<and> msg_zhops m) a)"
      by rule auto
  next
    fix i R
    show "\<langle>i : opaodv i \<langle>\<langle>\<^bsub>i\<^esub> qmsg : R\<rangle>\<^sub>o \<Turnstile>\<^sub>A
            (\<lambda>\<sigma> _. oarrivemsg (\<lambda>\<sigma> m. msg_fresh \<sigma> m \<and> msg_zhops m) \<sigma>,
             other quality_increases {i} \<rightarrow>) globala (\<lambda>(\<sigma>, a, \<sigma>').
               a \<noteq> \<tau> \<and> (\<forall>d. a \<noteq> i:deliver(d)) \<longrightarrow> \<sigma> i = \<sigma>' i)"
      by (rule ostep_invariant_weakenE [OF node_silent_change_only]) auto
  next
    fix i R
    show "\<langle>i : opaodv i \<langle>\<langle>\<^bsub>i\<^esub> qmsg : R\<rangle>\<^sub>o \<Turnstile>\<^sub>A
            (\<lambda>\<sigma> _. oarrivemsg (\<lambda>\<sigma> m. msg_fresh \<sigma> m \<and> msg_zhops m) \<sigma>,
             other quality_increases {i} \<rightarrow>) globala (\<lambda>(\<sigma>, a, \<sigma>').
               a = \<tau> \<or> (\<exists>d. a = i:deliver(d)) \<longrightarrow> quality_increases (\<sigma> i) (\<sigma>' i))"
      by (rule ostep_invariant_weakenE [OF node_quality_increases]) auto
  qed simp_all

subsection \<open>Lift to closed networks\<close>

lemma onet_nhop_quality_increases:
  shows "oclosed (opnet (\<lambda>i. opaodv i \<langle>\<langle>\<^bsub>i\<^esub> qmsg) p)
           \<Turnstile> (\<lambda>_ _ _. True, other quality_increases (net_tree_ips p) \<rightarrow>)
              global (\<lambda>\<sigma>. \<forall>i\<in>net_tree_ips p. \<forall>dip.
                          let nhip = the (nhop (rt (\<sigma> i)) dip)
                          in dip \<in> vD (rt (\<sigma> i)) \<inter> vD (rt (\<sigma> nhip)) \<and> nhip \<noteq> dip
                             \<longrightarrow> (rt (\<sigma> i)) \<sqsubset>\<^bsub>dip\<^esub> (rt (\<sigma> nhip)))"
  (is "_ \<Turnstile> (_, ?U \<rightarrow>) ?inv")
  proof (rule inclosed_closed)
    from opnet_nhop_quality_increases
      show "opnet (\<lambda>i. opaodv i \<langle>\<langle>\<^bsub>i\<^esub> qmsg) p
               \<Turnstile> (otherwith ((=)) (net_tree_ips p) inoclosed, ?U \<rightarrow>) ?inv"
    proof (rule oinvariant_weakenE)
      fix \<sigma> \<sigma>' :: "ip \<Rightarrow> state" and a :: "msg node_action"
      assume "otherwith ((=)) (net_tree_ips p) inoclosed \<sigma> \<sigma>' a"
      thus "otherwith ((=)) (net_tree_ips p)
              (oarrivemsg (\<lambda>\<sigma> m. msg_fresh \<sigma> m \<and> msg_zhops m)) \<sigma> \<sigma>' a"
      proof (rule otherwithEI)
        fix \<sigma> :: "ip \<Rightarrow> state" and a :: "msg node_action"
        assume "inoclosed \<sigma> a"
        thus "oarrivemsg (\<lambda>\<sigma> m. msg_fresh \<sigma> m \<and> msg_zhops m) \<sigma> a"
        proof (cases a)
          fix ii ni ms
          assume "a = ii\<not>ni:arrive(ms)"
          moreover with \<open>inoclosed \<sigma> a\<close> obtain d di where "ms = newpkt(d, di)"
            by (cases ms) auto
          ultimately show ?thesis by simp
        qed simp_all
      qed
    qed
  qed

subsection \<open>Transfer into the standard model\<close>

interpretation aodv_openproc: openproc paodv opaodv id
  rewrites "aodv_openproc.initmissing = initmissing"
  proof -
    show "openproc paodv opaodv id"
    proof unfold_locales
      fix i :: ip
      have "{(\<sigma>, \<zeta>). (\<sigma> i, \<zeta>) \<in> \<sigma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V i \<and> (\<forall>j. j \<noteq> i \<longrightarrow> \<sigma> j \<in> fst ` \<sigma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V j)} \<subseteq> \<sigma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V'"
        unfolding \<sigma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V_def \<sigma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V'_def
        proof (rule equalityD1)
          show "\<And>f p. {(\<sigma>, \<zeta>). (\<sigma> i, \<zeta>) \<in> {(f i, p)} \<and> (\<forall>j. j \<noteq> i
                      \<longrightarrow> \<sigma> j \<in> fst ` {(f j, p)})} = {(f, p)}"
            by (rule set_eqI) auto
        qed
      thus "{ (\<sigma>, \<zeta>) |\<sigma> \<zeta> s. s \<in> init (paodv i)
                             \<and> (\<sigma> i, \<zeta>) = id s
                             \<and> (\<forall>j. j\<noteq>i \<longrightarrow> \<sigma> j \<in> (fst o id) ` init (paodv j)) } \<subseteq> init (opaodv i)"
        by simp
    next
      show "\<forall>j. init (paodv j) \<noteq> {}"
        unfolding \<sigma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V_def by simp
    next
      fix i s a s' \<sigma> \<sigma>'
      assume "\<sigma> i = fst (id s)"
         and "\<sigma>' i = fst (id s')"
         and "(s, a, s') \<in> trans (paodv i)"
      then obtain q q' where "s = (\<sigma> i, q)"
                         and "s' = (\<sigma>' i, q')"
                         and "((\<sigma> i, q), a, (\<sigma>' i, q')) \<in> trans (paodv i)"
         by (cases s, cases s') auto
      from this(3) have "((\<sigma>, q), a, (\<sigma>', q')) \<in> trans (opaodv i)"
        by simp (rule open_seqp_action [OF aodv_wf])

      with \<open>s = (\<sigma> i, q)\<close> and \<open>s' = (\<sigma>' i, q')\<close>
        show "((\<sigma>, snd (id s)), a, (\<sigma>', snd (id s'))) \<in> trans (opaodv i)"
          by simp
    qed
    then interpret opn: openproc paodv opaodv id .
    have [simp]: "\<And>i. (SOME x. x \<in> (fst o id) ` init (paodv i)) = aodv_init i"
      unfolding \<sigma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V_def by simp
    hence "\<And>i. openproc.initmissing paodv id i = initmissing i"
      unfolding opn.initmissing_def opn.someinit_def initmissing_def
      by (auto split: option.split)
    thus "openproc.initmissing paodv id = initmissing" ..
  qed

interpretation aodv_openproc_par_qmsg: openproc_parq paodv opaodv id qmsg
  rewrites "aodv_openproc_par_qmsg.netglobal = netglobal"
    and "aodv_openproc_par_qmsg.initmissing = initmissing"
  proof -
    show "openproc_parq paodv opaodv id qmsg"
      by (unfold_locales) simp
    then interpret opq: openproc_parq paodv opaodv id qmsg .

    have im: "\<And>\<sigma>. openproc.initmissing (\<lambda>i. paodv i \<langle>\<langle> qmsg) (\<lambda>(p, q). (fst (id p), snd (id p), q)) \<sigma>
                                                                                = initmissing \<sigma>"
      unfolding opq.initmissing_def opq.someinit_def initmissing_def
      unfolding \<sigma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V_def \<sigma>\<^sub>Q\<^sub>M\<^sub>S\<^sub>G_def by (clarsimp cong: option.case_cong)
    thus "openproc.initmissing (\<lambda>i. paodv i \<langle>\<langle> qmsg) (\<lambda>(p, q). (fst (id p), snd (id p), q)) = initmissing"
      by (rule ext)
    have "\<And>P \<sigma>. openproc.netglobal (\<lambda>i. paodv i \<langle>\<langle> qmsg) (\<lambda>(p, q). (fst (id p), snd (id p), q)) P \<sigma>
                                                                                = netglobal P \<sigma>"
      unfolding opq.netglobal_def netglobal_def opq.initmissing_def initmissing_def opq.someinit_def
      unfolding \<sigma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V_def \<sigma>\<^sub>Q\<^sub>M\<^sub>S\<^sub>G_def
      by (clarsimp cong: option.case_cong
                   simp del: One_nat_def
                   simp add: fst_initmissing_netgmap_default_aodv_init_netlift
                                                  [symmetric, unfolded initmissing_def])
    thus "openproc.netglobal (\<lambda>i. paodv i \<langle>\<langle> qmsg) (\<lambda>(p, q). (fst (id p), snd (id p), q)) = netglobal"
      by auto
  qed

lemma net_nhop_quality_increases:
  assumes "wf_net_tree n"
  shows "closed (pnet (\<lambda>i. paodv i \<langle>\<langle> qmsg) n) \<TTurnstile> netglobal
                           (\<lambda>\<sigma>. \<forall>i dip. let nhip = the (nhop (rt (\<sigma> i)) dip)
                                        in dip \<in> vD (rt (\<sigma> i)) \<inter> vD (rt (\<sigma> nhip)) \<and> nhip \<noteq> dip
                                            \<longrightarrow> (rt (\<sigma> i)) \<sqsubset>\<^bsub>dip\<^esub> (rt (\<sigma> nhip)))"
        (is "_ \<TTurnstile> netglobal (\<lambda>\<sigma>. \<forall>i. ?inv \<sigma> i)")
  proof -
    from \<open>wf_net_tree n\<close>
      have proto: "closed (pnet (\<lambda>i. paodv i \<langle>\<langle> qmsg) n) \<TTurnstile> netglobal (\<lambda>\<sigma>. \<forall>i\<in>net_tree_ips n. \<forall>dip.
                                            let nhip = the (nhop (rt (\<sigma> i)) dip)
                                            in dip \<in> vD (rt (\<sigma> i)) \<inter> vD (rt (\<sigma> nhip)) \<and> nhip \<noteq> dip
                                                \<longrightarrow> (rt (\<sigma> i)) \<sqsubset>\<^bsub>dip\<^esub> (rt (\<sigma> nhip)))"
        by (rule aodv_openproc_par_qmsg.close_opnet [OF _ onet_nhop_quality_increases])
    show ?thesis
    unfolding invariant_def opnet_sos.opnet_tau1
    proof (rule, simp only: aodv_openproc_par_qmsg.netglobalsimp
                            fst_initmissing_netgmap_pair_fst, rule allI)
      fix \<sigma> i
      assume sr: "\<sigma> \<in> reachable (closed (pnet (\<lambda>i. paodv i \<langle>\<langle> qmsg) n)) TT"
      hence "\<forall>i\<in>net_tree_ips n. ?inv (fst (initmissing (netgmap fst \<sigma>))) i"
        by - (drule invariantD [OF proto],
              simp only: aodv_openproc_par_qmsg.netglobalsimp
                         fst_initmissing_netgmap_pair_fst)
      thus "?inv (fst (initmissing (netgmap fst \<sigma>))) i"
      proof (cases "i\<in>net_tree_ips n")
        assume "i\<notin>net_tree_ips n"
        from sr have "\<sigma> \<in> reachable (pnet (\<lambda>i. paodv i \<langle>\<langle> qmsg) n) TT" ..
        hence "net_ips \<sigma> = net_tree_ips n" ..
        with \<open>i\<notin>net_tree_ips n\<close> have "i\<notin>net_ips \<sigma>" by simp
        hence "(fst (initmissing (netgmap fst \<sigma>))) i = aodv_init i"
          by simp
        thus ?thesis by simp
      qed metis
    qed
  qed

subsection \<open>Loop freedom of AODV\<close>

theorem aodv_loop_freedom:
  assumes "wf_net_tree n"
  shows "closed (pnet (\<lambda>i. paodv i \<langle>\<langle> qmsg) n) \<TTurnstile> netglobal (\<lambda>\<sigma>. \<forall>dip. irrefl ((rt_graph \<sigma> dip)\<^sup>+))"
  using assms by (rule aodv_openproc_par_qmsg.netglobal_weakenE
                          [OF net_nhop_quality_increases inv_to_loop_freedom])

end