theory Memory
imports Main "~~/src/HOL/Library/AList"
  "../Syntax/Type" Int_Value "../Syntax/Wf_Checker"
begin

subsection \<open>Lens for Valuations\<close>
  definition "l_ffld e name \<equiv> (
    \<lambda>a. case map_of a name of None \<Rightarrow> EAssert e | Some b \<Rightarrow> return b,
    \<lambda>b a. do { assert (map_of a name \<noteq> None) e; return (AList.update name b a) }
    )"

  lemma elens_ffld[simp]: "elens (l_ffld e name)"
    unfolding l_ffld_def
    apply (unfold_locales)
    apply (e_vcg simp: update_conv update_triv split: option.splits)+
    done

  lemma l_ffld_get_spec[e_vcg]: "
    e_spec (\<lambda>x. map_of a name = Some x) (\<lambda>e'. e'=e \<and> map_of a name = None) False (eget (l_ffld e name) a)"
    unfolding l_ffld_def by e_vcg

  lemma l_ffld_set_spec[e_vcg]: "
    e_spec (\<lambda>a'. map_of a name \<noteq> None \<and> map_of a' = (map_of a)(name \<mapsto> b)) (\<lambda>_. map_of a name = None) False (eset (l_ffld e name) b a)"
    unfolding l_ffld_def by (e_vcg simp: update_conv)

subsection \<open>Address Values\<close>
text \<open>
  An address holds a memory block, and a path into the value stored there,
  which identifies the part of that value the pointer points to.
\<close>

datatype subscript =
  is_Idx: Idx (the_Idx: nat)
| is_Memb: Memb (the_Memb: mname)
interpretation Idx: l_C1 is_Idx the_Idx subscript.Idx "EDynamic EPtr"
  by unfold_locales simp_all
interpretation Memb: l_C1 is_Memb the_Memb subscript.Memb "EDynamic EPtr"
  by unfold_locales simp_all

hide_const (open) Idx Memb
type_synonym subpath = "subscript list"

type_synonym block_idx = nat

type_synonym addr = "block_idx \<times> subpath"

subsection \<open>Values\<close>

datatype val =
  Null                                    -- \<open>Null pointer\<close>
| is_I: I (the_I: int_val)                -- \<open>Integer\<close>
| is_Addr: Addr (the_Addr: addr)          -- \<open>Non-null pointer\<close>
| is_Array: Array (the_Array: "val list") -- \<open>Array (Block of consecutive values)\<close>
| is_Struct: Struct (the_Struct: "(mname \<times> val) list")  -- \<open>Struct (Name-value assignment)\<close>
| Uninit                                  -- \<open>Uninitialized value\<close>

interpretation I: l_C1 is_I the_I I "EStatic EType" by (unfold_locales) auto
interpretation Addr: l_C1 is_Addr the_Addr Addr "EStatic EType" by (unfold_locales) auto
interpretation Array: l_C1 is_Array the_Array Array "EStatic EType" by (unfold_locales) auto
interpretation Struct: l_C1 is_Struct the_Struct Struct "EStatic EType" by (unfold_locales) auto

(*definition l_Struct :: "(val,(mname\<times>val) list,_) elens" where
  "l_Struct \<equiv> ( \<lambda>(Struct _ ms) \<Rightarrow> return ms | _ \<Rightarrow> EAssert type_error,
     \<lambda>ms. \<lambda>(Struct sn _) \<Rightarrow> return (Struct sn ms) | _ \<Rightarrow> EAssert type_error)"

lemma elens_Struct[simp]: "elens (l_Struct)"
  apply unfold_locales
  unfolding l_Struct_def
  by (auto split: val.splits)

lemma struct_get_spec[e_vcg]:
  "e_spec (\<lambda>ms. is_Struct v \<and> ms = the_Struct v) (\<lambda>e. \<not>is_Struct v \<and> e=type_error) False (eget l_Struct v)"
  apply (cases v)
  by (auto simp: l_Struct_def)

lemma struct_set_spec[e_vcg]:
  "e_spec (\<lambda>v'. \<exists>n ms'. v=Struct n ms' \<and> v'=Struct n ms) (\<lambda>e. \<not>is_Struct v \<and> e=type_error) False (eset l_Struct ms v)"
  apply (cases v)
  by (auto simp: l_Struct_def)

subsection \<open>Paths into Values\<close>
primrec l_subscript :: "subscript \<Rightarrow> (val,val,_) elens" where
  "l_subscript (subscript.Idx i) = Array.l o\<^sub>l l_nth (EDynamic EOverflow) i"
| "l_subscript (subscript.Memb name) = Struct.l o\<^sub>l l_ffld (EStatic EStructure) name"

lemma l_subscript_alt: "l_subscript ss = (case ss of
  (subscript.Idx i) \<Rightarrow> Array.l o\<^sub>l l_nth (EDynamic EOverflow) i
| (subscript.Memb name) \<Rightarrow> Struct.l o\<^sub>l l_ffld (EStatic EStructure) name)"
  by (auto split: subscript.splits)

primrec l_subpath :: "subpath \<Rightarrow> (val,val,_) elens" where
  "l_subpath [] = l_id"
| "l_subpath (s#ss) = l_subscript s o\<^sub>l l_subpath ss"

lemma elens_subscript[simp]: "elens (l_subscript ss)"
  by (cases ss) simp_all

lemma elens_subpath[simp]: "elens (l_subpath p)"
  by (induction p) auto

subsection \<open>Memory\<close>

datatype mem_block =
  is_Block: Block ty bool (the_Block: val)
    -- \<open>Allocated memory block. The flag indicates structural memory,
        which is on stack or statically allocated, and thus cannot be
        freed by the program. \<close>
| is_Freed: Freed ty
    -- \<open>Freed memory block. We retain its type, to be able to argue
      about valid memory evolutions, where blocks can be freed, but
      must not be re-allocated or change type. \<close>

(* TODO: Check again why we need the type of a freed block, and explain here! *)
primrec block_ty :: "mem_block \<Rightarrow> ty" where
  "block_ty (Block ty _ _) = ty" | "block_ty (Freed ty) = ty"

primrec is_dynamic_block :: "mem_block \<Rightarrow> bool" where
  "is_dynamic_block (Block _ s _) \<longleftrightarrow> \<not>s" | "is_dynamic_block (Freed _) = False"

definition l_Block :: "(mem_block,val,_) elens" where
  "l_Block \<equiv> (
    \<lambda>(Block _ _ v) \<Rightarrow> return v | _ \<Rightarrow> EAssert pointer_error,
    \<lambda>v. \<lambda>(Block ty s _) \<Rightarrow> return (Block ty s v) | _ \<Rightarrow> EAssert pointer_error)"

lemma elens_Block[simp]: "elens (l_Block)"
  apply unfold_locales
  unfolding l_Block_def
  by (auto split: mem_block.splits)

lemma struct_get_spec[e_vcg]:
  "e_spec (\<lambda>ms. is_Block v \<and> ms = the_Block v) (\<lambda>e. \<not>is_Block v \<and> e=pointer_error) False (eget l_Block v)"
  apply (cases v)
  by (auto simp: l_Block_def)

lemma struct_set_spec[e_vcg]:
  "e_spec (\<lambda>v'. \<exists>n s ms'. v=Block n s ms' \<and> v'=Block n s ms) (\<lambda>e. \<not>is_Block v \<and> e=pointer_error) False (eset l_Block ms v)"
  apply (cases v)
  by (auto simp: l_Block_def)

lemma [simp]:
  "\<not>is_nonterm (eget l_Block a)"
  "\<not>is_nonterm (eset l_Block b a)"
  by (auto simp: l_Block_def split: mem_block.splits)

(*interpretation Block!: l_C1 is_Block the_Block Block "EDynamic EPtr"
  by (unfold_locales) auto
*)

type_synonym memory = "mem_block list"

definition is_valid_block :: "memory \<Rightarrow> nat \<Rightarrow> bool" where
  "is_valid_block m bi \<equiv> bi<length m \<and> \<not>is_Freed (m!bi)"

abbreviation assert_valid_block :: "memory \<Rightarrow> nat \<hookrightarrow> unit" where
  "assert_valid_block m bi \<equiv> assert (is_valid_block m bi) (EDynamic EPtr)"

text \<open>Memory can only hold positive sized values\<close>
fun nonzerosize_val :: "val \<Rightarrow> bool" where
  "nonzerosize_val val.Null \<longleftrightarrow> True"
| "nonzerosize_val (val.I _) \<longleftrightarrow> True"
| "nonzerosize_val (val.Addr _) \<longleftrightarrow> True"
| "nonzerosize_val (val.Array vs) \<longleftrightarrow> (\<exists>v\<in>set vs. nonzerosize_val v)"
| "nonzerosize_val (val.Struct ms) \<longleftrightarrow> (\<exists>(_,v)\<in>set ms. nonzerosize_val v)"
| "nonzerosize_val (val.Uninit) \<longleftrightarrow> True"

definition raw_alloc :: "ty \<Rightarrow> bool \<Rightarrow> val \<Rightarrow> memory \<hookrightarrow> (block_idx \<times> memory)"
  -- \<open>Allocate block initialized with value.
    The Boolean is set if the block is to be flagged as static or stack memory.\<close>
where
  "raw_alloc ty s v m \<equiv> do {
    assert (nonzerosize_val v) type_error;
    let idx = length m;
    let m = m@[Block ty s v];
    return (idx,m)
  }"

definition raw_free :: "bool \<Rightarrow> block_idx \<Rightarrow> memory \<hookrightarrow> memory"  where
  "raw_free allow_static bi m \<equiv> do {
    assert_valid_block m bi;
    let blk = m!bi;
    assert (allow_static \<or> is_dynamic_block blk) pointer_error;
    let ty = block_ty blk;
    let m = m[bi:=Freed ty];
    return m
  }"

definition l_raw_mem :: "block_idx \<Rightarrow> (memory,val,_) elens" where
  "l_raw_mem bi \<equiv> l_nth (EDynamic EPtr) bi o\<^sub>l l_Block"

lemma elens_raw_mem[simp]: "elens (l_raw_mem bi)"
  unfolding l_raw_mem_def by simp

subsection \<open>Types\<close>

