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
 *)

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


theory VCTheoryLemmas
  imports trafficLights
begin

lemma substate_refl: "substate s s"
  apply(cases s)
         apply(auto)
  done

lemma substate_trans:
"substate s1 s2 \<and> substate s2 s3 \<Longrightarrow> substate s1 s3"
proof(induction s3)
    case emptyState
 assume 1: "substate s1 s2 \<and> substate s2 emptyState"
    hence "s2=emptyState"
    proof(cases)
      assume "s2=emptyState"
      thus ?thesis by assumption
    next
      assume  "s2 \<noteq> emptyState"
      with 1 show ?thesis by simp
    qed
    with 1 show ?case by auto
  next
    case (toEnv s3)
    assume 1: "substate s1 s2 \<and> substate s2 (toEnv s3)"
     show ?case
    proof(cases)
      assume "s2=toEnv s3"
      with 1 show ?case by auto
    next
      assume "s2 \<noteq> toEnv s3"
      with 1 toEnv.IH show ?case by auto
    qed
  next
    case (toCon s3)
assume 1: "substate s1 s2 \<and> substate s2 (toCon s3)"
     show ?case
    proof(cases)
      assume "s2=toCon s3"
      with 1 show ?case by auto
    next
      assume "s2 \<noteq> toCon s3"
      with 1 toCon.IH show ?case by auto
    qed
  next
    case (setVarBool s3 v u)
      assume 1: "substate s1 s2 \<and> substate s2 (setVarBool s3 v u)"
      show ?case
      proof(cases)
        assume "s2 = setVarBool s3 v u"
        with 1 show ?case by auto
      next
        assume "s2 \<noteq> setVarBool s3 v u"
        with 1 setVarBool.IH show ?case by auto
      qed
  next
    case (setVarInt s3 v u)
    assume 1:  "substate s1 s2 \<and> substate s2 (setVarInt s3 v u)"
    show ?case
    proof(cases)
      assume "s2 = setVarInt s3 v u"
      with 1 show ?case by auto
    next
      assume "s2 \<noteq> setVarInt s3 v u"
      with 1 setVarInt.IH show ?case by auto
    qed
  next
    case (setVarAny s3 u)
    assume 1: "substate s1 s2 \<and>substate  s2 (setVarAny s3 u)"
    show ?case
    proof(cases)
      assume "s2 = setVarAny s3 u"
      with 1 show ?case by auto
    next
      assume "s2 \<noteq> setVarAny s3 u"
      with 1 setVarAny.IH show ?case by auto
    qed
  next
    case (setPstate s3 p q)
    assume 1: "substate s1 s2 \<and> substate s2 (setPstate s3 p q)"
    show ?case
    proof(cases)
      assume "s2 = setPstate s3 p q"
      with 1 show ?case by auto
    next
      assume "s2 \<noteq> setPstate s3 p q"
      with 1 setPstate.IH show ?case by auto
    qed
  next
    case (reset s3 p)
    assume 1: "substate s1 s2 \<and> substate s2 (reset s3 p)"
    show ?case
    proof(cases)
      assume "s2 = reset s3 p"
      with 1 show ?case by auto
    next
      assume "s2 \<noteq> reset s3 p"
      with 1 reset.IH show ?case by auto
    qed
  qed

lemma substate_asym:
 "substate s1 s2 \<and> substate s2 s1 \<Longrightarrow> s1=s2"
proof(induction s2 arbitrary: s1)
  case emptyState
  assume 1: "substate s1 emptyState \<and> substate emptyState s1"
  show ?case
  proof(cases)
    assume "s1=emptyState"
    thus ?case by assumption
  next
    assume "s1 \<noteq> emptyState"
    with 1 show ?case by auto
  qed
next
  case (toEnv s2)
  assume 1: "substate s1 (toEnv s2) \<and> substate (toEnv s2) s1"
  show ?case
  proof(cases)
    assume "s1 = toEnv s2"
    thus ?case by assumption
  next
    assume 2: "s1 \<noteq> toEnv s2"
    from 1 obtain 3: "substate s1 (toEnv s2)"
and 4: "substate (toEnv s2) s1" ..
    from 2 3 have "substate s1 s2" by simp
    with 4 substate_trans
    have 5: "substate (toEnv s2) s2" by blast
    have "substate s2 (toEnv s2)"
      using substate_refl by auto
    with 5 toEnv.IH have "toEnv s2 = s2" by auto
    with 3 4 toEnv.IH show ?case by auto
  qed
next
  case (toCon s2)
    assume 1: "substate s1 (toCon s2) \<and> substate (toCon s2) s1"
  show ?case
  proof(cases)
    assume "s1 = toCon s2"
    thus ?case by assumption
  next
    assume 2: "s1 \<noteq> toCon s2"
    from 1 obtain 3: "substate s1 (toCon s2)"
and 4: "substate (toCon s2) s1" ..
    from 2 3 have "substate s1 s2" by simp
    with 4 substate_trans
    have 5: "substate (toCon s2) s2" by blast
    have "substate s2 (toCon s2)"
      using substate_refl by auto
    with 5 toCon.IH have "toCon s2 = s2" by auto
    with 3 4 toCon.IH show ?case by auto
  qed
next
  case (setVarBool s2 v u)
    assume 1: "substate s1 (setVarBool s2 v u) \<and> substate (setVarBool s2 v u) s1"
  show ?case
  proof(cases)
    assume "s1 = setVarBool s2 v u"
    thus ?case by assumption
  next
    assume 2: "s1 \<noteq> setVarBool s2 v u"
    from 1 obtain 3: "substate s1 (setVarBool s2 v u)"
and 4: "substate (setVarBool s2 v u) s1" ..
    from 2 3 have "substate s1 s2" by simp
    with 4 substate_trans
    have 5: "substate (setVarBool s2 v u) s2" by blast
    have "substate s2 (setVarBool s2 v u)"
      using substate_refl by auto
    with 5 setVarBool.IH have "setVarBool s2 v u = s2" by auto
    with 3 4 setVarBool.IH show ?case by auto
  qed
next
  case (setVarInt s2 v u)
    assume 1: "substate s1 (setVarInt s2 v u) \<and> substate (setVarInt s2 v u) s1"
  show ?case
  proof(cases)
    assume "s1 = setVarInt s2 v u"
    thus ?case by assumption
  next
    assume 2: "s1 \<noteq> setVarInt s2 v u"
    from 1 obtain 3: "substate s1 (setVarInt s2 v u)"
and 4: "substate (setVarInt s2 v u) s1" ..
    from 2 3 have "substate s1 s2" by simp
    with 4 substate_trans
    have 5: "substate (setVarInt s2 v u) s2" by blast
    have "substate s2 (setVarInt s2 v u)"
      using substate_refl by auto
    with 5 setVarInt.IH have "setVarInt s2 v u = s2" by auto
    with 3 4 setVarInt.IH show ?case by auto
  qed
next
  case (setVarAny s2 u)
    assume 1: "substate s1 (setVarAny s2 u) \<and> substate (setVarAny s2 u) s1"
  show ?case
  proof(cases)
    assume "s1 = setVarAny s2 u"
    thus ?case by assumption
  next
    assume 2: "s1 \<noteq> setVarAny s2 u"
    from 1 obtain 3: "substate s1 (setVarAny s2 u)"
and 4: "substate (setVarAny s2 u) s1" ..
    from 2 3 have "substate s1 s2" by simp
    with 4 substate_trans
    have 5: "substate (setVarAny s2 u) s2" by blast
    have "substate s2 (setVarAny s2 u)"
      using substate_refl by auto
    with 5 setVarAny.IH have "setVarAny s2 u = s2" by auto
    with 3 4 setVarAny.IH show ?case by auto
  qed
next
  case (setPstate s2 p q)
    assume 1: "substate s1 (setPstate s2 p q) \<and> substate (setPstate s2 p q) s1"
  show ?case
  proof(cases)
    assume "s1 = setPstate s2 p q"
    thus ?case by assumption
  next
    assume 2: "s1 \<noteq> setPstate s2 p q"
    from 1 obtain 3: "substate s1 (setPstate s2 p q)"
