theory Balance
  imports
    "../Utilities"
    Balance_Adapted
begin

context rbt_impl
begin
interpretation rbt_impl_deps .

subsection \<open>Checks\<close>

definition "check_1 lhs_p rhs_p \<equiv> is_red lhs_p &&! is_red rhs_p"
definition "check_2 lhs_p rhs_p \<equiv> is_red lhs_p &&! (do {l \<leftarrow> left lhs_p; is_red l})"
definition "check_3 lhs_p rhs_p \<equiv> is_red lhs_p &&! (do {r \<leftarrow> right lhs_p; is_red r})"
definition "check_4 lhs_p rhs_p \<equiv> is_red rhs_p &&! (do {r \<leftarrow> right rhs_p; is_red r})"
definition "check_5 lhs_p rhs_p \<equiv> is_red rhs_p &&! (do {l \<leftarrow> left rhs_p; is_red l})"

lemma check_1_correct [vcg_rules]:
  "
    llvm_htriple
    (rbt_assn lhs lhsi ** rbt_assn rhs rhsi)
    (check_1 lhsi rhsi)
    (\<lambda>r. rbt_assn lhs lhsi ** rbt_assn rhs rhsi ** \<upharpoonleft>bool.assn(rbt_check_1 lhs rhs) r)
  "
  unfolding rbt_check_1_def check_1_def sc_and_def
  apply vcg
  unfolding rbt_is_red_def
   apply vcg
  done

lemma check_2_correct [vcg_rules]:
  "
    llvm_htriple
    (rbt_assn lhs lhsi ** rbt_assn rhs rhsi)
    (check_2 lhsi rhsi)
    (\<lambda>r. rbt_assn lhs lhsi ** rbt_assn rhs rhsi ** \<upharpoonleft>bool.assn (rbt_check_2 lhs rhs) r)
  "
  unfolding rbt_check_2_def check_2_def sc_and_def
  apply vcg
  subgoal
    unfolding rbt_is_red_def rbt_left_def
    apply vcg_try_solve
    done
  subgoal by vcg
  done

lemma check_3_correct [vcg_rules]:
  "
    llvm_htriple
    (rbt_assn lhs lhsi ** rbt_assn rhs rhsi)
    (check_3 lhsi rhsi)
    (\<lambda>r. rbt_assn lhs lhsi ** rbt_assn rhs rhsi ** \<upharpoonleft>bool.assn(rbt_check_3 lhs rhs) r)
  "
  unfolding rbt_check_3_def check_3_def sc_and_def
  apply vcg
  subgoal
    unfolding rbt_is_red_def rbt_right_def
    apply vcg_try_solve
    done
  subgoal by vcg
  done

lemma check_4_correct [vcg_rules]:
  "
    llvm_htriple
    (rbt_assn lhs lhsi ** rbt_assn rhs rhsi)
    (check_4 lhsi rhsi)
    (\<lambda>r. rbt_assn lhs lhsi ** rbt_assn rhs rhsi ** \<upharpoonleft>bool.assn(rbt_check_4 lhs rhs) r)
  "
  unfolding rbt_check_4_def check_4_def sc_and_def
  apply vcg
  subgoal
    unfolding rbt_is_red_def rbt_right_def
    apply vcg_try_solve
    done
  subgoal by vcg
  done

lemma check_5_correct [vcg_rules]:
  "
    llvm_htriple
    (rbt_assn lhs lhsi ** rbt_assn rhs rhsi)
    (check_5 lhsi rhsi)
    (\<lambda>r. rbt_assn lhs lhsi ** rbt_assn rhs rhsi ** \<upharpoonleft>bool.assn(rbt_check_5 lhs rhs) r)
  "
  unfolding rbt_check_5_def check_5_def sc_and_def
  apply vcg
  subgoal
    unfolding rbt_is_red_def rbt_left_def
    apply vcg_try_solve
    done
  subgoal by vcg
  done

lemmas [llvm_inline] =
  check_1_def
  check_2_def
  check_3_def
  check_4_def
  check_5_def

subsection \<open>Balance Cases\<close>

definition "balance_ad_case_1 lhs_p k v rhs_p \<equiv> do {
  set_color_p 1 lhs_p;
  set_color_p 1 rhs_p;
  new (RBT_NODE 0 lhs_p k v rhs_p)
}"

thm set_color_p_def[simplified mod_ptr_def]
schematic_goal "set_color_p color node_ptr = X ?X"
  unfolding set_color_p_def mod_ptr_def
  apply simp
  oops

lemma balance_ad_case_1_correct [vcg_rules]:
  "
    llvm_htriple
    (rbt_assn lhs lhsi ** rbt_assn rhs rhsi ** \<upharpoonleft>key_assn k ki ** \<upharpoonleft>value_assn v vi ** \<up>(rbt_check_1 lhs rhs))
    (balance_ad_case_1 lhsi ki vi rhsi)
    (\<lambda>r. rbt_assn (rbt_balance_ad_case_1 lhs k v rhs) r)
  "
  unfolding balance_ad_case_1_def rbt_balance_ad_case_1_def new_def
  apply vcg
  apply (erule rbt_check_1_unfold)
  apply vcg
  done

definition "balance_ad_case_2 lhs_p k v rhs_p \<equiv> do {
  lhs \<leftarrow> ll_load lhs_p;
  case lhs of (RBT_NODE _ llhs_p s t c) \<Rightarrow>
  do {
    llhs \<leftarrow> ll_load llhs_p;
    case llhs of (RBT_NODE _ a w x b) \<Rightarrow>
    let y = k; z = v; d = rhs_p in
    do {
      ll_free lhs_p;
      ll_free llhs_p;
      lhs_n \<leftarrow> new (RBT_NODE 1 a w x b);
      rhs_n \<leftarrow> new (RBT_NODE 1 c y z d);
      new (RBT_NODE 0 lhs_n s t rhs_n)
    }
  }
}"

lemma balance_ad_case_2_correct [vcg_rules]:
  "
    llvm_htriple
    (rbt_assn lhs lhsi ** rbt_assn rhs rhsi ** \<upharpoonleft>key_assn k ki ** \<upharpoonleft>value_assn v vi ** \<up>(rbt_check_2 lhs rhs))
    (balance_ad_case_2 lhsi ki vi rhsi)
    (\<lambda>r. rbt_assn (rbt_balance_ad_case_2 lhs k v rhs) r)
  "
  unfolding balance_ad_case_2_def rbt_balance_ad_case_2_def new_def
  apply vcg
  apply (erule rbt_check_2_unfold)
  apply vcg
  done

find_theorems rbt_assn is_rbt

definition "balance_ad_case_3 lhs_p k v rhs_p \<equiv> do {
  lhs \<leftarrow> ll_load lhs_p;
  case lhs of (RBT_NODE _ a w x rlhs_p) \<Rightarrow>
  do {
    rlhs \<leftarrow> ll_load rlhs_p;
    case rlhs of (RBT_NODE _ b s t c) \<Rightarrow>
    let y = k; z = v; d = rhs_p in
    do {
      ll_free lhs_p;
      ll_free rlhs_p;
      lhs_n \<leftarrow> new (RBT_NODE 1 a w x b);
      rhs_n \<leftarrow> new (RBT_NODE 1 c y z d);
      new (RBT_NODE 0 lhs_n s t rhs_n)
    }
  }
}"

lemma balance_ad_case_3_correct [vcg_rules]:
  "
    llvm_htriple
    (rbt_assn lhs lhsi ** rbt_assn rhs rhsi ** \<upharpoonleft>key_assn k ki ** \<upharpoonleft>value_assn v vi ** \<up>(rbt_check_3 lhs rhs))
    (balance_ad_case_3 lhsi ki vi rhsi)
    (\<lambda>r. rbt_assn (rbt_balance_ad_case_3 lhs k v rhs) r)
  "
  unfolding balance_ad_case_3_def rbt_balance_ad_case_3_def new_def
  apply vcg
  apply (erule rbt_check_3_unfold)
  apply vcg
  done

definition "balance_ad_case_4 l_p k v r_p \<equiv> do {
  let a=l_p; w=k; x=v in
  do {
    r \<leftarrow> ll_load r_p;
    case r of (RBT_NODE _ b s t rr_p) \<Rightarrow>
    do {
      rr \<leftarrow> ll_load rr_p;
      case rr of (RBT_NODE _ c y z d) \<Rightarrow>
      do {
        ll_free r_p;
        ll_free rr_p;
        lhs_n \<leftarrow> new (RBT_NODE 1 a w x b);
        rhs_n \<leftarrow> new (RBT_NODE 1 c y z d);
        new (RBT_NODE 0 lhs_n s t rhs_n)
      }
    }
  }
}"

lemma balance_ad_case_4_correct [vcg_rules]:
  "
    llvm_htriple
    (rbt_assn lhs lhsi ** rbt_assn rhs rhsi ** \<upharpoonleft>key_assn k ki ** \<upharpoonleft>value_assn v vi ** \<up>(rbt_check_4 lhs rhs))
    (balance_ad_case_4 lhsi ki vi rhsi)
    (\<lambda>r. rbt_assn (rbt_balance_ad_case_4 lhs k v rhs) r)
  "
  unfolding balance_ad_case_4_def rbt_balance_ad_case_4_def new_def
  apply vcg
  apply (erule rbt_check_4_unfold)
  apply vcg
  done

definition "balance_ad_case_5 l_p k v r_p \<equiv> do {
  let a=l_p; w=k; x=v in
  do {
    r \<leftarrow> ll_load r_p;
    case r of (RBT_NODE _ rl_p y z d) \<Rightarrow>
    do {
      rl \<leftarrow> ll_load rl_p;
      case rl of (RBT_NODE _ b s t c) \<Rightarrow>
      do {
        ll_free r_p;
        ll_free rl_p;
        lhs_n \<leftarrow> new (RBT_NODE 1 a w x b);
        rhs_n \<leftarrow> new (RBT_NODE 1 c y z d);
        new (RBT_NODE 0 lhs_n s t rhs_n)
      }
    }
  }
}"

lemma balance_ad_case_5_correct [vcg_rules]:
  "
    llvm_htriple
    (rbt_assn lhs lhsi ** rbt_assn rhs rhsi ** \<upharpoonleft>key_assn k ki ** \<upharpoonleft>value_assn v vi ** \<up>(rbt_check_5 lhs rhs))
    (balance_ad_case_5 lhsi ki vi rhsi)
    (\<lambda>r. rbt_assn (rbt_balance_ad_case_5 lhs k v rhs) r)
  "
  unfolding balance_ad_case_5_def rbt_balance_ad_case_5_def new_def
  apply vcg
  apply (erule rbt_check_5_unfold)
  apply vcg
  done

definition "balance_ad_case_6 l_p k v r_p \<equiv> new (RBT_NODE 1 l_p k v r_p)"

lemma balance_ad_case_6_correct [vcg_rules]:
  "
    llvm_htriple
    (rbt_assn lhs lhsi ** rbt_assn rhs rhsi ** \<upharpoonleft>key_assn k ki ** \<upharpoonleft>value_assn v vi)
    (balance_ad_case_6 lhsi ki vi rhsi)
    (\<lambda>r. rbt_assn (rbt_balance_ad_case_6 lhs k v rhs) r)
  "
  unfolding balance_ad_case_6_def rbt_balance_ad_case_6_def
  by vcg

lemmas [llvm_code] =
  balance_ad_case_1_def
  balance_ad_case_2_def
  balance_ad_case_3_def
  balance_ad_case_4_def
  balance_ad_case_5_def
  balance_ad_case_6_def

subsection \<open>Balance Function\<close>

definition balance ::
  "('ki, 'vi) rbti \<Rightarrow> 'ki \<Rightarrow> 'vi \<Rightarrow> ('ki, 'vi) rbti \<Rightarrow> ('ki, 'vi) rbti llM" where
  "balance lhs_p k v rhs_p = do {
      if! check_1 lhs_p rhs_p
      then! balance_ad_case_1 lhs_p k v rhs_p
      else! if! check_2 lhs_p rhs_p
      then! balance_ad_case_2 lhs_p k v rhs_p
      else! if! check_3 lhs_p rhs_p
      then! balance_ad_case_3 lhs_p k v rhs_p
      else! if! check_4 lhs_p rhs_p
      then! balance_ad_case_4 lhs_p k v rhs_p
      else! if! check_5 lhs_p rhs_p
      then! balance_ad_case_5 lhs_p k v rhs_p
      else! balance_ad_case_6 lhs_p k v rhs_p
  }"

lemmas [llvm_code] = balance_def

lemma balance_correct':
  "llvm_htriple
  (
    rbt_assn tree_l tree_li **
    rbt_assn tree_r tree_ri **
    \<upharpoonleft>key_assn k ki **
    \<upharpoonleft>value_assn v vi
  )
  (balance tree_li ki vi tree_ri)
  (\<lambda>ri. rbt_assn (rbt_balance_ad tree_l k v tree_r) ri)
  "
  unfolding balance_def
  by vcg

