section \<open> Shallow Expressions with Z \<close>

theory Shallow_Expressions_Z
  imports
    "Shallow-Expressions.Shallow_Expressions"
    "Z_Toolkit.Relation_Lib"
    Collections_Z
    Z_Store
begin

text \<open> Allow substitution maplets to be written in a Z-like way. \<close>

syntax "_zmaplet" :: "[svid, logic] => smaplet" ("_\<Zprime> = _")
translations "_zmaplet x e" => "_smaplet x e"

lemma ref_by_pred_iff [expr_simps]: "P \<sqsubseteq> Q \<longleftrightarrow> `Q \<longrightarrow> P`"
  by (simp add: ref_by_bool_def ref_by_fun_def taut_def)

end


theory "USubst"
imports
  Ordinary_Differential_Equations.ODE_Analysis
  "Ids"
  "Lib"
  "Syntax"
  "Denotational_Semantics"
  "Static_Semantics"
begin
section \<open>Uniform Substitution Definitions\<close>
text\<open>This section defines substitutions and implements the substitution operation.
  Every part of substitution comes in two flavors. The "Nsubst" variant of each function
  returns a term/formula/ode/program which (as encoded in the type system) has less symbols
  that the input. We use this operation when substitution into functions and function-like
  constructs to make it easy to distinguish identifiers that stand for arguments to functions
  from other identifiers. In order to expose a simpler interface, we also have a "subst" variant
  which does not delete variables.

  Naive substitution without side conditions would not always be sound. The various admissibility
  predicates *admit describe conditions under which the various substitution operations are sound.
  \<close>

text\<open>
Explicit data structure for substitutions.

