(******************************************************************************)
(* Project: Isabelle/UTP: Unifying Theories of Programming in Isabelle/HOL    *)
(* File: uvar.thy                                                             *)
(* Authors: Frank Zeyda and Simon Foster (University of York, UK)             *)
(* Emails: frank.zeyda@gmail.com and simon.foster@york.ac.uk                  *)
(******************************************************************************)
(* LAST REVIEWED: 09 Jun 2022 *)

section \<open>Variables\<close>

theory uvar
imports uattrib uconsts uname utype
begin

text \<open>We are going to use the colon for model typing.\<close>

no_notation (ASCII)
  Set.member  ("'(:')") and
  Set.member  ("(_/ : _)" [51, 51] 50)

text \<open>We are going to use the converse symbol for undashing.\<close>

no_notation
  converse  ("(_\<inverse>)" [1000] 999)

default_sort typerep

text \<open>Avoids verbose printing of the prefix in @{text "'a uvar.var"}.\<close>

hide_type (open) var

subsection \<open>Monomorphic Variables\<close>

text \<open>Variables are encoded by records consisting of a name and type.\<close>

record uvar =
  name :: uname
  type :: utype

abbreviation UVAR :: "uvar set" where
"UVAR \<equiv> UNIV"

subsubsection \<open>Constructors\<close>

abbreviation MkVar :: "uname \<Rightarrow> utype \<Rightarrow> uvar" where
"MkVar n t \<equiv> \<lparr>name = n, type = t\<rparr>"

subsubsection \<open>Syntax\<close>

syntax "_MkVar" :: "id \<Rightarrow> type \<Rightarrow> uvar" ("$_:{_}\<^sub>u" [1000, 0] 1000)

translations "$n:{'a}\<^sub>u" \<rightleftharpoons> "(CONST MkVar) \<lfloor>n\<rfloor> UTYPE('a)"

subsubsection \<open>Typed Variables\<close>

definition typed_UVAR :: "'a itself \<Rightarrow> uvar set" where
[simp]: "typed_UVAR (t :: 'a itself) = {v. type v = UTYPE('a)}"

paragraph \<open>Syntax for sets of variables with a fixed type.\<close>

syntax "_UVAR" :: "type \<Rightarrow> uvar set" ("UVAR'(_')")

translations "UVAR('a)" \<rightleftharpoons> "(CONST typed_UVAR) TYPE('a)"

subsubsection \<open>Restrictions\<close>

definition UNDASHED_uvar :: "uvar set" where
[vars]: "UNDASHED_uvar = {v. name v \<in> UNDASHED}"

adhoc_overloading UNDASHED UNDASHED_uvar

definition DASHED_uvar :: "uvar set" where
[vars]: "DASHED_uvar = {v. name v \<in> DASHED}"

adhoc_overloading DASHED DASHED_uvar

subsubsection \<open>Operators\<close>

definition dash_uvar :: "uvar \<Rightarrow> uvar" where
[vars]: "dash_uvar = (name_update dash_uname)"

adhoc_overloading dash dash_uvar

definition undash_uvar :: "uvar \<Rightarrow> uvar" where
[vars]: "undash_uvar = (name_update undash_uname)"

adhoc_overloading undash undash_uvar

subsection \<open>Polymorphic Variables\<close>

typedef (overloaded) 'a var = "UVAR('a)"
apply (rule_tac x = "$x:{'a}\<^sub>u" in exI)
apply (simp)
done

lemmas Abs_var_inject_sym = sym [OF Abs_var_inject]
lemmas Rep_var_inject_sym = sym [OF Rep_var_inject]

text \<open>\fixme{Use the transfer tactic rather than default simplifications?}\<close>

declare Abs_var_inverse [simp, intro]
declare Rep_var_inverse [simp]
declare Abs_var_inject [simp, intro]
declare Rep_var_inject_sym [simp]

text \<open>\fixme{Is there a way to fix the warning about relators below?}\<close>

setup_lifting type_definition_var

subsubsection \<open>Constructors\<close>

lift_definition MkPVar :: "uname \<Rightarrow> 'a itself \<Rightarrow> 'a var"
is "\<lambda> (n :: uname) (t :: 'a itself). MkVar n UTYPE('a)"
apply (simp)
done

subsubsection \<open>Type Erasure and Coercion\<close>

text \<open>Intuitively, type erasure converts polymorphic into model variables.\<close>

notation Rep_var ("_\<down>" [1000] 1000)

text \<open>Type erasure may also be done implicitly by virtue of a coercion.\<close>

declare [[coercion Rep_var]]

declare MkPVar.rep_eq [simp]

subsubsection \<open>Syntax\<close>

text \<open>
  We introduce two notations that subtly differ in terms of their underlying
  encoding. The first one @{text "$n:{'a}"} introduces a hidden free variable
  with the same name as @{text n}. This is useful to harvest HOL type-checking
  in order to type-check polymorphic variables. It also causes unification of
  explicitly written variables and variables introduced implicitly by the HOL
  lifting parser (the latter being defined in the theory @{text ulift}).

  The second notation @{text "$n:{'a}\<hyphen>"}, in contrast, does not introduce a
  free variable but uses a @{term "TYPE('a)"} constant in place of it. This
  is useful in definitions as Isabelle will grumbles about free variables in
  the RHS of a definition.

  To reap the benefit of both approaches, we provide a custom rewrite engine
  that automatically rewrites @{text "$n:{'a}"} terms into @{text "$n:{'a}\<hyphen>"}
  \emph{after} type-checking has taken place. This engine can be disabled but
  usually there is no need for hidden HOL variables to be retained after type
  unification. The notation @{text "$n"} introduces a fresh type variable that
  becomes subject to unification, too.
\<close>

syntax "_MkPVar1" :: "id \<Rightarrow>         'a var" ("$_" [1000] 1000)
syntax "_MkPVar2" :: "id \<Rightarrow> type \<Rightarrow> 'a var" ("$_:{_}"  [1000, 0] 1000)
syntax "_MkPVar3" :: "id \<Rightarrow> type \<Rightarrow> 'a var" ("$_:{_}-" [1000, 0] 1000)

translations "$n" \<rightharpoonup> "(CONST MkPVar) \<lfloor>n\<rfloor> TERM_TYPE(n)"
translations "$n:{'a}" \<rightharpoonup> "(CONST MkPVar) \<lfloor>n\<rfloor> TERM_TYPE(n::'a)"
translations "$n:{'a}" \<leftharpoondown> "(CONST MkPVar) \<lfloor>n\<rfloor> TERM_TYPE(x::'a)"
translations "$n:{'a}-" \<rightleftharpoons> "(CONST MkPVar) \<lfloor>n\<rfloor> TYPE('a)"

paragraph \<open>Post-Processing\<close>

text \<open>
  As explained above, hidden HOL variables are injected when using the syntax
  @{term "$n:{'a}"}; this is purely for unification purposes. The option below
  controls whether they are replace by @{term "TYPE('a)"} constants during a
  custom post-processing rewrite step. Replacement is the default behaviour,
\<close>

ML \<open>
  val (remove_hidden_vars, remove_hidden_vars_setup) =
    Attrib.config_bool @{binding remove_hidden_vars} (K true);
\<close>

setup \<open>remove_hidden_vars_setup\<close>

text \<open>ML file that contains the code for the rewrite engine.\<close>

ML_file "uvar.ML"

text \<open>Configure the custom rewrite step as a term checker.\<close>

setup \<open>
  Context.theory_map (Syntax_Phases.term_check 3
    "remove hidden variables" Var_Rewriter.remove_hidden_vars_tr)
\<close>

subsubsection \<open>Restrictions\<close>

definition UNDASHED_var :: "'a var set" where
[vars]: "UNDASHED_var = {v::'a var. name v \<in> UNDASHED}"

adhoc_overloading UNDASHED UNDASHED_var

