(*  Author:     Bernhard Haeupler *)

section {* Some examples demonstrating the comm-ring method *}

theory Commutative_Ring_Ex
imports "../Commutative_Ring"
begin

lemma "4*(x::int)^5*y^3*x^2*3 + x*z + 3^5 = 12*x^7*y^3 + z*x + 243"
  by comm_ring

lemma "((x::int) + y)^2  = x^2 + y^2 + 2*x*y"
  by comm_ring

lemma "((x::int) + y)^3  = x^3 + y^3 + 3*x^2*y + 3*y^2*x"
  by comm_ring

lemma "((x::int) - y)^3  = x^3 + 3*x*y^2 + (-3)*y*x^2 - y^3"
  by comm_ring

lemma "((x::int) - y)^2  = x^2 + y^2 - 2*x*y"
  by comm_ring

lemma " ((a::int) + b + c)^2 = a^2 + b^2 + c^2 + 2*a*b + 2*b*c + 2*a*c"
  by comm_ring

lemma "((a::int) - b - c)^2 = a^2 + b^2 + c^2 - 2*a*b + 2*b*c - 2*a*c"
  by comm_ring

lemma "(a::int)*b + a*c = a*(b+c)"
  by comm_ring

lemma "(a::int)^2 - b^2 = (a - b) * (a + b)"
  by comm_ring

lemma "(a::int)^3 - b^3 = (a - b) * (a^2 + a*b + b^2)"
  by comm_ring

lemma "(a::int)^3 + b^3 = (a + b) * (a^2 - a*b + b^2)"
  by comm_ring

lemma "(a::int)^4 - b^4 = (a - b) * (a + b)*(a^2 + b^2)"
  by comm_ring

lemma "(a::int)^10 - b^10 =
  (a - b) * (a^9 + a^8*b + a^7*b^2 + a^6*b^3 + a^5*b^4 + a^4*b^5 + a^3*b^6 + a^2*b^7 + a*b^8 + b^9)"
  by comm_ring

end


theory T94
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. 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=4,timeout=86400]
oops
end


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


theory Buchi_Graph_Basic
imports Main "../../../Automatic_Refinement/Lib/Refine_Lib"
begin

text {* Specification of a reachable accepting cycle: *}
definition "has_acc_cycle E A v0 \<equiv> \<exists>v\<in>A. (v0,v)\<in>E\<^sup>* \<and> (v,v)\<in>E\<^sup>+"

text {* Specification of witness for accepting cycle *}
definition "is_acc_cycle E A v0 v r c
  \<equiv> v\<in>A \<and> path E v0 r v \<and> path E v c v \<and> c\<noteq>[]"

text {* Specification is compatible with existence of accepting cycle *}
lemma is_acc_cycle_eq:
  "has_acc_cycle E A v0 \<longleftrightarrow> (\<exists>v r c. is_acc_cycle E A v0 v r c)"
  unfolding has_acc_cycle_def is_acc_cycle_def
  by (auto elim!: rtrancl_is_path trancl_is_path
    intro: path_is_rtrancl path_is_trancl)

end


section {* Domain Semirings *}

theory Domain_Semiring
  imports "$AFP/Kleene_Algebra/Kleene_Algebra"
begin

subsection {* Domain Semirings *}

text {* It is important to prove a dual statement for range semirings
with each statement for domain semirings! Perhaps, in the future,
these dual statements will be generated\<dots> *}

text{* We only consider domain semirings over semirings (and dioids)
with one and zero. A more refined hierarchy can of course be
obtained. We have already defined domain over near semirings and
pre-semirings with and without units. All this should eventually be
included.  *}

class nabla_op =
  fixes nabla :: "'a \<Rightarrow> 'a" ("\<nabla>_" [90] 95)

class fdiamond_op =
  fixes fdiamond :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" ("\<bar> _ \<rangle> _" [50,90] 95)

class fbox_op =
  fixes fbox :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" ("\<bar> _ ] _" [50,90] 95)

class bdiamond_op =
  fixes bdiamond :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" ("\<langle> _ \<bar> _" [50,90] 95)