and 4: "substate (setPstate s2 p q) s1" ..
    from 2 3 have "substate s1 s2" by simp
    with 4 substate_trans
    have 5: "substate (setPstate s2 p q) s2" by blast
    have "substate s2 (setPstate s2 p q)"
      using substate_refl by auto
    with 5 setPstate.IH have "setPstate s2 p q = s2" by auto
    with 3 4 setPstate.IH show ?case by auto
  qed
next
  case (reset s2 p)
    assume 1: "substate s1 (reset s2 p) \<and> substate (reset s2 p) s1"
  show ?case
  proof(cases)
    assume "s1 = reset s2 p"
    thus ?case by assumption
  next
    assume 2: "s1 \<noteq> reset s2 p"
    from 1 obtain 3: "substate s1 (reset s2 p)"
and 4: "substate (reset s2 p) s1" ..
    from 2 3 have "substate s1 s2" by simp
    with 4 substate_trans
    have 5: "substate (reset s2 p) s2" by blast
    have "substate s2 (reset s2 p)"
      using substate_refl by auto
    with 5 reset.IH have "reset s2 p = s2" by auto
    with 3 4 reset.IH show ?case by auto
  qed
qed

lemma predEnv_substate: "substate (predEnv s) s"
  apply(induction s)
  using substate_refl  by auto

lemma substate_eq_or_predEnv:
"substate s1 s2 \<and> toEnvP s1 \<longrightarrow> s1=s2 \<or> substate s1 (predEnv s2)"
  apply(induction s2)
         apply(auto)
  done
(*
  case emptyState
  then show ?case by force
next
  case (toEnv s2)
  assume 1:  "substate s1 (toEnv s2) \<and> toEnvP s1"
  show ?case
  proof cases
    assume "s1= toEnv s2"
    then show ?case by auto
  next
    assume "s1 \<noteq> toEnv s2"
    with 1 have "substate s1 s2" by simp
    with 1 toEnv.IH
    have "s1=s2 \<or> substate s1 (predEnv s2)" by auto
    thus ?case
    proof
      assume "s1=s2"
      with 1
      have "predEnv (toEnv s2) = s1" by auto
      thus ?case by auto
    next
      assume 2: "substate s1 (predEnv s2)"
      show ?case
      proof(cases)
        assume 3: "toEnvP s2"
        from 2 predEnv_substate[of s2]
 substate_trans have "substate s1 s2" by auto
        with 3 show ?case by auto
      next
        assume "\<not> toEnvP s2"
        with 2 show ?case by auto
      qed
    qed
  qed
next
  case (toCon s2)
  assume 1: "substate s1 (toCon s2) \<and> toEnvP s1"
  show ?case
  proof cases
    assume "s1= toCon s2"
    thus ?case by auto
  next
    assume "s1 \<noteq> toCon s2"
    with 1 have "substate s1 s2" by simp
    with 1 toCon.IH
    have "s1=s2 \<or> substate s1 (predEnv s2)" by auto
    thus ?case
    proof
      assume "s1=s2"
      with 1
      have "predEnv (toCon s2) = s1" by auto
      thus ?case by auto
    next
      assume 2: "substate s1 (predEnv s2)"
      show ?case
      proof(cases)
        assume 3: "toEnvP s2"
        from 2 predEnv_substate[of s2]
 substate_trans have "substate s1 s2" by auto
        with 3 show ?case by auto
      next
        assume "\<not> toEnvP s2"
        with 2 show ?case by auto
      qed
    qed
  qed
next
  case (setVarBool s2 v u)
  assume 1: "substate s1 (setVarBool s2 v u) \<and> toEnvP s1"
  show ?case
  proof cases
    assume "s1= setVarBool s2 v u"
    thus ?case by auto
  next
    assume "s1 \<noteq> setVarBool s2 v u"
    with 1 have "substate s1 s2" by simp
    with 1 setVarBool.IH
    have "s1=s2 \<or> substate s1 (predEnv s2)" by auto
    thus ?case
    proof
      assume "s1=s2"
      with 1
      have "predEnv (setVarBool s2 v u) = s1" by auto
      thus ?case by auto
    next
      assume 2: "substate s1 (predEnv s2)"
      show ?case
      proof(cases)
        assume 3: "toEnvP s2"
        from 2 predEnv_substate[of s2]
 substate_trans have "substate s1 s2" by auto
        with 3 show ?case by auto
      next
        assume "\<not> toEnvP s2"
        with 2 show ?case by auto
      qed
    qed
  qed
next
  case (setVarInt s2 v u)
  assume 1: "substate s1 (setVarInt s2 v u) \<and> toEnvP s1"
  show ?case
  proof cases
    assume "s1= setVarInt s2 v u"
    thus ?case by auto
  next
    assume "s1 \<noteq> setVarInt s2 v u"
    with 1 have "substate s1 s2" by simp
    with 1 setVarInt.IH
    have "s1=s2 \<or> substate s1 (predEnv s2)" by auto
    thus ?case
    proof
      assume "s1=s2"
      with 1
      have "predEnv (setVarInt s2 v u) = s1" by auto
      thus ?case by auto
    next
      assume 2: "substate s1 (predEnv s2)"
      show ?case
      proof(cases)
        assume 3: "toEnvP s2"
        from 2 predEnv_substate[of s2]
 substate_trans have "substate s1 s2" by auto
        with 3 show ?case by auto
      next
        assume "\<not> toEnvP s2"
        with 2 show ?case by auto
      qed
    qed
  qed
next
  case (setVarAny s2 u)
  assume 1: "substate s1 (setVarAny s2 u) \<and> toEnvP s1"
  show ?case
  proof cases
    assume "s1= setVarAny s2 u"
    thus ?case by auto
  next
    assume "s1 \<noteq> setVarAny s2 u"
    with 1 have "substate s1 s2" by simp
    with 1 setVarAny.IH
    have "s1=s2 \<or> substate s1 (predEnv s2)" by auto
    thus ?case
    proof
      assume "s1=s2"
      with 1
      have "predEnv (setVarAny s2 u) = s1" by auto
      thus ?case by auto
    next
      assume 2: "substate s1 (predEnv s2)"
      show ?case
      proof(cases)
        assume 3: "toEnvP s2"
        from 2 predEnv_substate[of s2]
 substate_trans have "substate s1 s2" by auto
        with 3 show ?case by auto
      next
        assume "\<not> toEnvP s2"
        with 2 show ?case by auto
      qed
    qed
  qed
next
  case (setPstate s2 p q)
  assume 1: "substate s1 (setPstate s2 p q) \<and> toEnvP s1"
  show ?case
  proof cases
    assume "s1= setPstate s2 p q"
    thus ?case by auto
  next
    assume "s1 \<noteq> setPstate s2 p q"
    with 1 have "substate s1 s2" by simp
    with 1 setPstate.IH
    have "s1=s2 \<or> substate s1 (predEnv s2)" by auto
    thus ?case
    proof
      assume "s1=s2"
      with 1
      have "predEnv (setPstate s2 p q) = s1" by auto
      thus ?case by auto
    next
      assume 2: "substate s1 (predEnv s2)"
      show ?case
      proof(cases)
        assume 3: "toEnvP s2"
        from 2 predEnv_substate[of s2]
 substate_trans have "substate s1 s2" by auto
        with 3 show ?case by auto
      next
        assume "\<not> toEnvP s2"
        with 2 show ?case by auto
      qed
    qed
  qed
next
  case (reset s2 p)
  assume 1: "substate s1 (reset s2 p) \<and> toEnvP s1"
  show ?case
  proof cases
    assume "s1= reset s2 p"
    thus ?case by auto
  next
    assume "s1 \<noteq> reset s2 p"
    with 1 have "substate s1 s2" by simp
    with 1 reset.IH
    have "s1=s2 \<or> substate s1 (predEnv s2)" by auto
    thus ?case
    proof
      assume "s1=s2"
      with 1
      have "predEnv (reset s2 p) = s1" by auto
      thus ?case by auto
    next
      assume 2: "substate s1 (predEnv s2)"
      show ?case
      proof(cases)
        assume 3: "toEnvP s2"
        from 2 predEnv_substate[of s2]
 substate_trans have "substate s1 s2" by auto
        with 3 show ?case by auto
      next
        assume "\<not> toEnvP s2"
        with 2 show ?case by auto
      qed
    qed
  qed
qed
*)