fun new_val :: "ty \<Rightarrow> val" where
  "new_val ty.Null = val.Uninit"
| "new_val ty.I = val.Uninit"
| "new_val (ty.Ptr _) = val.Uninit"
| "new_val (ty.StructPtr _) = val.Uninit"
| "new_val (ty.Array sz ty) = val.Array (replicate sz (new_val ty))"
| "new_val (ty.Struct sn ms) = val.Struct (map (\<lambda>(x,T). (x, new_val T)) ms)"

definition alloc :: "ty \<Rightarrow> bool \<Rightarrow> memory \<hookrightarrow> (addr\<times>memory)"
where
  "alloc ty static \<mu> \<equiv> do {
    (bi,\<mu>) \<leftarrow> raw_alloc ty static (new_val ty) \<mu>;
    return ((bi,[]),\<mu>)
  }"

definition calloc :: "ty \<Rightarrow> bool \<Rightarrow> nat \<Rightarrow> memory \<hookrightarrow> (addr\<times>memory)"
  -- \<open>Allocate an array of memory objects. Array size must be greater 0,
      as a zero size results in undefined behaviour. \<close>
where
  "calloc ty static n \<mu> \<equiv> do {
    assert (n>0) overflow_error;
    let ty = ty.Array n ty;
    (bi,\<mu>) \<leftarrow> raw_alloc ty static (new_val ty) \<mu>;
    return ((bi,[subscript.Idx 0]),\<mu>)
  }"

definition cp_alloc :: "ty \<Rightarrow> bool \<Rightarrow> val \<Rightarrow> memory \<hookrightarrow> (addr\<times>memory)" where
  "cp_alloc ty static v \<mu> \<equiv> do {
    (bi,\<mu>) \<leftarrow> raw_alloc ty static v \<mu>;
    return ((bi,[]),\<mu>)
  }"

definition free :: "bool \<Rightarrow> addr \<Rightarrow> memory \<hookrightarrow> memory" where
  "free allow_static \<equiv> \<lambda>(bi,p) \<mu>. do {
    (* Frees both, pointers created by cp_alloc and by calloc *)
    assert (p=[] \<or> p=[subscript.Idx 0]) pointer_error;
    raw_free allow_static bi \<mu>
  }"

definition l_addr :: "addr \<Rightarrow> (memory,val,_) elens" where
  "l_addr \<equiv> \<lambda>(bi,p). l_raw_mem bi o\<^sub>l l_subpath p"

lemma elens_addr[simp]: "elens (l_addr addr)" by (simp add: l_addr_def split: prod.split)

context
  fixes SM :: struct_map
  fixes \<mu> :: memory
begin

definition MT :: "nat \<rightharpoonup> ty" where
  "MT i \<equiv> if i<length \<mu> then Some (block_ty (\<mu>!i)) else None"

definition FREE :: "nat set" where
  "FREE \<equiv> { i . i<length \<mu> \<and> is_Freed (\<mu>!i) }"

fun nty_eq :: "ty \<Rightarrow> ty \<Rightarrow> bool" where
  "nty_eq (ty.StructPtr sn1) (ty.StructPtr sn2) \<longleftrightarrow> sn1=sn2"
| "nty_eq (ty.StructPtr sn1) (ty.Ptr (ty.Struct sn2 _)) \<longleftrightarrow> sn1 = sn2"
| "nty_eq (ty.Ptr (ty.Struct sn1 _)) (ty.StructPtr sn2) \<longleftrightarrow> sn1 = sn2"
| "nty_eq (ty.Ptr (ty.Struct sn1 _)) (ty.Ptr (ty.Struct sn2 _)) \<longleftrightarrow> sn1 = sn2"
| "nty_eq ty1 ty2 \<longleftrightarrow> ty1=ty2"

lemma nty_eq_refl[simp]:
  "nty_eq ty ty"
  apply (cases "(ty,ty)" rule: nty_eq.cases)
  apply (auto)
  done

lemma nty_eq_sym: "nty_eq ty1 ty2 \<longleftrightarrow> nty_eq ty2 ty1"
  apply (cases "(ty1, ty2)" rule: nty_eq.cases)
  by auto

lemma nty_eq_trans[trans]: "\<lbrakk>nty_eq ty1 ty2; nty_eq ty2 ty3\<rbrakk> \<Longrightarrow> nty_eq ty1 ty3"
  apply (cases "(ty1, ty2)" rule: nty_eq.cases)
  apply simp_all
  apply (cases "(ty1, ty3)" rule: nty_eq.cases)
  apply simp_all
  apply (cases "(ty2, ty3)" rule: nty_eq.cases)
  apply simp_all
  apply (cases "(ty1, ty3)" rule: nty_eq.cases)
  apply simp_all
  done

fun wt_path :: "ty \<Rightarrow> ty \<Rightarrow> subpath \<Rightarrow> bool" where
  "wt_path T ty [] \<longleftrightarrow> nty_eq ty T"
| "wt_path T (ty.Array _ ty) (subscript.Idx _ # ss) \<longleftrightarrow> wt_path T ty ss"
| "wt_path T (ty.Struct _ ms) (subscript.Memb name # ss) \<longleftrightarrow> (
    case map_of ms name of
      None \<Rightarrow> False
    | Some ty \<Rightarrow> wt_path T ty ss
    )"
| "wt_path _ _ _ \<longleftrightarrow> False"

