(*<*)
\<comment>\<open> ********************************************************************
 * Project         : CSP-RefTK - A Refinement Toolkit for HOL-CSP
 * Version         : 1.0
 *
 * Author          : Burkhart Wolff, Safouan Taha, Lina Ye.
 *
 * This file       : The Copy-Buffer Example Revisited
 *
 * Copyright (c) 2020 Université Paris-Saclay, France
 *
 * All rights reserved.
 *
 * Redistribution and use in source and binary forms, with or without
 * modification, are permitted provided that the following conditions are
 * met:
 *
 *     * Redistributions of source code must retain the above copyright
 *       notice, this list of conditions and the following disclaimer.
 *
 *     * Redistributions in binary form must reproduce the above
 *       copyright notice, this list of conditions and the following
 *       disclaimer in the documentation and/or other materials provided
 *       with the distribution.
 *
 *     * Neither the name of the copyright holders nor the names of its
 *       contributors may be used to endorse or promote products derived
 *       from this software without specific prior written permission.
 *
 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
 * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
 * A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
 * OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
 * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
 * LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
 * DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
 * THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
 * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
 * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 ******************************************************************************\<close>
(*>*)

chapter\<open>Examples\<close>

section\<open>CopyBuffer Refinement over an infinite alphabet\<close>

theory     CopyBuffer_props
 imports   "HOL-CSP.CopyBuffer" "Properties"
begin

subsection\<open> The Copy-Buffer vs. reference processes \<close>

lemma DF_COPY: "(DF (range left \<union> range right)) \<sqsubseteq>\<^sub>F\<^sub>D COPY"
    apply(simp add:DF_def,rule fix_ind2, simp_all)
  unfolding failure_divergence_refine_def
proof -
  show "adm (\<lambda>a. a \<le> COPY)"   by(rule le_adm, simp_all add:monofunI)
next
    have 1:"(\<sqinter>xa\<in> range left \<union> range right \<rightarrow> \<bottom>) \<le> (\<sqinter>xa\<in> range left \<rightarrow>  \<bottom>)"
      using mndet_subset_FD by (metis UNIV_I empty_iff imageI)
    have 2:"(\<sqinter>xa\<in> range left \<rightarrow>  \<bottom>) \<le> (left`?`x \<rightarrow>  \<bottom>)"
      unfolding read_def
      by (metis Mprefix_refines_Mndet comp_apply dual_order.antisym mono_mprefix_FD order_refl)

  show "(\<sqinter>x\<in>range left \<union> range right \<rightarrow>  \<bottom>) \<le> COPY"
    by (metis (mono_tags, lifting)  1 2 COPY_rec bot_less1 mono_read_FD order.trans)
next
  fix P::"'a channel process"
  assume  *: "P \<le> COPY" and ** : "(\<sqinter>x\<in>range left \<union> range right \<rightarrow>  P) \<le> COPY"
    have 1:"(\<sqinter>xa\<in> range left \<union> range right \<rightarrow>  P) \<le> (\<sqinter>xa\<in> range right \<rightarrow>  P)"
      using mndet_subset_FD by (metis UNIV_I Un_commute empty_iff imageI)
    have 2:"(\<sqinter>xa\<in> range right \<rightarrow>  P) \<le> (right`!`x \<rightarrow>  P)" for x
      using mndet_subset_FD[of "{right x}" "range right"]
      by(simp add:write_def write0_def mndet_unit)
    from 1 2 have ab:"(\<sqinter>xa\<in> range left \<union> range right \<rightarrow>  P) \<le> (right`!`x \<rightarrow>  P)" for x
      using dual_order.trans by blast
    hence 3:"(left`?`x \<rightarrow> (\<sqinter>xa\<in> range left \<union> range right \<rightarrow>  P)) \<le> (left`?`x \<rightarrow>(right`!`x \<rightarrow>  P))"
      by (simp add: mono_read_FD)
    have 4:"\<And>X. (\<sqinter>xa\<in> range left \<union> range right \<rightarrow> X) \<le> (\<sqinter>xa\<in> range left \<rightarrow> X)"
      using mndet_subset_FD by (metis UNIV_I empty_iff imageI)
    have 5:"\<And>X. (\<sqinter>xa\<in> range left \<rightarrow> X) \<le> (left`?`x \<rightarrow> X)"
      unfolding read_def
      by (metis Mprefix_refines_Mndet comp_apply dual_order.antisym mono_mprefix_FD order_refl)
    from 3 4[of "(\<sqinter>xa\<in> range left \<union> range right \<rightarrow>  P)"]
         5  [of "(\<sqinter>xa\<in> range left \<union> range right \<rightarrow>  P)"]
    have 6:"(\<sqinter>xa\<in> range left \<union> range right \<rightarrow>
                    (\<sqinter>xa\<in> range left \<union> range right \<rightarrow>  P)) \<le> (left`?`x \<rightarrow> (right`!`x \<rightarrow>  P))"
      by (meson dual_order.trans)
    from * ** have 7:"(left`?`x \<rightarrow> (right`!`x \<rightarrow>  P)) \<le> (left`?`x \<rightarrow> (right`!`x \<rightarrow>  COPY))"
      by (simp add: mono_read_FD mono_write_FD)

  show "(\<sqinter>x\<in>range left \<union> range right \<rightarrow>  \<sqinter>x\<in>range left \<union> range right \<rightarrow>  P) \<le> COPY"
    by (metis (mono_tags, lifting) 6 7  COPY_rec dual_order.trans)
qed

subsection\<open> ... and abstract consequences \<close>

corollary df_COPY: "deadlock_free COPY"
      and lf_COPY: "lifelock_free COPY"
   apply (meson DF_COPY DF_Univ_freeness UNIV_not_empty image_is_empty sup_eq_bot_iff)
  by (meson CHAOS_DF_refine_FD DF_COPY DF_Univ_freeness UNIV_not_empty deadlock_free_def
            image_is_empty lifelock_free_def sup_eq_bot_iff trans_FD)

corollary df_v2_COPY: "deadlock_free_v2 COPY"
      and lf_v2_COPY: "lifelock_free_v2 COPY"
      and nt_COPY: "non_terminating COPY"
  apply (simp add: df_COPY deadlock_free_is_deadlock_free_v2)
  apply (simp add: lf_COPY lifelock_free_is_lifelock_free_v2)
  using lf_COPY lifelock_free_is_non_terminating by blast

lemma DF_SYSTEM: "DF UNIV \<sqsubseteq>\<^sub>F\<^sub>D SYSTEM"
  using DF_subset[of "(range left \<union> range right)" UNIV, simplified]
  impl_refines_spec[THEN le_approx_implies_le_ref] DF_COPY
  failure_divergence_refine_def trans_FD by blast

corollary df_SYSTEM: "deadlock_free SYSTEM"
      and lf_SYSTEM: "lifelock_free SYSTEM"
  apply (simp add: DF_SYSTEM deadlock_free_def)
  using CHAOS_DF_refine_FD DF_SYSTEM lifelock_free_def trans_FD by blast

corollary df_v2_SYSTEM: "deadlock_free_v2 SYSTEM"
      and lf_v2_SYSTEM: "lifelock_free_v2 SYSTEM"
      and nt_SYSTEM: "non_terminating SYSTEM"
  apply (simp add: df_SYSTEM deadlock_free_is_deadlock_free_v2)
  apply (simp add: lf_SYSTEM lifelock_free_is_lifelock_free_v2)
  using lf_SYSTEM lifelock_free_is_non_terminating by blast

end


(*****************************************************************************
 * Copyright (c) 2005-2010 ETH Zurich, Switzerland
 *               2008-2015 Achim D. Brucker, Germany
 *               2009-2016 Université Paris-Sud, France
 *               2015-2016 The University of Sheffield, UK
 *
 * All rights reserved.
 *
 * Redistribution and use in source and binary forms, with or without
 * modification, are permitted provided that the following conditions are
 * met:
 *
 *     * Redistributions of source code must retain the above copyright
 *       notice, this list of conditions and the following disclaimer.
 *
 *     * Redistributions in binary form must reproduce the above
 *       copyright notice, this list of conditions and the following
 *       disclaimer in the documentation and/or other materials provided
 *       with the distribution.
 *
 *     * Neither the name of the copyright holders nor the names of its
 *       contributors may be used to endorse or promote products derived
 *       from this software without specific prior written permission.
 *
 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
 * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
 * A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
 * OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
 * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
 * LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
 * DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
 * THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
 * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
 * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 *****************************************************************************)

subsection\<open>Integer Addresses with Ports\<close>
theory
  IntegerPort
  imports
    NetworkCore
begin

text\<open>
  A theory describing addresses which are modelled as a pair of Integers - the first being the
  host address, the second the port number.
\<close>

type_synonym
  address = int

type_synonym
  port = int

type_synonym
  adr\<^sub>i\<^sub>p = "address \<times> port"

overloading src_port_int \<equiv> "src_port :: ('\<alpha>::adr,'\<beta>) packet \<Rightarrow> '\<gamma>::port"
begin
definition
  "src_port_int (x::(adr\<^sub>i\<^sub>p,'\<beta>) packet)  \<equiv> (snd o fst  o snd) x"
end

overloading dest_port_int \<equiv> "dest_port :: ('\<alpha>::adr,'\<beta>) packet \<Rightarrow> '\<gamma>::port"
begin
definition
  "dest_port_int (x::(adr\<^sub>i\<^sub>p,'\<beta>) packet) \<equiv> (snd o fst o  snd o snd) x"
end

overloading subnet_of_int \<equiv> "subnet_of :: '\<alpha>::adr \<Rightarrow> '\<alpha> net"
begin
definition
  "subnet_of_int (x::(adr\<^sub>i\<^sub>p)) \<equiv> {{(a,b::int). a = fst x}}"
end

lemma src_port: "src_port (a,x::adr\<^sub>i\<^sub>p,d,e) = snd x"
  by (simp add: src_port_int_def in_subnet)

lemma dest_port: "dest_port (a,d,x::adr\<^sub>i\<^sub>p,e) = snd x"
  by (simp add: dest_port_int_def in_subnet)

lemmas adr\<^sub>i\<^sub>pLemmas = src_port dest_port src_port_int_def dest_port_int_def

end


theory Swap_CounterExample
  imports Simpl.Semantic Simpl.Vcg "Rust-Verification.Rust_Semantics"
begin

record rustv_swap_env = globals_ram +
  x :: tagged_ref
  y :: tagged_ref
  tmp :: tagged_ref

definition rustv_swap_body :: "(rustv_swap_env, 'p, rust_error) com" where
  "rustv_swap_body ==
    Basic (\<lambda>s. let (r, s') = heap_new uninit s in s'\<lparr> tmp := r \<rparr>);;
    copy_betw_places x tmp;;
    copy_betw_places y x;;
    copy_betw_places tmp y"

definition root where
  "root = tag_val 0"
definition s1 where
  "s1 = tag_val 1"
definition u where
  "u = tag_val 2"
definition s2 where
  "s2 = tag_val 3"
definition borrow_stack where
  "borrow_stack = [(SharedReadWrite, {s2}), (Unique, {u}),
    (SharedReadWrite, {s1}), (Unique, {root})]"

lemma l1: "wf_reborrow borrow_stack"
  unfolding borrow_stack_def
  apply (rule ReborrowUniqueSRW)
   apply (rule ReborrowSRWUnique)
    apply (rule ReborrowUniqueSRW)
     apply (rule BorrowRoot)
  by (simp_all add: root_def s1_def u_def s2_def)

definition the_memory :: rustv_swap_env where
  "the_memory = \<lparr>
    memory = [int_val 100],
    tags = [borrow_stack],
    issued_tags = [root, s1, u, s2],
    x = \<lparr> pointer = ptr_val 0, tag = s1 \<rparr>,
    y = \<lparr> pointer = ptr_val 0, tag = s2 \<rparr>,
    tmp = undefined
  \<rparr>"

lemma l2: "wf_heap the_memory"
  apply (auto simp add: the_memory_def borrow_stack_def)
  using l1 by (simp add: borrow_stack_def)

lemma l3: "(let (r, s') = heap_new uninit the_memory
     in s'\<lparr>tmp := r\<rparr>)
    \<in> {s. Rustv.writable (tmp s) s \<and>
           Rustv.readable (x s) s}"
  unfolding the_memory_def
  by (auto simp add: Let_def borrow_stack_def)

lemma l4: "\<Gamma> \<turnstile>\<langle>rustv_swap_body, Normal the_memory\<rangle> \<Rightarrow> Fault invalid_ref"
  unfolding rustv_swap_body_def
  apply (rule Semantic.exec.Seq)
   apply (rule Semantic.exec.Seq)
    apply (rule Semantic.exec.Seq)
     apply (rule Semantic.exec.Basic)
    apply (rule Semantic.exec.Guard)
     apply (rule l3)
    apply (rule Semantic.exec.Seq)
     apply (rule Semantic.exec.Seq)
      apply (rule Semantic.exec.Basic)
     apply (rule Semantic.exec.Basic)
    apply (rule Semantic.exec.Basic)
   apply (rule Semantic.exec.GuardFault)
   prefer 2
   apply simp
  by (auto simp add: Let_def the_memory_def borrow_stack_def s1_def s2_def u_def root_def)

lemma l6: "writable (x the_memory) the_memory"
  unfolding the_memory_def borrow_stack_def
  by simp

lemma l7: "writable (y the_memory) the_memory"
  unfolding the_memory_def borrow_stack_def
  by simp

theorem "\<exists>s.
  writable (x s) s \<and>
  writable (y s) s \<and>
  \<Gamma> \<turnstile> \<langle>rustv_swap_body, Normal s\<rangle> \<Rightarrow> Fault invalid_ref"
  using l4 l6 l7 by auto

inductive det where
  DetBasic: "det (Basic f)" |
  DetSeq: "\<lbrakk>det c1; det c2\<rbrakk> \<Longrightarrow> det (c1;; c2)" |
  DetGuard: "det c \<Longrightarrow> det (Guard f g c)"

lemma det_det:
  assumes
    "det c"
    "\<Gamma> \<turnstile> \<langle>c, s\<rangle> \<Rightarrow> t"
    "\<Gamma> \<turnstile> \<langle>c, s\<rangle> \<Rightarrow> t'"
  shows "t = t'"
