section {* Constant Time (inductive) *}

theory Wasm_Constant_Time_Ind imports Wasm_Secret begin

definition config_actions :: "[s, v list, e list, nat, action list] \<Rightarrow> bool" ("p'_actions \<lparr>_;_;_\<rparr> _ _" 60) where
  "config_actions s vs es i as \<equiv> (\<exists>s' vs' es'. \<lparr>s;vs;es\<rparr> as^^\<leadsto>_i \<lparr>s';vs';es'\<rparr>)"

definition config_trace_set_ind :: "[(s \<times> v list \<times> e list), nat] \<Rightarrow> (action list) set" where
  "config_trace_set_ind \<equiv> \<lambda>(s,vs,es) i. Collect (config_actions s vs es i)"

lemma config_actions_indistinguishable_secrets_ind:
  assumes "(p_actions \<lparr>s;vs;es\<rparr> i as)"
          "(s,vs,es) \<sim>_c (s',vs',es')"
          "\<turnstile>_i s;vs;es : (Untrusted,ts)"
  shows "\<exists>as'. (p_actions \<lparr>s';vs';es'\<rparr> i as') \<and> list_all2 action_indistinguishable as as'"
  using assms(1,3) config_indistinguishable_trace_noninterference[OF _ assms(2)]
        config_indistinguishable_imp_config_typing[OF _ assms(2)]
  unfolding config_actions_def
  by blast

lemma config_actions_indistinguishable_secrets_abs_ind:
  assumes "(p_actions \<lparr>s;vs;es\<rparr> i as)"
          "(s,vs,es) \<sim>_c (s',vs',es')"
          "\<turnstile>_i s;vs;es : (Untrusted,ts)"
  shows "\<exists>as'. (p_actions \<lparr>s';vs';es'\<rparr> i as') \<and> ($\<A> as) = ($\<A> as')"
  using Quotient3_observation config_actions_indistinguishable_secrets_ind[OF assms]
  unfolding Quotient3_def
  by metis

lemma config_trace_set_ind_indistinguishable_secrets_ind:
  assumes "as \<in> (config_trace_set_ind (s,vs,es) i)"
          "(s,vs,es) \<sim>_c (s',vs',es')"
          "\<turnstile>_i s;vs;es : (Untrusted,ts)"
  shows "\<exists>as' \<in> (config_trace_set_ind (s',vs',es') i). list_all2 action_indistinguishable as as'"
proof -
  have "(p_actions \<lparr>s;vs;es\<rparr> i as)"
    using assms(1)
    unfolding config_trace_set_ind_def
    by fastforce
  then obtain as' where "(p_actions \<lparr>s';vs';es'\<rparr> i as') \<and> list_all2 action_indistinguishable as as'"
    using config_actions_indistinguishable_secrets_ind[OF _ assms(2,3)]
    by fastforce
  thus ?thesis
    unfolding config_trace_set_ind_def
    by fastforce
qed

lemma config_actions_indistinguishable_secrets_abs_set_ind:
  assumes "t \<in> (image abs_obs (config_trace_set_ind (s,vs,es) i))"
          "(s,vs,es) \<sim>_c (s',vs',es')"
          "\<turnstile>_i s;vs;es : (Untrusted,ts)"
  shows "t \<in> (image abs_obs (config_trace_set_ind (s',vs',es') i))"
proof -
  obtain as where "(p_actions \<lparr>s;vs;es\<rparr> i as) \<and> ($\<A> as) = t"
    using assms(1)
    unfolding config_trace_set_ind_def
    by fastforce
  then obtain as' where "(p_actions \<lparr>s';vs';es'\<rparr> i as') \<and> ($\<A> as') = t"
    using config_actions_indistinguishable_secrets_abs_ind[OF _ assms(2)] assms(3)
    by fastforce
  thus ?thesis
    unfolding config_trace_set_ind_def
    by fastforce
qed

lemma config_actions_indistinguishable_secrets_abs_set_equiv_ind:
  assumes "(s,vs,es) \<sim>_c (s',vs',es')"
          "\<turnstile>_i s;vs;es : (Untrusted,ts)"
  shows "(image abs_obs (config_trace_set_ind (s,vs,es) i)) = (image abs_obs (config_trace_set_ind (s',vs',es') i))"
  using config_actions_indistinguishable_secrets_abs_set_ind[OF _ assms(1,2)]
        config_indistinguishable_imp_config_typing[OF assms(2,1)]
        config_actions_indistinguishable_secrets_abs_set_ind[OF _ config_indistinguishable_symm[OF assms(1)]]
  by fastforce

lift_definition config_obs_set_ind :: "((s \<times> v list \<times> e list) \<times> nat) \<Rightarrow> observation set" is "(\<lambda>(c,i). (config_trace_set_ind c i))" .

lift_definition config_untrusted_quot_obs_set_ind :: "config_untrusted_quot \<Rightarrow> observation set" is "(\<lambda>c. config_obs_set_ind c)"
proof -
  fix prod1 prod2
  assume assms:"prod1 \<sim>_cp prod2"
  show "config_obs_set_ind prod1 = config_obs_set_ind prod2"
  proof (cases prod1; cases prod2)
    fix c1 i1 c2 i2
    assume prod_assms:"prod1 = (c1,i1)" "prod2 = (c2,i2)"
    show ?thesis
    proof (cases c1; cases c2)
      fix s vs es s' vs' es'
      assume config_assms:"c1 = (s,vs,es)" "c2 = (s',vs',es')"
      obtain ts where ts_def:"(s,vs,es) \<sim>_c (s',vs',es')"
                             "\<turnstile>_i1 s;vs;es : (Untrusted,ts)"
                             "i1 = i2"
        using assms prod_assms config_assms
        unfolding config_untrusted_equiv_def
        by fastforce
      thus ?thesis
        using assms prod_assms config_assms config_actions_indistinguishable_secrets_abs_set_equiv_ind
        unfolding config_obs_set_ind_def
        by simp
    qed
  qed
qed

definition constant_time_ind :: "((s \<times> v list \<times> e list) \<times> nat) \<Rightarrow> bool" where
  "constant_time_ind = (\<lambda>(c, i). \<forall>c'. (c \<sim>_c c') \<longrightarrow> ((config_obs_set_ind (c,i)) = (config_obs_set_ind (c',i))))"

theorem config_untrusted_constant_time_ind:
  assumes "\<turnstile>_i s;vs;es : (Untrusted,ts)"
  shows "constant_time_ind ((s,vs,es),i)"
    using config_actions_indistinguishable_secrets_abs_set_equiv_ind assms
    unfolding constant_time_ind_def config_obs_set_ind_def
    by simp