lemma nty_eq_nostruct_is_eq[simp]:
  "\<lbrakk>\<not>ty.is_StructPtr ty; \<not>ty.is_Ptr ty\<rbrakk> \<Longrightarrow> nty_eq ty ty' \<longleftrightarrow> ty=ty'"
  apply (cases ty; cases ty')
  apply (auto split: Option.bind_splits)
  done

lemma nty_eq_ptr_cases:
  assumes "nty_eq (ty.Ptr ty1) ty2"
  obtains
    ty2' where "ty2 = ty.Ptr ty2'" "ty1=ty2'"
  | sn ms1 where "ty1 = ty.Struct sn ms1" "ty2 = ty.StructPtr sn"
  | sn ms1 ms2 where "ty1 = ty.Struct sn ms1" "ty2 = ty.Ptr (ty.Struct sn ms2)"
  using assms
  apply (cases "(ty.Ptr ty1,ty2)" rule: nty_eq.cases)
  apply auto
  done

lemma nty_eq_struct_ptr_cases:
  assumes "nty_eq (ty.StructPtr sn) ty2"
  obtains
    "ty2 = ty.StructPtr sn"
  | ms2 where "ty2 = ty.Ptr (ty.Struct sn ms2)"
  using assms
  apply (cases "(ty.StructPtr sn,ty2)" rule: nty_eq.cases)
  apply auto
  done

lemma wt_path_cong: "nty_eq ty ty' \<Longrightarrow> wt_path T ty p \<longleftrightarrow> wt_path T ty' p"
  apply (induction T ty p arbitrary: ty' rule: wt_path.induct)
  apply (auto split: )
  apply (metis nty_eq_trans nty_eq_sym)
  apply (metis nty_eq_trans)
  apply (auto elim!: nty_eq_ptr_cases) []
  apply (auto elim!: nty_eq_struct_ptr_cases) []
  apply (auto elim!: nty_eq_ptr_cases) []
  apply (auto elim!: nty_eq_struct_ptr_cases) []
  done

lemma wt_path_cong2: "nty_eq T T' \<Longrightarrow> wt_path T ty p \<longleftrightarrow> wt_path T' ty p"
  apply (induction T ty p arbitrary: T' rule: wt_path.induct)
  apply (auto split: option.splits)
  apply (metis nty_eq_trans)
  apply (metis nty_eq_trans nty_eq_sym)
  done

inductive wt_addr:: "ty \<Rightarrow> addr \<Rightarrow> bool" where
  "\<lbrakk> MT bi = Some bty; wt_path T bty p \<rbrakk> \<Longrightarrow> wt_addr T (bi,p)"

inductive wt_val:: "ty \<Rightarrow> val \<Rightarrow> bool" where
  "wt_val (ty.Null) (val.Null)"
| "wt_val (ty.I) (val.I _)"
| "wt_val (ty.Ptr ty) (val.Null)"
| "\<lbrakk> wt_addr ty addr \<rbrakk> \<Longrightarrow> wt_val (ty.Ptr ty) (val.Addr addr)"
| "wt_val (ty.StructPtr ty) (val.Null)"
| "\<lbrakk> SM sname = Some mts; wt_addr (ty.Struct sname mts) addr \<rbrakk>
    \<Longrightarrow> wt_val (ty.StructPtr sname) (val.Addr addr)"
| "\<lbrakk> length vs = sz; \<forall>i < sz. wt_val ty (vs!i) \<rbrakk> \<Longrightarrow> wt_val (ty.Array sz ty) (val.Array vs)"
| "\<lbrakk> dom (map_of mts) = dom (map_of ms);
      \<forall>n T v. map_of mts n = Some T \<and> map_of ms n = Some v \<longrightarrow> wt_val T v \<rbrakk>
     \<Longrightarrow> wt_val (ty.Struct sname mts) (val.Struct ms)"
| "wt_val (ty.Null) (val.Uninit)"
| "wt_val (ty.I) (val.Uninit)"
| "wt_val (ty.Ptr _) (val.Uninit)"
| "wt_val (ty.StructPtr _) (val.Uninit)"

definition wt_block :: "mem_block \<Rightarrow> bool" where
  "wt_block \<equiv> \<lambda>
    (Block ty _ v) \<Rightarrow> wt_val ty v \<and> wf_ty SM ty \<and> nonzero_ty ty \<and> nonzerosize_val v
  | (Freed ty) \<Rightarrow> nonzero_ty ty \<and> wf_ty SM ty"

definition wt_mem :: "bool" where
  "wt_mem \<equiv> \<forall>blk\<in>set \<mu>. wt_block blk"

inductive_simps wt_val_ty_conv:
  "wt_val (ty.I) v"
  "wt_val (ty.Ptr ty) v"
  "wt_val (ty.StructPtr sn) v"
  "wt_val (ty.Array n ty) v"
  "wt_val (ty.Struct sn mts) v"
  "wt_val (ty.Null) v"

end

lemma wt_mem_empty[simp]: "wt_mem SM []"
  by (auto simp: wt_mem_def)

lemma MT_wf_ty:
  assumes "wt_mem SM \<mu>"
  assumes "MT \<mu> bi = Some bty"
  shows "wf_ty SM bty"
  using assms
  apply (auto simp: MT_def wt_mem_def
    split: split_if_asm)
  apply (auto dest!: nth_mem[of bi \<mu>] dest!: bspec)
  apply (auto simp: wt_block_def split: mem_block.splits)
  done

context wf_program_loc begin

lemma wt_path_append[simp]:
  assumes "wf_ty SM ty"
  shows "wt_path T ty (p1@p2) \<longleftrightarrow>
    (\<exists>ty'. wf_ty SM ty' \<and> wt_path ty' ty p1 \<and> wt_path T ty' p2)"
  using assms
  apply (induction T ty p1 rule: wt_path.induct)
  apply (auto split: option.splits)
  using wt_path_cong apply blast
  apply (auto simp: SM_mt_wf) []
  apply (auto simp: SM_mt_wf) []
  done

lemma wt_path_cons[simp]:
  assumes "NO_MATCH [] p2"
  assumes "wf_ty SM ty"
  shows "wt_path T ty (s # p2) = (\<exists>ty'. wf_ty SM ty' \<and> wt_path ty' ty [s] \<and> wt_path T ty' p2)"
  using wt_path_append[of ty T "[s]" p2, OF assms(2)] by simp

  lemma wt_val_cong:
    assumes "nty_eq ty ty'"
    assumes "wf_ty SM ty" "wf_ty SM ty'"
    shows "wt_val SM \<mu> ty b \<longleftrightarrow> wt_val SM \<mu> ty' b"
    using assms
    apply (cases "(ty,ty')" rule: nty_eq.cases)
    apply simp_all
    apply (auto intro!: wt_val.intros elim!: wt_val.cases)
    done

  lemma wt_addr_cong:
    assumes "nty_eq ty ty'"
    assumes "wf_ty SM ty" "wf_ty SM ty'"
    shows "wt_addr \<mu> ty addr \<longleftrightarrow> wt_addr \<mu> ty' addr"
    using assms wt_path_cong2
    by (auto simp: wt_addr.simps)

end

(* TODO/FIXME: Also include constraint that static-flags remain unchanged *)
definition mem_ord :: "memory \<Rightarrow> memory \<Rightarrow> bool" (infix "\<subseteq>\<^sub>\<mu>" 50) where
  "\<mu> \<subseteq>\<^sub>\<mu> \<mu>' \<equiv> length \<mu> \<le> length \<mu>'
    \<and> (\<forall>i<length \<mu>. block_ty (\<mu>!i) = block_ty (\<mu>'!i))
    \<and> (\<forall>i<length \<mu>. is_Freed (\<mu>!i) \<longrightarrow> is_Freed (\<mu>'!i))"

lemma mem_ord_alt: "\<mu> \<subseteq>\<^sub>\<mu> \<mu>' \<longleftrightarrow> MT \<mu> \<subseteq>\<^sub>m MT \<mu>' \<and> FREE \<mu> \<subseteq> FREE \<mu>'"
  apply rule
  apply (auto simp: mem_ord_def map_le_def MT_def dom_def FREE_def) []
  using leI apply (auto simp: mem_ord_def map_le_def MT_def dom_def FREE_def split: split_if_asm) []
  done

definition mem_eq :: "memory \<Rightarrow> memory \<Rightarrow> bool" (infix "=\<^sub>\<mu>" 50) where
  "\<mu> =\<^sub>\<mu> \<mu>' \<equiv> \<mu> \<subseteq>\<^sub>\<mu> \<mu>' \<and> \<mu>' \<subseteq>\<^sub>\<mu> \<mu>"

lemma mem_ord_refl[simp]: "\<mu> \<subseteq>\<^sub>\<mu> \<mu>"
  by (auto simp: mem_ord_def)

lemma mem_ord_trans[trans]: "\<lbrakk>\<mu>1 \<subseteq>\<^sub>\<mu> \<mu>2; \<mu>2 \<subseteq>\<^sub>\<mu> \<mu>3\<rbrakk> \<Longrightarrow> \<mu>1 \<subseteq>\<^sub>\<mu> \<mu>3"
  by (auto simp: mem_ord_def)

lemma mem_ord_antisym: "\<lbrakk> \<mu> \<subseteq>\<^sub>\<mu> \<mu>'; \<mu>'\<subseteq>\<^sub>\<mu> \<mu> \<rbrakk> \<Longrightarrow> \<mu> =\<^sub>\<mu> \<mu>'"
  unfolding mem_eq_def by auto

lemma mem_eq_refl[simp]: "\<mu> =\<^sub>\<mu> \<mu>"
  unfolding mem_eq_def by auto

lemma mem_eq_sym: "\<mu> =\<^sub>\<mu> \<mu>' \<Longrightarrow> \<mu>' =\<^sub>\<mu> \<mu>"
  unfolding mem_eq_def by auto

lemma mem_eq_trans[trans]: "\<lbrakk>\<mu>1 =\<^sub>\<mu> \<mu>2; \<mu>2 =\<^sub>\<mu> \<mu>3\<rbrakk> \<Longrightarrow> \<mu>1 =\<^sub>\<mu> \<mu>3"
  by (auto simp: mem_eq_def dest: mem_ord_trans)

lemma mem_eq_alt:
  "\<mu> =\<^sub>\<mu> \<mu>' \<longleftrightarrow> MT \<mu> = MT \<mu>' \<and> FREE \<mu> = FREE \<mu>'"
  unfolding mem_eq_def mem_ord_alt
  by (auto intro: map_le_antisym)

lemma mem_eqD1: "\<mu> =\<^sub>\<mu> \<mu>' \<Longrightarrow> \<mu> \<subseteq>\<^sub>\<mu> \<mu>'" by (auto simp: mem_eq_def)
lemma mem_eqD2: "\<mu> =\<^sub>\<mu> \<mu>' \<Longrightarrow> \<mu>' \<subseteq>\<^sub>\<mu> \<mu>" by (auto simp: mem_eq_def)

lemma wt_addr_mono:
  assumes "wt_addr \<mu> T addr"
  assumes "mem_ord \<mu> \<mu>'"
  shows "wt_addr \<mu>' T addr"
  using assms
  by (auto elim!: wt_addr.cases intro: wt_addr.intros simp: mem_ord_alt)

lemma wt_val_mono:
  assumes "wt_val SM \<mu> T v"
  assumes "\<mu> \<subseteq>\<^sub>\<mu> \<mu>'"
  shows "wt_val SM \<mu>' T v"
  using assms(1,2)
  by induction (auto intro: wt_val.intros dest: wt_addr_mono)

lemma wt_new_val[simp]: "wt_val SM \<mu> T (new_val T)"
  apply (induction T)
  apply (auto intro: wt_val.intros)
  apply (rule wt_val.intros)
  apply (auto simp: map_of_map)
  apply rprems
  apply (erule map_of_SomeD)
  by (simp add: snds.simps) (* TODO: This should be in default simpset! *)

lemma nonzero_ty_imp_nonzerosize_val:
  assumes "wt_val SM \<mu> ty v"
  assumes "nonzero_ty ty"
  shows "nonzerosize_val v"
  using assms
  apply induction
  apply auto
  apply (auto simp: in_set_conv_nth Bex_def) []
  apply (rename_tac mts ms)
  apply (case_tac mts; case_tac ms; simp)
  apply (auto)
  by (metis (full_types) case_prodI domD insert_iff map_of_SomeD snd_conv)

lemma raw_alloc_spec[e_vcg]:
  assumes "wt_mem SM \<mu>"
  assumes "wt_val SM \<mu> ty v"
  assumes "nonzero_ty ty" "wf_ty SM ty"
  shows "nd_spec (\<lambda>(bi,\<mu>').
    bi\<ge>length \<mu> \<and> MT \<mu>' bi = Some ty \<and> \<mu> \<subseteq>\<^sub>\<mu> \<mu>'
  \<and> wt_mem SM \<mu>') (raw_alloc ty static v \<mu>)"
proof -
  have MTSS: "\<mu> \<subseteq>\<^sub>\<mu> (\<mu> @ [Block ty static v])"
    by (auto simp: mem_ord_def nth_append)

  show ?thesis
    using assms MTSS
    unfolding raw_alloc_def Let_def
    by (fastforce
      simp: wt_mem_def nth_append MT_def wt_block_def
      simp: nonzero_ty_imp_nonzerosize_val
      split: mem_block.splits intro: wt_val_mono[OF _ MTSS])
qed

lemma alloc_spec[e_vcg]:
  assumes "wt_mem SM \<mu>"
  assumes "nonzero_ty ty" "wf_ty SM ty"
  shows "nd_spec (\<lambda>(addr,\<mu>').
    \<mu> \<subseteq>\<^sub>\<mu> \<mu>' \<and> wt_mem SM \<mu>' \<and> wt_addr \<mu>' ty addr) (alloc ty static \<mu>)"
proof -
  show ?thesis
    using assms
    unfolding alloc_def
    apply (e_vcg
      intro!: wt_new_val
      simp: wt_addr.simps wt_val_ty_conv
      split: prod.splits)
    done
qed

lemma calloc_spec[e_vcg]:
  assumes "wt_mem SM \<mu>"
  assumes "nonzero_ty ty" "wf_ty SM ty"
  shows "nd_spec (\<lambda>(addr,\<mu>').
    \<mu> \<subseteq>\<^sub>\<mu> \<mu>' \<and> wt_mem SM \<mu>' \<and> wt_addr \<mu>' ty addr) (calloc ty static n \<mu>)"
proof -
  show ?thesis
    using assms
    unfolding calloc_def
    apply (e_vcg
      intro!: wt_new_val
      simp: wt_addr.simps wt_val_ty_conv
      split: prod.splits)
    done
qed

lemma cp_alloc_spec[e_vcg]:
  assumes "wt_mem SM \<mu>"
  assumes "wt_val SM \<mu> ty v"
  assumes "nonzero_ty ty" "wf_ty SM ty"
  shows "nd_spec (\<lambda>(addr,\<mu>').
    \<mu> \<subseteq>\<^sub>\<mu> \<mu>' \<and> wt_mem SM \<mu>' \<and> wt_addr \<mu>' ty addr) (cp_alloc ty static v \<mu>)"
proof -
  show ?thesis
    using assms
    unfolding cp_alloc_def
    apply (e_vcg intro!: wt_new_val simp: wt_addr.simps split: prod.splits)
    done
qed

lemma raw_free_spec_aux:
  assumes "wt_mem SM \<mu>"
  assumes "i<length \<mu>" "\<mu>!i = Block ty static v"
  shows "wt_mem SM (\<mu>[i:=Freed ty])" (is "wt_mem SM ?\<mu>'")
proof -
  from assms have LE: "\<mu> \<subseteq>\<^sub>\<mu> ?\<mu>'"
    by (auto simp: mem_ord_def nth_list_update)

  show ?thesis
    using assms
    apply (auto simp: wt_mem_def elim!: in_set_upd_cases)
    apply (auto simp: wt_block_def split: mem_block.splits dest!: nth_mem) []
    apply (auto simp: wt_block_def wt_val_mono[OF _ LE] split: mem_block.splits) []
    done
qed

lemma raw_free_spec[e_vcg]:
  assumes "wt_mem SM \<mu>"
  shows "nd_spec (\<lambda>\<mu>'. \<mu> \<subseteq>\<^sub>\<mu> \<mu>' \<and> wt_mem SM \<mu>') (raw_free allow_static bi \<mu>)"
proof -
  have "nd_spec (\<lambda>\<mu>'. \<mu> \<subseteq>\<^sub>\<mu> \<mu>') (raw_free allow_static bi \<mu>)"
    unfolding raw_free_def
    by (e_vcg simp: is_valid_block_def mem_ord_def nth_list_update)
  hence aux: "\<And>P. nd_spec (\<lambda>\<mu>'. \<mu> \<subseteq>\<^sub>\<mu> \<mu>' \<longrightarrow> P \<mu>') (raw_free allow_static bi \<mu>)
    \<Longrightarrow> nd_spec P (raw_free allow_static bi \<mu>)"
    by (simp add: pw_espec_iff)

  show ?thesis
    apply (rule aux)
    using assms
    unfolding raw_free_def
    apply e_vcg'
    apply (cases "\<mu>!bi")
    apply (simp_all add: raw_free_spec_aux is_valid_block_def)
    done
qed

lemma free_spec[e_vcg]:
  assumes "wt_mem SM \<mu>"
  shows "nd_spec (\<lambda>\<mu>'. \<mu> \<subseteq>\<^sub>\<mu> \<mu>' \<and> wt_mem SM \<mu>') (free allow_static addr \<mu>)"
  using assms unfolding free_def by (cases addr) e_vcg

lemma is_BlockE: assumes "is_Block b" obtains ty static v where "b = Block ty static v"
  using assms by (cases b) auto

lemma raw_mem_get_spec[e_vcg]:
  assumes "wt_mem SM \<mu>"
  assumes "MT \<mu> bi = Some T"
  shows "nd_spec (wt_val SM \<mu> T) (eget (l_raw_mem bi) \<mu>)"
  using assms
  unfolding l_raw_mem_def wt_mem_def
  apply (e_vcg')
  apply (auto elim!: is_BlockE simp: dom_def wt_block_def split: mem_block.splits)
  using MT_def nth_mem by fastforce

lemma raw_mem_set_spec[e_vcg]:
  assumes "wt_mem SM \<mu>"
  assumes "MT \<mu> bi = Some T"
  assumes "wt_val SM \<mu> T v"
  shows "nd_spec (\<lambda>\<mu>'. wt_mem SM \<mu>' \<and> \<mu> =\<^sub>\<mu> \<mu>') (eset (l_raw_mem bi) v \<mu>)"
proof (cases "is_Freed (\<mu>!bi)")
  case True
  thus ?thesis
    by (e_vcg simp: l_raw_mem_def)

next
  case False
  with assms(2) obtain static vh where X1: "\<mu>!bi = Block T static vh" "bi<length \<mu>"
    by (cases "\<mu>!bi") (auto simp: MT_def split: split_if_asm)
  hence X2: "Block T static vh \<in> set \<mu>"
    by (auto simp: in_set_conv_nth)

  have MTEQ: "\<mu> =\<^sub>\<mu> \<mu>[bi := Block T static v]"
    using assms(2) X1
    by (auto simp: mem_eq_def mem_ord_def MT_def nth_list_update split: split_if_asm)
  hence MTSS: "\<mu> \<subseteq>\<^sub>\<mu> \<mu>[bi := Block T static v]"
    by (auto simp: mem_eq_def)

  from assms(1) have [simp]: "nonzero_ty T" "wf_ty SM T"
    unfolding wt_mem_def MT_def wt_block_def
    using X2 by auto

  with assms(3) have [simp]: "nonzerosize_val v"
    by (blast intro: nonzero_ty_imp_nonzerosize_val)

  show ?thesis
    using assms X1 MTEQ
    unfolding l_raw_mem_def wt_mem_def[abs_def]
    apply (e_vcg' simp: in_set_conv_nth nth_list_update split: split_if_asm)
    apply (auto
      simp: wt_block_def
      split: mem_block.splits split_if_asm
      elim!: in_set_upd_cases
      intro: wt_val_mono[OF _ MTSS]
      )
    done
qed

context wf_program_loc
begin

context begin

private lemma dom_eq_SomeE:
  assumes "dom a = dom b"
  assumes "a k = Some x"
  obtains y where "dom a = dom b" "b k = Some y"
  using assms by auto

lemma get_subpath_spec[e_vcg]:
  assumes "wt_path T bty p"
  assumes "wt_val SM \<mu> bty b"
  assumes "wf_ty SM T" "wf_ty SM bty"
  shows "nd_spec (wt_val SM \<mu> T) (eget (l_subpath p) b)"
  using assms
  apply (induction bty p arbitrary: b rule: wt_path.induct)
  apply (simp_all)

  apply (e_vcg dest: wt_val_cong)

  apply (erule wt_val.cases; clarsimp)
  apply e_vcg

  apply (erule wt_val.cases; clarsimp split: option.splits)
  apply (erule (1) dom_eq_SomeE)
  apply (e_vcg simp: SM_mt_wf)
  done

lemma set_subpath_spec[e_vcg]:
  assumes "wt_path T bty p"
  assumes "wt_val SM \<mu> bty b"
  assumes "wt_val SM \<mu> T v"
  assumes "wf_ty SM T" "wf_ty SM bty"
  shows "nd_spec (wt_val SM \<mu> bty) (eset (l_subpath p) v b)"
  using assms
  apply (induction bty p arbitrary: b rule: wt_path.induct)
  apply (simp_all)

  apply (e_vcg dest: wt_val_cong)

  apply (erule wt_val.cases; clarsimp)
  apply (e_vcg intro!: wt_val.intros simp: nth_list_update)

  apply (erule wt_val.cases; clarsimp split: option.splits)
  apply (erule (1) dom_eq_SomeE)
  apply (e_vcg simp: SM_mt_wf
      intro!: wt_val.intros elim: dom_eq_SomeE split: split_if_asm)
  done

end

lemma get_addr_spec[e_vcg]:
  assumes "wt_mem SM \<mu>"
  assumes "wt_addr \<mu> T addr"
  assumes "wf_ty SM T"
  shows "nd_spec (wt_val SM \<mu> T) (eget (l_addr addr) \<mu>)"
  using assms(1,2,3)
  unfolding l_addr_def
  apply (cases addr; clarsimp)
  apply (erule wt_addr.cases; clarsimp)
  apply (e_vcg simp: MT_wf_ty)
  done

lemma set_addr_spec[e_vcg]:
  assumes "wt_mem SM \<mu>"
  assumes "wt_addr \<mu> T addr"
  assumes "wt_val SM \<mu> T v"
  assumes "wf_ty SM T"
  shows "nd_spec (\<lambda>\<mu>'. wt_mem SM \<mu>' \<and> \<mu> =\<^sub>\<mu> \<mu>') (eset (l_addr addr) v \<mu>)"
  using assms
  unfolding l_addr_def
  apply (cases addr; clarsimp)
  apply (erule wt_addr.cases; clarsimp)
  apply (e_vcg simp: MT_wf_ty)
  done
end

subsection \<open>Memory Related Operations\<close>

definition is_allocated_raw :: "memory \<Rightarrow> nat \<Rightarrow> bool" where
  "is_allocated_raw \<mu> bi \<equiv> bi<length \<mu> \<and> is_Block (\<mu>!bi)"

definition is_allocated :: "memory \<Rightarrow> addr \<Rightarrow> bool" where
  "is_allocated \<mu> \<equiv> \<lambda>(bi,_). is_allocated_raw \<mu> bi"

definition resolve_subpath_array :: "val \<Rightarrow> subpath \<hookrightarrow> subpath \<times> nat \<times> nat"
  -- \<open>Get index and array size for sub-path to array element.
    Throws pointer-error if this is not a path to an array. \<close>
where
  "resolve_subpath_array v p \<equiv> do {
    j \<leftarrow> eget (l_last pointer_error o\<^sub>l Idx.l) p;
    p' \<leftarrow> eget (l_butlast pointer_error) p;
    vs \<leftarrow> eget (l_subpath p' o\<^sub>l Array.l) v;
    return (p',j,length vs)
  }"

definition index_subpath :: "val \<Rightarrow> int \<Rightarrow> subpath \<hookrightarrow> subpath" where
  "index_subpath v i p \<equiv> do {
    (_,j,len) \<leftarrow> resolve_subpath_array v p;
    let j = int j + i;
    assert (j \<ge> 0 \<and> nat j\<le>len) (EDynamic EPtr);
    p \<leftarrow> eset (l_last (EDynamic EPtr) o\<^sub>l Idx.l) (nat j) p;
    return p
  }"

definition index_addr :: "memory \<Rightarrow> int \<Rightarrow> addr \<hookrightarrow> addr" where
  "index_addr \<equiv> \<lambda>\<mu> i (bi,p). do {
    v \<leftarrow> eget (l_raw_mem bi) \<mu>;
    p \<leftarrow> index_subpath v i p;
    return (bi,p)
  }"

definition cnv_array_to_eptr :: "memory \<Rightarrow> addr \<hookrightarrow> addr"
  -- \<open>Convert address of array to address of its first element\<close>
where
  "cnv_array_to_eptr \<mu> \<equiv> \<lambda>(bi,p). do {
    eget (l_addr (bi,p) o\<^sub>l Array.l) \<mu>;
    return (bi,p@[subscript.Idx 0])
  }"

lemma norm_wt_subscript: "NO_MATCH 0 n \<Longrightarrow>
  wt_path T ty [subscript.Idx n] \<longleftrightarrow> wt_path T ty [subscript.Idx 0]"
  by (cases ty) auto

context wf_program_loc begin

lemma index_subpath_spec[e_vcg]:
  assumes "wt_val SM \<mu> ty v"
  assumes "wt_path T ty p"
  assumes "wf_ty SM T" "wf_ty SM ty"
  shows "nd_spec (wt_path T ty) (index_subpath v i p)"
  using assms
  unfolding index_subpath_def resolve_subpath_array_def
  apply (cases p rule: rev_cases)
  apply e_vcg
  apply (e_vcg elim!: Idx.E Array.E elim: wt_val.cases simp: norm_wt_subscript)
  done

lemma index_addr_spec[e_vcg]:
  assumes "wt_mem SM \<mu>"
  assumes "wt_addr \<mu> T addr"
  assumes "wf_ty SM T"
  shows "nd_spec (wt_addr \<mu> T) (index_addr \<mu> i addr)"
  using assms
  unfolding index_addr_def
  apply -
  apply (erule wt_addr.cases)
  apply (e_vcg intro: wt_addr.intros MT_wf_ty)
  done

lemma cnv_array_to_eptr_spec[e_vcg]:
  assumes "wt_mem SM \<mu>"
  assumes "wt_addr \<mu> (ty.Array n T) addr"
  assumes "wf_ty SM (ty.Array n T)"
  shows "nd_spec (wt_addr \<mu> T) (cnv_array_to_eptr \<mu> addr)"
  using assms
  unfolding cnv_array_to_eptr_def
  apply -
  apply (erule wt_addr.cases)
  apply (e_vcg
    intro!: wt_addr.intros exI[where x="ty.Array n T"]
    simp: MT_wf_ty wt_val_ty_conv)
  done

end

definition diff_subpath :: "val \<Rightarrow> subpath \<Rightarrow> subpath \<hookrightarrow> int" where
  "diff_subpath v p1 p2 \<equiv> do {
    (p1',i1,l) \<leftarrow> resolve_subpath_array v p1;
    (p2',i2,_) \<leftarrow> resolve_subpath_array v p2;
    assert (p1'=p2') (EDynamic EPtr);
    return (int i1 - int i2)
  }"

definition diff_addr :: "memory \<Rightarrow> addr \<Rightarrow> addr \<hookrightarrow> int" where
  "diff_addr \<equiv> \<lambda>\<mu> (bi1,p1) (bi2,p2). do {
    assert (is_allocated_raw \<mu> bi1) pointer_error;
    assert (is_allocated_raw \<mu> bi2) pointer_error;
    assert (bi1 = bi2) (EDynamic EPtr);
    v \<leftarrow> eget (l_raw_mem bi2) \<mu>;
    diff_subpath v p1 p2
  }"

context wf_program_loc begin
lemma diff_subpath_spec[e_vcg]:
  assumes "wt_val SM \<mu> ty v"
  assumes "wt_path T ty p1"
  assumes "wt_path T ty p2"
  assumes "wf_ty SM ty"
  shows "nd_spec (\<lambda>_. True) (diff_subpath v p1 p2)"
  using assms
  unfolding diff_subpath_def resolve_subpath_array_def
  apply (e_vcg elim!: Idx.E Array.E elim: wt_val.cases simp: norm_wt_subscript)
  done

lemma diff_addr_spec[e_vcg]:
  assumes "wt_mem SM \<mu>"
  assumes "wt_addr \<mu> T addr1"
  assumes "wt_addr \<mu> T addr2"
  assumes "wf_ty SM T"
  shows "nd_spec (\<lambda>_. True) (diff_addr \<mu> addr1 addr2)"
  using assms
  unfolding diff_addr_def
  apply (cases addr1, cases addr2)
  apply (e_vcg elim!: wt_addr.cases intro: MT_wf_ty)
  done
end

definition memb_subpath :: "val \<Rightarrow> mname \<Rightarrow> subpath \<hookrightarrow> subpath" where
  "memb_subpath v name p \<equiv> do {
    let p = p@[subscript.Memb name];
    eget (l_subpath p) v;
    return p
  }"

definition memb_addr :: "memory \<Rightarrow> mname \<Rightarrow> addr \<hookrightarrow> addr" where
  "memb_addr \<equiv> \<lambda>\<mu> name (bi,p). do {
    v \<leftarrow> eget (l_raw_mem bi) \<mu>;
    p \<leftarrow> memb_subpath v name p;
    return (bi,p)
  }"

context wf_program_loc begin

lemma memb_subpath_spec[e_vcg]:
  assumes "wt_val SM \<mu> ty v"
  assumes "wt_path (ty.Struct sname ms) ty p"
  assumes "map_of ms name = Some T"
  assumes "wf_ty SM ty" "wf_ty SM (ty.Struct sname ms)"
  shows "nd_spec (wt_path T ty) (memb_subpath v name p)"
  using assms
  unfolding memb_subpath_def
  apply (clarsimp simp: Let_def)
  apply (rule e_vcg)
  apply clarsimp
  apply (rule e_cons, rule e_vcg)
  apply (subst wt_path_append)
  apply (assumption)
  defer
  apply assumption
  apply (erule (1) SM_mt_wf)
  apply (auto intro!: exI[where x="(ty.Struct sname ms)"])
  done

lemma memb_addr_spec[e_vcg]:
  assumes "wt_mem SM \<mu>"
  assumes "wt_addr \<mu> (ty.Struct sname ms) addr"
  assumes "map_of ms name = Some T"
  assumes "wf_ty SM (ty.Struct sname ms)"
  shows "nd_spec (wt_addr \<mu> T) (memb_addr \<mu> name addr)"
  using assms
  unfolding memb_addr_def
  by (e_vcg elim!: wt_addr.cases intro: wt_addr.intros MT_wf_ty)

end

fun valid_subpath :: "val \<Rightarrow> subpath \<Rightarrow> bool" where
  "valid_subpath v [] \<longleftrightarrow> True"
| "valid_subpath (val.Array vs) ([subscript.Idx i]) \<longleftrightarrow> i\<le>length vs"
| "valid_subpath (val.Array vs) (subscript.Idx i#p) \<longleftrightarrow> i<length vs \<and> valid_subpath (vs!i) p"
| "valid_subpath (val.Struct ms) (subscript.Memb n#p) \<longleftrightarrow>
    (case map_of ms n of None \<Rightarrow> False | Some v \<Rightarrow> valid_subpath v p)"
| "valid_subpath _ _ \<longleftrightarrow> False"

definition valid_addr :: "memory \<Rightarrow> addr \<Rightarrow> bool" where
  "valid_addr \<mu> \<equiv> \<lambda>(bi,p). bi<length \<mu> \<and> (
    case \<mu>!bi of
      Freed ty \<Rightarrow> False
    | Block ty _ v \<Rightarrow> valid_subpath v p
  )"

fun readable_subpath :: "val \<Rightarrow> subpath \<Rightarrow> bool" where
  "readable_subpath v [] \<longleftrightarrow> True"
| "readable_subpath (val.Array vs) (subscript.Idx i#p) \<longleftrightarrow> i<length vs \<and> readable_subpath (vs!i) p"
| "readable_subpath (val.Struct ms) (subscript.Memb n#p) \<longleftrightarrow>
    (case map_of ms n of None \<Rightarrow> False | Some v \<Rightarrow> readable_subpath v p)"
| "readable_subpath _ _ \<longleftrightarrow> False"

definition readable_addr :: "memory \<Rightarrow> addr \<Rightarrow> bool" where
  "readable_addr \<mu> \<equiv> \<lambda>(bi,p). bi<length \<mu> \<and> (
    case \<mu>!bi of
      Freed ty \<Rightarrow> False
    | Block ty _ v \<Rightarrow> readable_subpath v p
  )"

context wf_program_loc begin

lemma l_subpath_iff_readable_spec: "e_spec
  (\<lambda>_. readable_subpath v p)
  (\<lambda>_. \<not>readable_subpath v p)
  False
  (eget (l_subpath p) v)"
proof -
  note [e_vcg del] = get_subpath_spec

  show ?thesis
    apply (induction v p rule: readable_subpath.induct)
    (* TODO: Why does splitting in e_vcg not work ?*)
    apply (e_vcg simp: l_subscript_alt;auto split: subscript.splits; e_vcg)+
    done
qed

lemma l_addr_iff_readable_spec: "e_spec
  (\<lambda>_. readable_addr \<mu> addr)
  (\<lambda>_. \<not>readable_addr \<mu> addr)
  False
  (eget (l_addr addr) \<mu>)"
proof -
  note [e_vcg del] = get_subpath_spec

  show ?thesis
    apply (cases addr)
    apply (clarsimp simp: readable_addr_def l_addr_def l_raw_mem_def)
    apply (e_vcg' vcg: l_subpath_iff_readable_spec)
    apply (auto split: mem_block.splits)
    done
qed

lemma "readable_subpath v p \<Longrightarrow> valid_subpath v p"
  apply (induction v p rule: valid_subpath.induct)
  apply (auto split: option.splits)
  done

lemma readable_addr_alt:
  "readable_addr \<mu> addr \<longleftrightarrow> (\<exists>v. eget (l_addr addr) \<mu> = return v)"
  using l_addr_iff_readable_spec[of \<mu> addr]
  apply (cases "eget (l_addr addr) \<mu>")
  apply (auto simp: pw_espec_iff)
  done

end

datatype ptr_comp_res = PC_EQ | PC_NEQ | PC_LESS | PC_GREATER

definition compare_addr :: "memory \<Rightarrow> addr \<Rightarrow> addr \<hookrightarrow> ptr_comp_res" where
  "compare_addr \<mu> addr1 addr2 \<equiv> do {
    assert (valid_addr \<mu> addr1) pointer_error;
    assert (valid_addr \<mu> addr2) pointer_error;

    let (bi1,p1) = addr1;
    let (bi2,p2) = addr2;

    if bi1\<noteq>bi2 then do {
      (* Force addresses to be in allocated range, otherwise
        the result is undefined due to overlap effects *)
      assert (readable_addr \<mu> addr1) pointer_error;
      assert (readable_addr \<mu> addr2) pointer_error;
      return PC_NEQ
    } else do {
      let (prf,r1,r2) = split_common_prefix p1 p2;

      case (r1,r2) of
        ([],[]) \<Rightarrow> return PC_EQ
      | ([],_) \<Rightarrow> EAssert pointer_error
      | (_,[]) \<Rightarrow> EAssert pointer_error
      | (s1#rr1, s2#rr2) \<Rightarrow> do {
          (* Do not compare address with its prefix: They might be equal
            due to zero-indexing --- however, we set it to undefined. *)
          assert (rr1=[] \<longleftrightarrow> rr2=[]) pointer_error;
          (* If the path continues, force addresses to be in range, otherwise
            the result is undefined due to overlap effects *)
          assert (rr1\<noteq>[] \<longrightarrow> readable_addr \<mu> addr1 \<and> readable_addr \<mu> addr2) pointer_error;
          case (s1,s2) of
            (subscript.Idx i1, subscript.Idx i2) \<Rightarrow>
              if i1<i2 then return PC_LESS else return PC_GREATER
          | (subscript.Memb _, subscript.Memb _) \<Rightarrow> return PC_NEQ
          | _ \<Rightarrow> EAssert pointer_error (* TODO: Might want type-error here?! *)
        }
    }
  }"

definition "addr_less \<mu> addr1 addr2 \<equiv> do {
  pc \<leftarrow> compare_addr \<mu> addr1 addr2;
  case pc of
    PC_EQ \<Rightarrow> return False
  | PC_NEQ \<Rightarrow> EAssert pointer_error
  | PC_LESS \<Rightarrow> return True
  | PC_GREATER \<Rightarrow> return False
}"

definition "addr_leq \<mu> addr1 addr2 \<equiv> do {
  pc \<leftarrow> compare_addr \<mu> addr1 addr2;
  case pc of
    PC_EQ \<Rightarrow> return True
  | PC_NEQ \<Rightarrow> EAssert pointer_error
  | PC_LESS \<Rightarrow> return True
  | PC_GREATER \<Rightarrow> return False
}"

definition "addr_eq \<mu> addr1 addr2 \<equiv> do {
  pc \<leftarrow> compare_addr \<mu> addr1 addr2;
  case pc of
    PC_EQ \<Rightarrow> return True
  | PC_NEQ \<Rightarrow> return False
  | PC_LESS \<Rightarrow> return False
  | PC_GREATER \<Rightarrow> return False
}"

