(*  Title:      Jinja/J/WellType.thy

    Author:     Tobias Nipkow
    Copyright   2003 Technische Universitaet Muenchen
*)

section \<open>Well-typedness of Jinja expressions\<close>

theory WellType
imports "../Common/Objects" Expr
begin

type_synonym
  env  = "vname \<rightharpoonup> ty"

inductive
  WT :: "[J_prog,env, expr     , ty     ] \<Rightarrow> bool"
         ("_,_ \<turnstile> _ :: _"   [51,51,51]50)
  and WTs :: "[J_prog,env, expr list, ty list] \<Rightarrow> bool"
         ("_,_ \<turnstile> _ [::] _" [51,51,51]50)
  for P :: J_prog
where

  WTNew:
  "is_class P C  \<Longrightarrow>
  P,E \<turnstile> new C :: Class C"

| WTCast:
  "\<lbrakk> P,E \<turnstile> e :: Class D;  is_class P C;  P \<turnstile> C \<preceq>\<^sup>* D \<or> P \<turnstile> D \<preceq>\<^sup>* C \<rbrakk>
  \<Longrightarrow> P,E \<turnstile> Cast C e :: Class C"

| WTVal:
  "typeof v = Some T \<Longrightarrow>
  P,E \<turnstile> Val v :: T"

| WTVar:
  "E V = Some T \<Longrightarrow>
  P,E \<turnstile> Var V :: T"
(*
WTBinOp:
  "\<lbrakk> P,E \<turnstile> e\<^sub>1 :: T\<^sub>1;  P,E \<turnstile> e\<^sub>2 :: T\<^sub>2;
     case bop of Eq \<Rightarrow> (P \<turnstile> T\<^sub>1 \<le> T\<^sub>2 \<or> P \<turnstile> T\<^sub>2 \<le> T\<^sub>1) \<and> T = Boolean
               | Add \<Rightarrow> T\<^sub>1 = Integer \<and> T\<^sub>2 = Integer \<and> T = Integer \<rbrakk>
  \<Longrightarrow> P,E \<turnstile> e\<^sub>1 \<guillemotleft>bop\<guillemotright> e\<^sub>2 :: T"
*)
| WTBinOpEq:
  "\<lbrakk> P,E \<turnstile> e\<^sub>1 :: T\<^sub>1;  P,E \<turnstile> e\<^sub>2 :: T\<^sub>2; P \<turnstile> T\<^sub>1 \<le> T\<^sub>2 \<or> P \<turnstile> T\<^sub>2 \<le> T\<^sub>1 \<rbrakk>
  \<Longrightarrow> P,E \<turnstile> e\<^sub>1 \<guillemotleft>Eq\<guillemotright> e\<^sub>2 :: Boolean"

| WTBinOpAdd:
  "\<lbrakk> P,E \<turnstile> e\<^sub>1 :: Integer;  P,E \<turnstile> e\<^sub>2 :: Integer \<rbrakk>
  \<Longrightarrow> P,E \<turnstile> e\<^sub>1 \<guillemotleft>Add\<guillemotright> e\<^sub>2 :: Integer"

| WTLAss:
  "\<lbrakk> E V = Some T;  P,E \<turnstile> e :: T';  P \<turnstile> T' \<le> T;  V \<noteq> this \<rbrakk>
  \<Longrightarrow> P,E \<turnstile> V:=e :: Void"

| WTFAcc:
  "\<lbrakk> P,E \<turnstile> e :: Class C;  P \<turnstile> C sees F:T in D \<rbrakk>
  \<Longrightarrow> P,E \<turnstile> e\<bullet>F{D} :: T"

| WTFAss:
  "\<lbrakk> P,E \<turnstile> e\<^sub>1 :: Class C;  P \<turnstile> C sees F:T in D;  P,E \<turnstile> e\<^sub>2 :: T';  P \<turnstile> T' \<le> T \<rbrakk>
  \<Longrightarrow> P,E \<turnstile> e\<^sub>1\<bullet>F{D}:=e\<^sub>2 :: Void"

| WTCall:
  "\<lbrakk> P,E \<turnstile> e :: Class C;  P \<turnstile> C sees M:Ts \<rightarrow> T = (pns,body) in D;
     P,E \<turnstile> es [::] Ts';  P \<turnstile> Ts' [\<le>] Ts \<rbrakk>
  \<Longrightarrow> P,E \<turnstile> e\<bullet>M(es) :: T"

| WTBlock:
  "\<lbrakk> is_type P T;  P,E(V \<mapsto> T) \<turnstile> e :: T' \<rbrakk>
  \<Longrightarrow>  P,E \<turnstile> {V:T; e} :: T'"

| WTSeq:
  "\<lbrakk> P,E \<turnstile> e\<^sub>1::T\<^sub>1;  P,E \<turnstile> e\<^sub>2::T\<^sub>2 \<rbrakk>
  \<Longrightarrow>  P,E \<turnstile> e\<^sub>1;;e\<^sub>2 :: T\<^sub>2"
| WTCond:
  "\<lbrakk> P,E \<turnstile> e :: Boolean;  P,E \<turnstile> e\<^sub>1::T\<^sub>1;  P,E \<turnstile> e\<^sub>2::T\<^sub>2;
     P \<turnstile> T\<^sub>1 \<le> T\<^sub>2 \<or> P \<turnstile> T\<^sub>2 \<le> T\<^sub>1;  P \<turnstile> T\<^sub>1 \<le> T\<^sub>2 \<longrightarrow> T = T\<^sub>2;  P \<turnstile> T\<^sub>2 \<le> T\<^sub>1 \<longrightarrow> T = T\<^sub>1 \<rbrakk>
  \<Longrightarrow> P,E \<turnstile> if (e) e\<^sub>1 else e\<^sub>2 :: T"

| WTWhile:
  "\<lbrakk> P,E \<turnstile> e :: Boolean;  P,E \<turnstile> c::T \<rbrakk>
  \<Longrightarrow> P,E \<turnstile> while (e) c :: Void"

| WTThrow:
  "P,E \<turnstile> e :: Class C  \<Longrightarrow>
  P,E \<turnstile> throw e :: Void"

| WTTry:
  "\<lbrakk> P,E \<turnstile> e\<^sub>1 :: T;  P,E(V \<mapsto> Class C) \<turnstile> e\<^sub>2 :: T; is_class P C \<rbrakk>
  \<Longrightarrow> P,E \<turnstile> try e\<^sub>1 catch(C V) e\<^sub>2 :: T"

\<comment> \<open>well-typed expression lists\<close>

| WTNil:
  "P,E \<turnstile> [] [::] []"

| WTCons:
  "\<lbrakk> P,E \<turnstile> e :: T;  P,E \<turnstile> es [::] Ts \<rbrakk>
  \<Longrightarrow>  P,E \<turnstile> e#es [::] T#Ts"

(*<*)
(*
lemmas [intro!] = WTNew WTCast WTVal WTVar WTBinOp WTLAss WTFAcc WTFAss WTCall WTBlock WTSeq
                  WTWhile WTThrow WTTry WTNil WTCons
lemmas [intro]  = WTCond1 WTCond2
*)
declare WT_WTs.intros[intro!] (* WTNil[iff] *)

lemmas WT_WTs_induct = WT_WTs.induct [split_format (complete)]
  and WT_WTs_inducts = WT_WTs.inducts [split_format (complete)]
(*>*)

lemma [iff]: "(P,E \<turnstile> e#es [::] T#Ts) = (P,E \<turnstile> e :: T \<and> P,E \<turnstile> es [::] Ts)"
(*<*)
apply(rule iffI)
apply (auto elim: WTs.cases)
done
(*>*)

