theory unique_ids_procedure_check
  imports unique_ids
begin

inductive procedure_cannot_guess_ids :: "uniqueId set \<Rightarrow> 'ls \<Rightarrow> ('ls, 'op::valueType, 'any::valueType) procedureImpl \<Rightarrow> bool"  where
  pcgi_local:  "\<lbrakk>impl ls = LocalStep ok ls'; procedure_cannot_guess_ids uids ls' impl\<rbrakk> \<Longrightarrow>  procedure_cannot_guess_ids uids ls impl"
| pcgi_beginAtomic: "\<lbrakk>impl ls = BeginAtomic ls'; procedure_cannot_guess_ids uids ls' impl\<rbrakk> \<Longrightarrow>  procedure_cannot_guess_ids uids ls impl"
| pcgi_endAtomic:"\<lbrakk>impl ls = EndAtomic ls'; procedure_cannot_guess_ids uids ls' impl\<rbrakk> \<Longrightarrow>  procedure_cannot_guess_ids uids ls impl"
| pcgi_newId:"\<lbrakk>impl ls = NewId f; \<And>uid ls'. f uid \<triangleq> ls' \<Longrightarrow> procedure_cannot_guess_ids (uids \<union> uniqueIds uid) ls' impl
    \<rbrakk> \<Longrightarrow>  procedure_cannot_guess_ids uids ls impl"
| pcgi_dbop: "\<lbrakk>impl ls = DbOperation opr f;  uniqueIds opr \<subseteq> uids;
    \<And>res. procedure_cannot_guess_ids (uids \<union> uniqueIds res) (f res) impl
    \<rbrakk> \<Longrightarrow>  procedure_cannot_guess_ids uids ls impl"
| pcgi_return: "\<lbrakk>impl ls = Return r; uniqueIds r \<subseteq> uids\<rbrakk> \<Longrightarrow> procedure_cannot_guess_ids uids ls impl"

lemma pcgi_local_case:"\<lbrakk>procedure_cannot_guess_ids uids ls impl; impl ls = LocalStep ok ls'\<rbrakk> \<Longrightarrow> procedure_cannot_guess_ids uids ls' impl"
  by (subst(asm) procedure_cannot_guess_ids.simps, auto)
lemma pcgi_beginAtomic_case:"\<lbrakk>procedure_cannot_guess_ids uids ls impl; impl ls = BeginAtomic ls'\<rbrakk> \<Longrightarrow> procedure_cannot_guess_ids uids ls' impl"
  by (subst(asm) procedure_cannot_guess_ids.simps, auto)
lemma pcgi_endAtomic_case:"\<lbrakk>procedure_cannot_guess_ids uids ls impl; impl ls = EndAtomic ls'\<rbrakk> \<Longrightarrow> procedure_cannot_guess_ids uids ls' impl"
  by (subst(asm) procedure_cannot_guess_ids.simps, auto)
lemma pcgi_newId_case:"\<lbrakk>procedure_cannot_guess_ids uids ls impl; impl ls = NewId f\<rbrakk> \<Longrightarrow> f uid \<triangleq> ls' \<Longrightarrow> procedure_cannot_guess_ids (uids \<union> uniqueIds uid) ls' impl"
  by (subst(asm) procedure_cannot_guess_ids.simps, auto)
lemma pcgi_dbop_case1:"\<lbrakk>procedure_cannot_guess_ids uids ls impl; impl ls = DbOperation opr f\<rbrakk> \<Longrightarrow> uniqueIds opr \<subseteq> uids"
  by (subst(asm) procedure_cannot_guess_ids.simps, auto)
lemma pcgi_dbop_case2:"\<lbrakk>procedure_cannot_guess_ids uids ls impl; impl ls = DbOperation opr f\<rbrakk> \<Longrightarrow> procedure_cannot_guess_ids (uids \<union> uniqueIds res) (f res) impl"
  by (subst(asm) procedure_cannot_guess_ids.simps, auto)
lemma pcgi_return_case:"\<lbrakk>procedure_cannot_guess_ids uids ls impl; impl ls = Return r\<rbrakk> \<Longrightarrow> uniqueIds r \<subseteq> uids"
  by (subst(asm) procedure_cannot_guess_ids.simps, auto)

definition procedures_cannot_guess_ids :: "('proc::valueType \<Rightarrow> ('ls \<times> ('ls, 'op::valueType, 'any::valueType) procedureImpl)) \<Rightarrow> bool" where
  "procedures_cannot_guess_ids proc =
(\<forall>p ls impl uids. proc p = (ls, impl) \<longrightarrow>  procedure_cannot_guess_ids (uids\<union>uniqueIds p) ls impl)"

lemmas show_procedures_cannot_guess_ids = procedures_cannot_guess_ids_def[THEN iffD1, rule_format]

lemma pscgi_to_iscgi:
  assumes "procedures_cannot_guess_ids (procedure progr)"
  shows "invocations_cannot_guess_ids progr"
  unfolding invocations_cannot_guess_ids_def invocation_cannot_guess_ids_def