lemma is_allocated_rawE:
  assumes "is_allocated_raw \<mu> bi"
  obtains ty static v where "bi<length \<mu>" "\<mu>!bi = Block ty static v"
  using assms
  apply (cases "\<mu>!bi")
  apply (auto simp: is_allocated_raw_def)
  done

lemma wt_mem_block_imp:
  assumes "\<mu>!bi = Block ty static v"
  assumes "bi < length \<mu>"
  assumes "wt_mem SM \<mu>"
  shows
    "MT \<mu> bi = Some ty"
    "wt_val SM \<mu> ty v" "wf_ty SM ty" "nonzero_ty ty" "nonzerosize_val v"
  using assms
  unfolding wt_mem_def wt_block_def
  by (auto simp: Ball_def in_set_conv_nth MT_def)

lemma wt_path_idx_conv: "wt_path T ty (subscript.Idx i#p)
  \<longleftrightarrow> (\<exists>n mty. ty=ty.Array n mty \<and> wt_path T mty p)"
  apply (cases "(T,ty,subscript.Idx i#p)" rule: wt_path.cases)
  apply auto
  done

context wf_program_loc begin

lemma compare_addr_spec[e_vcg]:
  (*assumes "wt_mem SM \<mu>"
  assumes "wt_addr \<mu> T addr1"
  assumes "wt_addr \<mu> T addr2"
  assumes "wf_ty SM T"*)
  shows "nd_spec (\<lambda>_. True) (compare_addr \<mu> addr1 addr2)"
  (*using assms(1-3)*)
  unfolding compare_addr_def
  apply (e_vcg')
  apply (clarsimp split: prod.split list.split subscript.split; safe?; clarsimp)
  apply e_vcg
  apply e_vcg
  apply e_vcg
  apply e_vcg
  apply e_vcg
  done

end
end


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

section "Lift and transfer invariants to show loop freedom"

theory B_Aodv_Loop_Freedom
imports AWN.OClosed_Transfer AWN.Qmsg_Lifting B_Global_Invariants B_Loop_Freedom
begin

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

end


section\<open>Temporal Properties\<close>
text\<open>This theory presents some examples of temporal properties over the simple drinks machine.\<close>

theory Drinks_Machine_LTL
imports "Drinks_Machine" "Extended_Finite_State_Machines-devel.EFSM_LTL"
begin

declare One_nat_def [simp del]

lemma P_ltl_step_0:
  assumes invalid: "P (None, [], <>)"
  assumes select: "l = STR ''select'' \<longrightarrow> P (Some 1, [], <1 $:= Some (hd i), 2 $:= Some (Num 0)>)"
  shows "P (ltl_step drinks (Some 0) <> (l, i))"
proof-
  have length_i: "\<exists>d. (l, i) = (STR ''select'', [d]) \<Longrightarrow> length i = 1"
    by (induct i, auto)
  have length_i_2: "\<forall>d. i \<noteq> [d] \<Longrightarrow> length i \<noteq> 1"
    by (induct i, auto)
  show ?thesis
    apply (case_tac "\<exists>d. (l, i) = (STR ''select'', [d])")
     apply (simp add: possible_steps_0 length_i select_def apply_updates_def)
    using select apply auto[1]
    by (simp add: possible_steps_0_invalid length_i_2 invalid)
qed

lemma P_ltl_step_1:
  assumes invalid: "P (None, [], r)"
  assumes coin: "l = STR ''coin'' \<longrightarrow> P (Some 1, [value_plus (r $ 2) (Some (hd i))], r(2 $:= value_plus (r $ 2) (Some (i ! 0))))"
  assumes vend_fail: "value_gt (Some (Num 100)) (r $ 2) = trilean.true \<longrightarrow> P (Some 1, [],r)"
  assumes vend: "\<not>? value_gt (Some (Num 100)) (r $ 2) = trilean.true \<longrightarrow> P (Some 2, [r$1], r)"
  shows "P (ltl_step drinks (Some 1) r (l, i))"
proof-
  have length_i: "\<And>s. \<exists>d. (l, i) = (s, [d]) \<Longrightarrow> length i = 1"
    by (induct i, auto)
  have length_i_2: "\<forall>d. i \<noteq> [d] \<Longrightarrow> length i \<noteq> 1"
    by (induct i, auto)
  show ?thesis
    apply (case_tac "\<exists>d. (l, i) = (STR ''coin'', [d])")
     apply (simp add: possible_steps_1_coin length_i coin_def apply_outputs_def apply_updates_def)
    using coin apply auto[1]
    apply (case_tac "(l, i) = (STR ''vend'', [])")
     apply (case_tac "\<exists>n. r $ 2 = Some (Num n)")
      apply clarsimp
    subgoal for n
      apply (case_tac "n \<ge> 100")
       apply (simp add: drinks_vend_sufficient vend_def apply_updates_def apply_outputs_def)
       apply (metis finfun_upd_triv possible_steps_2_vend vend vend_ge_100)
      apply (simp add: drinks_vend_insufficient vend_fail_def apply_updates_def apply_outputs_def)
      apply (metis MaybeBoolInt.simps(1) finfun_upd_triv not_less value_gt_def vend_fail)
      done
     apply (simp add: drinks_vend_invalid invalid)
    by (simp add: drinks_no_possible_steps_1 length_i_2 invalid)
qed

lemma LTL_r2_not_always_gt_100: "not (alw (check_exp (Gt (V (Rg 2)) (L (Num 100))))) (watch drinks i)"
  using value_gt_def by auto

lemma drinks_step_2_none: "ltl_step drinks (Some 2) r e = (None, [], r)"
  by (simp add: drinks_end ltl_step_none_2)

lemma one_before_two_2:
  "alw (\<lambda>x. statename (shd (stl x)) = Some 2 \<longrightarrow> statename (shd x) = Some 1) (make_full_observation drinks (Some 2) r [r $ 1] x2a)"
proof(coinduction)
  case alw
  then show ?case
    apply (simp add: drinks_step_2_none)
    by (metis (mono_tags, lifting) alw_mono nxt.simps once_none_nxt_always_none option.distinct(1))
qed

lemma one_before_two_aux:
  assumes "\<exists> p r i. j = nxt (make_full_observation drinks (Some 1) r p) i"
  shows "alw (\<lambda>x. nxt (state_eq (Some 2)) x \<longrightarrow> state_eq (Some 1) x) j"
  using assms apply(coinduct)
  apply simp
  apply clarify
  apply standard
   apply simp
  apply simp
  subgoal for r i
    apply (case_tac "shd (stl i)")
    apply (simp del: ltl_step.simps)
    apply (rule P_ltl_step_1)
       apply (rule disjI2)
       apply (rule alw_mono[of "nxt (state_eq None)"])
        apply (simp add: once_none_nxt_always_none)
       apply simp
      apply auto[1]
     apply auto[1]
    apply simp
    by (simp add: one_before_two_2)
  done

lemma LTL_nxt_2_means_vend:
  "alw (nxt (state_eq (Some 2)) impl (state_eq (Some 1))) (watch drinks i)"
proof(coinduction)
  case alw
  then show ?case
    apply (case_tac "shd i")
    apply (simp del: ltl_step.simps)
    apply (rule P_ltl_step_0)
     apply simp
     apply (rule disjI2)
     apply (rule alw_mono[of "nxt (state_eq None)"])
      apply (simp add: once_none_nxt_always_none)
    using one_before_two_aux by auto
qed

lemma costsMoney_aux:
  assumes "\<exists>p r i. j = (nxt (make_full_observation drinks (Some 1) r p) i)"
  shows "alw (\<lambda>xs. nxt (state_eq (Some 2)) xs \<longrightarrow> check_exp (Ge (V (Rg 2)) (L (Num 100))) xs) j"
  using assms apply coinduct
  apply clarsimp
  subgoal for r i
    apply (case_tac "shd (stl i)")
    apply (simp del: ltl_step.simps)
    apply (rule P_ltl_step_1)
       apply simp
       apply (rule disjI2)
       apply (rule alw_mono[of "nxt (state_eq None)"])
        apply (simp add: once_none_nxt_always_none)
       apply simp
      apply auto[1]
     apply auto[1]
    apply simp
    apply standard
    apply (rule disjI2)
    apply (rule alw_mono[of "nxt (state_eq None)"])
     apply (metis (no_types, lifting) drinks_step_2_none fst_conv make_full_observation.sel(2) nxt.simps nxt_alw once_none_always_none_aux)
    by simp
  done

(* costsMoney: THEOREM drinks |- G(X(cfstate=State_2) => gval(value_ge(r_2, Some(NUM(100))))); *)
lemma LTL_costsMoney:
  "(alw (nxt (state_eq (Some 2)) impl (check_exp (Ge (V (Rg 2)) (L (Num 100)))))) (watch drinks i)"
proof(coinduction)
  case alw
  then show ?case
    apply (cases "shd i")
    subgoal for l ip
      apply (case_tac "l = STR ''select'' \<and> length ip = 1")
       defer
       apply (simp add: possible_steps_0_invalid)
       apply (rule disjI2)
       apply (rule alw_mono[of "nxt (state_eq None)"])
        apply (simp add: once_none_nxt_always_none)
       apply (simp add: )
      apply (simp add: possible_steps_0 select_def)
      apply (rule disjI2)
      apply (simp only: nxt.simps[symmetric])
      using costsMoney_aux by auto
    done
qed

lemma LTL_costsMoney_aux:
  "(alw (not (check_exp (Ge (V (Rg 2)) (L (Num 100)))) impl (not (nxt (state_eq (Some 2)))))) (watch drinks i)"
  by (metis (no_types, lifting) LTL_costsMoney alw_mono)

lemma implode_select: "String.implode ''select'' = STR ''select''"
  by (metis Literal.rep_eq String.implode_explode_eq zero_literal.rep_eq)

lemma implode_coin: "String.implode ''coin'' = STR ''coin''"
  by (metis Literal.rep_eq String.implode_explode_eq zero_literal.rep_eq)

lemma implode_vend: "String.implode ''vend'' = STR ''vend''"
  by (metis Literal.rep_eq String.implode_explode_eq zero_literal.rep_eq)

lemmas implode_labels = implode_select implode_coin implode_vend

lemma LTL_neverReachS2:"(((((action_eq (''select'', [Str ''coke''])))
                    aand
                    (nxt ((action_eq (''coin'', [Num 100])))))
                    aand
                    (nxt (nxt((label_eq ''vend'' aand (input_eq []))))))
                    impl
                    (nxt (nxt (nxt (state_eq (Some 2))))))
                    (watch drinks i)"
  apply (simp add: implode_labels)
  apply (cases i)
  apply clarify
  apply simp
  apply (simp add: possible_steps_0 select_def)
  apply (case_tac "shd x2", clarify)
  apply (simp add: possible_steps_1_coin coin_def value_plus_def finfun_update_twist apply_updates_def)
  apply (case_tac "shd (stl x2)", clarify)
  by (simp add: drinks_vend_sufficient )

