(*
  File: DynamicArray.thy
  Author: Bohua Zhan
*)

section \<open>Implementation of dynamic arrays\<close>

theory DynamicArray
  imports Arrays_Impl
begin

text \<open>Dynamically allocated arrays.\<close>

datatype 'a dynamic_array = Dyn_Array (alen: nat) (aref: "'a array")
setup \<open>add_simple_datatype "dynamic_array"\<close>

subsection \<open>Raw assertion\<close>

fun dyn_array_raw :: "'a::heap list \<times> nat \<Rightarrow> 'a dynamic_array \<Rightarrow> assn" where
  "dyn_array_raw (xs, n) (Dyn_Array m a) = (a \<mapsto>\<^sub>a xs * \<up>(m = n))"
setup \<open>add_rewrite_ent_rule @{thm dyn_array_raw.simps}\<close>

definition dyn_array_new :: "'a::heap dynamic_array Heap" where
  "dyn_array_new = do {
     p \<leftarrow> Array.new 5 undefined;
     return (Dyn_Array 0 p)
   }"

lemma dyn_array_new_rule' [hoare_triple]:
  "<emp>
   dyn_array_new
   <dyn_array_raw (replicate 5 undefined, 0)>" by auto2

fun double_length :: "'a::heap dynamic_array \<Rightarrow> 'a dynamic_array Heap" where
  "double_length (Dyn_Array al ar) = do {
      am \<leftarrow> Array.len ar;
      p \<leftarrow> Array.new (2 * am + 1) undefined;
      array_copy ar p am;
      return (Dyn_Array am p)
    }"

fun double_length_fun :: "'a::heap list \<times> nat \<Rightarrow> 'a list \<times> nat" where
  "double_length_fun (xs, n) =
    (Arrays_Ex.array_copy xs (replicate (2 * n + 1) undefined) n, n)"
setup \<open>add_rewrite_rule @{thm double_length_fun.simps}\<close>

lemma double_length_rule' [hoare_triple]:
  "length xs = n \<Longrightarrow>
   <dyn_array_raw (xs, n) p>
   double_length p
   <dyn_array_raw (double_length_fun (xs, n))>\<^sub>t" by auto2

fun push_array_basic :: "'a \<Rightarrow> 'a::heap dynamic_array \<Rightarrow> 'a dynamic_array Heap" where
  "push_array_basic x (Dyn_Array al ar) = do {
    Array.upd al x ar;
    return (Dyn_Array (al + 1) ar)
   }"

fun push_array_basic_fun :: "'a \<Rightarrow> 'a::heap list \<times> nat \<Rightarrow> 'a list \<times> nat" where
  "push_array_basic_fun x (xs, n) = (list_update xs n x, n + 1)"
setup \<open>add_rewrite_rule @{thm push_array_basic_fun.simps}\<close>

lemma push_array_basic_rule' [hoare_triple]:
  "n < length xs \<Longrightarrow>
   <dyn_array_raw (xs, n) p>
   push_array_basic x p
   <dyn_array_raw (push_array_basic_fun x (xs, n))>" by auto2

definition array_length :: "'a dynamic_array \<Rightarrow> nat Heap" where
  "array_length d = return (alen d)"

lemma array_length_rule' [hoare_triple]:
  "<dyn_array_raw (xs, n) p>
   array_length p
   <\<lambda>r. dyn_array_raw (xs, n) p * \<up>(r = n)>" by auto2

definition array_max :: "'a::heap dynamic_array \<Rightarrow> nat Heap" where
  "array_max d = Array.len (aref d)"

lemma array_max_rule' [hoare_triple]:
  "<dyn_array_raw (xs, n) p>
   array_max p
   <\<lambda>r. dyn_array_raw (xs, n) p * \<up>(r = length xs)>" by auto2

definition array_nth :: "'a::heap dynamic_array \<Rightarrow> nat \<Rightarrow> 'a Heap" where
  "array_nth d i = Array.nth (aref d) i"

lemma array_nth_rule' [hoare_triple]:
  "i < n \<Longrightarrow> n \<le> length xs \<Longrightarrow>
   <dyn_array_raw (xs, n) p>
   array_nth p i
   <\<lambda>r. dyn_array_raw (xs, n) p * \<up>(r = xs ! i)>" by auto2

definition array_upd :: "nat \<Rightarrow> 'a \<Rightarrow> 'a::heap dynamic_array \<Rightarrow> unit Heap" where
  "array_upd i x d = do { Array.upd i x (aref d); return () }"

lemma array_upd_rule' [hoare_triple]:
  "i < n \<Longrightarrow> n \<le> length xs \<Longrightarrow>
   <dyn_array_raw (xs, n) p>
   array_upd i x p
   <\<lambda>_. dyn_array_raw (list_update xs i x, n) p>" by auto2

definition push_array :: "'a \<Rightarrow> 'a::heap dynamic_array \<Rightarrow> 'a dynamic_array Heap" where
  "push_array x p = do {
    m \<leftarrow> array_max p;
    l \<leftarrow> array_length p;
    if l < m then push_array_basic x p
    else do {
      u \<leftarrow> double_length p;
      push_array_basic x u
    }
  }"

definition pop_array :: "'a::heap dynamic_array \<Rightarrow> ('a \<times> 'a dynamic_array) Heap" where
  "pop_array d = do {
    x \<leftarrow> Array.nth (aref d) (alen d - 1);
    return (x, Dyn_Array (alen d - 1) (aref d))
   }"

lemma pop_array_rule' [hoare_triple]:
  "n > 0 \<Longrightarrow> n \<le> length xs \<Longrightarrow>
   <dyn_array_raw (xs, n) p>
   pop_array p
   <\<lambda>(x, r). dyn_array_raw (xs, n - 1) r * \<up>(x = xs ! (n - 1))>" by auto2

setup \<open>del_prfstep_thm @{thm dyn_array_raw.simps}\<close>
setup \<open>del_simple_datatype "dynamic_array"\<close>

fun push_array_fun :: "'a \<Rightarrow> 'a::heap list \<times> nat \<Rightarrow> 'a list \<times> nat" where
  "push_array_fun x (xs, n) = (
     if n < length xs then push_array_basic_fun x (xs, n)
     else push_array_basic_fun x (double_length_fun (xs, n)))"
setup \<open>add_rewrite_rule @{thm push_array_fun.simps}\<close>

lemma push_array_rule' [hoare_triple]:
  "n \<le> length xs \<Longrightarrow>
   <dyn_array_raw (xs, n) p>
   push_array x p
   <dyn_array_raw (push_array_fun x (xs, n))>\<^sub>t" by auto2

subsection \<open>Abstract assertion\<close>

fun abs_array :: "'a::heap list \<times> nat \<Rightarrow> 'a list" where
  "abs_array (xs, n) = take n xs"
setup \<open>add_rewrite_rule @{thm abs_array.simps}\<close>

lemma double_length_abs [rewrite]:
  "length xs = n \<Longrightarrow> abs_array (double_length_fun (xs, n)) = abs_array (xs, n)" by auto2

lemma push_array_basic_abs [rewrite]:
  "n < length xs \<Longrightarrow> abs_array (push_array_basic_fun x (xs, n)) = abs_array (xs, n) @ [x]"
@proof @have "length (take n xs @ [x]) = n + 1" @qed

lemma push_array_fun_abs [rewrite]:
  "n \<le> length xs \<Longrightarrow> abs_array (push_array_fun x (xs, n)) = abs_array (xs, n) @ [x]" by auto2

definition dyn_array :: "'a::heap list \<Rightarrow> 'a dynamic_array \<Rightarrow> assn" where [rewrite_ent]:
  "dyn_array xs a = (\<exists>\<^sub>Ap. dyn_array_raw p a * \<up>(xs = abs_array p) * \<up>(snd p \<le> length (fst p)))"

lemma dyn_array_new_rule [hoare_triple]:
  "<emp> dyn_array_new <dyn_array []>" by auto2

lemma array_length_rule [hoare_triple]:
  "<dyn_array xs p>
   array_length p
   <\<lambda>r. dyn_array xs p * \<up>(r = length xs)>" by auto2

lemma array_nth_rule [hoare_triple]:
  "i < length xs \<Longrightarrow>
   <dyn_array xs p>
    array_nth p i
   <\<lambda>r. dyn_array xs p * \<up>(r = xs ! i)>" by auto2

lemma array_upd_rule [hoare_triple]:
  "i < length xs \<Longrightarrow>
   <dyn_array xs p>
    array_upd i x p
   <\<lambda>_. dyn_array (list_update xs i x) p>" by auto2

lemma push_array_rule [hoare_triple]:
  "<dyn_array xs p>
    push_array x p
   <dyn_array (xs @ [x])>\<^sub>t" by auto2

lemma pop_array_rule [hoare_triple]:
  "xs \<noteq> [] \<Longrightarrow>
   <dyn_array xs p>
   pop_array p
   <\<lambda>(x, r). dyn_array (butlast xs) r * \<up>(x = last xs)>"
@proof @have "last xs = xs ! (length xs - 1)" @qed

setup \<open>del_prfstep_thm @{thm dyn_array_def}\<close>

