(* Title: Quantales
   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>Quantales\<close>

text \<open>This entry will be merged eventually with other quantale entries and become a standalone one.\<close>

theory Quantales
  imports Main

begin

notation sup (infixl "\<squnion>" 60)
  and inf (infixl "\<sqinter>" 55)
  and top ("\<top>")
  and bot ("\<bottom>")
  and relcomp (infixl ";" 70)
  and times (infixl "\<cdot>" 70)
  and Sup ("\<Squnion>_" [900] 900)
  and Inf ("\<Sqinter>_" [900] 900)

subsection \<open>Properties of Complete Lattices\<close>

lemma (in complete_lattice) Sup_sup_pred: "x \<squnion> \<Squnion>{y. P y} = \<Squnion>{y. y = x \<or> P y}"
  apply (rule order.antisym)
   apply (simp add: Collect_mono Sup_subset_mono Sup_upper)
  using Sup_least Sup_upper sup.coboundedI2 by force

lemma (in complete_lattice) sup_Sup: "x \<squnion> y = \<Squnion>{x,y}"
  by simp

lemma (in complete_lattice) sup_Sup_var: "x \<squnion> y = \<Squnion>{z. z \<in> {x,y}}"
  by (metis Collect_mem_eq sup_Sup)

lemma (in complete_boolean_algebra) shunt1: "x \<sqinter> y \<le> z \<longleftrightarrow> x \<le> -y \<squnion> z"
proof standard
  assume "x \<sqinter> y \<le> z"
  hence  "-y \<squnion> (x \<sqinter> y) \<le> -y \<squnion> z"
    using sup.mono by blast
  hence "-y \<squnion> x \<le> -y \<squnion> z"
    by (simp add: sup_inf_distrib1)
  thus "x \<le> -y \<squnion> z"
    by simp
next
  assume "x \<le> - y \<squnion> z"
  hence "x \<sqinter> y \<le> (-y \<squnion> z) \<sqinter> y"
    using inf_mono by auto
  thus  "x \<sqinter> y \<le> z"
    using inf.boundedE inf_sup_distrib2 by auto
qed

lemma (in complete_boolean_algebra) meet_shunt: "x \<sqinter> y = \<bottom> \<longleftrightarrow> x \<le> -y"
  by (metis bot_least inf_absorb2 inf_compl_bot_left2 shunt1 sup_absorb1)

lemma (in complete_boolean_algebra) join_shunt: "x \<squnion> y = \<top> \<longleftrightarrow> -x \<le> y"
  by (metis compl_sup compl_top_eq double_compl meet_shunt)

subsection \<open> Familes of Proto-Quantales\<close>

text \<open>Proto-Quanales are complete lattices equipped with an operation of composition or multiplication
that need not be associative.\<close>

class proto_near_quantale = complete_lattice + times +
  assumes Sup_distr: "\<Squnion>X \<cdot> y = \<Squnion>{x \<cdot> y |x. x \<in> X}"

begin

lemma mult_botl [simp]: "\<bottom> \<cdot> x = \<bottom>"
  using Sup_distr[where X="{}"] by auto

lemma sup_distr: "(x \<squnion> y) \<cdot> z = (x \<cdot> z) \<squnion> (y \<cdot> z)"
  using Sup_distr[where X="{x, y}"] by (fastforce intro!: Sup_eqI)

lemma mult_isor: "x \<le> y \<Longrightarrow> x \<cdot> z \<le> y \<cdot> z"
  by (metis sup.absorb_iff1 sup_distr)

definition bres :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixr "\<rightarrow>" 60) where
  "x \<rightarrow> z = \<Squnion>{y. x \<cdot> y \<le> z}"

definition fres :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "\<leftarrow>" 60) where
  "z \<leftarrow> y = \<Squnion>{x. x \<cdot> y \<le> z}"

lemma bres_galois_imp: "x \<cdot> y \<le> z \<longrightarrow> y \<le> x \<rightarrow> z"
  by (simp add: Sup_upper bres_def)

lemma fres_galois: "x \<cdot> y \<le> z \<longleftrightarrow> x \<le> z \<leftarrow> y"
proof
  show "x \<cdot> y \<le> z \<Longrightarrow> x \<le> z \<leftarrow> y"
    by (simp add: Sup_upper fres_def)
next
  assume "x \<le> z \<leftarrow> y"
  hence "x \<cdot> y \<le> \<Squnion>{x. x \<cdot> y \<le> z} \<cdot> y"
    by (simp add: fres_def mult_isor)
  also have "... = \<Squnion>{x \<cdot> y |x. x \<cdot> y \<le> z}"
    by (simp add: Sup_distr)
  also have "... \<le> z"
    by (rule Sup_least, auto)
  finally show "x \<cdot> y \<le> z" .
qed

end

class proto_pre_quantale = proto_near_quantale +
  assumes Sup_subdistl: "\<Squnion>{x \<cdot> y | y . y \<in> Y} \<le> x \<cdot> \<Squnion>Y"

begin

lemma sup_subdistl: "(x \<cdot> y) \<squnion> (x \<cdot> z) \<le> x \<cdot> (y \<squnion> z)"
  using Sup_subdistl[where Y="{y, z}"] Sup_le_iff by auto

lemma mult_isol: "x \<le> y \<Longrightarrow> z \<cdot> x \<le> z \<cdot> y"
  by (metis le_iff_sup le_sup_iff sup_subdistl)

end

class weak_proto_quantale = proto_near_quantale +
  assumes weak_Sup_distl: "Y \<noteq> {} \<Longrightarrow> x \<cdot> \<Squnion>Y = \<Squnion>{x \<cdot> y |y. y \<in> Y}"

begin

subclass proto_pre_quantale
proof standard
  have a: "\<And>x Y. Y = {} \<Longrightarrow> \<Squnion>{x \<cdot> y |y. y \<in> Y} \<le> x \<cdot> \<Squnion>Y"
    by simp
  have b: "\<And>x Y. Y \<noteq> {} \<Longrightarrow> \<Squnion>{x \<cdot> y |y. y \<in> Y} \<le> x \<cdot> \<Squnion>Y"
    by (simp add: weak_Sup_distl)
  show  "\<And>x Y. \<Squnion>{x \<cdot> y |y. y \<in> Y} \<le> x \<cdot> \<Squnion>Y"
    using a b by blast
qed

lemma  sup_distl: "x \<cdot> (y \<squnion> z) = (x \<cdot> y) \<squnion> (x \<cdot> z)"
  using weak_Sup_distl[where Y="{y, z}"] by (fastforce intro!: Sup_eqI)

lemma "y \<le> x \<rightarrow> z \<longrightarrow> x \<cdot> y \<le> z" (* nitpick [expect = genuine] *)
oops

end

class proto_quantale = proto_near_quantale +
  assumes Sup_distl: "x \<cdot> \<Squnion>Y = \<Squnion>{x \<cdot> y |y. y \<in> Y}"

begin

subclass weak_proto_quantale
  by standard (simp add: Sup_distl)

lemma bres_galois: "x \<cdot> y \<le> z \<longleftrightarrow> y \<le> x \<rightarrow> z"
proof
  show "x \<cdot> y \<le> z \<Longrightarrow> y \<le> x \<rightarrow> z"
    by (simp add: Sup_upper bres_def)
next
  assume "y \<le> x \<rightarrow> z"
  hence "x \<cdot> y \<le> x \<cdot> \<Squnion>{y. x \<cdot> y \<le> z}"
    by (simp add: bres_def mult_isol)
  also have "... = \<Squnion>{x \<cdot> y |y. x \<cdot> y \<le> z}"
    by (simp add: Sup_distl)
  also have "... \<le> z"
    by (rule Sup_least, auto)
  finally show "x \<cdot> y \<le> z" .
qed

end

subsection \<open>Families of Quantales\<close>

class near_quantale = proto_near_quantale + semigroup_mult

class unital_near_quantale = near_quantale + monoid_mult

begin

definition iter :: "'a \<Rightarrow> 'a" where
  "iter x \<equiv> \<Sqinter>{y. \<exists>i. y = x ^ i}"

lemma iter_ref [simp]: "iter x \<le> 1"
  apply (simp add: iter_def)
  by (metis (mono_tags, lifting) Inf_lower local.power.power_0 mem_Collect_eq)

lemma le_top: "x \<le> \<top> \<cdot> x"
  by (metis mult_isor mult.monoid_axioms top_greatest monoid.left_neutral)

end

class pre_quantale = proto_pre_quantale + semigroup_mult

subclass (in pre_quantale) near_quantale ..

class unital_pre_quantale = pre_quantale + monoid_mult

subclass (in unital_pre_quantale) unital_near_quantale ..

class weak_quantale = weak_proto_quantale + semigroup_mult

subclass (in weak_quantale) pre_quantale ..

text \<open>The following counterexample shows an important consequence of weakness:
the absence of right annihilation.\<close>

lemma (in weak_quantale) "x \<cdot> \<bottom> = \<bottom>" (*nitpick[expect=genuine]*)
  oops

class unital_weak_quantale = weak_quantale + monoid_mult

lemma (in unital_weak_quantale) "x \<cdot> \<bottom> = \<bottom>" (*nitpick[expect=genuine]*)
  oops

subclass (in unital_weak_quantale) unital_pre_quantale ..

class quantale = proto_quantale + semigroup_mult

begin

subclass weak_quantale ..

lemma mult_botr [simp]: "x \<cdot> \<bottom> = \<bottom>"
  using Sup_distl[where Y="{}"] by auto

end

class unital_quantale = quantale + monoid_mult

subclass (in unital_quantale) unital_weak_quantale ..

class ab_quantale = quantale + ab_semigroup_mult

begin

lemma bres_fres_eq: "x \<rightarrow> y = y \<leftarrow> x"
  by (simp add: fres_def bres_def mult_commute)

end

class ab_unital_quantale = ab_quantale + unital_quantale

class distrib_quantale = quantale + complete_distrib_lattice

class bool_quantale = quantale + complete_boolean_algebra

class distrib_unital_quantale = unital_quantale + complete_distrib_lattice

class bool_unital_quantale = unital_quantale + complete_boolean_algebra

class distrib_ab_quantale = distrib_quantale + ab_quantale

class bool_ab_quantale = bool_quantale + ab_quantale

class distrib_ab_unital_quantale = distrib_quantale + unital_quantale

class bool_ab_unital_quantale = bool_ab_quantale + unital_quantale

subsection \<open>Quantales of Booleans and Complete Boolean Algebras\<close>

instantiation bool :: bool_ab_unital_quantale
begin

definition "one_bool = True"

definition "times_bool = (\<lambda>x y. x \<and> y)"

instance
  by standard (auto simp: times_bool_def one_bool_def)

end

context complete_distrib_lattice
begin

interpretation cdl_quantale: distrib_quantale _ _ _ _ _ _ _ _ inf
  by standard (simp_all add: inf.assoc Setcompr_eq_image Sup_inf inf_Sup)

end

context complete_boolean_algebra
begin

interpretation cba_quantale: bool_ab_unital_quantale inf _ _ _ _ _ _ _ _ _ _ top
  apply standard
  apply (simp add: inf.assoc)
  apply (simp add: inf.commute)
  apply (simp add: Setcompr_eq_image Sup_inf)
  apply (simp add: Setcompr_eq_image inf_Sup)
  by simp_all

text \<open>In this setting, residuation can be translated like classical implication.\<close>

lemma cba_bres1: "x \<sqinter> y \<le> z \<longleftrightarrow> x \<le> cba_quantale.bres y z"
  using cba_quantale.bres_galois inf.commute by fastforce

lemma cba_bres2: "x \<le> -y \<squnion> z \<longleftrightarrow> x \<le> cba_quantale.bres y z"
  using cba_bres1 shunt1 by auto

lemma cba_bres_prop: "cba_quantale.bres x y = -x \<squnion> y"
  using cba_bres2 order.eq_iff by blast

end

text \<open>Other models will follow.\<close>

subsection \<open>Products of Quantales\<close>

definition "Inf_prod X = (\<Sqinter>{fst x |x. x \<in> X}, \<Sqinter>{snd x |x.  x \<in> X})"

definition "inf_prod x y = (fst x \<sqinter> fst y, snd x \<sqinter> snd y)"

definition "bot_prod = (bot,bot)"

definition "Sup_prod X = (\<Squnion>{fst x |x. x \<in> X}, \<Squnion>{snd x |x.  x \<in> X})"

definition "sup_prod x y = (fst x \<squnion> fst y, snd x \<squnion> snd y)"

definition "top_prod = (top,top)"

definition "less_eq_prod x y \<equiv> less_eq (fst x) (fst y) \<and> less_eq (snd x) (snd y)"

definition "less_prod x y \<equiv> less_eq (fst x) (fst y) \<and> less_eq (snd x) (snd y) \<and> x \<noteq> y"

definition "times_prod' x y = (fst x \<cdot> fst y, snd x \<cdot> snd y)"

definition "one_prod = (1,1)"

interpretation prod: complete_lattice Inf_prod Sup_prod inf_prod less_eq_prod less_prod sup_prod bot_prod "top_prod :: ('a::complete_lattice \<times> 'b::complete_lattice)"
  apply standard
     apply (simp_all add: Inf_prod_def Sup_prod_def inf_prod_def sup_prod_def bot_prod_def top_prod_def less_eq_prod_def less_prod_def Sup_distl Sup_distr)
        apply force+
     apply (rule conjI, (rule Inf_lower, force)+)
    apply (rule conjI, (rule Inf_greatest, force)+)
   apply (rule conjI, (rule Sup_upper, force)+)
  by (rule conjI, (rule Sup_least, force)+)

