(* Title:      Demonic refinement algebra
   Author:     Alasdair Armstrong, Victor B. F. Gomes, Georg Struth
   Maintainer: Georg Struth <g.struth at sheffield.ac.uk>
               Tjark Weber <tjark.weber at it.uu.se>
*)

section \<open>Demonic Refinement Algebras\<close>

theory DRA
  imports Kleene_Algebra
begin

text \<open>
  A demonic refinement algebra *DRA)~\<^cite>\<open>"vonwright04refinement"\<close> is a Kleene algebra without right annihilation plus
  an operation for possibly infinite iteration.
\<close>
class dra = kleene_algebra_zerol +
  fixes strong_iteration :: "'a \<Rightarrow> 'a" ("_\<^sup>\<infinity>" [101] 100)
  assumes iteration_unfoldl [simp] : "1 + x \<cdot> x\<^sup>\<infinity> = x\<^sup>\<infinity>"
  and coinduction: "y \<le> z + x \<cdot> y \<longrightarrow> y \<le> x\<^sup>\<infinity> \<cdot> z"
  and isolation [simp]: "x\<^sup>\<star> + x\<^sup>\<infinity> \<cdot> 0 = x\<^sup>\<infinity>"
begin

text \<open>$\top$ is an abort statement, defined as an infinite skip. It is the maximal element of any DRA.\<close>

abbreviation top_elem :: "'a" ("\<top>") where "\<top> \<equiv> 1\<^sup>\<infinity>"

text \<open>Simple/basic lemmas about the iteration operator\<close>

lemma iteration_refl: "1 \<le> x\<^sup>\<infinity>"
  using local.iteration_unfoldl local.order_prop by blast

lemma iteration_1l: "x \<cdot> x\<^sup>\<infinity> \<le> x\<^sup>\<infinity>"
  by (metis local.iteration_unfoldl local.join.sup.cobounded2)

lemma top_ref: "x \<le> \<top>"
proof -
  have "x \<le> 1 + 1 \<cdot> x"
    by simp
  thus ?thesis
    using local.coinduction by fastforce
qed

lemma it_ext: "x \<le> x\<^sup>\<infinity>"
proof -
  have "x \<le> x \<cdot> x\<^sup>\<infinity>"
    using iteration_refl local.mult_isol by fastforce
  thus ?thesis
    by (metis (full_types) local.isolation local.join.sup.coboundedI1 local.star_ext)
qed

lemma it_idem [simp]: "(x\<^sup>\<infinity>)\<^sup>\<infinity> = x\<^sup>\<infinity>"
(*nitpick [expect=genuine]*)
oops

lemma top_mult_annil [simp]: "\<top> \<cdot> x = \<top>"
  by (simp add: local.coinduction local.order.antisym top_ref)

lemma top_add_annil [simp]: "\<top> + x = \<top>"
  by (simp add: local.join.sup.absorb1 top_ref)

lemma top_elim: "x \<cdot> y \<le> x \<cdot> \<top>"
  by (simp add: local.mult_isol top_ref)

lemma iteration_unfoldl_distl [simp]: " y + y \<cdot> x \<cdot> x\<^sup>\<infinity> = y \<cdot> x\<^sup>\<infinity>"
  by (metis distrib_left mult.assoc mult_oner iteration_unfoldl)