subsection \<open>Derived operations\<close>

definition array_swap :: "'a::heap dynamic_array \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> unit Heap" where
  "array_swap d i j = do {
    x \<leftarrow> array_nth d i;
    y \<leftarrow> array_nth d j;
    array_upd i y d;
    array_upd j x d;
    return ()
   }"

lemma array_swap_rule [hoare_triple]:
  "i < length xs \<Longrightarrow> j < length xs \<Longrightarrow>
   <dyn_array xs p>
   array_swap p i j
   <\<lambda>_. dyn_array (list_swap xs i j) p>" by auto2

end


theory ValueOntologyTest (*** Benzmüller, Fuenmayor & Lomfeld, 2020 ***)
  imports ValueOntology
begin (* value ontology tests *)
(*values in two opposed quadrants: inconsistent*)
lemma "\<lfloor>[RESP\<^sup>x] \<^bold>\<and> [STAB\<^sup>x] \<^bold>\<rightarrow> INCONS\<^sup>x\<rfloor>" by simp
lemma "\<lfloor>[RELI\<^sup>x] \<^bold>\<and> [WILL\<^sup>x] \<^bold>\<rightarrow> INCONS\<^sup>x\<rfloor>" by simp
(*all values in two non-opposed quadrants: consistent*)
lemma "\<lfloor>[WILL\<^sup>x] \<^bold>\<and> [STAB\<^sup>x] \<^bold>\<rightarrow> INCONS\<^sup>x\<rfloor>" nitpick oops  (*countermodel*)
(*values in opposed quadrants for different parties: consistent*)
lemma "\<lfloor>[EQUI\<^sup>x] \<^bold>\<and> [GAIN\<^sup>y] \<^bold>\<rightarrow> (INCONS\<^sup>x \<^bold>\<or> INCONS\<^sup>y)\<rfloor>" nitpick oops (*ctm*)
lemma "\<lfloor>[RESP\<^sup>x] \<^bold>\<and> [STAB\<^sup>y] \<^bold>\<rightarrow> (INCONS\<^sup>x \<^bold>\<or> INCONS\<^sup>y)\<rfloor>" nitpick oops (*ctm*)
lemma "\<lfloor>[RELI\<^sup>p] \<^bold>\<and> [WILL\<^sup>p]\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
(*value preferences tests*)
lemma "\<lfloor>WILL\<^sup>x \<^bold>\<prec>\<^sub>v STAB\<^sup>x\<rfloor> \<longrightarrow> \<lfloor>WILL\<^sup>x \<^bold>\<prec>\<^sub>v RELI\<^sup>x\<^bold>\<oplus>STAB\<^sup>x\<rfloor>" by blast
lemma "\<lfloor>RELI\<^sup>x\<^bold>\<oplus>STAB\<^sup>x \<^bold>\<prec>\<^sub>v WILL\<^sup>x\<rfloor> \<longrightarrow> \<lfloor>STAB\<^sup>x \<^bold>\<prec>\<^sub>v WILL\<^sup>x\<rfloor>" by auto
lemma "\<lfloor>WILL\<^sup>x \<^bold>\<prec>\<^sub>v RELI\<^sup>x\<^bold>\<oplus>STAB\<^sup>x\<rfloor> \<longrightarrow> \<lfloor>WILL\<^sup>x \<^bold>\<prec>\<^sub>v STAB\<^sup>x\<rfloor>"
  nitpick nitpick[satisfy] oops (*contingent*)
lemma "\<lfloor>STAB\<^sup>x \<^bold>\<prec>\<^sub>v WILL\<^sup>x\<rfloor> \<longrightarrow> \<lfloor>RELI\<^sup>x\<^bold>\<oplus>STAB\<^sup>x \<^bold>\<prec>\<^sub>v WILL\<^sup>x\<rfloor>"
  nitpick nitpick[satisfy] oops (*contingent*)
end


(*
 * Copyright 2017, Data61, CSIRO
 *
 * 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(DATA61_BSD)
 *)

theory WordPolish
imports WordAbstract
begin