proof (intro allI impI)

  fix i1 tr1 a S'
  assume steps: "initialState progr ~~ tr1 @ [a] \<leadsto>* S'"

  define tr1a where "tr1a = tr1@[a]"

  from steps
  have "initialState progr ~~ tr1a \<leadsto>* S'"
    using tr1a_def by blast

  value "butlast [1,2,3::nat]"

  from this
  have "trace_outputs tr1a i1 \<subseteq> trace_inputs (butlast tr1a) i1
    \<and> (\<forall>ls impl. localState S' i1 \<triangleq> ls
        \<longrightarrow>  currentProc S' i1 \<triangleq> impl
        \<longrightarrow> procedure_cannot_guess_ids (trace_inputs tr1a i1) ls impl)"
  proof (induct rule: steps_induct)
    case initial
    then show ?case
      by (auto simp add: initialState_def trace_outputs_def)

  next
    case (step S' tr a S'')

    have IH1: "trace_outputs tr i1 \<subseteq> trace_inputs (butlast tr) i1"
      using step by auto

    hence IH1': "trace_outputs tr i1 \<subseteq> trace_inputs tr i1"
      by (induct tr rule: rev_induct, auto simp add:  trace_inputs_append)

    have IH2: "procedure_cannot_guess_ids (trace_inputs tr i1) ls impl "
      if "localState S' i1 \<triangleq> ls"
        and "currentProc S' i1 \<triangleq> impl"
      for ls impl
      using step that by blast

    show ?case
    proof (cases "get_invoc a = i1")
      case False
      have [simp]: "trace_inputs (tr @ [a]) i1 = trace_inputs tr i1"
        by (simp add: False trace_inputs_def)
      have [simp]: "trace_outputs (tr @ [a]) i1 = trace_outputs tr i1"
        by (simp add: False trace_outputs_def)

      show ?thesis
        using IH1' IH2 apply (auto simp add: step)
        by (metis False IH2 prod.collapse step.step unchangedInTransaction(1) unchangedInTransaction(2))
    next
      case True

      from `S' ~~ a \<leadsto> S''`
      have "action_outputs (get_action a) \<subseteq> trace_inputs tr i1"
      proof cases
        case (dbop i ls f Op ls' t c res vis)
        have pcgi: "procedure_cannot_guess_ids (trace_inputs tr i1) ls f"
          using True local.dbop(1) local.dbop(3) local.dbop(4) step.IH by auto

        from pcgi_dbop_case1[OF pcgi `f ls = DbOperation Op ls'`]
        have " uniqueIds Op \<subseteq> trace_inputs tr i1" .
        then show ?thesis
          by (auto simp add: `a = (i, ADbOp c Op res)` trace_outputs_empty)
      next
        case (return i ls f res)
        have pcgi: "procedure_cannot_guess_ids (trace_inputs tr i1) ls f"
          using IH2 True local.return(1) local.return(3) local.return(4) by auto

        from pcgi_return_case[OF pcgi]
        show ?thesis
          by (auto simp add: return)
      qed auto

      have [simp]: "(trace_inputs (tr @ [(i, action)]) i1)
          = trace_inputs tr i1 \<union> (if i = i1 then action_inputs action else {})" for i action
        by (auto simp add: trace_inputs_append trace_inputs_cons trace_inputs_empty)

      from `S' ~~ a \<leadsto> S''`
      have "procedure_cannot_guess_ids (trace_inputs (tr @ [a]) i1) ls impl"
        if l1: "localState S'' i1 \<triangleq> ls"
        and l2: "currentProc S'' i1 \<triangleq> impl"
      for ls impl
      proof cases
        case (local i ls f ok ls')
        then show ?thesis
          using IH2 l1 l2 apply (auto simp add:  split: if_splits)
          by (meson pcgi_local_case)
      next
        case (newId i ls f ls' uid uidv ls'')
        then show ?thesis
          using IH2 l1 l2 apply (auto simp add:  split: if_splits)
          using pcgi_newId_case by fastforce
      next
        case (beginAtomic i ls f ls' t vis snapshot)
        then show ?thesis
          using IH2 l1 l2 apply (auto simp add:  split: if_splits)
          by (meson pcgi_beginAtomic_case)
      next
        case (endAtomic i ls f ls' t)
        then show ?thesis
          using IH2 l1 l2 apply (auto simp add:  split: if_splits)
          by (meson pcgi_endAtomic_case)
      next
        case (dbop i ls f Op ls' t c res vis)
        then show ?thesis
          using IH2 l1 l2 apply (auto simp add:  split: if_splits)
          by (meson pcgi_dbop_case2)
      next
        case (invocation i proc initialState impl)
        from  `procedures_cannot_guess_ids (procedure progr)`
        have "procedure_cannot_guess_ids (uniqueIds proc) initialState impl"
          apply (auto simp add: procedures_cannot_guess_ids_def)
          by (metis (no_types, lifting) state.select_convs(1) initialState_def local.invocation(4) step.steps steps_do_not_change_prog sup.idem)

        from invocation
        show ?thesis
          using IH2 l1 l2 apply (auto simp add:  split: if_splits)
          by (metis (no_types, lifting) assms state.select_convs(1) initialState_def show_procedures_cannot_guess_ids step.steps steps_do_not_change_prog)
      next
        case (return i ls f res)
        then show ?thesis
          using IH2 l1 l2 by (auto simp add:  split: if_splits)
      next
        case (crash i ls)
        then show ?thesis
          using IH2 l1 l2 by (auto simp add:  split: if_splits)
      next
        case (invCheck res i)
        then show ?thesis
          using IH2 l1 l2 by (auto simp add:  split: if_splits)
      qed

      thus ?thesis
        using  IH1' \<open>action_outputs (get_action a) \<subseteq> trace_inputs tr i1\<close> by (auto simp add: trace_outputs_append True subsetD trace_outputs_cons trace_outputs_empty)
    qed
  qed
  thus "trace_outputs (tr1 @ [a]) i1 \<subseteq> trace_inputs tr1 i1 \<union> {}"
    by (simp add: tr1a_def)
qed

end


theory mailbox_manage_sys
imports rg_cond_post func_cor_other  func_cor_OSMboxAccept  func_cor_OSMboxPost
begin

definition OSMboxPost_RGF :: "Thread \<Rightarrow> mailbox_ref \<Rightarrow> Message option \<Rightarrow> (EventLabel, Core, State, State com option) rgformula_e"
where "OSMboxPost_RGF t pevent msg  \<equiv> (OSMboxPost t pevent msg, OSMboxPost_RGCond t)"

definition OSMboxAccept_RGF :: "Thread \<Rightarrow> mailbox_ref \<Rightarrow> (EventLabel, Core, State, State com option) rgformula_e"
 where "OSMboxAccept_RGF t pevent \<equiv> (OSMboxAccept t pevent, OSMboxAccept_RGCond t)"

definition Schedule_RGF :: "Thread \<Rightarrow> (EventLabel, Core, State, State com option) rgformula_e"
where "Schedule_RGF t \<equiv> (Schedule t, Schedule_RGCond t)"

definition Tick_RGF :: "(EventLabel, Core, State, State com option) rgformula_e"
where "Tick_RGF \<equiv> (Tick, Tick_RGCond)"

definition Thread_RGF :: "Thread \<Rightarrow> (EventLabel, Core, State, State com option) rgformula_es"
where "Thread_RGF t \<equiv>  (rgf_EvtSys ((\<Union>(pevent, msg).{OSMboxPost_RGF t pevent msg}) \<union>
                         (\<Union>(pevent). {OSMboxAccept_RGF t pevent})),
         RG[(OSMboxPost_pre t \<inter> OSMboxAccept_pre t \<inter> OSMboxPend_pre t),
            (OSMboxPost_rely t \<inter> OSMboxAccept_rely t \<inter> OSMboxPend_rely t ),
            (OSMboxPost_guar t \<union> OSMboxAccept_guar t \<union> OSMboxPend_guar t),
            (OSMboxPost_post t \<union> OSMboxAccept_post t \<union> OSMboxPend_post t )
           ])"

definition Scheduler_RGF :: "(EventLabel, Core, State, State com option) rgformula_es"
where "Scheduler_RGF \<equiv>  (rgf_EvtSys (\<Union>t. {Schedule_RGF t}),
         RG[{s. inv s}, Schedule_rely, Schedule_guar, {s. inv s}])"

definition Timer_RGF :: "(EventLabel, Core, State, State com option) rgformula_es"
where "Timer_RGF \<equiv>  (rgf_EvtSys {Tick_RGF},
         RG[\<lbrace>True\<rbrace>, Tick_rely, Tick_guar, \<lbrace>True\<rbrace>])"

definition Mailbox_manage_system_Spec :: "(EventLabel, Core, State, State com option) rgformula_par"
where "Mailbox_manage_system_Spec k \<equiv>
    case k of (\<T> t) \<Rightarrow> Thread_RGF t
            | \<S> \<Rightarrow> Scheduler_RGF
            | Timer \<Rightarrow> Timer_RGF"

section \<open> functional correctness of the whole specification\<close>
definition "sys_rely \<equiv> {}"
(*definition "sys_rely \<equiv> {(s,t). inv s \<longrightarrow> inv t}"*)
(*definition "sys_rely \<equiv> (\<Inter>t. lvars_nochange_rel t) \<inter> gvars_conf_stable \<inter> {(s,t). inv s \<longrightarrow> inv t}"*)

definition "sys_guar \<equiv> Tick_guar \<union> Schedule_guar \<union> (\<Union>t. (OSMboxPost_guar t \<union> OSMboxAccept_guar t \<union> OSMboxPend_guar t ))"

lemma scheduler_esys_sat: "\<Gamma> \<turnstile> fst (Mailbox_manage_system_Spec \<S>)
  sat\<^sub>s [Pre\<^sub>e\<^sub>s (Mailbox_manage_system_Spec \<S>),
        Rely\<^sub>e\<^sub>s (Mailbox_manage_system_Spec \<S>),
        Guar\<^sub>e\<^sub>s (Mailbox_manage_system_Spec \<S>),
        Post\<^sub>e\<^sub>s (Mailbox_manage_system_Spec \<S>)]"
apply(simp add:Mailbox_manage_system_Spec_def Scheduler_RGF_def Schedule_RGF_def)
  apply(rule EvtSys_h)
    apply auto[1] apply(simp add:E\<^sub>e_def Pre\<^sub>e_def Rely\<^sub>e_def Guar\<^sub>e_def Post\<^sub>e_def)
    using Schedule_satRG apply(simp add:Schedule_RGCond_def Evt_sat_RG_def Pre\<^sub>f_def Rely\<^sub>f_def Guar\<^sub>f_def Post\<^sub>f_def)
    apply fast
    apply(simp add:Pre\<^sub>e\<^sub>s_def Pre\<^sub>e_def Schedule_RGCond_def)
    apply(simp add:Rely\<^sub>e\<^sub>s_def Rely\<^sub>e_def Schedule_RGCond_def)
    apply(simp add:Guar\<^sub>e\<^sub>s_def Guar\<^sub>e_def Schedule_RGCond_def)
    apply(simp add:Post\<^sub>e\<^sub>s_def Post\<^sub>e_def Schedule_RGCond_def)
    apply(simp add:Post\<^sub>e_def Pre\<^sub>e_def Schedule_RGCond_def getrgformula_def)
    apply(simp add:Pre\<^sub>e\<^sub>s_def Rely\<^sub>e\<^sub>s_def getrgformula_def)
      using stable_inv_sched_rely apply(simp add:stable_def)
    apply(simp add:Guar\<^sub>e\<^sub>s_def getrgformula_def Schedule_guar_def)
      done

lemma Post_rely_eq_Accept_rely:"OSMboxPost_rely x  = OSMboxAccept_rely x "
  apply(simp add:OSMboxPost_rely_def OSMboxAccept_rely_def)
  done

lemma temp:"OSMboxPost_rely x \<inter> OSMboxAccept_rely x = OSMboxPost_rely x"
  apply (simp add:OSMboxPost_rely_def OSMboxAccept_rely_def)
  done

lemma thread_esys_sat: "\<Gamma> \<turnstile> fst (Mailbox_manage_system_Spec (\<T> x))
  sat\<^sub>s [Pre\<^sub>e\<^sub>s (Mailbox_manage_system_Spec (\<T> x)),
        Rely\<^sub>e\<^sub>s (Mailbox_manage_system_Spec (\<T> x)),
        Guar\<^sub>e\<^sub>s (Mailbox_manage_system_Spec (\<T> x)),
        Post\<^sub>e\<^sub>s (Mailbox_manage_system_Spec (\<T> x))]"
apply(simp add:Mailbox_manage_system_Spec_def Thread_RGF_def OSMboxPost_RGF_def OSMboxAccept_RGF_def)
apply(rule EvtSys_h)
  apply auto[1]
    apply(simp add:E\<^sub>e_def Pre\<^sub>e_def Rely\<^sub>e_def Guar\<^sub>e_def Post\<^sub>e_def getrgformula_def OSMboxPost_RGCond_def)
      using OSMboxPost_satRG apply(simp add:Evt_sat_RG_def OSMboxPost_RGCond_def
                                      getrgformula_def Pre\<^sub>f_def Rely\<^sub>f_def Guar\<^sub>f_def Post\<^sub>f_def) apply fast
    apply(simp add:E\<^sub>e_def Pre\<^sub>e_def Rely\<^sub>e_def Guar\<^sub>e_def Post\<^sub>e_def getrgformula_def OSMboxAccept_RGCond_def)
      using OSMboxAccept_satRG apply(simp add:Evt_sat_RG_def OSMboxAccept_RGCond_def
                                      getrgformula_def Pre\<^sub>f_def Rely\<^sub>f_def Guar\<^sub>f_def Post\<^sub>f_def) apply fast
  apply auto[1]
    apply(simp add:Pre\<^sub>e\<^sub>s_def Pre\<^sub>e_def getrgformula_def OSMboxPost_RGCond_def)
    apply(simp add:Pre\<^sub>e\<^sub>s_def Pre\<^sub>e_def getrgformula_def OSMboxAccept_RGCond_def)
  apply auto[1]
    apply(simp add:Rely\<^sub>e\<^sub>s_def Rely\<^sub>e_def getrgformula_def OSMboxPost_RGCond_def)
    apply(simp add:Rely\<^sub>e\<^sub>s_def Rely\<^sub>e_def getrgformula_def OSMboxAccept_RGCond_def)
  apply auto[1]
    apply(simp add:Guar\<^sub>e\<^sub>s_def Guar\<^sub>e_def getrgformula_def OSMboxPost_RGCond_def)
    apply(simp add:Guar\<^sub>e\<^sub>s_def Guar\<^sub>e_def getrgformula_def OSMboxAccept_RGCond_def)
  apply auto[1]
    apply(simp add:Post\<^sub>e\<^sub>s_def Post\<^sub>e_def getrgformula_def OSMboxPost_RGCond_def)
    apply(simp add:Post\<^sub>e\<^sub>s_def Post\<^sub>e_def getrgformula_def OSMboxAccept_RGCond_def)
  apply auto[1]
           apply(simp add:Post\<^sub>e_def Pre\<^sub>e_def OSMboxPost_RGCond_def getrgformula_def OSMboxPost_post_def)apply auto
      apply(simp add:inv_def OSMboxPost_pre_def)
    apply(simp add:Post\<^sub>e_def Pre\<^sub>e_def OSMboxPost_RGCond_def OSMboxAccept_RGCond_def
          getrgformula_def OSMboxPost_post_def)
 apply(simp add:inv_def OSMboxAccept_pre_def)
    apply(simp add:Post\<^sub>e_def Pre\<^sub>e_def OSMboxPost_RGCond_def OSMboxAccept_RGCond_def
          getrgformula_def OSMboxAccept_post_def)
         apply(simp add:inv_def OSMboxPost_pre_def)
        apply(simp add:Post\<^sub>e_def Pre\<^sub>e_def OSMboxAccept_RGCond_def getrgformula_def OSMboxAccept_post_def)
 apply(simp add:inv_def OSMboxAccept_pre_def)
  apply(simp add:Pre\<^sub>e\<^sub>s_def Rely\<^sub>e\<^sub>s_def getrgformula_def)
    defer 1 (* proved in mem_alloc *)
       apply(simp add:Guar\<^sub>e\<^sub>s_def getrgformula_def OSMboxAccept_guar_def)

      apply(simp add:OSMboxAccept_pre_def OSMboxPost_pre_def OSMboxPend_pre_def)
      apply(simp add:temp)
      apply(simp add:inv_def OSMboxPost_rely_def inv_cur_def stable_def OSMboxPend_rely_def)
      done

lemma timer_esys_sat: "\<Gamma> \<turnstile> fst (Mailbox_manage_system_Spec Timer)
  sat\<^sub>s [Pre\<^sub>e\<^sub>s (Mailbox_manage_system_Spec Timer),
        Rely\<^sub>e\<^sub>s (Mailbox_manage_system_Spec Timer),
        Guar\<^sub>e\<^sub>s (Mailbox_manage_system_Spec Timer),
        Post\<^sub>e\<^sub>s (Mailbox_manage_system_Spec Timer)]"
apply(simp add:Mailbox_manage_system_Spec_def Timer_RGF_def Tick_RGF_def)
apply(rule EvtSys_h)
  apply auto[1] apply(simp add:E\<^sub>e_def Pre\<^sub>e_def Rely\<^sub>e_def Guar\<^sub>e_def Post\<^sub>e_def)
    using Tick_satRG apply(simp add:Tick_RGCond_def Evt_sat_RG_def Pre\<^sub>f_def Rely\<^sub>f_def Guar\<^sub>f_def Post\<^sub>f_def)
    apply fast
  apply(simp add:Pre\<^sub>e\<^sub>s_def Pre\<^sub>e_def Tick_RGCond_def)
  apply(simp add:Rely\<^sub>e\<^sub>s_def Rely\<^sub>e_def Tick_RGCond_def)
  apply(simp add:Guar\<^sub>e\<^sub>s_def Guar\<^sub>e_def Tick_RGCond_def)
  apply(simp add:Post\<^sub>e\<^sub>s_def Post\<^sub>e_def Tick_RGCond_def)
  apply(simp add:Post\<^sub>e_def Pre\<^sub>e_def Tick_RGCond_def getrgformula_def)
  apply(simp add:Pre\<^sub>e\<^sub>s_def Rely\<^sub>e\<^sub>s_def getrgformula_def)
    using stable_inv_sched_rely apply(simp add:stable_def)
  apply(simp add:Guar\<^sub>e\<^sub>s_def getrgformula_def Tick_guar_def)
done

lemma esys_sat: "\<Gamma> \<turnstile> fst (Mailbox_manage_system_Spec k)
  sat\<^sub>s [Pre\<^sub>e\<^sub>s (Mailbox_manage_system_Spec k),
        Rely\<^sub>e\<^sub>s (Mailbox_manage_system_Spec k),
        Guar\<^sub>e\<^sub>s (Mailbox_manage_system_Spec k),
        Post\<^sub>e\<^sub>s (Mailbox_manage_system_Spec k)]"
  apply(induct k)
  using scheduler_esys_sat apply fast
  using thread_esys_sat apply fast
  using timer_esys_sat apply fast
done

lemma s0_esys_pre: "{s0} \<subseteq> Pre\<^sub>e\<^sub>s (Mailbox_manage_system_Spec k)"
apply(induct k)
  apply(simp add:Mailbox_manage_system_Spec_def Pre\<^sub>e\<^sub>s_def Scheduler_RGF_def getrgformula_def)    (*System 1: Scheduler *)
  using s0_inv apply fast

     apply(simp add:Mailbox_manage_system_Spec_def Pre\<^sub>e\<^sub>s_def Thread_RGF_def getrgformula_def)    (*System 2: Thread *)
    using s0_inv s0a4 s0a1 s0a2 s0a3 apply auto[1]
      apply(simp add:inv_def OSMboxPost_pre_def)
      apply(simp add:inv_def OSMboxAccept_pre_def)
     apply(simp add:inv_def OSMboxPend_pre_def)

  apply(simp add:Mailbox_manage_system_Spec_def Pre\<^sub>e\<^sub>s_def Timer_RGF_def getrgformula_def)       (*System 3: Timer *)
done

lemma alloc_free_eq_guar: " OSMboxPost_guar x\<subseteq> OSMboxAccept_guar x "
  apply(simp add:OSMboxAccept_guar_def OSMboxPost_guar_def)
  apply(simp add:gvars_conf_stable_def)
  apply auto
         apply(simp add: lvars_nochange_def lvars_nochange_lemma_def gvars_conf_stable_def gvars_conf_def)apply auto

lemma alloc_free_eq_rely: "OSMboxAccept_rely x = OSMboxPost_rely x"
  by(simp add:OSMboxAccept_rely_def OSMboxPost_rely_def)

lemma esys_guar_in_other:
  "jj \<noteq> k \<longrightarrow> Guar\<^sub>e\<^sub>s (Mailbox_manage_system_Spec jj) \<subseteq> Rely\<^sub>e\<^sub>s (Mailbox_manage_system_Spec k)"
  apply auto
  apply(induct jj)
    apply(induct k)
      apply simp
     apply(simp add:Guar\<^sub>e\<^sub>s_def Rely\<^sub>e\<^sub>s_def Mailbox_manage_system_Spec_def Scheduler_RGF_def Thread_RGF_def getrgformula_def)
  using Schedguar_in_OSMemGetrely  apply(simp add:OSMboxPost_rely_def OSMboxAccept_rely_def) apply auto[1]
  apply(induct k)
  using OSMemGetguar_in_OSMemGetrely OSMem_eq_guar OSMem_eq_rely by fast+

thm esys_guar_in_other

lemma esys_guar_in_sys: "Guar\<^sub>e\<^sub>s (Mailbox_manage_system_Spec k) \<subseteq> sys_guar"
apply(induct k)
  apply(simp add:Guar\<^sub>e\<^sub>s_def Mailbox_manage_system_Spec_def Scheduler_RGF_def getrgformula_def sys_guar_def) apply auto[1]
  apply(simp add:Guar\<^sub>e\<^sub>s_def Mailbox_manage_system_Spec_def Thread_RGF_def getrgformula_def sys_guar_def) apply auto[1]
  apply(simp add:Guar\<^sub>e\<^sub>s_def Mailbox_manage_system_Spec_def Timer_RGF_def getrgformula_def sys_guar_def) apply auto[1]
done

lemma mailbox_sys_sat: "\<Gamma> \<turnstile> Mailbox_manage_system_Spec SAT [{s0}, sys_rely, sys_guar, UNIV]"
apply(rule ParallelESys[of \<Gamma> Mailbox_manage_system_Spec"{s0}" sys_rely sys_guar UNIV])
  apply clarify using esys_sat apply fast
  using s0_esys_pre apply fast
  apply(simp add:sys_rely_def)
  using esys_guar_in_other apply fast
  using esys_guar_in_sys apply fast
  apply simp
  done

end


theory NP4_Direction_Values
  imports
  NP4_Direction_Syntax
  "~~/src/HOL/Word/Word"
  "~~/src/HOL/Word/Word_Bitwise"
(*  These files contain a minimalistic semantics of P4's action constructs. More complex concepts
    like switch statements are left out. The purpose of this verification effort is to showcase
    the viability of using Isabelle/HOL to verify P4 applications. These files focus on the
    action constructs.

    P4 actions are the code fragments that can read and write data being processed. The action
    constructs are where sequential code resides in P4. To this end the action constructs are the
    main way by which the control-plane can influence the behaviour of the data-plane.

    To this end these files define a small-step semantics of the P4 actions. Then a typing
    environment is built upon this, and the statements are extended with a termination-counter.
    These are used to prove properties like termination, determinism, progression,
    preservation, and more. The semantics can also be used to analyse reachability properties.
    Well-defined and well-typed P4 programs will yield a derivation tree, where as ill-defined
    or ill-typed P4 programs will yield no such tree. *)
begin

(* ============================================================================================================== *)
(*                                              VALUE MAPPINGS                                                    *)
(* ============================================================================================================== *)

(* Contains the value of a single bit, can be cast between bool *)
datatype sbit = ZERO | ONE

(* Mapping to concrete value *)
datatype val = SBIT sbit
  | UINT nat
  | SINT int
  | IINT int
  | VINT nat
  | BOOL bool
  | STRING string
  | ERROR "identifier list"
  | MATCH "identifier list"

datatype direction = IN | OUT | INOUT

(* State is a mapping from variable names to values *)
type_synonym state = "vname \<Rightarrow> val"
type_synonym directionMap = "vname \<Rightarrow> direction"

(* ============================================================================================================== *)
(*                                              HELPER FUNCTIONS                                                  *)
(* ============================================================================================================== *)

(* Convert a basetype to a concrete value used for converting the entries of derived types. *)
fun baseToVal :: "baseType \<Rightarrow> val" where
    "baseToVal (BBOOL b)       = (BOOL b)"
  | "baseToVal (BSBIT 0)       = (SBIT ZERO)"
  | "baseToVal (BSBIT (Suc n)) = (SBIT ONE)"
  | "baseToVal (BIINT n)       = (IINT n)"
  | "baseToVal (BUINT n)       = (UINT n)"
  | "baseToVal (BSINT n)       = (SINT n)"
  | "baseToVal (BVINT n)       = (VINT n)"
  | "baseToVal (BERROR e)      = (ERROR e)"
  | "baseToVal (BMATCH m)      = (MATCH m)"
  | "baseToVal (BSTRING s)     = (STRING s)"

(* ============================================================================================================== *)
(*                                   CONCRETE VALUE EVALUATION FUNCTIONS                                          *)
(* ============================================================================================================== *)

inductive eval :: "expression \<Rightarrow> state \<Rightarrow> val \<Rightarrow> bool" where
(* =============== Base types =============== *)
    RBOOL:    "eval (BASE (BBOOL b))      s (BOOL b)"
  | RBIT0:    "eval (BASE (BSBIT 0))       s (SBIT ZERO)"
  | RBIT1:    "eval (BASE (BSBIT (Suc n))) s (SBIT ONE)"
  | RIINT:    "eval (BASE (BIINT n))      s (IINT n)"
  | RUINT:    "eval (BASE (BUINT n))      s (UINT n)"
  | RSINT:    "eval (BASE (BSINT n))      s (SINT n)"
  | RVINT:    "eval (BASE (BVINT n))      s (VINT n)"
  | RERROR:   "eval (BASE (BERROR e))     s (ERROR e)"
  | RMATCH:   "eval (BASE (BMATCH m))     s (MATCH m)"
  | RSTRING:  "eval (BASE (BSTRING str))  s (STRING str)"
(* =============== Miscellaneous expressions =============== *)
  | TERNTRUE:  "eval e1 s (BOOL b) \<Longrightarrow> b = True \<Longrightarrow> eval e2 s v \<Longrightarrow> eval (TernExpr e1 e2 e3) s v"
  | TERNFALSE: "eval e1 s (BOOL b) \<Longrightarrow> b = False \<Longrightarrow> eval e3 s v \<Longrightarrow> eval (TernExpr e1 e2 e3) s v"
(* =============== Variable mapping  =============== *)
  | NAMEDVAR: "eval (NamedVar varName) s (s varName)"
(* =============== Operations that yield a single bit (SBIT)  =============== *)
          (* Empty for now *)
(* =============== Operations that yield a boolean (BOOL)  =============== *)
  | ULNEB: "eval e1 s (BOOL b) \<Longrightarrow> eval (UNA_LNE e1) s (BOOL (\<not>b))"
    (* Boolean operations *)
  | BEQUB: "eval e1 s (BOOL b1) \<Longrightarrow> eval e2 s (BOOL b2) \<Longrightarrow> eval (BIN_EQU e1 e2) s (BOOL (b1 = b2))"
(* Boolean equality check yields derivation error; code cannot be generated for inductive predicate eval *)
(*  | BNEQB: "eval e1 s (BOOL b1) \<Longrightarrow> eval e2 s (BOOL b2) \<Longrightarrow> eval (BIN_NEQ e1 e2) s (BOOL (b1 \<noteq> b2))" *)
  | BFANB: "eval e1 s (BOOL b1) \<Longrightarrow> eval e2 s (BOOL b2) \<Longrightarrow> eval (BIN_FAN e1 e2) s (BOOL (b1 \<and> b2))"
  | BFORB: "eval e1 s (BOOL b1) \<Longrightarrow> eval e2 s (BOOL b2) \<Longrightarrow> eval (BIN_FOR e1 e2) s (BOOL (b1 \<or> b2))"
    (* Signed integer opreations *)
  | BEQUS: "eval e1 s (SINT n1) \<Longrightarrow> eval e2 s (SINT n2) \<Longrightarrow> eval (BIN_EQU e1 e2) s (BOOL (n1 = n2))"
  | BNEQS: "eval e1 s (SINT n1) \<Longrightarrow> eval e2 s (SINT n2) \<Longrightarrow> eval (BIN_NEQ e1 e2) s (BOOL (n1 \<noteq> n2))"
  | BLEQS: "eval e1 s (SINT n1) \<Longrightarrow> eval e2 s (SINT n2) \<Longrightarrow> eval (BIN_LEQ e1 e2) s (BOOL (n1 \<le> n2))"
  | BGEQS: "eval e1 s (SINT n1) \<Longrightarrow> eval e2 s (SINT n2) \<Longrightarrow> eval (BIN_GEQ e1 e2) s (BOOL (n1 \<ge> n2))"
  | BLESS: "eval e1 s (SINT n1) \<Longrightarrow> eval e2 s (SINT n2) \<Longrightarrow> eval (BIN_LES e1 e2) s (BOOL (n1 < n2))"
  | BGRES: "eval e1 s (SINT n1) \<Longrightarrow> eval e2 s (SINT n2) \<Longrightarrow> eval (BIN_GRE e1 e2) s (BOOL (n1 > n2))"
    (* Unsigned integer opreations *)
  | BEQUU: "eval e1 s (UINT n1) \<Longrightarrow> eval e2 s (UINT n2) \<Longrightarrow> eval (BIN_EQU e1 e2) s (BOOL (n1 = n2))"
  | BNEQU: "eval e1 s (UINT n1) \<Longrightarrow> eval e2 s (UINT n2) \<Longrightarrow> eval (BIN_NEQ e1 e2) s (BOOL (n1 \<noteq> n2))"
  | BLEQU: "eval e1 s (UINT n1) \<Longrightarrow> eval e2 s (UINT n2) \<Longrightarrow> eval (BIN_LEQ e1 e2) s (BOOL (n1 \<le> n2))"
  | BGEQU: "eval e1 s (UINT n1) \<Longrightarrow> eval e2 s (UINT n2) \<Longrightarrow> eval (BIN_GEQ e1 e2) s (BOOL (n1 \<ge> n2))"
  | BLESU: "eval e1 s (UINT n1) \<Longrightarrow> eval e2 s (UINT n2) \<Longrightarrow> eval (BIN_LES e1 e2) s (BOOL (n1 < n2))"
  | BGREU: "eval e1 s (UINT n1) \<Longrightarrow> eval e2 s (UINT n2) \<Longrightarrow> eval (BIN_GRE e1 e2) s (BOOL (n1 > n2))"
    (* Infinite precision integer opreations *)
  | BEQUI: "eval e1 s (IINT n1) \<Longrightarrow> eval e2 s (IINT n2) \<Longrightarrow> eval (BIN_EQU e1 e2) s (BOOL (n1 = n2))"
  | BNEQI: "eval e1 s (IINT n1) \<Longrightarrow> eval e2 s (IINT n2) \<Longrightarrow> eval (BIN_NEQ e1 e2) s (BOOL (n1 \<noteq> n2))"
  | BLEQI: "eval e1 s (IINT n1) \<Longrightarrow> eval e2 s (IINT n2) \<Longrightarrow> eval (BIN_LEQ e1 e2) s (BOOL (n1 \<le> n2))"
  | BGEQI: "eval e1 s (IINT n1) \<Longrightarrow> eval e2 s (IINT n2) \<Longrightarrow> eval (BIN_GEQ e1 e2) s (BOOL (n1 \<ge> n2))"
  | BLESI: "eval e1 s (IINT n1) \<Longrightarrow> eval e2 s (IINT n2) \<Longrightarrow> eval (BIN_LES e1 e2) s (BOOL (n1 < n2))"
  | BGREI: "eval e1 s (IINT n1) \<Longrightarrow> eval e2 s (IINT n2) \<Longrightarrow> eval (BIN_GRE e1 e2) s (BOOL (n1 > n2))"
    (* Variable size bitstring opreations *)
  | BEQUV: "eval e1 s (VINT n1) \<Longrightarrow> eval e2 s (VINT n2) \<Longrightarrow> eval (BIN_EQU e1 e2) s (BOOL (n1 = n2))"
  | BNEQV: "eval e1 s (VINT n1) \<Longrightarrow> eval e2 s (VINT n2) \<Longrightarrow> eval (BIN_NEQ e1 e2) s (BOOL (n1 \<noteq> n2))"
(* =============== Operations that yield an unsigned integer (UINT)  =============== *)
  | UNEGU: "eval e1 s (UINT n1) \<Longrightarrow> eval (UNA_NEG e1) s (UINT n1)" (* Incorrect but w/e for now *)
  | UPOSU: "eval e1 s (UINT n1) \<Longrightarrow> eval (UNA_POS e1) s (UINT n1)"
  | UCOMU: "eval e1 s (UINT n1) \<Longrightarrow> eval (UNA_COM e1) s (UINT n1)" (* (nat (NOT (int n1))))" Incorrect but w/e *)
  | BADDU: "eval e1 s (UINT n1) \<Longrightarrow> eval e2 s (UINT n2) \<Longrightarrow> eval (BIN_ADD e1 e2) s (UINT (n1 + n2))"
  | BMINU: "eval e1 s (UINT n1) \<Longrightarrow> eval e2 s (UINT n2) \<Longrightarrow> eval (BIN_MIN e1 e2) s (UINT (n1 - n2))"
  | BANDU: "eval e1 s (UINT n1) \<Longrightarrow> eval e2 s (UINT n2) \<Longrightarrow> eval (BIN_AND e1 e2) s (UINT (nat ((int n1) AND (int n2))))"
  | BXORU: "eval e1 s (UINT n1) \<Longrightarrow> eval e2 s (UINT n2) \<Longrightarrow> eval (BIN_XOR e1 e2) s (UINT (nat ((int n1) XOR (int n2))))"
  | BLORU: "eval e1 s (UINT n1) \<Longrightarrow> eval e2 s (UINT n2) \<Longrightarrow> eval (BIN_LOR e1 e2) s (UINT (nat ((int n1) OR (int n2))))"
(* =============== Operations that yield a signed integer (SINT)  =============== *)
  | UNEGS: "eval e1 s (SINT n1) \<Longrightarrow> eval (UNA_NEG e1) s (SINT (-n1))"
  | UPOSS: "eval e1 s (SINT n1) \<Longrightarrow> eval (UNA_POS e1) s (SINT n1)"
  | BADDS: "eval e1 s (SINT n1) \<Longrightarrow> eval e2 s (SINT n2) \<Longrightarrow> eval (BIN_ADD e1 e2) s (SINT (n1 + n2))"
  | BMINS: "eval e1 s (SINT n1) \<Longrightarrow> eval e2 s (SINT n2) \<Longrightarrow> eval (BIN_MIN e1 e2) s (SINT (n1 - n2))"
(* =============== Operations that yield an infinite-precision integer (IINT)  =============== *)
  | UNEGI: "eval e1 s (IINT n1) \<Longrightarrow> eval (UNA_NEG e1) s (IINT (-n1))"
  | UPOSI: "eval e1 s (IINT n1) \<Longrightarrow> eval (UNA_POS e1) s (IINT n1)"
  | BADDI: "eval e1 s (IINT n1) \<Longrightarrow> eval e2 s (IINT n2) \<Longrightarrow> eval (BIN_ADD e1 e2) s (IINT (n1 + n2))"
  | BMINI: "eval e1 s (IINT n1) \<Longrightarrow> eval e2 s (IINT n2) \<Longrightarrow> eval (BIN_MIN e1 e2) s (IINT (n1 - n2))"
  | BMULI: "eval e1 s (IINT n1) \<Longrightarrow> eval e2 s (IINT n2) \<Longrightarrow> eval (BIN_MUL e1 e2) s (IINT (n1 * n2))"
  | BDIVI: "eval e1 s (IINT n1) \<Longrightarrow> eval e2 s (IINT n2) \<Longrightarrow> eval (BIN_DIV e1 e2) s (IINT (n1 div n2))"
  | BMODI: "eval e1 s (IINT n1) \<Longrightarrow> eval e2 s (IINT n2) \<Longrightarrow> eval (BIN_MOD e1 e2) s (IINT (n1 mod n2))"
(* =============== Operations that yield a variable-width integer (VINT)  =============== *)
      (* Empty for now *)

inductive_cases [elim!]: "eval (BASE b) s v" "eval (TernExpr e1 e2 e3) s v" "eval (NamedVar i) s v"
"eval (UNA_LNE e) s v" "eval (UNA_COM e) s v" "eval (UNA_NEG e) s v" "eval (UNA_POS e) s v" "eval (BIN_MUL e1 e2) s v"
"eval (BIN_DIV e1 e2) s v" "eval (BIN_MOD e1 e2) s v" "eval (BIN_ADD e1 e2) s v" "eval (BIN_MIN e1 e2) s v" "eval (BIN_AND e1 e2) s v"
"eval (BIN_XOR e1 e2) s v" "eval (BIN_LOR e1 e2) s v" "eval (BIN_LEQ e1 e2) s v" "eval (BIN_GEQ e1 e2) s v" "eval (BIN_LES e1 e2) s v"
"eval (BIN_GRE e1 e2) s v" "eval (BIN_NEQ e1 e2) s v" "eval (BIN_EQU e1 e2) s v" "eval (BIN_FAN e1 e2) s v" "eval (BIN_FOR e1 e2) s v"

lemma eval_deterministic: "(eval e s v) \<Longrightarrow> (eval e s v') \<Longrightarrow> (v = v')"
  apply (induction arbitrary: v' rule: eval.induct)
                      apply (blast+)
  done

code_pred eval .

definition null_state ("<>") where
  "null_state \<equiv> \<lambda>x. (UINT 0)"
syntax
  "_State" :: "updbinds \<Rightarrow> 'a" ("<_>")
translations
  "_State ms" == "_Update <> ms"
  "_State (_updbinds b bs)" <= "_Update (_State b) bs"

end


theory R_R_Spark_User
imports
  R_R_Spark_Specification
  R_R_Spark_Declaration
  Global_User
begin

lemma goal2'1:
  assumes "0 <= j''"
  assumes "j'' <= 79"
  shows "(block_permutation___default_arr''
     (0 := 5, 1 := 14, 2 := 7, 3 := 0, 4 := 9, 5 := 2, 6 := 11, 7 := 4,
      8 := 13, 9 := 6, 10 := 15, 11 := 8, 12 := 1, 13 := 10, 14 := 3,
      15 := 12, 16 := 6, 17 := 11, 18 := 3, 19 := 7, 20 := 0, 21 := 13,
      22 := 5, 23 := 10, 24 := 14, 25 := 15, 26 := 8, 27 := 12, 28 := 4,
      29 := 9, 30 := 1, 31 := 2, 32 := 15, 33 := 5, 34 := 1, 35 := 3,
      36 := 7, 37 := 14, 38 := 6, 39 := 9, 40 := 11, 41 := 8, 42 := 12,
      43 := 2, 44 := 10, 45 := 0, 46 := 4, 47 := 13, 48 := 8, 49 := 6,
      50 := 4, 51 := 1, 52 := 3, 53 := 11, 54 := 15, 55 := 0, 56 := 5,
      57 := 12, 58 := 2, 59 := 13, 60 := 9, 61 := 7, 62 := 10, 63 := 14,
      64 := 12, 65 := 15, 66 := 10, 67 := 4, 68 := 1, 69 := 5, 70 := 8,
      71 := 7, 72 := 6, 73 := 2, 74 := 13, 75 := 14, 76 := 0, 77 := 3,
      78 := 9, 79 := 11))
     j'' =
    R_R_Spark_Specification.r_r' j''"
proof -
  note nth_list_to_fun_eff_eq
  moreover have "0 <= nat j''" by simp
  moreover from `j'' <= 79` have "nat j'' < length r'_list"
    unfolding r'_list_def by simp
  ultimately have conversion:
    "int (r'_list ! nat j'') =
      list_to_fun_eff
        r'_list 0 block_permutation___default_arr'' (int (nat j''))" .
  show ?thesis unfolding r'_def conversion
    unfolding r'_list_def using `0 <= j''` `j'' <= 79`
    by simp
qed

lemma goal2'2:
  assumes "0 <= j''"
  assumes "j'' <= 79"
  shows " 0 \<le> (block_permutation___default_arr''
         (0 := 5, 1 := 14, 2 := 7, 3 := 0, 4 := 9, 5 := 2, 6 := 11, 7 := 4,
          8 := 13, 9 := 6, 10 := 15, 11 := 8, 12 := 1, 13 := 10, 14 := 3,
          15 := 12, 16 := 6, 17 := 11, 18 := 3, 19 := 7, 20 := 0, 21 := 13,
          22 := 5, 23 := 10, 24 := 14, 25 := 15, 26 := 8, 27 := 12, 28 := 4,
          29 := 9, 30 := 1, 31 := 2, 32 := 15, 33 := 5, 34 := 1, 35 := 3,
          36 := 7, 37 := 14, 38 := 6, 39 := 9, 40 := 11, 41 := 8, 42 := 12,
          43 := 2, 44 := 10, 45 := 0, 46 := 4, 47 := 13, 48 := 8, 49 := 6,
          50 := 4, 51 := 1, 52 := 3, 53 := 11, 54 := 15, 55 := 0, 56 := 5,
          57 := 12, 58 := 2, 59 := 13, 60 := 9, 61 := 7, 62 := 10, 63 := 14,
          64 := 12, 65 := 15, 66 := 10, 67 := 4, 68 := 1, 69 := 5, 70 := 8,
          71 := 7, 72 := 6, 73 := 2, 74 := 13, 75 := 14, 76 := 0, 77 := 3,
          78 := 9, 79 := 11))
         j''"
unfolding goal2'1[OF assms]
by simp

lemma goal2'3:
  assumes "0 <= j''"
  assumes "j'' <= 79"
  shows "(block_permutation___default_arr''
     (0 := 5, 1 := 14, 2 := 7, 3 := 0, 4 := 9, 5 := 2, 6 := 11, 7 := 4,
      8 := 13, 9 := 6, 10 := 15, 11 := 8, 12 := 1, 13 := 10, 14 := 3,
      15 := 12, 16 := 6, 17 := 11, 18 := 3, 19 := 7, 20 := 0, 21 := 13,
      22 := 5, 23 := 10, 24 := 14, 25 := 15, 26 := 8, 27 := 12, 28 := 4,
      29 := 9, 30 := 1, 31 := 2, 32 := 15, 33 := 5, 34 := 1, 35 := 3,
      36 := 7, 37 := 14, 38 := 6, 39 := 9, 40 := 11, 41 := 8, 42 := 12,
      43 := 2, 44 := 10, 45 := 0, 46 := 4, 47 := 13, 48 := 8, 49 := 6,
      50 := 4, 51 := 1, 52 := 3, 53 := 11, 54 := 15, 55 := 0, 56 := 5,
      57 := 12, 58 := 2, 59 := 13, 60 := 9, 61 := 7, 62 := 10, 63 := 14,
      64 := 12, 65 := 15, 66 := 10, 67 := 4, 68 := 1, 69 := 5, 70 := 8,
      71 := 7, 72 := 6, 73 := 2, 74 := 13, 75 := 14, 76 := 0, 77 := 3,
      78 := 9, 79 := 11))
     j''
    \<le> 15"
proof -
  have "r'_list ! nat j'' \<le> foldl max 0 r'_list"
    by (insert assms, rule list_max) (simp_all add: r'_list_def)
  thus ?thesis unfolding goal2'1[OF assms] r'_def
    by (rule list_max_int) (simp_all add: assms r'_list_def)
qed

lemmas userlemmas = goal2'2 goal2'3 goal2'1

end


(*  Title:       Toy.thy
    License:     BSD 2-Clause. See LICENSE.
    Author:      Timothy Bourke
    Author:      Peter Höfner
*)

header "Simple toy example"

theory Toy
imports Main AWN_Main Qmsg_Lifting
begin

subsection "Messages used in the protocol"

datatype msg =
    Pkt data ip
  | Newpkt data ip

instantiation msg :: msg
begin
definition newpkt_def [simp]: "newpkt \<equiv> \<lambda>(d,dip). Newpkt d dip"
definition eq_newpkt_def: "eq_newpkt m \<equiv> case m of Newpkt d dip  \<Rightarrow> True | _ \<Rightarrow> False"

instance by intro_classes (simp add: eq_newpkt_def)
end

definition pkt :: "nat \<times> nat \<Rightarrow> msg"
where "pkt \<equiv> \<lambda>(no, sip). Pkt no sip"

lemma pkt_simp [simp]:
  "pkt(no, sip) = Pkt no sip"
  unfolding pkt_def by simp

lemma not_eq_newpkt_pkt [simp]: "\<not>eq_newpkt (Pkt no sip)"
  unfolding eq_newpkt_def by simp

subsection "Protocol model"

record state =
  ip    :: "nat"
  no    :: "nat"
  nhip  :: "nat"
  (* all locals *)
  msg    :: "msg"
  num    :: "nat"
  sip    :: "nat"

abbreviation toy_init :: "ip \<Rightarrow> state"
where "toy_init i \<equiv> \<lparr>
         ip = i,
         no = 0,
         nhip = i,

         msg    = (SOME x. True),
         num    = (SOME x. True),
         sip    = (SOME x. True)
       \<rparr>"

lemma some_neq_not_eq [simp]: "\<not>((SOME x :: nat. x \<noteq> i) = i)"
  by (subst some_eq_ex) (metis zero_neq_numeral)

definition clear_locals :: "state \<Rightarrow> state"
where "clear_locals \<xi> = \<xi> \<lparr>
    msg    := (SOME x. True),
    num    := (SOME x. True),
    sip    := (SOME x. True)
  \<rparr>"

lemma clear_locals_but_not_globals [simp]:
  "ip (clear_locals \<xi>) = ip \<xi>"
  "no (clear_locals \<xi>) = no \<xi>"
  "nhip (clear_locals \<xi>) = nhip \<xi>"
  unfolding clear_locals_def by auto

definition is_newpkt
where "is_newpkt \<xi> \<equiv> case msg \<xi> of
                       Newpkt data dip \<Rightarrow> { \<xi>\<lparr>num := data\<rparr> }
                     | _ \<Rightarrow> {}"

definition is_pkt
where "is_pkt \<xi> \<equiv> case msg \<xi> of
                    Pkt num' sip' \<Rightarrow> { \<xi>\<lparr> num := num', sip := sip' \<rparr> }
                  | _ \<Rightarrow> {}"

lemmas is_msg_defs =
  is_pkt_def is_newpkt_def

lemma is_msg_inv_ip [simp]:
  "\<xi>' \<in> is_pkt \<xi>    \<Longrightarrow> ip \<xi>' = ip \<xi>"
  "\<xi>' \<in> is_newpkt \<xi> \<Longrightarrow> ip \<xi>' = ip \<xi>"
  unfolding is_msg_defs
  by (cases "msg \<xi>", clarsimp+)+

lemma is_msg_inv_sip [simp]:
  "\<xi>' \<in> is_newpkt \<xi> \<Longrightarrow> sip \<xi>' = sip \<xi>"
  unfolding is_msg_defs
  by (cases "msg \<xi>", clarsimp+)+

lemma is_msg_inv_no [simp]:
  "\<xi>' \<in> is_pkt \<xi>    \<Longrightarrow> no \<xi>' = no \<xi>"
  "\<xi>' \<in> is_newpkt \<xi> \<Longrightarrow> no \<xi>' = no \<xi>"
  unfolding is_msg_defs
  by (cases "msg \<xi>", clarsimp+)+

lemma is_msg_inv_nhip [simp]:
  "\<xi>' \<in> is_pkt \<xi>    \<Longrightarrow> nhip \<xi>' = nhip \<xi>"
  "\<xi>' \<in> is_newpkt \<xi> \<Longrightarrow> nhip \<xi>' = nhip \<xi>"
  unfolding is_msg_defs
  by (cases "msg \<xi>", clarsimp+)+

lemma is_msg_inv_msg [simp]:
  "\<xi>' \<in> is_pkt \<xi>    \<Longrightarrow> msg \<xi>' = msg \<xi>"
  "\<xi>' \<in> is_newpkt \<xi> \<Longrightarrow> msg \<xi>' = msg \<xi>"
  unfolding is_msg_defs
  by (cases "msg \<xi>", clarsimp+)+

datatype pseqp =
    PToy

fun nat_of_seqp :: "pseqp \<Rightarrow> nat"
where
  "nat_of_seqp PToy = 1"

instantiation "pseqp" :: ord
begin
definition less_eq_seqp [iff]: "l1 \<le> l2 = (nat_of_seqp l1 \<le> nat_of_seqp l2)"
definition less_seqp [iff]:    "l1 < l2 = (nat_of_seqp l1 < nat_of_seqp l2)"
instance ..
end

abbreviation Toy
where
  "Toy \<equiv> \<lambda>_. \<lbrakk>clear_locals\<rbrakk> call(PToy)"

fun \<Gamma>\<^sub>T\<^sub>O\<^sub>Y :: "(state, msg, pseqp, pseqp label) seqp_env"
where
  "\<Gamma>\<^sub>T\<^sub>O\<^sub>Y PToy = labelled PToy (
     receive(\<lambda>msg' \<xi>. \<xi> \<lparr> msg := msg' \<rparr>).
     \<lbrakk>\<xi>. \<xi> \<lparr>nhip := ip \<xi>\<rparr>\<rbrakk>
     (   \<langle>is_newpkt\<rangle>
         (
             \<lbrakk>\<xi>. \<xi> \<lparr>no := max (no \<xi>) (num \<xi>)\<rparr>\<rbrakk>
             broadcast(\<lambda>\<xi>. pkt(no \<xi>, ip \<xi>)). Toy()
         )
       \<oplus> \<langle>is_pkt\<rangle>
       (
            \<langle>\<xi>. num \<xi> \<ge> no \<xi>\<rangle>
               \<lbrakk>\<xi>. \<xi> \<lparr>no := num \<xi>\<rparr>\<rbrakk>
               \<lbrakk>\<xi>. \<xi> \<lparr>nhip := sip \<xi>\<rparr>\<rbrakk>
               broadcast(\<lambda>\<xi>. pkt(no \<xi>, ip \<xi>)). Toy()
         \<oplus> \<langle>\<xi>. num \<xi> < no \<xi>\<rangle>
               Toy()
       )
     ))"

declare \<Gamma>\<^sub>T\<^sub>O\<^sub>Y.simps [simp del, code del]
lemmas \<Gamma>\<^sub>T\<^sub>O\<^sub>Y_simps [simp, code] = \<Gamma>\<^sub>T\<^sub>O\<^sub>Y.simps [simplified]

fun \<Gamma>\<^sub>T\<^sub>O\<^sub>Y_skeleton
where "\<Gamma>\<^sub>T\<^sub>O\<^sub>Y_skeleton PToy = seqp_skeleton (\<Gamma>\<^sub>T\<^sub>O\<^sub>Y PToy)"

lemma \<Gamma>\<^sub>T\<^sub>O\<^sub>Y_skeleton_wf [simp]:
  "wellformed \<Gamma>\<^sub>T\<^sub>O\<^sub>Y_skeleton"
  proof (rule, intro allI)
    fix pn pn'
    show "call(pn') \<notin> stermsl (\<Gamma>\<^sub>T\<^sub>O\<^sub>Y_skeleton pn)"
      by (cases pn) simp_all
  qed

declare \<Gamma>\<^sub>T\<^sub>O\<^sub>Y_skeleton.simps [simp del, code del]
lemmas \<Gamma>\<^sub>T\<^sub>O\<^sub>Y_skeleton_simps [simp, code] = \<Gamma>\<^sub>T\<^sub>O\<^sub>Y_skeleton.simps [simplified \<Gamma>\<^sub>T\<^sub>O\<^sub>Y_simps seqp_skeleton.simps]

lemma toy_proc_cases [dest]:
  fixes p pn
  assumes "p \<in> ctermsl (\<Gamma>\<^sub>T\<^sub>O\<^sub>Y pn)"
    shows "p \<in> ctermsl (\<Gamma>\<^sub>T\<^sub>O\<^sub>Y PToy)"
  using assms
  by (cases pn) simp_all

definition \<sigma>\<^sub>T\<^sub>O\<^sub>Y :: "ip \<Rightarrow> (state \<times> (state, msg, pseqp, pseqp label) seqp) set"
where "\<sigma>\<^sub>T\<^sub>O\<^sub>Y i \<equiv> {(toy_init i, \<Gamma>\<^sub>T\<^sub>O\<^sub>Y PToy)}"

abbreviation ptoy
  :: "ip \<Rightarrow> (state \<times> (state, msg, pseqp, pseqp label) seqp, msg seq_action) automaton"
where
  "ptoy i \<equiv> \<lparr> init = \<sigma>\<^sub>T\<^sub>O\<^sub>Y i, trans = seqp_sos \<Gamma>\<^sub>T\<^sub>O\<^sub>Y \<rparr>"

lemma toy_trans: "trans (ptoy i) = seqp_sos \<Gamma>\<^sub>T\<^sub>O\<^sub>Y"
  by simp

lemma toy_control_within [simp]: "control_within \<Gamma>\<^sub>T\<^sub>O\<^sub>Y (init (ptoy i))"
  unfolding \<sigma>\<^sub>T\<^sub>O\<^sub>Y_def by (rule control_withinI) (auto simp del: \<Gamma>\<^sub>T\<^sub>O\<^sub>Y_simps)

lemma toy_wf [simp]:
  "wellformed \<Gamma>\<^sub>T\<^sub>O\<^sub>Y"
  proof (rule, intro allI)
    fix pn pn'
    show "call(pn') \<notin> stermsl (\<Gamma>\<^sub>T\<^sub>O\<^sub>Y pn)"
      by (cases pn) simp_all
  qed

lemmas toy_labels_not_empty [simp] = labels_not_empty [OF toy_wf]

lemma toy_ex_label [intro]: "\<exists>l. l\<in>labels \<Gamma>\<^sub>T\<^sub>O\<^sub>Y p"
  by (metis toy_labels_not_empty all_not_in_conv)

lemma toy_ex_labelE [elim]:
  assumes "\<forall>l\<in>labels \<Gamma>\<^sub>T\<^sub>O\<^sub>Y p. P l p"
      and "\<exists>p l. P l p \<Longrightarrow> Q"
    shows "Q"
 using assms by (metis toy_ex_label)

lemma toy_simple_labels [simp]: "simple_labels \<Gamma>\<^sub>T\<^sub>O\<^sub>Y"
  proof
    fix pn p
    assume "p\<in>subterms(\<Gamma>\<^sub>T\<^sub>O\<^sub>Y pn)"
    thus "\<exists>!l. labels \<Gamma>\<^sub>T\<^sub>O\<^sub>Y p = {l}"
    by (cases pn) (simp_all cong: seqp_congs | elim disjE)+
  qed

lemma \<sigma>\<^sub>T\<^sub>O\<^sub>Y_labels [simp]: "(\<xi>, p) \<in> \<sigma>\<^sub>T\<^sub>O\<^sub>Y i \<Longrightarrow>  labels \<Gamma>\<^sub>T\<^sub>O\<^sub>Y p = {PToy-:0}"
  unfolding \<sigma>\<^sub>T\<^sub>O\<^sub>Y_def by simp

text \<open>By default, we no longer let the simplifier descend into process terms.\<close>

declare seqp_congs [cong]

(* configure the inv_cterms tactic *)
declare
  \<Gamma>\<^sub>T\<^sub>O\<^sub>Y_simps [cterms_env]
  toy_proc_cases [ctermsl_cases]
  seq_invariant_ctermsI [OF toy_wf toy_control_within toy_simple_labels toy_trans, cterms_intros]
  seq_step_invariant_ctermsI [OF toy_wf toy_control_within toy_simple_labels toy_trans, cterms_intros]

subsection "Define an open version of the protocol"

definition \<sigma>\<^sub>O\<^sub>T\<^sub>O\<^sub>Y :: "((ip \<Rightarrow> state) \<times> ((state, msg, pseqp, pseqp label) seqp)) set"
where "\<sigma>\<^sub>O\<^sub>T\<^sub>O\<^sub>Y \<equiv> {(toy_init, \<Gamma>\<^sub>T\<^sub>O\<^sub>Y PToy)}"

abbreviation optoy
  :: "ip \<Rightarrow> ((ip \<Rightarrow> state) \<times> (state, msg, pseqp, pseqp label) seqp, msg seq_action) automaton"
where
  "optoy i \<equiv> \<lparr> init = \<sigma>\<^sub>O\<^sub>T\<^sub>O\<^sub>Y, trans = oseqp_sos \<Gamma>\<^sub>T\<^sub>O\<^sub>Y i \<rparr>"

lemma initiali_toy [intro!, simp]: "initiali i (init (optoy i)) (init (ptoy i))"
  unfolding \<sigma>\<^sub>T\<^sub>O\<^sub>Y_def \<sigma>\<^sub>O\<^sub>T\<^sub>O\<^sub>Y_def by rule simp_all

lemma oaodv_control_within [simp]: "control_within \<Gamma>\<^sub>T\<^sub>O\<^sub>Y (init (optoy i))"
  unfolding \<sigma>\<^sub>O\<^sub>T\<^sub>O\<^sub>Y_def by (rule control_withinI) (auto simp del: \<Gamma>\<^sub>T\<^sub>O\<^sub>Y_simps)

lemma \<sigma>\<^sub>O\<^sub>T\<^sub>O\<^sub>Y_labels [simp]: "(\<sigma>, p) \<in> \<sigma>\<^sub>O\<^sub>T\<^sub>O\<^sub>Y \<Longrightarrow>  labels \<Gamma>\<^sub>T\<^sub>O\<^sub>Y p = {PToy-:0}"
  unfolding \<sigma>\<^sub>O\<^sub>T\<^sub>O\<^sub>Y_def by simp

lemma otoy_trans: "trans (optoy i) = oseqp_sos \<Gamma>\<^sub>T\<^sub>O\<^sub>Y i"
  by simp

(* configure the inv_cterms tactic *)
declare
  oseq_invariant_ctermsI [OF toy_wf oaodv_control_within toy_simple_labels otoy_trans, cterms_intros]
  oseq_step_invariant_ctermsI [OF toy_wf oaodv_control_within toy_simple_labels otoy_trans, cterms_intros]

subsection "Predicates"

definition msg_sender :: "msg \<Rightarrow> ip"
where "msg_sender m \<equiv> case m of Pkt _ ipc \<Rightarrow> ipc"

lemma msg_sender_simps [simp]:
  "\<And>d dip sip. msg_sender (Pkt d sip) = sip"
  unfolding msg_sender_def by simp_all

abbreviation not_Pkt :: "msg \<Rightarrow> bool"
where "not_Pkt m \<equiv> case m of Pkt _ _ \<Rightarrow> False | _ \<Rightarrow> True"

definition nos_increase :: "state \<Rightarrow> state \<Rightarrow> bool"
where "nos_increase \<xi> \<xi>' \<equiv> (no \<xi> \<le> no \<xi>')"

definition msg_num_ok :: "(ip \<Rightarrow> state) \<Rightarrow> msg \<Rightarrow> bool"
where "msg_num_ok \<sigma> m \<equiv> case m of Pkt num' sip' \<Rightarrow> num' \<le> no (\<sigma> sip') | _ \<Rightarrow> True"

lemma msg_num_okI [intro]:
  assumes "\<And>num' sip'. m = Pkt num' sip' \<Longrightarrow> num' \<le> no (\<sigma> sip')"
    shows "msg_num_ok \<sigma> m"
  using assms unfolding msg_num_ok_def
  by (auto split: msg.split)

lemma msg_num_ok_Pkt [simp]:
  "msg_num_ok \<sigma> (Pkt data src) = (data \<le> no (\<sigma> src))"
  unfolding msg_num_ok_def by simp

lemma msg_num_ok_pkt [simp]:
  "msg_num_ok \<sigma> (pkt(data, src)) = (data \<le> no (\<sigma> src))"
  unfolding msg_num_ok_def by simp

lemma msg_num_ok_Newpkt [simp]:
  "msg_num_ok \<sigma> (Newpkt data dst)"
  unfolding msg_num_ok_def by simp

lemma msg_num_ok_newpkt [simp]:
  "msg_num_ok \<sigma> (newpkt(data, dst))"
  unfolding msg_num_ok_def by simp

subsection "Sequential Invariants"

lemma seq_no_leq_num:
  "ptoy i \<TTurnstile> onl \<Gamma>\<^sub>T\<^sub>O\<^sub>Y (\<lambda>(\<xi>, l). l\<in>{PToy-:7..PToy-:9} \<longrightarrow> no \<xi> \<le> num \<xi>)"
  by inv_cterms

lemma seq_nos_increases:
  "ptoy i \<TTurnstile>\<^sub>A onll \<Gamma>\<^sub>T\<^sub>O\<^sub>Y (\<lambda>((\<xi>, _), _, (\<xi>', _)). nos_increase \<xi> \<xi>')"
  unfolding nos_increase_def
  proof -
    show "ptoy i \<TTurnstile>\<^sub>A onll \<Gamma>\<^sub>T\<^sub>O\<^sub>Y (\<lambda>((\<xi>, _), _, (\<xi>', _)). no \<xi> \<le> no \<xi>')"
      by (inv_cterms inv add: onl_invariant_sterms [OF toy_wf seq_no_leq_num])
  qed

lemma seq_nos_increases':
  "ptoy i \<TTurnstile>\<^sub>A (\<lambda>((\<xi>, _), _, (\<xi>', _)). nos_increase \<xi> \<xi>')"
  by (rule step_invariant_weakenE [OF seq_nos_increases]) (auto dest!: onllD)

lemma sender_ip_valid:
  "ptoy i \<TTurnstile>\<^sub>A onll \<Gamma>\<^sub>T\<^sub>O\<^sub>Y (\<lambda>((\<xi>, _), a, _). anycast (\<lambda>m. msg_sender m = ip \<xi>) a)"
  by inv_cterms

lemma ip_constant:
  "ptoy i \<TTurnstile> onl \<Gamma>\<^sub>T\<^sub>O\<^sub>Y (\<lambda>(\<xi>, _). ip \<xi> = i)"
  by inv_cterms (simp add: \<sigma>\<^sub>T\<^sub>O\<^sub>Y_def)

lemma nhip_eq_ip:
  "ptoy i \<TTurnstile> onl \<Gamma>\<^sub>T\<^sub>O\<^sub>Y (\<lambda>(\<xi>, l). l\<in>{PToy-:2..PToy-:8} \<longrightarrow> nhip \<xi> = ip \<xi>)"
  by inv_cterms

lemma seq_msg_num_ok:
  "ptoy i \<TTurnstile>\<^sub>A onll \<Gamma>\<^sub>T\<^sub>O\<^sub>Y (\<lambda>((\<xi>, _), a, _).
                anycast (\<lambda>m. case m of Pkt num' sip' \<Rightarrow> num' = no \<xi> \<and> sip' = i | _ \<Rightarrow> True) a)"
  by (inv_cterms inv add: onl_invariant_sterms [OF toy_wf ip_constant])

lemma nhip_eq_i:
  "ptoy i \<TTurnstile> onl \<Gamma>\<^sub>T\<^sub>O\<^sub>Y (\<lambda>(\<xi>, l). l\<in>{PToy-:2..PToy-:8} \<longrightarrow> nhip \<xi> = i)"
  proof (rule invariant_arbitraryI, clarify intro!: onlI impI)
    fix \<xi> p l n
    assume "(\<xi>, p) \<in> reachable (ptoy i) TT"
       and "l \<in> labels \<Gamma>\<^sub>T\<^sub>O\<^sub>Y p"
       and "l \<in> {PToy-:2..PToy-:8}"
    from this(1-3) have "nhip \<xi> = ip \<xi>"
      by - (drule invariantD [OF nhip_eq_ip], auto)
    moreover with \<open>(\<xi>, p) \<in> reachable (ptoy i) TT\<close> and \<open>l \<in> labels \<Gamma>\<^sub>T\<^sub>O\<^sub>Y p\<close> have "ip \<xi> = i"
      by (auto dest: invariantD [OF ip_constant])
    ultimately show "nhip \<xi> = i"
      by simp
  qed

subsection "Global Invariants"

lemma nos_increaseD [dest]:
  assumes "nos_increase \<xi> \<xi>'"
    shows "no \<xi> \<le> no \<xi>'"
  using assms unfolding nos_increase_def .

lemma nos_increase_simp [simp]:
  "nos_increase \<xi> \<xi>' = (no \<xi> \<le> no \<xi>')"
  using assms unfolding nos_increase_def ..

lemmas oseq_nos_increases =
  open_seq_step_invariant [OF seq_nos_increases initiali_toy otoy_trans toy_trans,
                           simplified seqll_onll_swap]

lemmas oseq_no_leq_num =
  open_seq_invariant [OF seq_no_leq_num initiali_toy otoy_trans toy_trans,
                      simplified seql_onl_swap]

lemma all_nos_increase:
  shows "optoy i \<Turnstile>\<^sub>A (otherwith nos_increase {i} S,
                      other nos_increase {i} \<rightarrow>)
                       onll \<Gamma>\<^sub>T\<^sub>O\<^sub>Y (\<lambda>((\<sigma>, _), a, (\<sigma>', _)). (\<forall>j. nos_increase (\<sigma> j) (\<sigma>' j)))"
  proof -
    have *: "\<And>\<sigma> \<sigma>' a. \<lbrakk> otherwith nos_increase {i} S \<sigma> \<sigma>' a; no (\<sigma> i) \<le> no (\<sigma>' i) \<rbrakk>
                       \<Longrightarrow> \<forall>j. no (\<sigma> j) \<le> no (\<sigma>' j)"
      by (auto dest!: otherwith_syncD)
    show ?thesis
      by (inv_cterms
            inv add: oseq_step_invariant_sterms [OF oseq_nos_increases [THEN oinvariant_step_anyact]
                                                                                toy_wf otoy_trans]
            simp add: seqllsimp) (auto elim!: *)
  qed

lemma oreceived_msg_inv:
  assumes other: "\<And>\<sigma> \<sigma>' m. \<lbrakk> P \<sigma> m; other Q {i} \<sigma> \<sigma>' \<rbrakk> \<Longrightarrow> P \<sigma>' m"
      and local: "\<And>\<sigma> m. P \<sigma> m \<Longrightarrow> P (\<sigma>(i := \<sigma> i\<lparr>msg := m\<rparr>)) m"
    shows "optoy i \<Turnstile> (otherwith Q {i} (orecvmsg P), other Q {i} \<rightarrow>)
                       onl \<Gamma>\<^sub>T\<^sub>O\<^sub>Y (\<lambda>(\<sigma>, l). l \<in> {PToy-:1} \<longrightarrow> P \<sigma> (msg (\<sigma> i)))"
  proof (inv_cterms, intro impI)
    fix \<sigma> \<sigma>' l
    assume "l = PToy-:1 \<longrightarrow> P \<sigma> (msg (\<sigma> i))"
       and "l = PToy-:1"
       and "other Q {i} \<sigma> \<sigma>'"
    from this(1-2) have "P \<sigma> (msg (\<sigma> i))" ..
    hence "P \<sigma>' (msg (\<sigma> i))" using \<open>other Q {i} \<sigma> \<sigma>'\<close>
      by (rule other)
    moreover from \<open>other Q {i} \<sigma> \<sigma>'\<close> have "\<sigma>' i = \<sigma> i" ..
    ultimately show "P \<sigma>' (msg (\<sigma>' i))" by simp
  next
    fix \<sigma> \<sigma>' msg
    assume "otherwith Q {i} (orecvmsg P) \<sigma> \<sigma>' (receive msg)"
       and "\<sigma>' i = \<sigma> i\<lparr>msg := msg\<rparr>"
    from this(1) have "P \<sigma> msg"
                 and "\<forall>j. j\<noteq>i \<longrightarrow> Q (\<sigma> j) (\<sigma>' j)" by auto
    from this(1) have "P (\<sigma>(i := \<sigma> i\<lparr>msg := msg\<rparr>)) msg" by (rule local)
    thus "P \<sigma>' msg"
    proof (rule other)
      from \<open>\<sigma>' i = \<sigma> i\<lparr>msg := msg\<rparr>\<close> and \<open>\<forall>j. j\<noteq>i \<longrightarrow> Q (\<sigma> j) (\<sigma>' j)\<close>
        show "other Q {i} (\<sigma>(i := \<sigma> i\<lparr>msg := msg\<rparr>)) \<sigma>'"
          by - (rule otherI, auto)
    qed
  qed