definition DASHED_var :: "'a var set" where
[vars]: "DASHED_var = {v::'a var. name v \<in> DASHED}"

adhoc_overloading DASHED DASHED_var

subsubsection \<open>Operators\<close>

definition dash_var :: "'a var \<Rightarrow> 'a var" where
[vars]: "dash_var v = MkPVar (name v)\<acute> TYPE('a)"

adhoc_overloading dash dash_var

definition undash_var :: "'a var \<Rightarrow> 'a var" where
[vars]: "undash_var v = MkPVar (name v)\<inverse> TYPE('a)"

adhoc_overloading undash undash_var

subsection \<open>Proof Support\<close>

text \<open>
  To facilitate proofs about variables, we configure tactics that automatically
  apply transfer laws for the types @{type var}, @{type uvar} and @{type uname}.
  While record-based types already generate the underlying splitting laws, for
  the @{type var} type being defined via a type definition, we make use of the
  utility theory @{text Typedef_extra} which generates those laws for us.
\<close>

subsubsection \<open>Transfer Laws\<close>

text \<open>Using a named attribute supports future extension.\<close>

named_theorems var_transfer "variable transfer"

lemmas var_typedef_transfer =
  type_definition.transfer [OF uvar.type_definition_var]

declare uname.uname.splits [var_transfer]
declare uvar.uvar.splits [var_transfer]
declare var_typedef_transfer [var_transfer]

subsubsection \<open>Proof Methods\<close>

text \<open>The below automates, in particular, laws about variable decorations.\<close>

method var_tac = (clarsimp simp add: var_transfer vars typing fun_eq_iff)
method var_auto = (var_tac; auto)
method var_blast = (var_tac; blast)

subsubsection \<open>Theorems\<close>

lemma p_type_of_Rep_var [simp]:
fixes x :: "'a"
fixes v :: "'a var"
shows "x : (type v\<down>)"
apply (transfer)
apply (simp add: typing)
done

lemma undash_uvar_inv [simp]:
"(v::uvar) \<in> DASHED \<Longrightarrow> v\<inverse>\<acute> = v"
apply (var_tac)
done

lemma dash_uvar_inv [simp]:
"(v::uvar) \<in> UNDASHED \<Longrightarrow> v\<acute>\<inverse> = v"
apply (var_tac)
done

lemma dash_erasure_commutes:
"v\<acute>\<down> = v\<down>\<acute>"
apply (unfold vars)
apply (induct v)
apply (clarsimp)
done
end


theory Temporal_Logics
  imports CTL LTL.LTL LTL_Master_Theorem.Omega_Words_Fun_Stream
begin

lemmas [simp] = holds.simps

lemma suffix_stl:
  "suffix (Suc 0) (snth xs) = snth (stl xs)"
  unfolding suffix_def by auto

lemma suntil_iff_sdrop:
  "(\<phi> suntil \<psi>) xs \<longleftrightarrow> (\<exists>i. \<psi> (sdrop i xs) \<and> (\<forall>j<i. \<phi> (sdrop j xs)))"
proof safe
  show "\<exists>i. \<psi> (sdrop i xs) \<and> (\<forall>j<i. \<phi> (sdrop j xs))" if "(\<phi> suntil \<psi>) xs"
    using that
  proof (induction rule: suntil.induct)
    case (base \<omega>)
    then show ?case
      by force
  next
    case (step \<omega>)
    then obtain i where "\<psi> (sdrop i (stl \<omega>))" "\<forall>j<i. \<phi> (sdrop j (stl \<omega>))"
      by safe
    with \<open>\<phi> \<omega>\<close> have "\<phi> (sdrop j \<omega>)" if "j<i + 1" for j
      using that by (cases j) auto
    with \<open>\<psi> (sdrop i (stl \<omega>))\<close> show ?case
      by (inst_existentials "i + 1") auto
  qed
  show "(\<phi> suntil \<psi>) xs" if "\<psi> (sdrop i xs)" "\<forall>j<i. \<phi> (sdrop j xs)" for i
    using that by (induction i arbitrary: xs; fastforce intro: suntil.intros)
qed

lemma to_stream_suffix_Suc:
  "to_stream (suffix (Suc k) xs) = stl (to_stream (suffix k xs))"
  by (metis add.right_neutral add_Suc_right suffix_stl suffix_suffix
        to_omega_def to_omega_to_stream to_stream_to_omega)

lemma to_stream_stake:
  "sdrop k (to_stream w) = to_stream (suffix k w)"
  by (induction k arbitrary: w) (auto simp: sdrop_stl to_stream_suffix_Suc)

lemma to_omega_suffix[simp]:
  "suffix k (to_omega s) = to_omega (sdrop k s)"
  by auto
