(* Title: Partial Semigroups
   Author: Brijesh Dongol, Victor Gomes, Ian J Hayes, Georg Struth
   Maintainer: Victor Gomes <victor.gomes@cl.cam.ac.uk>
               Georg Struth <g.struth@sheffield.ac.uk>
*)

section \<open>Partial Semigroups\<close>

theory Partial_Semigroups
  imports Main

begin

notation times (infixl "\<cdot>" 70)
  and times (infixl "\<oplus>" 70)

subsection \<open>Partial Semigroups\<close>

text \<open>In this context, partiality is modelled by a definedness constraint $D$ instead of a bottom element,
which would make the algebra total. This is common practice in mathematics.\<close>

class partial_times = times +
  fixes D :: "'a \<Rightarrow> 'a \<Rightarrow> bool"

text \<open>The definedness constraints for associativity state that the right-hand side of the associativity
law is defined if and only if the left-hand side is and that, in this case, both sides are equal. This and
slightly different constraints can be found in the literature.\<close>

class partial_semigroup = partial_times +
  assumes add_assocD: "D y z \<and> D x (y \<cdot> z) \<longleftrightarrow> D x y \<and> D (x \<cdot> y) z"
  and add_assoc: "D x y \<and> D (x \<cdot> y) z \<Longrightarrow> (x \<cdot> y) \<cdot> z = x \<cdot> (y \<cdot> z)"

text \<open>Every semigroup is a partial semigroup.\<close>

sublocale semigroup_mult \<subseteq> sg: partial_semigroup _ "\<lambda>x y. True"
  by standard (simp_all add: mult_assoc)

context partial_semigroup
begin

text \<open>The following abbreviation is useful for sublocale statements.\<close>

abbreviation (input) "R x y z \<equiv> D y z \<and> x = y \<cdot> z"

lemma add_assocD_var1: "D y z \<and> D x (y \<cdot> z) \<Longrightarrow> D x y \<and> D (x \<cdot> y) z"
  by (simp add: add_assocD)

lemma add_assocD_var2: " D x y \<and> D (x \<cdot> y) z \<Longrightarrow> D y z \<and> D x (y \<cdot> z)"
  by (simp add: add_assocD)

lemma add_assoc_var: " D y z \<and> D x (y \<cdot> z) \<Longrightarrow> (x \<cdot> y) \<cdot> z = x \<cdot> (y \<cdot> z)"
  by (simp add: add_assoc add_assocD)

subsection \<open>Green's Preorders and Green's Relations\<close>

text \<open>We define the standard Green's preorders and Green's relations. They are usually defined on monoids.
  On (partial) semigroups, we only obtain transitive relations.\<close>

definition gR_rel :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<preceq>\<^sub>R" 50) where
  "x \<preceq>\<^sub>R y = (\<exists>z. D x z \<and> x \<cdot> z = y)"

definition strict_gR_rel :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<prec>\<^sub>R" 50) where
  "x \<prec>\<^sub>R y = (x \<preceq>\<^sub>R y \<and> \<not> y \<preceq>\<^sub>R x)"

definition gL_rel :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<preceq>\<^sub>L" 50) where
  "x \<preceq>\<^sub>L y = (\<exists>z. D z x \<and> z \<cdot> x = y)"

definition strict_gL_rel :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<prec>\<^sub>L" 50) where
  "x \<prec>\<^sub>L y = (x \<preceq>\<^sub>L y \<and> \<not> y \<preceq>\<^sub>L x)"

definition gH_rel :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<preceq>\<^sub>H" 50) where
  "x \<preceq>\<^sub>H y = (x \<preceq>\<^sub>L y \<and> x \<preceq>\<^sub>R y)"

definition gJ_rel :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<preceq>\<^sub>J" 50) where
  "x \<preceq>\<^sub>J y = (\<exists>v w. D v x \<and> D (v \<cdot> x) w \<and> (v \<cdot> x) \<cdot> w = y)"

definition "gR x y = (x \<preceq>\<^sub>R y \<and> y \<preceq>\<^sub>R x)"

definition "gL x y = (x \<preceq>\<^sub>L y \<and> y \<preceq>\<^sub>L x)"

definition "gH x y = (x \<preceq>\<^sub>H y \<and> y \<preceq>\<^sub>H x)"

definition "gJ x y = (x \<preceq>\<^sub>J y \<and> y \<preceq>\<^sub>J x)"

definition gR_downset :: "'a \<Rightarrow> 'a set" ("_\<down>" [100]100) where
  "x\<down> \<equiv> {y. y \<preceq>\<^sub>R x}"

text \<open>The following counterexample rules out reflexivity.\<close>

lemma "x \<preceq>\<^sub>R x" (* nitpick [expect=genuine] *)
  oops

lemma gR_rel_trans: "x \<preceq>\<^sub>R y \<Longrightarrow> y \<preceq>\<^sub>R z \<Longrightarrow> x \<preceq>\<^sub>R z"
  by (metis gR_rel_def add_assoc add_assocD_var2)

lemma gL_rel_trans: "x \<preceq>\<^sub>L y \<Longrightarrow> y \<preceq>\<^sub>L z \<Longrightarrow> x \<preceq>\<^sub>L z"
  by (metis gL_rel_def add_assocD_var1 add_assoc_var)

lemma gR_add_isol: "D z y \<Longrightarrow> x \<preceq>\<^sub>R y \<Longrightarrow> z \<cdot> x \<preceq>\<^sub>R z \<cdot> y"
  apply (simp add: gR_rel_def)
  using add_assocD_var1 add_assoc_var by blast

lemma gL_add_isor: "D y z \<Longrightarrow> x \<preceq>\<^sub>L y \<Longrightarrow> x \<cdot> z \<preceq>\<^sub>L y \<cdot> z"
  apply (simp add: gL_rel_def)
  by (metis add_assoc add_assocD_var2)

definition annil :: "'a \<Rightarrow> bool" where
  "annil x = (\<forall>y. D x y \<and> x \<cdot> y = x)"

definition annir :: "'a \<Rightarrow> bool" where
  "annir x = (\<forall>y. D y x \<and> y \<cdot> x = x)"

end

subsection \<open>Morphisms\<close>

definition ps_morphism :: "('a::partial_semigroup \<Rightarrow> 'b::partial_semigroup) \<Rightarrow> bool" where
  "ps_morphism f = (\<forall>x y. D x y \<longrightarrow> D (f x) (f y) \<and> f (x \<cdot> y) = (f x) \<cdot> (f y))"

definition strong_ps_morphism :: "('a::partial_semigroup \<Rightarrow> 'b::partial_semigroup) \<Rightarrow> bool" where
  "strong_ps_morphism f = (ps_morphism f \<and> (\<forall>x y. D (f x) (f y) \<longrightarrow> D x y))"

subsection \<open> Locally Finite Partial Semigroups\<close>

text \<open>In locally finite partial semigroups,  elements can only be split in finitely many ways.\<close>

class locally_finite_partial_semigroup = partial_semigroup +
  assumes loc_fin: "finite (x\<down>)"

subsection \<open>Cancellative Partial Semigroups\<close>

class cancellative_partial_semigroup = partial_semigroup +
  assumes add_cancl: "D z x \<Longrightarrow> D z y \<Longrightarrow> z \<cdot> x = z \<cdot> y \<Longrightarrow> x = y"
  and add_cancr: "D x z \<Longrightarrow> D y z \<Longrightarrow> x \<cdot> z = y \<cdot> z \<Longrightarrow> x = y"

begin

lemma unique_resl: "D x z \<Longrightarrow> D x z' \<Longrightarrow> x \<cdot> z = y \<Longrightarrow> x \<cdot> z' = y \<Longrightarrow> z = z'"
  by (simp add: add_cancl)

lemma unique_resr: "D z x \<Longrightarrow> D z' x  \<Longrightarrow> z \<cdot> x = y \<Longrightarrow> z' \<cdot> x = y \<Longrightarrow> z = z'"
  by (simp add: add_cancr)

lemma gR_rel_mult: "D x y \<Longrightarrow> x \<preceq>\<^sub>R x \<cdot> y"
  using gR_rel_def by force

lemma gL_rel_mult: "D x y \<Longrightarrow> y \<preceq>\<^sub>L x \<cdot> y"
  using gL_rel_def by force

text \<open>By cancellation, the element z is uniquely defined for each pair x y, provided it exists.
       In both cases, z is therefore a function of x and y; it is a quotient or residual of x y.\<close>

lemma quotr_unique: "x \<preceq>\<^sub>R y  \<Longrightarrow> (\<exists>!z. D x z \<and> y = x \<cdot> z)"
  using gR_rel_def add_cancl by force

lemma quotl_unique: "x \<preceq>\<^sub>L y \<Longrightarrow> (\<exists>!z. D z x \<and> y = z \<cdot> x)"
  using gL_rel_def unique_resr by force

definition "rquot y x = (THE z. D x z \<and> x \<cdot> z = y)"

definition "lquot y x = (THE z. D z x \<and> z \<cdot> x = y)"

lemma rquot_prop: "D x z \<and> y = x \<cdot> z \<Longrightarrow> z = rquot y x"
  by (metis (mono_tags, lifting) rquot_def the_equality unique_resl)

lemma rquot_mult: "x \<preceq>\<^sub>R y \<Longrightarrow> z = rquot y x \<Longrightarrow> x \<cdot> z = y"
  using gR_rel_def rquot_prop by force

lemma rquot_D: "x \<preceq>\<^sub>R y \<Longrightarrow> z = rquot y x \<Longrightarrow> D x z"
  using gR_rel_def rquot_prop by force

lemma add_rquot: "x \<preceq>\<^sub>R y \<Longrightarrow> (D x z \<and> x \<oplus> z = y \<longleftrightarrow> z = rquot y x)"
  using gR_rel_def rquot_prop by fastforce

lemma add_canc1: "D x y \<Longrightarrow> rquot (x \<cdot> y) x = y"
  using rquot_prop by simp

lemma add_canc2: "x \<preceq>\<^sub>R y \<Longrightarrow> x \<cdot> (rquot y x) = y"
  using gR_rel_def add_canc1 by force

lemma add_canc2_prop: "x \<preceq>\<^sub>R y \<Longrightarrow> rquot y x \<preceq>\<^sub>L y"
  using gL_rel_mult rquot_D rquot_mult by fastforce

text \<open>The next set of lemmas establishes standard Galois connections for cancellative partial semigroups.\<close>

lemma gR_galois_imp1: "D x z \<Longrightarrow> x \<cdot> z \<preceq>\<^sub>R y \<Longrightarrow> z \<preceq>\<^sub>R rquot y x"
  by (metis gR_rel_def add_assoc add_assocD_var2 rquot_prop)

lemma gR_galois_imp21: "x \<preceq>\<^sub>R y \<Longrightarrow> z \<preceq>\<^sub>R rquot y x \<Longrightarrow> x \<cdot> z \<preceq>\<^sub>R y"
  using gR_add_isol rquot_D rquot_mult by fastforce

lemma gR_galois_imp22: "x \<preceq>\<^sub>R y \<Longrightarrow> z \<preceq>\<^sub>R rquot y x \<Longrightarrow> D x z"
  using gR_rel_def add_assocD add_canc1 by fastforce

lemma gR_galois: "x \<preceq>\<^sub>R y \<Longrightarrow> (D x z \<and> x \<cdot> z \<preceq>\<^sub>R y \<longleftrightarrow> z \<preceq>\<^sub>R rquot y x)"
  using gR_galois_imp1 gR_galois_imp21 gR_galois_imp22  by blast

lemma gR_rel_defined: "x \<preceq>\<^sub>R y \<Longrightarrow> D x (rquot y x)"
  by (simp add: rquot_D)

lemma ex_add_galois: "D x z \<Longrightarrow> (\<exists>y. x \<cdot> z = y \<longleftrightarrow> rquot y x = z)"
  using add_canc1 by force

end

subsection \<open>Partial Monoids\<close>

text \<open>We allow partial monoids with multiple units. This is similar to and inspired by small categories.\<close>

