(*
TiTitle: 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>Type System for Ensuring Locally Sound Use of Modes\<close>

theory LocallySoundModeUse
imports Security Language
begin

subsection \<open>Typing Rules\<close>

locale sifum_modes =
  sifum_lang_no_dma ev\<^sub>A ev\<^sub>B aexp_vars bexp_vars + sifum_security dma \<C>_vars \<C> eval\<^sub>w undefined
  for ev\<^sub>A :: "('Var, 'Val) Mem \<Rightarrow> 'AExp \<Rightarrow> 'Val"
  and ev\<^sub>B :: "('Var, 'Val) Mem \<Rightarrow> 'BExp \<Rightarrow> bool"
  and aexp_vars :: "'AExp \<Rightarrow> 'Var set"
  and bexp_vars :: "'BExp \<Rightarrow> 'Var set"
  and dma :: "('Var,'Val) Mem \<Rightarrow> 'Var \<Rightarrow> Sec"
  and \<C>_vars :: "'Var \<Rightarrow> 'Var set"
  and \<C> :: "'Var set"

context sifum_modes
begin

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

fun
  update_annos :: "'Var Mds \<Rightarrow> 'Var ModeUpd list \<Rightarrow> 'Var Mds"
  (infix "\<oplus>" 140)
where
  "update_annos mds [] = mds" |
  "update_annos mds (a # as) = update_annos (update_modes a mds) as"

fun
  annotate :: "('Var, 'AExp, 'BExp) Stmt \<Rightarrow> 'Var ModeUpd list \<Rightarrow> ('Var, 'AExp, 'BExp) Stmt"
  (infix "\<otimes>" 140)
where
  "annotate c [] = c" |
  "annotate c (a # as) = (annotate c as)@[a]"

inductive
  mode_type :: "'Var Mds \<Rightarrow> ('Var, 'AExp, 'BExp) Stmt \<Rightarrow> 'Var Mds \<Rightarrow> bool" ("\<turnstile> _ { _ } _")
where
  skip: "\<turnstile> mds { Skip \<otimes> annos } (mds \<oplus> annos)" |
  assign: "\<lbrakk> x \<notin> mds GuarNoWrite \<union> mds GuarNoReadOrWrite ; aexp_vars e \<inter> mds GuarNoReadOrWrite = {};
             \<forall>v. (x \<in> \<C>_vars v \<longrightarrow> v \<notin> mds GuarNoWrite \<union> mds GuarNoReadOrWrite) \<and>
                 (\<C>_vars v \<inter> aexp_vars e \<noteq> {} \<longrightarrow> v \<notin> mds GuarNoReadOrWrite)\<rbrakk> \<Longrightarrow>
  \<turnstile> mds { (x \<leftarrow> e) \<otimes> annos } (mds \<oplus> annos)" |
  if_: "\<lbrakk> \<turnstile> (mds \<oplus> annos) { c\<^sub>1 } mds'' ;
          \<turnstile> (mds \<oplus> annos) { c\<^sub>2 } mds'' ;
          bexp_vars e \<inter> mds GuarNoReadOrWrite = {};
          \<forall> v. \<C>_vars v \<inter> bexp_vars e \<noteq> {} \<longrightarrow> v \<notin> mds GuarNoReadOrWrite\<rbrakk> \<Longrightarrow>
        \<turnstile> mds { If e c\<^sub>1 c\<^sub>2 \<otimes> annos } mds''" |
  while: "\<lbrakk> mds' = mds \<oplus> annos ; \<turnstile> mds' { c } mds' ; bexp_vars e \<inter> mds' GuarNoReadOrWrite = {};
            \<forall> v. \<C>_vars v \<inter> bexp_vars e \<noteq> {} \<longrightarrow> v \<notin> mds' GuarNoReadOrWrite\<rbrakk> \<Longrightarrow>
  \<turnstile> mds { While e c \<otimes> annos } mds'" |
  seq: "\<lbrakk> \<turnstile> mds { c\<^sub>1 } mds' ; \<turnstile> mds' { c\<^sub>2 } mds'' \<rbrakk> \<Longrightarrow> \<turnstile> mds { c\<^sub>1 ;; c\<^sub>2 } mds''" |
  sub: "\<lbrakk> \<turnstile> mds\<^sub>2 { c } mds\<^sub>2' ; mds\<^sub>1 \<le> mds\<^sub>2 ; mds\<^sub>2' \<le> mds\<^sub>1' \<rbrakk> \<Longrightarrow>
  \<turnstile> mds\<^sub>1 { c } mds\<^sub>1'"

subsection \<open>Soundness of the Type System\<close>

(* Special case for evaluation with an empty context *)

lemma update_preserves_le:
  "mds\<^sub>1 \<le> mds\<^sub>2 \<Longrightarrow> (mds\<^sub>1 \<oplus> annos) \<le> (mds\<^sub>2 \<oplus> annos)"
proof (induct annos arbitrary: mds\<^sub>1 mds\<^sub>2)
  case Nil
  thus ?case by simp
next
  case (Cons a annos mds\<^sub>1 mds\<^sub>2)
  hence "update_modes a mds\<^sub>1 \<le> update_modes a mds\<^sub>2"
    by (case_tac a, auto simp: le_fun_def)
  with Cons show ?case
    by auto
qed

(* Annotations do not affect doesnt_read and doesnt_modify: *)
lemma doesnt_read_annos:
  "doesnt_read_or_modify c x \<Longrightarrow> doesnt_read_or_modify (c \<otimes> annos) x"
  unfolding doesnt_read_or_modify_def doesnt_read_or_modify_vars_def
  apply clarify
  apply (induct annos)
   apply simp
   apply (metis (lifting))
  apply clarsimp
  apply (rule cxt_eval)
  apply (rule eval\<^sub>w.decl)
  apply (metis cxt_eval eval\<^sub>w.decl upd_elim)+
  done

lemma doesnt_modify_annos:
  "doesnt_modify c x \<Longrightarrow> doesnt_modify (c \<otimes> annos) x"
  unfolding doesnt_modify_def
  apply clarsimp
   apply (induct annos)
    apply simp
   by (metis annotate.simps(2) upd_elim)

(* The following part contains some lemmas about evaluation of
   commands annotated using \<otimes> and characterisations of loc_reach for
   commands. *)

lemma stop_loc_reach:
  "\<lbrakk> \<langle>c', mds', mem'\<rangle> \<in> loc_reach \<langle>Stop, mds, mem\<rangle> \<rbrakk> \<Longrightarrow>
  c' = Stop \<and> mds' = mds"
  apply (induct rule: loc_reach.induct)
  by (auto simp: stop_no_eval)

lemma stop_doesnt_access:
  "doesnt_modify Stop x \<and> doesnt_read_or_modify Stop x"
  unfolding doesnt_modify_def and doesnt_read_or_modify_def doesnt_read_or_modify_vars_def
  using stop_no_eval
  by auto

lemma skip_eval_step:
  "\<langle>Skip \<otimes> annos, mds, mem\<rangle> \<leadsto> \<langle>Stop, mds \<oplus> annos, mem\<rangle>"
  apply (induct annos arbitrary: mds)
   apply simp
   apply (metis cxt_to_stmt.simps(1) eval\<^sub>w.unannotated eval\<^sub>w_simple.skip)
  apply simp
  apply (insert eval\<^sub>w.decl)
  apply (rule cxt_eval)
  apply (rule eval\<^sub>w.decl)
  by auto

lemma skip_eval_elim:
  "\<lbrakk> \<langle>Skip \<otimes> annos, mds, mem\<rangle> \<leadsto> \<langle>c', mds', mem'\<rangle> \<rbrakk> \<Longrightarrow> c' = Stop \<and> mds' = mds \<oplus> annos \<and> mem' = mem"
  apply (rule ccontr)
  apply (insert skip_eval_step deterministic)
  apply clarify
  apply clarsimp
    by metis+

lemma skip_doesnt_read:
  "doesnt_read_or_modify (Skip \<otimes> annos) x"
  apply (rule doesnt_read_annos)
  apply (clarsimp simp: doesnt_read_or_modify_def doesnt_read_or_modify_vars_def)
  by (metis annotate.simps(1) skip_elim skip_eval_step)+

lemma skip_doesnt_write:
  "doesnt_modify (Skip \<otimes> annos) x"
  apply (rule doesnt_modify_annos)
  apply (clarsimp simp: doesnt_modify_def)
  by (metis skip_elim)+

lemma skip_loc_reach:
  "\<lbrakk> \<langle>c', mds', mem'\<rangle> \<in> loc_reach \<langle>Skip \<otimes> annos, mds, mem\<rangle> \<rbrakk> \<Longrightarrow>
  (c' = Stop \<and> mds' = (mds \<oplus> annos)) \<or> (c' = Skip \<otimes> annos \<and> mds' = mds)"
  apply (induct rule: loc_reach.induct)
    apply (metis fst_conv snd_conv)
   apply (metis skip_eval_elim stop_no_eval)
  by metis

lemma skip_doesnt_access:
  "\<lbrakk> lc \<in> loc_reach \<langle>Skip \<otimes> annos, mds, mem\<rangle> ; lc = \<langle>c', mds', mem'\<rangle> \<rbrakk> \<Longrightarrow> doesnt_read_or_modify c' x \<and> doesnt_modify c' x"
  apply (subgoal_tac "(c' = Stop \<and> mds' = (mds \<oplus> annos)) \<or> (c' = Skip \<otimes> annos \<and> mds' = mds)")
   apply (rule conjI, erule disjE)
     apply (simp add: doesnt_read_or_modify_def doesnt_read_or_modify_vars_def stop_no_eval)
    apply (metis (lifting) annotate.simps skip_doesnt_read)
   apply (erule disjE)
    apply (simp add: doesnt_modify_def stop_no_eval)
   apply (metis (lifting) annotate.simps skip_doesnt_write)
  by (metis skip_loc_reach)

lemma assign_doesnt_modify:
  "\<lbrakk> x \<noteq> y; x \<notin> \<C>_vars y \<rbrakk> \<Longrightarrow> doesnt_modify ((x \<leftarrow> e) \<otimes> annos) y"
  apply (rule doesnt_modify_annos)
  apply (simp add: doesnt_modify_def)
  by (metis assign_elim fun_upd_apply dma_\<C>_vars)

lemma assign_annos_eval:
  "\<langle>(x \<leftarrow> e) \<otimes> annos, mds, mem\<rangle> \<leadsto> \<langle>Stop, mds \<oplus> annos, mem (x := ev\<^sub>A mem e)\<rangle>"
  apply (induct annos arbitrary: mds)
   apply (simp only: annotate.simps update_annos.simps)
   apply (rule cxt_eval)
   apply (rule eval\<^sub>w.unannotated)
   apply (rule eval\<^sub>w_simple.assign)
  apply (rule cxt_eval)
  apply (simp del: cxt_to_stmt.simps)
  apply (rule eval\<^sub>w.decl)
  by auto

lemma assign_annos_eval_elim:
  "\<lbrakk> \<langle>(x \<leftarrow> e) \<otimes> annos, mds, mem\<rangle> \<leadsto> \<langle>c', mds', mem'\<rangle> \<rbrakk> \<Longrightarrow>
  c' = Stop \<and> mds' = mds \<oplus> annos"
  apply (rule ccontr)
  apply (insert deterministic assign_annos_eval)
  apply clarsimp
  by (metis (lifting))

lemma mem_upd_commute:
  "\<lbrakk> x \<noteq> y \<rbrakk> \<Longrightarrow> mem (x := v\<^sub>1, y := v\<^sub>2) = mem (y := v\<^sub>2, x := v\<^sub>1)"
  by (metis fun_upd_twist)

lemma assign_doesnt_read:
  "\<lbrakk> y \<noteq> x; y \<notin> aexp_vars e; x \<notin> \<C>_vars y; \<C>_vars y \<inter> aexp_vars e = {} \<rbrakk> \<Longrightarrow> doesnt_read_or_modify ((x \<leftarrow> e) \<otimes> annos) y"
  apply (rule doesnt_read_annos)
proof -
  assume  "y \<noteq> x"
          "y \<notin> aexp_vars e"
          "x \<notin> \<C>_vars y"
          "\<C>_vars y \<inter> aexp_vars e = {}"
  thus "doesnt_read_or_modify (x \<leftarrow> e) y"
    unfolding doesnt_read_or_modify_def doesnt_read_or_modify_vars_def
    apply -
    apply (rule allI)+
    apply (rename_tac mds mem c' mds' mem')
    apply (rule impI)
    apply (subgoal_tac "c' = Stop \<and> mds' = mds \<and> mem' = mem (x := ev\<^sub>A mem e)")
     apply simp
     apply clarify
     apply (rule conjI)
      apply clarify
      apply (subgoal_tac "mem (x := ev\<^sub>A mem e, y := v) = mem (y := v, x := ev\<^sub>A mem e)")
       apply simp
       apply (rule cxt_eval)
       apply (rule eval\<^sub>w.unannotated)
       apply (metis eval\<^sub>w_simple.assign eval_vars_det\<^sub>A fun_upd_apply)
      apply (metis mem_upd_commute)
     apply clarify
     apply (rename_tac va v)
     apply (subgoal_tac "mem (x := ev\<^sub>A mem e, va := v) = mem (va := v, x := ev\<^sub>A mem e)")
      apply simp
      apply (rule cxt_eval)
      apply (rule eval\<^sub>w.unannotated)
      apply (subgoal_tac "va \<notin> aexp_vars e")
       apply (metis eval\<^sub>w_simple.assign eval_vars_det\<^sub>A fun_upd_apply)
      apply blast
     apply (metis mem_upd_commute)
    apply (metis assign_elim)
    done
qed

lemma assign_loc_reach:
  "\<lbrakk> \<langle>c', mds', mem'\<rangle> \<in> loc_reach \<langle>(x \<leftarrow> e) \<otimes> annos, mds, mem\<rangle> \<rbrakk> \<Longrightarrow>
  (c' = Stop \<and> mds' = (mds \<oplus> annos)) \<or> (c' = (x \<leftarrow> e) \<otimes> annos \<and> mds' = mds)"
  apply (induct rule: loc_reach.induct)
    apply simp_all
  by (metis assign_annos_eval_elim stop_no_eval)

lemma if_doesnt_modify:
  "doesnt_modify (If e c\<^sub>1 c\<^sub>2 \<otimes> annos) x"
  apply (rule doesnt_modify_annos)
  by (auto simp: doesnt_modify_def)

lemma vars_eval\<^sub>B:
  "x \<notin> bexp_vars e \<Longrightarrow> ev\<^sub>B mem e = ev\<^sub>B (mem (x := v)) e"
  by (metis (lifting) eval_vars_det\<^sub>B fun_upd_other)

lemma if_doesnt_read:
  "x \<notin> bexp_vars e \<Longrightarrow> \<C>_vars x \<inter> bexp_vars e = {} \<Longrightarrow> doesnt_read_or_modify (If e c\<^sub>1 c\<^sub>2 \<otimes> annos) x"
  apply (rule doesnt_read_annos)
  apply (clarsimp simp: doesnt_read_or_modify_def doesnt_read_or_modify_vars_def, safe)
   apply (rename_tac mds mem c' mds' mem' v)
   apply (case_tac "ev\<^sub>B mem e")
    apply (subgoal_tac "c' = c\<^sub>1 \<and> mds' = mds \<and> mem' = mem")
     prefer 2
     apply auto[1]
    apply clarsimp
    apply (rule cxt_eval)
    apply (rule eval\<^sub>w.unannotated)
    apply (rule eval\<^sub>w_simple.if_true)
    apply (metis (lifting) vars_eval\<^sub>B)
   apply (subgoal_tac "c' = c\<^sub>2 \<and> mds' = mds \<and> mem' = mem")
    prefer 2
    apply auto[1]
   apply clarsimp
   apply (rule cxt_eval)
   apply (rule eval\<^sub>w.unannotated)
   apply (rule eval\<^sub>w_simple.if_false)
   apply (metis (lifting) vars_eval\<^sub>B)
  apply (rename_tac mds mem c' mds' mem' va v)
  apply (case_tac "ev\<^sub>B mem e")
   apply (subgoal_tac "c' = c\<^sub>1 \<and> mds' = mds \<and> mem' = mem")
    prefer 2
    apply auto[1]
   apply clarsimp
   apply (rule cxt_eval)
   apply (rule eval\<^sub>w.unannotated)
   apply (rule eval\<^sub>w_simple.if_true)
   apply (subgoal_tac "va \<notin> bexp_vars e")
    apply (metis (lifting) vars_eval\<^sub>B)
   apply blast
  apply (subgoal_tac "c' = c\<^sub>2 \<and> mds' = mds \<and> mem' = mem")
   prefer 2
   apply auto[1]
  apply clarsimp
  apply (rule cxt_eval)
  apply (rule eval\<^sub>w.unannotated)
  apply (rule eval\<^sub>w_simple.if_false)
  apply (subgoal_tac "va \<notin> bexp_vars e")
   apply (metis (lifting) vars_eval\<^sub>B)
  apply blast
  done

lemma if_eval_true:
  "\<lbrakk> ev\<^sub>B mem e \<rbrakk> \<Longrightarrow>
  \<langle>If e c\<^sub>1 c\<^sub>2 \<otimes> annos, mds, mem\<rangle> \<leadsto> \<langle>c\<^sub>1, mds \<oplus> annos, mem\<rangle>"
  apply (induct annos arbitrary: mds)
   apply simp
   apply (metis cxt_eval eval\<^sub>w.unannotated eval\<^sub>w_simple.if_true)
  by (metis annotate.simps(2) cxt_eval eval\<^sub>w.decl update_annos.simps(2))

lemma if_eval_false:
  "\<lbrakk> \<not> ev\<^sub>B mem e \<rbrakk> \<Longrightarrow>
  \<langle>If e c\<^sub>1 c\<^sub>2 \<otimes> annos, mds, mem\<rangle> \<leadsto> \<langle>c\<^sub>2, mds \<oplus> annos, mem\<rangle>"
  apply (induct annos arbitrary: mds)
   apply simp
   apply (metis cxt_eval eval\<^sub>w.unannotated eval\<^sub>w_simple.if_false)
  by (metis annotate.simps(2) cxt_eval eval\<^sub>w.decl update_annos.simps(2))

lemma if_eval_elim:
  "\<lbrakk> \<langle>If e c\<^sub>1 c\<^sub>2 \<otimes> annos, mds, mem\<rangle> \<leadsto> \<langle>c', mds', mem'\<rangle> \<rbrakk> \<Longrightarrow>
  ((c' = c\<^sub>1 \<and> ev\<^sub>B mem e) \<or> (c' = c\<^sub>2 \<and> \<not> ev\<^sub>B mem e)) \<and> mds' = mds \<oplus> annos \<and> mem' = mem"
  apply (rule ccontr)
  apply (cases "ev\<^sub>B mem e")
   apply (insert if_eval_true deterministic)
   apply blast
  using if_eval_false deterministic
  by blast

lemma if_eval_elim':
  "\<lbrakk> \<langle>If e c\<^sub>1 c\<^sub>2, mds, mem\<rangle> \<leadsto> \<langle>c', mds', mem'\<rangle> \<rbrakk> \<Longrightarrow>
  ((c' = c\<^sub>1 \<and> ev\<^sub>B mem e) \<or> (c' = c\<^sub>2 \<and> \<not> ev\<^sub>B mem e)) \<and> mds' = mds \<and> mem' = mem"
  using if_eval_elim [where annos = "[]"]
  by auto

lemma loc_reach_refl':
  "\<langle>c, mds, mem\<rangle> \<in> loc_reach \<langle>c, mds, mem\<rangle>"
  apply (subgoal_tac "\<exists> lc. lc \<in> loc_reach lc \<and> lc = \<langle>c, mds, mem\<rangle>")
   apply blast
  by (metis loc_reach.refl fst_conv snd_conv)

lemma if_loc_reach:
  "\<lbrakk> \<langle>c', mds', mem'\<rangle> \<in> loc_reach \<langle>If e c\<^sub>1 c\<^sub>2 \<otimes> annos, mds, mem\<rangle> \<rbrakk> \<Longrightarrow>
  (c' = If e c\<^sub>1 c\<^sub>2 \<otimes> annos \<and> mds' = mds) \<or>
  (\<exists> mem''. \<langle>c', mds', mem'\<rangle> \<in> loc_reach \<langle>c\<^sub>1, mds \<oplus> annos, mem''\<rangle>) \<or>
  (\<exists> mem''. \<langle>c', mds', mem'\<rangle> \<in> loc_reach \<langle>c\<^sub>2, mds \<oplus> annos, mem''\<rangle>)"
  apply (induct rule: loc_reach.induct)
    apply (metis fst_conv snd_conv)
   apply (erule disjE)
    apply (erule conjE)
    apply simp
    apply (drule if_eval_elim)
    apply (erule conjE)+
    apply (erule disjE)
     apply (erule conjE)
     apply simp
     apply (metis loc_reach_refl')
    apply (metis loc_reach_refl')
   apply (metis loc_reach.step)
  by (metis loc_reach.mem_diff)

lemma if_loc_reach':
  "\<lbrakk> \<langle>c', mds', mem'\<rangle> \<in> loc_reach \<langle>If e c\<^sub>1 c\<^sub>2, mds, mem\<rangle> \<rbrakk> \<Longrightarrow>
  (c' = If e c\<^sub>1 c\<^sub>2 \<and> mds' = mds) \<or>
  (\<exists> mem''. \<langle>c', mds', mem'\<rangle> \<in> loc_reach \<langle>c\<^sub>1, mds, mem''\<rangle>) \<or>
  (\<exists> mem''. \<langle>c', mds', mem'\<rangle> \<in> loc_reach \<langle>c\<^sub>2, mds, mem''\<rangle>)"
  using if_loc_reach [where annos = "[]"]
  by simp

lemma seq_loc_reach:
  "\<lbrakk> \<langle>c', mds', mem'\<rangle> \<in> loc_reach \<langle>c\<^sub>1 ;; c\<^sub>2, mds, mem\<rangle> \<rbrakk> \<Longrightarrow>
  (\<exists> c''. c' = c'' ;; c\<^sub>2 \<and> \<langle>c'', mds', mem'\<rangle> \<in> loc_reach \<langle>c\<^sub>1, mds, mem\<rangle>) \<or>
  (\<exists> c'' mds'' mem''. \<langle>Stop, mds'', mem''\<rangle> \<in> loc_reach \<langle>c\<^sub>1, mds, mem\<rangle> \<and>
                      \<langle>c', mds', mem'\<rangle> \<in> loc_reach \<langle>c\<^sub>2, mds'', mem''\<rangle>)"
  apply (induct rule: loc_reach.induct)
    apply simp
    apply (metis  loc_reach_refl')
   apply simp
   apply (metis (no_types) loc_reach.step loc_reach_refl' seq_elim seq_stop_elim)
  by (metis (lifting) loc_reach.mem_diff)

lemma seq_doesnt_read:
  "\<lbrakk> doesnt_read_or_modify c x \<rbrakk> \<Longrightarrow> doesnt_read_or_modify (c ;; c') x"
  apply (clarsimp simp: doesnt_read_or_modify_def doesnt_read_or_modify_vars_def | safe)+
   apply (rename_tac mds mem c'a mds' mem' v)
   apply (case_tac "c = Stop")
    apply clarsimp
    apply (subgoal_tac "c'a = c' \<and> mds' = mds \<and> mem' = mem")
     apply simp
     apply (metis cxt_eval eval\<^sub>w.unannotated eval\<^sub>w_simple.seq_stop)
    apply (metis (lifting) seq_stop_elim)
   apply (metis (lifting, no_types) eval\<^sub>w.seq seq_elim)
  apply (rename_tac mds mem c'a mds' mem' va v)
  apply (case_tac "c = Stop")
   apply clarsimp
   apply (subgoal_tac "c'a = c' \<and> mds' = mds \<and> mem' = mem")
    apply simp
    apply (metis cxt_eval eval\<^sub>w.unannotated eval\<^sub>w_simple.seq_stop)
   apply (metis (lifting) seq_stop_elim)
  apply (metis (lifting, no_types) eval\<^sub>w.seq seq_elim)
  done

lemma seq_split:
  "\<lbrakk> \<langle>Stop, mds', mem'\<rangle> \<in> loc_reach \<langle>c\<^sub>1 ;; c\<^sub>2, mds, mem\<rangle> \<rbrakk> \<Longrightarrow>
  \<exists> mds'' mem''. \<langle>Stop, mds'', mem''\<rangle> \<in> loc_reach \<langle>c\<^sub>1, mds, mem\<rangle> \<and>
                 \<langle>Stop, mds', mem'\<rangle> \<in> loc_reach \<langle>c\<^sub>2, mds'', mem''\<rangle>"
  apply (drule seq_loc_reach)
  by (metis Stmt.simps(49))

lemma while_eval:
  "\<langle>While e c \<otimes> annos, mds, mem\<rangle> \<leadsto> \<langle>(If e (c ;; While e c) Stop), mds \<oplus> annos, mem\<rangle>"
  apply (induct annos arbitrary: mds)
   apply simp
   apply (rule cxt_eval)
   apply (rule eval\<^sub>w.unannotated)
   apply (metis (lifting) eval\<^sub>w_simple.while)
  apply simp
  by (metis cxt_eval eval\<^sub>w.decl)

lemma while_eval':
  "\<langle>While e c, mds, mem\<rangle> \<leadsto> \<langle>If e (c ;; While e c) Stop, mds, mem\<rangle>"
  using while_eval [where annos = "[]"]
  by auto

lemma while_eval_elim:
  "\<lbrakk> \<langle>While e c \<otimes> annos, mds, mem\<rangle> \<leadsto> \<langle>c', mds', mem'\<rangle> \<rbrakk> \<Longrightarrow>
   (c' = If e (c ;; While e c) Stop \<and> mds' = mds \<oplus> annos \<and> mem' = mem)"
  apply (rule ccontr)
  apply (insert while_eval deterministic)
  by blast

lemma while_eval_elim':
  "\<lbrakk> \<langle>While e c, mds, mem\<rangle> \<leadsto> \<langle>c', mds', mem'\<rangle> \<rbrakk> \<Longrightarrow>
   (c' = If e (c ;; While e c) Stop \<and> mds' = mds \<and> mem' = mem)"
  using while_eval_elim [where annos = "[]"]
  by auto

lemma while_doesnt_read:
  "\<lbrakk> x \<notin> bexp_vars e \<rbrakk> \<Longrightarrow> doesnt_read_or_modify (While e c \<otimes> annos) x"
  unfolding doesnt_read_or_modify_def doesnt_read_or_modify_vars_def
  using while_eval while_eval_elim
  by metis

lemma while_doesnt_modify:
  "doesnt_modify (While e c \<otimes> annos) x"
  unfolding doesnt_modify_def
  using while_eval_elim
  by metis

(* TODO: try to find a better solution to this: *)
lemma disjE3:
  "\<lbrakk> A \<or> B \<or> C ; A \<Longrightarrow> P ; B \<Longrightarrow> P ; C \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  by auto

lemma disjE5:
  "\<lbrakk> A \<or> B \<or> C \<or> D \<or> E ; A \<Longrightarrow> P ; B \<Longrightarrow> P ; C \<Longrightarrow> P ; D \<Longrightarrow> P ; E \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  by auto

lemma if_doesnt_read':
  "x \<notin> bexp_vars e \<Longrightarrow> \<C>_vars x \<inter> bexp_vars e = {} \<Longrightarrow> doesnt_read_or_modify (If e c\<^sub>1 c\<^sub>2) x"
  using if_doesnt_read [where annos = "[]"]
  by auto

theorem mode_type_sound:
  assumes typeable: "\<turnstile> mds\<^sub>1 { c } mds\<^sub>1'"
  assumes mode_le: "mds\<^sub>2 \<le> mds\<^sub>1"
  shows "\<forall> mem. (\<langle>Stop, mds\<^sub>2', mem'\<rangle> \<in> loc_reach \<langle>c, mds\<^sub>2, mem\<rangle> \<longrightarrow> mds\<^sub>2' \<le> mds\<^sub>1') \<and>
                locally_sound_mode_use \<langle>c, mds\<^sub>2, mem\<rangle>"
  using typeable mode_le
proof (induct arbitrary: mds\<^sub>2 mds\<^sub>2' mem' mem rule: mode_type.induct)
  case (skip mds annos)
  thus ?case
    apply (clarsimp, intro conjI)
     apply (metis (lifting) skip_eval_step skip_loc_reach stop_no_eval update_preserves_le)
    apply (simp add: locally_sound_mode_use_def)
    by (metis annotate.simps skip_doesnt_access)
next
  case (assign x mds e annos)
  hence "\<forall> mem. locally_sound_mode_use \<langle>(x \<leftarrow> e) \<otimes> annos, mds\<^sub>2, mem\<rangle>"
    unfolding locally_sound_mode_use_def
  proof (clarify)
    fix mem c' mds' mem' y
    assume asm: "\<langle>c', mds', mem'\<rangle> \<in> loc_reach \<langle>(x \<leftarrow> e) \<otimes> annos, mds\<^sub>2, mem\<rangle>"
    hence "c' = (x \<leftarrow> e) \<otimes> annos \<and> mds' = mds\<^sub>2 \<or> c' = Stop \<and> mds' = mds\<^sub>2 \<oplus> annos"
      using assign_loc_reach by blast
    thus "(y \<in> mds' GuarNoReadOrWrite \<longrightarrow> doesnt_read_or_modify c' y) \<and>
          (y \<in> mds' GuarNoWrite \<longrightarrow> doesnt_modify c' y)"
    proof
      assume "c' = (x \<leftarrow> e) \<otimes> annos \<and> mds' = mds\<^sub>2"
      thus ?thesis
      proof (safe)
        assume nin: "y \<in> mds\<^sub>2 GuarNoReadOrWrite"
        hence nin: "y \<in> mds GuarNoReadOrWrite"
          using assign.prems unfolding le_fun_def by blast
        hence "y \<notin> aexp_vars e"
          by (metis IntD2 IntI assign.hyps(2) assign.prems empty_iff inf_apply le_iff_inf)
        moreover from nin assign.hyps(3) have "\<C>_vars y \<inter> aexp_vars e = {}"
          by (meson contra_subsetD)
        moreover from nin assign.hyps have "x \<notin> \<C>_vars y \<and> x \<noteq> y"
          by blast
        ultimately show "doesnt_read_or_modify ((x \<leftarrow> e) \<otimes> annos) y"
          using assign_doesnt_read
          by fastforce
      next
        assume "y \<in> mds\<^sub>2 GuarNoWrite"
        hence nin: "y \<in> mds GuarNoWrite"
          using assign.prems unfolding le_fun_def by blast
        hence "x \<noteq> y \<and> x \<notin> \<C>_vars y"
          using assign by blast
        with assign_doesnt_modify show "doesnt_modify ((x \<leftarrow> e) \<otimes> annos) y"
          by blast
      qed
    next
      assume "c' = Stop \<and> mds' = mds\<^sub>2 \<oplus> annos"
      with stop_doesnt_access show ?thesis by blast
    qed
  qed
  thus ?case
    apply clarsimp
    by (metis assign.prems assign_annos_eval assign_loc_reach stop_no_eval update_preserves_le)
next
  case (if_ mds annos c\<^sub>1 mds'' c\<^sub>2 e)
    let ?c = "(If e c\<^sub>1 c\<^sub>2) \<otimes> annos"
  from if_ have modes_le': "mds\<^sub>2 \<oplus> annos \<le> mds \<oplus> annos"
    by (metis (lifting) update_preserves_le)
  from if_ show ?case
    apply (simp add: locally_sound_mode_use_def)
    apply clarify
    apply (rule conjI)
     apply clarify
     prefer 2
     apply clarify
  proof -
    fix mem
    assume "\<langle>Stop, mds\<^sub>2', mem'\<rangle> \<in> loc_reach \<langle>If e c\<^sub>1 c\<^sub>2 \<otimes> annos, mds\<^sub>2, mem\<rangle>"
    with modes_le' and if_ show "mds\<^sub>2' \<le> mds''"
      by (metis if_eval_false if_eval_true if_loc_reach stop_no_eval)
  next
    fix mem c' mds' mem' x
    assume "\<langle>c', mds', mem'\<rangle> \<in> loc_reach \<langle>If e c\<^sub>1 c\<^sub>2 \<otimes> annos, mds\<^sub>2, mem\<rangle>"
    hence "(c' = If e c\<^sub>1 c\<^sub>2 \<otimes> annos \<and> mds' = mds\<^sub>2) \<or>
           (\<exists> mem''. \<langle>c', mds', mem'\<rangle> \<in> loc_reach \<langle>c\<^sub>1, mds\<^sub>2 \<oplus> annos, mem''\<rangle>) \<or>
           (\<exists> mem''. \<langle>c', mds', mem'\<rangle> \<in> loc_reach \<langle>c\<^sub>2, mds\<^sub>2 \<oplus> annos, mem''\<rangle>)"
      using if_loc_reach by blast
    thus "(x \<in> mds' GuarNoReadOrWrite \<longrightarrow> doesnt_read_or_modify c' x) \<and>
          (x \<in> mds' GuarNoWrite \<longrightarrow> doesnt_modify c' x)"
    proof
      assume "c' = If e c\<^sub>1 c\<^sub>2 \<otimes> annos \<and> mds' = mds\<^sub>2"
      thus ?thesis
      proof (safe)
        assume "x \<in> mds\<^sub>2 GuarNoReadOrWrite"
        hence nin: "x \<in> mds GuarNoReadOrWrite"
          using if_ unfolding le_fun_def by auto
        with \<open>bexp_vars e \<inter> mds GuarNoReadOrWrite = {}\<close> have "x \<notin> bexp_vars e"
          by (metis IntD2 disjoint_iff_not_equal)
        moreover from if_(6) nin have "\<C>_vars x \<inter> bexp_vars e = {}"
          by blast
        ultimately show "doesnt_read_or_modify (If e c\<^sub>1 c\<^sub>2 \<otimes> annos) x"
          using if_doesnt_read by blast
      next
        assume "x \<in> mds\<^sub>2 GuarNoWrite"
        thus "doesnt_modify (If e c\<^sub>1 c\<^sub>2 \<otimes> annos) x"
          using if_doesnt_modify by blast
      qed
    next
      assume "(\<exists>mem''. \<langle>c', mds', mem'\<rangle> \<in> loc_reach \<langle>c\<^sub>1, mds\<^sub>2 \<oplus> annos, mem''\<rangle>) \<or>
              (\<exists>mem''. \<langle>c', mds', mem'\<rangle> \<in> loc_reach \<langle>c\<^sub>2, mds\<^sub>2 \<oplus> annos, mem''\<rangle>)"
      with if_ show ?thesis
        by (metis locally_sound_mode_use_def modes_le')
    qed
  qed
next
  case (while mdsa mds annos c e)
  hence "mds\<^sub>2 \<oplus> annos \<le> mds \<oplus> annos"
    by (metis (lifting) update_preserves_le)
  have while_loc_reach: "\<And> c' mds' mem' mem.
  \<langle>c', mds', mem'\<rangle> \<in> loc_reach \<langle>While e c \<otimes> annos, mds\<^sub>2, mem\<rangle> \<Longrightarrow>
  c' = While e c \<otimes> annos \<and> mds' = mds\<^sub>2 \<or>
  c' = While e c \<and> mds' \<le> mdsa \<or>
  c' = Stmt.If e (c ;; While e c) Stop \<and> mds' \<le> mdsa \<or>
  c' = Stop \<and> mds' \<le> mdsa \<or>
  (\<exists>c'' mem'' mds\<^sub>3.
      c' = c'' ;; While e c \<and>
      mds\<^sub>3 \<le> mdsa \<and> \<langle>c'', mds', mem'\<rangle> \<in> loc_reach \<langle>c, mds\<^sub>3, mem''\<rangle>)"
  proof -
    fix mem c' mds' mem'
    assume "\<langle>c', mds', mem'\<rangle> \<in> loc_reach \<langle>While e c \<otimes> annos, mds\<^sub>2, mem\<rangle>"
    thus "?thesis c' mds' mem' mem"
      apply (induct rule: loc_reach.induct)
        apply simp_all
       apply (erule disjE)
        apply simp
        apply (metis \<open>mds\<^sub>2 \<oplus> annos \<le> mds \<oplus> annos\<close> while.hyps(1) while_eval_elim)
       apply (erule disjE)
        apply (metis while_eval_elim')
       apply (erule disjE)
        apply simp
        apply (metis if_eval_elim' loc_reach_refl')
       apply (erule disjE)
        apply (metis stop_no_eval)
       apply (erule exE)
       apply (rename_tac c' mds' mem' c'' mds'' mem'' c''a)
       apply (case_tac "c''a = Stop")
        apply (insert while.hyps(3))
        apply (metis seq_stop_elim while.hyps(3))
       apply (metis loc_reach.step seq_elim)
      by (metis (full_types) loc_reach.mem_diff)
  qed
  from while show ?case
  proof (safe)
    fix mem
    assume "\<langle>Stop, mds\<^sub>2', mem'\<rangle> \<in> loc_reach \<langle>While e c \<otimes> annos, mds\<^sub>2, mem\<rangle>"
    thus "mds\<^sub>2' \<le> mds \<oplus> annos"
      by (metis Stmt.distinct(35) Stmt.distinct(43) annotate.elims update_annos.simps(1) while.hyps(1) while.prems while_loc_reach)
  next
    fix mem
    from while have a: "bexp_vars e \<inter> (mds\<^sub>2 \<oplus> annos) GuarNoReadOrWrite = {}"
      by (metis (lifting, no_types) Int_empty_right Int_left_commute \<open>mds\<^sub>2 \<oplus> annos \<le> mds \<oplus> annos\<close> inf_fun_def le_iff_inf)
    from while have b: "\<forall>v.  \<C>_vars v \<inter> bexp_vars e \<noteq> {} \<longrightarrow> v \<notin> (mds\<^sub>2 \<oplus> annos) GuarNoReadOrWrite"
      by (meson \<open>mds\<^sub>2 \<oplus> annos \<le> mds \<oplus> annos\<close> le_fun_def subsetCE)
    show "locally_sound_mode_use \<langle>While e c \<otimes> annos, mds\<^sub>2, mem\<rangle>"
      unfolding locally_sound_mode_use_def
      apply (rule allI)+
      apply (rule impI)
    proof -
      fix c' mds' mem'
      define lc where "lc = \<langle>While e c \<otimes> annos, mds\<^sub>2, mem\<rangle>"
      assume "\<langle>c', mds', mem'\<rangle> \<in> loc_reach lc"
      thus "\<forall>x. (x \<in> mds' GuarNoReadOrWrite \<longrightarrow> doesnt_read_or_modify c' x) \<and>
                 (x \<in> mds' GuarNoWrite \<longrightarrow> doesnt_modify c' x)"
        apply (simp add: lc_def)
        apply (drule while_loc_reach)
        apply (rule allI)
        apply (erule disjE5)
      proof (clarsimp)
        fix x
        show "(x \<in> mds\<^sub>2 GuarNoReadOrWrite \<longrightarrow> doesnt_read_or_modify (While e c \<otimes> annos) x) \<and>
              (x \<in> mds\<^sub>2 GuarNoWrite \<longrightarrow> doesnt_modify (While e c \<otimes> annos) x)"
          unfolding doesnt_read_or_modify_def doesnt_read_or_modify_vars_def and doesnt_modify_def
          using while_eval and while_eval_elim
          by blast
      next
        fix x
        assume a: "c' = Stmt.If e (c ;; While e c) Stop \<and> mds' \<le> mdsa"
        hence "mds' \<le> mdsa" by blast
        let ?c' = "If e (c ;; While e c) Stop"
        have "x \<in> mds' GuarNoReadOrWrite \<longrightarrow> doesnt_read_or_modify ?c' x"
          apply clarify
          apply (rule if_doesnt_read')
           apply (metis IntI \<open>mds' \<le> mdsa\<close> empty_iff le_fun_def rev_subsetD while.hyps(1) while.hyps(4))
          by (metis IntI \<open>mds' \<le> mdsa\<close> empty_iff le_fun_def rev_subsetD while.hyps(1) while.hyps(5))
        moreover
        have "x \<in> mds' GuarNoWrite \<longrightarrow> doesnt_modify ?c' x"
          by (metis annotate.simps(1) if_doesnt_modify)
        ultimately show "(x \<in> mds' GuarNoReadOrWrite \<longrightarrow> doesnt_read_or_modify c' x) \<and>
                         (x \<in> mds' GuarNoWrite \<longrightarrow> doesnt_modify c' x)"
          using a by simp
      next
        fix x
        assume "c' = Stop \<and> mds' \<le> mdsa"
        thus "(x \<in> mds' GuarNoReadOrWrite \<longrightarrow> doesnt_read_or_modify c' x) \<and>
              (x \<in> mds' GuarNoWrite \<longrightarrow> doesnt_modify c' x)"
          by (simp, metis stop_doesnt_access)
      next
        fix x
        assume "\<exists>c'' mem'' mds\<^sub>3.
            c' = c'' ;; While e c \<and>
            mds\<^sub>3 \<le> mdsa \<and>
            \<langle>c'', mds', mem'\<rangle>
            \<in> loc_reach \<langle>c, mds\<^sub>3, mem''\<rangle>"
        from this obtain
         c'' mem'' mds\<^sub>3
        where "mds\<^sub>3 \<le> mdsa" and [simp]: "c' = c'' ;; While e c"
        and "\<langle>c'', mds', mem'\<rangle> \<in> loc_reach \<langle>c, mds\<^sub>3, mem''\<rangle>" by blast
        thus "(x \<in> mds' GuarNoReadOrWrite \<longrightarrow> doesnt_read_or_modify c' x) \<and>
              (x \<in> mds' GuarNoWrite \<longrightarrow> doesnt_modify c' x)"
          apply (clarsimp, safe)
           apply (rule seq_doesnt_read)
           apply (insert while(3))
           apply (metis \<open>mds\<^sub>3 \<le> mdsa\<close> locally_sound_mode_use_def while.hyps(1))
          apply (rule seq_doesnt_modify)
          by (metis \<open>mds\<^sub>3 \<le> mdsa\<close> locally_sound_mode_use_def while.hyps(1))
      next
        fix x
        assume "c' = While e c \<and> mds' \<le> mdsa"
        thus "(x \<in> mds' GuarNoReadOrWrite \<longrightarrow> doesnt_read_or_modify c' x) \<and>
              (x \<in> mds' GuarNoWrite \<longrightarrow> doesnt_modify c' x)"
          unfolding doesnt_read_or_modify_def doesnt_read_or_modify_vars_def and doesnt_modify_def
          using while_eval' and while_eval_elim'
          by blast
      qed
    qed
  qed
next
  case (seq mds c\<^sub>1 mds' c\<^sub>2 mds'')
  thus ?case
  proof (safe)
    fix mem
    assume "\<langle>Stop, mds\<^sub>2', mem'\<rangle> \<in> loc_reach \<langle>c\<^sub>1 ;; c\<^sub>2, mds\<^sub>2, mem\<rangle>"
    then obtain mds\<^sub>2'' mem'' where "\<langle>Stop, mds\<^sub>2'', mem''\<rangle> \<in> loc_reach \<langle>c\<^sub>1, mds\<^sub>2, mem\<rangle>" and
      "\<langle>Stop, mds\<^sub>2', mem'\<rangle> \<in> loc_reach \<langle>c\<^sub>2, mds\<^sub>2'', mem''\<rangle>"
      using seq_split by blast
    thus "mds\<^sub>2' \<le> mds''"
      using seq by blast
  next
    fix mem
    from seq show "locally_sound_mode_use \<langle>c\<^sub>1 ;; c\<^sub>2, mds\<^sub>2, mem\<rangle>"
      apply (simp add: locally_sound_mode_use_def)
      apply clarify
      apply (drule seq_loc_reach)
      apply (erule disjE)
       apply (metis seq_doesnt_modify seq_doesnt_read)
      by metis
  qed
next
  case (sub mds\<^sub>2'' c mds\<^sub>2' mds\<^sub>1 mds\<^sub>1' c\<^sub>1)
  thus ?case
    apply clarsimp
    by (metis (hide_lams, no_types) inf_absorb2 le_infI1)
qed

end

end


section \<open>Options and Maps with Default Value for None\<close>
theory Array_Map_Default
imports Dynamic_Array DRAT_Misc
begin
  text \<open>Implements maps from natural numbers to any value type that has an
    unused default value in its implementation type.
    Internally, uses a dynamic array.
    \<close>
  definition "is_unused_elem dflt A \<equiv> \<forall>x. A x dflt = false"
  lemma is_unused_elem_pure[simp]:
    "is_unused_elem dflt (pure R) \<longleftrightarrow> dflt \<notin> Domain R"
    unfolding is_unused_elem_def
    by (auto simp: pure_rel_eq_false_iff)

  definition "dflt_option_rel_aux dflt
    \<equiv> { (dflt,None) } \<union> { (x, Some x) | x. x\<noteq>dflt }"
  definition [to_relAPP]: "dflt_option_assn dflt A
    \<equiv> pure (dflt_option_rel_aux dflt O \<langle>the_pure A\<rangle>option_rel)"

  subsection \<open>Function-Level Map Operations\<close>
  text \<open>We justify the map operations implemented by a function\<close>
  lemma amd1_empty_refine:
    "(uncurry0 (\<lambda>_. dflt), uncurry0 op_map_empty)
    \<in> Id \<rightarrow>\<^sub>f (Id \<rightarrow> dflt_option_rel_aux dflt)"
    by (auto simp: dflt_option_rel_aux_def fref_def)

  lemma amd1_lookup_refine:
    "(\<lambda>x f. f x, op_map_lookup)
    \<in> Id \<rightarrow> (Id \<rightarrow> dflt_option_rel_aux dflt) \<rightarrow> dflt_option_rel_aux dflt"
    apply simp by parametricity

  lemma amd1_update_refine:
    "(uncurry2 (\<lambda>k v f. f(k:=v)), uncurry2 op_map_update)
    \<in> [\<lambda>((k,v),m). v\<noteq>dflt]\<^sub>f
      ((Id \<times>\<^sub>r Id) \<times>\<^sub>r (Id \<rightarrow> dflt_option_rel_aux dflt))
      \<rightarrow> (Id \<rightarrow> dflt_option_rel_aux dflt)"
    unfolding op_map_update_def
    apply (rule frefI)
    apply auto
    applyS (auto simp: dflt_option_rel_aux_def)
    applyS (parametricity; simp)
    done

  definition [simp]: "amd1_delete dflt k f \<equiv> fun_upd f k dflt"
  lemma amd1_delete_refine:
    "(uncurry (amd1_delete dflt), uncurry op_map_delete)
    \<in> Id \<times>\<^sub>r (Id \<rightarrow> dflt_option_rel_aux dflt) \<rightarrow>\<^sub>f (Id \<rightarrow> dflt_option_rel_aux dflt)"
    unfolding op_map_delete_def PR_CONST_def amd1_delete_def
    apply (rule frefI)
    apply parametricity
    apply (auto simp: dflt_option_rel_aux_def)
    done

  subsection \<open>Map Operations, array-level\<close>
  text \<open>We use dynamic arrays to implement the function, and combine both to
      implement the map interface.\<close>
  definition [code_unfold]: "amd_empty dflt \<equiv> dyn_array_new_sz dflt 16"
  definition [code_unfold]: "amd_lookup dflt k a \<equiv> array_get_dyn dflt a k"
  definition [code_unfold]: "amd_update dflt k v a \<equiv> array_set_dyn dflt a k v"
  definition [code_unfold]: "amd_delete dflt k a \<equiv> array_set_dyn dflt a k dflt"

  definition "amd_assn dflt K V
    \<equiv> hr_comp (hr_comp
        (is_nff dflt)
        (nat_rel \<rightarrow>\<^sub>f dflt_option_rel_aux dflt))
        (\<langle>the_pure K, the_pure V\<rangle>map_rel)"

  lemma amd_assn_fold2: "hr_comp (hr_comp
      (is_nff dflt)
      (nat_rel \<rightarrow> dflt_option_rel_aux dflt))
      (\<langle>the_pure K, the_pure V\<rangle>map_rel)
    = amd_assn dflt K V"
    unfolding amd_assn_def
    apply (fo_rule fun_cong arg_cong)+
    unfolding fref_def fun_rel_def by auto

  (* TODO: Move *)
  lemmas [intf_of_assn]
    = intf_of_assnI[where R="amd_assn dflt K V"
                      and 'a="(nat,'vv) i_map" for dflt K V]

  lemmas [safe_constraint_rules]
    = CN_FALSEI[of is_pure "amd_assn dflt K V" for dflt K V]

context
  notes [fcomp_norm_unfold] =
    amd_assn_def[symmetric] dflt_option_assn_def[symmetric] amd_assn_fold2
  notes [intro!] = hfrefI hn_refineI[THEN hn_refine_preI]
  notes [simp] = pure_def hn_ctxt_def invalid_assn_def
  fixes dflt :: "'a::heap"
begin
  lemma amd2_empty_refine:
    "(uncurry0 (amd_empty dflt), uncurry0 (RETURN (\<lambda>_. dflt)))
    \<in> unit_assn\<^sup>k \<rightarrow>\<^sub>a is_nff dflt"
    by (sep_auto simp: amd_empty_def)

  lemma amd2_lookup_refine:
    "(uncurry (amd_lookup dflt), uncurry (RETURN oo (\<lambda>x f. f x)))
    \<in> id_assn\<^sup>k*\<^sub>a(is_nff dflt)\<^sup>k \<rightarrow>\<^sub>a id_assn"
    by (sep_auto simp: amd_lookup_def)

  lemma amd2_update_refine:
    "(uncurry2 (amd_update dflt), uncurry2 (RETURN ooo (\<lambda>k v f. f(k:=v))))
    \<in> id_assn\<^sup>k*\<^sub>aid_assn\<^sup>k*\<^sub>a(is_nff dflt)\<^sup>d \<rightarrow>\<^sub>a is_nff dflt"
    by (sep_auto simp: amd_update_def)

  lemma amd2_delete_refine:
    "(uncurry (amd_delete dflt), uncurry (RETURN oo (amd1_delete dflt)))
    \<in> id_assn\<^sup>k*\<^sub>a(is_nff dflt)\<^sup>d \<rightarrow>\<^sub>a is_nff dflt"
    by (sep_auto simp: amd_delete_def)

  sepref_decl_impl (no_register) amd_empty:
    amd2_empty_refine[FCOMP amd1_empty_refine[where dflt=dflt]] .

  definition [simp]: "op_amd_empty \<equiv> op_map_empty"

  sepref_decl_impl
    amd2_lookup_refine[FCOMP amd1_lookup_refine[where dflt=dflt]] .
  sepref_decl_impl
    amd2_delete_refine[FCOMP amd1_delete_refine[where dflt=dflt]] .

  text \<open>The only complication arises for the update operation, where we have
    to use the fact that the default element is invalid, which forces us to do
    a manual composition proof.\<close>
  lemma amd2_update_hnr_aux:
    assumes "CONSTRAINT (IS_PURE single_valued) K"
      and "CONSTRAINT (IS_PURE IS_LEFT_UNIQUE) K"
      and "CONSTRAINT is_pure V"
      and "CONSTRAINT (is_unused_elem dflt) V"
    shows "(uncurry2 (amd_update dflt), uncurry2 (RETURN \<circ>\<circ>\<circ> op_map_update))
           \<in>  K\<^sup>k *\<^sub>a V\<^sup>k *\<^sub>a (amd_assn dflt K V)\<^sup>d \<rightarrow>\<^sub>a amd_assn dflt K V"
    apply (rule
        hfref_cons[
          OF amd2_update_refine[
                FCOMP amd1_update_refine[where dflt=dflt],
                FCOMP (no_prenorm) op_map_update.fref, of K V]])
    subgoal using assms by (simp add: IS_PURE_def)
    subgoal using assms by (simp add: IS_PURE_def)
    subgoal using assms by (simp add: IS_PURE_def)
    subgoal using assms by (simp add: IS_PURE_def IS_LEFT_UNIQUE_def)
    subgoal
      using assms
      by (auto
          simp del: pure_def
          simp: comp_PRE_def IS_PURE_def is_unused_elem_def is_pure_conv
          simp: pure_rel_eq_false_iff
          elim!: prod_relE)
    applyS simp
    applyS simp
    applyS simp
    done

  (* TODO: Somewhat of a hack. Perhaps add a flag to switch of
      automatic parameterization on sepref_decl_impl? *)
  private lemma op_map_update_id_param:
    "(uncurry2 (RETURN \<circ>\<circ>\<circ> op_map_update), uncurry2 (RETURN \<circ>\<circ>\<circ> op_map_update))
    \<in> (Id\<times>\<^sub>rId)\<times>\<^sub>rId \<rightarrow>\<^sub>f \<langle>Id\<rangle>nres_rel"
    by (simp add: fref_def nres_rel_def)

  sepref_decl_impl amd2_update_hnr_aux uses op_map_update_id_param .

end

interpretation amd: map_custom_empty op_amd_empty apply unfold_locales by auto
lemmas [sepref_fr_rules] = amd_empty_hnr[folded op_amd_empty_def]

subsection \<open>Operations on Options\<close>

text \<open>We give own names to constructors, otherwise, we will get confusions
  with the default option refinement.\<close>
definition [simp]: "dflt_None \<equiv> None"
definition [simp]: "dflt_Some \<equiv> Some"
sepref_register dflt_None dflt_Some

lemma doa_None_hnr:
  "(uncurry0 (return dflt), uncurry0 (RETURN dflt_None))
  \<in> unit_assn\<^sup>k \<rightarrow>\<^sub>a dflt_option_assn dflt A"
  apply (sepref_to_hoare)
  apply (sep_auto simp: pure_def dflt_option_rel_aux_def dflt_option_assn_def)
  done

lemma doa_Some_hnr: "\<lbrakk>CONSTRAINT (is_unused_elem dflt) A; CONSTRAINT is_pure A\<rbrakk>
  \<Longrightarrow> (return o (\<lambda>x. x), RETURN o dflt_Some) \<in> A\<^sup>k \<rightarrow>\<^sub>a dflt_option_assn dflt A"
  apply (sepref_to_hoare)
  apply (clarsimp simp: is_pure_conv dflt_option_assn_def)
  apply (sep_auto simp: pure_def)
  apply (fastforce simp: dflt_option_rel_aux_def)
  done

lemma doa_is_None_hnr[sepref_fr_rules]:
  "(return o ((=) dflt), RETURN o is_None)
  \<in> (dflt_option_assn dflt A)\<^sup>k \<rightarrow>\<^sub>a bool_assn"
  apply (sepref_to_hoare)
  by (sep_auto
        simp: dflt_option_assn_def pure_def dflt_option_rel_aux_def
        split: option.split)

lemma doa_the_hnr[sepref_fr_rules]: "\<lbrakk>CONSTRAINT is_pure A\<rbrakk>
  \<Longrightarrow> (return o (\<lambda>x. x), RETURN o the)
      \<in> [\<lambda>x. x\<noteq>None]\<^sub>a (dflt_option_assn dflt A)\<^sup>k \<rightarrow> A"
  apply (sepref_to_hoare)
  apply (clarsimp simp: is_pure_conv dflt_option_assn_def)
  apply (sep_auto simp: pure_def dflt_option_rel_aux_def)
  done

(* TODO: Add proper rule for case distinction *)

(* Workaround for case-distinction: Rewrite with abstract-level rule: *)
lemma cnv_option_case_2_if: "(case x of None \<Rightarrow> fn | Some v \<Rightarrow> fv v)
  \<longleftrightarrow> (if is_None x then fn else fv (the x))" by (cases x) auto

(* TODO: Hack:
  Due to lack of recursive generic algorithms with specialization,
  we have instantiated equality on options as combinator rule.
  This allows no backtracking or alternatives.
  Thus, we do a type-based rewriting of option-equalities for dflt-option
  types in operator-id phase.
*)
definition [simp]: "dflt_option_eq \<equiv> (=)"

locale dflt_option =
  fixes A :: "'a \<Rightarrow> 'c \<Rightarrow> assn"
  fixes dflt :: "'c"
  fixes eq :: "'c \<Rightarrow> 'c \<Rightarrow> bool Heap"
  assumes unused_dflt[safe_constraint_rules]: "(is_unused_elem dflt) A"

  assumes eq_op: "(uncurry eq, uncurry (RETURN oo (=))) \<in> A\<^sup>k*\<^sub>aA\<^sup>k\<rightarrow>\<^sub>abool_assn"
  assumes eq_dflt: "\<And>a b. \<lbrakk> a=dflt \<or> b=dflt \<rbrakk> \<Longrightarrow> <emp> eq a b <\<lambda>r. \<up>(r \<longleftrightarrow> a=b)>\<^sub>t"
begin
  (* Type-based rewrites.
      TODO: We would prefer type-based specializations in translate-phase! *)
  lemma fold_dflt_option[def_pat_rules]:
    "(None::'a option) \<equiv> dflt_None"
    "(Some::'a\<Rightarrow>_) \<equiv> dflt_Some"
    "((=)::'a option \<Rightarrow> _) \<equiv> dflt_option_eq"
     by auto

  (* Constructors *)
  lemmas [sepref_fr_rules] =
    doa_None_hnr[where dflt = dflt and A=A]
    doa_Some_hnr[where dflt = dflt and A=A]

  lemma eq_option_refine[sepref_fr_rules]:
    assumes "CONSTRAINT is_pure A"
    shows "(uncurry eq,uncurry (RETURN oo dflt_option_eq))
      \<in> (dflt_option_assn dflt A)\<^sup>k *\<^sub>a (dflt_option_assn dflt A)\<^sup>k \<rightarrow>\<^sub>a bool_assn"
  proof -
    from assms obtain R where [simp]: "A = pure R" by (auto simp: is_pure_conv)

    from eq_op have [sep_heap_rules]:
      "\<lbrakk> (x,x')\<in>R; (y,y')\<in>R \<rbrakk>
      \<Longrightarrow> <emp> eq x y <\<lambda>r. \<up>(r \<longleftrightarrow> x'=y')>\<^sub>t" for x x' y y'
      apply (drule_tac hfrefD[where a="(x',y')" and c="(x,y)"])
      apply simp
      apply (drule hn_refineD)
      apply simp
      apply (sep_auto simp: pure_def)
      apply (rule Hoare_Triple.cons_post_rule)
      apply assumption
      apply sep_auto
      done

    note [simplified,sep_heap_rules]
      = eq_dflt[of dflt dflt] eq_dflt[of dflt] eq_dflt[of _ dflt]

    show ?thesis
      apply sepref_to_hoare
      apply (simp add: dflt_option_assn_def)
      apply (auto simp: pure_def dflt_option_rel_aux_def elim!: option_relE)
      apply (sep_auto)
      apply (sep_auto)
      apply (sep_auto)
      apply (sep_auto)
      done
  qed

end

end


theory FurtherLogicExperimental
imports DerivedConstructions Frac BaseLogicDeepExperimental2 Namespace "../HeapLang/PrimitiveLaws"
  "../SpanningTree/SpanningTreeCameras" "../HeapLang/State"
begin

datatype inv = Inv "(name, iprop later) map_view \<times> name dset \<times> name dfset"
  and iprop = iProp (pred: "(graphUR auth \<times> markingUR auth \<times> inv \<times> heap_lang_heap) cmra_pred")

instance inv :: ucamera sorry
instance iprop :: ofe sorry

declare [[coercion pred, coercion Inv]]

abbreviation own_heap :: "heap_lang_heap \<Rightarrow> iprop" ("Own\<^sub>h _") where
  "own_heap h \<equiv> iProp (Atom (Own (ConstC (\<epsilon>,\<epsilon>,\<epsilon>,h))))"

definition points_to :: "loc \<Rightarrow> dfrac \<Rightarrow> val \<Rightarrow> iprop" where
  "points_to l dq v = Own\<^sub>h(view_frag [l\<mapsto>(dq, to_ag (Some v))])"
abbreviation points_to_disc :: "loc \<Rightarrow> val \<Rightarrow> iprop" where
  "points_to_disc \<equiv> \<lambda>l v. points_to l DfracDiscarded v"
abbreviation points_to_own :: "loc \<Rightarrow> frac \<Rightarrow> val \<Rightarrow> iprop" where
  "points_to_own \<equiv> \<lambda>l p v. points_to l (DfracOwn p) v"
abbreviation points_to_full :: "loc \<Rightarrow> val \<Rightarrow> iprop" where
  "points_to_full \<equiv> \<lambda>l v. points_to_own l 1 v"

definition "iprop_holds iP \<equiv> case iP of iProp P \<Rightarrow> pred_holds P"

lemma points_to_valid:
  "iprop_holds (iProp (Wand (pred (points_to l dq v)) (Pure (valid dq))))"
  unfolding pred_holds_def upred_holds_def points_to_def iprop_holds_def
  apply auto
  sorry

definition own_inv :: "inv \<Rightarrow> iprop" ("Own\<^sub>i _") where
  "own_inv i = iProp (Atom (Own(ConstC (\<epsilon>,\<epsilon>,i,\<epsilon>))))"

definition own_state_heap :: "state \<Rightarrow> iprop" where
  "own_state_heap s = Own\<^sub>h (view_auth_full (heap s))"

definition sep_map_set :: "('b\<Rightarrow>iprop) \<Rightarrow> 'b set \<Rightarrow> iprop" where
  "sep_map_set f s = iProp (folding_on.F (\<lambda>x a. Sep a (pred (f x))) (Pure True) s)"

context assumes "SORT_CONSTRAINT('c::ucamera)" and "SORT_CONSTRAINT('v::ofe)"
begin

definition ownI :: "name \<Rightarrow> iprop \<Rightarrow> iprop" where
  "ownI \<iota> P = Own\<^sub>i (Inv (view_frag [\<iota>\<mapsto>(DfracDiscarded,to_ag (Next P))],\<epsilon>,\<epsilon>))"

definition inv :: "namespace \<Rightarrow> iprop \<Rightarrow> iprop" where
  "inv N P = iProp (\<exists>\<^sub>u \<iota>. (Conj (Pure (uname \<iota>\<in>names N)) (pred (ownI (uname \<iota>) P))))"

definition ownE :: "name dset \<Rightarrow> iprop" where
  "ownE E = Own\<^sub>i (Inv (\<epsilon>,E,\<epsilon>))"

definition ownD :: "name dfset \<Rightarrow> iprop" where
  "ownD D = Own\<^sub>i (Inv (\<epsilon>,\<epsilon>,D))"

definition lift_inv_fmap :: "(name,iprop) fmap \<Rightarrow> (name,iprop later) fmap" where
  "lift_inv_fmap m = Abs_fmap (map_option Next \<circ> (fmlookup m))"

definition wsat :: iprop where
  "wsat \<equiv> \<exists>\<^sub>u (I::(name,iprop) fmap).
    (Sep (pred (Own\<^sub>i (Inv(view_auth_full(lift_inv_fmap I),\<epsilon>,\<epsilon>))))
     (pred (sep_map_set (\<lambda>\<iota>. iProp (Disj (Sep (Later((pred \<circ> the \<circ> (fmlookup I)) \<iota>)) (pred (ownD (DFSet {|\<iota>|}))))
      (pred (ownE (DSet {\<iota>}))))) (fmdom' I))))"
end

function wp :: "expr \<Rightarrow> (val \<Rightarrow> iprop) \<Rightarrow> iprop" where
  "wp e \<Phi> = iProp (case to_val e of Some v \<Rightarrow> BUpd (pred (\<Phi> v))
    | None \<Rightarrow> (\<forall>\<^sub>u \<sigma>. (Wand (pred (own_state_heap (ustate \<sigma>)))
      (BUpd (Conj (Pure(red e (ustate \<sigma>))) (Later (\<forall>\<^sub>u \<kappa> e2 \<sigma>2 efs. Wand
      (Pure(e (ustate \<sigma>) (ulist uobs \<kappa>) \<Rightarrow>\<^sub>h (uexpr e2) (ustate \<sigma>2) (ulist uexpr efs)))
        (BUpd (Sep (pred (own_state_heap (ustate \<sigma>2)))
        (Sep (pred (wp (uexpr e2) \<Phi>))
        (pred (sep_map_set (\<lambda>e'. (wp e' (\<lambda>_. iProp (Pure True)))) (set (ulist uexpr efs)
        )))))))))))))"
  by fast auto

end