lemma msg_num_ok_other_nos_increase [elim]:
  assumes "msg_num_ok \<sigma> m"
      and "other nos_increase {i} \<sigma> \<sigma>'"
    shows "msg_num_ok \<sigma>' m"
  proof (cases m)
    fix num sip
    assume "m = Pkt num sip"
    with \<open>msg_num_ok \<sigma> m\<close> have "num \<le> no (\<sigma> sip)" by simp
    also from \<open>other nos_increase {i} \<sigma> \<sigma>'\<close> have "no (\<sigma> sip) \<le> no (\<sigma>' sip)"
      by (rule otherE) (metis eq_iff nos_increaseD)
    finally have "num \<le> no (\<sigma>' sip)" .
    with \<open>m = Pkt num sip\<close> show ?thesis
      by simp
  qed simp

lemma msg_num_ok_no_leq_no [simp, elim]:
  assumes "msg_num_ok \<sigma> m"
      and "\<forall>j. no (\<sigma> j) \<le> no (\<sigma>' j)"
    shows "msg_num_ok \<sigma>' m"
  using assms(1) proof (cases m)
    fix num sip
    assume "m = Pkt num sip"
    with \<open>msg_num_ok \<sigma> m\<close> have "num \<le> no (\<sigma> sip)" by simp
    also from \<open>\<forall>j. no (\<sigma> j) \<le> no (\<sigma>' j)\<close> have "no (\<sigma> sip) \<le> no (\<sigma>' sip)"
      by simp
    finally have "num \<le> no (\<sigma>' sip)" .
    with \<open>m = Pkt num sip\<close> show ?thesis
      by simp
  qed (simp add: assms(1))