lemma ltl_step_not_select:
  "\<nexists>i. e = (STR ''select'', [i]) \<Longrightarrow>
   ltl_step drinks (Some 0) r e = (None, [], r)"
  apply (cases e, clarify)
  subgoal for a b
    apply (rule ltl_step_none)
    apply (simp add: possible_steps_empty drinks_def can_take_transition_def can_take_def select_def)
    by (cases e, case_tac b, auto)
  done

lemma ltl_step_select:
  "ltl_step drinks (Some 0) <> (STR ''select'', [i]) = (Some 1, [], <1 $:= Some i, 2 $:= Some (Num 0)>)"
  apply (rule  ltl_step_some[of _ _ _ _ _ _ select])
    apply (simp add: possible_steps_0)
   apply (simp add: select_def)
  by (simp add: select_def finfun_update_twist apply_updates_def)

lemma ltl_step_not_coin_or_vend:
  "\<nexists>i. e = (STR ''coin'', [i]) \<Longrightarrow>
    e \<noteq> (STR ''vend'', []) \<Longrightarrow>
    ltl_step drinks (Some 1) r e = (None, [], r)"
  apply (cases e)
  subgoal for a b
    apply (simp del: ltl_step.simps)
    apply (rule ltl_step_none)
    apply (simp add: possible_steps_empty drinks_def can_take_transition_def can_take_def transitions)
    by (case_tac e, case_tac b, auto)
  done