The RHS of a function or predicate substitution is a term or formula
with extra variables, which are used to refer to arguments. \<close>
record ('a, 'b, 'c) subst =
  SFunctions       :: "'a \<rightharpoonup> ('a + 'c, 'c) trm"
  SPredicates      :: "'c \<rightharpoonup> ('a + 'c, 'b, 'c) formula"
  SContexts        :: "'b \<rightharpoonup> ('a, 'b + unit, 'c) formula"
  SPrograms        :: "'c \<rightharpoonup> ('a, 'b, 'c) hp"
  SODEs            :: "'c \<rightharpoonup> ('a, 'c) ODE"

context ids begin
definition NTUadmit :: "('d \<Rightarrow> ('a, 'c) trm) \<Rightarrow> ('a + 'd, 'c) trm \<Rightarrow> ('c + 'c) set \<Rightarrow> bool"
where "NTUadmit \<sigma> \<theta> U \<longleftrightarrow> ((\<Union> i \<in> {i. Inr i \<in> SIGT \<theta>}. FVT (\<sigma> i)) \<inter> U) = {}"

inductive TadmitFFO :: "('d \<Rightarrow> ('a, 'c) trm) \<Rightarrow> ('a + 'd, 'c) trm \<Rightarrow> bool"
where
  TadmitFFO_Diff:"TadmitFFO \<sigma> \<theta> \<Longrightarrow> NTUadmit \<sigma> \<theta> UNIV \<Longrightarrow> TadmitFFO \<sigma> (Differential \<theta>)"
| TadmitFFO_Fun1:"(\<And>i. TadmitFFO \<sigma> (args i)) \<Longrightarrow> TadmitFFO \<sigma> (Function (Inl f) args)"
| TadmitFFO_Fun2:"(\<And>i. TadmitFFO \<sigma> (args i)) \<Longrightarrow> dfree (\<sigma> f) \<Longrightarrow> TadmitFFO \<sigma> (Function (Inr f) args)"
| TadmitFFO_Plus:"TadmitFFO \<sigma> \<theta>1 \<Longrightarrow> TadmitFFO \<sigma> \<theta>2 \<Longrightarrow> TadmitFFO \<sigma> (Plus \<theta>1 \<theta>2)"
| TadmitFFO_Times:"TadmitFFO \<sigma> \<theta>1 \<Longrightarrow> TadmitFFO \<sigma> \<theta>2 \<Longrightarrow> TadmitFFO \<sigma> (Times \<theta>1 \<theta>2)"
| TadmitFFO_Var:"TadmitFFO \<sigma> (Var x)"
| TadmitFFO_Const:"TadmitFFO \<sigma> (Const r)"

inductive_simps
  TadmitFFO_Diff_simps[simp]: "TadmitFFO \<sigma> (Differential \<theta>)"
and TadmitFFO_Fun_simps[simp]: "TadmitFFO \<sigma> (Function f args)"
and TadmitFFO_Plus_simps[simp]: "TadmitFFO \<sigma> (Plus t1 t2)"
and TadmitFFO_Times_simps[simp]: "TadmitFFO \<sigma> (Times t1 t2)"
and TadmitFFO_Var_simps[simp]: "TadmitFFO \<sigma> (Var x)"
and TadmitFFO_Const_simps[simp]: "TadmitFFO \<sigma> (Const r)"

primrec TsubstFO::"('a + 'b, 'c) trm \<Rightarrow> ('b \<Rightarrow> ('a, 'c) trm) \<Rightarrow> ('a, 'c) trm"
where
  "TsubstFO (Var v) \<sigma> = Var v"
| "TsubstFO (DiffVar v) \<sigma> = DiffVar v"
| "TsubstFO (Const r) \<sigma> = Const r"
| "TsubstFO (Function f args) \<sigma> =
    (case f of
      Inl f' \<Rightarrow> Function f' (\<lambda> i. TsubstFO (args i) \<sigma>)
    | Inr f' \<Rightarrow> \<sigma> f')"
| "TsubstFO (Plus \<theta>1 \<theta>2) \<sigma> = Plus (TsubstFO \<theta>1 \<sigma>) (TsubstFO \<theta>2 \<sigma>)"
| "TsubstFO (Times \<theta>1 \<theta>2) \<sigma> = Times (TsubstFO \<theta>1 \<sigma>) (TsubstFO \<theta>2 \<sigma>)"
| "TsubstFO (Differential \<theta>) \<sigma> = Differential (TsubstFO \<theta> \<sigma>)"

inductive TadmitFO :: "('d \<Rightarrow> ('a, 'c) trm) \<Rightarrow> ('a + 'd, 'c) trm \<Rightarrow> bool"
where
  TadmitFO_Diff:"TadmitFFO \<sigma> \<theta> \<Longrightarrow> NTUadmit \<sigma> \<theta> UNIV \<Longrightarrow> dfree (TsubstFO \<theta> \<sigma>) \<Longrightarrow> TadmitFO \<sigma> (Differential \<theta>)"
| TadmitFO_Fun:"(\<And>i. TadmitFO \<sigma> (args i)) \<Longrightarrow> TadmitFO \<sigma> (Function f args)"
| TadmitFO_Plus:"TadmitFO \<sigma> \<theta>1 \<Longrightarrow> TadmitFO \<sigma> \<theta>2 \<Longrightarrow> TadmitFO \<sigma> (Plus \<theta>1 \<theta>2)"
| TadmitFO_Times:"TadmitFO \<sigma> \<theta>1 \<Longrightarrow> TadmitFO \<sigma> \<theta>2 \<Longrightarrow> TadmitFO \<sigma> (Times \<theta>1 \<theta>2)"
| TadmitFO_DiffVar:"TadmitFO \<sigma> (DiffVar x)"
| TadmitFO_Var:"TadmitFO \<sigma> (Var x)"
| TadmitFO_Const:"TadmitFO \<sigma> (Const r)"

inductive_simps
      TadmitFO_Plus_simps[simp]: "TadmitFO \<sigma> (Plus a b)"
  and TadmitFO_Times_simps[simp]: "TadmitFO \<sigma> (Times a b)"
  and TadmitFO_Var_simps[simp]: "TadmitFO \<sigma> (Var x)"
  and TadmitFO_DiffVar_simps[simp]: "TadmitFO \<sigma> (DiffVar x)"
  and TadmitFO_Differential_simps[simp]: "TadmitFO \<sigma> (Differential \<theta>)"
  and TadmitFO_Const_simps[simp]: "TadmitFO \<sigma> (Const r)"
  and TadmitFO_Fun_simps[simp]: "TadmitFO \<sigma> (Function i args)"

primrec Tsubst::"('a, 'c) trm \<Rightarrow> ('a, 'b, 'c) subst \<Rightarrow> ('a, 'c) trm"
where
  "Tsubst (Var x) \<sigma> = Var x"
| "Tsubst (DiffVar x) \<sigma> = DiffVar x"
| "Tsubst (Const r) \<sigma> = Const r"
| "Tsubst (Function f args) \<sigma> = (case SFunctions \<sigma> f of Some f' \<Rightarrow> TsubstFO f' | None \<Rightarrow> Function f) (\<lambda> i. Tsubst (args i) \<sigma>)"
| "Tsubst (Plus \<theta>1 \<theta>2) \<sigma> = Plus (Tsubst \<theta>1 \<sigma>) (Tsubst \<theta>2 \<sigma>)"
| "Tsubst (Times \<theta>1 \<theta>2) \<sigma> = Times (Tsubst \<theta>1 \<sigma>) (Tsubst \<theta>2 \<sigma>)"
| "Tsubst (Differential \<theta>) \<sigma> = Differential (Tsubst \<theta> \<sigma>)"

primrec OsubstFO::"('a + 'b, 'c) ODE \<Rightarrow> ('b \<Rightarrow> ('a, 'c) trm) \<Rightarrow> ('a, 'c) ODE"
where
  "OsubstFO (OVar c) \<sigma> = OVar c"
| "OsubstFO (OSing x \<theta>) \<sigma> = OSing x (TsubstFO \<theta> \<sigma>)"
| "OsubstFO (OProd ODE1 ODE2) \<sigma> = OProd (OsubstFO ODE1 \<sigma>) (OsubstFO ODE2 \<sigma>)"

primrec Osubst::"('a, 'c) ODE \<Rightarrow> ('a, 'b, 'c) subst \<Rightarrow> ('a, 'c) ODE"
where
  "Osubst (OVar c) \<sigma> = (case SODEs \<sigma> c of Some c' \<Rightarrow> c' | None \<Rightarrow> OVar c)"
| "Osubst (OSing x \<theta>) \<sigma> = OSing x (Tsubst \<theta> \<sigma>)"
| "Osubst (OProd ODE1 ODE2) \<sigma> = OProd (Osubst ODE1 \<sigma>) (Osubst ODE2 \<sigma>)"

fun PsubstFO::"('a + 'd, 'b, 'c) hp \<Rightarrow> ('d \<Rightarrow> ('a, 'c) trm) \<Rightarrow> ('a, 'b, 'c) hp"
and FsubstFO::"('a + 'd, 'b, 'c) formula \<Rightarrow> ('d \<Rightarrow> ('a, 'c) trm) \<Rightarrow> ('a, 'b, 'c) formula"
where
  "PsubstFO (Pvar a) \<sigma> = Pvar a"
| "PsubstFO (Assign x \<theta>) \<sigma> = Assign x (TsubstFO \<theta> \<sigma>)"
| "PsubstFO (DiffAssign x \<theta>) \<sigma> = DiffAssign x (TsubstFO \<theta> \<sigma>)"
| "PsubstFO (Test \<phi>) \<sigma> = Test (FsubstFO \<phi> \<sigma>)"
| "PsubstFO (EvolveODE ODE \<phi>) \<sigma> = EvolveODE (OsubstFO ODE \<sigma>) (FsubstFO \<phi> \<sigma>)"
| "PsubstFO (Choice \<alpha> \<beta>) \<sigma> = Choice (PsubstFO \<alpha> \<sigma>) (PsubstFO \<beta> \<sigma>)"
| "PsubstFO (Sequence \<alpha> \<beta>) \<sigma> = Sequence (PsubstFO \<alpha> \<sigma>) (PsubstFO \<beta> \<sigma>)"
| "PsubstFO (Loop \<alpha>) \<sigma> = Loop (PsubstFO \<alpha> \<sigma>)"

| "FsubstFO (Geq \<theta>1 \<theta>2) \<sigma> = Geq (TsubstFO \<theta>1 \<sigma>) (TsubstFO \<theta>2 \<sigma>)"
| "FsubstFO (Prop p args) \<sigma> = Prop p (\<lambda>i. TsubstFO (args i) \<sigma>)"
| "FsubstFO (Not \<phi>) \<sigma> = Not (FsubstFO \<phi> \<sigma>)"
| "FsubstFO (And \<phi> \<psi>) \<sigma> = And (FsubstFO \<phi> \<sigma>) (FsubstFO \<psi> \<sigma>)"
| "FsubstFO (Exists x \<phi>) \<sigma> = Exists x (FsubstFO \<phi> \<sigma>)"
| "FsubstFO (Diamond \<alpha> \<phi>) \<sigma> = Diamond (PsubstFO \<alpha> \<sigma>) (FsubstFO \<phi> \<sigma>)"
| "FsubstFO (InContext C \<phi>) \<sigma> = InContext C (FsubstFO \<phi> \<sigma>)"

fun PPsubst::"('a, 'b + 'd, 'c) hp \<Rightarrow> ('d \<Rightarrow> ('a, 'b, 'c) formula) \<Rightarrow> ('a, 'b, 'c) hp"
and PFsubst::"('a, 'b + 'd, 'c) formula \<Rightarrow> ('d \<Rightarrow> ('a, 'b, 'c) formula) \<Rightarrow> ('a, 'b, 'c) formula"
where
  "PPsubst (Pvar a) \<sigma> = Pvar a"
| "PPsubst (Assign x \<theta>) \<sigma> = Assign x \<theta>"
| "PPsubst (DiffAssign x \<theta>) \<sigma> = DiffAssign x \<theta>"
| "PPsubst (Test \<phi>) \<sigma> = Test (PFsubst \<phi> \<sigma>)"
| "PPsubst (EvolveODE ODE \<phi>) \<sigma> = EvolveODE ODE (PFsubst \<phi> \<sigma>)"
| "PPsubst (Choice \<alpha> \<beta>) \<sigma> = Choice (PPsubst \<alpha> \<sigma>) (PPsubst \<beta> \<sigma>)"
| "PPsubst (Sequence \<alpha> \<beta>) \<sigma> = Sequence (PPsubst \<alpha> \<sigma>) (PPsubst \<beta> \<sigma>)"
| "PPsubst (Loop \<alpha>) \<sigma> = Loop (PPsubst \<alpha> \<sigma>)"

| "PFsubst (Geq \<theta>1 \<theta>2) \<sigma> = (Geq \<theta>1 \<theta>2)"
| "PFsubst (Prop p args) \<sigma> = Prop p args"
| "PFsubst (Not \<phi>) \<sigma> = Not (PFsubst \<phi> \<sigma>)"
| "PFsubst (And \<phi> \<psi>) \<sigma> = And (PFsubst \<phi> \<sigma>) (PFsubst \<psi> \<sigma>)"
| "PFsubst (Exists x \<phi>) \<sigma> = Exists x (PFsubst \<phi> \<sigma>)"
| "PFsubst (Diamond \<alpha> \<phi>) \<sigma> = Diamond (PPsubst \<alpha> \<sigma>) (PFsubst \<phi> \<sigma>)"
| "PFsubst (InContext C \<phi>) \<sigma> = (case C of Inl C' \<Rightarrow> InContext C' (PFsubst \<phi> \<sigma>) | Inr p' \<Rightarrow> \<sigma> p')"

fun Psubst::"('a, 'b, 'c) hp \<Rightarrow> ('a, 'b, 'c) subst \<Rightarrow> ('a, 'b, 'c) hp"
and Fsubst::"('a, 'b, 'c) formula \<Rightarrow> ('a, 'b, 'c) subst \<Rightarrow> ('a, 'b, 'c) formula"
where
  "Psubst (Pvar a) \<sigma> = (case SPrograms \<sigma> a of Some a' \<Rightarrow> a' | None \<Rightarrow> Pvar a)"
| "Psubst (Assign x \<theta>) \<sigma> = Assign x (Tsubst \<theta> \<sigma>)"
| "Psubst (DiffAssign x \<theta>) \<sigma> = DiffAssign x (Tsubst \<theta> \<sigma>)"
| "Psubst (Test \<phi>) \<sigma> = Test (Fsubst \<phi> \<sigma>)"
| "Psubst (EvolveODE ODE \<phi>) \<sigma> = EvolveODE (Osubst ODE \<sigma>) (Fsubst \<phi> \<sigma>)"
| "Psubst (Choice \<alpha> \<beta>) \<sigma> = Choice (Psubst \<alpha> \<sigma>) (Psubst \<beta> \<sigma>)"
| "Psubst (Sequence \<alpha> \<beta>) \<sigma> = Sequence (Psubst \<alpha> \<sigma>) (Psubst \<beta> \<sigma>)"
| "Psubst (Loop \<alpha>) \<sigma> = Loop (Psubst \<alpha> \<sigma>)"

| "Fsubst (Geq \<theta>1 \<theta>2) \<sigma> = Geq (Tsubst \<theta>1 \<sigma>) (Tsubst \<theta>2 \<sigma>)"
| "Fsubst (Prop p args) \<sigma> = (case SPredicates \<sigma> p of Some p' \<Rightarrow> FsubstFO p' (\<lambda>i. Tsubst (args i) \<sigma>) | None \<Rightarrow> Prop p (\<lambda>i. Tsubst (args i) \<sigma>))"
| "Fsubst (Not \<phi>) \<sigma> = Not (Fsubst \<phi> \<sigma>)"
| "Fsubst (And \<phi> \<psi>) \<sigma> = And (Fsubst \<phi> \<sigma>) (Fsubst \<psi> \<sigma>)"
| "Fsubst (Exists x \<phi>) \<sigma> = Exists x (Fsubst \<phi> \<sigma>)"
| "Fsubst (Diamond \<alpha> \<phi>) \<sigma> = Diamond (Psubst \<alpha> \<sigma>) (Fsubst \<phi> \<sigma>)"
| "Fsubst (InContext C \<phi>) \<sigma> = (case SContexts \<sigma> C of Some C' \<Rightarrow> PFsubst C' (\<lambda> _. (Fsubst \<phi> \<sigma>)) | None \<Rightarrow>  InContext C (Fsubst \<phi> \<sigma>))"

definition FVA :: "('a \<Rightarrow> ('a, 'c) trm) \<Rightarrow> ('c + 'c) set"
where "FVA args = (\<Union> i. FVT (args i))"

fun SFV :: "('a, 'b, 'c) subst \<Rightarrow> ('a + 'b + 'c) \<Rightarrow> ('c + 'c) set"
where "SFV \<sigma> (Inl i) = (case SFunctions \<sigma> i of Some f' \<Rightarrow> FVT f' | None \<Rightarrow> {})"
| "SFV \<sigma> (Inr (Inl i)) = {}"
| "SFV \<sigma> (Inr (Inr i)) = (case SPredicates \<sigma> i of Some p' \<Rightarrow> FVF p' | None \<Rightarrow> {})"

definition FVS :: "('a, 'b, 'c) subst \<Rightarrow> ('c + 'c) set"
where "FVS \<sigma> = (\<Union>i. SFV \<sigma> i)"

definition SDom :: "('a, 'b, 'c) subst \<Rightarrow> ('a + 'b + 'c) set"
where "SDom \<sigma> =
 {Inl x | x. x \<in> dom (SFunctions \<sigma>)}
 \<union> {Inr (Inl x) | x. x \<in> dom (SContexts \<sigma>)}
 \<union> {Inr (Inr x) | x. x \<in> dom (SPredicates \<sigma>)}
 \<union> {Inr (Inr x) | x. x \<in> dom (SPrograms \<sigma>)}"

definition TUadmit :: "('a, 'b, 'c) subst \<Rightarrow> ('a, 'c) trm \<Rightarrow> ('c + 'c) set \<Rightarrow> bool"
where "TUadmit \<sigma> \<theta> U \<longleftrightarrow> ((\<Union> i \<in> SIGT \<theta>. (case SFunctions \<sigma> i of Some f' \<Rightarrow> FVT f'  | None \<Rightarrow> {})) \<inter> U) = {}"

inductive Tadmit :: "('a, 'b, 'c) subst \<Rightarrow> ('a, 'c) trm \<Rightarrow> bool"
where
  Tadmit_Diff:"Tadmit \<sigma> \<theta> \<Longrightarrow> TUadmit \<sigma> \<theta> UNIV \<Longrightarrow> Tadmit \<sigma> (Differential \<theta>)"
| Tadmit_Fun1:"(\<And>i. Tadmit \<sigma> (args i)) \<Longrightarrow> SFunctions \<sigma> f = Some f' \<Longrightarrow> TadmitFO (\<lambda> i. Tsubst (args i) \<sigma>) f' \<Longrightarrow> Tadmit \<sigma> (Function f args)"
| Tadmit_Fun2:"(\<And>i. Tadmit \<sigma> (args i)) \<Longrightarrow> SFunctions \<sigma> f = None \<Longrightarrow> Tadmit \<sigma> (Function f args)"
| Tadmit_Plus:"Tadmit \<sigma> \<theta>1 \<Longrightarrow> Tadmit \<sigma> \<theta>2 \<Longrightarrow> Tadmit \<sigma> (Plus \<theta>1 \<theta>2)"
| Tadmit_Times:"Tadmit \<sigma> \<theta>1 \<Longrightarrow> Tadmit \<sigma> \<theta>2 \<Longrightarrow> Tadmit \<sigma> (Times \<theta>1 \<theta>2)"
| Tadmit_DiffVar:"Tadmit \<sigma> (DiffVar x)"
| Tadmit_Var:"Tadmit \<sigma> (Var x)"
| Tadmit_Const:"Tadmit \<sigma> (Const r)"

inductive_simps
      Tadmit_Plus_simps[simp]: "Tadmit \<sigma> (Plus a b)"
  and Tadmit_Times_simps[simp]: "Tadmit \<sigma> (Times a b)"
  and Tadmit_Var_simps[simp]: "Tadmit \<sigma> (Var x)"
  and Tadmit_DiffVar_simps[simp]: "Tadmit \<sigma> (DiffVar x)"
  and Tadmit_Differential_simps[simp]: "Tadmit \<sigma> (Differential \<theta>)"
  and Tadmit_Const_simps[simp]: "Tadmit \<sigma> (Const r)"
  and Tadmit_Fun_simps[simp]: "Tadmit \<sigma> (Function i args)"

inductive TadmitF :: "('a, 'b, 'c) subst \<Rightarrow> ('a, 'c) trm \<Rightarrow> bool"
where
  TadmitF_Diff:"TadmitF \<sigma> \<theta> \<Longrightarrow> TUadmit \<sigma> \<theta> UNIV \<Longrightarrow> TadmitF \<sigma> (Differential \<theta>)"
| TadmitF_Fun1:"(\<And>i. TadmitF \<sigma> (args i)) \<Longrightarrow> SFunctions \<sigma> f = Some f' \<Longrightarrow> (\<And>i. dfree (Tsubst (args i) \<sigma>)) \<Longrightarrow> TadmitFFO (\<lambda> i. Tsubst (args i) \<sigma>) f' \<Longrightarrow> TadmitF \<sigma> (Function f args)"
| TadmitF_Fun2:"(\<And>i. TadmitF \<sigma> (args i)) \<Longrightarrow> SFunctions \<sigma> f = None \<Longrightarrow> TadmitF \<sigma> (Function f args)"
| TadmitF_Plus:"TadmitF \<sigma> \<theta>1 \<Longrightarrow> TadmitF \<sigma> \<theta>2 \<Longrightarrow> TadmitF \<sigma> (Plus \<theta>1 \<theta>2)"
| TadmitF_Times:"TadmitF \<sigma> \<theta>1 \<Longrightarrow> TadmitF \<sigma> \<theta>2 \<Longrightarrow> TadmitF \<sigma> (Times \<theta>1 \<theta>2)"
| TadmitF_DiffVar:"TadmitF \<sigma> (DiffVar x)"
| TadmitF_Var:"TadmitF \<sigma> (Var x)"
| TadmitF_Const:"TadmitF \<sigma> (Const r)"

inductive_simps
      TadmitF_Plus_simps[simp]: "TadmitF \<sigma> (Plus a b)"
  and TadmitF_Times_simps[simp]: "TadmitF \<sigma> (Times a b)"
  and TadmitF_Var_simps[simp]: "TadmitF \<sigma> (Var x)"
  and TadmitF_DiffVar_simps[simp]: "TadmitF \<sigma> (DiffVar x)"
  and TadmitF_Differential_simps[simp]: "TadmitF \<sigma> (Differential \<theta>)"
  and TadmitF_Const_simps[simp]: "TadmitF \<sigma> (Const r)"
  and TadmitF_Fun_simps[simp]: "TadmitF \<sigma> (Function i args)"

inductive Oadmit:: "('a, 'b, 'c) subst \<Rightarrow> ('a, 'c) ODE \<Rightarrow> ('c + 'c) set \<Rightarrow> bool"
where
  Oadmit_Var:"Oadmit \<sigma> (OVar c) U"
| Oadmit_Sing:"TUadmit \<sigma> \<theta> U \<Longrightarrow> TadmitF \<sigma> \<theta> \<Longrightarrow> Oadmit \<sigma> (OSing x \<theta>) U"
| Oadmit_Prod:"Oadmit \<sigma> ODE1 U \<Longrightarrow> Oadmit \<sigma> ODE2 U \<Longrightarrow> ODE_dom (Osubst ODE1 \<sigma>) \<inter> ODE_dom (Osubst ODE2 \<sigma>) = {} \<Longrightarrow> Oadmit \<sigma> (OProd ODE1 ODE2) U"

inductive_simps
      Oadmit_Var_simps[simp]: "Oadmit \<sigma> (OVar c) U"
  and Oadmit_Sing_simps[simp]: "Oadmit \<sigma> (OSing x e) U"
  and Oadmit_Prod_simps[simp]: "Oadmit \<sigma> (OProd ODE1 ODE2) U"

definition PUadmit :: "('a, 'b, 'c) subst \<Rightarrow> ('a, 'b, 'c) hp \<Rightarrow> ('c + 'c) set \<Rightarrow> bool"
where "PUadmit \<sigma> \<theta> U \<longleftrightarrow> ((\<Union> i \<in> (SDom \<sigma> \<inter> SIGP \<theta>).  SFV \<sigma> i) \<inter> U) = {}"

definition FUadmit :: "('a, 'b, 'c) subst \<Rightarrow> ('a, 'b, 'c) formula \<Rightarrow> ('c + 'c) set \<Rightarrow> bool"
where "FUadmit \<sigma> \<theta> U \<longleftrightarrow> ((\<Union> i \<in> (SDom \<sigma> \<inter> SIGF \<theta>).  SFV \<sigma> i) \<inter> U) = {}"

definition OUadmitFO :: "('d \<Rightarrow> ('a, 'c) trm) \<Rightarrow> ('a + 'd,  'c) ODE \<Rightarrow> ('c + 'c) set \<Rightarrow> bool"
where "OUadmitFO \<sigma> \<theta> U \<longleftrightarrow> ((\<Union> i \<in> {i. Inl (Inr i) \<in> SIGO \<theta>}. FVT (\<sigma> i)) \<inter> U) = {}"

inductive OadmitFO :: "('d \<Rightarrow> ('a, 'c) trm) \<Rightarrow> ('a + 'd,  'c) ODE \<Rightarrow> ('c + 'c) set \<Rightarrow> bool"
where
  OadmitFO_OVar:"OUadmitFO \<sigma> (OVar c) U \<Longrightarrow> OadmitFO \<sigma> (OVar c) U"
| OadmitFO_OSing:"OUadmitFO \<sigma> (OSing x \<theta>) U \<Longrightarrow> TadmitFFO \<sigma> \<theta> \<Longrightarrow> OadmitFO \<sigma> (OSing x \<theta>) U"
| OadmitFO_OProd:"OadmitFO \<sigma> ODE1 U \<Longrightarrow> OadmitFO \<sigma> ODE2 U \<Longrightarrow> OadmitFO \<sigma> (OProd ODE1 ODE2) U"

inductive_simps
      OadmitFO_OVar_simps[simp]: "OadmitFO \<sigma> (OVar a) U"
  and OadmitFO_OProd_simps[simp]: "OadmitFO \<sigma> (OProd ODE1 ODE2) U"
  and OadmitFO_OSing_simps[simp]: "OadmitFO \<sigma> (OSing x e) U"

definition FUadmitFO :: "('d \<Rightarrow> ('a, 'c) trm) \<Rightarrow> ('a + 'd, 'b, 'c) formula \<Rightarrow> ('c + 'c) set \<Rightarrow> bool"
where "FUadmitFO \<sigma> \<theta> U \<longleftrightarrow> ((\<Union> i \<in> {i. Inl (Inr i) \<in> SIGF \<theta>}. FVT (\<sigma> i)) \<inter> U) = {}"

definition PUadmitFO :: "('d \<Rightarrow> ('a, 'c) trm) \<Rightarrow> ('a + 'd, 'b, 'c) hp \<Rightarrow> ('c + 'c) set \<Rightarrow> bool"
where "PUadmitFO \<sigma> \<theta> U \<longleftrightarrow> ((\<Union> i  \<in> {i. Inl (Inr i) \<in> SIGP \<theta>}. FVT (\<sigma> i)) \<inter> U) = {}"

inductive NPadmit :: "('d \<Rightarrow> ('a, 'c) trm) \<Rightarrow> ('a + 'd, 'b, 'c) hp \<Rightarrow> bool"
and NFadmit :: "('d \<Rightarrow> ('a, 'c) trm) \<Rightarrow> ('a + 'd, 'b, 'c) formula \<Rightarrow> bool"
where
  NPadmit_Pvar:"NPadmit \<sigma> (Pvar a)"
| NPadmit_Sequence:"NPadmit \<sigma> a \<Longrightarrow> NPadmit \<sigma> b \<Longrightarrow> PUadmitFO \<sigma> b (BVP (PsubstFO a \<sigma>))\<Longrightarrow> hpsafe (PsubstFO a \<sigma>) \<Longrightarrow> NPadmit \<sigma> (Sequence a b)"
| NPadmit_Loop:"NPadmit \<sigma> a \<Longrightarrow> PUadmitFO \<sigma> a (BVP (PsubstFO a \<sigma>)) \<Longrightarrow> hpsafe (PsubstFO a \<sigma>) \<Longrightarrow> NPadmit \<sigma> (Loop a)"
| NPadmit_ODE:"OadmitFO \<sigma> ODE (BVO ODE) \<Longrightarrow> NFadmit \<sigma> \<phi> \<Longrightarrow> FUadmitFO \<sigma> \<phi> (BVO ODE) \<Longrightarrow> fsafe (FsubstFO \<phi> \<sigma>) \<Longrightarrow> osafe (OsubstFO ODE \<sigma>) \<Longrightarrow> NPadmit \<sigma> (EvolveODE ODE \<phi>)"
| NPadmit_Choice:"NPadmit \<sigma> a \<Longrightarrow> NPadmit \<sigma> b \<Longrightarrow> NPadmit \<sigma> (Choice a b)"
| NPadmit_Assign:"TadmitFO \<sigma> \<theta> \<Longrightarrow> NPadmit \<sigma> (Assign x \<theta>)"
| NPadmit_DiffAssign:"TadmitFO \<sigma> \<theta> \<Longrightarrow> NPadmit \<sigma> (DiffAssign x \<theta>)"
| NPadmit_Test:"NFadmit \<sigma> \<phi> \<Longrightarrow> NPadmit \<sigma> (Test \<phi>)"

| NFadmit_Geq:"TadmitFO \<sigma> \<theta>1 \<Longrightarrow> TadmitFO \<sigma> \<theta>2 \<Longrightarrow> NFadmit \<sigma> (Geq \<theta>1 \<theta>2)"
| NFadmit_Prop:"(\<And>i. TadmitFO \<sigma> (args i)) \<Longrightarrow> NFadmit \<sigma> (Prop f args)"
| NFadmit_Not:"NFadmit \<sigma> \<phi> \<Longrightarrow> NFadmit \<sigma> (Not \<phi>)"
| NFadmit_And:"NFadmit \<sigma> \<phi> \<Longrightarrow> NFadmit \<sigma> \<psi> \<Longrightarrow> NFadmit \<sigma> (And \<phi> \<psi>)"
| NFadmit_Exists:"NFadmit \<sigma> \<phi> \<Longrightarrow> FUadmitFO \<sigma> \<phi> {Inl x} \<Longrightarrow> NFadmit \<sigma> (Exists x \<phi>)"
| NFadmit_Diamond:"NFadmit \<sigma> \<phi> \<Longrightarrow> NPadmit \<sigma> a \<Longrightarrow> FUadmitFO \<sigma> \<phi> (BVP (PsubstFO a \<sigma>)) \<Longrightarrow> hpsafe (PsubstFO a \<sigma>) \<Longrightarrow> NFadmit \<sigma> (Diamond a \<phi>)"
| NFadmit_Context:"NFadmit \<sigma> \<phi> \<Longrightarrow> FUadmitFO \<sigma> \<phi> UNIV \<Longrightarrow> NFadmit \<sigma> (InContext C \<phi>)"

inductive_simps
      NPadmit_Pvar_simps[simp]: "NPadmit \<sigma> (Pvar a)"
  and NPadmit_Sequence_simps[simp]: "NPadmit \<sigma> (a ;; b)"
  and NPadmit_Loop_simps[simp]: "NPadmit \<sigma> (a**)"
  and NPadmit_ODE_simps[simp]: "NPadmit \<sigma> (EvolveODE ODE p)"
  and NPadmit_Choice_simps[simp]: "NPadmit \<sigma> (a \<union>\<union> b)"
  and NPadmit_Assign_simps[simp]: "NPadmit \<sigma> (Assign x e)"
  and NPadmit_DiffAssign_simps[simp]: "NPadmit \<sigma> (DiffAssign x e)"
  and NPadmit_Test_simps[simp]: "NPadmit \<sigma> (? p)"

  and NFadmit_Geq_simps[simp]: "NFadmit \<sigma> (Geq t1 t2)"
  and NFadmit_Prop_simps[simp]: "NFadmit \<sigma> (Prop p args)"
  and NFadmit_Not_simps[simp]: "NFadmit \<sigma> (Not p)"
  and NFadmit_And_simps[simp]: "NFadmit \<sigma> (And p q)"
  and NFadmit_Exists_simps[simp]: "NFadmit \<sigma> (Exists x p)"
  and NFadmit_Diamond_simps[simp]: "NFadmit \<sigma> (Diamond a p)"
  and NFadmit_Context_simps[simp]: "NFadmit \<sigma> (InContext C p)"

definition PFUadmit :: "('d \<Rightarrow> ('a, 'b, 'c) formula) \<Rightarrow> ('a, 'b + 'd, 'c) formula \<Rightarrow> ('c + 'c) set \<Rightarrow> bool"
where "PFUadmit \<sigma> \<theta> U \<longleftrightarrow> True"

definition PPUadmit :: "('d \<Rightarrow> ('a, 'b, 'c) formula) \<Rightarrow> ('a, 'b + 'd, 'c) hp \<Rightarrow> ('c + 'c) set \<Rightarrow> bool"
where "PPUadmit \<sigma> \<theta> U \<longleftrightarrow> ((\<Union> i. FVF (\<sigma> i)) \<inter> U) = {}"

inductive PPadmit:: "('d \<Rightarrow> ('a, 'b, 'c) formula) \<Rightarrow> ('a, 'b + 'd, 'c) hp \<Rightarrow> bool"
and PFadmit:: "('d \<Rightarrow> ('a, 'b, 'c) formula) \<Rightarrow> ('a, 'b + 'd, 'c) formula \<Rightarrow> bool"
where
  PPadmit_Pvar:"PPadmit \<sigma> (Pvar a)"
| PPadmit_Sequence:"PPadmit \<sigma> a \<Longrightarrow> PPadmit \<sigma> b \<Longrightarrow> PPUadmit \<sigma> b (BVP (PPsubst a \<sigma>))\<Longrightarrow> hpsafe (PPsubst a \<sigma>) \<Longrightarrow> PPadmit \<sigma> (Sequence a b)"
| PPadmit_Loop:"PPadmit \<sigma> a \<Longrightarrow> PPUadmit \<sigma> a (BVP (PPsubst a \<sigma>)) \<Longrightarrow> hpsafe (PPsubst a \<sigma>) \<Longrightarrow> PPadmit \<sigma> (Loop a)"
| PPadmit_ODE:"PFadmit \<sigma> \<phi> \<Longrightarrow> PFUadmit \<sigma> \<phi> (BVO ODE) \<Longrightarrow> PPadmit \<sigma> (EvolveODE ODE \<phi>)"
| PPadmit_Choice:"PPadmit \<sigma> a \<Longrightarrow> PPadmit \<sigma> b \<Longrightarrow> PPadmit \<sigma> (Choice a b)"
| PPadmit_Assign:"PPadmit \<sigma> (Assign x \<theta>)"
| PPadmit_DiffAssign:"PPadmit \<sigma> (DiffAssign x \<theta>)"
| PPadmit_Test:"PFadmit \<sigma> \<phi> \<Longrightarrow> PPadmit \<sigma> (Test \<phi>)"

| PFadmit_Geq:"PFadmit \<sigma> (Geq \<theta>1 \<theta>2)"
| PFadmit_Prop:"PFadmit \<sigma> (Prop f args)"
| PFadmit_Not:"PFadmit \<sigma> \<phi> \<Longrightarrow> PFadmit \<sigma> (Not \<phi>)"
| PFadmit_And:"PFadmit \<sigma> \<phi> \<Longrightarrow> PFadmit \<sigma> \<psi> \<Longrightarrow> PFadmit \<sigma> (And \<phi> \<psi>)"
| PFadmit_Exists:"PFadmit \<sigma> \<phi> \<Longrightarrow> PFUadmit \<sigma> \<phi> {Inl x} \<Longrightarrow> PFadmit \<sigma> (Exists x \<phi>)"
| PFadmit_Diamond:"PFadmit \<sigma> \<phi> \<Longrightarrow> PPadmit \<sigma> a \<Longrightarrow> PFUadmit \<sigma> \<phi> (BVP (PPsubst a \<sigma>)) \<Longrightarrow> PFadmit \<sigma> (Diamond a \<phi>)"
| PFadmit_Context:"PFadmit \<sigma> \<phi> \<Longrightarrow> PFUadmit \<sigma> \<phi> UNIV \<Longrightarrow> PFadmit \<sigma> (InContext C \<phi>)"

inductive_simps
      PPadmit_Pvar_simps[simp]: "PPadmit \<sigma> (Pvar a)"
  and PPadmit_Sequence_simps[simp]: "PPadmit \<sigma> (a ;; b)"
  and PPadmit_Loop_simps[simp]: "PPadmit \<sigma> (a**)"
  and PPadmit_ODE_simps[simp]: "PPadmit \<sigma> (EvolveODE ODE p)"
  and PPadmit_Choice_simps[simp]: "PPadmit \<sigma> (a \<union>\<union> b)"
  and PPadmit_Assign_simps[simp]: "PPadmit \<sigma> (Assign x e)"
  and PPadmit_DiffAssign_simps[simp]: "PPadmit \<sigma> (DiffAssign x e)"
  and PPadmit_Test_simps[simp]: "PPadmit \<sigma> (? p)"

  and PFadmit_Geq_simps[simp]: "PFadmit \<sigma> (Geq t1 t2)"
  and PFadmit_Prop_simps[simp]: "PFadmit \<sigma> (Prop p args)"
  and PFadmit_Not_simps[simp]: "PFadmit \<sigma> (Not p)"
  and PFadmit_And_simps[simp]: "PFadmit \<sigma> (And p q)"
  and PFadmit_Exists_simps[simp]: "PFadmit \<sigma> (Exists x p)"
  and PFadmit_Diamond_simps[simp]: "PFadmit \<sigma> (Diamond a p)"
  and PFadmit_Context_simps[simp]: "PFadmit \<sigma> (InContext C p)"

inductive Padmit:: "('a, 'b, 'c) subst \<Rightarrow> ('a, 'b, 'c) hp \<Rightarrow> bool"
and Fadmit:: "('a, 'b, 'c) subst \<Rightarrow> ('a, 'b, 'c) formula \<Rightarrow> bool"
where
  Padmit_Pvar:"Padmit \<sigma> (Pvar a)"
| Padmit_Sequence:"Padmit \<sigma> a \<Longrightarrow> Padmit \<sigma> b \<Longrightarrow> PUadmit \<sigma> b (BVP (Psubst a \<sigma>))\<Longrightarrow> hpsafe (Psubst a \<sigma>) \<Longrightarrow> Padmit \<sigma> (Sequence a b)"
| Padmit_Loop:"Padmit \<sigma> a \<Longrightarrow> PUadmit \<sigma> a (BVP (Psubst a \<sigma>)) \<Longrightarrow> hpsafe (Psubst a \<sigma>) \<Longrightarrow> Padmit \<sigma> (Loop a)"
| Padmit_ODE:"Oadmit \<sigma> ODE (BVO ODE) \<Longrightarrow> Fadmit \<sigma> \<phi> \<Longrightarrow> FUadmit \<sigma> \<phi> (BVO ODE) \<Longrightarrow> Padmit \<sigma> (EvolveODE ODE \<phi>)"
| Padmit_Choice:"Padmit \<sigma> a \<Longrightarrow> Padmit \<sigma> b \<Longrightarrow> Padmit \<sigma> (Choice a b)"
| Padmit_Assign:"Tadmit \<sigma> \<theta> \<Longrightarrow> Padmit \<sigma> (Assign x \<theta>)"
| Padmit_DiffAssign:"Tadmit \<sigma> \<theta> \<Longrightarrow> Padmit \<sigma> (DiffAssign x \<theta>)"
| Padmit_Test:"Fadmit \<sigma> \<phi> \<Longrightarrow> Padmit \<sigma> (Test \<phi>)"

| Fadmit_Geq:"Tadmit \<sigma> \<theta>1 \<Longrightarrow> Tadmit \<sigma> \<theta>2 \<Longrightarrow> Fadmit \<sigma> (Geq \<theta>1 \<theta>2)"
| Fadmit_Prop1:"(\<And>i. Tadmit \<sigma> (args i)) \<Longrightarrow> SPredicates \<sigma> p = Some p' \<Longrightarrow> NFadmit (\<lambda> i. Tsubst (args i) \<sigma>) p' \<Longrightarrow> (\<And>i. dsafe (Tsubst (args i) \<sigma>))\<Longrightarrow> Fadmit \<sigma> (Prop p args)"
| Fadmit_Prop2:"(\<And>i. Tadmit \<sigma> (args i)) \<Longrightarrow> SPredicates \<sigma> p = None \<Longrightarrow> Fadmit \<sigma> (Prop p args)"
| Fadmit_Not:"Fadmit \<sigma> \<phi> \<Longrightarrow> Fadmit \<sigma> (Not \<phi>)"
| Fadmit_And:"Fadmit \<sigma> \<phi> \<Longrightarrow> Fadmit \<sigma> \<psi> \<Longrightarrow> Fadmit \<sigma> (And \<phi> \<psi>)"
| Fadmit_Exists:"Fadmit \<sigma> \<phi> \<Longrightarrow> FUadmit \<sigma> \<phi> {Inl x} \<Longrightarrow> Fadmit \<sigma> (Exists x \<phi>)"
| Fadmit_Diamond:"Fadmit \<sigma> \<phi> \<Longrightarrow> Padmit \<sigma> a \<Longrightarrow> FUadmit \<sigma> \<phi> (BVP (Psubst a \<sigma>)) \<Longrightarrow> hpsafe (Psubst a \<sigma>) \<Longrightarrow> Fadmit \<sigma> (Diamond a \<phi>)"
| Fadmit_Context1:"Fadmit \<sigma> \<phi> \<Longrightarrow> FUadmit \<sigma> \<phi> UNIV \<Longrightarrow> SContexts \<sigma> C = Some C' \<Longrightarrow> PFadmit (\<lambda> _. Fsubst \<phi> \<sigma>) C' \<Longrightarrow> fsafe(Fsubst \<phi> \<sigma>) \<Longrightarrow> Fadmit \<sigma> (InContext C \<phi>)"
| Fadmit_Context2:"Fadmit \<sigma> \<phi> \<Longrightarrow> FUadmit \<sigma> \<phi> UNIV \<Longrightarrow> SContexts \<sigma> C = None \<Longrightarrow> Fadmit \<sigma> (InContext C \<phi>)"

inductive_simps
      Padmit_Pvar_simps[simp]: "Padmit \<sigma> (Pvar a)"
  and Padmit_Sequence_simps[simp]: "Padmit \<sigma> (a ;; b)"
  and Padmit_Loop_simps[simp]: "Padmit \<sigma> (a**)"
  and Padmit_ODE_simps[simp]: "Padmit \<sigma> (EvolveODE ODE p)"
  and Padmit_Choice_simps[simp]: "Padmit \<sigma> (a \<union>\<union> b)"
  and Padmit_Assign_simps[simp]: "Padmit \<sigma> (Assign x e)"
  and Padmit_DiffAssign_simps[simp]: "Padmit \<sigma> (DiffAssign x e)"
  and Padmit_Test_simps[simp]: "Padmit \<sigma> (? p)"

  and Fadmit_Geq_simps[simp]: "Fadmit \<sigma> (Geq t1 t2)"
  and Fadmit_Prop_simps[simp]: "Fadmit \<sigma> (Prop p args)"
  and Fadmit_Not_simps[simp]: "Fadmit \<sigma> (Not p)"
  and Fadmit_And_simps[simp]: "Fadmit \<sigma> (And p q)"
  and Fadmit_Exists_simps[simp]: "Fadmit \<sigma> (Exists x p)"
  and Fadmit_Diamond_simps[simp]: "Fadmit \<sigma> (Diamond a p)"
  and Fadmit_Context_simps[simp]: "Fadmit \<sigma> (InContext C p)"

fun extendf :: "('sf, 'sc, 'sz) interp \<Rightarrow> 'sz Rvec \<Rightarrow> ('sf + 'sz, 'sc, 'sz) interp"
where "extendf I R =
\<lparr>Functions = (\<lambda>f. case f of Inl f' \<Rightarrow> Functions I f' | Inr f' \<Rightarrow> (\<lambda>_. R $ f')),
 Predicates = Predicates I,
 Contexts = Contexts I,
 Programs = Programs I,
 ODEs = ODEs I,
 ODEBV = ODEBV I
 \<rparr>"