lemma oreceived_msg_num_ok:
  "optoy i \<Turnstile> (otherwith nos_increase {i} (orecvmsg msg_num_ok),
               other nos_increase {i} \<rightarrow>)
              onl \<Gamma>\<^sub>T\<^sub>O\<^sub>Y (\<lambda>(\<sigma>, l). l\<in>{PToy-:1..} \<longrightarrow> msg_num_ok \<sigma> (msg (\<sigma> i)))"
  (is "_ \<Turnstile> (?S, ?U \<rightarrow>) _")
  proof (inv_cterms inv add: oseq_step_invariant_sterms [OF all_nos_increase toy_wf otoy_trans],
         intro impI, elim impE)
    fix \<sigma> \<sigma>'
    assume "msg_num_ok \<sigma> (msg (\<sigma> i))"
       and "other nos_increase {i} \<sigma> \<sigma>'"
    moreover from this(2) have "msg (\<sigma>' i) = msg (\<sigma> i)"
      by (clarsimp elim!: otherE)
    ultimately show "msg_num_ok \<sigma>' (msg (\<sigma>' i))"
      by (auto)
  next
    fix p l \<sigma> a q l' \<sigma>' pp p' m
    assume a1: "(\<sigma>', p') \<in> oreachable (optoy i) ?S ?U"
       and a2: "PToy-:1 \<in> labels \<Gamma>\<^sub>T\<^sub>O\<^sub>Y p'"
       and a3: "\<sigma>' i = \<sigma> i\<lparr>msg := m\<rparr>"
    have inv: "optoy i \<Turnstile> (?S, ?U \<rightarrow>) onl \<Gamma>\<^sub>T\<^sub>O\<^sub>Y (\<lambda>(\<sigma>, l). l \<in> {PToy-:1} \<longrightarrow> msg_num_ok \<sigma> (msg (\<sigma> i)))"
    proof (rule oreceived_msg_inv)
      fix \<sigma> \<sigma>' m
      assume "msg_num_ok \<sigma> m"
         and "other nos_increase {i} \<sigma> \<sigma>'"
      thus "msg_num_ok \<sigma>' m" ..
    next
      fix \<sigma> m
      assume "msg_num_ok \<sigma> m"
      thus "msg_num_ok (\<sigma>(i := \<sigma> i\<lparr>msg := m\<rparr>)) m"
        by (cases m) auto
    qed
    from a1 a2 a3 show "msg_num_ok \<sigma>' m"
      by (clarsimp dest!: oinvariantD [OF inv] onlD)
  qed simp