lemma balance_correct [vcg_rules]:
  "llvm_htriple
  (
    rbt_assn l li **
    rbt_assn r ri **
    \<upharpoonleft>key_assn k ki **
    \<upharpoonleft>value_assn v vi
  )
  (balance li ki vi ri)
  (\<lambda>res. rbt_assn (rbt_balance l k v r) res)
  "
  by (metis balance_correct' rbt_balance_ad_correct)

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 Crunch_Test_NonDet
imports
  Lib.Crunch_Instances_NonDet
  Crunch_Test_Qualified_NonDet
  Lib.GenericLib
  Lib.Defs
begin

text \<open>Test cases for crunch\<close>

definition
  "crunch_foo1 (x :: nat) \<equiv> do
    modify ((+) x);
    modify ((+) x)
  od"

definition
  "crunch_foo2 \<equiv> do
    crunch_foo1 12;
    crunch_foo1 13
  od"

crunch (empty_fail) empty_fail: crunch_foo2
  (ignore: modify bind)

crunch_ignore (add: crunch_foo1)

crunch gt: crunch_foo2 "\<lambda>x. x > y"
  (ignore: modify bind ignore_del: crunch_foo1)

crunch_ignore (del: crunch_foo1)

definition
  "crunch_always_true (x :: nat) \<equiv> \<lambda>y :: nat. True"

lemma crunch_foo1_at_2:
  "True \<Longrightarrow> \<lbrace>crunch_always_true 3 and crunch_always_true 2\<rbrace>
      crunch_foo1 x \<lbrace>\<lambda>rv. crunch_always_true 2 and K True\<rbrace>"
  by (simp add: crunch_always_true_def, wp)

lemma crunch_foo1_at_2':
  "True \<Longrightarrow> \<lbrace>crunch_always_true 3 and crunch_always_true 2\<rbrace>
      crunch_foo1 x \<lbrace>\<lambda>rv. crunch_always_true 3\<rbrace>"
  by (simp add: crunch_always_true_def, wp)

lemma crunch_foo1_at_3[wp]:
  "\<lbrace>crunch_always_true 3\<rbrace> crunch_foo1 x \<lbrace>\<lambda>rv. crunch_always_true 3\<rbrace>"
  by (simp add: crunch_always_true_def, wp)

lemma crunch_foo1_no_fail:
  "True \<Longrightarrow> no_fail (crunch_always_true 2 and crunch_always_true 3) (crunch_foo1 x)"
  apply (simp add:crunch_always_true_def crunch_foo1_def)
  apply (rule no_fail_pre)
   apply (wp, simp)
  done

crunch (no_fail) no_fail: crunch_foo2
  (ignore: modify bind wp: crunch_foo1_at_2[simplified])

crunch (valid) at_2': crunch_foo2 "crunch_always_true 2"
  (ignore: modify bind wp: crunch_foo1_at_2[simplified])

fun crunch_foo3 :: "nat => nat => 'a => (nat,unit) nondet_monad" where
  "crunch_foo3 0 x _ = crunch_foo1 x"
| "crunch_foo3 (Suc n) x y = crunch_foo3 n x y"

crunch gt2: crunch_foo3 "\<lambda>x. x > y"
  (ignore: modify bind)

crunch (empty_fail) empty_fail2: crunch_foo3
  (ignore: modify bind)

class foo_class =
  fixes stuff :: 'a
begin

fun crunch_foo4 :: "nat => nat => 'a => (nat,unit) nondet_monad" where
  "crunch_foo4 0 x _ s = crunch_foo1 x s"
| "crunch_foo4 (Suc n) x y s = crunch_foo4 n x y s"

definition
  "crunch_foo5 x (y::'a) \<equiv> crunch_foo1 x"

end

lemma crunch_foo4_alt:
  "crunch_foo4 n x y \<equiv> crunch_foo1 x"
  apply (induct n)
   apply (simp add: fun_eq_iff)+
  done

(* prove rules about crunch_foo4 with and without the alternative definition *)
crunch gt3: crunch_foo4 "\<lambda>x. x > y"
  (ignore: modify bind)

crunch (no_fail) no_fail2: crunch_foo4
  (rule: crunch_foo4_alt ignore: modify bind)

crunch gt3: crunch_foo4 "\<lambda>x. x > y"
  (rule: crunch_foo4_alt ignore: modify bind)

crunch gt4: crunch_foo5 "\<lambda>x. x > y"
  (ignore: modify bind)

(* Test cases for crunch in locales *)

definition
  "crunch_foo6 \<equiv> return () >>= (\<lambda>_. return ())"

locale test_locale =
fixes fixed_return_unit :: "(unit, unit) nondet_monad"

begin

definition
  "crunch_foo7 \<equiv> return () >>= (\<lambda>_. return ())"

(* crunch works on a global constant within a locale *)
crunch test[wp]: crunch_foo6 P
(ignore: bind)

(* crunch works on a locale constant *)
crunch test[wp]: crunch_foo7 P
(ignore: bind)

definition
  "crunch_foo8 \<equiv> fixed_return_unit >>= (\<lambda>_. fixed_return_unit)"

definition
  "crunch_foo9 (x :: nat) \<equiv> do
    modify ((+) x);
    modify ((+) x)
  od"

crunch test: crunch_foo9 "\<lambda>x. x > y" (ignore: bind)

definition
  "crunch_foo10 (x :: nat) \<equiv> do
    modify ((+) x);
    modify ((+) x)
  od"

(*crunch_def attribute overrides definition lookup *)

lemma crunch_foo10_def2[crunch_def]:
  "crunch_foo10 = crunch_foo9"
  unfolding crunch_foo10_def[abs_def] crunch_foo9_def[abs_def]
  by simp

crunch test[wp]: crunch_foo10 "\<lambda>x. x > y"

(* crunch_ignore works within a locale *)
crunch_ignore (add: bind)

crunch test': crunch_foo9 "\<lambda>x. x > y"

end

interpretation test_locale "return ()" .

(* interpretation promotes the wp attribute from the locale *)
lemma "\<lbrace>Q\<rbrace> crunch_foo7 \<lbrace>\<lambda>_. Q\<rbrace>" by wp

(* crunch still works on an interpreted locale constant *)
crunch test2: crunch_foo7 P
  (wp_del: crunch_foo7_test)

locale test_sublocale

sublocale test_sublocale < test_locale "return ()" .

context test_sublocale begin

(* crunch works on a locale constant with a fixed locale parameter *)
crunch test[wp]: crunch_foo8 P

end

(* check that qualified names are handled properly. *)

consts foo_const :: "(unit, unit) nondet_monad"
defs foo_const_def: "foo_const \<equiv> Crunch_Test_Qualified_NonDet.foo_const"

crunch test: foo_const P

(* check that the grid-style crunch is working *)

crunches crunch_foo3, crunch_foo4, crunch_foo5
  for silly: "\<lambda>s. True \<noteq> False" and (no_fail)nf and (empty_fail)ef
  (ignore: modify bind rule: crunch_foo4_alt wp_del: hoare_vcg_prop)

end


(*  Title:      JinjaDCI/Compiler/Compiler1.thy
    Author:     Tobias Nipkow, Susannah Mansky
    Copyright   TUM 2003, UIUC 2019-20

    Based on the Jinja theory Compiler/Compiler1.thy by Tobias Nipkow
*)

section \<open> Compilation Stage 1 \<close>

theory Compiler1 imports PCompiler J1 Hidden begin

text\<open> Replacing variable names by indices. \<close>

primrec compE\<^sub>1  :: "vname list \<Rightarrow> expr \<Rightarrow> expr\<^sub>1"
  and compEs\<^sub>1 :: "vname list \<Rightarrow> expr list \<Rightarrow> expr\<^sub>1 list" where
  "compE\<^sub>1 Vs (new C) = new C"
| "compE\<^sub>1 Vs (Cast C e) = Cast C (compE\<^sub>1 Vs e)"
| "compE\<^sub>1 Vs (Val v) = Val v"
| "compE\<^sub>1 Vs (e\<^sub>1 \<guillemotleft>bop\<guillemotright> e\<^sub>2) = (compE\<^sub>1 Vs e\<^sub>1) \<guillemotleft>bop\<guillemotright> (compE\<^sub>1 Vs e\<^sub>2)"
| "compE\<^sub>1 Vs (Var V) = Var(last_index Vs V)"
| "compE\<^sub>1 Vs (V:=e) = (last_index Vs V):= (compE\<^sub>1 Vs e)"
| "compE\<^sub>1 Vs (e\<bullet>F{D}) = (compE\<^sub>1 Vs e)\<bullet>F{D}"
| "compE\<^sub>1 Vs (C\<bullet>\<^sub>sF{D}) = C\<bullet>\<^sub>sF{D}"
| "compE\<^sub>1 Vs (e\<^sub>1\<bullet>F{D}:=e\<^sub>2) = (compE\<^sub>1 Vs e\<^sub>1)\<bullet>F{D} := (compE\<^sub>1 Vs e\<^sub>2)"
| "compE\<^sub>1 Vs (C\<bullet>\<^sub>sF{D}:=e\<^sub>2) = C\<bullet>\<^sub>sF{D} := (compE\<^sub>1 Vs e\<^sub>2)"
| "compE\<^sub>1 Vs (e\<bullet>M(es)) = (compE\<^sub>1 Vs e)\<bullet>M(compEs\<^sub>1 Vs es)"
| "compE\<^sub>1 Vs (C\<bullet>\<^sub>sM(es)) = C\<bullet>\<^sub>sM(compEs\<^sub>1 Vs es)"
| "compE\<^sub>1 Vs {V:T; e} = {(size Vs):T; compE\<^sub>1 (Vs@[V]) e}"
| "compE\<^sub>1 Vs (e\<^sub>1;;e\<^sub>2) = (compE\<^sub>1 Vs e\<^sub>1);;(compE\<^sub>1 Vs e\<^sub>2)"
| "compE\<^sub>1 Vs (if (e) e\<^sub>1 else e\<^sub>2) = if (compE\<^sub>1 Vs e) (compE\<^sub>1 Vs e\<^sub>1) else (compE\<^sub>1 Vs e\<^sub>2)"
| "compE\<^sub>1 Vs (while (e) c) = while (compE\<^sub>1 Vs e) (compE\<^sub>1 Vs c)"
| "compE\<^sub>1 Vs (throw e) = throw (compE\<^sub>1 Vs e)"
| "compE\<^sub>1 Vs (try e\<^sub>1 catch(C V) e\<^sub>2) =
    try(compE\<^sub>1 Vs e\<^sub>1) catch(C (size Vs)) (compE\<^sub>1 (Vs@[V]) e\<^sub>2)"
| "compE\<^sub>1 Vs (INIT C (Cs,b) \<leftarrow> e) = INIT C (Cs,b) \<leftarrow> (compE\<^sub>1 Vs e)"
| "compE\<^sub>1 Vs (RI(C,e);Cs \<leftarrow> e') = RI(C,(compE\<^sub>1 Vs e));Cs \<leftarrow> (compE\<^sub>1 Vs e')"

| "compEs\<^sub>1 Vs []     = []"
| "compEs\<^sub>1 Vs (e#es) = compE\<^sub>1 Vs e # compEs\<^sub>1 Vs es"

lemma [simp]: "\<And>Vs. sub_RI (compE\<^sub>1 Vs e) = sub_RI e"
 and [simp]: "\<And>Vs. sub_RIs (compEs\<^sub>1 Vs es) = sub_RIs es"
proof(induct rule: sub_RI_sub_RIs_induct) qed(auto)

primrec fin\<^sub>1:: "expr \<Rightarrow> expr\<^sub>1" where
  "fin\<^sub>1(Val v) = Val v"
| "fin\<^sub>1(throw e) = throw(fin\<^sub>1 e)"

lemma comp_final: "final e \<Longrightarrow> compE\<^sub>1 Vs e = fin\<^sub>1 e"
(*<*)by(erule finalE, simp_all)(*>*)

lemma [simp]:
      "\<And>Vs. max_vars (compE\<^sub>1 Vs e) = max_vars e"
and "\<And>Vs. max_varss (compEs\<^sub>1 Vs es) = max_varss es"
(*<*)by (induct e and es rule: max_vars.induct max_varss.induct) simp_all(*>*)

text\<open> Compiling programs: \<close>

definition compP\<^sub>1 :: "J_prog \<Rightarrow> J\<^sub>1_prog"
where
  "compP\<^sub>1  \<equiv>  compP (\<lambda>b (pns,body). compE\<^sub>1 (case b of NonStatic \<Rightarrow> this#pns | Static \<Rightarrow> pns) body)"

(*<*)
declare compP\<^sub>1_def[simp]
(*>*)

end


section \<open>Examples for infixl seq (;;)\<close>

theory examples_infixl_seq
  imports "../../../hoare/HoareLogic/TotalCorrectness/Abrupt/utp_hoare_total"
begin

text \<open>Burkhart Wolff suggests infixl rather than infixr (like how seL4 does it)\<close>
no_notation useq (infixr ";;" 51)
notation useq (infixl ";;" 51)

text \<open>Variable swapping\<close>

lemma swap_test1:
  assumes "weak_lens x" and "weak_lens y" and "weak_lens z"
  and "x \<bowtie> y" and "x \<bowtie> z" and "y \<bowtie> z"
  shows "\<lbrace>&x =\<^sub>u \<guillemotleft>a\<guillemotright> \<and> &y =\<^sub>u \<guillemotleft>b\<guillemotright>\<rbrace>
  z \<Midarrow> &x;;
  x \<Midarrow> &y;;
  y \<Midarrow> &z
  \<lbrace>&x =\<^sub>u \<guillemotleft>b\<guillemotright> \<and> &y =\<^sub>u \<guillemotleft>a\<guillemotright>\<rbrace>\<^sub>A\<^sub>B\<^sub>R"
  apply (insert assms)
  apply (rule seq_hoare_r_t)
   apply (rule seq_hoare_r_t)
    defer
    apply (rule assigns_abr_hoare_r'_t)
   apply (rule assigns_abr_hoare_r'_t)
  apply (rule assigns_abr_hoare_r_t)
  apply pred_simp
  apply (simp add: lens_indep_sym)
  done

lemma swap_test2:
  assumes "weak_lens x" and "weak_lens y" and "weak_lens z"
  and "x \<bowtie> y" and "x \<bowtie> z" and "y \<bowtie> z"
  shows "\<lbrace>&x =\<^sub>u \<guillemotleft>a\<guillemotright> \<and> &y =\<^sub>u \<guillemotleft>b\<guillemotright>\<rbrace>
  z \<Midarrow> &x;;
  x \<Midarrow> &y;;
  y \<Midarrow> &z
  \<lbrace>&x =\<^sub>u \<guillemotleft>b\<guillemotright> \<and> &y =\<^sub>u \<guillemotleft>a\<guillemotright>\<rbrace>\<^sub>A\<^sub>B\<^sub>R"
  apply (insert assms)
  apply (rule seq_hoare_r_t)
   defer
   apply (rule assigns_abr_hoare_r'_t)
  apply (rule seq_hoare_r_t)
   defer
   apply (rule assigns_abr_hoare_r'_t)
  apply (rule assigns_abr_hoare_r_t)
  apply pred_simp
  apply (simp add: lens_indep_sym)
  done

subsection \<open>Adding in loops\<close>

lemma increment:
  assumes "vwb_lens x" and "x \<bowtie> y"
  shows
  "\<lbrace>&y =\<^sub>u \<guillemotleft>5::int\<guillemotright>\<rbrace>
  x \<Midarrow> 0;;
  (&x =\<^sub>u 0 \<and> &y =\<^sub>u 5)\<^sup>\<top>\<^sup>C;;
  while &x <\<^sub>u &y
  invr &x \<le>\<^sub>u &y \<and> &y =\<^sub>u 5
  do x \<Midarrow> &x + 1 od
  \<lbrace>&x =\<^sub>u 5\<rbrace>\<^sub>A\<^sub>B\<^sub>R"
  apply (insert assms)
  apply (rule seq_hoare_r_t)
   apply (rule seq_hoare_r_t[of _ _ true])
    apply (rule assigns_abr_hoare_r_t)
    apply pred_auto
   apply (rule assume_hoare_r_t)
    apply (rule skip_abr_hoare_r_t)
   apply rel_auto
  apply (rule while_invr_hoare_r_t)
    apply (rule assigns_abr_hoare_r_t)
    unfolding lens_indep_def
    apply pred_auto
   apply pred_auto
  apply pred_auto
  done

lemma increment2:
  assumes "vwb_lens x" and "x \<bowtie> y"
  shows
  "\<lbrace>&y =\<^sub>u \<guillemotleft>5::int\<guillemotright>\<rbrace>
  x \<Midarrow> 0;;
  (&x =\<^sub>u 0 \<and> &y =\<^sub>u 5)\<^sup>\<top>\<^sup>C;;
  while &x <\<^sub>u &y
  invr &x \<le>\<^sub>u &y \<and> &y =\<^sub>u 5
  do x \<Midarrow> &x + 1 od
  \<lbrace>&x =\<^sub>u 5\<rbrace>\<^sub>A\<^sub>B\<^sub>R"
  apply (insert assms)
  apply (rule seq_hoare_r_t)
   defer
   apply (rule while_invr_hoare_r_t)
     apply (rule assigns_abr_hoare_r_t)
     unfolding lens_indep_def
     apply pred_auto
    defer
    apply pred_auto
   apply (rule seq_hoare_r_t)
    defer
    apply (rule assume_hoare_r_t)
     apply (rule skip_abr_hoare_r_t)
    apply rel_auto
   apply pred_auto
  apply (rule assigns_abr_hoare_r_t)
  apply pred_auto
  oops (*  (rule seq_hoare_r_t[of _ _ true]) is necessary to instantiate ?s27 *)

end


section \<open> Events for Reactive Processes \<close>

theory utp_rea_event
imports "UTP1.utp"
begin

subsection \<open> Events \<close>

text \<open> Events of some type @{typ "'\<theta>"} are just the elements of that type. \<close>

type_synonym '\<theta> event = "'\<theta>"

subsection \<open> Channels \<close>

text \<open>
  Typed channels are modelled as prisms. Below, @{typ "'a"} determines the
  channel type and @{typ "'\<theta>"} the underlying event alphabet type. As with values, it
  is difficult to introduce channels as monomorphic types due to the fact that
  they can have arbitrary parametrisations in term of @{typ "'a"}. Applying a
  channel to an element of its type yields an event, as we may expect. Though
  this is not formalised here, we may also sensibly assume that all channel-
  representing functions are injective.
\<close>

type_synonym ('a, '\<theta>) chan = "'a \<Longrightarrow>\<^sub>\<triangle> '\<theta> event"

text \<open>
  A downside of the approach is that the event type @{typ "'\<theta>"} must be able
  to encode \emph{all} events of a process model, and hence cannot be fixed
  upfront for a single channel or channel set. To do so, we actually require
  a notion of `extensible' datatypes, in analogy to extensible record types.
  Another solution is to encode a notion of channel scoping that namely uses
  @{type sum} types to lift channel types into extensible ones, that is using
  channel-set specific scoping operators. This is a current work in progress.
\<close>

subsubsection \<open> Operators \<close>

text \<open>
  The next lifted function creates an expression that yields a channel event,
  from an expression on the channel type @{typ "'a"}.
\<close>

definition chan_apply ::
  "('a, '\<theta>) chan \<Rightarrow> ('a, '\<alpha>) uexpr \<Rightarrow> ('\<theta> event, '\<alpha>) uexpr" ("'(_\<cdot>/_')\<^sub>u") where
[upred_defs]: "(c\<cdot>e)\<^sub>u = uop (build\<^bsub>c\<^esub>) e"

no_utp_lift chan_apply (0)

lemma unrest_chan_apply [unrest]: "x \<sharp> e \<Longrightarrow> x \<sharp> (c\<cdot>e)\<^sub>u"
  by (rel_auto)

lemma usubst_chan_apply [usubst]: "\<sigma> \<dagger> (c\<cdot>v)\<^sub>u = (c\<cdot>\<sigma> \<dagger> v)\<^sub>u"
  by (rel_auto)

lemma msubst_event [usubst]:
  "(c\<cdot>v x)\<^sub>u\<lbrakk>x\<rightarrow>u\<rbrakk> = (c\<cdot>(v x)\<lbrakk>x\<rightarrow>u\<rbrakk>)\<^sub>u"
  by (pred_simp)

lemma msubst_event_2 [usubst]:
  "(c\<cdot>v x y)\<^sub>u\<lbrakk>(x,y)\<rightarrow>u\<rbrakk> = (c\<cdot>(v x y)\<lbrakk>(x,y)\<rightarrow>u\<rbrakk>)\<^sub>u"
  by (pred_simp)+

lemma aext_event [alpha]: "(c\<cdot>v)\<^sub>u \<oplus>\<^sub>p a = (c\<cdot>v \<oplus>\<^sub>p a)\<^sub>u"
  by (pred_auto)

end


theory dADemo

imports dAutomaton_causal

begin

section \<open> flasher port chans \<close>

typedef botChan ="{SOME c. c\<in>cEmpty}"
  by simp

typedef flasherPortIn = "{SOME c. c\<notin>cEmpty}"
  apply auto
  done

typedef flasherPortOut = "{SOME c. c\<notin>cEmpty \<and> c\<notin>range(Rep_flasherPortIn)}"
  apply auto
  done

instantiation flasherPortIn::chan
begin
definition "Rep = Rep_flasherPortIn"
instance
  apply(standard)
  apply (smt Int_lower1 Rep_flasherPortIn_def inf.orderI subset_singletonD type_definition.Rep_range type_definition_flasherPortIn)
   by (simp add: Rep_flasherPortIn_def Rep_flasherPortIn_inject inj_on_def)
end

instance flasherPortIn::finite
  apply(intro_classes)
  apply (subst UNIV_def)
  by (metis (full_types) Abs_flasherPortIn_cases Collect_const ex_new_if_finite finite.emptyI finite_insert insert_iff singletonD)

instantiation flasherPortOut::chan
begin
definition "Rep = Rep_flasherPortOut"
instance
  apply(standard)
  apply (smt Int_lower1 Rep_flasherPortOut_def inf_commute subset_singletonD type_definition.Rep_range type_definition_flasherPortOut)
  by (smt Rep_flasherPortOut_def Rep_flasherPortOut_inject injI)
end

instantiation botChan::chan
begin
definition "Rep = Rep_botChan"
instance
  apply(standard)
  apply (smt Int_lower1 Rep_botChan_def inf_commute subset_singletonD type_definition.Rep_range type_definition_botChan)
  by (simp add: Rep_botChan_def Rep_botChan_inject inj_on_def)
end

lift_definition Nonesbe::"botChan sbElem" is (*Does not work for undefined ctype*)
"None"
  apply(simp)
  using Rep_botChan Rep_botChan_def sorry

section \<open>flasher states\<close>

datatype flasherState = S

section \<open>flasher automaton definition\<close>

definition flasherAutomatonw::"(flasherState,flasherPortIn,flasherPortOut,botChan) dAutomaton_weak" where
"flasherAutomatonw =(| dawTransition =(\<lambda>s sbe. (s,Abs_sbElem(Some (\<lambda>c. sbegetch c sbe)))),
                 dawInitState = S, dawInitOut = Nonesbe |)"

definition flasherAutomatons::"(flasherState,flasherPortIn,flasherPortOut) dAutomaton_strong" where
"flasherAutomatons =(| dawTransition =(\<lambda>s sbe. (s,Abs_sbElem(Some (\<lambda>c. sbegetch c sbe)))),
                 dawInitState = S, dawInitOut = Abs_sbElem(Some (\<lambda>c. SOME m. True)) |)"

section \<open> flasher automat to spf\<close>

definition flasherspfw::"(flasherPortIn,flasherPortOut)spfw"where
"flasherspfw = semantik_weak(flasherAutomatonw)"

definition flasherspfs::"(flasherPortIn,flasherPortOut)spfs"where
"flasherspfs = semantik_strong(flasherAutomatons)"

lemma dawinitout_genaut:"daInitOut (daw2da auts) =  sbe2sb\<cdot>(dawInitOut auts)"
  by(simp add: daw2da_def)

lemma semantik_strong_head:"\<exists>sb. (Rep_spfw (Rep_spfs (semantik_strong auts)))\<cdot>insb = sbe2sb\<cdot>(dawInitOut auts) \<bullet>\<^sup>\<Omega> sb"
  apply(simp add: semantik_strong_def daSem_def dawinitout_genaut)
  sorry

theorem flasherhead:assumes "B True \<in> ctype c2" shows"shd (((Rep_spfw (Rep_spfs flasherspfs))\<cdot>sb) \<^enum> (Abs c2)) = B True"
  apply(simp add: flasherspfs_def)
  apply(insert semantik_strong_head[of flasherAutomatons sb])
  apply(simp add: flasherAutomatons_def)
  apply auto
  oops

end


theory ProcSendCase
  imports ResMapValid ReduceWTS ProcDef ProcCVars
begin

lemma cancel_strong_leq_use_env: "\<lbrakk> strong_use_env r_x \<rbrakk> \<Longrightarrow> leq_use_env (diff_use_env r_x r_x) r_s"
  apply (simp add: leq_use_env_def)
  apply (simp add: diff_use_env_def)
  apply (simp add: strong_use_env_def)
  apply (auto)
  apply (erule_tac x="x" in allE)
  apply (case_tac "r_x x")
    apply (auto)
  done

lemma sfl_diff_use_env: "\<lbrakk> strong_use_env r_ex; leq_use_env r_ex r_s; is_own r \<rbrakk> \<Longrightarrow> diff_use_env r_s (diff_use_env (lift_use_env r_s r) r_ex) = r_ex"
  apply (case_tac "\<forall> x. diff_use_env r_s (diff_use_env (lift_use_env r_s r) r_ex) x = r_ex x")
   apply (auto)
  apply (simp add: strong_use_env_def)
  apply (simp add: leq_use_env_def)
  apply (simp add: diff_use_env_def)
  apply (simp add: is_own_def)
  apply (erule_tac x="x" in allE)
  apply (erule_tac x="x" in allE)
  apply (case_tac "r_ex x")
    apply (auto)
   apply (case_tac "r_s x")
    apply (auto)
  apply (case_tac "r_s x")
    apply (auto)
  done

    (* the question right now is, how do we make these types line up? *)

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

lemma safe_recv_exp: "\<lbrakk> well_typed env delta r_s1 (app_hole h (AppExp (ConstExp RecvConst) (VarExp (LocType a)))) tau r_s2 rx;
  well_formed_delta env delta; env (Loc a) = Some (ChanTy t REnd); well_typed env delta r_x v t r_x r_x; disj_use_env r_s1 r_x;
  strong_use_env r_x; is_value c; is_value v; is_own r \<rbrakk> \<Longrightarrow>
  well_typed env delta (comp_use_env r_s1 r_x) (app_hole h v) tau r_s2 rx"
  apply (induct h arbitrary: env r_s1 tau r_s2 rx)
       apply (auto)
    (* base case *)
       apply (cut_tac r_sc="r_s2" and r_sb="diff_use_env r_s3 (comp_use_env (comp_use_env rx1 (lift_use_env rx2 ra)) r_exa)" and
          r_sa="r_s1" in trans_leq_use_env)
         apply (rule_tac diff_leq_use_env)
         apply (rule_tac r_sb="diff_use_env r_s2a (comp_use_env (ereq_use_env (Loc (delta a)) tau_x) r_ex)" in trans_leq_use_env)
          apply (rule_tac diff_leq_use_env)
          apply (auto)
       apply (rule_tac ?r_s2.0="diff_use_env (comp_use_env r_s1 r_x) r_x"
        and rx="diff_use_env r_x r_x" in well_typed_simul_end_perm)
          apply (rule_tac well_typed_diff_end_perm)
           apply (rule_tac well_typed_comp_perms2)
            apply (simp add: pure_fun_def)
           apply (auto)
          apply (rule_tac comm_disj_use_env)
          apply (simp)
         apply (rule_tac self_comp_leq_use_env2)
        apply (rule_tac disj_diff_leq_use_env)
         apply (rule_tac r_s="r_s1" in disj_leq_use_env2)
          apply (rule_tac comm_disj_use_env)
          apply (simp_all)
        apply (rule_tac comp_leq_use_env1)
        apply (simp)
       apply (rule_tac cancel_strong_leq_use_env)
       apply (simp)
    (* lhs pair case. *)
      apply (rule_tac x="t1" in exI)
      apply (rule_tac x="ra" in exI)
      apply (rule_tac x="aa" in exI)
      apply (rule_tac x="r_s2a" in exI)
      apply (rule_tac x="rx1" in exI)
      apply (auto)
      apply (rule_tac x="rx2" in exI)
      apply (rule_tac x="r_s3" in exI)
      apply (auto)
      apply (rule_tac x="r_ex" in exI)
      apply (auto)
      apply (rule_tac comp_leq_use_env1)
      apply (simp)
    (* rhs pair case. *)
     apply (rule_tac x="t1" in exI)
     apply (rule_tac x="ra" in exI)
     apply (rule_tac x="aa" in exI)
     apply (rule_tac x="comp_use_env r_s2a r_x" in exI)
     apply (rule_tac x="rx1" in exI)
     apply (auto)
      apply (rule_tac well_typed_comp_perms)
       apply (simp_all)
     apply (rule_tac x="rx2" in exI)
     apply (rule_tac x="r_s3" in exI)
     apply (auto)
      apply (cut_tac r_x="r_s2a" and r_s="r_s1" and r_ex="r_x" in disj_leq_use_env1)
        apply (simp)
       apply (rule_tac well_typed_perm_leq)
       apply (auto)
     apply (rule_tac x="r_ex" in exI)
     apply (auto)
     apply (rule_tac comp_leq_use_env1)
     apply (simp)
    (* if case. *)
    apply (rule_tac x="rx'" in exI)
    apply (rule_tac x="r_s2a" in exI)
    apply (auto)
    (* lhs pair case. *)
   apply (rule_tac x="r_s2a" in exI)
   apply (rule_tac x="r_s3" in exI)
   apply (rule_tac x="rx1" in exI)
   apply (auto)
   apply (rule_tac x="rx2" in exI)
   apply (auto)
   apply (rule_tac x="r_ex" in exI)
   apply (auto)
   apply (rule_tac comp_leq_use_env1)
   apply (simp)
    (* rhs pair case. *)
  apply (rule_tac x="comp_use_env r_s2a r_x" in exI)
  apply (rule_tac x="r_s3" in exI)
  apply (rule_tac x="rx1" in exI)
   apply (auto)
   apply (rule_tac well_typed_comp_perms)
    apply (simp_all)
  apply (rule_tac x="rx2" in exI)
   apply (auto)
   apply (cut_tac r_x="r_s2a" and r_s="r_s1" and r_ex="r_x" in disj_leq_use_env1)
     apply (simp)
    apply (rule_tac well_typed_perm_leq)
    apply (auto)
  apply (rule_tac x="r_ex" in exI)
  apply (auto)
  apply (rule_tac comp_leq_use_env1)
  apply (simp)
  done

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

lemma safe_send_exp_ih: "\<lbrakk> well_typed env delta r_s1 (app_hole h (AppExp (AppExp (ConstExp SendConst) c) v)) tau r_s2 rx;
  well_formed_delta env delta; is_value c; is_value v \<rbrakk> \<Longrightarrow>
  well_typed env delta r_s1 (app_hole h (ConstExp UnitConst)) tau r_s2 rx"
  apply (induct h arbitrary: env r_s1 tau r_s2 rx)
       apply (auto)
    (* base case *)
        apply (simp add: pure_fun_def)
       apply (rule_tac r_sb="diff_use_env r_s3 (comp_use_env (comp_use_env rx1 (lift_use_env rx2 r)) r_ex)" in trans_leq_use_env)
        apply (rule_tac diff_leq_use_env)
        apply (rule_tac r_sb="r_s2a" in trans_leq_use_env)
         apply (rule_tac r_sb="diff_use_env r_s3a (comp_use_env (comp_use_env rx1a (lift_use_env rx2a ra)) r_exa)" in trans_leq_use_env)
          apply (rule_tac diff_leq_use_env)
          apply (rule_tac r_sb="r_s2b" in trans_leq_use_env)
           apply (simp_all)
        apply (rule_tac well_typed_perm_leq)
        apply (auto)
       apply (rule_tac well_typed_perm_leq)
       apply (auto)
    (* lhs app case *)
      apply (rule_tac x="t1" in exI)
      apply (rule_tac x="r" in exI)
      apply (rule_tac x="a" in exI)
      apply (rule_tac x="r_s2a" in exI)
      apply (rule_tac x="rx1" in exI)
      apply (auto)
    (* rhs app case *)
     apply (rule_tac x="t1" in exI)
     apply (rule_tac x="r" in exI)
     apply (rule_tac x="a" in exI)
     apply (rule_tac x="r_s2a" in exI)
     apply (rule_tac x="rx1" in exI)
     apply (auto)
     apply (rule_tac x="rx2" in exI)
     apply (rule_tac x="r_s3" in exI)
     apply (auto)
    (* if case *)
    apply (rule_tac x="rx'" in exI)
    apply (rule_tac x="r_s2a" in exI)
    apply (auto)
    (* lhs pair case *)
   apply (rule_tac x="r_s2a" in exI)
   apply (rule_tac x="r_s3" in exI)
   apply (rule_tac x="rx1" in exI)
   apply (auto)
    (* rhs pair case *)
  apply (rule_tac x="r_s2a" in exI)
  apply (rule_tac x="r_s3" in exI)
  apply (rule_tac x="rx1" in exI)
  apply (auto)
  apply (rule_tac x="rx2" in exI)
  apply (auto)
  done

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

lemma disj_lift_use_envr_rev: "\<lbrakk> strong_disj_use_env r_s r_x \<rbrakk> \<Longrightarrow> disj_use_env r_s (lift_use_env r_x r)"
  apply (simp add: strong_disj_use_env_def)
  apply (simp add: disj_use_env_def)
  apply (simp add: mini_disj_use_env_def)
  apply (auto)
   apply (erule_tac x="x" in allE)
   apply (auto)
   apply (case_tac r)
     apply (auto)
  apply (erule_tac x="x" in allE)
  apply (auto)
  apply (case_tac r)
    apply (auto)
  done

lemma lift_strong_disj_use_env1: "\<lbrakk> strong_disj_use_env r_x r_s \<rbrakk> \<Longrightarrow> strong_disj_use_env (lift_use_env r_x r) r_s"
  apply (simp add: strong_disj_use_env_def)
  apply (auto)
  apply (erule_tac x="x" in allE)
  apply (auto)
  apply (case_tac r)
    apply (auto)
  done

lemma send_disj_nres_map: "\<lbrakk> disj_nres_map p_map; p_map u1 = Some r_sa; p_map u2 = Some r_sb; is_own r;
  leq_use_env r_xa (lift_use_env r_sa r); leq_use_env r_xb (comp_use_env (lift_use_env r_sa r) (lift_use_env r_sb r));
  strong_disj_use_env r_xa r_xb \<rbrakk> \<Longrightarrow> disj_nres_map (add_env (add_env p_map u1 r_xa) u2 r_xb)"
  apply (rule_tac disj_add_nres_map)
   apply (rule_tac disj_add_nres_map)
    apply (simp)
    (* proving disjointness for the send thread's material *)
   apply (rule_tac r_s="lift_use_env r_sa r" in leq_sep_nres_map)
    apply (simp)
   apply (simp add: disj_nres_map_def)
   apply (simp add: sep_nres_map_def)
   apply (auto)
   apply (case_tac "x = u1")
    apply (simp add: nres_lookup_def)
    apply (simp add: rem_env_def)
    apply (rule_tac empty_strong_disj_use_env2)
   apply (rule_tac lift_strong_disj_use_env1)
   apply (erule_tac x="u1" in allE)
   apply (erule_tac x="x" in allE)
   apply (simp add: nres_lookup_def)
   apply (simp add: rem_env_def)
    (* proving disjointness for the recv thread *)
  apply (simp add: sep_nres_map_def)
  apply (auto)
  apply (case_tac "u2 = x")
   apply (simp add: nres_lookup_def)
   apply (simp add: rem_env_def)
   apply (rule_tac empty_strong_disj_use_env2)
  apply (case_tac "u1 = x")
   apply (simp add: nres_lookup_def)
   apply (simp add: rem_env_def)
   apply (simp add: add_env_def)
   apply (rule_tac comm_strong_disj_use_env)
   apply (simp)
  apply (simp add: nres_lookup_def)
  apply (simp add: rem_env_def)
  apply (simp add: add_env_def)
  apply (simp add: disj_nres_map_def)
  apply (rule_tac r_s="comp_use_env (lift_use_env r_sa r) (lift_use_env r_sb r)" in strong_disj_leq_use_env1)
   apply (rule_tac strong_disj_comp_use_env2)
    apply (rule_tac lift_strong_disj_use_env1)
    apply (erule_tac x="u1" in allE)
    apply (erule_tac x="x" in allE)
    apply (simp add: nres_lookup_def)
   apply (rule_tac lift_strong_disj_use_env1)
   apply (erule_tac x="u2" in allE)
   apply (erule_tac x="x" in allE)
   apply (simp add: nres_lookup_def)
  apply (simp)
  done
  (*
fun proper_hole where
  "proper_hole rs_map ExpHole = True"
| "proper_hole rs_map (AppHole1 h e) = (proper_hole rs_map h \<and> proper_exp rs_map e)"
| "proper_hole rs_map (AppHole2 v h) = (proper_exp rs_map v \<and> proper_hole rs_map h)"
| "proper_hole rs_map (IfHole h e1 e2) = (proper_hole rs_map h \<and> proper_exp rs_map e1 \<and> proper_exp rs_map e2)"
| "proper_hole rs_map (PairHole1 h e) = (proper_hole rs_map h \<and> proper_exp rs_map e)"
| "proper_hole rs_map (PairHole2 v h) = (proper_exp rs_map v \<and> proper_hole rs_map h)"

lemma proper_app_hole_split1: "\<lbrakk> proper_exp rs_map (app_hole h e) \<rbrakk> \<Longrightarrow> proper_hole rs_map h"
  apply (induct h)
       apply (auto)
            apply (simp_all add: proper_exp_def)
  done

lemma proper_app_hole_split2: "\<lbrakk> proper_exp rs_map (app_hole h e) \<rbrakk> \<Longrightarrow> proper_exp rs_map e"
  apply (induct h)
       apply (auto)
      apply (simp_all add: proper_exp_def)
  done

lemma proper_app_hole_recon: "\<lbrakk> proper_hole rs_map h; proper_exp rs_map e \<rbrakk> \<Longrightarrow> proper_exp rs_map (app_hole h e)"
  apply (induct h)
       apply (auto)
      apply (simp_all add: proper_exp_def)
  done

lemma proper_app_hole: "\<lbrakk> proper_exp rs_map (app_hole h e1); proper_exp rs_map e2 \<rbrakk> \<Longrightarrow> proper_exp rs_map (app_hole h e2)"
  apply (cut_tac rs_map="rs_map" and h="h" and e="e1" in proper_app_hole_split1)
   apply (auto)
  apply (rule_tac proper_app_hole_recon)
   apply (auto)
  done*)

lemma srps_send_case: "\<lbrakk>well_typed_system env delta p_map s2 ps1; valid_reduct app_red_exp; r_ax = SendAct;
        ps1 u1 = Some (app_hole h1 (AppExp (AppExp (ConstExp SendConst) (VarExp (LocType x_s))) v));
        ps1 u2 = Some (app_hole h2 (AppExp (ConstExp RecvConst) (VarExp (LocType x_r)))); u1 \<noteq> u2; wf_hole h1;
        wf_hole h2; is_value v; s2 x_s = Some ChanSValue;
        s2 x_r = Some (ChanRValue x_s); s1 = s2;
        ps2 = add_env (add_env ps1 u1 (app_hole h1 (ConstExp UnitConst))) u2 (app_hole h2 v)\<rbrakk>
       \<Longrightarrow> \<exists>r_s g_ax.
              (\<exists>p_map'. well_typed_system (red_env env g_ax) (red_delta delta g_ax) p_map' s2
                         (add_env (add_env ps1 u1 (app_hole h1 (ConstExp UnitConst))) u2 (app_hole h2 v))) \<and>
              safe_act s2 r_s g_ax"
      (* prelim: well-formed-delta *)
  apply (cut_tac delta="delta" in wts_well_formed_delta)
   apply (simp add: well_typed_system_def)
   apply (auto)
      (* send case. no resources are generated in this step *)
  apply (rule_tac x="empty_use_env" in exI)
  apply (rule_tac x="NoResAct" in exI)
  apply (auto)
  apply (simp add: well_typed_system_def)
  apply (auto)
    (* we have to get the well-typedness statement for h1 [send c v] *)
  apply (case_tac "\<not> (case ps1 u1 of None \<Rightarrow> True | Some e \<Rightarrow> (case p_map u1 of None \<Rightarrow> False | Some r_s \<Rightarrow> \<exists>rx r_s2. well_typed env delta r_s e UnitTy r_s2 rx))")
   apply (simp add: well_typed_proc_set_def)
   apply (auto)
   apply (erule_tac x="u1" in allE)
   apply (auto)
  apply (case_tac "p_map u1")
   apply (auto)
    (* we also get the well-typedness statement for h2 [recv c v] *)
  apply (case_tac "\<not> (case ps1 u2 of None \<Rightarrow> True | Some e \<Rightarrow> (case p_map u2 of None \<Rightarrow> False | Some r_s \<Rightarrow> \<exists>rx r_s2. well_typed env delta r_s e UnitTy r_s2 rx))")
   apply (simp add: well_typed_proc_set_def)
   apply (auto)
   apply (erule_tac x="u2" in allE)
   apply (auto)
  apply (case_tac "p_map u2")
   apply (auto)
    (* next we get the send channel's type *)
  apply (case_tac "\<not> (\<exists> t. env (Loc x_s) = Some (ChanTy t SEnd))")
   apply (simp add: well_typed_state_def)
   apply (auto)
   apply (erule_tac x="x_s" in allE)
   apply (auto)
   apply (case_tac "env (Loc x_s)")
    apply (auto)
    (* and the recv channel's type *)
  apply (case_tac "\<not> env (Loc x_r) = Some (ChanTy t REnd)")
   apply (simp add: well_typed_state_def)
   apply (auto)
   apply (erule_tac x="x_r" in allE)
   apply (auto)
   apply (case_tac "env (Loc x_r)")
    apply (auto)
    (* prelim: we prove the dominator of v \<le> lift a r (the permission map of u1) *)
  apply (cut_tac eq_own)
  apply (auto)
  apply (cut_tac r_sc="np_dom_use_env env delta v" and r_sb="np_dom_use_env env delta (app_hole h1 (AppExp (AppExp (ConstExp SendConst) (VarExp (LocType x_s))) v))"
      and r_sa="lift_use_env a r" in trans_leq_use_env)
    apply (rule_tac wt_np_leq_use_env)
     apply (auto)
   apply (simp add: np_dom_use_env_def)
   apply (rule_tac dist_dom_leq_use_env)
   apply (auto)
   apply (simp add: non_prim_vars_def)
   apply (rule_tac app_hole_res_vars)
   apply (auto)
    (* we can generate a type for h1 () *)
  apply (cut_tac env="env" and v="v" and ?r_s1.0="a" and tau="UnitTy" and h="h1" and ?r_s2.0="r_s2" and rx="rx" and s="s2" and delta="delta" in safe_send_exp)
        apply (auto)
    apply (simp add: well_typed_state_def)
    (* - complete proof that a is still valid *)
   apply (simp add: well_typed_proc_set_def)
   apply (simp add: sub_nres_map_def)
   apply (erule_tac x="u1" in allE)
   apply (simp add: nres_lookup_def)
    (* we can also generate a type for h2 v, first by getting a type for v, and then by putting it in the hole *)
  apply (cut_tac env="env" and v="v" and h="h1" and a="x_s" and t="t" in safe_val_exp)
      apply (auto)
  apply (cut_tac env="env" and ?r_s1.0="aa" and h="h2" and r_x="np_dom_use_env env delta v" in safe_recv_exp)
          apply (auto)
    (* - p_map disjointness proves that the permissions being added are disjoint *)
    apply (rule_tac r_s="lift_use_env a r" in disj_leq_use_env2)
     apply (case_tac "\<forall>x y. x \<noteq> y \<longrightarrow> strong_disj_use_env (nres_lookup p_map x) (nres_lookup p_map y)")
      apply (erule_tac x="u2" in allE)
      apply (erule_tac x="u1" in allE)
      apply (auto)
     apply (simp add: nres_lookup_def)
     apply (rule_tac disj_lift_use_envr_rev)
     apply (simp)
    apply (simp add: well_typed_proc_set_def)
    apply (simp add: disj_nres_map_def)
    (* - proving the dominator is strong *)
   apply (simp add: np_dom_use_env_def)
   apply (rule_tac strong_dom_use_env)
    (* lastly it remains to prove the new process map is well-formed *)
  apply (rule_tac x="add_env (add_env p_map u1 (diff_use_env a (np_dom_use_env env delta v)))
    u2 (comp_use_env aa (np_dom_use_env env delta v))" in exI)
  apply (simp add: well_typed_proc_set_def)
  apply (auto)
    (* completeness *)(*
      apply (rule_tac add_full_nres_map)
      apply (rule_tac add_full_nres_map)
      apply (simp)*)
    (* disjointness, assisted by lemma *)
     apply (rule_tac r_sa="a" and r_sb="aa" in send_disj_nres_map)
           apply (simp_all)
       apply (rule_tac diff_leq_use_env)
       apply (rule_tac self_lift_leq_use_env)
      apply (rule_tac dist_comp_leq_use_env)
       apply (rule_tac comp_leq_use_env2)
       apply (rule_tac self_lift_leq_use_env)
      apply (rule_tac comp_leq_use_env1)
      apply (simp)
     apply (rule_tac strong_disj_comp_use_env1)
      apply (rule_tac r_s="a" in strong_disj_leq_use_env1)
       apply (simp add: disj_nres_map_def)
       apply (erule_tac x="u1" in allE)
       apply (erule_tac x="u1" in allE)
       apply (erule_tac x="u2" in allE)
       apply (simp add: nres_lookup_def)
      apply (rule_tac self_diff_leq_use_env)
     apply (rule_tac r_s="np_dom_use_env env delta v" in strong_disj_leq_use_env2)
      apply (rule_tac diff_strong_disj_use_env)
      apply (simp add: np_dom_use_env_def)
     apply (rule_tac strong_dom_use_env)
    apply (rule_tac id_leq_use_env)
    (* proving that the processes are well-typed *)
    apply (case_tac "u = u1")
     apply (simp add: add_env_def)
     apply (auto)(*
     apply (rule_tac proper_app_hole)
      apply (simp)
     apply (simp add: proper_exp_def)*)
    apply (case_tac "u = u2")
     apply (simp add: add_env_def)
     apply (auto)(*
     apply (rule_tac proper_app_hole)
      apply (simp)
     apply (cut_tac rs_map="rs_map" and h="h1" and e="AppExp (AppExp (ConstExp SendConst) (VarExp (LocType x_s a_s))) v" in proper_app_hole_split2)
      apply (simp)
     apply (simp add: proper_exp_def)*)
    apply (simp add: add_env_def)
    apply (erule_tac x="u" in allE)
    apply (case_tac "ps1 u")
     apply (auto)
    apply (simp add: add_env_def)
    (* proving res_map element containment *)
   apply (rule_tac add_sub_nres_map1)
    apply (rule_tac add_sub_nres_map1)
     apply (simp)
    apply (rule_tac r_s="a" in trans_sub_use_env)
     apply (simp add: sub_nres_map_def)
     apply (erule_tac x="u1" in allE)
     apply (simp add: nres_lookup_def)
    apply (rule_tac self_diff_leq_use_env)
   apply (rule_tac comp_sub_use_env)
    apply (simp add: sub_nres_map_def)
    apply (erule_tac x="u2" in allE)
    apply (simp add: nres_lookup_def)
   apply (rule_tac r_s="lift_use_env a r" in trans_sub_use_env)
    apply (rule_tac lift_sub_use_env)
    apply (simp add: sub_nres_map_def)
    apply (erule_tac x="u1" in allE)
    apply (simp add: nres_lookup_def)
   apply (simp)
    (* proving the separation of the new maps *)(*
  apply (case_tac "u = u1")
   apply (simp add: add_env_def)
   apply (rule_tac r_s="a" in leq_sep_nres_map)
    apply (rule_tac self_diff_leq_use_env)
   apply (erule_tac x="u1" in allE)
   apply (auto)
  apply (case_tac "u = u2")
   apply (simp add: add_env_def)
   apply (rule_tac comp_sep_nres_map)
    apply (erule_tac x="u2" in allE)
    apply (auto)
   apply (erule_tac x="u1" in allE)
   apply (auto)
   apply (rule_tac r_s="lift_use_env a r" in leq_sep_nres_map)
    apply (simp)
   apply (simp add: sep_nres_map_def)
    apply (auto)
   apply (rule_tac lift_strong_disj_use_env1)
   apply (simp)
  apply (simp add: add_env_def)*)
  done

end


section\<open>The Needham-Schroeder Public-Key Protocol against Dolev-Yao --- with Gets event, hence with Reception rule\<close>

theory NS_Public_Bad imports Public begin

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

         (*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> ns_public;  X \<in> synth (analz (knows Spy evsf))\<rbrakk>
          \<Longrightarrow> Says Spy B X  # evsf \<in> ns_public"

         (*A message that is sent may be received*)
 | Reception: "\<lbrakk>evsr \<in> ns_public; Says A B X \<in> set evsr\<rbrakk>
                \<Longrightarrow> Gets B X # evsr \<in> ns_public"

         (*Alice initiates a protocol run, sending a nonce to Bob*)
 | NS1:  "\<lbrakk>evs1 \<in> ns_public;  Nonce NA \<notin> used evs1\<rbrakk>
          \<Longrightarrow> Says A B (Crypt (pubEK B) \<lbrace>Nonce NA, Agent A\<rbrace>)
                # evs1  \<in>  ns_public"

         (*Bob responds to Alice's message with a further nonce*)
 | NS2:  "\<lbrakk>evs2 \<in> ns_public;  Nonce NB \<notin> used evs2;
           Gets B (Crypt (pubEK B) \<lbrace>Nonce NA, Agent A\<rbrace>) \<in> set evs2\<rbrakk>
          \<Longrightarrow> Says B A (Crypt (pubEK A) \<lbrace>Nonce NA, Nonce NB\<rbrace>)
                # evs2  \<in>  ns_public"

         (*Alice proves her existence by sending NB back to Bob.*)
 | NS3:  "\<lbrakk>evs3 \<in> ns_public;
           Says A  B (Crypt (pubEK B) \<lbrace>Nonce NA, Agent A\<rbrace>) \<in> set evs3;
           Gets A (Crypt (pubEK A) \<lbrace>Nonce NA, Nonce NB\<rbrace>) \<in> set evs3\<rbrakk>
          \<Longrightarrow> Says A B (Crypt (pubEK B) (Nonce NB)) # evs3 \<in> ns_public"

declare knows_Spy_partsEs [elim] thm knows_Spy_partsEs
declare analz_into_parts [dest]
declare Fake_parts_insert_in_Un [dest]

(*A "possibility property": there are traces that reach the end*)
lemma "\<exists>NB. \<exists>evs \<in> ns_public. Says A B (Crypt (pubEK B) (Nonce NB)) \<in> set evs"
apply (intro exI bexI)
apply (rule_tac [2] ns_public.Nil [THEN ns_public.NS1, THEN ns_public.Reception,
                                   THEN ns_public.NS2, THEN ns_public.Reception,
                                   THEN ns_public.NS3])
by possibility

text\<open>Lemmas about reception invariant: if a message is received it certainly
was sent\<close>
lemma Gets_imp_Says :
     "\<lbrakk> Gets B X \<in> set evs; evs \<in> ns_public \<rbrakk> \<Longrightarrow> \<exists>A. Says A B X \<in> set evs"
apply (erule rev_mp)
apply (erule ns_public.induct)
apply auto
done

lemma Gets_imp_knows_Spy:
     "\<lbrakk> Gets B X \<in> set evs; evs \<in> ns_public \<rbrakk>  \<Longrightarrow> X \<in> knows Spy evs"
apply (blast dest!: Gets_imp_Says Says_imp_knows_Spy)
done

lemma Gets_imp_knows_Spy_parts[dest]:
    "\<lbrakk> Gets B X \<in> set evs; evs \<in> ns_public \<rbrakk>  \<Longrightarrow> X \<in> parts (knows Spy evs)"
apply (blast dest: Gets_imp_knows_Spy [THEN parts.Inj])
done

(**** Inductive proofs about ns_public ****)

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

(*Spy never sees another agent's private key! (unless it's bad at start)*)
lemma Spy_see_priEK [simp]:
      "evs \<in> ns_public \<Longrightarrow> (Key (priEK A) \<in> parts (knows Spy evs)) = (A \<in> bad)"
by (erule ns_public.induct, auto)

lemma Spy_analz_priEK [simp]:
      "evs \<in> ns_public \<Longrightarrow> (Key (priEK A) \<in> analz (knows Spy evs)) = (A \<in> bad)"
by auto

(*** Authenticity properties obtained from NS2 ***)

(*It is impossible to re-use a nonce in both NS1 and NS2, provided the nonce
  is secret.  (Honest users generate fresh nonces.)*)

(*Unicity for NS1: nonce NA identifies agents A and B*)
lemma unique_NA:
     "\<lbrakk>Crypt(pubEK B)  \<lbrace>Nonce NA, Agent A \<rbrace> \<in> parts(knows Spy evs);
       Crypt(pubEK B') \<lbrace>Nonce NA, Agent A'\<rbrace> \<in> parts(knows Spy evs);
       Nonce NA \<notin> analz (knows Spy evs); evs \<in> ns_public\<rbrakk>
      \<Longrightarrow> A=A' \<and> B=B'"
apply (erule rev_mp, erule rev_mp, erule rev_mp)
apply (erule ns_public.induct, simp_all)
(*Fake, NS1*)
apply (blast intro!: analz_insertI)+
done

(*Secrecy: Spy does not see the nonce sent in msg NS1 if A and B are secure
  The major premise "Says A B ..." makes it a dest-rule, so we use
  (erule rev_mp) rather than rule_format. *)
theorem Spy_not_see_NA:
      "\<lbrakk>Says A B (Crypt(pubEK B) \<lbrace>Nonce NA, Agent A\<rbrace>) \<in> set evs;
        A \<notin> bad;  B \<notin> bad;  evs \<in> ns_public\<rbrakk>
       \<Longrightarrow> Nonce NA \<notin> analz (knows Spy evs)"
apply (erule rev_mp)
apply (erule ns_public.induct, simp_all, spy_analz)
apply (blast dest: unique_NA intro: no_nonce_NS1_NS2)+
done

(*Authentication for A: if she receives message 2 and has used NA
  to start a run, then B has sent message 2.*)
lemma A_trusts_NS2_lemma [rule_format]:
   "\<lbrakk>A \<notin> bad;  B \<notin> bad;  evs \<in> ns_public\<rbrakk>
    \<Longrightarrow> Crypt (pubEK A) \<lbrace>Nonce NA, Nonce NB\<rbrace> \<in> parts (knows Spy evs) \<longrightarrow>
        Says A B (Crypt(pubEK B) \<lbrace>Nonce NA, Agent A\<rbrace>) \<in> set evs \<longrightarrow>
        Says B A (Crypt(pubEK A) \<lbrace>Nonce NA, Nonce NB\<rbrace>) \<in> set evs"
apply (erule ns_public.induct)
apply (auto dest: Spy_not_see_NA unique_NA)
done

theorem A_trusts_NS2:
     "\<lbrakk>Says A  B (Crypt(pubEK B) \<lbrace>Nonce NA, Agent A\<rbrace>) \<in> set evs;
       Gets A (Crypt(pubEK A) \<lbrace>Nonce NA, Nonce NB\<rbrace>) \<in> set evs;
       A \<notin> bad;  B \<notin> bad;  evs \<in> ns_public\<rbrakk>
      \<Longrightarrow> Says B A (Crypt(pubEK A) \<lbrace>Nonce NA, Nonce NB\<rbrace>) \<in> set evs"
by (blast intro: A_trusts_NS2_lemma)

(*If the encrypted message appears then it originated with Alice in NS1*)
lemma B_trusts_NS1 [rule_format]:
     "evs \<in> ns_public
      \<Longrightarrow> Crypt (pubEK B) \<lbrace>Nonce NA, Agent A\<rbrace> \<in> parts (knows Spy evs) \<longrightarrow>
          Nonce NA \<notin> analz (knows Spy evs) \<longrightarrow>
          Says A B (Crypt (pubEK B) \<lbrace>Nonce NA, Agent A\<rbrace>) \<in> set evs"
apply (erule ns_public.induct, simp_all)
(*Fake*)
apply (blast intro!: analz_insertI)
done

(*** Authenticity properties obtained from NS2 ***)

(*Unicity for NS2: nonce NB identifies nonce NA and agent A
  [proof closely follows that for unique_NA] *)
lemma unique_NB [dest]:
     "\<lbrakk>Crypt(pubEK A)  \<lbrace>Nonce NA, Nonce NB\<rbrace> \<in> parts(knows Spy evs);
       Crypt(pubEK A') \<lbrace>Nonce NA', Nonce NB\<rbrace> \<in> parts(knows Spy evs);
       Nonce NB \<notin> analz (knows Spy evs); evs \<in> ns_public\<rbrakk>
     \<Longrightarrow> A=A' \<and> NA=NA'"
apply (erule rev_mp, erule rev_mp, erule rev_mp)
apply (erule ns_public.induct, simp_all)
(*Fake, NS2*)
apply (blast intro!: analz_insertI)+
done

(*NB remains secret PROVIDED Alice never responds with round 3*)
theorem Spy_not_see_NB [dest]:
     "\<lbrakk>Says B A (Crypt (pubEK A) \<lbrace>Nonce NA, Nonce NB\<rbrace>) \<in> set evs;
       \<forall>C. Says A C (Crypt (pubEK C) (Nonce NB)) \<notin> set evs;
       A \<notin> bad;  B \<notin> bad;  evs \<in> ns_public\<rbrakk>
     \<Longrightarrow> Nonce NB \<notin> analz (knows Spy evs)"
apply (erule rev_mp, erule rev_mp)
apply (erule ns_public.induct, simp_all, spy_analz)
apply (simp_all add: all_conj_distrib) (*speeds up the next step*)
apply (blast intro: no_nonce_NS1_NS2)+
done

(*Authentication for B: if he receives message 3 and has used NB
  in message 2, then A has sent message 3--to somebody....*)

lemma B_trusts_NS3_lemma [rule_format]:
     "\<lbrakk>A \<notin> bad;  B \<notin> bad;  evs \<in> ns_public\<rbrakk>
      \<Longrightarrow> Crypt (pubEK B) (Nonce NB) \<in> parts (knows Spy evs) \<longrightarrow>
          Says B A  (Crypt (pubEK A) \<lbrace>Nonce NA, Nonce NB\<rbrace>) \<in> set evs \<longrightarrow>
          (\<exists>C. Says A C (Crypt (pubEK C) (Nonce NB)) \<in> set evs)"
apply (erule ns_public.induct, auto)
by (blast intro: no_nonce_NS1_NS2)+

theorem B_trusts_NS3:
     "\<lbrakk>Says B A  (Crypt (pubEK A) \<lbrace>Nonce NA, Nonce NB\<rbrace>) \<in> set evs;
       Gets B (Crypt (pubEK B) (Nonce NB)) \<in> set evs;
       A \<notin> bad;  B \<notin> bad;  evs \<in> ns_public\<rbrakk>
      \<Longrightarrow> \<exists>C. Says A C (Crypt (pubEK C) (Nonce NB)) \<in> set evs"
by (blast intro: B_trusts_NS3_lemma)

(*Can we strengthen the secrecy theorem Spy_not_see_NB?  NO*)
lemma "\<lbrakk>A \<notin> bad;  B \<notin> bad;  evs \<in> ns_public\<rbrakk>
       \<Longrightarrow> Says B A (Crypt (pubEK A) \<lbrace>Nonce NA, Nonce NB\<rbrace>) \<in> set evs
           \<longrightarrow> Nonce NB \<notin> analz (knows Spy evs)"
apply (erule ns_public.induct, simp_all, spy_analz)
(*NS1: by freshness*)
apply blast
(*NS2: by freshness and unicity of NB*)
apply (blast intro: no_nonce_NS1_NS2)
(*NS3: unicity of NB identifies A and NA, but not B*)
apply clarify
apply (frule_tac A' = A in
       Says_imp_knows_Spy [THEN parts.Inj, THEN unique_NB], auto)
apply (rename_tac evs3 B' C)
txt\<open>This is the attack!
@{subgoals[display,indent=0,margin=65]}
\<close>
oops

end


(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

theory GraphLang

imports
  "CParser.TypHeapLib"
  "Lib.SplitRule"
  "CommonOps"

begin

text \<open>Note that machine states here are assumed to be countable and
are thus represented by naturals.\<close>

datatype variable =
    VarNone
  | VarWord8 word8
  | VarWord16 word16
  | VarWord32 word32
  | VarWord64 word64
  | VarMem "machine_word \<Rightarrow> word8"
  | VarDom "machine_word set"
  | VarGhostState "ghost_assertions"
  | VarHTD "heap_typ_desc"
  | VarMS "unit \<times> nat"
  | VarBool bool

text \<open>States are a mapping from names to the variable type, which is
a union of the available names.\<close>

datatype state = State "string \<Rightarrow> variable"

text \<open>Accessors for grabbing variables by name and expected type.\<close>

definition
  "var_acc nm st = (case st of State f \<Rightarrow> f nm)"

definition
  "var_word8 nm st = (case var_acc nm st of
    VarWord8 w \<Rightarrow> w | _ \<Rightarrow> 0)"

definition
  "var_word16 nm st = (case var_acc nm st of
    VarWord16 w \<Rightarrow> w | _ \<Rightarrow> 0)"

definition
  "var_word32 nm st = (case var_acc nm st of
    VarWord32 w \<Rightarrow> w | _ \<Rightarrow> 0)"

definition
  "var_word64 nm st = (case var_acc nm st of
    VarWord64 w \<Rightarrow> w | _ \<Rightarrow> 0)"

definition
  "var_ghoststate nm st = (case var_acc nm st of
    VarGhostState arr \<Rightarrow> arr | _ \<Rightarrow> (\<lambda>_. 0))"

definition
  "var_mem nm st = (case var_acc nm st of
    VarMem m \<Rightarrow> m | _ \<Rightarrow> \<lambda>_. 0)"

definition
  "var_dom nm st = (case var_acc nm st of
    VarDom d \<Rightarrow> d | _ \<Rightarrow> {})"

definition
  "var_htd nm st = (case var_acc nm st of
    VarHTD htd \<Rightarrow> htd | _ \<Rightarrow> empty_htd)"

definition
  "var_ms nm st = (case var_acc nm st of
    VarMS ms \<Rightarrow> ms | _ \<Rightarrow> ((), 0))"

definition
  "var_bool nm st = (case var_acc nm st of
    VarBool bool \<Rightarrow> bool | _ \<Rightarrow> False)"

text \<open>The variable updator.\<close>

definition
  "var_upd nm v st = (case st of State f \<Rightarrow> State (f (nm := v)))"

definition
  "default_state = State (\<lambda>_. VarNone)"

text \<open>The type of nodes.\<close>

datatype next_node =
    NextNode nat | Ret | Err

datatype node =
    Basic next_node "(string \<times> (state \<Rightarrow> variable)) list"
  | Cond next_node next_node "state \<Rightarrow> bool"
  | Call next_node string "(state \<Rightarrow> variable) list" "string list"

definition Skip where
  "Skip nn = Cond nn nn (\<lambda>x. True)"

text \<open>The type for a total graph function, including list of inputs,
  list of outputs, graph, and entry point.\<close>

datatype graph_function
  = GraphFunction "string list" "string list" "nat \<Rightarrow> node option" nat

primrec entry_point where
  "entry_point (GraphFunction inputs outputs graph ep) = ep"

primrec function_graph where
  "function_graph (GraphFunction inputs outputs graph ep) = graph"

primrec function_inputs where
  "function_inputs (GraphFunction inputs outputs graph ep) = inputs"

primrec function_outputs where
  "function_outputs (GraphFunction inputs outputs graph ep) = outputs"

text \<open>The definition of execution, including a stack to allow function calls.\<close>

definition
  save_vals :: "string list \<Rightarrow> variable list \<Rightarrow> state \<Rightarrow> state"
where
 "save_vals vars vals st = fold (\<lambda>(var, val). var_upd var val) (zip vars vals) st"

definition
  init_vars :: "string list \<Rightarrow> (state \<Rightarrow> variable) list \<Rightarrow> state \<Rightarrow> state"
where
  "init_vars vars accs st = save_vals vars (map (\<lambda>i. i st) accs) default_state"

definition
  acc_vars :: "string list \<Rightarrow> state \<Rightarrow> variable list"
where
  "acc_vars vars st = map (\<lambda>v. var_acc v st) vars"

definition
  return_vars :: "string list \<Rightarrow> string list \<Rightarrow> state \<Rightarrow> state \<Rightarrow> state"
where
  "return_vars inner outer inner_st = save_vals outer (acc_vars inner inner_st)"

definition
  upd_vars :: "(string \<times> (state \<Rightarrow> variable)) list \<Rightarrow> state \<Rightarrow> state"
where
  "upd_vars upds st = save_vals (map fst upds) (map (\<lambda>(nm, vf). vf st) upds) st"

type_synonym stack = "(next_node \<times> state \<times> string) list"

primrec
  upd_stack :: "next_node \<Rightarrow> (state \<Rightarrow> state) \<Rightarrow> stack \<Rightarrow> stack"
where
    "upd_stack nn stf (x # xs) = (nn, stf (fst (snd x)), snd (snd x)) # xs"
  | "upd_stack nn stf [] = []"

primrec
  exec_node :: "(string \<Rightarrow> graph_function option)
        \<Rightarrow> state \<Rightarrow> node \<Rightarrow> stack \<Rightarrow> stack set"
where
    "exec_node Gamma st (Basic cont upds) stack
        = {upd_stack cont (K (upd_vars upds st)) stack}"
  | "exec_node Gamma st (Cond left right cond) stack
        = {upd_stack (if cond st then left else right) id stack}"
  | "exec_node Gamma st (Call cont fname inputs outputs) stack
        = (case Gamma fname of None \<Rightarrow> {upd_stack Err id stack}
            | Some (GraphFunction inps outps graph ep)
                \<Rightarrow> {(NextNode ep, init_vars inps inputs st, fname)
                        # stack})"

primrec
  exec_node_return :: "(string \<Rightarrow> graph_function option)
        \<Rightarrow> state \<Rightarrow> node \<Rightarrow> stack \<Rightarrow> stack set"
where
    "exec_node_return _ _ (Basic _ _) stack = {}"
  | "exec_node_return _ _ (Cond _ _ _) stack = {}"
  | "exec_node_return Gamma st (Call cont fname inputs outputs) stack
        = (case Gamma fname of None \<Rightarrow> {}
            | Some (GraphFunction inps outps graph ep)
                \<Rightarrow> {upd_stack cont (return_vars outps outputs st) stack})"

text \<open>The single-step relation on graph states.\<close>

definition
  exec_graph_step :: "(string \<Rightarrow> graph_function option)
        \<Rightarrow> (stack \<times> stack) set"
where
    "exec_graph_step Gamma = {(stack, stack'). case stack of
            (NextNode nn, st, fname) # _ \<Rightarrow>
                (case Gamma fname of None \<Rightarrow> False
                    | Some (GraphFunction _ _ graph _) \<Rightarrow>
                        (case graph nn of None \<Rightarrow> stack' = upd_stack Err id stack
                            | Some node \<Rightarrow> stack' \<in> exec_node Gamma st node stack))
          | (Ret, st, _) # (NextNode nn, _, fname) # _ \<Rightarrow>
                (case Gamma fname of None \<Rightarrow> False
                    | Some (GraphFunction _ _ graph _) \<Rightarrow>
                        (case graph nn of None \<Rightarrow> stack' = upd_stack Err id (tl stack)
                            | Some node \<Rightarrow> stack' \<in> exec_node_return Gamma st node (tl stack)))
          | [] \<Rightarrow> False
          | [_] \<Rightarrow> False \<comment> \<open>note NextNode case is handled\<close>
          | _ \<Rightarrow> stack' = upd_stack Err id (tl stack)
      }"

text \<open>Multi-step relations.\<close>

definition exec_graph
where "exec_graph Gamma = rtrancl (exec_graph_step Gamma)"

definition exec_graph_n
where "exec_graph_n Gamma n = exec_graph_step Gamma ^^ n"

lemma relpow_Suc_simp2:
  "R ^^ Suc n = R O R ^^ n"
  apply safe
   apply (erule relpow_Suc_E2, blast)
  apply (blast intro: relpow_Suc_I2)
  done

lemma exec_graph_n_take_step:
  "\<lbrakk> (stack, stack') \<in> exec_graph_n GGamma n;
    \<lbrakk> n = 0; stack' = stack \<rbrakk> \<Longrightarrow> P;
    \<And>stack''. \<lbrakk> n > 0; (stack, stack'') \<in> exec_graph_step GGamma;
            (stack'', stack') \<in> exec_graph_n GGamma (n - 1) \<rbrakk>
        \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  apply (cases n, simp_all only: exec_graph_n_def relpow_Suc_simp2)
   apply simp
  apply clarsimp
  done

lemma exec_graph_take_step:
  "\<lbrakk> ((NextNode m, gst, fname) # stack, stack') \<in> exec_graph_n GGamma n;
            GGamma fname = Some gf; function_graph gf m = Some node \<rbrakk>
    \<Longrightarrow> (n = 0 \<and> stack' = (NextNode m, gst, fname) # stack)
    \<or> (\<exists>stack''. n \<ge> 1
            \<and> stack'' \<in> exec_node GGamma gst node
                    ((NextNode m, gst, fname) # stack)
            \<and> (stack'', stack') \<in> exec_graph_n GGamma (n - 1))"
  apply (erule exec_graph_n_take_step)
   apply simp
  apply (clarsimp simp: exec_graph_step_def split: graph_function.split_asm)
  apply blast
  done

definition
  continuing :: "stack \<Rightarrow> bool"
where
  "continuing st = (case st of [] \<Rightarrow> False
    | [(NextNode _, _, _)] \<Rightarrow> True | [_] \<Rightarrow> False | _ \<Rightarrow> True)"

lemma continuing_simps[simp]:
  "\<not> continuing []"
  "continuing [(unn, st, g)] = (unn \<noteq> Ret \<and> unn \<noteq> Err)"
  "continuing ((Ret, st, g) # stk) = (stk \<noteq> [])"
  "continuing (stf # stf' # stk)"
  "continuing ((NextNode nn, st, g) # stk)"
  "continuing ((Err, st, g) # stk) = (stk \<noteq> [])"
  by (simp_all add: continuing_def split: next_node.split list.split)

lemma consume_Not_eq:
  "(\<not> P) = Q \<Longrightarrow> P = (\<not> Q)"
  by clarsimp

lemma exec_node_case_helper:
  "(stk' \<in> exec_node Gamma st node stk)
    = (case node of Basic _ _ \<Rightarrow> stk' \<in> id (exec_node Gamma) st node stk
        | _ \<Rightarrow> stk' \<in> id (exec_node Gamma) st node stk)"
  "(stk' \<in> exec_node_return Gamma st node stk)
    = (case node of Basic _ _ \<Rightarrow> stk' \<in> id (exec_node_return Gamma) st node stk
        | _ \<Rightarrow> stk' \<in> id (exec_node_return Gamma) st node stk)"
  by (simp_all split: node.split)

lemmas splits_raw = prod.split list.split option.split
    next_node.split graph_function.split node.split
lemmas splits_cooked = splits_raw[where P=Not, THEN consume_Not_eq]
    option.split[where P="\<lambda>S. x \<notin> S", THEN consume_Not_eq]
    graph_function.split[where P="\<lambda>S. x \<notin> S", THEN consume_Not_eq] for x

lemmas all_exec_graph_step_cases = exec_graph_step_def[THEN eqset_imp_iff,
    simplified, unfolded exec_node_case_helper splits_cooked, simplified,
    unfolded splits_cooked, simplified]

lemma exec_node_stack_extend:
  "continuing stack \<Longrightarrow>
    (stack' \<in> exec_node Gamma st node (stack @ xs))
        = (\<exists>stack''. stack' = stack'' @ xs
                \<and> stack'' \<in> exec_node Gamma st node stack)"
  apply (cases node, simp_all)
  apply (simp_all add: continuing_def
                split: list.split_asm prod.split_asm next_node.split_asm)
  apply (auto split: option.split graph_function.split)
  done

lemma exec_node_return_stack_extend:
  "continuing stack \<Longrightarrow>
    (stack' \<in> exec_node_return Gamma st node (stack @ xs))
        = (\<exists>stack''. stack' = stack'' @ xs
                \<and> stack'' \<in> exec_node_return Gamma st node stack)"
  apply (cases node, simp_all)
  apply (simp_all add: continuing_def
                split: list.split_asm prod.split_asm next_node.split_asm)
  apply (auto split: option.split graph_function.split)
  done

lemma exec_graph_step_stack_extend:
  "continuing stack \<Longrightarrow>
    ((stack @ xs, stack') \<in> exec_graph_step Gamma)
    = (\<exists>stack''. stack' = stack'' @ xs
        \<and> (stack, stack'') \<in> exec_graph_step Gamma)"
  using exec_node_stack_extend[where stack'=stack' and stack=stack
            and Gamma=Gamma and xs=xs]
        exec_node_return_stack_extend[where stack'=stack' and stack="tl stack"
            and Gamma=Gamma and xs=xs]
  apply (simp add: exec_graph_step_def)
  apply (cases stack, simp_all)
  apply clarsimp
  apply (case_tac a, simp_all)
    apply (clarsimp split: option.split graph_function.split)
   apply (clarsimp simp: neq_Nil_conv split: list.split)
   apply (clarsimp split: next_node.split option.split graph_function.split)
  apply (clarsimp simp: neq_Nil_conv split: list.split)
  done

lemma exec_graph_n_stack_extend:
  "continuing stack \<Longrightarrow>
    ((stack @ xs, stack') \<in> exec_graph_n Gamma n)
    = (\<exists>stack'' n'. (stack, stack'') \<in> (exec_graph_step Gamma
                \<inter> {(st, _). continuing st}) ^^ n'
        \<and> ((n' < n \<and> \<not> continuing stack''
                \<and> (stack'' @ xs, stack') \<in> exec_graph_n Gamma (n - n'))
            \<or> (stack' = stack'' @ xs \<and> n' = n)))"
  unfolding exec_graph_n_def
proof (induct n arbitrary: stack)
  case 0
  show ?case
    by auto[1]
next
  case (Suc n stack)
  show ?case
    apply (simp only: relpow_Suc_simp2)
    apply (rule iffI)
     apply (clarsimp simp: exec_graph_step_stack_extend Suc.prems)
     apply (case_tac "continuing stack''")
      apply (frule Suc.hyps, clarsimp)
      apply (rule_tac x="stack''a" in exI, rule_tac x="Suc n'" in exI)
      apply (simp only: relpow_Suc_simp2, clarsimp)
      apply (blast intro: Suc.prems)
     apply (rule_tac x="stack''" in exI, rule_tac x=1 in exI)
     apply (auto simp: Suc.prems)[1]
    apply (clarsimp)
    apply (case_tac n', simp_all only: minus_nat.diff_0 relpow_Suc_simp2)
     apply auto[1]
    apply clarsimp
    apply (rule_tac b="y @ xs" in relcompI)
     apply (simp add: exec_graph_step_stack_extend Suc.prems)
    apply (case_tac "nat = 0")
     apply auto[1]
    apply (subst Suc.hyps)
     apply (case_tac nat, simp_all only: relpow_Suc_simp2, auto)[1]
    apply auto[1]
    done
qed

definition
  "init_state fname gfun xs =
    (NextNode (entry_point gfun), save_vals (function_inputs gfun) xs default_state, fname)"

lemma exec_graph_step_nonempty:
  "\<lbrakk> (stack, stack') \<in> exec_graph_step Gamma ^^ n; stack \<noteq> [] \<rbrakk>
    \<Longrightarrow> stack' \<noteq> []"
  by (cases n, auto simp: all_exec_graph_step_cases
                   split: graph_function.split_asm)

lemma relpow_mono:
  "\<lbrakk> R \<subseteq> (S :: ('a \<times> 'a) set) \<rbrakk> \<Longrightarrow> R ^^ n \<subseteq> S ^^ n"
  by (induct n, auto)

lemma drop_eq_Cons:
  "(drop n xs = x # ys) = (\<exists>zs. length zs = n \<and> xs = zs @ x # ys)"
  apply (induct n arbitrary: xs)
   apply simp
  apply (case_tac xs, auto simp add: length_Suc_conv)
  done

lemma exec_graph_step_n_Err:
  "(((Err, st, graph) # stack, stack') \<in> exec_graph_n Gamma n)
    \<Longrightarrow> stack' = upd_stack Err id (drop n ((Err, st, graph) # stack))
        \<and> drop n ((Err, st, graph) # stack) \<noteq> []"
proof (induct n arbitrary: stack')
  case 0
  show ?case using 0
    by (auto simp add: exec_graph_n_def)
next
  case (Suc n)
  show ?case using Suc.prems
    apply (clarsimp simp: exec_graph_n_def relcomp_unfold linorder_not_le)
    apply (drule exec_graph_step_def[THEN eqset_imp_iff, THEN iffD1])
    apply (case_tac y, simp_all)
    apply (drule Suc.hyps[rotated, unfolded exec_graph_n_def])
    apply (simp only: neq_Nil_conv)
    apply (clarsimp simp: linorder_not_le drop_eq_Cons)
    apply (clarsimp split: list.split_asm)
    apply (case_tac zs, simp_all)
    done
qed

text \<open>Possibly infinite traces.\<close>

definition nat_trace_rel
  where "nat_trace_rel cont r = {tr. (\<forall>n. (tr n = None \<longrightarrow> tr (Suc n) = None)
    \<and> (tr (Suc n) \<noteq> None \<longrightarrow> (the (tr n), the (tr (Suc n))) \<in> r)
    \<and> (tr n \<noteq> None \<and> cont (the (tr n)) \<longrightarrow> tr (Suc n) \<noteq> None))}"

type_synonym trace = "(nat \<Rightarrow> stack option)"

definition
  trace_end :: "(nat \<Rightarrow> 'a option) \<Rightarrow> 'a option"
where
  "trace_end tr = (if \<exists>n. tr n = None then tr (Max (dom tr)) else None)"

lemma nat_trace_rel_Some_range:
  "tr \<in> nat_trace_rel cont r \<Longrightarrow> tr n = Some v
    \<Longrightarrow> \<forall>i \<le> n. \<exists>v'. tr i = Some v'"
  apply (induct n arbitrary: v, simp_all)
  apply (simp add: nat_trace_rel_def le_Suc_eq)
  apply (drule_tac x=n in spec, clarsimp)
  done

lemma trace_None_dom_subset:
  "tr n = None \<Longrightarrow> tr \<in> nat_trace_rel cont R
    \<Longrightarrow> dom tr \<subseteq> {..< n}"
  apply clarsimp
  apply (drule_tac n=x in nat_trace_rel_Some_range, simp+)
  apply (drule_tac x="n" in spec)
  apply simp
  done

lemma nat_trace_Max_dom_None:
  "tr \<in> nat_trace_rel cont R \<Longrightarrow> tr n \<noteq> None \<Longrightarrow> (tr (Max (dom tr)) \<noteq> None)"
  apply (rule notI)
  apply (frule(1) trace_None_dom_subset)
  apply (cases "dom tr = {}")
   apply clarsimp
  apply (drule Max_in[rotated])
   apply (simp add: finite_subset)
  apply clarsimp
  done

lemma trace_end_NoneD:
  "trace_end tr = None \<Longrightarrow> tr \<in> nat_trace_rel cont r
    \<Longrightarrow> tr = (\<lambda>_. None) \<or> (\<exists>f. tr = Some o f)"
  apply (subst disj_commute, rule disjCI)
  apply (clarsimp simp: fun_eq_iff)
  apply (simp add: trace_end_def split: if_split_asm)
   apply (metis nat_trace_Max_dom_None not_None_eq)
  apply (rule_tac x="the o tr" in exI, simp)
  done

lemma trace_end_SomeD:
  "trace_end tr = Some v \<Longrightarrow> tr \<in> nat_trace_rel cont r
    \<Longrightarrow> \<exists>n. tr n = Some v \<and> tr (Suc n) = None \<and> \<not> cont v"
  apply (clarsimp simp: trace_end_def split: if_split_asm)
  apply (rule exI, rule conjI, assumption)
  apply (case_tac "tr (Suc (Max (dom tr)))")
   apply (simp add: nat_trace_rel_def)
   apply (metis option.sel option.simps(3))
  apply (cut_tac x="Suc y" for y in Max_ge[OF finite_subset domI])
     apply (erule(1) trace_None_dom_subset[rotated])
    apply simp+
  done

definition
  exec_trace :: "(string \<Rightarrow> graph_function option) \<Rightarrow> string \<Rightarrow> trace set"
where
  "exec_trace Gamma fname
    = {trace. \<exists>gf. Gamma fname = Some gf
        \<and> (\<exists>st. trace 0 = Some [(NextNode (entry_point gf), st, fname)])
        \<and> trace \<in> nat_trace_rel continuing (exec_graph_step Gamma)}"

lemma relpow_nat_trace:
  "((s, s') \<in> r ^^ n) = (\<exists>tr \<in> nat_trace_rel (\<lambda>x. False) r. tr 0 = Some s
    \<and> tr n = Some s' \<and> tr (Suc n) = None)"
  apply (simp add: relpow_fun_conv, safe)
   apply (rule_tac x="\<lambda>x. if x < Suc n then Some (f x) else None" in bexI)
    apply simp
   apply (simp add: nat_trace_rel_def)
  apply (rule_tac x="the o tr" in exI)
  apply (frule(1) nat_trace_rel_Some_range[where n=n])
  apply (clarsimp simp: nat_trace_rel_def)
  done

text \<open>Parsing code for the graph language.\<close>

ML \<open>

structure ParseGraph = struct

exception PARSEGRAPH of string list

val debug = ref false

fun trace s = if (! debug) then writeln s else ()

fun parse_int str = if String.isPrefix "-" str
  then ~ (parse_int (unprefix "-" str))
  else case read_int (raw_explode str)
  of (n, []) => n
    | _ => raise PARSEGRAPH ["read_int:", str]

val s = @{term "s :: state"}

fun parse_n p (n :: ss) = let
    val n = parse_int n
  in funpow_yield n p ss end
  | parse_n _ [] = raise PARSEGRAPH ["parse_n: empty"]

fun mk_binT sz = Word_Lib.mk_wordT sz |> dest_Type |> snd |> hd

val ptr_size_str =
    case @{typ machine_word} of
      @{typ word32} => "32"
    | @{typ word64} => "64"

fun parse_typ ("Word" :: n :: ss) = let
    val n = parse_int n
  in (Word_Lib.mk_wordT n, ss) end
  | parse_typ ("Bool" :: ss) = (@{typ bool}, ss)
  | parse_typ ("Mem" :: ss) = (@{typ "machine_word \<Rightarrow> word8"}, ss)
  | parse_typ ("Dom" :: ss) = (@{typ "machine_word set"}, ss)
  | parse_typ ("HTD" :: ss) = (@{typ heap_typ_desc}, ss)
  | parse_typ ("PMS" :: ss) = (@{typ nat}, ss)
  | parse_typ ("UNIT" :: ss) = (@{typ unit}, ss)
  | parse_typ ("Array" :: ss) = let
    val (el_typ, ss) = parse_typ ss
    val (n, ss) = case ss of (n :: ss) => (parse_int n, ss)
        | [] => raise PARSEGRAPH ["parse_typ: array index"]
  in (Type (@{type_name array}, [el_typ, mk_binT n]), ss) end
  | parse_typ (bad as ("WordArray" :: "50" :: element_size :: ss)) =
      (if element_size = ptr_size_str
      then (@{typ "ghost_assertions"}, ss)
      else raise PARSEGRAPH ("parse_typ: bad ghost assertion codomain" :: bad))
  | parse_typ ("Struct" :: nm :: ss) = (Type (nm, []), ss)
  | parse_typ ("Ptr" :: ss) = let
    val (obj_typ, ss) = parse_typ ss
  in (Type (@{type_name ptr}, [obj_typ]), ss) end
  | parse_typ ss = raise PARSEGRAPH ("parse_typ: malformed" :: ss)

fun parse_lval ("VarUpdate" :: nm :: ss) = let
    val (_, ss) = parse_typ ss (* FIXME: check typ? *)
  in (nm, ss) end
  | parse_lval ss = raise PARSEGRAPH ("parse_lval" :: ss)

fun parse_var ss = parse_lval ("VarUpdate" :: ss)

val opers = Symtab.make [
      ("Plus", @{const_name "plus"}),
      ("Minus", @{const_name "minus"}),
      ("Times", @{const_name "times"}),
      ("Modulus", @{const_name "modulo_class.modulo"}),
      ("DividedBy", @{const_name "divide_class.divide"}),
      ("BWAnd", @{const_name "and"}),
      ("BWOr", @{const_name "or"}),
      ("BWXOR", @{const_name "xor"}),
      ("And", @{const_name "conj"}),
      ("Or", @{const_name "disj"}),
      ("Implies", @{const_name "implies"}),
      ("Equals", @{const_name "HOL.eq"}),
      ("Less", @{const_name "less"}),
      ("LessEquals", @{const_name "less_eq"}),
      ("SignedLess", @{const_name "word_sless"}),
      ("SignedLessEquals", @{const_name "word_sle"}),
      ("Not", @{const_name "Not"}),
      ("BWNot", @{const_name "not"}),
      ("WordCast", @{const_name "unsigned"}),
      ("WordCastSigned", @{const_name "signed"}),
      ("WordArrayAccess", @{const_name "fun_app"}),
      ("WordArrayUpdate", @{const_name "fun_upd"}),
      ("CountLeadingZeroes", @{const_name "bv_clz"}),
      ("CountTrailingZeroes", @{const_name "bv_ctz"}),
      ("True", @{const_name "True"}),
      ("False", @{const_name "False"}),
      ("IfThenElse", @{const_name "If"}),
      ("MemAcc", @{const_name "mem_acc"}),
      ("MemUpdate", @{const_name "mem_upd"}),
      ("MemDom", @{const_name "Set.member"}),
      ("ShiftLeft", @{const_name "bvshl"}),
      ("ShiftRight", @{const_name "bvlshr"}),
      ("SignedShiftRight", @{const_name "bvashr"}),
      ("PValid", @{const_name pvalid}),
      ("PArrayValid", @{const_name parray_valid}),
      ("PAlignValid", @{const_name palign_valid}),
      ("PGlobalValid", @{const_name pglobal_valid}),
      ("PWeakValid", @{const_name pweak_valid}),
      ("HTDUpdate", @{const_name all_htd_updates})
  ]

fun mk_acc nm typ st = (case typ of
        @{typ word8} => @{term var_word8}
      | @{typ word16} => @{term var_word16}
      | @{typ word32} => @{term var_word32}
      | @{typ word64} => @{term var_word64}
      | @{typ "machine_word \<Rightarrow> word8"} => @{term var_mem}
      | @{typ "machine_word set"} => @{term var_dom}
      | @{typ "ghost_assertions"} => @{term var_ghoststate}
      | @{typ "heap_typ_desc"} => @{term var_htd}
      | @{typ "nat"} => @{term var_ms}
      | @{typ bool} => @{term var_bool}
      | Type (@{type_name ptr}, [_]) =>
          (case @{typ "machine_word"} of
            @{typ word32} => @{term var_word32}
          | @{typ word64} => @{term var_word64})
      | _ => raise PARSEGRAPH ["mk_acc", nm, fst (dest_Type typ)])
    $ HOLogic.mk_string nm $ st

fun parse_val ("Num" :: ss) = let
    val (n, ss) = case ss of n :: ss => (n, ss)
        | [] => raise PARSEGRAPH ["parse_val: parsing num, no numeral"]
    val (typ, ss) = parse_typ ss
    val n = parse_int n
  in (HOLogic.mk_number typ n, ss) end
  | parse_val ("Op" :: nm :: ss) = let
    val const = case Symtab.lookup opers nm
      of SOME c => c
      | NONE => raise PARSEGRAPH ["parse_val: unexpected op", nm]
    val (typ, ss) = parse_typ ss
    val (args, ss) = parse_n parse_val ss
    val oper = Const (const, map fastype_of args ---> typ)
  in trace ("parsed oper " ^ nm ^ " and args");
    (list_comb (oper, args), ss) end
  | parse_val ("Var" :: nm :: ss) = let
    val (typ, ss) = parse_typ ss
  in (mk_acc nm typ s, ss) end
  | parse_val ("Type" :: ss) = let
    val (typ, ss) = parse_typ ss
  in (Logic.mk_type typ, ss) end
  | parse_val ("Symbol" :: nm :: ss) = let
    val (_, ss) = parse_typ ss
  in (TermsTypes.symbol_table $ HOLogic.mk_string nm, ss) end
  | parse_val ss = raise PARSEGRAPH ("parse_val: malformed" :: ss)

val parse_lvals = parse_n parse_lval

val parse_vars = parse_n parse_var

fun mk_var_typ T = (case T of
        @{typ word8} => @{term VarWord8}
      | @{typ word16} => @{term VarWord16}
      | @{typ word32} => @{term VarWord32}
      | @{typ word64} => @{term VarWord64}
      | Type (@{type_name word}, [Type (@{type_name signed}, [T2])])
        => let val uT = Type (@{type_name word}, [T2])
        in Abs ("t", T, mk_var_typ uT $ (Const (@{const_name unsigned}, T --> uT) $ Bound 0)) end
      | @{typ "machine_word \<Rightarrow> word8"} => @{term VarMem}
      | @{typ "ghost_assertions"} => @{term VarGhostState}
      | @{typ "machine_word set"} => @{term VarDom}
      | @{typ "heap_typ_desc"} => @{term VarHTD}
      | @{typ "unit \<times> nat"} => @{term VarMS}
      | @{typ bool} => @{term VarBool}
      | _ => raise TYPE ("mk_var_typ: unexpected var typ", [T], []))

fun mk_var_term t = betapply (mk_var_typ (fastype_of t), t)

fun parse_val_acc ss = let
    val (t, ss) = parse_val ss
  in (Term.lambda_name ("s", s) (mk_var_term t), ss) end

fun parse_cond ss = let
    val (t, ss) = parse_val ss
  in (Term.lambda_name ("s", s) t, ss) end

val parse_vals = parse_n parse_val_acc

fun mk_NextNode n = @{term NextNode} $ HOLogic.mk_number @{typ nat} n

fun parse_nn "Err" = @{term Err}
  | parse_nn "Ret" = @{term Ret}
  | parse_nn n = mk_NextNode (parse_int n)

fun parse_fun_decl ("Function" :: nm :: ss) = let
    val (xs, ss) = parse_vars ss
    val (ys, ss) = parse_vars ss
  in
    ss = [] orelse raise PARSEGRAPH ("parse_fun_decl: trailing" :: ss);
    (nm, xs, ys)
  end
  | parse_fun_decl ss = raise PARSEGRAPH ("parse_fun_decl: malformed" :: ss)

fun parse_var_and_val_acc ss = let
    val (var, ss) = parse_var ss
    val (v, ss) = parse_val_acc ss
  in (HOLogic.mk_prod (HOLogic.mk_string var, v), ss) end

val mk_stringlist = map HOLogic.mk_string #> HOLogic.mk_list @{typ string}

fun parse_node (n :: ss) = let
    val n = parse_int n
    val (t, ss) = case ss of
      "Cond" :: l :: r :: ss => let
        val l = parse_nn l
        val r = parse_nn r
        val (c, ss) = parse_cond ss
      in (@{term Cond} $ l $ r $ c, ss) end
      | "Basic" :: c :: ss => let
        val c = parse_nn c
        val (upds, ss) = parse_n parse_var_and_val_acc ss
      in (@{term Basic} $ c $ HOLogic.mk_list
            @{typ "string \<times> (state \<Rightarrow> variable)"} upds, ss) end
      | "Call" :: c :: fname :: ss => let
        val c = parse_nn c
        val (args, ss) = parse_vals ss
        val (rets, ss) = parse_vars ss
      in (@{term Call} $ c $ HOLogic.mk_string fname
            $ HOLogic.mk_list @{typ "state \<Rightarrow> variable"} args
            $ mk_stringlist rets, ss) end
      | _ => raise PARSEGRAPH ("parse_node: malformed" :: ss)
  in
    ss = [] orelse raise PARSEGRAPH ("parse_node: trailing" :: ss);
    (n, t)
  end
  | parse_node [] = raise PARSEGRAPH (["parse_node: empty"])

fun parse_fun (["Function" :: ss]) = let
    val (nm, xs, ys) = parse_fun_decl ("Function" :: ss)
  in SOME (nm, (xs, ys, NONE)) end
  | parse_fun (("Function" :: ss) :: sss) = let
    val (nm, xs, ys) = parse_fun_decl ("Function" :: ss)
    val _ = tracing ("Parsing " ^ nm)
    val (node_sss, sss) = chop_prefix
        (fn ss => not (is_prefix (op =) ["EntryPoint"] ss)) sss
    val (ep, _) = case sss of (ep :: sss) => (ep, sss)
        | [] => raise PARSEGRAPH [
        "parse_fun: EntryPoint not found"]
    val ep = case ep of [_, n] => parse_int n
        | _ => raise PARSEGRAPH (
        "parse_fun: EntryPoint line malformed" :: ep)
  in
    SOME (nm, (xs, ys, SOME (ep, map parse_node node_sss,
        Abs ("g", @{typ "nat \<Rightarrow> node option"}, @{term GraphFunction}
            $ mk_stringlist xs $ mk_stringlist ys
            $ Bound 0 $ HOLogic.mk_number @{typ nat} ep))))
  end
  | parse_fun [] = raise PARSEGRAPH ["parse_fun: empty"]
  | parse_fun (ss :: _) = (warning ("parse_fun: ignoring: "
    ^ space_implode " " ss); NONE)

fun fun_groups gp ((fs as ("Function" :: _)) :: sss) =
    (if null gp then [] else [rev gp]) @ fun_groups [fs] sss
  | fun_groups gp ([] :: sss) = fun_groups gp sss
  | fun_groups gp (ss :: sss) = fun_groups (ss :: gp) sss
  | fun_groups gp [] = [rev gp]

fun filename_relative thy name =
    Path.append (Resources.master_directory thy) (Path.explode name)
    |> File.standard_path

fun mkdir_relative thy name =
    Path.append (Resources.master_directory thy) (Path.explode name)
    |> Isabelle_System.make_directory

fun openIn_relative thy = filename_relative thy #> TextIO.openIn

fun get_funs thy file = let
    val f = openIn_relative thy file
    fun get () = case TextIO.inputLine f
      of NONE => []
      | SOME s => unsuffix "\n" s :: get ()
    val lines = get ()
      |> map (Library.space_explode " " #> filter (fn s => s <> ""))
      |> filter_out null
      |> filter_out (fn (s :: _) => String.isPrefix "#" s | _ => false)
  in fun_groups [] lines end

type funs = (string list * string list * (int * (int * term) list * term) option) Symtab.table

fun funs thy file : funs = get_funs thy file
  |> map_filter parse_fun
  |> Symtab.make

fun define_graph s nodes = let
    val nodes = sort (int_ord o apply2 fst) nodes
  in StaticFun.define_tree_and_save_thms (Binding.name s)
    (map (fst #> Int.toString #> prefix (s ^ "_")) nodes)
    (map (apfst (HOLogic.mk_number @{typ nat})) nodes)
    @{term "id :: nat => nat"} []
  end

fun define_graph_fun (funs : funs) b1 b2 nm ctxt =
        case (Symtab.lookup funs nm) of
    SOME (_, _, SOME (_, g, gf))
    => let
    val (graph_term, ctxt) = define_graph b1 g ctxt
    val (_, ctxt) = Local_Theory.define ((b2, NoSyn), ((Thm.def_binding b2, []),
        betapply (gf, graph_term))) ctxt
  in ctxt end
  | _ => error ("define_graph_fun: " ^ nm ^ " not in funs")

end

\<close>

end