lemma [iff]: "(P,E \<turnstile> (e#es) [::] Ts) =
  (\<exists>U Us. Ts = U#Us \<and> P,E \<turnstile> e :: U \<and> P,E \<turnstile> es [::] Us)"
(*<*)
apply(rule iffI)
apply (auto elim: WTs.cases)
done
(*>*)

lemma [iff]: "\<And>Ts. (P,E \<turnstile> es\<^sub>1 @ es\<^sub>2 [::] Ts) =
  (\<exists>Ts\<^sub>1 Ts\<^sub>2. Ts = Ts\<^sub>1 @ Ts\<^sub>2 \<and> P,E \<turnstile> es\<^sub>1 [::] Ts\<^sub>1 \<and> P,E \<turnstile> es\<^sub>2[::]Ts\<^sub>2)"
(*<*)
apply(induct es\<^sub>1 type:list)
 apply simp
apply clarsimp
apply(erule thin_rl)
apply (rule iffI)
 apply clarsimp
 apply(rule exI)+
 apply(rule conjI)
  prefer 2 apply blast
 apply simp
apply fastforce
done
(*>*)

lemma [iff]: "P,E \<turnstile> Val v :: T = (typeof v = Some T)"
(*<*)
apply(rule iffI)
apply (auto elim: WT.cases)
done
(*>*)

lemma [iff]: "P,E \<turnstile> Var V :: T = (E V = Some T)"
(*<*)
apply(rule iffI)
apply (auto elim: WT.cases)
done
(*>*)

lemma [iff]: "P,E \<turnstile> e\<^sub>1;;e\<^sub>2 :: T\<^sub>2 = (\<exists>T\<^sub>1. P,E \<turnstile> e\<^sub>1::T\<^sub>1 \<and> P,E \<turnstile> e\<^sub>2::T\<^sub>2)"
(*<*)
apply(rule iffI)
apply (auto elim: WT.cases)
done
(*>*)

lemma [iff]: "(P,E \<turnstile> {V:T; e} :: T') = (is_type P T \<and> P,E(V\<mapsto>T) \<turnstile> e :: T')"
(*<*)
apply(rule iffI)
apply (auto elim: WT.cases)
done
(*>*)

(*<*)
inductive_cases WT_elim_cases[elim!]:
  "P,E \<turnstile> V :=e :: T"
  "P,E \<turnstile> if (e) e\<^sub>1 else e\<^sub>2 :: T"
  "P,E \<turnstile> while (e) c :: T"
  "P,E \<turnstile> throw e :: T"
  "P,E \<turnstile> try e\<^sub>1 catch(C V) e\<^sub>2 :: T"
  "P,E \<turnstile> Cast D e :: T"
  "P,E \<turnstile> a\<bullet>F{D} :: T"
  "P,E \<turnstile> a\<bullet>F{D} := v :: T"
  "P,E \<turnstile> e\<^sub>1 \<guillemotleft>bop\<guillemotright> e\<^sub>2 :: T"
  "P,E \<turnstile> new C :: T"
  "P,E \<turnstile> e\<bullet>M(ps) :: T"
(*>*)

lemma wt_env_mono:
  "P,E \<turnstile> e :: T \<Longrightarrow> (\<And>E'. E \<subseteq>\<^sub>m E' \<Longrightarrow> P,E' \<turnstile> e :: T)" and
  "P,E \<turnstile> es [::] Ts \<Longrightarrow> (\<And>E'. E \<subseteq>\<^sub>m E' \<Longrightarrow> P,E' \<turnstile> es [::] Ts)"
(*<*)
apply(induct rule: WT_WTs_inducts)
apply(simp add: WTNew)
apply(fastforce simp: WTCast)
apply(fastforce simp: WTVal)
apply(simp add: WTVar map_le_def dom_def)
apply(fastforce simp: WTBinOpEq)
apply(fastforce simp: WTBinOpAdd)
apply(force simp:map_le_def)
apply(fastforce simp: WTFAcc)
apply(fastforce simp: WTFAss del:WT_WTs.intros WT_elim_cases)
apply(fastforce simp: WTCall)
apply(fastforce simp: map_le_def WTBlock)
apply(fastforce simp: WTSeq)
apply(fastforce simp: WTCond)
apply(fastforce simp: WTWhile)
apply(fastforce simp: WTThrow)
apply(fastforce simp: WTTry map_le_def dom_def)
apply(simp add: WTNil)
apply(simp add: WTCons)
done
(*>*)

lemma WT_fv: "P,E \<turnstile> e :: T \<Longrightarrow> fv e \<subseteq> dom E"
and "P,E \<turnstile> es [::] Ts \<Longrightarrow> fvs es \<subseteq> dom E"
(*<*)
apply(induct rule:WT_WTs.inducts)
apply(simp_all del: fun_upd_apply)
apply fast+
done

end
(*>*)


section \<open>Time Monad\<close>

theory Time_Monad
imports
  Main
  "HOL-Library.Monad_Syntax"
begin

datatype 'a tm = TM (val: 'a) nat

fun val :: "'a tm \<Rightarrow> 'a" where
"val (TM v n) = v"

fun time :: "'a tm \<Rightarrow> nat" where
"time (TM v n) = n"

definition bind_tm :: "'a tm \<Rightarrow> ('a \<Rightarrow> 'b tm) \<Rightarrow> 'b tm" where
"bind_tm s f = (case s of TM u m \<Rightarrow> case f u of TM v n \<Rightarrow> TM v (m+n))"

adhoc_overloading Monad_Syntax.bind bind_tm

definition "tick v = TM v 1"

definition "return v = TM v 0"

abbreviation eqtick :: "'a tm \<Rightarrow> 'a tm \<Rightarrow> bool" (infix "=1" 50) where
 "eqtick l r \<equiv> (l = (r \<bind> tick))"

(* warning: bind_tm is not a constant on purpose, does not work if it is: *)
translations "CONST eqtick l r" <= "(l = (bind_tm r CONST tick))"

lemmas tm_simps = bind_tm_def return_def tick_def

lemma time_return[simp]: "time (return x) = 0"
by(simp add: return_def)

lemma surj_TM: "v = val tm \<Longrightarrow> t = time tm \<Longrightarrow> tm = TM v t"
by (metis time.simps tm.exhaust val.simps)

text\<open>The following lemmas push @{const val} into a monadic term:\<close>

lemma val_return[simp]: "val (return x) = x"
by(simp add: return_def)

lemma val_bind_tm[simp]: "val (bind_tm m f) = (let x = val m in val(f x))"
by(simp add: bind_tm_def split: tm.split)

lemma val_tick[simp]: "val (tick x) = x"
by(simp add: tick_def)

lemma val_let: "val (let x = t in f(x)) = (let x = t in val(f x))"
by simp

lemma let_id: "(let x = t in x) = t"
  by simp

lemma time_distrib_bind:
  "time (bind_tm tm f) = time tm + time (f (val tm))"
  unfolding bind_tm_def by (simp split: tm.split)

lemmas time_simps = time_distrib_bind tick_def

lemmas val_simps =
  val_return
  val_bind_tm
  val_tick
  val_let
  let_id
  if_distrib[of val]
  prod.case_distrib[of val]

lemmas val_cong = arg_cong[where f=val]

lemma bind_tm_cong[fundef_cong]:
  assumes "\<And>v. v = val n \<Longrightarrow> f v = g v" "m = n"
  shows "bind_tm m f = bind_tm n g"
  using assms unfolding bind_tm_def by (auto split: tm.split)

hide_const TM

end


theory ProcHoleVars
  imports SafeRedLemma
begin

fun hole_free_vars where
  "hole_free_vars ExpHole = {}"
| "hole_free_vars (AppHole1 h e) = (hole_free_vars h \<union> free_vars e)"
| "hole_free_vars (AppHole2 v h) = (free_vars v \<union> hole_free_vars h)"
| "hole_free_vars (IfHole h e1 e2) = (hole_free_vars h \<union> free_vars e1 \<union> free_vars e2)"
| "hole_free_vars (PairHole1 h e) = (hole_free_vars h \<union> free_vars e)"
| "hole_free_vars (PairHole2 e h) = (free_vars e \<union> hole_free_vars h)"
(*| "hole_free_vars (UnpackHole e h) = (free_vars e \<union> hole_free_vars h)"    *)