lemma is_pkt_handler_num_leq_no:
  shows "optoy i \<Turnstile> (otherwith nos_increase {i} (orecvmsg msg_num_ok),
                      other nos_increase {i} \<rightarrow>)
                    onl \<Gamma>\<^sub>T\<^sub>O\<^sub>Y (\<lambda>(\<sigma>, l). l\<in>{PToy-:6..PToy-:10} \<longrightarrow> num (\<sigma> i) \<le> no (\<sigma> (sip (\<sigma> i))))"
  proof -
    { fix \<sigma> \<sigma>'
      assume "\<forall>j. no (\<sigma> j) \<le> no (\<sigma>' j)"
         and "num (\<sigma> i) \<le> no (\<sigma> (sip (\<sigma> i)))"
      have "num (\<sigma> i) \<le> no (\<sigma>' (sip (\<sigma> i)))"
      proof -
        note \<open>num (\<sigma> i) \<le> no (\<sigma> (sip (\<sigma> i)))\<close>
        also from \<open>\<forall>j. no (\<sigma> j) \<le> no (\<sigma>' j)\<close> have "no (\<sigma> (sip (\<sigma> i))) \<le> no (\<sigma>' (sip (\<sigma> i)))"
          by auto
        finally show ?thesis .
      qed
    } note solve_step = this
    show ?thesis
    proof (inv_cterms inv add: oseq_step_invariant_sterms [OF all_nos_increase toy_wf otoy_trans]
                               onl_oinvariant_sterms [OF toy_wf oreceived_msg_num_ok]
                        solve: solve_step, intro impI, elim impE)
      fix \<sigma> \<sigma>'
      assume *: "num (\<sigma> i) \<le> no (\<sigma> (sip (\<sigma> i)))"
         and "other nos_increase {i} \<sigma> \<sigma>'"
      from this(2) obtain "\<forall>i\<in>{i}. \<sigma>' i = \<sigma> i"
                      and "\<forall>j. j \<notin> {i} \<longrightarrow> nos_increase (\<sigma> j) (\<sigma>' j)" ..
      show "num (\<sigma>' i) \<le> no (\<sigma>' (sip (\<sigma>' i)))"
      proof (cases "sip (\<sigma> i) = i")
        assume "sip (\<sigma> i) = i"
        with * \<open>\<forall>i\<in>{i}. \<sigma>' i = \<sigma> i\<close>
        show ?thesis by simp
      next
        assume "sip (\<sigma> i) \<noteq> i"
        with \<open>\<forall>j. j \<notin> {i} \<longrightarrow> nos_increase (\<sigma> j) (\<sigma>' j)\<close>
          have "no (\<sigma> (sip (\<sigma> i))) \<le> no (\<sigma>' (sip (\<sigma> i)))" by simp
        with * \<open>\<forall>i\<in>{i}. \<sigma>' i = \<sigma> i\<close>
        show ?thesis by simp
      qed
    next
      fix p l \<sigma> a q l' \<sigma>' pp p'
      assume "msg_num_ok \<sigma> (msg (\<sigma> i))"
         and "\<forall>j. no (\<sigma> j) \<le> no (\<sigma>' j)"
         and "\<sigma>' i \<in> is_pkt (\<sigma> i)"
      show "num (\<sigma>' i) \<le> no (\<sigma>' (sip (\<sigma>' i)))"
      proof (cases "msg (\<sigma> i)")
        fix num' sip'
        assume "msg (\<sigma> i) = Pkt num' sip'"
        with \<open>\<sigma>' i \<in> is_pkt (\<sigma> i)\<close> obtain "num (\<sigma>' i) = num'"
                                      and "sip (\<sigma>' i) = sip'"
          unfolding is_pkt_def by auto
        with \<open>msg (\<sigma> i) = Pkt num' sip'\<close> and \<open>msg_num_ok \<sigma> (msg (\<sigma> i))\<close>
          have "num (\<sigma>' i) \<le> no (\<sigma> (sip (\<sigma>' i)))"
            by simp
        also from \<open>\<forall>j. no (\<sigma> j) \<le> no (\<sigma>' j)\<close> have "no (\<sigma> (sip (\<sigma>' i))) \<le> no (\<sigma>' (sip (\<sigma>' i)))" ..
        finally show ?thesis .
      next
        fix num' sip'
        assume "msg (\<sigma> i) = Newpkt num' sip'"
        with \<open>\<sigma>' i \<in> is_pkt (\<sigma> i)\<close> have False
          unfolding is_pkt_def by simp
        thus ?thesis ..
      qed
    qed
  qed