lemma substate_total:
"substate s1 s \<and> substate s2 s \<longrightarrow>
 substate s1 s2 \<or> substate s2 s1"
  apply(induction s)
         apply(auto)
  done

lemma toEnvNum_id: "toEnvNum s s = 0"
  apply(cases s)
         apply(auto)
  done

lemma substate_toEnvNum_id:
"substate s1 s2 \<and> toEnvNum s1 s2 = 0 \<and> toEnvP s1 \<and>
toEnvP s2 \<longrightarrow> s1=s2"
  apply(cases s2)
         apply(auto)
  done

lemma gtime_predI:
 "\<not> toEnvP s \<Longrightarrow>   toEnvNum emptyState s =
 toEnvNum emptyState (predEnv s)"
  apply(induction s)
         apply(auto)
  done
  (*
proof(induction s)
  case emptyState
  then show ?case by auto
next
  case (toEnv s)
  then show ?case by auto
next
  case (toCon s)
  then show ?case
  proof(cases)
    assume "toEnvP s"
    thus ?case by auto
  next
    assume 1: "\<not> toEnvP s"
    have 2: "toEnvNum emptyState (toCon s) =
 toEnvNum emptyState s" by auto
    from 1 2 toCon.IH show ?case by auto
  qed
next
  case (setVarBool s v u)
  then show ?case
  then show ?case
  proof(cases)
    assume "toEnvP s"
    thus ?case by auto
  next
    assume 1: "\<not> toEnvP s"
    have 2: "toEnvNum emptyState (setVarBool s v u) =
 toEnvNum emptyState s" by auto
    from 1 2 setVarBool.IH show ?case by auto
  qed
next
  case (setVarInt s v u)
  then show ?case
  then show ?case
  proof(cases)
    assume "toEnvP s"
    thus ?case by auto
  next
    assume 1: "\<not> toEnvP s"
    have 2: "toEnvNum emptyState (setVarInt s v u) =
 toEnvNum emptyState s" by auto
    from 1 2 setVarInt.IH show ?case by auto
  qed
next
  case (setVarAny s u)
  then show ?case
  then show ?case
  proof(cases)
    assume "toEnvP s"
    thus ?case by auto
  next
    assume 1: "\<not> toEnvP s"
    have 2: "toEnvNum emptyState (setVarAny s u) =
 toEnvNum emptyState s" by auto
    from 1 2 setVarAny.IH show ?case by auto
  qed
next
  case (setPstate s p q)
  then show ?case
  proof(cases)
    assume "toEnvP s"
    thus ?case by auto
  next
    assume 1: "\<not> toEnvP s"
    have 2: "toEnvNum emptyState (setPstate s p q) =
 toEnvNum emptyState s" by auto
    from 1 2 setPstate.IH show ?case by auto
  qed
next
  case (reset s p)
  then show ?case
  proof(cases)
    assume "toEnvP s"
    thus ?case by auto
  next
    assume 1: "\<not> toEnvP s"
    have 2: "toEnvNum emptyState (reset s p) =
 toEnvNum emptyState s" by auto
    from 1 2 reset.IH show ?case by auto
  qed
qed
*)
lemma gtime_predE:
"toEnvP s \<longrightarrow> toEnvNum emptyState s =
toEnvNum emptyState (predEnv s) + 1"
proof(induction s)
  case emptyState
  then show ?case by auto
next
  case (toEnv s)
  then show ?case
  proof cases
    assume "toEnvP s"
    thus ?case by auto
  next
    assume 1: "\<not> toEnvP s"
    have "toEnvNum emptyState (toEnv s) =
toEnvNum emptyState s + 1" by auto
    with 1 gtime_predI show ?thesis by auto
  qed
next
  case (toCon s)
  then show ?case by auto
next
  case (setVarBool s x2a x3a)
  then show ?case by auto
next
  case (setVarInt s x2a x3a)
  then show ?case by auto
next
  case (setVarAny s x2a)
  then show ?case by auto
next
  case (setPstate s x2a x3a)
  then show ?case by auto
next
  case (reset s x2a)
  then show ?case by auto
qed

lemma predEnvPI: "\<not> toEnvP s \<and>
toEnvNum emptyState s > 0 \<longrightarrow>
toEnvP (predEnv s)"
  apply(induction s)
         apply(auto)
  done

lemma predEnvP: "toEnvNum emptyState s > 1 \<Longrightarrow>
toEnvP (predEnv s)"
proof(induction s)
  case emptyState
  then show ?case by auto
next
  case (toEnv s)
  then show ?case
  proof(cases)
    assume "toEnvP s"
    thus ?case by auto
  next
    assume 1: "\<not> toEnvP s"
    assume "toEnvNum  emptyState (toEnv s) > 1"
    hence "toEnvNum emptyState s > 0" by auto
    with 1  predEnvPI  show ?case by auto
  qed
next
  case (toCon s)
  then show ?case
  proof(cases)
    assume "toEnvP s"
    thus ?case by auto
  next
    assume 1: "\<not> toEnvP s"
assume "toEnvNum  emptyState (toCon s) > 1"
  hence "toEnvNum emptyState s > 1" by auto
  with 1 toCon.IH show ?case by auto
qed
next
  case (setVarBool s v u)
  then show ?case
proof(cases)
    assume "toEnvP s"
    thus ?case by auto
  next
    assume 1: "\<not> toEnvP s"
assume "toEnvNum  emptyState (setVarBool s v u) > 1"
  hence "toEnvNum emptyState s > 1" by auto
  with 1 setVarBool.IH show ?case by auto
qed
next
  case (setVarInt s v u)
  then show ?case
proof(cases)
    assume "toEnvP s"
    thus ?case by auto
  next
    assume 1: "\<not> toEnvP s"
assume "toEnvNum  emptyState (setVarInt s v u) > 1"
  hence "toEnvNum emptyState s > 1" by auto
  with 1 setVarInt.IH show ?case by auto
qed
next
  case (setVarAny s u)
  then show ?case
proof(cases)
    assume "toEnvP s"
    thus ?case by auto
  next
    assume 1: "\<not> toEnvP s"
assume "toEnvNum  emptyState (setVarAny s u) > 1"
  hence "toEnvNum emptyState s > 1" by auto
  with 1 setVarAny.IH show ?case by auto
qed
next
  case (setPstate s p q)
  then show ?case
proof(cases)
    assume "toEnvP s"
    thus ?case by auto
  next
    assume 1: "\<not> toEnvP s"
assume "toEnvNum  emptyState (setPstate s p q) > 1"
  hence "toEnvNum emptyState s > 1" by auto
  with 1 setPstate.IH show ?case by auto
qed
next
  case (reset s p)
  then show ?case
proof(cases)
    assume "toEnvP s"
    thus ?case by auto
  next
    assume 1: "\<not> toEnvP s"
assume "toEnvNum  emptyState (reset s p) > 1"
  hence "toEnvNum emptyState s > 1" by auto
  with 1 reset.IH show ?case by auto
qed
qed

lemma shift_spec:
 "toEnvP s \<and> toEnvNum emptyState s > n \<Longrightarrow>
toEnvP (shiftEnv s n) \<and>
 toEnvNum emptyState (shiftEnv s n) =
 toEnvNum emptyState s - n"
proof(induction n)
  case 0
  then show ?case by auto
next
  case (Suc n)
  assume 1: "toEnvP s \<and>
         Suc n < toEnvNum emptyState s"
  with Suc.IH
  have "toEnvNum emptyState (shiftEnv s n) > 1"
    by auto
  with predEnvP have 2:
 "toEnvP (shiftEnv s (Suc n))"
    by auto
  from 1 Suc.IH have 3:  "toEnvP (shiftEnv s n)"
    by auto
  from 1 Suc.IH have
 "toEnvNum emptyState (shiftEnv s n) =
toEnvNum emptyState s - n" by auto
  with 1 3  gtime_predE have
"toEnvNum emptyState (shiftEnv s (Suc n)) =
toEnvNum emptyState s - (Suc n)" by auto
  with 2 show ?case ..
qed