class partial_monoid = partial_semigroup +
  fixes E :: "'a set"
  assumes unitl_ex: "\<exists>e \<in> E. D e x \<and> e \<cdot> x = x"
  and unitr_ex: "\<exists>e \<in> E. D x e \<and> x \<cdot> e = x"
  and units_eq: "e1 \<in> E \<Longrightarrow> e2 \<in> E \<Longrightarrow> D e1 e2 \<Longrightarrow> e1 = e2"

text \<open>Every monoid is a partial monoid.\<close>

sublocale monoid_mult \<subseteq> mon: partial_monoid _ "\<lambda>x y. True" "{1}"
  by (standard; simp_all)

context partial_monoid
begin

lemma units_eq_var: "e1 \<in> E \<Longrightarrow> e2 \<in> E \<Longrightarrow> e1 \<noteq> e2 \<Longrightarrow> \<not> D e1 e2"
  using units_eq by force

text \<open>In partial monoids, Green's relations become preorders, but need not be partial orders.\<close>

sublocale gR: preorder gR_rel strict_gR_rel
  apply standard
  apply (simp add: strict_gR_rel_def)
  using gR_rel_def unitr_ex apply force
  using gR_rel_trans by blast

sublocale gL: preorder gL_rel strict_gL_rel
  apply standard
  apply (simp add: strict_gL_rel_def)
  using gL_rel_def unitl_ex apply force
  using gL_rel_trans by blast

lemma "x \<preceq>\<^sub>R y \<Longrightarrow> y \<preceq>\<^sub>R x \<Longrightarrow> x = y" (* nitpick [expect=genuine] *)
  oops

lemma "annil x \<Longrightarrow> annil y \<Longrightarrow> x = y" (* nitpick [expext=genuine] *)
  oops

lemma  "annir x \<Longrightarrow> annir y \<Longrightarrow> x = y" (* nitpick [expect=genuine] *)
  oops

end

text \<open>Next we define partial monoid morphisms.\<close>

definition pm_morphism :: "('a::partial_monoid \<Rightarrow> 'b::partial_monoid) \<Rightarrow> bool" where
  "pm_morphism f = (ps_morphism f \<and> (\<forall>e. e \<in> E \<longrightarrow> (f e) \<in> E))"

definition strong_pm_morphism :: "('a::partial_monoid \<Rightarrow> 'b::partial_monoid) \<Rightarrow> bool" where
  "strong_pm_morphism f = (pm_morphism f \<and> (\<forall>e. (f e) \<in> E \<longrightarrow> e \<in> E))"

text \<open>Partial Monoids with a single unit form a special case.\<close>

class partial_monoid_one = partial_semigroup + one +
  assumes oneDl: "D x 1"
  and oneDr: "D 1 x"
  and oner: "x \<cdot> 1 = x"
  and onel: "1 \<cdot> x = x"

begin

sublocale pmo: partial_monoid _ _ "{1}"
  by standard (simp_all add: oneDr onel oneDl oner)

end

subsection \<open>Cancellative Partial Monoids\<close>

class cancellative_partial_monoid = cancellative_partial_semigroup + partial_monoid

begin

lemma canc_unitr: "D x e \<Longrightarrow> x \<cdot> e = x \<Longrightarrow> e \<in> E"
  by (metis add_cancl unitr_ex)

lemma canc_unitl: "D e x \<Longrightarrow> e \<cdot> x = x \<Longrightarrow> e \<in> E"
  by (metis add_cancr unitl_ex)

end

subsection \<open>Positive Partial Monoids\<close>

class positive_partial_monoid  = partial_monoid +
  assumes posl: "D x y \<Longrightarrow> x \<cdot> y \<in> E \<Longrightarrow> x \<in> E"
  and posr: "D x y \<Longrightarrow> x \<cdot> y \<in> E \<Longrightarrow> y \<in> E"

begin

lemma pos_unitl: "D x y \<Longrightarrow> e \<in> E \<Longrightarrow> x \<cdot> y = e \<Longrightarrow> x = e"
  by (metis posl posr unitr_ex units_eq_var)

lemma pos_unitr: "D x y \<Longrightarrow> e \<in> E \<Longrightarrow> x \<cdot> y = e \<Longrightarrow> y = e"
  by (metis posl posr unitr_ex units_eq_var)

end

subsection \<open>Positive Cancellative Partial Monoids\<close>

class positive_cancellative_partial_monoid = positive_partial_monoid + cancellative_partial_monoid

begin

text \<open>In positive cancellative monoids, the Green's relations are partial orders.\<close>

sublocale pcpmR: order gR_rel strict_gR_rel
  apply standard
  apply (clarsimp simp: gR_rel_def)
  by (metis canc_unitr add_assoc add_assocD_var2 pos_unitl)

sublocale pcpmL: order gL_rel strict_gL_rel
  apply standard
  apply (clarsimp simp: gL_rel_def)
  by (metis canc_unitl add_assoc add_assocD_var1 pos_unitr)

end

subsection \<open>From Partial Abelian Semigroups to Partial Abelian Monoids\<close>

text \<open>Next we define partial abelian semigroups. These are interesting, e.g., for the foundations
of quantum mechanics and as resource monoids in separation logic.\<close>

class pas = partial_semigroup +
  assumes add_comm: "D x y \<Longrightarrow> D y x \<and> x \<oplus> y = y \<oplus> x"

begin

lemma D_comm: "D x y \<longleftrightarrow> D y x"
  by (auto simp add: add_comm)

lemma annilr: "annil x = annir x"
  by (metis annil_def annir_def add_comm)

lemma anni_unique: "annil x \<Longrightarrow> annil y \<Longrightarrow> x = y"
  by (metis annilr annil_def annir_def)

end

text \<open>The following classes collect families of partially ordered abelian semigroups and monoids.\<close>

class locally_finite_pas = pas + locally_finite_partial_semigroup

class pam = pas + partial_monoid

class cancellative_pam = pam + cancellative_partial_semigroup

class positive_pam = pam + positive_partial_monoid

class positive_cancellative_pam  = positive_pam + cancellative_pam

class generalised_effect_algebra = pas + partial_monoid_one

class cancellative_pam_one = cancellative_pam + partial_monoid_one

class positive_cancellative_pam_one = positive_cancellative_pam  + cancellative_pam_one

context cancellative_pam_one
begin

lemma E_eq_one: "E = {1}"
  by (metis oneDr oner unitl_ex units_eq singleton_iff subsetI subset_antisym)

lemma one_in_E: "1 \<in> E"
  by (simp add: E_eq_one)

end

subsection \<open>Alternative Definitions\<close>

text \<open>PAS's can be axiomatised more compactly as follows.\<close>

class pas_alt = partial_times +
  assumes pas_alt_assoc: "D x y \<and> D (x \<oplus> y) z \<Longrightarrow> D y z \<and> D x (y \<oplus> z) \<and> (x \<oplus> y) \<oplus> z = x \<oplus> (y \<oplus> z)"
  and pas_alt_comm: "D x y \<Longrightarrow> D y x \<and> x \<oplus> y = y \<oplus> x"

sublocale pas_alt \<subseteq> palt: pas
  apply standard
  using pas_alt_assoc pas_alt_comm by blast+

text \<open>Positive abelian PAM's can be axiomatised more compactly as well.\<close>

class pam_pos_alt = pam +
  assumes pos_alt: "D x y \<Longrightarrow> e \<in> E \<Longrightarrow> x \<oplus> y = e \<Longrightarrow> x = e"

sublocale pam_pos_alt \<subseteq> ppalt: positive_pam
  apply standard
  using pos_alt apply force
  using add_comm pos_alt by fastforce

subsection \<open>Product Constructions\<close>

text \<open>We consider two kinds of product construction. The first one combines partial semigroups with sets,
        the second one partial semigroups with partial semigroups. The first one is interesting for
        Separation Logic. Semidirect product constructions are considered later.\<close>

instantiation prod :: (type, partial_semigroup) partial_semigroup
begin

definition "D_prod x y = (fst x = fst y \<and> D (snd x) (snd y))"
  for x y :: "'a \<times> 'b"

definition times_prod :: "'a \<times> 'b \<Rightarrow> 'a \<times> 'b \<Rightarrow> 'a \<times> 'b" where
  "times_prod x y = (fst x, snd x \<cdot> snd y)"

instance
  apply (standard, simp_all add: D_prod_def times_prod_def)
  using partial_semigroup_class.add_assocD apply force
  by (simp add: partial_semigroup_class.add_assoc)

end

instantiation prod :: (type, partial_monoid) partial_monoid
begin

definition E_prod :: "('a \<times> 'b) set" where
  "E_prod = {x. snd x \<in> E}"

instance
  apply (standard, simp_all add: D_prod_def times_prod_def E_prod_def)
  using partial_monoid_class.unitl_ex apply fastforce
  using partial_monoid_class.unitr_ex apply fastforce
  by (simp add: partial_monoid_class.units_eq prod_eq_iff)

end

instance prod :: (type, pas) pas
  apply (standard, simp add: D_prod_def times_prod_def)
  using pas_class.add_comm by force

lemma prod_div1: "(x1::'a, y1::'b::pas) \<preceq>\<^sub>R (x2::'a, y2::'b::pas) \<Longrightarrow> x1 = x2"
  by (force simp: partial_semigroup_class.gR_rel_def times_prod_def)

lemma prod_div2: "(x1, y1) \<preceq>\<^sub>R (x2, y2) \<Longrightarrow> y1 \<preceq>\<^sub>R y2"
  by (force simp: partial_semigroup_class.gR_rel_def D_prod_def times_prod_def)

lemma prod_div_eq: "(x1, y1) \<preceq>\<^sub>R (x2, y2) \<longleftrightarrow> x1 = x2 \<and> y1 \<preceq>\<^sub>R y2"
  by (force simp: partial_semigroup_class.gR_rel_def D_prod_def times_prod_def)

instance prod :: (type, pam) pam
  by standard

instance prod :: (type, cancellative_pam) cancellative_pam
  by (standard, auto simp: D_prod_def times_prod_def add_cancr add_cancl)

lemma prod_res_eq: "(x1, y1) \<preceq>\<^sub>R (x2::'a,y2::'b::cancellative_pam)
    \<Longrightarrow> rquot (x2, y2) (x1, y1) = (x1, rquot y2 y1)"
  apply (clarsimp simp: partial_semigroup_class.gR_rel_def D_prod_def times_prod_def rquot_def)
  apply (rule theI2 conjI)
    apply force
  using add_cancl apply force
  by (rule the_equality, auto simp: add_cancl)

instance prod :: (type, positive_pam) positive_pam
   apply (standard, simp_all add: E_prod_def D_prod_def times_prod_def)
  using positive_partial_monoid_class.posl apply blast
  using positive_partial_monoid_class.posr by blast

instance prod :: (type, positive_cancellative_pam) positive_cancellative_pam ..

instance prod :: (type, locally_finite_pas) locally_finite_pas
proof (standard, case_tac x, clarsimp)
  fix s :: 'a and x :: 'b
  have "finite (x\<down>)"
    by (simp add: loc_fin)
  hence "finite {y. \<exists>z. D y z \<and> y \<oplus> z = x}"
    by (simp add: partial_semigroup_class.gR_downset_def partial_semigroup_class.gR_rel_def)
  hence "finite {(s, y)| y. \<exists>z. D y z \<and> y \<oplus> z = x}"
    by (drule_tac f="\<lambda>y. (s, y)" in finite_image_set)
  moreover have "{y. \<exists>z1 z2. D y (z1, z2) \<and> y \<oplus> (z1, z2) = (s, x)}
                    \<subseteq> {(s, y)| y. \<exists>z. D y z \<and> y \<oplus> z = x}"
    by (auto simp: D_prod_def times_prod_def)
  ultimately have "finite {y. \<exists>z1 z2. D y (z1, z2) \<and> y \<oplus> (z1, z2) = (s, x)}"
    by (auto intro: finite_subset)
  thus "finite ((s, x)\<down>)"
    by (simp add: partial_semigroup_class.gR_downset_def partial_semigroup_class.gR_rel_def)
qed

text \<open>Next we consider products of two partial semigroups.\<close>