fun extendc :: "('sf, 'sc, 'sz) interp \<Rightarrow> 'sz state set \<Rightarrow> ('sf, 'sc + unit, 'sz) interp"
where "extendc I R =
\<lparr>Functions =  Functions I,
 Predicates = Predicates I,
 Contexts = (\<lambda>C. case C of Inl C' \<Rightarrow> Contexts I C' | Inr () \<Rightarrow> (\<lambda>_.  R)),
 Programs = Programs I,
 ODEs = ODEs I,
 ODEBV = ODEBV I\<rparr>"

definition adjoint :: "('sf, 'sc, 'sz) interp \<Rightarrow> ('sf, 'sc, 'sz) subst \<Rightarrow> 'sz state \<Rightarrow> ('sf, 'sc, 'sz) interp"
where "adjoint I \<sigma> \<nu> =
\<lparr>Functions =   (\<lambda>f. case SFunctions \<sigma> f of Some f' \<Rightarrow> (\<lambda>R. dterm_sem (extendf I R) f' \<nu>) | None \<Rightarrow> Functions I f),
 Predicates = (\<lambda>p. case SPredicates \<sigma> p of Some p' \<Rightarrow> (\<lambda>R. \<nu> \<in> fml_sem (extendf I R) p') | None \<Rightarrow> Predicates I p),
 Contexts =   (\<lambda>c. case SContexts \<sigma> c of Some c' \<Rightarrow> (\<lambda>R. fml_sem (extendc I R) c') | None \<Rightarrow> Contexts I c),
 Programs =   (\<lambda>a. case SPrograms \<sigma> a of Some a' \<Rightarrow> prog_sem I a' | None \<Rightarrow> Programs I a),
 ODEs =     (\<lambda>ode. case SODEs \<sigma> ode of Some ode' \<Rightarrow> ODE_sem I ode' | None \<Rightarrow> ODEs I ode),
 ODEBV = (\<lambda>ode. case SODEs \<sigma> ode of Some ode' \<Rightarrow> ODE_vars I ode' | None \<Rightarrow> ODEBV I ode)
 \<rparr>"