lemma toEnvNum3: "substate s1 s2 \<and> substate s2 s3
 \<Longrightarrow> toEnvNum s1 s3 = toEnvNum s1 s2 + toEnvNum s2 s3"
  proof(induction s3)
    case emptyState
    then show ?case by (cases s2; auto)
  next
    case (toEnv s3)
    then show ?case
    proof(cases)
      assume "s2= toEnv s3"
      thus ?case by auto
    next
      assume 1: "s2 \<noteq> toEnv s3"
      assume 2:  "substate s1 s2 \<and> substate s2 (toEnv s3)"
      with 1 have "substate s2 s3" by simp
      show ?case
      proof(cases)
        assume "s1 = toEnv s3"
        with 2 substate_asym[of "(toEnv s3)" s2]
        have "toEnv s3 = s2" by auto
        with 1 show ?case by auto
      next
        assume "s1 \<noteq> (toEnv s3)"
        with 1 2 toEnv.IH show?case by auto
      qed
    qed
  next
    case (toCon s3)
    then show ?case
    proof(cases)
      assume "s2= toCon s3"
      thus ?case by auto
    next
      assume 1: "s2 \<noteq> toCon s3"
      assume 2:  "substate s1 s2 \<and> substate s2 (toCon s3)"
      with 1 have "substate s2 s3" by simp
      show ?case
      proof(cases)
        assume "s1 = toCon s3"
        with 2 substate_asym[of "(toCon s3)" s2]
        have "toCon s3 = s2" by auto
        with 1 show ?case by auto
      next
        assume "s1 \<noteq> (toCon s3)"
        with 1 2 toCon.IH show?case by auto
      qed
    qed
  next
    case (setVarBool s3 v u)
    then show ?case
    proof(cases)
      assume "s2= setVarBool s3 v u"
      thus ?case by auto
    next
      assume 1: "s2 \<noteq> setVarBool s3 v u"
      assume 2:  "substate s1 s2 \<and> substate s2
 (setVarBool s3 v u)"
      with 1 have "substate s2 s3" by simp
      show ?case
      proof(cases)
        assume "s1 = setVarBool s3 v u"
        with 2 substate_asym[of "(setVarBool s3 v u)" s2]
        have "setVarBool s3 v u = s2" by auto
        with 1 show ?case by auto
      next
        assume "s1 \<noteq> (setVarBool s3 v u)"
        with 1 2 setVarBool.IH show?case by auto
      qed
    qed
  next
    case (setVarInt s3 v u)
    then show ?case
    proof(cases)
      assume "s2= setVarInt s3 v u"
      thus ?case by auto
    next
      assume 1: "s2 \<noteq> setVarInt s3 v u"
      assume 2:  "substate s1 s2 \<and> substate s2 (setVarInt s3 v u)"
      with 1 have "substate s2 s3" by simp
      show ?case
      proof(cases)
        assume "s1 = setVarInt s3 v u"
        with 2 substate_asym[of "(setVarInt s3 v u)" s2]
        have "setVarInt s3 v u = s2" by auto
        with 1 show ?case by auto
      next
        assume "s1 \<noteq> (setVarInt s3 v u)"
        with 1 2 setVarInt.IH show?case by auto
      qed
    qed
  next
    case (setVarAny s3 u)
    then show ?case
    proof(cases)
      assume "s2= setVarAny s3 u"
      thus ?case by auto
    next
      assume 1: "s2 \<noteq> setVarAny s3 u"
      assume 2:  "substate s1 s2 \<and> substate s2 (setVarAny s3 u)"
      with 1 have "substate s2 s3" by simp
      show ?case
      proof(cases)
        assume "s1 = setVarAny s3 u"
        with 2 substate_asym[of "(setVarAny s3 u)" s2]
        have "setVarAny s3 u = s2" by auto
        with 1 show ?case by auto
      next
        assume "s1 \<noteq> (setVarAny s3 u)"
        with 1 2 setVarAny.IH show?case by auto
      qed
    qed
  next
    case (setPstate s3 p q)
    then show ?case
    proof(cases)
      assume "s2= setPstate s3 p q"
      thus ?case by auto
    next
      assume 1: "s2 \<noteq> setPstate s3 p q"
      assume 2:  "substate s1 s2 \<and> substate s2 (setPstate s3 p q)"
      with 1 have "substate s2 s3" by simp
      show ?case
      proof(cases)
        assume "s1 = setPstate s3 p q"
        with 2 substate_asym[of "(setPstate s3 p q)" s2]
        have "setPstate s3 p q = s2" by auto
        with 1 show ?case by auto
      next
        assume "s1 \<noteq> (setPstate s3 p q)"
        with 1 2 setPstate.IH show?case by auto
      qed
    qed
  next
    case (reset s3 p)
    then show ?case
    proof(cases)
      assume "s2= reset s3 p"
      thus ?case by auto
    next
      assume 1: "s2 \<noteq> reset s3 p"
      assume 2:  "substate s1 s2 \<and> substate s2 (reset s3 p)"
      with 1 have "substate s2 s3" by simp
      show ?case
      proof(cases)
        assume "s1 = reset s3 p"
        with 2 substate_asym[of "(reset s3 p)" s2]
        have "reset s3 p = s2" by auto
        with 1 show ?case by auto
      next
        assume "s1 \<noteq> (reset s3 p)"
        with 1 2 reset.IH show?case by auto
      qed
    qed
  qed

lemma emptyState_substate: "substate emptyState s"
  apply(induction s)
         apply(auto)
  done

lemma gtimeE_inj:
"substate s1 s \<and> toEnvP s1 \<and> toEnvP s \<and>
toEnvNum emptyState s1 = toEnvNum emptyState s \<longrightarrow>
s1=s"
proof(cases s)
  case emptyState
  then show ?thesis by auto
next
  case (toEnv s2)
  then show ?thesis
  proof cases
    assume "s1 =s"
    then show ?thesis by auto
  next
    assume 1:  "s1 \<noteq> s"
    show ?thesis
    proof
      assume 2: "substate s1 s \<and>
    toEnvP s1 \<and>
    toEnvP s \<and>
    toEnvNum emptyState s1 =
    toEnvNum emptyState s"
      with 1 toEnv have 3: "substate s1 s2" by auto
      from toEnv have 4: "substate s2 s"
        using substate_refl by auto
      from 3 emptyState_substate toEnvNum3
      have 5:  "toEnvNum emptyState s2 =
toEnvNum emptyState s1 + toEnvNum s1 s2" by auto
      from emptyState_substate 4 toEnvNum3 have 6:
"toEnvNum emptyState s = toEnvNum emptyState s2 + toEnvNum s2 s"
        by auto
      with toEnv  have 7: "toEnvNum s2 s > 0" by auto
      from 5 have
 "toEnvNum emptyState s1 \<le> toEnvNum emptyState s2"
        by auto
      also from 6 7 have
"toEnvNum emptyState s2 < toEnvNum emptyState s"
        by auto
      finally have
 "toEnvNum emptyState s1 < toEnvNum emptyState s" .
      with 2 show
"substate s1 s \<and>
    toEnvP s1 \<and>
    toEnvP s \<and>
    toEnvNum emptyState s1 =
    toEnvNum emptyState s \<Longrightarrow> s1=s" by auto
    qed
  qed
next
  case (toCon x3)
  then show ?thesis by auto
next
  case (setVarBool x41 x42 x43)
  then show ?thesis by auto
next
  case (setVarInt x51 x52 x53)
  then show ?thesis by auto
next
  case (setVarAny x61 x62)
  then show ?thesis by auto
next
  case (setPstate x71 x72 x73)
  then show ?thesis by auto
next
  case (reset x81 x82)
  then show ?thesis by auto
qed

lemma shiftEnv_substate: "substate (shiftEnv s n) s"
proof(induction n)
  case 0
  then show ?case using substate_refl by auto
next
  case (Suc n)
  then have "substate (predEnv (shiftEnv s n)) s"
    using predEnv_substate[of "shiftEnv s n"]
substate_trans by blast
  thus ?case by simp
qed

lemma toEnvNum_shift: "toEnvP s \<and>
toEnvNum emptyState s > n
  \<Longrightarrow> toEnvNum (shiftEnv s n) s = n"