(* Depending on the platform, these names don't necessarily correspond to
   the C types of the same names. But by this point, we're sufficiently
   abstract that it doesn't really matter. *)

definition [simplified]: "LONG_MAX \<equiv> (2 :: int) ^ 63 - 1"
definition [simplified]: "LONG_MIN \<equiv> - ((2 :: int) ^ 63)"
definition [simplified]: "ULONG_MAX \<equiv> (2 :: nat) ^ 64 - 1"

definition [simplified]: "INT_MAX \<equiv> (2 :: int) ^ 31 - 1"
definition [simplified]: "INT_MIN \<equiv> - ((2 :: int) ^ 31)"
definition [simplified]: "UINT_MAX \<equiv> (2 :: nat) ^ 32 - 1"

definition [simplified]: "SHORT_MAX \<equiv> (2 :: int) ^ 15 - 1"
definition [simplified]: "SHORT_MIN \<equiv> - ((2 :: int) ^ 15)"
definition [simplified]: "USHORT_MAX \<equiv> (2 :: nat) ^ 16 - 1"

definition [simplified]: "CHAR_MAX \<equiv> (2 :: int) ^ 7 - 1"
definition [simplified]: "CHAR_MIN \<equiv> - ((2 :: int) ^ 7)"
definition [simplified]: "UCHAR_MAX \<equiv> (2 :: nat) ^ 8 - 1"

(* These are added to the Polish simps after translation *)
lemma WORD_MAX_simps:
   "WORD_MAX TYPE(64) = LONG_MAX"
   "WORD_MAX TYPE(32) = INT_MAX"
   "WORD_MAX TYPE(16) = SHORT_MAX"
   "WORD_MAX TYPE(8) = CHAR_MAX"
  by (auto simp: LONG_MAX_def INT_MAX_def SHORT_MAX_def CHAR_MAX_def WORD_MAX_def)

lemma WORD_MIN_simps:
   "WORD_MIN TYPE(64) = LONG_MIN"
   "WORD_MIN TYPE(32) = INT_MIN"
   "WORD_MIN TYPE(16) = SHORT_MIN"
   "WORD_MIN TYPE(8) = CHAR_MIN"
  by (auto simp: LONG_MIN_def INT_MIN_def SHORT_MIN_def CHAR_MIN_def WORD_MIN_def)

lemma UWORD_MAX_simps:
   "UWORD_MAX TYPE(64) = ULONG_MAX"
   "UWORD_MAX TYPE(32) = UINT_MAX"
   "UWORD_MAX TYPE(16) = USHORT_MAX"
   "UWORD_MAX TYPE(8) = UCHAR_MAX"
  by (auto simp: ULONG_MAX_def UINT_MAX_def USHORT_MAX_def UCHAR_MAX_def UWORD_MAX_def)

lemma MIN_MAX_lemmas_schema:
  "sint (s::'a::len signed word) \<le> WORD_MAX TYPE('a)"
  "WORD_MIN TYPE('a) \<le> sint (s::'a::len signed word)"
  "unat (u::'a::len word) \<le> UWORD_MAX TYPE('a)"
  "\<not> (sint (s::'a::len signed word) > WORD_MAX TYPE('a))"
  "\<not> (WORD_MIN TYPE('a) > sint (s::'a::len signed word))"
  "\<not> (unat (u::'a::len word) > UWORD_MAX TYPE('a))"
  "WORD_MIN TYPE('a) \<le> WORD_MAX TYPE('a)"
  "0 \<le> WORD_MAX TYPE('a)"
  "WORD_MIN TYPE('a) \<le> 0"
  unfolding WORD_MAX_def WORD_MIN_def UWORD_MAX_def
  using unat_lt2p[where x=u] less_eq_Suc_le
        sint_range_size [where w=s, simplified word_size, simplified]
  by auto

lemmas MIN_MAX_lemmas_pre =
  MIN_MAX_lemmas_schema[where 'a=64]
  MIN_MAX_lemmas_schema[where 'a=32]
  MIN_MAX_lemmas_schema[where 'a=16]
  MIN_MAX_lemmas_schema[where 'a=8]

lemmas INT_MIN_MAX_lemmas [simp] =
  MIN_MAX_lemmas_pre[unfolded WORD_MAX_simps WORD_MIN_simps UWORD_MAX_simps]

end


theory Conti     (*** Benzmüller, Fuenmayor & Lomfeld, 2020 ***)
  imports GeneralKnowledge
begin (*** ASPCA v. Conti "wild animal" case **)

(*case-specific 'world-vocabulary'*)
consts \<alpha>::"e" (*appropriated animal (parrot in this case) *)
consts Care::"c\<Rightarrow>e\<Rightarrow>\<sigma>"
consts Prop::"c\<Rightarrow>e\<Rightarrow>\<sigma>"
consts Capture::"c\<Rightarrow>e\<Rightarrow>\<sigma>"

(*case-specific taxonomic (legal domain) knowledge*)
axiomatization where
 CW1: "\<lfloor>Animal \<alpha> \<^bold>\<and> Pet \<alpha> \<^bold>\<rightarrow> Domestic \<alpha>\<rfloor>" and
 CW2: "\<lfloor>(\<^bold>\<exists>c. Capture c \<alpha> \<^bold>\<and> Domestic \<alpha>) \<^bold>\<rightarrow> appDomAnimal\<rfloor>" and
 CW3: "\<lfloor>\<^bold>\<forall>c. Care c \<alpha> \<^bold>\<rightarrow> Mtn c\<rfloor>" and
 CW4: "\<lfloor>\<^bold>\<forall>c. Prop c \<alpha> \<^bold>\<rightarrow> Own c\<rfloor>" and
 CW5: "\<lfloor>\<^bold>\<forall>c. Capture c \<alpha> \<^bold>\<rightarrow> Poss c\<rfloor>"

lemma True nitpick[satisfy,card i=4] oops (*satisfiable*)

(****************** pro-ASPCA's argument ****************)
abbreviation "ASPCA_facts \<equiv> \<lfloor>Parrot \<alpha> \<^bold>\<and> Pet \<alpha> \<^bold>\<and> Care p \<alpha> \<^bold>\<and>
                     Prop p \<alpha> \<^bold>\<and> (\<^bold>\<not>Prop d \<alpha>) \<^bold>\<and> Capture d \<alpha>\<rfloor>"

(* decision for defendant (Conti) is compatible with premises*)
lemma "ASPCA_facts \<and> \<lfloor>\<^bold>\<not>INCONS\<^sup>p\<rfloor> \<and> \<lfloor>\<^bold>\<not>INCONS\<^sup>d\<rfloor> \<and> \<lfloor>For p \<^bold>\<prec> For d\<rfloor>"
  nitpick[satisfy,card i=4] oops (* (non-trivial) model found*)

(* decision for plaintiff (ASPCA) is compatible with premises*)
lemma "ASPCA_facts \<and> \<lfloor>\<^bold>\<not>INCONS\<^sup>p\<rfloor> \<and> \<lfloor>\<^bold>\<not>INCONS\<^sup>d\<rfloor> \<and> \<lfloor>For d \<^bold>\<prec> For p\<rfloor>"
  nitpick[satisfy,card i=4] oops (* (non-trivial) model found*)

(* decision for plaintiff (ASPCA) is provable*)
lemma aux: assumes ASPCA_facts shows "\<lfloor>(STAB\<^sup>d \<^bold>\<prec>\<^sub>v RELI\<^sup>p\<^bold>\<oplus>RESP\<^sup>p)\<rfloor>"
  using CW1 CW2 W7 assms R3 by fastforce
theorem assumes ASPCA_facts shows "\<lfloor>For d \<^bold>\<prec> For p\<rfloor>"
  using assms aux CW5 ForAx F3 other.simps(1) rBR by metis

(* while a decision for the defendant is refutable*)
lemma assumes ASPCA_facts shows "\<lfloor>For p \<^bold>\<prec> For d\<rfloor>"
  nitpick[card i=4] oops (*(non-trivial) counterexample found*)
end


(*
Title: Value-Dependent SIFUM-Type-Systems
Authors: Toby Murray, Robert Sison, Edward Pierzchalski, Christine Rizkallah
(Based on the SIFUM-Type-Systems AFP entry, whose authors
 are: Sylvia Grewe, Heiko Mantel, Daniel Schoepe)
*)

section \<open>Definition of the SIFUM-Security Property\<close>

theory Security
imports Preliminaries
begin

type_synonym ('var, 'val) adaptation = "'var \<rightharpoonup> ('val \<times> 'val)"

definition apply_adaptation ::
  "bool \<Rightarrow> ('Var, 'Val) Mem \<Rightarrow> ('Var, 'Val) adaptation \<Rightarrow> ('Var, 'Val) Mem"
  where "apply_adaptation first mem A =
         (\<lambda> x. case (A x) of
               Some (v\<^sub>1, v\<^sub>2) \<Rightarrow> if first then v\<^sub>1 else v\<^sub>2
             | None \<Rightarrow> mem x)"

abbreviation apply_adaptation\<^sub>1 ::
  "('Var, 'Val) Mem \<Rightarrow> ('Var, 'Val) adaptation \<Rightarrow> ('Var, 'Val) Mem"
  ("_ [\<parallel>\<^sub>1 _]" [900, 0] 1000)
  where "mem [\<parallel>\<^sub>1 A] \<equiv> apply_adaptation True mem A"

abbreviation apply_adaptation\<^sub>2 ::
  "('Var, 'Val) Mem \<Rightarrow> ('Var, 'Val) adaptation \<Rightarrow> ('Var, 'Val) Mem"
  ("_ [\<parallel>\<^sub>2 _]" [900, 0] 1000)
  where "mem [\<parallel>\<^sub>2 A] \<equiv> apply_adaptation False mem A"

definition
  var_asm_not_written :: "'Var Mds \<Rightarrow> 'Var \<Rightarrow> bool"
where
  "var_asm_not_written mds x \<equiv> x \<in> mds AsmNoWrite \<or> x \<in> mds AsmNoReadOrWrite"

context sifum_security_init begin

subsection \<open>Evaluation of Concurrent Programs\<close>

abbreviation eval_abv :: "('Com, 'Var, 'Val) LocalConf \<Rightarrow> (_, _, _) LocalConf \<Rightarrow> bool"
  (infixl "\<leadsto>" 70)
where
  "x \<leadsto> y \<equiv> (x, y) \<in> eval"

abbreviation conf_abv :: "'Com \<Rightarrow> 'Var Mds \<Rightarrow> ('Var, 'Val) Mem \<Rightarrow> (_,_,_) LocalConf"
  ("\<langle>_, _, _\<rangle>" [0, 0, 0] 1000)
where
  "\<langle> c, mds, mem \<rangle> \<equiv> ((c, mds), mem)"

(* Labelled evaluation global configurations: *)
inductive_set meval :: "((_,_,_) GlobalConf \<times> nat \<times> (_,_,_) GlobalConf) set"
  and meval_abv :: "_ \<Rightarrow> _ \<Rightarrow> _ \<Rightarrow> bool" ("_ \<leadsto>\<^bsub>_\<^esub> _" 70)
where
  "conf \<leadsto>\<^bsub>k\<^esub> conf' \<equiv> (conf, k, conf') \<in> meval" |
  meval_intro [iff]: "\<lbrakk> (cms ! n, mem) \<leadsto> (cm', mem'); n < length cms \<rbrakk> \<Longrightarrow>
  ((cms, mem), n, (cms [n := cm'], mem')) \<in> meval"

inductive_cases meval_elim [elim!]: "((cms, mem), k, (cms', mem')) \<in> meval"

inductive neval :: "('Com, 'Var, 'Val) LocalConf \<Rightarrow> nat \<Rightarrow> (_, _, _) LocalConf \<Rightarrow> bool"
  (infixl "\<leadsto>\<^bsup>_\<^esup>" 70)
where
  neval_0: "x = y \<Longrightarrow> x \<leadsto>\<^bsup>0\<^esup> y" |
  neval_S_n: "x \<leadsto> y \<Longrightarrow> y \<leadsto>\<^bsup>n\<^esup> z \<Longrightarrow> x \<leadsto>\<^bsup>Suc n\<^esup> z"

inductive_cases neval_ZeroE: "neval x 0 y"
inductive_cases neval_SucE: "neval x (Suc n) y"

lemma neval_det:
  "x \<leadsto>\<^bsup>n\<^esup> y \<Longrightarrow> x \<leadsto>\<^bsup>n\<^esup> y' \<Longrightarrow> y = y'"
  apply(induct arbitrary: y' rule: neval.induct)
   apply(blast elim: neval_ZeroE)
  apply(blast elim: neval_SucE dest: deterministic)
  done

lemma neval_Suc_simp [simp]:
  "neval x (Suc 0) y = x \<leadsto> y"
proof
  assume a: "neval x (Suc 0) y"
  have "\<And>n. neval x n y \<Longrightarrow> n = Suc 0 \<Longrightarrow> x \<leadsto> y"
  proof -
    fix n
    assume "neval x n y"
       and "n = Suc 0"
    thus "x \<leadsto> y"
    by(induct rule: neval.induct, auto elim: neval_ZeroE)
  qed
  with a show "x \<leadsto> y" by simp
  next
  assume "x \<leadsto> y"
  thus "neval x (Suc 0) y"
    by(force intro: neval.intros)
qed

fun
  lc_set_var :: "(_, _, _) LocalConf \<Rightarrow> 'Var \<Rightarrow> 'Val \<Rightarrow> (_, _, _) LocalConf"
where
  "lc_set_var (c, mem) x v = (c, mem (x := v))"

fun
  meval_sched :: "nat list \<Rightarrow> ('Com, 'Var, 'Val) GlobalConf \<Rightarrow> (_, _, _) GlobalConf \<Rightarrow> bool"
where
  "meval_sched [] c c' = (c = c')" |
  "meval_sched (n#ns) c c' = (\<exists> c''.  c \<leadsto>\<^bsub>n\<^esub> c'' \<and> meval_sched ns c'' c')"

abbreviation
  meval_sched_abv :: "(_,_,_) GlobalConf \<Rightarrow> nat list \<Rightarrow> (_,_,_) GlobalConf \<Rightarrow> bool" ("_ \<rightarrow>\<^bsub>_\<^esub> _" 70)
where
  "c \<rightarrow>\<^bsub>ns\<^esub> c' \<equiv> meval_sched ns c c'"

lemma meval_sched_det:
  "meval_sched ns c c' \<Longrightarrow> meval_sched ns c c'' \<Longrightarrow> c' = c''"
  apply(induct ns arbitrary: c)
   apply(auto dest: deterministic)
  done

subsection \<open>Low-equivalence and Strong Low Bisimulations\<close>

(* Low-equality between memory states: *)
definition
  low_eq :: "('Var, 'Val) Mem \<Rightarrow> (_, _) Mem \<Rightarrow> bool" (infixl "=\<^sup>l" 80)
where
  "mem\<^sub>1 =\<^sup>l mem\<^sub>2 \<equiv> (\<forall> x. dma mem\<^sub>1 x = Low \<longrightarrow> mem\<^sub>1 x = mem\<^sub>2 x)"

(* Low-equality modulo a given mode state: *)
definition
  low_mds_eq :: "'Var Mds \<Rightarrow> ('Var, 'Val) Mem \<Rightarrow> (_, _) Mem \<Rightarrow> bool"
  ("_ =\<index>\<^sup>l _" [100, 100] 80)
where
  "(mem\<^sub>1 =\<^bsub>mds\<^esub>\<^sup>l mem\<^sub>2) \<equiv> (\<forall> x. dma mem\<^sub>1 x = Low \<and> (x \<in> \<C> \<or> x \<notin> mds AsmNoReadOrWrite) \<longrightarrow> mem\<^sub>1 x = mem\<^sub>2 x)"

lemma low_eq_low_mds_eq:
  "(mem\<^sub>1 =\<^sup>l mem\<^sub>2) = (mem\<^sub>1 =\<^bsub>(\<lambda>m. {})\<^esub>\<^sup>l mem\<^sub>2)"
  by(simp add: low_eq_def low_mds_eq_def)

lemma low_mds_eq_dma:
  "(mem\<^sub>1 =\<^bsub>mds\<^esub>\<^sup>l mem\<^sub>2) \<Longrightarrow> dma mem\<^sub>1 = dma mem\<^sub>2"
  apply(rule dma_\<C>)
  apply(simp add: low_mds_eq_def \<C>_Low)
  done

lemma low_mds_eq_sym:
  "(mem\<^sub>1 =\<^bsub>mds\<^esub>\<^sup>l mem\<^sub>2) \<Longrightarrow> (mem\<^sub>2 =\<^bsub>mds\<^esub>\<^sup>l mem\<^sub>1)"
  apply(frule low_mds_eq_dma)
  apply(simp add: low_mds_eq_def)
  done

lemma low_eq_sym:
  "(mem\<^sub>1 =\<^sup>l mem\<^sub>2) \<Longrightarrow> (mem\<^sub>2 =\<^sup>l mem\<^sub>1)"
  apply(simp add: low_eq_low_mds_eq low_mds_eq_sym)
  done

lemma [simp]: "(\<forall> mds. mem =\<^bsub>mds\<^esub>\<^sup>l mem') \<Longrightarrow> mem =\<^sup>l mem'"
  by (auto simp: low_mds_eq_def low_eq_def)

lemma High_not_in_\<C> [simp]:
  "dma mem\<^sub>1 x = High \<Longrightarrow> x \<notin> \<C>"
  apply(case_tac "x \<in> \<C>")
  by(simp add: \<C>_Low)

(* Closedness under globally consistent changes: *)
definition
  closed_glob_consistent :: "(('Com, 'Var, 'Val) LocalConf) rel \<Rightarrow> bool"
where
  "closed_glob_consistent \<R> =
  (\<forall> c\<^sub>1 mds mem\<^sub>1 c\<^sub>2 mem\<^sub>2. (\<langle> c\<^sub>1, mds, mem\<^sub>1 \<rangle>, \<langle> c\<^sub>2, mds, mem\<^sub>2 \<rangle>) \<in> \<R> \<longrightarrow>
   (\<forall> A. ((\<forall>x. case A x of Some (v,v') \<Rightarrow> (mem\<^sub>1 x \<noteq> v \<or> mem\<^sub>2 x \<noteq> v') \<longrightarrow> \<not> var_asm_not_written mds x | _ \<Rightarrow> True) \<and>
          (\<forall>x. dma (mem\<^sub>1 [\<parallel>\<^sub>1 A]) x \<noteq> dma mem\<^sub>1 x \<longrightarrow> \<not> var_asm_not_written mds x) \<and>
          (\<forall>x. dma (mem\<^sub>1 [\<parallel>\<^sub>1 A]) x = Low \<and> (x \<notin> mds AsmNoReadOrWrite \<or> x \<in> \<C>) \<longrightarrow> (mem\<^sub>1 [\<parallel>\<^sub>1 A]) x = (mem\<^sub>2 [\<parallel>\<^sub>2 A]) x)) \<longrightarrow>
         (\<langle> c\<^sub>1, mds, mem\<^sub>1[\<parallel>\<^sub>1 A] \<rangle>, \<langle> c\<^sub>2, mds, mem\<^sub>2[\<parallel>\<^sub>2 A] \<rangle>) \<in> \<R>))"

(* Strong low bisimulations modulo modes: *)
definition
  strong_low_bisim_mm :: "(('Com, 'Var, 'Val) LocalConf) rel \<Rightarrow> bool"
where
  "strong_low_bisim_mm \<R> \<equiv>
  sym \<R> \<and>
  closed_glob_consistent \<R> \<and>
  (\<forall> c\<^sub>1 mds mem\<^sub>1 c\<^sub>2 mem\<^sub>2. (\<langle> c\<^sub>1, mds, mem\<^sub>1 \<rangle>, \<langle> c\<^sub>2, mds, mem\<^sub>2 \<rangle>) \<in> \<R> \<longrightarrow>
   (mem\<^sub>1 =\<^bsub>mds\<^esub>\<^sup>l mem\<^sub>2) \<and>
   (\<forall> c\<^sub>1' mds' mem\<^sub>1'. \<langle> c\<^sub>1, mds, mem\<^sub>1 \<rangle> \<leadsto> \<langle> c\<^sub>1', mds', mem\<^sub>1' \<rangle> \<longrightarrow>
    (\<exists> c\<^sub>2' mem\<^sub>2'. \<langle> c\<^sub>2, mds, mem\<^sub>2 \<rangle> \<leadsto> \<langle> c\<^sub>2', mds', mem\<^sub>2' \<rangle> \<and>
                  (\<langle> c\<^sub>1', mds', mem\<^sub>1' \<rangle>, \<langle> c\<^sub>2', mds', mem\<^sub>2' \<rangle>) \<in> \<R>)))"

inductive_set mm_equiv :: "(('Com, 'Var, 'Val) LocalConf) rel"
  and mm_equiv_abv :: "('Com, 'Var, 'Val) LocalConf \<Rightarrow>
  ('Com, 'Var, 'Val) LocalConf \<Rightarrow> bool" (infix "\<approx>" 60)
where
  "mm_equiv_abv x y \<equiv> (x, y) \<in> mm_equiv" |
  mm_equiv_intro [iff]: "\<lbrakk> strong_low_bisim_mm \<R> ; (lc\<^sub>1, lc\<^sub>2) \<in> \<R> \<rbrakk> \<Longrightarrow> (lc\<^sub>1, lc\<^sub>2) \<in> mm_equiv"

inductive_cases mm_equiv_elim [elim]: "\<langle> c\<^sub>1, mds, mem\<^sub>1 \<rangle> \<approx> \<langle> c\<^sub>2, mds, mem\<^sub>2 \<rangle>"

definition low_indistinguishable :: "'Var Mds \<Rightarrow> 'Com \<Rightarrow> 'Com \<Rightarrow> bool"
  ("_ \<sim>\<index> _" [100, 100] 80)
where
  "c\<^sub>1 \<sim>\<^bsub>mds\<^esub> c\<^sub>2 = (\<forall> mem\<^sub>1 mem\<^sub>2. mem\<^sub>1 =\<^bsub>mds\<^esub>\<^sup>l mem\<^sub>2 \<longrightarrow> \<langle> c\<^sub>1, mds, mem\<^sub>1 \<rangle> \<approx> \<langle> c\<^sub>2, mds, mem\<^sub>2 \<rangle>)"

subsection \<open>SIFUM-Security\<close>

(* SIFUM-security for commands: *)
definition
  com_sifum_secure :: "'Com \<times> 'Var Mds \<Rightarrow> bool"
where
  "com_sifum_secure cmd \<equiv> case cmd of (c,mds\<^sub>s) \<Rightarrow> c \<sim>\<^bsub>mds\<^sub>s\<^esub> c"

(* Continuous SIFUM-security
   (where we don't care about whether the prog has any assumptions at termination *)
definition
  prog_sifum_secure_cont :: "('Com \<times> 'Var Mds) list \<Rightarrow> bool"
where "prog_sifum_secure_cont cmds =
   (\<forall> mem\<^sub>1 mem\<^sub>2. INIT mem\<^sub>1 \<and> INIT mem\<^sub>2 \<and> mem\<^sub>1 =\<^sup>l mem\<^sub>2 \<longrightarrow>
    (\<forall> sched cms\<^sub>1' mem\<^sub>1'.
     (cmds, mem\<^sub>1) \<rightarrow>\<^bsub>sched\<^esub> (cms\<^sub>1', mem\<^sub>1') \<longrightarrow>
      (\<exists> cms\<^sub>2' mem\<^sub>2'. (cmds, mem\<^sub>2) \<rightarrow>\<^bsub>sched\<^esub> (cms\<^sub>2', mem\<^sub>2') \<and>
                      map snd cms\<^sub>1' = map snd cms\<^sub>2' \<and>
                      length cms\<^sub>2' = length cms\<^sub>1' \<and>
                      (\<forall> x. dma mem\<^sub>1' x = Low \<and> (x \<in> \<C> \<or> (\<forall> i < length cms\<^sub>1'.
                        x \<notin> snd (cms\<^sub>1' ! i) AsmNoReadOrWrite)) \<longrightarrow> mem\<^sub>1' x = mem\<^sub>2' x))))"

(* Note that it is equivalent to the following because the
   programming language is deterministic *)
lemma prog_sifum_secure_cont_def2:
  "prog_sifum_secure_cont cmds \<equiv>
   (\<forall> mem\<^sub>1 mem\<^sub>2. INIT mem\<^sub>1 \<and> INIT mem\<^sub>2 \<and> mem\<^sub>1 =\<^sup>l mem\<^sub>2 \<longrightarrow>
    (\<forall> sched cms\<^sub>1' mem\<^sub>1'.
     (cmds, mem\<^sub>1) \<rightarrow>\<^bsub>sched\<^esub> (cms\<^sub>1', mem\<^sub>1') \<longrightarrow>
      (\<exists> cms\<^sub>2' mem\<^sub>2'. (cmds, mem\<^sub>2) \<rightarrow>\<^bsub>sched\<^esub> (cms\<^sub>2', mem\<^sub>2')) \<and>
      (\<forall> cms\<^sub>2' mem\<^sub>2'. (cmds, mem\<^sub>2) \<rightarrow>\<^bsub>sched\<^esub> (cms\<^sub>2', mem\<^sub>2') \<longrightarrow>
                      map snd cms\<^sub>1' = map snd cms\<^sub>2' \<and>
                      length cms\<^sub>2' = length cms\<^sub>1' \<and>
                      (\<forall> x. dma mem\<^sub>1' x = Low \<and> (x \<in> \<C> \<or> (\<forall> i < length cms\<^sub>1'.
                        x \<notin> snd (cms\<^sub>1' ! i) AsmNoReadOrWrite)) \<longrightarrow> mem\<^sub>1' x = mem\<^sub>2' x))))"
  apply(rule eq_reflection)
  unfolding prog_sifum_secure_cont_def
  apply(rule iffI)
   apply(blast dest: meval_sched_det)
  by fastforce

subsection \<open>Sound Mode Use\<close>

(* Suggestive notation for substitution / function application *)
definition
  subst :: "('a \<rightharpoonup> 'b) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b)"
where
  "subst f mem = (\<lambda> x. case f x of
                         None \<Rightarrow> mem x |
                         Some v \<Rightarrow> v)"

abbreviation
  subst_abv :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a \<rightharpoonup> 'b) \<Rightarrow> ('a \<Rightarrow> 'b)" ("_ [\<mapsto>_]" [900, 0] 1000)
where
  "f [\<mapsto> \<sigma>] \<equiv> subst \<sigma> f"

lemma subst_not_in_dom : "\<lbrakk> x \<notin> dom \<sigma> \<rbrakk> \<Longrightarrow> mem [\<mapsto> \<sigma>] x = mem x"
  by (simp add: domIff subst_def)

(* Toby: we restrict not reading to also imply not modifying a variable.
         This is done mostly to simplify part of the reasoning in the
         Compositionality theory, but also because reconciling doesnt_read_or_modify
         forcing also not reading the variable's classification in the case
         in the case where it would allow non-reading modifications proved
         to get too unwieldy *)
definition
  doesnt_read_or_modify_vars :: "'Com \<Rightarrow> 'Var set \<Rightarrow> bool"
where
  "doesnt_read_or_modify_vars c X = (\<forall> mds mem c' mds' mem'.
  \<langle> c, mds, mem \<rangle> \<leadsto> \<langle> c', mds', mem' \<rangle> \<longrightarrow>
  ((\<forall>x\<in>X. (\<forall> v. \<langle> c, mds, mem (x := v) \<rangle> \<leadsto> \<langle> c', mds', mem' (x := v) \<rangle>))))"

definition
  vars_\<C> :: "'Var set \<Rightarrow> 'Var set"
where
  "vars_\<C> X \<equiv> \<Union>x\<in>X. \<C>_vars x"

lemma vars_\<C>_subset_\<C>:
  "vars_\<C> X \<subseteq> \<C>"
  by(auto simp: \<C>_def vars_\<C>_def)

(* Toby: doesnt_read_or_modify now implies that the classification is not read too *)
definition
  doesnt_read_or_modify :: "'Com \<Rightarrow> 'Var \<Rightarrow> bool"
where
  "doesnt_read_or_modify c x \<equiv> doesnt_read_or_modify_vars c ({x} \<union> \<C>_vars x)"

definition
  doesnt_modify :: "'Com \<Rightarrow> 'Var \<Rightarrow> bool"
where
  "doesnt_modify c x = (\<forall> mds mem c' mds' mem'. (\<langle> c, mds, mem \<rangle> \<leadsto> \<langle> c', mds', mem' \<rangle>) \<longrightarrow>
                        mem x = mem' x \<and>  dma mem x = dma mem' x)"

lemma noread_nowrite:
  assumes step: "\<langle>c, mds, mem\<rangle> \<leadsto> \<langle>c', mds', mem'\<rangle>"
  assumes noread: "(\<And>v. \<langle>c, mds, mem(x := v)\<rangle> \<leadsto> \<langle>c', mds', mem'(x := v)\<rangle>)"
  shows "mem x = mem' x"
proof -
  from noread have "\<langle>c, mds, mem(x := (mem x))\<rangle> \<leadsto> \<langle>c', mds', mem'(x := (mem x))\<rangle>"
    by blast
  hence "\<langle>c, mds, mem\<rangle> \<leadsto> \<langle>c', mds', mem'(x := (mem x))\<rangle>" by simp
  from step this have "mem' = mem'(x := (mem x))" by (blast dest: deterministic)
  hence "mem' x = (mem'(x := (mem x))) x" by(rule arg_cong)
  thus ?thesis by simp
qed

(* Toby: not sure whether this implication should just be made explicit in the
         definition of doesnt_read_or_modify or not *)
lemma doesnt_read_or_modify_doesnt_modify:
  "doesnt_read_or_modify c x \<Longrightarrow> doesnt_modify c x"
  by(fastforce simp: doesnt_modify_def doesnt_read_or_modify_def doesnt_read_or_modify_vars_def
               intro: noread_nowrite dma_\<C>_vars)

(* Local reachability of local configurations: *)
inductive_set
  loc_reach :: "('Com, 'Var, 'Val) LocalConf \<Rightarrow> ('Com, 'Var, 'Val) LocalConf set"
  for lc :: "(_, _, _) LocalConf"
where
  refl : "\<langle>fst (fst lc), snd (fst lc), snd lc\<rangle> \<in> loc_reach lc" |
  step : "\<lbrakk> \<langle>c', mds', mem'\<rangle> \<in> loc_reach lc;
            \<langle>c', mds', mem'\<rangle> \<leadsto> \<langle>c'', mds'', mem''\<rangle> \<rbrakk> \<Longrightarrow>
          \<langle>c'', mds'', mem''\<rangle> \<in> loc_reach lc" |
  mem_diff : "\<lbrakk> \<langle> c', mds', mem' \<rangle> \<in> loc_reach lc;
                (\<forall> x. var_asm_not_written mds' x \<longrightarrow> mem' x = mem'' x \<and> dma mem' x = dma mem'' x) \<rbrakk> \<Longrightarrow>
              \<langle> c', mds', mem'' \<rangle> \<in> loc_reach lc"

lemma neval_loc_reach:
  "neval lc' n lc'' \<Longrightarrow> lc' \<in> loc_reach lc \<Longrightarrow> lc'' \<in> loc_reach lc"
proof(induct rule: neval.induct)
  case (neval_0 x y)
    thus ?case by simp
next
  case (neval_S_n x y n z)
  from \<open>x \<in> loc_reach lc\<close> and \<open>x \<leadsto> y\<close> have "y \<in> loc_reach lc"
    (* TODO: can we get rid of this case_tac nonsense? *)
    apply(case_tac x, rename_tac a b, case_tac a, clarsimp)
    apply(case_tac y, rename_tac c d, case_tac c, clarsimp)
    by(blast intro: loc_reach.step)
  thus ?case
    using neval_S_n(3) by blast
qed

definition
  locally_sound_mode_use :: "(_, _, _) LocalConf \<Rightarrow> bool"
where
  "locally_sound_mode_use lc =
  (\<forall> c' mds' mem'. \<langle> c', mds', mem' \<rangle> \<in> loc_reach lc \<longrightarrow>
    (\<forall> x. (x \<in> mds' GuarNoReadOrWrite \<longrightarrow> doesnt_read_or_modify c' x) \<and>
          (x \<in> mds' GuarNoWrite \<longrightarrow> doesnt_modify c' x)))"

(* RobS: The same property, but for an individual evaluation. Note it doesn't rely on mem! *)
definition
  respects_own_guarantees :: "('Com \<times> 'Var Mds) \<Rightarrow> bool"
where
  "respects_own_guarantees cm \<equiv>
  (\<forall> x. (x \<in> (snd cm) GuarNoReadOrWrite \<longrightarrow> doesnt_read_or_modify (fst cm) x) \<and>
        (x \<in> (snd cm) GuarNoWrite \<longrightarrow> doesnt_modify (fst cm) x))"

lemma locally_sound_mode_use_def2:
  "locally_sound_mode_use lc \<equiv> \<forall>lc' \<in> loc_reach lc. respects_own_guarantees (fst lc')"
  apply(rule eq_reflection)
  apply(simp add: locally_sound_mode_use_def respects_own_guarantees_def)
  apply force
  done

lemma locally_sound_respects_guarantees:
  "locally_sound_mode_use (cm, mem) \<Longrightarrow> respects_own_guarantees cm"
  unfolding locally_sound_mode_use_def respects_own_guarantees_def
  by (metis fst_conv loc_reach.refl)

definition
  compatible_modes :: "('Var Mds) list \<Rightarrow> bool"
where
  "compatible_modes mdss = (\<forall> (i :: nat) x. i < length mdss \<longrightarrow>
    (x \<in> (mdss ! i) AsmNoReadOrWrite \<longrightarrow>
     (\<forall> j < length mdss. j \<noteq> i \<longrightarrow> x \<in> (mdss ! j) GuarNoReadOrWrite)) \<and>
    (x \<in> (mdss ! i) AsmNoWrite \<longrightarrow>
     (\<forall> j < length mdss. j \<noteq> i \<longrightarrow> x \<in> (mdss ! j) GuarNoWrite)))"

definition
  reachable_mode_states :: "('Com, 'Var, 'Val) GlobalConf \<Rightarrow> (('Var Mds) list) set"
where
  "reachable_mode_states gc \<equiv>
     {mdss. (\<exists> cms' mem' sched. gc \<rightarrow>\<^bsub>sched\<^esub> (cms', mem') \<and> map snd cms' = mdss)}"

definition
  globally_sound_mode_use :: "('Com, 'Var, 'Val) GlobalConf \<Rightarrow> bool"
where
  "globally_sound_mode_use gc \<equiv>
     (\<forall> mdss. mdss \<in> reachable_mode_states gc \<longrightarrow> compatible_modes mdss)"

primrec
  sound_mode_use :: "(_, _, _) GlobalConf \<Rightarrow> bool"
where
  "sound_mode_use (cms, mem) =
     (list_all (\<lambda> cm. locally_sound_mode_use (cm, mem)) cms \<and>
      globally_sound_mode_use (cms, mem))"

(* We now show that mm_equiv itself forms a strong low bisimulation modulo modes: *)
lemma mm_equiv_sym:
  assumes equivalent: "\<langle>c\<^sub>1, mds\<^sub>1, mem\<^sub>1\<rangle> \<approx> \<langle>c\<^sub>2, mds\<^sub>2, mem\<^sub>2\<rangle>"
  shows "\<langle>c\<^sub>2, mds\<^sub>2, mem\<^sub>2\<rangle> \<approx> \<langle>c\<^sub>1, mds\<^sub>1, mem\<^sub>1\<rangle>"
proof -
  from equivalent obtain \<R>
    where \<R>_bisim: "strong_low_bisim_mm \<R> \<and> (\<langle>c\<^sub>1, mds\<^sub>1, mem\<^sub>1\<rangle>, \<langle>c\<^sub>2, mds\<^sub>2, mem\<^sub>2\<rangle>) \<in> \<R>"
    by (metis mm_equiv.simps)
  hence "sym \<R>"
    by (auto simp: strong_low_bisim_mm_def)
  hence "(\<langle>c\<^sub>2, mds\<^sub>2, mem\<^sub>2\<rangle>, \<langle>c\<^sub>1, mds\<^sub>1, mem\<^sub>1\<rangle>) \<in> \<R>"
    by (metis \<R>_bisim symE)
  thus ?thesis
    by (metis \<R>_bisim mm_equiv.intros)
qed

lemma low_indistinguishable_sym: "lc \<sim>\<^bsub>mds\<^esub> lc' \<Longrightarrow> lc' \<sim>\<^bsub>mds\<^esub> lc"
  apply(clarsimp simp: low_indistinguishable_def)
  apply(rule mm_equiv_sym)
  apply(blast dest: low_mds_eq_sym)
  done

lemma mm_equiv_glob_consistent: "closed_glob_consistent mm_equiv"
  unfolding closed_glob_consistent_def
  apply clarify
  apply (erule mm_equiv_elim)
  by (auto simp: strong_low_bisim_mm_def closed_glob_consistent_def)

lemma mm_equiv_strong_low_bisim: "strong_low_bisim_mm mm_equiv"
  unfolding strong_low_bisim_mm_def
proof (auto)
  show "closed_glob_consistent mm_equiv" by (rule mm_equiv_glob_consistent)
next
  fix c\<^sub>1 mds mem\<^sub>1 c\<^sub>2 mem\<^sub>2 x
  assume "\<langle> c\<^sub>1, mds, mem\<^sub>1 \<rangle> \<approx> \<langle> c\<^sub>2, mds, mem\<^sub>2 \<rangle>"
  then obtain \<R> where
    "strong_low_bisim_mm \<R> \<and> (\<langle> c\<^sub>1, mds, mem\<^sub>1 \<rangle>, \<langle> c\<^sub>2, mds, mem\<^sub>2 \<rangle>) \<in> \<R>"
    by blast
  thus "mem\<^sub>1 =\<^bsub>mds\<^esub>\<^sup>l mem\<^sub>2" by (auto simp: strong_low_bisim_mm_def)
next
  fix c\<^sub>1 :: 'Com
  fix mds mem\<^sub>1 c\<^sub>2 mem\<^sub>2 c\<^sub>1' mds' mem\<^sub>1'
  let ?lc\<^sub>1 = "\<langle> c\<^sub>1, mds, mem\<^sub>1 \<rangle>" and
      ?lc\<^sub>1' = "\<langle> c\<^sub>1', mds', mem\<^sub>1' \<rangle>" and
      ?lc\<^sub>2 = "\<langle> c\<^sub>2, mds, mem\<^sub>2 \<rangle>"
  assume "?lc\<^sub>1 \<approx> ?lc\<^sub>2"
  then obtain \<R> where "strong_low_bisim_mm \<R> \<and> (?lc\<^sub>1, ?lc\<^sub>2) \<in> \<R>"
    by (rule mm_equiv_elim, blast)
  moreover assume "?lc\<^sub>1 \<leadsto> ?lc\<^sub>1'"
  ultimately show "\<exists> c\<^sub>2' mem\<^sub>2'. ?lc\<^sub>2 \<leadsto> \<langle> c\<^sub>2', mds', mem\<^sub>2' \<rangle> \<and> ?lc\<^sub>1' \<approx> \<langle> c\<^sub>2', mds', mem\<^sub>2' \<rangle>"
    by (simp add: strong_low_bisim_mm_def mm_equiv_sym, blast)
next
  show "sym mm_equiv"
    by (auto simp: sym_def mm_equiv_sym)
qed

end

end


theory CorrectnessOriginal
imports Denotational Launchbury
begin

text \<open>
This is the main correctness theorem, Theorem 2 from \cite{launchbury}.
\<close>

(* Another possible invariant seems to be: "edom \<rho> - domA \<Gamma> \<subseteq> set L" *)

theorem correctness:
  assumes "\<Gamma> : e \<Down>\<^bsub>L\<^esub> \<Delta> : v"
  and     "fv (\<Gamma>, e) \<subseteq> set L \<union> domA \<Gamma>"
  shows   "\<lbrakk>e\<rbrakk>\<^bsub>\<lbrace>\<Gamma>\<rbrace>\<rho>\<^esub> = \<lbrakk>v\<rbrakk>\<^bsub>\<lbrace>\<Delta>\<rbrace>\<rho>\<^esub>"
  and     "(\<lbrace>\<Gamma>\<rbrace>\<rho>) f|` domA \<Gamma> = (\<lbrace>\<Delta>\<rbrace>\<rho>) f|` domA \<Gamma>"
  using assms
proof(nominal_induct arbitrary: \<rho> rule:reds.strong_induct)
case Lambda
  case 1 show ?case..
  case 2 show ?case..
next
case (Application y \<Gamma> e x L \<Delta> \<Theta> v e')
  have Gamma_subset: "domA \<Gamma> \<subseteq> domA \<Delta>"
    by (rule reds_doesnt_forget[OF Application.hyps(8)])

  case 1
  hence prem1: "fv (\<Gamma>, e) \<subseteq> set L \<union> domA \<Gamma>" and  "x \<in> set L \<union> domA \<Gamma>" by auto
  moreover
  note reds_pres_closed[OF Application.hyps(8) prem1]
  moreover
  note reds_doesnt_forget[OF Application.hyps(8)]
  moreover
  have "fv (e'[y::=x]) \<subseteq> fv (Lam [y]. e') \<union> {x}"
    by (auto simp add: fv_subst_eq)
  ultimately
  have prem2: "fv (\<Delta>, e'[y::=x]) \<subseteq> set L \<union> domA \<Delta>" by auto

  have *: "(\<lbrace>\<Gamma>\<rbrace>\<rho>) x = (\<lbrace>\<Delta>\<rbrace>\<rho>) x"
  proof(cases "x \<in> domA \<Gamma>")
    case True
    from Application.hyps(10)[OF prem1, where \<rho> = \<rho>]
    have "((\<lbrace>\<Gamma>\<rbrace>\<rho>) f|` domA \<Gamma>) x  = ((\<lbrace>\<Delta>\<rbrace>\<rho>) f|` domA \<Gamma>) x" by simp
    with True show ?thesis by simp
  next
    case False
    from False \<open>x \<in> set L \<union> domA \<Gamma>\<close> reds_avoids_live[OF Application.hyps(8)]
    show ?thesis by (auto simp add: lookup_HSem_other)
  qed

  text_raw \<open>% nice proof start\<close>
  have "\<lbrakk> App e x \<rbrakk>\<^bsub>\<lbrace>\<Gamma>\<rbrace>\<rho>\<^esub> = (\<lbrakk> e \<rbrakk>\<^bsub>\<lbrace>\<Gamma>\<rbrace>\<rho>\<^esub>) \<down>Fn (\<lbrace>\<Gamma>\<rbrace>\<rho>) x"
    by simp
  also have "\<dots> = (\<lbrakk> Lam [y]. e' \<rbrakk>\<^bsub>\<lbrace>\<Delta>\<rbrace>\<rho>\<^esub>) \<down>Fn (\<lbrace>\<Gamma>\<rbrace>\<rho>) x"
    using Application.hyps(9)[OF prem1] by simp
  also have "\<dots> = (\<lbrakk> Lam [y]. e' \<rbrakk>\<^bsub>\<lbrace>\<Delta>\<rbrace>\<rho>\<^esub>) \<down>Fn (\<lbrace>\<Delta>\<rbrace>\<rho>) x"
    unfolding *..
  also have "\<dots> = (Fn\<cdot>(\<Lambda> z. \<lbrakk> e' \<rbrakk>\<^bsub>(\<lbrace>\<Delta>\<rbrace>\<rho>)(y := z)\<^esub>)) \<down>Fn (\<lbrace>\<Delta>\<rbrace>\<rho>) x"
    by simp
  also have "\<dots> = \<lbrakk> e' \<rbrakk>\<^bsub>(\<lbrace>\<Delta>\<rbrace>\<rho>)(y := (\<lbrace>\<Delta>\<rbrace>\<rho>) x)\<^esub>"
    by simp
  also have "\<dots> = \<lbrakk> e'[y ::= x] \<rbrakk>\<^bsub>\<lbrace>\<Delta>\<rbrace>\<rho>\<^esub>"
    unfolding ESem_subst..
  also have "\<dots> = \<lbrakk> v \<rbrakk>\<^bsub>\<lbrace>\<Theta>\<rbrace>\<rho>\<^esub>"
    by (rule Application.hyps(12)[OF prem2])
  finally
  show "\<lbrakk> App e x \<rbrakk>\<^bsub>\<lbrace>\<Gamma>\<rbrace>\<rho>\<^esub> = \<lbrakk> v \<rbrakk>\<^bsub>\<lbrace>\<Theta>\<rbrace>\<rho>\<^esub>".
  text_raw \<open>% nice proof end\<close>

  show "(\<lbrace>\<Gamma>\<rbrace>\<rho>) f|` domA \<Gamma> = (\<lbrace>\<Theta>\<rbrace>\<rho>) f|` domA \<Gamma>"
    using Application.hyps(10)[OF prem1]
          env_restr_eq_subset[OF Gamma_subset Application.hyps(13)[OF prem2]]
    by (rule trans)
next
case (Variable \<Gamma> x e L \<Delta> v)
  hence [simp]:"x \<in> domA \<Gamma>" by (metis domA_from_set map_of_SomeD)

  let ?\<Gamma> = "delete x \<Gamma>"

  case 2
  have "x \<notin> domA \<Delta>"
    by (rule reds_avoids_live[OF Variable.hyps(2)], simp_all)

  have subset: "domA ?\<Gamma> \<subseteq> domA \<Delta>"
    by (rule reds_doesnt_forget[OF Variable.hyps(2)])

  let "?new" = "domA \<Delta> - domA \<Gamma>"
  have "fv (?\<Gamma>, e) \<union> {x} \<subseteq> fv (\<Gamma>, Var x)"
    by (rule fv_delete_heap[OF \<open>map_of \<Gamma> x = Some e\<close>])
  hence prem: "fv (?\<Gamma>, e) \<subseteq> set (x # L) \<union> domA ?\<Gamma>" using 2 by auto
  hence fv_subset: "fv (?\<Gamma>, e) - domA ?\<Gamma> \<subseteq> - ?new"
    using reds_avoids_live'[OF Variable.hyps(2)] by auto

  have "domA \<Gamma> \<subseteq> (-?new)" by auto

  have "\<lbrace>\<Gamma>\<rbrace>\<rho> = \<lbrace>(x,e) # ?\<Gamma>\<rbrace>\<rho>"
    by (rule HSem_reorder[OF map_of_delete_insert[symmetric, OF Variable(1)]])
  also have "\<dots> = (\<mu> \<rho>'. (\<rho> ++\<^bsub>(domA ?\<Gamma>)\<^esub> (\<lbrace>?\<Gamma>\<rbrace>\<rho>'))( x := \<lbrakk> e \<rbrakk>\<^bsub>\<rho>'\<^esub>))"
    by (rule iterative_HSem, simp)
  also have "\<dots> = (\<mu> \<rho>'. (\<rho> ++\<^bsub>(domA ?\<Gamma>)\<^esub> (\<lbrace>?\<Gamma>\<rbrace>\<rho>'))( x := \<lbrakk> e \<rbrakk>\<^bsub>\<lbrace>?\<Gamma>\<rbrace>\<rho>'\<^esub>))"
    by (rule iterative_HSem', simp)
  finally
  have "(\<lbrace>\<Gamma>\<rbrace>\<rho>)f|` (- ?new) = (...) f|` (- ?new)" by simp
  also have "\<dots> = (\<mu> \<rho>'. (\<rho> ++\<^bsub>domA \<Delta>\<^esub> (\<lbrace>\<Delta>\<rbrace>\<rho>'))( x := \<lbrakk> v \<rbrakk>\<^bsub>\<lbrace>\<Delta>\<rbrace>\<rho>'\<^esub>)) f|` (- ?new)"
  proof (induction rule: parallel_fix_ind[where P ="\<lambda> x y. x f|` (- ?new) = y f|` (- ?new)"])
    case 1 show ?case by simp
  next
    case 2 show ?case ..
  next
    case (3 \<sigma> \<sigma>')
    hence "\<lbrakk> e \<rbrakk>\<^bsub>\<lbrace>?\<Gamma>\<rbrace>\<sigma>\<^esub> = \<lbrakk> e \<rbrakk>\<^bsub>\<lbrace>?\<Gamma>\<rbrace>\<sigma>'\<^esub>"
      and "(\<lbrace>?\<Gamma>\<rbrace>\<sigma>) f|` domA ?\<Gamma> = (\<lbrace>?\<Gamma>\<rbrace>\<sigma>') f|` domA ?\<Gamma>"
      using fv_subset by (auto intro: ESem_fresh_cong HSem_fresh_cong  env_restr_eq_subset[OF _ 3])
    from trans[OF this(1) Variable(3)[OF prem]] trans[OF this(2) Variable(4)[OF prem]]
    have  "\<lbrakk> e \<rbrakk>\<^bsub>\<lbrace>?\<Gamma>\<rbrace>\<sigma>\<^esub> = \<lbrakk> v \<rbrakk>\<^bsub>\<lbrace>\<Delta>\<rbrace>\<sigma>'\<^esub>"
       and "(\<lbrace>?\<Gamma>\<rbrace>\<sigma>) f|` domA ?\<Gamma> = (\<lbrace>\<Delta>\<rbrace>\<sigma>') f|` domA ?\<Gamma>".
    thus ?case
      using subset
      by (fastforce simp add: lookup_override_on_eq  lookup_env_restr_eq dest: env_restr_eqD )
  qed
  also have "\<dots> = (\<mu> \<rho>'. (\<rho> ++\<^bsub>domA \<Delta>\<^esub> (\<lbrace>\<Delta>\<rbrace>\<rho>'))( x := \<lbrakk> v \<rbrakk>\<^bsub>\<rho>'\<^esub>)) f|` (-?new)"
    by (rule arg_cong[OF iterative_HSem'[symmetric], OF \<open>x \<notin> domA \<Delta>\<close>])
  also have "\<dots> = (\<lbrace>(x,v) # \<Delta>\<rbrace>\<rho>)  f|` (-?new)"
    by (rule arg_cong[OF iterative_HSem[symmetric], OF \<open>x \<notin> domA \<Delta>\<close>])
  finally
  show le: ?case by (rule env_restr_eq_subset[OF \<open>domA \<Gamma> \<subseteq> (-?new)\<close>])

  have "\<lbrakk> Var x \<rbrakk>\<^bsub>\<lbrace>\<Gamma>\<rbrace>\<rho>\<^esub> = \<lbrakk> Var x \<rbrakk>\<^bsub>\<lbrace>(x, v) # \<Delta>\<rbrace>\<rho>\<^esub>"
    using env_restr_eqD[OF le, where x = x]
    by simp
  also have "\<dots> = \<lbrakk> v \<rbrakk>\<^bsub>\<lbrace>(x, v) # \<Delta>\<rbrace>\<rho>\<^esub>"
    by (auto simp add: lookup_HSem_heap)
  finally
  show "\<lbrakk> Var x \<rbrakk>\<^bsub>\<lbrace>\<Gamma>\<rbrace>\<rho>\<^esub> = \<lbrakk> v \<rbrakk>\<^bsub>\<lbrace>(x, v) # \<Delta>\<rbrace>\<rho>\<^esub>".
next
case (Bool b)
  case 1
  show ?case by simp
  case 2
  show ?case by simp
next
case (IfThenElse \<Gamma> scrut L \<Delta> b e\<^sub>1 e\<^sub>2 \<Theta> v)
  have Gamma_subset: "domA \<Gamma> \<subseteq> domA \<Delta>"
    by (rule reds_doesnt_forget[OF IfThenElse.hyps(1)])

  let ?e = "if b then e\<^sub>1 else e\<^sub>2"

  case 1

  hence prem1: "fv (\<Gamma>, scrut) \<subseteq> set L \<union> domA \<Gamma>"
    and prem2: "fv (\<Delta>, ?e) \<subseteq> set L \<union> domA \<Delta>"
    and "fv ?e \<subseteq> domA \<Gamma> \<union> set L"
    using new_free_vars_on_heap[OF IfThenElse.hyps(1)] Gamma_subset by auto

  have "\<lbrakk> (scrut ? e\<^sub>1 : e\<^sub>2) \<rbrakk>\<^bsub>\<lbrace>\<Gamma>\<rbrace>\<rho>\<^esub> = B_project\<cdot>(\<lbrakk> scrut \<rbrakk>\<^bsub>\<lbrace>\<Gamma>\<rbrace>\<rho>\<^esub>)\<cdot>(\<lbrakk> e\<^sub>1 \<rbrakk>\<^bsub>\<lbrace>\<Gamma>\<rbrace>\<rho>\<^esub>)\<cdot>(\<lbrakk> e\<^sub>2 \<rbrakk>\<^bsub>\<lbrace>\<Gamma>\<rbrace>\<rho>\<^esub>)" by simp
  also have "\<dots> = B_project\<cdot>(\<lbrakk> Bool b \<rbrakk>\<^bsub>\<lbrace>\<Delta>\<rbrace>\<rho>\<^esub>)\<cdot>(\<lbrakk> e\<^sub>1 \<rbrakk>\<^bsub>\<lbrace>\<Gamma>\<rbrace>\<rho>\<^esub>)\<cdot>(\<lbrakk> e\<^sub>2 \<rbrakk>\<^bsub>\<lbrace>\<Gamma>\<rbrace>\<rho>\<^esub>)"
    unfolding IfThenElse.hyps(2)[OF prem1]..
  also have "\<dots> = \<lbrakk> ?e \<rbrakk>\<^bsub>\<lbrace>\<Gamma>\<rbrace>\<rho>\<^esub>" by simp
  also have "\<dots> = \<lbrakk> ?e \<rbrakk>\<^bsub>\<lbrace>\<Delta>\<rbrace>\<rho>\<^esub>"
    proof(rule ESem_fresh_cong_subset[OF  \<open>fv ?e \<subseteq> domA \<Gamma> \<union> set L\<close> env_restr_eqI])
      fix x
      assume "x \<in> domA \<Gamma> \<union> set L"
      thus "(\<lbrace>\<Gamma>\<rbrace>\<rho>) x = (\<lbrace>\<Delta>\<rbrace>\<rho>) x"
      proof(cases "x \<in> domA \<Gamma>")
        assume "x \<in> domA \<Gamma>"
        from IfThenElse.hyps(3)[OF prem1]
        have "((\<lbrace>\<Gamma>\<rbrace>\<rho>) f|` domA \<Gamma>) x  = ((\<lbrace>\<Delta>\<rbrace>\<rho>) f|` domA \<Gamma>) x" by simp
        with \<open>x \<in> domA \<Gamma>\<close> show ?thesis by simp
      next
        assume "x \<notin> domA \<Gamma>"
        from this \<open>x \<in> domA \<Gamma> \<union> set L\<close> reds_avoids_live[OF IfThenElse.hyps(1)]
        show ?thesis
          by (simp add: lookup_HSem_other)
      qed
    qed
  also have "\<dots> = \<lbrakk> v \<rbrakk>\<^bsub>\<lbrace>\<Theta>\<rbrace>\<rho>\<^esub>"
    unfolding IfThenElse.hyps(5)[OF prem2]..
  finally
  show ?case.
  thm env_restr_eq_subset
  show "(\<lbrace>\<Gamma>\<rbrace>\<rho>) f|` domA \<Gamma> = (\<lbrace>\<Theta>\<rbrace>\<rho>) f|` domA \<Gamma>"
    using IfThenElse.hyps(3)[OF prem1]
          env_restr_eq_subset[OF Gamma_subset IfThenElse.hyps(6)[OF prem2]]
    by (rule trans)
next
case (Let as \<Gamma> L body \<Delta> v)
  case 1
  { fix a
    assume a: "a \<in> domA  as"
    have "atom a \<sharp> \<Gamma>"
      by (rule Let(1)[unfolded fresh_star_def, rule_format, OF imageI[OF a]])
    hence "a \<notin> domA \<Gamma>"
      by (metis domA_not_fresh)
  }
  note * = this

  have "fv (as @ \<Gamma>, body) - domA (as @ \<Gamma>) \<subseteq>  fv (\<Gamma>, Let as body) - domA \<Gamma>"
    by auto
  with 1 have prem: "fv (as @ \<Gamma>, body) \<subseteq> set L \<union> domA (as @ \<Gamma>)" by auto

  have f1: "atom ` domA as \<sharp>* \<Gamma>"
    using Let(1) by (simp add: set_bn_to_atom_domA)

  have "\<lbrakk> Let as body \<rbrakk>\<^bsub>\<lbrace>\<Gamma>\<rbrace>\<rho>\<^esub> = \<lbrakk> body \<rbrakk>\<^bsub>\<lbrace>as\<rbrace>\<lbrace>\<Gamma>\<rbrace>\<rho>\<^esub>"
    by (simp)
  also have "\<dots> = \<lbrakk> body \<rbrakk>\<^bsub>\<lbrace>as @ \<Gamma>\<rbrace>\<rho>\<^esub>"
    by (rule arg_cong[OF HSem_merge[OF f1]])
  also have "\<dots> = \<lbrakk> v \<rbrakk>\<^bsub>\<lbrace>\<Delta>\<rbrace>\<rho>\<^esub>"
    by (rule Let.hyps(4)[OF prem])
  finally
  show ?case.

  have "(\<lbrace>\<Gamma>\<rbrace>\<rho>) f|` (domA \<Gamma>) = (\<lbrace>as\<rbrace>(\<lbrace>\<Gamma>\<rbrace>\<rho>)) f|` (domA \<Gamma>)"
    apply (rule ext)
    apply (case_tac "x \<in> domA as")
    apply (auto simp add: lookup_HSem_other lookup_env_restr_eq *)
    done
  also have "\<dots> = (\<lbrace>as @ \<Gamma>\<rbrace>\<rho>) f|` (domA \<Gamma>)"
    by (rule arg_cong[OF HSem_merge[OF f1]])
  also have "\<dots> = (\<lbrace>\<Delta>\<rbrace>\<rho>) f|` (domA \<Gamma>)"
    by (rule env_restr_eq_subset[OF _ Let.hyps(5)[OF prem]]) simp
  finally
  show "(\<lbrace>\<Gamma>\<rbrace>\<rho>) f|` domA \<Gamma> = (\<lbrace>\<Delta>\<rbrace>\<rho>) f|` domA \<Gamma>".
qed

end