lemma dsem_to_ssem:"dfree \<theta> \<Longrightarrow> dterm_sem I \<theta> \<nu> = sterm_sem I \<theta> (fst \<nu>)"
  by (induct rule: dfree.induct) (auto)

definition adjointFO::"('sf, 'sc, 'sz) interp \<Rightarrow> ('d::finite \<Rightarrow> ('sf, 'sz) trm) \<Rightarrow> 'sz state \<Rightarrow> ('sf + 'd, 'sc, 'sz) interp"
where "adjointFO I \<sigma> \<nu> =
\<lparr>Functions =   (\<lambda>f. case f of Inl f' \<Rightarrow> Functions I f' | Inr f' \<Rightarrow> (\<lambda>_. dterm_sem I (\<sigma> f') \<nu>)),
 Predicates = Predicates I,
 Contexts = Contexts I,
 Programs = Programs I,
 ODEs = ODEs I,
 ODEBV = ODEBV I
 \<rparr>"

lemma adjoint_free:
  assumes sfree:"(\<And>i f'. SFunctions \<sigma> i = Some f' \<Longrightarrow> dfree f')"
  shows "adjoint I \<sigma> \<nu> =
  \<lparr>Functions =  (\<lambda>f. case SFunctions \<sigma> f of Some f' \<Rightarrow> (\<lambda>R. sterm_sem (extendf I R) f' (fst \<nu>)) | None \<Rightarrow> Functions I f),
   Predicates = (\<lambda>p. case SPredicates \<sigma> p of Some p' \<Rightarrow> (\<lambda>R. \<nu> \<in> fml_sem (extendf I R) p') | None \<Rightarrow> Predicates I p),
   Contexts =   (\<lambda>c. case SContexts \<sigma> c of Some c' \<Rightarrow> (\<lambda>R. fml_sem (extendc I R) c') | None \<Rightarrow> Contexts I c),
   Programs =   (\<lambda>a. case SPrograms \<sigma> a of Some a' \<Rightarrow> prog_sem I a' | None \<Rightarrow> Programs I a),
   ODEs =     (\<lambda>ode. case SODEs \<sigma> ode of Some ode' \<Rightarrow> ODE_sem I ode' | None \<Rightarrow> ODEs I ode),
   ODEBV = (\<lambda>ode. case SODEs \<sigma> ode of Some ode' \<Rightarrow> ODE_vars I ode' | None \<Rightarrow> ODEBV I ode)\<rparr>"
  using dsem_to_ssem[OF sfree]
  by (cases \<nu>) (auto simp add: adjoint_def fun_eq_iff split: option.split)

lemma adjointFO_free:"(\<And>i. dfree (\<sigma> i)) \<Longrightarrow> (adjointFO I \<sigma> \<nu> =
\<lparr>Functions =   (\<lambda>f. case f of Inl f' \<Rightarrow> Functions I f' | Inr f' \<Rightarrow> (\<lambda>_. sterm_sem I (\<sigma> f') (fst \<nu>))),
 Predicates = Predicates I,
 Contexts = Contexts I,
 Programs = Programs I,
 ODEs = ODEs I,
 ODEBV = ODEBV I\<rparr>)"
  by (auto simp add: dsem_to_ssem adjointFO_def)

definition PFadjoint::"('sf, 'sc, 'sz) interp \<Rightarrow> ('d::finite \<Rightarrow> ('sf, 'sc, 'sz) formula) \<Rightarrow> ('sf, 'sc  + 'd, 'sz) interp"
where "PFadjoint I \<sigma> =
\<lparr>Functions =  Functions I,
 Predicates = Predicates I,
 Contexts = (\<lambda>f. case f of Inl f' \<Rightarrow> Contexts I f' | Inr f' \<Rightarrow> (\<lambda>_. fml_sem I (\<sigma> f'))),
 Programs = Programs I,
 ODEs = ODEs I,
 ODEBV = ODEBV I\<rparr>"

fun Ssubst::"('sf, 'sc, 'sz) sequent \<Rightarrow> ('sf,'sc,'sz) subst \<Rightarrow> ('sf,'sc,'sz) sequent"
where "Ssubst (\<Gamma>,\<Delta>) \<sigma> = (map (\<lambda> \<phi>. Fsubst \<phi> \<sigma>) \<Gamma>, map (\<lambda> \<phi>. Fsubst \<phi> \<sigma>) \<Delta>)"

fun Rsubst::"('sf, 'sc, 'sz) rule \<Rightarrow> ('sf,'sc,'sz) subst \<Rightarrow> ('sf,'sc,'sz) rule"
where "Rsubst (SG,C) \<sigma> = (map (\<lambda> \<phi>. Ssubst \<phi> \<sigma>) SG, Ssubst C \<sigma>)"

definition Sadmit::"('sf,'sc,'sz) subst \<Rightarrow> ('sf,'sc,'sz) sequent \<Rightarrow> bool"
where "Sadmit \<sigma> S \<longleftrightarrow> ((\<forall>i. i \<ge> 0 \<longrightarrow> i < length (fst S) \<longrightarrow> Fadmit \<sigma> (nth (fst S) i))
                      \<and>(\<forall>i. i \<ge> 0 \<longrightarrow> i < length (snd S) \<longrightarrow> Fadmit \<sigma> (nth (snd S) i)))"

definition Radmit::"('sf,'sc,'sz) subst \<Rightarrow> ('sf,'sc,'sz) rule \<Rightarrow> bool"
where "Radmit \<sigma> R \<longleftrightarrow> (((\<forall>i. i \<ge> 0 \<longrightarrow> i < length (fst R) \<longrightarrow> Sadmit \<sigma> (nth (fst R) i))
                   \<and> Sadmit \<sigma> (snd R)))"

end end


(*
    File:        OCons.thy
    Time-stamp:  <2016-01-03T12:57:35Z>
    Author:      JRF
    Web:         http://jrf.cocolog-nifty.com/software/2016/01/post.html
    Logic Image: ZF (of Isabelle2015)
*)

theory OCons imports OccTools Cardinal begin

definition OCons :: "[i, i]=>i" where
"OCons(n, u) == THE v. EX l T. u = <l, T> & v = <Cons(n, l), T>"

definition ODestr :: "[i, i]=>i" where
"ODestr(n, u) == THE v. EX l T. v = <l, T> & u = <Cons(n, l), T>"

lemma OCons_eq:
  "OCons(n, <l, T>) = <Cons(n, l), T>"
apply (unfold OCons_def)
apply (rule theI2)
apply (rule ex1I)
apply (assumption | rule exI refl conjI)+
apply (safe elim!: list.free_elims)
done

lemma ODestr_eq:
  "ODestr(n, <Cons(n, l), T>) = <l, T>"
apply (unfold ODestr_def)
apply (rule theI2)
apply (rule ex1I)
apply (assumption | rule exI refl conjI)+
apply (safe elim!: list.free_elims)
done

lemma ODestr_empty1:
  "ODestr(n, <[], T>) = 0"
apply (unfold ODestr_def)
apply (rule the_0)
apply (safe elim!: list.free_elims)
done

lemma ODestr_empty2:
  "n ~= m ==> ODestr(n, <Cons(m, l), T>) = 0"
apply (unfold ODestr_def)
apply (rule the_0)
apply (safe elim!: list.free_elims)
done

lemma lam_OCons_injective:
  assumes prem: "X <= list(A) * B"
  shows "(lam u: X. OCons(n, u)): inj(X, Occ_shift(n, X))"
apply (rule_tac d="ODestr(n)" in lam_injective)
apply (frule_tac [2] prem [THEN subsetD])
apply (frule_tac [1] prem [THEN subsetD])
apply safe
apply (simp_all only: OCons_eq ODestr_eq)
apply (erule Occ_shiftI)
done

lemma lam_ODestr_injective:
  "(lam u: Occ_shift(n, X). ODestr(n, u)): inj(Occ_shift(n, X), X)"
apply (rule_tac d="OCons(n)" in lam_injective)
apply (safe elim!: Occ_shiftE)
apply (simp_all only: OCons_eq ODestr_eq)
done

lemma Occ_shift_cardinal:
  assumes prem: "X <= list(A) * B"
  shows "|Occ_shift(n, X)| = |X|"
apply (rule cardinal_cong)
apply (rule eqpollI)
apply (unfold lepoll_def)
apply (assumption | rule exI prem [THEN lam_OCons_injective]
         lam_ODestr_injective)+
done

end


\<^marker>\<open>creator "Maximilian P. L. Haslbeck"\<close>
\<^marker>\<open>contributor "Peter Lammich"\<close>
section \<open>Type Class needed for currency refine and backwards reasoning gwp\<close>
theory NREST_Type_Classes
imports NREST
begin

paragraph \<open>Summary\<close>
text \<open>This theory collects the properties a resource type needs to allow for currency refinement
  and backwards reasoning.\<close>

subsection \<open>Type class for currency refinement\<close>

text \<open>this is needed for monotonicity of Sum_any\<close>

class nonneg = ord + zero +
  assumes needname_nonneg: "0 \<le> x"

subsection \<open>Algebraic structure needed for backwards reasoning\<close>

lemma le_None: "t \<le> None \<longleftrightarrow> t = None" apply(cases t) apply auto done

lemma enat_1: "top - a = (top::enat)"
  apply(cases a) by (auto simp: top_enat_def)
lemma enat_2: "a - (b + c) = a - c - (b::enat)"
  apply(cases a;cases b;cases c) by (auto)
lemma enat_3: "  \<lbrakk>a + b \<le> c;   b \<le> (c::enat) \<rbrakk> \<Longrightarrow>  a \<le> c - b"
  apply(cases a; cases b; cases c) by auto
lemma enat_4: "a + b \<le> c\<Longrightarrow>  b \<le> (c::enat)"
  apply(cases a; cases b; cases c) by auto
lemma enat_5: "\<lbrakk>t1 \<le> b - a; aa \<le> b - a - t1; a \<le> b\<rbrakk> \<Longrightarrow> t1 + a \<le> (b::enat)"
  apply(cases t1; cases b; cases aa; cases a) by auto

lemma nat_2: "a - (b + c) = a - c - (b::nat)"
  apply(cases a;cases b;cases c) by (auto)
lemma nat_3: "  \<lbrakk>a + b \<le> c;   b \<le> (c::nat) \<rbrakk> \<Longrightarrow>  a \<le> c - b"
  apply(rule linordered_semidom_class.add_le_imp_le_diff) .
lemma nat_4: "a + b \<le> c\<Longrightarrow>  b \<le> (c::nat)"
  by(rule Nat.add_leD2)

(* TODO: good name *)
class needname = complete_lattice + minus + plus +
  assumes top_absorb: "\<And>a. top - a = top"
      and minus_plus_assoc2: "\<And>a b c. a - (b + c) = a - c - b"
      and le_diff_if_add_le: "\<And>a b c. \<lbrakk>a + b \<le> c;   b \<le> c \<rbrakk> \<Longrightarrow>  a \<le> c - b"
      and add_leD2: "\<And>a b c. a + b \<le> c\<Longrightarrow>  b \<le> c"
      and add_le_if_le_diff: "\<And>t1 a aa b. \<lbrakk>t1 \<le> b - a; aa \<le> b - a - t1; a \<le> b\<rbrakk> \<Longrightarrow> t1 + a \<le> b"
begin
lemma needname_cancle: "t1 + t2 \<le> t \<Longrightarrow> t2 \<le> t"
  apply(rule add_leD2) .

lemma needname_adjoint: "a + b \<le> c \<Longrightarrow> a \<le> c - b"
  using add_leD2 le_diff_if_add_le by blast

end

(*
class resource = complete_lattice + monoid_add
begin

definition minus :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" where
  "minus a b = Sup {c. c + b \<le> a  }"

lemma "minus top a = top"
  unfolding minus_def
  apply(rule antisym)
   apply simp
  apply(rule Sup_upper)
  by simp

lemma "minus a (b + c) = minus (minus a b) c"
  unfolding minus_def
  apply(rule antisym)
  subgoal
   apply (rule Sup_upper)
   apply auto
    apply (rule Sup_upper)
    apply auto
    sorry
  subgoal
    apply(rule Sup_upper)
    apply auto
    sorry

    oops

lemma "\<lbrakk>a + b \<le> c;   b \<le> c \<rbrakk> \<Longrightarrow>  a \<le> minus c b"
  unfolding minus_def apply(rule Sup_upper)
  apply simp
  done

lemma " a + b \<le> c\<Longrightarrow>  b \<le> c"
  sorry

lemma " \<lbrakk>t1 \<le> minus b a; aa \<le> minus (minus b a) t1; a \<le> b\<rbrakk> \<Longrightarrow> t1 + a \<le> b"
  unfolding minus_def
  sorry

end
*)

instance enat :: needname
  apply standard
      apply(fact enat_1)
     apply(fact enat_2)
    apply(fact enat_3)
   apply(fact enat_4)
  apply(fact enat_5)
  done

instantiation acost :: (type, needname) needname
begin
instance
  apply standard
  subgoal for a apply(cases a) by (auto simp: top_acost_def top_absorb fun_eq_iff)
  subgoal for a b c apply(cases a;cases b;cases c) by (auto simp:  minus_plus_assoc2 less_eq_acost_def)
  subgoal for a b c apply(cases a;cases b;cases c) by (auto simp:  le_diff_if_add_le less_eq_acost_def)
  subgoal for a b c apply(cases a;cases b;cases c) by (auto intro: add_leD2 simp: less_eq_acost_def)
  subgoal for a b c d apply(cases a;cases b;cases c;cases d) by (auto intro: add_le_if_le_diff simp: less_eq_acost_def)
  done
end