definition ps_prod_D :: "'a :: partial_semigroup \<times> 'b :: partial_semigroup \<Rightarrow> 'a \<times> 'b  \<Rightarrow> bool"
  where "ps_prod_D x y \<equiv> D (fst x) (fst y) \<and> D (snd x) (snd y)"

definition ps_prod_times :: "'a :: partial_semigroup \<times> 'b :: partial_semigroup \<Rightarrow> 'a \<times> 'b \<Rightarrow> 'a \<times> 'b"
   where "ps_prod_times x y = (fst x \<cdot> fst y, snd x \<cdot> snd y)"

interpretation ps_prod: partial_semigroup ps_prod_times ps_prod_D
  apply (standard, simp_all add: ps_prod_D_def ps_prod_times_def)
  apply (meson partial_semigroup_class.add_assocD)
  by (simp add: partial_semigroup_class.add_assoc)

interpretation pas_prod: pas ps_prod_times "ps_prod_D :: 'a :: pas \<times> 'b :: pas \<Rightarrow> 'a \<times> 'b  \<Rightarrow> bool"
  by (standard, clarsimp simp: ps_prod_D_def ps_prod_times_def pas_class.add_comm)

definition pm_prod_E :: "('a :: partial_monoid \<times> 'b :: partial_monoid) set" where
  "pm_prod_E = {x. fst x \<in> E \<and> snd x \<in> E}"

interpretation pm_prod: partial_monoid ps_prod_times ps_prod_D pm_prod_E
  apply standard
  apply (simp_all add: ps_prod_times_def ps_prod_D_def pm_prod_E_def)
  apply (metis partial_monoid_class.unitl_ex prod.collapse)
  apply (metis partial_monoid_class.unitr_ex prod.collapse)
  by (simp add: partial_monoid_class.units_eq prod.expand)

interpretation pam_prod: pam ps_prod_times ps_prod_D "pm_prod_E :: ('a :: pam \<times> 'a :: pam) set" ..

subsection \<open>Partial Semigroup Actions and Semidirect Products\<close>

text \<open>(Semi)group actions are a standard mathematical construction. We generalise this to partial
semigroups and monoids. We use it to define semidirect products of partial semigroups. A generalisation
to wreath products might be added in the future.\<close>

text \<open>First we define the (left) action of a partial semigroup on a set. A right action could be defined in a similar way,
but we do not pursue this at the moment.\<close>

locale partial_sg_laction =
  fixes Dla :: "'a::partial_semigroup \<Rightarrow> 'b \<Rightarrow> bool"
  and act :: "'a::partial_semigroup \<Rightarrow> 'b \<Rightarrow> 'b" ("\<alpha>")
  assumes act_assocD: "D x y \<and> Dla (x \<cdot> y) p \<longleftrightarrow> Dla y p \<and> Dla x (\<alpha> y p)"
  and act_assoc: "D x y \<and> Dla (x \<cdot> y) p \<Longrightarrow> \<alpha> (x \<cdot> y) p = \<alpha> x (\<alpha> y p)"

text \<open>Next we define the action of a partial semigroup on another partial semigroup.
In the tradition of semigroup theory we use addition as a non-commutative operation for the second semigroup.\<close>

locale partial_sg_sg_laction = partial_sg_laction +
  assumes act_distribD: "D (p::'b::partial_semigroup) q \<and> Dla (x::'a::partial_semigroup) (p \<oplus> q) \<longleftrightarrow> Dla x p \<and> Dla x q \<and> D (\<alpha> x p) (\<alpha> x q)"
  and act_distrib: "D p q \<and> Dla x (p \<oplus> q) \<Longrightarrow> \<alpha> x (p \<oplus> q) = (\<alpha> x p) \<oplus> (\<alpha> x q)"

begin

text \<open>Next we define the semidirect product as a partial operation and show that the semidirect
product of two partial semigroups forms a partial semigroup.\<close>

definition sd_D :: "('a \<times> 'b) \<Rightarrow> ('a \<times> 'b) \<Rightarrow> bool" where
  "sd_D x y \<equiv> D (fst x) (fst y) \<and> Dla (fst x) (snd y) \<and> D (snd x) (\<alpha> (fst x) (snd y))"

definition sd_prod :: "('a \<times> 'b) \<Rightarrow> ('a \<times> 'b) \<Rightarrow> ('a \<times> 'b)" where
  "sd_prod x y = ((fst x) \<cdot> (fst y), (snd x) \<oplus> (\<alpha> (fst x) (snd y)))"

sublocale dp_semigroup: partial_semigroup sd_prod sd_D
  apply unfold_locales
   apply (simp_all add: sd_prod_def sd_D_def)
   apply (clarsimp, metis act_assoc act_assocD act_distrib act_distribD add_assocD)
  by (clarsimp, metis act_assoc act_assocD act_distrib act_distribD add_assoc add_assocD)

end

text \<open>Finally we define the semigroup action for two partial monoids and show that the semidirect product of two partial monoids
is a partial monoid.\<close>

locale partial_mon_sg_laction = partial_sg_sg_laction Dla
  for Dla :: "'a::partial_monoid \<Rightarrow> 'b::partial_semigroup \<Rightarrow> bool" +
  assumes act_unitl: "e \<in> E \<Longrightarrow> Dla e p \<and> \<alpha> e p = p"

locale partial_mon_mon_laction = partial_mon_sg_laction _ Dla
  for Dla :: "'a::partial_monoid \<Rightarrow> 'b::partial_monoid \<Rightarrow> bool" +
  assumes act_annir: "e \<in> Ea \<Longrightarrow> Dla x e \<and> \<alpha> x e = e"

begin

definition sd_E :: "('a \<times> 'b) set" where
  "sd_E = {x. fst x \<in> E \<and> snd x \<in> E}"

sublocale dp_semigroup : partial_monoid sd_prod sd_D sd_E
  apply unfold_locales
    apply (simp_all add: sd_prod_def sd_D_def sd_E_def)
    apply (metis act_annir eq_fst_iff eq_snd_iff mem_Collect_eq partial_monoid_class.unitl_ex)
   apply (metis act_annir eq_fst_iff eq_snd_iff partial_monoid_class.unitr_ex)
  by (metis act_annir partial_monoid_class.units_eq prod_eqI)

end

end


theory Bounded_Copy_SST_SST
  imports Main HOL.Finite_Set
          "../Core/Update" "../Composition/Compose_SST_SST" "../Single_Use/Single_Use"
begin

lemma count_list_H:
  "count_list (extract_variables (H tr to (f, \<theta>) (q, x))) (q0, x0)
 \<le> count_list (extract_variables (\<theta> x)) x0"
proof (simp add: H_def)
  show "count_list (extract_variables (Transducer.hat2 (delta2f f tr) (eta2f to) (q, u))) (q0, x0)
      \<le> count_list (extract_variables u) x0" for u
   by  (induct u arbitrary: q rule: xa_induct, simp_all add: Nat.le_SucI)
qed

lemma compose_reachable_SST_SST:
  assumes "reachable (compose_SST_SST sst1 sst2) (q1, f)"
  shows "reachable sst1 q1"
  unfolding reachable_def
proof -
  obtain w where *: "(q1, f) = delta_hat (compose_SST_SST sst1 sst2)
                                (initial (compose_SST_SST sst1 sst2), w)"
    using assms unfolding reachable_def by auto
  show "\<exists>w. q1 = delta_hat sst1 (initial sst1, w)" proof
    show "q1 = delta_hat sst1 (initial sst1, w)"
      using * by (simp add: compose_\<delta>_hat compose_SST_SST_def)
  qed
qed

theorem compose_SST_SST_bounded:
  fixes sst1 :: "('q1::finite, 'x1::finite, 'a, 'b) SST"
  fixes sst2 :: "('q2::finite, 'x2::finite, 'b, 'c) SST"
  assumes "bounded_copy_SST k sst1"
  shows "bounded_copy_SST (card (UNIV::'q2 set) * k) (compose_SST_SST sst1 sst2)"