using assms proof (induction arbitrary: s t t')
  case (DetBasic f)
  then show ?case
    by (metis exec_Normal_elim_cases(6) exec_elim_cases(7))
next
  case (DetSeq c1 c2)
  show ?case
  proof (cases s)
    case (Normal x1)
    then show ?thesis
      by (metis DetSeq.IH DetSeq.prems exec_Normal_elim_cases(8))
  next
    case (Abrupt x2)
    then show ?thesis
      by (metis Abrupt_end DetSeq.prems(1) DetSeq.prems(2))
  next
    case (Fault x3)
    then show ?thesis
      by (metis Fault_end DetSeq.prems(1) DetSeq.prems(2))
  next
    case Stuck
    then show ?thesis
      by (metis Stuck_end DetSeq.prems(1) DetSeq.prems(2))
  qed
next
  case (DetGuard c f g)
  thm exec_Normal_elim_cases(5)
  thm exec_elim_cases
  show ?case
  proof (cases s)
    case (Normal x1)
    then show ?thesis
      by (metis DetGuard.IH DetGuard.prems exec_Normal_elim_cases(5))
  next
    case (Abrupt x2)
    then show ?thesis
      by (metis Abrupt_end DetGuard.prems(1) DetGuard.prems(2))
  next
    case (Fault x3)
    then show ?thesis
      by (metis Fault_end DetGuard.prems(1) DetGuard.prems(2))
  next
    case Stuck
    then show ?thesis
      by (metis Stuck_end DetGuard.prems(1) DetGuard.prems(2))
  qed
qed

lemma det_swap: "det rustv_swap_body"
  unfolding rustv_swap_body_def
  by (simp add: DetBasic DetGuard DetSeq)

lemma l5: "\<Gamma> \<turnstile>\<langle>rustv_swap_body, Normal the_memory\<rangle> \<Rightarrow> t \<Longrightarrow> t = Fault invalid_ref"
proof -
  assume "\<Gamma> \<turnstile>\<langle>rustv_swap_body, Normal the_memory\<rangle> \<Rightarrow> t"
  then show "t = Fault invalid_ref"
    using det_det det_swap l4 by blast
qed

theorem "\<exists>s.
  writable (x s) s \<and>
  writable (y s) s \<and>
  (\<forall>t. \<Gamma> \<turnstile> \<langle>rustv_swap_body, Normal s\<rangle> \<Rightarrow> t \<longrightarrow> t = Fault invalid_ref)"
  using l5 l6 l7 by auto

lemma "\<Gamma> \<turnstile>\<^bsub>/{invalid_ref}\<^esub>
  {s. s = the_memory}
  rustv_swap_body
  {s. False}, {s. False}"
  unfolding rustv_swap_body_def
  apply vcg
  apply (auto simp add: Let_def)
  by (auto simp add: the_memory_def borrow_stack_def
      s1_def s2_def u_def root_def)

end


theory poST_HandDryer
  imports "~~/poST/poSTVM/poSTVM_alt_inductive"
begin

definition HandDryer :: "model" where
"HandDryer =
  (None,[],
  [(''HandDryer'',
    [(program_var.InVar ( [(''hands'',var_init_decl.Symbolic (basic_post_type.Bool False) None)])),
     (program_var.OutVar ( [(''control'',var_init_decl.Symbolic (basic_post_type.Bool False) None)]))],
    [(''Init'',
     [],
     [(''Wait'',
       False,
       [(statement.SelectSt
          (select_statement.IfSt [(expr.SymbolicVar ''hands'',
                                  [statement.AssignSt (common_var.Symbolic ''control'') (expr.Const (const.Bool True)),
                                   statement.SetStateSt None])] None))],
       None),
       (''Work'',
        False,
        [(statement.SelectSt
          (select_statement.IfSt [(expr.SymbolicVar ''hands'',
                                  [statement.ResetSt])] None))],
        Some (timeout_statement.Const
              (const.Time (time.Time 0 0 0 2 0))
              [statement.AssignSt (common_var.Symbolic ''control'') (expr.Const (const.Bool False)),
               statement.SetStateSt None]))
    :: state_decl])
  :: process_decl]):: program_decl],
  [],[]) "
declare HandDryer_def [simp]

definition stacked_HandDryer :: "stacked_model" where
"stacked_HandDryer = stack_model HandDryer"
declare stacked_HandDryer_def [simp]

value "stacked_HandDryer"

definition stacked_HandDaryer_model :: "model_state" where
"stacked_HandDaryer_model = initialize_model_state stacked_HandDryer"
declare stacked_HandDaryer_model_def [simp]

value "stacked_HandDaryer_model"

definition model_time :: "time" where
"model_time = time.Time 0 0 0 0 100"
declare model_time_def [simp]

definition set_hands :: "model_state \<Rightarrow> model_state" where
"set_hands st = set_symbvar st ''hands'' (basic_post_type.Bool True)"
declare set_hands_def [simp]

definition remove_hands :: "model_state \<Rightarrow> model_state" where
"remove_hands st = set_symbvar st ''hands'' (basic_post_type.Bool False)"
declare remove_hands_def [simp]

schematic_goal "model_time:stacked_HandDaryer_model\<turnstile>stacked_HandDryer\<mapsto>?st"
  apply (auto)
  apply (rule ModelStep)
  apply (auto)
   apply (rule ProgCons)
    apply (rule ProgStep)
      apply (auto)
    apply (rule ProcCons)
     apply (auto)
     apply (rule ProcStep)
        apply (auto)
     apply (rule StateStep)
       apply (rule If)
        apply (auto)
         apply (rule Var)
         apply (auto)
       apply (rule Blank)
      apply (auto)
    apply (rule ProcNil)
   apply (auto)
   apply (rule ProgNil)
  done

schematic_goal "model_time:(set_hands stacked_HandDaryer_model)\<turnstile>stacked_HandDryer\<mapsto>?st"
  apply (auto)
  apply (rule ModelStep)
  apply (auto)
  apply (rule ProgCons)
    apply (rule ProgStep)
      apply (auto)
    apply (rule ProcCons)
     apply (auto)
     apply (rule ProcStep)
        apply (auto)
     apply (rule StateStep)
       apply (rule If)
        apply (auto)
         apply (rule Var)
        apply (auto)
      apply (rule Comb)
       apply (rule AssignS)
        apply (rule Const)
        apply (auto)
       apply (rule SetState)
       apply (auto)
   apply (rule ProcNil)
  apply (auto)
  apply (rule ProgNil)
  done

definition set_control :: "model_state \<Rightarrow> model_state" where
"set_control st = set_symbvar st ''control'' (basic_post_type.Bool True)"
declare set_control_def [simp]

schematic_goal "model_time:(set_control stacked_HandDaryer_model)\<turnstile>stacked_HandDryer\<mapsto>?st"
  apply (auto)
  apply (rule ModelStep) apply (auto)
  apply (rule ProgCons)
   apply (rule ProgStep) apply (auto)
   apply (rule ProcCons) apply (auto)
    apply (rule ProcStep) apply (auto)
    apply (rule StateStep)
      apply (rule If) apply (auto)
        apply (rule Var) apply (auto)
      apply (rule Blank) apply (auto)
   apply (rule ProcNil) apply (auto)
  apply (rule ProgNil)
  done

definition set_overtime :: "model_state \<Rightarrow> model_state" where
"set_overtime st = add_time_to_active_processes st (time.Time 0 0 0 2 1)"
declare set_overtime_def [simp]

definition set_work_state :: "model_state \<Rightarrow> model_state" where
"set_work_state st = set_into_next_state (set_state st ''Work'')"
declare set_work_state_def [simp]

schematic_goal "model_time:(set_work_state (set_overtime (set_control stacked_HandDaryer_model)))\<turnstile>stacked_HandDryer\<mapsto>?st"
  apply (auto)
  apply (rule ModelStep) apply (auto)
  apply (rule ProgCons)
   apply (rule ProgStep) apply (auto)
   apply (rule ProcCons) apply (auto)
     apply (rule ProcStep) apply (auto)
       apply (rule StateStep)
         apply (rule If) apply (auto)
           apply (rule Var) apply (auto)
     apply (rule Blank) apply (auto)
    apply (rule Comb)
     apply (rule AssignS) apply (auto)
     apply (rule Const) apply (auto)
    apply (rule SetState) apply (auto)
   apply (rule ProcNil) apply (auto)
  apply (rule ProgNil)
  done
(*
lemma "(Suc 1)\<Zspot>model_time:stacked_HandDaryer_model\<turnstile>stacked_HandDryer\<mapsto>st"
  apply (auto)
  apply (rule ModelCons)
  apply (rule ModelStep)
   apply (rule ProgCons)
    apply (rule ProgStep)
      apply (auto)
    apply (rule ProcCons)
     apply (auto)
     apply (rule ProcStep)
        apply (auto)
     apply (rule StateStep)
      apply (rule Comb)
       apply (rule If)
        apply (auto)
         apply (rule Var)
         apply (auto)
       apply (rule Blank)
      apply (auto)
      apply (rule Blank)
     apply (auto)
    apply (rule ProcNil)
   apply (auto)
   apply (rule ProgNil)

  apply (rule ModelCons)
  apply (rule ModelStep)
   apply (rule ProgCons)
    apply (rule ProgStep)
      apply (simp)
    apply (rule ProcCons)
     apply (auto)
     apply (rule ProcStep)
        apply (auto)
     apply (rule StateStep)
      apply (rule Comb)
       apply (rule If)
         apply (rule Var)
           apply (auto)
           apply (rule Comb)
            apply (rule Reset)
           apply (auto)
           apply (rule Blank)
          apply (auto)
          apply (rule Blank)
         apply (rule Blank)
        apply (auto)
  apply (rule Comb)
  apply (rule ProcCons)
  done
*)
end


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

(* License: BSD, terms see file ./LICENSE *)

theory SepFrame
imports SepTactic
begin

class heap_state_type'

instance heap_state_type' \<subseteq> type ..

consts
  hst_mem :: "'a::heap_state_type' \<Rightarrow> heap_mem"
  hst_mem_update :: "(heap_mem \<Rightarrow> heap_mem) \<Rightarrow> 'a::heap_state_type' \<Rightarrow> 'a"
  hst_htd :: "'a::heap_state_type' \<Rightarrow> heap_typ_desc"
  hst_htd_update :: "(heap_typ_desc \<Rightarrow> heap_typ_desc) \<Rightarrow> 'a::heap_state_type' \<Rightarrow> 'a"

class heap_state_type = heap_state_type' +
  assumes hst_htd_htd_update [simp]: "hst_htd (hst_htd_update d s) = d (hst_htd s)"
  assumes hst_mem_mem_update [simp]: "hst_mem (hst_mem_update h s) = h (hst_mem s)"
  assumes hst_htd_mem_update [simp]: "hst_htd (hst_mem_update h s) = hst_htd s"
  assumes hst_mem_htd_update [simp]: "hst_mem (hst_htd_update d s) = hst_mem s"

translations
  "s\<lparr> hst_mem := x\<rparr>" <= "CONST hst_mem_update (K_record x) s"
  "s\<lparr> hst_htd := x\<rparr>" <= "CONST hst_htd_update (K_record x) s"

definition lift_hst :: "'a::heap_state_type' \<Rightarrow> heap_state" where
  "lift_hst s \<equiv> lift_state (hst_mem s,hst_htd s)"

definition point_eq_mod :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'a set \<Rightarrow> bool" where
  "point_eq_mod f g X \<equiv> \<forall>x. x \<notin> X \<longrightarrow> f x = g x"

definition exec_fatal :: "('s,'b,'c) com \<Rightarrow> ('s,'b,'c) body \<Rightarrow> 's \<Rightarrow> bool" where
  "exec_fatal C \<Gamma> s \<equiv> (\<exists>f. \<Gamma> \<turnstile> \<langle>C,Normal s\<rangle> \<Rightarrow> Fault f) \<or> (\<Gamma> \<turnstile> \<langle>C,Normal s\<rangle> \<Rightarrow> Stuck)"

definition restrict_htd :: "'s::heap_state_type' \<Rightarrow> s_addr set \<Rightarrow> 's" where
  "restrict_htd s X \<equiv> s\<lparr> hst_htd := restrict_s (hst_htd s) X \<rparr>"

definition restrict_safe_OK ::
  "'s \<Rightarrow> 's \<Rightarrow> ('s \<Rightarrow> ('s,'c) xstate) \<Rightarrow> s_addr set \<Rightarrow> ('s::heap_state_type','b,'c) com \<Rightarrow>
     ('s,'b,'c) body \<Rightarrow> bool" where
  "restrict_safe_OK s t f X C \<Gamma> \<equiv>
      \<Gamma> \<turnstile> \<langle>C,(Normal (restrict_htd s X))\<rangle> \<Rightarrow> f (restrict_htd t X) \<and>
      point_eq_mod (lift_state (hst_mem t,hst_htd t)) (lift_state (hst_mem s,hst_htd s)) X"

definition restrict_safe ::
  "'s \<Rightarrow> ('s,'c) xstate \<Rightarrow> ('s::heap_state_type','b,'c) com \<Rightarrow> ('s,'b,'c) body \<Rightarrow> bool" where
  "restrict_safe s t C \<Gamma> \<equiv>
     \<forall>X. (case t of
            Normal t' \<Rightarrow> restrict_safe_OK s t' Normal X C \<Gamma>
          | Abrupt t' \<Rightarrow> restrict_safe_OK s t' Abrupt X C \<Gamma>
          | _ \<Rightarrow> False) \<or>
         exec_fatal C \<Gamma> (restrict_htd s X)"

definition mem_safe :: "('s::{heap_state_type',type},'b,'c) com \<Rightarrow> ('s,'b,'c) body \<Rightarrow> bool" where
  "mem_safe C \<Gamma> \<equiv> \<forall>s t. \<Gamma> \<turnstile> \<langle>C,Normal s\<rangle> \<Rightarrow> t \<longrightarrow> restrict_safe s t C \<Gamma>"

definition point_eq_mod_safe ::
  "'s::{heap_state_type',type} set \<Rightarrow> ('s \<Rightarrow> 's) \<Rightarrow> ('s \<Rightarrow> s_addr \<Rightarrow> 'c) \<Rightarrow> bool" where
  "point_eq_mod_safe P f g \<equiv> \<forall>s X. restrict_htd s X \<in> P \<longrightarrow> point_eq_mod (g (f s)) (g s) X"

definition comm_restrict :: "('s::{heap_state_type',type} \<Rightarrow> 's) \<Rightarrow> 's \<Rightarrow> s_addr set \<Rightarrow> bool" where
  "comm_restrict f s X \<equiv> f (restrict_htd s X) = restrict_htd (f s) X"

definition comm_restrict_safe :: "'s set \<Rightarrow> ('s::{heap_state_type',type} \<Rightarrow> 's) \<Rightarrow> bool" where
  "comm_restrict_safe P f \<equiv> \<forall>s X. restrict_htd s X \<in> P \<longrightarrow> comm_restrict f s X"

definition htd_ind :: "('a::{heap_state_type',type} \<Rightarrow> 'b) \<Rightarrow> bool" where
  "htd_ind f \<equiv> \<forall>x s. f s = f (hst_htd_update x s)"

definition mono_guard :: "'s::{heap_state_type',type} set \<Rightarrow> bool" where
  "mono_guard P \<equiv> \<forall>s X. restrict_htd s X \<in> P \<longrightarrow> s \<in> P"

definition expr_htd_ind :: "'s::{heap_state_type',type} set \<Rightarrow> bool" where
  "expr_htd_ind P \<equiv> \<forall>d s. s\<lparr> hst_htd := d \<rparr> \<in> P = (s \<in> P)"

primrec intra_safe :: "('s::heap_state_type','b,'c) com \<Rightarrow>  bool"
where
  "intra_safe Skip = True"
| "intra_safe (Basic f) = (comm_restrict_safe UNIV f \<and>
      point_eq_mod_safe UNIV f (\<lambda>s. lift_state (hst_mem s,hst_htd s)))"
| "intra_safe (Spec r) = (\<forall>\<Gamma>. mem_safe (Spec r) (\<Gamma> :: ('s,'b,'c) body))"
| "intra_safe (Seq C D) = (intra_safe C \<and> intra_safe D)"
| "intra_safe (Cond P C D) = (expr_htd_ind P \<and> intra_safe C \<and> intra_safe D)"
| "intra_safe (While P C) = (expr_htd_ind P \<and> intra_safe C)"
| "intra_safe (Call p) = True"
| "intra_safe (DynCom f) = (htd_ind f \<and> (\<forall>s. intra_safe (f s)))"
| "intra_safe (Guard f P C) = (mono_guard P \<and> (case C of
      Basic g \<Rightarrow> comm_restrict_safe P g \<and>
                 point_eq_mod_safe P g (\<lambda>s. lift_state (hst_mem s,hst_htd s))
      | _ \<Rightarrow> intra_safe C))"