lemmas oseq_ip_constant =
  open_seq_invariant [OF ip_constant initiali_toy otoy_trans toy_trans,
                      simplified seql_onl_swap]

lemmas oseq_nhip_eq_i =
  open_seq_invariant [OF nhip_eq_i initiali_toy otoy_trans toy_trans,
                      simplified seql_onl_swap]

lemmas oseq_nhip_eq_ip =
  open_seq_invariant [OF nhip_eq_ip initiali_toy otoy_trans toy_trans,
                      simplified seql_onl_swap]

lemma oseq_bigger_than_next:
  shows "optoy i \<Turnstile> (otherwith nos_increase {i} (orecvmsg msg_num_ok),
                      other nos_increase {i} \<rightarrow>) global (\<lambda>\<sigma>. no (\<sigma> i) \<le> no (\<sigma> (nhip (\<sigma> i))))"
    (is "_ \<Turnstile> (?S, ?U \<rightarrow>) ?P")
  proof -
    have nhipinv: "optoy i \<Turnstile> (?S, ?U \<rightarrow>)
                              onl \<Gamma>\<^sub>T\<^sub>O\<^sub>Y (\<lambda>(\<sigma>, l). l\<in>{PToy-:2..PToy-:8}
                                                    \<longrightarrow> nhip (\<sigma> i) = ip (\<sigma> i))"
      by (rule oinvariant_weakenE [OF oseq_nhip_eq_ip]) (auto simp: seqlsimp)
    have ipinv: "optoy i \<Turnstile> (?S, ?U \<rightarrow>) onl \<Gamma>\<^sub>T\<^sub>O\<^sub>Y (\<lambda>(\<sigma>, l). ip (\<sigma> i) = i)"
      by (rule oinvariant_weakenE [OF oseq_ip_constant]) (auto simp: seqlsimp)
    { fix \<sigma> \<sigma>' a
      assume "no (\<sigma> i) \<le> no (\<sigma> (nhip (\<sigma> i)))"
         and "\<forall>j. nos_increase (\<sigma> j) (\<sigma>' j)"
      note this(1)
      also from \<open>\<forall>j. nos_increase (\<sigma> j) (\<sigma>' j)\<close> have "no (\<sigma> (nhip (\<sigma> i))) \<le> no (\<sigma>' (nhip (\<sigma> i)))"
        by auto
      finally have "no (\<sigma> i) \<le> no (\<sigma>' (nhip (\<sigma> i)))" ..
    } note * = this
    have "optoy i \<Turnstile> (otherwith nos_increase {i} (orecvmsg msg_num_ok),
                      other nos_increase {i} \<rightarrow>)
                     onl \<Gamma>\<^sub>T\<^sub>O\<^sub>Y (\<lambda>(\<sigma>, l). no (\<sigma> i) \<le> no (\<sigma> (nhip (\<sigma> i))))"
    proof (inv_cterms
             inv add: onl_oinvariant_sterms [OF toy_wf oseq_no_leq_num [THEN oinvariant_anyact]]
                      oseq_step_invariant_sterms [OF all_nos_increase toy_wf otoy_trans]
                      onl_oinvariant_sterms [OF toy_wf is_pkt_handler_num_leq_no]
                      onl_oinvariant_sterms [OF toy_wf nhipinv]
                      onl_oinvariant_sterms [OF toy_wf ipinv]
             simp add: seqlsimp seqllsimp
             simp del: nos_increase_simp
                solve: *)
      fix \<sigma> p l
      assume "(\<sigma>, p) \<in> \<sigma>\<^sub>O\<^sub>T\<^sub>O\<^sub>Y"
      thus "no (\<sigma> i) \<le> no (\<sigma> (nhip (\<sigma> i)))"
        by (simp add: \<sigma>\<^sub>O\<^sub>T\<^sub>O\<^sub>Y_def)
    next
      fix \<sigma> \<sigma>' p l
      assume or: "(\<sigma>, p) \<in> oreachable (optoy i) ?S ?U"
         and "l \<in> labels \<Gamma>\<^sub>T\<^sub>O\<^sub>Y p"
         and "no (\<sigma> i) \<le> no (\<sigma> (nhip (\<sigma> i)))"
         and "other nos_increase {i} \<sigma> \<sigma>'"
      show "no (\<sigma>' i) \<le> no (\<sigma>' (nhip (\<sigma>' i)))"
      proof (cases "nhip (\<sigma>' i) = i")
        assume "nhip (\<sigma>' i) = i"
        with \<open>no (\<sigma> i) \<le> no (\<sigma> (nhip (\<sigma> i)))\<close> show ?thesis
          by simp
      next
        assume "nhip (\<sigma>' i) \<noteq> i"
        moreover from \<open>other nos_increase {i} \<sigma> \<sigma>'\<close> [THEN other_localD] have "\<sigma>' i = \<sigma> i"
          by simp
        ultimately have "no (\<sigma> (nhip (\<sigma> i))) \<le> no (\<sigma>' (nhip (\<sigma>' i)))"
          using \<open>other nos_increase {i} \<sigma> \<sigma>'\<close> and \<open>\<sigma>' i = \<sigma> i\<close> by (auto)
        with \<open>no (\<sigma> i) \<le> no (\<sigma> (nhip (\<sigma> i)))\<close> and \<open>\<sigma>' i = \<sigma> i\<close> show ?thesis
          by simp
      qed
    next
      fix p l \<sigma> a q l' \<sigma>' pp p'
      assume "no (\<sigma> i) \<le> num (\<sigma> i)"
         and "num (\<sigma> i) \<le> no (\<sigma> (sip (\<sigma> i)))"
         and "\<forall>j. nos_increase (\<sigma> j) (\<sigma>' j)"
      from this(1-2) have "no (\<sigma> i) \<le> no (\<sigma> (sip (\<sigma> i)))"
        by (rule le_trans)
      also from \<open>\<forall>j. nos_increase (\<sigma> j) (\<sigma>' j)\<close>
        have "no (\<sigma> (sip (\<sigma> i))) \<le> no (\<sigma>' (sip (\<sigma> i)))"
          by auto
      finally show "no (\<sigma> i) \<le> no (\<sigma>' (sip (\<sigma> i)))" ..
    qed
    thus ?thesis
      by (rule oinvariant_weakenE)
         (auto simp: onl_def)
  qed

lemma anycast_weakenE [elim]:
  assumes "anycast P a"
      and "\<And>m. P m \<Longrightarrow> Q m"
  shows "anycast Q a"
  using assms unfolding anycast_def
  by (auto split: seq_action.split)

lemma oseq_msg_num_ok:
  "optoy i \<Turnstile>\<^sub>A (act TT, other U {i} \<rightarrow>) globala (\<lambda>(\<sigma>, a, _). anycast (msg_num_ok \<sigma>) a)"
  by (rule ostep_invariant_weakenE [OF open_seq_step_invariant
            [OF seq_msg_num_ok initiali_toy otoy_trans toy_trans, simplified seql_onl_swap]])
     (auto simp: seqllsimp dest!: onllD elim!: anycast_weakenE intro!: msg_num_okI)

subsection "Lifting"

lemma opar_bigger_than_next:
  shows "optoy i \<langle>\<langle>\<^bsub>i\<^esub> qmsg \<Turnstile> (otherwith nos_increase {i} (orecvmsg msg_num_ok),
                      other nos_increase {i} \<rightarrow>) global (\<lambda>\<sigma>. no (\<sigma> i) \<le> no (\<sigma> (nhip (\<sigma> i))))"
  proof (rule lift_into_qmsg [OF oseq_bigger_than_next])
    fix \<sigma> \<sigma>' m
    assume "\<forall>j. nos_increase (\<sigma> j) (\<sigma>' j)"
       and "msg_num_ok \<sigma> m"
    from this(2) show "msg_num_ok \<sigma>' m"
    proof (cases m, simp only: msg_num_ok_Pkt)
      fix num' sip'
      assume "num' \<le> no (\<sigma> sip')"
      also from \<open>\<forall>j. nos_increase (\<sigma> j) (\<sigma>' j)\<close> have "no (\<sigma> sip') \<le> no (\<sigma>' sip')"
        by simp
      finally show "num' \<le> no (\<sigma>' sip')" .
    qed simp
  next
    show "optoy i \<Turnstile>\<^sub>A (otherwith nos_increase {i} (orecvmsg msg_num_ok), other nos_increase {i} \<rightarrow>)
                      globala (\<lambda>(\<sigma>, _, \<sigma>'). nos_increase (\<sigma> i) (\<sigma>' i))"
      by (rule ostep_invariant_weakenE [OF open_seq_step_invariant
                                         [OF seq_nos_increases initiali_toy otoy_trans toy_trans]])
         (auto simp: seqllsimp dest!: onllD)
  qed simp

lemma onode_bigger_than_next:
  "\<langle>i : optoy i \<langle>\<langle>\<^bsub>i\<^esub> qmsg : R\<^sub>i\<rangle>\<^sub>o
     \<Turnstile> (otherwith nos_increase {i} (oarrivemsg msg_num_ok), other nos_increase {i} \<rightarrow>)
        global (\<lambda>\<sigma>. no (\<sigma> i) \<le> no (\<sigma> (nhip (\<sigma> i))))"
  by (rule node_lift [OF opar_bigger_than_next])

lemma node_local_nos_increase:
  "\<langle>i : optoy 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>, _, \<sigma>'). nos_increase (\<sigma> i) (\<sigma>' i))"
  proof (rule node_lift_step_statelessassm)
    have "optoy i \<Turnstile>\<^sub>A (\<lambda>\<sigma> _. orecvmsg (\<lambda>_ _. True) \<sigma>, other (\<lambda>_ _. True) {i} \<rightarrow>)
                      globala (\<lambda>(\<sigma>, _, \<sigma>'). nos_increase (\<sigma> i) (\<sigma>' i))"
      by (rule ostep_invariant_weakenE [OF oseq_nos_increases])
         (auto simp: seqllsimp dest!: onllD)
    thus "optoy i \<langle>\<langle>\<^bsub>i\<^esub> qmsg \<Turnstile>\<^sub>A (\<lambda>\<sigma> _. orecvmsg (\<lambda>_ _. True) \<sigma>, other (\<lambda>_ _. True) {i} \<rightarrow>)
                                globala (\<lambda>(\<sigma>, _, \<sigma>'). nos_increase (\<sigma> i) (\<sigma>' i))"
      by (rule lift_step_into_qmsg_statelessassm) auto
  qed simp