proof -
  assume 1: "toEnvP s \<and> toEnvNum emptyState s > n"
  have 2:  "toEnvNum emptyState s =
toEnvNum emptyState (shiftEnv s n) +
toEnvNum (shiftEnv s n) s"
    using emptyState_substate toEnvNum3
shiftEnv_substate by auto
  with 1 shift_spec show ?thesis by force
qed

lemma substate_shift:
"toEnvP s1 \<and> toEnvP s \<and> substate s1 s \<and>
toEnvNum s1 s \<ge> n \<Longrightarrow>
substate s1 (shiftEnv s n)"
proof(induction n)
  case 0
  then show ?case by auto
next
  case (Suc n)
  then show ?case
  proof -
    assume 1:  "toEnvP s1 \<and>
    toEnvP s \<and>
    substate s1 s \<and> Suc n \<le> toEnvNum s1 s"
    with Suc.IH have "substate s1 (shiftEnv s n)"
      by auto
    with 1 substate_eq_or_predEnv have
"s1 = shiftEnv s n \<or>
substate s1 (predEnv (shiftEnv s n))" by auto
    then show ?case
    proof
      assume 2: "s1 = shiftEnv s n"
      with 1 emptyState_substate[of s1]  toEnvNum3
      have  "toEnvNum emptyState s > n" by force
      with 1 toEnvNum_shift have
"toEnvNum (shiftEnv s n) s = n" by auto
      with 1 2 show ?case by auto
    next
      assume "substate s1 (predEnv (shiftEnv s n))"
      thus ?case by simp
    qed
  qed
qed

lemma predEnvP_or_emptyState:
"toEnvP (predEnv s) \<or> predEnv s = emptyState"
  apply(induction s)
         apply(auto)
  done

lemma shiftEnvP_or_emptyState: "n \<noteq> 0 \<longrightarrow>
 toEnvP (shiftEnv s n) \<or> shiftEnv s n = emptyState"
  apply(cases n)
  using predEnvP_or_emptyState by auto

lemma shift_toEnvNum:
"toEnvP s \<and> toEnvP s1 \<and> substate s1 s \<Longrightarrow>
shiftEnv s (toEnvNum s1 s) = s1"
proof -
  define s2:: state where
 "s2 = shiftEnv s (toEnvNum s1 s)"
  assume 1: "toEnvP s \<and> toEnvP s1 \<and> substate s1 s"
  with s2_def substate_shift have 2:
"substate s1 s2" by auto
  from 1 have "toEnvNum emptyState s1 > 0"
    by (cases s1; auto)
  with 1 emptyState_substate[of s1] toEnvNum3 have
"toEnvNum s1 s < toEnvNum emptyState s" by force
  with 1 shift_spec s2_def have
"toEnvNum emptyState s2 =
toEnvNum emptyState s - toEnvNum s1 s" by auto
  also from 1 emptyState_substate[of s1] toEnvNum3
  have "toEnvNum  emptyState s - toEnvNum s1 s =
toEnvNum emptyState s1" by force
  finally have 3:
 "toEnvNum emptyState s2 = toEnvNum emptyState s1"
    .
  show ?thesis
  proof(cases)
    assume 4: "toEnvNum s1 s = 0"
    with 1 substate_toEnvNum_id have "s1=s"
      by blast
    with 1 show ?thesis using toEnvNum_id  by auto
  next
    assume "toEnvNum s1 s \<noteq> 0"
    with s2_def shiftEnvP_or_emptyState have
"toEnvP s2 \<or> s2 = emptyState" by auto
    hence "toEnvP s2"
    proof
      assume "toEnvP s2"
      thus ?thesis by assumption
    next
      assume "s2 = emptyState"
      with 2 have "s1=emptyState"
        by (cases s1; auto)
      with 1 show ?thesis by auto
    qed
    with 1 2 3[symmetric]  gtimeE_inj
    have "s1=s2" by blast
    with s2_def show ?thesis by simp
  qed
qed

lemma ltime_le_toEnvNum:
"ltimeEnv s p \<le> toEnvNum emptyState s"
  apply(induction s)
         apply(auto)
  done

(*
lemma partitioning:
"substate s1 s2 \<and> substate s2 s3 \<and> substate s1 s \<and>
substate s s3 \<longrightarrow> substate s1 s \<and> substate s s2 \<or>
substate s2 s \<and> substate s s3"
  using substate_total by blast
*)

lemma predEnv_substate_imp_eq_or_substate:
"toEnvP s1 \<and> toEnvP s2 \<and> substate s1 s \<and>
 substate s2 s \<and> substate (predEnv s1) s2 \<longrightarrow>
s2 = predEnv s1 \<or> substate s1 s2"
proof cases
  assume "s1 = s2"
  with substate_refl show ?thesis by auto
next
  assume 1: "s1 \<noteq> s2"
  show ?thesis
  proof
    assume 2: "toEnvP s1 \<and>
    toEnvP s2 \<and>
    substate s1 s \<and>
    substate s2 s \<and> substate (predEnv s1) s2 "
    with substate_total
    have "substate s1 s2 \<or> substate s2 s1" by auto
    thus " s2 = predEnv s1 \<or> substate s1 s2"
    proof
      assume "substate s1 s2"
      thus ?thesis by auto
    next
      assume "substate s2 s1"
      with 1 substate_eq_or_predEnv 2 substate_asym
      show ?thesis by auto
    qed
  qed
qed

lemma state_down_ind:
"toEnvP s \<and> toEnvP s1 \<Longrightarrow> P s \<Longrightarrow>
 (\<And> s2. toEnvP s2 \<Longrightarrow>
 (substate s1 s2 \<and> substate s2 s \<and> s1 \<noteq> s2)
 \<Longrightarrow> P s2 \<Longrightarrow> P (predEnv s2)) \<Longrightarrow>
toEnvP s2 \<and> substate s1 s2 \<and> substate s2 s \<longrightarrow>
 P s2"
proof -
  assume 1: "toEnvP s \<and> toEnvP s1"
  define Q:: "nat \<Rightarrow> bool" where
"Q = (\<lambda> n. P (shiftEnv s n))"
  from Q_def  1 shift_toEnvNum have P_def:
"\<And> s'. toEnvP s' \<and> substate s' s \<Longrightarrow>
P s' = Q (toEnvNum s' s)" by auto
  define n where "n = toEnvNum s2 s"
  assume base: "P s" and ind_step:
"\<And> s2. toEnvP s2 \<Longrightarrow>
 (substate s1 s2 \<and> substate s2 s \<and> s1 \<noteq> s2)
 \<Longrightarrow> P s2 \<Longrightarrow> P (predEnv s2)"
  show ?thesis
  proof
    assume 2: "toEnvP s2 \<and> substate s1 s2 \<and>
 substate s2 s"
    with 1  n_def shift_toEnvNum have s2_def: "s2 = shiftEnv s n"
      by auto
     from 2 show "P s2"
      apply(simp only: P_def n_def[symmetric])
      apply(simp only: s2_def)
    proof(induction n)
      case 0
      then show ?case using Q_def base by auto
    next
      case (Suc n)
      then show ?case
        apply(simp only: Q_def)
        print_state
      proof cases
        assume 3: "s1 = shiftEnv s n"
        assume 4: "toEnvP (shiftEnv s (Suc n)) \<and>
    substate s1 (shiftEnv s (Suc n)) \<and>
    substate (shiftEnv s (Suc n)) s"
        from 3 have 5: "substate (shiftEnv s n) s1"
          using substate_refl by auto
        from predEnv_substate have
"substate (shiftEnv s (Suc n)) (shiftEnv s n)"
          by simp
        with 4 5  substate_asym substate_trans
        have "s1 = shiftEnv s (Suc n)"
          by blast
        with 3 have
 "shiftEnv s n = shiftEnv s (Suc n)" by simp
        with 4 gtime_predE show
 "P (shiftEnv s (Suc n))" by fastforce
      next
        assume 3: "s1 \<noteq> shiftEnv s n"
        assume 4: "toEnvP (shiftEnv s (Suc n)) \<and>
    substate s1 (shiftEnv s (Suc n)) \<and>
    substate (shiftEnv s (Suc n)) s"