lemma diff_left_mono_enat:
   "b \<le> (c::enat)   \<Longrightarrow> a - c \<le> a - b"
  apply(cases a; cases b; cases c) by(auto simp: minus_acost_alt less_eq_acost_def diff_left_mono )

class drm = minus + plus + ord + Inf + Sup +
  assumes diff_right_mono: "a \<le> b \<Longrightarrow> a - c \<le> b - c"
  and diff_left_mono: "\<And>a b c. b \<le> c   \<Longrightarrow> a - c \<le> a - b"
    (* TODO: investigate what those mean *)
  and minus_continuousInf: "R\<noteq>{} \<Longrightarrow> (INF r\<in>R. r - mt) \<le> Inf R - mt"
  and minus_continuousSup: "\<And>X t q. X\<noteq>{} \<Longrightarrow> \<forall>x\<in>X. t \<le> q - (x::'a) \<Longrightarrow> t \<le> q - (Sup X)"
  and plus_left_mono: "a \<le> b \<Longrightarrow> c + a \<le> c + b"

lemma ASSN_enat:
  shows "X\<noteq>{} \<Longrightarrow> \<forall>x\<in>X. t \<le> q - (x::enat) \<Longrightarrow> t \<le> q - (Sup X)"
  unfolding Sup_enat_def apply auto
  apply(cases q) apply auto
  by (metis antisym cancel_comm_monoid_add_class.diff_cancel diff_left_mono_enat
          finite_enat_bounded idiff_enat_enat linear zero_enat_def zero_le)

instance enat :: drm
  apply standard
  subgoal for a b c apply(cases a; cases b; cases c) by auto
  subgoal for a b c apply(cases a; cases b; cases c) by auto
  subgoal for R mt
    unfolding Inf_enat_def apply auto
    by (metis (full_types) INF_lower Inf_enat_def LeastI_ex equals0D imageI)
  subgoal apply(rule ASSN_enat) by auto
  subgoal for a b c apply(cases a; cases b; cases c) by auto
  done

class needname_zero = needname + nonneg + drm + ordered_comm_monoid_add + mult_zero +
  assumes needname_minus_absorb: "x - 0 = x"
   and needname_plus_absorb: "0 + x = x"

instance enat :: needname_zero
  apply standard
  by auto
lemma ll: "(case acostC x of acostC b \<Rightarrow> f b) = f x" by auto

instantiation acost :: (type, needname_zero) needname_zero
begin
  definition "a*b = acostC (\<lambda>x. the_acost a x * the_acost b x)"

instance
  apply standard
  subgoal for a b c apply(cases a; cases b; cases c) by(auto simp: minus_acost_alt less_eq_acost_def plus_left_mono )  subgoal for a b c apply(cases a; cases b; cases c) by(auto simp: minus_acost_alt less_eq_acost_def diff_right_mono )
  subgoal for a b c apply(cases a; cases b; cases c) by(auto simp: minus_acost_alt less_eq_acost_def diff_left_mono )
  subgoal premises prems for R mt apply(cases mt) unfolding Inf_acost_def less_eq_acost_def minus_acost_alt  apply simp
    apply (subst image_image) apply (auto ) apply(subst ll)
    apply(rule order.trans)
     defer apply(rule minus_continuousInf) subgoal using prems by auto
    apply (rule Inf_mono) apply auto
    by (metis acost.case_eq_if acost.sel order_mono_setup.refl)
  subgoal for X t q
    unfolding less_eq_acost_def minus_acost_alt Sup_acost_def
    apply(cases t) apply(cases q)
    apply simp
    apply clarsimp
    apply(rule minus_continuousSup)
    subgoal by blast
    subgoal by (simp add: acost.case_eq_if)
    done
  subgoal for x apply(cases x) by (auto simp: less_eq_acost_def zero_acost_def needname_nonneg)
  subgoal for x apply(cases x) by (auto simp: less_eq_acost_def times_acost_def zero_acost_def)
  subgoal for x apply(cases x) by (auto simp: less_eq_acost_def times_acost_def zero_acost_def)
  subgoal for x apply(cases x) by (auto simp: zero_acost_def needname_minus_absorb)
  subgoal for x apply(cases x) by (auto simp: zero_acost_def needname_plus_absorb)
  done
end

end


section \<open>Simple Cyclicity Checker\<close>
theory Cyc_Check
imports "../DFS_Framework"
  CAVA_Automata.Digraph_Impl
  "../Misc/Impl_Rev_Array_Stack"
begin
text \<open>
  This example presents a simple cyclicity checker:
    Given a directed graph with start nodes, decide whether it's reachable
    part is cyclic.

  The example tries to be a tutorial on using the DFS framework,
  explaining every required step in detail.

  We define two versions of the algorithm, a partial correct one assuming
  only a finitely branching graph, and a total correct one assuming finitely
  many reachable nodes.
\<close>

subsection \<open>Framework Instantiation\<close>
text \<open> Define a state, based on the DFS-state.
  In our case, we just add a break-flag.
\<close>
record 'v cycc_state = "'v state" +
  break :: bool

text \<open>Some utility lemmas for the simplifier, to handle idiosyncrasies of
  the record package. \<close>
lemma break_more_cong: "state.more s = state.more s' \<Longrightarrow> break s = break s'"
  by (cases s, cases s', simp)

text \<open>
  Define the parameterization. We start at a default parameterization, where
  all operations default to skip, and just add the operations we are
  interested in: Initially, the break flag is false, it is set if we
  encounter a back-edge, and once set, the algorithm shall terminate immediately. \<close>
definition cycc_params :: "('v,unit cycc_state_ext) parameterization"
where "cycc_params \<equiv> dflt_parametrization state.more
  (RETURN \<lparr> break = False \<rparr>) \<lparr>
  on_back_edge := \<lambda>_ _ _. RETURN \<lparr> break = True \<rparr>,
  is_break := break \<rparr>"
lemmas cycc_params_simp[simp] =
  gen_parameterization.simps[mk_record_simp, OF cycc_params_def[simplified]]

interpretation cycc: param_DFS_defs where param=cycc_params for G .

text \<open>We now can define our cyclicity checker.
  The partially correct version asserts a finitely branching graph:\<close>
definition "cyc_checker G \<equiv> do {
  ASSERT (fb_graph G);
  s \<leftarrow> cycc.it_dfs TYPE('a) G;
  RETURN (break s)
}"

text \<open>The total correct variant asserts finitely many reachable nodes.\<close>
definition "cyc_checkerT G \<equiv> do {
  ASSERT (graph G \<and> finite (graph_defs.reachable G));
  s \<leftarrow> cycc.it_dfsT TYPE('a) G;
  RETURN (break s)
}"

text \<open>
  Next, we define a locale for the cyclicity checker's
  precondition and invariant, by specializing the \<open>param_DFS\<close> locale.\<close>
locale cycc = param_DFS G cycc_params for G :: "('v, 'more) graph_rec_scheme"
begin
  text \<open>We can easily show that our parametrization does not fail, thus we also
    get the DFS-locale, which gives us the correctness theorem for
    the DFS-scheme \<close>
  sublocale DFS G cycc_params
    apply unfold_locales
    apply (simp_all add: cycc_params_def)
    done

  thm it_dfs_correct  \<comment> \<open>Partial correctness\<close>
  thm it_dfsT_correct \<comment> \<open>Total correctness if set of reachable states is finite\<close>
end

lemma cyccI:
  assumes "fb_graph G"
  shows "cycc G"
proof -
  interpret fb_graph G by fact
  show ?thesis by unfold_locales
qed

lemma cyccI':
  assumes "graph G"
  and FR: "finite (graph_defs.reachable G)"
  shows "cycc G"
proof -
  interpret graph G by fact
  from FR interpret fb_graph G by (rule fb_graphI_fr)
  show ?thesis by unfold_locales
qed

text \<open>Next, we specialize the @{term DFS_invar} locale to our parameterization.
  This locale contains all proven invariants. When proving new invariants,
  this locale is available as assumption, thus allowing us to re-use already
  proven invariants.
\<close>
locale cycc_invar = DFS_invar where param = cycc_params + cycc

text \<open> The lemmas to establish invariants only provide the \<open>DFS_invar\<close> locale.
  This lemma is used to convert it into the \<open>cycc_invar\<close> locale.
\<close>
lemma cycc_invar_eq[simp]:
  shows "DFS_invar G cycc_params s \<longleftrightarrow> cycc_invar G s"
proof
  assume "DFS_invar G cycc_params s"
  interpret DFS_invar G cycc_params s by fact
  show "cycc_invar G s" by unfold_locales
next
  assume "cycc_invar G s"
  then interpret cycc_invar G s .
  show "DFS_invar G cycc_params s" by unfold_locales
qed

subsection \<open>Correctness Proof\<close>
text \<open> We now enter the \<open>cycc_invar\<close> locale, and show correctness of
  our cyclicity checker.
\<close>
context cycc_invar begin
  text \<open>We show that we break if and only if there are back edges.
    This is straightforward from our parameterization, and we can use the
    @{thm [source] establish_invarI} rule provided by the DFS framework.

    We use this example to illustrate the general proof scheme:
    \<close>
  lemma (in cycc) i_brk_eq_back: "is_invar (\<lambda>s. break s \<longleftrightarrow> back_edges s \<noteq> {})"
  proof (induct rule: establish_invarI)
  txt \<open>The @{thm establish_invarI} rule is used with the induction method, and
    yields cases\<close>
  print_cases
    txt \<open>Our parameterization has only hooked into initialization and back-edges,
      so only these two cases are non-trivial\<close>
    case init thus ?case by (simp add: empty_state_def)
  next
    case (back_edge s s' u v)
    txt \<open>For proving invariant preservation, we may assume that the invariant
      holds on the previous state. Interpreting the invariant locale makes
      available all invariants ever proved into this locale (i.e., the invariants
      from all loaded libraries, and the ones you proved yourself.).
      \<close>
    then interpret cycc_invar G s by simp
    txt \<open>However, here we do not need them:\<close>
    from back_edge show ?case by simp
  qed (simp_all cong: break_more_cong)

  text \<open>For technical reasons, invariants are proved in the basic locale,
    and then transferred to the invariant locale:\<close>
  lemmas brk_eq_back = i_brk_eq_back[THEN make_invar_thm]

  text \<open>The above lemma is simple enough to have a short apply-style proof:\<close>
  lemma (in cycc) i_brk_eq_back_short_proof:
    "is_invar (\<lambda>s. break s \<longleftrightarrow> back_edges s \<noteq> {})"
    apply (induct rule: establish_invarI)
    apply (simp_all add: cond_def cong: break_more_cong)
    apply (simp add: empty_state_def)
    done

  text \<open>Now, when we know that the break flag indicates back-edges,
    we can easily prove correctness, using a lemma from the invariant
    library:\<close>
  thm cycle_iff_back_edges
  lemma cycc_correct_aux:
    assumes NC: "\<not>cond s"
    shows "break s \<longleftrightarrow> \<not>acyclic (E \<inter> reachable \<times> UNIV)"
  proof (cases "break s", simp_all)
    assume "break s"
    with brk_eq_back have "back_edges s \<noteq> {}" by simp
    with cycle_iff_back_edges have "\<not>acyclic (edges s)" by simp
    with acyclic_subset[OF _ edges_ss_reachable_edges]
    show "\<not>acyclic (E \<inter> reachable \<times> UNIV)" by blast
  next
    assume A: "\<not>break s"
    from A brk_eq_back have "back_edges s = {}" by simp
    with cycle_iff_back_edges have "acyclic (edges s)" by simp
    also from A nc_edges_covered[OF NC] have "edges s = E \<inter> reachable \<times> UNIV"
      by simp
    finally show "acyclic (E \<inter> reachable \<times> UNIV)" .
  qed

  text \<open>Again, we have a short two-line proof:\<close>
  lemma cycc_correct_aux_short_proof:
    assumes NC: "\<not>cond s"
    shows "break s \<longleftrightarrow> \<not>acyclic (E \<inter> reachable \<times> UNIV)"
    using nc_edges_covered[OF NC] brk_eq_back cycle_iff_back_edges
    by (auto dest: acyclic_subset[OF _ edges_ss_reachable_edges])

end

text \<open>Finally, we define a specification for cyclicity checking,
  and prove that our cyclicity checker satisfies the specification: \<close>
definition "cyc_checker_spec G \<equiv> do {
  ASSERT (fb_graph G);
  SPEC (\<lambda>r. r \<longleftrightarrow> \<not>acyclic (g_E G \<inter> ((g_E G)\<^sup>* `` g_V0 G) \<times> UNIV))}"

theorem cyc_checker_correct: "cyc_checker G \<le> cyc_checker_spec G"
  unfolding cyc_checker_def cyc_checker_spec_def
proof (refine_vcg le_ASSERTI order_trans[OF DFS.it_dfs_correct], clarsimp_all)
  assume "fb_graph G"
  then interpret fb_graph G .
  interpret cycc by unfold_locales
  show "DFS G cycc_params" by unfold_locales
next
  fix s
  assume "cycc_invar G s"
  then interpret cycc_invar G s .
  assume "\<not>cycc.cond TYPE('b) G s"
  thus "break s = (\<not> acyclic (g_E G \<inter> cycc.reachable TYPE('b) G \<times> UNIV))"
    by (rule cycc_correct_aux)
qed

text \<open>The same for the total correct variant:\<close>
definition "cyc_checkerT_spec G \<equiv> do {
  ASSERT (graph G \<and> finite (graph_defs.reachable G));
  SPEC (\<lambda>r. r \<longleftrightarrow> \<not>acyclic (g_E G \<inter> ((g_E G)\<^sup>* `` g_V0 G) \<times> UNIV))}"

theorem cyc_checkerT_correct: "cyc_checkerT G \<le> cyc_checkerT_spec G"
  unfolding cyc_checkerT_def cyc_checkerT_spec_def
proof (refine_vcg le_ASSERTI order_trans[OF DFS.it_dfsT_correct], clarsimp_all)
  assume "graph G" then interpret graph G .
  assume "finite (graph_defs.reachable G)"
  then interpret fb_graph G by (rule fb_graphI_fr)
  interpret cycc by unfold_locales
  show "DFS G cycc_params" by unfold_locales
next
  fix s
  assume "cycc_invar G s"
  then interpret cycc_invar G s .
  assume "\<not>cycc.cond TYPE('b) G s"
  thus "break s = (\<not> acyclic (g_E G \<inter> cycc.reachable TYPE('b) G \<times> UNIV))"
    by (rule cycc_correct_aux)
qed

subsection \<open>Implementation\<close>
text \<open>
  The implementation has two aspects: Structural implementation and data implementation.
  The framework provides recursive and tail-recursive implementations, as well as a variety
  of data structures for the state.

  We will choose the \<open>simple_state\<close> implementation, which provides
  a stack, an on-stack and a visited set, but no timing information.

  Note that it is common for state implementations to omit details from the
  very detailed abstract state. This means, that the algorithm's operations
  must not access these details (e.g. timing). However, the algorithm's
  correctness proofs may still use them.
\<close>

text \<open>We extend the state template to add a break flag\<close>
record 'v cycc_state_impl = "'v simple_state" +
  break :: bool

text \<open>Definition of refinement relation: The break-flag is refined by identity.\<close>
definition "cycc_erel \<equiv> {
  (\<lparr> cycc_state_impl.break = b \<rparr>, \<lparr> cycc_state.break = b\<rparr>) | b. True }"
abbreviation "cycc_rel \<equiv> \<langle>cycc_erel\<rangle>simple_state_rel"

text \<open>Implementation of the parameters\<close>
definition cycc_params_impl
  :: "('v,'v cycc_state_impl,unit cycc_state_impl_ext) gen_parameterization"