term true\<^sub>c
primrec semantics_ltlc' :: "['a word, ('a \<Rightarrow> bool) ltlc] \<Rightarrow> bool" ("_ \<Turnstile>\<^sub>c'' _" [80,80] 80)
where
  "\<xi> \<Turnstile>\<^sub>c' true\<^sub>c = True"
| "\<xi> \<Turnstile>\<^sub>c' false\<^sub>c = False"
| "\<xi> \<Turnstile>\<^sub>c' prop\<^sub>c(q) = (q (\<xi> 0))"
| "\<xi> \<Turnstile>\<^sub>c' not\<^sub>c \<phi> = (\<not> \<xi> \<Turnstile>\<^sub>c' \<phi>)"
| "\<xi> \<Turnstile>\<^sub>c' \<phi> and\<^sub>c \<psi> = (\<xi> \<Turnstile>\<^sub>c' \<phi> \<and> \<xi> \<Turnstile>\<^sub>c' \<psi>)"
| "\<xi> \<Turnstile>\<^sub>c' \<phi> or\<^sub>c \<psi> = (\<xi> \<Turnstile>\<^sub>c' \<phi> \<or> \<xi> \<Turnstile>\<^sub>c' \<psi>)"
| "\<xi> \<Turnstile>\<^sub>c' \<phi> implies\<^sub>c \<psi> = (\<xi> \<Turnstile>\<^sub>c' \<phi> \<longrightarrow> \<xi> \<Turnstile>\<^sub>c' \<psi>)"
| "\<xi> \<Turnstile>\<^sub>c' X\<^sub>c \<phi> = (suffix 1 \<xi> \<Turnstile>\<^sub>c' \<phi>)"
| "\<xi> \<Turnstile>\<^sub>c' F\<^sub>c \<phi> = (\<exists>i. suffix i \<xi> \<Turnstile>\<^sub>c' \<phi>)"
| "\<xi> \<Turnstile>\<^sub>c' G\<^sub>c \<phi> = (\<forall>i. suffix i \<xi> \<Turnstile>\<^sub>c' \<phi>)"
| "\<xi> \<Turnstile>\<^sub>c' \<phi> U\<^sub>c \<psi> = (\<exists>i. suffix i \<xi> \<Turnstile>\<^sub>c' \<psi> \<and> (\<forall>j<i. suffix j \<xi> \<Turnstile>\<^sub>c' \<phi>))"
| "\<xi> \<Turnstile>\<^sub>c' \<phi> R\<^sub>c \<psi> = (\<forall>i. suffix i \<xi> \<Turnstile>\<^sub>c' \<psi> \<or> (\<exists>j<i. suffix j \<xi> \<Turnstile>\<^sub>c' \<phi>))"
| "\<xi> \<Turnstile>\<^sub>c' \<phi> W\<^sub>c \<psi> = (\<forall>i. suffix i \<xi> \<Turnstile>\<^sub>c' \<phi> \<or> (\<exists>j\<le>i. suffix j \<xi> \<Turnstile>\<^sub>c' \<psi>))"
| "\<xi> \<Turnstile>\<^sub>c' \<phi> M\<^sub>c \<psi> = (\<exists>i. suffix i \<xi> \<Turnstile>\<^sub>c' \<phi> \<and> (\<forall>j\<le>i. suffix j \<xi> \<Turnstile>\<^sub>c' \<psi>))"

lemma semantics_ltlc'_sugar [simp]:
  "\<xi> \<Turnstile>\<^sub>c' \<phi> iff\<^sub>c \<psi> = (\<xi> \<Turnstile>\<^sub>c' \<phi> \<longleftrightarrow> \<xi> \<Turnstile>\<^sub>c' \<psi>)"
  "\<xi> \<Turnstile>\<^sub>c' F\<^sub>c \<phi> = \<xi> \<Turnstile>\<^sub>c' (true\<^sub>c U\<^sub>c \<phi>)"
  "\<xi> \<Turnstile>\<^sub>c' G\<^sub>c \<phi> = \<xi> \<Turnstile>\<^sub>c' (false\<^sub>c R\<^sub>c \<phi>)"
  by (auto simp add: Iff_ltlc_def)

definition "language_ltlc' \<phi> \<equiv> {\<xi>. \<xi> \<Turnstile>\<^sub>c' \<phi>}"

fun ltlc_to_pltl :: "('a \<Rightarrow> bool) ltlc \<Rightarrow> 'a pltl"
where
  "ltlc_to_pltl true\<^sub>c = true\<^sub>p"
| "ltlc_to_pltl false\<^sub>c = false\<^sub>p"
| "ltlc_to_pltl (prop\<^sub>c(q)) = atom\<^sub>p(q)"
| "ltlc_to_pltl (not\<^sub>c \<phi>) = not\<^sub>p (ltlc_to_pltl \<phi>)"
| "ltlc_to_pltl (\<phi> and\<^sub>c \<psi>) = (ltlc_to_pltl \<phi>) and\<^sub>p (ltlc_to_pltl \<psi>)"
| "ltlc_to_pltl (\<phi> or\<^sub>c \<psi>) = (ltlc_to_pltl \<phi>) or\<^sub>p (ltlc_to_pltl \<psi>)"
| "ltlc_to_pltl (\<phi> implies\<^sub>c \<psi>) = (ltlc_to_pltl \<phi>) implies\<^sub>p (ltlc_to_pltl \<psi>)"
| "ltlc_to_pltl (X\<^sub>c \<phi>) = X\<^sub>p (ltlc_to_pltl \<phi>)"
| "ltlc_to_pltl (F\<^sub>c \<phi>) = F\<^sub>p (ltlc_to_pltl \<phi>)"
| "ltlc_to_pltl (G\<^sub>c \<phi>) = G\<^sub>p (ltlc_to_pltl \<phi>)"
| "ltlc_to_pltl (\<phi> U\<^sub>c \<psi>) = (ltlc_to_pltl \<phi>) U\<^sub>p (ltlc_to_pltl \<psi>)"
| "ltlc_to_pltl (\<phi> R\<^sub>c \<psi>) = (ltlc_to_pltl \<phi>) R\<^sub>p (ltlc_to_pltl \<psi>)"
| "ltlc_to_pltl (\<phi> W\<^sub>c \<psi>) = (ltlc_to_pltl \<phi>) W\<^sub>p (ltlc_to_pltl \<psi>)"
| "ltlc_to_pltl (\<phi> M\<^sub>c \<psi>) = (ltlc_to_pltl \<phi>) M\<^sub>p (ltlc_to_pltl \<psi>)"

lemma ltlc_to_pltl_semantics [simp]:
  "w \<Turnstile>\<^sub>p ltlc_to_pltl \<phi> \<longleftrightarrow> w \<Turnstile>\<^sub>c' \<phi>"
  by (induction \<phi> arbitrary: w) simp_all

lemma semantics_ltlc'_semantics_ltlc_atoms_iff:
  "w \<Turnstile>\<^sub>c' \<phi> \<longleftrightarrow> (\<lambda>i. {a \<in> atoms_ltlc \<phi>. a (w i)}) \<Turnstile>\<^sub>c \<phi>"
proof -
  have *:
    "(\<lambda>i. {a. (a \<in> atoms_ltlc \<phi>1 \<or> a \<in> atoms_ltlc \<phi>2) \<and> a (w i)}) \<Turnstile>\<^sub>c \<phi>1
    \<longleftrightarrow> ((\<lambda>i. {a \<in> atoms_ltlc \<phi>1. a (w i)}) \<Turnstile>\<^sub>c \<phi>1)" for w :: "nat \<Rightarrow> 'a" and \<phi>1 \<phi>2
    by (rule ltlc_eq_on) (auto simp: pw_eq_on_def)
  have **:
    "(\<lambda>i. {a. (a \<in> atoms_ltlc \<phi>1 \<or> a \<in> atoms_ltlc \<phi>2) \<and> a (w i)}) \<Turnstile>\<^sub>c \<phi>2
    \<longleftrightarrow> ((\<lambda>i. {a \<in> atoms_ltlc \<phi>2. a (w i)}) \<Turnstile>\<^sub>c \<phi>2)"  for w :: "nat \<Rightarrow> 'a" and \<phi>1 \<phi>2
      by (rule ltlc_eq_on) (auto simp: pw_eq_on_def)
  show ?thesis
    by (induction \<phi> arbitrary: w) (simp_all add: suffix_def * **)
qed

lemma semantics_ltlc'_semantics_ltlc_atoms_iff':
  "w \<Turnstile>\<^sub>c' \<phi> \<longleftrightarrow> ((\<lambda>x. {a \<in> atoms_ltlc \<phi>. a x}) o w) \<Turnstile>\<^sub>c \<phi>"
  unfolding comp_def by (rule semantics_ltlc'_semantics_ltlc_atoms_iff)

lemma map_semantics_ltlc_inj:
  assumes "inj f"
  shows "w \<Turnstile>\<^sub>c \<phi> \<longleftrightarrow> (image f o w) \<Turnstile>\<^sub>c map_ltlc f \<phi>"
  using assms unfolding comp_def by (intro map_semantics_ltlc_aux) auto

lemma semantics_ltlc'_abstract:
  assumes "inj abstr" "\<And>x. label x = abstr ` {a \<in> atoms_ltlc \<phi>. a x}"
  shows "w \<Turnstile>\<^sub>c' \<phi> \<longleftrightarrow> (label o w) \<Turnstile>\<^sub>c map_ltlc abstr \<phi>"
  by (subst semantics_ltlc'_semantics_ltlc_atoms_iff')
     (simp add: comp_def assms(2) map_semantics_ltlc_inj[OF \<open>inj abstr\<close>])

context
  includes lifting_syntax
begin

lemma holds_transfer:
  "((R ===> (=)) ===> stream_all2 R ===> (=)) holds holds"
  apply (intro rel_funI)
  subgoal for \<phi> \<psi> xs ys
    by (cases xs; cases ys) (auto dest: rel_funD)
  done

lemma alw_mono1:
  "alw \<phi> xs" if "(stream_all2 R ===> (=)) \<phi> \<psi>" "stream_all2 R xs ys" "alw \<psi> ys"
  using that(2,3)
  by (coinduction arbitrary: xs ys) (use that(1) stream.rel_sel in \<open>auto dest!: rel_funD\<close>)

lemma alw_mono2:
  "alw \<psi> ys" if "(stream_all2 R ===> (=)) \<phi> \<psi>" "stream_all2 R xs ys" "alw \<phi> xs"
  using that(2,3)
  by (coinduction arbitrary: xs ys) (use that(1) stream.rel_sel in \<open>auto dest!: rel_funD\<close>)

lemma alw_transfer':
  "alw x xs = alw y ys" if "(stream_all2 R ===> (=)) x y" "stream_all2 R xs ys"
  using alw_mono1 alw_mono2 that by blast

lemma alw_transfer:
  "((stream_all2 R ===> (=)) ===> stream_all2 R ===> (=)) alw alw"
  by (intro rel_funI) (rule alw_transfer')

lemma nxt_transfer:
  "((stream_all2 R ===> (=)) ===> stream_all2 R ===> (=)) nxt nxt"
  by (intro rel_funI) (simp, meson rel_funD stream.rel_sel)

lemma suntil_mono1:
  "(\<phi> suntil \<psi>) xs"
  if "(stream_all2 R ===> (=)) \<phi> \<phi>'" "(stream_all2 R ===> (=)) \<psi> \<psi>'" "stream_all2 R xs ys"
     "(\<phi>' suntil \<psi>') ys"
  using that(4,3)
proof (induction arbitrary: xs)
  case (base \<omega>)
  then show ?case
    using that(1,2) by (auto dest!: rel_funD intro: suntil.base)
next
  case (step \<omega>)
  from \<open>stream_all2 R xs \<omega>\<close> have "stream_all2 R (stl xs) (stl \<omega>)"
    using stream.rel_sel by auto
  from \<open>\<phi>' \<omega>\<close> \<open>stream_all2 R xs \<omega>\<close> have "\<phi> xs"
    using that(1,2) by (auto dest!: rel_funD)
  moreover from step.IH \<open>stream_all2 R xs \<omega>\<close> have "(\<phi> suntil \<psi>) (stl xs)"
    using stream.rel_sel by auto
  ultimately show ?case ..
qed

lemma suntil_mono2:
  "(\<phi>' suntil \<psi>') ys"
  if "(stream_all2 R ===> (=)) \<phi> \<phi>'" "(stream_all2 R ===> (=)) \<psi> \<psi>'" "stream_all2 R xs ys"
     "(\<phi> suntil \<psi>) xs"
  using that(4,3)
proof (induction arbitrary: ys)
  case (base \<omega>)
  then show ?case
    using that(1,2) by (auto dest!: rel_funD intro: suntil.base)
next
  case (step xs \<omega>)
  from \<open>stream_all2 R xs \<omega>\<close> have "stream_all2 R (stl xs) (stl \<omega>)"
    using stream.rel_sel by auto
  from \<open>\<phi> xs\<close> \<open>stream_all2 R xs \<omega>\<close> have "\<phi>' \<omega>"
    using that(1,2) by (auto dest!: rel_funD)
  moreover from step.IH \<open>stream_all2 R xs \<omega>\<close> have "(\<phi>' suntil \<psi>') (stl \<omega>)"
    using stream.rel_sel by auto
  ultimately show ?case ..
qed

lemma suntil_transfer':
  "(\<phi> suntil \<psi>) xs = (\<phi>' suntil \<psi>') ys"
  if "(stream_all2 R ===> (=)) \<phi> \<phi>'" "(stream_all2 R ===> (=)) \<psi> \<psi>'" "stream_all2 R xs ys"
  using suntil_mono1 suntil_mono2 that by metis

lemma suntil_transfer:
  "((stream_all2 R ===> (=)) ===> (stream_all2 R ===> (=)) ===> stream_all2 R ===> (=))
    Linear_Temporal_Logic_on_Streams.suntil Linear_Temporal_Logic_on_Streams.suntil"
  by (intro rel_funI) (rule suntil_transfer')

lemma ev_mono1:
  "ev \<phi> xs" if "(stream_all2 R ===> (=)) \<phi> \<psi>" "stream_all2 R xs ys" "ev \<psi> ys"
  using that(3,2) by (induction arbitrary: xs; use that(1) stream.rel_sel in \<open>blast dest: rel_funD\<close>)

lemma ev_mono2:
  "ev \<psi> ys" if "(stream_all2 R ===> (=)) \<phi> \<psi>" "stream_all2 R xs ys" "ev \<phi> xs"
  using that(3,2) by (induction arbitrary: ys; use that(1) stream.rel_sel in \<open>blast dest: rel_funD\<close>)

lemma ev_transfer':
  "ev x xs = ev y ys" if "(stream_all2 R ===> (=)) x y" "stream_all2 R xs ys"
  using ev_mono1 ev_mono2 that by blast

lemma ev_transfer:
  "((stream_all2 R ===> (=)) ===> (stream_all2 R ===> (=))) ev ev"
  by (intro rel_funI) (rule ev_transfer')

end

datatype 'a ctl_formula =
  AG "'a ctl_formula" | AX "'a ctl_formula" | EG "'a ctl_formula" | EX "'a ctl_formula" | PropC 'a |
  ImpliesC "'a ctl_formula" "'a ctl_formula" | NotC "'a ctl_formula"

datatype 'a state_formula =
  All "'a path_formula" | Ex "'a path_formula"
| ImpliesS "'a state_formula" "'a state_formula" | NotS "'a state_formula" | PropS 'a
and 'a path_formula =
  G "'a path_formula" | F "'a path_formula"
| X "'a path_formula" | Until "'a path_formula" "'a path_formula"
| ImpliesP "'a path_formula" "'a path_formula" | NotP "'a path_formula" | State "'a state_formula"
| FalseP

fun ctl_to_state where
  "ctl_to_state (AG \<phi>) = All (G (State (ctl_to_state \<phi>)))"
| "ctl_to_state (AX \<phi>) = All (F (State (ctl_to_state \<phi>)))"
| "ctl_to_state (EG \<phi>) = Ex  (G (State (ctl_to_state \<phi>)))"
| "ctl_to_state (ctl_formula.EX \<phi>) = Ex (F (State (ctl_to_state \<phi>)))"
| "ctl_to_state (PropC \<phi>) = PropS \<phi>"
| "ctl_to_state (ImpliesC \<phi> \<psi>) = ImpliesS (ctl_to_state \<phi>) (ctl_to_state \<psi>)"
| "ctl_to_state (NotC \<phi>) = NotS (ctl_to_state \<phi>)"

fun ltlp_to_path where
  "ltlp_to_path false\<^sub>p = FalseP"
| "ltlp_to_path (atom\<^sub>p(\<phi>)) = State (PropS \<phi>)"
| "ltlp_to_path (\<phi> implies\<^sub>p \<psi>) = ImpliesP (ltlp_to_path \<phi>) (ltlp_to_path \<psi>)"
| "ltlp_to_path (X\<^sub>p \<phi>) = X (ltlp_to_path \<phi>)"
| "ltlp_to_path (\<phi> U\<^sub>p \<psi>) = Until (ltlp_to_path \<phi>) (ltlp_to_path \<psi>)"

fun rel_pltl where
  "rel_pltl R false\<^sub>p false\<^sub>p = True"
| "rel_pltl R atom\<^sub>p(x) atom\<^sub>p(y) = R x y"
| "rel_pltl R (x implies\<^sub>p y) (x' implies\<^sub>p y') \<longleftrightarrow> rel_pltl R x x' \<and> rel_pltl R y y'"
| "rel_pltl R (x U\<^sub>p y) (x' U\<^sub>p y') \<longleftrightarrow> rel_pltl R x x' \<and> rel_pltl R y y'"
| "rel_pltl R (X\<^sub>p x) (X\<^sub>p y) \<longleftrightarrow> rel_pltl R x y"
| "rel_pltl _ _ _ = False"

lemma rel_ltlp_to_path:
  "rel_pltl R \<phi> \<psi> \<longleftrightarrow> rel_path_formula R (ltlp_to_path \<phi>) (ltlp_to_path \<psi>)"
  by (induction R \<phi> \<psi> rule: rel_pltl.induct) auto

lemmas ltlp_defs =
  True_ltlp_def Not_ltlp_def And_ltlp_def Or_ltlp_def
  Eventually_ltlp_def Always_ltlp_def Release_ltlp_def WeakUntil_ltlp_def StrongRelease_ltlp_def

text \<open>The converse does not hold!\<close>
lemma rel_ltlc_to_pltl:
  "rel_pltl R (ltlc_to_pltl \<phi>) (ltlc_to_pltl \<psi>)" if "rel_ltlc R \<phi> \<psi>"
  using that by (induction rule: ltlc.rel_induct) (auto simp: ltlp_defs)

context Graph_Defs
begin

fun models_state and models_path where
  "models_state (PropS P) x = P x"
| "models_state (All \<phi>) x = (\<forall>xs. run (x ## xs) \<longrightarrow> models_path \<phi> (x ## xs))"
| "models_state (Ex \<phi>) x = (\<exists>xs. run (x ## xs) \<and> models_path \<phi> (x ## xs))"
| "models_state (ImpliesS \<psi> \<psi>') xs = (models_state \<psi> xs \<longrightarrow> models_state \<psi>' xs)"
| "models_state (NotS \<psi>) xs = (\<not> models_state \<psi> xs)"
| "models_path  (State \<psi>) = holds (models_state \<psi>)"
| "models_path  (G \<psi>) = alw (models_path \<psi>)"
| "models_path  (F \<psi>) = ev (models_path \<psi>)"
| "models_path  (X \<psi>) = nxt (models_path \<psi>)"
| "models_path  (Until \<psi> \<psi>') = models_path \<psi> suntil models_path \<psi>'"
| "models_path  FalseP = (\<lambda>_. False)"
| "models_path  (ImpliesP \<psi> \<psi>') = (\<lambda>xs. models_path \<psi> xs \<longrightarrow> models_path \<psi>' xs)"
| "models_path  (NotP \<psi>) = (\<lambda>xs. \<not> models_path \<psi> xs)"

fun models_ctl where
  "models_ctl (PropC P) = P"
| "models_ctl (AG \<phi>) = Alw_alw (models_ctl \<phi>)"
| "models_ctl (AX \<phi>) = Alw_ev (models_ctl \<phi>)"
| "models_ctl (EG \<phi>) = Ex_alw (models_ctl \<phi>)"
| "models_ctl (ctl_formula.EX \<phi>) = Ex_ev (models_ctl \<phi>)"
| "models_ctl (ImpliesC \<phi> \<psi>) = (\<lambda>x. models_ctl \<phi> x \<longrightarrow> models_ctl \<psi> x)"
| "models_ctl (NotC \<phi>) = (\<lambda>x. \<not> models_ctl \<phi> x)"

fun models_ltlp where
  "models_ltlp false\<^sub>p = (\<lambda>_. False)"
| "models_ltlp (atom\<^sub>p(P)) = holds P"
| "models_ltlp (\<phi> implies\<^sub>p \<psi>) = (\<lambda>x. models_ltlp \<phi> x \<longrightarrow> models_ltlp \<psi> x)"
| "models_ltlp (\<phi> U\<^sub>p \<psi>) = models_ltlp \<phi> suntil models_ltlp \<psi>"
| "models_ltlp (X\<^sub>p \<phi>) = nxt (models_ltlp \<phi>)"

lemma models_ltlp_correct:
  "models_ltlp \<phi> xs \<longleftrightarrow> to_omega xs \<Turnstile>\<^sub>p \<phi>"
  by (induction \<phi> arbitrary: xs; simp add: suntil_iff_sdrop)

definition
  "models_ltlc \<phi> xs = to_omega xs \<Turnstile>\<^sub>c' \<phi>"

lemma models_ltlc_alt_def:
  "models_ltlc \<phi> = models_ltlp (ltlc_to_pltl \<phi>)"
  unfolding models_ltlc_def models_ltlp_correct by simp

theorem ctl_to_state_correct:
  "models_ctl \<phi> = models_state (ctl_to_state \<phi>)"
  by (induction \<phi>) (simp add: Alw_alw_def Alw_ev_def Ex_ev_def Ex_alw_def)+

theorem ltlp_to_path_correct:
  "models_ltlp \<phi> = models_path (ltlp_to_path \<phi>)"
  by (induction \<phi>; simp)

end

context Bisimulation_Invariant
begin

context
  includes lifting_syntax
begin

abbreviation compatible where
  "compatible \<equiv> A_B.equiv' ===> (=)"

abbreviation (input)
  "compatible_op \<equiv> compatible ===> compatible"

abbreviation
  "compatible_path \<equiv> stream_all2 A_B.equiv' ===> (=)"

named_theorems compatible

lemma compatible_opI:
  assumes "\<And>\<phi> \<psi>. compatible \<phi> \<psi> \<Longrightarrow> compatible (\<Phi> \<phi>) (\<Psi> \<psi>)"
  shows "compatible_op \<Phi> \<Psi>"
  using assms unfolding rel_fun_def by auto

lemma compatible_opE:
  assumes "compatible_op \<Phi> \<Psi>" "compatible \<phi> \<psi>"
  shows "compatible (\<Phi> \<phi>) (\<Psi> \<psi>)"
  using assms unfolding rel_fun_def by auto

lemma Ex_ev_compatible[compatible, transfer_rule]:
  "compatible_op A.Ex_ev B.Ex_ev"
  using Ex_ev_iff unfolding rel_fun_def by blast

lemma Alw_ev_compatible[compatible, transfer_rule]:
  "compatible_op A.Alw_ev B.Alw_ev"
  using Alw_ev_iff unfolding rel_fun_def by blast

lemma Not_compatible[compatible]:
  "compatible_op ((\<circ>) Not) ((\<circ>) Not)"
  unfolding rel_fun_def by simp

lemma compatible_op_compI:
  assumes [transfer_rule]: "compatible_op \<Phi> \<Psi>" "compatible_op \<Phi>' \<Psi>'"
  shows "compatible_op (\<Phi> o \<Phi>') (\<Psi> o \<Psi>')"
  by transfer_prover

lemma compatible_op_NotI:
  assumes "compatible_op \<Phi> \<Psi>"
  shows "compatible_op (\<lambda>\<phi> x. \<not> \<Phi> \<phi> x) (\<lambda>\<psi> x. \<not> \<Psi> \<psi> x)"
  by (rule compatible_op_compI[unfolded comp_def],
      rule Not_compatible[unfolded comp_def], rule assms)

lemma
  shows Alw_alw_compatible[compatible, transfer_rule]: "compatible_op A.Alw_alw B.Alw_alw"
    and Ex_alw_compatible[compatible, transfer_rule]:  "compatible_op A.Ex_alw B.Ex_alw"
  unfolding Graph_Defs.Alw_alw_iff Graph_Defs.Ex_alw_iff
  by (rule compatible_op_NotI, rule compatible_op_compI[unfolded comp_def]; (rule compatible))+

lemma conj_compatible:
  "(compatible ===> compatible ===> compatible) (\<lambda>\<phi> \<phi>' x. \<phi> x \<and> \<phi>' x) (\<lambda>\<psi> \<psi>' x. \<psi> x \<and> \<psi>' x)"
  by transfer_prover

lemma implies_compatible:
  "(compatible ===> compatible ===> compatible) (\<lambda>\<phi> \<phi>' x. \<phi> x \<longrightarrow> \<phi>' x) (\<lambda>\<psi> \<psi>' x. \<psi> x \<longrightarrow> \<psi>' x)"
  by transfer_prover

lemma disj_compatible:
  "(compatible ===> compatible ===> compatible) (\<lambda>\<phi> \<phi>' x. \<phi> x \<or> \<phi>' x) (\<lambda>\<psi> \<psi>' x. \<psi> x \<or> \<psi>' x)"
  by transfer_prover

lemma Leadsto_compatible:
  "(compatible ===> compatible ===> compatible) A.leadsto B.leadsto"
  unfolding A.leadsto_def B.leadsto_def by transfer_prover

lemmas [compatible] = implies_compatible[THEN rel_funD]

definition
  "protect x = x"

lemma protect_cong[cong]:
  "protect x = protect x"
  unfolding protect_def ..

lemmas [compatible] = Not_compatible[unfolded comp_def]

lemma CTL_compatible:
  assumes "rel_ctl_formula compatible \<phi> \<psi>"
  shows "compatible (A.models_ctl \<phi>) (B.models_ctl \<psi>)"
  using assms by induction (simp; rule compatible_opE, rule compatible, assumption)+

lemma ctl_star_compatible_aux:
  "(rel_state_formula compatible \<phi> \<phi>' \<longrightarrow> compatible (A.models_state \<phi>) (B.models_state \<phi>'))
\<and> (rel_path_formula compatible \<psi> \<psi>' \<longrightarrow> compatible_path (A.models_path \<psi>) (B.models_path \<psi>'))"
proof (induction rule: state_formula_path_formula.rel_induct)
  case (All a b) \<comment> \<open>State\<close>
  then show ?case
    by - (drule holds_transfer[THEN rel_funD], unfold A.models_path.simps B.models_path.simps)
next
  case (ImpliesS a b) \<comment> \<open>All\<close>
  then show ?case
    apply simp
    apply (intro rel_funI allI iffI impI)
     apply (auto 4 4
        dest!: B_A.simulation_run stream_all2_rotate_1 dest: rel_funD elim: equiv'_rotate_1; fail)
    by (auto 4 4 dest!: A_B.simulation_run dest: rel_funD)
next
  case (NotS a12 b12) \<comment> \<open>Ex\<close>
  then show ?case
    apply simp
    apply (intro rel_funI allI iffI impI)
     apply (smt A_B.simulation_run rel_fun_def stream.rel_sel stream.sel(1) stream.sel(2))
    by (smt B_A.simulation_run equiv'_rotate_1 rel_fun_def stream.rel_inject stream_all2_rotate_1)
next
  case (Until a22 b22) \<comment> \<open>F\<close>
  then show ?case
    by - (drule ev_transfer[THEN rel_funD], unfold A.models_path.simps B.models_path.simps)
next
  case (X a b) \<comment> \<open>G\<close>
  then show ?case
    by - (drule alw_transfer[THEN rel_funD], unfold A.models_path.simps B.models_path.simps)
next
  case (ImpliesP a b) \<comment> \<open>X\<close>
  then show ?case
    by - (drule nxt_transfer[THEN rel_funD], unfold A.models_path.simps B.models_path.simps)
next
  case (NotP a22 b22) \<comment> \<open>Until\<close>
  then show ?case
    by - (drule suntil_transfer[THEN rel_funD, THEN rel_funD],
          unfold A.models_path.simps B.models_path.simps)
qed (simp add: rel_fun_def; fail | auto; fail)+

lemmas models_state_compatible = ctl_star_compatible_aux[THEN conjunct1, rule_format]
   and models_path_compatible  = ctl_star_compatible_aux[THEN conjunct2, rule_format]

lemma
  "(compatible_path ===> compatible_path) alw alw"
  by (rule alw_transfer)

lemma
  "(compatible_path ===> compatible_path) ev ev"
  by (rule ev_transfer)

lemma holds_compatible:
  "(compatible ===> compatible_path) holds holds"
  by (rule holds_transfer)

lemma models_ltlp_compatible:
  assumes "rel_pltl compatible \<psi> \<psi>'"
  shows "compatible_path (A.models_ltlp \<psi>) (B.models_ltlp \<psi>')"
  by (metis assms
      A.ltlp_to_path_correct B.ltlp_to_path_correct models_path_compatible rel_ltlp_to_path)

lemma models_ltlc_compatible:
  assumes "rel_ltlc compatible \<psi> \<psi>'"
  shows "compatible_path (A.models_ltlc \<psi>) (B.models_ltlc \<psi>')"
  using assms unfolding A.models_ltlc_alt_def
  by (intro models_ltlp_compatible) (simp only: rel_ltlc_to_pltl)

end (* Transfer Syntax *)

end (* Bisimulation Invariant *)

lemmas [simp del] = holds.simps

end (* Theory *)


section \<open>Operator Semantics\<close>

theory Values
  imports
    JavaWords
begin

text \<open>
In order to properly implement the IR semantics we first introduce
a type that represents runtime values.
These runtime values represent the full range of primitive types
currently allowed by our semantics, ranging from basic integer types
to object references and arrays.

Note that Java supports 64, 32, 16, 8 signed ints, plus 1 bit (boolean)
ints, and char is 16-bit unsigned.
E.g. an 8-bit stamp has a default range of -128..+127.
And a 1-bit stamp has a default range of -1..0, surprisingly.

During calculations the smaller sizes are sign-extended to 32 bits, but explicit
widening nodes will do that, so most binary calculations should see equal input sizes.

An object reference is an option type where the @{term None} object reference
points to the static fields. This is examined more closely in our
definition of the heap.
\<close>

type_synonym objref = "nat option"

datatype (discs_sels) Value  =
  UndefVal |
  (* IntVal32 "32 word" | *)  (* also used for 16, 8, and 1-bit (boolean) values *)
  (* IntVal64 "64 word" | *)
  (* IntVal IntType int64 |  -- all types smaller than 64 bits are zero-extended *)
  (* or widths: IntVal (ibits:IntWidth) (ival:int64) | *)
  (* or just:   IntVal (ibits:nat) (ival:int64) ? *)
  (* or         IntVal IntWord where IntWord = (nat,int64)? *)
  (* IntValv2 nat bool int64 |   bits, signed, word *)
  IntVal iwidth int64 | (* bits and word because we cannot know sign until do compare! *)
  (* FloatVal float | not supported *)
  ObjRef objref |
  ObjStr string

fun intval_bits :: "Value \<Rightarrow> nat" where
  "intval_bits (IntVal b v) = b"

fun intval_word :: "Value \<Rightarrow> int64" where
  "intval_word (IntVal b v) = v"

text \<open>Converts an integer word into a Java value.\<close>
fun new_int :: "iwidth \<Rightarrow> int64 \<Rightarrow> Value" where
  "new_int b w = IntVal b (take_bit b w)"

text \<open>Converts an integer word into a Java value, iff the two types are equal.\<close>
fun new_int_bin :: "iwidth \<Rightarrow> iwidth \<Rightarrow> int64 \<Rightarrow> Value" where
  "new_int_bin b1 b2 w = (if b1=b2 then new_int b1 w else UndefVal)"

fun wf_bool :: "Value \<Rightarrow> bool" where
  "wf_bool (IntVal b w) = (b = 1)" |
  "wf_bool _ = False"

fun val_to_bool :: "Value \<Rightarrow> bool" where
  "val_to_bool (IntVal b val) = (if val = 0 then False else True)" |
  "val_to_bool val = False"

fun bool_to_val :: "bool \<Rightarrow> Value" where
  "bool_to_val True = (IntVal 32 1)" |
  "bool_to_val False = (IntVal 32 0)"

text \<open>Converts an Isabelle bool into a Java value, iff the two types are equal.\<close>
fun bool_to_val_bin :: "iwidth \<Rightarrow> iwidth \<Rightarrow> bool \<Rightarrow> Value" where
  "bool_to_val_bin t1 t2 b = (if t1 = t2 then bool_to_val b else UndefVal)"

(* Deprecated - just for backwards compatibility. *)
fun is_int_val :: "Value \<Rightarrow> bool" where
  "is_int_val v = is_IntVal v"

lemma neg_one_value[simp]: "new_int b (neg_one b) = IntVal b (mask b)"
  by simp

lemma neg_one_signed[simp]:
  assumes "0 < b"
  shows "int_signed_value b (neg_one b) = -1"
  by (smt (verit, best) assms diff_le_self diff_less int_signed_value.simps less_one mask_eq_take_bit_minus_one neg_one.simps nle_le signed_minus_1 signed_take_bit_of_minus_1 signed_take_bit_take_bit verit_comp_simplify1(1))

subsection \<open>Arithmetic Operators\<close>

text \<open>
We need to introduce arithmetic operations which agree with the JVM.

Within the JVM, bytecode arithmetic operations are performed on 32
or 64 bit integers, unboxing where appropriate.

The following collection of intval functions correspond to the JVM
arithmetic operations.  We merge the 32 and 64 bit operations into
a single function, even though the stamp of each IRNode tells us
exactly what the bit widths will be.  These merged functions
make it easier to do the instantiation of Value as 'plus', etc.
It might be worse for reasoning, because it could cause more case analysis,
but this does not seem to be a problem in practice.
\<close>

(* Corresponds to JVM iadd and ladd instructions. *)
fun intval_add :: "Value \<Rightarrow> Value \<Rightarrow> Value" where
  "intval_add (IntVal b1 v1) (IntVal b2 v2) =
    (if b1 = b2 then IntVal b1 (take_bit b1 (v1+v2)) else UndefVal)" |
  "intval_add _ _ = UndefVal"

(* Corresponds to JVM isub and lsub instructions. *)
fun intval_sub :: "Value \<Rightarrow> Value \<Rightarrow> Value" where
  "intval_sub (IntVal b1 v1) (IntVal b2 v2) = new_int_bin b1 b2 (v1-v2)" |
  "intval_sub _ _ = UndefVal"

(* Corresponds to JVM imul and lmul instructions. *)
fun intval_mul :: "Value \<Rightarrow> Value \<Rightarrow> Value" where
  "intval_mul (IntVal b1 v1) (IntVal b2 v2) = new_int_bin b1 b2 (v1*v2)" |
  "intval_mul _ _ = UndefVal"

(* Java division rounds towards 0, so we use sdiv, not div. *)
(* TODO: find a signed division operator in the Word library? *)
fun intval_div :: "Value \<Rightarrow> Value \<Rightarrow> Value" where
  "intval_div (IntVal b1 v1) (IntVal b2 v2) =
        new_int_bin b1 b2 (word_of_int
           ((int_signed_value b1 v1) sdiv (int_signed_value b2 v2)))" |
  "intval_div _ _ = UndefVal"

(* Java % is a modulo operator that can give negative results, since div rounds towards 0. *)
fun intval_mod :: "Value \<Rightarrow> Value \<Rightarrow> Value" where
  "intval_mod (IntVal b1 v1) (IntVal b2 v2) =
        new_int_bin b1 b2 (word_of_int
           ((int_signed_value b1 v1) smod (int_signed_value b2 v2)))" |
  "intval_mod _ _ = UndefVal"

fun intval_negate :: "Value \<Rightarrow> Value" where
  "intval_negate (IntVal t v) = new_int t (- v)" |
  "intval_negate _ = UndefVal"

fun intval_abs :: "Value \<Rightarrow> Value" where
  "intval_abs (IntVal t v) = new_int t (if int_signed_value t v < 0 then - v else v)" |
  "intval_abs _ = UndefVal"

text \<open>TODO: clarify which widths this should work on: just 1-bit or all?\<close>
fun intval_logic_negation :: "Value \<Rightarrow> Value" where
  "intval_logic_negation (IntVal b v) = new_int b (logic_negate v)" |
  "intval_logic_negation _ = UndefVal"

subsection \<open>Bitwise Operators\<close>

fun intval_and :: "Value \<Rightarrow> Value \<Rightarrow> Value" where
  "intval_and (IntVal b1 v1) (IntVal b2 v2) = new_int_bin b1 b2 (and v1 v2)" |
  "intval_and _ _ = UndefVal"

fun intval_or :: "Value \<Rightarrow> Value \<Rightarrow> Value" where
  "intval_or (IntVal b1 v1) (IntVal b2 v2) = new_int_bin b1 b2 (or v1 v2)" |
  "intval_or _ _ = UndefVal"

fun intval_xor :: "Value \<Rightarrow> Value \<Rightarrow> Value" where
  "intval_xor (IntVal b1 v1) (IntVal b2 v2) = new_int_bin b1 b2 (xor v1 v2)" |
  "intval_xor _ _ = UndefVal"

fun intval_not :: "Value \<Rightarrow> Value" where
  "intval_not (IntVal t v) = new_int t (not v)" |
  "intval_not _ = UndefVal"

subsection \<open>Comparison Operators\<close>

fun intval_short_circuit_or :: "Value \<Rightarrow> Value \<Rightarrow> Value" where
  "intval_short_circuit_or (IntVal b1 v1) (IntVal b2 v2) = bool_to_val_bin b1 b2 (((v1 \<noteq> 0) \<or> (v2 \<noteq> 0)))" |
  "intval_short_circuit_or _ _ = UndefVal"

fun intval_equals :: "Value \<Rightarrow> Value \<Rightarrow> Value" where
  "intval_equals (IntVal b1 v1) (IntVal b2 v2) = bool_to_val_bin b1 b2 (v1 = v2)" |
  "intval_equals _ _ = UndefVal"

fun intval_less_than :: "Value \<Rightarrow> Value \<Rightarrow> Value" where
  "intval_less_than (IntVal b1 v1) (IntVal b2 v2) =
    bool_to_val_bin b1 b2 (int_signed_value b1 v1 < int_signed_value b2 v2)" |
  "intval_less_than _ _ = UndefVal"

fun intval_below :: "Value \<Rightarrow> Value \<Rightarrow> Value" where
  "intval_below (IntVal b1 v1) (IntVal b2 v2) = bool_to_val_bin b1 b2 (v1 < v2)" |
  "intval_below _ _ = UndefVal"

fun intval_conditional :: "Value \<Rightarrow> Value \<Rightarrow> Value \<Rightarrow> Value" where
  "intval_conditional cond tv fv = (if (val_to_bool cond) then tv else fv)"

subsection \<open>Narrowing and Widening Operators\<close>

text \<open>Note: we allow these operators to have inBits=outBits, because the Graal compiler
  also seems to allow that case, even though it should rarely / never arise in practice.\<close>

text \<open>Some sanity checks that $take\_bit N$ and $signed\_take\_bit (N-1)$ match up as expected.\<close>
corollary "sint (signed_take_bit 0 (1 :: int32)) = -1" by code_simp
corollary "sint (signed_take_bit 7 ((256 + 128) :: int64)) = -128" by code_simp
corollary "sint (take_bit 7 ((256 + 128 + 64) :: int64)) = 64" by code_simp
corollary "sint (take_bit 8 ((256 + 128 + 64) :: int64)) = 128 + 64" by code_simp

fun intval_narrow :: "nat \<Rightarrow> nat \<Rightarrow> Value \<Rightarrow> Value" where
  "intval_narrow inBits outBits (IntVal b v) =
     (if inBits = b \<and> 0 < outBits \<and> outBits \<le> inBits \<and> inBits \<le> 64
      then new_int outBits v
      else UndefVal)" |
  "intval_narrow _ _ _ = UndefVal"

fun intval_sign_extend :: "nat \<Rightarrow> nat \<Rightarrow> Value \<Rightarrow> Value" where
  "intval_sign_extend inBits outBits (IntVal b v) =
     (if inBits = b \<and> 0 < inBits \<and> inBits \<le> outBits \<and> outBits \<le> 64
      then new_int outBits (signed_take_bit (inBits - 1) v)
      else UndefVal)" |
  "intval_sign_extend _ _ _ = UndefVal"

fun intval_zero_extend :: "nat \<Rightarrow> nat \<Rightarrow> Value \<Rightarrow> Value" where
  "intval_zero_extend inBits outBits (IntVal b v) =
     (if inBits = b \<and> 0 < inBits \<and> inBits \<le> outBits \<and> outBits \<le> 64
      then new_int outBits (take_bit inBits v)
      else UndefVal)" |
  "intval_zero_extend _ _ _ = UndefVal"

text \<open>Some well-formedness results to help reasoning about narrowing and widening operators\<close>

lemma intval_narrow_ok:
  assumes "intval_narrow inBits outBits val \<noteq> UndefVal"
  shows "0 < outBits \<and> outBits \<le> inBits \<and> inBits \<le> 64 \<and> outBits \<le> 64 \<and>
        is_IntVal val \<and>
        intval_bits val = inBits"
  using assms intval_narrow.simps neq0_conv intval_bits.simps
  by (metis Value.disc(2) intval_narrow.elims le_trans)

lemma intval_sign_extend_ok:
  assumes "intval_sign_extend inBits outBits val \<noteq> UndefVal"
  shows "0 < inBits \<and>
        inBits \<le> outBits \<and> outBits \<le> 64 \<and>
        is_IntVal val \<and>
        intval_bits val = inBits"
  using assms intval_sign_extend.simps neq0_conv
  by (metis intval_bits.simps intval_sign_extend.elims is_IntVal_def)

lemma intval_zero_extend_ok:
  assumes "intval_zero_extend inBits outBits val \<noteq> UndefVal"
  shows "0 < inBits \<and>
        inBits \<le> outBits \<and> outBits \<le> 64 \<and>
        is_IntVal val \<and>
        intval_bits val = inBits"
  using assms intval_sign_extend.simps neq0_conv
  by (metis intval_bits.simps intval_zero_extend.elims is_IntVal_def)

subsection \<open>Bit-Shifting Operators\<close>

text \<open>Note that Java shift operators use unary numeric promotion, unlike other binary
  operators, which use binary numeric promotion (see the Java language reference manual).
  This means that the left-hand input determines the output size, while the
  right-hand input can be any size.\<close>

fun shift_amount :: "iwidth \<Rightarrow> int64 \<Rightarrow> nat" where
  "shift_amount b val = unat (and val (if b = 64 then 0x3F else 0x1f))"

fun intval_left_shift :: "Value \<Rightarrow> Value \<Rightarrow> Value" where
  "intval_left_shift (IntVal b1 v1) (IntVal b2 v2) = new_int b1 (v1 << shift_amount b1 v2)" |
  "intval_left_shift _ _ = UndefVal"

text \<open>Signed shift is more complex, because we sometimes have to insert 1 bits
  at the correct point, which is at b1 bits.\<close>
fun intval_right_shift :: "Value \<Rightarrow> Value \<Rightarrow> Value" where
  "intval_right_shift (IntVal b1 v1) (IntVal b2 v2) =
     (let shift = shift_amount b1 v2 in
      let ones = and (mask b1) (not (mask (b1 - shift) :: int64)) in
      (if int_signed_value b1 v1 < 0
       then new_int b1 (or ones (v1 >>> shift))
       else new_int b1 (v1 >>> shift)))" |
  "intval_right_shift _ _ = UndefVal"

fun intval_uright_shift :: "Value \<Rightarrow> Value \<Rightarrow> Value" where
  "intval_uright_shift (IntVal b1 v1) (IntVal b2 v2) = new_int b1 (v1 >>> shift_amount b1 v2)" |
  "intval_uright_shift _ _ = UndefVal"

subsubsection \<open>Examples of Narrowing / Widening Functions\<close>

experiment begin
corollary "intval_narrow 32 8 (IntVal 32 (256 + 128)) = IntVal 8 128" by simp
corollary "intval_narrow 32 8 (IntVal 32 (-2)) = IntVal 8 254" by simp
corollary "intval_narrow 32 1 (IntVal 32 (-2)) = IntVal 1 0"    by simp
corollary "intval_narrow 32 1 (IntVal 32 (-3)) = IntVal 1 1" by simp

(* now test some 64 bit inputs and outputs *)
corollary "intval_narrow 32 8 (IntVal 64 (-2)) = UndefVal" by simp
corollary "intval_narrow 64 8 (IntVal 32 (-2)) = UndefVal" by simp
corollary "intval_narrow 64 8 (IntVal 64 254) = IntVal 8 254" by simp
corollary "intval_narrow 64 8 (IntVal 64 (256+127)) = IntVal 8 127" by simp
corollary "intval_narrow 64 64 (IntVal 64 (-2)) = IntVal 64 (-2)" by simp
end

experiment begin
corollary "intval_sign_extend 8 32 (IntVal 8 (256 + 128)) = IntVal 32 (2^32 - 128)" by simp
corollary "intval_sign_extend 8 32 (IntVal 8 (-2)) = IntVal 32 (2^32 - 2)" by simp
corollary "intval_sign_extend 1 32 (IntVal 1 (-2)) = IntVal 32 0"    by simp
corollary "intval_sign_extend 1 32 (IntVal 1 (-3)) = IntVal 32 (mask 32)" by simp

(* now test some 64 bit inputs and outputs *)
corollary "intval_sign_extend 8 32 (IntVal 64 254) = UndefVal" by simp
corollary "intval_sign_extend 8 64 (IntVal 32 254) = UndefVal" by simp
corollary "intval_sign_extend 8 64 (IntVal 8 254) = IntVal 64 (-2)" by simp
corollary "intval_sign_extend 32 64 (IntVal 32 (2^32 - 2)) = IntVal 64 (-2)" by simp
corollary "intval_sign_extend 64 64 (IntVal 64 (-2)) = IntVal 64 (-2)" by simp
end

experiment begin
corollary "intval_zero_extend 8 32 (IntVal 8 (256 + 128)) = IntVal 32 128" by simp
corollary "intval_zero_extend 8 32 (IntVal 8 (-2)) = IntVal 32 254" by simp
corollary "intval_zero_extend 1 32 (IntVal 1 (-1)) = IntVal 32 1"   by simp
corollary "intval_zero_extend 1 32 (IntVal 1 (-2)) = IntVal 32 0"   by simp

(* now test some 64 bit inputs and outputs *)
corollary "intval_zero_extend 8 32 (IntVal 64 (-2)) = UndefVal" by simp
corollary "intval_zero_extend 8 64 (IntVal 64 (-2)) = UndefVal" by simp
corollary "intval_zero_extend 8 64 (IntVal 8 254) = IntVal 64 254" by simp
corollary "intval_zero_extend 32 64 (IntVal 32 (2^32 - 2)) = IntVal 64 (2^32 - 2)" by simp
corollary "intval_zero_extend 64 64 (IntVal 64 (-2)) = IntVal 64 (-2)" by simp
end

experiment begin
corollary "intval_right_shift (IntVal 8 128) (IntVal 8 0) = IntVal 8 128" by eval
corollary "intval_right_shift (IntVal 8 128) (IntVal 8 1) = IntVal 8 192" by eval
corollary "intval_right_shift (IntVal 8 128) (IntVal 8 2) = IntVal 8 224" by eval
corollary "intval_right_shift (IntVal 8 128) (IntVal 8 8) = IntVal 8 255" by eval
corollary "intval_right_shift (IntVal 8 128) (IntVal 8 31) = IntVal 8 255" by eval
end

(* ========================================================================
   Commutative and Associative results.  (Not used yet).
   ======================================================================== *)

(* commutative rules to be used when needed. *)
lemma intval_add_sym:
  shows "intval_add a b = intval_add b a"
  by (induction a; induction b; auto simp: add.commute)

(* view dependency graph of code definitions:
code_deps intval_add
*)
(* print all code definitions used by intval_add:
code_thms intval_add
*)

(* Some example tests. *)
lemma "intval_add (IntVal 32 (2^31-1)) (IntVal 32 (2^31-1)) = IntVal 32 (2^32 - 2)"
  by eval
lemma "intval_add (IntVal 64 (2^31-1)) (IntVal 64 (2^31-1)) = IntVal 64 4294967294"
  by eval

end