lemma ltl_step_coin:
  "\<exists>p r'. ltl_step drinks (Some 1) r (STR ''coin'', [i]) = (Some 1, p, r')"
  by (simp add: possible_steps_1_coin)

lemma alw_tl:
  "alw \<phi> (make_full_observation e (Some 0) <> [] xs) \<Longrightarrow>
    alw \<phi>
     (make_full_observation e (fst (ltl_step e (Some 0) <> (shd xs))) (snd (snd (ltl_step e (Some 0) <> (shd xs))))
       (fst (snd (ltl_step e (Some 0) <> (shd xs)))) (stl xs))"
  by auto

lemma stop_at_none:
  "alw (\<lambda>xs. output (shd (stl xs)) = [Some (EFSM.Str drink)] \<longrightarrow> check_exp (Ge (V (Rg 2)) (L (Num 100))) xs)
            (make_full_observation drinks None r p t)"
  apply (rule alw_mono[of "nxt (output_eq [])"])
   apply (simp add: no_output_none_nxt)
  by simp

lemma drink_costs_money_aux:
  assumes "\<exists>p r t. j = make_full_observation drinks (Some 1) r p t"
  shows "alw (\<lambda>xs. output (shd (stl xs)) = [Some (EFSM.Str drink)] \<longrightarrow> check_exp (Ge (V (Rg 2)) (L (Num 100))) xs) j"
  using assms apply coinduct
  apply clarsimp
  apply (case_tac "shd t")
  apply (simp del: ltl_step.simps)
  apply (rule P_ltl_step_1)
     apply simp
     apply (rule disjI2)
     apply (rule alw_mono[of "nxt (output_eq [])"])
      apply (simp add: no_output_none_nxt)
     apply simp
    apply (simp add: Str_def value_plus_never_string)
    apply auto[1]
   apply auto[1]
  apply simp
  apply standard
  apply (rule disjI2)
  apply (rule alw_mono[of "nxt (output_eq [])"])
   apply (simp add: drinks_step_2_none no_output_none_if_empty nxt_alw)
  by simp