lemma opnet_bigger_than_next:
  "opnet (\<lambda>i. optoy i \<langle>\<langle>\<^bsub>i\<^esub> qmsg) n
     \<Turnstile> (otherwith nos_increase (net_tree_ips n) (oarrivemsg msg_num_ok),
         other nos_increase (net_tree_ips n) \<rightarrow>)
        global (\<lambda>\<sigma>. \<forall>i\<in>net_tree_ips n. no (\<sigma> i) \<le> no (\<sigma> (nhip (\<sigma> i))))"
  proof (rule pnet_lift [OF onode_bigger_than_next])
    fix i R\<^sub>i
    have "\<langle>i : optoy i \<langle>\<langle>\<^bsub>i\<^esub> qmsg : R\<^sub>i\<rangle>\<^sub>o \<Turnstile>\<^sub>A (\<lambda>\<sigma> _. oarrivemsg msg_num_ok \<sigma>, other (\<lambda>_ _. True) {i} \<rightarrow>)
                                            globala (\<lambda>(\<sigma>, a, _). castmsg (msg_num_ok \<sigma>) a)"
    proof (rule node_lift_anycast_statelessassm)
      have "optoy i \<Turnstile>\<^sub>A (\<lambda>\<sigma> _. orecvmsg (\<lambda>_ _. True) \<sigma>, other (\<lambda>_ _. True) {i} \<rightarrow>)
                        globala (\<lambda>(\<sigma>, a, _). anycast (msg_num_ok \<sigma>) a)"
        by (rule ostep_invariant_weakenE [OF oseq_msg_num_ok]) auto
      hence "optoy i \<langle>\<langle>\<^bsub>i\<^esub> qmsg \<Turnstile>\<^sub>A (\<lambda>\<sigma> _. orecvmsg (\<lambda>_ _. True) \<sigma>, other (\<lambda>_ _. True) {i} \<rightarrow>)
                                   globala (\<lambda>(\<sigma>, a, _). anycast (msg_num_ok \<sigma>) a)"
        by (rule lift_step_into_qmsg_statelessassm) auto
      thus "optoy i \<langle>\<langle>\<^bsub>i\<^esub> qmsg \<Turnstile>\<^sub>A (\<lambda>\<sigma> _. orecvmsg msg_num_ok \<sigma>, other (\<lambda>_ _. True) {i} \<rightarrow>)
                                  globala (\<lambda>(\<sigma>, a, _). anycast (msg_num_ok \<sigma>) a)"
        by (rule ostep_invariant_weakenE) auto
    qed
    thus "\<langle>i : optoy i \<langle>\<langle>\<^bsub>i\<^esub> qmsg : R\<^sub>i\<rangle>\<^sub>o \<Turnstile>\<^sub>A (\<lambda>\<sigma> _. oarrivemsg msg_num_ok \<sigma>, other nos_increase {i} \<rightarrow>)
                                            globala (\<lambda>(\<sigma>, a, _). castmsg (msg_num_ok \<sigma>) a)"
      by (rule ostep_invariant_weakenE) auto
  next
    fix i R\<^sub>i
    show "\<langle>i : optoy i \<langle>\<langle>\<^bsub>i\<^esub> qmsg : R\<^sub>i\<rangle>\<^sub>o \<Turnstile>\<^sub>A (\<lambda>\<sigma> _. oarrivemsg msg_num_ok \<sigma>,
                                            other nos_increase {i} \<rightarrow>)
             globala (\<lambda>(\<sigma>, a, \<sigma>'). a \<noteq> \<tau> \<and> (\<forall>i d. a \<noteq> i:deliver(d)) \<longrightarrow> nos_increase (\<sigma> i) (\<sigma>' i))"
      by (rule ostep_invariant_weakenE [OF node_local_nos_increase]) auto
  next
    fix i R
    show "\<langle>i : optoy i \<langle>\<langle>\<^bsub>i\<^esub> qmsg : R\<rangle>\<^sub>o \<Turnstile>\<^sub>A (\<lambda>\<sigma> _. oarrivemsg msg_num_ok \<sigma>,
                                           other nos_increase {i} \<rightarrow>)
             globala (\<lambda>(\<sigma>, a, \<sigma>'). a = \<tau> \<or> (\<exists>d. a = i:deliver(d)) \<longrightarrow> nos_increase (\<sigma> i) (\<sigma>' i))"
      by (rule ostep_invariant_weakenE [OF node_local_nos_increase]) auto
  qed simp_all

lemma ocnet_bigger_than_next:
  "oclosed (opnet (\<lambda>i. optoy i \<langle>\<langle>\<^bsub>i\<^esub> qmsg) n)
     \<Turnstile> (\<lambda>_ _ _. True, other nos_increase (net_tree_ips n) \<rightarrow>)
        global (\<lambda>\<sigma>. \<forall>i\<in>net_tree_ips n. no (\<sigma> i) \<le> no (\<sigma> (nhip (\<sigma> i))))"
  proof (rule inclosed_closed)
    show "opnet (\<lambda>i. optoy i \<langle>\<langle>\<^bsub>i\<^esub> qmsg) n
            \<Turnstile> (otherwith op = (net_tree_ips n) inoclosed, other nos_increase (net_tree_ips n) \<rightarrow>)
               global (\<lambda>\<sigma>. \<forall>i\<in>net_tree_ips n. no (\<sigma> i) \<le> no (\<sigma> (nhip (\<sigma> i))))"
    proof (rule oinvariant_weakenE [OF opnet_bigger_than_next])
      fix s s':: "nat \<Rightarrow> state" and a :: "msg node_action"
      assume "otherwith op = (net_tree_ips n) inoclosed s s' a"
      thus "otherwith nos_increase (net_tree_ips n) (oarrivemsg msg_num_ok) s s' a"
      proof (rule otherwithE, intro otherwithI)
        assume "inoclosed s a"
           and "\<forall>j. j \<notin> net_tree_ips n \<longrightarrow> s j = s' j"
           and "otherwith (op=) (net_tree_ips n) inoclosed s s' a"
        thus "oarrivemsg msg_num_ok s a"
          by (cases a) auto
      qed auto
    qed simp
  qed

subsection "Transfer"

definition
  initmissing :: "(nat \<Rightarrow> state option) \<times> 'a \<Rightarrow> (nat \<Rightarrow> state) \<times> 'a"
where
  "initmissing \<sigma> = (\<lambda>i. case (fst \<sigma>) i of None \<Rightarrow> toy_init i | Some s \<Rightarrow> s, snd \<sigma>)"

lemma not_in_net_ips_fst_init_missing [simp]:
  assumes "i \<notin> net_ips \<sigma>"
    shows "fst (initmissing (netgmap fst \<sigma>)) i = toy_init i"
  using assms unfolding initmissing_def by simp

lemma fst_initmissing_netgmap_pair_fst [simp]:
  "fst (initmissing (netgmap (\<lambda>(p, q). (fst (id p), snd (id p), q)) s))
                                               = fst (initmissing (netgmap fst s))"
  unfolding initmissing_def by auto

interpretation toy_openproc: openproc ptoy optoy id
  where "toy_openproc.initmissing = initmissing"
  proof -
    show "openproc ptoy optoy id"
    proof unfold_locales
      fix i :: ip
      have "{(\<sigma>, \<zeta>). (\<sigma> i, \<zeta>) \<in> \<sigma>\<^sub>T\<^sub>O\<^sub>Y i \<and> (\<forall>j. j \<noteq> i \<longrightarrow> \<sigma> j \<in> fst ` \<sigma>\<^sub>T\<^sub>O\<^sub>Y j)} \<subseteq> \<sigma>\<^sub>O\<^sub>T\<^sub>O\<^sub>Y"
        unfolding \<sigma>\<^sub>T\<^sub>O\<^sub>Y_def \<sigma>\<^sub>O\<^sub>T\<^sub>O\<^sub>Y_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 (ptoy i)
                             \<and> (\<sigma> i, \<zeta>) = id s
                             \<and> (\<forall>j. j\<noteq>i \<longrightarrow> \<sigma> j \<in> (fst o id) ` init (ptoy j)) } \<subseteq> init (optoy i)"
        by simp
    next
      show "\<forall>j. init (ptoy j) \<noteq> {}"
        unfolding \<sigma>\<^sub>T\<^sub>O\<^sub>Y_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 (ptoy 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 (ptoy i)"
         by (cases s, cases s') auto
      from this(3) have "((\<sigma>, q), a, (\<sigma>', q')) \<in> trans (optoy i)"
        by simp (rule open_seqp_action [OF toy_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 (optoy i)"
          by simp
    qed
    then interpret op: openproc ptoy optoy id .
    have [simp]: "\<And>i. (SOME x. x \<in> (fst o id) ` init (ptoy i)) = toy_init i"
      unfolding \<sigma>\<^sub>T\<^sub>O\<^sub>Y_def by simp
    hence "\<And>i. openproc.initmissing ptoy id i = initmissing i"
      unfolding op.initmissing_def op.someinit_def initmissing_def
      by (auto split: option.split)
    thus "openproc.initmissing ptoy id = initmissing" ..
  qed

lemma fst_initmissing_netgmap_default_toy_init_netlift:
  "fst (initmissing (netgmap fst s)) = default toy_init (netlift fst s)"
  unfolding initmissing_def default_def
  by (simp add: fst_netgmap_netlift del: One_nat_def)

definition
  netglobal :: "((nat \<Rightarrow> state) \<Rightarrow> bool) \<Rightarrow> ((state \<times> 'b) \<times> 'c) net_state \<Rightarrow> bool"
where
  "netglobal P \<equiv> (\<lambda>s. P (default toy_init (netlift fst s)))"

interpretation toy_openproc_par_qmsg: openproc_parq ptoy optoy id qmsg
  where "toy_openproc_par_qmsg.netglobal = netglobal"
    and "toy_openproc_par_qmsg.initmissing = initmissing"
  proof -
    show "openproc_parq ptoy optoy id qmsg"
      by (unfold_locales) simp
    then interpret opq: openproc_parq ptoy optoy id qmsg .

    have im: "\<And>\<sigma>. openproc.initmissing (\<lambda>i. ptoy 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>T\<^sub>O\<^sub>Y_def \<sigma>\<^sub>Q\<^sub>M\<^sub>S\<^sub>G_def by (clarsimp cong: option.case_cong)
    thus "openproc.initmissing (\<lambda>i. ptoy 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. ptoy 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>T\<^sub>O\<^sub>Y_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_toy_init_netlift
                                                  [symmetric, unfolded initmissing_def])
    thus "openproc.netglobal (\<lambda>i. ptoy i \<langle>\<langle> qmsg) (\<lambda>(p, q). (fst (id p), snd (id p), q)) = netglobal"
      by auto
  qed

subsection "Final result"

lemma bigger_than_next:
  assumes "wf_net_tree n"
  shows "closed (pnet (\<lambda>i. ptoy i \<langle>\<langle> qmsg) n) \<TTurnstile> netglobal (\<lambda>\<sigma>. \<forall>i. no (\<sigma> i) \<le> no (\<sigma> (nhip (\<sigma> i))))"
        (is "_ \<TTurnstile> netglobal (\<lambda>\<sigma>. \<forall>i. ?inv \<sigma> i)")
  proof -
    from \<open>wf_net_tree n\<close>
      have proto: "closed (pnet (\<lambda>i. ptoy i \<langle>\<langle> qmsg) n)
                      \<TTurnstile> netglobal (\<lambda>\<sigma>. \<forall>i\<in>net_tree_ips n. no (\<sigma> i) \<le> no (\<sigma> (nhip (\<sigma> i))))"
        by (rule toy_openproc_par_qmsg.close_opnet [OF _ ocnet_bigger_than_next])
    show ?thesis
    unfolding invariant_def opnet_sos.opnet_tau1
    proof (rule, simp only: toy_openproc_par_qmsg.netglobalsimp
                            fst_initmissing_netgmap_pair_fst, rule allI)
      fix \<sigma> i
      assume sr: "\<sigma> \<in> reachable (closed (pnet (\<lambda>i. ptoy 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: toy_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. ptoy 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 = toy_init i"
          by simp
        thus ?thesis by simp
      qed metis
    qed
  qed

end


(*******************************************************************************

  Project: IsaNet

  Author:  Tobias Klenze, ETH Zurich <tobias.klenze@inf.ethz.ch>
  Version: JCSPaper.1.0
  Isabelle Version: Isabelle2021-1

  Copyright (c) 2022 Tobias Klenze
  Licence: Mozilla Public License 2.0 (MPL) / BSD-3-Clause (dual license)

*******************************************************************************)

section \<open>ICING\<close>
text\<open>We abstract and simplify from the protocol ICING in several ways. First, we only consider
Proofs of Consent (PoC), not Proofs of Provenance (PoP). Our framework does not support proving the
path validation properties that PoPs provide, and it also currently does not support XOR, and
dynamically changing hop fields.
Thus, instead of embedding $A_i \oplus PoP_{0,1}$, we embed $A_i$ directly.
We also remove the payload from the Hash that is included in each packet.

We offer three versions of this protocol:
\begin{itemize}
\item @{text "ICING"}, which contains our best effort at modeling the protocol as accurately as
possible.
\item @{text "ICING_variant"}, in which we strip down the protocol to what is required to obtain the
security guarantees and remove unnecessary fields.
\item @{text "ICING_variant2"}, in which we furthermore simplify the protocol. The key of the MAC in
this protocol is only the key of the AS, as opposed to a key derived specifically for this hop field.
In order to prove that this scheme is secure, we have to assume that ASes only occur once on an
authorized path, since otherwise the MAC for two different hop fields (by the same AS) would be the
same, and the AS could not distinguish the hop fields based on the MAC.
\end{itemize}\<close>
theory ICING
  imports
    "../Parametrized_Dataplane_3_undirected"
begin

locale icing_defs = network_assums_undirect _ _ _ auth_seg0
  for auth_seg0 :: "(msgterm \<times> nat ahi_scheme list) set"
begin

(******************************************************************************)
subsection \<open>Hop validation check and extract functions\<close>
(******************************************************************************)
type_synonym ICING_HF = "(nat, unit) HF"

text\<open>The term @{term "sntag"} is a key that is derived from the key of an AS and a specific
hop field. We use it in the computation of @{term "hf_valid"}.
The "tag" field is a opaque numeric value which is used to encode further routing information of a
node.\<close>

fun sntag :: "nat ahi_scheme \<Rightarrow> msgterm" where
  "sntag \<lparr>UpIF = upif, DownIF = downif, ASID = asid, \<dots> = tag\<rparr>
    = \<langle>macKey asid, if2term upif, if2term downif, Num tag\<rangle>"

lemma sntag_eq: "sntag ahi2 = sntag ahi1 \<Longrightarrow> ahi2 = ahi1"
  by(cases ahi1,cases ahi2) auto

(*redefined these functions in terms of a @{text "nat ahi_scheme"}*)
fun hf2term :: "nat ahi_scheme \<Rightarrow> msgterm" where
  "hf2term \<lparr>UpIF = upif, DownIF = downif, ASID = asid, \<dots> = tag\<rparr>
  = L [if2term upif, if2term downif, Num asid, Num tag]"

fun term2hf :: "msgterm \<Rightarrow> nat ahi_scheme" where
  "term2hf (L [upif, downif, Num asid, Num tag])
  = \<lparr>UpIF = term2if upif, DownIF = term2if downif, ASID = asid, \<dots> = tag\<rparr>"

lemma term2hf_hf2term[simp]: "term2hf (hf2term hf) = hf" apply(cases hf) by auto

text\<open>We make some useful definitions that will be used to define the predicate @{term "hf_valid"}.
Having them as separate definitions is useful to prevent unfolding in proofs that don't require it.\<close>
definition fullpath :: "ICING_HF list \<Rightarrow> msgterm" where
  "fullpath hfs = L (map (hf2term o AHI) hfs)"