lift_definition config_untrusted_quot_constant_time_ind :: "config_untrusted_quot \<Rightarrow> bool" is constant_time_ind
proof -
  fix prod1 prod2
  assume assms:"prod1 \<sim>_cp prod2"
  show "constant_time_ind prod1 = constant_time_ind prod2"
  proof (cases prod1; cases prod2)
    fix c i c' i'
    assume local_assms:"prod1 = (c,i)" "prod2 = (c',i')"
    show ?thesis
    proof (cases c; cases c')
      fix s vs es s' vs' es'
      assume inner_assms:"c = (s,vs,es)" "c' = (s',vs',es')"
      thus ?thesis
        using assms local_assms config_untrusted_constant_time_ind
        unfolding config_untrusted_equiv_def
        by (simp del: config_indistinguishable.simps) (metis config_indistinguishable_imp_config_typing)
    qed
  qed
qed

lemma config_untrusted_quot_constant_time_trivial_ind:
  "config_untrusted_quot_constant_time_ind = (\<lambda>x. True)"
  using config_untrusted_constant_time_ind rep_config_untrusted_quot_typing
  unfolding config_untrusted_quot_constant_time_ind.rep_eq
  by (metis prod.exhaust)

definition "trace_set_equiv = rel_set (list_all2 action_indistinguishable)"

definition constant_time_traces_ind :: "((s \<times> v list \<times> e list) \<times> nat) \<Rightarrow> bool" where
  "constant_time_traces_ind = (\<lambda>(c, i). \<forall>c'. (c \<sim>_c c') \<longrightarrow> trace_set_equiv (config_trace_set_ind c i) (config_trace_set_ind c' i))"

lemma config_untrusted_constant_time_traces:
  assumes "\<turnstile>_i s;vs;es : (Untrusted,ts)"
  shows "constant_time_traces_ind ((s,vs,es),i)"
  using assms
  unfolding trace_set_equiv_def rel_set_def constant_time_traces_ind_def
  apply (simp del: config_indistinguishable.simps)
  apply (metis config_indistinguishable_imp_config_typing config_indistinguishable_symm config_trace_set_ind_indistinguishable_secrets_ind observation.abs_eq_iff)
  done
end


section \<open>Array-Blocks --- Reasoning Setup\<close>
theory Sep_Array_Block_RS
imports "../basic/LLVM_Basic_Main" Sep_Block_Allocator_RS
begin

type_synonym 'aval ablock = "nat \<Rightarrow> 'aval"

instantiation baddr :: (this_addr) addr_algebra begin
  definition "abase \<equiv> \<lambda>BADDR i va \<Rightarrow> va=this_addr"
  definition "(~\<^sub>a) \<equiv> \<lambda>BADDR i1 va1 \<Rightarrow> \<lambda>BADDR i2 va2 \<Rightarrow> va1=this_addr \<and> va2=this_addr"
  definition "(-\<^sub>a) \<equiv> \<lambda>BADDR i1 va1 \<Rightarrow> \<lambda>BADDR i2 va2 \<Rightarrow> i1 - i2"
  definition "(+\<^sub>a) \<equiv> \<lambda>BADDR i va \<Rightarrow> \<lambda>j. BADDR (i+j) va"

  lemma abase_baddr_simp[simp]: "abase (BADDR i va) \<longleftrightarrow> va=this_addr"
    by (simp add: abase_baddr_def)
  lemma acompat_baddr_simp[simp]: "BADDR i1 va1 ~\<^sub>a BADDR i2 va2 \<longleftrightarrow> va1=this_addr \<and> va2=this_addr"
    by (simp add: acompat_baddr_def)
  lemma adiff_baddr_simp[simp]: "BADDR i1 va1 -\<^sub>a BADDR i2 va2 = i1 - i2"
    by (simp add: adiff_baddr_def)
  lemma aidx_baddr_simp[simp]: "BADDR i va +\<^sub>a j = BADDR (i+j) va"
    by (simp add: aidx_baddr_def)

  instance
    apply standard
    apply (intro part_equivpI sympI transpI)
    apply (auto
      simp: abase_baddr_def acompat_baddr_def adiff_baddr_def aidx_baddr_def
      split: baddr.splits)
    done

end

locale array_block2 = array_block1 static_err mem_err vload vstore vgep
    for static_err :: 'err
    and mem_err :: 'err
    and vload :: "'vaddr::this_addr \<Rightarrow> ('val,_,'val,'err) M"
    and vstore :: "'val \<Rightarrow> 'vaddr \<Rightarrow> (unit,_,'val,'err) M"
    and vgep :: "'vaddr \<Rightarrow> 'vidx \<Rightarrow> ('vaddr,_,'val,'err) M"

+ fixes \<alpha>v :: "'val \<Rightarrow> 'aval::unique_zero_sep_algebra"
    and vpto :: "'val \<Rightarrow> 'vaddr \<Rightarrow> 'aval \<Rightarrow> bool"
    and vcomplete :: "'aval \<Rightarrow> bool"

  assumes vload_rule: "htriple \<alpha>v (vpto x va) (vload va) (\<lambda>r. \<up>(r=x) ** vpto x va)"
      and vstore_rule: "htriple \<alpha>v (vpto xx va) (vstore x va) (\<lambda>_. vpto x va)"
      and vpto_notZ: "\<And>x a. \<not>vpto x a 0"
      and vcompleteD: "\<And>v v'. \<lbrakk>vcomplete v; v##v'\<rbrakk> \<Longrightarrow> v'=0"
      and vpto_this: "\<And>v av. vpto v this_addr av \<longleftrightarrow> av = \<alpha>v v"
      and \<alpha>v_complete: "\<And>v. vcomplete (\<alpha>v v)"

begin

  (*
  lemma is_arr_baddr_idx[simp]: "is_arr_baddr (idx_baddr a i) \<longleftrightarrow> is_arr_baddr a"
    by (auto simp: is_arr_baddr_def idx_baddr_def split: baddr.splits)

  lemma idx_baddr_add[simp]: "idx_baddr (idx_baddr a i) j = idx_baddr a (i+j)"
    by (auto simp: idx_baddr_def split: prod.splits baddr.splits)

  definition "idx_ptr \<equiv> \<lambda>RP_ADDR (ADDR bi ba) \<Rightarrow> \<lambda>i. RP_ADDR (ADDR bi (idx_baddr ba i)) | RP_NULL \<Rightarrow> \<lambda>i. RP_NULL"
  *)

  (* TODO: Rename to is_block_ptr! *)
  definition is_block_ptr :: "'vaddr baddr addr rptr \<Rightarrow> bool"
    where "is_block_ptr \<equiv> \<lambda>RP_ADDR (ADDR bi ba) \<Rightarrow> ba=this_addr | _ \<Rightarrow> False"

  (*definition "is_arr_ptr \<equiv> \<lambda>RP_ADDR (ADDR bi ba) \<Rightarrow> is_arr_baddr ba | _ \<Rightarrow> False"*)

  (*
  lemma is_arr_ptr_simps[simp]:
    "is_arr_ptr (RP_ADDR (ADDR bi ba)) = is_arr_baddr ba"
    "is_arr_ptr RP_NULL \<longleftrightarrow> False"
    by (auto simp: is_arr_ptr_def)
  *)

  lemma is_block_ptr_simps[simp]:
    "\<not>is_block_ptr RP_NULL"
    "is_block_ptr (RP_ADDR (ADDR bi ba)) \<longleftrightarrow> ba=this_addr"
    by (auto simp: is_block_ptr_def)

  lemma block_ptr_imp_abase[simp, intro]: "is_block_ptr p \<Longrightarrow> abase p"
    by (auto simp: is_block_ptr_def this_addr_baddr_def split: rptr.splits addr.splits)

  (*

  lemma idx_ptr_add[simp]: "idx_ptr (idx_ptr a i) j = idx_ptr a (i+j)"
    by (auto simp: idx_ptr_def split: rptr.splits addr.splits)

  lemma is_arr_ptr_idx[simp]: "is_arr_ptr (idx_ptr p i) \<longleftrightarrow> is_arr_ptr p"
    by (cases p) (auto simp: idx_ptr_def is_arr_ptr_def split: rptr.splits addr.splits)
  *)

  lemma \<alpha>v_notZ[simp]: "\<alpha>v v \<noteq> 0"
    using vpto_notZ vpto_this by fastforce

  definition "\<alpha> \<equiv> list\<alpha> \<alpha>v"

  definition pto :: "'val \<Rightarrow> 'vaddr baddr \<Rightarrow> 'aval ablock \<Rightarrow> bool"
    where "pto \<equiv> \<lambda>x. \<lambda>BADDR i va \<Rightarrow> \<lambda>s. \<exists>v. i\<ge>0 \<and> s=0(nat i:=v) \<and> vpto x va v"

  definition tag_of :: "'val block \<Rightarrow> int" where "tag_of \<equiv> int o length"

  definition "is_complete_tag ablk n \<equiv> 0\<le>n \<and> (\<forall>i. (ablk i \<noteq> 0 \<longleftrightarrow> i<nat n) \<and> (\<forall>i. ablk i \<noteq> 0 \<longrightarrow> vcomplete (ablk i)))"

  definition "array_lifter i \<equiv> idx_lifter (\<lambda>_. ()) \<alpha>v i"

  lemma array_lifter_simps[simp]:
    "sep_lifter.\<alpha>s (array_lifter i) = \<alpha>v"
    "sep_lifter.\<alpha>b (array_lifter i) = \<alpha>"
    "sep_lifter.L (array_lifter i) = idx\<^sub>L i"
    unfolding array_lifter_def \<alpha>_def by auto

  interpretation array_lifter: sep_lifter "array_lifter i" for i
    unfolding array_lifter_def by simp

  lemma pto_is_lift: "pto x = (\<lambda>BADDR i va \<Rightarrow> (\<up>(i\<ge>0) ** array_lifter.lift_assn (nat i) (vpto x va)))"
    unfolding array_lifter.lift_assn_def
    apply (rule ext)
    apply (clarsimp simp: array_lifter_def pto_def split: baddr.splits)
    apply (intro ext)
    apply (auto simp: sep_algebra_simps pred_lift_extract_simps)
    by (metis fun_upd_triv fun_upd_upd)

  lemma lift_is_pto: "i\<ge>0 \<Longrightarrow> array_lifter.lift_assn (nat i) (vpto x va) = pto x (BADDR i va)"
    by (simp add: pto_is_lift sep_algebra_simps pred_lift_extract_simps)

  declare vpto_notZ[simp]

  lemma load_rule: "htriple \<alpha> (pto x va) (load va) (\<lambda>r. \<up>(r=x) ** pto x va)"
    unfolding load_def
    supply pto_is_lift[simp]
    apply (cases va; clarsimp simp: htriple_extract_pre_pure sep_algebra_simps)
    using array_lifter.lift_operation[simplified, OF _ vload_rule, simplified]
    .

  lemma store_rule: "htriple \<alpha> (pto xx va) (store x va) (\<lambda>_. pto x va)"
    unfolding store_def
    supply pto_is_lift[simp]
    apply (cases va; clarsimp simp: htriple_extract_pre_pure sep_algebra_simps)
    using array_lifter.lift_operation[simplified, OF _ vstore_rule, simplified]
    .

  lemma load_pres_tag: "wlp (load a) (\<lambda>_ s'. tag_of s' = tag_of s) s"
    unfolding load_def
    apply (auto simp: wlp_def run_simps tag_of_def split: prod.splits option.splits baddr.splits)
    apply (rule mwp_trivI)
    by auto

  lemma store_pres_tag: "wlp (store a x) (\<lambda>_ s'. tag_of s' = tag_of s) s"
    unfolding store_def
    apply (auto simp: wlp_def run_simps tag_of_def split: prod.splits option.splits baddr.splits)
    apply (rule mwp_trivI)
    by auto

  lemma complete_tag:
    "\<lbrakk>is_complete_tag ablock (tag_of cblock); ablock ## f; \<alpha> cblock = ablock + f\<rbrakk> \<Longrightarrow> f = 0"
    apply (auto simp: is_complete_tag_def tag_of_def)
    by (smt \<alpha>_def disjoint_zero_sym list\<alpha>_in_range sep_add_disj_eq sep_disj_fun_def sep_disj_zero unique_zero vcompleteD)

  (* TODO: Move *)
  lemma Z_upd_eq_Z_iff[simp]: "0(i:=x) = 0 \<longleftrightarrow> x=0" by (auto simp: fun_eq_iff)

  lemma pto_notZ: "\<not> pto x a 0"
    apply (cases a)
    apply (auto simp: pto_def sep_algebra_simps)
    done

  lemma checked_idx_baddr_rule: "abase a
    \<Longrightarrow> htriple \<alpha> (pto xx (a +\<^sub>a i)) (checked_idx_baddr a i) (\<lambda>r. \<up>(r=a +\<^sub>a i) ** pto xx (a +\<^sub>a i))"
    apply (rule htripleI')
    unfolding checked_idx_baddr_def check_addr_def pto_is_lift
    apply (clarsimp simp: pred_lift_extract_simps split: baddr.splits)
    apply (frule (1) array_lifter.infer_pre_get_with_frame, simp, simp)
    apply (force simp: wp_def run_simps aidx_baddr_def abase_baddr_def sep_algebra_simps split: prod.splits baddr.splits)
    done

  sublocale ba: block_allocator2 static_err mem_err load store check_addr \<alpha> pto tag_of is_complete_tag
    apply unfold_locales
    apply (rule load_rule)
    apply (rule store_rule)
    apply (rule load_pres_tag)
    apply (rule store_pres_tag)
    apply (rule complete_tag; assumption)
    apply (rule pto_notZ)
    done

  lemma list\<alpha>_rep_nn: "list\<alpha> \<alpha>v (replicate n v) n = 0"
    by (auto simp: list\<alpha>_def)

  lemma pto_this_exact: "pto x (BADDR i this_addr) = (\<up>(i\<ge>0) ** EXACT (0(nat i:=\<alpha>v x)))"
    by (auto simp: pto_def vpto_this pred_lift_extract_simps del: ext intro!: ext)

  lemma ba_pto_this_exact:
    "\<lbrakk>is_block_ptr p; i\<ge>0\<rbrakk>
    \<Longrightarrow> ba.pto x (p +\<^sub>a i) = EXACT (0(rptr_the_block_index p := (0(nat i:=\<alpha>v x),0)))"
    apply (auto
      simp: ba.pto_def aidx_baddr_def pto_this_exact this_addr_baddr_def
      simp: pred_lift_extract_simps is_block_ptr_def
      split: rptr.splits addr.splits baddr.splits)
    done

  lemma lift_pto_exact: "i\<ge>0 \<Longrightarrow> ba.block_lifter.lift_assn bi (pto v (this_addr +\<^sub>a i)) = EXACT (0(bi := (0(nat i:=\<alpha>v v),0)))"
    apply (auto
      simp:  aidx_baddr_def pto_this_exact this_addr_baddr_def
      simp: pred_lift_extract_simps is_block_ptr_def
      split: rptr.splits addr.splits baddr.splits)
    done

  (* TODO: Move *)
  lemma atLeast_lessThan_plus1:
    "l\<le>v \<Longrightarrow> {l..<1+v::int} = insert v {l..<v}"
    "l\<le>v \<Longrightarrow> {l..<v+1::int} = insert v {l..<v}"
    by auto

  lemma sep_set_img_int_range_to_nat: "(\<Union>*i\<in>{0..<int n}. f i) = (\<Union>*i\<in>{0..<n}. f (int i))"
    apply (induction n)
    apply (auto simp: atLeast_lessThan_plus1 atLeast0_lessThan_Suc)
    done

  lemma ba_block_alt:
    "ba.block (\<alpha> (init v n)) p = (\<up>(is_block_ptr p) ** (\<Union>*i\<in>{0..<int n}. ba.pto v (p +\<^sub>a i)))"
  proof -
    have ba_block_alt_aux: "(\<Union>*i\<in>{0..<int n}. EXACT (0(x1 := (0(nat i := \<alpha>v v), 0)))) = EXACT (0(x1 := (list\<alpha> \<alpha>v (replicate n v), 0)))"
      for x1::nat
      apply (induction n)
      supply replicate_Suc_conv_snoc[simp] replicate_Suc[simp del]
      subgoal by (auto simp: sep_algebra_simps del: ext intro!: ext)
      subgoal
        apply simp
        by (auto
          simp: list\<alpha>_snoc sep_algebra_simps sep_disj_fun_def atLeast0_lessThan_Suc atLeast_lessThan_plus1 sep_conj_def list\<alpha>_rep_nn
          cong del: if_cong
          del: ext intro!: ext)
      done

    have foo: "\<lbrakk>P=Q; Q \<Longrightarrow> X=Y\<rbrakk> \<Longrightarrow> (\<up>P**X) = (\<up>Q**Y)" for P Q X Y by auto
    have [simp]: "(\<Union>*x\<in>{0..<int n}. ba.pto v ((RP_ADDR (ADDR x1 (this_addr +\<^sub>a x)))))
      = (\<Union>*x\<in>{0..<int n}. EXACT (0(x1 := (0(nat x := \<alpha>v v), 0))))" for x1
      apply (rule sep_set_img_cong)
      apply (auto simp: lift_pto_exact)
      done

    note [simp del] = ba.pto_addr_eq

    show ?thesis
      unfolding init_def ba.block_def
      by (auto
        split: rptr.splits addr.splits
        simp: sep_algebra_simps
        simp: \<alpha>_def ba_block_alt_aux
        intro!: foo
        )
  qed

  lemma ba_block_exs_alt_aux:
    assumes "n\<ge>0"
    shows "(\<Union>*i\<in>{0..<n}. (EXS x. ba.pto x ((RP_ADDR (ADDR bi (this_addr +\<^sub>a i))))))
      = (EXS xs. \<up>(int (length xs) = n) ** EXACT (0(bi := (list\<alpha> \<alpha>v xs, 0))))"
    using assms
  proof (induction n rule: int_induct[where k=0])
    case base
    then show ?case by (auto simp: sep_algebra_simps pred_lift_extract_simps del: ext intro!: ext)
  next
    case (step1 n)

    note [simp] = \<open>0\<le>n\<close>
    note IH = step1.IH[simplified]

    have [simp]: "n+1\<noteq>0" using \<open>0\<le>n\<close> by linarith

    note replicate_Suc_conv_snoc[simp] replicate_Suc[simp del]
    show ?case
      apply (simp add: atLeast_lessThan_plus1)
      apply (simp add: IH)
      apply (rule ext)
      apply (auto simp: sep_algebra_simps pred_lift_extract_simps sep_disj_fun_def sep_conj_def list\<alpha>_at_len lift_pto_exact)
      subgoal for x xs
        apply (rule exI[where x="xs@[x]"])
        apply (auto del: ext intro!: ext simp: list\<alpha>_snoc sep_algebra_simps list\<alpha>_at_len
          simp: this_addr_baddr_def pto_this_exact
        )
        done
      subgoal for xs
        apply (rule exI[where x="last xs"])
        apply (rule exI[where x="butlast xs"]; simp)
        apply (cases xs rule: rev_cases)
        apply (auto simp: list\<alpha>_gt_len sep_algebra_simps list\<alpha>_snoc del: ext intro!: ext)
        done
      done
  next
    case (step2 n) thus ?case by (auto)
  qed

  lemma ba_block_exs_alt:
    "\<lbrakk>is_block_ptr p; n\<ge>0\<rbrakk> \<Longrightarrow> (\<Union>*i\<in>{0..<n}. EXS v. ba.pto v (p +\<^sub>a i)) = (EXS blk. \<up>(int (length blk) = n) ** ba.block (\<alpha> blk) p)"
    unfolding init_def ba.block_def
    supply [simp del] = ba.pto_addr_eq
    apply (cases p rule: ba.rptr_cases.cases; simp)
    apply (rule ext)
    apply (auto
      split: rptr.splits addr.splits
      simp: sep_algebra_simps pred_lift_extract_simps \<alpha>_def ba_block_exs_alt_aux
      )
    done

  lemma tag_of_init[simp]: "tag_of (init v n) = int n" by (auto simp: tag_of_def init_def)

  lemma ba_allocn_rule: "htriple ba.\<alpha> \<box> (ba_allocn v n) (\<lambda>r. (\<Union>*i\<in>{0..<int n}. ba.pto v (r +\<^sub>a i)) ** ba.tag (int n) r ** \<up>(abase r))"
    unfolding ba_allocn_def
    apply (rule cons_rule[OF ba.alloc_rule])
    apply simp
    apply (simp add: ba_block_alt sep_algebra_simps pred_lift_extract_simps)
    done

  (* TODO: Move to gen_wp locale *)
  lemma wp_cons: "wp c Q s \<Longrightarrow> (\<And>x s. Q x s \<Longrightarrow> Q' x s) \<Longrightarrow> wp c Q' s"
    by (simp add: wp_monoI)

  lemma blk_complete_tag[simp]: "is_complete_tag (\<alpha> blk) (int (length blk))"
    by (auto simp: is_complete_tag_def \<alpha>_def list\<alpha>_def \<alpha>v_complete)

  (* TODO: is_base_ptr: This logic is already encoded in ba.tag! Try to get rid of is_base_ptr! *)
  lemma ba_tag_extr_baseptr: "ba.tag n p = (\<up>(is_block_ptr p \<and> 0\<le>n) ** ba.tag n p)"
    apply (rule ext)
    apply (auto simp: ba.tag_def sep_algebra_simps pred_lift_extract_simps split: addr.splits rptr.splits)
    apply (auto simp: tag_of_def)
    done

  lemma ba_freen_rule: "htriple ba.\<alpha> ((\<Union>*i\<in>{0..<n}. EXS v. ba.pto v (p+\<^sub>ai)) \<and>* ba.tag n p) (ba.free p) (\<lambda>_. \<box>)"
    apply (subst ba_tag_extr_baseptr)
    apply (rule htripleI')
    apply (clarsimp simp: sep_algebra_simps pred_lift_extract_simps)
    apply (simp add: ba_block_exs_alt)
    apply (clarsimp simp: sep_algebra_simps pred_lift_extract_simps)

    subgoal for pp s f blk
      supply R = ba.free_rule[of "\<alpha> blk" p "int (length blk)"]
      apply (rule R[THEN htripleD', THEN wp_cons])
      apply assumption+
      apply (simp add: sep_algebra_simps)
      apply (simp add: sep_algebra_simps)
      done
    done

  lemma checked_idx_baddr_pres_tag: "wlp (checked_idx_baddr (BADDR a b) i) (\<lambda>_ s'. tag_of s' = tag_of sa) sa"
    by (auto simp: wlp_def checked_idx_baddr_def check_addr_def run_simps split: prod.splits baddr.splits)

  (* TODO: Move *)
  lemma return_rule: "htriple \<alpha> P (return x) (\<lambda>r. \<up>(r=x)**P)" for \<alpha>
    by vcg

  (* TODO: Move *)
  lemma wlp_return[simp]: "wlp (return x) Q s = Q x s"
    by (auto simp: wlp_def run_simps)

  lemma checked_idx_ptr_rule: "abase p
    \<Longrightarrow> htriple ba.\<alpha> (ba.pto xx (p +\<^sub>a i)) (checked_idx_ptr p i) (\<lambda>r. \<up>(r=p +\<^sub>a i) ** ba.pto xx (p +\<^sub>a i))"
    unfolding checked_idx_ptr_def
    apply (cases p rule: ba.rptr_cases.cases; simp add: zoom_bind)
    supply [vcg_rules] = ba.block_lifter.lift_operation[simplified, OF _ _ checked_idx_baddr_rule]
    supply [vcg_rules] = ba.block_lifter.lift_operation[simplified, OF _ _ return_rule]
    supply [simp] = pto_notZ checked_idx_baddr_pres_tag abase_baddr_def
    supply [named_ss fri_prepare_simps] = aidx_baddr_simp
    supply [split] = baddr.splits
    apply vcg
    done

end

end


(*
 * Copyright 2014, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(NICTA_BSD)
 *)

section "32-Bit Machine Word Setup"

theory Machine_Word_32
  imports Machine_Word_32_Basics More_Word Bit_Shifts_Infix_Syntax Rsplit
begin

context
  includes bit_operations_syntax
begin

type_synonym machine_word = \<open>machine_word_len word\<close>

lemma word_bits_len_of:
  \<open>LENGTH(machine_word_len) = word_bits\<close>
  by (simp add: word_bits_conv)

lemma word_bits_size:
  "size (w :: machine_word) = word_bits"
  by (simp add: word_bits_def word_size)

lemma word_bits_word_size_conv:
  \<open>word_bits = word_size * 8\<close>
  by (simp add: word_bits_def word_size_def)

lemma word_size_word_size_bits:
  \<open>word_size = (2 :: 'a :: semiring_1) ^ word_size_bits\<close>
  by (simp add: word_size_def word_size_bits_def)

lemma lt_word_bits_lt_pow:
  "sz < word_bits \<Longrightarrow> sz < 2 ^ word_bits"
  by (simp add: word_bits_conv)

lemma if_then_1_else_0:
  "((if P then 1 else 0) = (0 :: machine_word)) = (\<not> P)"
  by simp

lemma if_then_0_else_1:
  "((if P then 0 else 1) = (0 :: machine_word)) = (P)"
  by simp

lemmas if_then_simps = if_then_0_else_1 if_then_1_else_0

lemma bool_mask [simp]:
  \<open>0 < x AND 1 \<longleftrightarrow> x AND 1 = 1\<close> for x :: machine_word
  by (rule bool_mask') auto

lemma in_16_range:
  "0 \<in> S \<Longrightarrow> r \<in> (\<lambda>x. r + x * (16 :: machine_word)) ` S"
  "n - 1 \<in> S \<Longrightarrow> (r + (16 * n - 16)) \<in> (\<lambda>x :: machine_word. r + x * 16) ` S"
  by (clarsimp simp: image_def elim!: bexI[rotated])+

lemma le_step_down_word_3:
  fixes x :: machine_word
  shows "\<lbrakk>x \<le> y; x \<noteq> y\<rbrakk> \<Longrightarrow> x \<le> y - 1"
  by (fact le_step_down_word_2)

lemma shiftr_1:
  "(x::machine_word) >> 1 = 0 \<Longrightarrow> x < 2"
  apply transfer
  apply (simp add: take_bit_drop_bit)
  apply (simp add: drop_bit_Suc)
  done

lemma Suc_unat_mask_div:
  "Suc (unat (mask sz div word_size :: machine_word)) = 2 ^ (min sz word_bits - word_size_bits)"
  by (simp add: word_size_word_size_bits unat_drop_bit_eq unat_mask_eq drop_bit_mask_eq Suc_mask_eq_exp
    flip: drop_bit_eq_div word_bits_conv)

lemma ucast_not_helper:
  fixes a::"8 word"
  assumes a: "a \<noteq> 0xFF"
  shows "ucast a \<noteq> (0xFF::machine_word)"
proof
  assume "ucast a = (0xFF::machine_word)"
  also
  have "(0xFF::machine_word) = ucast (0xFF::8 word)" by simp
  finally
  show False using a
    apply -
    apply (drule up_ucast_inj, simp)
    apply simp
    done
qed

lemma unat_less_2p_word_bits:
  "unat (x :: machine_word) < 2 ^ word_bits"
  apply (simp only: word_bits_def)
  apply (rule unat_lt2p)
  done

lemma unat_less_word_bits:
  fixes y :: machine_word
  shows "x < unat y \<Longrightarrow> x < 2 ^ word_bits"
  unfolding word_bits_def
  by (rule order_less_trans [OF _ unat_lt2p])

lemma unat_mask_2_less_4:
  "unat (p AND mask 2 :: machine_word) < 4"
  by (rule unat_less_helper) (simp only: take_bit_eq_mod word_mod_less_divisor flip: take_bit_eq_mask, simp add: word_mod_less_divisor)

lemma unat_mult_simple:
  \<open>unat (x * y) = unat x * unat y\<close>
    if \<open>unat x * unat y < 2 ^ LENGTH(machine_word_len)\<close>
    for x y :: machine_word
  using that by (simp flip: unat_mult_lem)

lemma upto_2_helper:
  "{0..<2 :: machine_word} = {0, 1}"
  by (safe; simp) unat_arith

lemma word_ge_min:
  \<open>- (2 ^ (word_bits - 1)) \<le> sint x\<close> for x :: machine_word
  using sint_ge [of x] by (simp add: word_bits_def)

lemma word_rsplit_0:
  "word_rsplit (0 :: machine_word) = replicate (word_bits div 8) (0 :: 8 word)"
  by (simp add: word_rsplit_def bin_rsplit_def word_bits_def word_size_def Cons_replicate_eq)

lemma x_less_2_0_1:
  fixes x :: machine_word
  shows "x < 2 \<Longrightarrow> x = 0 \<or> x = 1"
  by (rule x_less_2_0_1') auto

end

end


(*  Title:       Isabelle Collections Library
    Author:      Peter Lammich <peter dot lammich at uni-muenster.de>
    Maintainer:  Peter Lammich <peter dot lammich at uni-muenster.de>
*)
section {* \isaheader{Map Implementation by Associative Lists} *}
theory ListMapImpl
imports
  "../spec/MapSpec"
  "../../Lib/Assoc_List"
  "../gen_algo/MapGA"
begin
text_raw {*\label{thy:ListMapImpl}*}

(*@impl Map
  @type 'a lm
  @abbrv lm,l
  Maps implemented by associative lists. If you need efficient
  @{text "insert_dj"} operation, you should use list sets with explicit
  invariants (lmi).
*)

type_synonym ('k,'v) lm = "('k,'v) assoc_list"

definition [icf_rec_def]: "lm_basic_ops \<equiv> \<lparr>
  bmap_op_\<alpha> = Assoc_List.lookup,
  bmap_op_invar = \<lambda>_. True,
  bmap_op_empty = (\<lambda>_::unit. Assoc_List.empty),
  bmap_op_lookup = (\<lambda>k m. Assoc_List.lookup m k),
  bmap_op_update = Assoc_List.update,
  bmap_op_update_dj = Assoc_List.update,
  bmap_op_delete = Assoc_List.delete,
  bmap_op_list_it = Assoc_List.iteratei
\<rparr>"

setup Locale_Code.open_block
interpretation lm_basic: StdBasicMapDefs lm_basic_ops .
interpretation lm_basic: StdBasicMap lm_basic_ops
  apply unfold_locales
  apply (simp_all add: icf_rec_unf
    Assoc_List.lookup_empty' Assoc_List.iteratei_correct)
  done
setup Locale_Code.close_block

definition [icf_rec_def]: "lm_ops \<equiv> lm_basic.dflt_ops"
setup Locale_Code.open_block
interpretation lm: StdMapDefs lm_ops .
interpretation lm: StdMap lm_ops
  unfolding lm_ops_def
  by (rule lm_basic.dflt_ops_impl)
interpretation lm: StdMap_no_invar lm_ops
  by unfold_locales (simp add: icf_rec_unf)
setup Locale_Code.close_block

setup {* ICF_Tools.revert_abbrevs "lm"*}

lemma pi_lm[proper_it]:
  "proper_it' Assoc_List.iteratei Assoc_List.iteratei"
  unfolding Assoc_List.iteratei_def[abs_def]
  by (intro icf_proper_iteratorI proper_it'I)

interpretation pi_lm: proper_it_loc Assoc_List.iteratei Assoc_List.iteratei
  apply unfold_locales
  apply (rule pi_lm)
  done

lemma pi_lm'[proper_it]:
  "proper_it' lm.iteratei lm.iteratei"
  unfolding lm.iteratei_def[abs_def]
  by (intro icf_proper_iteratorI proper_it'I)

interpretation pi_lm': proper_it_loc lm.iteratei lm.iteratei
  apply unfold_locales
  apply (rule pi_lm')
  done

text {* Code generator test *}
definition "test_codegen \<equiv> (
  lm.add ,
  lm.add_dj ,
  lm.ball ,
  lm.bex ,
  lm.delete ,
  lm.empty ,
  lm.isEmpty ,
  lm.isSng ,
  lm.iterate ,
  lm.iteratei ,
  lm.list_it ,
  lm.lookup ,
  lm.restrict ,
  lm.sel ,
  lm.size ,
  lm.size_abort ,
  lm.sng ,
  lm.to_list ,
  lm.to_map ,
  lm.update ,
  lm.update_dj)"

export_code test_codegen in SML

end


(*
 * Copyright 2014, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(NICTA_BSD)
 *)

(* License: BSD, terms see file ./LICENSE *)

theory Addr_Type
imports "~~/src/HOL/Word/Word"
begin

type_synonym addr_bitsize = "32"
type_synonym addr = "addr_bitsize word"
definition addr_bitsize :: nat where "addr_bitsize \<equiv> 32"
definition addr_align :: nat where "addr_align \<equiv> 2"
declare addr_align_def[simp]

definition addr_card :: nat where
  "addr_card \<equiv> card (UNIV::addr set)"

declare addr_bitsize_def[simp]

lemma addr_card:
  "addr_card = 2^addr_bitsize"
  by (simp add: addr_card_def card_word)

lemma len_of_addr_card:
  "2 ^ len_of TYPE(addr_bitsize) = addr_card"
  by (simp add: addr_card)

lemma of_nat_addr_card [simp]:
  "of_nat addr_card = (0::addr)"
  by (simp add: addr_card)

end


theory AltDropEnv
  imports WTLemma
begin

  (*
lemma var_value_prim1: "\<lbrakk> v \<noteq> NoRef; var_val_type v tau tau_x \<rbrakk> \<Longrightarrow> req_type tau \<noteq> Prim"
  apply (case_tac v)
    apply (auto)
   apply (case_tac tau_x)
         apply (auto)
  apply (case_tac tau_x)
        apply (auto)
  done

lemma var_value_unlim: "\<lbrakk> v \<noteq> NoRef; var_val_type v tau tau_x \<rbrakk> \<Longrightarrow> req_type tau_x = Ref"
  apply (case_tac v)
    apply (auto)
   apply (case_tac tau_x)
         apply (auto)
  apply (case_tac tau_x)
        apply (auto)
  done  *)

    (* - requirements dropping (reduces requirements to pass into lambdas) *)

definition drop_use_env where
  "drop_use_env r_s = (\<lambda> x. if r_s x = OwnPerm then UsePerm else r_s x)"

lemma self_drop_leq_use_env: "leq_use_env (drop_use_env r_x) r_x"
  apply (simp add: leq_use_env_def)
  apply (simp add: drop_use_env_def)
  apply (auto)
  apply (case_tac "r_x x")
    apply (auto)
  done

lemma drop_leq_use_env: "\<lbrakk> leq_use_env r_x r_s \<rbrakk> \<Longrightarrow> leq_use_env (drop_use_env r_x) r_s"
  apply (rule_tac r_sb="r_x" in trans_leq_use_env)
   apply (simp)
  apply (rule_tac self_drop_leq_use_env)
  done

lemma dist_drop_leq_use_env: "\<lbrakk> leq_use_env r_x r_s \<rbrakk> \<Longrightarrow> leq_use_env (drop_use_env r_x) (drop_use_env r_s)"
  apply (simp add: leq_use_env_def)
  apply (auto)
  apply (erule_tac x="x" in allE)
  apply (simp add: drop_use_env_def)
  apply (auto)
   apply (case_tac "r_s x")
     apply (auto)
  apply (case_tac "r_x x")
    apply (auto)
  done

lemma weak_drop_use_env: "\<lbrakk> weak_use_env r_s \<rbrakk> \<Longrightarrow> drop_use_env r_s = r_s"
  apply (case_tac "\<forall> x. drop_use_env r_s x = r_s x")
   apply (auto)
  apply (simp add: drop_use_env_def)
  apply (simp add: weak_use_env_def)
  done

lemma drop_weak_use_env: "weak_use_env (drop_use_env r_s)"
  apply (simp add: weak_use_env_def)
  apply (simp add: drop_use_env_def)
  done

lemma dist_drop_comp_use_env: "drop_use_env (comp_use_env r_sa r_sb) = comp_use_env (drop_use_env r_sa) (drop_use_env r_sb)"
  apply (case_tac "\<forall> x. drop_use_env (comp_use_env r_sa r_sb) x = comp_use_env (drop_use_env r_sa) (drop_use_env r_sb) x")
   apply (auto)
  apply (simp add: comp_use_env_def)
  apply (simp add: drop_use_env_def)
  apply (case_tac "r_sa x")
    apply (auto)
    apply (case_tac "r_sb x")
      apply (auto)
   apply (case_tac "r_sb x")
     apply (auto)
  apply (case_tac "r_sb x")
    apply (auto)
  done

lemma dom_lift_comp_use_env: "\<lbrakk> r = OwnPerm \<rbrakk> \<Longrightarrow> comp_use_env r_s (lift_use_env r_s r) = comp_use_env (drop_use_env r_s) (lift_use_env r_s r)"
  apply (case_tac "\<forall> x. comp_use_env r_s (lift_use_env r_s r) x = comp_use_env (drop_use_env r_s) (lift_use_env r_s r) x")
   apply (auto)
  apply (simp add: comp_use_env_def)
  apply (simp add: drop_use_env_def)
  apply (case_tac "r_s x")
    apply (auto)
  done

lemma drop_lift_leq_use_env: "leq_use_env (drop_use_env (lift_use_env r_s r)) (lift_use_env (drop_use_env r_s) r)"
  apply (simp add: drop_use_env_def)
  apply (simp add: leq_use_env_def)
  apply (auto)
   apply (case_tac r)
     apply (auto)
  apply (case_tac r)
    apply (auto)
   apply (case_tac "r_s x")
     apply (auto)
  apply (case_tac "r_s x")
    apply (auto)
  done

lemma rhs_drop_leq_use_env: "\<lbrakk> weak_use_env r_x; leq_use_env r_x r_s \<rbrakk> \<Longrightarrow> leq_use_env r_x (drop_use_env r_s)"
  apply (simp add: weak_use_env_def)
  apply (simp add: leq_use_env_def)
  apply (simp add: drop_use_env_def)
  apply (auto)
  apply (erule_tac x="x" in allE)
  apply (erule_tac x="x" in allE)
  apply (case_tac "r_x x")
    apply (auto)
  done

lemma diff_drop_use_env: "drop_use_env (diff_use_env r_s r_ex) = diff_use_env (drop_use_env r_s) r_ex"
  apply (case_tac "\<forall> x. drop_use_env (diff_use_env r_s r_ex) x = diff_use_env (drop_use_env r_s) r_ex x")
   apply (auto)
  apply (simp add: diff_use_env_def)
  apply (simp add: drop_use_env_def)
  apply (case_tac "r_ex x")
    apply (auto)
   apply (case_tac "r_s x")
     apply (auto)
  apply (case_tac "r_s x")
    apply (auto)
  done

lemma dist_drop_diff_use_env: "diff_use_env (drop_use_env r_s) r_x = drop_use_env (diff_use_env r_s r_x)"
  apply (case_tac "\<forall> x. diff_use_env (drop_use_env r_s) r_x x = drop_use_env (diff_use_env r_s r_x) x")
   apply (auto)
  apply (simp add: diff_use_env_def)
  apply (simp add: drop_use_env_def)
  apply (case_tac "r_s x = OwnPerm")
   apply (auto)
   apply (case_tac "r_x x")
     apply (auto)
  apply (case_tac "r_x x")
    apply (auto)
  done

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

lemma wt_sexp_drop_all: "\<lbrakk> well_typed env rx e tau rx rx'; req_type tau \<noteq> Aff; is_sexp e \<rbrakk> \<Longrightarrow>
  well_typed env (drop_use_env rx) e tau (drop_use_env rx) (drop_use_env rx')"
  apply (induct e arbitrary: env tau rx rx')
        apply (auto)
    (* const + op cases *)
          apply (rule_tac id_leq_use_env)
         apply (rule_tac dist_drop_leq_use_env)
         apply (simp)
        apply (rule_tac id_leq_use_env)
       apply (rule_tac dist_drop_leq_use_env)
       apply (simp)
    (* var case p1.
        - say that x was non-affine, but was owned by an affine data structure. in this case, the permissions we receive cannot be reduced.
     *)
      apply (case_tac x)
       apply (auto)
      apply (rule_tac ereq_leq_use_envx)
      apply (cut_tac r_x="ereq_use_env (Loc x22) tau_x" and r_s="rx" and x="Loc x22" in spec_leq_perm)
       apply (simp)
      apply (simp add: ereq_use_env_def)
      apply (simp add: one_use_env_def)
      apply (simp add: drop_use_env_def)
      apply (simp add: end_req_perm_def)
    (* var case p2 *)
     apply (cut_tac r_s="rx" and r_x="comp_use_env (ereq_use_env (owner_name x) tau_x) r_ex" in wtsdr_weak_use_env)
       apply (simp)
      apply (rule_tac dist_comp_leq_use_env)
       apply (auto)
     apply (rule_tac x="r_ex" in exI)
     apply (auto)
        apply (rule_tac rhs_weak_leq_use_env)
         apply (case_tac tau)
               apply (auto)
        apply (rule_tac id_leq_use_env)
       apply (rule_tac dist_drop_leq_use_env)
       apply (simp)
      apply (rule_tac rhs_drop_leq_use_env)
       apply (rule_tac r_sa="ereq_use_env (owner_name x) tau_x" in weak_comp_use_env2)
       apply (auto)
     apply (rule_tac rhs_drop_leq_use_env)
      apply (rule_tac weak_diff_use_env)
      apply (rule_tac r_sb="r_ex" in weak_comp_use_env1)
      apply (case_tac tau)
            apply (auto)
    (* pair case *)
    apply (case_tac "r = OwnPerm")
     apply (auto)
    apply (case_tac "max_aff (req_type t1) (req_type t2) = Aff")
     apply (case_tac r)
       apply (auto)
    apply (case_tac "req_type t1 = Aff")
     apply (auto)
    apply (case_tac "req_type t2 = Aff")
      apply (case_tac "req_type t1")
       apply (auto)
    apply (case_tac "lift_use_env rx2 r \<noteq> rx2 \<or> lift_use_env rx1 r \<noteq> rx1")
     apply (case_tac r)
       apply (auto)
(*
    apply (case_tac "\<not> (req_type t1 \<noteq> Aff \<and> req_type t2 \<noteq> Aff)")
     apply (auto)
     apply (case_tac "req_type t1")
       apply (auto)*)
    apply (cut_tac r_s="rx" and r_x="r_ex" in wtsdr_weak_use_env)
      apply (rule_tac r_sb="diff_use_env r_s3 r_ex" in trans_leq_use_env)
       apply (rule_tac dist_diff_leq_use_env)
       apply (rule_tac r_sb="r_s2" in trans_leq_use_env)
        apply (rule_tac well_typed_perm_leq)
        apply (auto)
     apply (rule_tac well_typed_perm_leq)
     apply (auto)
    apply (rule_tac x="drop_use_env rx" in exI)
    apply (rule_tac x="drop_use_env rx" in exI)
    apply (rule_tac x="drop_use_env rx1" in exI)
    apply (auto)
     apply (cut_tac e="e1" in value_is_sexp)
      apply (auto)
     apply (cut_tac env="env" and ?r_s1.0="rx" and r_c="r_s2" and ?r_s2.0="rx" and e="e1" and tau="t1" and rx="rx1" in well_typed_decr_end_perm)
        apply (auto)
      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)
     apply (rule_tac r_sb="r_s2" in trans_leq_use_env)
      apply (rule_tac well_typed_perm_leq)
      apply (auto)
     apply (rule_tac well_typed_perm_leqx)
     apply (auto)
    apply (cut_tac r_sc="r_s3" and r_sb="r_s2" and r_sa="rx" in trans_leq_use_env)
      apply (rule_tac well_typed_perm_leq)
      apply (auto)
     apply (rule_tac well_typed_perm_leq)
     apply (auto)
    apply (cut_tac r_sc="rx" and r_sb="diff_use_env r_s3 r_ex" and r_sa="r_s3" in trans_leq_use_env)
      apply (rule_tac self_diff_leq_use_env)
     apply (simp)
    apply (case_tac "lift_use_env (drop_use_env rx2) r \<noteq> drop_use_env rx2")
     apply (case_tac r)
       apply (auto)
    apply (case_tac "lift_use_env (drop_use_env rx1) r \<noteq> drop_use_env rx1")
     apply (case_tac r)
       apply (auto)
    apply (rule_tac x="drop_use_env rx2" in exI)
    apply (auto)
          apply (cut_tac e="e2" in value_is_sexp)
           apply (auto)
          apply (cut_tac env="env" and ?r_s1.0="rx" and r_c="r_s3" and ?r_s2.0="rx" and e="e2" and tau="t2" and rx="rx2" in well_typed_decr_end_perm)
             apply (rule_tac ?r_s1.0="r_s2" in well_typed_incr_start_perm)
              apply (auto)
           apply (rule_tac well_typed_perm_leq)
           apply (auto)
          apply (rule_tac r_sb="r_s3" in trans_leq_use_env)
         apply (auto)
         apply (rule_tac dist_drop_leq_use_env)
         apply (rule_tac r_sb="r_s3" in trans_leq_use_env)
          apply (auto)
        apply (rule_tac dist_drop_leq_use_env)
        apply (rule_tac r_sb="r_s3" in trans_leq_use_env)
         apply (auto)
     apply (rule_tac r_s="rx1" in disj_leq_use_env1)
      apply (rule_tac r_s="rx2" in disj_leq_use_env2)
       apply (simp)
      apply (rule_tac self_drop_leq_use_env)
     apply (rule_tac self_drop_leq_use_env)
    apply (rule_tac x="empty_use_env" in exI)
    apply (auto)
       apply (rule_tac rhs_weak_leq_use_env)
        apply (simp add: weak_use_env_def)
        apply (simp add: empty_use_env_def)
       apply (rule_tac id_leq_use_env)
      apply (rule_tac dist_drop_leq_use_env)
      apply (simp)
     apply (rule_tac leq_empty_use_env)
    apply (case_tac "req_type (PairTy t1 t2 r) = Prim")
     apply (simp add: pair_req_def)
     apply (rule_tac leq_empty_use_env)
    apply (simp add: pair_req_def)
    apply (rule_tac diff_leq_use_env)
    apply (rule_tac r_sb="drop_use_env (diff_use_env (comp_use_env rx1 rx2) r_ex)" in trans_leq_use_env)
     apply (rule_tac dist_drop_leq_use_env)
     apply (simp)
    apply (rule_tac t="drop_use_env (diff_use_env (comp_use_env rx1 rx2) r_ex)" and s="diff_use_env (drop_use_env (comp_use_env rx1 rx2)) r_ex" in subst)
     apply (rule_tac dist_drop_diff_use_env)
    apply (rule_tac rhs_weak_leq_use_env)
     apply (simp)
    apply (simp add: dist_drop_comp_use_env)
    apply (rule_tac id_leq_use_env)
    (* lam case *)
   apply (simp add: aff_use_env_def)
   apply (rule_tac x="rxa" in exI)
   apply (auto)
    apply (rule_tac rhs_drop_leq_use_env)
     apply (auto)
    apply (case_tac a)
      apply (auto)
    apply (simp add: weak_use_env_def)
    apply (simp add: null_use_env_def)
   apply (cut_tac r_s="rx" and r_x="r_ex" in wtsdr_weak_use_env)
     apply (auto)
   apply (rule_tac x="r_ex" in exI)
   apply (auto)
      apply (rule_tac rhs_weak_leq_use_env)
       apply (simp)
      apply (rule_tac id_leq_use_env)
     apply (rule_tac dist_drop_leq_use_env)
     apply (simp)
    apply (rule_tac rhs_drop_leq_use_env)
     apply (auto)
   apply (rule_tac rhs_drop_leq_use_env)
    apply (rule_tac weak_diff_use_env)
    apply (auto)
   apply (case_tac a)
     apply (auto)
   apply (simp add: weak_use_env_def)
   apply (simp add: null_use_env_def)
    (* app case. e1 *)
  apply (rule_tac x="t1" in exI)
  apply (rule_tac x="r" in exI)
  apply (rule_tac x="a" in exI)
  apply (rule_tac x="drop_use_env rx" in exI)
  apply (rule_tac x="empty_use_env" in exI)
  apply (auto)
   apply (case_tac e1)
         apply (auto)
    apply (rule_tac id_leq_use_env)
   apply (rule_tac leq_empty_use_env)
    (* app case. e2, lambda unrolling *)
  apply (rule_tac x="drop_use_env rx2" in exI)
  apply (rule_tac x="drop_use_env rx" in exI)
  apply (auto)
   apply (cut_tac env="env" and r_c="rx" and ?r_s1.0="r_s2" and ?r_s2.0="rx" and e="e2" and tau="t1" and rx="rx2" in well_typed_incr_start_perm)
     apply (rule_tac r_c="r_s3" in well_typed_decr_end_perm)
       apply (simp)
      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 (simp)
     apply (rule_tac r_sb="r_s3" in trans_leq_use_env)
      apply (rule_tac r_sb="r_s2" in trans_leq_use_env)
       apply (rule_tac well_typed_perm_leq)
       apply (auto)
      apply (rule_tac well_typed_perm_leq)
      apply (auto)
     apply (rule_tac well_typed_perm_leqx)
     apply (auto)
    apply (rule_tac well_typed_perm_leq)
    apply (auto)
    (* - prove that e2 is an s-expression *)
   apply (case_tac "\<not> is_sexp e2")
    apply (cut_tac ?e1.0="e1" and ?e2.0="e2" in e2_sexp)
     apply (simp_all)
    (* - prove that t1 is unlim *)
   apply (case_tac "\<not> req_type t1 \<noteq> Aff")
    apply (case_tac e1)
         apply (auto)
    apply (case_tac x1)
               apply (auto)
        apply (simp_all add: pure_fun_def)
    (* app case. tau primitive case (only happens for fixed point w/ primitive fun) *)
  apply (simp add: app_req_def)
  apply (case_tac "req_type tau = Prim")
   apply (auto)
   apply (case_tac e1)
        apply (auto)
    apply (case_tac x1)
                apply (auto)
        apply (simp_all add: pure_fun_def)
   apply (auto)
   apply (case_tac t)
          apply (auto)
   apply (case_tac "\<not> weak_use_env empty_use_env")
    apply (simp add: weak_use_env_def)
    apply (simp add: empty_use_env_def)
   apply (rule_tac x="empty_use_env" in exI)
   apply (auto)
         apply (rule_tac rhs_weak_leq_use_env)
          apply (rule_tac dist_weak_comp_use_env)
           apply (rule_tac dist_weak_comp_use_env)
            apply (auto)
          apply (rule_tac drop_weak_use_env)
         apply (rule_tac id_leq_use_env)
       apply (rule_tac dist_comp_leq_use_env)
        apply (rule_tac leq_empty_use_env)
       apply (rule_tac dist_drop_leq_use_env)
       apply (rule_tac r_sb="r_s2" in trans_leq_use_env)
        apply (simp)
       apply (rule_tac r_sb="r_s3" in trans_leq_use_env)
        apply (rule_tac well_typed_perm_leq)
        apply (auto)
       apply (rule_tac well_typed_perm_leqx)
       apply (auto)
      apply (rule_tac disj_empty_use_env2)
     apply (rule_tac dist_drop_leq_use_env)
     apply (simp)
    apply (rule_tac leq_empty_use_env)
   apply (rule_tac leq_empty_use_env)
    (* non prim case. *)
    (* - prove weakness of rx1 + rx2 + r_ex *)
  apply (cut_tac r_s="r_s3" and r_x="comp_use_env (comp_use_env rx1 (lift_use_env rx2 r)) r_ex" in wtsdr_weak_use_env)
    apply (rule_tac r_sb="rx" in trans_leq_use_env)
     apply (simp)
    apply (rule_tac r_sb="r_s2" in trans_leq_use_env)
     apply (rule_tac well_typed_perm_leq)
     apply (auto)
    apply (rule_tac well_typed_perm_leq)
    apply (auto)
   apply (rule_tac dist_comp_leq_use_env)
    apply (simp)
   apply (rule_tac r_sb="rx" in trans_leq_use_env)
    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 (simp_all)
    (* - r not ownership *)
  apply (case_tac "r = OwnPerm")
   apply (case_tac e1)
        apply (auto)
   apply (case_tac x1)
               apply (auto)
        apply (simp_all add: pure_fun_def)
    (* - final manipulation *)
  apply (rule_tac x="r_ex" in exI)
  apply (auto)
       apply (rule_tac rhs_weak_leq_use_env)
        apply (rule_tac r_s="comp_use_env (comp_use_env rx1 (lift_use_env rx2 r)) r_ex" in leq_weak_use_env)
         apply (simp)
        apply (rule_tac dist_comp_leq_use_env)
         apply (rule_tac comp_leq_use_env1)
         apply (rule_tac dist_comp_leq_use_env)
          apply (rule_tac leq_empty_use_env)
         apply (rule_tac comp_leq_use_env2)
         apply (rule_tac dist_lift_leq_use_env)
         apply (rule_tac self_drop_leq_use_env)
        apply (rule_tac self_comp_leq_use_env2)
       apply (rule_tac id_leq_use_env)
(*
       apply (simp add: drop_use_env_def)
       apply (case_tac r)
         apply (auto)*)
      apply (rule_tac dist_comp_leq_use_env)
       apply (rule_tac leq_empty_use_env)
      apply (case_tac "lift_use_env (drop_use_env rx2) r \<noteq> drop_use_env rx2")
       apply (case_tac r)
         apply (auto)
      apply (rule_tac dist_drop_leq_use_env)
      apply (rule_tac r_sb="comp_use_env rx1 (lift_use_env rx2 r)" in trans_leq_use_env)
       apply (rule_tac r_sb="r_s3" in trans_leq_use_env)
        apply (rule_tac r_sb="r_s2" in trans_leq_use_env)
         apply (rule_tac well_typed_perm_leq)
         apply (auto)
       apply (rule_tac well_typed_perm_leq)
       apply (auto)
      apply (rule_tac comp_leq_use_env2)
      apply (rule_tac self_lift_leq_use_env)
     apply (rule_tac disj_empty_use_env2)
    apply (rule_tac dist_drop_leq_use_env)
    apply (simp)
   apply (rule_tac rhs_drop_leq_use_env)
    apply (rule_tac r_sa="comp_use_env rx1 (lift_use_env rx2 r)" in weak_comp_use_env2)
    apply (auto)
  apply (rule_tac r_sb="drop_use_env (diff_use_env (comp_use_env rx1 rx2) (comp_use_env (comp_use_env rx1 (lift_use_env rx2 r)) r_ex))" in trans_leq_use_env)
   apply (rule_tac dist_drop_leq_use_env)
   apply (auto)
  apply (rule_tac rhs_drop_leq_use_env)
   apply (rule_tac weak_diff_use_env)
   apply (rule_tac dist_weak_comp_use_env)
    apply (simp add: weak_use_env_def)
    apply (simp add: empty_use_env_def)
   apply (rule_tac drop_weak_use_env)
  apply (rule_tac rhs_weak_leq_use_env)
   apply (simp)
  apply (rule_tac diff_leq_use_env)
  apply (rule_tac dist_comp_leq_use_env)
   apply (rule_tac leq_empty_use_env)
  apply (rule_tac comp_leq_use_env2)
  apply (rule_tac self_drop_leq_use_env)
  done

lemma wt_sexp_drop_req: "\<lbrakk> well_typed env r_s1 e tau r_s2 rx; req_type tau \<noteq> Aff; (*\<not> aff_fun_ty tau;*) is_sexp e \<rbrakk> \<Longrightarrow>
    well_typed env r_s1 e tau r_s2 (drop_use_env rx)"
  apply (induct e arbitrary: r_s1 r_s2 tau rx)
        apply (auto)
    (* const + op cases *)
       apply (rule_tac drop_leq_use_env)
       apply (simp)
      apply (rule_tac drop_leq_use_env)
      apply (simp)
    (* var case. *)
     apply (rule_tac x="r_ex" in exI)
     apply (auto)
      apply (rule_tac drop_leq_use_env)
      apply (simp)
     apply (rule_tac rhs_drop_leq_use_env)
      apply (rule_tac weak_diff_use_env)
      apply (rule_tac weak_ereq_use_env)
      apply (simp add: unlim_def)
      apply (case_tac x)
       apply (auto)
    (* pair case. *)
    apply (case_tac "r = OwnPerm")
     apply (auto)
    apply (case_tac "max_aff (req_type t1) (req_type t2) = Aff")
     apply (case_tac r)
       apply (auto)
    apply (rule_tac x="r_s2a" in exI)
    apply (rule_tac x="r_s3" in exI)
    apply (rule_tac x="drop_use_env rx1" in exI)
    apply (auto)
     apply (case_tac "req_type t1 = Aff")
      apply (auto)
     apply (cut_tac e="e1" in value_is_sexp)
      apply (auto)
    apply (rule_tac x="drop_use_env rx2" in exI)
    apply (auto)
        apply (case_tac "req_type t2 = Aff")
         apply (case_tac "req_type t1")
           apply (auto)
        apply (cut_tac e="e2" in value_is_sexp)
         apply (auto)
       apply (rule_tac r_sb="lift_use_env rx1 r" in trans_leq_use_env)
        apply (simp)
       apply (rule_tac dist_lift_leq_use_env)
       apply (rule_tac self_drop_leq_use_env)
      apply (rule_tac r_sb="lift_use_env rx2 r" in trans_leq_use_env)
       apply (simp)
      apply (rule_tac dist_lift_leq_use_env)
      apply (rule_tac self_drop_leq_use_env)
     apply (rule_tac r_s="lift_use_env rx1 r" in disj_leq_use_env1)
      apply (rule_tac r_s="lift_use_env rx2 r" in disj_leq_use_env2)
       apply (simp)
      apply (rule_tac dist_lift_leq_use_env)
      apply (rule_tac self_drop_leq_use_env)
     apply (rule_tac dist_lift_leq_use_env)
     apply (rule_tac self_drop_leq_use_env)
    apply (rule_tac x="r_ex" in exI)
    apply (auto)
     apply (rule_tac drop_leq_use_env)
     apply (simp)
    apply (case_tac "lift_use_env (drop_use_env rx1) r \<noteq> drop_use_env rx1")
     apply (case_tac r)
       apply (auto)
    apply (case_tac "lift_use_env (drop_use_env rx2) r \<noteq> drop_use_env rx2")
     apply (case_tac r)
       apply (auto)
    apply (case_tac "req_type (PairTy t1 t2 r) = Prim")
     apply (simp add: pair_req_def)
     apply (rule_tac leq_empty_use_env)
    apply (simp add: pair_req_def)
    apply (rule_tac rhs_drop_leq_use_env)
     apply (rule_tac weak_diff_use_env)
     apply (rule_tac dist_weak_comp_use_env)
      apply (rule_tac drop_weak_use_env)
     apply (rule_tac drop_weak_use_env)
    apply (rule_tac r_sb="diff_use_env (comp_use_env (lift_use_env rx1 r) (lift_use_env rx2 r)) r_ex" in trans_leq_use_env)
     apply (simp)
    apply (rule_tac dist_diff_leq_use_env)
    apply (rule_tac dist_comp_leq_use_env)
     apply (rule_tac comp_leq_use_env1)
     apply (rule_tac drop_leq_use_env)
     apply (rule_tac self_lift_leq_use_env)
    apply (rule_tac comp_leq_use_env2)
    apply (rule_tac drop_leq_use_env)
    apply (rule_tac self_lift_leq_use_env)
    (* lam case  *)
   apply (rule_tac x="rxa" in exI)
   apply (auto)
   apply (rule_tac x="r_ex" in exI)
   apply (auto)
    apply (rule_tac drop_leq_use_env)
    apply (simp)
   apply (rule_tac rhs_drop_leq_use_env)
    apply (rule_tac weak_diff_use_env)
    apply (simp add: aff_use_env_def)
    apply (case_tac a)
      apply (auto)
   apply (simp add: null_use_env_def)
   apply (simp add: weak_use_env_def)
    (* app case *)
  apply (rule_tac x="t1" in exI)
  apply (rule_tac x="r" in exI)
  apply (rule_tac x="a" in exI)
  apply (rule_tac x="r_s2a" in exI)
  apply (rule_tac x="drop_use_env rx1" in exI)
  apply (auto)
   apply (case_tac "req_type (FunTy t1 tau r a) = Aff")
    apply (case_tac e1)
          apply (auto)
    apply (case_tac x1)
                apply (auto)
         apply (simp_all add: pure_fun_def)
   apply (case_tac "\<not> is_sexp e1")
    apply (case_tac e1)
          apply (auto)
  apply (rule_tac x="drop_use_env rx2" in exI)
  apply (rule_tac x="r_s3" in exI)
  apply (auto)
   apply (case_tac "req_type t1 = Aff")
    apply (case_tac e1)
          apply (auto)
    apply (case_tac x1)
                apply (auto)
         apply (simp_all add: pure_fun_def)
   apply (case_tac "\<not> is_sexp e2")
    apply (case_tac "is_value e2")
     apply (cut_tac e="e2" in value_is_sexp)
      apply (auto)
    apply (case_tac e1)
          apply (auto)
   apply (case_tac x1)
               apply (auto)
   apply (case_tac e2)
         apply (auto)
  apply (cut_tac r_xa="drop_use_env rx1" and r_xb="lift_use_env (drop_use_env rx2) r" and r_s="comp_use_env rx1 (lift_use_env rx2 r)" in dist_comp_leq_use_env)
    apply (rule_tac comp_leq_use_env1)
    apply (rule_tac self_drop_leq_use_env)
   apply (rule_tac comp_leq_use_env2)
   apply (rule_tac dist_lift_leq_use_env)
   apply (rule_tac self_drop_leq_use_env)
  apply (rule_tac x="comp_use_env (comp_use_env rx1 (lift_use_env rx2 r)) r_ex" in exI)
  apply (auto)
      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 dist_diff_leq_use_env_gen)
        apply (rule_tac id_leq_use_env)
       apply (rule_tac dist_comp_leq_use_env)
        apply (rule_tac comp_leq_use_env1)
         apply (simp)
        apply (rule_tac id_leq_use_env)
       apply (simp)
     apply (rule_tac r_sb="comp_use_env rx1 (lift_use_env rx2 r)" in trans_leq_use_env)
      apply (simp_all)
    apply (rule_tac r_s="rx1" in disj_leq_use_env1)
     apply (rule_tac r_s="lift_use_env rx2 r" in disj_leq_use_env2)
      apply (simp)
     apply (rule_tac dist_lift_leq_use_env)
     apply (rule_tac self_drop_leq_use_env)
    apply (rule_tac self_drop_leq_use_env)
   apply (rule_tac drop_leq_use_env)
    apply (simp)
   apply (rule_tac dist_comp_leq_use_env)
    apply (rule_tac r_sb="r_s3" in trans_leq_use_env)
     apply (rule_tac r_sb="r_s2a" in trans_leq_use_env)
      apply (rule_tac well_typed_perm_leq)
      apply (auto)
   apply (rule_tac well_typed_perm_leq)
   apply (auto)
  apply (case_tac "req_type tau = Prim")
   apply (simp add: app_req_def)
   apply (rule_tac leq_empty_use_env)
  apply (simp add: app_req_def)
  apply (rule_tac rhs_drop_leq_use_env)
   apply (rule_tac weak_diff_use_env)
   apply (rule_tac dist_weak_comp_use_env)
    apply (rule_tac drop_weak_use_env)
   apply (rule_tac drop_weak_use_env)
  apply (rule_tac r_sb="diff_use_env (comp_use_env rx1 rx2) (comp_use_env (comp_use_env rx1 (lift_use_env rx2 r)) r_ex)" in trans_leq_use_env)
   apply (simp)
  apply (rule_tac dist_diff_leq_use_env_gen)
   apply (rule_tac dist_comp_leq_use_env)
    apply (rule_tac comp_leq_use_env1)
    apply (rule_tac self_drop_leq_use_env)
   apply (rule_tac comp_leq_use_env2)
   apply (rule_tac self_drop_leq_use_env)
  apply (rule_tac self_comp_leq_use_env2)
  done

    (* ####### primitive lemmas *)

lemma wt_sexp_no_all: "\<lbrakk> well_typed env r_s1 e tau r_s2 rx; req_type tau = Prim; is_sexp e \<rbrakk> \<Longrightarrow> well_typed env empty_use_env e tau empty_use_env empty_use_env"
  apply (induction e arbitrary: env tau r_s1 r_s2 rx)
        apply (auto)
    (* const + op case *)
        apply (rule_tac leq_empty_use_env)
       apply (rule_tac leq_empty_use_env)
    (* var case *)
      apply (case_tac x)
       apply (auto)
     apply (case_tac x)
      apply (auto)
    (* pair case *)
    apply (case_tac "r \<noteq> NoPerm")
     apply (case_tac r)
       apply (auto)
    apply (case_tac "max_aff (req_type t1) (req_type t2)")
      apply (auto)
    apply (case_tac "req_type t1")
       apply (auto)
     apply (case_tac "req_type t2")
       apply (auto)
    apply (case_tac "req_type t2")
      apply (auto)
    apply (rule_tac x="empty_use_env" in exI)
    apply (rule_tac x="empty_use_env" in exI)
    apply (rule_tac x="empty_use_env" in exI)
    apply (auto)
     apply (cut_tac e="e1" in value_is_sexp)
      apply (auto)
    apply (rule_tac x="empty_use_env" in exI)
    apply (auto)
        apply (cut_tac e="e2" in value_is_sexp)
         apply (auto)
      apply (rule_tac leq_empty_use_env)
     apply (rule_tac disj_empty_use_env1)
    apply (rule_tac x="empty_use_env" in exI)
    apply (auto)
      apply (rule_tac leq_empty_use_env)
     apply (rule_tac leq_empty_use_env)
    apply (simp add: pair_req_def)
    apply (rule_tac leq_empty_use_env)
    (* lam case *)
   apply (rule_tac x="rxa" in exI)
   apply (auto)
    apply (simp add: leq_use_env_def)
    apply (simp add: aff_use_env_def)
    apply (simp add: null_use_env_def)
   apply (rule_tac x="empty_use_env" in exI)
   apply (auto)
     apply (rule_tac leq_empty_use_env)
    apply (rule_tac leq_empty_use_env)
   apply (rule_tac diff_leq_use_env)
   apply (simp add: leq_use_env_def)
   apply (simp add: aff_use_env_def)
   apply (simp add: null_use_env_def)
    (* app case. since tau is primitive, the only possible const is the fix point *)
  apply (case_tac e1)
        apply (auto)
  apply (case_tac "x1 \<noteq> FixConst")
   apply (case_tac x1)
               apply (auto)
       apply (simp_all add: pure_fun_def)
    (* - with that in mind, we fill in the rest *)
  apply (auto)
  apply (rule_tac x="empty_use_env" in exI)
  apply (auto)
   apply (rule_tac leq_empty_use_env)
  apply (rule_tac x="empty_use_env" in exI)
  apply (auto)
   apply (rule_tac leq_empty_use_env)
  apply (rule_tac x="empty_use_env" in exI)
  apply (rule_tac x="empty_use_env" in exI)
  apply (auto)
   apply (case_tac "\<not> is_sexp e2")
    apply (case_tac e2)
          apply (auto)
  apply (rule_tac x="empty_use_env" in exI)
  apply (auto)
       apply (rule_tac leq_empty_use_env)
     apply (rule_tac dist_comp_leq_use_env)
      apply (rule_tac leq_empty_use_env)
     apply (rule_tac leq_empty_use_env)
    apply (rule_tac disj_empty_use_env2)
   apply (rule_tac leq_empty_use_env)
  apply (simp add: app_req_def)
  apply (rule_tac leq_empty_use_env)
  done

lemma wt_sexp_no_req: "\<lbrakk> well_typed env r_s1 e tau r_s2 rx; req_type tau = Prim; is_sexp e \<rbrakk> \<Longrightarrow> well_typed env r_s1 e tau r_s2 empty_use_env"
  apply (rule_tac r_c="r_s1" in well_typed_decr_end_perm)
    apply (rule_tac r_s="empty_use_env" in well_typed_incr_simul_perm)
     apply (rule_tac leq_empty_use_env)
    apply (rule_tac wt_sexp_no_all)
      apply (auto)
   apply (rule_tac well_typed_perm_leq)
   apply (auto)
  apply (rule_tac leq_empty_use_env)
  done

fun drop_use_env_dep where
  "drop_use_env_dep r_s OwnPerm = r_s"
| "drop_use_env_dep r_s UsePerm = drop_use_env r_s"
| "drop_use_env_dep r_s NoPerm = empty_use_env"

lemma wt_sexp_drop_dep_req: "\<lbrakk> well_typed env r_s1 e tau r_s2 rx; is_sexp e; safe_type_x tau r \<rbrakk> \<Longrightarrow> well_typed env r_s1 e tau r_s2 (drop_use_env_dep rx r)"
  apply (case_tac r)
    apply (auto)
   apply (rule_tac wt_sexp_no_req)
     apply (auto)
  apply (rule_tac wt_sexp_drop_req)
    apply (auto)
  apply (simp add: unlim_def)
  done

end


theory ExtraLemmas
imports AutoCorres
begin

lemma shiftr1_is_div_2': "shiftr1 (x :: ('a :: len) word) = x div 2"
apply (simp only: shiftr1_unfold)
using shiftr1_is_div_2 by auto

lemma shiftr2_is_div_4:
assumes "2 < len_of TYPE('a)"
shows "(x :: ('a :: len) word) >> 2 = x div 4"
proof -
  from assms have "x >> 2 = x div 2 ^ 2" by (simp add: shiftr_div_2n_w word_size)
  thus ?thesis by auto
qed

lemma shiftr3_is_div_8:
assumes "3 < len_of TYPE('a)"
shows "(x :: ('a :: len) word) >> 3 = x div 8"
proof -
  from assms have "x >> 3 = x div 2 ^ 3" by (simp add: shiftr_div_2n_w word_size)
  thus ?thesis by auto
qed

lemma array_addrs_ptr_add[intro]: "0 \<le> i \<Longrightarrow> i < int n \<Longrightarrow> p +\<^sub>p i \<in> set (array_addrs p n)"
apply (simp add: set_array_addrs)
apply (rule_tac x="nat i" in exI)
apply simp
done

lemma array_addrs_ptr_ex[dest]:
  "q \<in> set (array_addrs p n)\<Longrightarrow> \<exists>i. q = p +\<^sub>p (int i) \<and> i < n"
by (simp add: set_array_addrs)

lemma ptr_val_inject: "(p :: 'a ptr) = q \<Longrightarrow> ptr_val p = ptr_val q"
by auto

lemma ptr_arith_index: "0 \<le> i \<Longrightarrow> 0 \<le> k
  \<Longrightarrow> nat i * size_of TYPE('a :: wf_type) < 2 ^ len_of TYPE(32)
  \<Longrightarrow> nat k * size_of TYPE('a :: wf_type) < 2 ^ len_of TYPE(32)
  \<Longrightarrow> ((p :: 'a ptr) +\<^sub>p i = p +\<^sub>p k) = (i = k)"
unfolding ptr_add_def
proof auto
  fix i k :: int
  assume size_i: "nat i * size_of TYPE('a) < 4294967296" and "0 \<le> i"
     and size_k: "nat k * size_of TYPE('a) < 4294967296" and "0 \<le> k"
     and eq: "of_int i * of_nat (size_of TYPE('a)) = (of_int k * of_nat (size_of TYPE('a)) :: 32 word)"
  hence "(of_nat (nat i) :: 32 word) * of_nat (size_of TYPE('a))
    = of_nat (nat k) * of_nat (size_of TYPE('a))" by simp
  hence "(of_nat (nat i * size_of TYPE('a)) :: 32 word) = of_nat (nat k * size_of TYPE('a))"
    (is "of_nat ?L = of_nat ?R") by simp
  moreover have "((of_nat ?L :: 32 word) = of_nat ?R) = (?L = ?R)"
    using size_i and size_k by (fastforce intro!: Word_Lemmas.of_nat_inj)
  ultimately have "?L = ?R" by auto
  thus "i = k" using not_gr0 sz_nzero
    by (metis \<open>0 \<le> i\<close> \<open>0 \<le> k\<close> int_nat_eq mult.commute mult_cancel1)
qed

lemma hoare_post_imp: "\<forall>r s. Q r s \<longrightarrow> R r s \<Longrightarrow> \<lbrace>P\<rbrace> m \<lbrace>Q\<rbrace> \<Longrightarrow> \<lbrace>P\<rbrace> m \<lbrace>R\<rbrace>"
unfolding valid_def by blast

lemma size_of_le_n[dest]: "size_of TYPE('a :: wf_type) \<le> unat (n :: ('b :: len) word) \<Longrightarrow> 0 < n"
proof -
  fix n :: "'b word"
  assume "size_of TYPE('a) \<le> unat n"
  moreover have "0 < size_of TYPE('a)" using sz_nzero by auto
  ultimately have "0 < unat n" by linarith
  thus "0 < n" using word_of_nat_less by force
qed

lemma ptr_less_simp : "a < b = (ptr_val a < ptr_val b)"
  by (simp add: ptr_less_def ptr_less_def')
lemma ptr_le_simp : "a \<le> b = (ptr_val a \<le> ptr_val b)"
  by (simp add: ptr_le_def ptr_le_def')
lemmas ptr_comp_simps = ptr_less_simp and ptr_le_simp
end


(*

 Licensed under the Apache License, Version 2.0 (the "License");
 you may not use this file except in compliance with the License.
 You may obtain a copy of the License at

     http://www.apache.org/licenses/LICENSE-2.0

 Unless required by applicable law or agreed to in writing, software
 distributed under the License is distributed on an "AS IS" BASIS,
 WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
 See the License for the specific language governing permissions and
 limitations under the License.

 *)

theory BitVector_Rewriting
  imports reassembly_rewriting.Take_Bits_Rewriting reassembly_manual_execution.BitVectors
begin

subsection \<open>Logical Operators\<close>

lemma bv_to_bool_bool_to_bv:
  shows "bv_to_bool (bool_to_bv b) = b"
  by (cases b,auto simp add: bv_to_bool_def)

lemma snd_bool_to_bv:
  shows "snd (bool_to_bv b) = 1"
  by (cases b,auto)

lemma bv_to_bool_True:
  shows "bv_to_bool (1, 1) = True"
  by (auto simp add: bv_to_bool_def)

lemma bv_to_bool_True_Suc0:
  shows "bv_to_bool (1, Suc 0) = True"
  by (auto simp add: bv_to_bool_def)

lemma bv_to_bool_False:
  shows "bv_to_bool (0, 1) = False"
  by (auto simp add: bv_to_bool_def)

lemma bv_to_bool_False_Suc0:
  shows "bv_to_bool (0, Suc 0) = False"
  by (auto simp add: bv_to_bool_def)

lemma bool_to_bv_eq:
  shows "bool_to_bv b = (x, Suc 0) \<longleftrightarrow> (x \<in> {0,1} \<and> ((x = 1) \<longleftrightarrow> b))"
  by (cases b,auto)

lemma bv_NOT_bool_to_bv:
  shows "bv_NOT (bool_to_bv b) = bool_to_bv (\<not>b)"
  by (cases b, auto simp add: max_word_def)

subsection \<open>Concatenation and slicing\<close>

lemmas bv_slice_simps[simp] =
  bv_slice.simps[of "numeral h" "numeral l" "numeral w" "numeral s"]
  bv_slice.simps[of "numeral h" "numeral l" "numeral w" 0]
  bv_slice.simps[of "numeral h" "numeral l" "numeral w" 1]
  bv_slice.simps[of "numeral h" "numeral l" 0            "numeral s"]
  bv_slice.simps[of "numeral h" "numeral l" 0            0]
  bv_slice.simps[of "numeral h" "numeral l" 0            1]
  bv_slice.simps[of "numeral h" "numeral l" 1            "numeral s"]
  bv_slice.simps[of "numeral h" "numeral l" 1            0]
  bv_slice.simps[of "numeral h" "numeral l" 1            1]
  bv_slice.simps[of "numeral h" 0            "numeral w" "numeral s"]
  bv_slice.simps[of "numeral h" 0            "numeral w" 0]
  bv_slice.simps[of "numeral h" 0            "numeral w" 1]
  bv_slice.simps[of "numeral h" 0            0            "numeral s"]
  bv_slice.simps[of "numeral h" 0            0            0]
  bv_slice.simps[of "numeral h" 0            0            1]
  bv_slice.simps[of "numeral h" 0            1            "numeral s"]
  bv_slice.simps[of "numeral h" 0            1            0]
  bv_slice.simps[of "numeral h" 0            1            1]
  bv_slice.simps[of "numeral h" 1            "numeral w" "numeral s"]
  bv_slice.simps[of "numeral h" 1            "numeral w" 0]
  bv_slice.simps[of "numeral h" 1            "numeral w" 1]
  bv_slice.simps[of "numeral h" 1            0            "numeral s"]
  bv_slice.simps[of "numeral h" 1            0            0]
  bv_slice.simps[of "numeral h" 1            0            1]
  bv_slice.simps[of "numeral h" 1            1            "numeral s"]
  bv_slice.simps[of "numeral h" 1            1            0]
  bv_slice.simps[of "numeral h" 1            1            1]
  bv_slice.simps[of 0           "numeral l" "numeral w" "numeral s"]
  bv_slice.simps[of 0           "numeral l" "numeral w" 0]
  bv_slice.simps[of 0           "numeral l" "numeral w" 1]
  bv_slice.simps[of 0           "numeral l" 0            "numeral s"]
  bv_slice.simps[of 0           "numeral l" 0            0]
  bv_slice.simps[of 0           "numeral l" 0            1]
  bv_slice.simps[of 0           "numeral l" 1            "numeral s"]
  bv_slice.simps[of 0           "numeral l" 1            0]
  bv_slice.simps[of 0           "numeral l" 1            1]
  bv_slice.simps[of 0           0            "numeral w" "numeral s"]
  bv_slice.simps[of 0           0            "numeral w" 0]
  bv_slice.simps[of 0           0            "numeral w" 1]
  bv_slice.simps[of 0           0            0            "numeral s"]
  bv_slice.simps[of 0           0            0            0]
  bv_slice.simps[of 0           0            0            1]
  bv_slice.simps[of 0           0            1            "numeral s"]
  bv_slice.simps[of 0           0            1            0]
  bv_slice.simps[of 0           0            1            1]
  bv_slice.simps[of 0           1            "numeral w" "numeral s"]
  bv_slice.simps[of 0           1            "numeral w" 0]
  bv_slice.simps[of 0           1            "numeral w" 1]
  bv_slice.simps[of 0           1            0            "numeral s"]
  bv_slice.simps[of 0           1            0            0]
  bv_slice.simps[of 0           1            0            1]
  bv_slice.simps[of 0           1            1            "numeral s"]
  bv_slice.simps[of 0           1            1            0]
  bv_slice.simps[of 0           1            1            1]
  bv_slice.simps[of 1           "numeral l" "numeral w" "numeral s"]
  bv_slice.simps[of 1           "numeral l" "numeral w" 0]
  bv_slice.simps[of 1           "numeral l" "numeral w" 1]
  bv_slice.simps[of 1           "numeral l" 0            "numeral s"]
  bv_slice.simps[of 1           "numeral l" 0            0]
  bv_slice.simps[of 1           "numeral l" 0            1]
  bv_slice.simps[of 1           "numeral l" 1            "numeral s"]
  bv_slice.simps[of 1           "numeral l" 1            0]
  bv_slice.simps[of 1           "numeral l" 1            1]
  bv_slice.simps[of 1           0            "numeral w" "numeral s"]
  bv_slice.simps[of 1           0            "numeral w" 0]
  bv_slice.simps[of 1           0            "numeral w" 1]
  bv_slice.simps[of 1           0            0            "numeral s"]
  bv_slice.simps[of 1           0            0            0]
  bv_slice.simps[of 1           0            0            1]
  bv_slice.simps[of 1           0            1            "numeral s"]
  bv_slice.simps[of 1           0            1            0]
  bv_slice.simps[of 1           0            1            1]
  bv_slice.simps[of 1           1            "numeral w" "numeral s"]
  bv_slice.simps[of 1           1            "numeral w" 0]
  bv_slice.simps[of 1           1            "numeral w" 1]
  bv_slice.simps[of 1           1            0            "numeral s"]
  bv_slice.simps[of 1           1            0            0]
  bv_slice.simps[of 1           1            0            1]
  bv_slice.simps[of 1           1            1            "numeral s"]
  bv_slice.simps[of 1           1            1            0]
  bv_slice.simps[of 1           1            1            1]
  for h l w s

lemmas bv_cat_simps[simp] =
  bv_cat.simps[of "numeral w0" "numeral s0" "numeral w1" "numeral s1"]
  bv_cat.simps[of "numeral w0" "numeral s0" "numeral w1" 0]
  bv_cat.simps[of "numeral w0" "numeral s0" "numeral w1" 1]
  bv_cat.simps[of "numeral w0" "numeral s0" 0            "numeral s1"]
  bv_cat.simps[of "numeral w0" "numeral s0" 0            0]
  bv_cat.simps[of "numeral w0" "numeral s0" 0            1]
  bv_cat.simps[of "numeral w0" "numeral s0" 1            "numeral s1"]
  bv_cat.simps[of "numeral w0" "numeral s0" 1            0]
  bv_cat.simps[of "numeral w0" "numeral s0" 1            1]
  bv_cat.simps[of "numeral w0" 0            "numeral w1" "numeral s1"]
  bv_cat.simps[of "numeral w0" 0            "numeral w1" 0]
  bv_cat.simps[of "numeral w0" 0            "numeral w1" 1]
  bv_cat.simps[of "numeral w0" 0            0            "numeral s1"]
  bv_cat.simps[of "numeral w0" 0            0            0]
  bv_cat.simps[of "numeral w0" 0            0            1]
  bv_cat.simps[of "numeral w0" 0            1            "numeral s1"]
  bv_cat.simps[of "numeral w0" 0            1            0]
  bv_cat.simps[of "numeral w0" 0            1            1]
  bv_cat.simps[of "numeral w0" 1            "numeral w1" "numeral s1"]
  bv_cat.simps[of "numeral w0" 1            "numeral w1" 0]
  bv_cat.simps[of "numeral w0" 1            "numeral w1" 1]
  bv_cat.simps[of "numeral w0" 1            0            "numeral s1"]
  bv_cat.simps[of "numeral w0" 1            0            0]
  bv_cat.simps[of "numeral w0" 1            0            1]
  bv_cat.simps[of "numeral w0" 1            1            "numeral s1"]
  bv_cat.simps[of "numeral w0" 1            1            0]
  bv_cat.simps[of "numeral w0" 1            1            1]
  bv_cat.simps[of 0           "numeral s0" "numeral w1" "numeral s1"]
  bv_cat.simps[of 0           "numeral s0" "numeral w1" 0]
  bv_cat.simps[of 0           "numeral s0" "numeral w1" 1]
  bv_cat.simps[of 0           "numeral s0" 0            "numeral s1"]
  bv_cat.simps[of 0           "numeral s0" 0            0]
  bv_cat.simps[of 0           "numeral s0" 0            1]
  bv_cat.simps[of 0           "numeral s0" 1            "numeral s1"]
  bv_cat.simps[of 0           "numeral s0" 1            0]
  bv_cat.simps[of 0           "numeral s0" 1            1]
  bv_cat.simps[of 0           0            "numeral w1" "numeral s1"]
  bv_cat.simps[of 0           0            "numeral w1" 0]
  bv_cat.simps[of 0           0            "numeral w1" 1]
  bv_cat.simps[of 0           0            0            "numeral s1"]
  bv_cat.simps[of 0           0            0            0]
  bv_cat.simps[of 0           0            0            1]
  bv_cat.simps[of 0           0            1            "numeral s1"]
  bv_cat.simps[of 0           0            1            0]
  bv_cat.simps[of 0           0            1            1]
  bv_cat.simps[of 0           1            "numeral w1" "numeral s1"]
  bv_cat.simps[of 0           1            "numeral w1" 0]
  bv_cat.simps[of 0           1            "numeral w1" 1]
  bv_cat.simps[of 0           1            0            "numeral s1"]
  bv_cat.simps[of 0           1            0            0]
  bv_cat.simps[of 0           1            0            1]
  bv_cat.simps[of 0           1            1            "numeral s1"]
  bv_cat.simps[of 0           1            1            0]
  bv_cat.simps[of 0           1            1            1]
  bv_cat.simps[of 1           "numeral s0" "numeral w1" "numeral s1"]
  bv_cat.simps[of 1           "numeral s0" "numeral w1" 0]
  bv_cat.simps[of 1           "numeral s0" "numeral w1" 1]
  bv_cat.simps[of 1           "numeral s0" 0            "numeral s1"]
  bv_cat.simps[of 1           "numeral s0" 0            0]
  bv_cat.simps[of 1           "numeral s0" 0            1]
  bv_cat.simps[of 1           "numeral s0" 1            "numeral s1"]
  bv_cat.simps[of 1           "numeral s0" 1            0]
  bv_cat.simps[of 1           "numeral s0" 1            1]
  bv_cat.simps[of 1           0            "numeral w1" "numeral s1"]
  bv_cat.simps[of 1           0            "numeral w1" 0]
  bv_cat.simps[of 1           0            "numeral w1" 1]
  bv_cat.simps[of 1           0            0            "numeral s1"]
  bv_cat.simps[of 1           0            0            0]
  bv_cat.simps[of 1           0            0            1]
  bv_cat.simps[of 1           0            1            "numeral s1"]
  bv_cat.simps[of 1           0            1            0]
  bv_cat.simps[of 1           0            1            1]
  bv_cat.simps[of 1           1            "numeral w1" "numeral s1"]
  bv_cat.simps[of 1           1            "numeral w1" 0]
  bv_cat.simps[of 1           1            "numeral w1" 1]
  bv_cat.simps[of 1           1            0            "numeral s1"]
  bv_cat.simps[of 1           1            0            0]
  bv_cat.simps[of 1           1            0            1]
  bv_cat.simps[of 1           1            1            "numeral s1"]
  bv_cat.simps[of 1           1            1            0]
  bv_cat.simps[of 1           1            1            1]
  for w0 s0 w1 s1

lemma size_bv_cat:
  shows "snd (bv_cat a b) = snd a + snd b"
  by (cases a,cases b,auto simp add: bv_cat.simps)

lemma size_bv_slice:
  shows "snd (bv_slice h l a) = h + 1 - l"
  by (cases a,auto simp add: bv_slice.simps)

lemma bv_cat_prepend_0:
  fixes a :: "'a::len word"
  assumes "s < LENGTH('a)"
  shows "bv_cat (0, s') (a,s) = (if s = 0 then 0 else \<langle>s-1,0\<rangle>a,s + s')"
proof(cases "s = 0")
  case True
  thus ?thesis
    by (auto simp add: bv_cat.simps)
next
  case False
  {
    fix b :: "'a::len word"
    assume b: "b=0"
    {
      fix n::nat
      assume n: "n < LENGTH('a)"
      {
        fix x h l :: nat
        {
          fix m :: nat
          assume m: "m < LENGTH('a)"
          hence "\<not> b !! (LENGTH('a) - 1 - m)"
            using b
            by auto
          hence "\<not> to_bl b ! m"
            using m
            by (auto simp add: unfold_test_bit split: if_split_asm)
        }
        hence "\<not>((\<langle>h,l\<rangle>b)::'a::len word) !! x"
          apply (cases "x < LENGTH('a)";cases "h < LENGTH('a)")
          apply (auto simp add: test_bit_of_take_bits)[1]
          using b apply simp
          by (auto simp add: take_bits_def test_bit_bl word_size rev_nth word_rep_drop min_def nth_append)
      }
      note 1 = this
      have "(fst (bv_cat (b, s') (a,s))) !! n= ((\<langle>s-1,0\<rangle>a):: 'a::len word)!!n"
        using assms n 1 False
        apply (auto split: if_split_asm simp add: test_bit_of_take_bits bv_cat.simps word_ao_nth nth_shiftl)
        using b nth_0 by blast
    }
    hence "(fst (bv_cat (b, s') (a,s))) = ((\<langle>s-1,0\<rangle>a):: 'a::len word)"
      and "(snd (bv_cat (b, s') (a,s))) = (s+s')"
      apply (intro word_eqI)
      by (auto simp add: word_size bv_cat.simps)+
  }
  thus ?thesis
    using False
    apply auto
    by (metis prod.exhaust_sel)
qed

lemma test_bit_of_bv_cat:
  fixes a b :: "'a ::len0 word \<times> nat"
  assumes "snd a \<le> LENGTH('a)"
      and "snd b \<le> LENGTH('a)"
      and "i < LENGTH('a)"
    shows "fst (bv_cat a b) !! i = (if i \<ge> snd b then (fst a) !! (i - snd b) else (fst b) !! i)"
  using assms
  by (cases a, cases b,auto simp add: bv_cat.simps test_bit_of_take_bits word_ao_nth nth_shiftl word_size split: if_split_asm)

lemma test_bit_of_bv_slice:
  assumes "h < \<M>"
  shows "fst (bv_slice h l a) !! n = (if n < Suc h - l then fst a!!(l+n) else False)"
  using assms
  apply (cases a, cases "n < \<M>",auto simp add: bv_slice.simps test_bit_of_take_bits)
  by (simp add: word_size test_bit_bin')

lemma bv_slice_bv_cat:
assumes "h < \<M>"
    and "snd a \<le> \<M>"
    and "snd b \<le> \<M>"
  shows "bv_slice h l (bv_cat a b) =
        (if h \<ge> snd b then
          (if l \<ge> snd b then
            bv_slice (h - snd b) (l - snd b) a
           else
            bv_cat (bv_slice (h - snd b) 0 a) (bv_slice (snd b - 1) l b))
        else
          (if l \<ge> snd b then
               (0,0)
           else
              bv_slice h l b))"
proof(cases "h \<ge> snd b")
  case True
  note h = this
  show ?thesis
  proof(cases "l \<ge> snd b")
    case True
    {
      fix i :: nat
      assume "i < \<M>"
      hence "fst (bv_slice h l (bv_cat a b)) !! i = fst (bv_slice (h - snd b) (l - snd b) a) !! i"
        using h True assms
        by (auto simp add: bv_cat.simps test_bit_of_bv_slice nth_ucast test_bit_of_bv_cat split: if_split_asm)
    }
    hence "fst (bv_slice h l (bv_cat a b)) = fst (bv_slice (h - snd b) (l - snd b) a)"
      apply (intro word_eqI)
      by (auto simp add: word_size)
    moreover
    have "snd (bv_slice h l (bv_cat a b)) = snd (bv_slice (h - snd b) (l - snd b) a)"
      using True h
      by (cases a, cases b,auto simp add: size_bv_slice)
    ultimately
    show ?thesis
      using True h
      apply (auto)
      by (metis prod.exhaust_sel)
  next
    case False
    {
      fix i :: nat
      assume "i < \<M>"
      hence "fst (bv_slice h l (bv_cat a b)) !! i = fst (bv_cat (bv_slice (h - snd b) 0 a) (bv_slice (snd b - 1) l b)) !! i"
        using h False assms
        apply (auto simp add: bv_cat.simps nth_ucast test_bit_of_bv_slice test_bit_of_bv_cat word_ao_nth nth_shiftl size_bv_slice split: if_split_asm)
        by (simp add: Groups.add_ac(2))+
    }
    hence "fst (bv_slice h l (bv_cat a b)) = fst (bv_cat (bv_slice (h - snd b) 0 a) (bv_slice (snd b - 1) l b))"
      apply (intro word_eqI)
      by (auto simp add: word_size)
    moreover
    have "snd (bv_slice h l (bv_cat a b)) = snd (bv_cat (bv_slice (h - snd b) 0 a) (bv_slice (snd b - 1) l b))"
      using False h
      by (cases a, cases b,auto simp add: size_bv_slice size_bv_cat)
    ultimately
    show ?thesis
      using False h
      apply (auto)
      by (metis prod.exhaust_sel)
  qed
next
  case False
  note h = this
  show ?thesis
  proof(cases "l \<ge> snd b")
    case True
    {
      fix i :: nat
      assume "i < \<M>"
      hence "fst (bv_slice h l (bv_cat a b)) !! i = (0::longword) !! i"
        using h True assms
        by (auto simp add: bv_cat.simps nth_ucast test_bit_of_bv_slice test_bit_of_bv_cat split: if_split_asm)
    }
    hence "fst (bv_slice h l (bv_cat a b)) = 0"
      apply (intro word_eqI)
      by (auto simp add: word_size)
    moreover
    have "snd (bv_slice h l (bv_cat a b)) = 0"
      using True h
      by (cases a, cases b,auto simp add: size_bv_slice size_bv_cat)
    ultimately
    show ?thesis
      using True h
      apply (auto)
      by (metis prod.exhaust_sel)
  next
    case False
    {
      fix i :: nat
      assume "i < \<M>"
      hence "fst (bv_slice h l (bv_cat a b)) !! i = fst (bv_slice h l b) !! i"
        using h False assms
        by (auto simp add: bv_cat.simps nth_ucast test_bit_of_bv_slice test_bit_of_bv_cat split: if_split_asm)
    }
    hence "fst (bv_slice h l (bv_cat a b)) = fst (bv_slice h l b)"
      apply (intro word_eqI)
      by (auto simp add: word_size)
    moreover
    have "snd (bv_slice h l (bv_cat a b)) = snd (bv_slice h l b)"
      using False h
      by (cases a, cases b,auto simp add: size_bv_slice size_bv_cat)
    ultimately
    show ?thesis
      using False h
      apply (auto)
      by (metis prod.exhaust_sel)
  qed
qed

definition "bv_cat' \<equiv> bv_cat"
lemma take_bits_bv_cat:
  fixes a b :: "'b ::len0 word \<times> nat"
  assumes "h < LENGTH('b)"
      and "snd a \<le> LENGTH('b)"
      and "snd b \<le> LENGTH('b)"
    shows "((\<langle>h,l\<rangle> (fst (bv_cat a b)))::'a::len0 word) =
        (if h \<ge> snd b then
          (if l \<ge> snd b then
            \<langle>h - snd b,l - snd b\<rangle>fst a
           else
            ((\<langle>h,l\<rangle> (fst (bv_cat' a b)))::'a::len0 word))
        else
          (if l \<ge> snd b then
               0
           else
              \<langle>h,l\<rangle> (fst b)))"
proof(cases "h \<ge> snd b")
  case True
  note h = this
  show ?thesis
  proof(cases "l \<ge> snd b")
    case True
    {
      fix i :: nat
      assume "i < LENGTH('a)"
      hence "((\<langle>h,l\<rangle> (fst (bv_cat a b)))::'a::len0 word) !! i = ((\<langle>h - snd b,l - snd b\<rangle>fst a)::'a::len0 word) !! i"
        using h True assms
        by (auto simp add: bv_cat.simps test_bit_of_take_bits nth_ucast test_bit_of_bv_cat split: if_split_asm)
    }
    hence "((\<langle>h,l\<rangle> (fst (bv_cat a b)))::'a::len0 word) = ((\<langle>h - snd b,l - snd b\<rangle>fst a)::'a::len0 word)"
      apply (intro word_eqI)
      by (auto simp add: word_size)
    thus ?thesis
      using True h
      by auto
  next
    case False
    thus ?thesis
      using h
      by (auto simp add: bv_cat'_def)
  qed
next
  case False
  note h = this
  show ?thesis
  proof(cases "l \<ge> snd b")
    case True
    {
      fix i :: nat
      assume "i < LENGTH('a)"
      hence "((\<langle>h,l\<rangle> (fst (bv_cat a b)))::'a::len0 word) !! i = (0::'a::len0 word) !! i"
        using h True assms
        by (auto simp add: bv_cat.simps nth_ucast test_bit_of_take_bits test_bit_of_bv_cat split: if_split_asm)
    }
    thus ?thesis
      using True h
      apply (auto)
      apply (intro word_eqI)
      by (auto simp add: word_size)
  next
    case False
    {
      fix i :: nat
      assume "i < LENGTH('a)"
      hence "((\<langle>h,l\<rangle> (fst (bv_cat a b)))::'a::len0 word) !! i = (\<langle>h,l\<rangle> (fst b)::'a::len0 word) !! i"
        using h False assms
        by (auto simp add: bv_cat.simps nth_ucast test_bit_of_take_bits test_bit_of_bv_cat split: if_split_asm)

    }
    thus ?thesis
      using False h
      apply (auto)
      apply (intro word_eqI)
      by (auto simp add: word_size)
  qed
qed

lemma take_bits_bv_slice:
  assumes "h < \<M>"
      and "h' < \<M>"
  shows "\<langle>h,l\<rangle>fst (bv_slice h' l' a) =  \<langle>(if Suc h - l < Suc h' - (l + l') then h + l' else h'),l + l'\<rangle>fst a"
  using assms
  by (cases a,auto simp add: bv_slice.simps)

lemma bv_slice_take_bits:
  assumes "h < \<M>"
      and "h' < LENGTH('a)"
  fixes a ::"'a::len0 word"
  shows "bv_slice h l (\<langle>h',l'\<rangle>a, s) = (\<langle>(if Suc h - l < Suc h' - (l + l') then h + l' else h'),l + l'\<rangle>a, h + 1 - l)"
  using assms
  by (auto simp add: bv_slice.simps)

lemma bv_slice_bit32:
  fixes a :: longword
  assumes "s \<ge> 32"
  shows "bv_slice 31 0 (a,s) = (ucast ((\<langle>31,0\<rangle>a)::32 word), 32)"
  using assms
  by (auto simp add: bv_slice.simps)

lemma bv_slice_nth_bit:
  assumes "h < \<M>"
  shows "bv_slice h h a = bool_to_bv (fst a !! h)"
proof-
  {
    fix i :: nat
    assume "i < \<M>"
    hence "((\<langle>h,h\<rangle>(fst a))::longword) !! i = (if fst a !! h then 1::longword else 0) !! i"
      using assms
      by (auto simp add: test_bit_of_take_bits)
  }
  hence "((\<langle>h,h\<rangle>(fst a))::longword) = (if fst a !! h then 1::longword else 0)"
    apply (intro word_eqI)
    by (auto simp add: word_size)
  thus ?thesis
    by (cases a;auto simp add: bv_slice.simps)
qed

subsection \<open>Arithmetic\<close>

lemma BV_Add_bit64:
  fixes a b :: longword
    shows "(a,64) +\<^sup>b\<^sup>v (b,64) = (ucast (((\<langle>63,0\<rangle>a)::64 word) + \<langle>63,0\<rangle>b), 64)"
proof-
  have "(a,64) +\<^sup>b\<^sup>v (b,64) = (\<langle>63,0\<rangle>(a + b), 64)"
    by (cases a;cases b;auto simp add: exec_BV_Plus_def case_prod_unfold)
  also have "... = (ucast ((\<langle>63,0\<rangle>(a + b))::64 word), 64)"
    by (subst ucast_take_bits,simp,simp,simp)
  also have "... = (ucast (((\<langle>63,0\<rangle>a)::64 word) + \<langle>63,0\<rangle>b), 64)"
    by (subst take_bits_plus,simp,simp,simp)
  finally
  show ?thesis
    by auto
qed

lemma BV_Add_bit33:
  fixes a b :: longword
    shows "(a,33) +\<^sup>b\<^sup>v (b,33) = (ucast (((\<langle>32,0\<rangle>a)::33 word) + \<langle>32,0\<rangle>b), 33)"
proof-
  have "(a,33) +\<^sup>b\<^sup>v (b,33) = (\<langle>32,0\<rangle>(a + b), 33)"
    by (cases a;cases b;auto simp add: exec_BV_Plus_def case_prod_unfold)
  also have "... = (ucast ((\<langle>32,0\<rangle>(a + b))::33 word), 33)"
    by (subst ucast_take_bits,simp,simp,simp)
  also have "... = (ucast (((\<langle>32,0\<rangle>a)::33 word) + \<langle>32,0\<rangle>b), 33)"
    by (subst take_bits_plus,simp,simp,simp)
  finally
  show ?thesis
    by auto
qed

lemma BV_Add_bit65:
  fixes a b :: longword
    shows "(a,65) +\<^sup>b\<^sup>v (b,65) = (ucast (((\<langle>64,0\<rangle>a)::65 word) + \<langle>64,0\<rangle>b), 65)"
proof-
  have "(a,65) +\<^sup>b\<^sup>v (b,65) = (\<langle>64,0\<rangle>(a + b), 65)"
    by (cases a;cases b;auto simp add: exec_BV_Plus_def case_prod_unfold)
  also have "... = (ucast ((\<langle>64,0\<rangle>(a + b))::65 word), 65)"
    by (subst ucast_take_bits,simp,simp,simp)
  also have "... = (ucast (((\<langle>64,0\<rangle>a)::65 word) + \<langle>64,0\<rangle>b), 65)"
    by (subst take_bits_plus,simp,simp,simp)
  finally
  show ?thesis
    by auto
qed

subsection \<open>Floating Point operations\<close>

context abstract_float
begin

lemma BV_Plus_bit64:
  fixes a b :: "64 word"
  shows "(\<langle>63,0\<rangle>a, 64) fplus\<^sup>b\<^sup>v (\<langle>63,0\<rangle>b, 64) = (\<langle>63,0\<rangle>(a +\<^sup>f b), 64)"
  by (auto simp add: exec_BV_Plus_Double_def)

lemma BV_Plus_bit64_numeral:
  fixes a :: "64 word"
  shows "(\<langle>63,0\<rangle>a, 64) fplus\<^sup>b\<^sup>v (numeral n, 64) = (\<langle>63,0\<rangle>(a +\<^sup>f \<langle>63,0\<rangle>((numeral n)::longword)), 64)"
  by (auto simp add: exec_BV_Plus_Double_def)

lemma BV_Sub_bit64:
  fixes a b :: "64 word"
  shows "(\<langle>63,0\<rangle>a, 64) fsub\<^sup>b\<^sup>v (\<langle>63,0\<rangle>b, 64) = (\<langle>63,0\<rangle>(a -\<^sup>f b), 64)"
  by (auto simp add: exec_BV_Sub_Double_def)

lemma BV_Sub_bit64_numeral:
  fixes a :: "64 word"
  shows "(\<langle>63,0\<rangle>a, 64) fsub\<^sup>b\<^sup>v (numeral n, 64) = (\<langle>63,0\<rangle>(a -\<^sup>f \<langle>63,0\<rangle>((numeral n)::longword)), 64)"
  by (auto simp add: exec_BV_Sub_Double_def)

lemma BV_Mult_bit64:
  fixes a b :: "64 word"
  shows "(\<langle>63,0\<rangle>a, 64) fmult\<^sup>b\<^sup>v (\<langle>63,0\<rangle>b, 64) = (\<langle>63,0\<rangle>(a *\<^sup>f b), 64)"
  by (auto simp add: exec_BV_Mul_Double_def)

lemma BV_Mult_bit64_numeral_r:
  fixes a :: "64 word"
  shows "(\<langle>63,0\<rangle>a, 64) fmult\<^sup>b\<^sup>v (numeral n, 64) = (\<langle>63,0\<rangle>(a *\<^sup>f \<langle>63,0\<rangle>((numeral n)::longword)), 64)"
  by (auto simp add: exec_BV_Mul_Double_def)
lemma BV_Mult_bit64_numeral_l:
  fixes a :: "64 word"
  shows "(numeral n, 64) fmult\<^sup>b\<^sup>v (\<langle>63,0\<rangle>a, 64) = (\<langle>63,0\<rangle>(\<langle>63,0\<rangle>((numeral n)::longword) *\<^sup>f a), 64)"
  by (auto simp add: exec_BV_Mul_Double_def)
lemma BV_Mult_bit64_0_l:
  fixes a :: "64 word"
  shows "(0, 64) fmult\<^sup>b\<^sup>v (\<langle>63,0\<rangle>a, 64) = (\<langle>63,0\<rangle>(0\<^sup>+ *\<^sup>f a), 64)"
  by (auto simp add: exec_BV_Mul_Double_def plus_zero_def)
lemma BV_Mult_bit64_0_r:
  fixes a :: "64 word"
  shows "(\<langle>63,0\<rangle>a, 64) fmult\<^sup>b\<^sup>v (0, 64) = (\<langle>63,0\<rangle>(a *\<^sup>f 0\<^sup>+), 64)"
  by (auto simp add: exec_BV_Mul_Double_def plus_zero_def)

lemma BV_Div_bit64:
  fixes a b :: "64 word"
  shows "(\<langle>63,0\<rangle>a, 64) fdiv\<^sup>b\<^sup>v (\<langle>63,0\<rangle>b, 64) = (\<langle>63,0\<rangle>(a div\<^sup>f b), 64)"
  by (auto simp add: exec_BV_Div_Double_def)

lemma BV_Div_bit64_numeral:
  fixes a :: "64 word"
  shows "(\<langle>63,0\<rangle>a, 64) fdiv\<^sup>b\<^sup>v (numeral n, 64) = (\<langle>63,0\<rangle>(a div\<^sup>f \<langle>63,0\<rangle>((numeral n)::longword)), 64)"
  by (auto simp add: exec_BV_Div_Double_def)

end

subsection \<open>Simplification rules\<close>

lemmas (in abstract_float) bit_vector_simps =
    bv_slice_bv_cat take_bits_bv_slice bv_slice_take_bits take_bits_bv_cat bv_slice_bit32
    bv_cat_prepend_0 size_bv_cat size_bv_slice
    bv_to_bool_bool_to_bv snd_bool_to_bv
    bv_to_bool_True bv_to_bool_True_Suc0
    bv_to_bool_False bv_to_bool_False_Suc0
    BV_Add_bit65 BV_Add_bit64 BV_Add_bit33
    BV_Plus_bit64 BV_Plus_bit64_numeral
    BV_Sub_bit64 BV_Sub_bit64_numeral
    BV_Mult_bit64 BV_Mult_bit64_numeral_r BV_Mult_bit64_numeral_l BV_Mult_bit64_0_l BV_Mult_bit64_0_r
    BV_Div_bit64 BV_Div_bit64_numeral
    bv_slice_bit32
    bv_NOT.simps
    bv_NOT_bool_to_bv bool_to_bv_eq bv_slice_nth_bit
end


(*  Title:      HOL/Proofs/ex/XML_Data.thy
    Author:     Makarius
    Author:     Stefan Berghofer

XML data representation of proof terms.
*)

theory XML_Data
imports "~~/src/HOL/Isar_Examples/Drinker"
begin

subsection {* Export and re-import of global proof terms *}

ML {*
  fun export_proof thm =
    let
      val thy = Thm.theory_of_thm thm;
      val {prop, hyps, shyps, ...} = Thm.rep_thm thm;
      val (_, prop) = Logic.unconstrainT shyps (Logic.list_implies (hyps, prop));
      val prf =
        Proofterm.proof_of (Proofterm.strip_thm (Thm.proof_body_of thm)) |>
        Reconstruct.reconstruct_proof thy prop |>
        Reconstruct.expand_proof thy [("", NONE)] |>
        Proofterm.rew_proof thy |>
        Proofterm.no_thm_proofs;
    in Proofterm.encode prf end;

  fun import_proof thy xml =
    let
      val prf = Proofterm.decode xml;
      val (prf', _) = Proofterm.freeze_thaw_prf prf;
    in Drule.export_without_context (Proof_Checker.thm_of_proof thy prf') end;
*}

subsection {* Examples *}

ML {* val thy1 = @{theory} *}

lemma ex: "A \<longrightarrow> A" ..

ML_val {*
  val xml = export_proof @{thm ex};
  val thm = import_proof thy1 xml;
*}

ML_val {*
  val xml = export_proof @{thm de_Morgan};
  val thm = import_proof thy1 xml;
*}

ML_val {*
  val xml = export_proof @{thm Drinker's_Principle};
  val thm = import_proof thy1 xml;
*}

text {* Some fairly large proof: *}

ML_val {*
  val xml = export_proof @{thm Int.times_int.abs_eq};
  val thm = import_proof thy1 xml;
  @{assert} (size (YXML.string_of_body xml) > 50000000);
*}

end