lemma LTL_drinks_cost_money:
  "alw (nxt (output_eq [Some (Str drink)]) impl (check_exp (Ge (V (Rg 2)) (L (Num 100))))) (watch drinks t)"
proof(coinduction)
  case alw
  then show ?case
    apply (case_tac "shd t")
    apply (simp del: ltl_step.simps)
    apply (rule P_ltl_step_0)
     apply simp
     apply (rule disjI2)
     apply (rule alw_mono[of "nxt (output_eq [])"])
      apply (simp add: no_output_none_nxt)
     apply simp
    apply simp
    using drink_costs_money_aux
    apply simp
    by blast
qed

lemma steps_1_invalid:
      "\<nexists>i. (a, b) = (STR ''coin'', [i]) \<Longrightarrow>
       \<nexists>i. (a, b) = (STR ''vend'', []) \<Longrightarrow>
       possible_steps drinks 1 r a b = {||}"
  apply (simp add: possible_steps_empty drinks_def transitions can_take_transition_def can_take_def)
  by (induct b, auto)

lemma output_vend_aux:
  assumes "\<exists>p r t. j = make_full_observation drinks (Some 1) r p t"
  shows "alw (\<lambda>xs. label_eq ''vend'' xs \<and> output (shd (stl xs)) = [Some d] \<longrightarrow> check_exp (Ge (V (Rg 2)) (L (Num 100))) xs) j"
  using assms apply coinduct
  apply clarsimp
  subgoal for r t
    apply (case_tac "shd t")
    apply (simp add: implode_vend del: ltl_step.simps)
    apply (rule P_ltl_step_1)
       apply simp
       apply (rule disjI2)
       apply (rule alw_mono[of "nxt (output_eq [])"])
        apply (simp add: no_output_none_nxt)
       apply simp
      apply auto[1]
     apply auto[1]
    apply simp
    apply standard
    apply (rule disjI2)
    apply (rule alw_mono[of "nxt (output_eq [])"])
     apply (simp add: drinks_step_2_none no_output_none_if_empty nxt_alw)
    by simp
  done

text_raw\<open>\snip{outputVend}{1}{2}{%\<close>
lemma LTL_output_vend:
  "alw (((label_eq ''vend'') aand (nxt (output_eq [Some d]))) impl
         (check_exp (Ge (V (Rg 2)) (L (Num 100))))) (watch drinks t)"
text_raw\<open>}%endsnip\<close>
proof(coinduction)
  case alw
  then show ?case
    apply (simp add: implode_vend)
    apply (case_tac "shd t")
    apply (simp del: ltl_step.simps)
    apply (rule P_ltl_step_0)
     apply simp
    apply (rule disjI2)
     apply (rule alw_mono[of "nxt (output_eq [])"])
      apply (simp add: no_output_none_nxt)
     apply simp
    apply simp
    subgoal for a b
      using output_vend_aux[of "(make_full_observation drinks (Some 1)
              <1 $:= Some (hd b), 2 $:= Some (Num 0)> [] (stl t))" d]
      using implode_vend by auto
    done