from predEnv_substate have
"substate (shiftEnv s (Suc n)) (shiftEnv s n)"
  by simp
  with 4 substate_trans have 5:
 "substate s1 (shiftEnv s n)" by blast
  have 6: "toEnvP (shiftEnv s n)"
  proof cases
    assume "n = 0"
    with 1 show ?thesis by auto
  next
    assume "n \<noteq> 0"
    with shiftEnvP_or_emptyState have
"toEnvP (shiftEnv s n) \<or>
 (shiftEnv s n) =  emptyState" by auto
    thus ?thesis
    proof
      assume "toEnvP (shiftEnv s n)"
      thus ?thesis by assumption
    next
      assume "shiftEnv s n = emptyState"
      with 5 have "s1 = emptyState"
        by (cases s1; auto)
      with 1 show ?thesis by auto
    qed
  qed
  assume "(toEnvP (shiftEnv s n) \<and>
     substate s1 (shiftEnv s n) \<and>
     substate (shiftEnv s n) s \<Longrightarrow>
     P (shiftEnv s n))"
  with 3 5 6 shiftEnv_substate ind_step
  show "P (shiftEnv s (Suc n))"
    by auto
qed
qed
qed
qed

end


subsection \<open> UTP theory of Designs \<close>

theory utp_des_theory
  imports utp_des_healths
begin

subsection \<open> UTP theories \<close>

interpretation des_theory: utp_theory_continuous "\<^bold>H"
  rewrites "P \<in> carrier des_theory.thy_order \<longleftrightarrow> P is \<^bold>H"
  and "carrier des_theory.thy_order \<rightarrow> carrier des_theory.thy_order \<equiv> \<lbrakk>\<^bold>H\<rbrakk>\<^sub>H \<rightarrow> \<lbrakk>\<^bold>H\<rbrakk>\<^sub>H"
  and "le des_theory.thy_order = (\<sqsubseteq>)"
  and "eq des_theory.thy_order = (=)"
  and des_top: "des_theory.utp_top = \<top>\<^sub>D"
  and des_bottom: "des_theory.utp_bottom = \<bottom>\<^sub>D"
proof -
  show "utp_theory_continuous \<^bold>H"
    by (unfold_locales, simp_all add: H1_H2_idempotent H1_H2_Continuous)
  then interpret utp_theory_continuous "\<^bold>H"
    by simp
  show "utp_top = \<top>\<^sub>D" "utp_bottom = \<bottom>\<^sub>D"
    by (simp_all add: H1_H2_false healthy_top H1_H2_true healthy_bottom)
qed (simp_all)

interpretation ndes_theory: utp_theory_continuous "\<^bold>N"
  rewrites "P \<in> carrier ndes_theory.thy_order \<longleftrightarrow> P is \<^bold>N"
  and "carrier ndes_theory.thy_order \<rightarrow> carrier ndes_theory.thy_order \<equiv> \<lbrakk>\<^bold>N\<rbrakk>\<^sub>H \<rightarrow> \<lbrakk>\<^bold>N\<rbrakk>\<^sub>H"
  and "le ndes_theory.thy_order = (\<sqsubseteq>)"
  and "eq ndes_theory.thy_order = (=)"
  and ndes_top: "ndes_theory.utp_top = \<top>\<^sub>D"
  and ndes_bottom: "ndes_theory.utp_bottom = \<bottom>\<^sub>D"
proof -
  show "utp_theory_continuous \<^bold>N"
    by (unfold_locales, simp_all add: H1_H3_idempotent H1_H3_Continuous)
  then interpret utp_theory_continuous "\<^bold>N"
    by simp
  show "utp_top = \<top>\<^sub>D" "utp_bottom = \<bottom>\<^sub>D"
    by (simp_all add: H1_H3_false healthy_top H1_H3_true healthy_bottom)
qed (simp_all)

interpretation des_left_unital: utp_theory_left_unital "\<^bold>H" "II\<^sub>D"
  by (unfold_locales, simp_all add: H1_H2_left_unit closure)

interpretation ndes_unital: utp_theory_unital "\<^bold>N" "II\<^sub>D"
  by (unfold_locales, simp_all add: H1_H3_left_unit H1_H3_right_unit closure)

interpretation ndes_kleene: utp_theory_kleene "\<^bold>N" "II\<^sub>D"
  by (unfold_locales, simp add: ndes_top H1_H3_top_left)

abbreviation ndes_star :: "_ \<Rightarrow> _"  ("_\<^sup>\<star>\<^sup>D" [999] 999) where
"P\<^sup>\<star>\<^sup>D \<equiv> ndes_unital.utp_star"

subsection \<open> Galois Connection \<close>

text \<open> Example Galois connection between designs and relations. Based on Jim's example in COMPASS
        deliverable D23.5. \<close>

definition [upred_defs]: "Des(R) = \<^bold>H(\<lceil>R\<rceil>\<^sub>D \<and> $ok\<acute>)"
definition [upred_defs]: "Rel(D) = \<lfloor>D\<lbrakk>true,true/$ok,$ok\<acute>\<rbrakk>\<rfloor>\<^sub>D"

lemma Des_design: "Des(R) = true \<turnstile>\<^sub>r R"
  by (rel_auto)

lemma Rel_design: "Rel(P \<turnstile>\<^sub>r Q) = (P \<Rightarrow> Q)"
  by (rel_auto)

interpretation Des_Rel_coretract:
  coretract "\<^bold>H \<Leftarrow>\<langle>Des,Rel\<rangle>\<Rightarrow> id"
  rewrites
    "\<And> x. x \<in> carrier \<X>\<^bsub>\<^bold>H \<Leftarrow>\<langle>Des,Rel\<rangle>\<Rightarrow> id\<^esub> = (x is \<^bold>H)" and
    "\<And> x. x \<in> carrier \<Y>\<^bsub>\<^bold>H \<Leftarrow>\<langle>Des,Rel\<rangle>\<Rightarrow> id\<^esub> = True" and
    "\<pi>\<^sub>*\<^bsub>\<^bold>H \<Leftarrow>\<langle>Des,Rel\<rangle>\<Rightarrow> id\<^esub> = Des" and
    "\<pi>\<^sup>*\<^bsub>\<^bold>H \<Leftarrow>\<langle>Des,Rel\<rangle>\<Rightarrow> id\<^esub> = Rel" and
    "le \<X>\<^bsub>\<^bold>H \<Leftarrow>\<langle>Des,Rel\<rangle>\<Rightarrow> id\<^esub> = (\<sqsubseteq>)" and
    "le \<Y>\<^bsub>\<^bold>H \<Leftarrow>\<langle>Des,Rel\<rangle>\<Rightarrow> id\<^esub> = (\<sqsubseteq>)"
proof (unfold_locales, simp_all)
  show "\<And>x. x is id"
    by (simp add: Healthy_def)
next
  show "Rel \<in> \<lbrakk>\<^bold>H\<rbrakk>\<^sub>H \<rightarrow> \<lbrakk>id\<rbrakk>\<^sub>H"
    by (auto simp add: Rel_def Healthy_def)
next
  show "Des \<in> \<lbrakk>id\<rbrakk>\<^sub>H \<rightarrow> \<lbrakk>\<^bold>H\<rbrakk>\<^sub>H"
    by (auto simp add: Des_def Healthy_def H1_H2_commute H1_idem H2_idem)
next
  fix R :: "('a, 'b) urel"
  show "R \<sqsubseteq> Rel (Des R)"
    by (simp add: Des_design Rel_design)