where "cycc_params_impl
  \<equiv> dflt_parametrization simple_state.more (RETURN \<lparr> break = False \<rparr>) \<lparr>
  on_back_edge := \<lambda>u v s. RETURN \<lparr> break = True \<rparr>,
  is_break := break \<rparr>"
lemmas cycc_params_impl_simp[simp,DFS_code_unfold] =
  gen_parameterization.simps[mk_record_simp, OF cycc_params_impl_def[simplified]]

text \<open>Note: In this simple case, the reformulation of the extension state and
  parameterization is just redundant, However, in general the refinement will
  also affect the parameterization.\<close>

lemma break_impl: "(si,s)\<in>cycc_rel
  \<Longrightarrow> cycc_state_impl.break si = cycc_state.break s"
  by (cases si, cases s, simp add: simple_state_rel_def cycc_erel_def)

interpretation cycc_impl: simple_impl_defs G cycc_params_impl cycc_params
  for G .

text \<open>The above interpretation creates an iterative and a recursive implementation \<close>
term cycc_impl.tailrec_impl term cycc_impl.rec_impl
term cycc_impl.tailrec_implT \<comment> \<open>Note, for total correctness we currently only support tail-recursive implementations.\<close>

text \<open>We use both to derive a tail-recursive and a recursive cyclicity checker:\<close>
definition [DFS_code_unfold]: "cyc_checker_impl G \<equiv> do {
  ASSERT (fb_graph G);
  s \<leftarrow> cycc_impl.tailrec_impl TYPE('a) G;
  RETURN (break s)
}"

definition [DFS_code_unfold]: "cyc_checker_rec_impl G \<equiv> do {
  ASSERT (fb_graph G);
  s \<leftarrow> cycc_impl.rec_impl TYPE('a) G;
  RETURN (break s)
}"

definition [DFS_code_unfold]: "cyc_checker_implT G \<equiv> do {
  ASSERT (graph G \<and> finite (graph_defs.reachable G));
  s \<leftarrow> cycc_impl.tailrec_implT TYPE('a) G;
  RETURN (break s)
}"

text \<open>To show correctness of the implementation, we integrate the
  locale of the simple implementation into our cyclicity checker's locale:\<close>
context cycc begin
  sublocale simple_impl G cycc_params cycc_params_impl cycc_erel
    apply unfold_locales
    apply (intro fun_relI, clarsimp simp: simple_state_rel_def, parametricity) []
    apply (auto simp: cycc_erel_def break_impl simple_state_rel_def)
    done

  text \<open>We get that our implementation refines the abstrct DFS algorithm.\<close>
  lemmas impl_refine = simple_tailrec_refine simple_rec_refine simple_tailrecT_refine

  text \<open>Unfortunately, the combination of locales and abbreviations gets to its
    limits here, so we state the above lemma a bit more readable:\<close>
  lemma
    "cycc_impl.tailrec_impl TYPE('more) G \<le> \<Down> cycc_rel it_dfs"
    "cycc_impl.rec_impl TYPE('more) G \<le> \<Down> cycc_rel it_dfs"
    "cycc_impl.tailrec_implT TYPE('more) G \<le> \<Down> cycc_rel it_dfsT"
    using impl_refine .

end

text \<open>Finally, we get correctness of our cyclicity checker implementations\<close>
lemma cyc_checker_impl_refine: "cyc_checker_impl G \<le> \<Down>Id (cyc_checker G)"
  unfolding cyc_checker_impl_def cyc_checker_def
  apply (refine_vcg cycc.impl_refine)
  apply (simp_all add: break_impl cyccI)
  done

lemma cyc_checker_rec_impl_refine:
  "cyc_checker_rec_impl G \<le> \<Down>Id (cyc_checker G)"
  unfolding cyc_checker_rec_impl_def cyc_checker_def
  apply (refine_vcg cycc.impl_refine)
  apply (simp_all add: break_impl cyccI)
  done