interpretation prod: proto_near_quantale Inf_prod Sup_prod inf_prod less_eq_prod less_prod sup_prod bot_prod "top_prod :: ('a::proto_near_quantale \<times> 'b::proto_near_quantale)" times_prod'
  apply (standard, simp add: times_prod'_def Sup_prod_def)
  by (rule conjI, (simp add: Sup_distr, clarify, metis)+)

interpretation prod: proto_quantale Inf_prod Sup_prod inf_prod less_eq_prod less_prod sup_prod bot_prod "top_prod :: ('a::proto_quantale \<times> 'b::proto_quantale)" times_prod'
  apply (standard, simp add: times_prod'_def Sup_prod_def less_eq_prod_def)
  by (rule conjI, (simp add: Sup_distl, metis)+)

interpretation prod: unital_quantale one_prod times_prod' Inf_prod Sup_prod inf_prod less_eq_prod less_prod sup_prod bot_prod "top_prod :: ('a::unital_quantale \<times> 'b::unital_quantale)"
  by standard (simp_all add: one_prod_def times_prod'_def mult.assoc)

subsection \<open>Quantale Modules and Semidirect Products\<close>

text \<open>Quantale modules are extensions of semigroup actions in that a quantale acts on a complete lattice.\<close>

locale unital_quantale_module =
  fixes act :: "'a::unital_quantale \<Rightarrow> 'b::complete_lattice \<Rightarrow> 'b" ("\<alpha>")
  assumes act1: "\<alpha> (x \<cdot> y) p = \<alpha> x (\<alpha> y p)"
    and act2 [simp]: "\<alpha> 1 p = p"
    and act3: "\<alpha> (\<Squnion>X) p = \<Squnion>{\<alpha> x p |x. x \<in> X}"
    and act4: "\<alpha> x (\<Squnion>P) = \<Squnion>{\<alpha> x p |p. p \<in> P}"

context unital_quantale_module
begin

text \<open>Actions are morphisms. The curried notation is particularly convenient for this.\<close>

lemma act_morph1: "\<alpha> (x \<cdot> y) = (\<alpha> x) \<circ> (\<alpha> y)"
  by (simp add: fun_eq_iff act1)

lemma act_morph2: "\<alpha> 1 = id"
  by (simp add: fun_eq_iff)

lemma emp_act: "\<alpha> (\<Squnion>{}) p = \<bottom>"
  by (simp only: act3, force)

lemma emp_act_var: "\<alpha> \<bottom> p = \<bottom>"
  using emp_act by auto

lemma act_emp: "\<alpha> x (\<Squnion>{}) = \<bottom>"
  by (simp only: act4, force)

lemma act_emp_var: "\<alpha> x \<bottom> = \<bottom>"
  using act_emp by auto

lemma act_sup_distl: "\<alpha> x (p \<squnion> q) = (\<alpha> x p) \<squnion> (\<alpha> x q)"
proof-
  have "\<alpha> x (p \<squnion> q) = \<alpha> x (\<Squnion>{p,q})"
    by simp
  also have "... = \<Squnion>{\<alpha> x y |y. y \<in> {p,q}}"
    by (rule act4)
  also have "... = \<Squnion>{v. v = \<alpha> x p \<or> v = \<alpha> x q}"
    by (metis empty_iff insert_iff)
  finally show ?thesis
    by (metis Collect_disj_eq Sup_insert ccpo_Sup_singleton insert_def singleton_conv)
qed

lemma act_sup_distr: "\<alpha> (x \<squnion> y) p = (\<alpha> x p) \<squnion> (\<alpha> y p)"
  proof-
  have "\<alpha> (x \<squnion> y) p  = \<alpha> (\<Squnion>{x,y}) p"
    by simp
  also have "... = \<Squnion>{\<alpha> v p |v. v \<in> {x,y}}"
    by (rule act3)
  also have "... = \<Squnion>{v. v = \<alpha> x p \<or> v = \<alpha> y p}"
    by (metis empty_iff insert_iff)
  finally show ?thesis
    by (metis Collect_disj_eq Sup_insert ccpo_Sup_singleton insert_def singleton_conv)
qed

lemma act_sup_distr_var: "\<alpha> (x \<squnion> y) = (\<alpha> x) \<squnion> (\<alpha> y)"
  by (simp add: fun_eq_iff act_sup_distr)

text \<open>Next we define the semidirect product of a  unital quantale and a complete lattice. \<close>

definition "sd_prod x y = (fst x \<cdot> fst y, snd x \<squnion> \<alpha> (fst x) (snd y))"

lemma sd_distr_aux:
  "\<Squnion>{snd x |x. x \<in> X} \<squnion> \<Squnion>{\<alpha> (fst x) p |x. x \<in> X} = \<Squnion>{snd x \<squnion> \<alpha> (fst x) p |x. x \<in> X}"
proof (rule antisym, rule sup_least)
  show "\<Squnion>{snd x |x. x \<in> X} \<le> \<Squnion>{snd x \<squnion> \<alpha> (fst x) p |x. x \<in> X}"
  proof (rule Sup_least)
    fix x :: 'b
    assume "x \<in> {snd x |x. x \<in> X}"
    hence "\<exists>b pa. x \<squnion> b = snd pa \<squnion> \<alpha> (fst pa) p \<and> pa \<in> X"
      by blast
    hence "\<exists>b. x \<squnion> b \<in> {snd pa \<squnion> \<alpha> (fst pa) p |pa. pa \<in> X}"
      by blast
    thus "x \<le> \<Squnion>{snd pa \<squnion> \<alpha> (fst pa) p |pa. pa \<in> X}"
      by (meson Sup_upper sup.bounded_iff)
  qed
next
  show "\<Squnion>{\<alpha> (fst x) p |x. x \<in> X} \<le> \<Squnion>{snd x \<squnion> \<alpha> (fst x) p |x. x \<in> X}"
  proof (rule Sup_least)
    fix x :: 'b
    assume "x \<in> {\<alpha> (fst x) p |x. x \<in> X}"
    then have "\<exists>b pa. b \<squnion> x = snd pa \<squnion> \<alpha> (fst pa) p \<and> pa \<in> X"
      by blast
    then have "\<exists>b. b \<squnion> x \<in> {snd pa \<squnion> \<alpha> (fst pa) p |pa. pa \<in> X}"
      by blast
    then show "x \<le> \<Squnion>{snd pa \<squnion> \<alpha> (fst pa) p |pa. pa \<in> X}"
      by (meson Sup_upper le_supE)
  qed
next
  show "\<Squnion>{snd x \<squnion> \<alpha> (fst x) p |x. x \<in> X} \<le> \<Squnion>{snd x |x. x \<in> X} \<squnion> \<Squnion>{\<alpha> (fst x) p |x. x \<in> X}"
    apply (rule Sup_least)
    apply safe
    apply (rule sup_least)
    apply (metis (mono_tags, lifting) Sup_upper mem_Collect_eq sup.coboundedI1)
    by (metis (mono_tags, lifting) Sup_upper mem_Collect_eq sup.coboundedI2)
qed

lemma sd_distr: "sd_prod (Sup_prod X) y = Sup_prod {sd_prod x y |x. x \<in> X}"
proof -
  have "sd_prod (Sup_prod X) y = sd_prod (\<Squnion>{fst x |x. x \<in> X}, \<Squnion>{snd x |x. x \<in> X}) y"
    by (simp add: Sup_prod_def)
  also have
    "... = ((\<Squnion>{fst x |x. x \<in> X}) \<cdot> fst y, (\<Squnion>{snd x |x. x \<in> X}) \<squnion> (\<alpha> (\<Squnion>{fst x | x. x \<in> X})  (snd y)))"
    by (simp add: sd_prod_def)
  also have
    "... = (\<Squnion>{fst x \<cdot> fst y|x. x \<in> X}, (\<Squnion>{snd x |x. x \<in> X}) \<squnion> (\<alpha> (\<Squnion>{fst x | x. x \<in> X})  (snd y)))"
    by (simp add: Sup_distr)
  also have
    "... = (\<Squnion>{fst x \<cdot> fst y|x. x \<in> X}, (\<Squnion> {snd x |x. x \<in> X}) \<squnion> (\<Squnion>{\<alpha> (fst x) (snd y) | x. x \<in> X}))"
    by (simp add: act3)
  also have "... = (\<Squnion>{fst x \<cdot> fst y|x. x \<in> X}, \<Squnion>{snd x \<squnion> (\<alpha> (fst x) (snd y)) | x. x \<in> X})"
    by (simp only: sd_distr_aux)
  also have "... = Sup_prod {(fst x \<cdot> fst y, snd x \<squnion> (\<alpha> (fst x) (snd y))) |x. x \<in> X}"
    by (simp add: Sup_prod_def, metis)
  finally show ?thesis
    by (simp add: sd_prod_def)
qed

lemma sd_distl_aux: "Y \<noteq> {} \<Longrightarrow> p \<squnion> (\<Squnion>{\<alpha> x (snd y) |y. y \<in> Y}) = \<Squnion>{p \<squnion> \<alpha> x (snd y) |y. y \<in> Y}"
proof (rule antisym, rule sup_least)
  show "Y \<noteq> {} \<Longrightarrow> p \<le> \<Squnion>{p \<squnion> \<alpha> x (snd y) |y. y \<in> Y}"
  proof -
    assume "Y \<noteq> {}"
    hence "\<exists>b. b \<in> {p \<squnion> \<alpha> x (snd pa) |pa. pa \<in> Y} \<and> p \<le> b"
      by fastforce
    thus "p \<le> \<Squnion>{p \<squnion> \<alpha> x (snd pa) |pa. pa \<in> Y}"
      by (meson Sup_upper2)
  qed
next
  show "Y \<noteq> {} \<Longrightarrow> \<Squnion>{\<alpha> x (snd y) |y. y \<in> Y} \<le> \<Squnion>{p \<squnion> \<alpha> x (snd y) |y. y \<in> Y}"
    apply (rule Sup_least)
  proof -
    fix xa :: 'b
    assume "xa \<in> {\<alpha> x (snd y) |y. y \<in> Y}"
    then have "\<exists>b. (\<exists>pa. b = p \<squnion> \<alpha> x (snd pa) \<and> pa \<in> Y) \<and> xa \<le> b"
      by fastforce
    then have "\<exists>b. b \<in> {p \<squnion> \<alpha> x (snd pa) |pa. pa \<in> Y} \<and> xa \<le> b"
      by blast
    then show "xa \<le> \<Squnion>{p \<squnion> \<alpha> x (snd pa) |pa. pa \<in> Y}"
      by (meson Sup_upper2)
  qed
next
  show "Y \<noteq> {} \<Longrightarrow> \<Squnion>{p \<squnion> \<alpha> x (snd y) |y. y \<in> Y} \<le> p \<squnion> \<Squnion>{\<alpha> x (snd y) |y. y \<in> Y}"
    apply (rule Sup_least)
    apply safe
    by (metis (mono_tags, lifting) Sup_le_iff le_sup_iff mem_Collect_eq sup_ge1 sup_ge2)
qed

lemma sd_distl: "Y \<noteq> {} \<Longrightarrow> sd_prod x (Sup_prod Y) = Sup_prod {sd_prod x y |y. y \<in> Y}"
proof -
  assume a: "Y \<noteq> {}"
  have "sd_prod x (Sup_prod Y) = sd_prod x (\<Squnion>{fst y |y. y \<in> Y}, \<Squnion>{snd y |y. y \<in> Y})"
    by (simp add: Sup_prod_def)
  also have "... = ((fst x) \<cdot> (\<Squnion>{fst y |y. y \<in> Y}), (snd x \<squnion> (\<alpha> (fst x) (\<Squnion>{snd y |y. y \<in> Y}))))"
    by (simp add: sd_prod_def)
  also have "... = (\<Squnion>{fst x \<cdot> fst y |y. y \<in> Y}, (snd x \<squnion> (\<alpha> (fst x) (\<Squnion>{snd y |y. y \<in> Y}))))"
    by (simp add: Sup_distl)
  also have "... = (\<Squnion>{fst x \<cdot> fst y |y. y \<in> Y}, (snd x \<squnion> (\<Squnion>{\<alpha> (fst x) (snd y) |y. y \<in> Y})))"
    by (simp add: act4, meson)
  also have "... = (\<Squnion>{fst x \<cdot> fst y |y. y \<in> Y}, \<Squnion>{snd x \<squnion> (\<alpha> (fst x) (snd y)) |y. y \<in> Y})"
    using a sd_distl_aux by blast
  also have "... = Sup_prod {(fst x \<cdot> fst y, snd x \<squnion> (\<alpha> (fst x) (snd y))) |y. y \<in> Y}"
    by (simp add: Sup_prod_def, metis)
  finally show ?thesis
    by (simp add: sd_prod_def)
qed

definition "sd_unit = (1,\<bottom>)"

lemma sd_unitl [simp]: "sd_prod sd_unit x = x"
  by (simp add: sd_prod_def sd_unit_def)

lemma sd_unitr [simp]: "sd_prod x sd_unit = x"
  apply (simp add: sd_prod_def sd_unit_def)
  using act_emp by force

text \<open>The following counterexamples rule out that semidirect products of quantales and complete lattices form quantales.
The reason is that the right annihilation law fails.\<close>

lemma "sd_prod x (Sup_prod Y) = Sup_prod {sd_prod x y |y. y \<in> Y}" (*nitpick[show_all,expect=genuine]*)
  oops

lemma "sd_prod x bot_prod = bot_prod" (*nitpick[show_all,expect=genuine]*)
  oops

text \<open>However we can show that semidirect products of (unital) quantales with complete lattices form weak (unital) quantales. \<close>

interpretation dp_quantale: weak_quantale sd_prod Inf_prod Sup_prod inf_prod less_eq_prod less_prod sup_prod bot_prod top_prod
  apply standard
  apply (simp_all add: sd_distl sd_distr)
  apply (simp_all add: sd_prod_def Inf_prod_def Sup_prod_def bot_prod_def sup_prod_def top_prod_def inf_prod_def less_eq_prod_def less_prod_def)
  by (rule conjI, simp add: mult.assoc, simp add: act1 act_sup_distl sup_assoc)

interpretation dpu_quantale: unital_weak_quantale sd_unit sd_prod Inf_prod Sup_prod inf_prod less_eq_prod less_prod sup_prod bot_prod top_prod
  by (standard; simp_all)

end

end


subsection \<open>Guards Expressions\<close>
text\<open>
This theory defines the guard language of EFSMs which can be translated directly to and from
contexts. Boolean values true and false respectively represent the guards which are always and never
satisfied. Guards may test for (in)equivalence of two arithmetic expressions or be connected using
\textsc{nor} logic into compound expressions. The use of \textsc{nor} logic reduces the number of
subgoals when inducting over guard expressions.

We also define syntax hacks for the relations less than, less than or equal to, greater than or
equal to, and not equal to as well as the expression of logical conjunction, disjunction, and
negation in terms of nor logic.\<close>

theory GExp
imports AExp Trilean
begin

text_raw\<open>\snip{gexptype}{1}{2}{%\<close>
datatype 'a gexp = Bc bool | Eq "'a aexp" "'a aexp" | Gt "'a aexp" "'a aexp" | In 'a "value list" |  Nor "'a gexp" "'a gexp"
text_raw\<open>}%endsnip\<close>

fun gval :: "'a gexp \<Rightarrow> 'a datastate \<Rightarrow> trilean" where
  "gval (Bc True) _ = true" |
  "gval (Bc False) _ = false" |
  "gval (Gt a1 a2) s = value_gt (aval a1 s) (aval a2 s)" |
  "gval (Eq a1 a2) s = value_eq (aval a1 s) (aval a2 s)" |
  "gval (In v l) s = (case s v of None \<Rightarrow> invalid | Some vv \<Rightarrow> if vv \<in> set l then true else false)" |
  "gval (Nor a1 a2) s = \<not>? ((gval a1 s) \<or>? (gval a2 s))"

text_raw\<open>\snip{connectives}{1}{2}{%\<close>
definition gNot :: "'a gexp \<Rightarrow> 'a gexp"  where
  "gNot g \<equiv> Nor g g"

definition gOr :: "'a gexp \<Rightarrow> 'a gexp \<Rightarrow> 'a gexp" (*infix "\<or>" 60*) where
  "gOr v va \<equiv> Nor (Nor v va) (Nor v va)"

definition gAnd :: "'a gexp \<Rightarrow> 'a gexp \<Rightarrow> 'a gexp" (*infix "\<and>" 60*) where
  "gAnd v va \<equiv> Nor (Nor v v) (Nor va va)"

definition gImplies :: "'a gexp \<Rightarrow> 'a gexp \<Rightarrow> 'a gexp" where
  "gImplies p q \<equiv> gOr (gNot p) q"

definition Lt :: "'a aexp \<Rightarrow> 'a aexp \<Rightarrow> 'a gexp" (*infix "<" 60*) where
  "Lt a b \<equiv> Gt b a"

definition Le :: "'a aexp \<Rightarrow> 'a aexp \<Rightarrow> 'a gexp" (*infix "\<le>" 60*) where
  "Le v va \<equiv> gNot (Gt v va)"

definition Ge :: "'a aexp \<Rightarrow> 'a aexp \<Rightarrow> 'a gexp" (*infix "\<ge>" 60*) where
  "Ge v va \<equiv> gNot (Lt v va)"

definition Ne :: "'a aexp \<Rightarrow> 'a aexp \<Rightarrow> 'a gexp" (*infix "\<noteq>" 60*) where
  "Ne v va \<equiv> gNot (Eq v va)"
text_raw\<open>}%endsnip\<close>

lemma gval_Lt [simp]:
  "gval (Lt a1 a2) s = value_gt (aval a2 s) (aval a1 s)"
  by (simp add: Lt_def)

lemma gval_Le [simp]:
  "gval (Le a1 a2) s = \<not>? (value_gt (aval a1 s) (aval a2 s))"
  by (simp add: Le_def value_gt_def gNot_def maybe_or_idempotent)

lemma gval_Ge [simp]:
  "gval (Ge a1 a2) s = \<not>? (value_gt (aval a2 s) (aval a1 s))"
  by (simp add: Ge_def value_gt_def gNot_def maybe_or_idempotent)

lemma gval_Ne [simp]:
  "gval (Ne a1 a2) s = \<not>? (value_eq (aval a1 s) (aval a2 s))"
  by (simp add: Ne_def value_gt_def gNot_def maybe_or_idempotent)

lemmas connectives = gAnd_def gOr_def gNot_def Lt_def Le_def Ge_def Ne_def

lemma gval_gOr [simp]: "gval (gOr x y) r = (gval x r) \<or>? (gval y r)"
  by (simp add: maybe_double_negation maybe_or_idempotent gOr_def)

lemma gval_gNot [simp]: "gval (gNot x) s = \<not>? (gval x s)"
  by (simp add: maybe_or_idempotent gNot_def)

lemma gval_gAnd [simp]:
  "gval (gAnd g1 g2) s = (gval g1 s) \<and>? (gval g2 s)"
  by (simp add: de_morgans_1 maybe_double_negation maybe_or_idempotent gAnd_def)

lemma gAnd_commute: "gval (gAnd a b) s = gval (gAnd b a) s"
  by (simp add: times_trilean_commutative)

lemma gOr_commute: "gval (gOr a b) s = gval (gOr b a) s"
  by (simp add: plus_trilean_commutative gOr_def)

lemma gval_gAnd_True:
  "(gval (gAnd g1 g2) s = true) = ((gval g1 s = true) \<and> gval g2 s = true)"
  by (simp add: maybe_and_true)

lemma nor_equiv: "gval (gNot (gOr a b)) s = gval (Nor a b) s"
  by simp

definition satisfiable :: "vname gexp \<Rightarrow> bool" where
  "satisfiable g \<equiv> (\<exists>i r. gval g (join_ir i r) = true)"

definition "satisfiable_list l = satisfiable (fold gAnd l (Bc True))"

lemma unsatisfiable_false: "\<not> satisfiable (Bc False)"
  by (simp add: satisfiable_def)

lemma satisfiable_true: "satisfiable (Bc True)"
  by (simp add: satisfiable_def)

definition valid :: "vname gexp \<Rightarrow> bool" where
  "valid g \<equiv> (\<forall>s. gval g s = true)"

lemma valid_true: "valid (Bc True)"
  by (simp add: valid_def)

fun gexp_constrains :: "'a gexp \<Rightarrow> 'a aexp \<Rightarrow> bool" where
  "gexp_constrains (Bc _) _ = False" |
  "gexp_constrains (Eq a1 a2) a = (aexp_constrains a1 a \<or> aexp_constrains a2 a)" |
  "gexp_constrains (Gt a1 a2) a = (aexp_constrains a1 a \<or> aexp_constrains a2 a)" |
  "gexp_constrains (Nor g1 g2) a = (gexp_constrains g1 a \<or> gexp_constrains g2 a)" |
  "gexp_constrains (In v l) a = aexp_constrains (V v) a"

fun contains_bool :: "'a gexp \<Rightarrow> bool" where
  "contains_bool (Bc _) = True" |
  "contains_bool (Nor g1 g2) = (contains_bool g1 \<or> contains_bool g2)" |
  "contains_bool _ = False"

fun gexp_same_structure :: "'a gexp \<Rightarrow> 'a gexp \<Rightarrow> bool" where
  "gexp_same_structure (Bc b) (Bc b') = (b = b')" |
  "gexp_same_structure (Eq a1 a2) (Eq a1' a2') = (aexp_same_structure a1 a1' \<and> aexp_same_structure a2 a2')" |
  "gexp_same_structure (Gt a1 a2) (Gt a1' a2') = (aexp_same_structure a1 a1' \<and> aexp_same_structure a2 a2')" |
  "gexp_same_structure (Nor g1 g2) (Nor g1' g2') = (gexp_same_structure g1 g1' \<and> gexp_same_structure g2 g2')" |
  "gexp_same_structure (In v l) (In v' l') = (v = v' \<and> l = l')" |
  "gexp_same_structure _ _ = False"

lemma gval_foldr_true:
  "(gval (foldr gAnd G (Bc True)) s = true) = (\<forall>g \<in> set G. gval g s = true)"
proof(induct G)
  case (Cons a G)
  then show ?case
    apply (simp only: foldr.simps comp_def gval_gAnd maybe_and_true)
    by simp
qed auto

fun enumerate_gexp_inputs :: "vname gexp \<Rightarrow> nat set" where
  "enumerate_gexp_inputs (Bc _) = {}" |
  "enumerate_gexp_inputs (Eq v va) = enumerate_aexp_inputs v \<union> enumerate_aexp_inputs va" |
  "enumerate_gexp_inputs (Gt v va) = enumerate_aexp_inputs v \<union> enumerate_aexp_inputs va" |
  "enumerate_gexp_inputs (In v va) = enumerate_aexp_inputs (V v)" |
  "enumerate_gexp_inputs (Nor v va) = enumerate_gexp_inputs v \<union> enumerate_gexp_inputs va"

lemma enumerate_gexp_inputs_list: "\<exists>l. enumerate_gexp_inputs g = set l"
proof(induct g)
  case (Eq x1a x2)
  then show ?case
    by (metis enumerate_aexp_inputs_list enumerate_gexp_inputs.simps(2) set_append)
next
  case (Gt x1a x2)
  then show ?case
    by (metis enumerate_aexp_inputs_list enumerate_gexp_inputs.simps(3) set_append)
next
  case (In x1a x2)
  then show ?case
    by (simp add: enumerate_aexp_inputs_list)
next
  case (Nor g1 g2)
  then show ?case
    by (metis enumerate_gexp_inputs.simps(5) set_append)
qed auto

definition max_input :: "vname gexp \<Rightarrow> nat option" where
  "max_input g = (let inputs = enumerate_gexp_inputs g in if inputs = {} then None else Some (Max inputs))"

definition max_input_list :: "vname gexp list \<Rightarrow> nat option" where
  "max_input_list g = fold max (map max_input g) None"

fun enumerate_regs :: "vname gexp \<Rightarrow> nat set" where
  "enumerate_regs (Bc _) = {}" |
  "enumerate_regs (Eq v va) = AExp.enumerate_regs v \<union> AExp.enumerate_regs va" |
  "enumerate_regs (Gt v va) = AExp.enumerate_regs v \<union> AExp.enumerate_regs va" |
  "enumerate_regs (In v va) = AExp.enumerate_regs (V v)" |
  "enumerate_regs (Nor v va) = enumerate_regs v \<union> enumerate_regs va"

lemma finite_enumerate_regs: "finite (enumerate_regs g)"
  using AExp.finite_enumerate_regs by (induct g, auto)

definition max_reg :: "vname gexp \<Rightarrow> nat option" where
  "max_reg g = (let regs = (enumerate_regs g) in if regs = {} then None else Some (Max regs))"

lemma max_reg_gNot: "max_reg (gNot x) = max_reg x"
  by (simp add: max_reg_def gNot_def)

lemma max_reg_Eq: "max_reg (Eq a b) = max (AExp.max_reg a) (AExp.max_reg b)"
  apply (simp add: max_reg_def AExp.max_reg_def Let_def max_absorb2)
  by (metis AExp.finite_enumerate_regs Max.union bot_option_def max_bot2 sup_Some sup_max)

lemma max_reg_Gt: "max_reg (Gt a b) = max (AExp.max_reg a) (AExp.max_reg b)"
  apply (simp add: max_reg_def AExp.max_reg_def Let_def max_absorb2)
  by (metis AExp.finite_enumerate_regs Max.union bot_option_def max_bot2 sup_Some sup_max)

lemma max_reg_Nor: "max_reg (Nor a b) = max (max_reg a) (max_reg b)"
  apply (simp add: max_reg_def AExp.max_reg_def Let_def max_absorb2)
  by (metis GExp.finite_enumerate_regs Max.union bot_option_def max_bot2 sup_Some sup_max)

lemma gval_In_cons:
  "gval (In v (a # as)) s = (gval (Eq (V v) (L a)) s \<or>? gval (In v as) s)"
  by (cases "s v", auto)

lemma possible_to_be_in: "s \<noteq> [] \<Longrightarrow> satisfiable (In v s)"
proof-
  assume "s \<noteq> []"
  have aux: "\<exists>v' i r. join_ir i r v = Some v' \<and> v' \<in> set s \<Longrightarrow>
             \<exists>i r. (case join_ir i r v of None \<Rightarrow> false | Some v \<Rightarrow> if v \<in> set s then true else false) = true"
    by (metis (mono_tags, lifting) option.simps(5))
  show ?thesis
    apply (simp add: satisfiable_def gval_In_cons)
    apply (cases s)
     apply (simp add: \<open>s \<noteq> []\<close>)
    apply (cases v)
     apply (case_tac "\<exists>(i::value list). length i > x1 \<and> i ! x1 = a")
      apply clarsimp
    subgoal for _ _ i by (rule exI[of _ i], intro exI, simp)
     apply (metis gt_ex length_list_update length_repeat nth_list_update_eq)
    apply (rule_tac exI)
    apply (case_tac "\<exists>r. r $ x2 = Some a")
     apply clarsimp
    subgoal for _ _ _ r by (rule exI[of _ r], simp)
    by (metis join_ir_R join_ir_double_exists)
qed

definition max_reg_list :: "vname gexp list \<Rightarrow> nat option" where
  "max_reg_list g = fold max (map max_reg g) None"

lemma max_reg_list_cons:
  "max_reg_list (a # G) = max (max_reg a) (max_reg_list G)"
  apply (simp add: max_reg_list_def flip: Max.set_eq_fold)
  apply (metis List.finite_set Max_insert bot_option_def empty_not_insert finite_imageI finite_insert insert_commute max.commute max_bot2)
  done

lemma max_reg_list_append_singleton:
  "max_reg_list (as@[bs]) = max (max_reg_list as) (max_reg_list [bs])"
  apply (simp add: max_reg_list_def)
  by (metis max.commute sup_None_2 sup_max)

lemma max_reg_list_append:
  "max_reg_list (as@bs) = max (max_reg_list as) (max_reg_list bs)"
proof(induct bs rule: rev_induct)
  case Nil
  then show ?case
    by (metis append_Nil2 fold_simps(1) list.simps(8) max_reg_list_def sup_None_2 sup_max)
next
  case (snoc x xs)
  then show ?case
    by (metis append_assoc max.assoc max_reg_list_append_singleton)
qed

definition apply_guards :: "vname gexp list \<Rightarrow> vname datastate \<Rightarrow> bool" where
  "apply_guards G s = (\<forall>g \<in> set (map (\<lambda>g. gval g s) G). g = true)"

lemma apply_guards_singleton[simp]: "(apply_guards [g] s) = (gval g s = true)"
  by (simp add: apply_guards_def)

lemma apply_guards_empty [simp]: "apply_guards [] s"
  by (simp add: apply_guards_def)

lemma apply_guards_cons:
  "apply_guards (a # G) c = (gval a c = true \<and> apply_guards G c)"
  by (simp add: apply_guards_def)

lemma apply_guards_append:
  "apply_guards (a@a') s = (apply_guards a s \<and> apply_guards a' s)"
  using apply_guards_def by auto

lemma apply_guards_foldr:
  "apply_guards G s = (gval (foldr gAnd G (Bc True)) s = true)"
proof(induct G)
  case Nil
  then show ?case
    by (simp add: apply_guards_def)
next
  case (Cons a G)
  then show ?case
    by (metis apply_guards_cons foldr.simps(2) gval_gAnd_True o_apply)
qed

lemma rev_apply_guards: "apply_guards (rev G) s = apply_guards G s"
  by (simp add: apply_guards_def)

lemma apply_guards_fold:
  "apply_guards G s = (gval (fold gAnd G (Bc True)) s = true)"
  using rev_apply_guards[symmetric]
  by (simp add: foldr_conv_fold apply_guards_foldr)

lemma fold_apply_guards:
  "(gval (fold gAnd G (Bc True)) s = true) = apply_guards G s"
  by (simp add: apply_guards_fold)

lemma foldr_apply_guards:
  "(gval (foldr gAnd G (Bc True)) s = true) = apply_guards G s"
  by (simp add: apply_guards_foldr)

lemma apply_guards_subset:
  "set g' \<subseteq> set g \<Longrightarrow> apply_guards g c \<longrightarrow> apply_guards g' c"
proof(induct g)
  case (Cons a g)
  then show ?case
    using apply_guards_def by auto
qed auto

lemma apply_guards_subset_append:
  "set G \<subseteq> set G' \<Longrightarrow> apply_guards (G @ G') s = apply_guards (G') s"
  using apply_guards_append apply_guards_subset by blast

lemma apply_guards_rearrange:
  "x \<in> set G \<Longrightarrow> apply_guards G s = apply_guards (x#G) s"
  using apply_guards_def by auto

lemma apply_guards_condense: "\<exists>g. apply_guards G s = (gval g s = true)"
    using apply_guards_fold by blast

lemma apply_guards_false_condense: "\<exists>g. (\<not>apply_guards G s) = (gval g s = false)"
  using foldr_apply_guards gval.simps(2) not_true by blast

lemma max_input_Bc: "max_input (Bc x) = None"
  by (simp add: max_input_def)

lemma max_input_Eq:
  "max_input (Eq a1 a2) = max (AExp.max_input a1) (AExp.max_input a2)"
  apply (simp add: AExp.max_input_def max_input_def Let_def max_absorb2)
  by (metis List.finite_set Max.union bot_option_def enumerate_aexp_inputs_not_empty max_bot2 sup_Some sup_max)

lemma max_input_Gt:
  "max_input (Gt a1 a2) = max (AExp.max_input a1) (AExp.max_input a2)"
  apply (simp add: AExp.max_input_def max_input_def Let_def max_absorb2)
  by (metis List.finite_set Max.union bot_option_def enumerate_aexp_inputs_not_empty max_bot2 sup_Some sup_max)

lemma gexp_max_input_Nor:
  "max_input (Nor g1 g2) = max (max_input g1) (max_input g2)"
  apply (simp add: AExp.max_input_def max_input_def Let_def max_absorb2)
  by (metis List.finite_set Max.union enumerate_gexp_inputs_list less_eq_option_Some_None max_def sup_Some sup_max)

lemma gexp_max_input_In: "max_input (In v l) = AExp.max_input (V v)"
  by (simp add: AExp.max_input_def GExp.max_input_def)

lemma gval_foldr_gOr_invalid:
  "(gval (fold gOr l g) s = invalid) = (\<exists>g' \<in> (set (g#l)). gval g' s = invalid)"
proof(induct l rule: rev_induct)
  case (snoc x xs)
  then show ?case
    by (simp, metis gval_gOr maybe_or_invalid)
qed auto

lemma gval_foldr_gOr_true:
  "(gval (fold gOr l g) s = true) = ((\<exists>g' \<in> (set (g#l)). gval g' s = true) \<and> (\<forall>g' \<in> (set (g#l)). gval g' s \<noteq> invalid))"
proof(induct l rule: rev_induct)
  case (snoc x xs)
  then show ?case
    apply (simp add: maybe_or_true)
    using gval_foldr_gOr_invalid by auto
qed auto

lemma gval_foldr_gOr_false:
  "(gval (fold gOr l g) s = false) = (\<forall>g' \<in> (set (g#l)). gval g' s = false)"
proof(induct l rule: rev_induct)
  case (snoc x xs)
  then show ?case
    by (auto simp add: maybe_or_false)
qed auto

lemma gval_fold_gOr_rev: "gval (fold gOr (rev l) g) s = gval (fold gOr l g) s"
  apply (cases "gval (fold gOr l g) s")
    apply (simp, simp add: gval_foldr_gOr_true)
   apply (simp, simp add: gval_foldr_gOr_false)
  by (simp, simp add: gval_foldr_gOr_invalid)

lemma gval_fold_gOr_foldr: "gval (fold gOr l g) s = gval (foldr gOr l g) s"
  by (simp add: foldr_conv_fold gval_fold_gOr_rev)

lemma gval_fold_gOr:
  "gval (fold gOr (a # l) g) s = (gval a s \<or>? gval (fold gOr l g) s)"
  by (simp only: gval_fold_gOr_foldr foldr.simps comp_def gval_gOr)

lemma gval_In_fold:
  "gval (In v l) s = (if s v = None then invalid else gval (fold gOr (map (\<lambda>x. Eq (V v) (L x)) l) (Bc False)) s)"
proof(induct l)
  case Nil
  then show ?case
    apply simp
    apply (cases "s v")
     apply simp
    by auto
next
  case (Cons a l)
  then show ?case
    apply (simp only: gval_In_cons)
    apply (cases "s v")
     apply simp
    by (simp add: gval_fold_gOr del: fold.simps)
qed

fun fold_In :: "'a \<Rightarrow> value list \<Rightarrow> 'a gexp" where
  "fold_In _ [] = Bc False" |
  "fold_In v (l#t) = gOr (Eq (V v) (L l)) (fold_In v t)"

lemma gval_fold_In: "l \<noteq> [] \<Longrightarrow> gval (In v l) s = gval (fold_In v l) s"
proof(induct l)
next
  case (Cons a l)
  then show ?case
    apply (case_tac "s v")
     apply simp
    apply simp
    apply safe
       apply simp
       apply (metis fold_In.simps(1) gval.simps(2) plus_trilean.simps(4) plus_trilean.simps(5))
      apply fastforce
     apply fastforce
    by fastforce
qed auto

lemma fold_maybe_or_invalid_base: "fold (\<or>?) l invalid = invalid"
proof(induct l)
  case (Cons a l)
  then show ?case
    by (metis fold_simps(2) maybe_or_valid)
qed auto

lemma fold_maybe_or_true_base_never_false:
  "fold (\<or>?) l true \<noteq> false"
proof(induct l)
  case (Cons a l)
  then show ?case
    by (metis fold_maybe_or_invalid_base fold_simps(2) maybe_not.cases maybe_or_valid plus_trilean.simps(4) plus_trilean.simps(6))
qed auto

lemma fold_true_fold_false_not_invalid:
  "fold (\<or>?) l true = true \<Longrightarrow>
   fold (\<or>?) (rev l) false \<noteq> invalid"
proof(induct l)
  case (Cons a l)
  then show ?case
    apply simp
    by (metis fold_maybe_or_invalid_base maybe_or_invalid maybe_or_true)
qed auto

lemma fold_true_invalid_fold_rev_false_invalid:
  "fold (\<or>?) l true = invalid \<Longrightarrow>
   fold (\<or>?) (rev l) false = invalid"
proof(induct l)
  case (Cons a l)
  then show ?case
    apply simp
    by (metis maybe_or_true maybe_or_valid)
qed auto

lemma fold_maybe_or_rev:
  "fold (\<or>?) l b = fold (\<or>?) (rev l) b"
proof(induct l)
  case (Cons a l)
  then show ?case
  proof(induction a b rule: plus_trilean.induct)
    case (1 uu)
    then show ?case
      by (simp add: fold_maybe_or_invalid_base)
  next
    case "2_1"
    then show ?case
      by (simp add: fold_maybe_or_invalid_base)
  next
    case "2_2"
    then show ?case
      by (simp add: fold_maybe_or_invalid_base)
  next
    case "3_1"
    then show ?case
      apply simp
      by (metis add.assoc fold_maybe_or_true_base_never_false maybe_not.cases maybe_or_idempotent maybe_or_true)
  next
    case "3_2"
    then show ?case
      apply simp
      apply (case_tac "fold (\<or>?) l true")
        apply (simp add: eq_commute[of true])
        apply (case_tac "fold (\<or>?) (rev l) false")
          apply simp
         apply simp
        apply (simp add: fold_true_fold_false_not_invalid)
       apply (simp add: fold_maybe_or_true_base_never_false)
      by (simp add: fold_true_invalid_fold_rev_false_invalid)
  next
    case 4
    then show ?case
      by (simp add: maybe_or_zero)
  next
    case 5
    then show ?case
      by (simp add: maybe_or_zero)
  qed
qed auto

lemma fold_maybe_or_cons:
  "fold (\<or>?) (a#l) b = a \<or>? (fold (\<or>?) l b)"
  by (metis fold_maybe_or_rev foldr.simps(2) foldr_conv_fold o_apply)

lemma gval_fold_gOr_map:
  "gval (fold gOr l (Bc False)) s = fold (\<or>?) (map (\<lambda>g. gval g s) l) (false)"
proof(induct l)
  case (Cons a l)
  then show ?case
    by (metis fold_maybe_or_cons gval_fold_gOr list.simps(9))
qed auto

lemma gval_unfold_first:
  "gval (fold gOr (map (\<lambda>x. Eq (V v) (L x)) ls) (Eq (V v) (L l))) s =
       gval (fold gOr (map (\<lambda>x. Eq (V v) (L x)) (l#ls)) (Bc False)) s"
proof(induct ls)
  case Nil
  then show ?case
    apply (cases "s v")
     apply simp
    by (simp add: gOr_def)
next
  case (Cons a ls)
  then show ?case
  proof -
    have "gval (fold gOr (map (\<lambda>va. Eq (V v) (L va)) ls) (gOr (Eq (V v) (L l)) (Bc False))) s = gval (fold gOr (map (\<lambda>va. Eq (V v) (L va)) (l # ls)) (Bc False)) s"
      by simp
    then have "gval (fold gOr (map (\<lambda>va. Eq (V v) (L va)) (a # ls)) (Eq (V v) (L l))) s = gval (fold gOr (Eq (V v) (L a) # map (\<lambda>va. Eq (V v) (L va)) ls) (gOr (Eq (V v) (L l)) (Bc False))) s"
      by (metis (no_types) Cons.hyps gval_fold_gOr list.simps(9))
    then show ?thesis
      by force
  qed
qed

lemma fold_Eq_true:
  "\<forall>v. fold (\<or>?) (map (\<lambda>x. if v = x then true else false) vs) true = true"
  by(induct vs, auto)

lemma x_not_in_set_fold_eq:
  "s v \<notin> Some ` set ll \<Longrightarrow>
   false = fold (\<or>?) (map (\<lambda>x. if s v = Some x then true else false) ll) false"
  by(induct ll, auto)

lemma gval_take: "max_input g < Some a \<Longrightarrow>
   gval g (join_ir i r) = gval g (join_ir (take a i) r)"
proof(induct g)
case (Bc x)
  then show ?case
    by (metis (full_types) gval.simps(1) gval.simps(2))
next
  case (Eq x1a x2)
  then show ?case
    by (metis aval_take gval.simps(4) max_input_Eq max_less_iff_conj)
next
  case (Gt x1a x2)
  then show ?case
    by (metis aval_take gval.simps(3) max_input_Gt max_less_iff_conj)
next
  case (Nor g1 g2)
  then show ?case
    by (simp add: maybe_not_eq gexp_max_input_Nor)
next
  case (In v l)
  then show ?case
    apply (simp add: gexp_max_input_In)
    using aval_take by fastforce
qed

lemma gval_fold_gAnd_append_singleton:
  "gval (fold gAnd (a @ [G]) (Bc True)) s = gval (fold gAnd a (Bc True)) s \<and>? gval G s"
  apply simp
  using times_trilean_commutative by blast

lemma gval_fold_rev_true:
  "gval (fold gAnd (rev G) (Bc True)) s = true \<Longrightarrow>
   gval (fold gAnd G (Bc True)) s = true"
  by (metis foldr_conv_fold gval_foldr_true rev_rev_ident set_rev)

lemma gval_fold_not_invalid_all_valid_contra:
  "\<exists>g \<in> set G. gval g s = invalid \<Longrightarrow>
   gval (fold gAnd G (Bc True)) s = invalid"
proof(induct G rule: rev_induct)
  case (snoc a G)
  then show ?case
    apply (simp only: gval_fold_gAnd_append_singleton)
    apply simp
    using maybe_and_valid by blast
qed auto

lemma gval_fold_not_invalid_all_valid:
  "gval (fold gAnd G (Bc True)) s \<noteq> invalid \<Longrightarrow>
   \<forall>g \<in> set G. gval g s \<noteq> invalid"
  using gval_fold_not_invalid_all_valid_contra by blast

lemma all_gval_not_false:
  "(\<forall>g \<in> set G. gval g s \<noteq> false) = (\<forall>g \<in> set G. gval g s = true) \<or> (\<exists>g \<in> set G. gval g s = invalid)"
  using trilean.exhaust by auto

lemma must_have_one_false_contra:
  "\<forall>g \<in> set G. gval g s \<noteq> false \<Longrightarrow>
   gval (fold gAnd G (Bc True)) s \<noteq> false"
  using all_gval_not_false[of G s]
  apply simp
  apply (case_tac "(\<forall>g\<in>set G. gval g s = true)")
  apply (metis (full_types) foldr_conv_fold gval_fold_rev_true gval_foldr_true not_true)
  by (simp add: gval_fold_not_invalid_all_valid_contra)

lemma must_have_one_false:
  "gval (fold gAnd G (Bc True)) s = false \<Longrightarrow>
   \<exists>g \<in> set G. gval g s = false"
  using must_have_one_false_contra by blast

lemma all_valid_fold:
  "\<forall>g \<in> set G. gval g s \<noteq> invalid \<Longrightarrow>
   gval (fold gAnd G (Bc True)) s \<noteq> invalid"
  apply (induct G rule: rev_induct)
   apply simp
  by (simp add: maybe_and_invalid)

lemma one_false_all_valid_false:
  "\<exists>g\<in>set G. gval g s = false \<Longrightarrow>
   \<forall>g\<in>set G. gval g s \<noteq> invalid \<Longrightarrow>
   gval (fold gAnd G (Bc True)) s = false"
  by (metis (full_types) all_valid_fold foldr_conv_fold gval_foldr_true not_true rev_rev_ident set_rev)

lemma gval_fold_rev_false:
  "gval (fold gAnd (rev G) (Bc True)) s = false \<Longrightarrow>
   gval (fold gAnd G (Bc True)) s = false"
  using must_have_one_false[of "rev G" s]
        gval_fold_not_invalid_all_valid[of "rev G" s]
  by (simp add: one_false_all_valid_false)

lemma fold_invalid_means_one_invalid:
  "gval (fold gAnd G (Bc True)) s = invalid \<Longrightarrow>
   \<exists>g \<in> set G. gval g s = invalid"
  using all_valid_fold by blast

lemma gval_fold_rev_invalid:
  "gval (fold gAnd (rev G) (Bc True)) s = invalid \<Longrightarrow>
   gval (fold gAnd G (Bc True)) s = invalid"
  using fold_invalid_means_one_invalid[of "rev G" s]
  by (simp add: gval_fold_not_invalid_all_valid_contra)

lemma gval_fold_rev_equiv_fold:
  "gval (fold gAnd (rev G) (Bc True)) s =  gval (fold gAnd G (Bc True)) s"
  apply (cases "gval (fold gAnd (rev G) (Bc True)) s")
    apply (simp add: gval_fold_rev_true)
   apply (simp add: gval_fold_rev_false)
  by (simp add: gval_fold_rev_invalid)

lemma gval_fold_equiv_fold_rev:
  "gval (fold gAnd G (Bc True)) s = gval (fold gAnd (rev G) (Bc True)) s"
  by (simp add: gval_fold_rev_equiv_fold)

lemma gval_fold_equiv_gval_foldr:
  "gval (fold gAnd G (Bc True)) s = gval (foldr gAnd G (Bc True)) s"
proof -
  have "gval (fold gAnd G (Bc True)) s = gval (fold gAnd (rev G) (Bc True)) s"
    using gval_fold_equiv_fold_rev by force
  then show ?thesis
  by (simp add: foldr_conv_fold)
qed

lemma gval_foldr_equiv_gval_fold:
  "gval (foldr gAnd G (Bc True)) s = gval (fold gAnd G (Bc True)) s"
  by (simp add: gval_fold_equiv_gval_foldr)

lemma gval_fold_cons:
  "gval (fold gAnd (g # gs) (Bc True)) s = gval g s \<and>? gval (fold gAnd gs (Bc True)) s"
  apply (simp only: apply_guards_fold gval_fold_equiv_gval_foldr)
  by (simp only: foldr.simps comp_def gval_gAnd)

lemma gval_fold_take: "max_input_list G < Some a \<Longrightarrow>
   a \<le> length i \<Longrightarrow>
   max_input_list G \<le> Some (length i) \<Longrightarrow>
   gval (fold gAnd G (Bc True)) (join_ir i r) = gval (fold gAnd G (Bc True)) (join_ir (take a i) r)"
proof(induct G)
  case (Cons g gs)
  then show ?case
    apply (simp only: gval_fold_cons)
    apply (simp add: max_input_list_cons)
    using gval_take[of g a i r]
    by simp
qed auto

primrec padding :: "nat \<Rightarrow> 'a list" where
  "padding 0 = []" |
  "padding (Suc m) = (Eps (\<lambda>x. True))#(padding m)"

definition take_or_pad :: "'a list \<Rightarrow> nat \<Rightarrow> 'a list" where
  "take_or_pad a n = (if length a \<ge> n then take n a else a@(padding (n-length a)))"

lemma length_padding: "length (padding n) = n"
  by (induct n, auto)

lemma length_take_or_pad: "length (take_or_pad a n) = n"
  by (induction n) (simp_all add: take_or_pad_def length_padding)

fun enumerate_gexp_strings :: "'a gexp \<Rightarrow> String.literal set" where
  "enumerate_gexp_strings (Bc _) = {}" |
  "enumerate_gexp_strings (Eq a1 a2) = enumerate_aexp_strings a1 \<union> enumerate_aexp_strings a2" |
  "enumerate_gexp_strings (Gt a1 a2) = enumerate_aexp_strings a1 \<union> enumerate_aexp_strings a2" |
  "enumerate_gexp_strings (In v l) = fold (\<lambda>x acc. case x of Num n \<Rightarrow> acc | Str s \<Rightarrow> insert s acc) l {}" |
  "enumerate_gexp_strings (Nor g1 g2) = enumerate_gexp_strings g1 \<union> enumerate_gexp_strings g2"

fun enumerate_gexp_ints :: "'a gexp \<Rightarrow> int set" where
  "enumerate_gexp_ints (Bc _) = {}" |
  "enumerate_gexp_ints (Eq a1 a2) = enumerate_aexp_ints a1 \<union> enumerate_aexp_ints a2" |
  "enumerate_gexp_ints (Gt a1 a2) = enumerate_aexp_ints a1 \<union> enumerate_aexp_ints a2" |
  "enumerate_gexp_ints (In v l) = fold (\<lambda>x acc. case x of Str s \<Rightarrow> acc | Num n \<Rightarrow> insert n acc) l {}" |
  "enumerate_gexp_ints (Nor g1 g2) = enumerate_gexp_ints g1 \<union> enumerate_gexp_ints g2"

definition restricted_once :: "'a \<Rightarrow> 'a gexp list \<Rightarrow> bool" where
  "restricted_once v G = (length (filter (\<lambda>g. gexp_constrains g (V v)) G) = 1)"

definition not_restricted :: "'a \<Rightarrow> 'a gexp list \<Rightarrow> bool" where
  "not_restricted v G = (length (filter (\<lambda>g. gexp_constrains g (V v)) G) = 0)"

lemma restricted_once_cons:
  "restricted_once v (g#gs) = ((gexp_constrains g (V v) \<and> not_restricted v gs) \<or> ((\<not> gexp_constrains g (V v)) \<and> restricted_once v gs))"
  by (simp add: restricted_once_def not_restricted_def)

lemma not_restricted_cons:
  "not_restricted v (g#gs) = ((\<not> gexp_constrains g (V v)) \<and> not_restricted v gs)"
  by (simp add: not_restricted_def)

definition enumerate_vars :: "vname gexp \<Rightarrow> vname list" where
  "enumerate_vars g = sorted_list_of_set ((image R (enumerate_regs g)) \<union> (image I (enumerate_gexp_inputs g)))"

fun rename_regs :: "(nat \<Rightarrow> nat) \<Rightarrow> vname gexp \<Rightarrow> vname gexp" where
  "rename_regs _ (Bc b) = Bc b" |
  "rename_regs f (Eq a1 a2) = Eq (AExp.rename_regs f a1) (AExp.rename_regs f a2)" |
  "rename_regs f (Gt a1 a2) = Gt (AExp.rename_regs f a1) (AExp.rename_regs f a2)" |
  "rename_regs f (In (R r) vs) = In (R (f r)) vs" |
  "rename_regs f (In v vs) = In v vs" |
  "rename_regs f (Nor g1 g2) = Nor (rename_regs f g1) (rename_regs f g2)"

definition eq_upto_rename :: "vname gexp \<Rightarrow> vname gexp \<Rightarrow> bool" where
  "eq_upto_rename g1 g2 = (\<exists>f. bij f \<and> rename_regs f g1 = g2)"

lemma gval_reg_some_superset:
"\<forall>a. (r $ a  \<noteq> None) \<longrightarrow> r $ a = r' $ a \<Longrightarrow>
  x \<noteq> invalid \<Longrightarrow>
 gval a (join_ir i r) = x \<Longrightarrow>
 gval a (join_ir i r') = x"
proof(induct a arbitrary: x)
case (Bc b)
  then show ?case by (cases b, auto)
next
  case (Eq x1a x2)
  then show ?case
    apply (cases x)
      apply simp
    using value_eq_true[of "aval x1a (join_ir i r)" "aval x2 (join_ir i r)"]
      apply clarsimp
      apply (simp add: aval_reg_some_superset)
     apply simp
    using value_eq_false[of "aval x1a (join_ir i r)" "aval x2 (join_ir i r)"]
     apply clarsimp
     apply (simp add: aval_reg_some_superset)
    by simp
next
  case (Gt x1a x2)
  then show ?case
    apply (cases x)
      apply simp
    using value_gt_true_Some[of "aval x1a (join_ir i r)" "aval x2 (join_ir i r)"]
      apply clarsimp
      apply (simp add: aval_reg_some_superset)
     apply simp
    using value_gt_false_Some[of "aval x1a (join_ir i r)" "aval x2 (join_ir i r)"]
     apply clarsimp
     apply (simp add: aval_reg_some_superset)
    by simp
next
  case (In x1a x2)
  then show ?case
    apply simp
    apply (case_tac "join_ir i r x1a")
     apply simp
    apply (case_tac "join_ir i r' x1a")
     apply simp
     apply (metis aval_reg_some_superset In.prems(1) aval.simps(2) option.distinct(1))
    apply simp
    by (metis (full_types) aval_reg_some_superset In.prems(1) aval.simps(2) option.inject)
next
  case (Nor a1 a2)
  then show ?case
    apply simp
    apply (cases x)
      apply (simp add: maybe_negate_true maybe_or_false)
     apply (simp add: maybe_negate_false maybe_or_true)
     apply presburger
    by simp
qed

lemma apply_guards_reg_some_superset:
  "\<forall>a. (r $ a  \<noteq> None) \<longrightarrow> r $ a = r' $ a \<Longrightarrow>
   apply_guards G (join_ir i r) \<Longrightarrow>
   apply_guards G (join_ir i r')"
  apply (induct G)
   apply simp
  apply (simp add: apply_guards_cons)
  using gval_reg_some_superset
  by simp

end


(*
  STLC with Locally Nameless Representation
  Based on the lecture notes by Jeremy Siek's 522 class at Indiana University
*)

theory STLC
imports Main
begin

datatype const = IntC int | BoolC bool | PairC const const
datatype primitive = Inc | Dec | Neg | IsZero | Not
datatype prim_result = Result const | PError

fun eval_prim :: "primitive \<Rightarrow> const \<Rightarrow> prim_result" where
    "eval_prim Inc (IntC n) = Result (IntC (n + 1))"
  | "eval_prim Dec (IntC n) = Result (IntC (n - 1))"
  | "eval_prim Neg (IntC n) = Result (IntC (-n))"
  | "eval_prim IsZero (IntC n) = Result (BoolC (n=0))"
  | "eval_prim Not (BoolC b) = Result (BoolC (\<not> b))"
  | "eval_prim _ _ = PError"

type_synonym var = nat

datatype exp =
    Const const
  | Prim primitive exp
  | IfE exp exp exp
  | FVar var
  | BVar nat
  | LambdaE exp
  | AppE exp exp
  | Cons exp exp
  | Car exp
  | Cdr exp

abbreviation list_max :: "nat list \<Rightarrow> nat" where
  "list_max ls \<equiv> foldr max ls (0::nat)"

lemma list_max_fresh: fixes n::nat assumes g: "list_max ls < n" shows "n \<notin> set ls"
using g by (induction ls arbitrary: n) auto

primrec FV :: "exp \<Rightarrow> var list" where
    "FV (Const c) = []"
  | "FV (Prim p e) = FV e"
  | "FV (IfE e1 e2 e3) = (FV e1 @ FV e2 @ FV e3)"
  | "FV (FVar y) = [y]"
  | "FV (BVar k) = []"
  | "FV (LambdaE e) = FV e"
  | "FV (AppE e1 e2) = (FV e1 @ FV e2)"
  | "FV (Cons e1 e2) = (FV e1 @ FV e2)"
  | "FV (Car e) = FV e"
  | "FV (Cdr e) = FV e"

abbreviation mklet :: "exp \<Rightarrow> exp \<Rightarrow> exp" where
  "mklet e1 e2 \<equiv> AppE (LambdaE e2) e1"

primrec bsubst :: "nat \<Rightarrow> exp \<Rightarrow> exp \<Rightarrow> exp" ("{_\<rightarrow>_}_" [54,54,54] 53) where
    "{j\<rightarrow>e} (Const c) = Const c"
  | "{j\<rightarrow>e} (Prim p e') = Prim p ({j\<rightarrow>e} e')"
  | "{j\<rightarrow>e} (IfE e1 e2 e3) = IfE ({j\<rightarrow>e} e1) ({j\<rightarrow>e} e2) ({j\<rightarrow>e} e3)"
  | "{j\<rightarrow>e} (FVar x) = FVar x"
  | "{j\<rightarrow>e} (BVar k) = (if k = j then e else BVar k)"
  | "{j\<rightarrow>e} (LambdaE e') = LambdaE ({(Suc j)\<rightarrow>e} e')"
  | "{j\<rightarrow>e} (AppE e1 e2) = AppE ({j\<rightarrow>e} e1) ({j\<rightarrow>e} e2)"
  | "{j\<rightarrow>e} (Cons e1 e2) = Cons ({j\<rightarrow>e} e1) ({j\<rightarrow>e} e2)"
  | "{j\<rightarrow>e} (Car e1) = Car ({j\<rightarrow>e} e1)"
  | "{j\<rightarrow>e} (Cdr e1) = Cdr ({j\<rightarrow>e} e1)"

primrec subst :: "var \<Rightarrow> exp \<Rightarrow> exp \<Rightarrow> exp" ("[_\<mapsto>_] _" [72,72,72] 71) where
    "[x\<mapsto>v] (Const c) = (Const c)"
  | "[x\<mapsto>v] (Prim p e1) = Prim p ([x\<mapsto>v]e1)"
  | "[x\<mapsto>v] (IfE e1 e2 e3) = IfE ([x\<mapsto>v]e1) ([x\<mapsto>v]e2) ([x\<mapsto>v]e3)"
  | "[x\<mapsto>v] (FVar y) = (if x = y then v else (FVar y))"
  | "[x\<mapsto>v] (BVar k) = BVar k"
  | "[x\<mapsto>v] (LambdaE e) = LambdaE ([x\<mapsto>v]e)"
  | "[x\<mapsto>v] (AppE e1 e2) = AppE ([x\<mapsto>v]e1) ([x\<mapsto>v]e2)"
  | "[x\<mapsto>v] (Cons e1 e2) = Cons ([x\<mapsto>v]e1) ([x\<mapsto>v]e2)"
  | "[x\<mapsto>v] (Car e) = Car ([x\<mapsto>v]e)"
  | "[x\<mapsto>v] (Cdr e) = Cdr ([x\<mapsto>v]e)"

lemma subst_id: fixes e::exp
assumes xfv: "x \<notin> set (FV e)" shows "[x\<mapsto>v]e = e"
using xfv by (induction e, auto)

type_synonym env = "(var \<times> exp) list"

fun msubst :: "env \<Rightarrow> exp \<Rightarrow> exp" ("[_] _" [72,72] 71) where
  "msubst [] e = e" |
  "msubst ((x,v)#\<rho>) e = msubst \<rho> ([x\<mapsto>v]e)"

abbreviation assoc_dom :: "('a \<times> 'b) list \<Rightarrow> 'a set" where
 "assoc_dom \<Gamma> \<equiv> set (map fst \<Gamma>)"

lemma msubst_id: fixes e::exp assumes rfv: "assoc_dom \<rho> \<inter> set (FV e) = {}"
  shows "[\<rho>]e = e"
using rfv apply (induction \<rho> arbitrary: e) apply simp using subst_id by auto

datatype result = Res exp | Error | TimeOut

fun interp :: "exp \<Rightarrow> nat \<Rightarrow> result" where
    Const: "interp (Const c) (Suc n) = Res (Const c)"
  | Prim: "interp (Prim p e) (Suc n) =
       (case interp e n of
           Res (Const c) \<Rightarrow> (case eval_prim p c of
                              Result c' \<Rightarrow> Res (Const c')
                            | PError \<Rightarrow> Error)
       | Error \<Rightarrow> Error | TimeOut \<Rightarrow> TimeOut)"
  | IfE: "interp (IfE e1 e2 e3) (Suc n) =
          (case interp e1 n of
            Res (Const (BoolC True)) \<Rightarrow> interp e2 n
          | Res (Const (BoolC False)) \<Rightarrow> interp e3 n
          | _ \<Rightarrow> Error)"
  | FVar: "interp (FVar x) (Suc n) = Error"
  | BVar: "interp (BVar k) (Suc n) = Error"
  | LambdaE: "interp (LambdaE e) (Suc n) = Res (LambdaE e)"
  | AppE: "interp (AppE e1 e2) (Suc n) =
        (case (interp e1 n, interp e2 n) of
          (Res (LambdaE e), Res v) \<Rightarrow> interp (bsubst 0 v e) n
        | (TimeOut, _) \<Rightarrow> TimeOut | (_, TimeOut) \<Rightarrow> TimeOut | (_,_) \<Rightarrow> Error)"
  | Cons: "interp (Cons e1 e2) (Suc n) =
        (case (interp e1 n, interp e2 n) of
          (Res (Const c1), Res (Const c2)) \<Rightarrow> Res (Const (PairC c1 c2))
        | (TimeOut, _) \<Rightarrow> TimeOut | (_, TimeOut) \<Rightarrow> TimeOut | (_,_) \<Rightarrow> Error)"
  | Car: "interp (Car e) (Suc n) =
        (case interp e n of
          Res (Const (PairC c1 c2)) \<Rightarrow> Res (Const c1)
        | _ \<Rightarrow> Error)"
  | Cdr: "interp (Cdr e) (Suc n) =
        (case interp e n of
          Res (Const (PairC c1 c2)) \<Rightarrow> Res (Const c2)
        | _ \<Rightarrow> Error)"
  | Else: "interp _ 0 = TimeOut"

lemma inv_interp_if:
  "\<lbrakk> interp (IfE e1 e2 e3) n' = Res v;
     \<And> n b. \<lbrakk> n' = Suc n; interp e1 n = Res (Const (BoolC b));
              b \<longrightarrow> interp e2 n = Res v; \<not> b \<longrightarrow> interp e3 n = Res v
    \<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  apply (case_tac n') apply force
  apply (case_tac "interp e1 nat", auto)
  apply (case_tac x1, auto) apply (case_tac x1a, force+)
done

lemma inv_interp_app:
  "\<lbrakk> interp (AppE e1 e2) n' = Res v;
     \<And> n e v2. \<lbrakk> n' = Suc n; interp e1 n = Res (LambdaE e);
                 interp e2 n = Res v2; interp (bsubst 0 v2 e) n = Res v
    \<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  apply (case_tac n') apply force apply (case_tac "interp e1 nat", auto)
  apply (case_tac x1, auto) apply (case_tac "interp e2 nat", auto)+
done

lemma inv_interp_cons:
  "\<lbrakk> interp (Cons e1 e2) n' = Res v;
     \<And> n c1 c2. \<lbrakk> n' = Suc n; interp e1 n = Res (Const c1);
                  interp e2 n = Res (Const c2); Res (Const (PairC c1 c2)) = Res v
    \<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  apply (case_tac n') apply force apply (case_tac "interp e1 nat", auto)
  apply (case_tac x1, auto)
  apply (case_tac "interp e2 nat", auto)
  apply (case_tac x1, auto)
  apply (case_tac "interp e2 nat", auto)+
done

lemma interp_mono: assumes ie: "interp e n = Res v'" and nn: "n \<le> n'"
  shows "interp e n' = Res v'"
  using ie nn
  apply (induction e n arbitrary: v' n' rule: interp.induct)
  apply (case_tac n') apply simp apply force
  apply (case_tac n') apply force apply (case_tac "interp e n") apply force apply force
      apply force
  apply (erule inv_interp_if) apply (case_tac n') apply force
    apply (case_tac b) apply force apply force
  apply simp
  apply simp
  apply (case_tac n') apply simp apply force
  apply (erule inv_interp_app) apply (case_tac n') apply force apply force
  defer apply (case_tac n') apply force apply (case_tac "interp e n")
  apply force apply force apply force
  defer apply (case_tac n') apply force apply (case_tac "interp e n")
  apply force apply force apply force
  defer apply (case_tac n') apply force apply (case_tac "interp e n")
  apply force apply force apply force
  apply (erule inv_interp_cons) apply (case_tac n') apply force apply force
done

primrec close :: "nat \<Rightarrow> var \<Rightarrow> exp \<Rightarrow> exp" ("{_\<leftarrow>_}_" [54,54,54] 53) where
    "{j\<leftarrow>x} (Const c) = Const c"
  | "{j\<leftarrow>x} (Prim p e') = Prim p ({j\<leftarrow>x} e')"
  | "{j\<leftarrow>x} (IfE e1 e2 e3) = IfE ({j\<leftarrow>x} e1) ({j\<leftarrow>x} e2) ({j\<leftarrow>x} e3)"
  | "{j\<leftarrow>x} (FVar y) = (if x = y then BVar j else FVar y)"
  | "{j\<leftarrow>x} (BVar k) = BVar k"
  | "{j\<leftarrow>x} (LambdaE e') = LambdaE ({(Suc j)\<leftarrow>x} e')"
  | "{j\<leftarrow>x} (AppE e1 e2) = AppE ({j\<leftarrow>x} e1) ({j\<leftarrow>x} e2)"
  | "{j\<leftarrow>x} (Cons e1 e2) = Cons ({j\<leftarrow>x} e1) ({j\<leftarrow>x} e2)"
  | "{j\<leftarrow>x} (Car e) = Car ({j\<leftarrow>x} e)"
  | "{j\<leftarrow>x} (Cdr e) = Cdr ({j\<leftarrow>x} e)"

inductive reduce_fb :: "exp \<Rightarrow> exp \<Rightarrow> bool" (infix "\<longmapsto>fb" 70) where
    full_beta[intro!]: "AppE (LambdaE e) e' \<longmapsto>fb ({0\<rightarrow>e'}e)"
  | c_lambda[intro!]: "\<lbrakk> x \<notin> set (FV e); ({0\<rightarrow>FVar x}e) \<longmapsto>fb e' \<rbrakk>
                       \<Longrightarrow> (LambdaE e) \<longmapsto>fb (LambdaE ({0\<leftarrow>x}e'))"
  | c_app1_fb[intro!]: "\<lbrakk> e1 \<longmapsto>fb e1' \<rbrakk> \<Longrightarrow> AppE e1 e2 \<longmapsto>fb AppE e1' e2"
  | c_app2_fb[intro!]: "\<lbrakk> e2 \<longmapsto>fb e2' \<rbrakk> \<Longrightarrow> AppE e1 e2 \<longmapsto>fb AppE e1 e2'"
  | r_prim_fb[intro!]: "\<lbrakk> eval_prim p c = Result c' \<rbrakk>
                       \<Longrightarrow> Prim p (Const c) \<longmapsto>fb Const c'"
  | c_prim_fb[intro!]: "\<lbrakk> e \<longmapsto>fb e' \<rbrakk> \<Longrightarrow> Prim p e \<longmapsto>fb Prim p e'"
  | r_if_true_fb[intro!]: "IfE (Const (BoolC True)) e2 e3 \<longmapsto>fb e2"
  | r_if_false_fb[intro!]: "IfE (Const (BoolC False)) e2 e3 \<longmapsto>fb e3"
  | c_if1_fb[intro!]: "\<lbrakk> e1 \<longmapsto>fb e1' \<rbrakk> \<Longrightarrow> IfE e1 e2 e3 \<longmapsto>fb IfE e1' e2 e3"
  | c_if2_fb[intro!]: "\<lbrakk> e2 \<longmapsto>fb e2' \<rbrakk> \<Longrightarrow> IfE e1 e2 e3 \<longmapsto>fb IfE e1 e2' e3"
  | c_if3_fb[intro!]: "\<lbrakk> e3 \<longmapsto>fb e3' \<rbrakk> \<Longrightarrow> IfE e1 e2 e3 \<longmapsto>fb IfE e1 e2 e3'"
  | c_cons1[intro!]: "\<lbrakk> e1 \<longmapsto>fb e1' \<rbrakk> \<Longrightarrow> Cons e1 e2 \<longmapsto>fb Cons e1' e2"
  | c_cons2[intro!]: "\<lbrakk> e2 \<longmapsto>fb e2' \<rbrakk> \<Longrightarrow> Cons e1 e2 \<longmapsto>fb Cons e1 e2'"
  | c_car[intro!]: "\<lbrakk> e \<longmapsto>fb e' \<rbrakk> \<Longrightarrow> Car e \<longmapsto>fb Car e'"
  | c_cdr[intro!]: "\<lbrakk> e \<longmapsto>fb e' \<rbrakk> \<Longrightarrow> Cdr e \<longmapsto>fb Cdr e'"
  | r_car[intro!]: "Car (Cons e1 e2) \<longmapsto>fb e1"
  | r_cdr[intro!]: "Cdr (Cons e1 e2) \<longmapsto>fb e2"

fun val :: "exp \<Rightarrow> bool" where
    "val (Const c) = True"
  | "val (LambdaE e) = True"
  | "val (Cons e1 e2) = ((val e1) \<and> (val e2))"
  | "val _ = False"

inductive reduce_bv :: "exp \<Rightarrow> exp \<Rightarrow> bool" (infix "\<longmapsto>" 70) where
    beta_bv[intro!]: "val v \<Longrightarrow> AppE (LambdaE e) v \<longmapsto> ({0\<rightarrow>v}e)"
  | c_app1_bv[intro!]: "\<lbrakk> e1 \<longmapsto> e1' \<rbrakk> \<Longrightarrow> AppE e1 e2 \<longmapsto> AppE e1' e2"
  | c_app2_bv[intro!]: "\<lbrakk> val v; e2 \<longmapsto> e2' \<rbrakk> \<Longrightarrow> AppE v e2 \<longmapsto> AppE v e2'"
  | r_prim_bv[intro!]: "\<lbrakk> eval_prim p c = Result c' \<rbrakk>
                       \<Longrightarrow> Prim p (Const c) \<longmapsto> Const c'"
  | c_prim_bv[intro!]: "\<lbrakk> e \<longmapsto> e' \<rbrakk> \<Longrightarrow> Prim p e \<longmapsto> Prim p e'"
  | r_if_true_bv[intro!]: "IfE (Const (BoolC True)) e2 e3 \<longmapsto> e2"
  | r_if_false_bv[intro!]: "IfE (Const (BoolC False)) e2 e3 \<longmapsto> e3"
  | c_if_bv[intro!]: "\<lbrakk> e1 \<longmapsto> e1' \<rbrakk> \<Longrightarrow> IfE e1 e2 e3 \<longmapsto> IfE e1' e2 e3"
  | c_cons1_bv[intro!]: "\<lbrakk> e1 \<longmapsto> e1' \<rbrakk> \<Longrightarrow> Cons e1 e2 \<longmapsto> Cons e1' e2"
  | c_cons2_bv[intro!]: "\<lbrakk> e2 \<longmapsto> e2' \<rbrakk> \<Longrightarrow> Cons e1 e2 \<longmapsto> Cons e1 e2'"
  | c_car_bv[intro!]: "\<lbrakk> e \<longmapsto> e' \<rbrakk> \<Longrightarrow> Car e \<longmapsto> Car e'"
  | c_cdr_bv[intro!]: "\<lbrakk> e \<longmapsto> e' \<rbrakk> \<Longrightarrow> Cdr e \<longmapsto> Cdr e'"
  | r_car_bv[intro!]: "Car (Cons e1 e2) \<longmapsto> e1"
  | r_cdr_bv[intro!]: "Cdr (Cons e1 e2) \<longmapsto> e2"

inductive reduces_bv :: "exp \<Rightarrow> exp \<Rightarrow> bool" (infix "\<longmapsto>*" 70) where
    red_bv_nil[intro!]: "(e::exp) \<longmapsto>* e"
  | red_bv_cons[intro!]: "\<lbrakk> (e1::exp) \<longmapsto> e2; e2 \<longmapsto>* e3 \<rbrakk> \<Longrightarrow> e1 \<longmapsto>* e3"

datatype ty = IntT | BoolT | PairT ty ty | FunT ty ty (infix "\<rightarrow>" 75)

primrec prim_type :: "primitive \<Rightarrow> ty \<times> ty" where
    "prim_type Inc = (IntT, IntT)"
  | "prim_type Dec = (IntT, IntT)"
  | "prim_type Neg = (IntT, IntT)"
  | "prim_type IsZero = (IntT, BoolT)"
  | "prim_type Not = (BoolT, BoolT)"

primrec const_type :: "const \<Rightarrow> ty" where
    "const_type (IntC n) = IntT"
  | "const_type (BoolC b) = BoolT"
  | "const_type (PairC t1 t2) = PairT (const_type t1) (const_type t2)"

fun lookup :: "'a \<Rightarrow> ('a \<times> 'b) list \<Rightarrow> 'b option" where
    "lookup k [] = None"
  | "lookup k ((k',v)#ls) = (if k = k' then Some v else lookup k ls)"

lemma lookup_app: assumes lx: "lookup x \<Gamma> = Some v"
shows "lookup x (\<Gamma>@\<Gamma>') = Some v"
using lx by (induction \<Gamma> arbitrary: x v) auto

lemma lookup_app_none: assumes lx: "lookup x \<Gamma> = None"
shows "lookup x (\<Gamma>@[(x,T)]) = Some T"
using lx by (induction \<Gamma> arbitrary: x T) auto

lemma not_dom_lookup_none:
assumes x: "x \<notin> assoc_dom \<Gamma>" shows "lookup x \<Gamma> = None"
using x by (induction \<Gamma> arbitrary: x) auto

lemma lookup_dom:
assumes x: "lookup x \<Gamma> = Some T" shows "x \<in> assoc_dom \<Gamma>"
using x apply (induction \<Gamma> arbitrary: x T) apply auto apply (case_tac "x = a") by auto

type_synonym ty_env = "(var \<times> ty) list"

inductive wt :: "ty_env \<Rightarrow> exp \<Rightarrow> ty \<Rightarrow> bool" ("_ \<turnstile>o _ : _" [60,60,60] 59) where
    wt_c[intro!]: "\<lbrakk> const_type c = T \<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile>o Const c : T"
  | wt_p[intro!]: "\<lbrakk> \<Gamma> \<turnstile>o e : T1; prim_type p = (T1, T2) \<rbrakk>
            \<Longrightarrow> \<Gamma> \<turnstile>o Prim p e : T2"
  | wt_i[intro!]: "\<lbrakk> \<Gamma> \<turnstile>o e1 : BoolT; \<Gamma> \<turnstile>o e2 : T; \<Gamma> \<turnstile>o e3 : T \<rbrakk>
                      \<Longrightarrow> \<Gamma> \<turnstile>o IfE e1 e2 e3 : T"
  | wt_v[intro!]: "\<lbrakk> lookup x \<Gamma> = Some T \<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile>o FVar x : T"
  | wt_l[intro!]: "\<lbrakk> x \<notin> set (FV e); (x,T1)#\<Gamma> \<turnstile>o ({0\<rightarrow>FVar x} e) : T2 \<rbrakk>
            \<Longrightarrow> \<Gamma> \<turnstile>o LambdaE e : T1\<rightarrow>T2"
  | wt_a[intro!]: "\<lbrakk> \<Gamma> \<turnstile>o e1 : T \<rightarrow> T'; \<Gamma> \<turnstile>o e2 : T \<rbrakk>
            \<Longrightarrow> \<Gamma> \<turnstile>o AppE e1 e2 : T'"
  | wt_p1[intro!]: "\<lbrakk> \<Gamma> \<turnstile>o e1 : T1; \<Gamma> \<turnstile>o e2 : T2 \<rbrakk>
            \<Longrightarrow> \<Gamma> \<turnstile>o Cons e1 e2 : PairT T1 T2"
  | wt_p2[intro!]: "\<lbrakk> \<Gamma> \<turnstile>o e : (PairT T1 T2) \<rbrakk>
            \<Longrightarrow> \<Gamma> \<turnstile>o Car e : T1"
  | wt_p3[intro!]: "\<lbrakk> \<Gamma> \<turnstile>o e : (PairT T1 T2) \<rbrakk>
            \<Longrightarrow> \<Gamma> \<turnstile>o Cdr e : T2"

inductive well_typed :: "ty_env \<Rightarrow> exp \<Rightarrow> ty \<Rightarrow> bool" ("_ \<turnstile> _ : _" [60,60,60] 59) where
    wt_const[intro!]: "\<lbrakk> const_type c = T \<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> Const c : T"
  | wt_prim[intro!]: "\<lbrakk> \<Gamma> \<turnstile> e : T1; prim_type p = (T1, T2) \<rbrakk>
            \<Longrightarrow> \<Gamma> \<turnstile> Prim p e : T2"
  | wt_if[intro!]: "\<lbrakk> \<Gamma> \<turnstile> e1 : BoolT; \<Gamma> \<turnstile> e2 : T; \<Gamma> \<turnstile> e3 : T \<rbrakk>
                      \<Longrightarrow> \<Gamma> \<turnstile> IfE e1 e2 e3 : T"
  | wt_var[intro!]: "\<lbrakk> lookup x \<Gamma> = Some T \<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> FVar x : T"
  | wt_lambda[intro!]: "\<lbrakk> \<forall> x. x \<notin> set L \<longrightarrow> (x,T1)#\<Gamma> \<turnstile> ({0\<rightarrow>FVar x} e) : T2 \<rbrakk>
            \<Longrightarrow> \<Gamma> \<turnstile> LambdaE e : T1\<rightarrow>T2"
  | wt_app[intro!]: "\<lbrakk> \<Gamma> \<turnstile> e1 : T \<rightarrow> T'; \<Gamma> \<turnstile> e2 : T \<rbrakk>
            \<Longrightarrow> \<Gamma> \<turnstile> AppE e1 e2 : T'"
  | wt_pair[intro!]: "\<lbrakk> \<Gamma> \<turnstile> e1 : T1; \<Gamma> \<turnstile> e2 : T2 \<rbrakk>
            \<Longrightarrow> \<Gamma> \<turnstile> Cons e1 e2 : PairT T1 T2"
  | wt_car[intro!]: "\<lbrakk> \<Gamma> \<turnstile> e : (PairT T1 T2) \<rbrakk>
            \<Longrightarrow> \<Gamma> \<turnstile> Car e : T1"
  | wt_cdr[intro!]: "\<lbrakk> \<Gamma> \<turnstile> e : (PairT T1 T2) \<rbrakk>
            \<Longrightarrow> \<Gamma> \<turnstile> Cdr e : T2"

inductive_cases
  inv_wt_fvar[elim!]: "\<Gamma> \<turnstile> FVar x : T" and
  inv_wt_bvar[elim!]: "\<Gamma> \<turnstile> BVar k : T" and
  inv_wt_const[elim!]: "\<Gamma> \<turnstile> Const c : T" and
  inv_wt_prim[elim!]: "\<Gamma> \<turnstile> Prim p e : T" and
  inv_wt_lambda[elim!]: "\<Gamma> \<turnstile> LambdaE e : T" and
  inv_wt_app[elim!]: "\<Gamma> \<turnstile> AppE e1 e2 : T" and
  inv_wt_pair[elim!]: "\<Gamma> \<turnstile> Cons e1 e2 : T" and
  inv_wt_car[elim!]: "\<Gamma> \<turnstile> Car e : T" and
  inv_wt_cdr[elim!]: "\<Gamma> \<turnstile> Cdr e : T"

inductive wt_env :: "ty_env \<Rightarrow> env \<Rightarrow> bool" ("_ \<turnstile> _" [60,60] 59) where
    wt_nil[intro!]: "[] \<turnstile> []"
  | wt_cons[intro!]: "\<lbrakk> [] \<turnstile> v : T; \<Gamma> \<turnstile> \<rho> \<rbrakk> \<Longrightarrow> (x,T)#\<Gamma> \<turnstile> (x,v)#\<rho>"

inductive_cases
  inv_wt_nil[elim!]: "\<Gamma> \<turnstile> []" and
  inv_wt_cons[elim!]: "\<Gamma> \<turnstile> (x,v)#\<rho>"

lemma bsubst_cross[rule_format]:
  "\<forall> (i::nat) j u v. i \<noteq> j \<and> {i\<rightarrow>u}({j\<rightarrow>v}t) = {j\<rightarrow>v}t \<longrightarrow> {i\<rightarrow>u}t = t"
apply (induction t)
apply force
apply clarify apply (erule_tac x=i in allE) apply (erule_tac x=j in allE)
  apply force
apply clarify apply (erule_tac x=i in allE) apply (erule_tac x=i in allE)
  apply (erule_tac x=i in allE) apply (erule_tac x=j in allE)
  apply (erule_tac x=j in allE) apply (erule_tac x=j in allE) apply force
apply force
apply force
apply clarify apply (erule_tac x="Suc i" in allE)
  apply (erule_tac x="Suc j" in allE) apply force
apply clarify apply (erule_tac x=i in allE) apply (erule_tac x=i in allE)
  apply force
apply clarify apply (erule_tac x=i in allE) apply (erule_tac x=i in allE)
  apply force
apply (metis bsubst.simps(9) exp.inject(9))
apply (metis bsubst.simps(10) exp.inject(10))
done

lemma bsubst_id: fixes e::exp assumes wte: "\<Gamma> \<turnstile> e : T" shows "{k\<rightarrow>e'}e = e"
using wte apply (induction \<Gamma> e T arbitrary: k e')
apply force apply force apply force apply force defer apply force
apply force apply force apply force
apply (erule_tac x="Suc (list_max L)" in allE) apply (erule impE)
apply (rule list_max_fresh) apply simp apply simp apply clarify
apply (rule bsubst_cross) apply blast
done

lemma fv_bsubst: fixes e::exp and e'::exp shows "set (FV e) \<subseteq> set (FV ({k\<rightarrow>e'}e))"
apply (induction e arbitrary: e' k) apply auto apply blast+
done

lemma subst_permute:
  fixes x::nat and z::nat and e::exp and e'::exp
  assumes xz: "z \<notin> set (FV v)" and wte: "\<Gamma> \<turnstile> e' : T"
  shows "{j\<rightarrow>v}([z\<mapsto>e']e) = [z\<mapsto>e']({j\<rightarrow>v}e)"
  using xz wte apply (induction e arbitrary: j x z \<Gamma> T e')
  apply force apply force apply force
  using bsubst_id apply force apply simp
  using subst_id apply force apply force apply force
  apply auto
done

lemma decompose_subst[rule_format]:
  "\<forall> u x i. x \<notin> set (FV e) \<longrightarrow> {i\<rightarrow>u}e = [x\<mapsto>u]({i\<rightarrow>FVar x}e)"
apply (induction e)
apply force
apply clarify apply (erule_tac x=u in allE) apply (erule_tac x=x in allE)
  apply force
apply force apply force apply force
apply clarify apply (erule_tac x=u in allE) apply (erule_tac x=x in allE)
  apply force
apply force
apply force
apply (metis FV.simps(9) bsubst.simps(9) subst.simps(9))
apply (metis FV.simps(10) bsubst.simps(10) subst.simps(10))
done

lemma msubst_const[simp]: "[\<rho>]Const c = Const c" by (induction \<rho>) auto

lemma msubst_prim[simp]: "[\<rho>]Prim p e = Prim p ([\<rho>]e)"
  by (induction \<rho> arbitrary: p e) auto

lemma msubst_var1: fixes v::exp assumes lx: "lookup x \<rho> = Some v" and fv: "FV v = []"
  shows "[\<rho>]FVar x = v"
using lx fv apply (induction \<rho> arbitrary: x v)
apply force
apply (case_tac a) apply simp apply (case_tac "x = aa")
apply simp apply (rule msubst_id) apply auto
done

lemma msubst_var2:
  fixes v::exp assumes lx: "lookup x \<rho> = None" shows "[\<rho>]FVar x = FVar x"
using lx by (induction \<rho> arbitrary: x v) auto

lemma msubst_if[simp]: "[\<rho>]IfE e1 e2 e3 = IfE ([\<rho>]e1) ([\<rho>]e2) ([\<rho>]e3)"
  by (induction \<rho> arbitrary: e1 e2 e3) auto

lemma msubst_app[simp]: "[\<rho>]AppE e1 e2 = AppE ([\<rho>]e1) ([\<rho>]e2)"
  by (induction \<rho> arbitrary: e1 e2) auto

lemma msubst_lam[simp]: "[\<rho>]LambdaE e = LambdaE ([\<rho>]e)"
  by (induction \<rho> arbitrary: e) auto

lemma msubst_permute:
  fixes e::exp and \<rho>::env
  assumes rv: "assoc_dom \<rho> \<inter> set (FV v) = {}" and wtr: "\<Gamma> \<turnstile> \<rho>"
  shows "{j\<rightarrow>v}([\<rho>]e) = [\<rho>]({j\<rightarrow>v}e)"
using rv wtr proof (induction \<rho> arbitrary: j v e \<Gamma>)
  case (Nil j v e)
  show "{j\<rightarrow>v}[[]] e = [[]]({j\<rightarrow>v}e)" by simp
next
  case (Cons a \<rho> j v e)
  show "{j\<rightarrow>v}[(a # \<rho>)] e = [(a # \<rho>)] ({j\<rightarrow>v}e)"
  proof (cases a)
    fix z e' assume a: "a = (z,e')"
    let ?E = "[z\<mapsto>e']e"
    from a have "[(a # \<rho>)] e = [\<rho>]( ?E )" by simp
    from Cons have d: "assoc_dom \<rho> \<inter> set (FV v) = {}" by auto
    from Cons a obtain \<Gamma>' T where g: "\<Gamma> = (z,T)#\<Gamma>'" and gr2: "\<Gamma>' \<turnstile> \<rho>"
      and wtep: "[] \<turnstile> e' : T" by blast
    from Cons a have zfv: "z \<notin> set (FV v)" by simp
    from Cons a d gr2 have IH: "{j\<rightarrow>v}[\<rho>] ?E = [\<rho>]({j\<rightarrow>v} ?E)" by blast
    also with zfv wtep have "... = [\<rho>]([z\<mapsto>e']({j\<rightarrow>v}e))"
      using subst_permute[of z v "[]" e' T j e] by simp
    finally have "{j\<rightarrow>v}[\<rho>] ([z\<mapsto>e']e) = [\<rho>]([z\<mapsto>e']({j\<rightarrow>v}e))" by simp
    with a show ?thesis by simp
  qed
qed

lemma wt_env_lookup:
  assumes lg: "lookup x \<Gamma> = Some T" and wt_env: "\<Gamma> \<turnstile> \<rho>"
  shows "\<exists> (v::exp). lookup x \<rho> = Some v \<and> [] \<turnstile> v : T"
  using wt_env lg by (induction \<Gamma> \<rho> arbitrary: x T) auto

abbreviation subseteq :: "ty_env \<Rightarrow> ty_env \<Rightarrow> bool" (infixl "\<preceq>" 80) where
  "\<Gamma> \<preceq> \<Gamma>' \<equiv> \<forall> x T. lookup x \<Gamma> = Some T \<longrightarrow> lookup x \<Gamma>' = Some T"

lemma env_weakening[rule_format]:
  fixes e::exp shows "\<Gamma> \<turnstile> e : T \<Longrightarrow> \<forall> \<Gamma>'. \<Gamma> \<preceq> \<Gamma>' \<longrightarrow> \<Gamma>' \<turnstile> e : T"
by (induct rule: well_typed.induct, force, auto)

lemma wt_dom_fv: assumes wt: "\<Gamma> \<turnstile>o e : T" shows "set (FV e) \<subseteq> assoc_dom \<Gamma>"
using wt apply (induction \<Gamma> e T, auto)
using lookup_dom apply force
using fv_bsubst apply force
done

lemma weaken_cons_snoc: assumes xng: "x \<notin> assoc_dom \<Gamma>"
  shows "([(x,T1)]@\<Gamma>) \<preceq> (\<Gamma>@[(x,T1)])" using xng
proof clarify
  fix x' T assume lxg1: "lookup x' ([(x,T1)]@\<Gamma>) = Some T"
  show "lookup x' (\<Gamma>@[(x,T1)]) = Some T"
  proof (cases "x' = x")
    assume x: "x' = x"
    with lxg1 have lxg1b: "lookup x' ([(x,T1)]@\<Gamma>) = Some T1" by simp
    from xng not_dom_lookup_none have xg: "lookup x \<Gamma> = None" by simp
    from lxg1b xg x have "lookup x' (\<Gamma>@[(x,T1)]) = Some T1"
      using lookup_app_none[of x \<Gamma>] by simp
    with x lxg1 show ?thesis by simp
  next
    assume x: "x' \<noteq> x"
    from x lxg1 have lxg1b: "lookup x' \<Gamma> = Some T" by simp
    thus ?thesis by (rule lookup_app)
  qed
qed

abbreviation remove_bind :: "var \<Rightarrow> ty_env \<Rightarrow> ty_env \<Rightarrow> bool" where
  "remove_bind z \<Gamma> \<Gamma>' \<equiv> \<forall>x T. x\<noteq>z \<and> lookup x \<Gamma> = Some T
            \<longrightarrow> lookup x \<Gamma>' = Some T"

lemma subst_pres_types:
  fixes M::exp and v::exp and \<Gamma>::ty_env
  assumes wtm: "\<Gamma> \<turnstile> M : A" and lx: "lookup x \<Gamma> = Some B"
  and rg: "remove_bind x \<Gamma> \<Gamma>'" and vb: "\<Gamma>' \<turnstile> v : B"
  shows "\<Gamma>' \<turnstile> [x \<mapsto> v]M : A" using wtm lx rg vb
proof (induction arbitrary: x B \<Gamma>' v rule: well_typed.induct)
  case (wt_const c T \<Gamma> x B \<Gamma>' v)
  thus "\<Gamma>' \<turnstile> [x\<mapsto>v](Const c) : T" by auto
next
  case (wt_prim \<Gamma> e T1 p T2 x B \<Gamma>' v)
  hence "\<Gamma>' \<turnstile> [x\<mapsto>v]e : T1" and "prim_type p = (T1,T2)" by auto
  thus "\<Gamma>' \<turnstile> [x\<mapsto>v] (Prim p e) : T2" by auto
next
  case (wt_if \<Gamma> e1 e2 T e3 x B \<Gamma>' v)
  from wt_if have wte1: "\<Gamma>' \<turnstile> [x\<mapsto>v]e1 : BoolT"
    and wte2: "\<Gamma>' \<turnstile> [x\<mapsto>v]e2 : T"  and wte3: "\<Gamma>' \<turnstile> [x\<mapsto>v]e3 : T" by auto
  from wte1 wte2 wte3 show "\<Gamma>' \<turnstile> [x\<mapsto>v] IfE e1 e2 e3 : T" by auto
next
  case (wt_var y \<Gamma> T x B \<Gamma>' v)
  from wt_var have wtv: "\<Gamma>' \<turnstile> v : B" and ly: "lookup y \<Gamma> = Some T"
      and lx: "lookup x \<Gamma> = Some B" and rb: "remove_bind x \<Gamma> \<Gamma>'" by auto
  show "\<Gamma>' \<turnstile> [x\<mapsto>v]FVar y : T"
  proof (cases "x = y")
    assume x: "x = y"
    have "[] \<preceq> \<Gamma>'" by auto
    from wtv x ly lx show ?thesis by simp
  next
    assume x: "x \<noteq> y" with ly rb have "\<Gamma>' \<turnstile> FVar y : T" by auto
    with x show ?thesis by auto
  qed
next
  case (wt_lambda L T1 \<Gamma> e T2 x B \<Gamma>' v)
  from wt_lambda have lx: "lookup x \<Gamma> = Some B" by simp
  from wt_lambda have rb: "remove_bind x \<Gamma> \<Gamma>'" by simp
  from wt_lambda have wtv: "\<Gamma>' \<turnstile> v : B" by simp
  have "\<Gamma>' \<turnstile> LambdaE ([x\<mapsto>v]e) : T1 \<rightarrow> T2"
  proof clarify
    fix x' assume xL: "x' \<notin> set ((x#L) @ (map fst \<Gamma>'))"
    from wt_lambda xL have "(x',T1)#\<Gamma> \<turnstile> bsubst 0 (FVar x') e : T2" by auto
    from xL lx have lx2: "lookup x ((x',T1)#\<Gamma>) = Some B" by simp
    from rb xL have rb2: "remove_bind x ((x',T1)#\<Gamma>) ((x',T1)#\<Gamma>')" by auto
    from xL have xL2: "x' \<notin> set L" by auto
    from xL have xx: "x' \<noteq> x" by simp
    from xL have xgp: "lookup x' \<Gamma>' = None" using not_dom_lookup_none by auto
    from xgp have "\<Gamma>' \<preceq> ((x',T1)#\<Gamma>')" by simp
    with wtv env_weakening[of \<Gamma>' v B "(x',T1)#\<Gamma>'"]
    have wtv2: "(x',T1)#\<Gamma>' \<turnstile> v : B" by blast
    from wt_lambda lx2 rb2 xL2 wtv2 xx
    have 1: "(x',T1)#\<Gamma>' \<turnstile> [x\<mapsto>v]({0\<rightarrow>FVar x'} e) : T2" by auto
    from wtv xx  subst_permute
    have "[x\<mapsto>v]({0\<rightarrow>FVar x'}e) = {0\<rightarrow>FVar x'}([x\<mapsto>v]e)" by auto
    with 1 show "(x',T1)#\<Gamma>' \<turnstile> ({0\<rightarrow>FVar x'}([x\<mapsto>v]e)) : T2" by simp
  qed
  thus "\<Gamma>' \<turnstile> [x\<mapsto>v]LambdaE e : T1 \<rightarrow> T2" by simp
next
  case (wt_app \<Gamma> e1 T T' e2 x B \<Gamma>' v)
  thus "\<Gamma>' \<turnstile> [x\<mapsto>v]AppE e1 e2 : T'" by auto
next
  case (wt_pair \<Gamma> e1 T1 e2 T2 x B \<Gamma>' v)
  thus "\<Gamma>' \<turnstile> [x\<mapsto>v] Cons e1 e2 : PairT T1 T2" by auto
next
  case (wt_car \<Gamma> e T1 T2 x B \<Gamma>' v)
  thus "\<Gamma>' \<turnstile> [x\<mapsto>v] Car e : T1" by auto
next
  case (wt_cdr \<Gamma> e T1 T2 x B \<Gamma>' v)
  thus "\<Gamma>' \<turnstile> [x\<mapsto>v] Cdr e : T2" by auto
qed

lemma substitution_preserves_types:
  fixes M::exp and v::exp
  assumes wtm: "(x,B)#\<Gamma> \<turnstile> M : A" and vb: "\<Gamma> \<turnstile> v : B"
  shows "\<Gamma> \<turnstile> [x \<mapsto> v]M : A"
using wtm vb subst_pres_types[of "(x,B)#\<Gamma>" M A x B \<Gamma> v] by auto

lemma msubst_preserves_types:
  fixes M::exp and \<rho>::env assumes wtm: "\<Gamma>1@\<Gamma>2 \<turnstile> M : A" and sr: "\<Gamma>1 \<turnstile> \<rho>"
  shows "\<Gamma>2 \<turnstile> [\<rho>]M : A" using wtm sr
proof (induction \<rho> arbitrary: \<Gamma>1 \<Gamma>2 M A)
  case (Nil \<Gamma>1 \<Gamma>2 M A) thus "\<Gamma>2 \<turnstile> [[]] M : A" by auto
next
  case (Cons a \<rho> \<Gamma>1 \<Gamma>2 M A)
  show "\<Gamma>2 \<turnstile> [(a#\<rho>)] M : A"
  proof (cases a)
    fix x v assume a: "a = (x,v)"
    from a have 1: "[(a#\<rho>)]M = [\<rho>] ([x\<mapsto>v] M)" by simp
    from Cons a obtain \<Gamma>1'::ty_env and B::ty where g1: "\<Gamma>1 = (x,B)#\<Gamma>1'"
      and wtv: "[] \<turnstile> v : B" and g1pr: "\<Gamma>1' \<turnstile> \<rho>" by auto
    from Cons g1 have wtm: "(x,B)#(\<Gamma>1'@\<Gamma>2) \<turnstile> M : A" by simp
    from wtv env_weakening[of "[]"]  have wtv2: "\<Gamma>1'@\<Gamma>2 \<turnstile> v : B" by auto
    from wtm wtv2 have wtm2: "\<Gamma>1'@\<Gamma>2 \<turnstile> [x\<mapsto>v]M : A"
      using substitution_preserves_types by blast
    from wtm2 Cons g1pr have "\<Gamma>2 \<turnstile> [\<rho>]([x\<mapsto>v]M) : A" by blast
    with a show ?thesis by simp
  qed
qed

lemma adequacy1: fixes e::exp assumes wte: "\<Gamma> \<turnstile> e : T" shows "\<Gamma> \<turnstile>o e : T"
using wte apply (induction \<Gamma> e T) apply force apply force apply force
apply force defer apply force defer apply force apply force defer apply force
proof -
  case (wt_lambda L T1 \<Gamma> e T2)
  let ?X = "Suc (max (list_max L) (list_max (FV e)))"
  show "\<Gamma> \<turnstile>o LambdaE e : T1 \<rightarrow> T2"
  proof
    show "?X \<notin> set (FV e)" using list_max_fresh[of "FV e" "?X"] by auto
  next
    have "?X \<notin> set L" using list_max_fresh by auto
    with wt_lambda show "(?X,T1)#\<Gamma> \<turnstile>o ({0\<rightarrow>FVar ?X} e) : T2" by blast
  qed
qed

lemma adequacy2: fixes e::exp assumes wte: "\<Gamma> \<turnstile>o e : T" shows "\<Gamma> \<turnstile> e : T"
using wte apply (induction \<Gamma> e T rule: wt.induct) apply force
apply force apply force apply force defer apply force defer apply force apply force
defer apply force
proof -
  case (wt_l x e T1 \<Gamma> T2)
  from wt_l have xfv: "x \<notin> set (FV e)" and
    1: "(x,T1)#\<Gamma> \<turnstile> ({0\<rightarrow>FVar x}e) : T2" by auto
  show "\<Gamma> \<turnstile> LambdaE e : T1 \<rightarrow> T2"
  proof clarify
    fix x' assume xL: "x' \<notin> set (FV e @ map fst \<Gamma>)"
    from xL not_dom_lookup_none[of x' \<Gamma>]
    have lxg: "lookup x' \<Gamma> = None" by simp
    hence rb: "remove_bind x ((x,T1)#\<Gamma>) ((x',T1)#\<Gamma>)" by auto
    have lxg2: "lookup x ((x,T1)#\<Gamma>) = Some T1" by simp
    have wtxp: "(x',T1)#\<Gamma> \<turnstile> FVar x' : T1" by auto
    from 1 lxg2 rb wtxp subst_pres_types
    have 2: "(x',T1)#\<Gamma> \<turnstile> [x\<mapsto>FVar x']({0\<rightarrow>FVar x}e) : T2" by blast
    from xfv have 3: "{0\<rightarrow>FVar x'}e = [x\<mapsto>FVar x']({0\<rightarrow>FVar x}e)"
      using decompose_subst[of x e] by blast
    from 2 3 show "(x',T1)#\<Gamma> \<turnstile> ({0\<rightarrow>FVar x'}e) : T2" by simp
  qed
qed

end


theory rotate_mod
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype Nat = S "Nat" | Z

datatype 'a List2 = Cons2 "'a" "'a List2" | Nil2

fun take :: "Nat => 'a List2 => 'a List2" where
"take (S z) (Cons2 x2 x3) = Cons2 x2 (take z x3)"
| "take (S z) (Nil2) = Nil2"
| "take (Z) y = Nil2"

fun minus :: "Nat => Nat => Nat" where
"minus (S z) (S x2) = minus z x2"
| "minus (S z) (Z) = S z"
| "minus (Z) y = Z"

fun lt :: "Nat => Nat => bool" where
"lt (S x2) (S z) = lt x2 z"
| "lt (Z) (S z) = True"
| "lt x (Z) = False"

fun mod2 :: "Nat => Nat => Nat" where
"mod2 x (S z) =
   (if lt x (S z) then x else mod2 (minus x (S z)) (S z))"
| "mod2 x (Z) = Z"

fun length :: "'a List2 => Nat" where
"length (Cons2 y xs) = S (length xs)"
| "length (Nil2) = Z"

fun drop :: "Nat => 'a List2 => 'a List2" where
"drop (S z) (Cons2 x2 x3) = drop z x3"
| "drop (S z) (Nil2) = Nil2"
| "drop (Z) y = y"

fun append :: "'a List2 => 'a List2 => 'a List2" where
"append (Cons2 z xs) y = Cons2 z (append xs y)"
| "append (Nil2) y = y"

fun rotate :: "Nat => 'a List2 => 'a List2" where
"rotate (S z) (Cons2 x2 x3) =
   rotate z (append x3 (Cons2 x2 (Nil2)))"
| "rotate (S z) (Nil2) = Nil2"
| "rotate (Z) y = y"

(*hipster take minus lt mod2 length drop append rotate *)

theorem x0 :
  "!! (n :: Nat) (xs :: 'a List2) .
     (rotate n xs) =
       (append
          (drop (mod2 n (length xs)) xs) (take (mod2 n (length xs)) xs))"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end


theory T122
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(meet(x, y), z) = meet(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(x, join(y, z)) = join(undr(x, y), undr(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(x, meet(y, z)) = join(over(x, y), over(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(meet(x, y), z) = join(undr(x, z), undr(y, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(join(x, y), z) = join(over(x, z), over(y, z)))
"
nitpick[card nat=7,timeout=86400]
oops
end


(*  Title:      HOL/Isar_Examples/Drinker.thy
    Author:     Makarius
*)

section \<open>The Drinker's Principle\<close>

theory Drinker
  imports Main
begin

text \<open>
  Here is another example of classical reasoning: the Drinker's Principle says
  that for some person, if he is drunk, everybody else is drunk!

  We first prove a classical part of de-Morgan's law.
\<close>

lemma de_Morgan:
  assumes "\<not> (\<forall>x. P x)"
  shows "\<exists>x. \<not> P x"
proof (rule classical)
  assume "\<nexists>x. \<not> P x"
  hence "\<forall>x. P x" by blast
  with assms show ?thesis by contradiction
qed

theorem Drinker's_Principle: "\<exists>x. drunk x \<longrightarrow> (\<forall>x. drunk x)"
proof (cases "\<forall>x. drunk x")
  case True
  then show ?thesis by blast
next
  case False
  then show ?thesis by blast
qed

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_list_deleteAll_count
imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

fun deleteBy :: "('a => ('a => bool)) => 'a => 'a list =>
                 'a list" where
"deleteBy x y (nil2) = nil2"
| "deleteBy x y (cons2 y2 ys) =
     (if (x y) y2 then ys else cons2 y2 (deleteBy x y ys))"

fun deleteAll :: "'a => 'a list => 'a list" where
"deleteAll x (nil2) = nil2"
| "deleteAll x (cons2 z ys) =
     (if (x = z) then deleteAll x ys else cons2 z (deleteAll x ys))"

fun count :: "'a => 'a list => int" where
"count x (nil2) = 0"
| "count x (cons2 z ys) =
     (if (x = z) then 1 + (count x ys) else count x ys)"

theorem property0 :
  "(((deleteAll x xs) =
       (deleteBy (% (y :: 'a) => % (z :: 'a) => (y = z)) x xs)) ==>
      ((count x xs) <= 1))"
  oops

end