class bbox_op =
  fixes bbox :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" ("[ _ \<bar> _" [50,90] 95)

class a_op =
  fixes a :: "'a \<Rightarrow> 'a"

class d_op =
  fixes d :: "'a \<Rightarrow> 'a"

class r_op =
  fixes r :: "'a \<Rightarrow> 'a"

class ar_op =
  fixes ar :: "'a \<Rightarrow> 'a"

class domain_semiring = semiring_one_zero + plus_ord + d_op +
  assumes d1: "x+(d(x)\<cdot>x) = d(x)\<cdot>x"
  and d2: "d(x\<cdot>y) = d(x\<cdot>d(y))"
  and d3: "d(x)+1 = 1"
  and d4 [simp]: "d(0) = 0"
  and d5: "d(x+y) = d(x)+d(y)"
begin

text {* We first show that every domain semiring is "automatically"
idempotent, hence a dioid *}

subclass dioid_one_zero
proof
  fix x y z :: 'a
  show "x+x = x"
    by (metis add_commute local.d1 local.d3 local.distrib_right' local.mult_1_left)
qed

lemma d1_eq: "x = d(x)\<cdot>x"
  by (metis d1 d3 eq_iff less_eq_def mult_isor mult_onel)

lemma domain_invol: "d(d(x)) = d(x)"
  by (metis d1_eq d2 mult_assoc)

text {* The next lemma formulates the fixed point lemma without
sets. It states that $x$ is a domain element (of some element $y$ if
and only if $x=d(x)$. *}

lemma domain_fixed_point: "(\<exists>y.(x = d(y))) \<longleftrightarrow> x = d(x)"
  by (metis domain_invol)

text {* One can now use $x=d(x)$ for typing domain elements. The next
lemma shows that two different ways of typing domain elements are
equivalent *}

lemma type_conv: "\<forall>P.(\<forall>x.(x = d(x) \<longrightarrow> P(x))) \<longleftrightarrow> (\<forall>x.(P(d(x))))"
  by (metis domain_invol)

text {* We now continue proving properties. *}

lemma domain_1: "d(x\<cdot>y) \<le> d(x)"
  by (metis local.add_ub1 local.d2 local.d3 local.d5 local.distrib_left local.mult_oner)

lemma domain_subid: "x \<le> 1 \<longrightarrow> x \<le> d(x)"
  by (metis d1_eq mult_isol mult_oner)

lemma domain_very_strict: "d(x) = 0 \<longleftrightarrow> x = 0"
  by (metis d1_eq local.annil local.d4)

lemma domain_one [simp]: "d(1) = 1"
  by (metis d1_eq mult_oner)

lemma dom_subid: "d(x) \<le> 1"
  by (metis domain_1 domain_one mult_onel)

lemma domain_iso: "x \<le> y \<longrightarrow> d(x) \<le> d(y)"
  by (metis d5 less_eq_def)

lemma domain_subdist: "d(x) \<le> d(x+y)"
  by (metis domain_iso order_prop)

lemma domain_export: "d(d(x)\<cdot>y) = d(x)\<cdot>d(y)"
proof -
  have "d(d(x)\<cdot>y) \<le> d(x)\<cdot>d(y)"
    by (metis d1_eq dom_subid domain_1 domain_invol domain_iso local.mult_isol_var local.mult_isor local.mult_onel)
  thus ?thesis
    by (metis dom_subid domain_subid local.antisym_conv local.d2 local.dual_order.trans local.mult_isol local.mult_oner)
qed

text {* Metis takes very long *}

lemma dom_el_idemp: "d(x)\<cdot>d(x) = d(x)"
  by (metis d1_eq domain_export)

lemma dom_el_comm: "d(x)\<cdot>d(y) = d(y)\<cdot>d(x)"
    by (metis d1_eq d2 domain_1 domain_export mult_assoc mult_isor mult_onel antisym_conv)

text {* The next lemma shows that domain is a least left preserver; it
is the leas (domain) element for which the left hand side holds *}

lemma dom_llp: "x \<le> d(y)\<cdot>x \<longleftrightarrow> d(x) \<le> d(y)"
  by (metis add_comm d1_eq d3 domain_1 domain_invol less_eq_def mult_isor mult_onel)

lemma dom_weakly_local: "x\<cdot>y = 0 \<longleftrightarrow> x\<cdot>d(y) = 0"
  by (metis annil d1_eq d2 d4)

text {* We can now show that domain elements are closed under addition
and multiplication. This means that they form a subalgebra of the
domain semiring. *}

lemma dom_add_closed: "d(d(x)+d(y)) = d(x)+d(y)"
  by (metis d5 domain_invol)

lemma dom_mult_closed: "d(d(x)\<cdot>d(y)) = d(x)\<cdot>d(y)"
  by (metis d2 domain_export)

lemma dom_lb: "d(x)\<cdot>d(y) \<le> d(x)"
  by (metis domain_1 domain_export domain_invol)

lemma dom_glb: "d(x) \<le> d(y)\<cdot>d(z) \<longleftrightarrow> (d(x) \<le> d(y) \<and> d(x) \<le> d(z))"
  apply auto
  apply (metis dom_lb local.order.trans)
  apply (metis dom_el_comm dom_lb local.dual_order.trans)
  by (metis dom_el_idemp local.mult_isol_var)

text {* We have already shown that domain elements form a semilattice
under multiplication, and they form a semilattice under addition by
definition of dioids. We now show that the absorption laws hold. *}

lemma domain_absorption_1: "d(x)\<cdot>(d(x)+d(y)) = d(x)"
  by (metis add_comm  d1_eq d3 distrib_left domain_export mult_oner)

lemma domain_absorption_2: "d(x)+(d(x)\<cdot>d(y)) = d(x)"
  by (metis d1_eq distrib_left domain_absorption_1 domain_export)

text {* This proves that domain elements form a lattice. It follows
immediately from the semiring distributivity law that domain elements
form a distributive lattice. In every lattice, one of the
distributivity laws suffices for that. We now show the other
distributivity law explicitly. *}

lemma domain_distributivity: "d(x)+(d(y)\<cdot>d(z)) = (d(x)+d(y))\<cdot>(d(x)+d(z))"
proof -
  have "d(x)+(d(y)\<cdot>d(z)) \<le> (d(x)+d(y))\<cdot>(d(x)+d(z))"
    by (metis domain_absorption_1 local.add_comm local.add_idem' local.add_iso_var local.distrib_right local.subdistl)
  thus ?thesis
    by (smt add_assoc' d1_eq distrib_left distrib_right dom_el_comm domain_absorption_2 domain_export order_refl)
qed

text {* This should probably be made explicit with a sublocale statement *}

text {* Finally we relate domain elements with the order the meet semilattice way *}

lemma domain_order: "d(x) \<le> d(y) \<longleftrightarrow> d(x) = d(x)\<cdot>d(y)"
  by (metis dom_glb domain_export eq_iff)

end

section {* Antidomain Semirings *}

text {* In this setting, domain can be defined *}

class antidomain_semiring = semiring_one_zero + plus_ord + a_op +
  assumes a1: "(a x) \<cdot> x = 0"
  and a2: "a(x\<cdot>y)+a(x\<cdot>a(a(y))) = a(x\<cdot>a(a(y)))"
  and a3: "a(a(x))+a(x) = 1"

begin

text {* Definition of domain. *}

definition (in antidomain_semiring)
  antidomain_semiring_domain :: "'a \<Rightarrow> 'a" ("d")
  where "d(x) = a(a(x))"

text {* Again, every antidomain semiring is a dioid *}

subclass dioid
proof
  fix x y z :: 'a
  show "x+x = x"
    by (metis local.a1 local.a2 local.a3 local.add_zerol local.annir local.distrib_left local.mult_oner)
qed

lemma a_fixed_point: "\<forall>x.(a(x) = x \<longrightarrow> (\<forall>y.(y = 0)))"
  by (metis a1 a3 add_idem annil mult_onel)

lemma a_subid: "a(x) \<le> 1"
  by (metis a3 add_comm add_ub1)

text {* The next lemma shows that antidomain elements are greatest left annihilators *}

lemma a_gla: "a(x)\<cdot>y = 0 \<longleftrightarrow> a(x) \<le> a(y)"
proof -
 have "a(x)\<cdot>y = 0 \<longrightarrow> a(x)\<cdot>d(y) = 0"
   by (metis a1 a2 a3 add_comm add_zerol antidomain_semiring_domain_def less_eq_def mult_onel mult_oner order_prop)
  hence "a(x)\<cdot>y = 0 \<longrightarrow> a(x) \<le> a(y)"
    by (metis a3 a_subid add_zerol antidomain_semiring_domain_def distrib_left mult_isor mult_onel mult_oner)
  thus ?thesis
    by (metis a1 a3 add_lub distrib_right eq_iff less_eq_def mult_onel mult_oner order_prop)
qed

lemma a2_eq: "a(x\<cdot>y) = a(x\<cdot>d(y))"
  sorry (*
  by (metis a1 a3 a_gla add_zerol antidomain_semiring_domain_def distrib_right' mult_assoc mult_onel a2 add_comm less_eq_def
*)

lemma a_closure:  "d(a(x)) = a(x)"
  by (metis a2_eq antidomain_semiring_domain_def mult_onel)

lemma a_subdist: "a(x+y) \<le> a(x)"
  by (metis a_gla local.add_ub1 local.add_zeror distrib_left local.less_eq_def)

lemma a_idem: "a(x)\<cdot>a(x) = a(x)"
  by (metis a1 a3 add_zerol distrib_right mult_onel)

lemma a_1: "a(x) = 1 \<longrightarrow> x = 0"
  by (metis a1 mult_onel)

lemma a_3: "a(x)\<cdot>a(y)\<cdot>d(x+y) = 0"
 by (metis a2_eq a_gla a_subid local.add_comm local.distrib_left local.distrib_right local.less_eq_def local.mult_onel local.order_prop mult_assoc)

lemma a_add: "a(x)\<cdot>a(y) = a(x+y)"
proof -
  have  "a(x)\<cdot>a(y) = a(x)\<cdot>a(y)\<cdot>a(x+y)"
    sorry
  hence   "a(x)\<cdot>a(y) \<le> a(x+y)"
    by (metis a_subid mult_isor mult_onel order_trans)
  thus ?thesis
    by (metis a_idem a_subdist add_comm order_trans mult_isol mult_isor eq_iff)
qed

lemma a_export: "a(a(x)\<cdot>y) = d(x)+a(y)"
proof -
  have "a(a(x)\<cdot>y) = (a(a(x)\<cdot>y)\<cdot>d(y))+(a(a(x)\<cdot>y)\<cdot>a(y))"
    by (metis a3 add_comm antidomain_semiring_domain_def distrib_left mult_oner)
  hence "a(a(x)\<cdot>y) \<le> (a(a(x)\<cdot>y)\<cdot>d(y))+a(y)"
    by (metis a_add a_subdist add_commute local.add_iso)
  hence "a(a(x)\<cdot>y) \<le> (a(a(x)\<cdot>y)\<cdot>(a(x)+d(x))\<cdot>d(y))+a(y)"
    by (metis a3 add_comm antidomain_semiring_domain_def mult_oner)
  hence one: "a(a(x)\<cdot>y) \<le> (a(a(x)\<cdot>y)\<cdot>a(x)\<cdot>d(y))+(a(a(x)\<cdot>y)\<cdot>d(x)\<cdot>d(y))+a(y)"
    by (metis add_comm distrib_left distrib_right mult_assoc)
  have two: "(a(a(x)\<cdot>y)\<cdot>a(x)\<cdot>d(y)) = 0"
    by (metis a1 a2_eq mult_assoc)
  from one two have three:"a(a(x)\<cdot>y) \<le> (a(a(x)\<cdot>y)\<cdot>d(x)\<cdot>d(y))+a(y)"
    by (metis add_zerol)
  have four: "\<dots> \<le> d(x)+a(y)"
    by (metis a_add a_subdist add_assoc add_comm add_ub1 antidomain_semiring_domain_def less_eq_def)
  from three four have "a(a(x)\<cdot>y) \<le> d(x)+a(y)"
    by (metis order_trans)
  thus ?thesis
    sorry
qed

end

sublocale antidomain_semiring \<subseteq> domain_semiring "op +"  "op \<cdot>" "(1\<Colon>'a)" "(0\<Colon>'a)" "d" "op \<le>" "op <"

proof
  fix x y :: 'a
  have  "x = d(x)\<cdot>x"
    by (metis a1 a3 add_comm add_zerol antidomain_semiring_domain_def distrib_right mult_onel)
  thus "x+d(x)\<cdot>x = d(x)\<cdot>x"
    by (metis add_idem)
  show  "d(x\<cdot>y) = d(x\<cdot>d(y))"
    by (metis a2_eq antidomain_semiring_domain_def)
  show "d(x)+1 = 1"
    by (metis a_subid antidomain_semiring_domain_def less_eq_def)
  show  "d(0) = 0"
    by (metis a1 a3 a_export antidomain_semiring_domain_def mult_oner)
  show  "d(x+y) = d(x)+d(y)"
    by (metis a_add a_export antidomain_semiring_domain_def)
qed

text {* together with a-closure it now follows that antidomain
elements form distributive lattices *}

context antidomain_semiring
begin

lemma a_zero: "a(0) = 1"
  by (metis a3 add_zerol d4 antidomain_semiring_domain_def)

lemma a_one: "a(1) = 0"
  by (metis a1 mult_oner)

lemma a_comp_1: "d(x)\<cdot>a(x) = 0"
  by (metis a1 antidomain_semiring_domain_def)

lemma a_comp_2: "a(x)\<cdot>d(x) = 0"
  by (metis a1 dom_weakly_local)

text {* By the previous two lemmas it is now clear that antidomain algebras form a Boolean subalgebra *}

text {* perhaps we should make this explict with a sublocale statement
*}

lemma a_2_var: "a(x)\<cdot>d(y) = 0 \<longleftrightarrow> a(x) \<le> a(y)"
  by (metis a_gla dom_weakly_local)

lemma a_antitone: "x \<le> y \<longrightarrow> a(y) \<le> a(x)"
  by (metis a_subdist less_eq_def)

lemma a_de_morgan: "a(a(x)\<cdot>a(y)) = d(x+y)"
  by (metis a_add antidomain_semiring_domain_def)

lemma a_de_morgan_var_1: "a(a(x)\<cdot>a(y)) = d(x)+d(y)"
  by (metis a_export antidomain_semiring_domain_def)

lemma a_de_morgan_var_2: "a(a(x)+a(y)) = d(x)\<cdot>d(y)"
 by (metis a_add antidomain_semiring_domain_def)

lemma a_de_morgan_var_3: "a(d(x)+d(y)) =a(x)\<cdot>a(y)"
  by (metis a_add a_closure antidomain_semiring_domain_def)

lemma a_de_morgan_var_4: "a(d(x)\<cdot>d(y))=a(x)+a(y)"
  by (metis a_closure a_export antidomain_semiring_domain_def)

lemma a_comm: "a(x)\<cdot>a(y) = a(y)\<cdot>a(x)"
  by (metis a_add add_comm)

lemma a_4: "a(x) \<le> a(x\<cdot>y)"
  by (metis a1 a_gla annir mult_assoc)

lemma a_5: "a(d(x)) = a(x)"
  by (metis a_closure antidomain_semiring_domain_def)

lemma a_6: "a(d(x)\<cdot>y) = a(x)+a(y)"
  by (metis a_closure a_export antidomain_semiring_domain_def)

lemma a_7: "d(x)\<cdot>a(d(y)+d(z)) = d(x)\<cdot>a(y)\<cdot>a(z)"
  by (metis a_5 a_add d5 mult_assoc)

text {* The following two lemmas give the Galois connection of Heyting
algebras *}

lemma d_a_galois1: "d(x)\<cdot>a(y) \<le> d(z) \<longleftrightarrow> d(x) \<le> d(z)+d(y)"
  by (metis a_add a_gla add_assoc add_comm d5 antidomain_semiring_domain_def)

lemma d_a_galois2: "d(x)\<cdot>d(y) \<le> d(z) \<longleftrightarrow> d(x) \<le> d(z)+a(y)"
  by (metis a_closure d_a_galois1 antidomain_semiring_domain_def)

lemma d_cancellation_1: "d(x) \<le> d(y)+(d(x)\<cdot>a(y))"
  by (metis a1 a_add a_export a_gla antidomain_semiring_domain_def mult_assoc)

lemma d_cancellation_2: "(d(z)+d(y))\<cdot>a(y) \<le> d(z)"
  by (metis a_3 a_add a_export a_gla add_assoc' add_comm antidomain_semiring_domain_def)

text {* The next lemmas explicitly show that antidomain elements are closed under addition and multiplication. *}

lemma a_d_add_closure: "d(a(x)+a(y))=a(x)+a(y)"
  by (metis a_6 a_closure)

lemma a_d_mult_closure: "d(a(x)\<cdot>a(y))=a(x)\<cdot>a(y)"
  by (metis a_add a_closure)

lemma d_a_zero: "d(x)\<cdot>a(y) = 0 \<longleftrightarrow> d(x) \<le> d(y)"
  by (metis a_gla antidomain_semiring_domain_def)

lemma d_d_zero: "d(x)\<cdot>d(y) = 0 \<longleftrightarrow> d(x) \<le> a(y)"
  by (metis a_2_var antidomain_semiring_domain_def)

lemma d_6: "d(x)+d(y) = d(x)+a(x)\<cdot>d(y)"
  by (metis a1 a_add a_export add_zerol antidomain_semiring_domain_def distrib_left)

lemma d_7: "a(x)+a(y) = a(x)+d(x)\<cdot>a(y)"
proof -
  have "a(x)+a(y) =  a(x)\<cdot>a(x)+a(x)\<cdot>a(y)+d(x)\<cdot>a(x)+d(x)\<cdot>a(y)"
    by (metis a3 add_comm antidomain_semiring_domain_def mult_onel distrib_left distrib_right add_assoc)
  thus ?thesis
    by (metis a_add a_gla a_subid add_comm add_idem add_zerol antidomain_semiring_domain_def domain_subid domain_absorption_2 add_assoc a_closure)
qed

lemma kat_1: "d(x)\<cdot>y \<le> y\<cdot>d(z) \<longrightarrow> y\<cdot>a(z) \<le> a(x)\<cdot>y"
proof
  assume hyp: "d(x)\<cdot>y \<le> y\<cdot>d(z)"
  hence  "d(x)\<cdot>y\<cdot>a(z)+a(x)\<cdot>y\<cdot>a(z) \<le> a(x)\<cdot>y\<cdot>a(z)"
    sorry
  hence "d(x)\<cdot>y\<cdot>a(z)+a(x)\<cdot>y\<cdot>a(z)  \<le> a(x)\<cdot>y"
    by (metis a_subid mult_isol mult_oner order_trans)
  thus "y\<cdot>a(z)  \<le> a(x)\<cdot>y"
    by (metis a1 a_export a_zero distrib_right mult_onel)
qed

lemma kat_2:  "y\<cdot>a(z) \<le> a(x)\<cdot>y \<longrightarrow> d(x)\<cdot>y\<cdot>a(z) = 0"
  by (metis a_4 local.a1 local.antidomain_semiring_domain_def local.mult_isol_var local.zero_unique mult_assoc)

lemma kat_3: "d(x)\<cdot>y\<cdot>a(z) = 0 \<longrightarrow> d(x)\<cdot>y = d(x)\<cdot>y\<cdot>d(z)"
  by (metis a3 antidomain_semiring_domain_def mult_oner distrib_left add_zeror)

lemma kat_4: "d(x)\<cdot>y = d(x)\<cdot>y\<cdot>d(z) \<longrightarrow> d(x)\<cdot>y \<le> y\<cdot>d(z)"
  by (metis dom_subid mult_isor mult_onel)

lemma kat_1_equiv: "d(x)\<cdot>y \<le> y\<cdot>d(z) \<longleftrightarrow> y\<cdot>a(z) \<le> a(x)\<cdot>y"
  by (metis kat_1 kat_2 kat_3 kat_4)

lemma kat_2_equiv:  "y\<cdot>a(z) \<le> a(x)\<cdot>y \<longleftrightarrow> d(x)\<cdot>y\<cdot>a(z) = 0"
  by (metis kat_1_equiv kat_2 kat_3 kat_4)

lemma kat_3_equiv: "d(x)\<cdot>y\<cdot>a(z) = 0 \<longleftrightarrow> d(x)\<cdot>y = d(x)\<cdot>y\<cdot>d(z)"
  by (metis kat_1_equiv kat_2_equiv kat_3 kat_4)

lemma kat_4_equiv: "d(x)\<cdot>y = d(x)\<cdot>y\<cdot>d(z) \<longleftrightarrow> d(x)\<cdot>y \<le> y\<cdot>d(z)"
  by (metis kat_1_equiv kat_2_equiv kat_3_equiv)

lemma kat_1_equiv_opp: "y\<cdot>d(x) \<le> d(z)\<cdot>y \<longleftrightarrow> a(z)\<cdot>y \<le> y\<cdot>a(x)"
  by (metis a_closure antidomain_semiring_domain_def kat_1_equiv)

lemma kat_2_equiv_opp:  "a(z)\<cdot>y \<le> y\<cdot>a(x) \<longleftrightarrow> a(z)\<cdot>y\<cdot>d(x) = 0"
  by (metis a_closure antidomain_semiring_domain_def kat_1_equiv_opp kat_2_equiv)

lemma kat_3_equiv_opp: "a(z)\<cdot>y\<cdot>d(x) = 0 \<longleftrightarrow> y\<cdot>d(x) = d(z)\<cdot>y\<cdot>d(x)"
  apply auto
  apply (metis a_zero d_7 local.add_zerol local.distrib_right local.mult_onel mult_assoc)
  by (metis a_4 a_comp_2 local.a_gla mult_assoc)

lemma kat_4_equiv_opp: "y\<cdot>d(x) = d(z)\<cdot>y\<cdot>d(x) \<longleftrightarrow> y\<cdot>d(x) \<le> d(z)\<cdot>y"
  by (metis a_closure antidomain_semiring_domain_def kat_2_equiv kat_3_equiv_opp)

end

section{* Antidomain Kleene Algebras *}

class antidomain_kleene_algebra = antidomain_semiring + kleene_algebra

begin

lemma fdom_star: "d(x\<^sup>\<star>) = 1"
  apply (rule antisym)
  apply (metis local.dom_subid)
  by (metis local.domain_iso local.domain_one local.star_ref)

end

section{* Forward Diamond *}

text {* In this section we define a forward diamond operator over an
antidomain semiring *}

class fdiamond_semiring = antidomain_semiring + fdiamond_op +
  assumes fdiamond_def: "(\<bar>x\<rangle>y)  =  d(x\<cdot>y)"

(* context antidomain_semiring
begin

definition fdiamond :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"  ("( \<bar>  _ \<rangle> _)" 90)
  where fdiamond_def: "(\<bar>x\<rangle>y)  =  d(x\<cdot>y)"
*)
begin

lemma fdia_simp: "\<bar>x\<rangle>p = \<bar>x\<rangle>d(p)"
  by (metis d2 fdiamond_def)

lemma fdia_simp_2:  "\<bar>x\<rangle>p =d(\<bar>x\<rangle>p)"
  by (metis domain_invol fdiamond_def)

lemma fdia_dom: "d(x) =\<bar>x\<rangle>1"
  by (metis fdiamond_def mult_oner)

lemma fdia_add1: "\<bar>x\<rangle>(y+z) = (\<bar>x\<rangle>y)+(\<bar>x\<rangle>z)"
  by (metis a_add a_export antidomain_semiring_domain_def fdiamond_def distrib_left)

lemma fdia_add2: "\<bar>x+y\<rangle>z = (\<bar>x\<rangle>z)+(\<bar>y\<rangle>z)"
  by (metis a_add a_export antidomain_semiring_domain_def fdiamond_def distrib_right)

lemma fdia_mult: "\<bar>x\<cdot>y\<rangle>z = \<bar>x\<rangle>(\<bar>y\<rangle>z)"
  by (metis a2_eq antidomain_semiring_domain_def fdiamond_def mult_assoc)

lemma fdia_one: "\<bar>1\<rangle>x = d(x)"
  by (metis antidomain_semiring_domain_def fdiamond_def mult_onel)

lemma fdia_zero: "\<bar>x\<rangle>0 = 0"
  by  (metis a_one a_zero annir antidomain_semiring_domain_def fdiamond_def)

lemma fdemodalisation1: "d(z)\<cdot>(\<bar>x\<rangle>y) = 0 \<longleftrightarrow> d(z)\<cdot>x\<cdot>d(y) = 0"
  by (metis dom_weakly_local fdiamond_def mult_assoc)

lemma fdemodalisation2: "\<bar>x\<rangle>y \<le> d(z) \<longleftrightarrow> a(z)\<cdot>x\<cdot>d(y) = 0"
  by (metis a2_eq a_gla fdiamond_def kat_1_equiv mult_assoc mult_onel mult_oner)

lemma fdemodalisation3: "\<bar>x\<rangle>y \<le> d(z) \<longleftrightarrow> x\<cdot>d(y) \<le> d(z)\<cdot>x"
  by (metis fdemodalisation2 kat_1_equiv_opp kat_2_equiv_opp)

lemma fdia_iso: "d(x) \<le> d(y) \<longrightarrow> \<bar>z\<rangle>x \<le> \<bar>z\<rangle>y"
  by (metis d2 d5 fdia_add1 fdiamond_def less_eq_def)

lemma dia_iso_var: "x \<le> y \<longrightarrow> \<bar>x\<rangle>p \<le> \<bar>y\<rangle>p"
  by (metis a_add a_export antidomain_semiring_domain_def distrib_right fdiamond_def less_eq_def)

lemma fdia_zero_var: "\<bar>0\<rangle>x = 0"
  by (metis a_one a_zero annil antidomain_semiring_domain_def fdiamond_def)

lemma fdia_subdist_1: "\<bar>x\<rangle>p \<le> \<bar>x\<rangle>(p+q)"
  by (metis fdia_add1 add_lub order_refl)

lemma fdia_subdist_2: "\<bar>x\<rangle>(d(p)\<cdot>d(q)) \<le> \<bar>x\<rangle>d(p)"
  by (metis a2_eq a_add a_d_add_closure a_subdist antidomain_semiring_domain_def fdia_iso fdiamond_def)

lemma fdia_subdist: "\<bar>x\<rangle>(d(y)\<cdot>d(z)) \<le> (\<bar>x\<rangle>d(y))\<cdot>\<bar>x\<rangle>d(z)"
  by (metis fdia_subdist_2 dom_el_comm dom_glb fdia_simp_2)

lemma dia_diff_var: "\<bar>x\<rangle>d(p) \<le> (\<bar>x\<rangle>(d(p)\<cdot>a(q)))+\<bar>x\<rangle>d(q)"
  by (metis fdia_simp antidomain_semiring_domain_def a1 a_add a_closure a_gla add_comm fdia_iso mult_assoc fdia_add1)

lemma dia_diff: "(\<bar>x\<rangle>p)\<cdot>a(\<bar>x\<rangle>q) \<le> \<bar>x\<rangle>(d(p)\<cdot>a(q))"
  by (metis dia_diff_var fdia_add1 fdia_simp d5 d_a_galois1 fdiamond_def domain_invol)

lemma fdia_export_1:  "d(y)\<cdot>\<bar>x\<rangle>p = \<bar>d(y)\<cdot>x\<rangle>p"
  by (metis domain_export fdia_mult fdia_simp fdiamond_def)

lemma fdia_export_2: "a(y)\<cdot>\<bar>x\<rangle>p = \<bar>a(y)\<cdot>x\<rangle>p"
  by (metis a_closure fdiamond_def domain_export mult_assoc)

lemma fdia_split: "\<bar>x\<rangle>y = d(z)\<cdot>(\<bar>x\<rangle>y)+a(z)\<cdot>(\<bar>x\<rangle>y)"
    by (smt mult_onel a3 antidomain_semiring_domain_def distrib_right)

end

section {* Forward Box *}

class fmodal_semiring = fdiamond_semiring + fbox_op +
  assumes fbox_def:  "\<bar>x]y = a(x\<cdot>a(y))"

(*
definition
  fbox :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"  ("( \<bar>  _ ] _)" 90)
  where  "(\<bar>x]y) = a(x\<cdot>a(y))"
*)

begin

text {* the next lemmas establish the De Morgan duality between boxes
and diamonds *}

lemma fbox_fdia: "\<bar>x]y = a(\<bar>x\<rangle>a(y))"
  by (metis a_5 fdiamond_def fbox_def)

lemma fdia_fbox: "\<bar>x\<rangle>y = a(\<bar>x]a(y))"
  by (metis antidomain_semiring_domain_def fdia_mult fdia_one fbox_fdia mult_onel mult_oner)

lemma fbox_fdia_de_morgan_1: "a(\<bar>x]y) = \<bar>x\<rangle>a(y)"
  by (metis antidomain_semiring_domain_def fbox_def fdiamond_def)

lemma fdia_fbox_de_morgan_2: "a(\<bar>x\<rangle>y) = \<bar>x]a(y)"
  by (metis a2_eq a_closure antidomain_semiring_domain_def fbox_def fdiamond_def)

lemma fbox_simp: "\<bar>x]p = \<bar>x]d(p)"
by (metis fbox_fdia a_5)

lemma fbox_simp_2:  "\<bar>x]p =d(\<bar>x]p)"
by (metis a_closure fbox_fdia)

text {* I use the following set of hypothesis for dualising statements. All box statements can then be obtained from the dual diamond statement *}

(*
sledgehammer (fdia_simp fdia_simp_2 fbox_simp fbox_simp_2 a_closure a_5 dom_add_closed dom_mult_closed a_antitone a_de_morgan_var_1 a_de_morgan_var_2 a_de_morgan_var_3 a_de_morgan_var_4 fdia_fbox fbox_fdia a_one a_zero fbox_fdia_de_morgan_1 fdia_fbox_de_morgan_2  antidomain_semiring_domain_def **dual_statement*** )
*)

lemma fbox_dom: "a(x) =\<bar>x]0"
by (metis a_5 a_zero fbox_fdia fdia_dom)

lemma fbox_add1: "\<bar>x](d(y)\<cdot>d(z)) = (\<bar>x]y)\<cdot>(\<bar>x]z)"
by  (smt fdia_simp fdia_simp_2 fbox_simp fbox_simp_2 a_closure a_5 dom_add_closed dom_mult_closed a_antitone a_de_morgan_var_1 a_de_morgan_var_2 a_de_morgan_var_3 a_de_morgan_var_4 fdia_fbox fbox_fdia a_one a_zero fdia_add1)

text {* Interestingly sledgehammer couldn't do this one\<dots> *}

lemma fbox_add2: "\<bar>x+y]z = (\<bar>x]z)\<cdot>(\<bar>y]z)"
by (metis a_de_morgan_var_3 fbox_fdia fdia_add2 fdia_simp_2)

lemma fbox_mult: "\<bar>x\<cdot>y]z = \<bar>x](\<bar>y]z)"
by (metis fbox_fdia fbox_fdia_de_morgan_1 fdia_mult)

lemma fbox_one: "\<bar>1]x = d(x)"
by (metis a_closure fbox_fdia_de_morgan_1 fbox_simp_2 fdia_fbox fdia_one)

lemma fbox_one_1: "\<bar>x]1 = 1"
by (metis a_one a_zero fbox_fdia fdia_zero)

lemma fbox_demodalisation3: "d(y) \<le> \<bar>x]d(z) \<longleftrightarrow> d(y)\<cdot>x \<le> x\<cdot>d(z)"
  by (metis a_gla antidomain_semiring_domain_def fbox_def kat_2_equiv_opp mult_assoc)

text {* Duality did not work here. *}

lemma fbox_iso: "d(x) \<le> d(y) \<longrightarrow> \<bar>z]x \<le> \<bar>z]y"
by (metis a_5 a_antitone a_closure fbox_fdia fdia_iso)

lemma fbox_antitone_var: "x \<le> y \<longrightarrow> \<bar>y]p \<le> \<bar>x]p"
by (metis a_antitone dia_iso_var fbox_fdia)

lemma fbox_subdist_1: "\<bar>x](d(p)\<cdot>d(q)) \<le> \<bar>x]d(p)"
by (metis a_antitone a_de_morgan_var_4 fbox_fdia fbox_simp fdia_subdist_1)

lemma fbox_subdist_2: "\<bar>x]d(p) \<le>\<bar>x](d(p)+d(q))"
by (metis a_antitone a_closure a_de_morgan_var_3 fbox_fdia fbox_simp fdia_subdist_2)

lemma fbox_diff_var: "(\<bar>x](d(p)+a(q)))\<cdot>(\<bar>x]d(q)) \<le> \<bar>x]d(p)"
by   (smt a_antitone  a_de_morgan_var_3 a_de_morgan_var_4  fbox_fdia fbox_fdia_de_morgan_1
 fdia_fbox_de_morgan_2 antidomain_semiring_domain_def dia_diff_var)

lemma fbox_diff: "\<bar>x](d(p)+a(q)) \<le> (\<bar>x]p)+a(\<bar>x]q)"
by (smt a_antitone a_de_morgan_var_4 fbox_fdia fbox_fdia_de_morgan_1 fdia_fbox_de_morgan_2 antidomain_semiring_domain_def dia_diff)

end

class  fmodal_kleene_algebra = fmodal_semiring + kleene_algebra

begin

lemma a_star: "a(x\<^sup>\<star>) = 0"
  by (metis a_gla a_subdist mult_oner star_plus_one)

lemma dom_star: "d(x\<^sup>\<star>) = 1"
  by (metis a_star a_zero antidomain_semiring_domain_def)

lemma fdia_star_unfold: "(\<bar>1\<rangle>z)+\<bar>x\<rangle>(\<bar>x\<^sup>\<star>\<rangle>z) = \<bar>x\<^sup>\<star>\<rangle>z"
  by (metis fdia_mult fdia_add2 star_unfoldl_eq)

lemma fbox_star_unfold: "(\<bar>1]z)\<cdot>\<bar>x](\<bar>x\<^sup>\<star>]z) = \<bar>x\<^sup>\<star>]z"
by  (smt fdia_simp fdia_simp_2 fbox_simp fbox_simp_2 a_closure a_5 dom_add_closed dom_mult_closed a_antitone a_de_morgan_var_1 a_de_morgan_var_2 a_de_morgan_var_3 a_de_morgan_var_4 fdia_fbox fbox_fdia a_one a_zero fbox_fdia_de_morgan_1 fdia_fbox_de_morgan_2  antidomain_semiring_domain_def fdia_star_unfold )

lemma fdia_star_unfold_var: "d(z)+\<bar>x\<rangle>(\<bar>x\<^sup>\<star>\<rangle>z) = \<bar>x\<^sup>\<star>\<rangle>z"
by (metis fdia_one fdia_star_unfold)

lemma fbox_star_unfold_var: "d(z)\<cdot>\<bar>x](\<bar>x\<^sup>\<star>]z) = \<bar>x\<^sup>\<star>]z"
  by (metis a_closure a_de_morgan_var_2 antidomain_semiring_domain_def fbox_fdia_de_morgan_1 fbox_simp_2 fdia_star_unfold_var)

lemma fdia_star_unfold_var_2: "d(z)+\<bar>x\<rangle>(\<bar>x\<^sup>\<star>\<rangle>d(z)) = \<bar>x\<^sup>\<star>\<rangle>d(z)"
  by (metis d2 fdia_star_unfold_var fdiamond_def)

lemma fbox_star_unfold_var_2: "d(z)\<cdot>\<bar>x](\<bar>x\<^sup>\<star>]d(z)) = \<bar>x\<^sup>\<star>]d(z)"
  by (metis a_closure a_de_morgan_var_2 antidomain_semiring_domain_def fbox_fdia_de_morgan_1 fbox_simp_2 fdia_star_unfold_var_2)

lemma fdia_star_unfoldr: "(\<bar>1\<rangle>z)+(\<bar>x\<^sup>\<star>\<rangle>(\<bar>x\<rangle>z)) = \<bar>x\<^sup>\<star>\<rangle>z"
  by (metis fdia_mult fdia_one fdia_star_unfold_var star_slide_var)

lemma fbox_star_unfoldr: "(\<bar>1]z)\<cdot>(\<bar>x\<^sup>\<star>](\<bar>x]z)) = \<bar>x\<^sup>\<star>]z"
by   (smt fdia_simp fdia_simp_2 fbox_simp fbox_simp_2 a_closure a_5 dom_add_closed dom_mult_closed a_antitone a_de_morgan_var_1 a_de_morgan_var_2 a_de_morgan_var_3 a_de_morgan_var_4 fdia_fbox fbox_fdia a_one a_zero fbox_fdia_de_morgan_1 fdia_fbox_de_morgan_2  antidomain_semiring_domain_def fdia_star_unfoldr)

lemma fdia_star_unfoldr_var: "d(z)+(\<bar>x\<^sup>\<star>\<rangle>(\<bar>x\<rangle>z)) = \<bar>x\<^sup>\<star>\<rangle>z"
  by (metis fdia_mult fdia_star_unfold_var star_slide_var)

lemma fbox_star_unfoldr_var: "d(z)\<cdot>(\<bar>x\<^sup>\<star>](\<bar>x]z)) = \<bar>x\<^sup>\<star>]z"
  by (metis a_closure a_de_morgan_var_2 antidomain_semiring_domain_def fbox_fdia_de_morgan_1 fbox_simp_2 fdia_star_unfoldr_var)

lemma fdia_star_induct_var: "\<bar>x\<rangle>d(y) \<le> d(y) \<longrightarrow> \<bar>x\<^sup>\<star>\<rangle>d(y) \<le> d(y)"
  by (metis d2 fdemodalisation3 fdiamond_def star_sim1)

lemma fbox_star_induct_var: "d(y) \<le> \<bar>x]d(y) \<longrightarrow> d(y) \<le> \<bar>x\<^sup>\<star>]d(y)"
by (metis a_antitone a_closure antidomain_semiring_domain_def fbox_fdia_de_morgan_1 fbox_simp_2 fdia_star_induct_var)

lemma fdia_star_induct: "d(z)+(\<bar>x\<rangle>d(y)) \<le> d(y) \<Longrightarrow> \<bar>x\<^sup>\<star>\<rangle>d(z) \<le> d(y)"
  by (metis fdia_star_induct_var local.add_lub local.fdia_iso local.fdia_simp local.order_trans)

lemma fbox_star_induct: "d(y) \<le> d(z)\<cdot>\<bar>x]d(y) \<longrightarrow>  d(y) \<le> \<bar>x\<^sup>\<star>]d(z)"
by  (smt fdia_simp fdia_simp_2 fbox_simp fbox_simp_2 a_closure a_5 dom_add_closed dom_mult_closed a_antitone a_de_morgan_var_1 a_de_morgan_var_2 a_de_morgan_var_3 a_de_morgan_var_4 fdia_fbox fbox_fdia a_one a_zero fbox_fdia_de_morgan_1 fdia_fbox_de_morgan_2  antidomain_semiring_domain_def fdia_star_induct)

lemma fdia_star_induct_eq: "d(z)+(\<bar>x\<rangle>d(y)) = d(y) \<longrightarrow> \<bar>x\<^sup>\<star>\<rangle>d(z) \<le> d(y)"
  by (metis fdia_star_induct order_refl)

lemma fbox_star_induct_eq: "d(z)\<cdot>(\<bar>x]d(y)) = d(y) \<longrightarrow> d(y) \<le> \<bar>x\<^sup>\<star>]d(z)"
by   (smt fdia_simp fdia_simp_2 fbox_simp fbox_simp_2 a_closure a_5 dom_add_closed dom_mult_closed a_antitone a_de_morgan_var_1 a_de_morgan_var_2 a_de_morgan_var_3 a_de_morgan_var_4 fdia_fbox fbox_fdia a_one a_zero fbox_fdia_de_morgan_1 fdia_fbox_de_morgan_2  antidomain_semiring_domain_def fdia_star_induct_eq)

lemma fbox_export_1: "a(p)+\<bar>x]d(p) = \<bar>d(p)\<cdot>x]d(p)"
  by (metis a_6 a_closure antidomain_semiring_domain_def fbox_fdia fdiamond_def mult_assoc)

lemma fbox_export_2: "d(p)+\<bar>x]d(p) = \<bar>a(p)\<cdot>x]d(p)"
  by (metis a_closure a_export antidomain_semiring_domain_def fbox_fdia fdiamond_def mult_assoc)

end

end

(*

lemma a_a2_0: "a(x)\<cdot>a(a(x)) = 0"
  by (metis a_comp_2 antidomain_semiring_domain_def)

lemma fbox_test: "a(p)\<cdot>\<bar>a(p)]a(q) = a(p)\<cdot>a(q)"
  by (metis a_export fbox_dom fbox_mult antidomain_semiring_domain_def mult_compl_intro pre_def)

lemma d_restrict: "(d(x)\<cdot>y \<le> z) = (d(x)\<cdot>y \<le> d(x)\<cdot>z)"
  by (metis mult_isol dom_el_idemp mult_assoc dom_subid mult_isor mult_onel order_trans)
*)


(* Author: Tobias Nipkow *)

section \<open>Pairing Heap According to Oksaki (Modified)\<close>

theory Pairing_Heap_List2
imports
  "HOL-Library.Multiset"
  "HOL-Data_Structures.Priority_Queue_Specs"
begin

subsection \<open>Definitions\<close>

text \<open>This version of pairing heaps is a modified version
of the one by Okasaki \<^cite>\<open>"Okasaki"\<close> that avoids structural invariants.\<close>

datatype 'a hp = Hp 'a (hps: "'a hp list")

type_synonym 'a heap = "'a hp option"

hide_const (open) insert

fun get_min  :: "'a heap \<Rightarrow> 'a" where
"get_min (Some(Hp x _)) = x"

fun link :: "('a::linorder) hp \<Rightarrow> 'a hp \<Rightarrow> 'a hp" where
"link (Hp x lx) (Hp y ly) =
    (if x < y then Hp x (Hp y ly # lx) else Hp y (Hp x lx # ly))"

fun merge :: "('a::linorder) heap \<Rightarrow> 'a heap \<Rightarrow> 'a heap" where
"merge h None = h" |
"merge None h = h" |
"merge (Some h1) (Some h2) = Some(link h1 h2)"

lemma merge_None[simp]: "merge None h = h"
by(cases h)auto

fun insert :: "('a::linorder) \<Rightarrow> 'a heap \<Rightarrow> 'a heap" where
"insert x None = Some(Hp x [])" |
"insert x (Some h) = Some(link (Hp x []) h)"

fun pass\<^sub>1 :: "('a::linorder) hp list \<Rightarrow> 'a hp list" where
  "pass\<^sub>1 [] = []"
| "pass\<^sub>1 [h] = [h]"
| "pass\<^sub>1 (h1#h2#hs) = link h1 h2 # pass\<^sub>1 hs"

fun pass\<^sub>2 :: "('a::linorder) hp list \<Rightarrow> 'a heap" where
  "pass\<^sub>2 [] = None"
| "pass\<^sub>2 (h#hs) = Some(case pass\<^sub>2 hs of None \<Rightarrow> h | Some h' \<Rightarrow> link h h')"

fun merge_pairs :: "('a::linorder) hp list \<Rightarrow> 'a heap" where
  "merge_pairs [] = None"
| "merge_pairs [h] = Some h"
| "merge_pairs (h1 # h2 # hs) =
  Some(let h12 = link h1 h2 in case merge_pairs hs of None \<Rightarrow> h12 | Some h \<Rightarrow> link h12 h)"

fun del_min :: "('a::linorder) heap \<Rightarrow> 'a heap" where
  "del_min None = None"
| "del_min (Some(Hp x hs)) = pass\<^sub>2 (pass\<^sub>1 hs)"

subsection \<open>Correctness Proofs\<close>

text \<open>An optimization:\<close>

lemma pass12_merge_pairs: "pass\<^sub>2 (pass\<^sub>1 hs) = merge_pairs hs"
by (induction hs rule: merge_pairs.induct) (auto split: option.split)

declare pass12_merge_pairs[code_unfold]

subsubsection \<open>Invariants\<close>

fun php :: "('a::linorder) hp \<Rightarrow> bool" where
"php (Hp x hs) = (\<forall>h \<in> set hs. (\<forall>y \<in> set_hp h. x \<le> y) \<and> php h)"

definition invar :: "('a::linorder) heap \<Rightarrow> bool" where
"invar ho = (case ho of None \<Rightarrow> True | Some h \<Rightarrow> php h)"

lemma php_link: "php h1 \<Longrightarrow> php h2 \<Longrightarrow> php (link h1 h2)"
by (induction h1 h2 rule: link.induct) fastforce+

lemma invar_merge:
  "\<lbrakk> invar h1; invar h2 \<rbrakk> \<Longrightarrow> invar (merge h1 h2)"
by (auto simp: php_link invar_def split: option.splits)

lemma invar_insert: "invar h \<Longrightarrow> invar (insert x h)"
by (auto simp: php_link invar_def split: option.splits)

lemma invar_pass1: "\<forall>h \<in> set hs. php h \<Longrightarrow> \<forall>h \<in> set (pass\<^sub>1 hs). php h"
by(induction hs rule: pass\<^sub>1.induct) (auto simp: php_link)

lemma invar_pass2: "\<forall>h \<in> set hs. php h \<Longrightarrow> invar (pass\<^sub>2 hs)"
by (induction hs)(auto simp: php_link invar_def split: option.splits)

lemma invar_del_min: "invar h \<Longrightarrow> invar (del_min h)"
by(induction h rule: del_min.induct)
  (auto simp: invar_Some intro!: invar_pass1 invar_pass2)

subsubsection \<open>Functional Correctness\<close>

fun mset_hp :: "'a hp \<Rightarrow>'a multiset" where
"mset_hp (Hp x hs) = {#x#} + sum_mset(mset(map mset_hp hs))"

definition mset_heap :: "'a heap \<Rightarrow>'a multiset" where
"mset_heap ho = (case ho of None \<Rightarrow> {#} | Some h \<Rightarrow> mset_hp h)"

lemma set_mset_mset_hp: "set_mset (mset_hp h) = set_hp h"
by(induction h) auto

lemma mset_hp_empty[simp]: "mset_hp hp \<noteq> {#}"
by (cases hp) auto

lemma mset_heap_Some: "mset_heap(Some hp) = mset_hp hp"
by(simp add: mset_heap_def)

lemma mset_heap_empty: "mset_heap h = {#} \<longleftrightarrow> h = None"
by (cases h) (auto simp add: mset_heap_def)

lemma get_min_in:
  "h \<noteq> None \<Longrightarrow> get_min h \<in> set_hp(the h)"
by(induction rule: get_min.induct)(auto)

lemma get_min_min: "\<lbrakk> h \<noteq> None; invar h; x \<in> set_hp(the h) \<rbrakk> \<Longrightarrow> get_min h \<le> x"
by(induction h rule: get_min.induct)(auto simp: invar_def)

lemma mset_link: "mset_hp (link h1 h2) = mset_hp h1 + mset_hp h2"
by(induction h1 h2 rule: link.induct)(auto simp: add_ac)

lemma mset_merge: "mset_heap (merge h1 h2) = mset_heap h1 + mset_heap h2"
by (induction h1 h2 rule: merge.induct)
   (auto simp add: mset_heap_def mset_link ac_simps)

lemma mset_insert: "mset_heap (insert a h) = {#a#} + mset_heap h"
by(cases h) (auto simp add: mset_link mset_heap_def insert_def)

lemma mset_merge_pairs: "mset_heap (merge_pairs hs) = sum_mset(image_mset mset_hp (mset hs))"
by(induction hs rule: merge_pairs.induct)
  (auto simp: mset_merge mset_link mset_heap_def Let_def split: option.split)

lemma mset_del_min: "h \<noteq> None \<Longrightarrow>
  mset_heap (del_min h) = mset_heap h - {#get_min h#}"
by(induction h rule: del_min.induct)
  (auto simp: mset_heap_Some pass12_merge_pairs mset_merge_pairs)

text \<open>Last step: prove all axioms of the priority queue specification:\<close>

interpretation pairing: Priority_Queue_Merge
where empty = None and is_empty = "\<lambda>h. h = None"
and merge = merge and insert = insert
and del_min = del_min and get_min = get_min
and invar = invar and mset = mset_heap
proof(standard, goal_cases)
  case 1 show ?case by(simp add: mset_heap_def)
next
  case (2 q) thus ?case by(auto simp add: mset_heap_def split: option.split)
next
  case 3 show ?case by(simp add: mset_insert mset_merge)
next
  case 4 thus ?case by(simp add: mset_del_min mset_heap_empty)
next
  case (5 q) thus ?case using get_min_in[of q]
    by(auto simp add: eq_Min_iff get_min_min mset_heap_empty mset_heap_Some set_mset_mset_hp)
next
  case 6 thus ?case by (simp add: invar_def)
next
  case 7 thus ?case by(rule invar_insert)
next
  case 8 thus ?case by (simp add: invar_del_min)
next
  case 9 thus ?case by (simp add: mset_merge)
next
  case 10 thus ?case by (simp add: invar_merge)
qed

end


(*
=============================================================================
FinFun is now part of the Isabelle distribution. The entry is kept for
archival; maintained but not developed further. Use the Isabelle distribution
version instead.
=============================================================================
*)

(* Author: Andreas Lochbihler, KIT *)

header {* A type class for computing the cardinality of a type's universe *}

theory Card_Univ imports Main begin

subsection {* A type class for computing the cardinality of a type's universe *}

class card_UNIV =
  fixes card_UNIV :: "'a itself \<Rightarrow> nat"
  assumes card_UNIV: "card_UNIV x = card (UNIV :: 'a set)"
begin

lemma card_UNIV_neq_0_finite_UNIV:
  "card_UNIV x \<noteq> 0 \<longleftrightarrow> finite (UNIV :: 'a set)"
by(simp add: card_UNIV card_eq_0_iff)

lemma card_UNIV_ge_0_finite_UNIV:
  "card_UNIV x > 0 \<longleftrightarrow> finite (UNIV :: 'a set)"
by(auto simp add: card_UNIV intro: card_ge_0_finite finite_UNIV_card_ge_0)

lemma card_UNIV_eq_0_infinite_UNIV:
  "card_UNIV x = 0 \<longleftrightarrow> \<not> finite (UNIV :: 'a set)"
by(simp add: card_UNIV card_eq_0_iff)

definition is_list_UNIV :: "'a list \<Rightarrow> bool"
where "is_list_UNIV xs = (let c = card_UNIV (TYPE('a)) in if c = 0 then False else size (remdups xs) = c)"

lemma is_list_UNIV_iff:
  fixes xs :: "'a list"
  shows "is_list_UNIV xs \<longleftrightarrow> set xs = UNIV"
proof
  assume "is_list_UNIV xs"
  hence c: "card_UNIV (TYPE('a)) > 0" and xs: "size (remdups xs) = card_UNIV (TYPE('a))"
    unfolding is_list_UNIV_def by(simp_all add: Let_def split: split_if_asm)
  from c have fin: "finite (UNIV :: 'a set)" by(auto simp add: card_UNIV_ge_0_finite_UNIV)
  have "card (set (remdups xs)) = size (remdups xs)" by(subst distinct_card) auto
  also note set_remdups
  finally show "set xs = UNIV" using fin unfolding xs card_UNIV by-(rule card_eq_UNIV_imp_eq_UNIV)
next
  assume xs: "set xs = UNIV"
  from finite_set[of xs] have fin: "finite (UNIV :: 'a set)" unfolding xs .
  hence "card_UNIV (TYPE ('a)) \<noteq> 0" unfolding card_UNIV_neq_0_finite_UNIV .
  moreover have "size (remdups xs) = card (set (remdups xs))"
    by(subst distinct_card) auto
  ultimately show "is_list_UNIV xs" using xs by(simp add: is_list_UNIV_def Let_def card_UNIV)
qed

lemma card_UNIV_eq_0_is_list_UNIV_False:
  assumes cU0: "card_UNIV x = 0"
  shows "is_list_UNIV = (\<lambda>xs. False)"
proof(rule ext)
  fix xs :: "'a list"
  from cU0 have "\<not> finite (UNIV :: 'a set)"
    by(auto simp only: card_UNIV_eq_0_infinite_UNIV)
  moreover have "finite (set xs)" by(rule finite_set)
  ultimately have "(UNIV :: 'a set) \<noteq> set xs" by(auto simp del: finite_set)
  thus "is_list_UNIV xs = False" unfolding is_list_UNIV_iff by simp
qed

end

subsection {* Instantiations for @{text "card_UNIV"} *}

subsubsection {* @{typ "nat"} *}

instantiation nat :: card_UNIV begin

definition card_UNIV_nat_def:
  "card_UNIV_class.card_UNIV = (\<lambda>a :: nat itself. 0)"

instance proof
  fix x :: "nat itself"
  show "card_UNIV x = card (UNIV :: nat set)"
    unfolding card_UNIV_nat_def by simp
qed

end

subsubsection {* @{typ "int"} *}

instantiation int :: card_UNIV begin

definition card_UNIV_int_def:
  "card_UNIV_class.card_UNIV = (\<lambda>a :: int itself. 0)"

instance proof
  fix x :: "int itself"
  show "card_UNIV x = card (UNIV :: int set)"
    unfolding card_UNIV_int_def by(simp add: infinite_UNIV_int)
qed

end

subsubsection {* @{typ "'a list"} *}

instantiation list :: (type) card_UNIV begin

definition card_UNIV_list_def:
  "card_UNIV_class.card_UNIV = (\<lambda>a :: 'a list itself. 0)"

instance proof
  fix x :: "'a list itself"
  show "card_UNIV x = card (UNIV :: 'a list set)"
    unfolding card_UNIV_list_def by(simp add: infinite_UNIV_listI)
qed

end

subsubsection {* @{typ "unit"} *}

lemma card_UNIV_unit: "card (UNIV :: unit set) = 1"
  unfolding UNIV_unit by simp

instantiation unit :: card_UNIV begin

definition card_UNIV_unit_def:
  "card_UNIV_class.card_UNIV = (\<lambda>a :: unit itself. 1)"

instance proof
  fix x :: "unit itself"
  show "card_UNIV x = card (UNIV :: unit set)"
    by(simp add: card_UNIV_unit_def card_UNIV_unit)
qed

end

subsubsection {* @{typ "bool"} *}

lemma card_UNIV_bool: "card (UNIV :: bool set) = 2"
  unfolding UNIV_bool by simp

instantiation bool :: card_UNIV begin

definition card_UNIV_bool_def:
  "card_UNIV_class.card_UNIV = (\<lambda>a :: bool itself. 2)"

instance proof
  fix x :: "bool itself"
  show "card_UNIV x = card (UNIV :: bool set)"
    by(simp add: card_UNIV_bool_def card_UNIV_bool)
qed

end

subsubsection {* @{typ "char"} *}

instantiation char :: card_UNIV begin

definition card_UNIV_char_def:
  "card_UNIV_class.card_UNIV = (\<lambda>a :: char itself. 256)"

instance proof
  fix x :: "char itself"
  show "card_UNIV x = card (UNIV :: char set)"
    by(simp add: card_UNIV_char_def card_UNIV_char)
qed

end

subsubsection {* @{typ "'a \<times> 'b"} *}

instantiation prod :: (card_UNIV, card_UNIV) card_UNIV begin

definition card_UNIV_product_def:
  "card_UNIV_class.card_UNIV = (\<lambda>a :: ('a \<times> 'b) itself. card_UNIV (TYPE('a)) * card_UNIV (TYPE('b)))"

instance proof
  fix x :: "('a \<times> 'b) itself"
  show "card_UNIV x = card (UNIV :: ('a \<times> 'b) set)"
    by(simp add: card_UNIV_product_def card_UNIV UNIV_Times_UNIV[symmetric] card_cartesian_product del: UNIV_Times_UNIV)
qed

end

subsubsection {* @{typ "'a + 'b"} *}

instantiation sum :: (card_UNIV, card_UNIV) card_UNIV begin

definition card_UNIV_sum_def:
  "card_UNIV_class.card_UNIV = (\<lambda>a :: ('a + 'b) itself. let ca = card_UNIV (TYPE('a)); cb = card_UNIV (TYPE('b))
                           in if ca \<noteq> 0 \<and> cb \<noteq> 0 then ca + cb else 0)"

instance proof
  fix x :: "('a + 'b) itself"
  show "card_UNIV x = card (UNIV :: ('a + 'b) set)"
    by (auto simp add: card_UNIV_sum_def card_UNIV card_eq_0_iff UNIV_Plus_UNIV[symmetric] finite_Plus_iff Let_def card_Plus simp del: UNIV_Plus_UNIV dest!: card_ge_0_finite)
qed

end

subsubsection {* @{typ "'a \<Rightarrow> 'b"} *}

instantiation "fun" :: (card_UNIV, card_UNIV) card_UNIV begin

definition card_UNIV_fun_def:
  "card_UNIV_class.card_UNIV = (\<lambda>a :: ('a \<Rightarrow> 'b) itself. let ca = card_UNIV (TYPE('a)); cb = card_UNIV (TYPE('b))
                           in if ca \<noteq> 0 \<and> cb \<noteq> 0 \<or> cb = 1 then cb ^ ca else 0)"

instance proof
  fix x :: "('a \<Rightarrow> 'b) itself"

  { assume "0 < card (UNIV :: 'a set)"
    and "0 < card (UNIV :: 'b set)"
    hence fina: "finite (UNIV :: 'a set)" and finb: "finite (UNIV :: 'b set)"
      by(simp_all only: card_ge_0_finite)
    from finite_distinct_list[OF finb] obtain bs
      where bs: "set bs = (UNIV :: 'b set)" and distb: "distinct bs" by blast
    from finite_distinct_list[OF fina] obtain as
      where as: "set as = (UNIV :: 'a set)" and dista: "distinct as" by blast
    have cb: "card (UNIV :: 'b set) = length bs"
      unfolding bs[symmetric] distinct_card[OF distb] ..
    have ca: "card (UNIV :: 'a set) = length as"
      unfolding as[symmetric] distinct_card[OF dista] ..
    let ?xs = "map (\<lambda>ys. the o map_of (zip as ys)) (List.n_lists (length as) bs)"
    have "UNIV = set ?xs"
    proof(rule UNIV_eq_I)
      fix f :: "'a \<Rightarrow> 'b"
      from as have "f = the \<circ> map_of (zip as (map f as))"
        by(auto simp add: map_of_zip_map intro: ext)
      thus "f \<in> set ?xs" using bs by(auto simp add: set_n_lists)
    qed
    moreover have "distinct ?xs" unfolding distinct_map
    proof(intro conjI distinct_n_lists distb inj_onI)
      fix xs ys :: "'b list"
      assume xs: "xs \<in> set (List.n_lists (length as) bs)"
        and ys: "ys \<in> set (List.n_lists (length as) bs)"
        and eq: "the \<circ> map_of (zip as xs) = the \<circ> map_of (zip as ys)"
      from xs ys have [simp]: "length xs = length as" "length ys = length as"
        by(simp_all add: length_n_lists_elem)
      have "map_of (zip as xs) = map_of (zip as ys)"
      proof
        fix x
        from as bs have "\<exists>y. map_of (zip as xs) x = Some y" "\<exists>y. map_of (zip as ys) x = Some y"
          by(simp_all add: map_of_zip_is_Some[symmetric])
        with eq show "map_of (zip as xs) x = map_of (zip as ys) x"
          by(auto dest: fun_cong[where x=x])
      qed
      with dista show "xs = ys" by(simp add: map_of_zip_inject)
    qed
    hence "card (set ?xs) = length ?xs" by(simp only: distinct_card)
    moreover have "length ?xs = length bs ^ length as" by(simp add: length_n_lists)
    ultimately have "card (UNIV :: ('a \<Rightarrow> 'b) set) = card (UNIV :: 'b set) ^ card (UNIV :: 'a set)"
      using cb ca by simp }
  moreover {
    assume cb: "card (UNIV :: 'b set) = Suc 0"
    then obtain b where b: "UNIV = {b :: 'b}" by(auto simp add: card_Suc_eq)
    have eq: "UNIV = {\<lambda>x :: 'a. b ::'b}"
    proof(rule UNIV_eq_I)
      fix x :: "'a \<Rightarrow> 'b"
      { fix y
        have "x y \<in> UNIV" ..
        hence "x y = b" unfolding b by simp }
      thus "x \<in> {\<lambda>x. b}" by(auto intro: ext)
    qed
    have "card (UNIV :: ('a \<Rightarrow> 'b) set) = Suc 0" unfolding eq by simp }
  ultimately show "card_UNIV x = card (UNIV :: ('a \<Rightarrow> 'b) set)"
    unfolding card_UNIV_fun_def card_UNIV Let_def
    by(auto simp del: One_nat_def)(auto simp add: card_eq_0_iff dest: finite_fun_UNIVD2 finite_fun_UNIVD1)
qed

end

subsubsection {* @{typ "'a option"} *}

instantiation option :: (card_UNIV) card_UNIV
begin

definition card_UNIV_option_def:
  "card_UNIV_class.card_UNIV = (\<lambda>a :: 'a option itself. let c = card_UNIV (TYPE('a))
                           in if c \<noteq> 0 then Suc c else 0)"

instance proof
  fix x :: "'a option itself"
  show "card_UNIV x = card (UNIV :: 'a option set)"
    unfolding UNIV_option_conv
    by(auto simp add: card_UNIV_option_def card_UNIV card_eq_0_iff Let_def intro: inj_Some dest: finite_imageD)
      (subst card_insert_disjoint, auto simp add: card_eq_0_iff card_image inj_Some intro: finite_imageI card_ge_0_finite)
qed

end

end


theory sort_MSortTDIsSort
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

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

fun ztake :: "int => 'a list => 'a list" where
"ztake x y =
   (if x = 0 then Nil2 else
      case y of
          Nil2 => y
        | Cons2 z xs => Cons2 z (ztake (x - 1) xs))"

fun zlength :: "'a list => int" where
"zlength (Nil2) = 0"
| "zlength (Cons2 y xs) = 1 + (zlength xs)"

fun zdrop :: "int => 'a list => 'a list" where
"zdrop x y =
   (if x = 0 then y else
      case y of
          Nil2 => y
        | Cons2 z xs => zdrop (x - 1) xs)"

fun lmerge :: "int list => int list => int list" where
"lmerge (Nil2) y = y"
| "lmerge (Cons2 z x2) (Nil2) = Cons2 z x2"
| "lmerge (Cons2 z x2) (Cons2 x3 x4) =
     (if z <= x3 then Cons2 z (lmerge x2 (Cons2 x3 x4)) else
        Cons2 x3 (lmerge (Cons2 z x2) x4))"

fun msorttd :: "int list => int list" where
"msorttd (Nil2) = Nil2"
| "msorttd (Cons2 y (Nil2)) = Cons2 y (Nil2)"
| "msorttd (Cons2 y (Cons2 x2 x3)) =
     lmerge (msorttd (ztake
                      ((op div) (zlength (Cons2 y (Cons2 x2 x3))) 2)
                      (Cons2 y (Cons2 x2 x3))))
            (msorttd (zdrop
                      ((op div) (zlength (Cons2 y (Cons2 x2 x3))) 2)
                        (Cons2 y (Cons2 x2 x3))))"

fun insert2 :: "int => int list => int list" where
"insert2 x (Nil2) = Cons2 x (Nil2)"
| "insert2 x (Cons2 z xs) =
     (if x <= z then Cons2 x (Cons2 z xs) else Cons2 z (insert2 x xs))"

fun isort :: "int list => int list" where
"isort (Nil2) = Nil2"
| "isort (Cons2 y xs) = insert2 y (isort xs)"

(*hipster ztake zlength zdrop lmerge msorttd insert2 isort *)

theorem x0 :
  "!! (x :: int list) . (msorttd x) = (isort x)"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end


theory Knapsack
  imports "../DP_CRelVS" "../DP_Proof"
begin
context (* Knapsack *)
  fixes w :: "nat \<Rightarrow> nat"
begin

fun su :: "nat\<times>nat \<Rightarrow> nat" where
  "su (0, W) = (if W < w 0 then 0 else w 0)" |
  "su (Suc i, W) = (if W < w (Suc i)
    then su (i, W)
    else max (su (i, W)) (w i + su (i, W - w i)))"
ML_file \<open>../scratch/Transform.ML\<close>
local_setup \<open>
lift_fun NONE;
\<close>
print_theorems

interpretation su: dp_consistency su .

lemma "su.consistentDP su\<^sub>T"
  by (dp_match induct: su\<^sub>T.induct simp: su.simps simp\<^sub>T: su\<^sub>T.simps)

end
end


section \<open> Kripke Semantics For Intuitionistic Logic \<close>

theory Kripke_Semantics
  imports
    Main
    "./Combinators"
begin

(*:maxLineLen=78:*)

record ('a, 'b) Kripke_Model =
  R :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
  V :: "'a \<Rightarrow> 'b \<Rightarrow> bool"

primrec
Intuitionistic_Kripke_Semantics
  :: "('a, 'b) Kripke_Model \<Rightarrow> 'a \<Rightarrow> 'b Simple_Type \<Rightarrow> bool"
     ("_ _ \<Turnstile> _" [60,60,60] 60)
  where
    "(\<MM> x \<Turnstile> \<^bold>\<lbrace> v \<^bold>\<rbrace>) = (\<exists> w. (R \<MM>)\<^sup>*\<^sup>* w x \<and> (V \<MM>) w v)"
  | "(\<MM> x \<Turnstile> \<phi> \<^bold>\<Rightarrow> \<psi>) = (\<forall> y. (R \<MM>)\<^sup>*\<^sup>* x y \<longrightarrow> \<MM> y \<Turnstile> \<phi> \<longrightarrow> \<MM> y \<Turnstile> \<psi>)"

lemma Kripke_model_monotone:
  "(R \<MM>)\<^sup>*\<^sup>* x y \<Longrightarrow> \<MM> x \<Turnstile> \<phi> \<Longrightarrow> \<MM> y \<Turnstile> \<phi>"
  by (induct \<phi> arbitrary: y; simp)
     (meson rtranclp_trans)+

lemma Kripke_models_impl_flatten:
  "\<MM> x \<Turnstile> \<phi> \<^bold>\<Rightarrow> \<psi> \<^bold>\<Rightarrow> \<chi> =
    (\<forall> y. (R \<MM>)\<^sup>*\<^sup>* x y \<longrightarrow> \<MM> y \<Turnstile> \<phi> \<longrightarrow> \<MM> y \<Turnstile> \<psi> \<longrightarrow> \<MM> y \<Turnstile> \<chi>)"
  by (rule iffI ; simp)
     (meson Kripke_model_monotone rtranclp_trans)

lemma Kripke_models_K:
  "\<MM> x \<Turnstile> \<phi> \<^bold>\<Rightarrow> \<psi> \<^bold>\<Rightarrow> \<phi>"
  by (meson Kripke_models_impl_flatten)

lemma Kripke_models_S:
  "\<MM> x \<Turnstile> (\<phi> \<^bold>\<Rightarrow> \<psi> \<^bold>\<Rightarrow> \<chi>) \<^bold>\<Rightarrow> (\<phi> \<^bold>\<Rightarrow> \<psi>) \<^bold>\<Rightarrow> \<phi> \<^bold>\<Rightarrow> \<chi>"
  by (simp, meson rtranclp.rtrancl_refl rtranclp_trans)

lemma Kripke_models_modus_ponens:
  "\<MM> x \<Turnstile> \<phi> \<^bold>\<Rightarrow> \<psi> \<Longrightarrow> \<MM> x \<Turnstile> \<phi> \<Longrightarrow> \<MM> x \<Turnstile> \<psi>"
  by auto

theorem Combinator_Typing_Kripke_Soundness:
  "X \<Colon> \<phi> \<Longrightarrow> \<MM> x \<Turnstile> \<phi>"
  by (induct rule: Simply_Typed_SKComb.induct)
     (meson Kripke_models_S, meson Kripke_models_K, auto)

lemma Combinator_Typing_Kripke_Soundness_alt:
  "\<exists> X . X \<Colon> \<phi> \<Longrightarrow> \<forall> \<MM> x. \<MM> x \<Turnstile> \<phi>"
  by (meson Combinator_Typing_Kripke_Soundness)

lemma Kripke_Cont_Monad:
  assumes "a \<noteq> b"
  and "p \<noteq> q"
  and "\<MM> = \<lparr> R = (\<lambda> x y. x = a \<and> y = b), V = (\<lambda> x y. x = b \<and> y = p) \<rparr>"
  shows "\<not> \<MM> a \<Turnstile> ((\<^bold>\<lbrace> p \<^bold>\<rbrace> \<^bold>\<Rightarrow> \<^bold>\<lbrace> q \<^bold>\<rbrace>) \<^bold>\<Rightarrow> \<^bold>\<lbrace> q \<^bold>\<rbrace>) \<^bold>\<Rightarrow> \<^bold>\<lbrace> p \<^bold>\<rbrace>"
proof -
  have  "\<not> \<MM> b \<Turnstile> \<^bold>\<lbrace> p \<^bold>\<rbrace> \<^bold>\<Rightarrow> \<^bold>\<lbrace> q \<^bold>\<rbrace>"
        "\<not> \<MM> a \<Turnstile> \<^bold>\<lbrace> p \<^bold>\<rbrace> \<^bold>\<Rightarrow> \<^bold>\<lbrace> q \<^bold>\<rbrace>"
    unfolding assms(3)
    using assms(1) assms(2) by auto
  hence "\<forall> x. (R \<MM>)\<^sup>*\<^sup>* a x \<longrightarrow> \<not> \<MM> x \<Turnstile> \<^bold>\<lbrace> p \<^bold>\<rbrace> \<^bold>\<Rightarrow> \<^bold>\<lbrace> q \<^bold>\<rbrace>"
    unfolding assms(3)
    by (simp, metis (mono_tags, lifting) rtranclp.simps)
  hence "\<MM> a \<Turnstile> (\<^bold>\<lbrace> p \<^bold>\<rbrace> \<^bold>\<Rightarrow> \<^bold>\<lbrace> q \<^bold>\<rbrace>) \<^bold>\<Rightarrow> \<^bold>\<lbrace> q \<^bold>\<rbrace>"
    by fastforce
  moreover have "\<not> \<MM> a \<Turnstile> \<^bold>\<lbrace> p \<^bold>\<rbrace>"
    unfolding assms(3)
    using assms(1) converse_rtranclpE by fastforce
  ultimately show ?thesis
    by (meson Kripke_models_modus_ponens)
qed

lemma no_extract:
  assumes "p \<noteq> q"
  shows "\<nexists> X . X \<Colon> ((\<^bold>\<lbrace> p \<^bold>\<rbrace> \<^bold>\<Rightarrow> \<^bold>\<lbrace> q \<^bold>\<rbrace>) \<^bold>\<Rightarrow> \<^bold>\<lbrace> q \<^bold>\<rbrace>) \<^bold>\<Rightarrow> \<^bold>\<lbrace> p \<^bold>\<rbrace>"
  using assms
  by (metis
        Combinator_Typing_Kripke_Soundness
        Kripke_Cont_Monad)

end