qed

text_raw\<open>\snip{outputVendUnfolded}{1}{2}{%\<close>
lemma LTL_output_vend_unfolded:
  "alw (\<lambda>xs. (label (shd xs) = STR ''vend'' \<and>
             nxt (\<lambda>s. output (shd s) = [Some d]) xs) \<longrightarrow>
              \<not>? value_gt (Some (Num 100)) (datastate (shd xs) $ 2) = trilean.true)
     (watch drinks t)"
text_raw\<open>}%endsnip\<close>
  apply (insert LTL_output_vend[of d t])
  by (simp add: implode_vend)

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 StringOrd
imports "~~/src/HOL/Main"
begin

datatype anotherBL =
   BLNon
 | BLZer anotherBL
 | BLOne anotherBL
 | BLTwo anotherBL
 | BLThr anotherBL

lemma twice_bound_meta_all:
  "(\<And>a b. x = a \<and> y = b \<Longrightarrow> PROP Q a b) \<equiv> (PROP Q x y)"
  apply (rule equal_intr_rule)
   apply (erule meta_allE, erule meta_allE, erule meta_mp)
   apply simp
  apply clarsimp
  done

function(sequential) anotherBL_ord :: "anotherBL \<Rightarrow> anotherBL \<Rightarrow> bool"
where
   "anotherBL_ord BLNon x = True"
 | "anotherBL_ord x BLNon = False"
 | "anotherBL_ord (BLZer x) (BLZer y) = anotherBL_ord x y"
 | "anotherBL_ord (BLZer x) y = True"
 | "anotherBL_ord x (BLZer y) = False"
 | "anotherBL_ord (BLOne x) (BLOne y) = anotherBL_ord x y"
 | "anotherBL_ord (BLOne x) y = True"
 | "anotherBL_ord x (BLOne y) = False"
 | "anotherBL_ord (BLTwo x) (BLTwo y) = anotherBL_ord x y"
 | "anotherBL_ord (BLTwo x) y = True"
 | "anotherBL_ord x (BLTwo y) = False"
 | "anotherBL_ord (BLThr x) (BLThr y) = anotherBL_ord x y"
  apply simp_all
  apply (case_tac x, simp_all)
  apply (case_tac a, simp_all)
     apply (case_tac b, simp_all add: twice_bound_meta_all)[1]
    apply (case_tac b, simp_all add: twice_bound_meta_all)[1]
   apply (case_tac b, simp_all add: twice_bound_meta_all)[1]
  apply (case_tac b, simp_all add: twice_bound_meta_all)[1]
  done

termination anotherBL_ord
  apply (rule anotherBL_ord.termination)
      apply (rule wf_measure[where f="size_prod size size"])
     apply simp+
  done

instantiation
  anotherBL :: ord
begin
  definition le_anotherBL: "a \<le> b \<equiv> anotherBL_ord a b"
  definition less_anotherBL: "a < b \<equiv> (anotherBL_ord a b \<and> a \<noteq> b)"

  instance ..
end

lemma anotherBL_to_less_simps:
  "(anotherBL_ord a b = v) \<Longrightarrow> (a < b = (v \<and> a \<noteq> b))"
  by (simp add: less_anotherBL)

lemmas anotherBL_ords[simp] =
  anotherBL_ord.simps[folded le_anotherBL, simplified]
  anotherBL_ord.simps [THEN anotherBL_to_less_simps,
                       simplified, folded less_anotherBL]

lemma anotherBL_trans:
  "\<lbrakk> x \<le> (y :: anotherBL); y \<le> z \<rbrakk> \<Longrightarrow> x \<le> z"
  apply (rule ccontr)
  apply (erule rev_mp)+
  apply (induct y arbitrary: x z)
      apply (case_tac x, simp_all)[1]
     apply (case_tac x, simp_all(no_asm_simp))[1]
     apply (case_tac z, simp_all)[1]
    apply (case_tac x, simp_all(no_asm_simp))[1]
     apply (case_tac z, simp_all)[1]
    apply (case_tac z, simp_all)[1]
   apply (case_tac z, simp_all(no_asm_simp))[1]
    apply (case_tac x, simp_all)[1]
   apply (case_tac x, simp_all)[1]
  apply (case_tac z, simp_all(no_asm_simp))[1]
  apply (case_tac x, simp_all)[1]
  done

lemma anotherBL_antisym:
  "\<lbrakk> x \<le> y; (y :: anotherBL) \<le> x \<rbrakk> \<Longrightarrow> x = y"
  apply (erule rev_mp)+
  apply (induct x arbitrary: y)
      apply (case_tac y, simp_all)[1]
     apply (case_tac y, simp_all)[1]
    apply (case_tac y, simp_all)[1]
   apply (case_tac y, simp_all)[1]
  apply (case_tac y, simp_all)[1]
  done

lemma anotherBL_total_ord:
  "x \<le> y \<or> y \<le> (x :: anotherBL)"
  apply (induct x arbitrary: y)
      apply simp
     apply (case_tac y, simp_all)[1]
    apply (case_tac y, simp_all)[1]
   apply (case_tac y, simp_all)[1]
  apply (case_tac y, simp_all)[1]
  done

lemma less_eq_conj_anotherBL:
  "x < (y :: anotherBL) = (x \<le> y \<and> x \<noteq> y)"
  by (simp add: less_anotherBL le_anotherBL)

instantiation anotherBL :: linorder
begin

instance
  apply intro_classes
      apply (simp add: less_eq_conj_anotherBL)
      apply safe[1]
      apply (drule(1) anotherBL_antisym)
      apply simp
     apply (induct_tac x, simp_all)[1]
    apply (erule(1) anotherBL_trans)
   apply (erule(1) anotherBL_antisym)
  apply (rule anotherBL_total_ord)
  done

end

primrec
  nibble_to_anbl :: "nibble \<Rightarrow> anotherBL \<Rightarrow> anotherBL"
where
  "nibble_to_anbl Nibble0 anbl = BLZer (BLZer anbl)"
| "nibble_to_anbl Nibble1 anbl = BLZer (BLOne anbl)"
| "nibble_to_anbl Nibble2 anbl = BLZer (BLTwo anbl)"
| "nibble_to_anbl Nibble3 anbl = BLZer (BLThr anbl)"
| "nibble_to_anbl Nibble4 anbl = BLOne (BLZer anbl)"
| "nibble_to_anbl Nibble5 anbl = BLOne (BLOne anbl)"
| "nibble_to_anbl Nibble6 anbl = BLOne (BLTwo anbl)"
| "nibble_to_anbl Nibble7 anbl = BLOne (BLThr anbl)"
| "nibble_to_anbl Nibble8 anbl = BLTwo (BLZer anbl)"
| "nibble_to_anbl Nibble9 anbl = BLTwo (BLOne anbl)"
| "nibble_to_anbl NibbleA anbl = BLTwo (BLTwo anbl)"
| "nibble_to_anbl NibbleB anbl = BLTwo (BLThr anbl)"
| "nibble_to_anbl NibbleC anbl = BLThr (BLZer anbl)"
| "nibble_to_anbl NibbleD anbl = BLThr (BLOne anbl)"
| "nibble_to_anbl NibbleE anbl = BLThr (BLTwo anbl)"
| "nibble_to_anbl NibbleF anbl = BLThr (BLThr anbl)"

primrec
  char_to_anbl :: "char \<Rightarrow> anotherBL \<Rightarrow> anotherBL"
where
 "char_to_anbl (Char nib nob) anbl = nibble_to_anbl nib (nibble_to_anbl nob anbl)"

primrec
  string_to_anbl :: "string \<Rightarrow> anotherBL"
where
  "string_to_anbl []          = BLNon"
| "string_to_anbl (chr # str) = char_to_anbl chr (string_to_anbl str)"

lemmas string_ord_simps
  = string_to_anbl.simps char_to_anbl.simps nibble_to_anbl.simps
    anotherBL_ords anotherBL.simps

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 MultByAdd
imports
  "AutoCorres.AutoCorres"
begin

(* Parse the input file. *)
external_file "mult_by_add.c"
install_C_file "mult_by_add.c"

(* Abstract the input file. *)
autocorres [ ts_force nondet = mult_by_add ] "mult_by_add.c"

context mult_by_add begin

(*
 * Prove the function returns the correct result, and (simultaneously)
 * does not fail and terminates.
 *)
lemma "\<lbrace> \<lambda>s. True \<rbrace> mult_by_add' a b \<lbrace> \<lambda>r s. r = a * b \<rbrace>!"
  (* Unfold function definition. *)
  apply (clarsimp simp: mult_by_add'_def)

  (* Annotate while loop with an invariant and measure. *)
  apply (subst whileLoop_add_inv
    [where I="\<lambda>(a', r) s. (a' * b) + r = (a * b)"
       and M="\<lambda>((a', _), s). unat a'"])

  (* Run "wp" weakest precondition tactic, and solve verification *
   * conditions generated by it. *)
  apply wp
     apply (simp add: field_simps)
    apply unat_arith
   apply (simp add: split_def word_neq_0_conv[symmetric])
  apply (simp add: split_def | wp)+
  done

(*
 * Equivalent partial-correctness proof using Simpl framework.
 *)
lemma "\<Gamma> \<turnstile> {s. s = t} \<acute>ret__unsigned :== CALL mult_by_add(\<acute>a, \<acute>b) \<lbrace> (\<acute>ret__unsigned = \<^bsup>t\<^esup>a * \<^bsup>t\<^esup>b) \<rbrace>"
  (* Unfold the body. *)
  apply vcg_step
   defer

   (* Annotate the while loop with an invariant and variant. *)
   apply (subst whileAnno_def)
   apply (subst whileAnno_def [symmetric,
     where I=" \<lbrace> (\<acute>a * \<acute>b + \<acute>result) = (\<^bsup>t\<^esup>a * \<^bsup>t\<^esup>b) \<rbrace>"
     and V="measure (\<lambda>s. unat (a_' s))"])

  (* Solve the remaining conditions. *)
   apply vcg
   apply (fastforce intro: unat_mono simp: gt0_iff_gem1 field_simps less_1_simp scast_id)+
  done

end

end