lemma cyc_checker_implT_refine: "cyc_checker_implT G \<le> \<Down>Id (cyc_checkerT G)"
  unfolding cyc_checker_implT_def cyc_checkerT_def
  apply (refine_vcg cycc.impl_refine)
  apply (simp_all add: break_impl cyccI')
  done

subsection \<open>Synthesizing Executable Code\<close>
text \<open>
  Our algorithm's implementation is still abstract, as it uses abstract data
  structures like sets and relations. In a last step, we use the Autoref tool
  to derive an implementation with efficient data structures.
\<close>

text \<open>Again, we derive our state implementation from the template provided by
  the framework. The break-flag is implemented by a Boolean flag.
  Note that, in general, the user-defined state extensions may be data-refined
  in this step.\<close>
record ('si,'nsi,'psi)cycc_state_impl' = "('si,'nsi)simple_state_impl" +
  break_impl :: bool

text \<open>We define the refinement relation for the state extension\<close>
definition [to_relAPP]: "cycc_state_erel erel \<equiv> {
  (\<lparr>break_impl = bi, \<dots> =  mi\<rparr>,\<lparr>break = b, \<dots> = m\<rparr>) | bi mi b m.
    (bi,b)\<in>bool_rel \<and> (mi,m)\<in>erel}"

text \<open>And register it with the Autoref tool:\<close>
consts
  i_cycc_state_ext :: "interface \<Rightarrow> interface"

lemmas [autoref_rel_intf] = REL_INTFI[of cycc_state_erel i_cycc_state_ext]

text \<open>We show that the record operations on our extended state are parametric,
  and declare these facts to Autoref: \<close>
lemma [autoref_rules]:
  fixes ns_rel vis_rel erel
  defines "R \<equiv> \<langle>ns_rel,vis_rel,\<langle>erel\<rangle>cycc_state_erel\<rangle>ss_impl_rel"
  shows
    "(cycc_state_impl'_ext, cycc_state_impl_ext) \<in> bool_rel \<rightarrow> erel \<rightarrow> \<langle>erel\<rangle>cycc_state_erel"
    "(break_impl, cycc_state_impl.break) \<in> R \<rightarrow> bool_rel"
  unfolding cycc_state_erel_def ss_impl_rel_def R_def
  by auto

text \<open>Finally, we can synthesize an implementation for our cyclicity checker,
  using the standard Autoref-approach:\<close>
schematic_goal cyc_checker_impl:
  defines "V \<equiv> Id :: ('v \<times> 'v::hashable) set"
  assumes [unfolded V_def,autoref_rules]:
    "(Gi, G) \<in> \<langle>Rm, V\<rangle>g_impl_rel_ext"
  notes [unfolded V_def,autoref_tyrel] =
    TYRELI[where R="\<langle>V\<rangle>dflt_ahs_rel"]
    TYRELI[where R="\<langle>V \<times>\<^sub>r \<langle>V\<rangle>list_set_rel\<rangle>ras_rel"]
  shows "nres_of (?c::?'c dres) \<le>\<Down>?R (cyc_checker_impl G)"
  unfolding DFS_code_unfold
  using [[autoref_trace_failed_id, goals_limit=1]]
  apply (autoref_monadic (trace))
  done
concrete_definition cyc_checker_code uses cyc_checker_impl
export_code cyc_checker_code checking SML

text \<open>Combining the refinement steps yields a correctness
  theorem for the cyclicity checker implementation:\<close>
theorem cyc_checker_code_correct:
  assumes 1: "fb_graph G"
  assumes 2: "(Gi, G) \<in> \<langle>Rm, Id\<rangle>g_impl_rel_ext"
  assumes 4: "cyc_checker_code Gi = dRETURN x"
  shows "x \<longleftrightarrow> (\<not>acyclic (g_E G \<inter> ((g_E G)\<^sup>* `` g_V0 G) \<times> UNIV))"
proof -
  note cyc_checker_code.refine[OF 2]
  also note cyc_checker_impl_refine
  also note cyc_checker_correct
  finally show ?thesis using 1 4
  unfolding cyc_checker_spec_def by auto
qed

text \<open>We can repeat the same boilerplate for the recursive version of the algorithm:\<close>
schematic_goal cyc_checker_rec_impl:
  defines "V \<equiv> Id :: ('v \<times> 'v::hashable) set"
  assumes [unfolded V_def,autoref_rules]:
    "(Gi, G) \<in> \<langle>Rm, V\<rangle>g_impl_rel_ext"
  notes [unfolded V_def,autoref_tyrel] =
    TYRELI[where R="\<langle>V\<rangle>dflt_ahs_rel"]
    TYRELI[where R="\<langle>V \<times>\<^sub>r \<langle>V\<rangle>list_set_rel\<rangle>ras_rel"]
  shows "nres_of (?c::?'c dres) \<le>\<Down>?R (cyc_checker_rec_impl G)"
  unfolding DFS_code_unfold
  using [[autoref_trace_failed_id, goals_limit=1]]
  apply (autoref_monadic (trace))
  done
concrete_definition cyc_checker_rec_code uses cyc_checker_rec_impl
prepare_code_thms cyc_checker_rec_code_def
export_code cyc_checker_rec_code checking SML

lemma cyc_checker_rec_code_correct:
  assumes 1: "fb_graph G"
  assumes 2: "(Gi, G) \<in> \<langle>Rm, Id\<rangle>g_impl_rel_ext"
  assumes 4: "cyc_checker_rec_code Gi = dRETURN x"
  shows "x \<longleftrightarrow> (\<not>acyclic (g_E G \<inter> ((g_E G)\<^sup>* `` g_V0 G) \<times> UNIV))"
proof -
  note cyc_checker_rec_code.refine[OF 2]
  also note cyc_checker_rec_impl_refine
  also note cyc_checker_correct
  finally show ?thesis using 1 4
  unfolding cyc_checker_spec_def by auto
qed

text \<open>And, again, for the total correct version.
  Note that we generate a plain implementation, not inside a monad:\<close>
schematic_goal cyc_checker_implT:
  defines "V \<equiv> Id :: ('v \<times> 'v::hashable) set"
  assumes [unfolded V_def,autoref_rules]:
    "(Gi, G) \<in> \<langle>Rm, V\<rangle>g_impl_rel_ext"
  notes [unfolded V_def,autoref_tyrel] =
    TYRELI[where R="\<langle>V\<rangle>dflt_ahs_rel"]
    TYRELI[where R="\<langle>V \<times>\<^sub>r \<langle>V\<rangle>list_set_rel\<rangle>ras_rel"]
  shows "RETURN (?c::?'c) \<le>\<Down>?R (cyc_checker_implT G)"
  unfolding DFS_code_unfold
  using [[autoref_trace_failed_id, goals_limit=1]]
  apply (autoref_monadic (trace,plain))
  done
concrete_definition cyc_checker_codeT uses cyc_checker_implT
export_code cyc_checker_codeT checking SML

theorem cyc_checker_codeT_correct:
  assumes 1: "graph G" "finite (graph_defs.reachable G)"
  assumes 2: "(Gi, G) \<in> \<langle>Rm, Id\<rangle>g_impl_rel_ext"
  shows "cyc_checker_codeT Gi \<longleftrightarrow> (\<not>acyclic (g_E G \<inter> ((g_E G)\<^sup>* `` g_V0 G) \<times> UNIV))"
proof -
  note cyc_checker_codeT.refine[OF 2]
  also note cyc_checker_implT_refine
  also note cyc_checkerT_correct
  finally show ?thesis using 1
  unfolding cyc_checkerT_spec_def by auto
qed

end


theory vertex_example_simps
imports "Lib/FiniteGraph" TopoS_Vertices
begin
(*<*)
--{*The follwoing lemmata are used in the @{text "\<exists>"}-style uniqueness proof*}
lemma False_set: "{(e1, e2). False} = {}" by blast
lemma succ_tran_empty: "(succ_tran \<lparr>nodes = V, edges = {}\<rparr> v) = {}"
  by(simp add: succ_tran_def)
lemma vertex_1_vertex_2_set_simp: "{vertex_1, vertex_2, vertex_1, vertex_2} = {vertex_1, vertex_2}" by blast


(*  Title:      JinjaThreads/Common/BinOp.thy
    Author:     Andreas Lochbihler
*)

section \<open>Binary Operators\<close>

theory BinOp
imports
  WellForm "Word_Lib.Bit_Shifts_Infix_Syntax"
begin

datatype bop =  \<comment> \<open>names of binary operations\<close>
    Eq
  | NotEq
  | LessThan
  | LessOrEqual
  | GreaterThan
  | GreaterOrEqual
  | Add
  | Subtract
  | Mult
  | Div
  | Mod
  | BinAnd
  | BinOr
  | BinXor
  | ShiftLeft
  | ShiftRightZeros
  | ShiftRightSigned

subsection\<open>The semantics of binary operators\<close>

type_synonym 'addr binop_ret = "'addr val + 'addr" \<comment> \<open>a value or the address of an exception\<close>

fun binop_LessThan :: "'addr val \<Rightarrow> 'addr val \<Rightarrow> 'addr binop_ret option"
where
  "binop_LessThan (Intg i1) (Intg i2) = Some (Inl (Bool (i1 <s i2)))"
| "binop_LessThan v1 v2 = None"

fun binop_LessOrEqual :: "'addr val \<Rightarrow> 'addr val \<Rightarrow> 'addr binop_ret option"
where
  "binop_LessOrEqual (Intg i1) (Intg i2) = Some (Inl (Bool (i1 <=s i2)))"
| "binop_LessOrEqual v1 v2 = None"

fun binop_GreaterThan :: "'addr val \<Rightarrow> 'addr val \<Rightarrow> 'addr binop_ret option"
where
  "binop_GreaterThan (Intg i1) (Intg i2) = Some (Inl (Bool (i2 <s i1)))"
| "binop_GreaterThan v1 v2 = None"

fun binop_GreaterOrEqual :: "'addr val \<Rightarrow> 'addr val \<Rightarrow> 'addr binop_ret option"
where
  "binop_GreaterOrEqual (Intg i1) (Intg i2) = Some (Inl (Bool (i2 <=s i1)))"
| "binop_GreaterOrEqual v1 v2 = None"

fun binop_Add :: "'addr val \<Rightarrow> 'addr val \<Rightarrow> 'addr binop_ret option"
where
  "binop_Add (Intg i1) (Intg i2) = Some (Inl (Intg (i1 + i2)))"
| "binop_Add v1 v2 = None"

fun binop_Subtract :: "'addr val \<Rightarrow> 'addr val \<Rightarrow> 'addr binop_ret option"
where
  "binop_Subtract (Intg i1) (Intg i2) = Some (Inl (Intg (i1 - i2)))"
| "binop_Subtract v1 v2 = None"

fun binop_Mult :: "'addr val \<Rightarrow> 'addr val \<Rightarrow> 'addr binop_ret option"
where
  "binop_Mult (Intg i1) (Intg i2) = Some (Inl (Intg (i1 * i2)))"
| "binop_Mult v1 v2 = None"

fun binop_BinAnd :: "'addr val \<Rightarrow> 'addr val \<Rightarrow> 'addr binop_ret option"
where
  "binop_BinAnd (Intg i1) (Intg i2) = Some (Inl (Intg (i1 AND i2)))"
| "binop_BinAnd (Bool b1) (Bool b2) = Some (Inl (Bool (b1 \<and> b2)))"
| "binop_BinAnd v1 v2 = None"

fun binop_BinOr :: "'addr val \<Rightarrow> 'addr val \<Rightarrow> 'addr binop_ret option"
where
  "binop_BinOr (Intg i1) (Intg i2) = Some (Inl (Intg (i1 OR i2)))"
| "binop_BinOr (Bool b1) (Bool b2) = Some (Inl (Bool (b1 \<or> b2)))"
| "binop_BinOr v1 v2 = None"

fun binop_BinXor :: "'addr val \<Rightarrow> 'addr val \<Rightarrow> 'addr binop_ret option"
where
  "binop_BinXor (Intg i1) (Intg i2) = Some (Inl (Intg (i1 XOR i2)))"
| "binop_BinXor (Bool b1) (Bool b2) = Some (Inl (Bool (b1 \<noteq> b2)))"
| "binop_BinXor v1 v2 = None"

fun binop_ShiftLeft :: "'addr val \<Rightarrow> 'addr val \<Rightarrow> 'addr binop_ret option"
where
  "binop_ShiftLeft (Intg i1) (Intg i2) = Some (Inl (Intg (i1 << unat (i2 AND 0x1f))))"
| "binop_ShiftLeft v1 v2 = None"

fun binop_ShiftRightZeros :: "'addr val \<Rightarrow> 'addr val \<Rightarrow> 'addr binop_ret option"
where
  "binop_ShiftRightZeros (Intg i1) (Intg i2) = Some (Inl (Intg (i1 >> unat (i2 AND 0x1f))))"
| "binop_ShiftRightZeros v1 v2 = None"

fun binop_ShiftRightSigned :: "'addr val \<Rightarrow> 'addr val \<Rightarrow> 'addr binop_ret option"
where
  "binop_ShiftRightSigned (Intg i1) (Intg i2) = Some (Inl (Intg (i1 >>> unat (i2 AND 0x1f))))"
| "binop_ShiftRightSigned v1 v2 = None"

text \<open>
  Division on @{typ "'a word"} is unsigned, but JLS specifies signed division.
\<close>
definition word_sdiv :: "'a :: len word \<Rightarrow> 'a word \<Rightarrow> 'a word" (infixl "sdiv" 70)
where [code]:
  "x sdiv y =
   (let x' = sint x; y' = sint y;
        negative = (x' < 0) \<noteq> (y' < 0);
        result = abs x' div abs y'
    in word_of_int (if negative then -result else result))"

definition word_smod :: "'a :: len word \<Rightarrow> 'a word \<Rightarrow> 'a word" (infixl "smod" 70)
where [code]:
  "x smod y =
   (let x' = sint x; y' = sint y;
        negative = (x' < 0);
        result = abs x' mod abs y'
    in word_of_int (if negative then -result else result))"

declare word_sdiv_def [simp] word_smod_def [simp]

lemma sdiv_smod_id: "(a sdiv b) * b + (a smod b) = a"
proof -
  have F5: "\<forall>u::'a word. - (- u) = u"
    by simp
  have F7: "\<forall>v u::'a word. u + v = v + u"
    by (simp add: ac_simps)
  have F8: "\<forall>(w::'a word) (v::int) u::int. word_of_int u + word_of_int v * w = word_of_int (u + v * sint w)"
    by simp
  have "\<exists>u. u = - sint b \<and> word_of_int (sint a mod u + - (- u * (sint a div u))) = a"
    using F5 by simp
  hence "word_of_int (sint a mod - sint b + - (sint b * (sint a div - sint b))) = a"
    by (metis equation_minus_iff)
  hence "word_of_int (sint a mod - sint b) + word_of_int (- (sint a div - sint b)) * b = a"
    using F8 by (simp add: ac_simps)
  hence eq: "word_of_int (- (sint a div - sint b)) * b + word_of_int (sint a mod - sint b) = a"
    using F7 by simp

  show ?thesis
  proof(cases "sint a < 0")
    case True note a = this
    show ?thesis
    proof(cases "sint b < 0")
      case True
      with a show ?thesis
        by simp (metis F7 F8 eq minus_equation_iff minus_mult_minus mod_div_mult_eq)
    next
      case False
      from eq have "word_of_int (- (- sint a div sint b)) * b + word_of_int (- (- sint a mod sint b)) = a"
        by (metis div_minus_right mod_minus_right)
      with a False show ?thesis by simp
    qed
  next
    case False note a = this
    show ?thesis
    proof(cases "sint b < 0")
      case True
      with a eq show ?thesis by simp
    next
      case False with a show ?thesis
        by (simp add: F7 F8)
    qed
  qed
qed

notepad begin
have  "  5  sdiv ( 3 :: word32) =  1"
  and "  5  smod ( 3 :: word32) =  2"
  and "  5  sdiv (-3 :: word32) = -1"
  and "  5  smod (-3 :: word32) =  2"
  and "(-5) sdiv ( 3 :: word32) = -1"
  and "(-5) smod ( 3 :: word32) = -2"
  and "(-5) sdiv (-3 :: word32) =  1"
  and "(-5) smod (-3 :: word32) = -2"
  and "-2147483648 sdiv 1 = (-2147483648 :: word32)"
  by eval+
end

context heap_base begin

fun binop_Mod :: "'addr val \<Rightarrow> 'addr val \<Rightarrow> 'addr binop_ret option"
where
  "binop_Mod (Intg i1) (Intg i2) =
   Some (if i2 = 0 then Inr (addr_of_sys_xcpt ArithmeticException) else Inl (Intg (i1 smod i2)))"
| "binop_Mod v1 v2 = None"

fun binop_Div :: "'addr val \<Rightarrow> 'addr val \<Rightarrow> 'addr binop_ret option"
where
  "binop_Div (Intg i1) (Intg i2) =
   Some (if i2 = 0 then Inr (addr_of_sys_xcpt ArithmeticException) else Inl (Intg (i1 sdiv i2)))"
| "binop_Div v1 v2 = None"

primrec binop :: "bop \<Rightarrow> 'addr val \<Rightarrow> 'addr val \<Rightarrow> 'addr binop_ret option"
where
  "binop Eq v1 v2 =  Some (Inl (Bool (v1 = v2)))"
| "binop NotEq v1 v2 = Some (Inl (Bool (v1 \<noteq> v2)))"
| "binop LessThan = binop_LessThan"
| "binop LessOrEqual = binop_LessOrEqual"
| "binop GreaterThan = binop_GreaterThan"
| "binop GreaterOrEqual = binop_GreaterOrEqual"
| "binop Add = binop_Add"
| "binop Subtract = binop_Subtract"
| "binop Mult = binop_Mult"
| "binop Mod = binop_Mod"
| "binop Div = binop_Div"
| "binop BinAnd = binop_BinAnd"
| "binop BinOr = binop_BinOr"
| "binop BinXor = binop_BinXor"
| "binop ShiftLeft = binop_ShiftLeft"
| "binop ShiftRightZeros = binop_ShiftRightZeros"
| "binop ShiftRightSigned = binop_ShiftRightSigned"

end

lemma [simp]:
  "(binop_LessOrEqual v1 v2 = Some va) \<longleftrightarrow>
   (\<exists>i1 i2. v1 = Intg i1 \<and> v2 = Intg i2 \<and> va = Inl (Bool (i1 <=s i2)))"
by(cases "(v1, v2)" rule: binop_LessOrEqual.cases) auto

lemma [simp]:
  "(binop_GreaterThan v1 v2 = Some va) \<longleftrightarrow>
   (\<exists>i1 i2. v1 = Intg i1 \<and> v2 = Intg i2 \<and> va = Inl (Bool (i2 <s i1)))"
by(cases "(v1, v2)" rule: binop_GreaterThan.cases) auto

lemma [simp]:
  "(binop_GreaterOrEqual v1 v2 = Some va) \<longleftrightarrow>
   (\<exists>i1 i2. v1 = Intg i1 \<and> v2 = Intg i2 \<and> va = Inl (Bool (i2 <=s i1)))"
by(cases "(v1, v2)" rule: binop_GreaterOrEqual.cases) auto

lemma [simp]:
  "(binop_Add v\<^sub>1 v\<^sub>2  = Some va) \<longleftrightarrow>
   (\<exists>i\<^sub>1 i\<^sub>2. v\<^sub>1 = Intg i\<^sub>1 \<and> v\<^sub>2 = Intg i\<^sub>2 \<and> va = Inl (Intg (i\<^sub>1+i\<^sub>2)))"
by(cases "(v\<^sub>1, v\<^sub>2)" rule: binop_Add.cases) auto

lemma [simp]:
  "(binop_Subtract v1 v2 = Some va) \<longleftrightarrow>
   (\<exists>i1 i2. v1 = Intg i1 \<and> v2 = Intg i2 \<and> va = Inl (Intg (i1 - i2)))"
by(cases "(v1, v2)" rule: binop_Subtract.cases) auto

lemma [simp]:
  "(binop_Mult v1 v2 = Some va) \<longleftrightarrow>
   (\<exists>i1 i2. v1 = Intg i1 \<and> v2 = Intg i2 \<and> va = Inl (Intg (i1 * i2)))"
by(cases "(v1, v2)" rule: binop_Mult.cases) auto

lemma [simp]:
  "(binop_BinAnd v1 v2 = Some va) \<longleftrightarrow>
   (\<exists>b1 b2. v1 = Bool b1 \<and> v2 = Bool b2 \<and> va = Inl (Bool (b1 \<and> b2))) \<or>
   (\<exists>i1 i2. v1 = Intg i1 \<and> v2 = Intg i2 \<and> va = Inl (Intg (i1 AND i2)))"
by(cases "(v1, v2)" rule: binop_BinAnd.cases) auto

lemma [simp]:
  "(binop_BinOr v1 v2 = Some va) \<longleftrightarrow>
   (\<exists>b1 b2. v1 = Bool b1 \<and> v2 = Bool b2 \<and> va = Inl (Bool (b1 \<or> b2))) \<or>
   (\<exists>i1 i2. v1 = Intg i1 \<and> v2 = Intg i2 \<and> va = Inl (Intg (i1 OR i2)))"
by(cases "(v1, v2)" rule: binop_BinOr.cases) auto

lemma [simp]:
  "(binop_BinXor v1 v2 = Some va) \<longleftrightarrow>
   (\<exists>b1 b2. v1 = Bool b1 \<and> v2 = Bool b2 \<and> va = Inl (Bool (b1 \<noteq> b2))) \<or>
   (\<exists>i1 i2. v1 = Intg i1 \<and> v2 = Intg i2 \<and> va = Inl (Intg (i1 XOR i2)))"
by(cases "(v1, v2)" rule: binop_BinXor.cases) auto

lemma [simp]:
  "(binop_ShiftLeft v1 v2 = Some va) \<longleftrightarrow>
   (\<exists>i1 i2. v1 = Intg i1 \<and> v2 = Intg i2 \<and> va = Inl (Intg (i1 << unat (i2 AND 0x1f))))"
by(cases "(v1, v2)" rule: binop_ShiftLeft.cases) auto

lemma [simp]:
  "(binop_ShiftRightZeros v1 v2 = Some va) \<longleftrightarrow>
   (\<exists>i1 i2. v1 = Intg i1 \<and> v2 = Intg i2 \<and> va = Inl (Intg (i1 >> unat (i2 AND 0x1f))))"
by(cases "(v1, v2)" rule: binop_ShiftRightZeros.cases) auto

lemma [simp]:
  "(binop_ShiftRightSigned v1 v2 = Some va) \<longleftrightarrow>
   (\<exists>i1 i2. v1 = Intg i1 \<and> v2 = Intg i2 \<and> va = Inl (Intg (i1 >>> unat (i2 AND 0x1f))))"
by(cases "(v1, v2)" rule: binop_ShiftRightSigned.cases) auto

context heap_base begin

lemma [simp]:
  "(binop_Mod v1 v2 = Some va) \<longleftrightarrow>
   (\<exists>i1 i2. v1 = Intg i1 \<and> v2 = Intg i2 \<and>
      va = (if i2 = 0 then Inr (addr_of_sys_xcpt ArithmeticException) else Inl (Intg(i1 smod i2))))"
by(cases "(v1, v2)" rule: binop_Mod.cases) auto

lemma [simp]:
  "(binop_Div v1 v2 = Some va) \<longleftrightarrow>
   (\<exists>i1 i2. v1 = Intg i1 \<and> v2 = Intg i2 \<and>
      va = (if i2 = 0 then Inr (addr_of_sys_xcpt ArithmeticException) else Inl (Intg(i1 sdiv i2))))"
by(cases "(v1, v2)" rule: binop_Div.cases) auto

end

subsection \<open>Typing for binary operators\<close>

inductive WT_binop :: "'m prog \<Rightarrow> ty \<Rightarrow> bop \<Rightarrow> ty \<Rightarrow> ty \<Rightarrow> bool" ("_ \<turnstile> _\<guillemotleft>_\<guillemotright>_ :: _" [51,0,0,0,51] 50)
where
  WT_binop_Eq:
  "P \<turnstile> T1 \<le> T2 \<or> P \<turnstile> T2 \<le> T1 \<Longrightarrow> P \<turnstile> T1\<guillemotleft>Eq\<guillemotright>T2 :: Boolean"

| WT_binop_NotEq:
  "P \<turnstile> T1 \<le> T2 \<or> P \<turnstile> T2 \<le> T1 \<Longrightarrow> P \<turnstile> T1\<guillemotleft>NotEq\<guillemotright>T2 :: Boolean"

| WT_binop_LessThan:
  "P \<turnstile> Integer\<guillemotleft>LessThan\<guillemotright>Integer :: Boolean"

| WT_binop_LessOrEqual:
  "P \<turnstile> Integer\<guillemotleft>LessOrEqual\<guillemotright>Integer :: Boolean"

| WT_binop_GreaterThan:
  "P \<turnstile> Integer\<guillemotleft>GreaterThan\<guillemotright>Integer :: Boolean"

| WT_binop_GreaterOrEqual:
  "P \<turnstile> Integer\<guillemotleft>GreaterOrEqual\<guillemotright>Integer :: Boolean"

| WT_binop_Add:
  "P \<turnstile> Integer\<guillemotleft>Add\<guillemotright>Integer :: Integer"

| WT_binop_Subtract:
  "P \<turnstile> Integer\<guillemotleft>Subtract\<guillemotright>Integer :: Integer"

| WT_binop_Mult:
  "P \<turnstile> Integer\<guillemotleft>Mult\<guillemotright>Integer :: Integer"

| WT_binop_Div:
  "P \<turnstile> Integer\<guillemotleft>Div\<guillemotright>Integer :: Integer"

| WT_binop_Mod:
  "P \<turnstile> Integer\<guillemotleft>Mod\<guillemotright>Integer :: Integer"

| WT_binop_BinAnd_Bool:
  "P \<turnstile> Boolean\<guillemotleft>BinAnd\<guillemotright>Boolean :: Boolean"

| WT_binop_BinAnd_Int:
  "P \<turnstile> Integer\<guillemotleft>BinAnd\<guillemotright>Integer :: Integer"

| WT_binop_BinOr_Bool:
  "P \<turnstile> Boolean\<guillemotleft>BinOr\<guillemotright>Boolean :: Boolean"

| WT_binop_BinOr_Int:
  "P \<turnstile> Integer\<guillemotleft>BinOr\<guillemotright>Integer :: Integer"

| WT_binop_BinXor_Bool:
  "P \<turnstile> Boolean\<guillemotleft>BinXor\<guillemotright>Boolean :: Boolean"

| WT_binop_BinXor_Int:
  "P \<turnstile> Integer\<guillemotleft>BinXor\<guillemotright>Integer :: Integer"

| WT_binop_ShiftLeft:
  "P \<turnstile> Integer\<guillemotleft>ShiftLeft\<guillemotright>Integer :: Integer"

| WT_binop_ShiftRightZeros:
  "P \<turnstile> Integer\<guillemotleft>ShiftRightZeros\<guillemotright>Integer :: Integer"

| WT_binop_ShiftRightSigned:
  "P \<turnstile> Integer\<guillemotleft>ShiftRightSigned\<guillemotright>Integer :: Integer"

lemma WT_binopI [intro]:
  "P \<turnstile> T1 \<le> T2 \<or> P \<turnstile> T2 \<le> T1 \<Longrightarrow> P \<turnstile> T1\<guillemotleft>Eq\<guillemotright>T2 :: Boolean"
  "P \<turnstile> T1 \<le> T2 \<or> P \<turnstile> T2 \<le> T1 \<Longrightarrow> P \<turnstile> T1\<guillemotleft>NotEq\<guillemotright>T2 :: Boolean"
  "bop = Add \<or> bop = Subtract \<or> bop = Mult \<or> bop = Mod \<or> bop = Div \<or> bop = BinAnd \<or> bop = BinOr \<or> bop = BinXor \<or>
   bop = ShiftLeft \<or> bop = ShiftRightZeros \<or> bop = ShiftRightSigned
   \<Longrightarrow> P \<turnstile> Integer\<guillemotleft>bop\<guillemotright>Integer :: Integer"
  "bop = LessThan \<or> bop = LessOrEqual \<or> bop = GreaterThan \<or> bop = GreaterOrEqual \<Longrightarrow> P \<turnstile> Integer\<guillemotleft>bop\<guillemotright>Integer :: Boolean"
  "bop = BinAnd \<or> bop = BinOr \<or> bop = BinXor \<Longrightarrow> P \<turnstile> Boolean\<guillemotleft>bop\<guillemotright>Boolean :: Boolean"
by(auto intro: WT_binop.intros)

inductive_cases [elim]:
  "P \<turnstile> T1\<guillemotleft>Eq\<guillemotright>T2 :: T"
  "P \<turnstile> T1\<guillemotleft>NotEq\<guillemotright>T2 :: T"
  "P \<turnstile> T1\<guillemotleft>LessThan\<guillemotright>T2 :: T"
  "P \<turnstile> T1\<guillemotleft>LessOrEqual\<guillemotright>T2 :: T"
  "P \<turnstile> T1\<guillemotleft>GreaterThan\<guillemotright>T2 :: T"
  "P \<turnstile> T1\<guillemotleft>GreaterOrEqual\<guillemotright>T2 :: T"
  "P \<turnstile> T1\<guillemotleft>Add\<guillemotright>T2 :: T"
  "P \<turnstile> T1\<guillemotleft>Subtract\<guillemotright>T2 :: T"
  "P \<turnstile> T1\<guillemotleft>Mult\<guillemotright>T2 :: T"
  "P \<turnstile> T1\<guillemotleft>Div\<guillemotright>T2 :: T"
  "P \<turnstile> T1\<guillemotleft>Mod\<guillemotright>T2 :: T"
  "P \<turnstile> T1\<guillemotleft>BinAnd\<guillemotright>T2 :: T"
  "P \<turnstile> T1\<guillemotleft>BinOr\<guillemotright>T2 :: T"
  "P \<turnstile> T1\<guillemotleft>BinXor\<guillemotright>T2 :: T"
  "P \<turnstile> T1\<guillemotleft>ShiftLeft\<guillemotright>T2 :: T"
  "P \<turnstile> T1\<guillemotleft>ShiftRightZeros\<guillemotright>T2 :: T"
  "P \<turnstile> T1\<guillemotleft>ShiftRightSigned\<guillemotright>T2 :: T"

lemma WT_binop_fun: "\<lbrakk> P \<turnstile> T1\<guillemotleft>bop\<guillemotright>T2 :: T; P \<turnstile> T1\<guillemotleft>bop\<guillemotright>T2 :: T' \<rbrakk> \<Longrightarrow> T = T'"
by(cases bop)(auto)

lemma WT_binop_is_type:
  "\<lbrakk> P \<turnstile> T1\<guillemotleft>bop\<guillemotright>T2 :: T; is_type P T1; is_type P T2 \<rbrakk> \<Longrightarrow> is_type P T"
by(cases bop) auto

inductive WTrt_binop :: "'m prog \<Rightarrow> ty \<Rightarrow> bop \<Rightarrow> ty \<Rightarrow> ty \<Rightarrow> bool" ("_ \<turnstile> _\<guillemotleft>_\<guillemotright>_ : _" [51,0,0,0,51] 50)
where
  WTrt_binop_Eq:
  "P \<turnstile> T1\<guillemotleft>Eq\<guillemotright>T2 : Boolean"

| WTrt_binop_NotEq:
  "P \<turnstile> T1\<guillemotleft>NotEq\<guillemotright>T2 : Boolean"

| WTrt_binop_LessThan:
  "P \<turnstile> Integer\<guillemotleft>LessThan\<guillemotright>Integer : Boolean"

| WTrt_binop_LessOrEqual:
  "P \<turnstile> Integer\<guillemotleft>LessOrEqual\<guillemotright>Integer : Boolean"

| WTrt_binop_GreaterThan:
  "P \<turnstile> Integer\<guillemotleft>GreaterThan\<guillemotright>Integer : Boolean"

| WTrt_binop_GreaterOrEqual:
  "P \<turnstile> Integer\<guillemotleft>GreaterOrEqual\<guillemotright>Integer : Boolean"

| WTrt_binop_Add:
  "P \<turnstile> Integer\<guillemotleft>Add\<guillemotright>Integer : Integer"

| WTrt_binop_Subtract:
  "P \<turnstile> Integer\<guillemotleft>Subtract\<guillemotright>Integer : Integer"

| WTrt_binop_Mult:
  "P \<turnstile> Integer\<guillemotleft>Mult\<guillemotright>Integer : Integer"

| WTrt_binop_Div:
  "P \<turnstile> Integer\<guillemotleft>Div\<guillemotright>Integer : Integer"

| WTrt_binop_Mod:
  "P \<turnstile> Integer\<guillemotleft>Mod\<guillemotright>Integer : Integer"

| WTrt_binop_BinAnd_Bool:
  "P \<turnstile> Boolean\<guillemotleft>BinAnd\<guillemotright>Boolean : Boolean"

| WTrt_binop_BinAnd_Int:
  "P \<turnstile> Integer\<guillemotleft>BinAnd\<guillemotright>Integer : Integer"

| WTrt_binop_BinOr_Bool:
  "P \<turnstile> Boolean\<guillemotleft>BinOr\<guillemotright>Boolean : Boolean"

| WTrt_binop_BinOr_Int:
  "P \<turnstile> Integer\<guillemotleft>BinOr\<guillemotright>Integer : Integer"

| WTrt_binop_BinXor_Bool:
  "P \<turnstile> Boolean\<guillemotleft>BinXor\<guillemotright>Boolean : Boolean"

| WTrt_binop_BinXor_Int:
  "P \<turnstile> Integer\<guillemotleft>BinXor\<guillemotright>Integer : Integer"

| WTrt_binop_ShiftLeft:
  "P \<turnstile> Integer\<guillemotleft>ShiftLeft\<guillemotright>Integer : Integer"

| WTrt_binop_ShiftRightZeros:
  "P \<turnstile> Integer\<guillemotleft>ShiftRightZeros\<guillemotright>Integer : Integer"

| WTrt_binop_ShiftRightSigned:
  "P \<turnstile> Integer\<guillemotleft>ShiftRightSigned\<guillemotright>Integer : Integer"

inductive_cases WTrt_binop_cases [elim]:
  "P \<turnstile> T1\<guillemotleft>Eq\<guillemotright>T2 : T"
  "P \<turnstile> T1\<guillemotleft>NotEq\<guillemotright>T2 : T"
  "P \<turnstile> T1\<guillemotleft>LessThan\<guillemotright>T2 : T"
  "P \<turnstile> T1\<guillemotleft>LessOrEqual\<guillemotright>T2 : T"
  "P \<turnstile> T1\<guillemotleft>GreaterThan\<guillemotright>T2 : T"
  "P \<turnstile> T1\<guillemotleft>GreaterOrEqual\<guillemotright>T2 : T"
  "P \<turnstile> T1\<guillemotleft>Add\<guillemotright>T2 : T"
  "P \<turnstile> T1\<guillemotleft>Subtract\<guillemotright>T2 : T"
  "P \<turnstile> T1\<guillemotleft>Mult\<guillemotright>T2 : T"
  "P \<turnstile> T1\<guillemotleft>Div\<guillemotright>T2 : T"
  "P \<turnstile> T1\<guillemotleft>Mod\<guillemotright>T2 : T"
  "P \<turnstile> T1\<guillemotleft>BinAnd\<guillemotright>T2 : T"
  "P \<turnstile> T1\<guillemotleft>BinOr\<guillemotright>T2 : T"
  "P \<turnstile> T1\<guillemotleft>BinXor\<guillemotright>T2 : T"
  "P \<turnstile> T1\<guillemotleft>ShiftLeft\<guillemotright>T2 : T"
  "P \<turnstile> T1\<guillemotleft>ShiftRightZeros\<guillemotright>T2 : T"
  "P \<turnstile> T1\<guillemotleft>ShiftRightSigned\<guillemotright>T2 : T"

inductive_simps WTrt_binop_simps [simp]:
  "P \<turnstile> T1\<guillemotleft>Eq\<guillemotright>T2 : T"
  "P \<turnstile> T1\<guillemotleft>NotEq\<guillemotright>T2 : T"
  "P \<turnstile> T1\<guillemotleft>LessThan\<guillemotright>T2 : T"
  "P \<turnstile> T1\<guillemotleft>LessOrEqual\<guillemotright>T2 : T"
  "P \<turnstile> T1\<guillemotleft>GreaterThan\<guillemotright>T2 : T"
  "P \<turnstile> T1\<guillemotleft>GreaterOrEqual\<guillemotright>T2 : T"
  "P \<turnstile> T1\<guillemotleft>Add\<guillemotright>T2 : T"
  "P \<turnstile> T1\<guillemotleft>Subtract\<guillemotright>T2 : T"
  "P \<turnstile> T1\<guillemotleft>Mult\<guillemotright>T2 : T"
  "P \<turnstile> T1\<guillemotleft>Div\<guillemotright>T2 : T"
  "P \<turnstile> T1\<guillemotleft>Mod\<guillemotright>T2 : T"
  "P \<turnstile> T1\<guillemotleft>BinAnd\<guillemotright>T2 : T"
  "P \<turnstile> T1\<guillemotleft>BinOr\<guillemotright>T2 : T"
  "P \<turnstile> T1\<guillemotleft>BinXor\<guillemotright>T2 : T"
  "P \<turnstile> T1\<guillemotleft>ShiftLeft\<guillemotright>T2 : T"
  "P \<turnstile> T1\<guillemotleft>ShiftRightZeros\<guillemotright>T2 : T"
  "P \<turnstile> T1\<guillemotleft>ShiftRightSigned\<guillemotright>T2 : T"

fun binop_relevant_class :: "bop \<Rightarrow> 'm prog \<Rightarrow> cname \<Rightarrow> bool"
where
  "binop_relevant_class Div = (\<lambda>P C. P \<turnstile> ArithmeticException \<preceq>\<^sup>* C )"
| "binop_relevant_class Mod = (\<lambda>P C. P \<turnstile> ArithmeticException \<preceq>\<^sup>* C )"
| "binop_relevant_class _ = (\<lambda>P C. False)"

lemma WT_binop_WTrt_binop:
  "P \<turnstile> T1\<guillemotleft>bop\<guillemotright>T2 :: T \<Longrightarrow> P \<turnstile> T1\<guillemotleft>bop\<guillemotright>T2 : T"
by(auto elim: WT_binop.cases)

context heap begin

lemma binop_progress:
  "\<lbrakk> typeof\<^bsub>h\<^esub> v1 = \<lfloor>T1\<rfloor>; typeof\<^bsub>h\<^esub> v2 = \<lfloor>T2\<rfloor>; P \<turnstile> T1\<guillemotleft>bop\<guillemotright>T2 : T \<rbrakk>
  \<Longrightarrow> \<exists>va. binop bop v1 v2 = \<lfloor>va\<rfloor>"
by(cases bop)(auto del: disjCI split del: if_split)

lemma binop_type:
  assumes wf: "wf_prog wf_md P"
  and pre: "preallocated h"
  and type: "typeof\<^bsub>h\<^esub> v1 = \<lfloor>T1\<rfloor>" "typeof\<^bsub>h\<^esub> v2 = \<lfloor>T2\<rfloor>" "P \<turnstile> T1\<guillemotleft>bop\<guillemotright>T2 : T"
  shows "binop bop v1 v2 = \<lfloor>Inl v\<rfloor> \<Longrightarrow> P,h \<turnstile> v :\<le> T"
  and "binop bop v1 v2 = \<lfloor>Inr a\<rfloor> \<Longrightarrow> P,h \<turnstile> Addr a :\<le> Class Throwable"
using type
apply(case_tac [!] bop)
apply(auto split: if_split_asm simp add: conf_def wf_preallocatedD[OF wf pre])
done

lemma binop_relevant_class:
  assumes wf: "wf_prog wf_md P"
  and pre: "preallocated h"
  and bop: "binop bop v1 v2 = \<lfloor>Inr a\<rfloor>"
  and sup: "P \<turnstile> cname_of h a \<preceq>\<^sup>* C"
  shows "binop_relevant_class bop P C"
using assms
by(cases bop)(auto split: if_split_asm)

end

lemma WTrt_binop_fun: "\<lbrakk> P \<turnstile> T1\<guillemotleft>bop\<guillemotright>T2 : T; P \<turnstile> T1\<guillemotleft>bop\<guillemotright>T2 : T' \<rbrakk> \<Longrightarrow> T = T'"
by(cases bop)(auto)

lemma WTrt_binop_THE [simp]: "P \<turnstile> T1\<guillemotleft>bop\<guillemotright>T2 : T \<Longrightarrow> The (WTrt_binop P T1 bop T2) = T"
by(auto dest: WTrt_binop_fun)

lemma WTrt_binop_widen_mono:
  "\<lbrakk> P \<turnstile> T1\<guillemotleft>bop\<guillemotright>T2 : T; P \<turnstile> T1' \<le> T1; P \<turnstile> T2' \<le> T2 \<rbrakk> \<Longrightarrow> \<exists>T'. P \<turnstile> T1'\<guillemotleft>bop\<guillemotright>T2' : T' \<and> P \<turnstile> T' \<le> T"
by(cases bop)(auto elim!: WTrt_binop_cases)

lemma WTrt_binop_is_type:
  "\<lbrakk> P \<turnstile> T1\<guillemotleft>bop\<guillemotright>T2 : T; is_type P T1; is_type P T2 \<rbrakk> \<Longrightarrow> is_type P T"
by(cases bop) auto

subsection \<open>Code generator setup\<close>

lemmas [code] =
  heap_base.binop_Div.simps
  heap_base.binop_Mod.simps
  heap_base.binop.simps

code_pred
  (modes: i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> bool, i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> bool)
  WT_binop
.

code_pred
  (modes: i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> bool, i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> bool)
  WTrt_binop
.

lemma eval_WTrt_binop_i_i_i_i_o:
  "Predicate.eval (WTrt_binop_i_i_i_i_o P T1 bop T2) T \<longleftrightarrow> P \<turnstile> T1\<guillemotleft>bop\<guillemotright>T2 : T"
by(auto elim: WTrt_binop_i_i_i_i_oE intro: WTrt_binop_i_i_i_i_oI)

lemma the_WTrt_binop_code:
  "(THE T. P \<turnstile> T1\<guillemotleft>bop\<guillemotright>T2 : T) = Predicate.the (WTrt_binop_i_i_i_i_o P T1 bop T2)"
by(simp add: Predicate.the_def eval_WTrt_binop_i_i_i_i_o)

end