next
  fix R :: "('a, 'b) urel" and D :: "('a, 'b) rel_des"
  assume a: "D is \<^bold>H"
  then obtain D\<^sub>1 D\<^sub>2 where D: "D = D\<^sub>1 \<turnstile>\<^sub>r D\<^sub>2"
    by (metis H1_H2_commute H1_H2_is_rdesign H1_idem Healthy_def')
  show "(Rel D \<sqsubseteq> R) = (D \<sqsubseteq> Des R)"
  proof -
    have "(D \<sqsubseteq> Des R) = (D\<^sub>1 \<turnstile>\<^sub>r D\<^sub>2 \<sqsubseteq> true \<turnstile>\<^sub>r R)"
      by (simp add: D Des_design)
    also have "... = `D\<^sub>1 \<and> R \<Rightarrow> D\<^sub>2`"
      by (simp add: rdesign_refinement)
    also have "... = ((D\<^sub>1 \<Rightarrow> D\<^sub>2) \<sqsubseteq> R)"
      by (rel_auto)
    also have "... = (Rel D \<sqsubseteq> R)"
      by (simp add: D Rel_design)
    finally show ?thesis ..
  qed
qed

text \<open> From this interpretation we gain many Galois theorems. Some require simplification to
        remove superfluous assumptions. \<close>

thm Des_Rel_coretract.deflation[simplified]
thm Des_Rel_coretract.inflation
thm Des_Rel_coretract.upper_comp[simplified]
thm Des_Rel_coretract.lower_comp

subsection \<open> Fixed Points \<close>

notation des_theory.utp_lfp ("\<mu>\<^sub>D")
notation des_theory.utp_gfp ("\<nu>\<^sub>D")

notation ndes_theory.utp_lfp ("\<mu>\<^sub>N")
notation ndes_theory.utp_gfp ("\<nu>\<^sub>N")

utp_const des_theory.utp_lfp des_theory.utp_gfp
  ndes_theory.utp_lfp ndes_theory.utp_gfp

syntax
  "_dmu" :: "pttrn \<Rightarrow> logic \<Rightarrow> logic" ("\<mu>\<^sub>D _ \<bullet> _" [0, 10] 10)
  "_dnu" :: "pttrn \<Rightarrow> logic \<Rightarrow> logic" ("\<nu>\<^sub>D _ \<bullet> _" [0, 10] 10)
  "_ndmu" :: "pttrn \<Rightarrow> logic \<Rightarrow> logic" ("\<mu>\<^sub>N _ \<bullet> _" [0, 10] 10)
  "_ndnu" :: "pttrn \<Rightarrow> logic \<Rightarrow> logic" ("\<nu>\<^sub>N _ \<bullet> _" [0, 10] 10)

translations
  "\<mu>\<^sub>D X \<bullet> P" == "\<mu>\<^sub>D (\<lambda> X. P)"
  "\<nu>\<^sub>D X \<bullet> P" == "\<nu>\<^sub>D (\<lambda> X. P)"
  "\<mu>\<^sub>N X \<bullet> P" == "\<mu>\<^sub>N (\<lambda> X. P)"
  "\<nu>\<^sub>N X \<bullet> P" == "\<nu>\<^sub>N (\<lambda> X. P)"

thm des_theory.LFP_unfold
thm des_theory.GFP_unfold

text \<open> Specialise @{thm [source] mu_refine_intro} to designs. \<close>

lemma design_mu_refine_intro:
  assumes "$ok\<acute> \<sharp> C" "$ok\<acute> \<sharp> S" "(C \<turnstile> S) \<sqsubseteq> F(C \<turnstile> S)" "`C \<Rightarrow> (\<mu>\<^sub>D F \<Leftrightarrow> \<nu>\<^sub>D F)`"
  shows "(C \<turnstile> S) \<sqsubseteq> \<mu>\<^sub>D F"
proof -
  from assms have "(C \<turnstile> S) \<sqsubseteq> \<nu>\<^sub>D F"
    by (simp add: design_is_H1_H2 des_theory.GFP_upperbound)
  with assms show ?thesis
    by (rel_auto, metis (no_types, lifting))
qed

lemma rdesign_mu_refine_intro:
  assumes "(C \<turnstile>\<^sub>r S) \<sqsubseteq> F(C \<turnstile>\<^sub>r S)" "`\<lceil>C\<rceil>\<^sub>D \<Rightarrow> (\<mu>\<^sub>D F \<Leftrightarrow> \<nu>\<^sub>D F)`"
  shows "(C \<turnstile>\<^sub>r S) \<sqsubseteq> \<mu>\<^sub>D F"
  using assms by (simp add: rdesign_def design_mu_refine_intro unrest)

lemma H1_H2_mu_refine_intro:
  assumes "P is \<^bold>H" "P \<sqsubseteq> F(P)" "`\<lceil>pre\<^sub>D(P)\<rceil>\<^sub>D \<Rightarrow> (\<mu>\<^sub>D F \<Leftrightarrow> \<nu>\<^sub>D F)`"
  shows "P \<sqsubseteq> \<mu>\<^sub>D F"
  by (metis H1_H2_eq_rdesign Healthy_if assms rdesign_mu_refine_intro)

text \<open> Foundational theorem for recursion introduction using a well-founded relation. Contributed
  by Dr. Yakoub Nemouchi. \<close>

theorem rdesign_mu_wf_refine_intro:
  assumes   WF: "wf R"
    and      M: "Monotonic F"
    and      H: "F \<in> \<lbrakk>\<^bold>H\<rbrakk>\<^sub>H \<rightarrow> \<lbrakk>\<^bold>H\<rbrakk>\<^sub>H"
    and  induct_step:
    "\<And>st. (P \<and> \<lceil>e\<rceil>\<^sub>< =\<^sub>u \<guillemotleft>st\<guillemotright>) \<turnstile>\<^sub>r Q \<sqsubseteq> F ((P \<and> (\<lceil>e\<rceil>\<^sub><, \<guillemotleft>st\<guillemotright>)\<^sub>u \<in>\<^sub>u \<guillemotleft>R\<guillemotright>) \<turnstile>\<^sub>r Q)"
  shows "(P \<turnstile>\<^sub>r Q) \<sqsubseteq> \<mu>\<^sub>D F"
proof -
  {
  fix st
  have "(P \<and> \<lceil>e\<rceil>\<^sub>< =\<^sub>u \<guillemotleft>st\<guillemotright>) \<turnstile>\<^sub>r Q \<sqsubseteq> \<mu>\<^sub>D F"
  using WF proof (induction rule: wf_induct_rule)
    case (less st)
    hence 0: "(P \<and> (\<lceil>e\<rceil>\<^sub><, \<guillemotleft>st\<guillemotright>)\<^sub>u \<in>\<^sub>u \<guillemotleft>R\<guillemotright>) \<turnstile>\<^sub>r Q \<sqsubseteq> \<mu>\<^sub>D F"
      by rel_blast
    from M H
    have 1: "\<mu>\<^sub>D F \<sqsubseteq>  F (\<mu>\<^sub>D F)"
      by (simp add: des_theory.LFP_lemma3 mono_Monotone_utp_order)
    from 0 1 have 2:"(P \<and> (\<lceil>e\<rceil>\<^sub><,\<guillemotleft>st\<guillemotright>)\<^sub>u\<in>\<^sub>u\<guillemotleft>R\<guillemotright>) \<turnstile>\<^sub>r Q \<sqsubseteq> F (\<mu>\<^sub>D F)"
      by simp
    have 3: "F ((P \<and> (\<lceil>e\<rceil>\<^sub><, \<guillemotleft>st\<guillemotright>)\<^sub>u \<in>\<^sub>u \<guillemotleft>R\<guillemotright>) \<turnstile>\<^sub>r Q) \<sqsubseteq> F (\<mu>\<^sub>D F)"
      by (simp add: 0 M monoD)
    have 4:"(P \<and> \<lceil>e\<rceil>\<^sub>< =\<^sub>u \<guillemotleft>st\<guillemotright>) \<turnstile>\<^sub>r Q \<sqsubseteq> \<dots>"
      by (rule induct_step)
    show ?case
      using order_trans[OF 3 4] H M des_theory.LFP_lemma2 dual_order.trans mono_Monotone_utp_order
      by (metis (no_types) partial_object.simps(1) utp_order_def)
  qed
  }
  thus ?thesis
    by (pred_simp)
qed

theorem ndesign_mu_wf_refine_intro':
  assumes   WF: "wf R"
    and      M: "Monotonic F"
    and      H: "F \<in> \<lbrakk>\<^bold>H\<rbrakk>\<^sub>H \<rightarrow> \<lbrakk>\<^bold>H\<rbrakk>\<^sub>H"
    and  induct_step:
    "\<And>st. ((p \<and> e =\<^sub>u \<guillemotleft>st\<guillemotright>) \<turnstile>\<^sub>n Q) \<sqsubseteq> F ((p \<and> (e, \<guillemotleft>st\<guillemotright>)\<^sub>u \<in>\<^sub>u \<guillemotleft>R\<guillemotright>) \<turnstile>\<^sub>n Q)"
  shows "(p \<turnstile>\<^sub>n Q) \<sqsubseteq> \<mu>\<^sub>D F"
  using assms unfolding ndesign_def
  by (rule_tac rdesign_mu_wf_refine_intro[of R F "\<lceil>p\<rceil>\<^sub><" e], simp_all add: alpha)

theorem ndesign_mu_wf_refine_intro:
  assumes   WF: "wf R"
    and      M: "Monotonic F"
    and      H: "F \<in> \<lbrakk>\<^bold>N\<rbrakk>\<^sub>H \<rightarrow> \<lbrakk>\<^bold>N\<rbrakk>\<^sub>H"
    and  induct_step:
    "\<And>st. ((p \<and> e =\<^sub>u \<guillemotleft>st\<guillemotright>) \<turnstile>\<^sub>n Q) \<sqsubseteq> F ((p \<and> (e, \<guillemotleft>st\<guillemotright>)\<^sub>u \<in>\<^sub>u \<guillemotleft>R\<guillemotright>) \<turnstile>\<^sub>n Q)"
  shows "(p \<turnstile>\<^sub>n Q) \<sqsubseteq> \<mu>\<^sub>N F"
proof -
  {
  fix st
  have "(p \<and> e =\<^sub>u \<guillemotleft>st\<guillemotright>) \<turnstile>\<^sub>n Q \<sqsubseteq> \<mu>\<^sub>N F"
  using WF proof (induction rule: wf_induct_rule)
    case (less st)
    hence 0: "(p \<and> (e, \<guillemotleft>st\<guillemotright>)\<^sub>u \<in>\<^sub>u \<guillemotleft>R\<guillemotright>) \<turnstile>\<^sub>n Q \<sqsubseteq> \<mu>\<^sub>N F"
      by rel_blast
    from M H des_theory.LFP_lemma3 mono_Monotone_utp_order
    have 1: "\<mu>\<^sub>N F \<sqsubseteq>  F (\<mu>\<^sub>N F)"
      by (simp add: mono_Monotone_utp_order ndes_theory.LFP_lemma3)
    from 0 1 have 2:"(p \<and> (e, \<guillemotleft>st\<guillemotright>)\<^sub>u\<in>\<^sub>u\<guillemotleft>R\<guillemotright>) \<turnstile>\<^sub>n Q \<sqsubseteq> F (\<mu>\<^sub>N F)"
      by simp
    have 3: "F ((p \<and> (e, \<guillemotleft>st\<guillemotright>)\<^sub>u \<in>\<^sub>u \<guillemotleft>R\<guillemotright>) \<turnstile>\<^sub>n Q) \<sqsubseteq> F (\<mu>\<^sub>N F)"
      by (simp add: 0 M monoD)
    have 4:"(p \<and> e =\<^sub>u \<guillemotleft>st\<guillemotright>) \<turnstile>\<^sub>n Q \<sqsubseteq> \<dots>"
      by (rule induct_step)
    show ?case
      using order_trans[OF 3 4] H M ndes_theory.LFP_lemma2 dual_order.trans mono_Monotone_utp_order
      by (metis (no_types) partial_object.simps(1) utp_order_def)
  qed
  }
  thus ?thesis
    by (pred_simp)
qed

end


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

theory fncall
imports "CParser.CTranslation"
begin

declare sep_conj_ac [simp add]

primrec
  fac :: "nat \<Rightarrow> nat"
where
  "fac 0 = 1"
| "fac (Suc n) = (Suc n) * fac n"

ML \<open>

val ast = IsarInstall.get_Csyntax @{theory} "fncall.c"

\<close>

external_file "fncall.c"
install_C_file "fncall.c"

context fncall
begin

thm "\<Gamma>_def"
thm has_bogus_spec_'proc_def
thm has_bogus_spec_impl
thm f_impl
thm g_impl
thm h_impl
thm i_impl
thm calls_bogus_impl
thm f_body_def
thm g_body_def
thm fact_body_def

thm fact_'proc_def

thm has_bogus_spec_modifies
thm g_modifies
thm f_modifies
thm fact_modifies

term "f_body"
term "\<Gamma>"
term "fact_body"
term "f_'proc"

end

print_locale fncall_global_addresses

print_locale g_modifies
thm g_modifies_def

print_locale f_spec
thm f_spec_def

lemma (in g_modifies)
  shows "\<Gamma> \<turnstile> \<lbrace> \<acute>t_hrs = t \<rbrace> \<acute>ret__int :== PROC g() \<lbrace> \<acute>t_hrs = t \<rbrace>"
apply (hoare_rule HoarePartial.ProcRec1)
apply (vcg spec=modifies)
done

lemma (in fncall_global_addresses) f_impl_result:
  "\<Gamma> f_'proc = Some f_body"
  apply (rule f_impl)
  done

lemma (in fncall_global_addresses) g_spec:
  shows
  "\<Gamma> \<turnstile> \<lbrace> True \<rbrace> \<acute>ret__int :== PROC g() \<lbrace> \<acute>ret__int = 257 \<rbrace>"
  apply vcg
  done

lemma (in fncall_global_addresses) foo:
  shows
   "\<Gamma> \<turnstile> \<lbrace> True \<rbrace> \<acute>ret__int :== PROC f(n) \<lbrace> \<acute>ret__int = 1 \<rbrace>"
apply vcg
apply (simp )
done

lemma (in f_spec) foo :
shows
  "\<Gamma> \<turnstile> \<lbrace> True \<rbrace> \<acute>ret__int :== CALL f(\<acute>n) \<lbrace> \<acute>ret__int = 1 \<rbrace>"

apply vcg
done

lemma (in fncall_global_addresses) bar:
shows "\<Gamma> \<turnstile> \<lbrace> 1\<le> \<acute>n & \<acute>n \<le> 12 \<rbrace> \<acute>ret__int :== CALL fact(\<acute>n) \<lbrace> \<acute>ret__int = of_nat (fac (unat \<acute>n)) \<rbrace>"
apply vcg
apply unat_arith
oops

lemma (in fncall_global_addresses) baz:
shows "\<Gamma> \<turnstile>\<^bsub>/UNIV\<^esub> \<lbrace> \<acute>t_hrs = t \<rbrace> \<acute>ret__int :== PROC i() \<lbrace> \<acute>t_hrs = t \<rbrace>"
apply (hoare_rule HoarePartial.ProcRec1)
apply (vcg spec=modifies)
done

locale ih = i_modifies + h_modifies
lemma (in ih) qux:
shows "\<forall>t. \<Gamma> \<turnstile> \<lbrace>\<acute>t_hrs = t\<rbrace> \<acute>ret__int :== CALL i() \<lbrace> t = \<acute>t_hrs \<rbrace>"
apply vcg
oops

locale ff = f_spec + f_modifies
(* this lemma is bogus, because f does actually modify the globals *)
lemma (in ff) bogus1:
shows "\<forall>t. \<Gamma> \<turnstile> \<lbrace> \<acute>t_hrs = t \<rbrace> \<acute>ret__int :== CALL f(\<acute>n) \<lbrace> t = \<acute>t_hrs \<rbrace>"
apply vcg
apply simp
done

lemma (in has_bogus_spec_spec) bogus2:
shows "\<Gamma> \<turnstile> \<lbrace> \<acute>n = 42 \<rbrace> \<acute>ret__int :== CALL has_bogus_spec() \<lbrace> \<acute>ret__int = 4 \<rbrace>"
apply vcg
done

lemma (in fncall_global_addresses) toldyou:
shows "\<Gamma> \<turnstile> \<lbrace> \<acute>n = 42 \<rbrace> \<acute>ret__int :== CALL has_bogus_spec() \<lbrace> \<acute>ret__int = 3 \<rbrace>"
apply vcg
done

lemma (in has_bogus_spec_spec) bogus3:
shows "\<Gamma> \<turnstile> \<lbrace> \<acute>n = 42 \<rbrace> \<acute>ret__int :== CALL calls_bogus() \<lbrace> \<acute>ret__int = 4 \<rbrace>"
apply vcg
done

end