| "intra_safe Throw = True"
| "intra_safe (Catch C D) = (intra_safe C \<and> intra_safe D)"

instance state_ext :: (heap_state_type',type) heap_state_type' ..

overloading
  hs_mem_state \<equiv> hst_mem
  hs_mem_update_state \<equiv> hst_mem_update
  hs_htd_state \<equiv> hst_htd
  hs_htd_update_state \<equiv> hst_htd_update
begin
  definition hs_mem_state [simp]: "hs_mem_state \<equiv> hst_mem \<circ> globals"
  definition hs_mem_update_state [simp]: "hs_mem_update_state \<equiv> globals_update \<circ> hst_mem_update"
  definition hs_htd_state[simp]: "hs_htd_state \<equiv> hst_htd \<circ> globals"
  definition hs_htd_update_state [simp]: "hs_htd_update_state \<equiv> globals_update \<circ> hst_htd_update"
end

instance state_ext :: (heap_state_type,type) heap_state_type
  by intro_classes auto

primrec
  intra_deps :: "('s','b,'c) com \<Rightarrow> 'b set"
where
  "intra_deps Skip = {}"
| "intra_deps (Basic f) = {}"
| "intra_deps (Spec r) = {}"
| "intra_deps (Seq C D) = (intra_deps C \<union> intra_deps D)"
| "intra_deps (Cond P C D) = (intra_deps C \<union> intra_deps D)"
| "intra_deps (While P C) = intra_deps C"
| "intra_deps (Call p) = {p}"
| "intra_deps (DynCom f) = \<Union>{intra_deps (f s) | s. True}"
| "intra_deps (Guard f P C) = intra_deps C"
| "intra_deps Throw = {}"
| "intra_deps (Catch C D) = (intra_deps C \<union> intra_deps D)"

inductive_set
  proc_deps :: "('s','b,'c) com \<Rightarrow> ('s,'b,'c) body \<Rightarrow> 'b set"
  for "C" :: "('s','b,'c) com"
  and "\<Gamma>" :: "('s,'b,'c) body"
where
  "x \<in> intra_deps C \<Longrightarrow> x \<in> proc_deps C \<Gamma>"
| "\<lbrakk> x \<in> proc_deps C \<Gamma>; \<Gamma> x = Some D; y \<in> intra_deps D \<rbrakk> \<Longrightarrow> y \<in> proc_deps C \<Gamma>"

text \<open>----\<close>

lemma point_eq_mod_refl [simp]:
  "point_eq_mod f f X"
  by (simp add: point_eq_mod_def)

lemma point_eq_mod_subs:
  "\<lbrakk> point_eq_mod f g Y; Y \<subseteq> X \<rbrakk> \<Longrightarrow> point_eq_mod f g X"
  by (force simp: point_eq_mod_def)

lemma point_eq_mod_trans:
  "\<lbrakk> point_eq_mod x y X; point_eq_mod y z X \<rbrakk> \<Longrightarrow> point_eq_mod x z X"
  by (force simp: point_eq_mod_def)

lemma mem_safe_NormalD:
  "\<lbrakk> \<Gamma> \<turnstile> \<langle>C,Normal s\<rangle> \<Rightarrow> Normal t; mem_safe C \<Gamma>;
      \<not> exec_fatal C \<Gamma> (restrict_htd s X) \<rbrakk> \<Longrightarrow>
      (\<Gamma> \<turnstile> \<langle>C,(Normal (restrict_htd s X))\<rangle> \<Rightarrow> Normal (restrict_htd t X) \<and>
       point_eq_mod (lift_state (hst_mem t,hst_htd t))
          (lift_state (hst_mem s,hst_htd s)) X)"
  by (force simp: mem_safe_def restrict_safe_def restrict_safe_OK_def)

lemma mem_safe_AbruptD:
  "\<lbrakk> \<Gamma> \<turnstile> \<langle>C,Normal s\<rangle> \<Rightarrow> Abrupt t; mem_safe C \<Gamma>;
      \<not> exec_fatal C \<Gamma> (restrict_htd s X) \<rbrakk> \<Longrightarrow>
      (\<Gamma> \<turnstile> \<langle>C,(Normal (restrict_htd s X))\<rangle> \<Rightarrow> Abrupt (restrict_htd t X) \<and>
       point_eq_mod (lift_state (hst_mem t,hst_htd t))
          (lift_state (hst_mem s,hst_htd s)) X)"
  by (force simp: mem_safe_def restrict_safe_def restrict_safe_OK_def)

lemma mem_safe_FaultD:
  "\<lbrakk> \<Gamma> \<turnstile> \<langle>C,Normal s\<rangle> \<Rightarrow> Fault f; mem_safe C \<Gamma> \<rbrakk> \<Longrightarrow>
      exec_fatal C \<Gamma> (restrict_htd s X)"
  by (force simp: mem_safe_def restrict_safe_def)

lemma mem_safe_StuckD:
  "\<lbrakk> \<Gamma> \<turnstile> \<langle>C,Normal s\<rangle> \<Rightarrow> Stuck; mem_safe C \<Gamma> \<rbrakk> \<Longrightarrow>
      exec_fatal C \<Gamma> (restrict_htd s X)"
  by (force simp: mem_safe_def restrict_safe_def)

lemma lift_state_d_restrict [simp]:
  "lift_state (h,(restrict_s d X)) = lift_state (h,d) |` X"
  by (auto simp: lift_state_def restrict_map_def restrict_s_def split: s_heap_index.splits)

lemma dom_merge_restrict [simp]:
  "(x ++ y) |` dom y = y"
  by (rule map_add_restrict_dom_right)

lemma dom_compl_restrict [simp]:
  "x |` (UNIV - dom x) = Map.empty"
  by (force simp: restrict_map_def)

lemma lift_state_point_eq_mod:
  "\<lbrakk> point_eq_mod (lift_state (h,d)) (lift_state (h',d')) X \<rbrakk> \<Longrightarrow>
      lift_state (h,d) |` (UNIV - X) =
          lift_state (h',d') |` (UNIV - X)"
  by (auto simp: point_eq_mod_def restrict_map_def)

lemma htd_'_update_ind [simp]:
  "htd_ind f \<Longrightarrow> f (hst_htd_update x s) = f s"
  by (simp add: htd_ind_def)

lemma sep_frame':
  assumes orig_spec:  "\<forall>s. \<Gamma> \<turnstile> \<lbrace>s. P (f \<acute>(\<lambda>x. x)) (lift_hst \<acute>(\<lambda>x. x))\<rbrace>
                               C
                               \<lbrace>Q (g s \<acute>(\<lambda>x. x)) (lift_hst \<acute>(\<lambda>x. x))\<rbrace>"
      and hi_f: "htd_ind f" and hi_g: "htd_ind g"
      and hi_g': "\<forall>s. htd_ind (g s)"
      and safe: "mem_safe (C::('s::heap_state_type,'b,'c) com) \<Gamma>"
  shows "\<forall>s. \<Gamma> \<turnstile> \<lbrace>s. (P (f \<acute>(\<lambda>x. x)) \<and>\<^sup>* R (h \<acute>(\<lambda>x. x))) (lift_hst \<acute>(\<lambda>x. x))\<rbrace>
                 C
                 \<lbrace>(Q (g s \<acute>(\<lambda>x. x)) \<and>\<^sup>* R (h s)) (lift_hst \<acute>(\<lambda>x. x))\<rbrace>"
proof (rule, rule hoare_complete, simp only: valid_def, clarify)
  fix ta x
  assume ev: "\<Gamma>\<turnstile> \<langle>C,Normal x\<rangle> \<Rightarrow> ta" and
      pre: "(P (f x) \<and>\<^sup>* R (h x)) (lift_hst x)"
  then obtain s\<^sub>0 and s\<^sub>1 where pre_P: "P (f x) s\<^sub>0" and pre_R: "R (h x) s\<^sub>1" and
      disj: "s\<^sub>0 \<bottom> s\<^sub>1" and m: "lift_hst x = s\<^sub>1 ++ s\<^sub>0"
    by (clarsimp simp: sep_conj_def map_ac_simps)
  with orig_spec hi_f have nofault: "\<not> exec_fatal C \<Gamma>
      (restrict_htd x (dom s\<^sub>0))"
    by (force simp: exec_fatal_def image_def lift_hst_def cvalid_def valid_def
                    restrict_htd_def
              dest: hoare_sound)
  show "ta \<in> Normal ` {t. (Q (g x t) \<and>\<^sup>* R (h x)) (lift_hst t)}"
  proof (cases ta)
    case (Normal s)
    moreover from this ev safe nofault have ev': "\<Gamma> \<turnstile>
        \<langle>C,Normal (x\<lparr> hst_htd := (restrict_s (hst_htd x) (dom s\<^sub>0)) \<rparr>)\<rangle> \<Rightarrow>
           Normal (s\<lparr> hst_htd := (restrict_s (hst_htd s) (dom s\<^sub>0)) \<rparr>)" and
        "point_eq_mod (lift_state (hst_mem s,hst_htd s))
            (lift_state (hst_mem x,hst_htd x)) (dom s\<^sub>0)"
      by (auto simp: restrict_htd_def dest: mem_safe_NormalD)
    moreover from this m disj have "s\<^sub>1 = lift_hst s |` (UNIV - dom s\<^sub>0)"
      apply(clarsimp simp: lift_hst_def)
      apply(subst lift_state_point_eq_mod)
       apply(fastforce dest: sym)
      apply(simp add: lift_hst_def lift_state_point_eq_mod map_add_restrict)
      apply(subst restrict_map_subdom, auto dest: map_disjD)
      done
    ultimately show ?thesis using orig_spec hi_f hi_g hi_g' pre_P pre_R m
      by (force simp: cvalid_def valid_def image_def lift_hst_def
                      map_disj_def
                intro: sep_conjI dest: hoare_sound)
  next
    case (Abrupt s) with ev safe nofault orig_spec pre_P hi_f m show ?thesis
      by - (simp, drule spec, drule hoare_sound, drule_tac X="dom s\<^sub>0" in
            mem_safe_AbruptD, assumption+,
            force simp: valid_def cvalid_def lift_hst_def restrict_htd_def)
  next
    case (Fault f) with ev safe nofault show ?thesis
      by (force dest: mem_safe_FaultD)
  next
    case Stuck with ev safe nofault show ?thesis
      by (force dest: mem_safe_StuckD)
  qed
qed

lemma sep_frame:
  "\<lbrakk> k = (\<lambda>s. (hst_mem s,hst_htd s));
      \<forall>s. \<Gamma> \<turnstile> \<lbrace>s. P (f \<acute>(\<lambda>x. x)) (lift_state (k \<acute>(\<lambda>x. x)))\<rbrace>
              C
              \<lbrace>Q (g s \<acute>(\<lambda>x. x)) (lift_state (k \<acute>(\<lambda>x. x)))\<rbrace>;
      htd_ind f; htd_ind g; \<forall>s. htd_ind (g s);
      mem_safe (C::('s::heap_state_type,'b,'c) com) \<Gamma> \<rbrakk> \<Longrightarrow>
      \<forall>s. \<Gamma> \<turnstile> \<lbrace>s. (P (f \<acute>(\<lambda>x. x)) \<and>\<^sup>* R (h \<acute>(\<lambda>x. x))) (lift_state (k \<acute>(\<lambda>x. x)))\<rbrace>
               C
               \<lbrace>(Q (g s \<acute>(\<lambda>x. x)) \<and>\<^sup>* R (h s)) (lift_state (k \<acute>(\<lambda>x. x)))\<rbrace>"
  apply(simp only:)
  apply(fold lift_hst_def)
  apply(erule (4) sep_frame')
  done

lemma point_eq_mod_safe [simp]:
  "\<lbrakk> point_eq_mod_safe P f g; restrict_htd s X \<in> P; x \<notin> X \<rbrakk> \<Longrightarrow>
      g (f s) x = (g s) x"
  apply(simp add: point_eq_mod_safe_def point_eq_mod_def)
  apply(case_tac x, force)
  done

lemma comm_restrict_safe [simp]:
  "\<lbrakk> comm_restrict_safe P f; restrict_htd s X \<in> P \<rbrakk> \<Longrightarrow>
        restrict_htd (f s ) X = f (restrict_htd s X)"
  by (simp add: comm_restrict_safe_def comm_restrict_def)

lemma mono_guardD:
  "\<lbrakk> mono_guard P; restrict_htd s X \<in> P \<rbrakk> \<Longrightarrow> s \<in> P"
  by (unfold mono_guard_def, fast)

lemma expr_htd_ind:
  "expr_htd_ind P \<Longrightarrow> restrict_htd s X \<in> P = (s \<in> P)"
  by (simp add: expr_htd_ind_def restrict_htd_def)

(* exec.intros without those already declared as [intro] *)
lemmas exec_other_intros = exec.intros(1-3) exec.intros(5-14) exec.intros(16-17) exec.intros(19-)

lemma exec_fatal_Seq:
  "exec_fatal C \<Gamma> s \<Longrightarrow> exec_fatal (C;;D) \<Gamma> s"
  by (force simp: exec_fatal_def intro: exec_other_intros)

lemma exec_fatal_Seq2:
  "\<lbrakk> \<Gamma> \<turnstile> \<langle>C,Normal s\<rangle> \<Rightarrow> Normal t; exec_fatal D \<Gamma> t \<rbrakk> \<Longrightarrow> exec_fatal (C;;D) \<Gamma> s"
  by (force simp: exec_fatal_def intro: exec_other_intros)

lemma exec_fatal_Cond:
  "exec_fatal (Cond P C D) \<Gamma> s = (if s \<in> P then exec_fatal C \<Gamma> s else
      exec_fatal D \<Gamma> s)"
  by (force simp: exec_fatal_def intro: exec_other_intros
            elim: exec_Normal_elim_cases)

lemma exec_fatal_While:
  "\<lbrakk> exec_fatal C \<Gamma> s; s \<in> P \<rbrakk> \<Longrightarrow> exec_fatal (While P C) \<Gamma> s"
  by (force simp: exec_fatal_def intro: exec_other_intros
            elim: exec_Normal_elim_cases)

lemma exec_fatal_While2:
  "\<lbrakk> exec_fatal (While P C) \<Gamma> t; \<Gamma> \<turnstile> \<langle>C,Normal s\<rangle> \<Rightarrow> Normal t; s \<in> P \<rbrakk> \<Longrightarrow>
      exec_fatal (While P C) \<Gamma> s"
  by (force simp: exec_fatal_def intro: exec_other_intros
            elim: exec_Normal_elim_cases)

lemma exec_fatal_Call:
  "\<lbrakk> \<Gamma> p = Some C; exec_fatal C \<Gamma> s \<rbrakk> \<Longrightarrow> exec_fatal (Call p) \<Gamma> s"
  by (force simp: exec_fatal_def intro: exec_other_intros)

lemma exec_fatal_DynCom:
  "exec_fatal (f s) \<Gamma> s \<Longrightarrow> exec_fatal (DynCom f) \<Gamma> s"
  by (force simp: exec_fatal_def intro: exec_other_intros)

lemma exec_fatal_Guard:
  "exec_fatal (Guard f P C) \<Gamma> s = (s \<in> P \<longrightarrow> exec_fatal C \<Gamma> s)"
proof (cases "s \<in> P")
  case True thus ?thesis
    by (force simp: exec_fatal_def intro: exec_other_intros
              elim: exec_Normal_elim_cases)
next
  case False thus ?thesis
    by (force simp: exec_fatal_def intro: exec_other_intros)
qed

lemma restrict_safe_Guard:
  assumes restrict: "restrict_safe s t C \<Gamma>"
  shows "restrict_safe s t (Guard f P C) \<Gamma>"
proof (cases t)
  case (Normal s) with restrict show ?thesis
    by (force simp: restrict_safe_def restrict_safe_OK_def exec_fatal_Guard
              intro: exec_other_intros)
next
  case (Abrupt s) with restrict show ?thesis
    by (force simp: restrict_safe_def restrict_safe_OK_def exec_fatal_Guard
              intro: exec_other_intros)
next
  case (Fault f) with restrict show ?thesis
    by (force simp: restrict_safe_def exec_fatal_Guard)
next
  case Stuck with restrict show ?thesis
    by (force simp: restrict_safe_def exec_fatal_Guard)
qed

lemma restrict_safe_Guard2:
  "\<lbrakk> s \<notin> P; mono_guard P \<rbrakk> \<Longrightarrow> restrict_safe s (Fault f) (Guard f P C) \<Gamma>"
  by (force simp: restrict_safe_def exec_fatal_def intro: exec_other_intros
            dest: mono_guardD)

lemma exec_fatal_Catch:
  "exec_fatal C \<Gamma> s \<Longrightarrow> exec_fatal (TRY C CATCH D END) \<Gamma> s"
  by (force simp: exec_fatal_def intro: exec_other_intros)

lemma exec_fatal_Catch2:
  "\<lbrakk> \<Gamma> \<turnstile> \<langle>C,Normal s\<rangle> \<Rightarrow> Abrupt t; exec_fatal D \<Gamma> t \<rbrakk> \<Longrightarrow>
      exec_fatal (TRY C CATCH D END) \<Gamma> s"
  by (force simp: exec_fatal_def intro: exec_other_intros)

lemma intra_safe_restrict [rule_format]:
  assumes safe_env: "\<And>n C. \<Gamma> n = Some C \<Longrightarrow> intra_safe C" and
      exec: "\<Gamma> \<turnstile> \<langle>C,s\<rangle> \<Rightarrow> t"
  shows "\<forall>s'. s = Normal s' \<longrightarrow> intra_safe C \<longrightarrow> restrict_safe s' t C \<Gamma>"
using exec
proof induct
  case (Skip s) thus ?case
    by (force simp: restrict_safe_def restrict_safe_OK_def intro: exec_other_intros)
next
  case (Guard s' P C t f) show ?case
  proof (cases "\<exists>g. C = Basic g")
    case False with Guard show ?thesis
      by - (clarsimp, split com.splits, auto dest: restrict_safe_Guard)
  next
    case True with Guard show ?thesis
      by (cases t) (force simp: restrict_safe_def restrict_safe_OK_def
                                point_eq_mod_safe_def exec_fatal_Guard
                          intro: exec_other_intros
                          elim: exec_Normal_elim_cases,
                    (fast elim: exec_Normal_elim_cases)+)
  qed
next
  case (GuardFault C f P s) thus ?case
    by (force dest: restrict_safe_Guard2)
next
  case (FaultProp C f) thus ?case by simp
next
  case (Basic f s) thus ?case
    by (force simp: restrict_safe_def restrict_safe_OK_def point_eq_mod_safe_def
              intro: exec_other_intros)
next
  case (Spec r s t) thus ?case
    by (fastforce simp: mem_safe_def intro: exec.Spec)
next
  case (SpecStuck r s) thus ?case
    by (simp add: exec.SpecStuck mem_safe_StuckD restrict_safe_def)
next
  case (Seq C s sa D ta) show ?case
  proof (cases sa)
    case (Normal s') with Seq show ?thesis
      by (cases ta)
         (clarsimp simp: restrict_safe_def restrict_safe_OK_def,
          (drule_tac x=X in spec)+, auto intro: exec_other_intros point_eq_mod_trans
                                               exec_fatal_Seq exec_fatal_Seq2)+
  next
    case (Abrupt s') with Seq show ?thesis
      by (force simp: restrict_safe_def restrict_safe_OK_def
                intro: exec_other_intros dest: exec_fatal_Seq
                elim: exec_Normal_elim_cases)
  next
    case (Fault f) with Seq show ?thesis
      by (force simp: restrict_safe_def dest: exec_fatal_Seq
                elim: exec_Normal_elim_cases)
  next
    case Stuck with Seq show ?thesis
      by (force simp: restrict_safe_def dest: exec_fatal_Seq
                elim: exec_Normal_elim_cases)
  qed
next
  case (CondTrue s P C t D) thus ?case
    by (cases t)
       (auto simp: restrict_safe_def restrict_safe_OK_def exec_fatal_Cond
             intro: exec_other_intros dest: expr_htd_ind split: if_split_asm)
next
  case (CondFalse s P C t D) thus ?case
    by (cases t)
       (auto simp: restrict_safe_def restrict_safe_OK_def exec_fatal_Cond
             intro: exec_other_intros dest: expr_htd_ind split: if_split_asm)
next
  case (WhileTrue P C s s' t) show ?case
  proof (cases s')
    case (Normal sa) with WhileTrue show ?thesis
      by (cases t)
         (clarsimp simp: restrict_safe_def restrict_safe_OK_def,
          (drule_tac x=X in spec)+, auto simp: expr_htd_ind intro: exec_other_intros
               point_eq_mod_trans exec_fatal_While exec_fatal_While2)+
  next
    case (Abrupt sa) with WhileTrue show ?thesis
      by (force simp: restrict_safe_def restrict_safe_OK_def expr_htd_ind
                intro: exec_other_intros exec_fatal_While
                elim: exec_Normal_elim_cases)
  next
    case (Fault f) with WhileTrue show ?thesis
      by (force simp: restrict_safe_def expr_htd_ind intro: exec_fatal_While)
  next
    case Stuck with WhileTrue show ?thesis
      by (force simp: restrict_safe_def expr_htd_ind intro: exec_fatal_While)
  qed
next
  case (WhileFalse P C s) thus ?case
    by (force simp: restrict_safe_def restrict_safe_OK_def expr_htd_ind
              intro: exec_other_intros)
next
  case (Call C p s t) with safe_env show ?case
    by (cases t)
       (auto simp: restrict_safe_def restrict_safe_OK_def
             intro: exec_fatal_Call exec_other_intros)
next
  case (CallUndefined p s) thus ?case
    by (force simp: restrict_safe_def exec_fatal_def intro: exec_other_intros)

next
  case (StuckProp C) thus ?case by simp
next
  case (DynCom f s t) thus ?case
    by (cases t)
       (auto simp: restrict_safe_def restrict_safe_OK_def
                   restrict_htd_def
             intro!: exec_other_intros exec_fatal_DynCom)
next
  case (Throw s) thus ?case
    by (force simp: restrict_safe_def restrict_safe_OK_def intro: exec_other_intros)
next
  case (AbruptProp C s) thus ?case by simp
next
  case (CatchMatch C D s s' t) thus ?case
    by (cases t)
       (clarsimp simp: restrict_safe_def, drule_tac x=X in spec,
        auto simp: restrict_safe_OK_def intro: exec_other_intros point_eq_mod_trans
             dest: exec_fatal_Catch exec_fatal_Catch2)+
next
  case (CatchMiss C s t D) thus ?case
    by (cases t)
       (clarsimp simp: restrict_safe_def, drule_tac x=X in spec,
        auto simp: restrict_safe_OK_def intro: exec_other_intros
             dest: exec_fatal_Catch)+
qed

lemma intra_mem_safe:
  "\<lbrakk> \<And>n C. \<Gamma> n = Some C \<Longrightarrow> intra_safe C; intra_safe C \<rbrakk> \<Longrightarrow> mem_safe C \<Gamma>"
  by (force  simp: mem_safe_def intro: intra_safe_restrict)

lemma point_eq_mod_safe_triv:
  "(\<And>s. g (f s) = g s) \<Longrightarrow> point_eq_mod_safe P f g"
  by (simp add: point_eq_mod_safe_def point_eq_mod_def)

lemma comm_restrict_safe_triv:
  "(\<And>s X. f (s\<lparr> hst_htd := restrict_s (hst_htd s) X \<rparr>) =
      (f s)\<lparr> hst_htd := restrict_s (hst_htd (f s)) X \<rparr>) \<Longrightarrow> comm_restrict_safe P f"
  by (force simp: comm_restrict_safe_def comm_restrict_def restrict_htd_def)

lemma mono_guard_UNIV [simp]:
  "mono_guard UNIV"
  by (force simp: mono_guard_def)

lemma mono_guard_triv:
  "(\<And>s X. s\<lparr> hst_htd := X \<rparr> \<in> g \<Longrightarrow> s \<in> g) \<Longrightarrow> mono_guard g"
  by (unfold mono_guard_def, unfold restrict_htd_def, fast)

lemma mono_guard_triv2:
  "(\<And>s X. s\<lparr> hst_htd := X \<rparr> \<in> g = ((s::'a::heap_state_type') \<in> g)) \<Longrightarrow>
      mono_guard g"
  by (unfold mono_guard_def, unfold restrict_htd_def, fast)

lemma dom_restrict_s:
  "x \<in> dom_s (restrict_s d X) \<Longrightarrow> x \<in> dom_s d \<and> x \<in> X"
  by (auto simp: restrict_s_def dom_s_def split: if_split_asm)

lemma mono_guard_ptr_safe:
  "\<lbrakk> \<And>s. d s = hst_htd (s::'a::heap_state_type); htd_ind p \<rbrakk> \<Longrightarrow>
      mono_guard {s. ptr_safe (p s) (d s)}"
  by (auto simp: mono_guard_def ptr_safe_def restrict_htd_def dest: subsetD dom_restrict_s)

lemma point_eq_mod_safe_ptr_safe_update:
  "\<lbrakk> d = (hst_htd::'a::heap_state_type \<Rightarrow> heap_typ_desc);
      m = (\<lambda>s. hst_mem_update (heap_update (p s) ((v s)::'b::mem_type)) s);
      h = hst_mem; k = (\<lambda>s. lift_state (h s,d s)); htd_ind p \<rbrakk> \<Longrightarrow>
      point_eq_mod_safe {s. ptr_safe (p s) (d s)} m k"
  apply (clarsimp simp: point_eq_mod_safe_def point_eq_mod_def ptr_safe_def heap_update_def
                        restrict_htd_def lift_state_def
                  intro!: heap_update_nmem_same
                  split: s_heap_index.splits)
  apply(subgoal_tac "(a,SIndexVal) \<in> s_footprint (p s)")
   apply(drule (1) subsetD)
   apply(drule dom_restrict_s, clarsimp)
  apply(drule intvlD, clarsimp)
  apply(erule s_footprintI2)
  done

lemma field_ti_s_sub_typ:
  "field_lookup (export_uinfo (typ_info_t TYPE('b::mem_type))) f 0 = Some (typ_uinfo_t TYPE('a),b) \<Longrightarrow>
      s_footprint ((Ptr &(p\<rightarrow>f))::'a::mem_type ptr) \<subseteq> s_footprint (p::'b ptr)"
  by (drule field_ti_s_sub) (simp add: s_footprint_def)

lemma ptr_safe_mono:
  "\<lbrakk> ptr_safe (p::'a::mem_type ptr) d; field_lookup (typ_info_t TYPE('a)) f 0
      = Some (t,n); export_uinfo t = typ_uinfo_t TYPE('b) \<rbrakk> \<Longrightarrow>
      ptr_safe ((Ptr &(p\<rightarrow>f))::'b::mem_type ptr) d"
  unfolding ptr_safe_def
  by (drule field_lookup_export_uinfo_Some) (auto dest: field_ti_s_sub_typ)

lemma point_eq_mod_safe_ptr_safe_update_fl:
  "\<lbrakk> d = (hst_htd::'a::heap_state_type \<Rightarrow> heap_typ_desc);
      m = (\<lambda>s. hst_mem_update (heap_update (Ptr &((p s)\<rightarrow>f)) ((v s)::'b::mem_type)) s);
      h = hst_mem; k = (\<lambda>s. lift_state (h s,d s)); htd_ind p;
      field_lookup (typ_info_t TYPE('c)) f 0 = Some (t,n);
      export_uinfo t = typ_uinfo_t TYPE('b) \<rbrakk> \<Longrightarrow>
      point_eq_mod_safe {s. ptr_safe ((p::'a \<Rightarrow> 'c::mem_type ptr) s) (d s)} m k"
  apply(drule (3) point_eq_mod_safe_ptr_safe_update)
   apply(fastforce simp: htd_ind_def)
  apply(fastforce simp: point_eq_mod_safe_def intro!: ptr_safe_mono)
  done

context
begin

private method m =
  (clarsimp simp: ptr_retyp_d_eq_snd ptr_retyp_footprint list_map_eq,
   erule notE,
   drule intvlD, clarsimp,
   (rule s_footprintI; assumption?),
   subst (asm) unat_of_nat,
   (subst (asm) mod_less; assumption?),
   subst len_of_addr_card,
   erule less_trans,
   simp)

lemma point_eq_mod_safe_ptr_safe_tag:
  "\<lbrakk> d = (hst_htd::'a::heap_state_type \<Rightarrow> heap_typ_desc); h = hst_mem;
     m = (\<lambda>s. hst_htd_update (ptr_retyp (p s)) s);
     k = (\<lambda>s. lift_state (h s,d s));
     htd_ind p \<rbrakk> \<Longrightarrow>
   point_eq_mod_safe {s. ptr_safe ((p s)::'b::mem_type ptr) (d s)} m k"
  supply if_split_asm[split]
  apply(clarsimp simp: point_eq_mod_safe_def point_eq_mod_def ptr_safe_def)
  apply(subgoal_tac "(a,b) \<notin> s_footprint (p (restrict_htd s X))")
   prefer 2
   apply(fastforce simp: restrict_htd_def dest: dom_restrict_s)
  apply(clarsimp simp: restrict_htd_def  lift_state_def split: s_heap_index.split option.splits)
  apply (safe; m?)
    apply(fastforce simp: ptr_retyp_d_eq_fst dest!: intvlD dest: s_footprintI2)
   apply(fastforce simp: ptr_retyp_d_eq_fst)
  apply(subst (asm) ptr_retyp_d_eq_snd, clarsimp)
  done

end

lemma comm_restrict_safe_ptr_safe_tag:
  fixes d::"'a::heap_state_type \<Rightarrow> heap_typ_desc"
  assumes
    fun_d: "d = hst_htd" and
    fun_upd: "m = (\<lambda>s. hst_htd_update (ptr_retyp (p s)) s)" and
    ind: "htd_ind p" and
    upd: "\<And>d d' (s::'a).
               hst_htd_update (d s) (hst_htd_update (d' s) s) = hst_htd_update ((d s) \<circ> (d' s)) s"
  shows "comm_restrict_safe {s. ptr_safe ((p s)::'b::mem_type ptr) (d s)} m"
proof (simp only: comm_restrict_safe_def comm_restrict_def, auto)
  fix s X
  assume "ptr_safe (p (restrict_htd s X)) (d (restrict_htd s X))"
  moreover from ind
  have p: "p (restrict_htd s X) = p s"
    by (simp add:  restrict_htd_def)
  ultimately
  have "ptr_retyp (p s) (restrict_s (hst_htd s) X) = restrict_s (ptr_retyp (p s) (hst_htd s))  X"
    using fun_d
    apply -
    apply(rule ext)
    apply(clarsimp simp: point_eq_mod_safe_def point_eq_mod_def ptr_safe_def restrict_htd_def)
    apply(case_tac "x \<notin> {ptr_val (p s)..+size_of TYPE('b)}")
     apply(clarsimp simp: ptr_retyp_d restrict_map_def restrict_s_def)
     apply(subst ptr_retyp_d; simp)
    apply(clarsimp simp: ptr_retyp_footprint restrict_map_def restrict_s_def)
    apply(subst ptr_retyp_footprint, simp)
    apply(rule conjI)
     apply(subgoal_tac "(x,SIndexVal) \<in> s_footprint (p s)")
      apply(fastforce simp: dom_s_def)
     apply(fastforce dest: intvlD elim: s_footprintI2)
    apply(rule ext)
    apply(clarsimp simp: map_add_def list_map_eq)
    apply(subgoal_tac "(x,SIndexTyp y) \<in> s_footprint (p s)")
     apply(fastforce simp: dom_s_def split: if_split_asm)
    apply(drule intvlD, clarsimp)
    apply(rule s_footprintI; assumption?)
    apply(metis len_of_addr_card less_trans max_size mod_less word_unat.eq_norm)
    done
  hence "((ptr_retyp (p s) \<circ> (\<lambda>x _. x) (restrict_s (hst_htd s) X)::heap_typ_desc \<Rightarrow> heap_typ_desc) =
              (\<lambda>x _. x) (restrict_s (ptr_retyp (p s) (hst_htd s)) X))"
    by - (rule ext, simp)
  moreover from upd have "hst_htd_update (ptr_retyp (p s))
        (hst_htd_update ((\<lambda>x _. x) (restrict_s (hst_htd s) X)) s) =
         hst_htd_update (((ptr_retyp (p s)) \<circ> ((\<lambda>x _. x) (restrict_s (hst_htd s) X)))) s" .
  moreover from upd
  have
    "hst_htd_update ((\<lambda>x _. x) (restrict_s (ptr_retyp (p s) (hst_htd s)) X))
                    (hst_htd_update (ptr_retyp (p s)) s) =
     hst_htd_update (((\<lambda>x _. x) (restrict_s ((ptr_retyp (p s) (hst_htd s))) X)) \<circ> (ptr_retyp (p s))) s" .
  ultimately show "m (restrict_htd s X) = restrict_htd (m s) X" using fun_d fun_upd upd p
    by (simp add: restrict_htd_def o_def)
qed

lemmas intra_sc = hrs_comm comp_def hrs_htd_update_htd_update
  point_eq_mod_safe_triv comm_restrict_safe_triv mono_guard_triv2
  mono_guard_ptr_safe point_eq_mod_safe_ptr_safe_update
  point_eq_mod_safe_ptr_safe_tag comm_restrict_safe_ptr_safe_tag
  point_eq_mod_safe_ptr_safe_update_fl

declare expr_htd_ind_def [iff]
declare htd_ind_def [iff]

lemma proc_deps_Skip [simp]:
  "proc_deps Skip \<Gamma> = {}"
  by (force elim: proc_deps.induct)

lemma proc_deps_Basic [simp]:
  "proc_deps (Basic f) \<Gamma> = {}"
  by (force elim: proc_deps.induct)

lemma proc_deps_Spec [simp]:
  "proc_deps (Spec r) \<Gamma> = {}"
  by (force elim: proc_deps.induct)

lemma proc_deps_Seq [simp]:
  "proc_deps (Seq C D) \<Gamma> = proc_deps C \<Gamma> \<union> proc_deps D \<Gamma>"
proof
  show "proc_deps (C;; D) \<Gamma> \<subseteq> proc_deps C \<Gamma> \<union> proc_deps D \<Gamma>"
    by - (rule, erule proc_deps.induct, auto intro: proc_deps.intros)
next
  show "proc_deps C \<Gamma> \<union> proc_deps D \<Gamma> \<subseteq> proc_deps (C;; D) \<Gamma>"
    by auto (erule proc_deps.induct, auto intro: proc_deps.intros)+
qed

lemma proc_deps_Cond [simp]:
  "proc_deps (Cond P C D) \<Gamma> = proc_deps C \<Gamma> \<union> proc_deps D \<Gamma>"
proof
  show "proc_deps (Cond P C D) \<Gamma> \<subseteq> proc_deps C \<Gamma> \<union> proc_deps D \<Gamma>"
    by (rule, erule proc_deps.induct, auto intro: proc_deps.intros)
next
  show "proc_deps C \<Gamma> \<union> proc_deps D \<Gamma> \<subseteq> proc_deps (Cond P C D) \<Gamma>"
    by auto (erule proc_deps.induct, auto intro: proc_deps.intros)+
qed

lemma proc_deps_While [simp]:
  "proc_deps (While P C) \<Gamma> = proc_deps C \<Gamma>"
  by auto (erule proc_deps.induct, auto intro: proc_deps.intros)+

lemma proc_deps_Guard [simp]:
  "proc_deps (Guard f P C) \<Gamma> = proc_deps C \<Gamma>"
  by auto (erule proc_deps.induct, auto intro: proc_deps.intros)+

lemma proc_deps_Throw [simp]:
  "proc_deps Throw \<Gamma> = {}"
  by (force elim: proc_deps.induct)

lemma proc_deps_Catch [simp]:
  "proc_deps (Catch  C D) \<Gamma> = proc_deps C \<Gamma> \<union> proc_deps D \<Gamma>"
proof
  show "proc_deps (Catch C D) \<Gamma> \<subseteq> proc_deps C \<Gamma> \<union> proc_deps D \<Gamma>"
    by (rule, erule proc_deps.induct, auto intro: proc_deps.intros)
next
  show "proc_deps C \<Gamma> \<union> proc_deps D \<Gamma> \<subseteq> proc_deps (Catch C D) \<Gamma>"
    by auto (erule proc_deps.induct, auto intro: proc_deps.intros)+
qed

lemma proc_deps_Call [simp]:
  "proc_deps (Call p) \<Gamma> = {p} \<union> (case \<Gamma> p of Some C \<Rightarrow>
      proc_deps C (\<Gamma>(p := None)) | _ \<Rightarrow> {})" (is "?X = ?Y \<union> ?Z")
proof
  note proc_deps.intros[intro]
  show "?X \<subseteq> ?Y \<union> ?Z"
    by (rule subsetI, erule proc_deps.induct, fastforce)
       (rename_tac x D y, case_tac "x = p"; fastforce split: option.splits)
next
  show "?Y \<union> ?Z \<subseteq> ?X"
  proof (clarsimp, rule)
    show "p \<in> ?X" by (force intro: proc_deps.intros)
  next
    show "?Z \<subseteq> ?X"
      by (split option.splits, rule, force intro: proc_deps.intros)
         (clarify, erule proc_deps.induct;
          force intro: proc_deps.intros split: if_split_asm)
  qed
qed

lemma proc_deps_DynCom [simp]:
  "proc_deps (DynCom f) \<Gamma> = \<Union>{proc_deps (f s) \<Gamma> | s. True}"
  by (rule equalityI; clarsimp; erule proc_deps.induct; force intro: proc_deps.intros)

lemma proc_deps_restrict:
  "proc_deps C \<Gamma> \<subseteq> proc_deps C (\<Gamma>(p := None)) \<union> proc_deps (Call p) \<Gamma>"
proof
  fix xa
  assume mem: "xa \<in> proc_deps C \<Gamma>"
  hence "\<forall>p. xa \<in> proc_deps C (\<Gamma>(p := None)) \<union> proc_deps (Call p) \<Gamma>" (is "?X")
  using mem
  proof induct
    fix x
    assume "x \<in> intra_deps C"
    thus "\<forall>p. x \<in> proc_deps C (\<Gamma>(p := None)) \<union> proc_deps (Call p) \<Gamma>"
      by (force intro: proc_deps.intros)
  next
    fix D x y
    assume x:
      "x \<in> proc_deps C \<Gamma>"
      "x \<in> proc_deps C \<Gamma> \<Longrightarrow> \<forall>p. x \<in> proc_deps C (\<Gamma>(p := None)) \<union> proc_deps (Call p) \<Gamma>"
      "\<Gamma> x = Some D"
      "y \<in> intra_deps D"
      "y \<in> proc_deps C \<Gamma>"
    show "\<forall>p. y \<in> proc_deps C (\<Gamma>(p := None)) \<union> proc_deps (Call p) \<Gamma>"
    proof clarify
      fix p
      assume y: "y \<notin> proc_deps (Call p) \<Gamma>"
      show "y \<in> proc_deps C (\<Gamma>(p := None))"
      proof (cases "x=p")
        case True with x y show ?thesis
          by (force intro: proc_deps.intros)
      next
        case False with x y show ?thesis
          by (clarsimp, drule_tac x=p in spec)
             (auto intro: proc_deps.intros split: option.splits)
      qed
    qed
  qed
  thus "xa \<in> proc_deps C (\<Gamma>(p := None)) \<union> proc_deps (Call p) \<Gamma>" by simp
qed

lemma exec_restrict:
  assumes exec: "\<Gamma>' \<turnstile> \<langle>C,s\<rangle> \<Rightarrow> t"
  shows "\<And>\<Gamma> X. \<lbrakk> \<Gamma>' = \<Gamma> |` X; proc_deps C \<Gamma> \<subseteq> X \<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> \<langle>C,s\<rangle> \<Rightarrow> t"
using exec
proof induct
  case (Call p C s t)
  thus ?case
    using proc_deps_restrict [of C \<Gamma> p] by (force intro: exec_other_intros)
qed (force intro: exec_other_intros)+

lemma exec_restrict2:
  assumes exec: "\<Gamma> \<turnstile> \<langle>C,s\<rangle> \<Rightarrow> t"
  shows "\<And>X. proc_deps C \<Gamma> \<subseteq> X \<Longrightarrow> \<Gamma> |` X \<turnstile> \<langle>C,s\<rangle> \<Rightarrow> t"
using exec
proof induct
  case (Call p C s t) thus ?case
  using proc_deps_restrict [of C \<Gamma> p]
    by (auto intro!: exec_other_intros split: option.splits)
next
  case (DynCom f s t) thus ?case
    by - (rule exec.intros, simp, blast)
qed (auto intro: exec_other_intros)

lemma exec_restrict_eq:
  "\<Gamma> |` proc_deps C \<Gamma> \<turnstile> \<langle>C,s\<rangle> \<Rightarrow> t = \<Gamma> \<turnstile> \<langle>C,s\<rangle> \<Rightarrow> t"
  by (fast intro: exec_restrict exec_restrict2)

lemma mem_safe_restrict:
  "mem_safe C \<Gamma> = mem_safe C (\<Gamma> |` proc_deps C \<Gamma>)"
  by (auto simp: mem_safe_def restrict_safe_def restrict_safe_OK_def
                 exec_restrict_eq exec_fatal_def
           split: xstate.splits)

end


theory Timed_Game_Certification_Impl2
  imports Timed_Game_Certification_Impl
begin

text \<open>This theory tried to achieve the same goals as theory \<open>Timed_Game_Certification_Impl\<close> but
turned out too complicated for our purposes.
It is therefore incomplete and can be considered deprecated.
We leave it for now to document the thought process.\<close>

subsection \<open>More Simulation Theorems\<close>

text \<open>These theorems might be useful, maybe they should be moved somewhere else.\<close>

lemma (in Graphs.Simulation) Graph_InvariantI:
  assumes "Graphs.Graph_Invariant B I"
  shows "Graphs.Graph_Invariant A (\<lambda>a. \<exists>b. a \<sim> b \<and> I b)"
  by (smt (verit, ccfv_SIG) Graphs.Graph_Invariant_def A_B_step assms(1))

lemmas Graph_Invariant_simulationI = Simulation.Graph_InvariantI

lemma (in Graphs.Simulation) Graph_Invariant_StartI:
  assumes "Graphs.Graph_Invariant_Start B b\<^sub>0 I" "a\<^sub>0 \<sim> b\<^sub>0"
  shows "Graphs.Graph_Invariant_Start A a\<^sub>0 (\<lambda>a. \<exists>b. a \<sim> b \<and> I b)"
  using assms unfolding Graphs.Graph_Invariant_Start_def Graphs.Graph_Invariant_Start_axioms_def
  by (blast intro: Graph_InvariantI)

lemmas Graph_Invariant_Start_simulationI = Simulation.Graph_Invariant_StartI

lemma (in Graphs.Graph_Invariant) replaceI:
  assumes "P = Q"
  shows "Graphs.Graph_Invariant E Q"
  using Graph_Invariant_axioms assms by simp

lemma (in Graphs.Graph_Invariant_Start) replaceI:
  assumes "P = Q"
  shows "Graphs.Graph_Invariant_Start E s\<^sub>0 Q"
  using Graph_Invariant_Start_axioms assms by simp

lemma (in Graphs.Simulation_Invariant) Graph_InvariantI:
  assumes "Graphs.Graph_Invariant B I"
  shows "Graphs.Graph_Invariant A (\<lambda>a. \<exists>b. PA a \<and> a \<sim> b \<and> I b \<and> PB b)"
  using assms
  by (smt (verit, ccfv_threshold) A_B_step A_invariant B_invariant Graphs.Graph_Invariant_def)

lemma Simulation_Invariant_composition:
  assumes
    "Graphs.Simulation_Invariant A B sim1 PA PB"
    "Graphs.Simulation_Invariant B C sim2 PB PC"
  shows
    "Graphs.Simulation_Invariant A C (\<lambda> a c. \<exists> b. PB b \<and> sim1 a b \<and> sim2 b c) PA PC"
proof -
  interpret A: Graphs.Simulation_Invariant A B sim1 PA PB
    by (rule assms(1))
  interpret B: Graphs.Simulation_Invariant B C sim2 PB PC
    by (rule assms(2))
  show ?thesis
    by (standard; (blast dest: A.A_B_step B.A_B_step))
qed

lemma (in Graphs.Simulation) Simulation_Invariant:
  "Graphs.Simulation_Invariant A B sim (\<lambda>_. True) (\<lambda>_. True)"
  by unfold_locales (rule A_B_step)

lemma Simulation_Invariant_sim_replace:
  assumes "Graphs.Simulation_Invariant A B sim PA PB"
      and "\<And> a b. PA a \<Longrightarrow> PB b \<Longrightarrow> sim a b \<longleftrightarrow> sim' a b"
    shows "Graphs.Simulation_Invariant A B sim' PA PB"
proof -
  interpret Graphs.Simulation_Invariant A B sim PA PB
    by (rule assms(1))
  from assms(2) show ?thesis
    by (unfold_locales; blast dest: A_B_step)
qed

subsection \<open>The Original More Layered Approach\<close>

text \<open>To make it work properly,
  one would need to introduce an invariant already in the zone semantics.\<close>

paragraph \<open>Zone Semantics\<close>

locale Timed_Game_Automaton_Zones =
  Timed_Game_Automaton where A = A for A :: "('a, 'c, 't :: time, 's) ta" +
  fixes Strategy :: "'s \<times> ('c, 't) zone \<Rightarrow> (('c, 't) zone \<times> 'a move set) set"
  assumes strategy_Strategy:
    "a \<in> strategy (l, u) \<Longrightarrow> u \<in> Z \<Longrightarrow> \<exists>Z\<^sub>s M. (Z\<^sub>s, M) \<in> Strategy (l, Z) \<and> a \<in> M \<and> u \<in> Z\<^sub>s"
begin

text \<open>XXX: Choose maximal \<open>Z'\<close>\<close>
\<^cancel>\<open>definition "Strategy \<equiv> \<lambda>(l, Z). {(Z', C) | Z' C. Z' \<subseteq> Z \<and> (\<forall>u \<in> Z'. strategy (l, u) = C)}"\<close>

text \<open>Are strategies convex, i.e. is \<^term>\<open>Strategy(l, Z)\<close> always singleton?\<close>

inductive step_z where
  action: "step_z (l, Z) (l', Z')"
  if "A \<turnstile> \<langle>l, Z\<^sub>s\<rangle> \<leadsto>\<^bsub>\<upharpoonleft>a\<^esub> \<langle>l', Z'\<rangle>" "controllable a" "(Z\<^sub>s, C) \<in> Strategy (l, Z)" "Act a \<in> C"
| wait: "step_z (l, Z) (l', Z')"
  if "A \<turnstile> \<langle>l, Z\<^sub>s\<rangle> \<leadsto>\<^bsub>\<tau>\<^esub> \<langle>l',Z'\<rangle>" "(Z\<^sub>s, C) \<in> Strategy (l, Z)" "Wait \<in> C"
| uncontrolled: "step_z (l, Z) (l', Z')"
  if "A \<turnstile> \<langle>l, Z\<rangle> \<leadsto>\<^bsub>\<upharpoonleft>a\<^esub> \<langle>l', Z'\<rangle>" "\<not> controllable a"

lemma strategy_StrategyE:
  assumes "u \<in> Z" "a \<in> strategy (l, u)"
  obtains Z\<^sub>s M where "(Z\<^sub>s, M) \<in> Strategy (l, Z)" "a \<in> M" \<^cancel>\<open>"Z\<^sub>s \<subseteq> Z"\<close> "u \<in> Z\<^sub>s"
  using assms by atomize_elim (rule strategy_Strategy)

sublocale zone_simulation:
  Graphs.Simulation
  step
  "\<lambda> (l, Z) (l', Z'). step_z (l, Z) (l', Z') \<and> Z' \<noteq> {}"
  "\<lambda> (l, u) (l', Z). l' = l \<and> u \<in> Z"
  apply standard
  apply clarsimp
  apply (erule step.cases; clarsimp; (erule (1) strategy_StrategyE)?)
    apply (auto intro: step_z.intros dest!: step_a_z_complete step_t_z_complete)
  done

end

paragraph \<open>Concrete Semantics To Zone Semantics\<close>
context Timed_Safety_Game_Strat
begin

thm invariant_safe_fromI

\<comment> \<open>We directly establish the invariant in the end, see below.\<close>
lemma invariant_safe_fromI:
  assumes "Labeled_Graphs.Graph_Invariant_Start (\<lambda> (l, Z) a (l', Z'). step_z (l, Z) a (l', Z') \<and> Z' \<noteq> {}) (l\<^sub>0, Z\<^sub>0) I"
    "\<forall>l Z. I (l, Z) \<longrightarrow> from_R l Z \<inter> K = {}" "u\<^sub>0 \<in> Z\<^sub>0"
  shows "safe_from (l\<^sub>0, u\<^sub>0)"
  apply (rule invariant_safe_fromI[where I = "\<lambda>(l, u). \<exists>Z. I (l, Z) \<and> u \<in> Z"])
  apply (rule Graph_Invariant_Start.replaceI)
  apply (rule zone_simulation.Graph_Invariant_StartI)
  using assms by auto

end

paragraph \<open>Zone Semantics To Implementation Semantics\<close>

locale TGA_Start_Defs1 =
  \<^cancel>\<open>TA_Start_Defs where A = A for A :: "('a, nat, int, 's) ta" +\<close>
  TA_Impl_Precise where A = A for A :: "('a, nat, int, 's) ta" +
  fixes controllable :: "'a \<Rightarrow> bool"
  fixes strategy :: "('a, nat, real, 's) strategy"
  fixes S :: "'s \<times> int DBM' \<Rightarrow> (int DBM' \<times> 'a move set) set"
  fixes K :: "(nat, real, 's) ta_config set"
  assumes strategy_S:
    "a \<in> strategy (l, u) \<Longrightarrow> u \<in> [curry (conv_M M)]\<^bsub>v,n\<^esub> \<Longrightarrow> wf_state (l, M)
  \<Longrightarrow> \<exists>M\<^sub>s C. (M\<^sub>s, C) \<in> S (l, M) \<and> a \<in> C \<and> u \<in> [curry (conv_M M\<^sub>s)]\<^bsub>v,n\<^esub>"
begin

term "conv_A A \<turnstile> \<langle>l, Z\<rangle> \<leadsto> \<langle>l', Z'\<rangle>"

sublocale sem: Timed_Game_Automaton "conv_A A" controllable strategy .

definition
  "Strategy \<equiv> \<lambda>(l, Z).
    {([curry (conv_M M\<^sub>s)]\<^bsub>v,n\<^esub>, C) | M\<^sub>s C. \<exists>M. Z = [curry (conv_M M)]\<^bsub>v,n\<^esub> \<and> (M\<^sub>s, C) \<in> S (l, M)}"

inductive step_z where
  action: "step_z (l, Z) (l', Z')"
  if "conv_A A \<turnstile> \<langle>l, Z\<^sub>s\<rangle> \<leadsto>\<^bsub>\<upharpoonleft>a\<^esub> \<langle>l', Z'\<rangle>" "controllable a" "(Z\<^sub>s, C) \<in> Strategy (l, Z)" "Act a \<in> C"
| wait: "step_z (l, Z) (l', Z')"
  if "conv_A A \<turnstile> \<langle>l, Z\<^sub>s\<rangle> \<leadsto>\<^bsub>\<tau>\<^esub> \<langle>l',Z'\<rangle>" "(Z\<^sub>s, C) \<in> Strategy (l, Z)" "Wait \<in> C"
| uncontrolled: "step_z (l, Z) (l', Z')"
  if "conv_A A \<turnstile> \<langle>l, Z\<rangle> \<leadsto>\<^bsub>\<upharpoonleft>a\<^esub> \<langle>l', Z'\<rangle>" "\<not> controllable a"

lemma strategy_StrategyE:
  assumes "u \<in> Z" "a \<in> strategy (l, u)" "Z = [curry (conv_M M)]\<^bsub>v,n\<^esub>" "wf_state (l, M)"
  obtains Z\<^sub>s M where "(Z\<^sub>s, M) \<in> Strategy (l, Z)" "a \<in> M" \<^cancel>\<open>"Z\<^sub>s \<subseteq> Z"\<close> "u \<in> Z\<^sub>s"
  using assms
  unfolding Strategy_def
  by (blast dest!: strategy_S[where M = M])

sublocale sem: Timed_Game_Automaton_Zones controllable strategy "conv_A A" Strategy
  apply standard
  sorry

inductive step_impl where
  action: "step_impl (l, M) (l', M')"
  if "op_precise.E_from_op_empty (l, M\<^sub>s) (\<upharpoonleft>a) (l', M')"
  "controllable a" "(M\<^sub>s, C) \<in> S (l, M)" "Act a \<in> C"
| wait: "step_impl (l, M) (l', M')"
  if "op_precise.E_from_op_empty (l, M\<^sub>s) \<tau> (l', M')" "(M\<^sub>s, C) \<in> S (l, M)" "Wait \<in> C"
| uncontrolled: "step_impl (l, M) (l', M')"
  if "op_precise.E_from_op_empty (l, M) (\<upharpoonleft>a) (l', M')" "\<not> controllable a"

sublocale sem: Timed_Safety_Game_Strat "conv_A A" controllable K strategy .

lemma S_dbm_equivE:
  assumes "(M\<^sub>s, C) \<in> S (l, M)" "M \<simeq> M'"
  obtains M\<^sub>s' where "(M\<^sub>s', C) \<in> S (l, M')" "M\<^sub>s \<simeq> M\<^sub>s'"
  sorry

lemma strategy_SimulationE:
  assumes "(Z\<^sub>s, C) \<in> Strategy (l, [curry (conv_M M)]\<^bsub>v,n\<^esub>)" "wf_state (l, M)"
  obtains M\<^sub>s where "(M\<^sub>s, C) \<in> S (l, M)" "Z\<^sub>s = [curry (conv_M M\<^sub>s)]\<^bsub>v,n\<^esub>"
  apply atomize_elim
  using assms
  unfolding Strategy_def
  apply (auto 4 3 simp: dbm_equiv_def elim: S_dbm_equivE[where M' = M])
  done

lemma strategy_split_preserves_wf_state:
  assumes "(M\<^sub>s, C) \<in> S (l, M)" "wf_state (l, M)"
  shows "wf_state (l, M\<^sub>s)"
  sorry

interpretation bisim_empty_zone:
  Bisimulation_Invariant
  "\<lambda>(l, Z) a (l', Z'). conv_A A \<turnstile> \<langle>l, Z\<rangle> \<leadsto>\<^bsub>a\<^esub> \<langle>l', Z'\<rangle> \<and> Z' \<noteq> {}"
  op_precise.E_from_op_empty
  "\<lambda>(l, Z) (l', D). l' = l \<and> [curry (conv_M D)]\<^bsub>v,n\<^esub> = Z"
  "\<lambda>_. True"
  wf_state
  by (rule op_precise.step_z_E_from_op_bisim_empty)

sublocale zone_impl_simulation:
  Graphs.Simulation_Invariant
  "\<lambda> (l, Z) (l', Z'). sem.step_z (l, Z) (l', Z') \<and> Z' \<noteq> {}"
  step_impl
  "\<lambda>(l, Z) (l', D). l' = l \<and> [curry (conv_M D)]\<^bsub>v,n\<^esub> = Z"
  "\<lambda>_. True"
  wf_state
proof (standard; (clarsimp simp del: One_nat_def)?)
  fix l l' :: 's and Z' :: "(nat \<Rightarrow> real) set" and M :: "int DBM'"
  assume
    "wf_state (l, M)" and
    sem_step: "sem.step_z (l, [curry (conv_M M)]\<^bsub>v,n\<^esub>) (l', Z')" and
    "Z' \<noteq> {}"
  from sem_step show "\<exists>b. local.step_impl (l, M) (l', b) \<and> [curry (conv_M b)]\<^bsub>v,n\<^esub> = Z'"
  proof cases
    case (action Z\<^sub>s a C)
    from strategy_SimulationE[OF action(3) \<open>wf_state _\<close>] obtain M\<^sub>s where
      "(M\<^sub>s, C) \<in> S (l, M)"
      "Z\<^sub>s = [curry (conv_M M\<^sub>s)]\<^bsub>v,n\<^esub>" .
    have "wf_state (l, M\<^sub>s)"
      using \<open>(M\<^sub>s, C) \<in> S (l, M)\<close> \<open>wf_state (l, M)\<close> by (rule strategy_split_preserves_wf_state)
    with bisim_empty_zone.A_B_step[of "(l, Z\<^sub>s)" "\<upharpoonleft>a" "(l', Z')" "(l, M\<^sub>s)", simplified]
      action(1) \<open>Z' \<noteq> {}\<close> \<open>Z\<^sub>s = _\<close>
    obtain M' where
      "op_precise.E_from_op_empty (l, M\<^sub>s) \<upharpoonleft>a (l', M')" "[curry (conv_M M')]\<^bsub>v,n\<^esub> = Z'"
      by metis
    with action(2,4) \<open>_\<in> S (l, M)\<close> show ?thesis
      by (inst_existentials M') (rule step_impl.intros; simp)
  next
    case (wait Z\<^sub>s C)
    from strategy_SimulationE[OF wait(2) \<open>wf_state _\<close>] obtain M\<^sub>s where
      "(M\<^sub>s, C) \<in> S (l, M)"
      "Z\<^sub>s = [curry (conv_M M\<^sub>s)]\<^bsub>v,n\<^esub>" .
    have "wf_state (l, M\<^sub>s)"
      using \<open>(M\<^sub>s, C) \<in> S (l, M)\<close> \<open>wf_state (l, M)\<close> by (rule strategy_split_preserves_wf_state)
    with bisim_empty_zone.A_B_step[of "(l, Z\<^sub>s)" \<tau> "(l', Z')" "(l, M\<^sub>s)", simplified]
      wait(1) \<open>Z' \<noteq> {}\<close> \<open>Z\<^sub>s = _\<close>
    obtain M' where
      "op_precise.E_from_op_empty (l, M\<^sub>s) \<tau> (l', M')" "[curry (conv_M M')]\<^bsub>v,n\<^esub> = Z'"
      by metis
    with wait(3) \<open>_\<in> S (l, M)\<close> show ?thesis
      by (inst_existentials M') (rule step_impl.intros; simp)
  next
    case (uncontrolled a)
    from bisim_empty_zone.A_B_step[of _ "\<upharpoonleft>a" "(l', Z')" "(l, M)", simplified]
      uncontrolled(1) \<open>Z' \<noteq> {}\<close> \<open>wf_state _\<close>
    obtain M' where
      "op_precise.E_from_op_empty (l, M) \<upharpoonleft>a (l', M')" "[curry (conv_M M')]\<^bsub>v,n\<^esub> = Z'"
      by auto
    with uncontrolled(2-) show ?thesis
      by (inst_existentials M') (rule step_impl.intros; simp)
  qed
next
  fix l l' :: 's and M M' :: "int DBM'"
  assume "wf_state (l, M)" "step_impl (l, M) (l', M')"
  from this(2,1) show "wf_state (l', M')"
    by (cases; elim bisim_empty_zone.B_invariant[rotated] strategy_split_preserves_wf_state)
qed

sublocale sem_impl_simulation:
  Graphs.Simulation_Invariant
  sem.step
  step_impl
  "\<lambda>(l, u) (l', D). l' = l \<and> u \<in> [curry (conv_M D)]\<^bsub>v,n\<^esub>"
  "\<lambda>_. True"
  wf_state
  apply (rule Simulation_Invariant_sim_replace)
   apply (rule Simulation_Invariant_composition)
    apply (rule sem.zone_simulation.Simulation_Invariant)
   apply (rule zone_impl_simulation.Simulation_Invariant_axioms)
  apply auto
  done

lemma invariant_safe_fromI:
  assumes "Graph_Invariant_Start step_impl (l\<^sub>0, Z\<^sub>0) I"
    "\<forall>l Z. I (l, Z) \<longrightarrow> from_R l ([curry (conv_M Z)]\<^bsub>v,n\<^esub>) \<inter> K = {}"
    "u\<^sub>0 \<in> [curry (conv_M Z\<^sub>0)]\<^bsub>v,n\<^esub>" "wf_state (l\<^sub>0, Z\<^sub>0)"
  shows "sem.safe_from (l\<^sub>0, u\<^sub>0)"
proof -
  interpret inv: Graph_Invariant_Start step_impl "(l\<^sub>0, Z\<^sub>0)" I
    by (rule assms)
  show ?thesis
    unfolding sem.safe_from_alt_def using assms
    by (auto dest!: inv.invariant_reaches
          sem_impl_simulation.simulation_reaches[where b = "(l\<^sub>0, Z\<^sub>0)"])
qed

lemma safe_fromI:
  "sem.safe_from (l\<^sub>0, u\<^sub>0)"
  if "(\<nexists>l' D'. step_impl\<^sup>*\<^sup>* (l\<^sub>0, D\<^sub>0) (l', D') \<and> from_R l' ([curry (conv_M D')]\<^bsub>v,n\<^esub>) \<inter> K \<noteq> {})"
    "u\<^sub>0 \<in> [curry (conv_M D\<^sub>0)]\<^bsub>v,n\<^esub>" "wf_dbm D\<^sub>0"
  unfolding sem.safe_from_alt_def using that
  by (auto simp: wf_state_def dest!: sem_impl_simulation.simulation_reaches[where b = "(l\<^sub>0, D\<^sub>0)"])

end

end


theory Free_Ext
  imports
    Extended_Assertion
    Free
begin

context rbt_impl
begin

lemma free_correct_ext [vcg_rules]:
  "
    llvm_htriple
    (rbt_assn_ext t {} ti)
    (free ti)
    (\<lambda>_. \<box>)
  "
proof(induction t arbitrary: ti)
  case ATEmpty
  then show ?case
    apply (subst free.simps)
    apply vcg
    done
next
  case (ATBranch c k v ci li ki vi ri al ar)

  note [vcg_rules] = ATBranch.IH

  then show ?case
    apply (subst free.simps)
    apply vcg
    done
qed

end

end


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

theory longlong
imports "../CTranslation"
begin

install_C_file "longlong.c"

ML {* NameGeneration.return_var_name (Absyn.Signed Absyn.LongLong) *}

context longlong
begin

thm f_body_def
thm shifts1_body_def
thm shifts2_body_def

lemma "(ucast :: 16 word \<Rightarrow> 8 word) 32768 = 0"
apply simp
done

lemma "(scast :: 16 word \<Rightarrow> 8 word) 32768 = 0"
by simp

lemma "(scast :: 16 word \<Rightarrow> 8 word) 65535 = 255"
by simp

lemma "(ucast :: 16 word \<Rightarrow> 8 word) 65535 = 255"
by simp

lemma "(ucast :: 16 word \<Rightarrow> 8 word) 32767 = 255" by simp
lemma "(scast :: 16 word \<Rightarrow> 8 word) 32767 = 255" by simp

lemma "(scast :: 8 word \<Rightarrow> 16 word) 255 = 65535" by simp
lemma "(ucast :: 8 word \<Rightarrow> 16 word) 255 = 255" by simp

lemma sint_1 [simp]: "1 < len_of TYPE('a) \<Longrightarrow> sint (1 :: 'a::len word) = 1"
apply (subgoal_tac "1 \<in> sints (len_of TYPE ('a))")
  defer
  apply (simp add: sints_num)
  apply (rule order_trans [where y = 0])
    apply simp
  apply simp
  apply (drule Word.word_sint.Abs_inverse)
  apply (simp add: Word.word_of_int_hom_syms)
done

lemma g_result:
  "\<Gamma> \<turnstile> \<lbrace> True \<rbrace> \<acute>ret__int :== CALL callg() \<lbrace> \<acute>ret__int = 0 \<rbrace>"
apply vcg
apply (simp add: max_word_def)
done

thm literals_body_def

lemma literals_result:
  "\<Gamma> \<turnstile> \<lbrace> True \<rbrace> \<acute>ret__int :== CALL literals() \<lbrace> \<acute>ret__int = 31 \<rbrace>"
apply vcg
apply simp
done

end (* context *)

end (* theory *)


(*  Title:      HOL/Auth/Yahalom2.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1996  University of Cambridge
*)

section\<open>The Yahalom Protocol, Variant 2\<close>

theory Yahalom2 imports Public begin

text\<open>
This version trades encryption of NB for additional explicitness in YM3.
Also in YM3, care is taken to make the two certificates distinct.

From page 259 of
  Burrows, Abadi and Needham (1989).  A Logic of Authentication.
  Proc. Royal Soc. 426

This theory has the prototypical example of a secrecy relation, KeyCryptNonce.
\<close>

inductive_set yahalom :: "event list set"
  where
         (*Initial trace is empty*)
   Nil:  "[] \<in> yahalom"

         (*The spy MAY say anything he CAN say.  We do not expect him to
           invent new nonces here, but he can also use NS1.  Common to
           all similar protocols.*)
 | Fake: "\<lbrakk>evsf \<in> yahalom;  X \<in> synth (analz (knows Spy evsf))\<rbrakk>
          \<Longrightarrow> Says Spy B X  # evsf \<in> yahalom"

         (*A message that has been sent can be received by the
           intended recipient.*)
 | Reception: "\<lbrakk>evsr \<in> yahalom;  Says A B X \<in> set evsr\<rbrakk>
               \<Longrightarrow> Gets B X # evsr \<in> yahalom"

         (*Alice initiates a protocol run*)
 | YM1:  "\<lbrakk>evs1 \<in> yahalom;  Nonce NA \<notin> used evs1\<rbrakk>
          \<Longrightarrow> Says A B \<lbrace>Agent A, Nonce NA\<rbrace> # evs1 \<in> yahalom"

         (*Bob's response to Alice's message.*)
 | YM2:  "\<lbrakk>evs2 \<in> yahalom;  Nonce NB \<notin> used evs2;
             Gets B \<lbrace>Agent A, Nonce NA\<rbrace> \<in> set evs2\<rbrakk>
          \<Longrightarrow> Says B Server
                  \<lbrace>Agent B, Nonce NB, Crypt (shrK B) \<lbrace>Agent A, Nonce NA\<rbrace>\<rbrace>
                # evs2 \<in> yahalom"

         (*The Server receives Bob's message.  He responds by sending a
           new session key to Alice, with a certificate for forwarding to Bob.
           Both agents are quoted in the 2nd certificate to prevent attacks!*)
 | YM3:  "\<lbrakk>evs3 \<in> yahalom;  Key KAB \<notin> used evs3;
             Gets Server \<lbrace>Agent B, Nonce NB,
                           Crypt (shrK B) \<lbrace>Agent A, Nonce NA\<rbrace>\<rbrace>
               \<in> set evs3\<rbrakk>
          \<Longrightarrow> Says Server A
               \<lbrace>Nonce NB,
                 Crypt (shrK A) \<lbrace>Agent B, Key KAB, Nonce NA\<rbrace>,
                 Crypt (shrK B) \<lbrace>Agent A, Agent B, Key KAB, Nonce NB\<rbrace>\<rbrace>
                 # evs3 \<in> yahalom"

         (*Alice receives the Server's (?) message, checks her Nonce, and
           uses the new session key to send Bob his Nonce.*)
 | YM4:  "\<lbrakk>evs4 \<in> yahalom;
             Gets A \<lbrace>Nonce NB, Crypt (shrK A) \<lbrace>Agent B, Key K, Nonce NA\<rbrace>,
                      X\<rbrace>  \<in> set evs4;
             Says A B \<lbrace>Agent A, Nonce NA\<rbrace> \<in> set evs4\<rbrakk>
          \<Longrightarrow> Says A B \<lbrace>X, Crypt K (Nonce NB)\<rbrace> # evs4 \<in> yahalom"

         (*This message models possible leaks of session keys.  The nonces
           identify the protocol run.  Quoting Server here ensures they are
           correct. *)
 | Oops: "\<lbrakk>evso \<in> yahalom;
             Says Server A \<lbrace>Nonce NB,
                             Crypt (shrK A) \<lbrace>Agent B, Key K, Nonce NA\<rbrace>,
                             X\<rbrace>  \<in> set evso\<rbrakk>
          \<Longrightarrow> Notes Spy \<lbrace>Nonce NA, Nonce NB, Key K\<rbrace> # evso \<in> yahalom"

declare Says_imp_knows_Spy [THEN analz.Inj, dest]
declare parts.Body  [dest]
declare Fake_parts_insert_in_Un  [dest]
declare analz_into_parts [dest]

text\<open>A "possibility property": there are traces that reach the end\<close>
lemma "Key K \<notin> used []
       \<Longrightarrow> \<exists>X NB. \<exists>evs \<in> yahalom.
             Says A B \<lbrace>X, Crypt K (Nonce NB)\<rbrace> \<in> set evs"
apply (intro exI bexI)
apply (rule_tac [2] yahalom.Nil
                    [THEN yahalom.YM1, THEN yahalom.Reception,
                     THEN yahalom.YM2, THEN yahalom.Reception,
                     THEN yahalom.YM3, THEN yahalom.Reception,
                     THEN yahalom.YM4])
apply (possibility, simp add: used_Cons)
done

lemma Gets_imp_Says:
     "\<lbrakk>Gets B X \<in> set evs; evs \<in> yahalom\<rbrakk> \<Longrightarrow> \<exists>A. Says A B X \<in> set evs"
by (erule rev_mp, erule yahalom.induct, auto)

text\<open>Must be proved separately for each protocol\<close>
lemma Gets_imp_knows_Spy:
     "\<lbrakk>Gets B X \<in> set evs; evs \<in> yahalom\<rbrakk>  \<Longrightarrow> X \<in> knows Spy evs"
by (blast dest!: Gets_imp_Says Says_imp_knows_Spy)

declare Gets_imp_knows_Spy [THEN analz.Inj, dest]

subsection\<open>Inductive Proofs\<close>

text\<open>Result for reasoning about the encrypted portion of messages.
Lets us treat YM4 using a similar argument as for the Fake case.\<close>
lemma YM4_analz_knows_Spy:
     "\<lbrakk>Gets A \<lbrace>NB, Crypt (shrK A) Y, X\<rbrace> \<in> set evs;  evs \<in> yahalom\<rbrakk>
      \<Longrightarrow> X \<in> analz (knows Spy evs)"
by blast

lemmas YM4_parts_knows_Spy =
       YM4_analz_knows_Spy [THEN analz_into_parts]

(** Theorems of the form X \<notin> parts (knows Spy evs) imply that NOBODY
    sends messages containing X! **)

text\<open>Spy never sees a good agent's shared key!\<close>
lemma Spy_see_shrK [simp]:
     "evs \<in> yahalom \<Longrightarrow> (Key (shrK A) \<in> parts (knows Spy evs)) = (A \<in> bad)"
by (erule yahalom.induct, force,
    drule_tac [6] YM4_parts_knows_Spy, simp_all, blast+)

lemma Spy_analz_shrK [simp]:
     "evs \<in> yahalom \<Longrightarrow> (Key (shrK A) \<in> analz (knows Spy evs)) = (A \<in> bad)"
by auto

lemma Spy_see_shrK_D [dest!]:
     "\<lbrakk>Key (shrK A) \<in> parts (knows Spy evs);  evs \<in> yahalom\<rbrakk> \<Longrightarrow> A \<in> bad"
by (blast dest: Spy_see_shrK)

text\<open>Nobody can have used non-existent keys!
    Needed to apply \<open>analz_insert_Key\<close>\<close>
lemma new_keys_not_used [simp]:
    "\<lbrakk>Key K \<notin> used evs; K \<in> symKeys; evs \<in> yahalom\<rbrakk>
     \<Longrightarrow> K \<notin> keysFor (parts (spies evs))"
apply (erule rev_mp)
apply (erule yahalom.induct, force,
       frule_tac [6] YM4_parts_knows_Spy, simp_all)
subgoal \<comment> \<open>Fake\<close> by (force dest!: keysFor_parts_insert)
subgoal \<comment> \<open>YM3\<close>by blast
subgoal \<comment> \<open>YM4\<close> by (fastforce dest!: Gets_imp_knows_Spy [THEN parts.Inj])
done

text\<open>Describes the form of K when the Server sends this message.  Useful for
  Oops as well as main secrecy property.\<close>
lemma Says_Server_message_form:
     "\<lbrakk>Says Server A \<lbrace>nb', Crypt (shrK A) \<lbrace>Agent B, Key K, na\<rbrace>, X\<rbrace>
          \<in> set evs;  evs \<in> yahalom\<rbrakk>
      \<Longrightarrow> K \<notin> range shrK"
by (erule rev_mp, erule yahalom.induct, simp_all)

(****
 The following is to prove theorems of the form

          Key K \<in> analz (insert (Key KAB) (knows Spy evs)) \<Longrightarrow>
          Key K \<in> analz (knows Spy evs)

 A more general formula must be proved inductively.
****)

(** Session keys are not used to encrypt other session keys **)

lemma analz_image_freshK [rule_format]:
 "evs \<in> yahalom \<Longrightarrow>
   \<forall>K KK. KK \<subseteq> - (range shrK) \<longrightarrow>
          (Key K \<in> analz (Key`KK \<union> (knows Spy evs))) =
          (K \<in> KK | Key K \<in> analz (knows Spy evs))"
apply (erule yahalom.induct)
apply (frule_tac [8] Says_Server_message_form)
apply (drule_tac [7] YM4_analz_knows_Spy, analz_freshK, spy_analz, blast)
done

lemma analz_insert_freshK:
     "\<lbrakk>evs \<in> yahalom;  KAB \<notin> range shrK\<rbrakk> \<Longrightarrow>
      (Key K \<in> analz (insert (Key KAB) (knows Spy evs))) =
      (K = KAB | Key K \<in> analz (knows Spy evs))"
by (simp only: analz_image_freshK analz_image_freshK_simps)

text\<open>The Key K uniquely identifies the Server's  message\<close>
lemma unique_session_keys:
     "\<lbrakk>Says Server A
          \<lbrace>nb, Crypt (shrK A) \<lbrace>Agent B, Key K, na\<rbrace>, X\<rbrace> \<in> set evs;
        Says Server A'
          \<lbrace>nb', Crypt (shrK A') \<lbrace>Agent B', Key K, na'\<rbrace>, X'\<rbrace> \<in> set evs;
        evs \<in> yahalom\<rbrakk>
     \<Longrightarrow> A=A' \<and> B=B' \<and> na=na' \<and> nb=nb'"
apply (erule rev_mp, erule rev_mp)
apply (erule yahalom.induct, simp_all)
txt\<open>YM3, by freshness\<close>
apply blast
done

subsection\<open>Crucial Secrecy Property: Spy Does Not See Key \<^term>\<open>KAB\<close>\<close>

lemma secrecy_lemma:
     "\<lbrakk>A \<notin> bad;  B \<notin> bad;  evs \<in> yahalom\<rbrakk>
      \<Longrightarrow> Says Server A
            \<lbrace>nb, Crypt (shrK A) \<lbrace>Agent B, Key K, na\<rbrace>,
                  Crypt (shrK B) \<lbrace>Agent A, Agent B, Key K, nb\<rbrace>\<rbrace>
           \<in> set evs \<longrightarrow>
          Notes Spy \<lbrace>na, nb, Key K\<rbrace> \<notin> set evs \<longrightarrow>
          Key K \<notin> analz (knows Spy evs)"
apply (erule yahalom.induct, force, frule_tac [7] Says_Server_message_form,
       drule_tac [6] YM4_analz_knows_Spy)
apply (simp_all add: pushes analz_insert_eq analz_insert_freshK, spy_analz)
apply (blast dest: unique_session_keys)+  (*YM3, Oops*)
done

text\<open>Final version\<close>
lemma Spy_not_see_encrypted_key:
     "\<lbrakk>Says Server A
            \<lbrace>nb, Crypt (shrK A) \<lbrace>Agent B, Key K, na\<rbrace>,
                  Crypt (shrK B) \<lbrace>Agent A, Agent B, Key K, nb\<rbrace>\<rbrace>
         \<in> set evs;
         Notes Spy \<lbrace>na, nb, Key K\<rbrace> \<notin> set evs;
         A \<notin> bad;  B \<notin> bad;  evs \<in> yahalom\<rbrakk>
      \<Longrightarrow> Key K \<notin> analz (knows Spy evs)"
by (blast dest: secrecy_lemma Says_Server_message_form)

text\<open>This form is an immediate consequence of the previous result.  It is
similar to the assertions established by other methods.  It is equivalent
to the previous result in that the Spy already has \<^term>\<open>analz\<close> and
\<^term>\<open>synth\<close> at his disposal.  However, the conclusion
\<^term>\<open>Key K \<notin> knows Spy evs\<close> appears not to be inductive: all the cases
other than Fake are trivial, while Fake requires
\<^term>\<open>Key K \<notin> analz (knows Spy evs)\<close>.\<close>
lemma Spy_not_know_encrypted_key:
     "\<lbrakk>Says Server A
            \<lbrace>nb, Crypt (shrK A) \<lbrace>Agent B, Key K, na\<rbrace>,
                  Crypt (shrK B) \<lbrace>Agent A, Agent B, Key K, nb\<rbrace>\<rbrace>
         \<in> set evs;
         Notes Spy \<lbrace>na, nb, Key K\<rbrace> \<notin> set evs;
         A \<notin> bad;  B \<notin> bad;  evs \<in> yahalom\<rbrakk>
      \<Longrightarrow> Key K \<notin> knows Spy evs"
by (blast dest: Spy_not_see_encrypted_key)

subsection\<open>Security Guarantee for A upon receiving YM3\<close>

text\<open>If the encrypted message appears then it originated with the Server.
  May now apply \<open>Spy_not_see_encrypted_key\<close>, subject to its conditions.\<close>
lemma A_trusts_YM3:
     "\<lbrakk>Crypt (shrK A) \<lbrace>Agent B, Key K, na\<rbrace> \<in> parts (knows Spy evs);
         A \<notin> bad;  evs \<in> yahalom\<rbrakk>
      \<Longrightarrow> \<exists>nb. Says Server A
                    \<lbrace>nb, Crypt (shrK A) \<lbrace>Agent B, Key K, na\<rbrace>,
                          Crypt (shrK B) \<lbrace>Agent A, Agent B, Key K, nb\<rbrace>\<rbrace>
                  \<in> set evs"
apply (erule rev_mp)
apply (erule yahalom.induct, force,
       frule_tac [6] YM4_parts_knows_Spy, simp_all)
txt\<open>Fake, YM3\<close>
apply blast+
done

text\<open>The obvious combination of \<open>A_trusts_YM3\<close> with
\<open>Spy_not_see_encrypted_key\<close>\<close>
theorem A_gets_good_key:
     "\<lbrakk>Crypt (shrK A) \<lbrace>Agent B, Key K, na\<rbrace> \<in> parts (knows Spy evs);
         \<forall>nb. Notes Spy \<lbrace>na, nb, Key K\<rbrace> \<notin> set evs;
         A \<notin> bad;  B \<notin> bad;  evs \<in> yahalom\<rbrakk>
      \<Longrightarrow> Key K \<notin> analz (knows Spy evs)"
by (blast dest!: A_trusts_YM3 Spy_not_see_encrypted_key)

subsection\<open>Security Guarantee for B upon receiving YM4\<close>

text\<open>B knows, by the first part of A's message, that the Server distributed
  the key for A and B, and has associated it with NB.\<close>
lemma B_trusts_YM4_shrK:
     "\<lbrakk>Crypt (shrK B) \<lbrace>Agent A, Agent B, Key K, Nonce NB\<rbrace>
           \<in> parts (knows Spy evs);
         B \<notin> bad;  evs \<in> yahalom\<rbrakk>
  \<Longrightarrow> \<exists>NA. Says Server A
             \<lbrace>Nonce NB,
               Crypt (shrK A) \<lbrace>Agent B, Key K, Nonce NA\<rbrace>,
               Crypt (shrK B) \<lbrace>Agent A, Agent B, Key K, Nonce NB\<rbrace>\<rbrace>
             \<in> set evs"
apply (erule rev_mp)
apply (erule yahalom.induct, force,
       frule_tac [6] YM4_parts_knows_Spy, simp_all)
txt\<open>Fake, YM3\<close>
apply blast+
done

text\<open>With this protocol variant, we don't need the 2nd part of YM4 at all:
  Nonce NB is available in the first part.\<close>

text\<open>What can B deduce from receipt of YM4?  Stronger and simpler than Yahalom
  because we do not have to show that NB is secret.\<close>
lemma B_trusts_YM4:
     "\<lbrakk>Gets B \<lbrace>Crypt (shrK B) \<lbrace>Agent A, Agent B, Key K, Nonce NB\<rbrace>,  X\<rbrace>
           \<in> set evs;
         A \<notin> bad;  B \<notin> bad;  evs \<in> yahalom\<rbrakk>
  \<Longrightarrow> \<exists>NA. Says Server A
             \<lbrace>Nonce NB,
               Crypt (shrK A) \<lbrace>Agent B, Key K, Nonce NA\<rbrace>,
               Crypt (shrK B) \<lbrace>Agent A, Agent B, Key K, Nonce NB\<rbrace>\<rbrace>
            \<in> set evs"
by (blast dest!: B_trusts_YM4_shrK)

text\<open>The obvious combination of \<open>B_trusts_YM4\<close> with
\<open>Spy_not_see_encrypted_key\<close>\<close>
theorem B_gets_good_key:
     "\<lbrakk>Gets B \<lbrace>Crypt (shrK B) \<lbrace>Agent A, Agent B, Key K, Nonce NB\<rbrace>, X\<rbrace>
           \<in> set evs;
         \<forall>na. Notes Spy \<lbrace>na, Nonce NB, Key K\<rbrace> \<notin> set evs;
         A \<notin> bad;  B \<notin> bad;  evs \<in> yahalom\<rbrakk>
      \<Longrightarrow> Key K \<notin> analz (knows Spy evs)"
by (blast dest!: B_trusts_YM4 Spy_not_see_encrypted_key)

subsection\<open>Authenticating B to A\<close>

text\<open>The encryption in message YM2 tells us it cannot be faked.\<close>
lemma B_Said_YM2:
     "\<lbrakk>Crypt (shrK B) \<lbrace>Agent A, Nonce NA\<rbrace> \<in> parts (knows Spy evs);
         B \<notin> bad;  evs \<in> yahalom\<rbrakk>
      \<Longrightarrow> \<exists>NB. Says B Server \<lbrace>Agent B, Nonce NB,
                               Crypt (shrK B) \<lbrace>Agent A, Nonce NA\<rbrace>\<rbrace>
                      \<in> set evs"
apply (erule rev_mp)
apply (erule yahalom.induct, force,
       frule_tac [6] YM4_parts_knows_Spy, simp_all)
txt\<open>Fake, YM2\<close>
apply blast+
done

text\<open>If the server sends YM3 then B sent YM2, perhaps with a different NB\<close>
lemma YM3_auth_B_to_A_lemma:
     "\<lbrakk>Says Server A \<lbrace>nb, Crypt (shrK A) \<lbrace>Agent B, Key K, Nonce NA\<rbrace>, X\<rbrace>
           \<in> set evs;
         B \<notin> bad;  evs \<in> yahalom\<rbrakk>
      \<Longrightarrow> \<exists>nb'. Says B Server \<lbrace>Agent B, nb',
                                   Crypt (shrK B) \<lbrace>Agent A, Nonce NA\<rbrace>\<rbrace>
                       \<in> set evs"
apply (erule rev_mp)
apply (erule yahalom.induct, simp_all)
txt\<open>Fake, YM2, YM3\<close>
apply (blast dest!: B_Said_YM2)+
done

text\<open>If A receives YM3 then B has used nonce NA (and therefore is alive)\<close>
theorem YM3_auth_B_to_A:
     "\<lbrakk>Gets A \<lbrace>nb, Crypt (shrK A) \<lbrace>Agent B, Key K, Nonce NA\<rbrace>, X\<rbrace>
           \<in> set evs;
         A \<notin> bad;  B \<notin> bad;  evs \<in> yahalom\<rbrakk>
 \<Longrightarrow> \<exists>nb'. Says B Server
                  \<lbrace>Agent B, nb', Crypt (shrK B) \<lbrace>Agent A, Nonce NA\<rbrace>\<rbrace>
               \<in> set evs"
by (blast dest!: A_trusts_YM3 YM3_auth_B_to_A_lemma)

subsection\<open>Authenticating A to B\<close>

text\<open>using the certificate \<^term>\<open>Crypt K (Nonce NB)\<close>\<close>

text\<open>Assuming the session key is secure, if both certificates are present then
  A has said NB.  We can't be sure about the rest of A's message, but only
  NB matters for freshness.  Note that \<^term>\<open>Key K \<notin> analz (knows Spy evs)\<close>
  must be the FIRST antecedent of the induction formula.\<close>

text\<open>This lemma allows a use of \<open>unique_session_keys\<close> in the next proof,
  which otherwise is extremely slow.\<close>
lemma secure_unique_session_keys:
     "\<lbrakk>Crypt (shrK A) \<lbrace>Agent B, Key K, na\<rbrace> \<in> analz (spies evs);
         Crypt (shrK A') \<lbrace>Agent B', Key K, na'\<rbrace> \<in> analz (spies evs);
         Key K \<notin> analz (knows Spy evs);  evs \<in> yahalom\<rbrakk>
     \<Longrightarrow> A=A' \<and> B=B'"
by (blast dest!: A_trusts_YM3 dest: unique_session_keys Crypt_Spy_analz_bad)

lemma Auth_A_to_B_lemma [rule_format]:
     "evs \<in> yahalom
      \<Longrightarrow> Key K \<notin> analz (knows Spy evs) \<longrightarrow>
          K \<in> symKeys \<longrightarrow>
          Crypt K (Nonce NB) \<in> parts (knows Spy evs) \<longrightarrow>
          Crypt (shrK B) \<lbrace>Agent A, Agent B, Key K, Nonce NB\<rbrace>
            \<in> parts (knows Spy evs) \<longrightarrow>
          B \<notin> bad \<longrightarrow>
          (\<exists>X. Says A B \<lbrace>X, Crypt K (Nonce NB)\<rbrace> \<in> set evs)"
apply (erule yahalom.induct, force,
       frule_tac [6] YM4_parts_knows_Spy)
apply (analz_mono_contra, simp_all)
  subgoal \<comment> \<open>Fake\<close> by blast
  subgoal \<comment> \<open>YM3 because the message \<^term>\<open>Crypt K (Nonce NB)\<close> could not exist\<close>
    by (force dest!: Crypt_imp_keysFor)
  subgoal \<comment> \<open>YM4: was \<^term>\<open>Crypt K (Nonce NB)\<close> the very last message? If not, use the induction hypothesis,
             otherwise by unicity of session keys\<close>
    by (blast dest!: B_trusts_YM4_shrK dest: secure_unique_session_keys)
done

text\<open>If B receives YM4 then A has used nonce NB (and therefore is alive).
  Moreover, A associates K with NB (thus is talking about the same run).
  Other premises guarantee secrecy of K.\<close>
theorem YM4_imp_A_Said_YM3 [rule_format]:
     "\<lbrakk>Gets B \<lbrace>Crypt (shrK B) \<lbrace>Agent A, Agent B, Key K, Nonce NB\<rbrace>,
                  Crypt K (Nonce NB)\<rbrace> \<in> set evs;
         (\<forall>NA. Notes Spy \<lbrace>Nonce NA, Nonce NB, Key K\<rbrace> \<notin> set evs);
         K \<in> symKeys;  A \<notin> bad;  B \<notin> bad;  evs \<in> yahalom\<rbrakk>
      \<Longrightarrow> \<exists>X. Says A B \<lbrace>X, Crypt K (Nonce NB)\<rbrace> \<in> set evs"
by (blast intro: Auth_A_to_B_lemma
          dest: Spy_not_see_encrypted_key B_trusts_YM4_shrK)

end