definition maccontents where
  "maccontents ahi hfs PoC_i_expire
  = \<langle>Mac[sntag ahi] \<langle>fullpath hfs, Num PoC_i_expire\<rangle>, \<langle>Num 0, Hash (fullpath hfs)\<rangle>\<rangle>"

text\<open>The predicate @{term "hf_valid"} is given to the concrete parametrized model as a parameter.
It ensures the authenticity of the hop authenticator in the hop field. The predicate takes an
expiration timestamp (in this model always a numeric value, hence the matching on
@{term "Num PoC_i_expire"}), the entire segment and the hop field to be validated.\<close>
fun hf_valid :: "msgterm \<Rightarrow> msgterm
    \<Rightarrow> ICING_HF list
    \<Rightarrow> ICING_HF
    \<Rightarrow> bool" where
  "hf_valid (Num PoC_i_expire) uinfo hfs \<lparr>AHI = ahi, UHI = uhi, HVF = A_i\<rparr> \<longleftrightarrow>
    uhi = () \<and> uinfo = \<epsilon> \<and> A_i = Hash (maccontents ahi hfs PoC_i_expire)"
| "hf_valid _ _ _ _ = False"

text\<open>We can extract the entire path (past and future) from the hvf field.\<close>
fun extr :: "msgterm \<Rightarrow> nat ahi_scheme list" where
  "extr (Mac[Mac[_] \<langle>L fullpathhfs, Num PoC_i_expire\<rangle>] _)
 = map term2hf fullpathhfs"
| "extr _ = []"

text\<open>Extract the authenticated info field from a hop validation field.\<close>
fun extr_ainfo :: "msgterm \<Rightarrow> msgterm" where
  "extr_ainfo (Mac[_] (L (Num ts # xs))) = Num ts"
| "extr_ainfo _ = \<epsilon>"

abbreviation term_ainfo :: "msgterm \<Rightarrow> msgterm" where
  "term_ainfo \<equiv> id"

text\<open>An authenticated info field is always a number (corresponding to a timestamp). The
     unauthenticated info field is set to the empty term @{term "\<epsilon>"}.\<close>
definition auth_restrict where
  "auth_restrict ainfo uinfo l \<equiv> (\<exists>ts. ainfo = Num ts) \<and> (uinfo = \<epsilon>)"

text\<open>When observing a hop field, an attacker learns the HVF. UHI is empty and the AHI only contains
public information that are not terms.\<close>
fun terms_hf :: "ICING_HF \<Rightarrow> msgterm set" where
  "terms_hf hf = {HVF hf}"

abbreviation terms_uinfo :: "msgterm \<Rightarrow> msgterm set" where
  "terms_uinfo x \<equiv> {x}"

abbreviation no_oracle where "no_oracle \<equiv> (\<lambda> _ _. True)"

text\<open>We now define useful properties of the above definition.\<close>
lemma hf_valid_invert:
  "hf_valid tsn uinfo hfs hf \<longleftrightarrow>
(\<exists> PoC_i_expire ahi A_i . tsn = Num PoC_i_expire \<and> ahi = AHI hf \<and>
UHI hf = () \<and> uinfo = \<epsilon> \<and>
HVF hf = A_i \<and>
A_i = Hash (maccontents ahi hfs PoC_i_expire))"
  apply(cases hf) by(auto elim!: hf_valid.elims)

lemma hf_valid_auth_restrict[dest]: "hf_valid ainfo uinfo hfs hf \<Longrightarrow> auth_restrict ainfo uinfo l"
  by(auto simp add: hf_valid_invert auth_restrict_def)

lemma auth_restrict_ainfo[dest]: "auth_restrict ainfo uinfo l \<Longrightarrow> \<exists>ts. ainfo = Num ts"
  by(auto simp add: auth_restrict_def)
lemma auth_restrict_uinfo[dest]: "auth_restrict ainfo uinfo l \<Longrightarrow> uinfo = \<epsilon>"
  by(auto simp add: auth_restrict_def)

lemma info_hvf:
  assumes "hf_valid ainfo uinfo hfs m" "hf_valid ainfo' uinfo' hfs' m'"
          "HVF m = HVF m'" "m \<in> set hfs" "m' \<in> set hfs'"
  shows "ainfo' = ainfo" "m' = m"
  using assms
  apply(auto simp add: hf_valid_invert maccontents_def intro: ahi_eq)
  apply(cases m,cases m')
  by(auto intro: sntag_eq)

(******************************************************************************)
subsection\<open>Definitions and properties of the added intruder knowledge\<close>
(******************************************************************************)
text\<open>Here we define a @{text "ik_add"} and @{text "ik_oracle"} as being empty, as these features are
not used in this instance model.\<close>

print_locale dataplane_3_undirected_defs
sublocale dataplane_3_undirected_defs _ _ _ auth_seg0 hf_valid auth_restrict extr extr_ainfo
  term_ainfo terms_hf terms_uinfo no_oracle
  by unfold_locales

declare parts_singleton[dest]

definition ik_add :: "msgterm set" where
  "ik_add \<equiv> { PoC | ainfo l uinfo hf PoC pkthash.
                 (ainfo, l) \<in> auth_seg2 uinfo
                  \<and> hf \<in> set l \<and> HVF hf = Mac[PoC] pkthash }"

lemma ik_addI:
  "\<lbrakk>(ainfo, l) \<in> local.auth_seg2 uinfo; hf \<in> set l; HVF hf = Mac[PoC] pkthash\<rbrakk> \<Longrightarrow> PoC \<in> ik_add"
  by(auto simp add: ik_add_def)

lemma ik_add_form:
  "t \<in> ik_add \<Longrightarrow> \<exists> asid upif downif tag l . t = Mac[\<langle>macKey asid, if2term upif, if2term downif, Num tag\<rangle>] l"
  apply(auto simp add: ik_add_def auth_seg2_def maccontents_def dest!: TW.holds_set_list)
  apply(auto simp add: hf_valid_invert maccontents_def auth_restrict_def)
    by (meson sntag.elims)

lemma elem_eq: "\<lbrakk>x \<in> xs; x = y; xs = ys\<rbrakk> \<Longrightarrow> y \<in> ys"
  by simp

lemma valid_hf_eq:
"\<lbrakk>HVF hf = Mac[Mac[sntag (AHI hf)] \<langle>fullpath hfs, ainfo'\<rangle>] \<langle>Num 0, Hash (fullpath hfs)\<rangle>;
 HVF hf' = Mac[Mac[sntag (AHI hf)] \<langle>fullpath hfs, ainfo'\<rangle>] pkthash;
(ainfo', l) \<in> auth_seg2 uinfo; hf' \<in> set l\<rbrakk>
  \<Longrightarrow> hf = hf'"
  by(auto simp add: auth_seg2_def hf_valid_invert maccontents_def auth_restrict_def dest!: sntag_eq)

lemma parts_ik_add[simp]: "parts ik_add = ik_add"
  by (auto intro!: parts_Hash dest: ik_add_form)

abbreviation ik_oracle :: "msgterm set" where "ik_oracle \<equiv> {}"

lemma uinfo_empty[dest]: "(ainfo, hfs) \<in> auth_seg2 uinfo \<Longrightarrow> uinfo = \<epsilon>"
  by(auto simp add: auth_seg2_def auth_restrict_def)

(******************************************************************************)
subsection\<open>Properties of the intruder knowledge, including @{text "ik_add"} and  @{text "ik_oracle"}\<close>
  (******************************************************************************)
text\<open>We now instantiate the parametrized model's definition of the intruder knowledge, using the
definitions of @{text "ik_add"} and  @{text "ik_oracle"} from above. We then prove the properties
that we need to instantiate the @{text "dataplane_3_undirected"} locale.\<close>
print_locale dataplane_3_undirected_ik_defs
sublocale
  dataplane_3_undirected_ik_defs _ _ _ auth_seg0 terms_uinfo no_oracle hf_valid auth_restrict extr
    extr_ainfo term_ainfo terms_hf ik_add ik_oracle
  by unfold_locales

lemma ik_hfs_form: "t \<in> parts ik_hfs \<Longrightarrow> \<exists> t' . t = Hash t'"
  apply auto apply(drule parts_singleton)
  by(auto simp add: auth_seg2_def hf_valid_invert)

declare ik_hfs_def[simp del]

lemma parts_ik_hfs[simp]: "parts ik_hfs = ik_hfs"
  by (auto intro!: parts_Hash ik_hfs_form)

text\<open>This lemma allows us not only to expand the definition of @{term "ik_hfs"}, but also
to obtain useful properties, such as a term being a Hash, and it being part of a valid hop field.\<close>
lemma ik_hfs_simp:
  "t \<in> ik_hfs \<longleftrightarrow> (\<exists>t' . t = Hash t') \<and> (\<exists>hf . t = HVF hf
                    \<and> (\<exists>hfs. hf \<in> set hfs \<and> (\<exists>ainfo uinfo. (ainfo, hfs) \<in> auth_seg2 uinfo
                    \<and> hf_valid ainfo uinfo hfs hf)))" (is "?lhs \<longleftrightarrow> ?rhs")
proof
  assume asm: "?lhs"
  then obtain ainfo uinfo hf hfs where
    dfs: "hf \<in> set hfs" "(ainfo, hfs) \<in> auth_seg2 uinfo" "t = HVF hf"
    by(auto simp add: ik_hfs_def)
  then obtain uinfo where "hfs_valid_prefix ainfo uinfo [] hfs = hfs"  "(ainfo, AHIS hfs) \<in> auth_seg0"
    by(auto simp add: auth_seg2_def)
  then show "?rhs" using asm dfs
    by (auto 3 4 simp add: auth_seg2_def intro!: ik_hfs_form intro!: exI[of _ hf])+
qed(auto simp add: ik_hfs_def)

lemma ik_uinfo_empty[simp]: "ik_uinfo = {\<epsilon>}"
  by(auto simp add: ik_uinfo_def auth_seg2_def auth_restrict_def intro!: exI[of _ "[]"])
declare ik_uinfo_def[simp del]

(******************************************************************************)
subsubsection \<open>Properties of Intruder Knowledge\<close>
(******************************************************************************)
lemma auth_ainfo[dest]: "\<lbrakk>(ainfo, hfs) \<in> auth_seg2 uinfo\<rbrakk> \<Longrightarrow> \<exists> ts . ainfo = Num ts"
  by(auto simp add: auth_seg2_def auth_restrict_def)

lemma Num_ik[intro]: "Num ts \<in> ik"
  by(auto simp add: ik_def auth_seg2_def auth_restrict_def intro!: exI[of _ "[]"])

text \<open>There are no ciphertexts (or signatures) in @{term "parts ik"}. Thus, @{term "analz ik"}
and @{term "parts ik"} are identical.\<close>
lemma analz_parts_ik[simp]: "analz ik = parts ik"
  apply(rule no_crypt_analz_is_parts)
  by(auto simp add: ik_def auth_seg2_def auth_restrict_def ik_hfs_simp dest: ik_add_form)

lemma parts_ik[simp]: "parts ik = ik"
  by(auto 3 4 simp add: ik_def auth_restrict_def auth_seg2_def dest!: parts_singleton_set)

lemma sntag_synth_bad: "sntag ahi \<in> synth ik \<Longrightarrow> ASID ahi \<in> bad"
  by(cases ahi)
    (auto simp add: ik_def ik_hfs_simp auth_restrict_def auth_seg2_def dest: ik_add_form)

lemma HF_eq:
  "\<lbrakk>AHI hf' = AHI hf; UHI hf' = UHI hf; HVF hf' = HVF hf\<rbrakk> \<Longrightarrow> hf' = (hf::('x, 'y)HF)"
  apply(cases hf', cases hf)
  by(auto elim: HF.cases)

(******************************************************************************)
subsection\<open>Direct proof goals for interpretation of @{text "dataplane_3_undirected"}\<close>
(******************************************************************************)

lemma COND_honest_hf_analz:
  assumes "ASID (AHI hf) \<notin> bad" "hf_valid ainfo uinfo hfs hf" "terms_hf hf \<subseteq> synth (analz ik)"
    "no_oracle ainfo uinfo" "hf \<in> set hfs"
    shows "terms_hf hf \<subseteq> analz ik"
proof-
  from assms(3) have hf_synth_ik: "HVF hf \<in> synth ik" by auto
  then have "\<exists>hfs uinfo. hf \<in> set hfs \<and> (ainfo, hfs) \<in> auth_seg2 uinfo"
    using assms(1,2,4,5)
    apply(auto simp add: ik_def hf_valid_invert ik_hfs_simp)
    subgoal for PoC_i_expire hf' hfs' PoC_i_expire'
      by(auto intro!: exI[of _ hfs'] elim!: back_subst[where ?a=hf', where ?b=hf]
              simp add: maccontents_def sntag_eq)
    subgoal by(auto simp add: ik_hfs_simp ik_def hf_valid_invert simp del: ik_uinfo_def)
    subgoal by(auto simp add: ik_hfs_simp ik_def hf_valid_invert maccontents_def
               intro: sntag_synth_bad dest: ik_add_form)
    subgoal
      apply(auto simp add: ik_hfs_simp ik_def hf_valid_invert maccontents_def auth_restrict_def auth_seg2_def
               intro: sntag_synth_bad dest: ik_add_form simp del: ik_uinfo_def) (*takes ~ 10 sec*)
      subgoal by (simp add: fullpath_def)
      subgoal using fullpath_def ik_add_form by auto
        apply (auto simp add: ik_add_def)
        subgoal for ainfoa l uinfoa hf' pkthash
          apply(frule valid_hf_eq[where ?hf'="hf'"])
          by(auto dest: valid_hf_eq simp add: hf_valid_invert maccontents_def auth_seg2_def auth_restrict_def)
      done
    done
  then have "HVF hf \<in> ik"
    using assms(2)
    by(auto simp add: ik_hfs_def intro!: ik_ik_hfs intro!: exI)
  then show ?thesis by auto
qed

lemma COND_terms_hf:
  assumes "hf_valid ainfo uinfo hfs hf" and "HVF hf \<in> ik" and "no_oracle ainfo uinfo" and "hf \<in> set hfs"
  shows "\<exists>hfs. hf \<in> set hfs \<and> (\<exists>uinfo' . (ainfo, hfs) \<in> auth_seg2 uinfo')"
  using assms apply(auto 3 4 simp add: hf_valid_invert ik_hfs_simp ik_def dest: ahi_eq)
  using assms(1) assms(2) apply(auto simp add: maccontents_def)
  apply(frule sntag_eq)
  apply(auto simp add: ik_def ik_hfs_simp dest: ik_add_form)
  by (metis info_hvf(1) info_hvf(2))

lemma COND_extr:
    "\<lbrakk>hf_valid ainfo uinfo l hf\<rbrakk> \<Longrightarrow> extr (HVF hf) = AHIS l"
  by(auto simp add: hf_valid_invert maccontents_def fullpath_def)

lemma COND_hf_valid_uinfo:
    "\<lbrakk>hf_valid ainfo uinfo l hf; hf_valid ainfo' uinfo' l' hf\<rbrakk>
    \<Longrightarrow> uinfo' = uinfo"
  by(auto simp add: hf_valid_invert)

(******************************************************************************)
subsection\<open>Instantiation of @{text "dataplane_3_undirected"} locale\<close>
(******************************************************************************)
print_locale dataplane_3_undirected
sublocale
  dataplane_3_undirected _ _ _ auth_seg0 hf_valid auth_restrict extr extr_ainfo term_ainfo terms_uinfo ik_add terms_hf
            ik_oracle  no_oracle
  apply unfold_locales
  using COND_terms_hf COND_honest_hf_analz COND_extr COND_hf_valid_uinfo by auto

end
end