theory T25
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(join(x, y), z) = join(over(x, z), over(y, 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. 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. mult(x, meet(y, z)) = meet(mult(x, y), mult(x, z)))
"
nitpick[card nat=8,timeout=86400]
oops
end


(*<*)
theory Tree2 imports Tree begin
(*>*)

text{*\noindent In Exercise~\ref{ex:Tree} we defined a function
@{term"flatten"} from trees to lists. The straightforward version of
@{term"flatten"} is based on @{text"@"} and is thus, like @{term"rev"},
quadratic. A linear time version of @{term"flatten"} again reqires an extra
argument, the accumulator. Define *}
(*<*)primrec(*>*)flatten2 :: "'a tree \<Rightarrow> 'a list \<Rightarrow> 'a list"(*<*)where
"flatten2 Tip xs = xs" |
"flatten2 (Node l x r) xs = flatten2 l (x#(flatten2 r xs))"
(*>*)

text{*\noindent and prove*}
(*<*)

end
(*>*)


theory CSP
imports Main
begin

(* declarations *)

definition funrel :: "int \<Rightarrow> int \<Rightarrow> int rel \<Rightarrow> bool" where
  "funrel m n b = (Domain b = {m..n} \<and> (\<forall>i x y. (i,x)\<in>b \<and> (i,y)\<in>b \<longrightarrow> x=y))"

definition array :: "int \<Rightarrow> int \<Rightarrow> int rel \<Rightarrow> bool" where
  "array n q b = (Domain b = {1..n} \<and> Range b \<subseteq> {1..q} \<and> (\<forall>i x y. (i,x)\<in>b \<and> (i,y)\<in>b \<longrightarrow> x=y))"

lemma arrayb1: "array n q b \<Longrightarrow> funrel 1 n b" by (simp add: funrel_def array_def)

definition valof :: "int rel \<Rightarrow> int \<Rightarrow> int" where
  "x\<in>Domain b \<Longrightarrow> (valof b x = (THE y. (x,y)\<in>b))"

lemma valofarr: "array n q b \<Longrightarrow> (x,z)\<in>b \<Longrightarrow> z = valof b x"
proof (simp add: array_def)
  {
  assume "(x, z) \<in> b"
     and f: "(\<forall>i x y. (i, x) \<in> b \<and> (i, y) \<in> b \<longrightarrow> x = y)"
  hence a: "\<exists>!v. (x,v)\<in>b \<and> z = v" by blast
  then obtain v where h: "(x,v)\<in>b \<and> z = v" by blast
  hence "z = (THE y. y = v)" by auto
  hence "z = (THE y. (x,y)\<in>b)" using f a h theI by metis
  hence "z = valof b x" using \<open>(x, z) \<in> b\<close> valof_def by fastforce
  }
  thus "Domain b = {1..n} \<and>
    Range b \<subseteq> {1..q} \<and> (\<forall>i x y. (i, x) \<in> b \<and> (i, y) \<in> b \<longrightarrow> x = y) \<Longrightarrow>
    (x, z) \<in> b \<Longrightarrow> z = valof b x" by (simp)
qed

lemma valofarrev: "array n q b \<Longrightarrow> x\<in>Domain b \<Longrightarrow> z = valof b x \<Longrightarrow> (x,z)\<in>b"
proof -
assume a: "array n q b"
hence "(\<forall>i x y. (i, x) \<in> b \<and> (i, y) \<in> b \<longrightarrow> x = y)" by (simp add: array_def)
assume d: "x\<in>Domain b"
   and z: "z = valof b x"
hence "z = (THE y. (x,y)\<in>b)" by (simp add: valof_def)
thus ?thesis using a d valofarr z by auto
qed

lemma card1: "card {1..(n::nat)} = n"
proof (induction n)
case 0 show ?case by (simp)
next
case (Suc n) show ?case by (simp)
qed

lemma card2: "card {1..(n::nat)} = card {1..int n}"
proof (induction n)
case 0 show ?case by (simp)
next
case (Suc n) show ?case by (simp)
qed

lemma card3: "n\<ge>0 \<Longrightarrow> int (card {1..n}) = n "
proof -
  assume "n\<ge>0"
  then have "\<exists>m::nat. n = int m" by presburger
  then obtain m where h: "n = int m" by blast
  hence "card {1..int m} = m" using card1 card2 by simp
  thus "int (card {1..n}) = n" using h by simp
qed

lemma domcard: "finite b \<Longrightarrow> (\<forall>i x y. (i, x) \<in> b \<and> (i, y) \<in> b \<longrightarrow> x = y) \<Longrightarrow> n = card b \<Longrightarrow> n = card (Domain b)"
proof (induction n arbitrary: b)
case 0
assume h0: "finite b"
assume h1: "\<forall>i x y. (i, x) \<in> b \<and> (i, y) \<in> b \<longrightarrow> x = y"
assume h2: "0 = card b"
 show ?case
proof -
  from h0 h2 have "b={}" by (simp)
  hence "Domain b = {}" by simp
  thus ?thesis by simp
qed
next
case (Suc n)
assume h1: "\<And>b. finite b \<Longrightarrow>
    \<forall>i x y. (i, x) \<in> b \<and> (i, y) \<in> b \<longrightarrow> x = y \<Longrightarrow> n = card b \<Longrightarrow> n = card (Domain b)"
assume h2: "finite b"
assume h3: "\<forall>i x y. (i, x) \<in> b \<and> (i, y) \<in> b \<longrightarrow> x = y"
assume h4: "Suc n = card b"
show ?case
proof -
  from h4 have "\<exists>x. x\<in>b" using card_le_Suc_iff h2 insertI1 le_refl by fastforce
  then obtain x where h5: "x\<in>b" by blast
  then have "\<exists>a. x\<notin>a\<and>b=a\<union>{x}" by (metis Set.set_insert Un_commute insert_is_Un)
  then obtain a where h6: "x\<notin>a\<and>b=a\<union>{x}" by blast
  hence h7: "n = card a"
  using Un_infinite Un_insert_right card_insert_disjoint
        diff_Suc_1 h2 h4 sup_bot.right_neutral by auto
  hence h8: "n = card a \<Longrightarrow> n = card (Domain a)" using Suc.IH h2 h3 h6 by fastforce
  hence h9: "n = card (Domain a)" by (simp add: h7)
  from h6 have h11: "\<exists>p q. x=(p,q)" by simp
  then obtain p q where h12: "x=(p,q)" by blast
  hence h13: "Domain b - {p} = Domain a"
  using Diff_insert_absorb DomainE Domain_insert Un_insert_right h3 h6
        insertCI sup_bot.comm_neutral by blast
  hence h14: "card (Domain b - {p}) = n" by (simp add: h9)
  thus h10: "Suc n = card (Domain b)" using h3
  by (metis Domain.DomainI card_Suc_Diff1 finite_Domain h12 h2 h5)
qed
qed

lemma domcard1: "finite b \<Longrightarrow> (\<forall>i x y. (i, x) \<in> b \<and> (i, y) \<in> b \<longrightarrow> x = y) \<Longrightarrow> card b = card (Domain b)"
using domcard by blast

lemma arraycard: "\<lbrakk>n\<ge>0; array n q b\<rbrakk> \<Longrightarrow> int (card b) = n"
proof (simp add: array_def, auto)
  {
  assume b0: "0\<le>n"
     and b1: "Domain b = {1..n}"
     and b2: "Range b \<subseteq> {1..q}"
     and b3: "\<forall>i x y. (i, x) \<in> b \<and> (i, y) \<in> b \<longrightarrow> x = y"
  from b1 b2 have f0: "b \<subseteq> {1..n}\<times>{1..q}"
  using Domain.DomainI Range.intros mem_Sigma_iff subrelI subset_eq by auto
  hence f1: "finite b" by (meson finite_SigmaI finite_atLeastAtMost_int rev_finite_subset)
  hence s3: "int (card b) = n" by (simp add: b0 b1 b3 domcard1)
  }
  thus "0 \<le> n \<Longrightarrow>
    Domain b = {1..n} \<Longrightarrow>
    Range b \<subseteq> {1..q} \<Longrightarrow> \<forall>i x y. (i, x) \<in> b \<and> (i, y) \<in> b \<longrightarrow> x = y \<Longrightarrow> int (card b) = n"
    by blast
qed

(* constraints *)

definition allDifferent :: "('s\<times>'t) set \<Rightarrow> bool" where
  "allDifferent a = (\<forall>x y p q. (x,p)\<in>a \<and> (y,q)\<in>a \<and> x\<noteq>y \<longrightarrow> p\<noteq>q)"

definition notInSet :: "'s \<Rightarrow> 's set \<Rightarrow> bool" where
  "notInSet a s = (a\<notin>s)"

end


(*  Author: Lukas Bulwahn <lukas.bulwahn-at-gmail.com> *)

section \<open>Cardinality of Equivalence Relations\<close>

theory Card_Equiv_Relations
imports
  Card_Partitions.Card_Partitions
  Bell_Numbers_Spivey.Bell_Numbers
begin

subsection \<open>Bijection between Equivalence Relations and Set Partitions\<close>

subsubsection \<open>Possibly Interesting Theorem for @{theory HOL.Equiv_Relations}\<close>

text \<open>This theorem was historically useful in this theory, but
is now after some proof refactoring not needed here anymore.
Possibly it is an interesting fact about equivalence relations, though.
\<close>

lemma equiv_quotient_eq_quotient_on_UNIV:
  assumes "equiv A R"
  shows "A // R = (UNIV // R) - {{}}"
proof
  show "UNIV // R - {{}} \<subseteq> A // R"
  proof
    fix X
    assume "X \<in> UNIV // R - {{}}"
    from this obtain x where "X = R `` {x}" and "X \<noteq> {}"
      by (auto elim!: quotientE)
    from this have "x \<in> A"
      using \<open>equiv A R\<close> equiv_class_eq_iff by fastforce
    from this \<open>X = R `` {x}\<close> show "X \<in> A // R"
      by (auto intro!: quotientI)
  qed
next
  show "A // R \<subseteq> UNIV // R - {{}}"
  proof
    fix X
    assume "X \<in> A // R"
    from this have "X \<noteq> {}"
      using \<open>equiv A R\<close> in_quotient_imp_non_empty by auto
    moreover from \<open>X \<in> A // R\<close> have "X \<in> UNIV // R"
      by (metis UNIV_I assms proj_Eps proj_preserves)
    ultimately show "X \<in> UNIV // R - {{}}" by simp
  qed
qed

subsubsection \<open>Dedicated Facts for Bijection Proof\<close>

(* TODO: rename to fit Disjoint_Sets' naming scheme and move to Disjoint_Sets *)
lemma equiv_relation_of_partition_of:
  assumes "equiv A R"
  shows "{(x, y). \<exists>X\<in>A // R. x \<in> X \<and> y \<in> X} = R"
proof
  show "{(x, y). \<exists>X\<in>A // R. x \<in> X \<and> y \<in> X} \<subseteq> R"
  proof
    fix xy
    assume "xy \<in> {(x, y). \<exists>X\<in>A // R. x \<in> X \<and> y \<in> X}"
    from this obtain x y and X where "xy = (x, y)"
      and "X \<in> A // R" and "x \<in> X" "y \<in> X"
      by auto
    from \<open>X \<in> A // R\<close> obtain z where "X = R `` {z}"
      by (auto elim: quotientE)
    show "xy \<in> R"
      using \<open>xy = (x, y)\<close> \<open>X = R `` {z}\<close> \<open>x \<in> X\<close> \<open>y \<in> X\<close> \<open>equiv A R\<close>
      by (simp add: equiv_class_eq_iff)
  qed
next
  show "R \<subseteq> {(x, y). \<exists>X\<in>A // R. x \<in> X \<and> y \<in> X}"
  proof
    fix xy
    assume "xy \<in> R"
    obtain x y where "xy = (x, y)" by fastforce
    from \<open>xy \<in> R\<close> have "(x, y) \<in> R"
      using \<open>xy = (x, y)\<close> by simp
    have "R `` {x} \<in> A // R"
      using \<open>equiv A R\<close> \<open>(x, y) \<in> R\<close>
      by (simp add: equiv_class_eq_iff quotientI)
    moreover have "x \<in> R `` {x}"
      using \<open>(x, y) \<in> R\<close> \<open>equiv A R\<close>
      by (meson equiv_class_eq_iff equiv_class_self)
    moreover have "y \<in> R `` {x}"
      using \<open>(x, y) \<in> R\<close> \<open>equiv A R\<close> by simp
    ultimately have "(x, y) \<in> {(x, y). \<exists>X\<in>A // R. x \<in> X \<and> y \<in> X}"
      by auto
    from this show "xy \<in> {(x, y). \<exists>X\<in>A // R. x \<in> X \<and> y \<in> X}"
      using \<open>xy = (x, y)\<close> by simp
  qed
qed

subsubsection \<open>Bijection Proof\<close>

lemma bij_betw_partition_of:
  "bij_betw (\<lambda>R. A // R) {R. equiv A R} {P. partition_on A P}"
proof (rule bij_betw_byWitness[where f'="\<lambda>P. {(x, y). \<exists>X\<in>P. x \<in> X \<and> y \<in> X}"])
  show "\<forall>R\<in>{R. equiv A R}. {(x, y). \<exists>X\<in>A // R. x \<in> X \<and> y \<in> X} = R"
    by (simp add: equiv_relation_of_partition_of)
  show "\<forall>P\<in>{P. partition_on A P}. A // {(x, y). \<exists>X\<in>P. x \<in> X \<and> y \<in> X} = P"
    by (simp add: partition_on_eq_quotient)
  show "(\<lambda>R. A // R) ` {R. equiv A R} \<subseteq> {P. partition_on A P}"
    using partition_on_quotient by auto
  show "(\<lambda>P. {(x, y). \<exists>X\<in>P. x \<in> X \<and> y \<in> X}) ` {P. partition_on A P} \<subseteq> {R. equiv A R}"
    using equiv_partition_on by auto
qed

lemma bij_betw_partition_of_equiv_with_k_classes:
  "bij_betw (\<lambda>R. A // R) {R. equiv A R \<and> card (A // R) = k} {P. partition_on A P \<and> card P = k}"
proof (rule bij_betw_byWitness[where f'="\<lambda>P. {(x, y). \<exists>X\<in>P. x \<in> X \<and> y \<in> X}"])
  show "\<forall>R\<in>{R. equiv A R \<and> card (A // R) = k}. {(x, y). \<exists>X\<in>A // R. x \<in> X \<and> y \<in> X} = R"
    by (auto simp add: equiv_relation_of_partition_of)
  show "\<forall>P\<in>{P. partition_on A P \<and> card P = k}. A // {(x, y). \<exists>X\<in>P. x \<in> X \<and> y \<in> X} = P"
    by (auto simp add: partition_on_eq_quotient)
  show "(\<lambda>R. A // R) ` {R. equiv A R \<and> card (A // R) = k} \<subseteq> {P. partition_on A P \<and> card P = k}"
    using partition_on_quotient by auto
  show "(\<lambda>P. {(x, y). \<exists>X\<in>P. x \<in> X \<and> y \<in> X}) ` {P. partition_on A P \<and> card P = k} \<subseteq> {R. equiv A R \<and> card (A // R) = k}"
    using equiv_partition_on by (auto simp add: partition_on_eq_quotient)
qed

subsection \<open>Finiteness of Equivalence Relations\<close>

lemma finite_equiv:
  assumes "finite A"
  shows "finite {R. equiv A R}"
proof -
  have "bij_betw (\<lambda>R. A // R) {R. equiv A R} {P. partition_on A P}"
    by (rule bij_betw_partition_of)
  from this show "finite {R. equiv A R}"
    using \<open>finite A\<close> finitely_many_partition_on by (simp add: bij_betw_finite)
qed

subsection \<open>Cardinality of Equivalence Relations\<close>

theorem card_equiv_rel_eq_card_partitions:
  "card {R. equiv A R} = card {P. partition_on A P}"
proof -
  have "bij_betw (\<lambda>R. A // R) {R. equiv A R} {P. partition_on A P}"
    by (rule bij_betw_partition_of)
  from this show "card {R. equiv A R} = card {P. partition_on A P}"
    by (rule bij_betw_same_card)
qed

corollary card_equiv_rel_eq_Bell:
  assumes "finite A"
  shows "card {R. equiv A R} = Bell (card A)"
using assms Bell_altdef card_equiv_rel_eq_card_partitions by force

corollary card_equiv_rel_eq_sum_Stirling:
  assumes "finite A"
  shows "card {R. equiv A R} = sum (Stirling (card A)) {..card A}"
using assms card_equiv_rel_eq_Bell Bell_Stirling_eq by simp

theorem card_equiv_k_classes_eq_card_partitions_k_parts:
  "card {R. equiv A R \<and> card (A // R) = k} = card {P. partition_on A P \<and> card P = k}"
proof -
  have "bij_betw (\<lambda>R. A // R) {R. equiv A R \<and> card (A // R) = k} {P. partition_on A P \<and> card P = k}"
    by (rule bij_betw_partition_of_equiv_with_k_classes)
  from this show "card {R. equiv A R \<and> card (A // R) = k} = card {P. partition_on A P \<and> card P = k}"
    by (rule bij_betw_same_card)
qed

corollary
  assumes "finite A"
  shows "card {R. equiv A R \<and> card (A // R) = k} = Stirling (card A) k"
using card_equiv_k_classes_eq_card_partitions_k_parts
  card_partition_on[OF \<open>finite A\<close>] by metis

end


header {* A List-Machine Benchmark for Mechanized Metatheory (in Isabelle) *}

theory CIV
imports Main
begin

(* ---------------------------------------------------------
 *
 * Syntax
 *
 * ---------------------------------------------------------
 *)

types V    = nat                        (* Variables *)
      L    = nat                        (* Labels *)
datatype F = Fst | Snd                  (* Field selectors *)

(* Code blocks *)
datatype I = Cons V V V                 (* Allocate a cons cell *)
           | FetchField V F V           (* Access the field of a cons cell *)

           | BranchIfNil V L            (* Conditional jump *)
           | Jump L                     (* Unconditional jump *)

           | Halt                       (* Stop execution *)
           | Seq I I   (infixr "\<guillemotright>" 60)  (* Sequential execution *)

(* Programs *)
types P    = "L \<rightharpoonup> I"

(* Examples *)

constdefs sample :: "P"
"sample \<equiv> [ 0 \<mapsto> Cons 0 0 1
              \<guillemotright> Cons 0 1 1
              \<guillemotright> Cons 0 1 1
              \<guillemotright> Jump 1
          , 1 \<mapsto> BranchIfNil 1 2
              \<guillemotright> FetchField 1 Fst 1
              \<guillemotright> BranchIfNil 0 1
              \<guillemotright> Jump 2
          , 2 \<mapsto> Halt
          ]"

constdefs sampleLoop :: P
"sampleLoop \<equiv> [ 0 \<mapsto> Jump 0 ]"

(* -----------------------------------------------
 *
 * Operational Semantics
 *
 * -----------------------------------------------
 *)

(* Values *)
datatype A = Null                  (* Nil cell *)
           | Node A A              (* Cons cell *)

(*
Machine States

The machine state has two components:
 - a store, which maps variable names to values, and
 - an instruction pointer, which specifies what to do next.

*)

types R    = "V \<rightharpoonup> A"   (* The type of stores *)
      S    = "R \<times> I"   (* The type of machine states *)

(* A small-step operational semantics:

- The relation 'step' relates machine states.
- Two states are related if the machine can transition between them.
- The relation is inductively defined.
- Decisions are based on the instruction pointer.

*)

consts step :: "P \<Rightarrow> (S\<times>S) set"
inductive "step p"
intros

Seq[intro!]:
"((r, (i1\<guillemotright>i2)\<guillemotright>i3)
 ,(r, i1\<guillemotright>(i2\<guillemotright>i3))) \<in> step p"

Fetch[intro!]:
"\<lbrakk> r v = Some (Node a0 a1) \<rbrakk> \<Longrightarrow>
 ((r, FetchField v f v' \<guillemotright> i)
 ,(r(v' \<mapsto> if f = Fst then a0 else a1), i)) \<in> step p"

Cons[intro!]:
"\<lbrakk> r v0 = Some a0; r v1 = Some a1 \<rbrakk> \<Longrightarrow>
 ((r, Cons v0 v1 v' \<guillemotright> i)
 ,(r (v' \<mapsto> Node a0 a1), i)) \<in> step p"

BranchNot:
"\<lbrakk> r v = Some (Node a0 a1) \<rbrakk> \<Longrightarrow>
 ((r, BranchIfNil v l \<guillemotright> i)
 ,(r, i)) \<in> step p"

BranchYes:
"\<lbrakk> r v = Some Null; p l = Some i' \<rbrakk> \<Longrightarrow>
 ((r, BranchIfNil v l \<guillemotright> i)
 ,(r, i')) \<in> step p"

Jump[intro!]:
"\<lbrakk> p l = Some i' \<rbrakk> \<Longrightarrow>
 ((r, Jump l)
 ,(r, i')) \<in> step p"

(* -----------------------------------------------------------
 *
 * What constitutes a "good" program?
 *
 * -----------------------------------------------------------
 *)

(* The machine is in a good state if either:
   - it can continue executing, or
   - the program execution has terminated.
 *)

thm step.induct

consts goodState :: "P \<Rightarrow> S set"
coinductive "goodState p"
intros
step: "\<lbrakk> (s1,s2) \<in> step p; s2 \<in> goodState p \<rbrakk> \<Longrightarrow> s1 \<in> goodState p"
halt[intro!]: "(r,Halt) \<in> goodState p"

(* Note:
   The set 'goodState' is "coinductive" because we are interested
   in the largest set that satisifes the two properties above.
   In particular, this includes programs that may run forever.
 *)

(* We say that a program 'runs' if:
   - it has a valid entry point (label 0, think "main" in a C program)
   - its initial state is "good"

   Note: upon start, a program has Null in register 0.
 *)

constdefs runs :: "P \<Rightarrow> bool"
"runs p \<equiv> case p 0 of
            None \<Rightarrow> False |
            Some i \<Rightarrow> ([0\<mapsto>Null],i) \<in> goodState p"

(* Specialized rules that may be used aggresively
   (i.e., no need to backtrack) to conclude new facts.
 *)
lemmas goodState_safe_irules [intro!] =
  goodState.step[OF step.Cons]
  goodState.step[OF step.Seq]
  goodState.step[OF step.Jump]
  goodState.step[OF step.Fetch]

lemmas goodState_irules [intro] =
  goodState.step[OF step.BranchYes]
  goodState.step[OF step.BranchNot]

(* Examples *)

lemma "runs sample"
  apply (simp add: runs_def sample_def)
  apply (auto, rule goodState.step[OF step.BranchNot])
  apply (auto, rule goodState.step[OF step.BranchYes])
by auto

lemma "runs sampleLoop"
  apply (simp add: runs_def sampleLoop_def)
  apply (rule goodState.coinduct [where ?X = "{([0 \<mapsto> Null], Jump 0)}"])
  apply (auto, rule, rule, auto)
done

(* -------------------------------------------------------
 *
 * Type System
 *
 * -------------------------------------------------------
 *)

datatype T = TNil            (* The type of Null values *)
           | TCons T         (* The type of Cons values (of T) *)
           | TList T         (* The type of list (Nil or Cons) values of T *)

(* A subtyping relation on types *)

consts sub :: "(T \<times> T) set"
inductive sub
intros
nil_nil[intro!]:   "(TNil,TNil) \<in> sub"
nil_list[intro!]:  "(TNil,TList t) \<in> sub"
cons_cons[intro!]: "\<lbrakk> (t,t') \<in> sub \<rbrakk> \<Longrightarrow> (TCons t, TCons t') \<in> sub"
list_list[intro!]: "\<lbrakk> (t,t') \<in> sub \<rbrakk> \<Longrightarrow> (TList t, TList t') \<in> sub"
cons_list[intro!]: "\<lbrakk> (t,t') \<in> sub \<rbrakk> \<Longrightarrow> (TCons t, TList t') \<in> sub"

(* Inverted rules *)
inductive_cases sub_TNil[elim!]: "(t,TNil) \<in> sub"
inductive_cases sub_TCons[elim!]: "(t1,TCons t2) \<in> sub"
inductive_cases sub_TList[elim!]: "(t1,TList t2) \<in> sub"
thm sub_TNil
thm sub_TCons

lemma sub_refl[intro!]: "(t,t) \<in> sub"
  by (induct t,auto)

(* Computing least upper boubds *)

consts lub :: "T \<Rightarrow> T \<Rightarrow> T"
primrec
"lub TNil x      = (case x of
                      TNil     \<Rightarrow> TNil |
                      TCons t1 \<Rightarrow> TList t1 |
                      TList t1 \<Rightarrow> TList t1)"
"lub (TCons t) x = (case x of
                      TNil     \<Rightarrow> TList t |
                      TCons t1 \<Rightarrow> TCons (lub t t1) |
                      TList t1 \<Rightarrow> TList (lub t t1))"
"lub (TList t) x = (case x of
                      TNil     \<Rightarrow> TList t |
                      TCons t1 \<Rightarrow> TList (lub t t1) |
                      TList t1 \<Rightarrow> TList (lub t t1))"

lemma lub_ref[iff]: "lub t t = t"
  by (induct t, auto)

(* LUBs and sub-typing interact as expected. *)

lemma lub_sub_left[intro!]: "\<And>t2. (t1,lub t1 t2) \<in> sub"
  apply (induct t1) by (case_tac t2, auto)+

lemma lub_sym: "\<And>t2. lub t1 t2 = lub t2 t1"
  apply (induct t1) by (case_tac t2, auto)+

lemma lub_sub_right[intro!]: "(t2,lub t1 t2) \<in> sub"
  using lub_sym by (rule ssubst,fast)

lemma lub_least: " \<And>t1 t2. \<lbrakk> (t1,t4) \<in> sub; (t2,t4) \<in> sub \<rbrakk>
                   \<Longrightarrow> (lub t1 t2,t4) \<in> sub"
  by (induct t4,auto)

(* Typing environments

- To type the store of the machine, we associate types with
  the different variables (registers).

- To type a program, we associate a store-type with each
  program block.  The store type specifies the types of
  values that should be placed in the various registers
  before we can start executing the block.
*)

types E    = "V \<rightharpoonup> T"   (* Associates variables with types. *)
      PT   = "L \<rightharpoonup> E"   (* Associates labels with environments. *)

(* Examples *)

constdefs sampleT :: "PT"
"sampleT \<equiv> [ 0 \<mapsto> [0 \<mapsto> TNil]
           , 1 \<mapsto> [0 \<mapsto> TNil, 1 \<mapsto> TList TNil]
           , 2 \<mapsto> empty
           ]"

constdefs sampleLoopT :: "PT"
"sampleLoopT \<equiv> [ 0 \<mapsto> [0 \<mapsto> TNil ] ]"

(* We can "lift" the notion of sub-typing to environments *)
constdefs subEnv :: "E \<Rightarrow> E \<Rightarrow> bool"
"subEnv e1 e2 \<equiv> \<forall>x t. (e2 x = Some t) \<longrightarrow> (\<exists> s. (e1 x = Some s) \<and> (s,t) \<in> sub)"

(* This is the type of the initial environment. *)
constdefs initTEnv :: "E"
"initTEnv \<equiv> [ 0 \<mapsto> TNil ]"

declare initTEnv_def [simp]

(* Typing rules for single instructions:

Given the type of the whole program, we define a
relation between instructions and environments:

E1 \<turnstile> I :: E2

E1: the types of variables before executing I
E2: the typpes of the variables after executing I

*)

consts checkInstr :: "PT \<Rightarrow> (E \<times> I \<times> E) set"
inductive "checkInstr p"
intros
Seq[intro!]:
"\<lbrakk> (e1,i1,e2) \<in> checkInstr p; (e2,i2,e3) \<in> checkInstr p \<rbrakk>
\<Longrightarrow>
(e1, i1 \<guillemotright> i2, e3) \<in> checkInstr p"

BranchIfNil_TList:
"\<lbrakk> e v = Some (TList t); p l = Some e1; subEnv (e(v\<mapsto>TNil)) e1 \<rbrakk>
\<Longrightarrow>
(e, BranchIfNil v l, e(v\<mapsto>TCons t)) \<in> checkInstr p"

BranchIfNil_TCons:
"\<lbrakk> e v = Some (TCons t); p l = Some e1; subEnv (e(v\<mapsto>TNil)) e1 \<rbrakk>
\<Longrightarrow>
(e,BranchIfNil v l,e) \<in> checkInstr p"

BranchIfNil_TNil:
"\<lbrakk> e v = Some TNil; p l = Some e1; subEnv e e1 \<rbrakk>
\<Longrightarrow>
(e,BranchIfNil v l,e) \<in> checkInstr p"

FetchField[intro!]:
"\<lbrakk> e v = Some (TCons t) \<rbrakk>
\<Longrightarrow>
(e,FetchField v F v',e(v'\<mapsto>if (F = Fst) then t else TList t)) \<in> checkInstr p"

Cons[intro!]:
"\<lbrakk> e v0 = Some t0; e v1 = Some t1; lub (TList t0) t1 = TList t \<rbrakk>
\<Longrightarrow>
(e,Cons v0 v1 v,e(v\<mapsto>TCons t)) \<in> checkInstr p"

(* Inverted rules *)
inductive_cases checkInstr_Seq: "(e1,i1\<guillemotright>i2,e2) \<in> checkInstr pt"
inductive_cases checkInstr_BranchIfNil:
  "(e1,BranchIfNil v0 l,e2) \<in> checkInstr p"
inductive_cases checkInstr_FetchField:
  "(e1,FetchField v0 f v,e2) \<in> checkInstr p"
inductive_cases checkInstr_Cons: "(e1,Cons v0 v1 v,e2) \<in> checkInstr pt"
inductive_cases checkInstr_Halt: "(e1,Halt,e2) \<in> checkInstr pt"
inductive_cases checkInstr_Jump: "(e1,Jump l,e2) \<in> checkInstr pt"

thm checkInstr_Seq
thm checkInstr_Jump  (* Jumps are impossible *)

(* Typing rules for program blocks:

E \<turnstile> I

asserts that in environment E, I is a well-typed block.
*)

consts checkBlock :: "PT \<Rightarrow> (E \<times> I) set"
inductive "checkBlock pt"
intros
Halt[intro!]:
"(e,Halt) \<in> checkBlock pt"

Seq[intro!]:
"\<lbrakk> (e,i1,e') \<in> checkInstr pt; (e',i2) \<in> checkBlock pt \<rbrakk>
\<Longrightarrow>
(e,i1\<guillemotright>i2) \<in> checkBlock pt"

Jump[intro!]:
"\<lbrakk> pt l = Some e1; subEnv e e1 \<rbrakk>
\<Longrightarrow>
(e,Jump l) \<in> checkBlock pt"

(* Inverted rules *)
inductive_cases checkBlock_Seq[elim!]: "(e,i1\<guillemotright>i2) \<in> checkBlock pt"
inductive_cases checkBlock_Jump[elim!]: "(e,Jump l) \<in> checkBlock pt"
thm checkBlock_Jump

(* Typing rules for an entire progrm *)

(* Is given block in a program well typed? *)
constdefs checkBlockName :: "PT \<Rightarrow> P \<Rightarrow> L \<Rightarrow> bool"
"checkBlockName pt p l \<equiv> case pt l of
                           Some e \<Rightarrow> (case p l of
                                       Some i \<Rightarrow> (e,i) \<in> checkBlock pt |
                                       None   \<Rightarrow> False) |
                           None \<Rightarrow> True"

(* A program is well-typed if all of its blocks are *)
constdefs checkProg :: "PT \<Rightarrow> P \<Rightarrow> bool"
"checkProg pt p \<equiv> (\<forall>l. checkBlockName pt p l) \<and> pt 0 = Some initTEnv"

(* Some facts about well-typed programs *)

(* All of their blocks are well-typed *)
lemma progOK_blocks: "checkProg pt p \<Longrightarrow> checkBlockName pt p l"
  using checkProg_def by simp

(* The type of the initial block is the initial environment *)
lemma progOK_entry: "checkProg pt p \<Longrightarrow> pt 0 = Some initTEnv"
  using checkProg_def by simp

(* All labels are defined, and point to well-typed blocks. *)
lemma getCode:
  assumes A: "checkProg pt p"
      and B: "pt l = Some e"
  shows      "\<exists>i. p l = Some i \<and> (e,i) \<in> checkBlock pt"
proof -
  from A and progOK_blocks have "checkBlockName pt p l" by fast
  then obtain i where "p l = Some i" and "(e,i) \<in> checkBlock pt"
     using A B checkBlockName_def by (cases "p l",simp_all)
  thus ?thesis by simp
qed

(* Examples *)

(* The sample program is type correct *)
lemma "checkProg sampleT sample"
proof -
  have Entry: "sampleT 0 = Some initTEnv" by (simp add: sampleT_def)

  have block0: "([0 \<mapsto> TNil],
                  Cons 0 0 1
                \<guillemotright> Cons 0 1 1
                \<guillemotright> Cons 0 1 1
                \<guillemotright> Jump 1) \<in> checkBlock sampleT"
    by (auto simp:sampleT_def subEnv_def)

  have block1: "([0 \<mapsto> TNil, 1 \<mapsto> TList TNil],
                 BranchIfNil 1 2
               \<guillemotright> FetchField 1 Fst 1
               \<guillemotright> BranchIfNil 0 1
               \<guillemotright> Jump 2) \<in> checkBlock sampleT"
   apply (rule checkBlock.Seq [OF checkInstr.BranchIfNil_TList])
   apply (auto simp: sampleT_def subEnv_def)
   apply (rule checkInstr.BranchIfNil_TNil)
   by (auto simp: subEnv_def)

  have block2: "(empty,Halt) \<in> checkBlock sampleT"
    by (rule checkBlock.Halt)

  have no_more: "\<And>l. l > 2 \<Longrightarrow> checkBlockName sampleT sample l"
    by (simp add: checkBlockName_def sampleT_def)

  have Blocks: "\<forall>l. checkBlockName sampleT sample l"
  proof
    fix l show "checkBlockName sampleT sample l"
    proof (cases l)
    case 0 from block0 show ?thesis using prems
      by (auto simp: checkBlockName_def sampleT_def sample_def) next
    case (Suc n) thus ?thesis
      proof (cases n)
      case 0 from block1 show ?thesis using prems
        by (auto simp: checkBlockName_def sampleT_def sample_def) next
      case (Suc m) thus ?thesis
        proof (cases m)
        case 0 from block2 show ?thesis using prems
          by (auto simp: checkBlockName_def sampleT_def sample_def) next
        case (Suc m') from no_more show ?thesis using prems by simp
        qed
      qed
    qed
  qed

  from Blocks and Entry show ?thesis
    by (simp add: checkProg_def)
qed

(* The looping sample program is type correct *)
lemma "checkProg sampleLoopT sampleLoop"
proof -
  have B0: "(initTEnv,Jump 0) \<in> checkBlock sampleLoopT"
    apply (simp add: checkProg_def sampleLoop_def)
    apply (rule checkBlock.Jump)
    apply (auto simp: subEnv_def sampleLoopT_def)
  done
  have "\<forall>l. checkBlockName sampleLoopT sampleLoop l"
  proof
    fix l show "checkBlockName sampleLoopT sampleLoop l"
    using B0 by (cases l, simp_all add: checkBlockName_def
                                        sampleLoopT_def sampleLoop_def)
  qed
  thus ?thesis by (simp add: checkProg_def sampleLoopT_def sampleLoop_def)
qed

(* Typing Values

The definitions bellow associates types with values.
This is another way of saying that we are defining
the semantics of types (i.e., for each type we define
the set of values that belong to it.)
*)

consts valType :: "(A\<times>T) set"
inductive valType
intros
Tip_TNil   [intro!]: "(Null,TNil) \<in> valType"
Tip_TList  [intro!]: "(Null,TList t) \<in> valType"
Node_TCons [intro!]: "\<lbrakk> (x,t) \<in> valType; (xs,TList t) \<in> valType \<rbrakk>
                    \<Longrightarrow> (Node x xs, TCons t) \<in> valType"
Node_TList [intro!]: "\<lbrakk> (x,t) \<in> valType; (xs,TList t) \<in> valType \<rbrakk>
                    \<Longrightarrow> (Node x xs, TList t) \<in> valType"

(* Inverted rules *)
inductive_cases Node_TCons[elim!]: "(Node x xs,TCons t) \<in> valType"
inductive_cases Node_TList[elim!]: "(Node x xs,TList t) \<in> valType"
inductive_cases Null_T[elim!]: "(Null,t) \<in> valType"
inductive_cases Val_TNil[elim!]: "(x,TNil) \<in> valType"
inductive_cases Val_TCons[elim!]: "(x,TCons t) \<in> valType"

inductive_cases Val_TList: "(x,TList t) \<in> valType"
inductive_cases Node_T: "(Node x xs,t) \<in> valType"
thm Node_TCons

(* Well-typed stores:
   A store is typed by an environment if the values
   in the registers match their corresponding types.
 *)
constdefs envType :: "R \<Rightarrow> E \<Rightarrow> bool"
"envType r e \<equiv> \<forall>x. (case e x of
                      Some t \<Rightarrow> (case r x of
                                  Some v \<Rightarrow> (v,t) \<in> valType |
                                  None \<Rightarrow> False) |
                      None \<Rightarrow> True)"

(* A convenient way to prove that a store is well-typed. *)
lemma envTypeI:
 assumes A: "\<And>x t. \<lbrakk> e x = Some t \<rbrakk> \<Longrightarrow> \<exists>v. r x = Some v \<and> (v,t) \<in> valType"
 shows      "envType r e"
 apply (unfold envType_def,rule, case_tac "e x",simp_all)
 apply (drule A, erule exE, simp)
done

(* Lookup a value in a well-typed store.
   Produces a well-typed value. *)
lemma getVar:
  assumes A: "envType r e"
      and B: "e x = Some t"
  shows      "\<exists>v. r x = Some v \<and> (v,t) \<in> valType"
proof -
  from prems obtain v where "r x = Some v"
                        and "(v,t) \<in> valType"
    apply (simp add:envType_def)
    apply (erule_tac x ="x" in allE, simp)
    apply (cases "r x", simp_all)
  done
  thus ?thesis by simp
qed

(* Cast between subtypes:
If a value, V, is of type T, which happens to be a subtype of S,
then V also has type S.
 *)
lemma cast: "\<And>t1 t2. \<lbrakk> (v,t1) \<in> valType; (t1,t2) \<in> sub \<rbrakk> \<Longrightarrow> (v,t2) \<in> valType"
proof (induct v)
  case Null thus ?case by (cases t2,auto) next
  case (Node x xs) thus ?case by (cases t2,fast+)
qed

(* Cast between environments with subtype types *)
lemma castEnv:
  assumes A: "envType r e1"
      and B: "subEnv e1 e2"
  shows      "envType r e2"
proof (rule envTypeI)
  fix x t assume "e2 x = Some t"
  with B subEnv_def have "\<exists>t1. e1 x = Some t1 \<and> (t1,t) \<in> sub" by simp
  then obtain t1 where C: "e1 x = Some t1" and D: "(t1,t) \<in> sub" by fast
  from A C obtain v where E: "r x = Some v"
                      and F: "(v,t1) \<in> valType" using getVar by fast
  from F D have "(v,t) \<in> valType" using cast by fast
  with E show "\<exists>v. r x = Some v \<and> (v,t) \<in> valType" by simp
qed

(* The set of well-typed states for a program *)
constdefs TypedState :: "PT \<Rightarrow> S set"
"TypedState pt \<equiv> { (r,i). \<exists>e. envType r e \<and> (e,i) \<in> checkBlock pt }"

declare TypedState_def[simp]

(* ------------------------------------------------------------
 *
 * Proving soundness
 *
 * ------------------------------------------------------------
 *)

(* Assertion that well typed instructions can step (or are halted)
   and they result in well typed states. *)

constdefs steps :: "PT \<Rightarrow> P \<Rightarrow> R \<Rightarrow> I \<Rightarrow> bool"
"steps pt p r i \<equiv> \<exists>s. ((r,i),s) \<in> step p \<and> s \<in> TypedState pt \<union> goodState p"

declare steps_def[simp]

(* Jump instructions are OK *)
lemma Jump_steps:
assumes progOK:    "checkProg pt p"
    and envOK:     "envType r e"
    and labelOK:   "pt l = Some e1"
    and targetSub: "subEnv e e1"
shows "steps pt p r (Jump l)"
proof -
  from progOK and labelOK
    obtain i1 where targetCode: "p l = Some i1"
                and targetEnv:  "(e1,i1) \<in> checkBlock pt" using getCode by fast
  from targetCode have Step: "((r,Jump l),(r,i1)) \<in> step p" by (rule step.Jump)

  from envOK and targetSub
    have targetEnvOK: "envType r e1" using castEnv by fast
  with targetEnv have "(r,i1) \<in> TypedState pt" by auto
  with Step show ?thesis by auto
qed

(* Updating a well-type env. with a well-typed value
   results in a well-typed environment. *)
lemma updEnv:
assumes envOK: "envType r e"
    and valOK: "(a,t) \<in> valType"
shows          "envType (r (v \<mapsto> a)) (e (v \<mapsto> t))"
proof (rule envTypeI)
  fix x t1 assume A1: "(e (v\<mapsto>t)) x = Some t1"
  show "\<exists>a1. (r (v \<mapsto> a)) x = Some a1 \<and> (a1,t1) \<in> valType"
  proof cases
    assume A2: "x = v"
    hence F1: "(r (v \<mapsto> a)) x = Some a" by simp
    from A1 and A2 have "t = t1" by simp
    with F1 and valOK show ?thesis by fast
  next
    assume A2: "x \<noteq> v"
    hence F1: "(r (v \<mapsto> a)) x = r x" by simp
    from A1 and A2 have F2: "(e (v\<mapsto>t)) x = e x" by simp
    with A1 have F3: "e x = Some t1" by simp
    with envOK obtain a1 where "r x = Some a1 \<and> (a1,t1) \<in> valType"
                                                         using getVar by fast
    with F1 show ?thesis by simp
  qed
qed

(* Consing instructions are OK *)
lemma Cons_steps:
assumes instrOK: "(e,Cons v0 v1 v,e1) \<in> checkInstr pt"
    and nextOK:  "(e1,i) \<in> checkBlock pt"
    and envOK:   "envType r e"
shows            "steps pt p r (Cons v0 v1 v \<guillemotright> i)"
proof -
  from instrOK
    obtain t0 t1 t where tV0:    "e v0 = Some t0"
                     and tV1:    "e v1 = Some t1"
                     and tV:     "lub (TList t0) t1 = TList t"
                     and e1_def: "e1 = e (v \<mapsto> TCons t)"
      by (rule checkInstr_Cons,simp)

  from envOK and tV0
    obtain a0 where A0:  "r v0 = Some a0"
                and tA0: "(a0,t0) \<in> valType" using getVar by fast
  from envOK and tV1
    obtain a1 where A1:  "r v1 = Some a1"
                and tA1: "(a1,t1) \<in> valType" using getVar by fast
  let ?r1 = "r(v \<mapsto> Node a0 a1)"

  from A0 and A1
    have Step: "((r, Cons v0 v1 v \<guillemotright> i),(?r1,i)) \<in> step p" by (rule step.Cons)
    have resType: "(Node a0 a1,TCons t) \<in> valType"
    proof
      from tV and lub_sub_left [of "TList t0" t1]
        have "(TList t0, TList t) \<in> sub" by simp
        hence "(t0,t) \<in> sub" by fast
        with tA0 show "(a0,t) \<in> valType" using cast by fast

     from tV and lub_sub_right [of t1 "TList t0"]
       have "(t1,TList t) \<in> sub" by simp
       with tA1 show "(a1, TList t) \<in> valType" using cast by fast
   qed

   from envOK resType and e1_def have "envType ?r1 e1" using updEnv by simp
   with nextOK and Step show ?thesis by auto
qed

(* Fetching instructions are OK *)
lemma Fetch_steps:
assumes instrOK: "(e,FetchField v0 f v,e1) \<in> checkInstr pt"
    and nextOK:  "(e1,i) \<in> checkBlock pt"
    and envOK:   "envType r e"
shows "steps pt p r (FetchField v0 f v \<guillemotright> i)"
proof -
  from instrOK
    obtain t where tV0:    "e v0 = Some (TCons t)"
               and e1_def: "e1 = e (v \<mapsto> if f = Fst then t else TList t )"
    by (rule checkInstr_FetchField,simp)
  from envOK and tV0
    obtain a0 a1 where A:   "r v0 = Some (Node a0 a1)"
                   and tA0: "(a0,t) \<in> valType"
                   and tA1: "(a1,TList t) \<in> valType"
                                  using getVar by fast
  let ?r1 = "r (v \<mapsto> if f = Fst then a0 else a1)"
  from A have Step: "((r,FetchField v0 f v \<guillemotright> i),(?r1,i)) \<in> step p"
                                            by (rule step.Fetch)
  from envOK tA0 tA1 and e1_def have "envType ?r1 e1" using updEnv by simp
  with nextOK and Step show ?thesis by auto
qed

(* Branching instructions for Cons are OK *)
lemma Branch_Node_steps:
assumes nextOK: "(e,i) \<in> checkBlock pt"
    and envOK:  "envType r e"
    and isNode: "r v = Some (Node a0 a1)"
shows "steps pt p r (BranchIfNil v l \<guillemotright> i)"
proof -
  have Step: "((r,BranchIfNil v l \<guillemotright> i),(r,i)) \<in> step p" by (rule step.BranchNot)
  with prems show ?thesis by (simp, fast)
qed

(* Branching instructions for Nil are OK *)
lemma Branch_Null_steps:
assumes progOK: "checkProg pt p"
    and envOK:  "envType r e"
    and isNull: "r v = Some Null"
    and labOK:  "pt l = Some e1"
    and subEnv: "subEnv e e1"
shows "steps pt p r (BranchIfNil v l \<guillemotright> i)"
proof -
 from progOK labOK
    obtain k where tgtCode: "p l = Some k"
               and tgtOK:   "(e1,k) \<in> checkBlock pt" using getCode by fast
  from isNull tgtCode
    have Step: "((r,BranchIfNil v l \<guillemotright> i),(r,k)) \<in> step p"
     by (rule step.BranchYes)
  from envOK subEnv have "envType r e1" using castEnv by fast
  with Step tgtOK show ?thesis by (simp,fast)
qed

(* Branching instructiosn are OK *)
lemma Branch_steps:
assumes progOK:  "checkProg pt p"
    and instrOK: "(e,BranchIfNil v l,e1) \<in> checkInstr pt"
    and nextOK:  "(e1,i) \<in> checkBlock pt"
    and envOK:   "envType r e"
shows "steps pt p r (BranchIfNil v l \<guillemotright> i)"
using instrOK proof (rule checkInstr_BranchIfNil)
  fix t assume "e v = Some (TCons t)" and "e1 = e"
  with envOK obtain a0 a1 where "r v = Some (Node a0 a1)" using getVar by fast
  with prems show ?thesis using Branch_Node_steps by fast
next
  fix e2 assume "e v = Some TNil" "pt l = Some e2" "subEnv e e2"
  with envOK have "r v = Some Null" using getVar by fast
  with prems show ?thesis using Branch_Null_steps by fast
next
  fix e2 t assume varOK:  "e v = Some (TList t)"
              and labOK:  "pt l = Some e2"
              and subEnv: "subEnv (e(v \<mapsto> TNil)) e2"
              and e1_def: "e1 = e(v \<mapsto> TCons t)"
  from envOK varOK
    obtain a where A:  "r v = Some a"
               and tA: "(a,TList t) \<in> valType"  using getVar by fast
  show ?thesis using tA
  proof (rule Val_TList)
    fix x xs assume A_def:"a = Node x xs"
                and tX:   "(x,t) \<in> valType"
                and tXS:  "(xs,TList t) \<in> valType"
    hence A_type: "(a,TCons t) \<in> valType" by fast
    have envOK: "envType r e1"
    proof -
      from envOK A_type have"envType (r(v\<mapsto>a)) (e (v \<mapsto> TCons t))"
        using updEnv by simp
      moreover from A have "r(v\<mapsto>a) = r" using map_upd_triv by fast
      ultimately show ?thesis using e1_def by simp
    qed

    from A A_def have "r v = Some (Node x xs)" by simp
    with nextOK envOK show ?thesis by (rule Branch_Node_steps)
  next
    assume Null: "a = Null"
    with A have isNull: "r v = Some Null" by simp
    have envOK: "envType r (e (v \<mapsto> TNil))"
    proof -
      from envOK have "envType (r (v \<mapsto> Null)) (e (v \<mapsto> TNil))"
        using updEnv by fast
      moreover from isNull have "r (v \<mapsto> Null) = r" by (rule map_upd_triv)
      ultimately show ?thesis by simp
    qed
    from progOK envOK isNull labOK subEnv
     show ?thesis by (rule Branch_Null_steps)
  qed
qed

(* Sequencing instructions are OK *)
lemma Seq_steps:
assumes instrOK: "(e1,i1\<guillemotright>i2,e3) \<in> checkInstr pt"
    and nextOK:  "(e3,i3) \<in> checkBlock pt"
    and envOK:   "envType r e1"
shows   "steps pt p r ((i1 \<guillemotright> i2) \<guillemotright> i3)"
proof -
  from instrOK obtain e2 where step1: "(e1,i1,e2) \<in> checkInstr pt"
                           and step2: "(e2,i2,e3) \<in> checkInstr pt"
               by (rule checkInstr_Seq,simp)
  from step2 nextOK have "(e2, i2\<guillemotright>i3) \<in> checkBlock pt" by fast
  with step1 have "(e1,i1\<guillemotright>(i2\<guillemotright>i3)) \<in> checkBlock pt" by fast
  with envOK have "(r,i1\<guillemotright>i2\<guillemotright>i3) \<in> TypedState pt" by (simp,fast)
  moreover have "( (r,(i1\<guillemotright>i2)\<guillemotright>i3), (r,i1\<guillemotright>i2\<guillemotright>i3)) \<in> step p" by (rule step.Seq)
  ultimately show ?thesis by (simp,fast)
qed

(* In well typed programs we can either step, or we have halted. *)
lemma step_or_halt:
assumes progOK:  "checkProg pt p"
    and blockOK: "(e,i) \<in> checkBlock pt"
    and envOK:   "envType r e"
shows "steps pt p r i \<or> i = Halt"
using blockOK proof (rule checkBlock.cases)
  fix e1 assume "(e,i) = (e1,Halt)" hence "i = Halt" by simp thus ?thesis ..
next
  fix e1 e2 l assume "(e,i) = (e1,Jump l)"
                 and "pt l = Some e2"
                 and "subEnv e1 e2"
  with progOK envOK show ?thesis using Jump_steps by fast
next
  fix e1 e2 i1 i2 assume shape: "(e,i) = (e1,i1 \<guillemotright> i2)"
                     and instrOK: "(e1,i1,e2) \<in> checkInstr pt"
                     and nextOK:  "(e2,i2) \<in> checkBlock pt"
  show ?thesis
  proof (cases i1)
  case BranchIfNil with prems show ?thesis using Branch_steps by fast next
  case FetchField with prems show ?thesis using Fetch_steps by fast next
  case Cons with prems show ?thesis using Cons_steps by fast next
  case Seq with prems show ?thesis using Seq_steps by simp next
  case Halt with instrOK show ?thesis
        apply simp by (rule checkInstr_Halt,simp) next
  case Jump with instrOK show ?thesis
        apply simp by (rule checkInstr_Jump,simp)
 qed
qed

(* If a program is well-typed, then it will run. *)
theorem soundness:
assumes progOK: "checkProg pt p"
shows "runs p"
proof -
  from progOK have "pt 0 = Some initTEnv" using progOK_entry by fast
  then obtain entry where entry_def: "p 0 = Some entry"
                      and blockOK:   "(initTEnv,entry) \<in> checkBlock pt"
       using progOK getCode by fast
  have envOK: "envType [0\<mapsto>Null] initTEnv" by (simp add: envType_def, fast)
  have "([0\<mapsto>Null], entry) \<in> goodState p"
  proof (rule goodState.coinduct)
    from envOK blockOK show "([0\<mapsto>Null],entry) \<in> TypedState pt" by (simp,fast)

    fix z assume "z \<in> TypedState pt"
    then obtain r i e where "z = (r,i)"
                        and "(e,i) \<in> checkBlock pt"
                        and "envType r e" by (simp,fast)
      with prems have "steps pt p r i \<or> i = Halt" using step_or_halt by fast
      thus "(\<exists>s1 s2. z = s1 \<and> (s1, s2) \<in> step p
                            \<and> s2 \<in> TypedState pt \<union> goodState p)
          \<or> (\<exists>r. z = (r, Halt))" using prems by simp
  qed
  with entry_def show "runs p" by (simp add: runs_def)
qed

end


section\<open>Tangle moves and Kauffman bracket\<close>

theory Linkrel_Kauffman
imports Computations
begin

lemma mat1_vert_wall_left:
assumes "is_tangle_diagram b"
shows
"rat_poly.matrix_mult  (blockmat (make_vert_block (nat (domain_wall b)))) (kauff_mat b)
             = (kauff_mat b)"
proof-
 have "mat (2^(nat (domain_wall b))) (length (kauff_mat b)) (kauff_mat b)"
           by (metis assms matrix_kauff_mat)
 moreover have "(blockmat (make_vert_block (nat (domain_wall b))))
                       = mat1 (2^(nat (domain_wall b)))"
               using make_vert_block_map_blockmat by auto
 ultimately show ?thesis by (metis blockmat_make_vert mat1_mult_left prop_make_vert_equiv(1))
qed

lemma mat1_vert_wall_right:
assumes "is_tangle_diagram b"
shows
"rat_poly.matrix_mult  (kauff_mat b) (blockmat (make_vert_block (nat (codomain_wall b))))
             = (kauff_mat b)"
proof-
 have "mat (rat_poly.row_length (kauff_mat b)) (2^(nat (codomain_wall b))) (kauff_mat b)"
           by (metis assms matrix_kauff_mat)
 moreover have "(blockmat (make_vert_block (nat (codomain_wall b))))
                       = mat1 (2^(nat (codomain_wall b)))"
          using make_vert_block_map_blockmat by auto
 ultimately show ?thesis by (metis mat1_rt_mult)
qed

lemma compress_top_inv:"(compress_top w1 w2) \<Longrightarrow> kauff_mat w1 = kauff_mat w2"
proof-
 assume assm:"compress_top w1 w2"
 have " \<exists>B.((w1 = (basic (make_vert_block (nat (domain_wall B))))\<circ> B)
                              \<and>(w2 = (B \<circ> (basic ([]))))\<and>(codomain_wall B = 0)
          \<and>(is_tangle_diagram B))"
        using compress_top_def assm by auto
 then obtain B where "(w1 = (basic (make_vert_block (nat (domain_wall B))))\<circ> B)
                              \<and>(w2 = (B \<circ> (basic ([]))))\<and>(codomain_wall B = 0)\<and>(is_tangle_diagram B)"
        by auto
 then have 1:"(w1 = (basic (make_vert_block (nat (domain_wall B))))\<circ> B)
                         \<and>(w2 = (B \<circ> (basic ([]))))\<and>(codomain_wall B = 0)\<and>(is_tangle_diagram B)"
        by auto
 then have "kauff_mat(w1) = (kauff_mat ((basic (make_vert_block (nat (domain_wall B))))\<circ> B))"
        by auto
 moreover then have "... = kauff_mat ((make_vert_block (nat (domain_wall B)))*B)"
        by auto
 moreover then have "... = rat_poly.matrix_mult (blockmat (make_vert_block (nat (domain_wall B))))
                                    (kauff_mat B)"
        by auto
 moreover then have "... = (kauff_mat B)"
        using 1 mat1_vert_wall_left by (metis)
 ultimately have "kauff_mat(w1) = kauff_mat B"
        by auto
 moreover have "kauff_mat w2 = kauff_mat B"
        using 1 by (metis left_mat_compose)
 ultimately show ?thesis by auto
qed

lemma domain_make_vert_int:"(n \<ge> 0) \<Longrightarrow> (domain_block (make_vert_block (nat n)))
                      = n"
 using domain_make_vert by auto

lemma compress_bottom_inv:"(compress_bottom w1 w2) \<Longrightarrow> kauff_mat w1 = kauff_mat w2"
proof-
 assume assm:"compress_bottom w1 w2"
 have "\<exists>B.((w1 = B \<circ> (basic (make_vert_block (nat (codomain_wall B)))))
                              \<and>(w2 = ((basic ([]) \<circ> B)))\<and>(domain_wall B = 0)
                               \<and>(is_tangle_diagram B))"
     using compress_bottom_def assm by auto
 then obtain B where "((w1 = B \<circ> (basic (make_vert_block (nat (codomain_wall B)))))
                              \<and>(w2 = ((basic ([]) \<circ> B)))\<and>(domain_wall B = 0)
                               \<and>(is_tangle_diagram B))"
     by auto
 then have 1:"((w1 = B \<circ> (basic (make_vert_block (nat (codomain_wall B)))))
                              \<and>(w2 = ((basic ([]) \<circ> B)))\<and>(domain_wall B = 0)
                               \<and>(is_tangle_diagram B))"
     by auto
 then have "kauff_mat(w1) = (kauff_mat ( B \<circ> (basic (make_vert_block (nat (codomain_wall B))))))"
     by auto
  moreover then have "... = rat_poly.matrix_mult (kauff_mat B)
                                    (kauff_mat (basic (make_vert_block (nat (codomain_wall B)))))"
  proof-
   have "is_tangle_diagram B"
         using 1 by auto
   moreover have "is_tangle_diagram  (basic (make_vert_block (nat (codomain_wall B))))"
         using is_tangle_diagram.simps by auto
   moreover have "codomain_wall B = domain_wall (basic (make_vert_block (nat (codomain_wall B))))"
   proof-
    have "codomain_wall B \<ge> 0"
     apply (induct B)
     by (auto) (metis codomain_block_nonnegative)
    then have "domain_block (make_vert_block (nat (codomain_wall B)))
                     = codomain_wall B"
              using domain_make_vert_int by auto
    then show ?thesis unfolding domain_wall.simps(1)  by auto
   qed
  ultimately show ?thesis using tangle_compose_matrix by auto
 qed
 moreover then have  "... = rat_poly.matrix_mult (kauff_mat B)
                                    (blockmat (make_vert_block (nat (codomain_wall B))))"
     using kauff_mat.simps(1) tangle_compose_matrix  by auto
 moreover then have "... = (kauff_mat B)"
     using 1 mat1_vert_wall_right by auto
 ultimately have "kauff_mat(w1) = kauff_mat B"
     by auto
 moreover have "kauff_mat w2 = kauff_mat B"
     using 1 by (metis right_mat_compose)
 ultimately show ?thesis by auto
qed

theorem compress_inv:"compress w1 w2 \<Longrightarrow> (kauff_mat w1 = kauff_mat w2)"
 unfolding compress_def using compress_bottom_inv compress_top_inv
 by auto

lemma striaghten_topdown_computation:"kauff_mat ((basic ([vert,cup]))\<circ>(basic ([cap,vert])))
                  =  kauff_mat ((basic ([vert]))\<circ>(basic ([vert])))"
 apply(simp add:kauff_mat_def)
 apply(simp add:mat_multI_def)
 apply(simp add:matT_vec_multI_def)
 apply(auto simp add:replicate_def rat_poly.row_length_def)
 apply(auto simp add:scalar_prod)
 apply (auto simp add:inverse1 inverse2)
 done

theorem straighten_topdown_inv:"straighten_topdown w1 w2 \<Longrightarrow> (kauff_mat w1) = (kauff_mat w2)"
 unfolding straighten_topdown_def using striaghten_topdown_computation by auto

lemma striaghten_downtop_computation:"kauff_mat ((basic ([cup,vert]))\<circ>(basic ([vert,cap])))
                  =  kauff_mat ((basic ([vert]))\<circ>(basic ([vert])))"
 apply(simp add:kauff_mat_def)
 apply(simp add:mat_multI_def)
 apply(simp add:matT_vec_multI_def)
 apply(auto simp add:replicate_def rat_poly.row_length_def)
 apply(auto simp add:scalar_prod)
 apply (auto simp add:inverse1 inverse2)
 done

theorem straighten_downtop_inv:"straighten_downtop w1 w2 \<Longrightarrow> (kauff_mat w1) = (kauff_mat w2)"
 unfolding straighten_downtop_def using striaghten_downtop_computation by auto

theorem straighten_inv:"straighten w1 w2 \<Longrightarrow> (kauff_mat w1) = (kauff_mat w2)"
 unfolding straighten_def using straighten_topdown_inv straighten_downtop_inv by auto

(*swing relations*)

lemma kauff_mat_swingpos:
 "kauff_mat (r_over_braid) = kauff_mat (l_over_braid)"
 apply (simp)
 apply(simp add:mat_multI_def)
 apply(simp add:matT_vec_multI_def)
 apply(auto simp add:replicate_def rat_poly.row_length_def)
 apply(auto simp add:scalar_prod)
 apply(auto simp add:computation_swingpos)
 done

lemma swing_pos_inv:"swing_pos w1 w2 \<Longrightarrow> (kauff_mat w1) = (kauff_mat w2)"
 unfolding swing_pos_def using kauff_mat_swingpos by auto

lemma kauff_mat_swingneg:
"kauff_mat (r_under_braid) = kauff_mat (l_under_braid)"
 apply (simp)
 apply(simp add:mat_multI_def)
 apply(simp add:matT_vec_multI_def)
 apply(auto simp add:replicate_def rat_poly.row_length_def)
 apply(auto simp add:scalar_prod)
 apply(auto simp add:computation_swingneg)
 done

lemma swing_neg_inv:"swing_neg w1 w2 \<Longrightarrow> (kauff_mat w1) = (kauff_mat w2)"
 unfolding swing_neg_def using kauff_mat_swingneg by auto

theorem swing_inv:
"swing w1 w2 \<Longrightarrow> (kauff_mat w1) = (kauff_mat w2)"
 unfolding swing_def using swing_pos_inv swing_neg_inv by auto

lemma rotate_topneg_kauff_mat:"kauff_mat ((basic [vert,under])\<circ>(basic [cap, vert]))
                      =  kauff_mat ((basic [over,vert])\<circ>(basic [vert,cap]))"
 apply(simp add:mat_multI_def)
 apply(simp add:matT_vec_multI_def)
 apply(auto simp add:replicate_def rat_poly.row_length_def)
 apply(auto simp add:scalar_prod)
 apply(simp add:computation_toppos)
 done

lemma rotate_topneg_inv:"rotate_topneg w1 w2 \<Longrightarrow> (kauff_mat w1) = (kauff_mat w2)"
 unfolding rotate_topneg_def using rotate_topneg_kauff_mat by auto

lemma rotate_downpos_kauff_mat:
 "kauff_mat ((basic [cup,vert])\<circ>(basic [vert,over]))= kauff_mat ((basic [vert,cup])\<circ>(basic [under,vert]))"
 apply(simp add:mat_multI_def)
 apply(simp add:matT_vec_multI_def)
 apply(auto simp add:replicate_def rat_poly.row_length_def)
 apply(auto simp add:scalar_prod)
 apply(simp add:computation_downpos)
 done

lemma rotate_downpos_inv:"rotate_downpos w1 w2 \<Longrightarrow> (kauff_mat w1) = (kauff_mat w2)"
 unfolding rotate_downpos_def using rotate_downpos_kauff_mat by auto

lemma rotate_downneg_kauff_mat:
 "kauff_mat ((basic [cup,vert])\<circ>(basic [vert,under]))= kauff_mat ((basic [vert,cup])\<circ>(basic [over,vert]))"
 apply(simp add:mat_multI_def)
 apply(simp add:matT_vec_multI_def)
 apply(auto simp add:replicate_def rat_poly.row_length_def)
 apply(auto simp add:scalar_prod)
 apply(simp add:computation_downpos)
 done

lemma rotate_downneg_inv:"rotate_downneg w1 w2 \<Longrightarrow> (kauff_mat w1) = (kauff_mat w2)"
 unfolding rotate_downneg_def using rotate_downneg_kauff_mat by auto

(*the matrix is an invariant under rotation *)
theorem rotate_inv:"rotate w1 w2 \<Longrightarrow> (kauff_mat w1) = (kauff_mat w2)"
 unfolding rotate_def using rotate_downneg_inv rotate_downpos_inv rotate_topneg_inv
           rotate_toppos_inv by auto

(*framed_uncross begins*)

lemma positive_flip_kauff_mat:
 "kauff_mat (left_over) = kauff_mat (right_over)"
 apply(simp add:mat_multI_def)
 apply(simp add:matT_vec_multI_def)
 apply(auto simp add:replicate_def rat_poly.row_length_def)
 apply(auto simp add:scalar_prod)
 using computatition_positive_flip apply auto[1]
 using computatition_positive_flip by auto

lemma uncross_positive_flip_inv: "uncross_positive_flip w1 w2 \<Longrightarrow> (kauff_mat w1) = (kauff_mat w2)"
 unfolding uncross_positive_flip_def using  positive_flip_kauff_mat by auto

lemma negative_flip_kauff_mat: "kauff_mat (left_under) = kauff_mat (right_under)"
 apply(simp add:mat_multI_def)
 apply(simp add:matT_vec_multI_def)
 apply(auto simp add:replicate_def rat_poly.row_length_def)
 apply(auto simp add:scalar_prod)
 using computation_negative_flip apply auto
 done

lemma uncross_negative_flip_inv: "uncross_negative_flip w1 w2 \<Longrightarrow> (kauff_mat w1) = (kauff_mat w2)"
 unfolding uncross_negative_flip_def using  negative_flip_kauff_mat by auto

theorem framed_uncross_inv:"(framed_uncross w1 w2) \<Longrightarrow> (kauff_mat w1) = (kauff_mat w2)"
 unfolding framed_uncross_def using uncross_negative_flip_inv uncross_positive_flip_inv
 by auto

(*pull begins here*)

lemma  pos_neg_kauff_mat:
"kauff_mat ((basic [over]) \<circ> (basic [under]))
                    = kauff_mat ((basic [vert,vert]) \<circ> (basic [vert,vert])) "
 apply(simp add:mat_multI_def)
 apply(simp add:matT_vec_multI_def)
 apply(auto simp add:replicate_def rat_poly.row_length_def)
 apply(auto simp add:scalar_prod)
 apply(auto simp add:inverse1 inverse2)
 apply(auto simp add:computation_pull_pos_neg)
 done

lemma pull_posneg_inv: "pull_posneg w1 w2 \<Longrightarrow> (kauff_mat w1) = (kauff_mat w2)"
 unfolding pull_posneg_def using  pos_neg_kauff_mat by auto

lemma  neg_pos_kauff_mat:"kauff_mat ((basic [under]) \<circ> (basic [over]))
   = kauff_mat ((basic [vert,vert]) \<circ> (basic [vert,vert])) "
 apply(simp add:mat_multI_def)
 apply(simp add:matT_vec_multI_def)
 apply(auto simp add:replicate_def rat_poly.row_length_def)
 apply(auto simp add:scalar_prod)
 apply(auto simp add:inverse1 inverse2)
 using computation_pull_pos_neg by (simp add: computation_downpos)

lemma pull_negpos_inv:"pull_negpos w1 w2 \<Longrightarrow> (kauff_mat w1) = (kauff_mat w2)"
 unfolding pull_negpos_def using neg_pos_kauff_mat by auto

theorem pull_inv:"pull w1 w2 \<Longrightarrow> (kauff_mat w1) = (kauff_mat w2)"
 unfolding pull_def using pull_posneg_inv pull_negpos_inv by auto

theorem slide_inv:"slide w1 w2 \<Longrightarrow> (kauff_mat w1 = kauff_mat w2)"
proof-
 assume assm:"slide w1 w2"
 have " \<exists>B.((w1 = ((basic (make_vert_block (nat (domain_block B))))\<circ>(basic B)))
               \<and>(w2 = ((basic B)\<circ>(basic (make_vert_block (nat (codomain_block B))))))
               \<and> ((domain_block B) \<noteq> 0))"
       using slide_def assm  by auto
 then obtain B where  "((w1 = ((basic (make_vert_block (nat (domain_block B))))\<circ>(basic B)))
               \<and>(w2 = ((basic B)\<circ>(basic (make_vert_block (nat (codomain_block B))))))
               \<and> ((domain_block B) \<noteq> 0))" by auto
 then have 1:"((w1 = ((basic (make_vert_block (nat (domain_block B))))\<circ>(basic B)))
               \<and>(w2 = ((basic B)\<circ>(basic (make_vert_block (nat (codomain_block B))))))
               \<and> ((domain_block B) \<noteq> 0))"
       by auto
 have "kauff_mat w1 = kauff_mat (basic B)"
 proof-
  have s1:"mat (2^(nat (domain_block B))) (length (blockmat B)) (blockmat B)"
          by (metis matrix_blockmat row_length_domain_block)
  have "w1 = ((basic (make_vert_block (nat (domain_wall (basic B))))\<circ>(basic B)))"
          using 1 domain_wall.simps by auto
  then have "kauff_mat w1 = rat_poly.matrix_mult
                                     (kauff_mat (basic (make_vert_block (nat (domain_wall (basic B))))))
                                      (kauff_mat (basic B))"
          using tangle_compose_matrix is_tangle_diagram.simps
          by (metis compose_Nil kauff_mat.simps(1) kauff_mat.simps(2))
  moreover then have "... =  rat_poly.matrix_mult  (mat1 (2^(nat (domain_block B)))) (blockmat B)"
          using kauff_mat.simps(1) domain_wall.simps(1) by (metis make_vert_block_map_blockmat)
  moreover have "... = (blockmat B)"
          using s1 mat1_mult_left by (metis make_vert_equiv_mat prop_make_vert_equiv(1))
  ultimately show ?thesis by auto
 qed
 moreover have "kauff_mat w2 = kauff_mat (basic B)"
  proof-
   have s1:"mat (2^(nat (domain_block B))) (2^(nat (codomain_block B))) (blockmat B)"
            by (metis length_codomain_block matrix_blockmat row_length_domain_block)
   have "w2  = ((basic B) \<circ>(basic (make_vert_block (nat (codomain_wall (basic B))))))"
           using 1 domain_wall.simps by auto
   then have "kauff_mat w2 =
                         rat_poly.matrix_mult
                            (kauff_mat (basic B))
                            (kauff_mat (basic (make_vert_block (nat (codomain_wall (basic B))))))"
           using tangle_compose_matrix is_tangle_diagram.simps
           by (metis compose_Nil kauff_mat.simps(1) kauff_mat.simps(2))
   moreover then have "... =  rat_poly.matrix_mult  (blockmat B) (mat1 (2^(nat (codomain_block B)))) "
                             using kauff_mat.simps(1) domain_wall.simps(1)
           by (metis blockmat_make_vert codomain_wall.simps(1) make_vert_equiv_mat)
   moreover have "... = (blockmat B)"
           using s1  by (metis mat1_rt_mult)
   ultimately show ?thesis by auto
  qed
  ultimately show ?thesis by auto
qed

theorem framed_linkrel_inv:"framed_linkrel w1 w2 \<Longrightarrow> (kauff_mat w1)= (kauff_mat w2)"
 unfolding framed_linkrel_def
 apply(auto)
 using framed_uncross_inv pull_inv straighten_inv  swing_inv rotate_inv compress_inv slide_inv
 by auto

end


section \<open>Galois Connections and Fusion Theorems \label{S:galois}\<close>

theory Galois_Connections
imports Refinement_Lattice
begin

text \<open>
  The concept of Galois connections is introduced here to prove the fixed-point fusion lemmas.
  The definition of Galois connections used is quite simple but encodes a lot of
  information.
  The material in this section is largely based on the work of the Eindhoven
  Mathematics of Program Construction Group \<^cite>\<open>"fixedpointcalculus1995"\<close>
  and the reader is referred to their work for a full explanation of this section.
\<close>

subsection \<open>Lower Galois connections\<close>

(* auxiliary lemma to prefer 2-element sets rather than disjunction *)
lemma Collect_2set [simp]:  "{F x |x. x = a \<or> x = b} = {F a, F b}"
  by auto

locale lower_galois_connections
begin

definition
  l_adjoint :: "('a::refinement_lattice \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a)" ("_\<^sup>\<flat>" [201] 200)
where
  "(F\<^sup>\<flat>) x \<equiv> \<Sqinter>{y. x \<sqsubseteq> F y}"

lemma l_cancellation: "dist_over_inf F \<Longrightarrow> x \<sqsubseteq> (F \<circ> F\<^sup>\<flat>) x"
proof -
  assume dist: "dist_over_inf F"

  define Y where "Y = {F y | y. x \<sqsubseteq> F y}"
  define X where "X = {x}"

  have "(\<forall> y \<in> Y. (\<exists> x \<in> X. x \<sqsubseteq> y))" using X_def Y_def CollectD singletonI by auto
  then have "\<Sqinter> X \<sqsubseteq> \<Sqinter> Y" by (simp add: Inf_mono)
  then have "x \<sqsubseteq> \<Sqinter>{F y | y. x \<sqsubseteq> F y}" by (simp add: X_def Y_def)
  then have "x \<sqsubseteq> F (\<Sqinter>{y. x \<sqsubseteq> F y})" by (simp add: dist le_INF_iff)
  thus ?thesis by (metis comp_def l_adjoint_def)
qed

lemma l_galois_connection: "dist_over_inf F \<Longrightarrow> ((F\<^sup>\<flat>) x \<sqsubseteq> y) \<longleftrightarrow> (x \<sqsubseteq> F y)"
proof
  assume "x \<sqsubseteq> F y"
  then have "\<Sqinter>{y. x \<sqsubseteq> F y} \<sqsubseteq> y" by (simp add: Inf_lower)
  thus "(F\<^sup>\<flat>) x \<sqsubseteq> y" by (metis l_adjoint_def)
next
  assume dist: "dist_over_inf F" then have monoF: "mono F" by (simp add: dist_inf_mono)
  assume "(F\<^sup>\<flat>) x \<sqsubseteq> y" then have a: "F ((F\<^sup>\<flat>) x) \<sqsubseteq> F y" by (simp add: monoD monoF)
  have "x \<sqsubseteq> F ((F\<^sup>\<flat>) x)" using dist l_cancellation by simp
  thus "x \<sqsubseteq> F y" using a by auto
qed

lemma v_simple_fusion: "mono G \<Longrightarrow> \<forall>x. ((F \<circ> G) x \<sqsubseteq> (H \<circ> F) x) \<Longrightarrow> F (gfp G) \<sqsubseteq> gfp H"
  by (metis comp_eq_dest_lhs gfp_unfold gfp_upperbound)

subsection \<open>Greatest fixpoint fusion theorems\<close>

text \<open>
  Combining lower Galois connections and greatest fixed points allows
  elegant proofs of the weak fusion lemmas.
\<close>

theorem fusion_gfp_geq:
  assumes monoH: "mono H"
  and distribF: "dist_over_inf F"
  and comp_geq: "\<And>x. ((H \<circ> F) x \<sqsubseteq> (F \<circ> G) x)"
  shows "gfp H \<sqsubseteq> F (gfp G)"
proof -
  have "(gfp H) \<sqsubseteq> (F \<circ> F\<^sup>\<flat>) (gfp H)" using distribF l_cancellation by simp
  then have "H (gfp H) \<sqsubseteq> H ((F \<circ> F\<^sup>\<flat>) (gfp H))" by (simp add: monoD monoH)
  then have "H (gfp H) \<sqsubseteq> F ((G \<circ> F\<^sup>\<flat>) (gfp H))" using comp_geq by (metis comp_def refine_trans)
  then have "(F\<^sup>\<flat>) (H (gfp H)) \<sqsubseteq> (G \<circ> F\<^sup>\<flat>) (gfp H)" using distribF by (metis (mono_tags) l_galois_connection)
  then have "(F\<^sup>\<flat>) (gfp H) \<sqsubseteq> (gfp G)" by (metis comp_apply gfp_unfold gfp_upperbound monoH)
  thus "gfp H \<sqsubseteq> F (gfp G)" using distribF by (metis (mono_tags) l_galois_connection)
qed

theorem fusion_gfp_eq:
  assumes monoH: "mono H" and monoG: "mono G"
  and distF: "dist_over_inf F"
  and fgh_comp: "\<And>x. ((F \<circ> G) x = (H \<circ> F) x)"
  shows "F (gfp G) = gfp H"
proof (rule antisym)
  show "F (gfp G) \<sqsubseteq> (gfp H)" by (metis fgh_comp le_less v_simple_fusion monoG)
next
  have "\<And>x. ((H \<circ> F) x \<sqsubseteq> (F \<circ> G) x)" using fgh_comp by auto
  then show "gfp H \<sqsubseteq> F (gfp G)" using monoH distF fusion_gfp_geq by blast
qed

end

subsection \<open>Upper Galois connections\<close>

locale upper_galois_connections
begin

definition
  u_adjoint :: "('a::refinement_lattice \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a)" ("_\<^sup>#" [201] 200)
where
  "(F\<^sup>#) x \<equiv> \<Squnion>{y. F y \<sqsubseteq> x}"

lemma dist_sup_mono:
  assumes distF: "dist_over_sup F"
  shows "mono F"
proof
  fix x :: 'a and y :: 'a
  assume "x \<sqsubseteq> y"
  then have "F y = F (x \<squnion> y)" by (simp add: le_iff_sup)
  also have "... = F x \<squnion> F y"
  proof -
    from distF
    have "F (\<Squnion>{x, y}) = \<Squnion>{F x, F y}" by (drule_tac x = "{x, y}" in spec, simp)
    then show "F (x \<squnion> y) = F x \<squnion> F y" by simp
  qed
  finally show "F x \<sqsubseteq> F y" by (metis le_iff_sup)
qed

lemma u_cancellation: "dist_over_sup F \<Longrightarrow> (F \<circ> F\<^sup>#) x \<sqsubseteq> x"
proof -
  assume dist: "dist_over_sup F"
  define Y where "Y = {F y | y. F y \<sqsubseteq> x}"
  define X where "X = {x}"

  have "(\<forall> y \<in> Y. (\<exists> x \<in> X. y \<sqsubseteq> x))" using X_def Y_def CollectD singletonI by auto
  then have "\<Squnion> Y \<sqsubseteq> \<Squnion> X" by (simp add: Sup_mono)
  then have "\<Squnion>{F y | y. F y \<sqsubseteq> x} \<sqsubseteq> x" by (simp add: X_def Y_def)
  then have "F (\<Squnion>{y. F y \<sqsubseteq> x}) \<sqsubseteq> x" using SUP_le_iff dist by fastforce
  thus ?thesis by (metis comp_def u_adjoint_def)
qed

lemma u_galois_connection: "dist_over_sup F \<Longrightarrow> (F x \<sqsubseteq> y) \<longleftrightarrow> (x \<sqsubseteq> (F\<^sup>#) y)"
proof
  assume dist: "dist_over_sup F" then have monoF: "mono F" by (simp add: dist_sup_mono)
  assume "x \<sqsubseteq> (F\<^sup>#) y" then have a: "F x \<sqsubseteq> F ((F\<^sup>#) y)" by (simp add: monoD monoF)
  have "F ((F\<^sup>#) y) \<sqsubseteq> y" using dist u_cancellation by simp
  thus "F x \<sqsubseteq> y" using a by auto
next
  assume "F x \<sqsubseteq> y"
  then have "x \<sqsubseteq> \<Squnion>{x. F x \<sqsubseteq> y}" by (simp add: Sup_upper)
  thus "x \<sqsubseteq> (F\<^sup>#) y" by (metis u_adjoint_def)
qed

lemma u_simple_fusion: "mono H \<Longrightarrow> \<forall>x. ((F \<circ> G) x \<sqsubseteq> (G \<circ> H) x) \<Longrightarrow> lfp F \<sqsubseteq> G (lfp H)"
  by (metis comp_def lfp_lowerbound lfp_unfold)

subsection \<open>Least fixpoint fusion theorems\<close>

text \<open>
  Combining upper Galois connections and least fixed points allows elegant proofs
  of the strong fusion lemmas.
\<close>

theorem fusion_lfp_leq:
  assumes monoH: "mono H"
  and distribF: "dist_over_sup F"
  and comp_leq: "\<And>x. ((F \<circ> G) x \<sqsubseteq> (H \<circ> F) x)"
  shows "F (lfp G) \<sqsubseteq> (lfp H)"
proof -
  have "((F \<circ> F\<^sup>#) (lfp H)) \<sqsubseteq> lfp H"  using distribF u_cancellation by simp
  then have "H ((F \<circ> F\<^sup>#) (lfp H)) \<sqsubseteq> H (lfp H)" by (simp add: monoD monoH)
  then have "F ((G \<circ> F\<^sup>#) (lfp H)) \<sqsubseteq> H (lfp H)" using comp_leq by (metis comp_def refine_trans)
  then have "(G \<circ> F\<^sup>#) (lfp H) \<sqsubseteq> (F\<^sup>#) (H (lfp H))" using distribF by (metis (mono_tags) u_galois_connection)
  then have "(lfp G) \<sqsubseteq> (F\<^sup>#) (lfp H)" by (metis comp_def def_lfp_unfold lfp_lowerbound monoH)
  thus "F (lfp G) \<sqsubseteq> (lfp H)" using distribF by (metis (mono_tags) u_galois_connection)
qed

theorem fusion_lfp_eq:
  assumes monoH: "mono H" and monoG: "mono G"
  and distF: "dist_over_sup F"
  and fgh_comp: "\<And>x. ((F \<circ> G) x = (H \<circ> F) x)"
  shows "F (lfp G) = (lfp H)"
proof (rule antisym)
  show "lfp H \<sqsubseteq> F (lfp G)" by (metis monoG fgh_comp eq_iff upper_galois_connections.u_simple_fusion)
next
  have "\<And>x. (F \<circ> G) x \<sqsubseteq> (H \<circ> F) x" using fgh_comp by auto
  then show "F (lfp G) \<sqsubseteq> (lfp H)" using monoH distF fusion_lfp_leq by blast
qed

end
end