lemma iteration_unfoldl_distr [simp]: " y + x \<cdot> x\<^sup>\<infinity> \<cdot> y = x\<^sup>\<infinity> \<cdot> y"
  by (metis distrib_right' mult_1_left iteration_unfoldl)

lemma iteration_unfoldl' [simp]: "z \<cdot> y + z \<cdot> x \<cdot> x\<^sup>\<infinity> \<cdot> y = z \<cdot> x\<^sup>\<infinity> \<cdot> y"
  by (metis iteration_unfoldl_distl local.distrib_right)

lemma iteration_idem [simp]: "x\<^sup>\<infinity> \<cdot> x\<^sup>\<infinity> = x\<^sup>\<infinity>"
proof (rule order.antisym)
  have "x\<^sup>\<infinity> \<cdot> x\<^sup>\<infinity> \<le> 1 + x \<cdot> x\<^sup>\<infinity> \<cdot> x\<^sup>\<infinity>"
    by (metis add_assoc iteration_unfoldl_distr local.eq_refl local.iteration_unfoldl local.subdistl_eq mult_assoc)
  thus "x\<^sup>\<infinity> \<cdot> x\<^sup>\<infinity> \<le> x\<^sup>\<infinity>"
    using local.coinduction mult_assoc by fastforce
  show "x\<^sup>\<infinity> \<le>  x\<^sup>\<infinity> \<cdot> x\<^sup>\<infinity>"
    using local.coinduction by auto
qed

lemma iteration_induct: "x \<cdot> x\<^sup>\<infinity> \<le> x\<^sup>\<infinity> \<cdot> x"
proof -
  have "x + x \<cdot> (x \<cdot> x\<^sup>\<infinity>) = x \<cdot> x\<^sup>\<infinity>"
    by (metis (no_types) local.distrib_left local.iteration_unfoldl local.mult_oner)
  thus ?thesis
    by (simp add: local.coinduction)
qed

lemma iteration_ref_star: "x\<^sup>\<star> \<le> x\<^sup>\<infinity>"
  by (simp add: local.star_inductl_one)

lemma iteration_subdist: "x\<^sup>\<infinity> \<le> (x + y)\<^sup>\<infinity>"
  by (metis add_assoc' distrib_right' mult_oner coinduction join.sup_ge1 iteration_unfoldl)

lemma iteration_iso: "x \<le> y \<Longrightarrow> x\<^sup>\<infinity> \<le> y\<^sup>\<infinity>"
  using iteration_subdist local.order_prop by auto

lemma iteration_unfoldr [simp]: "1 + x\<^sup>\<infinity> \<cdot> x = x\<^sup>\<infinity>"
  by (metis add_0_left annil eq_refl isolation mult.assoc iteration_idem iteration_unfoldl iteration_unfoldl_distr star_denest star_one star_prod_unfold star_slide tc)

lemma iteration_unfoldr_distl [simp]: " y + y \<cdot> x\<^sup>\<infinity> \<cdot> x = y \<cdot> x\<^sup>\<infinity>"
  by (metis distrib_left mult.assoc mult_oner iteration_unfoldr)

lemma iteration_unfoldr_distr [simp]: " y + x\<^sup>\<infinity> \<cdot> x \<cdot> y = x\<^sup>\<infinity> \<cdot> y"
  by (metis iteration_unfoldl_distr iteration_unfoldr_distl)

lemma iteration_unfold_eq: "x\<^sup>\<infinity> \<cdot> x = x \<cdot> x\<^sup>\<infinity>"
  by (metis iteration_unfoldl_distr iteration_unfoldr_distl)

lemma iteration_unfoldr' [simp]: "z \<cdot> y + z \<cdot> x\<^sup>\<infinity> \<cdot> x \<cdot> y = z \<cdot> x\<^sup>\<infinity> \<cdot> y"
  by (metis distrib_left mult.assoc iteration_unfoldr_distr)

lemma iteration_double [simp]: "(x\<^sup>\<infinity>)\<^sup>\<infinity> = \<top>"
  by (simp add: iteration_iso iteration_refl order.eq_iff top_ref)

lemma star_iteration [simp]: "(x\<^sup>\<star>)\<^sup>\<infinity> = \<top>"
  by (simp add: iteration_iso order.eq_iff top_ref)

lemma iteration_star [simp]: "(x\<^sup>\<infinity>)\<^sup>\<star> = x\<^sup>\<infinity>"
  by (metis (no_types) iteration_idem iteration_refl local.star_inductr_var_eq2 local.sup_id_star1)

lemma iteration_star2 [simp]: "x\<^sup>\<star> \<cdot> x\<^sup>\<infinity> = x\<^sup>\<infinity>"
proof -
  have f1: "(x\<^sup>\<infinity>)\<^sup>\<star> \<cdot> x\<^sup>\<star> = x\<^sup>\<infinity>"
    by (metis (no_types) it_ext iteration_induct iteration_star local.bubble_sort local.join.sup.absorb1)
  have "x\<^sup>\<infinity> = x\<^sup>\<infinity> \<cdot> x\<^sup>\<infinity>"
    by simp
  hence "x\<^sup>\<star> \<cdot> x\<^sup>\<infinity> = x\<^sup>\<star> \<cdot> (x\<^sup>\<infinity>)\<^sup>\<star> \<cdot> (x\<^sup>\<star> \<cdot> (x\<^sup>\<infinity>)\<^sup>\<star>)\<^sup>\<star>"
    using f1 by (metis (no_types) iteration_star local.star_denest_var_4 mult_assoc)
  thus ?thesis
    using f1 by (metis (no_types) iteration_star local.star_denest_var_4 local.star_denest_var_8)
qed

lemma iteration_zero [simp]: "0\<^sup>\<infinity> = 1"
  by (metis add_zeror annil iteration_unfoldl)

lemma iteration_subdenest: "x\<^sup>\<infinity> \<cdot> y\<^sup>\<infinity> \<le> (x + y)\<^sup>\<infinity>"
  by (metis add_commute iteration_idem iteration_subdist local.mult_isol_var)

lemma sup_id_top: "1 \<le> y \<Longrightarrow> y \<cdot> \<top> = \<top>"
  using order.eq_iff local.mult_isol_var top_ref by fastforce

lemma iteration_top [simp]: "x\<^sup>\<infinity> \<cdot> \<top> = \<top>"
  by (simp add: iteration_refl sup_id_top)

text \<open>Next, we prove some simulation laws for data refinement.\<close>

lemma iteration_sim: "z \<cdot> y \<le> x \<cdot> z \<Longrightarrow> z \<cdot> y\<^sup>\<infinity> \<le> x\<^sup>\<infinity> \<cdot> z"
proof -
  assume assms: "z \<cdot> y \<le> x \<cdot> z"
  have "z \<cdot> y\<^sup>\<infinity> = z + z \<cdot> y \<cdot> y\<^sup>\<infinity>"
    by simp
  also have "... \<le> z + x \<cdot> z \<cdot> y\<^sup>\<infinity>"
    by (metis assms add.commute add_iso mult_isor)
  finally show "z \<cdot> y\<^sup>\<infinity> \<le> x\<^sup>\<infinity> \<cdot> z"
    by (simp add: local.coinduction mult_assoc)
qed

text \<open>Nitpick gives a counterexample to the dual simulation law.\<close>

lemma "y \<cdot> z \<le> z \<cdot> x \<Longrightarrow> y\<^sup>\<infinity> \<cdot> z \<le> z \<cdot> x\<^sup>\<infinity>"
(*nitpick [expect=genuine]*)
oops

text \<open>Next, we prove some sliding laws.\<close>

lemma iteration_slide_var: "x \<cdot> (y \<cdot> x)\<^sup>\<infinity> \<le> (x \<cdot> y)\<^sup>\<infinity> \<cdot> x"
  by (simp add: iteration_sim mult_assoc)

lemma iteration_prod_unfold [simp]: "1 + y \<cdot> (x \<cdot> y)\<^sup>\<infinity> \<cdot> x = (y \<cdot> x)\<^sup>\<infinity>"
proof (rule order.antisym)
  have "1 + y \<cdot> (x \<cdot> y)\<^sup>\<infinity> \<cdot> x \<le> 1 + (y \<cdot> x)\<^sup>\<infinity> \<cdot> y \<cdot> x"
    using iteration_slide_var local.join.sup_mono local.mult_isor by blast
  thus "1 + y \<cdot> (x \<cdot> y)\<^sup>\<infinity> \<cdot> x \<le>  (y \<cdot> x)\<^sup>\<infinity>"
    by (simp add: mult_assoc)
  have "(y \<cdot> x)\<^sup>\<infinity> = 1 + y \<cdot> x \<cdot> (y \<cdot> x)\<^sup>\<infinity>"
    by simp
  thus "(y \<cdot> x)\<^sup>\<infinity> \<le> 1 + y \<cdot> (x \<cdot> y)\<^sup>\<infinity> \<cdot> x"
    by (metis iteration_sim local.eq_refl local.join.sup.mono local.mult_isol mult_assoc)
qed

lemma iteration_slide: "x \<cdot> (y \<cdot> x)\<^sup>\<infinity> = (x \<cdot> y)\<^sup>\<infinity> \<cdot> x"
  by (metis iteration_prod_unfold iteration_unfoldl_distr distrib_left mult_1_right mult.assoc)

lemma star_iteration_slide [simp]: " y\<^sup>\<star> \<cdot> (x\<^sup>\<star> \<cdot> y)\<^sup>\<infinity> = (x\<^sup>\<star> \<cdot> y)\<^sup>\<infinity>"
  by (metis iteration_star2 local.conway.dagger_unfoldl_distr local.join.sup.orderE local.mult_isor local.star_invol local.star_subdist local.star_trans_eq)

text \<open>The following laws are called denesting laws.\<close>

lemma iteration_sub_denest: "(x + y)\<^sup>\<infinity> \<le> x\<^sup>\<infinity> \<cdot> (y \<cdot> x\<^sup>\<infinity>)\<^sup>\<infinity>"
proof -
  have "(x + y)\<^sup>\<infinity> = x \<cdot> (x + y)\<^sup>\<infinity> + y \<cdot> (x + y)\<^sup>\<infinity> + 1"
    by (metis add.commute distrib_right' iteration_unfoldl)
  hence "(x + y)\<^sup>\<infinity> \<le> x\<^sup>\<infinity> \<cdot> (y \<cdot> (x + y)\<^sup>\<infinity> + 1)"
    by (metis add_assoc' join.sup_least join.sup_ge1 join.sup_ge2 coinduction)
  moreover hence "x\<^sup>\<infinity> \<cdot> (y \<cdot> (x + y)\<^sup>\<infinity> + 1) \<le> x\<^sup>\<infinity> \<cdot> (y \<cdot> x\<^sup>\<infinity>)\<^sup>\<infinity>"
    by (metis add_iso mult.assoc mult_isol add.commute coinduction mult_oner mult_isol)
  ultimately show ?thesis
    using local.order_trans by blast
qed

lemma iteration_denest: "(x + y)\<^sup>\<infinity> = x\<^sup>\<infinity> \<cdot> (y \<cdot> x\<^sup>\<infinity>)\<^sup>\<infinity>"
proof -
  have "x\<^sup>\<infinity> \<cdot> (y \<cdot> x\<^sup>\<infinity>)\<^sup>\<infinity> \<le> x \<cdot> x\<^sup>\<infinity> \<cdot> (y \<cdot> x\<^sup>\<infinity>)\<^sup>\<infinity> + y \<cdot> x\<^sup>\<infinity> \<cdot> (y \<cdot> x\<^sup>\<infinity>)\<^sup>\<infinity> + 1"
    by (metis add.commute iteration_unfoldl_distr add_assoc' add.commute iteration_unfoldl order_refl)
  thus ?thesis
    by (metis add.commute iteration_sub_denest order.antisym coinduction distrib_right' iteration_sub_denest mult.assoc mult_oner order.antisym)
qed
(*
end

sublocale dra \<subseteq> conway_zerol strong_iteration
  apply (unfold_locales)
  apply (simp add: iteration_denest iteration_slide)
  apply simp
  by (simp add: iteration_sim)

context dra
begin
*)
lemma iteration_denest2 [simp]: "y\<^sup>\<star> \<cdot> x \<cdot> (x + y)\<^sup>\<infinity> + y\<^sup>\<infinity> = (x + y)\<^sup>\<infinity>"
proof -
  have "(x + y)\<^sup>\<infinity> = y\<^sup>\<infinity> \<cdot> x \<cdot> (y\<^sup>\<infinity> \<cdot> x)\<^sup>\<infinity> \<cdot> y\<^sup>\<infinity> + y\<^sup>\<infinity>"
    by (metis add.commute iteration_denest iteration_slide iteration_unfoldl_distr)
  also have "... = y\<^sup>\<star> \<cdot> x \<cdot> (y\<^sup>\<infinity> \<cdot> x)\<^sup>\<infinity> \<cdot> y\<^sup>\<infinity> + y\<^sup>\<infinity> \<cdot> 0 + y\<^sup>\<infinity>"
    by (metis isolation mult.assoc distrib_right' annil mult.assoc)
  also have "... = y\<^sup>\<star> \<cdot> x \<cdot> (y\<^sup>\<infinity> \<cdot> x)\<^sup>\<infinity> \<cdot> y\<^sup>\<infinity> + y\<^sup>\<infinity>"
    by (metis add.assoc distrib_left mult_1_right add_0_left mult_1_right)
  finally show ?thesis
    by (metis add.commute iteration_denest iteration_slide mult.assoc)
qed

lemma iteration_denest3: "(y\<^sup>\<star> \<cdot> x)\<^sup>\<infinity> \<cdot> y\<^sup>\<infinity> = (x + y)\<^sup>\<infinity>"
proof (rule order.antisym)
  have  "(y\<^sup>\<star> \<cdot> x)\<^sup>\<infinity> \<cdot> y\<^sup>\<infinity> \<le> (y\<^sup>\<infinity> \<cdot> x)\<^sup>\<infinity> \<cdot> y\<^sup>\<infinity>"
    by (simp add: iteration_iso iteration_ref_star local.mult_isor)
  thus  "(y\<^sup>\<star> \<cdot> x)\<^sup>\<infinity> \<cdot> y\<^sup>\<infinity> \<le> (x + y)\<^sup>\<infinity>"
    by (metis iteration_denest iteration_slide local.join.sup_commute)
  have "(x + y)\<^sup>\<infinity> = y\<^sup>\<infinity> + y\<^sup>\<star> \<cdot> x \<cdot> (x + y)\<^sup>\<infinity>"
    by (metis iteration_denest2 local.join.sup_commute)
  thus "(x + y)\<^sup>\<infinity> \<le> (y\<^sup>\<star> \<cdot> x)\<^sup>\<infinity> \<cdot> y\<^sup>\<infinity>"
    by (simp add: local.coinduction)
qed

text \<open>Now we prove separation laws for reasoning about distributed systems in the context of action systems.\<close>

lemma iteration_sep: "y \<cdot> x \<le> x \<cdot> y \<Longrightarrow> (x + y)\<^sup>\<infinity> = x\<^sup>\<infinity> \<cdot> y\<^sup>\<infinity>"
proof -
  assume "y \<cdot> x \<le> x \<cdot> y"
  hence "y\<^sup>\<star> \<cdot> x \<le> x\<cdot>(x + y)\<^sup>\<star>"
    by (metis star_sim1 add.commute mult_isol order_trans star_subdist)
  hence "y\<^sup>\<star> \<cdot> x \<cdot> (x + y)\<^sup>\<infinity> + y\<^sup>\<infinity> \<le> x \<cdot> (x + y)\<^sup>\<infinity> + y\<^sup>\<infinity>"
    by (metis mult_isor mult.assoc iteration_star2 join.sup.mono eq_refl)
  thus ?thesis
    by (metis iteration_denest2 add.commute coinduction add.commute less_eq_def iteration_subdenest)
qed

lemma iteration_sim2: "y \<cdot> x \<le> x \<cdot> y \<Longrightarrow> y\<^sup>\<infinity> \<cdot> x\<^sup>\<infinity> \<le> x\<^sup>\<infinity> \<cdot> y\<^sup>\<infinity>"
  by (metis add.commute iteration_sep iteration_subdenest)

lemma iteration_sep2: "y \<cdot> x \<le> x \<cdot> y\<^sup>\<star> \<Longrightarrow> (x + y)\<^sup>\<infinity> = x\<^sup>\<infinity> \<cdot> y\<^sup>\<infinity>"
proof -
  assume "y \<cdot> x \<le> x \<cdot> y\<^sup>\<star>"
  hence "y\<^sup>\<star> \<cdot> (y\<^sup>\<star> \<cdot> x)\<^sup>\<infinity> \<cdot> y\<^sup>\<infinity> \<le> x\<^sup>\<infinity> \<cdot> y\<^sup>\<star> \<cdot> y\<^sup>\<infinity>"
    by (metis mult.assoc mult_isor iteration_sim star_denest_var_2 star_sim1 star_slide_var star_trans_eq tc_eq)
  moreover have "x\<^sup>\<infinity> \<cdot> y\<^sup>\<star> \<cdot> y\<^sup>\<infinity> \<le> x\<^sup>\<infinity> \<cdot> y\<^sup>\<infinity>"
    by (metis eq_refl mult.assoc iteration_star2)
  moreover have "(y\<^sup>\<star> \<cdot> x)\<^sup>\<infinity> \<cdot> y\<^sup>\<infinity> \<le> y\<^sup>\<star> \<cdot> (y\<^sup>\<star> \<cdot> x)\<^sup>\<infinity> \<cdot> y\<^sup>\<infinity>"
    by (metis mult_isor mult_onel star_ref)
  ultimately show ?thesis
    by (metis order.antisym iteration_denest3 iteration_subdenest order_trans)
qed

lemma iteration_sep3: "y \<cdot> x \<le> x \<cdot> (x + y) \<Longrightarrow> (x + y)\<^sup>\<infinity> = x\<^sup>\<infinity> \<cdot> y\<^sup>\<infinity>"
proof -
  assume "y \<cdot> x \<le> x \<cdot> (x + y)"
  hence "y\<^sup>\<star> \<cdot> x \<le> x \<cdot> (x + y)\<^sup>\<star>"
    by (metis star_sim1)
  hence "y\<^sup>\<star> \<cdot> x \<cdot> (x + y)\<^sup>\<infinity> + y\<^sup>\<infinity> \<le> x \<cdot> (x + y)\<^sup>\<star> \<cdot> (x + y)\<^sup>\<infinity> + y\<^sup>\<infinity>"
    by (metis add_iso mult_isor)
  hence "(x + y)\<^sup>\<infinity> \<le> x\<^sup>\<infinity> \<cdot> y\<^sup>\<infinity>"
    by (metis mult.assoc iteration_denest2 iteration_star2 add.commute coinduction)
  thus ?thesis
    by (metis add.commute less_eq_def iteration_subdenest)
qed

lemma iteration_sep4: "y \<cdot> 0 = 0 \<Longrightarrow> z \<cdot> x = 0 \<Longrightarrow> y \<cdot> x \<le> (x + z) \<cdot> y\<^sup>\<star> \<Longrightarrow> (x + y + z)\<^sup>\<infinity> = x\<^sup>\<infinity> \<cdot> (y + z)\<^sup>\<infinity>"
proof -
  assume assms: "y \<cdot> 0 = 0" "z \<cdot> x = 0" "y \<cdot> x \<le> (x + z) \<cdot> y\<^sup>\<star>"
  have "y \<cdot> y\<^sup>\<star> \<cdot> z \<le> y\<^sup>\<star> \<cdot> z \<cdot> y\<^sup>\<star>"
    by (metis mult_isor star_1l mult_oner order_trans star_plus_one subdistl)
  have "y\<^sup>\<star> \<cdot> z \<cdot> x \<le> x \<cdot> y\<^sup>\<star> \<cdot> z"
    by (metis join.bot_least assms(1) assms(2) independence1 mult.assoc)
  have "y \<cdot> (x + y\<^sup>\<star> \<cdot> z) \<le> (x + z) \<cdot> y\<^sup>\<star> + y \<cdot> y\<^sup>\<star> \<cdot> z"
    by (metis assms(3) distrib_left mult.assoc add_iso)
  also have "... \<le> (x + y\<^sup>\<star> \<cdot> z) \<cdot> y\<^sup>\<star> + y \<cdot> y\<^sup>\<star> \<cdot> z"
    by (metis star_ref join.sup.mono eq_refl mult_1_left mult_isor)
  also have "... \<le> (x + y\<^sup>\<star> \<cdot> z) \<cdot> y\<^sup>\<star> + y\<^sup>\<star> \<cdot> z  \<cdot> y\<^sup>\<star>" using \<open>y \<cdot> y\<^sup>\<star> \<cdot> z \<le> y\<^sup>\<star> \<cdot> z \<cdot> y\<^sup>\<star>\<close>
    by (metis add.commute add_iso)
  finally have "y \<cdot> (x + y\<^sup>\<star> \<cdot> z) \<le> (x + y\<^sup>\<star> \<cdot> z) \<cdot> y\<^sup>\<star>"
    by (metis add.commute add_idem' add.left_commute distrib_right)
  moreover have "(x + y + z)\<^sup>\<infinity> \<le> (x + y + y\<^sup>\<star> \<cdot> z)\<^sup>\<infinity>"
    by (metis star_ref join.sup.mono eq_refl mult_1_left mult_isor iteration_iso)
  moreover have "... = (x + y\<^sup>\<star> \<cdot> z)\<^sup>\<infinity> \<cdot> y\<^sup>\<infinity>"
    by (metis add_commute calculation(1) iteration_sep2 local.add_left_comm)
  moreover have "... = x\<^sup>\<infinity> \<cdot> (y\<^sup>\<star> \<cdot> z)\<^sup>\<infinity> \<cdot> y\<^sup>\<infinity>" using \<open>y\<^sup>\<star> \<cdot> z \<cdot> x \<le> x \<cdot> y\<^sup>\<star> \<cdot> z\<close>
    by (metis iteration_sep mult.assoc)
  ultimately have "(x + y + z)\<^sup>\<infinity> \<le> x\<^sup>\<infinity> \<cdot> (y + z)\<^sup>\<infinity>"
    by (metis add.commute mult.assoc iteration_denest3)
  thus ?thesis
    by (metis add.commute add.left_commute less_eq_def iteration_subdenest)
qed

text \<open>Finally, we prove some blocking laws.\<close>

text \<open>Nitpick refutes the next lemma.\<close>

lemma "x \<cdot> y = 0 \<Longrightarrow> x\<^sup>\<infinity> \<cdot> y = y"
(*nitpick*)
oops

lemma iteration_idep: "x \<cdot> y = 0 \<Longrightarrow> x \<cdot> y\<^sup>\<infinity> = x"
  by (metis add_zeror annil iteration_unfoldl_distl)

text \<open>Nitpick refutes the next lemma.\<close>

lemma "y \<cdot> w \<le> x \<cdot> y + z \<Longrightarrow> y \<cdot> w\<^sup>\<infinity> \<le> x\<^sup>\<infinity> \<cdot> z"
(*nitpick [expect=genuine]*)
oops

text \<open>At the end of this file, we consider a data refinement example from von Wright~\<^cite>\<open>"Wright02"\<close>.\<close>

lemma data_refinement:
  assumes "s' \<le> s \<cdot> z" and "z \<cdot> e' \<le> e" and "z \<cdot> a' \<le> a \<cdot> z" and "z \<cdot> b \<le> z" and "b\<^sup>\<infinity> = b\<^sup>\<star>"
  shows "s' \<cdot> (a' + b)\<^sup>\<infinity> \<cdot> e' \<le> s \<cdot> a\<^sup>\<infinity> \<cdot> e"
proof -
  have "z \<cdot> b\<^sup>\<star> \<le> z"
    by (metis assms(4) star_inductr_var)
  have "(z \<cdot> a') \<cdot> b\<^sup>\<star> \<le> (a \<cdot> z) \<cdot> b\<^sup>\<star>"
    by (metis assms(3) mult.assoc mult_isor)
  hence "z \<cdot> (a' \<cdot> b\<^sup>\<star>)\<^sup>\<infinity> \<le>  a\<^sup>\<infinity> \<cdot> z" using \<open>z \<cdot> b\<^sup>\<star> \<le> z\<close>
    by (metis mult.assoc mult_isol order_trans iteration_sim mult.assoc)
  have "s' \<cdot> (a' + b)\<^sup>\<infinity> \<cdot> e' \<le> s' \<cdot> b\<^sup>\<star> \<cdot> (a' \<cdot> b\<^sup>\<star>)\<^sup>\<infinity> \<cdot> e'"
    by (metis add.commute assms(5) eq_refl iteration_denest mult.assoc)
  also have "... \<le> s \<cdot> z \<cdot> b\<^sup>\<star> \<cdot> (a' \<cdot> b\<^sup>\<star>)\<^sup>\<infinity> \<cdot> e'"
    by (metis assms(1) mult_isor)
  also have "... \<le> s \<cdot> z \<cdot> (a' \<cdot> b\<^sup>\<star>)\<^sup>\<infinity> \<cdot> e'" using \<open>z \<cdot> b\<^sup>\<star> \<le> z\<close>
    by (metis mult.assoc mult_isol mult_isor)
  also have "... \<le> s \<cdot> a\<^sup>\<infinity> \<cdot> z \<cdot> e'" using \<open>z \<cdot> (a' \<cdot> b\<^sup>\<star>)\<^sup>\<infinity> \<le>  a\<^sup>\<infinity> \<cdot> z\<close>
    by (metis mult.assoc mult_isol mult_isor)
  finally show ?thesis
    by (metis assms(2) mult.assoc mult_isol mult.assoc mult_isol order_trans)
qed

end

end


theory PermEnv
  imports Main
begin

    (*
      ####################################
        P1. permission definitions
      ####################################
    *)

datatype p_perm = NoPerm | UsePerm | OwnPerm

datatype ext_perm = NoEP | DiffEP | OwnEP

fun leq_perm where
  "leq_perm UsePerm NoPerm = False"
| "leq_perm OwnPerm NoPerm = False"
| "leq_perm OwnPerm UsePerm = False"
| "leq_perm p1 p2 = True"

fun minus_ep where
  "minus_ep NoPerm p = NoPerm"
| "minus_ep UsePerm OwnEP = NoPerm"
| "minus_ep UsePerm p = UsePerm"
| "minus_ep OwnPerm OwnEP = NoPerm"
| "minus_ep OwnPerm DiffEP = UsePerm"
| "minus_ep OwnPerm p = OwnPerm"

fun union_ep where
  "union_ep OwnPerm p = OwnPerm"
| "union_ep UsePerm OwnEP = OwnPerm"
| "union_ep UsePerm DiffEP = OwnPerm"
| "union_ep UsePerm p = UsePerm"
| "union_ep NoPerm OwnEP = OwnPerm"
| "union_ep NoPerm DiffEP = UsePerm"
| "union_ep NoPerm NoEP = NoPerm"

fun union_perm where
  "union_perm OwnPerm p = OwnPerm"
| "union_perm p OwnPerm = OwnPerm"
| "union_perm NoPerm NoPerm = NoPerm"
| "union_perm p1 p2 = UsePerm"

    (*
      ####################################
        P2.
      ####################################
    *)

type_synonym perm_use_env = "string \<Rightarrow> p_perm"

type_synonym ep_use_env = "string \<Rightarrow> ext_perm"

definition empty_use_env where
  "empty_use_env x = NoPerm"

definition add_use_env where
  "add_use_env env x p = (\<lambda> x'. if x = x' then p else env x')"

definition rem_use_env where
  "rem_use_env env x = (\<lambda> x'. if x = x' then NoPerm else env x')"

definition leq_use_env where
  "leq_use_env env1 env2 = (\<forall> x. leq_perm (env1 x) (env2 x))"

   (* shift related functions *)

definition one_use_env where
  "one_use_env x r = (\<lambda> x'. if x = x' then r else NoPerm)"

fun neg_perm where
  "neg_perm OwnPerm = OwnEP"
| "neg_perm p = NoEP"

definition neg_use_env where
  "neg_use_env env = (\<lambda> x. neg_perm (env x))"

definition empty_ep_use_env where
  "empty_ep_use_env x = NoEP"

definition minus_use_env where
  "minus_use_env env1 env2 = (\<lambda> x. minus_ep (env1 x) (env2 x))"

definition diff_use_env where
  "diff_use_env env1 env2 = minus_use_env env1 (neg_use_env env2)"

definition comp_use_env where
  "comp_use_env r_s1 r_s2 = (\<lambda> x. union_perm (r_s1 x) (r_s2 x))"

definition mini_disj_use_env where
  "mini_disj_use_env r_s r_ex = (\<forall> x. r_s x = OwnPerm \<longrightarrow> r_ex x = NoPerm)"

definition disj_use_env where
  "disj_use_env r_s1 r_s2 = (mini_disj_use_env r_s1 r_s2 \<and> mini_disj_use_env r_s2 r_s1)"

definition weak_use_env where
  "weak_use_env r_s = (\<forall> x. r_s x \<noteq> OwnPerm)"

definition is_own where
  "is_own r = (r = OwnPerm)"

    (* #### no perm lemmas #### *)

    (* - none lemmas *)

lemma leq_use_none: "\<lbrakk> leq_use_env r_x r_s; r_s x = NoPerm \<rbrakk> \<Longrightarrow> r_x x = NoPerm"
  apply (simp add: leq_use_env_def)
  apply (erule_tac x="x" in allE)
  apply (case_tac "r_x x")
    apply (auto)
  done

lemma add_use_none_rev: "\<lbrakk> r_s x = NoPerm ; x \<noteq> y \<rbrakk> \<Longrightarrow> add_use_env r_s y r x = NoPerm"
  apply (simp add: add_use_env_def)
  done

lemma minus_use_none_infer: "\<lbrakk> minus_use_env r_s r_ex x = NoPerm; r_s x \<noteq> NoPerm \<rbrakk> \<Longrightarrow> minus_use_env r_x r_ex x = NoPerm"
  apply (simp add: minus_use_env_def)
  apply (case_tac "r_s x")
    apply (auto)
   apply (case_tac "r_ex x")
     apply (auto)
   apply (case_tac "r_x x")
     apply (auto)
  apply (case_tac "r_ex x")
    apply (auto)
  apply (case_tac "r_x x")
    apply (auto)
  done

lemma diff_use_none_infer: "\<lbrakk> r_x x = OwnPerm; diff_use_env r_x r_ex x \<noteq> OwnPerm \<rbrakk> \<Longrightarrow> diff_use_env r_s r_ex x = NoPerm"
  apply (simp add: diff_use_env_def)
  apply (simp add: neg_use_env_def)
  apply (simp add: minus_use_env_def)
  apply (case_tac "r_ex x")
    apply (auto)
  apply (case_tac "r_s x")
    apply (auto)
  done

lemma diff_use_none: "\<lbrakk> r_x x \<noteq> NoPerm; diff_use_env r_x r_ex x = NoPerm \<rbrakk> \<Longrightarrow> diff_use_env r_s r_ex x = NoPerm"
  apply (simp add: diff_use_env_def)
  apply (simp add: neg_use_env_def)
  apply (simp add: minus_use_env_def)
  apply (case_tac "r_x x")
    apply (auto)
   apply (case_tac "r_s x")
     apply (auto)
   apply (case_tac "r_ex x")
     apply (auto)
  apply (case_tac "r_ex x")
    apply (auto)
  apply (case_tac "r_s x")
    apply (auto)
  done

lemma diff_use_none_ex: "\<lbrakk> r_ex x = OwnPerm \<rbrakk> \<Longrightarrow> diff_use_env r_s r_ex x = NoPerm"
  apply (simp add: diff_use_env_def)
  apply (simp add: neg_use_env_def)
  apply (simp add: minus_use_env_def)
  apply (case_tac "r_s x")
    apply (auto)
  done

lemma comp_use_none: "\<lbrakk> r_sa x = NoPerm; r_sb x = NoPerm \<rbrakk> \<Longrightarrow> comp_use_env r_sa r_sb x = NoPerm"
  apply (simp add: comp_use_env_def)
  done

lemma comp_use_none_both: "\<lbrakk> comp_use_env r_sa r_sb x = NoPerm \<rbrakk> \<Longrightarrow> r_sa x = NoPerm \<and> r_sb x = NoPerm"
  apply (simp add: comp_use_env_def)
  apply (case_tac "r_sa x")
    apply (auto)
   apply (case_tac "r_sb x")
     apply (auto)
  apply (case_tac "r_sb x")
    apply (auto)
  done

    (* - no own lemmas *)

lemma leq_use_no_own: "\<lbrakk> r_s x \<noteq> OwnPerm; leq_use_env r_x r_s \<rbrakk> \<Longrightarrow> r_x x \<noteq> OwnPerm"
  apply (simp add: leq_use_env_def)
  apply (erule_tac x="x" in allE)
  apply (case_tac "r_s x")
    apply (auto)
  done

lemma comp_use_no_own_both: "\<lbrakk> comp_use_env r_sa r_sb x \<noteq> OwnPerm \<rbrakk> \<Longrightarrow> r_sa x \<noteq> OwnPerm \<and> r_sb x \<noteq> OwnPerm"
  apply (simp add: comp_use_env_def)
  apply (auto)
  apply (case_tac "r_sa x")
    apply (auto)
  done

lemma diff_use_no_own: "\<lbrakk> diff_use_env r_s r_ex x \<noteq> NoPerm \<rbrakk> \<Longrightarrow> r_ex x \<noteq> OwnPerm"
  apply (simp add: diff_use_env_def)
  apply (simp add: minus_use_env_def)
  apply (simp add: neg_use_env_def)
  apply (case_tac "r_ex x")
    apply (auto)
  apply (case_tac "r_s x")
    apply (auto)
  done

    (* - own lemmas *)

lemma leq_use_own: "\<lbrakk> r_x x = OwnPerm; leq_use_env r_x r_s \<rbrakk> \<Longrightarrow> r_s x = OwnPerm"
  apply (simp add: leq_use_env_def)
  apply (erule_tac x="x" in allE)
  apply (auto)
  apply (case_tac "r_s x")
    apply (auto)
  done

lemma diff_use_own: "\<lbrakk> leq_use_env (diff_use_env r_x r_ex) r_s; r_x x \<noteq> NoPerm; r_s x = NoPerm \<rbrakk> \<Longrightarrow> r_ex x = OwnPerm"
  apply (simp add: diff_use_env_def)
  apply (simp add: minus_use_env_def)
  apply (simp add: neg_use_env_def)
  apply (simp add: leq_use_env_def)
  apply (erule_tac x="x" in allE)
  apply (case_tac "r_x x")
    apply (auto)
   apply (case_tac "r_ex x")
     apply (auto)
  apply (case_tac "r_ex x")
    apply (auto)
  done

   (* - eq lemmas *)

lemma diff_use_eq: "\<lbrakk> r_x x \<noteq> OwnPerm \<rbrakk> \<Longrightarrow> diff_use_env r_s r_x x = r_s x"
  apply (simp add: diff_use_env_def)
  apply (simp add: minus_use_env_def)
  apply (simp add: neg_use_env_def)
  apply (case_tac "r_x x")
    apply (auto)
   apply (case_tac "r_s x")
     apply (auto)
  apply (case_tac "r_s x")
    apply (auto)
  done

    (* - fundamental lemmas *)

lemma spec_leq_perm: "\<lbrakk> leq_use_env r_x r_s \<rbrakk> \<Longrightarrow> leq_perm (r_x x) (r_s x)"
  apply (simp add: leq_use_env_def)
  done

    (* - leq lemmas *)

lemma diff_use_leq: "\<lbrakk> r_ex x \<noteq> OwnPerm; leq_use_env (diff_use_env r_x r_ex) r_s \<rbrakk> \<Longrightarrow> leq_perm (r_x x) (r_s x)"
  apply (simp add: leq_use_env_def)
  apply (erule_tac x="x" in allE)
  apply (simp add: diff_use_env_def)
  apply (simp add: minus_use_env_def)
  apply (simp add: neg_use_env_def)
  apply (case_tac "r_x x")
    apply (auto)
   apply (case_tac "r_ex x")
     apply (auto)
  apply (case_tac "r_ex x")
    apply (auto)
  done

lemma diff_use_leq2: "\<lbrakk> leq_use_env r_x (diff_use_env r_s r_ex); r_ex x \<noteq> OwnPerm \<rbrakk> \<Longrightarrow> leq_perm (r_x x) (r_s x)"
  apply (simp add: leq_use_env_def)
  apply (erule_tac x="x" in allE)
  apply (simp add: diff_use_env_def)
  apply (simp add: minus_use_env_def)
  apply (simp add: neg_use_env_def)
  apply (case_tac "r_ex x")
    apply (auto)
   apply (case_tac "r_s x")
     apply (auto)
  apply (case_tac "r_s x")
    apply (auto)
  done

end


theory Chap5 imports Main
begin
lemma "\<not>  surj (f::'a \<Rightarrow> 'a set)"
proof
  assume 0: "surj f"
  from 0 have 1: "\<forall>A. \<exists>a. A = f a" by (simp add: surj_def)
  from 1 have 2: "\<exists>a. {x. x \<notin> f x} = f a" by blast
  from 2 show "False" by blast
qed

lemma "\<not>surj (f::'a \<Rightarrow> 'a set)"
proof
  assume "surj f"
  from this have "\<exists>a. {x. x \<notin> f x} = f a" by (auto simp: surj_def)
  from this show False by blast
qed

lemma "\<not>surj (f::'a \<Rightarrow> 'a set)"
proof
  assume "surj f"
  hence "\<exists>a. {x. x \<notin> f x} = f a" by (auto simp: surj_def)
  thus "False" by blast
qed

lemma
  fixes f :: "'a \<Rightarrow> 'a set"
  assumes s: "surj f"
  shows "False"
proof -
  have "\<exists>a. {x. x \<notin> f x} = f a" using s by (auto simp: surj_def)
  thus ?thesis by blast
qed

lemma "\<not>surj (f::'a \<Rightarrow> 'a set)"
proof
  assume "surj f"
  hence "\<exists>a. {x. x \<notin> f x} = f a" by (auto simp: surj_def)
  then obtain a where "{x. x \<notin> f x} = f a" by blast
  hence "a \<in> f a \<longleftrightarrow> a \<notin> f a" by blast
  thus "False" by blast
qed

lemma "R"
proof cases
  assume P
  show R sorry
next
  assume "\<not>P"
  show R sorry
qed

lemma assumes "P \<or> Q" shows R
  using assms
proof
  assume P
  show R sorry
next
  assume Q
  show R sorry
qed

lemma "P \<longleftrightarrow> Q"
proof
  assume P show Q sorry
next
  assume Q show P sorry
qed

lemma "P"
proof (rule ccontr)
  assume "\<not>P"
  show "False" sorry
qed

lemma "\<forall>x. P x"
proof
  fix y
  show "P y" sorry
qed

lemma "(A::'a set) = B"
proof
  show "A\<le>B" sorry
next
  show "B\<le>A" sorry
qed

lemma "(A::'a set) \<le> B"
proof
  fix x
  assume "x \<in> A"
  show "x \<in> B" sorry
qed

lemma "formula\<^sub>1 \<longleftrightarrow> formula\<^sub>2" (is "?L \<longleftrightarrow> ?R")
proof
  assume "?L"
  show "?R" sorry
next
  assume "?R"
  show "?L" sorry
qed

lemma "\<forall>(x::nat). x \<ge> 0"
proof
  fix x :: nat
  have "x \<ge> 0" sorry
  from `x \<ge> 0` show "x \<ge> 0" sorry
qed

lemma P
proof -
  have P1 sorry
  moreover have P2 sorry
  ultimately have P3 sorry
  thus P sorry
qed

lemma fixes a b :: int assumes "b dvd (a+b)" shows "b dvd a"
proof -
  have "\<exists>k'. a = b*k'" if asm: "a+b = b*k" for k
  proof
    show "a = b*(k-1)" using asm by (simp add: algebra_simps)
  qed
  then show ?thesis using assms by (auto simp add: dvd_def)
qed

lemma assumes T: "\<forall>x y. T x y \<or> T y x"
and A: "\<forall>x y. A x y \<and> A y x \<longrightarrow> x = y"
and TA: "\<forall>x y. T x y \<longrightarrow> A x y" and "A x y"
shows "T x y"
proof (rule disjE[of "T x y" "T y x"])
  show "T x y \<or> T y x" using T by blast
next
  show "T x y \<Longrightarrow> T x y" by assumption
next
  assume 1: "T y x"
  hence "A y x" using TA by blast
  hence "x = y" using A assms by blast
  thus "T x y" using 1 by blast
qed

lemma "\<exists>ys zs. xs = ys@zs \<and> (length ys = length zs \<or> length ys = length zs + 1)"
proof -
  obtain k r where f1: "length xs = 2*k + r" and f2: "r = 0 \<or> r = 1"
    by (metis bot_nat_0.not_eq_extremum mod2_gr_0 mult_div_mod_eq)
  let ?ys = "take (k+r) xs" and ?zs = "drop (k+r) xs"
  have "length ?ys = k+r" and "length ?zs = k" using f1 by auto
  hence "length ?ys = length ?zs \<or> length ?ys = length ?zs + 1" using f2 by simp
  moreover have "xs = ?ys@?zs" by simp
  ultimately show ?thesis by blast
qed

lemma "length (tl xs) = length xs - 1"
proof (cases xs)
  assume "xs = []"
  thus ?thesis by simp
next
  fix y ys assume "xs = y#ys"
  thus ?thesis by simp
qed

lemma "length (tl xs) = length xs - 1"
proof (cases xs)
  case Nil
  then show ?thesis by simp
next
  case (Cons a list)
  then show ?thesis by simp
qed

lemma "\<Sum>{0..n::nat} = n*(n+1) div 2" (is "?P n")
proof (induction n)
  show "?P 0" by simp
next
  fix n assume "?P n"
  thus "?P (Suc n)" by simp
qed

lemma "\<Sum>{0..n::nat} = n*(n+1) div 2" (is "?P n")
proof (induction n)
  case 0
  then show ?case by simp
next
  case (Suc n)
  then show ?case by simp
qed

inductive ev :: "nat \<Rightarrow> bool" where
ev0: "ev 0"
| evSS: "ev n \<Longrightarrow> ev (Suc (Suc n))"

fun evn :: "nat \<Rightarrow> bool" where
"evn 0 = True"
| "evn (Suc 0) = False"
| "evn (Suc (Suc n)) = evn n"

lemma "ev n \<Longrightarrow> evn n"
proof (induction rule: ev.induct)
  case ev0
  then show ?case by simp
next
  case evSS
  thus ?case by simp
qed

lemma "ev n \<Longrightarrow> evn n"
proof (induction rule: ev.induct)
  case ev0
  then show ?case by simp
next
  case (evSS n)
  thm evSS.IH
  thm evSS.hyps
  thm evSS.prems
  then have "evn (Suc (Suc n)) = evn n" by simp
  thus ?case using \<open>evn n\<close> by blast
qed

lemma "ev n \<Longrightarrow> ev (n-2)"
proof -
  assume "ev n"
  thus "ev (n-2)"
  proof cases
    case ev0
    then show ?thesis by (simp add: ev.ev0)
  next
    case (evSS n)
    then show ?thesis by (simp add: ev.evSS)
  qed
qed

lemma "ev (Suc 0) \<Longrightarrow> P"
proof -
  assume "ev (Suc 0)" then show "P" by cases
qed

lemma "\<not>ev (Suc (Suc (Suc 0)))"
proof
  assume "ev (Suc (Suc (Suc 0)))"
  from this have "ev (Suc 0)" by cases
  thus False by cases
qed

fun P :: "nat \<Rightarrow> bool" where
"P (Suc n) = (\<not>ev n)"
| "P _ = True"

lemma "ev n \<Longrightarrow> P n \<Longrightarrow> \<not> ev (Suc n)"
proof (cases n)
  case 0
  then show ?thesis sorry
next
  case (Suc nat)
  then show ?thesis sorry
qed

lemma "ev (Suc m) \<Longrightarrow>
P 0 \<Longrightarrow> (\<And>n. ev n \<Longrightarrow> P n \<Longrightarrow> P (Suc (Suc n))) \<Longrightarrow> P (Suc m)"
  apply simp
  oops

lemma "ev (Suc m) \<Longrightarrow> \<not>ev m"
  thm ev.induct[where x="Suc m" and P=P]
proof (induction "Suc m" arbitrary: m rule: ev.induct)
  fix n assume IH: "\<And>m. n = Suc m \<Longrightarrow> \<not>ev m"
  show "\<not>ev (Suc n)"
  proof
    assume "ev (Suc n)"
    thus False
    proof cases
      fix k assume "n = Suc k" "ev k"
      thus False using IH by auto
    qed
  qed
qed

lemma
  assumes "ev (Suc (Suc n))"
  shows "ev n"
  using assms
proof cases
  assume "ev n" thus "ev n" by blast
qed

inductive star :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" for r where
refl: "star r x x"
| step: "r x y \<Longrightarrow> star r y z \<Longrightarrow> star r x z"

inductive iter :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" for r where
"iter r 0 x x"
| "iter r n y z \<Longrightarrow> r x y \<Longrightarrow> iter r (n+1) x z"

lemma "iter r n x y \<Longrightarrow> star r x y"
proof (induction rule: iter.induct)
  case (1 x)
  show ?case using refl by force
next
  case (2 n y z x)
  from 2(2) 2(3) show ?case using step by force
qed

fun elems :: "'a list \<Rightarrow> 'a set" where
"elems [] = {}"
| "elems (x#xs) = insert x (elems xs)"

lemma "x \<in> elems xs \<Longrightarrow> \<exists>ys zs. xs = ys @ x # zs \<and> x \<notin> elems ys"
proof (induction xs)
  case Nil
  hence False by simp
  thus ?case by blast
next
  case (Cons a xs)
  show ?case
  proof (cases "x = a")
    case True
    hence "a # xs = [] @ x # xs" by simp
    moreover have "x \<notin> elems []" by simp
    ultimately show ?thesis by blast
  next
    case False
    then obtain ys zs where "xs = ys @ x # zs" and 1: "x \<notin> elems ys"
      using Cons by auto
    hence "a # xs = (a#ys) @ x # zs" by simp
    moreover have "x \<notin> elems (a#ys)" using False 1 by simp
    ultimately show ?thesis by blast
  qed
qed

datatype alphabet = a | b
inductive S :: "alphabet list \<Rightarrow> bool" where
"S []"
| "S w \<Longrightarrow> S (a#w@[b])"
| "S v \<Longrightarrow> S w \<Longrightarrow> S (v@w)"

fun balanced :: "nat \<Rightarrow> alphabet list \<Rightarrow> bool" where
"balanced 0 [] = True"
| "balanced (Suc n) [] = False"
| "balanced n (a#xs) = balanced (Suc n) xs"
| "balanced 0 (b#xs) = False"
| "balanced (Suc n) (b#xs) = balanced n xs"

lemma balanced1: "S (replicate n a) \<Longrightarrow> n > 0 \<Longrightarrow> False"
proof (induction "replicate n a" arbitrary: n rule: S.induct)
  case 1
  then show ?case by simp
next
  case (2 w)
  then show ?case
    by (metis alphabet.distinct(1) append_is_Nil_conv bot_nat_0.not_eq_extremum last.simps last_replicate last_snoc list.distinct(1))
next
  case (3 v w)
  then obtain n' n'' where f1: "v = replicate n' a" and f2: "w = replicate n'' a"
    by (metis map_eq_append_conv map_replicate_const map_replicate_trivial)
  have "n' = 0 \<Longrightarrow> n'' = 0 \<Longrightarrow> False" using 3 f1 by simp
  hence "n' > 0 \<or> n'' > 0" by blast
  then show ?case using 3 f1 f2 by blast
qed

lemma balanced6:
  assumes a1: "v \<noteq> []" and a2: "S v" and a3: "S w"
  and a4: "v @ w = replicate n a @ xs"
  shows "\<exists>ys. v = replicate n a @ ys"
proof -
  have "\<not>(\<exists>v'. v@v' = replicate n a)"
  proof
    assume "\<exists>v'. v @ v' = replicate n a"
    then obtain n' where f1: "v = replicate n' a" and f2: "n' > 0"
      by (metis a1 gr_zeroI list.simps(8) list.size(3) map_eq_append_conv map_replicate_const map_replicate_trivial)
    have "S v \<Longrightarrow> False" using f1 balanced1 f2 by blast
    then show "False" using a2 by simp
  qed
  thus ?thesis
    by (meson a4 append_eq_append_conv2)
qed

lemma balanced2: "S (replicate n a @ xs) \<Longrightarrow> S (replicate (Suc n) a @ b # xs)"
proof (induction "replicate n a @ xs" arbitrary: n xs rule: S.induct)
  case 1
  then show ?case using S.intros(1) S.intros(2) by force
next
  case (2 w)
  then show ?case
  proof (cases n)
    assume f1: "n = 0"
    hence "S xs" using 2 S.intros by force
    moreover have "S [a, b]" using S.intros by force
    ultimately have "S ([a, b] @ xs)" using S.intros 2 by force
    hence "S (replicate (Suc 0) a @ b # xs)" by simp
    thus ?thesis using f1 by simp
  next
    case (Suc nat)
    then obtain xs' where f1: "w = replicate nat a @ xs'" using 2(3)
      by (metis alphabet.distinct(1) append.right_neutral append_Cons butlast_append list.sel(3) replicate_Suc replicate_append_same snoc_eq_iff_butlast)
    with 2(2) have "S (replicate (Suc nat) a @ b # xs')" by simp
    moreover have "xs = xs'@[b]" using 2(3) f1 Suc by simp
    ultimately show ?thesis using Suc S.intros by force
  qed
next
  case (3 v w)
  show ?case
  proof (cases v)
    case Nil
    then show ?thesis using 3 S.intros by force
  next
    case Cons
    with 3(1,3,5) obtain ys where f1: "v = replicate n a @ ys"
      using balanced6 by blast
    hence "S (replicate (Suc n) a @ b # ys)" using 3 by blast
    moreover have "replicate (Suc n) a @ b # xs = replicate (Suc n) a @ b # ys @ w"
      using 3 f1 by force
    ultimately show ?thesis using 3 by (metis S.intros(3) append.assoc append_Cons)
  qed
qed

lemma balanced3: "balanced n w \<Longrightarrow> S (replicate n a @ w)"
proof (induction n w rule: balanced.induct)
  case 1
  then show ?case
    by (simp add: S.intros(1))
next
  case (2 n)
  then show ?case by simp
next
  case (3 n xs)
  hence "balanced (Suc n) xs" by simp
  hence "S (replicate (Suc n) a @ xs)" using 3 by simp
  then show ?case by (simp add: replicate_app_Cons_same)
next
  case (4 xs)
  then show ?case by simp
next
  case (5 n xs)
  hence "balanced n xs" by simp
  hence "S (replicate n a @ xs)" using 5 by simp
  then show ?case using balanced2 by blast
qed

lemma balanced5: "balanced n w \<Longrightarrow> balanced (Suc n) (w@[b])"
  apply (induction n w rule: balanced.induct)
  by auto

lemma balanced7: "balanced m v \<Longrightarrow> balanced 0 w \<Longrightarrow> balanced m (v@w)"
  apply (induction arbitrary: w rule: balanced.induct)
  by auto

lemma balanced4: "S (replicate n a @ w) \<Longrightarrow> balanced n w"
proof (induction "replicate n a @ w" arbitrary: n w rule: S.induct)
  case 1
  then show ?case by simp
next
  case (2 w')
  then show ?case
  proof (cases n)
    case 0
    hence "balanced 0 w'" using 2 by simp
    hence "balanced 1 (w' @ [b])" using balanced5 by simp
    then show ?thesis using 0 2 by auto
  next
    case (Suc nat)
    then obtain w'' where f1: "w' = replicate nat a @ w''" using 2
      by (metis alphabet.distinct(1) append_Cons append_is_Nil_conv butlast_append butlast_snoc last_snoc list.distinct(1) list.sel(3) replicate_Suc replicate_append_same)
    hence "balanced nat w''" using 2 by simp
    moreover have "w'' @ [b] = w" using Suc 2 f1 by simp
    ultimately show ?thesis using 2 Suc apply clarsimp
      using balanced5 by presburger
  qed
next
  case (3 v' w')
  show ?case
  proof (cases v')
    case Nil
    then show ?thesis using 3 by simp
  next
    case Cons
    hence "v' \<noteq> []" by simp
    then obtain ys where f1: "v' = replicate n a @ ys"
      using 3 balanced6 by meson
    hence "balanced n ys" using 3 by blast
    moreover have "balanced 0 w'" using 3 by simp
    moreover have "ys @ w' = w" using 3 f1 by simp
    ultimately show ?thesis using balanced7 by blast
  qed
qed

lemma "balanced n w = S (replicate n a @ w)"
  using balanced3 balanced4 by blast

end


theory Fresh_Monad
imports
  "HOL-Library.State_Monad"
  Term_Utils
begin

text \<open>
  Generation of fresh names in general can be thought of as picking a string that is not an element
  of a (finite) set of already existing names. For Isabelle, the \<^emph>\<open>Nominal\<close> framework
  @{cite urban2008nominal and urban2013nominal} provides support for reasoning over fresh names, but
  unfortunately, its definitions are not executable.

  Instead, I chose to model generation of fresh names as a monad based on @{type state}. With this,
  it becomes possible to write programs using \<open>do\<close>-notation. This is implemented abstractly as a
  @{command locale} that expects two operations:

  \<^item> \<open>next\<close> expects a value and generates a larger value, according to @{class linorder}
  \<^item> \<open>arb\<close> produces any value, similarly to @{const undefined}, but executable
\<close>

locale fresh =
  fixes "next" :: "'a::linorder \<Rightarrow> 'a" and arb :: 'a
  assumes next_ge: "next x > x"
begin

abbreviation update_next :: "('a, unit) state" where
"update_next \<equiv> State_Monad.update next"

lemma update_next_strict_mono[simp, intro]: "strict_mono_state update_next"
using next_ge by (auto intro: update_strict_mono)

lemma update_next_mono[simp, intro]: "mono_state update_next"
by (rule strict_mono_implies_mono) (rule update_next_strict_mono)

definition create :: "('a, 'a) state" where
"create = update_next \<bind> (\<lambda>_. State_Monad.get)"

lemma create_alt_def[code]: "create = State (\<lambda>a. (next a, next a))"
unfolding create_def State_Monad.update_def State_Monad.get_def State_Monad.set_def State_Monad.bind_def
by simp

abbreviation fresh_in :: "'a set \<Rightarrow> 'a \<Rightarrow> bool" where
"fresh_in S s \<equiv> Ball S ((\<ge>) s)"

lemma next_ge_all: "finite S \<Longrightarrow> fresh_in S s \<Longrightarrow> next s \<notin> S"
by (metis antisym less_imp_le less_irrefl next_ge)

definition Next :: "'a set \<Rightarrow> 'a" where
"Next S = (if S = {} then arb else next (Max S))"

lemma Next_ge_max: "finite S \<Longrightarrow> S \<noteq> {} \<Longrightarrow> Next S > Max S"
unfolding Next_def using next_ge by simp

lemma Next_not_member_subset: "finite S' \<Longrightarrow> S \<subseteq> S' \<Longrightarrow> Next S' \<notin> S"
unfolding Next_def using next_ge
by (metis Max_ge Max_mono empty_iff finite_subset leD less_le_trans subset_empty)

lemma Next_not_member: "finite S \<Longrightarrow> Next S \<notin> S"
by (rule Next_not_member_subset) auto

lemma Next_geq_not_member: "finite S \<Longrightarrow> s \<ge> Next S \<Longrightarrow> s \<notin> S"
unfolding Next_def using next_ge
by (metis (full_types) Max_ge all_not_in_conv leD le_less_trans)

lemma next_not_member: "finite S \<Longrightarrow> s \<ge> Next S \<Longrightarrow> next s \<notin> S"
by (meson Next_geq_not_member less_imp_le next_ge order_trans)

lemma create_mono[simp, intro]: "mono_state create"
unfolding create_def
by (auto intro: bind_mono_strong)

lemma create_strict_mono[simp, intro]: "strict_mono_state create"
unfolding create_def
by (rule bind_strict_mono_strong2) auto

abbreviation run_fresh where
"run_fresh m S \<equiv> fst (run_state m (Next S))"

abbreviation fresh_fin :: "'a fset \<Rightarrow> 'a \<Rightarrow> bool" where
"fresh_fin S s \<equiv> fBall S ((\<ge>) s)"

context includes fset.lifting begin

lemma next_ge_fall: "fresh_fin S s \<Longrightarrow> next s |\<notin>| S"
by (transfer fixing: "next") (rule next_ge_all)

lift_definition fNext :: "'a fset \<Rightarrow> 'a" is Next .

lemma fNext_ge_max: "S \<noteq> {||} \<Longrightarrow> fNext S > fMax S"
by transfer (rule Next_ge_max)

lemma next_not_fmember: "s \<ge> fNext S \<Longrightarrow> next s |\<notin>| S"
by transfer (rule next_not_member)

lemma fNext_geq_not_member: "s \<ge> fNext S \<Longrightarrow> s |\<notin>| S"
by transfer (rule Next_geq_not_member)

lemma fNext_not_member: "fNext S |\<notin>| S"
by transfer (rule Next_not_member)

lemma fNext_not_member_subset: "S |\<subseteq>| S' \<Longrightarrow> fNext S' |\<notin>| S"
by transfer (rule Next_not_member_subset)

abbreviation frun_fresh where
"frun_fresh m S \<equiv> fst (run_state m (fNext S))"

end

end

end


(* ----------------------------------------------------------------- *)
subsection \<open>Generalized unitary matrices with signature $(1, 1)$\<close>
(* ----------------------------------------------------------------- *)

theory Unitary11_Matrices
imports Matrices More_Complex
begin

text \<open> When acting as Möbius transformations in the extended
complex plane, generalized complex $2\times 2$ unitary matrices fix
the imaginary unit circle (a Hermitean form with (2, 0) signature). We
now describe matrices that fix the ordinary unit circle (a Hermitean
form with (1, 1) signature, i.e., one positive and one negative
element on the diagonal). These are extremely important for further
formalization, since they will represent disc automorphisims and
isometries of the Poincar\'e disc. The development of this theory
follows the development of the theory of generalized unitary matrices.
\<close>

text \<open>Unitary11 matrices\<close>
definition unitary11 where
  "unitary11 M \<longleftrightarrow> congruence M (1, 0, 0, -1) = (1, 0, 0, -1)"

text \<open>Generalized unitary11 matrices\<close>
definition unitary11_gen where
  "unitary11_gen M \<longleftrightarrow> (\<exists> k. k \<noteq> 0 \<and> congruence M (1, 0, 0, -1) = k *\<^sub>s\<^sub>m (1, 0, 0, -1))"

text \<open>Scalar can always be a non-zero real number\<close>
lemma unitary11_gen_real:
  shows "unitary11_gen M \<longleftrightarrow> (\<exists> k. k \<noteq> 0 \<and> congruence M (1, 0, 0, -1) = cor k *\<^sub>s\<^sub>m (1, 0, 0, -1))"
  unfolding unitary11_gen_def
proof (auto simp del: congruence_def)
  fix k
  assume "k \<noteq> 0" "congruence M (1, 0, 0, -1) = (k, 0, 0, - k)"
  hence "mat_det (congruence M (1, 0, 0, -1)) = -k*k"
    by simp
  moreover
  have "is_real (mat_det (congruence M (1, 0, 0, -1)))" "Re (mat_det (congruence M (1, 0, 0, -1))) \<le> 0"
    by (auto simp add: mat_det_adj)
  ultimately
  have "is_real (k*k)" "Re (-k*k) \<le> 0"
    by auto
  hence "is_real (k*k) \<and> Re (k * k) > 0"
    using \<open>k \<noteq> 0\<close>
    by (smt complex_eq_if_Re_eq mult_eq_0_iff mult_minus_left uminus_complex.simps(1) zero_complex.simps(1) zero_complex.simps(2))
  hence "is_real k"
    by auto
  thus "\<exists>ka. ka \<noteq> 0 \<and> k = cor ka"
    using \<open>k \<noteq> 0\<close>
    by (rule_tac x="Re k" in exI) (cases k, auto simp add: Complex_eq)
qed

text \<open>Unitary11 matrices are special cases of generalized unitary 11 matrices\<close>
lemma unitary11_unitary11_gen [simp]:
  assumes "unitary11 M"
  shows "unitary11_gen M"
  using assms
  unfolding unitary11_gen_def unitary11_def
  by (rule_tac x="1" in exI, auto)

text \<open>All generalized unitary11 matrices are regular\<close>
lemma unitary11_gen_regular:
  assumes "unitary11_gen M"
  shows "mat_det M \<noteq> 0"
proof-
  from assms obtain k where
    "k \<noteq> 0" "mat_adj M *\<^sub>m\<^sub>m (1, 0, 0, -1) *\<^sub>m\<^sub>m M = cor k *\<^sub>s\<^sub>m (1, 0, 0, -1)"
    unfolding unitary11_gen_real
    by auto
  hence "mat_det (mat_adj M *\<^sub>m\<^sub>m (1, 0, 0, -1) *\<^sub>m\<^sub>m M) \<noteq> 0"
    by simp
  thus ?thesis
    by (simp add: mat_det_adj)
qed

lemmas unitary11_regular = unitary11_gen_regular[OF unitary11_unitary11_gen]

(* ----------------------------------------------------------------- *)
subsubsection \<open>The characterization in terms of matrix elements\<close>
(* ----------------------------------------------------------------- *)

text \<open>Special matrices are those having the determinant equal to 1. We first give their characterization.\<close>
lemma unitary11_special:
  assumes "unitary11 M" and "mat_det M = 1"
  shows "\<exists> a b. M = (a, b, cnj b, cnj a)"
proof-
  have "mat_adj M *\<^sub>m\<^sub>m (1, 0, 0, -1) = (1, 0, 0, -1) *\<^sub>m\<^sub>m mat_inv M"
    using assms mult_mm_inv_r
    by (simp add: unitary11_def)
  thus ?thesis
    using assms(2)
    by (cases M) (simp add: mat_adj_def mat_cnj_def)
qed

lemma unitary11_gen_special:
  assumes "unitary11_gen M" and "mat_det M = 1"
  shows "\<exists> a b. M = (a, b, cnj b, cnj a) \<or> M = (a, b, -cnj b, -cnj a)"
proof-
  from assms
  obtain k where *: "k \<noteq> 0" "mat_adj M *\<^sub>m\<^sub>m (1, 0, 0, -1) *\<^sub>m\<^sub>m M = cor k *\<^sub>s\<^sub>m (1, 0, 0, -1)"
    unfolding unitary11_gen_real
    by auto
  hence "mat_det (mat_adj M *\<^sub>m\<^sub>m (1, 0, 0, -1) *\<^sub>m\<^sub>m M) = -  cor k* cor k"
    by simp
  hence "mat_det (mat_adj M *\<^sub>m\<^sub>m M) = cor k* cor k"
    by simp
  hence "cor k* cor k = 1"
    using assms(2)
    by (simp add: mat_det_adj)
  hence "cor k = 1 \<or> cor k = -1"
    using square_eq_1_iff[of "cor k"]
    by simp
  moreover
  have "mat_adj M *\<^sub>m\<^sub>m (1, 0, 0, -1) = (cor k *\<^sub>s\<^sub>m (1, 0, 0, -1)) *\<^sub>m\<^sub>m mat_inv M "
    using *
    using assms mult_mm_inv_r mat_eye_r mat_eye_l
    by auto
  moreover
  obtain a b c d where "M = (a, b, c, d)"
    by (cases M) auto
  ultimately
  have "M = (a, b, cnj b, cnj a) \<or> M = (a, b, -cnj b, -cnj a)"
    using assms(2)
    by (auto simp add: mat_adj_def mat_cnj_def)
  thus ?thesis
    by auto
qed

text \<open>A characterization of all generalized unitary11 matrices\<close>
lemma unitary11_gen_iff':
  shows "unitary11_gen M \<longleftrightarrow>
         (\<exists> a b k. k \<noteq> 0 \<and> mat_det (a, b, cnj b, cnj a) \<noteq> 0 \<and>
                           (M = k *\<^sub>s\<^sub>m (a, b, cnj b, cnj a) \<or>
                            M = k *\<^sub>s\<^sub>m (-1, 0, 0, 1) *\<^sub>m\<^sub>m (a, b, cnj b, cnj a)))" (is "?lhs = ?rhs")
proof
  assume ?lhs
  obtain d where *: "d*d = mat_det M"
    using ex_complex_sqrt
    by auto
  hence "d \<noteq> 0"
    using unitary11_gen_regular[OF \<open>unitary11_gen M\<close>]
    by auto
  from \<open>unitary11_gen M\<close>
  obtain k where "k \<noteq> 0" "mat_adj M *\<^sub>m\<^sub>m (1, 0, 0, -1) *\<^sub>m\<^sub>m M = cor k *\<^sub>s\<^sub>m (1, 0, 0, -1)"
    unfolding unitary11_gen_real
    by auto
  hence "mat_adj ((1/d)*\<^sub>s\<^sub>mM)*\<^sub>m\<^sub>m (1, 0, 0, -1) *\<^sub>m\<^sub>m ((1/d)*\<^sub>s\<^sub>mM) = (cor k / (d*cnj d)) *\<^sub>s\<^sub>m (1, 0, 0, -1)"
    by simp
  moreover
  have "is_real (cor k / (d * cnj d))"
    by (metis complex_In_mult_cnj_zero div_reals Im_complex_of_real)
  hence "cor (Re (cor k / (d * cnj d))) = cor k / (d * cnj d)"
    by simp
  ultimately
  have "unitary11_gen ((1/d)*\<^sub>s\<^sub>mM)"
    unfolding unitary11_gen_real
    using \<open>d \<noteq> 0\<close> \<open>k \<noteq> 0\<close>
    using \<open>cor (Re (cor k / (d * cnj d))) = cor k / (d * cnj d)\<close>
    by (rule_tac x="Re (cor k / (d * cnj d))" in exI, auto, simp add: *)
  moreover
  have "mat_det ((1 / d) *\<^sub>s\<^sub>m M) = 1"
    using * unitary11_gen_regular[of M] \<open>unitary11_gen M\<close>
    by auto
  ultimately
  obtain a b where "(a, b, cnj b, cnj a) = (1 / d) *\<^sub>s\<^sub>m M \<or> (a, b, -cnj b, -cnj a) = (1 / d) *\<^sub>s\<^sub>m M"
    using unitary11_gen_special[of "(1 / d) *\<^sub>s\<^sub>m M"]
    by force
  thus ?rhs
  proof
    assume "(a, b, cnj b, cnj a) = (1 / d) *\<^sub>s\<^sub>m M"
    moreover
    hence "mat_det (a, b, cnj b, cnj a) \<noteq> 0"
      using unitary11_gen_regular[OF \<open>unitary11_gen M\<close>] \<open>d \<noteq> 0\<close>
      by auto
    ultimately
    show ?rhs
      using \<open>d \<noteq> 0\<close>
      by (rule_tac x="a" in exI, rule_tac x="b" in exI, rule_tac x="d" in exI, simp)
  next
    assume *: "(a, b, -cnj b, -cnj a) = (1 / d) *\<^sub>s\<^sub>m M"
    hence " (1 / d) *\<^sub>s\<^sub>m M = (a, b, -cnj b, -cnj a)"
      by simp
    hence "M = (a * d, b * d, - (d * cnj b), - (d * cnj a))"
      using \<open>d \<noteq> 0\<close>
      using mult_sm_inv_l[of "1/d" M "(a, b, -cnj b, -cnj a)", symmetric]
      by (simp add: field_simps)
    moreover
    have "mat_det (a, b, -cnj b, -cnj a) \<noteq> 0"
      using * unitary11_gen_regular[OF \<open>unitary11_gen M\<close>] \<open>d \<noteq> 0\<close>
      by auto
    ultimately
    show ?thesis
      using \<open>d \<noteq> 0\<close>
      by (rule_tac x="a" in exI, rule_tac x="b" in exI, rule_tac x="-d" in exI) (simp add: field_simps)
  qed
next
  assume ?rhs
  then obtain a b k where "k \<noteq> 0" "mat_det (a, b, cnj b, cnj a) \<noteq> 0"
    "M = k *\<^sub>s\<^sub>m (a, b, cnj b, cnj a) \<or> M = k *\<^sub>s\<^sub>m (-1, 0, 0, 1) *\<^sub>m\<^sub>m (a, b, cnj b, cnj a)"
    by auto
  moreover
  let ?x = "cnj k * cnj a * (k * a) + - (cnj k * b * (k * cnj b))"
  have "?x = (k*cnj k)*(a*cnj a - b*cnj b)"
    by (auto simp add: field_simps)
  hence "is_real ?x"
    by simp
  hence "cor (Re ?x) = ?x"
    by (rule complex_of_real_Re)
  moreover
  have "?x \<noteq> 0"
    using mult_eq_0_iff[of "cnj k * k" "(cnj a * a + - cnj b * b)"]
    using \<open>mat_det (a, b, cnj b, cnj a) \<noteq> 0\<close> \<open>k \<noteq> 0\<close>
    by (auto simp add: field_simps)
  hence "Re ?x \<noteq> 0"
    using \<open>is_real ?x\<close>
    by (metis calculation(4) of_real_0)
  ultimately
  show ?lhs
    unfolding unitary11_gen_real
    by (rule_tac x="Re ?x" in exI) (auto simp add: mat_adj_def mat_cnj_def)
qed

text \<open>Another characterization of all generalized unitary11 matrices. They are products of
rotation and Blaschke factor matrices.\<close>
lemma unitary11_gen_cis_blaschke:
  assumes "k \<noteq> 0" and "M = k *\<^sub>s\<^sub>m (a, b, cnj b, cnj a)" and
          "a \<noteq> 0" and "mat_det (a, b, cnj b, cnj a) \<noteq> 0"
  shows "\<exists> k' \<phi> a'. k' \<noteq> 0 \<and> a' * cnj a' \<noteq> 1 \<and>
                                 M = k' *\<^sub>s\<^sub>m (cis \<phi>, 0, 0, 1) *\<^sub>m\<^sub>m (1, -a', -cnj a', 1)"
proof-
  have "a = cnj a * cis (2 * arg a)"
    using rcis_cmod_arg[of a] rcis_cnj[of a]
    using cis_rcis_eq rcis_mult
    by simp
  thus ?thesis
    using assms
    by (rule_tac x="k*cnj a" in exI, rule_tac x="2*arg a" in exI, rule_tac x="- b / a" in exI) (auto simp add: field_simps)
qed

lemma unitary11_gen_cis_blaschke':
  assumes "k \<noteq> 0" and "M = k *\<^sub>s\<^sub>m (-1, 0, 0, 1) *\<^sub>m\<^sub>m (a, b, cnj b, cnj a)" and
          "a \<noteq> 0" and "mat_det (a, b, cnj b, cnj a) \<noteq> 0"
  shows "\<exists> k' \<phi> a'. k' \<noteq> 0 \<and> a' * cnj a' \<noteq> 1 \<and>
                                 M = k' *\<^sub>s\<^sub>m (cis \<phi>, 0, 0, 1) *\<^sub>m\<^sub>m (1, -a', -cnj a', 1)"
proof-
  obtain k' \<phi> a' where *: "k' \<noteq> 0" "k *\<^sub>s\<^sub>m (a, b, cnj b, cnj a) = k' *\<^sub>s\<^sub>m (cis \<phi>, 0, 0, 1) *\<^sub>m\<^sub>m (1, -a', -cnj a', 1)" "a' * cnj a' \<noteq> 1"
    using unitary11_gen_cis_blaschke[OF \<open>k \<noteq> 0\<close> _ \<open>a \<noteq> 0\<close>] \<open>mat_det (a, b, cnj b, cnj a) \<noteq> 0\<close>
    by blast
  have "(cis \<phi>, 0, 0, 1) *\<^sub>m\<^sub>m (-1, 0, 0, 1) = (cis (\<phi> + pi), 0, 0, 1)"
   by (simp add: cis_def complex.corec Complex_eq)
  thus ?thesis
    using * \<open>M = k *\<^sub>s\<^sub>m (-1, 0, 0, 1) *\<^sub>m\<^sub>m (a, b, cnj b, cnj a)\<close>
    by (rule_tac x="k'" in exI, rule_tac x="\<phi> + pi" in exI, rule_tac x="a'" in exI, simp)
qed

lemma unitary11_gen_cis_blaschke_rev:
  assumes "k' \<noteq> 0" and "M = k' *\<^sub>s\<^sub>m (cis \<phi>, 0, 0, 1) *\<^sub>m\<^sub>m (1, -a', -cnj a', 1)" and
          "a' * cnj a' \<noteq> 1"
  shows "\<exists> k a b. k \<noteq> 0 \<and> mat_det (a, b, cnj b, cnj a) \<noteq> 0  \<and>
                          M = k *\<^sub>s\<^sub>m (a, b, cnj b, cnj a)"
  using assms
  apply (rule_tac x="k'*cis(\<phi>/2)" in exI, rule_tac x="cis(\<phi>/2)" in exI, rule_tac x="-a'*cis(\<phi>/2)" in exI)
  apply (simp add: cis_mult mult.commute mult.left_commute)
  done

lemma unitary11_gen_cis_inversion:
  assumes "k \<noteq> 0" and "M = k *\<^sub>s\<^sub>m (0, b, cnj b, 0)" and "b \<noteq> 0"
  shows "\<exists> k' \<phi>. k' \<noteq> 0 \<and>
                              M = k' *\<^sub>s\<^sub>m (cis \<phi>, 0, 0, 1) *\<^sub>m\<^sub>m (0, 1, 1, 0)"
using assms
using rcis_cmod_arg[of b, symmetric] rcis_cnj[of b] cis_rcis_eq
by simp (rule_tac x="2*arg b" in exI, simp add: rcis_mult)

lemma unitary11_gen_cis_inversion':
  assumes "k \<noteq> 0" and "M = k *\<^sub>s\<^sub>m (-1, 0, 0, 1) *\<^sub>m\<^sub>m (0, b, cnj b, 0)" and "b \<noteq> 0"
  shows "\<exists> k' \<phi>. k' \<noteq> 0 \<and>
                   M = k' *\<^sub>s\<^sub>m (cis \<phi>, 0, 0, 1) *\<^sub>m\<^sub>m (0, 1, 1, 0)"
proof-
  obtain k' \<phi> where *: "k' \<noteq> 0" "k *\<^sub>s\<^sub>m (0, b, cnj b, 0) = k' *\<^sub>s\<^sub>m (cis \<phi>, 0, 0, 1) *\<^sub>m\<^sub>m (0, 1, 1, 0)"
    using unitary11_gen_cis_inversion[OF \<open>k \<noteq> 0\<close> _ \<open>b \<noteq> 0\<close>]
    by metis
  have "(cis \<phi>, 0, 0, 1) *\<^sub>m\<^sub>m (-1, 0, 0, 1) = (cis (\<phi> + pi), 0, 0, 1)"
    by (simp add: cis_def complex.corec Complex_eq)
  thus ?thesis
    using * \<open>M = k *\<^sub>s\<^sub>m (-1, 0, 0, 1) *\<^sub>m\<^sub>m (0, b, cnj b, 0)\<close>
    by (rule_tac x="k'" in exI, rule_tac x="\<phi> + pi" in exI, simp)
qed

lemma unitary11_gen_cis_inversion_rev:
  assumes "k' \<noteq> 0" and "M = k' *\<^sub>s\<^sub>m (cis \<phi>, 0, 0, 1) *\<^sub>m\<^sub>m (0, 1, 1, 0)"
  shows "\<exists> k a b. k \<noteq> 0 \<and> mat_det (a, b, cnj b, cnj a) \<noteq> 0 \<and>
                          M = k *\<^sub>s\<^sub>m (a, b, cnj b, cnj a)"
  using assms
  by (rule_tac x="k'*cis(\<phi>/2)" in exI, rule_tac x=0 in exI, rule_tac x="cis(\<phi>/2)" in exI) (simp add: cis_mult)

text \<open>Another characterization of generalized unitary11 matrices\<close>
lemma unitary11_gen_iff:
  shows "unitary11_gen M \<longleftrightarrow>
         (\<exists> k a b. k \<noteq> 0 \<and> mat_det (a, b, cnj b, cnj a) \<noteq> 0 \<and>
                           M = k *\<^sub>s\<^sub>m (a, b, cnj b, cnj a))" (is "?lhs = ?rhs")
proof
  assume ?lhs
  then obtain a b k where *: "k \<noteq> 0" "mat_det (a, b, cnj b, cnj a) \<noteq> 0" "M = k *\<^sub>s\<^sub>m (a, b, cnj b, cnj a) \<or> M = k *\<^sub>s\<^sub>m (-1, 0, 0, 1) *\<^sub>m\<^sub>m (a, b, cnj b, cnj a)"
    using unitary11_gen_iff'
    by auto
  show ?rhs
  proof (cases "M = k *\<^sub>s\<^sub>m (a, b, cnj b, cnj a)")
    case True
    thus ?thesis
      using *
      by auto
  next
    case False
    hence **: "M = k *\<^sub>s\<^sub>m (-1, 0, 0, 1) *\<^sub>m\<^sub>m (a, b, cnj b, cnj a)"
      using *
      by simp
    show ?thesis
    proof (cases "a = 0")
      case True
      hence "b \<noteq> 0"
        using *
        by auto
      show ?thesis
        using unitary11_gen_cis_inversion_rev[of _ M]
        using ** \<open>a = 0\<close>
        using unitary11_gen_cis_inversion'[OF \<open>k \<noteq> 0\<close> _ \<open>b \<noteq> 0\<close>, of M]
        by auto
    next
      case False
      show ?thesis
        using unitary11_gen_cis_blaschke_rev[of _ M]
        using **
        using unitary11_gen_cis_blaschke'[OF \<open>k \<noteq> 0\<close> _ \<open>a \<noteq> 0\<close>, of M b] \<open>mat_det (a, b, cnj b, cnj a) \<noteq> 0\<close>
        by blast
    qed
  qed
next
  assume ?rhs
  thus ?lhs
    using unitary11_gen_iff'
    by auto
qed

lemma unitary11_iff:
  shows "unitary11 M \<longleftrightarrow>
         (\<exists> a b k. (cmod a)\<^sup>2 > (cmod b)\<^sup>2 \<and>
                           (cmod k)\<^sup>2 = 1 / ((cmod a)\<^sup>2 - (cmod b)\<^sup>2) \<and>
                           M = k *\<^sub>s\<^sub>m (a, b, cnj b, cnj a))" (is "?lhs = ?rhs")
proof
  assume ?lhs
  obtain k a b where *:
    "M = k *\<^sub>s\<^sub>m (a, b, cnj b, cnj a)""mat_det (a, b, cnj b, cnj a) \<noteq> 0" "k \<noteq> 0"
    using unitary11_gen_iff unitary11_unitary11_gen[OF \<open>unitary11 M\<close>]
    by auto

  have md: "mat_det (a, b, cnj b, cnj a) = cor ((cmod a)\<^sup>2 - (cmod b)\<^sup>2)"
    by (auto simp add: complex_mult_cnj_cmod)
  hence **: "(cmod a)\<^sup>2 \<noteq> (cmod b)\<^sup>2"
    using \<open>mat_det (a, b, cnj b, cnj a) \<noteq> 0\<close>
    by auto

  have "k * cnj k * mat_det (a, b, cnj b, cnj a) = 1"
    using \<open>M = k *\<^sub>s\<^sub>m (a, b, cnj b, cnj a)\<close>
    using \<open>unitary11 M\<close>
    unfolding unitary11_def
    by (auto simp add: mat_adj_def mat_cnj_def) (simp add: field_simps)
  hence ***: "(cmod k)\<^sup>2 * ((cmod a)\<^sup>2 - (cmod b)\<^sup>2) = 1"
    by (subst (asm) complex_mult_cnj_cmod, subst (asm) md, subst (asm) cor_mult[symmetric]) (metis of_real_1 of_real_eq_iff)
  hence "((cmod a)\<^sup>2 - (cmod b)\<^sup>2) = 1 / (cmod k)\<^sup>2"
    by (cases "k=0") (auto simp add: field_simps)
  hence "cmod a ^ 2 = cmod b ^ 2 + 1 / cmod k ^ 2"
    by simp
  thus ?rhs
    using \<open>M = k *\<^sub>s\<^sub>m (a, b, cnj b, cnj a)\<close> ** mat_eye_l
    by (rule_tac x="a" in exI, rule_tac x="b" in exI, rule_tac x="k" in exI)
       (auto simp add: complex_mult_cnj_cmod intro!: )
next
  assume ?rhs
  then obtain a b k where "(cmod b)\<^sup>2 < (cmod a)\<^sup>2 \<and> (cmod k)\<^sup>2 = 1 / ((cmod a)\<^sup>2 - (cmod b)\<^sup>2) \<and> M = k *\<^sub>s\<^sub>m (a, b, cnj b, cnj a)"
    by auto
  moreover
  have "cnj k * cnj a * (k * a) + - (cnj k * b * (k * cnj b)) = (cor ((cmod k)\<^sup>2 * ((cmod a)\<^sup>2 - (cmod b)\<^sup>2)))"
  proof-
    have "cnj k * cnj a * (k * a) = cor ((cmod k)\<^sup>2 * (cmod a)\<^sup>2)"
      using complex_mult_cnj_cmod[of a] complex_mult_cnj_cmod[of k]
      by (auto simp add: field_simps)
    moreover
    have "cnj k * b * (k * cnj b) = cor ((cmod k)\<^sup>2 * (cmod b)\<^sup>2)"
      using complex_mult_cnj_cmod[of b, symmetric] complex_mult_cnj_cmod[of k]
      by (auto simp add: field_simps)
    ultimately
    show ?thesis
      by (auto simp add: field_simps)
  qed
  ultimately
  show ?lhs
    unfolding unitary11_def
    by (auto simp add: mat_adj_def mat_cnj_def field_simps)
qed

(* ----------------------------------------------------------------- *)
subsubsection \<open>Group properties\<close>
(* ----------------------------------------------------------------- *)

text \<open>Generalized unitary11 matrices form a group under
multiplication (it is sometimes denoted by $GU_{1, 1}(2,
\mathbb{C})$). The group is also closed under non-zero complex scalar
multiplication. Since these matrices are always regular, they form a
subgroup of general linear group (usually denoted by $GL(2,
\mathbb{C})$) of all regular matrices.\<close>

lemma unitary11_gen_mult_sm:
  assumes "k \<noteq> 0" and "unitary11_gen M"
  shows "unitary11_gen (k *\<^sub>s\<^sub>m M)"
proof-
  have "k * cnj k = cor (Re (k * cnj k))"
    by (subst complex_of_real_Re) auto
  thus ?thesis
    using assms
    unfolding unitary11_gen_real
    by auto (rule_tac x="Re (k*cnj k) * ka" in exI, auto)
qed

lemma unitary11_gen_div_sm:
  assumes "k \<noteq> 0" and "unitary11_gen (k *\<^sub>s\<^sub>m M)"
  shows "unitary11_gen M"
  using assms unitary11_gen_mult_sm[of "1/k" "k *\<^sub>s\<^sub>m M"]
  by simp

lemma unitary11_inv:
  assumes "k \<noteq> 0" and "M = k *\<^sub>s\<^sub>m (a, b, cnj b, cnj a)" and "mat_det (a, b, cnj b, cnj a) \<noteq> 0"
  shows "\<exists> k' a' b'. k' \<noteq> 0 \<and> mat_inv M = k' *\<^sub>s\<^sub>m (a', b', cnj b', cnj a') \<and> mat_det (a', b', cnj b', cnj a') \<noteq> 0"
  using assms
  by (subst assms, subst mat_inv_mult_sm[OF assms(1)])
     (rule_tac x="1/(k * mat_det (a, b, cnj b, cnj a))" in exI, rule_tac x="cnj a" in exI, rule_tac x="-b" in exI, simp add: field_simps)

lemma unitary11_comp:
  assumes "k1 \<noteq> 0" and "M1 = k1 *\<^sub>s\<^sub>m (a1, b1, cnj b1, cnj a1)" and "mat_det (a1, b1, cnj b1, cnj a1) \<noteq> 0"
          "k2 \<noteq> 0" "M2 = k2 *\<^sub>s\<^sub>m (a2, b2, cnj b2, cnj a2)" "mat_det (a2, b2, cnj b2, cnj a2) \<noteq> 0"
  shows "\<exists> k a b. k \<noteq> 0 \<and> M1 *\<^sub>m\<^sub>m M2 = k *\<^sub>s\<^sub>m (a, b, cnj b, cnj a) \<and> mat_det (a, b, cnj b, cnj a) \<noteq> 0"
  using assms
  apply (rule_tac x="k1*k2" in exI)
  apply (rule_tac x="a1*a2 + b1*cnj b2" in exI)
  apply (rule_tac x="a1*b2 + b1*cnj a2" in exI)
proof (auto simp add: algebra_simps)
  assume *: "a1 * (a2 * (cnj a1 * cnj a2)) + b1 * (b2 * (cnj b1 * cnj b2)) =
            a1 * (b2 * (cnj a1 * cnj b2)) + a2 * (b1 * (cnj a2 * cnj b1))" and
         **: "a1*cnj a1 \<noteq> b1 * cnj b1" "a2*cnj a2 \<noteq> b2*cnj b2"
  hence "(a1*cnj a1)*(a2*cnj a2 - b2*cnj b2) = (b1*cnj b1)*(a2*cnj a2 - b2*cnj b2)"
    by (simp add: field_simps)
  hence "a1*cnj a1 = b1*cnj b1"
    using **(2)
    by simp
  thus False
    using **(1)
    by simp
qed

lemma unitary11_gen_mat_inv:
  assumes "unitary11_gen M" and "mat_det M \<noteq> 0"
  shows "unitary11_gen (mat_inv M)"
proof-
  obtain k a b where "k \<noteq> 0 \<and> mat_det (a, b, cnj b, cnj a) \<noteq> 0 \<and> M = k *\<^sub>s\<^sub>m (a, b, cnj b, cnj a)"
    using assms unitary11_gen_iff[of M]
    by auto
  then obtain k' a' b' where "k' \<noteq> 0 \<and> mat_inv M = k' *\<^sub>s\<^sub>m (a', b', cnj b', cnj a') \<and> mat_det (a', b', cnj b', cnj a') \<noteq> 0"
    using unitary11_inv [of k M a b]
    by auto
  thus ?thesis
    using unitary11_gen_iff[of "mat_inv M"]
    by auto
qed

lemma unitary11_gen_comp:
  assumes "unitary11_gen M1" and "mat_det M1 \<noteq> 0" and "unitary11_gen M2"  and "mat_det M2 \<noteq> 0"
  shows "unitary11_gen (M1 *\<^sub>m\<^sub>m M2)"
proof-
  from assms obtain k1 k2 a1 a2 b1 b2 where
    "k1 \<noteq> 0 \<and> mat_det (a1, b1, cnj b1, cnj a1) \<noteq> 0 \<and> M1 = k1 *\<^sub>s\<^sub>m (a1, b1, cnj b1, cnj a1)"
    "k2 \<noteq> 0 \<and> mat_det (a2, b2, cnj b2, cnj a2) \<noteq> 0 \<and> M2 = k2 *\<^sub>s\<^sub>m (a2, b2, cnj b2, cnj a2)"
    using unitary11_gen_iff[of M1]  unitary11_gen_iff[of M2]
    by blast
  then obtain k a b where "k \<noteq> 0 \<and> M1 *\<^sub>m\<^sub>m M2 = k *\<^sub>s\<^sub>m (a, b, cnj b, cnj a) \<and> mat_det (a, b, cnj b, cnj a) \<noteq> 0"
    using unitary11_comp[of k1 M1 a1 b1 k2 M2 a2 b2]
    by blast
  thus ?thesis
    using unitary11_gen_iff[of "M1 *\<^sub>m\<^sub>m M2"]
    by blast
qed

text \<open>Classification into orientation-preserving and orientation-reversing matrices\<close>
lemma unitary11_sgn_det_orientation:
  assumes "k \<noteq> 0" and "mat_det (a, b, cnj b, cnj a) \<noteq> 0" and "M = k *\<^sub>s\<^sub>m (a, b, cnj b, cnj a)"
  shows "\<exists> k'. sgn k' = sgn (Re (mat_det (a, b, cnj b, cnj a))) \<and> congruence M (1, 0, 0, -1) = cor k' *\<^sub>s\<^sub>m (1, 0, 0, -1)"
proof-
  let ?x = "cnj k * cnj a * (k * a) - (cnj k * b * (k * cnj b))"
  have *: "?x = k * cnj k * (a * cnj a - b * cnj b)"
    by (auto simp add: field_simps)
  hence "is_real ?x"
    by auto
  hence "cor (Re ?x) = ?x"
    by (rule complex_of_real_Re)
  moreover
  have "sgn (Re ?x) = sgn (Re (a * cnj a - b * cnj b))"
  proof-
    have *: "Re ?x = (cmod k)\<^sup>2 * Re (a * cnj a - b * cnj b)"
      by (subst *, subst complex_mult_cnj_cmod, subst Re_mult_real) (metis Im_complex_of_real, metis Re_complex_of_real)
    show ?thesis
      using \<open>k \<noteq> 0\<close>
      by (subst *) (simp add: sgn_mult)
  qed
  ultimately
  show ?thesis
    using assms(3)
    by (rule_tac x="Re ?x" in exI) (auto simp add: mat_adj_def mat_cnj_def)
qed

lemma unitary11_sgn_det:
  assumes "k \<noteq> 0" and "mat_det (a, b, cnj b, cnj a) \<noteq> 0" and "M = k *\<^sub>s\<^sub>m (a, b, cnj b, cnj a)" and "M = (A, B, C, D)"
  shows "sgn (Re (mat_det (a, b, cnj b, cnj a))) = (if b = 0 then 1 else sgn (Re ((A*D)/(B*C)) - 1))"
proof (cases "b = 0")
  case True
  thus ?thesis
    using assms
    by (simp only: mat_det.simps, subst complex_mult_cnj_cmod, subst minus_complex.sel, subst Re_complex_of_real, simp)
next
  case False
  from assms have *: "A =  k * a" "B =  k * b" "C =  k * cnj b" "D =  k * cnj a"
    by auto
  hence *: "(A*D)/(B*C) = (a*cnj a)/(b*cnj b)"
    using \<open>k \<noteq> 0\<close>
    by simp
  show ?thesis
    using \<open>b \<noteq> 0\<close>
    apply (subst *, subst Re_divide_real, simp, simp)
    apply (simp only: mat_det.simps)
    apply (subst complex_mult_cnj_cmod)+
    apply ((subst Re_complex_of_real)+, subst minus_complex.sel, (subst Re_complex_of_real)+, simp add: field_simps sgn_if)
    done
qed

lemma unitary11_orientation:
  assumes "unitary11_gen M" and "M = (A, B, C, D)"
  shows "\<exists> k'. sgn k' = sgn (if B = 0 then 1 else sgn (Re ((A*D)/(B*C)) - 1)) \<and> congruence M (1, 0, 0, -1) = cor k' *\<^sub>s\<^sub>m (1, 0, 0, -1)"
proof-
  from \<open>unitary11_gen M\<close>
  obtain k a b where *: "k \<noteq> 0" "mat_det (a, b, cnj b, cnj a) \<noteq> 0" "M = k*\<^sub>s\<^sub>m (a, b, cnj b, cnj a)"
    using unitary11_gen_iff[of M]
    by auto
  moreover
  have "b = 0 \<longleftrightarrow> B = 0"
    using \<open>M = (A, B, C, D)\<close> *
    by auto
  ultimately
  show ?thesis
    using unitary11_sgn_det_orientation[OF *] unitary11_sgn_det[OF * \<open>M = (A, B, C, D)\<close>]
    by auto
qed

lemma unitary11_sgn_det_orientation':
  assumes "congruence M (1, 0, 0, -1) = cor k' *\<^sub>s\<^sub>m (1, 0, 0, -1)" and "k' \<noteq> 0"
  shows "\<exists> a b k. k \<noteq> 0 \<and> M = k *\<^sub>s\<^sub>m (a, b, cnj b, cnj a) \<and> sgn k' = sgn (Re (mat_det (a, b, cnj b, cnj a)))"
proof-
  obtain a b k where
    "k \<noteq> 0" "mat_det (a, b, cnj b, cnj a) \<noteq> 0" "M = k *\<^sub>s\<^sub>m (a, b, cnj b, cnj a)"
    using assms
    using unitary11_gen_iff[of M]
    unfolding unitary11_gen_def
    by auto
  moreover
  have "sgn k' = sgn (Re (mat_det (a, b, cnj b, cnj a)))"
  proof-
    let ?x = "cnj k * cnj a * (k * a) - (cnj k * b * (k * cnj b))"
    have *: "?x = k * cnj k * (a * cnj a - b * cnj b)"
      by (auto simp add: field_simps)
    hence "is_real ?x"
      by auto
    hence "cor (Re ?x) = ?x"
      by (rule complex_of_real_Re)

    have **: "sgn (Re ?x) = sgn (Re (a * cnj a - b * cnj b))"
    proof-
      have *: "Re ?x = (cmod k)\<^sup>2 * Re (a * cnj a - b * cnj b)"
        by (subst *, subst complex_mult_cnj_cmod, subst Re_mult_real) (metis Im_complex_of_real, metis Re_complex_of_real)
      show ?thesis
        using \<open>k \<noteq> 0\<close>
        by (subst *) (simp add: sgn_mult)
    qed
    moreover
    have "?x = cor k'"
      using \<open>M = k *\<^sub>s\<^sub>m (a, b, cnj b, cnj a)\<close> assms
      by (simp add: mat_adj_def mat_cnj_def)
    hence "sgn (Re ?x) = sgn k'"
      using \<open>cor (Re ?x) = ?x\<close>
      unfolding complex_of_real_def
      by simp
    ultimately
    show ?thesis
      by simp
  qed
  ultimately
  show ?thesis
    by (rule_tac x="a" in exI, rule_tac x="b" in exI, rule_tac x="k" in exI)  simp
qed

end


(* Author: R. Thiemann *)

section \<open>Unsatisfiability over the Reals\<close>

text \<open>By using Farkas' Lemma we prove that a finite set of
  linear rational inequalities is satisfiable over the rational numbers
  if and only if it is satisfiable over the real numbers.
  Hence, the simplex algorithm either gives a rational solution or
  shows unsatisfiability over the real numbers.\<close>

theory Simplex_for_Reals
  imports
    Farkas
    Simplex.Simplex_Incremental
begin

instantiation real :: lrv
begin
definition scaleRat_real :: "rat \<Rightarrow> real \<Rightarrow> real" where
  [simp]: "x *R y = real_of_rat x * y"
instance by standard (auto simp add: field_simps of_rat_mult of_rat_add)
end

abbreviation real_satisfies_constraints :: "real valuation \<Rightarrow> constraint set \<Rightarrow> bool" (infixl "\<Turnstile>\<^sub>r\<^sub>c\<^sub>s" 100) where
  "v \<Turnstile>\<^sub>r\<^sub>c\<^sub>s cs \<equiv> \<forall> c \<in> cs. v \<Turnstile>\<^sub>c c"

definition of_rat_val :: "rat valuation \<Rightarrow> real valuation" where
  "of_rat_val v x = of_rat (v x)"

lemma of_rat_val_eval: "p \<lbrace>of_rat_val v\<rbrace> = of_rat (p \<lbrace>v\<rbrace>)"
  unfolding of_rat_val_def linear_poly_sum of_rat_sum
  by (rule sum.cong, auto simp: of_rat_mult)

lemma of_rat_val_constraint: "of_rat_val v \<Turnstile>\<^sub>c c \<longleftrightarrow> v \<Turnstile>\<^sub>c c"
  by (cases c, auto simp: of_rat_val_eval of_rat_less of_rat_less_eq)

lemma of_rat_val_constraints: "of_rat_val v \<Turnstile>\<^sub>r\<^sub>c\<^sub>s cs \<longleftrightarrow> v \<Turnstile>\<^sub>c\<^sub>s cs"
  using of_rat_val_constraint by auto

lemma sat_scale_rat_real: assumes "(v :: real valuation) \<Turnstile>\<^sub>c c"
  shows "v \<Turnstile>\<^sub>c (r *R c)"
proof -
  have "r < 0 \<or> r = 0 \<or> r > 0" by auto
  then show ?thesis using assms by (cases c, simp_all add: right_diff_distrib
        valuate_minus valuate_scaleRat scaleRat_leq1 scaleRat_leq2 valuate_zero
        of_rat_less of_rat_mult)
qed

fun of_rat_lec :: "rat le_constraint \<Rightarrow> real le_constraint" where
  "of_rat_lec (Le_Constraint r p c) = Le_Constraint r p (of_rat c)"

lemma lec_of_constraint_real:
  assumes "is_le c"
  shows "(v \<Turnstile>\<^sub>l\<^sub>e of_rat_lec (lec_of_constraint c)) \<longleftrightarrow> (v \<Turnstile>\<^sub>c c)"
  using assms by (cases c, auto)

lemma of_rat_lec_add: "of_rat_lec (c + d) = of_rat_lec c + of_rat_lec d"
  by (cases c; cases d, auto simp: of_rat_add)

lemma of_rat_lec_zero: "of_rat_lec 0 = 0"
  unfolding zero_le_constraint_def by simp

lemma of_rat_lec_sum: "of_rat_lec (sum_list c) = sum_list (map of_rat_lec c)"
  by (induct c, auto simp: of_rat_lec_zero of_rat_lec_add)

text \<open>This is the main lemma: a finite set of linear constraints is
  satisfiable over Q if and only if it is satisfiable over R.\<close>
lemma rat_real_conversion: assumes "finite cs"
  shows "(\<exists> v :: rat valuation. v \<Turnstile>\<^sub>c\<^sub>s cs) \<longleftrightarrow> (\<exists> v :: real valuation. v \<Turnstile>\<^sub>r\<^sub>c\<^sub>s cs)"
proof
  show "\<exists>v. v \<Turnstile>\<^sub>c\<^sub>s cs \<Longrightarrow> \<exists>v. v \<Turnstile>\<^sub>r\<^sub>c\<^sub>s cs" using of_rat_val_constraint by auto
  assume "\<exists>v. v \<Turnstile>\<^sub>r\<^sub>c\<^sub>s cs"
  then obtain v where *: "v \<Turnstile>\<^sub>r\<^sub>c\<^sub>s cs" by auto
  show "\<exists>v. v \<Turnstile>\<^sub>c\<^sub>s cs"
  proof (rule ccontr)
    assume "\<nexists>v. v \<Turnstile>\<^sub>c\<^sub>s cs"
    from farkas_coefficients[OF assms] this
    obtain C where "farkas_coefficients cs C" by auto
    from this[unfolded farkas_coefficients_def]
    obtain d rel where
      isleq: "(\<forall>(r,c) \<in> set C. c \<in> cs \<and> is_le (r *R c) \<and> r \<noteq> 0)" and
      leq: "(\<Sum> (r,c) \<leftarrow> C. lec_of_constraint (r *R c)) = Le_Constraint rel 0 d" and
      choice: "rel = Lt_Rel \<and> d \<le> 0 \<or> rel = Leq_Rel \<and> d < 0" by blast
    {
      fix r c
      assume c: "(r,c) \<in> set C"
      from c * isleq have "v \<Turnstile>\<^sub>c c" by auto
      hence v: "v \<Turnstile>\<^sub>c (r *R c)" by (rule sat_scale_rat_real)
      from c isleq have "is_le (r *R c)" by auto
      from lec_of_constraint_real[OF this] v
      have "v \<Turnstile>\<^sub>l\<^sub>e of_rat_lec (lec_of_constraint (r *R c))" by blast
    } note v = this
    have "Le_Constraint rel 0 (of_rat d) = of_rat_lec (\<Sum> (r,c) \<leftarrow> C. lec_of_constraint (r *R c))"
      unfolding leq by simp
    also have "\<dots> = (\<Sum> (r,c) \<leftarrow> C. of_rat_lec (lec_of_constraint (r *R c)))" (is "_ = ?sum")
      unfolding of_rat_lec_sum map_map o_def by (rule arg_cong[of _ _ sum_list], auto)
    finally have leq: "Le_Constraint rel 0 (of_rat d) = ?sum" by simp
    have "v \<Turnstile>\<^sub>l\<^sub>e Le_Constraint rel 0 (of_rat d)" unfolding leq
      by (rule satisfies_sumlist_le_constraints, insert v, auto)
    with choice show False by (auto simp: linear_poly_sum)
  qed
qed

text \<open>The main result of simplex, now using unsatisfiability over the reals.\<close>

fun i_satisfies_cs_real (infixl "\<Turnstile>\<^sub>r\<^sub>i\<^sub>c\<^sub>s" 100) where
  "(I,v) \<Turnstile>\<^sub>r\<^sub>i\<^sub>c\<^sub>s cs \<longleftrightarrow> v \<Turnstile>\<^sub>r\<^sub>c\<^sub>s Simplex.restrict_to I cs"

lemma simplex_index_real:
  "simplex_index cs = Unsat I \<Longrightarrow> set I \<subseteq> fst ` set cs \<and> \<not> (\<exists> v. (set I, v) \<Turnstile>\<^sub>r\<^sub>i\<^sub>c\<^sub>s set cs) \<and>
     (distinct_indices cs \<longrightarrow> (\<forall> J \<subset> set I. (\<exists> v. (J, v) \<Turnstile>\<^sub>i\<^sub>c\<^sub>s set cs)))" \<comment> \<open>minimal unsat core over the reals\<close>
  "simplex_index cs = Sat v \<Longrightarrow> \<langle>v\<rangle> \<Turnstile>\<^sub>c\<^sub>s (snd ` set cs)" \<comment> \<open>satisfying assingment\<close>
  using simplex_index(1)[of cs I] simplex_index(2)[of cs v]
    rat_real_conversion[of "Simplex.restrict_to (set I) (set cs)"]
  by auto

lemma simplex_real:
  "simplex cs = Unsat I \<Longrightarrow> \<not> (\<exists> v. v \<Turnstile>\<^sub>r\<^sub>c\<^sub>s set cs)" \<comment> \<open>unsat of original constraints over the reals\<close>
  "simplex cs = Unsat I \<Longrightarrow> set I \<subseteq> {0..<length cs} \<and> \<not> (\<exists> v. v \<Turnstile>\<^sub>r\<^sub>c\<^sub>s {cs ! i | i. i \<in> set I})
    \<and> (\<forall>J\<subset>set I. \<exists>v. v \<Turnstile>\<^sub>c\<^sub>s {cs ! i |i. i \<in> J})" \<comment> \<open>minimal unsat core over reals\<close>
  "simplex cs = Sat v \<Longrightarrow> \<langle>v\<rangle> \<Turnstile>\<^sub>c\<^sub>s set cs"  \<comment> \<open>satisfying assignment over the rationals\<close>
proof (intro simplex(1)[unfolded rat_real_conversion[OF finite_set]])
  assume unsat: "simplex cs = Inl I"
  have "finite {cs ! i |i. i \<in> set I}" by auto
  from simplex(2)[OF unsat, unfolded rat_real_conversion[OF this]]
  show "set I \<subseteq> {0..<length cs} \<and> \<not> (\<exists> v. v \<Turnstile>\<^sub>r\<^sub>c\<^sub>s {cs ! i | i. i \<in> set I})
    \<and> (\<forall>J\<subset>set I. \<exists>v. v \<Turnstile>\<^sub>c\<^sub>s {cs ! i |i. i \<in> J})" by auto
qed (insert simplex(3), auto)

text \<open>Define notion of minimal unsat core over the reals:
  the subset has to be unsat over the reals, and every proper subset has
  to be satisfiable over the rational numbers.\<close>

definition minimal_unsat_core_real :: "'i set \<Rightarrow> 'i i_constraint list \<Rightarrow> bool" where
  "minimal_unsat_core_real I ics  = ((I \<subseteq> fst ` set ics) \<and> (\<not> (\<exists> v. (I,v) \<Turnstile>\<^sub>r\<^sub>i\<^sub>c\<^sub>s set ics))
     \<and> (distinct_indices ics \<longrightarrow> (\<forall> J. J \<subset> I \<longrightarrow> (\<exists> v. (J,v) \<Turnstile>\<^sub>i\<^sub>c\<^sub>s set ics))))"

text \<open>Because of equi-satisfiability the two notions of minimal unsat cores coincide.\<close>
lemma minimal_unsat_core_real_conv: "minimal_unsat_core_real I ics = minimal_unsat_core I ics"
proof
  show "minimal_unsat_core_real I ics \<Longrightarrow> minimal_unsat_core I ics"
    unfolding minimal_unsat_core_real_def minimal_unsat_core_def
    using of_rat_val_constraint by simp metis
next
  assume "minimal_unsat_core I ics"
  thus "minimal_unsat_core_real I ics"
    unfolding minimal_unsat_core_real_def minimal_unsat_core_def
    using rat_real_conversion[of "Simplex.restrict_to I (set ics)"]
    by auto
qed

text \<open>Easy consequence: The incremental simplex algorithm is also sound wrt.
  minimal-unsat-cores over the reals.\<close>
lemmas incremental_simplex_real =
  init_simplex
  assert_simplex_ok
  assert_simplex_unsat[folded minimal_unsat_core_real_conv]
  assert_all_simplex_ok
  assert_all_simplex_unsat[folded minimal_unsat_core_real_conv]
  check_simplex_ok
  check_simplex_unsat[folded minimal_unsat_core_real_conv]
  solution_simplex
  backtrack_simplex
  checked_invariant_simplex

end


theory DeterministicRelation3
  imports PartialOrderRelation3
begin

text "Deterministic relation of three inputs"

definition determ :: "('a \<Rightarrow> 'b \<Rightarrow> 'c \<Rightarrow> bool) \<Rightarrow> bool"
  where
"determ r = (\<forall>f a b c. r f a b \<and> r f a c \<longrightarrow> b = c)"

lemma determD:
  "\<lbrakk>determ r; r f a b; r f a c\<rbrakk> \<Longrightarrow> b = c"
  unfolding determ_def
  by blast

text "Any relation that is less than or equal to a deterministic relation is also deterministic"

lemma determ_rel_leqD:
  "\<lbrakk>rel_leq f g; determ g\<rbrakk> \<Longrightarrow> determ f"
  unfolding determ_def
  apply clarsimp
  apply (drule (1) rel_leqD[rotated 1]; simp?)
  apply (drule (1) rel_leqD[rotated 1]; simp?)
  done

end


theory Automation
  imports Main
begin

lemma "\<forall>x. \<exists>y. x = y"
  by auto

lemma "A \<subseteq> B \<inter> C \<Longrightarrow> A \<subseteq> B \<union> C"
  by auto

lemma "\<lbrakk> \<forall>xs \<in> A. \<exists>ys. xs = ys @ ys; us \<in> A \<rbrakk> \<Longrightarrow> \<exists>n. length us = n + n"
  by fastforce

lemma "\<lbrakk> \<forall>x y. T x y \<or> T y x;
        \<forall>x y. A x y \<and> A y x \<longrightarrow> x = y;
        \<forall>x y. T x y \<longrightarrow> A x y\<rbrakk>
        \<Longrightarrow> \<forall>x y. A x y \<longrightarrow> T x y"
  by blast

lemma "\<lbrakk> xs @ ys = ys @ xs; length xs = length ys \<rbrakk> \<Longrightarrow> xs = ys"
  using append_eq_append_conv by blast

lemma "\<lbrakk> (a::nat) \<le> x + b; 2*x < c\<rbrakk> \<Longrightarrow> 2*a + 1 \<le> 2*b + c"
  by arith

lemma "\<lbrakk> (a::nat) \<le> b; b \<le> c; c \<le> d; d \<le> e\<rbrakk> \<Longrightarrow> a \<le> e"
  by (blast intro: le_trans)

end