theory doc
  imports "repliss_sem"
    "repliss_sem_single_invocation"
    "HOL-Library.OptionalSugar"
    unique_ids
begin

section "Document Snippets"

notation (tab output)
  "HOL.eq"  ("(_) = (1_)" [50,49] 50) and
  "Pure.eq"  ("(_) \<equiv> (1_)" [1,1] 2)

text \<open>
\DefineSnippet{local}{
  @{thm [display] repliss_sem.local}
}%EndSnippet

\DefineSnippet{newId}{
  @{thm [display] repliss_sem.newId}
}%EndSnippet

\DefineSnippet{beginAtomic}{
  @{thm [display] repliss_sem.beginAtomic}
}%EndSnippet

\DefineSnippet{endAtomic}{
  @{thm [display] repliss_sem.endAtomic}
}%EndSnippet

\DefineSnippet{dbop}{
  @{thm [display] repliss_sem.dbop}
}%EndSnippet

\DefineSnippet{invocation}{
  @{thm [display] repliss_sem.invocation}
}%EndSnippet

\DefineSnippet{return}{
  @{thm [display] repliss_sem.return}
}%EndSnippet

\DefineSnippet{crash}{
  @{thm [display] repliss_sem.crash}
}%EndSnippet

\DefineSnippet{invCheck}{
  @{thm [display] repliss_sem.invCheck}
}%EndSnippet

\<close>

text \<open>
\DefineSnippet{s_local}{
  @{thm [display] repliss_sem_single_invocation.local}
}%EndSnippet

\DefineSnippet{s_newId}{
  @{thm [display] repliss_sem_single_invocation.newId}
}%EndSnippet

\DefineSnippet{s_beginAtomic}{
  @{thm [display] repliss_sem_single_invocation.beginAtomic[unfolded atomize_all]}
}%EndSnippet

\DefineSnippet{s_endAtomic}{
  @{thm [display] repliss_sem_single_invocation.endAtomic}
}%EndSnippet

\DefineSnippet{s_dbop}{
  @{thm [display] repliss_sem_single_invocation.dbop}
}%EndSnippet

\DefineSnippet{s_invocation}{
  @{thm [display] repliss_sem_single_invocation.invocation[unfolded atomize_all]}
}%EndSnippet

\DefineSnippet{s_return}{
  @{thm [display] repliss_sem_single_invocation.return}
}%EndSnippet

\<close>

text \<open>
\DefineSnippet{traces}{
  @{thm [display] traces_def}
}%EndSnippet

\DefineSnippet{actionCorrect_def}{
  @{thm [display] actionCorrect_def}
}%EndSnippet

\DefineSnippet{traceCorrect}{
  @{thm [display] traceCorrect_def}
}%EndSnippet

\DefineSnippet{programCorrect}{
  @{thm [display] programCorrect_def}
}%EndSnippet

\<close>

schematic_goal getContext_def: "visibleCalls S i \<triangleq> vis \<Longrightarrow> getContext S i = ?x"
  unfolding getContextH_def
  by auto

text \<open>\DefineSnippet{getContext_def}{
  @{thm [display] getContext_def}
}%EndSnippet\<close>

text \<open>\DefineSnippet{getContext_def_prem}{
  @{thm [display] (prem 1) getContext_def}
}%EndSnippet\<close>

text \<open>\DefineSnippet{getContext_def_concl}{
  @{thm  [display] (concl) getContext_def}
}%EndSnippet\<close>

schematic_goal invariant_all_def: "invariant_all S = ?x"
  unfolding invContextH_def
  by simp

text \<open>\DefineSnippet{invariant_all_def}{
  @{thm [display] invariant_all_def}
}%EndSnippet\<close>

lemma committedCalls_def: "committedCalls S = {c. \<exists>tx. callOrigin S c \<triangleq> tx \<and> txStatus S tx \<triangleq> Committed}"
  unfolding committedCallsH_def isCommittedH_def
  by simp

text \<open>\DefineSnippet{committedCalls_def}{
  @{thm [display] committedCalls_def}
}%EndSnippet\<close>

text \<open>\DefineSnippet{traceCorrect_s_def}{
  @{thm [display] traceCorrect_s_def}
}%EndSnippet\<close>

text \<open>\DefineSnippet{programCorrect_s_def}{
  @{thm [display] programCorrect_s_def}
}%EndSnippet\<close>

text \<open>\DefineSnippet{steps_s_refl}{
  @{thm [display] steps_s_refl}
}%EndSnippet\<close>

text \<open>\DefineSnippet{steps_s_step}{
  @{thm [display] steps_s_step}
}%EndSnippet\<close>

text \<open>\DefineSnippet{state_monotonicGrowth_def}{
  @{thm [display] state_monotonicGrowth_def}
}%EndSnippet\<close>

text \<open>\DefineSnippet{program_wellFormed_def}{
  @{thm [display] program_wellFormed_def}
}%EndSnippet\<close>

text \<open>\DefineSnippet{invocations_cannot_guess_ids_def}{
  @{thm [display] invocations_cannot_guess_ids_def}
}%EndSnippet\<close>

text \<open>\DefineSnippet{invocations_cannot_guess_ids_def2}{
  @{thm [display] invocations_cannot_guess_ids_def2}
}%EndSnippet\<close>

text \<open>\DefineSnippet{invocation_cannot_guess_ids_def}{
  @{thm [display] invocation_cannot_guess_ids_def}
}%EndSnippet\<close>

text \<open>\DefineSnippet{trace_outputs_def}{
  @{thm [display] trace_outputs_def}
}%EndSnippet\<close>

text \<open>\DefineSnippet{action_outputs_simps}{
  @{thm [display] action_outputs.simps}
}%EndSnippet\<close>

text \<open>\DefineSnippet{trace_inputs_def}{
  @{thm [display] trace_inputs_def}
}%EndSnippet\<close>

text \<open>\DefineSnippet{action_inputs_simps}{
  @{thm [display] action_inputs.simps}
}%EndSnippet\<close>

text \<open>\DefineSnippet{queries_cannot_guess_ids_def}{
  @{thm [display] queries_cannot_guess_ids_def}
}%EndSnippet\<close>

text \<open>\DefineSnippet{query_cannot_guess_ids_def}{
  @{thm [display] query_cannot_guess_ids_def}
}%EndSnippet\<close>

text \<open>\DefineSnippet{queries_cannot_guess_ids_def2}{
  @{thm [display] queries_cannot_guess_ids_def2}
}%EndSnippet\<close>

end


section {* Host Properties *}

theory Wasm_Axioms imports Wasm begin

lemma old_mem_size_def:
  shows "mem_size m = length (fst (Rep_mem m)) div Ki64"
  unfolding mem_size_def mem_length_def
  by (simp split: prod.splits)

(* these were originally axioms, but memory now has a concrete representation in the model *)
lemma mem_grow_size:
  assumes "mem_grow m n = Some m'"
  shows "(mem_size m + n) = mem_size m'"
  using assms Abs_mem_inverse
  unfolding mem_grow_def old_mem_size_def mem_append_def bytes_replicate_def
  by (auto simp add: Ki64_def Let_def split: prod.splits if_splits)

lemma mem_grow_max1:
  assumes "mem_grow m n = Some m'"
  shows "mem_max m = mem_max m'"
  using assms Abs_mem_inverse
  unfolding mem_grow_def mem_max_def mem_append_def
  by (auto simp add: Ki64_def Let_def split: prod.splits if_splits)

lemma mem_grow_max2:
  assumes "mem_grow m n = Some m'"
  shows "pred_option ((\<le>) (mem_size m')) (mem_max m')"
  using assms Abs_mem_inverse
  unfolding mem_grow_def mem_max_def mem_append_def
  by (auto simp add: assms mem_grow_size Let_def split: prod.splits if_splits)

lemma mem_grow_length:
  assumes "mem_grow m n = Some m'"
  shows "(mem_length m + (n * Ki64)) = mem_length m'"
  using assms Abs_mem_inverse
        bytes_replicate_def mem_append.rep_eq mem_length.rep_eq
  unfolding mem_grow_def old_mem_size_def mem_append_def bytes_replicate_def
  by (auto simp add: Let_def split: prod.splits if_splits)

lemma mem_grow_byte_at_m:
  assumes "k < mem_length m"
          "(mem_grow m n) = Some m'"
  shows "byte_at m' k = byte_at m k"
  using assms
  unfolding byte_at.rep_eq mem_length.rep_eq mem_grow_def mem_append.rep_eq mem_append_def
  by (auto simp add: Abs_mem_inverse nth_append Let_def split: prod.splits if_splits)

lemma mem_grow_byte_at_m_n:
  assumes "k \<ge> mem_length m"
          "(mem_grow m n) = Some m'"
          "k < mem_length m'"
  shows "byte_at m' k = (0::byte)"
  using assms
  unfolding byte_at.rep_eq mem_length.rep_eq mem_grow_def mem_append.rep_eq bytes_replicate_def mem_append_def
  by (auto simp add: Abs_mem_inverse nth_append Let_def split: prod.splits if_splits)

lemma load_size:
  "(load m n off l = None) = (mem_length m < (off + n + l))"
  unfolding load_def
  by (cases "n + off + l \<le> mem_length m") auto

lemma load_packed_size:
  "(load_packed sx m n off lp l = None) = (mem_length m < (off + n + lp))"
  using load_size
  unfolding load_packed_def
  by (cases "n + off + l \<le> mem_length m") auto

lemma store_size1:
  "(store m n off v l = None) = (mem_length m < (off + n + l))"
  unfolding store_def
  by (cases "n + off + l \<le> mem_length m") auto

lemma store_size:
  assumes "(store m n off v l = Some m')"
  shows "mem_size m = mem_size m'"
  using assms Abs_mem_inverse mem_length.rep_eq
  unfolding store_def write_bytes_def bytes_takefill_def
  by (cases "n + off + l \<le> mem_length m") (auto simp add: old_mem_size_def split: prod.splits)

lemma store_max:
  assumes "(store m n off v l = Some m')"
  shows "mem_max m = mem_max m'"
  using assms Abs_mem_inverse
  unfolding store_def mem_max.rep_eq write_bytes_def
  by (auto split: if_splits prod.splits)

lemma store_length:
  assumes "(store m n off v l = Some m')"
  shows "mem_length m = mem_length m'"
  using assms Abs_mem_inverse mem_length.rep_eq
  unfolding store_def write_bytes_def bytes_takefill_def
  by (cases "n + off + l \<le> mem_length m") (auto split: prod.splits)

lemma store_packed_size1:
  "(store_packed m n off v l = None) = (mem_length m < (off + n + l))"
  using store_size1
  unfolding store_packed_def
  by simp

lemma store_packed_size:
  assumes "(store_packed m n off v l = Some m')"
  shows "mem_size m = mem_size m'"
  using assms store_size
  unfolding store_packed_def
  by simp

lemma store_packed_max:
  assumes "(store_packed m n off v l = Some m')"
  shows "mem_max m = mem_max m'"
  using assms store_max
  unfolding store_packed_def
  by simp

axiomatization where
  wasm_deserialise_type:"typeof (wasm_deserialise bs t) = t"

axiomatization where
    host_apply_preserve_store1:"host_apply s (t1s _> t2s) f vs hs = Some (s', vs') \<Longrightarrow> store_extension s s'"
and host_apply_preserve_store2:"host_apply s (t1s _> t2s) f vs hs = Some (s', vs') \<Longrightarrow> store_typing s \<Longrightarrow> store_typing s'"
and host_apply_respect_type:"list_all2 types_agree t1s vs \<Longrightarrow> host_apply s (t1s _> t2s) f vs hs = Some (s', vs') \<Longrightarrow> list_all2 types_agree t2s vs'"

lemma host_apply_preserve_store:
  assumes "host_apply s (t1s _> t2s) f vs hs = Some (s', vs')"
          "store_typing s"
  shows "store_extension s s' \<and> store_typing s'"
  using assms host_apply_preserve_store1 host_apply_preserve_store2
  by blast

end