lemma app_hole_free_vars: "\<lbrakk> x \<in> free_vars e \<rbrakk> \<Longrightarrow> x \<in> free_vars (app_hole h e)"
  apply (induct h)
    apply (auto)
  done

lemma app_hole_free_vars2: "\<lbrakk> x \<in> hole_free_vars h \<rbrakk> \<Longrightarrow> x \<in> free_vars (app_hole h e)"
  apply (induct h)
    apply (auto)
  done

lemma app_hole_free_vars_rev: "\<lbrakk> x \<in> free_vars (app_hole h e) \<rbrakk> \<Longrightarrow> x \<in> hole_free_vars h \<or> x \<in> free_vars e"
  apply (induct h)
    apply (auto)
  done

    (* ##### states that if x is a non-prim var in 'e', it will not be a free var in 'h' if 'h (fork e)' is well-typed.  ##### *)

fun strong_fun_ty where
  "strong_fun_ty (FunTy t1 t2 r a) = (r = OwnPerm)"
| "strong_fun_ty tau = False"

fun strong_fun_ty2 where
  "strong_fun_ty2 (FunTy t1 (FunTy t2 t3 r a) rx ax) = (r = OwnPerm)"
| "strong_fun_ty2 tau = False"

fun strong_fun where
  "strong_fun (ConstExp c) = (\<forall> tau. tau \<in> const_type c \<longrightarrow> strong_fun_ty tau)"
| "strong_fun (AppExp (ConstExp c) v) = (\<forall> tau. tau \<in> const_type c \<longrightarrow> strong_fun_ty2 tau)"
| "strong_fun e = False"

lemma strong_fun_own: "\<lbrakk>  well_typed env r_s1 f (FunTy t1 t2 r a) r_s2 rx; strong_fun f \<rbrakk> \<Longrightarrow> is_own r"
  apply (case_tac f)
        apply (auto)
   apply (simp add: is_own_def)
   apply (auto)
  apply (simp add: is_own_def)
  apply (case_tac x71)
        apply (auto)
  done

lemma safe_hole_npv_use_ih: "\<lbrakk> well_typed env r_s1 (app_hole h (AppExp f e)) tau r_s2 rx;
  is_value f; strong_fun f; is_value e; x \<in> non_prim_vars env e \<rbrakk> \<Longrightarrow> r_s2 x = NoPerm"
  apply (induct h arbitrary: env r_s1 r_s2 tau rx)
       apply (auto)
    (* base case. x is subtracted out in the lifting of the inflected rx2 *)
       apply (cut_tac env="env" and ?r_s1.0="r_s2a" and e="e" and tau="t1" and ?r_s2.0="r_s3" and rx="rx2" in infl_sexp_wp)
         apply (auto)
        apply (rule_tac value_is_sexp)
        apply (simp)
    (* - r_s3 x has a value since otherwise it would be trivial *)
       apply (case_tac "r_s3 x = NoPerm")
        apply (rule_tac r_s="r_s3" in leq_use_none)
         apply (rule_tac r_sb="diff_use_env r_s3 (comp_use_env (comp_use_env rx1 (lift_use_env rx2 r)) r_ex)" in trans_leq_use_env)
          apply (rule_tac self_diff_leq_use_env)
         apply (auto)
    (* - we know that rx2 has a value, because otherwise rx2 + [r_s2a - r_s3] would not have a value, altho it is the start perms of e *)
       apply (case_tac "rx2 x = NoPerm")
        apply (cut_tac r_sa="rx2" and r_sb="infl_use_env r_s2a r_s3" and x="x" in comp_use_none)
          apply (simp)
         apply (simp add: infl_use_env_def)
        apply (cut_tac env="env" and ?r_s1.0="comp_use_env rx2 (infl_use_env r_s2a r_s3)" and x="x" in well_typed_no_npv_use)
          apply (auto)
    (* - by construction of strong functions, we also know that r = OwnPerm *)
       apply (cut_tac f="f" and r="r" in strong_fun_own)
         apply (auto)
    (* - from here we can deduce EX x = Own *)
        apply (rule_tac r_s="diff_use_env r_s3 (comp_use_env (comp_use_env rx1 (lift_use_env rx2 r)) r_ex)" in leq_use_none)
         apply (auto)
        apply (rule_tac diff_use_none_ex)
        apply (rule_tac r_x="lift_use_env rx2 r" in leq_use_own)
         apply (simp add: is_own_def)
        apply (rule_tac comp_leq_use_env1)
        apply (rule_tac self_comp_leq_use_env2)
    (* lhs induct. *)
      apply (rule_tac r_s="r_s2a" in leq_use_none)
       apply (rule_tac r_sb="diff_use_env r_s3 (comp_use_env (comp_use_env rx1 (lift_use_env rx2 r)) r_ex)" in trans_leq_use_env)
        apply (rule_tac diff_leq_use_env)
        apply (rule_tac well_typed_perm_leq)
        apply (auto)
    (* rhs induct. *)
     apply (rule_tac r_s="r_s3" in leq_use_none)
      apply (rule_tac r_sb="diff_use_env r_s3 (comp_use_env (comp_use_env rx1 (lift_use_env rx2 r)) r_ex)" in trans_leq_use_env)
       apply (rule_tac self_diff_leq_use_env)
      apply (auto)
    (* if case. *)
    apply (rule_tac r_s="r_s2a" in leq_use_none)
     apply (rule_tac well_typed_perm_leq)
     apply (auto)
    (* pair case 1. *)
   apply (rule_tac r_s="r_s2a" in leq_use_none)
    apply (rule_tac r_sb="diff_use_env r_s3 r_ex" in trans_leq_use_env)
     apply (rule_tac diff_leq_use_env)
     apply (rule_tac well_typed_perm_leq)
     apply (auto)
    (* pair case 2. *)
  apply (rule_tac r_s="r_s3" in leq_use_none)
   apply (rule_tac r_sb="diff_use_env r_s3 r_ex" in trans_leq_use_env)
    apply (rule_tac self_diff_leq_use_env)
   apply (auto)
  done

lemma safe_hole_npv_use_st: "\<lbrakk> well_typed env r_s1 (app_hole h (AppExp f e)) tau r_s2 rx; is_value f; strong_fun f;
 wf_hole h; is_value e \<rbrakk> \<Longrightarrow> x \<notin> non_prim_vars env e \<or> x \<notin> hole_free_vars h"
  apply (induct h arbitrary: env r_s1 tau r_s2 rx)
        apply (auto)
    (* lhs induct. since r_s2a x = None, it cannot be in e2 *)
        apply (cut_tac h="h" and e="e" and ?r_s2.0="r_s2a" and x="x" in safe_hole_npv_use_ih)
           apply (auto)
        apply (cut_tac ?r_s1.0="r_s2a" and e="x2" and x="x" in well_typed_no_npv_use)
          apply (auto)
        apply (simp add: non_prim_vars_def)
    (* rhs induct. r_s2a x has a value. since x is in e2. *)
       apply (case_tac "r_s2a x = NoPerm")
        apply (cut_tac ?r_s1.0="r_s2a" and x="x" and e="app_hole h (AppExp f e)" in well_typed_no_npv_use)
          apply (auto)
        apply (cut_tac h="h" and e="AppExp f e" and x="x" in app_hole_free_vars)
         apply (auto)
         apply (simp add: non_prim_vars_def)
        apply (simp add: non_prim_vars_def)
    (* - by lemma, rx1 x has a value as well. *)
       apply (cut_tac env="env" and e="x1" and tau="FunTy t1 tau r a" and ?r_s2.0="r_s2a" and rx="rx1" in wt_sexp_req_use)
           apply (auto)
         apply (rule_tac value_is_sexp)
         apply (auto)
        apply (simp add: non_prim_vars_def)
    (* - this is a contradiction, since r_s3 x = None, and rx1 is contained by it *)
       apply (cut_tac r_x="rx1" and r_s="r_s3" and x="x" in leq_use_none)
         apply (rule_tac r_sb="comp_use_env rx1 (lift_use_env rx2 r)" in trans_leq_use_env)
          apply (simp)
         apply (rule_tac self_comp_leq_use_env1)
        apply (rule_tac safe_hole_npv_use_ih)
          apply (auto)
    (* lhs if case. since r_s2a x = None, it cannot be in e2 *)
      apply (cut_tac h="h" and e="e" and ?r_s2.0="r_s2a" and x="x" in safe_hole_npv_use_ih)
         apply (auto)
      apply (cut_tac ?r_s1.0="r_s2a" and e="x2" and x="x" in well_typed_no_npv_use)
        apply (auto)
      apply (simp add: non_prim_vars_def)
    (* rhs if case. since r_s2a x = None, it cannot be in e2 *)
     apply (cut_tac h="h" and e="e" and ?r_s2.0="r_s2a" and x="x" in safe_hole_npv_use_ih)
        apply (auto)
     apply (cut_tac ?r_s1.0="r_s2a" and e="x3" and x="x" in well_typed_no_npv_use)
       apply (auto)
     apply (simp add: non_prim_vars_def)
    (* lhs pair case. same for lhs induct *)
    apply (cut_tac h="h" and e="e" and ?r_s2.0="r_s2a" and x="x" in safe_hole_npv_use_ih)
       apply (auto)
    apply (cut_tac ?r_s1.0="r_s2a" and e="x2" and x="x" in well_typed_no_npv_use)
      apply (auto)
    apply (simp add: non_prim_vars_def)
    (* rhs pair case. same for rhs induct *)
    (* - r_s2a x has a value. since x is in e2 *)
   apply (case_tac "r_s2a x = NoPerm")
    apply (cut_tac ?r_s1.0="r_s2a" and x="x" and e="app_hole h (AppExp f e)" in well_typed_no_npv_use)
      apply (auto)
    apply (cut_tac h="h" and e="AppExp f e" and x="x" in app_hole_free_vars)
     apply (auto)
     apply (simp add: non_prim_vars_def)
    apply (simp add: non_prim_vars_def)
    (* - then rx1 x has a value *)
   apply (cut_tac env="env" and ?r_s1.0="r_s1" and e="x1" and tau="t1" and ?r_s2.0="r_s2a" and rx="rx1" in wt_sexp_req_use)
       apply (auto)
     apply (rule_tac value_is_sexp)
     apply (auto)
    apply (simp add: non_prim_vars_def)
    (* - this is a contradiction, since r_s3 x = None, and rx1 is contained by it *)
   apply (cut_tac r_x="rx1" and r_s="r_s3" and x="x" in leq_use_none)
     apply (rule_tac r_sb="lift_use_env rx1 r" in trans_leq_use_env)
      apply (simp)
     apply (rule_tac self_lift_leq_use_env)
    apply (rule_tac safe_hole_npv_use_ih)
      apply (auto)
  done

lemma safe_fork_hole_npv_use: "\<lbrakk> well_typed env r_s1 (app_hole h (AppExp (ConstExp ForkConst) e)) tau r_s2 rx;
 wf_hole h; is_value e; x \<in> non_prim_vars env e \<rbrakk> \<Longrightarrow> x \<notin> hole_free_vars h"
  apply (cut_tac env="env" and ?r_s1.0="r_s1" and h="h" and e="e" and f="ConstExp ForkConst" and x="x" in safe_hole_npv_use_st)
       apply (auto)
  apply (simp add: is_own_def)
  done

lemma safe_send_hole_npv_use: "\<lbrakk> well_typed env r_s1 (app_hole h (AppExp (AppExp (ConstExp SendConst) v) e)) tau r_s2 rx;
 wf_hole h; is_value v; is_value e; x \<in> non_prim_vars env e \<rbrakk> \<Longrightarrow> x \<notin> hole_free_vars h"
  apply (cut_tac env="env" and ?r_s1.0="r_s1" and h="h" and e="e" and f="AppExp (ConstExp SendConst) v" and x="x" in safe_hole_npv_use_st)
       apply (auto)
  apply (simp add: pure_fun_def)
  apply (simp add: is_own_def)
  done
    (*
lemma safe_fork_hole_npv_use_ih: "\<lbrakk> well_typed env r_s1 (app_hole h (AppExp (ConstExp ForkConst) e)) tau r_s2 rx;
 is_value e; x \<in> non_prim_vars env e \<rbrakk> \<Longrightarrow> r_s2 x = NoPerm"
  apply (induct h arbitrary: env r_s1 r_s2 tau rx)
        apply (auto)
    (* base case. x is subtracted out in the lifting of the inflected rx2 *)
        apply (cut_tac env="env" and ?r_s1.0="r_s2a" and e="e" and tau="FunTy UnitTy UnitTy UsePerm a" and ?r_s2.0="r_s3" and rx="rx2" in infl_sexp_wp)
          apply (auto)
         apply (rule_tac value_is_sexp)
         apply (simp)
    (* - r_s3 x has a value since otherwise it would be trivial *)
        apply (case_tac "r_s3 x = NoPerm")
         apply (rule_tac r_s="r_s3" in leq_use_none)
          apply (rule_tac r_sb="diff_use_env r_s3 (comp_use_env (comp_use_env rx1 (lift_use_env rx2 r)) r_ex)" in trans_leq_use_env)
           apply (rule_tac self_diff_leq_use_env)
          apply (auto)
    (* - we know that rx2 has a value, because otherwise rx2 + [r_s2a - r_s3] would not have a value, altho it is the start perms of e *)
        apply (case_tac "rx2 x = NoPerm")
         apply (cut_tac r_sa="rx2" and r_sb="infl_use_env r_s2a r_s3" and x="x" in comp_use_none)
           apply (simp)
          apply (simp add: infl_use_env_def)
         apply (cut_tac env="env" and ?r_s1.0="comp_use_env rx2 (infl_use_env r_s2a r_s3)" and x="x" in well_typed_no_npv_use)
           apply (auto)
    (* - from here we can deduce EX x = Own *)
        apply (rule_tac r_s="diff_use_env r_s3 (comp_use_env (comp_use_env rx1 (lift_use_env rx2 r)) r_ex)" in leq_use_none)
         apply (auto)
        apply (rule_tac diff_use_none_ex)
        apply (rule_tac r_x="lift_use_env rx2 r" in leq_use_own)
         apply (simp add: is_own_def)
        apply (rule_tac comp_leq_use_env1)
        apply (rule_tac self_comp_leq_use_env2)
    (* lhs induct. *)
       apply (rule_tac r_s="r_s2a" in leq_use_none)
        apply (rule_tac r_sb="diff_use_env r_s3 (comp_use_env (comp_use_env rx1 (lift_use_env rx2 r)) r_ex)" in trans_leq_use_env)
         apply (rule_tac diff_leq_use_env)
         apply (rule_tac well_typed_perm_leq)
         apply (auto)
    (* rhs induct. *)
      apply (rule_tac r_s="r_s3" in leq_use_none)
       apply (rule_tac r_sb="diff_use_env r_s3 (comp_use_env (comp_use_env rx1 (lift_use_env rx2 r)) r_ex)" in trans_leq_use_env)
        apply (rule_tac self_diff_leq_use_env)
       apply (auto)
    (* if case. *)
     apply (rule_tac r_s="r_s2a" in leq_use_none)
      apply (rule_tac well_typed_perm_leq)
      apply (auto)
    (* pair case 1. *)
    apply (rule_tac r_s="r_s2a" in leq_use_none)
     apply (rule_tac r_sb="diff_use_env r_s3 r_ex" in trans_leq_use_env)
      apply (rule_tac diff_leq_use_env)
      apply (rule_tac well_typed_perm_leq)
      apply (auto)
    (* pair case 2. *)
    apply (rule_tac r_s="r_s3" in leq_use_none)
    apply (rule_tac r_sb="diff_use_env r_s3 r_ex" in trans_leq_use_env)
     apply (rule_tac self_diff_leq_use_env)
    apply (auto)
    (* unpack case *)(*
  apply (rule_tac r_s="r_s3" in leq_use_none)
   apply (rule_tac r_sb="diff_use_env r_s3 (comp_use_env (comp_use_env rx1 (lift_use_env rx2 r)) r_ex)" in trans_leq_use_env)
    apply (rule_tac self_diff_leq_use_env)
   apply (auto)*)
  done

    (* the point of this lemma is basically that any non-primitive variable from e will be completely absent from h. *)

lemma safe_fork_hole_npv_use_st: "\<lbrakk> well_typed env r_s1 (app_hole h (AppExp (ConstExp ForkConst) e)) tau r_s2 rx;
 wf_hole h; is_value e \<rbrakk> \<Longrightarrow> x \<notin> non_prim_vars env e \<or> x \<notin> hole_free_vars h"
  apply (induct h arbitrary: env r_s1 tau r_s2 rx)
        apply (auto)
    (* lhs induct. since r_s2a x = None, it cannot be in e2 *)
        apply (cut_tac h="h" and e="e" and ?r_s2.0="r_s2a" and x="x" in safe_fork_hole_npv_use_ih)
           apply (auto)
        apply (cut_tac ?r_s1.0="r_s2a" and e="x2" and x="x" in well_typed_no_npv_use)
          apply (auto)
        apply (simp add: non_prim_vars_def)
    (* rhs induct. r_s2a x has a value. since x is in e2. *)
       apply (case_tac "r_s2a x = NoPerm")
        apply (cut_tac ?r_s1.0="r_s2a" and x="x" and e="app_hole h (AppExp (ConstExp ForkConst) e)" in well_typed_no_npv_use)
          apply (auto)
        apply (cut_tac h="h" and e="AppExp (ConstExp ForkConst) e" and x="x" in app_hole_free_vars)
         apply (auto)
         apply (simp add: non_prim_vars_def)
        apply (simp add: non_prim_vars_def)
    (* - by lemma, rx1 x has a value as well. *)
       apply (cut_tac env="env" and e="x1" and tau="FunTy t1 tau r a" and ?r_s2.0="r_s2a" and rx="rx1" in wt_sexp_req_use)
           apply (auto)
         apply (rule_tac value_is_sexp)
         apply (auto)
        apply (simp add: non_prim_vars_def)
    (* - this is a contradiction, since r_s3 x = None, and rx1 is contained by it *)
       apply (cut_tac r_x="rx1" and r_s="r_s3" and x="x" in leq_use_none)
         apply (rule_tac r_sb="comp_use_env rx1 (lift_use_env rx2 r)" in trans_leq_use_env)
          apply (simp)
         apply (rule_tac self_comp_leq_use_env1)
        apply (rule_tac safe_fork_hole_npv_use_ih)
          apply (auto)
    (* lhs if case. since r_s2a x = None, it cannot be in e2 *)
      apply (cut_tac h="h" and e="e" and ?r_s2.0="r_s2a" and x="x" in safe_fork_hole_npv_use_ih)
         apply (auto)
      apply (cut_tac ?r_s1.0="r_s2a" and e="x2" and x="x" in well_typed_no_npv_use)
        apply (auto)
      apply (simp add: non_prim_vars_def)
    (* rhs if case. since r_s2a x = None, it cannot be in e2 *)
     apply (cut_tac h="h" and e="e" and ?r_s2.0="r_s2a" and x="x" in safe_fork_hole_npv_use_ih)
        apply (auto)
     apply (cut_tac ?r_s1.0="r_s2a" and e="x3" and x="x" in well_typed_no_npv_use)
       apply (auto)
     apply (simp add: non_prim_vars_def)
    (* lhs pair case. same for lhs induct *)
    apply (cut_tac h="h" and e="e" and ?r_s2.0="r_s2a" and x="x" in safe_fork_hole_npv_use_ih)
       apply (auto)
    apply (cut_tac ?r_s1.0="r_s2a" and e="x2" and x="x" in well_typed_no_npv_use)
      apply (auto)
    apply (simp add: non_prim_vars_def)
    (* rhs pair case. same for rhs induct *)
    (* - r_s2a x has a value. since x is in e2 *)
   apply (case_tac "r_s2a x = NoPerm")
    apply (cut_tac ?r_s1.0="r_s2a" and x="x" and e="app_hole h (AppExp (ConstExp ForkConst) e)" in well_typed_no_npv_use)
      apply (auto)
    apply (cut_tac h="h" and e="AppExp (ConstExp ForkConst) e" and x="x" in app_hole_free_vars)
     apply (auto)
     apply (simp add: non_prim_vars_def)
    apply (simp add: non_prim_vars_def)
    (* - then rx1 x has a value *)
   apply (cut_tac env="env" and ?r_s1.0="r_s1" and e="x1" and tau="t1" and ?r_s2.0="r_s2a" and rx="rx1" in wt_sexp_req_use)
       apply (auto)
     apply (rule_tac value_is_sexp)
     apply (auto)
    apply (simp add: non_prim_vars_def)
    (* - this is a contradiction, since r_s3 x = None, and rx1 is contained by it *)
   apply (cut_tac r_x="rx1" and r_s="r_s3" and x="x" in leq_use_none)
     apply (rule_tac r_sb="lift_use_env rx1 r" in trans_leq_use_env)
      apply (simp)
     apply (rule_tac self_lift_leq_use_env)
    apply (rule_tac safe_fork_hole_npv_use_ih)
      apply (auto)
    (* unpack case. like the other rhs cases, we want to show that x cannot be in e1, because doing so would mean that rx1 x has a value.
        - now, we can easily show that r_s3a x \<noteq> None, so rx2a x \<noteq> None follows
     *)(*
  apply (case_tac "r_s3a x = NoPerm")
   apply (cut_tac r_x="r_s2a" and r_s="r_s3a" and x="x" in leq_use_none)
     apply (rule_tac r_sb="diff_use_env r_s3a (comp_use_env (comp_use_env rx1a (lift_use_env rx2a ra)) r_exa)" in trans_leq_use_env)
      apply (rule_tac self_diff_leq_use_env)
     apply (simp_all)
   apply (cut_tac ?r_s1.0="r_s2a" and e="app_hole h (AppExp (ConstExp ForkConst) e)" and x="x" in well_typed_no_npv_use)
     apply (auto)
   apply (cut_tac h="h" and e="AppExp (ConstExp ForkConst) e" and x="x" in app_hole_free_vars)
    apply (auto)
    apply (simp add: non_prim_vars_def)
   apply (simp add: non_prim_vars_def)
  apply (cut_tac env="env" and ?r_s2.0="r_s3a" and e="x1" and rx="rx2a" in wt_sexp_req_use)
      apply (auto)
    apply (rule_tac e="x1" in value_is_sexp)
    apply (auto)
   apply (simp add: non_prim_vars_def)
    (* - we know the lhs is not primitive, therefore rx1 is not necessarily empty. *)
  apply (simp add: app_req_def)
  apply (case_tac "a = Prim")
   apply (simp add: pure_fun_def)
  apply (auto)
    (* - then rx1 x \<noteq> None, since it would have had to be subtracted from r_s2a. *)
  apply (case_tac "rx1 x = NoPerm")
   apply (cut_tac r_x="r_s2a" and r_s="diff_use_env r_s3a (comp_use_env (comp_use_env rx1a (lift_use_env rx2a ra)) r_exa)" and x="x" in leq_use_none)
     apply (simp)
    apply (rule_tac r_x="comp_use_env rx1a rx2a" in diff_use_none)
     apply (case_tac "comp_use_env rx1a rx2a x = NoPerm")
      apply (cut_tac r_sa="rx1a" and r_sb="rx2a" and x="x" in comp_use_none_both)
       apply (auto)
    apply (rule_tac r_s="rx1" in leq_use_none)
     apply (auto)
   apply (cut_tac ?r_s1.0="r_s2a" and e="app_hole h (AppExp (ConstExp ForkConst) e)" and x="x" in well_typed_no_npv_use)
     apply (auto)
   apply (cut_tac h="h" and e="AppExp (ConstExp ForkConst) e" and x="x" in app_hole_free_vars)
    apply (auto)
    apply (simp add: non_prim_vars_def)
   apply (simp add: non_prim_vars_def)
    (* this is a contradiction, since r_s3 x = None *)
  apply (cut_tac r_x="rx1" and r_s="r_s3" and x="x" in leq_use_none)
    apply (rule_tac r_sb="comp_use_env rx1 (lift_use_env rx2 r)" in trans_leq_use_env)
     apply (simp)
    apply (rule_tac self_comp_leq_use_env1)
   apply (rule_tac safe_fork_hole_npv_use_ih)
     apply (auto)*)
  done

lemma safe_fork_hole_npv_use: "\<lbrakk> well_typed env r_s1 (app_hole h (AppExp (ConstExp ForkConst) e)) tau r_s2 rx;
 wf_hole h; is_value e; x \<in> non_prim_vars env e \<rbrakk> \<Longrightarrow> x \<notin> hole_free_vars h"
  apply (cut_tac env="env" and ?r_s1.0="r_s1" and h="h" and e="e" and x="x" in safe_fork_hole_npv_use_st)
     apply (auto)
  done    *)

end


theory Exp
  imports Definitions
begin

section \<open>Semantics of Expressions\<close>

text \<open>This section presents the big-step semantics of expressions.\<close>

text \<open>Introducing a locale here looks a good idea as it helps us formulate
axioms among the heap access modifier. Expected axioms:
\<^item> Modifier must be idempotent: \<^term>\<open>m p (m p H) = m p H\<close>.
\<^item> Modifier must not allocate/deallocate a memory cell: \<^term>\<open>length (m p H) = length H\<close>.
\<^item> The content is left intact: \<^term>\<open>fst ((m p H) ! a) = fst (H ! a)\<close>
\<close>

type_synonym modifier = "(address * tag) \<Rightarrow> heap \<Rightarrow> heap option"
fun write_access :: modifier where
  "write_access (a, t) H =
    (if writable H (a, t) then
      let (v, ts) = H ! a in
      Some (H[a := (v, kill t ts)])
     else None)"
fun read_access :: modifier where
  "read_access (a, t) H =
    (if readable H (a, t) then
      let (v, ts) = H ! a in
      Some (H[a := (v, kill t ts)])
     else None)"

inductive place_sem ::
  "gamma \<Rightarrow> modifier \<Rightarrow> heap * place \<Rightarrow> heap * val \<Rightarrow> bool"
  ("(_; _ \<turnstile> _ \<Down>\<^sub>p _)") for \<Gamma> m
where
  Var: "\<Gamma> x = (a, t) \<Longrightarrow> \<Gamma>; m \<turnstile> (H, Var x) \<Down>\<^sub>p (H, Reference a t)" |
  Deref: "\<lbrakk>\<Gamma>; m \<turnstile> (H, p) \<Down>\<^sub>p (H', Reference a t); m (a, t) H' = Some H''\<rbrakk> \<Longrightarrow>
          \<Gamma>; m \<turnstile> (H, Deref p) \<Down>\<^sub>p (H'', fst (H'' ! a))"

text \<open>The relation @{const place_sem} describes the semantics of places
with respect to a heap access modifier \<^term>\<open>m\<close>.
\<^term>\<open>\<Gamma>; m \<turnstile> (H, p) \<Down>\<^sub>p (H', v)\<close> means that a place expression \<^term>\<open>p\<close> evaluates to
a value \<^term>\<open>v\<close> under the environment \<^term>\<open>\<Gamma>\<close> and \<^term>\<open>H\<close>, while the access
has changed the state of the heap to \<^term>\<open>H'\<close>.\<close>

text \<open>We give a shorthand for read and write access to the place.\<close>

abbreviation read_place_sem :: "gamma \<Rightarrow> heap * place \<Rightarrow> heap * val \<Rightarrow> bool"
  ("(_ \<turnstile>\<^sub>r _ \<Down>\<^sub>p _)")
  where
  "\<Gamma> \<turnstile>\<^sub>r p \<Down>\<^sub>p v == \<Gamma>; read_access \<turnstile> p \<Down>\<^sub>p v"
abbreviation write_place_sem :: "gamma \<Rightarrow> heap * place \<Rightarrow> heap * val \<Rightarrow> bool"
  ("(_ \<turnstile>\<^sub>w _ \<Down>\<^sub>p _)")
  where
  "\<Gamma> \<turnstile>\<^sub>w p \<Down>\<^sub>p v == \<Gamma>; write_access \<turnstile> p \<Down>\<^sub>p v"

(*<*)
lemmas place_sem_cases = place_sem.cases[split_format(complete)]
lemmas place_sem_induct = place_sem.induct[split_format(complete)]
declare place_sem.intros[simp, intro]
inductive_cases place_sem_inv[elim!]:
  "\<Gamma>; m \<turnstile> (H, Var x) \<Down>\<^sub>p (H', v)"
  "\<Gamma>; m \<turnstile> (H, Deref p) \<Down>\<^sub>p (H', v)"
(*>*)

text \<open>Note that every operand is considered as a read access to the place.\<close>

inductive operand_sem ::
  "gamma \<Rightarrow> heap * operand \<Rightarrow> heap * val \<Rightarrow> bool"
  ("(_ \<turnstile> _ \<Down>\<^sub>o\<^sub>p _)") for \<Gamma>
where
  Place: "\<Gamma> \<turnstile>\<^sub>r (H, p) \<Down>\<^sub>p v \<Longrightarrow> \<Gamma> \<turnstile> (H, Place p) \<Down>\<^sub>o\<^sub>p v" |
  Constant: "\<Gamma> \<turnstile> (H, Constant v) \<Down>\<^sub>o\<^sub>p (H, v)"

(*<*)
lemmas operand_sem_cases = operand_sem.cases[split_format(complete)]
lemmas operand_sem_induct = operand_sem.induct[split_format(complete)]
declare operand_sem.simps[simp, intro]
inductive_cases operand_sem_inv[elim!]:
  "\<Gamma> \<turnstile> (H, Place p) \<Down>\<^sub>o\<^sub>p v"
  "\<Gamma> \<turnstile> (H, Constant v) \<Down>\<^sub>o\<^sub>p v'"
(*>*)

inductive rvalue_sem ::
  "gamma \<Rightarrow> tags * heap * rvalue \<Rightarrow> tags * heap * val \<Rightarrow> bool"
  ("(_ \<turnstile> _ \<Down> _)") for \<Gamma>
where
  Use: "\<Gamma> \<turnstile> (H, op) \<Down>\<^sub>o\<^sub>p (H', v) \<Longrightarrow> \<Gamma> \<turnstile> (T, H, Use op) \<Down> (T, H', v)" |
  Box: "\<lbrakk>\<Gamma> \<turnstile> (H, op) \<Down>\<^sub>o\<^sub>p (H', v); p = length H'; t = length T\<rbrakk>
        \<Longrightarrow> \<Gamma> \<turnstile> (T, H, Box op) \<Down> (T @ [Unique], H' @ [(v, [t])], Reference p t)" |
  Ref: "\<Gamma> \<turnstile>\<^sub>w (H, p) \<Down>\<^sub>p (H', Reference a t) \<Longrightarrow> \<Gamma> \<turnstile> (T, H, Ref p) \<Down> (T, H', Reference a t)" |
  Reborrow: "\<lbrakk>\<Gamma> \<turnstile>\<^sub>w (H, p) \<Down>\<^sub>p (H', Reference a t); writable H (a, t);
              t' = length T; H' ! a = (v, ts)\<rbrakk>
             \<Longrightarrow> \<Gamma> \<turnstile> (T, H, Reborrow p) \<Down> (T @ [Unique], H'[a := (v, ts @ [t'])], Reference a t')" |
  Plus: "\<lbrakk>\<Gamma> \<turnstile> (H, lhs) \<Down>\<^sub>o\<^sub>p (H', VInt lhs'); \<Gamma> \<turnstile> (H', rhs) \<Down>\<^sub>o\<^sub>p (H'', VInt rhs')\<rbrakk>
         \<Longrightarrow> \<Gamma> \<turnstile> (T, H, Plus lhs rhs) \<Down> (T, H'', VInt (lhs' + rhs'))" |
  Less: "\<lbrakk>\<Gamma> \<turnstile> (H, lhs) \<Down>\<^sub>o\<^sub>p (H', VInt lhs'); \<Gamma> \<turnstile> (H', rhs) \<Down>\<^sub>o\<^sub>p (H'', VInt rhs')\<rbrakk>
         \<Longrightarrow> \<Gamma> \<turnstile> (T, H, Less lhs rhs) \<Down> (T, H'', VBool (lhs' < rhs'))" |
  Not: "\<Gamma> \<turnstile> (H, op) \<Down>\<^sub>o\<^sub>p (H', VBool v) \<Longrightarrow> \<Gamma> \<turnstile> (T, H, Not op) \<Down> (T, H', VBool (\<not>v))" |
  And: "\<lbrakk>\<Gamma> \<turnstile> (H, lhs) \<Down>\<^sub>o\<^sub>p (H', VBool lhs'); \<Gamma> \<turnstile> (H', rhs) \<Down>\<^sub>o\<^sub>p (H'', VBool rhs')\<rbrakk>
         \<Longrightarrow> \<Gamma> \<turnstile> (T, H, And lhs rhs) \<Down> (T, H'', VBool (lhs' \<and> rhs'))"

(*<*)
lemmas rvalue_sem_cases = rvalue_sem.cases[split_format(complete)]
lemmas rvalue_sem_induct = rvalue_sem.induct[split_format(complete)]
declare rvalue_sem.intros[simp, intro]
inductive_cases rvalue_sem_inv[elim!]:
  "\<Gamma> \<turnstile> (T, H, Use op) \<Down> (T', H', v)"
  "\<Gamma> \<turnstile> (T, H, Box op) \<Down> (T', H', v)"
  "\<Gamma> \<turnstile> (T, H, Ref p) \<Down> (T', H', v)"
  "\<Gamma> \<turnstile> (T, H, Reborrow p) \<Down> (T', H', v)"
  "\<Gamma> \<turnstile> (T, H, Plus lhs rhs) \<Down> (T', H', v)"
  "\<Gamma> \<turnstile> (T, H, Less lhs rhs) \<Down> (T', H', v)"
  "\<Gamma> \<turnstile> (T, H, Not op) \<Down> (T', H', v)"
  "\<Gamma> \<turnstile> (T, H, And lhs rhs) \<Down> (T', H', v)"
(*>*)

text \<open>
Some TODO notes on the semantics of expressions:
\<^item> I don't get the semantics of @{const Ref} in MIR and how it should behave under the auto-boxing of variables.
\<^item> I'm not sure readable/writable checking is correct.
\<close>

text \<open>
We present the intuition behind the selected rules.
First, {\sc{Box}} rule allocates a new slot at the end of heap,
returning a reference pointing to the slot with a fresh tag.

\begin{framed}
\centering
@{thm[mode=Rule] Box} \sc{Box}
\end{framed}

Next, {\sc{Use}} and {\sc{Ref}} rules allow us to read the content through a place (or give a constant).

\begin{framed}
\centering
@{thm[mode=Rule] Use} \sc{Use}\\
@{thm[mode=Rule] Ref} \sc{Ref}
\end{framed}

Last but not least, {\sc{Reborrow}} rule creates a new reference pointing to the same object but with a fresh tag.
The newly created reference is writable. Thus the original reference must be valid for writes.
Reborrow is considered as the use of the original reference and hence it invalidates former children
of the reference. As a result, the reborrow tree will have the original reference and the reborrowing
reference as the last two element.

\begin{framed}
\sc{Reborrow} rule:
\centering
@{thm[mode=Rule] Reborrow}
\end{framed}
\<close>

text \<open>We can prove that the semantics of expressions is deterministic.\<close>

lemma place_sem_det: "\<Gamma>; m \<turnstile> p \<Down>\<^sub>p v \<Longrightarrow> \<Gamma>; m \<turnstile> p \<Down>\<^sub>p v' \<Longrightarrow> v' = v"
proof (induction arbitrary: v' rule: place_sem.induct)
  case (Var x a t H)
  then show ?case
    by (metis Pair_inject place_sem_inv(1) surj_pair)
next
  case (Deref m H p H' a t H'')
  then show ?case
  sorry
  (*
    by (smt Pair_inject option.inject place_sem_inv(2) surj_pair val.inject(3))
  *)
qed
lemma place_sem_det': "\<Gamma>; m \<turnstile> (H, p) \<Down>\<^sub>p (H', v') \<Longrightarrow> \<Gamma>; m \<turnstile> (H, p) \<Down>\<^sub>p (H'', v'')
  \<Longrightarrow> (H'', v'') = (H', v')"
  using place_sem_det by auto

lemma operand_sem_det: "\<Gamma> \<turnstile> op \<Down>\<^sub>o\<^sub>p v \<Longrightarrow> \<Gamma> \<turnstile> op \<Down>\<^sub>o\<^sub>p v' \<Longrightarrow> v' = v"
proof (induction arbitrary: v' rule: operand_sem.induct)
  case (Place \<Gamma> H p v)
  then show ?case
    by (metis operand_sem_inv(1) place_sem_det' surj_pair)
next
  case (Constant \<Gamma> H v)
  then show ?case by blast
qed
lemma operand_sem_det': "\<Gamma> \<turnstile> (H, op) \<Down>\<^sub>o\<^sub>p (H', v') \<Longrightarrow> \<Gamma> \<turnstile> (H, op) \<Down>\<^sub>o\<^sub>p (H'', v'')
  \<Longrightarrow> (H'', v'') = (H', v')"
  using operand_sem_det by blast

lemma rvalue_sem_det: "\<Gamma> \<turnstile> (T, H, rv) \<Down> (T', H', v') \<Longrightarrow> \<Gamma> \<turnstile> (T, H, rv) \<Down> (T'', H'', v'')
  \<Longrightarrow> (T'', H'', v'') = (T', H', v')"
proof (induction arbitrary: T'' H'' v'' rule: rvalue_sem_induct)
  case (Use H op H' v T)
  then show ?case using operand_sem_det' by fastforce
next
  case (Box H op H' v p t T)
  then show ?case using place_sem_det' by blast
next
  case (Ref H p H' a t T)
  then show ?case using place_sem_det' by blast
next
  case (Reborrow H p H' a t t' T v ts)
  show ?case
  proof (rule rvalue_sem_inv(4))
    show "\<Gamma> \<turnstile> (T, H, Reborrow p) \<Down> (T'', H'', v'')" using Reborrow.prems by simp
  next
    fix H'a aa ta va tsa
    assume "\<Gamma> \<turnstile>\<^sub>w (H, p) \<Down>\<^sub>p (H'a, Reference aa ta)"
    then have "H'a = H' \<and> aa = a \<and> ta = t" using Reborrow.hyps place_sem_det by fastforce
    moreover assume "H'a ! aa = (va, tsa)"
    then have "va = v \<and> tsa = ts" using Reborrow.hyps calculation by auto
    moreover assume "H'' = H'a[aa := (va, tsa @ [length T])]"
    then have "H'' = H'a[a := (v, ts @ [t'])]" using Reborrow.hyps calculation by simp
    moreover assume "v'' = Reference aa (length T)"
    then have "v'' = Reference a t'" using Reborrow.hyps calculation by simp
    moreover assume "T'' = T @ [Unique]"
    thus ?thesis using calculation by simp
  qed
next
  case (Plus H lhs H' lhs' rhs He rhs' T)
  show ?case
  proof (rule rvalue_sem_inv(5))
    show "\<Gamma> \<turnstile> (T, H, Plus lhs rhs) \<Down> (T'', H'', v'')" using Plus.prems by simp
  next
    fix H'a lhs'a rhs'a
    assume "(\<exists>p. lhs = Place p \<and> (\<Gamma> \<turnstile>\<^sub>r (H, p) \<Down>\<^sub>p (H'a, VInt lhs'a)))
            \<or> lhs = Constant (VInt lhs'a) \<and> H'a = H"
    then have "lhs'a = lhs' \<and> H'a = H'" using Plus.hyps operand_sem_det' by fastforce
    moreover
    assume "(\<exists>p. rhs = Place p \<and> (\<Gamma> \<turnstile>\<^sub>r (H'a, p) \<Down>\<^sub>p (H'', VInt rhs'a)))
            \<or> rhs = Constant (VInt rhs'a) \<and> H'' = H'a"
    then have "rhs'a = rhs' \<and> He = H''"
      using Plus.hyps calculation operand_sem_det' by fastforce
    moreover assume "v'' = VInt (lhs'a + rhs'a)"
    thus ?thesis using calculation Plus.prems by auto
  qed
next
  case (Less H lhs H' lhs' rhs He rhs' T)
  show ?case
  proof (rule rvalue_sem_inv(6))
    show "\<Gamma> \<turnstile> (T, H, Less lhs rhs) \<Down> (T'', H'', v'')" using Less.prems by simp
  next
    fix H'a lhs'a rhs'a
    assume "(\<exists>p. lhs = Place p \<and> (\<Gamma> \<turnstile>\<^sub>r (H, p) \<Down>\<^sub>p (H'a, VInt lhs'a)))
            \<or> lhs = Constant (VInt lhs'a) \<and> H'a = H"
    then have "lhs'a = lhs' \<and> H'a = H'" using Less.hyps operand_sem_det' by fastforce
    moreover
    assume "(\<exists>p. rhs = Place p \<and> (\<Gamma> \<turnstile>\<^sub>r (H'a, p) \<Down>\<^sub>p (H'', VInt rhs'a)))
            \<or> rhs = Constant (VInt rhs'a) \<and> H'' = H'a"
    then have "rhs'a = rhs' \<and> He = H''"
      using Less.hyps calculation operand_sem_det' by fastforce
    moreover assume "v'' = VBool (lhs'a < rhs'a)"
    thus ?thesis using calculation Less.prems by auto
  qed
next
  case (Not H op H' v T)
  show ?case
  proof (rule rvalue_sem_inv(7))
    show "\<Gamma> \<turnstile> (T, H, Not op) \<Down> (T'', H'', v'')" using Not.prems by simp
  next
    fix va
    assume "(\<exists>p. op = Place p \<and> (\<Gamma> \<turnstile>\<^sub>r (H, p) \<Down>\<^sub>p (H'', VBool va)))
            \<or> op = Constant (VBool va) \<and> H'' = H"
    then have "H'' = H' \<and> va = v" using Not.hyps operand_sem_det' by fastforce
    moreover assume "T'' = T" and "v'' = VBool (\<not>va)"
    thus ?thesis by (simp add: calculation)
  qed
next
  case (And H lhs H' lhs' rhs He rhs' T)
  show ?case
  proof (rule rvalue_sem_inv(8))
    show "\<Gamma> \<turnstile> (T, H, And lhs rhs) \<Down> (T'', H'', v'')" using And.prems by simp
  next
    fix H'a lhs'a rhs'a
    assume "(\<exists>p. lhs = Place p \<and> (\<Gamma> \<turnstile>\<^sub>r (H, p) \<Down>\<^sub>p (H'a, VBool lhs'a)))
            \<or> lhs = Constant (VBool lhs'a) \<and> H'a = H"
    then have "lhs'a = lhs' \<and> H'a = H'" using And.hyps operand_sem_det' by fastforce
    moreover
    assume "(\<exists>p. rhs = Place p \<and> (\<Gamma> \<turnstile>\<^sub>r (H'a, p) \<Down>\<^sub>p (H'', VBool rhs'a)))
            \<or> rhs = Constant (VBool rhs'a) \<and> H'' = H'a"
    then have "rhs'a = rhs' \<and> He = H''"
      using And.hyps calculation operand_sem_det' by fastforce
    moreover assume "v'' = VBool (lhs'a \<and> rhs'a)"
    thus ?thesis using calculation And.prems by auto
  qed
qed

text \<open>The following lemmas are sanity checks of the semantics.
We must be able to write through the references retrieved by {\sc{Box}} and {\sc{Reborrow}} rules.\<close>

lemma box_writable: "\<Gamma> \<turnstile> (T, H, Box e) \<Down> (T', H', Reference a t) \<Longrightarrow> writable H' (a, t)"
  by auto

lemma wa_preserve_length: "write_access at H = Some H' \<Longrightarrow> length H' = length H"
  sorry
  (*
  by (smt kill_heap.simps kill_preserve_length option.distinct(1)
          option.sel prod.case_eq_if write_access.elims)
*)

lemma write_preserve_length: "\<Gamma> \<turnstile>\<^sub>w p \<Down>\<^sub>p v \<Longrightarrow> length (fst p) = length (fst v)"
proof (induction rule: place_sem.induct)
  case (Var x a t H)
  then show ?case by simp
next
  case (Deref H p H' a t H'')
  assume "write_access (a, t) H' = Some H''"
  then have "length H'' = length H'" using wa_preserve_length by blast
  moreover
  assume "length (fst (H, p)) = length (fst (H', Reference a t))"
  then have "length H = length H'" by simp
  ultimately have "length H'' = length H" by simp
  thus ?case by simp
qed

lemma reborrow_writable: "\<Gamma> \<turnstile> (T, H, Reborrow p) \<Down> (T', H', Reference a t) \<Longrightarrow> writable H' (a, t)"
proof (rule rvalue_sem_inv(4))
  assume "\<Gamma> \<turnstile> (T, H, Reborrow p) \<Down> (T', H', Reference a t)"
  then show "\<Gamma> \<turnstile> (T, H, Reborrow p) \<Down> (T', H', Reference a t)" by auto
next
  fix H'a aa ta va tsa
  assume "Reference a t = Reference aa (length T)"
  then have "aa = a" and "length T = t" by auto

  assume "\<Gamma> \<turnstile>\<^sub>w (H, p) \<Down>\<^sub>p (H'a, Reference aa ta)"
  then have "length H'a = length H" using write_preserve_length by auto
  moreover assume "aa < length H" then have "aa < length H'a" using calculation by simp
  moreover assume "H' = H'a[aa := (va, tsa @ [length T])]"
  then have "H' ! a = (va, tsa @ [t])" and "length H' = length H'a"
    using \<open>aa < length H\<close> \<open>aa = a\<close> \<open>length T = t\<close> calculation by auto
  thus ?thesis using \<open>aa = a\<close> \<open>aa < length H'a\<close> by auto
qed

end