proof (simp add: bounded_copy_SST_def, intro allI, rule impI)
  fix w qs f
  let ?tr = "delta sst2" and ?to = "SST.eta sst2"
  let ?xi = "SST.eta_hat sst1 (qs, w)"
  assume r0: "reachable (compose_SST_SST sst1 sst2) (qs, f)"
  have reach: "reachable sst1 qs" by (rule compose_reachable_SST_SST, rule r0)
  show "bounded (card (UNIV::'q2 set) * k) (SST.eta_hat (compose_SST_SST sst1 sst2) ((qs, f), w))"
    unfolding compose_SST_SST_def bounded_def count_var_def
  proof (simp add: compose_\<eta>_hat, intro allI)
    fix q0 x0
    have "(\<Sum>y\<in>(UNIV::('q2\<times>'x1)set). count_list (extract_variables (H ?tr ?to (f, ?xi) y)) (q0, x0))
        = (\<Sum>q\<in>(UNIV::'q2 set). \<Sum>x\<in>(UNIV::'x1 set). count_list (extract_variables (H ?tr ?to (f, ?xi) (q, x))) (q0, x0))"
      by (simp add: sum.Sigma)
    also have "... \<le> (\<Sum>q\<in>(UNIV::'q2 set). \<Sum>x\<in>(UNIV::'x1 set).  count_list (extract_variables (?xi x)) x0)"
      by (intro sum_mono, rule count_list_H)
    also have "... = card (UNIV::'q2 set) * (\<Sum>x\<in>(UNIV::'x1 set). count_list (extract_variables (?xi x)) x0)"
      by (simp)
    also have "... \<le> card (UNIV::'q2 set) * k"
      using assms reach unfolding bounded_copy_SST_def bounded_def count_var_def
      by (simp add: reach)
    finally show "(\<Sum>y\<in>(UNIV::('q2\<times>'x1)set). count_list (extract_variables (H ?tr ?to (f, ?xi) y)) (q0, x0))
                \<le> card (UNIV::'q2 set) * k" .
  qed
qed

end


theory HS_Exponential_Ex
  imports "Hybrid-Verification.Hybrid_Verification"
begin

lit_vars

subsubsection \<open> Classical exponential example \<close>

locale exponential_evol =
  fixes x :: "real \<Longrightarrow> real^1"
  assumes x_def [simp]: "x \<equiv> vec_lens 1"
begin

\<comment> \<open>Verified with annotated dynamics \<close>

abbreviation "exp_f \<equiv> [x \<leadsto> -x]" (* x>0 -> [{x'=-x}](x>0) *)
abbreviation "exp_flow \<tau> \<equiv> [x \<leadsto> x * exp (- \<tau>)]"

lemma "D (\<lambda>t. exp_flow t s) = (\<lambda>t. exp_f (exp_flow t s)) on {0--t}"
  by (expr_auto, auto intro!: vderiv_intros)

lemma "\<^bold>{x > 0\<^bold>}(EVOL exp_flow G (\<lambda>s. {t. t \<ge> 0}))\<^bold>{x > 0\<^bold>}"
  by (simp add: fbox_g_evol) expr_auto

\<comment> \<open>Verified with the flow \<close>

lemma local_lipschitz_exp_f: "local_lipschitz UNIV UNIV (\<lambda>t::real. exp_f)"
  apply(simp_all add: local_lipschitz_def lipschitz_on_def, clarsimp)
    apply(rule_tac x="1" in exI, clarsimp, rule_tac x=1 in exI)
  by (clarsimp, expr_auto, simp add: dist_norm norm_vec_def)

lemma local_flow_exp_flow: "local_flow exp_f UNIV UNIV exp_flow"
  apply(unfold_locales)
  apply (auto)
  using local_lipschitz_exp_f apply force
   apply (expr_auto, auto intro!: vderiv_intros, expr_auto)
  done

(* x>0 -> [{x'=-x}](x>0) *)
lemma "\<^bold>{x > 0\<^bold>}(x\<acute>= exp_f & G)\<^bold>{x > 0\<^bold>}"
  apply (subst local_flow.fbox_g_ode_subset[OF local_flow_exp_flow])
   apply (simp)
  apply (expr_auto)
  done

end

dataspace exponential =
  variables x::real y::real z::real
context exponential
begin

\<comment> \<open>Verified with differential ghosts \<close>

abbreviation "dyn \<equiv> {x` = - x}"

lemma exp_arith: "0 < (a::real) \<longleftrightarrow> (\<exists>b. a * b\<^sup>2 = 1)"
  by (auto, rule_tac x="1/sqrt(a)" in exI, simp add: power_divide)
     (metis not_square_less_zero power2_eq_square zero_less_mult_iff zero_less_one)

(* x>0 -> [{x'=-x}](x>0) *)
lemma dG_example: "\<^bold>{x > 0\<^bold>}dyn\<^bold>{x > 0\<^bold>}"
  apply (dGhost "y" "(x*y\<^sup>2 = 1)\<^sub>e" "1/2")
  apply (dInduct_auto)
  apply (expr_auto add: exp_arith)
  done

abbreviation (input) "exp_f \<equiv> [x \<leadsto> -x]" (* x>0 -> [{x'=-x}](x>0) *)
abbreviation (input) "exp_flow \<tau> \<equiv> [x \<leadsto> x * exp (- \<tau>)]"

term exp_f
term exp_flow

term "tsubst2vecf x (\<lambda> _. exp_f) s"

lemma "D (\<lambda>t. tsubst2vecf x exp_flow s t (get\<^bsub>x\<^esub> s)) = (\<lambda> t. tsubst2vecf x (\<lambda> _. exp_f) s t (tsubst2vecf x exp_flow s t (get\<^bsub>x\<^esub> s))) on {0--t}"
  by (expr_auto, auto intro!: vderiv_intros)

term "(\<lambda>t. exp_f (exp_flow t s))"

term "tsubst2vecf x (\<lambda> t. exp_f)"

lemma "\<^bold>{x > 0\<^bold>}(EVOL exp_flow G (\<lambda>s. {t. t \<ge> 0}))\<^bold>{x > 0\<^bold>}"
  by (simp add: fbox_g_evol) expr_auto

lemma "\<^bold>{x > 0\<^bold>}{EVOL x = x * exp (- \<tau>)}\<^bold>{x > 0\<^bold>}"
  by (hoare_wp_auto)

lemma local_flow_exp_flow: "local_flow_on exp_f x UNIV UNIV exp_flow"
  by (local_flow 1)

lemma flow_example: "\<^bold>{x > 0\<^bold>}dyn\<^bold>{x > 0\<^bold>}"
  by (hoare_wp_auto local_flow: local_flow_exp_flow)

lemma "\<^bold>{x \<ge> 0\<^bold>}dyn\<^bold>{x \<ge> 0\<^bold>}"
  apply (rule darboux_geq[of x y z, where g="-1"]; expr_simp add: framed_derivs
      ldifferentiable closure usubst unrest_ssubst unrest usubst_eval; clarsimp?)
  subgoal
    by (subst lens_indep_comm; expr_simp)
  subgoal for s
    by expr_auto
      (rule_tac x="put\<^bsub>y\<^esub> s 1" in exI, simp)
  apply (metis indeps(3) indeps(6) lens_indep_comm)
  apply (simp add: frechet_derivative_fst)
  using bounded_linear_fst
    bounded_linear_imp_differentiable
  by blast

end

end


theory LowLevelEvm imports Main "HOL-Library.Numeral_Type"
MiniEvm
begin

(* define EVM instruction syntax in terms of their representation as instruction-words *)
typedef inst = "{n :: nat . n < 256 }"
proof-
  have "(0 :: nat) \<in> {n . n < 256}" by auto
  thus "\<exists> (x :: nat) . x \<in> {n . n < 256}" by blast
qed
setup_lifting type_definition_inst

(* begin opcodes *)
(*
 * STOP
 *)
definition stop_codes  :: "nat list"  where "stop_codes = [0 :: nat]"
declare stop_codes_def [simp add]
typedef stop_inst = "set stop_codes" by auto
setup_lifting type_definition_stop_inst

lift_definition STOP_INST :: "stop_inst \<Rightarrow> inst" is id by auto

lift_definition STOP_STOP :: stop_inst is "0x00 :: nat" by auto
free_constructors cases_stop_inst for STOP_STOP
  by (transfer; auto)+

definition is_STOP :: "stop_inst \<Rightarrow> bool" where
"is_STOP x \<equiv> case x of STOP_STOP \<Rightarrow> True"

(*
 * Arithmetic
 *)
definition arith_codes :: "nat list" where
"arith_codes = (List.upt 0x01 0x0c)"

declare arith_codes_def [simp add]
typedef arith_inst = "set arith_codes" by auto
setup_lifting type_definition_arith_inst

lift_definition ARITH_INST :: "arith_inst \<Rightarrow> inst" is id by auto

lift_definition ARITH_ADD        :: "arith_inst" is "0x01 :: nat" by auto
lift_definition ARITH_MUL        :: "arith_inst" is "0x02 :: nat" by auto
lift_definition ARITH_SUB        :: "arith_inst" is "0x03 :: nat" by auto
lift_definition ARITH_DIV        :: "arith_inst" is "0x04 :: nat" by auto
lift_definition ARITH_SDIV       :: "arith_inst" is "0x05 :: nat" by auto
lift_definition ARITH_MOD        :: "arith_inst" is "0x06 :: nat" by auto
lift_definition ARITH_SMOD       :: "arith_inst" is "0x07 :: nat" by auto
lift_definition ARITH_ADDMOD     :: "arith_inst" is "0x08 :: nat" by auto
lift_definition ARITH_MULMOD     :: "arith_inst" is "0x09 :: nat" by auto
lift_definition ARITH_EXP        :: "arith_inst" is "0x0a :: nat" by auto
lift_definition ARITH_SIGNEXTEND :: "arith_inst" is "0x0b :: nat" by auto

free_constructors cases_arith_inst for
  ARITH_ADD
| ARITH_MUL
| ARITH_SUB
| ARITH_DIV
| ARITH_SDIV
| ARITH_MOD
| ARITH_SMOD
| ARITH_ADDMOD
| ARITH_MULMOD
| ARITH_EXP
| ARITH_SIGNEXTEND
  by(transfer;
     auto simp del:set_upt simp add:List.upt_def)+

fun is_arith_ADD :: "arith_inst => bool" where
"is_arith_ADD ARITH_ADD = True"
| "is_arith_ADD _ = False"
fun is_arith_MUL :: "arith_inst => bool" where
"is_arith_MUL ARITH_MUL = True"
| "is_arith_MUL _ = False"
fun is_arith_SUB :: "arith_inst => bool" where
"is_arith_SUB ARITH_SUB = True"
| "is_arith_SUB _ = False"
fun is_arith_DIV :: "arith_inst => bool" where
"is_arith_DIV ARITH_DIV = True"
| "is_arith_DIV _ = False"
fun is_arith_SDIV :: "arith_inst => bool" where
"is_arith_SDIV ARITH_SDIV = True"
| "is_arith_SDIV _ = False"
fun is_arith_MOD :: "arith_inst => bool" where
"is_arith_MOD ARITH_MOD = True"
| "is_arith_MOD _ = False"
fun is_arith_SMOD :: "arith_inst => bool" where
"is_arith_SMOD ARITH_SMOD = True"
| "is_arith_SMOD _ = False"
fun is_arith_ADDMOD :: "arith_inst => bool" where
"is_arith_ADDMOD ARITH_ADDMOD = True"
| "is_arith_ADDMOD _ = False"
fun is_arith_MULMOD :: "arith_inst => bool" where
"is_arith_MULMOD ARITH_MULMOD = True"
| "is_arith_MULMOD _ = False"
fun is_arith_EXP :: "arith_inst => bool" where
"is_arith_EXP ARITH_EXP = True"
| "is_arith_EXP _ = False"
fun is_arith_SIGNEXTEND :: "arith_inst => bool" where
"is_arith_SIGNEXTEND ARITH_SIGNEXTEND = True"
| "is_arith_SIGNEXTEND _ = False"

(*
 * Bits + Comparisons
 *)
definition bits_compare_codes :: "nat list" where
  "bits_compare_codes = (List.upt 0x10 0x1e)"
declare bits_compare_codes_def [simp add]
typedef bits_compare_inst = "set bits_compare_codes" by auto
setup_lifting type_definition_bits_compare_inst

lift_definition BITS_COMPARE_LT     :: "bits_compare_inst" is "0x10" by auto
lift_definition BITS_COMPARE_GT     :: "bits_compare_inst" is "0x11" by auto
lift_definition BITS_COMPARE_SLT    :: "bits_compare_inst" is "0x12" by auto
lift_definition BITS_COMPARE_SGT    :: "bits_compare_inst" is "0x13" by auto
lift_definition BITS_COMPARE_EQ     :: "bits_compare_inst" is "0x14" by auto
lift_definition BITS_COMPARE_ISZERO :: "bits_compare_inst" is "0x15" by auto
lift_definition BITS_COMPARE_AND    :: "bits_compare_inst" is "0x16" by auto
lift_definition BITS_COMPARE_OR     :: "bits_compare_inst" is "0x17" by auto
lift_definition BITS_COMPARE_XOR    :: "bits_compare_inst" is "0x18" by auto
lift_definition BITS_COMPARE_NOT    :: "bits_compare_inst" is "0x19" by auto
lift_definition BITS_COMPARE_BYTE   :: "bits_compare_inst" is "0x1a" by auto
lift_definition BITS_COMPARE_SHL    :: "bits_compare_inst" is "0x1b" by auto
lift_definition BITS_COMPARE_SHR    :: "bits_compare_inst" is "0x1c" by auto
lift_definition BITS_COMPARE_SAR    :: "bits_compare_inst" is "0x1d" by auto

lift_definition BITS_COMPARE_INST :: "bits_compare_inst \<Rightarrow> inst" is id by auto

free_constructors cases_compare_inst for
  BITS_COMPARE_LT
| BITS_COMPARE_GT
| BITS_COMPARE_SLT
| BITS_COMPARE_SGT
| BITS_COMPARE_EQ
| BITS_COMPARE_ISZERO
| BITS_COMPARE_AND
| BITS_COMPARE_OR
| BITS_COMPARE_XOR
| BITS_COMPARE_NOT
| BITS_COMPARE_BYTE
| BITS_COMPARE_SHL
| BITS_COMPARE_SHR
| BITS_COMPARE_SAR
  by(transfer;
     auto simp del:set_upt simp add:List.upt_def)+

fun "is_bits_compare_LT" :: "bits_compare_inst => bool" where
"is_bits_compare_LT BITS_COMPARE_LT = True"
| "is_bits_compare_LT _ = False"
fun "is_bits_compare_GT" :: "bits_compare_inst => bool" where
"is_bits_compare_GT BITS_COMPARE_GT = True"
| "is_bits_compare_GT _ = False"
fun "is_bits_compare_SLT" :: "bits_compare_inst => bool" where
"is_bits_compare_SLT BITS_COMPARE_SLT = True"
| "is_bits_compare_SLT _ = False"
fun "is_bits_compare_SGT" :: "bits_compare_inst => bool" where
"is_bits_compare_SGT BITS_COMPARE_SGT = True"
| "is_bits_compare_SGT _ = False"
fun "is_bits_compare_EQ" :: "bits_compare_inst => bool" where
"is_bits_compare_EQ BITS_COMPARE_EQ = True"
| "is_bits_compare_EQ _ = False"
fun "is_bits_compare_ISZERO" :: "bits_compare_inst => bool" where
"is_bits_compare_ISZERO BITS_COMPARE_ISZERO = True"
| "is_bits_compare_ISZERO _ = False"
fun "is_bits_compare_AND" :: "bits_compare_inst => bool" where
"is_bits_compare_AND BITS_COMPARE_AND = True"
| "is_bits_compare_AND _ = False"
fun "is_bits_compare_OR" :: "bits_compare_inst => bool" where
"is_bits_compare_OR BITS_COMPARE_OR = True"
| "is_bits_compare_OR _ = False"
fun "is_bits_compare_XOR" :: "bits_compare_inst => bool" where
"is_bits_compare_XOR BITS_COMPARE_XOR = True"
| "is_bits_compare_XOR _ = False"
fun "is_bits_compare_NOT" :: "bits_compare_inst => bool" where
"is_bits_compare_NOT BITS_COMPARE_NOT = True"
| "is_bits_compare_NOT _ = False"
fun "is_bits_compare_BYTE" :: "bits_compare_inst => bool" where
"is_bits_compare_BYTE BITS_COMPARE_BYTE = True"
| "is_bits_compare_BYTE _ = False"
fun "is_bits_compare_SHL" :: "bits_compare_inst => bool" where
"is_bits_compare_SHL BITS_COMPARE_SHL = True"
| "is_bits_compare_SHL _ = False"
fun "is_bits_compare_SHR" :: "bits_compare_inst => bool" where
"is_bits_compare_SHR BITS_COMPARE_SHR = True"
| "is_bits_compare_SHR _ = False"
fun "is_bits_compare_SAR" :: "bits_compare_inst => bool" where
"is_bits_compare_SAR BITS_COMPARE_SAR = True"
| "is_bits_compare_SAR _ = False"

(* keccak256 *)
definition keccak256_codes  :: "nat list"  where "keccak256_codes = [0x20 :: nat]"
declare keccak256_codes_def [simp add]
typedef keccak256_inst = "set keccak256_codes" by auto
setup_lifting type_definition_keccak256_inst

lift_definition KECCAK256_KECCAK256 :: keccak256_inst is "0x20 :: nat" by auto

lift_definition KECCAK256_INST :: "keccak256_inst \<Rightarrow> inst" is id by auto

free_constructors cases_keccak256_inst for KECCAK256_KECCAK256
  by (transfer; auto)+

fun "is_keccak256_KECCAK256" :: "keccak256_inst => bool" where
"is_keccak256_KECCAK256 KECCAK256_KECCAK256 = True"

(*
 * transaction-specific data instructions
 *)
definition tx_data_codes :: "nat list"
  where
  "tx_data_codes = (List.upt 0x30 0x40)"
declare tx_data_codes_def[simp add]
typedef tx_data_inst = "set tx_data_codes" by auto
setup_lifting type_definition_tx_data_inst

lift_definition TX_DATA_ADDRESS        :: "tx_data_inst" is "0x30" by auto
lift_definition TX_DATA_BALANCE        :: "tx_data_inst" is "0x31" by auto
lift_definition TX_DATA_ORIGIN         :: "tx_data_inst" is "0x32" by auto
lift_definition TX_DATA_CALLER         :: "tx_data_inst" is "0x33" by auto
lift_definition TX_DATA_CALLVALUE      :: "tx_data_inst" is "0x34" by auto
lift_definition TX_DATA_CALLDATALOAD   :: "tx_data_inst" is "0x35" by auto
lift_definition TX_DATA_CALLDATASIZE   :: "tx_data_inst" is "0x36" by auto
lift_definition TX_DATA_CALLDATACOPY   :: "tx_data_inst" is "0x37" by auto
lift_definition TX_DATA_CODESIZE       :: "tx_data_inst" is "0x38" by auto
lift_definition TX_DATA_CODECOPY       :: "tx_data_inst" is "0x39" by auto
lift_definition TX_DATA_GASPRICE       :: "tx_data_inst" is "0x3a" by auto
lift_definition TX_DATA_EXTCODESIZE    :: "tx_data_inst" is "0x3b" by auto
lift_definition TX_DATA_EXTCODECOPY    :: "tx_data_inst" is "0x3c" by auto
lift_definition TX_DATA_RETURNDATASIZE :: "tx_data_inst" is "0x3d" by auto
lift_definition TX_DATA_RETURNDATACOPY :: "tx_data_inst" is "0x3e" by auto
lift_definition TX_DATA_EXTCODEHASH    :: "tx_data_inst" is "0x3f" by auto

lift_definition TX_DATA_INST :: "tx_data_inst \<Rightarrow> inst" is id by auto

free_constructors cases_tx_data_inst for
TX_DATA_ADDRESS
| TX_DATA_BALANCE
| TX_DATA_ORIGIN
| TX_DATA_CALLER
| TX_DATA_CALLVALUE
| TX_DATA_CALLDATALOAD
| TX_DATA_CALLDATASIZE
| TX_DATA_CALLDATACOPY
| TX_DATA_CODESIZE
| TX_DATA_CODECOPY
| TX_DATA_GASPRICE
| TX_DATA_EXTCODESIZE
| TX_DATA_EXTCODECOPY
| TX_DATA_RETURNDATASIZE
| TX_DATA_RETURNDATACOPY
| TX_DATA_EXTCODEHASH
  by(transfer;
     auto simp del:set_upt simp add:List.upt_def)+

fun "is_tx_data_ADDRESS" :: "tx_data_inst => bool" where
"is_tx_data_ADDRESS TX_DATA_ADDRESS = True"
| "is_tx_data_ADDRESS _ = False"
fun "is_tx_data_BALANCE" :: "tx_data_inst => bool" where
"is_tx_data_BALANCE TX_DATA_BALANCE = True"
| "is_tx_data_BALANCE _ = False"
fun "is_tx_data_ORIGIN" :: "tx_data_inst => bool" where
"is_tx_data_ORIGIN TX_DATA_ORIGIN = True"
| "is_tx_data_ORIGIN _ = False"
fun "is_tx_data_CALLER" :: "tx_data_inst => bool" where
"is_tx_data_CALLER TX_DATA_CALLER = True"
| "is_tx_data_CALLER _ = False"
fun "is_tx_data_CALLVALUE" :: "tx_data_inst => bool" where
"is_tx_data_CALLVALUE TX_DATA_CALLVALUE = True"
| "is_tx_data_CALLVALUE _ = False"
fun "is_tx_data_CALLDATALOAD" :: "tx_data_inst => bool" where
"is_tx_data_CALLDATALOAD TX_DATA_CALLDATALOAD = True"
| "is_tx_data_CALLDATALOAD _ = False"
fun "is_tx_data_CALLDATASIZE" :: "tx_data_inst => bool" where
"is_tx_data_CALLDATASIZE TX_DATA_CALLDATASIZE = True"
| "is_tx_data_CALLDATASIZE _ = False"
fun "is_tx_data_CALLDATACOPY" :: "tx_data_inst => bool" where
"is_tx_data_CALLDATACOPY TX_DATA_CALLDATACOPY = True"
| "is_tx_data_CALLDATACOPY _ = False"
fun "is_tx_data_CODESIZE" :: "tx_data_inst => bool" where
"is_tx_data_CODESIZE TX_DATA_CODESIZE = True"
| "is_tx_data_CODESIZE _ = False"
fun "is_tx_data_CODECOPY" :: "tx_data_inst => bool" where
"is_tx_data_CODECOPY TX_DATA_CODECOPY = True"
| "is_tx_data_CODECOPY _ = False"
fun "is_tx_data_GASPRICE" :: "tx_data_inst => bool" where
"is_tx_data_GASPRICE TX_DATA_GASPRICE = True"
| "is_tx_data_GASPRICE _ = False"
fun "is_tx_data_EXTCODESIZE" :: "tx_data_inst => bool" where
"is_tx_data_EXTCODESIZE TX_DATA_EXTCODESIZE = True"
| "is_tx_data_EXTCODESIZE _ = False"
fun "is_tx_data_EXTCODECOPY" :: "tx_data_inst => bool" where
"is_tx_data_EXTCODECOPY TX_DATA_EXTCODECOPY = True"
| "is_tx_data_EXTCODECOPY _ = False"
fun "is_tx_data_RETURNDATASIZE" :: "tx_data_inst => bool" where
"is_tx_data_RETURNDATASIZE TX_DATA_RETURNDATASIZE = True"
| "is_tx_data_RETURNDATASIZE _ = False"
fun "is_tx_data_RETURNDATACOPY" :: "tx_data_inst => bool" where
"is_tx_data_RETURNDATACOPY TX_DATA_RETURNDATACOPY = True"
| "is_tx_data_RETURNDATACOPY _ = False"
fun "is_tx_data_EXTCODEHASH" :: "tx_data_inst => bool" where
"is_tx_data_EXTCODEHASH TX_DATA_EXTCODEHASH = True"
| "is_tx_data_EXTCODEHASH _ = False"

(*
 * chain-specific data instructions
 *)
definition chain_data_codes :: "nat list"
  where
  "chain_data_codes = List.upt 0x40 0x48"
declare chain_data_codes_def[simp add]
typedef chain_data_inst = "set chain_data_codes" by auto
setup_lifting type_definition_chain_data_inst

lift_definition CHAIN_DATA_BLOCKHASH   :: "chain_data_inst" is "0x40" by auto
lift_definition CHAIN_DATA_COINBASE    :: "chain_data_inst" is "0x41" by auto
lift_definition CHAIN_DATA_TIMESTAMP   :: "chain_data_inst" is "0x42" by auto
lift_definition CHAIN_DATA_NUMBER      :: "chain_data_inst" is "0x43" by auto
lift_definition CHAIN_DATA_DIFFICULTY  :: "chain_data_inst" is "0x44" by auto
lift_definition CHAIN_DATA_GASLIMIT    :: "chain_data_inst" is "0x45" by auto
lift_definition CHAIN_DATA_CHAINID     :: "chain_data_inst" is "0x46" by auto
lift_definition CHAIN_DATA_SELFBALANCE :: "chain_data_inst" is "0x47" by auto

lift_definition CHAIN_DATA_INST :: "chain_data_inst \<Rightarrow> inst" is id by auto

free_constructors cases_chain_data_inst for
CHAIN_DATA_BLOCKHASH
| CHAIN_DATA_COINBASE
| CHAIN_DATA_TIMESTAMP
| CHAIN_DATA_NUMBER
| CHAIN_DATA_DIFFICULTY
| CHAIN_DATA_GASLIMIT
| CHAIN_DATA_CHAINID
| CHAIN_DATA_SELFBALANCE
  by(transfer;
     auto simp del:set_upt simp add:List.upt_def)+

fun "is_chain_data_BLOCKHASH" :: "chain_data_inst => bool" where
"is_chain_data_BLOCKHASH CHAIN_DATA_BLOCKHASH = True"
| "is_chain_data_BLOCKHASH _ = False"
fun "is_chain_data_COINBASE" :: "chain_data_inst => bool" where
"is_chain_data_COINBASE CHAIN_DATA_COINBASE = True"
| "is_chain_data_COINBASE _ = False"
fun "is_chain_data_TIMESTAMP" :: "chain_data_inst => bool" where
"is_chain_data_TIMESTAMP CHAIN_DATA_TIMESTAMP = True"
| "is_chain_data_TIMESTAMP _ = False"
fun "is_chain_data_NUMBER" :: "chain_data_inst => bool" where
"is_chain_data_NUMBER CHAIN_DATA_NUMBER = True"
| "is_chain_data_NUMBER _ = False"
fun "is_chain_data_DIFFICULTY" :: "chain_data_inst => bool" where
"is_chain_data_DIFFICULTY CHAIN_DATA_DIFFICULTY = True"
| "is_chain_data_DIFFICULTY _ = False"
fun "is_chain_data_CHAINID" :: "chain_data_inst => bool" where
"is_chain_data_CHAINID CHAIN_DATA_CHAINID = True"
| "is_chain_data_CHAINID _ = False"
fun "is_chain_data_GASLIMIT" :: "chain_data_inst => bool" where
"is_chain_data_GASLIMIT CHAIN_DATA_GASLIMIT = True"
| "is_chain_data_GASLIMIT _ = False"
fun "is_chain_data_SELFBALANCE" :: "chain_data_inst => bool" where
"is_chain_data_SELFBALANCE CHAIN_DATA_SELFBALANCE = True"
| "is_chain_data_SELFBALANCE _ = False"

(*
 * state and control instructions
 *)
(* we could break this down; e.g. into
- put
- memory ops
- storage ops
- resource queries
- control flow *)
definition state_control_codes :: "nat list" where
"state_control_codes = (List.upt 0x50 0x5c)"
declare state_control_codes_def[simp add]
typedef state_control_inst = "set state_control_codes" by auto
setup_lifting type_definition_state_control_inst

lift_definition STATE_CONTROL_POP      :: "state_control_inst" is "0x50" by auto
lift_definition STATE_CONTROL_MLOAD    :: "state_control_inst" is "0x51" by auto
lift_definition STATE_CONTROL_MSTORE   :: "state_control_inst" is "0x52" by auto
lift_definition STATE_CONTROL_MSTORE8  :: "state_control_inst" is "0x53" by auto
lift_definition STATE_CONTROL_SLOAD    :: "state_control_inst" is "0x54" by auto
lift_definition STATE_CONTROL_SSTORE   :: "state_control_inst" is "0x55" by auto
lift_definition STATE_CONTROL_JUMP     :: "state_control_inst" is "0x56" by auto
lift_definition STATE_CONTROL_JUMPI    :: "state_control_inst" is "0x57" by auto
lift_definition STATE_CONTROL_PC       :: "state_control_inst" is "0x58" by auto
lift_definition STATE_CONTROL_MSIZE    :: "state_control_inst" is "0x59" by auto
lift_definition STATE_CONTROL_GAS      :: "state_control_inst" is "0x5a" by auto
lift_definition STATE_CONTROL_JUMPDEST :: "state_control_inst" is "0x5b" by auto

lift_definition STATE_CONTROL_INST :: "state_control_inst => inst" is id by auto

free_constructors cases_state_control_inst for
STATE_CONTROL_POP
| STATE_CONTROL_MLOAD
| STATE_CONTROL_MSTORE
| STATE_CONTROL_MSTORE8
| STATE_CONTROL_SLOAD
| STATE_CONTROL_SSTORE
| STATE_CONTROL_JUMP
| STATE_CONTROL_JUMPI
| STATE_CONTROL_PC
| STATE_CONTROL_MSIZE
| STATE_CONTROL_GAS
| STATE_CONTROL_JUMPDEST
  by(transfer;
     auto simp del:set_upt simp add:List.upt_def)+

fun "is_state_control_POP" :: "state_control_inst => bool" where
"is_state_control_POP STATE_CONTROL_POP = True"
| "is_state_control_POP _ = False"
fun "is_state_control_MLOAD" :: "state_control_inst => bool" where
"is_state_control_MLOAD STATE_CONTROL_MLOAD = True"
| "is_state_control_MLOAD _ = False"
fun "is_state_control_MSTORE" :: "state_control_inst => bool" where
"is_state_control_MSTORE STATE_CONTROL_MSTORE = True"
| "is_state_control_MSTORE _ = False"
fun "is_state_control_MSTORE8" :: "state_control_inst => bool" where
"is_state_control_MSTORE8 STATE_CONTROL_MSTORE8 = True"
| "is_state_control_MSTORE8 _ = False"
fun "is_state_control_SLOAD" :: "state_control_inst => bool" where
"is_state_control_SLOAD STATE_CONTROL_SLOAD = True"
| "is_state_control_SLOAD _ = False"
fun "is_state_control_SSTORE" :: "state_control_inst => bool" where
"is_state_control_SSTORE STATE_CONTROL_SSTORE = True"
| "is_state_control_SSTORE _ = False"
fun "is_state_control_JUMP" :: "state_control_inst => bool" where
"is_state_control_JUMP STATE_CONTROL_JUMP = True"
| "is_state_control_JUMP _ = False"
fun "is_state_control_JUMPI" :: "state_control_inst => bool" where
"is_state_control_JUMPI STATE_CONTROL_JUMPI = True"
| "is_state_control_JUMPI _ = False"
fun "is_state_control_PC" :: "state_control_inst => bool" where
"is_state_control_PC STATE_CONTROL_PC = True"
| "is_state_control_PC _ = False"
fun "is_state_control_MSIZE" :: "state_control_inst => bool" where
"is_state_control_MSIZE STATE_CONTROL_MSIZE = True"
| "is_state_control_MSIZE _ = False"
fun "is_state_control_GAS" :: "state_control_inst => bool" where
"is_state_control_GAS STATE_CONTROL_GAS = True"
| "is_state_control_GAS _ = False"
fun "is_state_control_JUMPDEST" :: "state_control_inst => bool" where
"is_state_control_JUMPDEST STATE_CONTROL_JUMPDEST = True"
| "is_state_control_JUMPDEST _ = False"

(*
 * push instructions
 *)
definition push_codes :: "nat list" where
"push_codes = (List.upt 0x60 0x80)"
declare push_codes_def[simp add]
typedef push_inst = "set push_codes" by auto
setup_lifting type_definition_push_inst

lift_definition PUSH_INST :: "push_inst \<Rightarrow> inst" is id by auto

typedef nat32 = "{x :: nat . x < 32}"
proof
  have "0 < (32 :: nat)" by auto
  thus "0 \<in> {x :: nat . x < 32}" by(auto)
qed
setup_lifting type_definition_nat32

lift_definition nat_of_nat32 :: "nat32 \<Rightarrow> nat" is id done

lift_definition nat32_of_nat :: "nat \<Rightarrow> nat32" is "(\<lambda> n . n mod 32)"
  using pos_mod_bound[of 32 n] by auto

(* helper for building push instructions *)
fun make_push :: "nat \<Rightarrow> nat" where
"make_push n =
  0x60 + (n mod 32)"

lift_definition MAKE_PUSH :: "nat \<Rightarrow> push_inst" is make_push
proof-
  fix n :: nat

  have "n mod 32 < 32" using pos_mod_bound[of 32 n] by auto

  hence Upt32: "n mod 32 \<in> set (List.upt 0 32)" by auto

  hence "(0x60 + (n mod 32)) \<in> ((\<lambda> x . x + 0x60) ` set (List.upt 0 32))"
    using Set.imageI[OF Upt32, of "(\<lambda> x . x + 0x60)"] by auto

  hence Mapped : "(0x60 + (n mod 32)) \<in> set (map (\<lambda> x . x + 0x60) (List.upt 0 32))"
    by auto

  then show "make_push n \<in> set push_codes"
    using List.map_add_upt by auto
qed

lift_definition PUSH_PUSH :: "nat32 \<Rightarrow> push_inst" is make_push
proof-
  fix n :: nat
  assume "n < 32"

  have "n mod 32 < 32" using pos_mod_bound[of 32 n] by auto

  hence Upt32: "n mod 32 \<in> set (List.upt 0 32)" by auto

  hence "(0x60 + (n mod 32)) \<in> ((\<lambda> x . x + 0x60) ` set (List.upt 0 32))"
    using Set.imageI[OF Upt32, of "(\<lambda> x . x + 0x60)"] by auto

  hence Mapped : "(0x60 + (n mod 32)) \<in> set (map (\<lambda> x . x + 0x60) (List.upt 0 32))"
    by auto

  then show "make_push n \<in> set push_codes"
    using List.map_add_upt by auto
qed

free_constructors cases_push_inst for PUSH_PUSH
  by(transfer;
     auto simp del:set_upt simp add:List.upt_def)+

fun is_PUSH_PUSH :: "push_inst \<Rightarrow> bool" where
"is_PUSH_PUSH (PUSH_PUSH _) = True"

fun get_PUSH_PUSH :: "push_inst \<Rightarrow> nat" where
"get_PUSH_PUSH (PUSH_PUSH x) = nat_of_nat32 x"

fun is_PUSH_PUSH_n :: "push_inst \<Rightarrow> nat \<Rightarrow> bool" where
"is_PUSH_PUSH_n i x = (get_PUSH_PUSH i = x)"

(*
 * dup instructions
 *)
definition dup_codes :: "nat list" where
"dup_codes = (List.upt 0x80 0x90)"
declare dup_codes_def[simp add]
typedef dup_inst = "set dup_codes" by auto
setup_lifting type_definition_dup_inst

typedef nat16 = "{x :: nat . x < 16}"
proof
  have "0 < (16 :: nat)" by auto
  thus "0 \<in> {x :: nat . x < 16}" by(auto)
qed
setup_lifting type_definition_nat16

lift_definition DUP_INST :: "dup_inst => inst" is id by auto

lift_definition nat_of_nat16 :: "nat16 \<Rightarrow> nat" is id done

lift_definition nat16_of_nat :: "nat \<Rightarrow> nat16" is "(\<lambda> n . n mod 16)"
  using pos_mod_bound[of 16 ] by auto

(* helper for building dup instructions *)
fun make_dup :: "nat \<Rightarrow> nat" where
"make_dup n =
  0x80 + (n mod 16)"

lift_definition MAKE_DUP :: "nat \<Rightarrow> dup_inst" is make_dup
proof-
  fix n :: nat

  have "n mod 16 < 16" using pos_mod_bound[of 16 n] by auto

  hence Upt32: "n mod 16 \<in> set (List.upt 0 16)" by auto

  hence "(0x80 + (n mod 16)) \<in> ((\<lambda> x . x + 0x80) ` set (List.upt 0 16))"
    using Set.imageI[OF Upt32, of "(\<lambda> x . x + 0x80)"] by auto

  hence Mapped : "(0x80 + (n mod 16)) \<in> set (map (\<lambda> x . x + 0x80) (List.upt 0 16))"
    by auto

  then show "make_dup n \<in> set dup_codes"
    using List.map_add_upt by auto
qed

lift_definition DUP_DUP :: "nat16 \<Rightarrow> dup_inst" is make_dup
proof-
  fix n :: nat

  have "n mod 16 < 16" using pos_mod_bound[of 16 n] by auto

  hence Upt32: "n mod 16 \<in> set (List.upt 0 16)" by auto

  hence "(0x80 + (n mod 16)) \<in> ((\<lambda> x . x + 0x80) ` set (List.upt 0 16))"
    using Set.imageI[OF Upt32, of "(\<lambda> x . x + 0x80)"] by auto

  hence Mapped : "(0x80 + (n mod 16)) \<in> set (map (\<lambda> x . x + 0x80) (List.upt 0 16))"
    by auto

  then show "make_dup n \<in> set dup_codes"
    using List.map_add_upt by auto
qed

free_constructors cases_dup_inst for DUP_DUP
  by(transfer;
     auto simp del:set_upt simp add:List.upt_def)+

fun is_DUP_DUP :: "dup_inst \<Rightarrow> bool" where
"is_DUP_DUP (DUP_DUP _) = True"

fun get_DUP_DUP :: "dup_inst \<Rightarrow> nat" where
"get_DUP_DUP (DUP_DUP x) = nat_of_nat16 x"

fun is_DUP_DUP_n :: "dup_inst \<Rightarrow> nat \<Rightarrow> bool" where
"is_DUP_DUP_n i x = (get_DUP_DUP i = x)"

(*
 * swap instructions
 *)
definition swap_codes :: "nat list" where
"swap_codes = (List.upt 0x90 0xa0)"
declare swap_codes_def[simp add]
typedef swap_inst = "set swap_codes" by auto
setup_lifting type_definition_swap_inst

lift_definition SWAP_INST :: "swap_inst => inst" is id by auto

(* helper for building swap instructions *)
fun make_swap :: "nat \<Rightarrow> nat" where
"make_swap n =
  0x90 + (n mod 16)"

lift_definition MAKE_SWAP :: "nat \<Rightarrow> swap_inst" is make_swap
proof-
  fix n :: nat

  have "n mod 16 < 16" using pos_mod_bound[of 16 n] by auto

  hence Upt32: "n mod 16 \<in> set (List.upt 0 16)" by auto

  hence "(0x90 + (n mod 16)) \<in> ((\<lambda> x . x + 0x90) ` set (List.upt 0 16))"
    using Set.imageI[OF Upt32, of "(\<lambda> x . x + 0x90)"] by auto

  hence Mapped : "(0x90 + (n mod 16)) \<in> set (map (\<lambda> x . x + 0x90) (List.upt 0 16))"
    by auto

  then show "make_swap n \<in> set swap_codes"
    using List.map_add_upt by auto
qed

lift_definition SWAP_SWAP :: "nat16 \<Rightarrow> swap_inst" is make_swap
proof-
  fix n :: nat

  have "n mod 16 < 16" using pos_mod_bound[of 16 n] by auto

  hence Upt32: "n mod 16 \<in> set (List.upt 0 16)" by auto

  hence "(0x90 + (n mod 16)) \<in> ((\<lambda> x . x + 0x90) ` set (List.upt 0 16))"
    using Set.imageI[OF Upt32, of "(\<lambda> x . x + 0x90)"] by auto

  hence Mapped : "(0x90 + (n mod 16)) \<in> set (map (\<lambda> x . x + 0x90) (List.upt 0 16))"
    by auto

  then show "make_swap n \<in> set swap_codes"
    using List.map_add_upt by auto
qed

free_constructors cases_swap_inst for SWAP_SWAP
  by(transfer;
     auto simp del:set_upt simp add:List.upt_def)+

fun is_SWAP_SWAP :: "swap_inst \<Rightarrow> bool" where
"is_SWAP_SWAP (SWAP_SWAP _) = True"

fun get_SWAP_SWAP :: "swap_inst \<Rightarrow> nat" where
"get_SWAP_SWAP (SWAP_SWAP x) = nat_of_nat16 x"

fun is_SWAP_SWAP_n :: "swap_inst \<Rightarrow> nat \<Rightarrow> bool" where
"is_SWAP_SWAP_n i x = (get_SWAP_SWAP i = x)"

(*
 * log instructions
 *)
definition log_codes where
"log_codes = (List.upt 0xa0 0xa5)"
declare log_codes_def[simp]
typedef log_inst = "set log_codes" by auto
setup_lifting type_definition_log_inst

lift_definition LOG_LOG0 :: "log_inst" is "0xa0" by auto
lift_definition LOG_LOG1 :: "log_inst" is "0xa1" by auto
lift_definition LOG_LOG2 :: "log_inst" is "0xa2" by auto
lift_definition LOG_LOG3 :: "log_inst" is "0xa3" by auto
lift_definition LOG_LOG4 :: "log_inst" is "0xa4" by auto

lift_definition LOG_INST :: "log_inst => inst" is id by auto

free_constructors cases_log_inst for
LOG_LOG0
| LOG_LOG1
| LOG_LOG2
| LOG_LOG3
| LOG_LOG4
  by(transfer;
     auto simp del:set_upt simp add:List.upt_def)+

fun "is_log_LOG0" :: "log_inst => bool" where
"is_log_LOG0 LOG_LOG0 = True"
| "is_log_LOG0 _ = False"
fun "is_log_LOG1" :: "log_inst => bool" where
"is_log_LOG1 LOG_LOG1 = True"
| "is_log_LOG1 _ = False"
fun "is_log_LOG2" :: "log_inst => bool" where
"is_log_LOG2 LOG_LOG2 = True"
| "is_log_LOG2 _ = False"
fun "is_log_LOG3" :: "log_inst => bool" where
"is_log_LOG3 LOG_LOG3 = True"
| "is_log_LOG3 _ = False"
fun "is_log_LOG4" :: "log_inst => bool" where
"is_log_LOG4 LOG_LOG4 = True"
| "is_log_LOG4 _ = False"

(*
 * EIP615 instructions
 *)
definition eip615_codes where
"eip615_codes = (List.upt 0xb0 0xba)"
declare eip615_codes_def[simp]
typedef eip615_inst = "set eip615_codes" by auto
setup_lifting type_definition_eip615_inst

lift_definition EIP615_JUMPTO    :: "eip615_inst" is "0xb0" by auto
lift_definition EIP615_JUMPIF    :: "eip615_inst" is "0xb1" by auto
lift_definition EIP615_JUMPV     :: "eip615_inst" is "0xb2" by auto
lift_definition EIP615_JUMPSUB   :: "eip615_inst" is "0xb3" by auto
lift_definition EIP615_JUMPSUBV  :: "eip615_inst" is "0xb4" by auto
lift_definition EIP615_BEGINSUB  :: "eip615_inst" is "0xb5" by auto
lift_definition EIP615_BEGINDATA :: "eip615_inst" is "0xb6" by auto
lift_definition EIP615_RETURNSUB :: "eip615_inst" is "0xb7" by auto
lift_definition EIP615_PUTLOCAL  :: "eip615_inst" is "0xb8" by auto
lift_definition EIP615_GETLOCAL  :: "eip615_inst" is "0xb9" by auto

lift_definition EIP615_INST :: "eip615_inst => inst" is id by auto

free_constructors cases_eip615_inst for
EIP615_JUMPTO
| EIP615_JUMPIF
| EIP615_JUMPV
| EIP615_JUMPSUB
| EIP615_JUMPSUBV
| EIP615_BEGINSUB
| EIP615_BEGINDATA
| EIP615_RETURNSUB
| EIP615_PUTLOCAL
| EIP615_GETLOCAL
  by(transfer;
     auto simp del:set_upt simp add:List.upt_def)+

fun "is_eip615_JUMPTO" :: "eip615_inst => bool" where
"is_eip615_JUMPTO EIP615_JUMPTO = True"
| "is_eip615_JUMPTO _ = False"
fun "is_eip615_JUMPIF" :: "eip615_inst => bool" where
"is_eip615_JUMPIF EIP615_JUMPIF = True"
| "is_eip615_JUMPIF _ = False"
fun "is_eip615_JUMPV" :: "eip615_inst => bool" where
"is_eip615_JUMPV EIP615_JUMPV = True"
| "is_eip615_JUMPV _ = False"
fun "is_eip615_JUMPSUB" :: "eip615_inst => bool" where
"is_eip615_JUMPSUB EIP615_JUMPSUB = True"
| "is_eip615_JUMPSUB _ = False"
fun "is_eip615_JUMPSUBV" :: "eip615_inst => bool" where
"is_eip615_JUMPSUBV EIP615_JUMPSUBV = True"
| "is_eip615_JUMPSUBV _ = False"
fun "is_eip615_BEGINSUB" :: "eip615_inst => bool" where
"is_eip615_BEGINSUB EIP615_BEGINSUB = True"
| "is_eip615_BEGINSUB _ = False"
fun "is_eip615_BEGINDATA" :: "eip615_inst => bool" where
"is_eip615_BEGINDATA EIP615_BEGINDATA = True"
| "is_eip615_BEGINDATA _ = False"
fun "is_eip615_RETURNSUB" :: "eip615_inst => bool" where
"is_eip615_RETURNSUB EIP615_RETURNSUB = True"
| "is_eip615_RETURNSUB _ = False"
fun "is_eip615_PUTLOCAL" :: "eip615_inst => bool" where
"is_eip615_PUTLOCAL EIP615_PUTLOCAL = True"
| "is_eip615_PUTLOCAL _ = False"
fun "is_eip615_GETLOCAL" :: "eip615_inst => bool" where
"is_eip615_GETLOCAL EIP615_GETLOCAL = True"
| "is_eip615_GETLOCAL _ = False"

(*
 * cross-contract communication instructions
 *)
definition comms_codes where
"comms_codes = (List.upt 0xf0 0xf6) @ [0xfa]"
declare comms_codes_def[simp]
typedef comms_inst = "set comms_codes" by auto
setup_lifting type_definition_comms_inst

lift_definition COMMS_CREATE       :: "comms_inst" is "0xf0" by auto
lift_definition COMMS_CALL         :: "comms_inst" is "0xf1" by auto
lift_definition COMMS_CALLCODE     :: "comms_inst" is "0xf2" by auto
lift_definition COMMS_RETURN       :: "comms_inst" is "0xf3" by auto
lift_definition COMMS_DELEGATECALL :: "comms_inst" is "0xf4" by auto
lift_definition COMMS_CREATE2      :: "comms_inst" is "0xf5" by auto
lift_definition COMMS_STATICCALL   :: "comms_inst" is "0xfa" by auto

lift_definition COMMS_INST :: "comms_inst => inst" is id by auto

free_constructors cases_comms_inst for
COMMS_CREATE
| COMMS_CALL
| COMMS_CALLCODE
| COMMS_RETURN
| COMMS_DELEGATECALL
| COMMS_CREATE2
| COMMS_STATICCALL
  by(transfer;
     auto simp del:set_upt simp add:List.upt_def)+

fun "is_comms_CREATE" :: "comms_inst => bool" where
"is_comms_CREATE COMMS_CREATE = True"
| "is_comms_CREATE _ = False"
fun "is_comms_CALL" :: "comms_inst => bool" where
"is_comms_CALL COMMS_CALL = True"
| "is_comms_CALL _ = False"
fun "is_comms_CALLCODE" :: "comms_inst => bool" where
"is_comms_CALLCODE COMMS_CALLCODE = True"
| "is_comms_CALLCODE _ = False"
fun "is_comms_RETURN" :: "comms_inst => bool" where
"is_comms_RETURN COMMS_RETURN = True"
| "is_comms_RETURN _ = False"
fun "is_comms_DELEGATECALL" :: "comms_inst => bool" where
"is_comms_DELEGATECALL COMMS_DELEGATECALL = True"
| "is_comms_DELEGATECALL _ = False"
fun "is_comms_CREATE2" :: "comms_inst => bool" where
"is_comms_CREATE2 COMMS_CREATE2 = True"
| "is_comms_CREATE2 _ = False"
fun "is_comms_STATICCALL" :: "comms_inst => bool" where
"is_comms_STATICCALL COMMS_STATICCALL = True"
| "is_comms_STATICCALL _ = False"

(*
 * special halting instructions
 *)
definition special_halt_codes where
"special_halt_codes = (List.upt 0xfd 0x100)"
declare special_halt_codes_def[simp]
typedef special_halt_inst = "set special_halt_codes" by auto
setup_lifting type_definition_special_halt_inst

lift_definition SPECIAL_HALT_REVERT       :: "special_halt_inst" is "0xfd" by auto
lift_definition SPECIAL_HALT_INVALID      :: "special_halt_inst" is "0xfe" by auto
lift_definition SPECIAL_HALT_SELFDESTRUCT :: "special_halt_inst" is "0xff" by auto

lift_definition SPECIAL_HALT_INST :: "special_halt_inst => inst" is id by auto

free_constructors cases_special_halt_inst for
SPECIAL_HALT_REVERT
| SPECIAL_HALT_INVALID
| SPECIAL_HALT_SELFDESTRUCT
  by(transfer;
     auto simp del:set_upt simp add:List.upt_def)+

fun "is_special_halt_REVERT" :: "special_halt_inst => bool" where
"is_special_halt_REVERT SPECIAL_HALT_REVERT = True"
| "is_special_halt_REVERT _ = False"
fun "is_special_halt_INVALID" :: "special_halt_inst => bool" where
"is_special_halt_INVALID SPECIAL_HALT_INVALID = True"
| "is_special_halt_INVALID _ = False"
fun "is_special_halt_SELFDESTRUCT" :: "special_halt_inst => bool" where
"is_special_halt_SELFDESTRUCT SPECIAL_HALT_SELFDESTRUCT = True"
| "is_special_halt_SELFDESTRUCT _ = False"

(*
 * Putting the pieces together to get case analysis for all instructions
 *)

(* we are leaving out EIP615 *)
definition good_codes :: "nat list" where
"good_codes =
  stop_codes @
  arith_codes @
  bits_compare_codes @
  keccak256_codes @
  tx_data_codes @
  chain_data_codes @
  state_control_codes @
  push_codes @
  dup_codes @
  swap_codes @
  log_codes @
  comms_codes @
  special_halt_codes"

typedef good_inst = "set good_codes"
  by(auto simp add: good_codes_def)
setup_lifting type_definition_good_inst

lift_definition GOOD_INST :: "good_inst \<Rightarrow> inst" is id
  by(auto simp add: good_codes_def)

(* "more computable" approach to set differencing -
still not fast enough*)

(*
fun list_diff :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"list_diff l [] = l"
| "list_diff l (x#xs) =
   list_diff (remove1 x l) xs"

lemma list_diff_set :
  assumes H : "distinct l1"
  shows "set (list_diff l1 l2) = set l1 - set l2" using assms
proof(induction l2 arbitrary: l1)
case Nil
  then show ?case by auto
next
  case (Cons a l2)
  then show ?case
    by(auto)
qed
*)
(*
definition bad_codes :: "nat list" where
"bad_codes =
  list_diff (List.upt 0 256) good_codes"

lemma bad_codes_spec :
  shows "set bad_codes = set (List.upt 0 (256 :: nat)) - set good_codes"
  unfolding bad_codes_def list_diff_set[OF distinct_upt]
  by auto
*)

(* TODO: doing this by hand was pretty painful.
   If we had a better data structure than lists readily available,
   we could probably compute this in a reasonable way *)
definition bad_codes :: "nat list" where
"bad_codes =
  [0x0c, 0x0d, 0x0e, 0x0f,
   0x1e, 0x1f,
   0x21, 0x22, 0x23, 0x24, 0x25, 0x26, 0x27, 0x28, 0x29, 0x2a, 0x2b, 0x2c, 0x2d, 0x2e, 0x2f,
   0x48, 0x49, 0x4a, 0x4b, 0x4c, 0x4d, 0x4e, 0x4f,
   0x5c, 0x5d, 0x5e, 0x5f,
   0xa5, 0xa6, 0xa7, 0xa8, 0xa9, 0xaa, 0xab, 0xac, 0xad, 0xae, 0xaf,
   0xb0, 0xb1, 0xb2, 0xb3, 0xb4, 0xb5, 0xb6, 0xb7, 0xb8, 0xb9, 0xba, 0xbb, 0xbc, 0xbd, 0xbe, 0xbf,
   0xc0, 0xc1, 0xc2, 0xc3, 0xc4, 0xc5, 0xc6, 0xc7, 0xc8, 0xc9, 0xca, 0xcb, 0xcc, 0xcd, 0xce, 0xcf,
   0xd0, 0xd1, 0xd2, 0xd3, 0xd4, 0xd5, 0xd6, 0xd7, 0xd8, 0xd9, 0xda, 0xdb, 0xdc, 0xdd, 0xde, 0xdf,
   0xe0, 0xe1, 0xe2, 0xe3, 0xe4, 0xe5, 0xe6, 0xe7, 0xe8, 0xe9, 0xea, 0xeb, 0xec, 0xed, 0xee, 0xef,
   0xf6, 0xf7, 0xf8, 0xf9,
   0xfb, 0xfc]"

typedef bad_inst = "set bad_codes" by(auto simp add: bad_codes_def)
setup_lifting type_definition_bad_inst

lift_definition BAD_INST :: "bad_inst \<Rightarrow> inst" is id by(auto simp add: bad_codes_def)

lemma good_are_insts : "set good_codes \<subseteq> {x . x < 256}"
  by(auto simp add: good_codes_def)

(*
lemma good_bad : "set good_codes \<union> set bad_codes = {x . x < 256}"
  unfolding bad_codes_def good_codes_def
  apply(auto)
*)

lemma cases_inst_helper :
  assumes Hy :  "(y :: nat) < 256"
  assumes H1 :  "(\<And>x1. x1 \<in> set stop_codes \<Longrightarrow> y = id x1 \<Longrightarrow> P)"
  assumes H2 :  "(\<And>x2. x2 \<in> set arith_codes \<Longrightarrow> y = id x2 \<Longrightarrow> P)"
  assumes H4 :  "(\<And>x4. x4 \<in> set bits_compare_codes \<Longrightarrow> y = id x4 \<Longrightarrow> P)"
  assumes H5 :  "(\<And>x5. x5 \<in> set keccak256_codes \<Longrightarrow> y = id x5 \<Longrightarrow> P)"
  assumes H6 :  "(\<And>x6. x6 \<in> set tx_data_codes \<Longrightarrow> y = id x6 \<Longrightarrow> P)"
  assumes H7 :  "(\<And>x7. x7 \<in> set chain_data_codes \<Longrightarrow> y = id x7 \<Longrightarrow> P)"
  assumes H8 :  "(\<And>x8. x8 \<in> set state_control_codes \<Longrightarrow> y = id x8 \<Longrightarrow> P)"
  assumes H9 :  "(\<And>x9. x9 \<in> set push_codes \<Longrightarrow> y = id x9 \<Longrightarrow> P)"
  assumes H10 : "(\<And>x10. x10 \<in> set dup_codes \<Longrightarrow> y = id x10 \<Longrightarrow> P)"
  assumes H11 : "(\<And>x11. x11 \<in> set swap_codes \<Longrightarrow> y = id x11 \<Longrightarrow> P)"
  assumes H12 : "(\<And>x12. x12 \<in> set log_codes \<Longrightarrow> y = id x12 \<Longrightarrow> P)"
  assumes H13 : "(\<And>x13. x13 \<in> set comms_codes \<Longrightarrow> y = id x13 \<Longrightarrow> P)"
  assumes H14 : "(\<And>x14. x14 \<in> set special_halt_codes \<Longrightarrow> y = id x14 \<Longrightarrow> P)"
  assumes H15 : "(\<And>x15. x15 \<in> set bad_codes \<Longrightarrow> y = id x15 \<Longrightarrow> P)"
  shows P

  sorry
(*

(* "constructors" for each instruction type *)
free_constructors cases_inst for
STOP_INST
| ARITH_INST
| BITS_COMPARE_INST
| KECCAK256_INST
| TX_DATA_INST
| CHAIN_DATA_INST
| STATE_CONTROL_INST
| PUSH_INST
| DUP_INST
| SWAP_INST
| LOG_INST
| COMMS_INST
| SPECIAL_HALT_INST
| BAD_INST

                      apply(transfer)
  defer
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)

  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)

(* apply(rule cases_inst_helper; blast) *)

(*
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
  apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
apply(transfer; auto simp: bad_codes_def good_codes_def; fail)
*)

(*
  by (transfer; auto simp: bad_codes_spec good_codes_def; fail)+
*)

(*
                      apply(transfer;
  match conclusion in "x = y" for x y \<Rightarrow> \<open>transfer;
  fastforce simp add: bad_codes_def good_codes_def
List.upt_def simp del: set_upt\<close>
      | match conclusion in"x \<noteq> y" for x y \<Rightarrow>  \<open>transfer;
  fastforce simp add: bad_codes_def good_codes_def
List.upt_def simp del: set_upt\<close>
      | rule cases_inst_helper; blast)
*)

(*
                      apply(transfer;
  fastforce simp add: bad_codes_def good_codes_def
List.upt_def simp del: set_upt; fail)+
*)
(*
                      apply(match premises in I : "\<And> P y . y < 256"  \<Rightarrow>
\<open>simp only: stop_codes_def\<close>)
*)

(*
(rule cases_inst_helper; blast)[1])
*)
(*
  apply( auto simp del:set_upt simp add:List.upt_def)+
                      defer
               apply(transfer; force)+
  *)
*)

end


(*  Title:      Schutz_Spacetime/TemporalOrderExtra.thy
    Authors:    Richard Schmoetten, Jake Palmer and Jacques D. Fleuriot
                University of Edinburgh, 2021
*)
theory TemporalOrderExtra
  imports Main Minkowski TernaryOrdering TemporalOrderOnPath "HOL-Algebra.Order"
begin

section \<open>Ternary-to-binary\<close>

context MinkowskiSpacetime
begin

\<comment> \<open>The cases we need to cover where x <= y if we take a < b as our ordering basis:
    [abxy], [axby], [axyb],
    [xaby], [xayb], [xyab].
\<close>
abbreviation betw_gorder :: "'a \<Rightarrow> 'a \<Rightarrow> 'a set \<Rightarrow> 'a gorder" where
  "betw_gorder a b Q \<equiv> \<lparr>carrier = Q, eq = (=),
                        le = (\<lambda>x y. x = y
                                 \<comment> \<open>Base case. Everything from here is < really.\<close>
                                 \<or> x = a \<and> y = b
                                 \<comment> \<open>a < y\<noteq>b case (\<noteq> fact is covered by [___].\<close>
                                 \<or> x = a \<and> ([a;b;y] \<or> [a;y;b])
                                 \<comment> \<open>b < y case. Can't have [b a y].\<close>
                                 \<or> x = b \<and> [a;b;y]
                                 \<comment> \<open>x < a\<close>
                                 \<or> y = a \<and> [x;a;b]
                                 \<comment> \<open>x < b\<close>
                                 \<or> y = b \<and> ([x;a;b] \<or> [a;x;b])
                                 \<comment> \<open>4-event cases.\<close>
                                 \<or> [a;b;x;y] \<or> [a;x;b;y] \<or> [a;x;y;b]
                                 \<or> [x;a;b;y] \<or> [x;a;y;b] \<or> [x;y;a;b]
                             )
                         \<rparr>"

lemma betw_total_order_on_path:
  fixes a b :: 'a
    and Q :: "'a set"
  assumes "Q \<in> \<P>"
      and "a \<in> Q"
      and "b \<in> Q"
      and "a \<noteq> b"
  shows "total_order (betw_gorder a b Q)" (is "total_order ?o")
proof
  show "\<And>x. x \<in> carrier ?o \<Longrightarrow> x .=\<^bsub>?o\<^esub> x"
    by simp
next
  show "\<And>x y. \<lbrakk>x .=\<^bsub>?o\<^esub> y; x \<in> carrier ?o; y \<in> carrier ?o\<rbrakk> \<Longrightarrow> y .=\<^bsub>?o\<^esub> x"
    by simp
next
  show "\<And>x y z. \<lbrakk>x .=\<^bsub>?o\<^esub> y; y .=\<^bsub>?o\<^esub> z; x \<in> carrier ?o;
                 y \<in> carrier ?o; z \<in> carrier ?o\<rbrakk>
        \<Longrightarrow> x .=\<^bsub>?o\<^esub> z"
    by simp
next
  show "\<And>x. x \<in> carrier ?o \<Longrightarrow> x \<sqsubseteq>\<^bsub>?o\<^esub> x"
    by simp
next
  show "\<And>x y. \<lbrakk>x \<sqsubseteq>\<^bsub>?o\<^esub> y; y \<sqsubseteq>\<^bsub>?o\<^esub> x; x \<in> carrier ?o; y \<in> carrier ?o\<rbrakk> \<Longrightarrow> x .=\<^bsub>?o\<^esub> y"
    by (smt abc_abc_neq abcd_dcba_only(18) betw4_sym betw4_weak eq_object.select_convs(1)
      gorder.select_convs(1))
next
  show "\<And>x y z.
       \<lbrakk>x \<sqsubseteq>\<^bsub>?o\<^esub> y; y \<sqsubseteq>\<^bsub>?o\<^esub> z; x \<in> carrier ?o;
        y \<in> carrier ?o; z \<in> carrier ?o\<rbrakk>
       \<Longrightarrow> x \<sqsubseteq>\<^bsub>?o\<^esub> z"
    by (smt (z3) abc_acd_abd abc_acd_bcd abc_bcd_acd abc_only_cba(1,4) assms(1)
      gorder.select_convs(1) partial_object.select_convs(1) some_betw2)
next
  show "\<And>x y z w.
       \<lbrakk>x .=\<^bsub>?o\<^esub> y; z .=\<^bsub>?o\<^esub> w; x \<in> carrier ?o;
        y \<in> carrier ?o; z \<in> carrier ?o; w \<in> carrier ?o\<rbrakk>
       \<Longrightarrow> (x \<sqsubseteq>\<^bsub>?o\<^esub> z) = (y \<sqsubseteq>\<^bsub>?o\<^esub> w)"
    by simp
next
  show "(.=\<^bsub>?o\<^esub>) = (=)"
    by simp
next
  show "\<And>x y. \<lbrakk>x \<in> carrier (betw_gorder a b Q); y \<in> carrier (betw_gorder a b Q)\<rbrakk>
           \<Longrightarrow> x \<sqsubseteq>\<^bsub>betw_gorder a b Q\<^esub> y \<or> y \<sqsubseteq>\<^bsub>betw_gorder a b Q\<^esub> x"
    by (smt (z3) abc_sym assms gorder.select_convs(1) partial_object.select_convs(1)
      some_betw2 some_betw4b)
qed

end

end