(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

(*
 * Verifying quicksort implementation using AutoCorres!
 *)
theory Quicksort
imports
  "AutoCorres.AutoCorres"
  "HOL-Library.Multiset"
begin

declare validNF_whileLoop_inv_measure_twosteps [wp]
declare validNF_whileLoopE_inv_measure_twosteps [wp]

declare creturn_def [vcg_simp]

external_file "quicksort.c"
install_C_file "quicksort.c"
autocorres "quicksort.c"

context quicksort begin

thm partition_body_def
thm quicksort_body_def

thm partition'_def
thm quicksort'.simps

(* Some rules for pointer addition *)

(* FIXME: move *)
lemma ptr_add_assoc [simp]:
  "p +\<^sub>p (i + j) = p +\<^sub>p i +\<^sub>p j"
  by (simp add: CTypesDefs.ptr_add_def distrib_right)

(* FIXME: move *)
lemma ptr_add_commute [simp]:
  "p +\<^sub>p i +\<^sub>p j = p +\<^sub>p j +\<^sub>p i"
  by (metis ptr_add_assoc add.commute)

(*
 * Array validity definitions
 *)

definition
  array_loc_valid :: "word32 ptr \<Rightarrow> nat \<Rightarrow> bool"
where
  "array_loc_valid a n \<equiv>
   (unat (ptr_val a) + size_of TYPE(word32) * n \<le> 2 ^ len_of TYPE(addr_bitsize))"

fun
  array_elems_valid :: "lifted_globals \<Rightarrow> word32 ptr \<Rightarrow> nat \<Rightarrow> bool"
where
  "array_elems_valid s a 0 = True" |
  "array_elems_valid s a (Suc n) = (is_valid_w32 s a \<and> array_elems_valid s (a +\<^sub>p 1) n)"

lemma array_all_elems_valid:
  (* equivalent characterisation of array validity *)
  "array_elems_valid s a n = (\<forall>m. m < n \<longrightarrow> is_valid_w32 s (a +\<^sub>p int m))"
  apply (induct n arbitrary: a)
   apply simp
  apply (case_tac "n = 0")
   apply simp
  apply (rule iffI)
   apply clarsimp
   apply (case_tac "m = 0")
    apply simp
   apply (case_tac "m = n")
    apply clarsimp
    apply (drule_tac x = "n - 1" in spec)
    apply (simp add: CTypesDefs.ptr_add_def)
   apply (drule_tac x = "m - 1" in spec)
   apply (simp add: CTypesDefs.ptr_add_def)
  apply simp
  apply (frule_tac x = "0" in spec)
  apply clarsimp
  apply (frule_tac x = "m + 1" in spec)
  apply simp
  done

definition
  is_array :: "lifted_globals \<Rightarrow> word32 ptr \<Rightarrow> nat \<Rightarrow> bool"
where
  "is_array s a n \<equiv> (array_loc_valid a n \<and> array_elems_valid s a n)"

(* Necessary condition for many pointer comparison lemmas *)
definition array_not_at_mem_end :: "word32 ptr \<Rightarrow> nat \<Rightarrow> bool"
where
  "array_not_at_mem_end a n \<equiv>
   (unat (ptr_val a) + size_of TYPE(word32) * n < 2 ^ len_of TYPE(addr_bitsize))"
  (* same as "array_loc_valid a n" but excluding equality *)

(* Some obvious but useful corollaries *)

lemma array_valid_elem:
  "\<lbrakk> is_array s a n; m < n \<rbrakk> \<Longrightarrow> is_valid_w32 s (a +\<^sub>p int m)"
  by (metis is_array_def array_all_elems_valid)

lemma array_valid_elem2:
  "\<lbrakk> is_array s a (unat n); m < n \<rbrakk> \<Longrightarrow> is_valid_w32 s (a +\<^sub>p uint m)"
  by (metis array_valid_elem uint_nat word_less_nat_alt)

lemma empty_array_is_array:
  "is_array s a 0"
  apply (insert unat_lt2p[of "ptr_val a"])
  apply (simp add: is_array_def array_loc_valid_def)
  done

lemma empty_array_not_at_mem_end:
  "array_not_at_mem_end a 0"
  apply (insert unat_lt2p[of "ptr_val a"])
  apply (simp add: array_not_at_mem_end_def)
  done

lemma subarray_not_at_mem_end1:
  "\<lbrakk> array_loc_valid a n; m < n \<rbrakk> \<Longrightarrow> array_not_at_mem_end a m"
  by (simp add: array_loc_valid_def array_not_at_mem_end_def)

lemma subarray_not_at_mem_end2:
  "\<lbrakk> is_array s a n; m < n \<rbrakk> \<Longrightarrow> array_not_at_mem_end a m"
  by (clarsimp simp: is_array_def subarray_not_at_mem_end1)

lemma updated_array_elems_valid [simp]:
  "array_elems_valid (heap_w32_update f s) a n = array_elems_valid s a n"
  by (induct n arbitrary: a, auto)

lemma updated_array_is_array [simp]:
  "is_array (heap_w32_update f s) a n = is_array s a n"
  by (simp add: is_array_def)

(* Some word arithmetic *)

(* FIXME: move *)
lemma unat_plus_weak:
  "(x::addr) \<le> x + y \<Longrightarrow> unat (x + y) = unat x + unat y"
  by (simp add: unat_plus_simple)

lemma unat_linear_over_array_loc:
  "array_not_at_mem_end a n \<Longrightarrow>
   unat (ptr_val a + of_nat (size_of TYPE(word32)) * (of_nat n)) =
   unat (ptr_val a) + size_of TYPE(word32) * n"
  apply (simp add: array_not_at_mem_end_def)
  apply (subgoal_tac "unat (4 * (of_nat n)) = 4 * n")
   apply (subst unat_plus_weak)
    apply (subst no_olen_add_nat)
    apply (rule_tac s = "4 * n" and t = "unat (4 * of_nat n)" in subst)
     apply (erule sym)
    apply simp+
  apply (simp add: unat_mult_simple unat_of_nat_eq)
  done

lemma unat_linear_over_array_loc2:
  "array_not_at_mem_end a n \<Longrightarrow>
   unat (ptr_val a + 4 * (of_nat n)) = unat (ptr_val a) + 4 * n"
  by (frule unat_linear_over_array_loc, simp)

(* Pointer inequalities *)

lemma array_no_wrap:
  "\<lbrakk> array_loc_valid a n; m < n \<rbrakk> \<Longrightarrow> a \<le> a +\<^sub>p int m"
  apply (clarsimp simp: array_loc_valid_def CTypesDefs.ptr_add_def
                        ptr_le_def' ptr_le_def)
  apply (subst no_olen_add_nat)
  apply (subst unat_mult_simple)
   apply (subst unat_of_nat_eq, simp+)+
  done

lemma array_no_wrap2:
  "\<lbrakk> array_loc_valid a (unat n); m < n \<rbrakk> \<Longrightarrow> a \<le> a +\<^sub>p uint m"
  by (metis array_no_wrap uint_nat word_less_nat_alt)

lemma array_loc_mono:
  "\<lbrakk> array_not_at_mem_end a n; m \<le> n \<rbrakk> \<Longrightarrow> a +\<^sub>p int m \<le> a +\<^sub>p int n"
  apply (clarsimp simp: array_not_at_mem_end_def CTypesDefs.ptr_add_def
                        ptr_le_def' ptr_le_def)
  apply (rule word_plus_mono_right)
   apply (rule word_mult_le_mono1)
     apply (rule PackedTypes.of_nat_mono_maybe_le, simp+)
   apply (subst unat_of_nat_eq, simp+)
  apply (subst no_olen_add_nat)
  apply (subst unat_mult_simple)
   apply (subst unat_of_nat_eq, simp+)+
  done

lemma array_loc_mono2:
  "\<lbrakk> array_not_at_mem_end a (unat n); m \<le> n \<rbrakk> \<Longrightarrow> a +\<^sub>p uint m \<le> a +\<^sub>p uint n"
  by (metis array_loc_mono uint_nat word_le_nat_alt)

lemma array_loc_strict_mono:
  "\<lbrakk> array_not_at_mem_end a n; m < n \<rbrakk> \<Longrightarrow> a +\<^sub>p int m < a +\<^sub>p int n"
  apply (clarsimp simp: array_not_at_mem_end_def CTypesDefs.ptr_add_def
                        ptr_less_def' ptr_less_def)
  apply (rule word_plus_strict_mono_right)
   apply (rule word_mult_less_mono1)
     apply (subst of_nat_mono_maybe, simp+)
   apply (subst unat_of_nat_eq, simp+)
  apply (subst no_olen_add_nat)
  apply (subst unat_mult_simple)
   apply (subst unat_of_nat_eq, simp+)+
  done

lemma array_loc_strict_mono2:
  "\<lbrakk> array_not_at_mem_end a (unat n); m < n \<rbrakk> \<Longrightarrow> a +\<^sub>p uint m < a +\<^sub>p uint n"
  by (metis array_loc_strict_mono uint_nat word_less_nat_alt)

(* Concatenation lemmas *)

lemma array_concat_elems_valid:
  "array_elems_valid s a (n + m) =
   (array_elems_valid s a n \<and> array_elems_valid s (a +\<^sub>p int n) m)"
  apply (subst array_all_elems_valid)+
  apply (rule iffI)
   apply clarsimp
   apply (frule_tac x = "n + ma" in spec)
   apply simp
  apply clarsimp
  apply (case_tac "ma < n")
   apply simp
  apply (frule_tac x = "ma - n" and
                   P = "\<lambda>ma. (ma < m \<longrightarrow> is_valid_w32 s (a +\<^sub>p int ma +\<^sub>p int n))"
                   in spec)
  apply (subgoal_tac "ma - n < m")
   apply (simp add: CTypesDefs.ptr_add_def)
  apply simp
  done

lemma is_array_concat:
  "\<lbrakk> m = 0 \<or> array_not_at_mem_end a n \<rbrakk> \<Longrightarrow>
   is_array s a (n + m) = (is_array s a n \<and> is_array s (a +\<^sub>p int n) m)"
  apply (erule disjE)
   apply (simp add: empty_array_is_array)
  apply (frule unat_linear_over_array_loc)
  apply (subgoal_tac "array_loc_valid a n")
   apply (simp add: is_array_def array_loc_valid_def
                    array_concat_elems_valid add.assoc conj_commute)
  apply (simp add: array_loc_valid_def array_not_at_mem_end_def)
  done

lemma is_array_concat2:
  "\<lbrakk> m \<le> n; array_not_at_mem_end a m \<or> m = n \<rbrakk> \<Longrightarrow>
   is_array s a n = (is_array s a m \<and> is_array s (a +\<^sub>p int m) (n - m))"
  apply (subst diff_add_inverse[symmetric, where n = "m"])
  apply (subst diff_add_assoc, assumption)
  apply (rule is_array_concat, force)
  done

lemma subarray1_is_array:
  "\<lbrakk> is_array s a n; m \<le> n \<rbrakk> \<Longrightarrow> is_array s a m"
  apply (case_tac "m = n", simp)
  apply (frule_tac m = "m" in subarray_not_at_mem_end2, simp)
  apply (simp add: is_array_concat2)
  done

lemma subarray2_is_array:
  "\<lbrakk> is_array s a n; m \<le> n; array_not_at_mem_end a m \<or> m = n \<rbrakk> \<Longrightarrow>
   is_array s (a +\<^sub>p int m) (n - m)"
  by (simp add: is_array_concat2)

lemma concat_is_array:
  "\<lbrakk> is_array s a m; is_array s (a +\<^sub>p int m) (n - m);
     m \<le> n; array_not_at_mem_end a m \<or> m = n \<rbrakk> \<Longrightarrow>
   is_array s a n"
  by (subst is_array_concat2[where m = "m"], simp_all)

(* Array contents, definitions and lemmas *)

primrec
  the_array :: "lifted_globals \<Rightarrow> word32 ptr \<Rightarrow> nat \<Rightarrow> word32 list"
where
  "the_array s a 0 = []" |
  "the_array s a (Suc n) = (heap_w32 s a) # (the_array s (a +\<^sub>p 1) n)"

lemma the_array_length [simp]:
  "length (the_array s a n) = n"
  by (induct n arbitrary: a, auto)

lemma the_array_elem:
  "m < n \<Longrightarrow> the_array s a n ! m = heap_w32 s (a +\<^sub>p int m)"
  apply (induct n arbitrary: a m)
   apply simp
  apply (case_tac "m = 0")
   apply (auto simp: CTypesDefs.ptr_add_def)
  done

lemma the_arrays_equal:
  "(the_array s a n = the_array s' a' n) =
   (\<forall>m < n. heap_w32 s (a +\<^sub>p int m) = heap_w32 s' (a' +\<^sub>p int m))"
  by (simp add: list_eq_iff_nth_eq the_array_elem)

lemma the_array_concat:
  "the_array s a (n + m) = the_array s a n @ the_array s (a +\<^sub>p int n) m"
  by (induct n arbitrary: a m, auto)

lemma the_array_concat2:
  "m \<le> n \<Longrightarrow>
   the_array s a n = the_array s a m @ the_array s (a +\<^sub>p int m) (n - m)"
  apply (subst diff_add_inverse[symmetric, where n = "m"])
  apply (subst diff_add_assoc)
  apply (simp_all only: the_array_concat)
  done

(* Pointer simplification rules *)

(* FIXME: move *)
lemma word32_mult_cancel_right:
  fixes a :: "addr" and b :: "addr" and c :: "addr"
  shows
  "\<lbrakk> unat a * unat c < 2 ^ len_of TYPE(addr_bitsize);
     unat b * unat c < 2 ^ len_of TYPE(addr_bitsize); c \<noteq> 0 \<rbrakk> \<Longrightarrow>
   (a * c = b * c) = (a = b)"
  apply (rule iffI)
   apply simp_all
  apply (subgoal_tac "a = a * c div c")
   apply simp
   apply (rule sym)
   apply (rule Word.word_div_mult[symmetric, where 'a = addr_bitsize],
          unat_arith, simp)+
  done

lemma ptr_offsets_eq [simp]:
  fixes i :: "nat" and j :: "nat" and a :: "word32 ptr"
  shows
  "\<lbrakk> i * size_of TYPE(word32) < 2 ^ len_of TYPE(addr_bitsize);
     j * size_of TYPE(word32) < 2 ^ len_of TYPE(addr_bitsize) \<rbrakk> \<Longrightarrow>
   (a +\<^sub>p int i = a +\<^sub>p int j) = (i = j)"
  by (simp add: CTypesDefs.ptr_add_def word32_mult_cancel_right
                unat_of_nat_eq of_nat_inj)

lemma ptr_offsets_eq2 [simp]:
  fixes i :: "addr" and j :: "addr" and a :: "word32 ptr"
  shows
  "\<lbrakk> unat i * size_of TYPE(word32) < 2 ^ len_of TYPE(addr_bitsize);
     unat j * size_of TYPE(word32) < 2 ^ len_of TYPE(addr_bitsize) \<rbrakk> \<Longrightarrow>
   (a +\<^sub>p uint i = a +\<^sub>p uint j) = (i = j)"
  by (simp add: ptr_add_def word32_mult_cancel_right)

(* Array update simplification *)

(* FIXME: move? *)
lemma trivial_heap_update [simp]:
  "heap_w32_update (\<lambda>x. x) s = s"
  by simp

lemma the_updated_array:
  "\<lbrakk> is_array s p n; m < n \<rbrakk> \<Longrightarrow>
   the_array (heap_w32_update (\<lambda>h q. if q = p +\<^sub>p int m then x else f h q) s) p n =
   (the_array (heap_w32_update f s) p n)[m := x]"
  by (auto simp: is_array_def array_loc_valid_def the_array_elem
           intro: nth_equalityI)

lemma multiset_of_cycle:
  (* Courtesy of Dave G *)
  "\<lbrakk> i < length ls; j < length ls; k < length ls; i = k \<Longrightarrow> ls ! i = ls ! j \<rbrakk> \<Longrightarrow>
   mset (ls[i := (ls ! j), j := ls ! k, k := ls ! i]) = mset ls"
  apply (subst (2) mset_swap[symmetric, where i = j and j = i], assumption+)
  apply (subst (2) mset_swap[symmetric, where i = j and j = k], simp+)
  apply (clarsimp simp: nth_list_update)
  apply (metis list_update_overwrite list_update_swap)
  done

(* Defining sanity of program, i.e. that only the array can change,
   and some related lemmas *)

definition unmodified_outside_range ::
             "lifted_globals \<Rightarrow> lifted_globals \<Rightarrow> word32 ptr \<Rightarrow> nat \<Rightarrow> bool"
where
  "unmodified_outside_range s s' a n \<equiv>
   (\<forall>p. (p < a \<or> (array_not_at_mem_end a n \<and> p \<ge> a +\<^sub>p int n)) \<longrightarrow>
        (is_valid_w32 s' p = is_valid_w32 s p \<and> heap_w32 s' p = heap_w32 s p))"

lemma unmodified_outside_range_refl [simp]:
  "unmodified_outside_range s s a n"
  by (simp add: unmodified_outside_range_def)

lemma unmodified_outside_range_trans:
  "\<lbrakk> unmodified_outside_range s1 s2 a n; unmodified_outside_range s2 s3 a n \<rbrakk>
   \<Longrightarrow> unmodified_outside_range s1 s3 a n"
  by (simp add: unmodified_outside_range_def)

lemma unmodified_outside_empty_range:
  "unmodified_outside_range s s' p 0
   \<Longrightarrow> \<forall>p. (is_valid_w32 s' p = is_valid_w32 s p \<and>
            heap_w32 s' p = heap_w32 s p)"
  apply (clarsimp simp: unmodified_outside_range_def empty_array_not_at_mem_end)
  apply (case_tac "pa < p", simp+)
  done

lemma unmodified_outside_empty_range2:
  "\<lbrakk> unmodified_outside_range s s' p 0; array_loc_valid a n \<rbrakk>
   \<Longrightarrow> unmodified_outside_range s s' a n"
  apply (clarsimp simp: unmodified_outside_range_def empty_array_not_at_mem_end)
  apply (case_tac "pa < p", simp+)
  done

lemma unmodified_outside_subrange1:
  "\<lbrakk> array_loc_valid a n; unmodified_outside_range s s' a m; m \<le> n \<rbrakk>
   \<Longrightarrow> unmodified_outside_range s s' a n"
  apply (unfold unmodified_outside_range_def)
  apply clarsimp
  apply (subgoal_tac "array_not_at_mem_end a m \<and> a +\<^sub>p int m \<le> p", simp)
  apply (simp add: array_not_at_mem_end_def)
  apply (rule_tac y = "a +\<^sub>p int n" in order_trans)
   apply (simp add: array_loc_mono array_not_at_mem_end_def)
  apply assumption
  done

lemma unmodified_outside_subrange2:
  "\<lbrakk> array_loc_valid a n;
     unmodified_outside_range s s' (a +\<^sub>p int m) (n - m); m \<le> n \<rbrakk>
   \<Longrightarrow> unmodified_outside_range s s' a n"
  apply (case_tac "m = n", simp)
   apply (rule_tac p = "a +\<^sub>p int n" in unmodified_outside_empty_range2, assumption+)
  apply (unfold unmodified_outside_range_def)
  apply clarsimp
  apply (simp add: ptr_add_assoc[symmetric])
  apply (rule conjI)
   apply clarsimp
   apply (frule_tac z = "a +\<^sub>p int m" in order_less_le_trans)
    apply (simp add: array_no_wrap)
   apply simp
  apply (auto simp: array_not_at_mem_end_def unat_linear_over_array_loc2)
  done

(* Sanity in terms of arrays not changing *)

lemma is_still_array:
  "\<lbrakk> unmodified_outside_range s s' a n;
     (array_not_at_mem_end a' n' \<and> a' +\<^sub>p int n' \<le> a) \<or>
     (array_not_at_mem_end a n \<and> a +\<^sub>p int n \<le> a') \<or> n = 0;
     is_array s a' n' \<rbrakk> \<Longrightarrow> is_array s' a' n'"
  apply (clarsimp simp: unmodified_outside_range_def is_array_def
                        array_all_elems_valid)
  apply (drule_tac x = "m" in spec, clarsimp)
  apply (drule_tac R = "is_valid_w32 s' (a' +\<^sub>p int m)" in disjE, simp_all)
   apply clarsimp
   apply (subgoal_tac "a' +\<^sub>p int m < a", simp)
   apply (rule_tac y = "a' +\<^sub>p int n'" in less_le_trans)
    apply (rule array_loc_strict_mono, assumption+)
  apply (drule_tac R = "is_valid_w32 s' (a' +\<^sub>p int m)" in disjE, simp_all)
   apply clarsimp
   apply (subgoal_tac "a +\<^sub>p int n \<le> a' +\<^sub>p int m", simp)
   apply (erule_tac y = "a'" in order_trans)
   apply (rule_tac n = "n'" in array_no_wrap, assumption+)
  apply (case_tac "a' +\<^sub>p int m < a", simp)
  apply (simp add: empty_array_not_at_mem_end)
  done

lemma the_same_array:
  "\<lbrakk> unmodified_outside_range s s' a n; array_loc_valid a' n';
     (array_not_at_mem_end a' n' \<and> a' +\<^sub>p int n' \<le> a) \<or>
     (array_not_at_mem_end a n \<and> a' \<ge> a +\<^sub>p int n) \<or> n = 0 \<rbrakk> \<Longrightarrow>
   the_array s' a' n' = the_array s a' n'"
  apply (clarsimp simp: unmodified_outside_range_def the_arrays_equal)
  apply (drule_tac R = "heap_w32 s' (a' +\<^sub>p int m) = heap_w32 s (a' +\<^sub>p int m)"
                in disjE)
    apply simp_all
   apply clarsimp
   apply (subgoal_tac "a' +\<^sub>p int m < a", simp)
   apply (rule_tac y = "a' +\<^sub>p int n'" in less_le_trans)
    apply (rule array_loc_strict_mono, assumption+)
  apply (drule_tac R = "heap_w32 s' (a' +\<^sub>p int m) = heap_w32 s (a' +\<^sub>p int m)"
                in disjE)
    apply simp_all
   apply (subgoal_tac "a +\<^sub>p int n \<le> a' +\<^sub>p int m", simp)
   apply clarsimp
   apply (erule_tac y = "a'" in order_trans)
   apply (rule_tac n = "n'" in array_no_wrap, assumption+)
  apply (case_tac "a' +\<^sub>p int m < a", simp)
  apply (simp add: empty_array_not_at_mem_end)
  done

(*
 * Proof of partition function!
 *)

definition partitioned
where
  "partitioned s a n pivot_idx \<equiv>
   (\<forall>i. i < n \<longrightarrow> (i < pivot_idx \<longleftrightarrow> heap_w32 s (a +\<^sub>p int i) < heap_w32 s (a +\<^sub>p int pivot_idx)))"

lemma partition_correct:
  "\<forall>s0. \<lbrace> \<lambda>s. is_array s a (unat n) \<and> n > 0 \<and> s = s0 \<rbrace>
        partition' a n
        \<lbrace> \<lambda>r s. is_array s a (unat n) \<and>
                mset (the_array s a (unat n)) = mset (the_array s0 a (unat n)) \<and>
                r < n \<and> partitioned s a (unat n) (unat r) \<and>
                unmodified_outside_range s0 s a (unat n) \<rbrace>!"
  apply clarsimp
  apply (unfold partition'_def)
  apply (subst whileLoop_add_inv [where
         I = "\<lambda>(i, pivot_idx) s. is_array s a (unat n) \<and>
                                 mset (the_array s a (unat n)) =
                                 mset (the_array s0 a (unat n)) \<and>
                                 i \<le> n \<and> pivot_idx < i \<and>
                                 partitioned s a (unat i) (unat pivot_idx) \<and>
                                 unmodified_outside_range s0 s a (unat n)" and
         M = "\<lambda>((i, pivot_idx), s). n - i"])

  apply wp
     apply clarsimp
     apply (intro conjI impI)
                 defer
                apply unat_arith
                apply unat_arith
               defer defer
              apply (erule_tac n = "n" in array_valid_elem2, unat_arith)
              apply (rule_tac n = "n" in array_valid_elem2, assumption+)
             apply (erule_tac n = "n" in array_valid_elem2, unat_arith)
            apply unat_arith
           apply unat_arith
          apply (unfold partitioned_def)
          apply clarsimp
          apply (case_tac "i = unat aa")
           apply (metis less_or_eq_imp_le not_less uint_nat word_less_nat_alt)
          apply (subgoal_tac "i < unat aa", simp)
          apply unat_arith
         apply (rule_tac n = "n" in array_valid_elem2, assumption+)
        apply (erule_tac n = "n" in array_valid_elem2, unat_arith)
       apply wp
       apply clarsimp
       apply (intro conjI impI)
        apply unat_arith
       apply unat_arith
      apply clarsimp
     apply clarsimp
     apply unat_arith
    defer
    apply (clarsimp simp: is_array_def array_loc_valid_def)
    apply (intro conjI impI allI)
              apply simp
             apply (simp add: CTypesDefs.ptr_add_def)
            apply (simp add: CTypesDefs.ptr_add_def )
           apply (simp add: CTypesDefs.ptr_add_def)
          apply unat_arith
         apply (simp add: CTypesDefs.ptr_add_def)
        apply (simp only: uint_nat)
        apply (subst (asm) (2) ptr_offsets_eq)
          apply (simp, unat_arith)
         apply (simp, unat_arith)
        apply clarsimp
        apply unat_arith
       apply (simp only: uint_nat)
       apply (subst (asm) ptr_offsets_eq, simp, unat_arith, simp, unat_arith)+
       apply simp
      apply (simp only: uint_nat)
      apply (subst (asm) (3) ptr_offsets_eq)
        apply (simp, unat_arith)
       apply (simp, unat_arith)
      apply (subst (asm) ptr_offsets_eq, simp, unat_arith, simp, unat_arith)+
      apply clarsimp
      apply (drule_tac x = "unat (b + 1)" in spec)
      apply (subgoal_tac "unat (b + 1) < unat aa")
       apply clarsimp
       apply (subgoal_tac "\<not> unat (b + 1) < unat b")
        apply (subgoal_tac "\<not> unat aa < unat (b + 1)", simp)
        apply simp
       apply unat_arith
      subgoal by unat_arith
     apply (simp only: uint_nat)
     apply (subst (asm) (3) ptr_offsets_eq)
       apply (simp, unat_arith)
      apply (simp, unat_arith)
     apply simp
    apply (simp only: uint_nat)
    apply (subst (asm) ptr_offsets_eq, simp, unat_arith, simp, unat_arith)+
    apply clarsimp
    apply (drule_tac x = "i" in spec)
    apply (subgoal_tac "i < unat aa")
     apply clarsimp
     apply (subgoal_tac "(i < unat b) = (i < unat (b + 1))", simp)
     apply unat_arith
    apply unat_arith
   defer
   apply (simp add: o_def)
   apply (subst uint_nat, subst the_updated_array, assumption, unat_arith)+
   apply (clarsimp simp: is_array_def array_loc_valid_def)
   apply (intro conjI impI)
    apply (subst (asm) ptr_offsets_eq2, simp, unat_arith, simp, unat_arith)
    apply simp
   apply (simp only: uint_nat)
   apply (subst the_array_elem[symmetric, where n = "unat n"], unat_arith)+
   apply (subst multiset_of_cycle)
       apply (simp, unat_arith)
      apply (simp, unat_arith)
     apply (simp, unat_arith)
    apply simp+
  apply (clarsimp simp: is_array_def unmodified_outside_range_def)
  apply (intro conjI impI)
           apply (subst (asm) ptr_offsets_eq2)
             apply simp+
         apply (subgoal_tac "a \<le> a +\<^sub>p uint b", simp)
         apply (rule_tac n = "n" in array_no_wrap2, simp, unat_arith)
        apply clarsimp
        apply (subgoal_tac "a +\<^sub>p uint b < a +\<^sub>p uint n", simp)
        apply (erule_tac n = "n" in array_loc_strict_mono2, unat_arith)
       apply (subgoal_tac "a \<le> a +\<^sub>p uint (b + 1)", simp)
       apply (erule_tac n = "n" in array_no_wrap2, unat_arith)
      apply clarsimp
      apply (subgoal_tac "a +\<^sub>p uint aa < a +\<^sub>p uint n", simp)
      apply (rule_tac n = "n" in array_loc_strict_mono2, assumption+)
     apply (subgoal_tac "a \<le> a +\<^sub>p uint aa", simp)
     apply (rule_tac n = "n" in array_no_wrap2, assumption+)
    apply clarsimp
    apply (subgoal_tac "a +\<^sub>p uint aa < a +\<^sub>p uint n", simp)
    apply (rule_tac n = "n" in array_loc_strict_mono2, assumption+)
   apply (subgoal_tac "a \<le> a +\<^sub>p uint (b + 1)", simp)
   apply (erule_tac n = "n" in array_no_wrap2, unat_arith)
  apply clarsimp
  apply (subgoal_tac "a +\<^sub>p uint (b + 1) < a +\<^sub>p uint n", simp)
  apply (erule_tac n = "n" in array_loc_strict_mono2, unat_arith)
  done

(* Induction rule used for quicksort proof *)
lemma word_strong_induct[case_names Ind]:
  "(\<And>n. (\<forall>k < n. P k) \<Longrightarrow> P n) \<Longrightarrow> P (m::addr)"
  by (rule less_induct, blast)

(* Some extra Hoare logic rules *)

lemma when_True:
  "P \<Longrightarrow> when P A = A"
  by monad_eq

lemma when_False:
  "\<not> P \<Longrightarrow> when P A = return ()"
  by monad_eq

lemma hoare_save_pre_state:
  "(\<And>s'. P s' \<Longrightarrow> \<lbrace>\<lambda>s. P s \<and> s = s' \<rbrace> f \<lbrace>Q\<rbrace>) \<Longrightarrow> \<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>"
  by (clarsimp simp: valid_def)

lemma validNF_save_pre_state:
  "(\<And>s'. P s' \<Longrightarrow> \<lbrace>\<lambda>s. P s \<and> s = s' \<rbrace> f \<lbrace>Q\<rbrace>!) \<Longrightarrow> \<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>!"
  by (auto simp: validNF_def valid_def no_fail_def)

lemma is_array_after_changing_left:
  "\<lbrakk> m \<le> n; is_array s1 a n; is_array s2 a m;
     unmodified_outside_range s1 s2 a m \<rbrakk>
   \<Longrightarrow> is_array s2 a n"
  apply (case_tac "m = n", simp)
  apply (frule_tac m = "m" in subarray_not_at_mem_end2, simp)
  apply (erule_tac m = "m" in concat_is_array)
    apply (auto simp: is_still_array subarray2_is_array)
  done

lemma is_array_after_changing_right:
  "\<lbrakk> m \<le> n; is_array s1 a n; is_array s2 (a +\<^sub>p int m) (n - m);
     unmodified_outside_range s1 s2 (a +\<^sub>p int m) (n - m) \<rbrakk>
   \<Longrightarrow> is_array s2 a n"
  apply (case_tac "m = n")
   apply (simp add: is_array_def array_all_elems_valid unmodified_outside_empty_range)
  apply (frule_tac m = "m" in subarray_not_at_mem_end2, simp)
  apply (rule_tac m = "m" in concat_is_array)
     apply (rule_tac s = "s1" and a = "a +\<^sub>p int m" and n = "n - m" in is_still_array)
       apply simp+
     apply (rule_tac n = "n" in subarray1_is_array)
      apply simp+
  done

(*
 * There is an issue later on with using "subst" substitutions on expressions
 * involving certain variables, so we have to use "rule_tac" with rules like
 * the following.
 *)
lemma multiset_of_concat_array:
  "\<lbrakk> m \<le> n; mset (the_array s a m) = mset (the_array s' a m);
     mset (the_array s (a +\<^sub>p int m) (n - m)) = mset (the_array s' (a +\<^sub>p int m) (n - m)) \<rbrakk>
   \<Longrightarrow> mset (the_array s a n) = mset (the_array s' a n)"
  by (simp add: the_array_concat2)

lemma multiset_same_after_shuffling_left:
  "\<lbrakk> m \<le> n; array_loc_valid a n;
     mset (the_array s1 a m) = mset (the_array s2 a m);
     unmodified_outside_range s1 s2 a m \<rbrakk>
   \<Longrightarrow> mset (the_array s1 a n) = mset (the_array s2 a n)"
  apply (case_tac "m = n", simp)
  apply (frule_tac m = "m" in subarray_not_at_mem_end1, simp)
  apply (rule_tac m = "m" in multiset_of_concat_array, assumption+)
  apply (subgoal_tac "the_array s2 (a +\<^sub>p int m) (n - m) =
                      the_array s1 (a +\<^sub>p int m) (n - m)", simp)
  apply (erule_tac a = "a" and n = "m" in the_same_array)
   apply (clarsimp simp: is_array_def array_loc_valid_def
                         unat_linear_over_array_loc2, unat_arith)
  apply simp
  done

lemma multiset_same_after_shuffling_right:
  "\<lbrakk> m \<le> n; array_loc_valid a n;
     mset (the_array s1 (a +\<^sub>p int m) (n - m)) =
     mset (the_array s2 (a +\<^sub>p int m) (n - m));
     unmodified_outside_range s1 s2 (a +\<^sub>p int m) (n - m) \<rbrakk>
   \<Longrightarrow> mset (the_array s1 a n) = mset (the_array s2 a n)"
  apply (rule_tac m = "m" in multiset_of_concat_array)
    apply assumption
   apply (subgoal_tac "the_array s2 a m = the_array s1 a m", simp)
   apply (case_tac "m = n")
    apply (simp add: unmodified_outside_empty_range the_arrays_equal)
   apply (frule_tac m = "m" in subarray_not_at_mem_end1, simp)
   apply (rule_tac a = "a +\<^sub>p int m" and n = "n - m" in the_same_array)
    apply (auto simp: array_not_at_mem_end_def array_loc_valid_def)
  done

(* Preparing for lemmas about partitioned-ness being preserved *)

lemma old_array_elem:
  "\<lbrakk> mset (the_array s a n) =
     mset (the_array s0 a n); i < n \<rbrakk>
   \<Longrightarrow> \<exists>j < n. heap_w32 s (a +\<^sub>p int i) = heap_w32 s0 (a +\<^sub>p int j)"
  apply (drule mset_eq_setD)
  apply (subgoal_tac "heap_w32 s (a +\<^sub>p int i) \<in> set (the_array s a n)")
   apply simp
   apply (frule nth_the_index)
   apply (rule_tac x = "the_index (the_array s0 a n) (heap_w32 s (a +\<^sub>p int i))"
          in exI)
   apply (rule conjI)
    apply (subst (4) the_array_length[symmetric, where s = "s0" and a = "a"])
    apply (erule the_index_bounded)
   apply (subst (asm) the_array_elem)
    apply (subst (4) the_array_length[symmetric, where s = "s0" and a = "a"])
    apply (erule the_index_bounded)
   apply simp
  apply (subst the_array_elem[symmetric, where n = "n"], assumption)
  apply (rule nth_mem, simp)
  done

lemma old_array_elem2:
  "\<lbrakk> mset (the_array s (a +\<^sub>p int k) (n - k)) =
     mset (the_array s0 (a +\<^sub>p int k) (n - k)); k + i < n \<rbrakk>
   \<Longrightarrow> \<exists>j < n. j \<ge> k \<and> heap_w32 s (a +\<^sub>p int (k + i)) = heap_w32 s0 (a +\<^sub>p int j)"
  apply (drule_tac i = "i" in old_array_elem, simp)
  apply clarsimp
  apply (rule_tac x = "k + j" in exI)
  apply simp
  done

lemma partitioned_after_shuffling_left:
  "\<lbrakk> is_array s0 a (unat n); pivot_idx < n;
     partitioned s0 a (unat n) (unat pivot_idx);
     mset (the_array s a (unat pivot_idx)) =
     mset (the_array s0 a (unat pivot_idx));
     unmodified_outside_range s0 s a (unat pivot_idx) \<rbrakk>
   \<Longrightarrow> partitioned s a (unat n) (unat pivot_idx)"
  apply (clarsimp simp: partitioned_def unmodified_outside_range_def)
  apply (subgoal_tac "heap_w32 s (a +\<^sub>p uint pivot_idx) =
                      heap_w32 s0 (a +\<^sub>p uint pivot_idx)", simp)
   apply (subgoal_tac "array_not_at_mem_end a (unat pivot_idx)")
    apply (case_tac "i < unat pivot_idx", clarsimp)
     apply (subgoal_tac "\<exists>j. (j < unat pivot_idx \<and>
                              heap_w32 s (a +\<^sub>p int i) = heap_w32 s0 (a +\<^sub>p int j))")
      apply clarsimp
      apply (drule_tac x = "j" in spec)
      apply (subgoal_tac "j < unat n")
       apply (clarsimp)
      apply unat_arith
     apply (erule old_array_elem, simp)
    apply (drule_tac x = "a +\<^sub>p int i" in spec)
    apply (subgoal_tac "a +\<^sub>p int (unat pivot_idx) \<le> a +\<^sub>p int i")
     apply simp
    apply (rule array_loc_mono)
     apply (rule_tac s = "s0" and n = "unat n" in subarray_not_at_mem_end2,
            assumption+)
    apply unat_arith
   apply (erule_tac s = "s0" and n = "unat n" in subarray_not_at_mem_end2,
          unat_arith)
  apply (drule_tac x = "a +\<^sub>p uint pivot_idx" in spec)
  apply (subgoal_tac "array_not_at_mem_end a (unat pivot_idx)")
   apply (simp)
  apply (erule_tac s = "s0" and n = "unat n" in subarray_not_at_mem_end2,
         unat_arith)
  done

lemma partitioned_after_shuffling_right:
  "\<lbrakk> is_array s0 a (unat n); pivot_idx < n;
     partitioned s0 a (unat n) (unat pivot_idx);
     mset (the_array s (a +\<^sub>p int (Suc (unat pivot_idx)))
                       (unat n - Suc (unat pivot_idx))) =
     mset (the_array s0 (a +\<^sub>p int (Suc (unat pivot_idx)))
                        (unat n - Suc (unat pivot_idx)));
     unmodified_outside_range s0 s (a +\<^sub>p int (Suc (unat pivot_idx)))
                                   (unat n - unat pivot_idx - 1) \<rbrakk>
   \<Longrightarrow> partitioned s a (unat n) (unat pivot_idx)"
  apply (unfold partitioned_def)
  apply (case_tac "unat n = Suc (unat pivot_idx)")
   apply (simp add: unmodified_outside_empty_range)
  apply (subgoal_tac "Suc (unat pivot_idx) < unat n")
   prefer 2
   apply unat_arith
  apply (subgoal_tac "array_not_at_mem_end a (Suc (unat pivot_idx))")
   prefer 2
   apply (rule_tac s = "s0" and n = "unat n" in subarray_not_at_mem_end2)
    apply assumption+
  apply (unfold unmodified_outside_range_def, clarify)
  apply (frule_tac x = "a +\<^sub>p int (unat pivot_idx)" in spec)
  apply (subgoal_tac "a +\<^sub>p int (unat pivot_idx) < a +\<^sub>p int (Suc (unat pivot_idx))")
   prefer 2
   apply (erule array_loc_strict_mono, simp)
  apply (case_tac "i \<le> unat pivot_idx")
   apply (frule_tac x = "a +\<^sub>p int i" in spec)
   apply (subgoal_tac "a +\<^sub>p int i < a +\<^sub>p int (Suc (unat pivot_idx))")
    apply simp
   apply (erule array_loc_strict_mono, simp)
  apply (subgoal_tac "\<not> i < unat pivot_idx")
   prefer 2
   apply unat_arith
  apply (drule_tac i = "i - Suc (unat pivot_idx)" in old_array_elem2)
   apply unat_arith
  apply clarify
  apply (frule_tac x = "j" in spec)
  apply (subgoal_tac "\<not> j < unat pivot_idx")
   apply (subgoal_tac "a +\<^sub>p 1 +\<^sub>p int (unat pivot_idx) +\<^sub>p
                       int (i - Suc (unat pivot_idx)) = a +\<^sub>p int i")
    apply simp
   apply (subst of_nat_diff, unat_arith)
   apply (subst ptr_add_assoc[symmetric])+
   apply simp
  apply unat_arith
  done

(*
 * The basic idea of quicksort: if the array is partitioned and
 * both halves are sorted then the array is sorted.
 *)

lemma partitioned_array_sorted:
  "\<lbrakk> m < n; sorted (the_array s a m);
     sorted (the_array s (a +\<^sub>p int (Suc m)) (n - Suc m));
     partitioned s a n m \<rbrakk> \<Longrightarrow>
   sorted (the_array s a n)"
  apply (subst the_array_concat2[where m = "m"], simp)
  apply (subst sorted_append, simp)
  apply (rule conjI)
   apply (subst the_array_concat2[where m = "1"], simp+)
   apply (simp add: partitioned_def)
   apply (subst all_set_conv_all_nth)
   apply (clarsimp simp: the_array_elem)
   apply (drule_tac x = "m + i + 1" in spec)
   apply (subgoal_tac "m + i + 1 < n")
    apply clarsimp
    apply unat_arith
   apply unat_arith
  apply (subst all_set_conv_all_nth)
  apply (clarsimp simp: the_array_elem partitioned_def)
  apply (frule_tac x = "i" in spec)
  apply simp
  apply (subgoal_tac "x \<ge> heap_w32 s (a +\<^sub>p int m)")
   apply simp
  apply (frule nth_the_index)
  apply (subst (asm) the_array_elem)
  apply (frule the_index_bounded, simp)
  apply (subgoal_tac "m + the_index (the_array s (a +\<^sub>p int m) (n - m)) x < n")
   apply (frule_tac x = "m + the_index (the_array s (a +\<^sub>p int m) (n - m)) x"
          in spec)
   apply simp
  apply (subgoal_tac "the_index (the_array s (a +\<^sub>p int m) (n - m)) x < n - m")
   apply simp
  apply (frule the_index_bounded, simp)
  done

(* Some more trivial lemmas *)

lemma array_index_Suc:
  "a +\<^sub>p uint m +\<^sub>p 1 = a +\<^sub>p int (Suc (unat m))"
  by simp

lemma array_loc_le_Suc:
  "array_not_at_mem_end a (Suc (unat m)) \<Longrightarrow> a +\<^sub>p uint m \<le> a +\<^sub>p 1 +\<^sub>p uint m"
  apply (subst ptr_add_commute)
  apply (subst array_index_Suc)
  apply (simp only: uint_nat)
  apply (rule array_loc_mono, simp+)
  done

lemma unat_sub_sub1 [simp]:
  "(m::addr) < n \<Longrightarrow> unat (n - m - 1) = unat n - unat m - 1"
  by unat_arith

lemma unat_inc:
  "(m::addr) < n \<Longrightarrow> unat (m + 1) = Suc (unat m)"
  by unat_arith

lemma old_quicksort_correct:
  shows "\<lbrace> \<lambda>s. is_array s a (unat n) \<and> s = s0 \<and> unat n < m \<rbrace>
         quicksort' m a n
         \<lbrace> \<lambda>r s. is_array s a (unat n) \<and>
                 mset (the_array s a (unat n)) =
                 mset (the_array s0 a (unat n)) \<and>
                 sorted (the_array s a (unat n)) \<and>
                 unmodified_outside_range s0 s a (unat n) \<rbrace>!"
   ( is "\<lbrace> ?pre a n s0 m \<rbrace> quicksort' m a n \<lbrace> ?post a n s0 \<rbrace>!" )
  oops

(* FIXME: move *)
(* This puts our {partition,quicksort}_correct lemmas into a form that
   wp can use. *)
lemma make_schematic_post:
  "(\<forall>s0. \<lbrace> \<lambda>s. P s0 s \<rbrace> f \<lbrace> \<lambda>rv s. Q s0 rv s \<rbrace>!) \<Longrightarrow>
   \<lbrace> \<lambda>s. \<exists>s0. P s0 s \<and> (\<forall>rv s'. Q s0 rv s' \<longrightarrow> Q' rv s') \<rbrace> f \<lbrace> Q' \<rbrace>!"
  by (auto simp add: valid_def validNF_def no_fail_def split: prod.splits)

(*
 * Proof of recursive quicksort function!
 *)

lemma quicksort_correct:
  shows "\<forall>a m s0. \<lbrace> \<lambda>s. is_array s a (unat n) \<and> s = s0 \<and> unat n < m \<rbrace>
         quicksort' m a n
         \<lbrace> \<lambda>r s. is_array s a (unat n) \<and>
                 mset (the_array s a (unat n)) =
                 mset (the_array s0 a (unat n)) \<and>
                 sorted (the_array s a (unat n)) \<and>
                 unmodified_outside_range s0 s a (unat n) \<rbrace>!"
   ( is "\<forall>a m s0. \<lbrace> ?pre a n s0 m \<rbrace> quicksort' m a n \<lbrace> ?post a n s0 \<rbrace>!" )

proof (induct n rule: word_strong_induct)
  fix a m s0

next
  fix a n m s0
  assume quicksort_ind_hyp:
    "\<forall>k < n. \<forall>a m s0. \<lbrace> ?pre a k s0 m \<rbrace> quicksort' m a k \<lbrace> ?post a k s0 \<rbrace>!"

  have quicksort_ind_hyp':
    "\<And>k a m. \<forall>s0. \<lbrace> \<lambda>s. ?pre a k s0 m s \<and> k < n \<rbrace> quicksort' m a k \<lbrace> ?post a k s0 \<rbrace>!"
    apply clarsimp
    apply (rule validNF_assume_pre)
    apply (rule validNF_chain)
      apply (rule quicksort_ind_hyp [rule_format])
      apply auto
    done

  show "\<forall>a m s0. \<lbrace> ?pre a n s0 m \<rbrace> quicksort' m a n \<lbrace> ?post a n s0 \<rbrace>!"
    apply clarsimp
    apply (subst quicksort'.simps)
    apply (unfold when_def)
    apply (wp quicksort_ind_hyp' [THEN make_schematic_post]
              partition_correct  [THEN make_schematic_post])
    apply clarsimp
    apply safe
              apply unat_arith
             apply (erule subarray1_is_array, unat_arith)
            apply unat_arith
           apply (case_tac "unat n = Suc (unat rv)", simp add: empty_array_is_array)
           (* Add a few useful facts into the assumption set *)
           apply (frule_tac s = "s'" and m = "unat rv" in subarray_not_at_mem_end2, unat_arith)
           apply (frule_tac s = "s'" and m = "Suc (unat rv)" in subarray_not_at_mem_end2, unat_arith)
           apply (frule_tac s = "s'" and m = "unat rv" in subarray1_is_array, unat_arith)
           apply (frule_tac s = "s'" and m = "unat rv" in subarray2_is_array, unat_arith, simp)
           apply (frule_tac s = "s'" and m = "Suc (unat rv)" in subarray1_is_array, unat_arith)
           apply (frule_tac s = "s'" and m = "Suc (unat rv)" in subarray2_is_array,
                  unat_arith, simp)
           (* ...and back to the proof *)
           apply (erule is_still_array)
            apply (rule disjI2, rule disjI1)
            apply (simp add: array_loc_le_Suc)
           apply simp
          apply unat_arith
         apply unat_arith
        apply (rule_tac ?s1.0 = "s'a" and m = "Suc (unat rv)"
                     in is_array_after_changing_right)
           apply unat_arith
          apply (rule_tac ?s1.0 = "s'" and m = "unat rv"
                       in is_array_after_changing_left)
             apply unat_arith
            apply assumption+
         apply (simp)+
       apply (subgoal_tac "mset (the_array s'b a (unat n)) =
                           mset (the_array s'a a (unat n))")
        apply (subgoal_tac "mset (the_array s'a a (unat n)) =
                            mset (the_array s' a (unat n))", simp)
        apply (rule_tac m = "unat rv" in multiset_same_after_shuffling_left)
           apply unat_arith
          apply (simp add: is_array_def)
         apply assumption
        apply (simp add: unmodified_outside_range_def)
       apply (rule_tac m = "Suc (unat rv)" in multiset_same_after_shuffling_right)
          apply unat_arith
         apply (simp add: is_array_def)
        apply simp
       apply (simp add: unmodified_outside_range_def)
      apply (rule_tac m = "unat rv" in partitioned_array_sorted)
         apply unat_arith
        apply (subgoal_tac "the_array s'b a (unat rv) = the_array s'a a (unat rv)", simp)
        apply (case_tac "Suc (unat rv) = unat n")
         apply (simp add: unmodified_outside_empty_range the_arrays_equal)
        apply (erule_tac a = "a +\<^sub>p 1 +\<^sub>p uint rv" and n = "unat n - Suc (unat rv)"
                     in the_same_array)
         apply (simp add: is_array_def)
        apply (rule disjI1, rule conjI)
         apply (erule subarray_not_at_mem_end2, unat_arith)
        apply simp
        apply (rule array_loc_le_Suc)
        apply (erule subarray_not_at_mem_end2, unat_arith)
       apply simp
      apply (rule_tac ?s0.0 = "s'a" in partitioned_after_shuffling_right)
          apply (rule_tac ?s1.0 = "s'" and m = "unat rv" in is_array_after_changing_left)
             apply unat_arith
            apply assumption+
        apply (rule_tac ?s0.0 = "s'" in partitioned_after_shuffling_left, assumption+)
       apply simp+
     apply (erule unmodified_outside_range_trans)
     apply (rule_tac ?s2.0 = "s'a" in unmodified_outside_range_trans)
      apply (rule_tac m = "unat rv" in unmodified_outside_subrange1)
        apply (simp add: is_array_def)
       apply assumption
      apply unat_arith
     apply (rule_tac m = "Suc (unat rv)" in unmodified_outside_subrange2)
       apply (simp add: is_array_def)
      apply simp
     apply unat_arith
    apply (case_tac "n = 1", simp)
    apply (subgoal_tac "n = 0", simp, unat_arith)
    done

qed

end

end


(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

theory longlong
imports "CParser.CTranslation"
begin

external_file "longlong.c"
install_C_file "longlong.c"

ML \<open>NameGeneration.return_var_name (Absyn.Signed Absyn.LongLong)\<close>

context longlong
begin

thm f_body_def
thm shifts1_body_def
thm shifts2_body_def

lemma "(ucast :: 16 word \<Rightarrow> 8 word) 32768 = 0"
apply simp
done

lemma "(scast :: 16 word \<Rightarrow> 8 word) 32768 = 0"
by simp

lemma "(scast :: 16 word \<Rightarrow> 8 word) 65535 = 255"
by simp

lemma "(ucast :: 16 word \<Rightarrow> 8 word) 65535 = 255"
by simp

lemma "(ucast :: 16 word \<Rightarrow> 8 word) 32767 = 255" by simp
lemma "(scast :: 16 word \<Rightarrow> 8 word) 32767 = 255" by simp

lemma "(scast :: 8 word \<Rightarrow> 16 word) 255 = 65535" by simp
lemma "(ucast :: 8 word \<Rightarrow> 16 word) 255 = 255" by simp

lemma g_result:
  "\<Gamma> \<turnstile> \<lbrace> True \<rbrace> \<acute>ret__int :== CALL callg() \<lbrace> \<acute>ret__int = 0 \<rbrace>"
apply vcg
apply (simp add: max_word_def)
done

thm literals_body_def

lemma literals_result:
  "\<Gamma> \<turnstile> \<lbrace> True \<rbrace> \<acute>ret__int :== CALL literals() \<lbrace> \<acute>ret__int = 31 \<rbrace>"
apply vcg
apply simp
done

end (* context *)

end (* theory *)


(*
(C) Copyright Andreas Viktor Hess, DTU, 2018-2020
(C) Copyright Sebastian A. Mödersheim, DTU, 2018-2020
(C) Copyright Achim D. Brucker, University of Sheffield, 2018-2020

All Rights Reserved.

Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:

- Redistributions of source code must retain the above copyright
  notice, this list of conditions and the following disclaimer.

- Redistributions in binary form must reproduce the above copyright
  notice, this list of conditions and the following disclaimer in the
  documentation and/or other materials provided with the distribution.

- Neither the name of the copyright holder nor the names of its
  contributors may be used to endorse or promote products
  derived from this software without specific prior written
  permission.

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*)

(*  Title:      Labeled_Strands.thy
    Author:     Andreas Viktor Hess, DTU
    Author:     Sebastian A. Mödersheim, DTU
    Author:     Achim D. Brucker, The University of Sheffield
*)

section \<open>Labeled Strands\<close>
theory Labeled_Strands
imports Strands_and_Constraints
begin

subsection \<open>Definitions: Labeled Strands and Constraints\<close>
datatype 'l strand_label =
  LabelN (the_LabelN: "'l") ("ln _")
| LabelS ("\<star>")

text \<open>Labeled strands are strands whose steps are equipped with labels\<close>
type_synonym ('a,'b,'c) labeled_strand_step = "'c strand_label \<times> ('a,'b) strand_step"
type_synonym ('a,'b,'c) labeled_strand = "('a,'b,'c) labeled_strand_step list"

abbreviation is_LabelN where "is_LabelN n x \<equiv> fst x = ln n"
abbreviation is_LabelS where "is_LabelS x \<equiv> fst x = \<star>"

definition unlabel where "unlabel S \<equiv> map snd S"
definition proj where "proj n S \<equiv> filter (\<lambda>s. is_LabelN n s \<or> is_LabelS s) S"
abbreviation proj_unl where "proj_unl n S \<equiv> unlabel (proj n S)"

abbreviation wfrestrictedvars\<^sub>l\<^sub>s\<^sub>t where "wfrestrictedvars\<^sub>l\<^sub>s\<^sub>t S \<equiv> wfrestrictedvars\<^sub>s\<^sub>t (unlabel S)"

abbreviation subst_apply_labeled_strand_step (infix "\<cdot>\<^sub>l\<^sub>s\<^sub>t\<^sub>p" 51) where
  "x \<cdot>\<^sub>l\<^sub>s\<^sub>t\<^sub>p \<theta> \<equiv> (case x of (l, s) \<Rightarrow> (l, s \<cdot>\<^sub>s\<^sub>t\<^sub>p \<theta>))"

abbreviation subst_apply_labeled_strand (infix "\<cdot>\<^sub>l\<^sub>s\<^sub>t" 51) where
  "S \<cdot>\<^sub>l\<^sub>s\<^sub>t \<theta> \<equiv> map (\<lambda>x. x \<cdot>\<^sub>l\<^sub>s\<^sub>t\<^sub>p \<theta>) S"

abbreviation trms\<^sub>l\<^sub>s\<^sub>t where "trms\<^sub>l\<^sub>s\<^sub>t S \<equiv> trms\<^sub>s\<^sub>t (unlabel S)"
abbreviation trms_proj\<^sub>l\<^sub>s\<^sub>t where "trms_proj\<^sub>l\<^sub>s\<^sub>t n S \<equiv> trms\<^sub>s\<^sub>t (proj_unl n S)"

abbreviation vars\<^sub>l\<^sub>s\<^sub>t where "vars\<^sub>l\<^sub>s\<^sub>t S \<equiv> vars\<^sub>s\<^sub>t (unlabel S)"
abbreviation vars_proj\<^sub>l\<^sub>s\<^sub>t where "vars_proj\<^sub>l\<^sub>s\<^sub>t n S \<equiv> vars\<^sub>s\<^sub>t (proj_unl n S)"

abbreviation bvars\<^sub>l\<^sub>s\<^sub>t where "bvars\<^sub>l\<^sub>s\<^sub>t S \<equiv> bvars\<^sub>s\<^sub>t (unlabel S)"
abbreviation fv\<^sub>l\<^sub>s\<^sub>t where "fv\<^sub>l\<^sub>s\<^sub>t S \<equiv> fv\<^sub>s\<^sub>t (unlabel S)"

abbreviation wf\<^sub>l\<^sub>s\<^sub>t where "wf\<^sub>l\<^sub>s\<^sub>t V S \<equiv> wf\<^sub>s\<^sub>t V (unlabel S)"

subsection \<open>Lemmata: Projections\<close>
lemma is_LabelS_proj_iff_not_is_LabelN:
  "list_all is_LabelS (proj l A) \<longleftrightarrow> \<not>list_ex (is_LabelN l) A"
by (induct A) (auto simp add: proj_def)

lemma proj_subset_if_no_label:
  assumes "\<not>list_ex (is_LabelN l) A"
  shows "set (proj l A) \<subseteq> set (proj l' A)"
    and "set (proj_unl l A) \<subseteq> set (proj_unl l' A)"
using assms by (induct A) (auto simp add: unlabel_def proj_def)

lemma proj_in_setD:
  assumes a: "a \<in> set (proj l A)"
  obtains k b where "a = (k, b)" "k = (ln l) \<or> k = \<star>"
using that a unfolding proj_def by (cases a) auto

lemma proj_set_mono:
  assumes "set A \<subseteq> set B"
  shows "set (proj n A) \<subseteq> set (proj n B)"
    and "set (proj_unl n A) \<subseteq> set (proj_unl n B)"
using assms unfolding proj_def unlabel_def by auto

lemma unlabel_nil[simp]: "unlabel [] = []"
by (simp add: unlabel_def)

lemma unlabel_mono: "set A \<subseteq> set B \<Longrightarrow> set (unlabel A) \<subseteq> set (unlabel B)"
by (auto simp add: unlabel_def)

lemma unlabel_in: "(l,x) \<in> set A \<Longrightarrow> x \<in> set (unlabel A)"
unfolding unlabel_def by force

lemma unlabel_mem_has_label: "x \<in> set (unlabel A) \<Longrightarrow> \<exists>l. (l,x) \<in> set A"
unfolding unlabel_def by auto

lemma proj_nil[simp]: "proj n [] = []" "proj_unl n [] = []"
unfolding unlabel_def proj_def by auto

lemma singleton_lst_proj[simp]:
  "proj_unl l [(ln l, a)] = [a]"
  "l \<noteq> l' \<Longrightarrow> proj_unl l' [(ln l, a)] = []"
  "proj_unl l [(\<star>, a)] = [a]"
  "unlabel [(l'', a)] = [a]"
unfolding proj_def unlabel_def by simp_all

lemma unlabel_nil_only_if_nil[simp]: "unlabel A = [] \<Longrightarrow> A = []"
unfolding unlabel_def by auto

lemma unlabel_Cons[simp]:
  "unlabel ((l,a)#A) = a#unlabel A"
  "unlabel (b#A) = snd b#unlabel A"
unfolding unlabel_def by simp_all

lemma unlabel_append[simp]: "unlabel (A@B) = unlabel A@unlabel B"
unfolding unlabel_def by auto

lemma proj_Cons[simp]:
  "proj n ((ln n,a)#A) = (ln n,a)#proj n A"
  "proj n ((\<star>,a)#A) = (\<star>,a)#proj n A"
  "m \<noteq> n \<Longrightarrow> proj n ((ln m,a)#A) = proj n A"
  "l = (ln n) \<Longrightarrow> proj n ((l,a)#A) = (l,a)#proj n A"
  "l = \<star> \<Longrightarrow> proj n ((l,a)#A) = (l,a)#proj n A"
  "fst b \<noteq> \<star> \<Longrightarrow> fst b \<noteq> (ln n) \<Longrightarrow> proj n (b#A) = proj n A"
unfolding proj_def by auto

lemma proj_append[simp]:
  "proj l (A'@B') = proj l A'@proj l B'"
  "proj_unl l (A@B) = proj_unl l A@proj_unl l B"
unfolding proj_def unlabel_def by auto

lemma proj_unl_cons[simp]:
  "proj_unl l ((ln l, a)#A) = a#proj_unl l A"
  "l \<noteq> l' \<Longrightarrow> proj_unl l' ((ln l, a)#A) = proj_unl l' A"
  "proj_unl l ((\<star>, a)#A) = a#proj_unl l A"
unfolding proj_def unlabel_def by simp_all

lemma trms_unlabel_proj[simp]:
  "trms\<^sub>s\<^sub>t\<^sub>p (snd (ln l, x)) \<subseteq> trms_proj\<^sub>l\<^sub>s\<^sub>t l [(ln l, x)]"
by auto

lemma trms_unlabel_star[simp]:
  "trms\<^sub>s\<^sub>t\<^sub>p (snd (\<star>, x)) \<subseteq> trms_proj\<^sub>l\<^sub>s\<^sub>t l [(\<star>, x)]"
by auto

lemma trms\<^sub>l\<^sub>s\<^sub>t_union[simp]: "trms\<^sub>l\<^sub>s\<^sub>t A = (\<Union>l. trms_proj\<^sub>l\<^sub>s\<^sub>t l A)"
proof (induction A)
  case (Cons a A)
  obtain l s where ls: "a = (l,s)" by moura
  have "trms\<^sub>l\<^sub>s\<^sub>t [a] = (\<Union>l. trms_proj\<^sub>l\<^sub>s\<^sub>t l [a])"
  proof -
    have *: "trms\<^sub>l\<^sub>s\<^sub>t [a] = trms\<^sub>s\<^sub>t\<^sub>p s" using ls by simp
    show ?thesis
    proof (cases l)
      case (LabelN n)
      hence "trms_proj\<^sub>l\<^sub>s\<^sub>t n [a] = trms\<^sub>s\<^sub>t\<^sub>p s" using ls by simp
      moreover have "\<forall>m. n \<noteq> m \<longrightarrow> trms_proj\<^sub>l\<^sub>s\<^sub>t m [a] = {}" using ls LabelN by auto
      ultimately show ?thesis using * ls by fastforce
    next
      case LabelS
      hence "\<forall>l. trms_proj\<^sub>l\<^sub>s\<^sub>t l [a] = trms\<^sub>s\<^sub>t\<^sub>p s" using ls by auto
      thus ?thesis using * ls by fastforce
    qed
  qed
  moreover have "\<forall>l. trms_proj\<^sub>l\<^sub>s\<^sub>t l (a#A) = trms_proj\<^sub>l\<^sub>s\<^sub>t l [a] \<union> trms_proj\<^sub>l\<^sub>s\<^sub>t l A"
    unfolding unlabel_def proj_def by auto
  hence "(\<Union>l. trms_proj\<^sub>l\<^sub>s\<^sub>t l (a#A)) = (\<Union>l. trms_proj\<^sub>l\<^sub>s\<^sub>t l [a]) \<union> (\<Union>l. trms_proj\<^sub>l\<^sub>s\<^sub>t l A)" by auto
  ultimately show ?case using Cons.IH ls by auto
qed simp

lemma trms\<^sub>l\<^sub>s\<^sub>t_append[simp]: "trms\<^sub>l\<^sub>s\<^sub>t (A@B) = trms\<^sub>l\<^sub>s\<^sub>t A \<union> trms\<^sub>l\<^sub>s\<^sub>t B"
by (metis trms\<^sub>s\<^sub>t_append unlabel_append)

lemma trms_proj\<^sub>l\<^sub>s\<^sub>t_append[simp]: "trms_proj\<^sub>l\<^sub>s\<^sub>t l (A@B) = trms_proj\<^sub>l\<^sub>s\<^sub>t l A \<union> trms_proj\<^sub>l\<^sub>s\<^sub>t l B"
by (metis (no_types, lifting) filter_append proj_def trms\<^sub>l\<^sub>s\<^sub>t_append)

lemma trms_proj\<^sub>l\<^sub>s\<^sub>t_subset[simp]:
  "trms_proj\<^sub>l\<^sub>s\<^sub>t l A \<subseteq> trms_proj\<^sub>l\<^sub>s\<^sub>t l (A@B)"
  "trms_proj\<^sub>l\<^sub>s\<^sub>t l B \<subseteq> trms_proj\<^sub>l\<^sub>s\<^sub>t l (A@B)"
using trms_proj\<^sub>l\<^sub>s\<^sub>t_append[of l] by blast+

lemma trms\<^sub>l\<^sub>s\<^sub>t_subset[simp]:
  "trms\<^sub>l\<^sub>s\<^sub>t A \<subseteq> trms\<^sub>l\<^sub>s\<^sub>t (A@B)"
  "trms\<^sub>l\<^sub>s\<^sub>t B \<subseteq> trms\<^sub>l\<^sub>s\<^sub>t (A@B)"
proof (induction A)
  case (Cons a A)
  obtain l s where *: "a = (l,s)" by moura
  { case 1 thus ?case using Cons * by auto }
  { case 2 thus ?case using Cons * by auto }
qed simp_all

lemma vars\<^sub>l\<^sub>s\<^sub>t_union: "vars\<^sub>l\<^sub>s\<^sub>t A = (\<Union>l. vars_proj\<^sub>l\<^sub>s\<^sub>t l A)"
proof (induction A)
  case (Cons a A)
  obtain l s where ls: "a = (l,s)" by moura
  have "vars\<^sub>l\<^sub>s\<^sub>t [a] = (\<Union>l. vars_proj\<^sub>l\<^sub>s\<^sub>t l [a])"
  proof -
    have *: "vars\<^sub>l\<^sub>s\<^sub>t [a] = vars\<^sub>s\<^sub>t\<^sub>p s" using ls by auto
    show ?thesis
    proof (cases l)
      case (LabelN n)
      hence "vars_proj\<^sub>l\<^sub>s\<^sub>t n [a] = vars\<^sub>s\<^sub>t\<^sub>p s" using ls by simp
      moreover have "\<forall>m. n \<noteq> m \<longrightarrow> vars_proj\<^sub>l\<^sub>s\<^sub>t m [a] = {}" using ls LabelN by auto
      ultimately show ?thesis using * ls by fast
    next
      case LabelS
      hence "\<forall>l. vars_proj\<^sub>l\<^sub>s\<^sub>t l [a] = vars\<^sub>s\<^sub>t\<^sub>p s" using ls by auto
      thus ?thesis using * ls by fast
    qed
  qed
  moreover have "\<forall>l. vars_proj\<^sub>l\<^sub>s\<^sub>t l (a#A) = vars_proj\<^sub>l\<^sub>s\<^sub>t l [a] \<union> vars_proj\<^sub>l\<^sub>s\<^sub>t l A"
    unfolding unlabel_def proj_def by auto
  hence "(\<Union>l. vars_proj\<^sub>l\<^sub>s\<^sub>t l (a#A)) = (\<Union>l. vars_proj\<^sub>l\<^sub>s\<^sub>t l [a]) \<union> (\<Union>l. vars_proj\<^sub>l\<^sub>s\<^sub>t l A)"
    using strand_vars_split(1) by auto
  ultimately show ?case using Cons.IH ls strand_vars_split(1) by auto
qed simp

lemma unlabel_Cons_inv:
  "unlabel A = b#B \<Longrightarrow> \<exists>A'. (\<exists>n. A = (ln n, b)#A') \<or> A = (\<star>, b)#A'"
proof -
  assume *: "unlabel A = b#B"
  then obtain l A' where "A = (l,b)#A'" unfolding unlabel_def by moura
  thus "\<exists>A'. (\<exists>l. A = (ln l, b)#A') \<or> A = (\<star>, b)#A'" by (metis strand_label.exhaust)
qed

lemma unlabel_snoc_inv:
  "unlabel A = B@[b] \<Longrightarrow> \<exists>A'. (\<exists>n. A = A'@[(ln n, b)]) \<or> A = A'@[(\<star>, b)]"
proof -
  assume *: "unlabel A = B@[b]"
  then obtain A' l where "A = A'@[(l,b)]"
    unfolding unlabel_def by (induct A rule: List.rev_induct) auto
  thus "\<exists>A'. (\<exists>n. A = A'@[(ln n, b)]) \<or> A = A'@[(\<star>, b)]" by (cases l) auto
qed

lemma proj_idem[simp]: "proj l (proj l A) = proj l A"
unfolding proj_def by auto

lemma proj_ik\<^sub>s\<^sub>t_is_proj_rcv_set:
  "ik\<^sub>s\<^sub>t (proj_unl n A) = {t. (ln n, Receive t) \<in> set A \<or> (\<star>, Receive t) \<in> set A} "
using ik\<^sub>s\<^sub>t_is_rcv_set unfolding unlabel_def proj_def by force

lemma unlabel_ik\<^sub>s\<^sub>t_is_rcv_set:
  "ik\<^sub>s\<^sub>t (unlabel A) = {t | l t. (l, Receive t) \<in> set A}"
using ik\<^sub>s\<^sub>t_is_rcv_set unfolding unlabel_def by force

lemma proj_ik_union_is_unlabel_ik:
  "ik\<^sub>s\<^sub>t (unlabel A) = (\<Union>l. ik\<^sub>s\<^sub>t (proj_unl l A))"
proof
  show "(\<Union>l. ik\<^sub>s\<^sub>t (proj_unl l A)) \<subseteq> ik\<^sub>s\<^sub>t (unlabel A)"
    using unlabel_ik\<^sub>s\<^sub>t_is_rcv_set[of A] proj_ik\<^sub>s\<^sub>t_is_proj_rcv_set[of _ A] by auto

  show "ik\<^sub>s\<^sub>t (unlabel A) \<subseteq> (\<Union>l. ik\<^sub>s\<^sub>t (proj_unl l A))"
  proof
    fix t assume "t \<in> ik\<^sub>s\<^sub>t (unlabel A)"
    then obtain l where "(l, Receive t) \<in> set A"
      using ik\<^sub>s\<^sub>t_is_rcv_set unlabel_mem_has_label[of _ A]
      by moura
    thus "t \<in> (\<Union>l. ik\<^sub>s\<^sub>t (proj_unl l A))" using proj_ik\<^sub>s\<^sub>t_is_proj_rcv_set[of _ A] by (cases l) auto
  qed
qed

lemma proj_ik_append[simp]:
  "ik\<^sub>s\<^sub>t (proj_unl l (A@B)) = ik\<^sub>s\<^sub>t (proj_unl l A) \<union> ik\<^sub>s\<^sub>t (proj_unl l B)"
using proj_append(2)[of l A B] ik_append by auto

lemma proj_ik_append_subst_all:
  "ik\<^sub>s\<^sub>t (proj_unl l (A@B)) \<cdot>\<^sub>s\<^sub>e\<^sub>t I = (ik\<^sub>s\<^sub>t (proj_unl l A) \<cdot>\<^sub>s\<^sub>e\<^sub>t I) \<union> (ik\<^sub>s\<^sub>t (proj_unl l B) \<cdot>\<^sub>s\<^sub>e\<^sub>t I)"
using proj_ik_append[of l] by auto

lemma ik_proj_subset[simp]: "ik\<^sub>s\<^sub>t (proj_unl n A) \<subseteq> trms_proj\<^sub>l\<^sub>s\<^sub>t n A"
by auto

lemma prefix_proj:
  "prefix A B \<Longrightarrow> prefix (unlabel A) (unlabel B)"
  "prefix A B \<Longrightarrow> prefix (proj n A) (proj n B)"
  "prefix A B \<Longrightarrow> prefix (proj_unl n A) (proj_unl n B)"
unfolding prefix_def unlabel_def proj_def by auto

subsection \<open>Lemmata: Well-formedness\<close>
lemma wfvarsoccs\<^sub>s\<^sub>t_proj_union:
  "wfvarsoccs\<^sub>s\<^sub>t (unlabel A) = (\<Union>l. wfvarsoccs\<^sub>s\<^sub>t (proj_unl l A))"
proof (induction A)
  case (Cons a A)
  obtain l s where ls: "a = (l,s)" by moura
  have "wfvarsoccs\<^sub>s\<^sub>t (unlabel [a]) = (\<Union>l. wfvarsoccs\<^sub>s\<^sub>t (proj_unl l [a]))"
  proof -
    have *: "wfvarsoccs\<^sub>s\<^sub>t (unlabel [a]) = wfvarsoccs\<^sub>s\<^sub>t\<^sub>p s" using ls by auto
    show ?thesis
    proof (cases l)
      case (LabelN n)
      hence "wfvarsoccs\<^sub>s\<^sub>t (proj_unl n [a]) = wfvarsoccs\<^sub>s\<^sub>t\<^sub>p s" using ls by simp
      moreover have "\<forall>m. n \<noteq> m \<longrightarrow> wfvarsoccs\<^sub>s\<^sub>t (proj_unl m [a]) = {}" using ls LabelN by auto
      ultimately show ?thesis using * ls by fast
    next
      case LabelS
      hence "\<forall>l. wfvarsoccs\<^sub>s\<^sub>t (proj_unl l [a]) = wfvarsoccs\<^sub>s\<^sub>t\<^sub>p s" using ls by auto
      thus ?thesis using * ls by fast
    qed
  qed
  moreover have
      "wfvarsoccs\<^sub>s\<^sub>t (proj_unl l (a#A)) =
       wfvarsoccs\<^sub>s\<^sub>t (proj_unl l [a]) \<union> wfvarsoccs\<^sub>s\<^sub>t (proj_unl l A)"
    for l
    unfolding unlabel_def proj_def by auto
  hence "(\<Union>l. wfvarsoccs\<^sub>s\<^sub>t (proj_unl l (a#A))) =
         (\<Union>l. wfvarsoccs\<^sub>s\<^sub>t (proj_unl l [a])) \<union> (\<Union>l. wfvarsoccs\<^sub>s\<^sub>t (proj_unl l A))"
    using strand_vars_split(1) by auto
  ultimately show ?case using Cons.IH ls strand_vars_split(1) by auto
qed simp

lemma wf_if_wf_proj:
  assumes "\<forall>l. wf\<^sub>s\<^sub>t V (proj_unl l A)"
  shows "wf\<^sub>s\<^sub>t V (unlabel A)"
using assms
proof (induction A arbitrary: V rule: List.rev_induct)
  case (snoc a A)
  hence IH: "wf\<^sub>s\<^sub>t V (unlabel A)" using proj_append(2)[of _ A] by auto
  obtain b l where b: "a = (ln l, b) \<or> a = (\<star>, b)" by (cases a, metis strand_label.exhaust)
  hence *: "wf\<^sub>s\<^sub>t V (proj_unl l A@[b])"
    by (metis snoc.prems proj_append(2) singleton_lst_proj(1) proj_unl_cons(1,3))
  thus ?case using IH b snoc.prems proj_append(2)[of l A "[a]"] unlabel_append[of A "[a]"]
  proof (cases b)
    case (Receive t)
    have "fv t \<subseteq> wfvarsoccs\<^sub>s\<^sub>t (unlabel A) \<union> V"
    proof
      fix x assume "x \<in> fv t"
      hence "x \<in> V \<union> wfvarsoccs\<^sub>s\<^sub>t (proj_unl l A)" using wf_append_exec[OF *] b Receive by auto
      thus "x \<in> wfvarsoccs\<^sub>s\<^sub>t (unlabel A) \<union> V" using wfvarsoccs\<^sub>s\<^sub>t_proj_union[of A] by auto
    qed
    hence "fv t \<subseteq> wfrestrictedvars\<^sub>s\<^sub>t (unlabel A) \<union> V"
      using vars_snd_rcv_strand_subset2(4)[of "unlabel A"] by blast
    hence "wf\<^sub>s\<^sub>t V (unlabel A@[Receive t])" by (rule wf_rcv_append'''[OF IH])
    thus ?thesis using b Receive unlabel_append[of A "[a]"] by auto
  next
    case (Equality ac s t)
    have "fv t \<subseteq> wfvarsoccs\<^sub>s\<^sub>t (unlabel A) \<union> V" when "ac = Assign"
    proof
      fix x assume "x \<in> fv t"
      hence "x \<in> V \<union> wfvarsoccs\<^sub>s\<^sub>t (proj_unl l A)" using wf_append_exec[OF *] b Equality that by auto
      thus "x \<in> wfvarsoccs\<^sub>s\<^sub>t (unlabel A) \<union> V" using wfvarsoccs\<^sub>s\<^sub>t_proj_union[of A] by auto
    qed
    hence "fv t \<subseteq> wfrestrictedvars\<^sub>l\<^sub>s\<^sub>t A \<union> V" when "ac = Assign"
      using vars_snd_rcv_strand_subset2(4)[of "unlabel A"] that by blast
    hence "wf\<^sub>s\<^sub>t V (unlabel A@[Equality ac s t])"
      by (cases ac) (metis wf_eq_append'''[OF IH], metis wf_eq_check_append''[OF IH])
    thus ?thesis using b Equality unlabel_append[of A "[a]"] by auto
  qed auto
qed simp

end


           (*-------------------------------------------*
            |        CSP-Prover on Isabelle2004         |
            |                    May 2005               |
            |                   June 2005  (modified)   |
            |              September 2005  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2005         |
            |                October 2005  (modified)   |
            |                  April 2006  (modified)   |
            |                  March 2007  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2016         |
            |                    May 2016  (modified)   |
            |                                           |
            |        Yoshinao Isobe (AIST JAPAN)        |
            *-------------------------------------------*)

theory CSP_T_op_rep_par
imports CSP_T_op_alpha_par
begin

(*  The following simplification rules are deleted in this theory file *)
(*  because they unexpectly rewrite UnionT and InterT.                 *)
(*                  Union (B ` A) = (UN x:A. B x)                      *)
(*                  Inter (B ` A) = (INT x:A. B x)                     *)

declare Sup_image_eq [simp del]
declare Inf_image_eq [simp del]

(*  The following simplification rules are deleted in this theory file *)
(*  because they unexpectly rewrite (notick | t = <>)                  *)
(*                                                                     *)
(*                  disj_not1: (~ P | Q) = (P --> Q)                   *)

declare disj_not1 [simp del]

(*============================================================*
 |                                                            |
 |            replicated alphabetized parallel                |
 |                                                            |
 *============================================================*)

(*** traces Inductive_parallel ***)

lemma in_traces_Inductive_parallel_lm1:
  "(P, X) : set PXs ==> X <= Union (snd ` (set PXs))"
by (auto)

(* main *)

lemma in_traces_Inductive_parallel_lm:
  "PXs ~= [] --> (ALL u.
    (u :t traces ([||] PXs) M) =
     (sett(u) <= insert Tick (Ev ` (Union (snd ` (set PXs)))) &
      (ALL P X. (P,X):(set PXs) --> (u rest-tr X) :t traces P M)))"
apply (induct_tac PXs)

(* case 0 *)
 apply (simp)

(* case 1 *)
 apply (case_tac "list = []")
 apply (simp)
 apply (intro allI)
 apply (simp add: in_traces_Alpha_parallel in_traces)
 apply (simp add: pair_eq_decompo)
 apply (simp add: rest_tr_empty)
 apply (rule iffI)
 (* => *)
  apply (simp)
 (* <= *)
  apply (simp)

(* step case *)
apply (simp add: in_traces_Alpha_parallel)
apply (intro allI impI)
apply (rule iffI)

(* => *)
 apply (simp)
 apply (intro allI)
 apply (rule conjI)

  apply (intro impI)
  apply (simp add: pair_eq_decompo)

  apply (intro impI)
  apply (elim conjE)
  apply (drule_tac x="P" in spec)
  apply (drule_tac x="X" in spec)
  apply (subgoal_tac "X <= Union (snd ` set list)")
  apply (simp add: rest_tr_of_rest_tr_subset)
  apply (simp add: in_traces_Inductive_parallel_lm1)

(* <= *)
 apply (simp add: rest_tr_sett_subseteq_sett)
 apply (intro allI impI)
 apply (elim conjE)
 apply (drule_tac x="P" in spec)
 apply (drule_tac x="X" in spec)
 apply (subgoal_tac "X <= Union (snd ` set list)")
 apply (simp add: rest_tr_of_rest_tr_subset)
 apply (simp add: in_traces_Inductive_parallel_lm1)
done

(*** remove ALL ***)

lemma in_traces_Inductive_parallel:
  "PXs ~= []
   ==> (u :t traces ([||] PXs) M) =
       (sett(u) <= insert Tick (Ev ` (Union (snd ` (set PXs)))) &
        (ALL P X. (P,X):(set PXs) --> (u rest-tr X) :t traces P M))"
by (simp add: in_traces_Inductive_parallel_lm)

(*** Semantics for replicated alphabetized parallel on T ***)

lemma traces_Inductive_parallel:
  "PXs ~= []
   ==> traces ([||] PXs) M =
       {u. sett(u) <= insert Tick (Ev ` (Union (snd ` (set PXs)))) &
        (ALL P X. (P,X):(set PXs) --> (u rest-tr X) :t traces P M)}t"
apply (simp add: in_traces_Inductive_parallel[THEN sym])
done

(************************************
 |              traces              |
 ************************************)

lemma sett_in_traces_Inductive_parallel:
  "[| PXs ~= [] ; t :t traces ([||] PXs) M |]
   ==> sett t <= insert Tick (Ev ` Union (snd ` set PXs))"
by (simp add: in_traces_Inductive_parallel)

(*---------------------------------------------------------*
 |        another expression of Inductive_parallel_eval          |
 *---------------------------------------------------------*)

lemma in_traces_Inductive_parallel_nth:
  "PXs ~= []
   ==> (u :t traces ([||] PXs) M) =
       (sett(u) <= insert Tick (Ev ` (Union (snd ` (set PXs)))) &
        (ALL i. i < length PXs --> (u rest-tr (snd (PXs!i))) :t traces (fst (PXs!i)) M))"
apply (simp add: in_traces_Inductive_parallel)
apply (simp add: set_nth)
apply (simp add: pair_eq_decompo)
by (auto)

(*============================================================*
 |                                                            |
 |              indexed alphabetized parallel                 |
 |                                                            |
 *============================================================*)

(*** index_style ***)

lemma to_index_style_T:
   "(ALL P X. (P,X):(PXf ` I) --> (u rest-tr X) :t traces P M)
  = (ALL i:I. u rest-tr (snd (PXf i)) :t traces (fst (PXf i)) M)"
apply (auto)
apply (simp add: pair_eq_decompo)
done

(*** in_traces_Rep_parallel (pre) ***)

lemma in_traces_Rep_parallel_pre:
  "[| I ~= {} ; finite I |]
   ==> (u :t traces ([||]:I PXf) M) =
       (sett(u) <= insert Tick (Ev ` (Union (snd ` PXf ` I))) &
        (ALL P X. (P,X):PXf ` I --> (u rest-tr X) :t traces P M))"
apply (simp add: Rep_parallel_def)
apply (subgoal_tac "EX Is. Is isListOf I")
apply (elim conjE exE)
apply (subgoal_tac "(map PXf (SOME Is. Is isListOf I)) ~= []")
apply (simp add: in_traces in_traces_Inductive_parallel)
apply (rule someI2)
 apply (simp)
 apply (simp add: isListOf_set_eq)

apply (rule someI2)
 apply (simp)
 apply (simp add: isListOf_nonemptyset)

apply (simp add: isListOf_EX)
done

(*** in_traces_Rep_parallel ***)

lemma in_traces_Rep_parallel:
  "[| I ~= {} ; finite I |]
   ==> (u :t traces ([||]:I PXf) M) =
       (sett(u) <= insert Tick (Ev ` (Union (snd ` PXf ` I))) &
        (ALL i:I. (u rest-tr (snd (PXf i))) :t traces (fst (PXf i)) M))"
apply (simp add: in_traces_Rep_parallel_pre)
apply (simp add: to_index_style_T)
done

lemmas in_traces_par = in_traces_Alpha_parallel
                       in_traces_Inductive_parallel
                       in_traces_Rep_parallel

(*** Semantics for indexed alphabetized parallel on T ***)

lemma traces_Rep_parallel:
  "[| I ~= {} ; finite I |]
   ==> traces ([||]:I PXf) M =
             {u. (sett(u) <= insert Tick (Ev ` (Union (snd ` PXf ` I))) &
              (ALL i:I. (u rest-tr (snd (PXf i))) :t traces (fst (PXf i)) M))}t"
apply (simp add: in_traces_Rep_parallel[THEN sym])
done

(************************************
 |              traces              |
 ************************************)

lemma sett_in_traces_Rep_parallel:
  "[| I ~= {} ; finite I ; t :t traces ([||]:I PXf) M |]
   ==> sett t <= insert Tick (Ev ` Union (snd ` PXf ` I))"
by (simp add: in_traces_Rep_parallel)

(****************** to add it again ******************)

declare disj_not1   [simp]
(*
declare Union_image_eq [simp]
declare Inter_image_eq [simp]
*)

declare Sup_image_eq [simp]
declare Inf_image_eq [simp]

end


section \<open>Stack by Array\<close>
theory Impl_Array_Stack
imports
  "../../../Automatic_Refinement/Automatic_Refinement"
  "../../Lib/Diff_Array"
begin

type_synonym 'a array_stack = "'a array \<times> nat"

term Diff_Array.array_length

definition "as_raw_\<alpha> s \<equiv> take (snd s) (list_of_array (fst s))"
definition "as_raw_invar s \<equiv> snd s \<le> array_length (fst s)"

definition as_rel_def_internal: "as_rel R \<equiv> br as_raw_\<alpha> as_raw_invar O \<langle>R\<rangle>list_rel"
lemma as_rel_def: "\<langle>R\<rangle>as_rel \<equiv> br as_raw_\<alpha> as_raw_invar O \<langle>R\<rangle>list_rel"
  unfolding as_rel_def_internal[abs_def] by (simp add: relAPP_def)

lemma [relator_props]: "single_valued R \<Longrightarrow> single_valued (\<langle>R\<rangle>as_rel)"
  unfolding as_rel_def
  by tagged_solver

lemmas [autoref_rel_intf] = REL_INTFI[of as_rel i_list]

definition "as_empty (_::unit) \<equiv> (array_of_list [],0)"

lemma as_empty_refine[autoref_rules]: "(as_empty (),[]) \<in> \<langle>R\<rangle>as_rel"
  unfolding as_rel_def as_empty_def br_def
  unfolding as_raw_\<alpha>_def as_raw_invar_def
  by auto

definition "as_push s x \<equiv> let
    (a,n)=s;
    a = if n = array_length a then
        array_grow a (max 4 (2*n)) x
      else a;
    a = array_set a n x
  in
    (a,n+1)"

lemma as_push_refine[autoref_rules]:
  "(as_push,op_list_append_elem) \<in> \<langle>R\<rangle>as_rel \<rightarrow> R \<rightarrow> \<langle>R\<rangle>as_rel"
  apply (intro fun_relI)
  apply (simp add: as_push_def op_list_append_elem_def as_rel_def br_def
    as_raw_\<alpha>_def as_raw_invar_def)
  apply clarsimp
  apply safe
  apply (rule)
  apply auto []
  apply (clarsimp simp: array_length_list) []
  apply parametricity

  apply rule
  apply auto []
  apply (auto simp: take_Suc_conv_app_nth array_length_list list_update_append) []
  apply parametricity
  done

term array_shrink

definition "as_shrink s \<equiv> let
    (a,n) = s;
    a = if 128*n \<le> array_length a \<and> n>4 then
        array_shrink a n
      else a
  in
    (a,n)"

lemma as_shrink_id_refine: "(as_shrink,id) \<in> \<langle>R\<rangle>as_rel \<rightarrow> \<langle>R\<rangle>as_rel"
  apply (intro fun_relI)
  apply (simp add: as_shrink_def as_rel_def br_def
    as_raw_\<alpha>_def as_raw_invar_def Let_def)
  apply clarsimp
  apply safe

  apply (rule)
  apply (auto simp: array_length_list)
  done

lemma as_shrinkI:
  assumes [param]: "(s,a)\<in>\<langle>R\<rangle>as_rel"
  shows "(as_shrink s,a)\<in>\<langle>R\<rangle>as_rel"
  apply (subst id_apply[of a,symmetric])
  apply (parametricity add: as_shrink_id_refine)
  done

definition "as_pop s \<equiv> let (a,n)=s in as_shrink (a,n - 1)"

lemma as_pop_refine[autoref_rules]: "(as_pop,butlast) \<in> \<langle>R\<rangle>as_rel \<rightarrow> \<langle>R\<rangle>as_rel"
  apply (intro fun_relI)
  apply (clarsimp simp add: as_pop_def split: prod.split)
  apply (rule as_shrinkI)

  apply (simp add: as_pop_def as_rel_def br_def
    as_raw_\<alpha>_def as_raw_invar_def Let_def)
  apply clarsimp

  apply rule
  apply (auto simp: array_length_list) []
  apply (clarsimp simp: array_length_list take_minus_one_conv_butlast) []
  apply parametricity
  done

definition "as_get s i \<equiv> let (a,_::nat)=s in array_get a i"

lemma as_get_refine:
  assumes 1: "i'<length l"
  assumes 2: "(a,l)\<in>\<langle>R\<rangle>as_rel"
  assumes 3[param]: "(i,i')\<in>nat_rel"
  shows "(as_get a i,l!i')\<in>R"
  using 2
  apply (clarsimp
    simp add: as_get_def as_rel_def br_def as_raw_\<alpha>_def as_raw_invar_def
    split: prod.split)
  apply (rename_tac aa bb)
  apply (case_tac aa, simp)
proof -
  fix n cl
  assume TKR[param]: "(take n cl, l) \<in> \<langle>R\<rangle>list_rel"

  have "(take n cl!i, l!i')\<in>R"
    by parametricity (rule 1)
  also have "take n cl!i = cl!i"
    using 1 3 list_rel_imp_same_length[OF TKR]
    by simp
  finally show "(cl!i,l!i')\<in>R" .
qed

context begin interpretation autoref_syn .
lemma as_get_autoref[autoref_rules]:
  assumes "(l,l')\<in>\<langle>R\<rangle>as_rel"
  assumes "(i,i')\<in>Id"
  assumes "SIDE_PRECOND (i' < length l')"
  shows "(as_get l i,(OP nth ::: \<langle>R\<rangle>as_rel \<rightarrow> nat_rel \<rightarrow> R)$l'$i')\<in>R"
  using assms by (simp add: as_get_refine)

definition "as_set s i x \<equiv> let (a,n::nat)=s in (array_set a i x,n)"

lemma as_set_refine[autoref_rules]:
  "(as_set,list_update)\<in>\<langle>R\<rangle>as_rel \<rightarrow> nat_rel \<rightarrow> R \<rightarrow> \<langle>R\<rangle>as_rel"
  apply (intro fun_relI)
  apply (clarsimp
    simp: as_set_def as_rel_def br_def as_raw_\<alpha>_def as_raw_invar_def
    split: prod.split)
  apply rule
  apply auto []
  apply parametricity
  by simp

definition as_length :: "'a array_stack \<Rightarrow> nat" where
  "as_length = snd"

lemma as_length_refine[autoref_rules]:
  "(as_length,length) \<in> \<langle>R\<rangle>as_rel \<rightarrow> nat_rel"
  by (auto
    simp: as_length_def as_rel_def br_def as_raw_\<alpha>_def as_raw_invar_def
      array_length_list
    dest!: list_rel_imp_same_length
  )

definition "as_top s \<equiv> as_get s (as_length s - 1)"

lemma as_top_code[code]: "as_top s = (let (a,n)=s in array_get a (n - 1))"
  unfolding as_top_def as_get_def as_length_def
  by (auto split: prod.split)

lemma as_top_refine: "\<lbrakk>l\<noteq>[]; (s,l)\<in>\<langle>R\<rangle>as_rel\<rbrakk> \<Longrightarrow> (as_top s,last l)\<in>R"
  unfolding as_top_def
  apply (simp add: last_conv_nth)
  apply (rule as_get_refine)
  apply (auto simp: as_length_def as_rel_def br_def as_raw_\<alpha>_def
    as_raw_invar_def array_length_list
    dest!: list_rel_imp_same_length)
  done

lemma as_top_autoref[autoref_rules]:
  assumes "(l,l')\<in>\<langle>R\<rangle>as_rel"
  assumes "SIDE_PRECOND (l' \<noteq> [])"
  shows "(as_top l,(OP last ::: \<langle>R\<rangle>as_rel \<rightarrow> R)$l')\<in>R"
  using assms by (simp add: as_top_refine)

definition "as_is_empty s \<equiv> as_length s = 0"
lemma as_is_empty_code[code]: "as_is_empty s = (snd s = 0)"
  unfolding as_is_empty_def as_length_def by simp

lemma as_is_empty_refine[autoref_rules]:
  "(as_is_empty,is_Nil) \<in> \<langle>R\<rangle>as_rel \<rightarrow> bool_rel"
proof
  fix s l
  assume [param]: "(s,l)\<in>\<langle>R\<rangle>as_rel"
  have "(as_is_empty s,length l = 0) \<in> bool_rel"
    unfolding as_is_empty_def
    by (parametricity add: as_length_refine)
  also have "length l = 0 \<longleftrightarrow> is_Nil l"
    by (cases l) auto
  finally show "(as_is_empty s, is_Nil l) \<in> bool_rel" .
qed

definition "as_take m s \<equiv> let (a,n) = s in
  if m<n then
    as_shrink (a,m)
  else (a,n)"

lemma as_take_refine[autoref_rules]:
  "(as_take,take)\<in>nat_rel \<rightarrow> \<langle>R\<rangle>as_rel \<rightarrow> \<langle>R\<rangle>as_rel"
  apply (intro fun_relI)
  apply (clarsimp simp add: as_take_def, safe)

  apply (rule as_shrinkI)
  apply (simp add: as_rel_def br_def as_raw_\<alpha>_def as_raw_invar_def)
  apply rule
  apply auto []
  apply clarsimp
  apply (subgoal_tac "take a' (list_of_array a) = take a' (take ba (list_of_array a))")
  apply (simp only: )
  apply (parametricity, rule IdI)
  apply simp

  apply (simp add: as_rel_def br_def as_raw_\<alpha>_def as_raw_invar_def)
  apply rule
  apply auto []
  apply clarsimp
  apply (frule list_rel_imp_same_length)
  apply simp
  done

definition "as_singleton x \<equiv> (array_of_list [x],1)"
lemma as_singleton_refine[autoref_rules]:
  "(as_singleton,op_list_singleton)\<in>R \<rightarrow> \<langle>R\<rangle>as_rel"
  apply (intro fun_relI)
  apply (simp add: as_singleton_def as_rel_def br_def as_raw_\<alpha>_def
    as_raw_invar_def)
  apply rule
  apply (auto simp: array_length_list) []
  apply simp
  done

end

end