(*  Title       : HOL/Decision_Procs/Dense_Linear_Order.thy
    Author      : Amine Chaieb, TU Muenchen
*)

section \<open>Dense linear order without endpoints
  and a quantifier elimination procedure in Ferrante and Rackoff style\<close>

theory Dense_Linear_Order
imports Main
begin

ML_file "langford_data.ML"
ML_file "ferrante_rackoff_data.ML"

context linorder
begin

lemma less_not_permute[no_atp]: "\<not> (x < y \<and> y < x)"
  by (simp add: not_less linear)

lemma gather_simps[no_atp]:
  "(\<exists>x. (\<forall>y \<in> L. y < x) \<and> (\<forall>y \<in> U. x < y) \<and> x < u \<and> P x) \<longleftrightarrow>
    (\<exists>x. (\<forall>y \<in> L. y < x) \<and> (\<forall>y \<in> (insert u U). x < y) \<and> P x)"
  "(\<exists>x. (\<forall>y \<in> L. y < x) \<and> (\<forall>y \<in> U. x < y) \<and> l < x \<and> P x) \<longleftrightarrow>
    (\<exists>x. (\<forall>y \<in> (insert l L). y < x) \<and> (\<forall>y \<in> U. x < y) \<and> P x)"
  "(\<exists>x. (\<forall>y \<in> L. y < x) \<and> (\<forall>y \<in> U. x < y) \<and> x < u) \<longleftrightarrow>
    (\<exists>x. (\<forall>y \<in> L. y < x) \<and> (\<forall>y \<in> (insert u U). x < y))"
  "(\<exists>x. (\<forall>y \<in> L. y < x) \<and> (\<forall>y \<in> U. x < y) \<and> l < x) \<longleftrightarrow>
    (\<exists>x. (\<forall>y \<in> (insert l L). y < x) \<and> (\<forall>y \<in> U. x < y))"
  by auto

lemma gather_start [no_atp]: "(\<exists>x. P x) \<equiv> (\<exists>x. (\<forall>y \<in> {}. y < x) \<and> (\<forall>y\<in> {}. x < y) \<and> P x)"
  by simp

text\<open>Theorems for \<open>\<exists>z. \<forall>x. x < z \<longrightarrow> (P x \<longleftrightarrow> P\<^sub>-\<^sub>\<infinity>)\<close>\<close>
lemma minf_lt[no_atp]:  "\<exists>z . \<forall>x. x < z \<longrightarrow> (x < t \<longleftrightarrow> True)" by auto
lemma minf_gt[no_atp]: "\<exists>z . \<forall>x. x < z \<longrightarrow>  (t < x \<longleftrightarrow>  False)"
  by (simp add: not_less) (rule exI[where x="t"], auto simp add: less_le)

lemma minf_le[no_atp]: "\<exists>z. \<forall>x. x < z \<longrightarrow> (x \<le> t \<longleftrightarrow> True)" by (auto simp add: less_le)
lemma minf_ge[no_atp]: "\<exists>z. \<forall>x. x < z \<longrightarrow> (t \<le> x \<longleftrightarrow> False)"
  by (auto simp add: less_le not_less not_le)
lemma minf_eq[no_atp]: "\<exists>z. \<forall>x. x < z \<longrightarrow> (x = t \<longleftrightarrow> False)" by auto
lemma minf_neq[no_atp]: "\<exists>z. \<forall>x. x < z \<longrightarrow> (x \<noteq> t \<longleftrightarrow> True)" by auto
lemma minf_P[no_atp]: "\<exists>z. \<forall>x. x < z \<longrightarrow> (P \<longleftrightarrow> P)" by blast

text\<open>Theorems for \<open>\<exists>z. \<forall>x. x < z \<longrightarrow> (P x \<longleftrightarrow> P\<^sub>+\<^sub>\<infinity>)\<close>\<close>
lemma pinf_gt[no_atp]:  "\<exists>z. \<forall>x. z < x \<longrightarrow> (t < x \<longleftrightarrow> True)" by auto
lemma pinf_lt[no_atp]: "\<exists>z. \<forall>x. z < x \<longrightarrow>  (x < t \<longleftrightarrow>  False)"
  by (simp add: not_less) (rule exI[where x="t"], auto simp add: less_le)

lemma pinf_ge[no_atp]: "\<exists>z. \<forall>x. z < x \<longrightarrow> (t \<le> x \<longleftrightarrow> True)" by (auto simp add: less_le)
lemma pinf_le[no_atp]: "\<exists>z. \<forall>x. z < x \<longrightarrow> (x \<le> t \<longleftrightarrow> False)"
  by (auto simp add: less_le not_less not_le)
lemma pinf_eq[no_atp]: "\<exists>z. \<forall>x. z < x \<longrightarrow> (x = t \<longleftrightarrow> False)" by auto
lemma pinf_neq[no_atp]: "\<exists>z. \<forall>x. z < x \<longrightarrow> (x \<noteq> t \<longleftrightarrow> True)" by auto
lemma pinf_P[no_atp]: "\<exists>z. \<forall>x. z < x \<longrightarrow> (P \<longleftrightarrow> P)" by blast

lemma nmi_lt[no_atp]: "t \<in> U \<Longrightarrow> \<forall>x. \<not>True \<and> x < t \<longrightarrow>  (\<exists>u\<in> U. u \<le> x)" by auto
lemma nmi_gt[no_atp]: "t \<in> U \<Longrightarrow> \<forall>x. \<not>False \<and> t < x \<longrightarrow>  (\<exists>u\<in> U. u \<le> x)"
  by (auto simp add: le_less)
lemma  nmi_le[no_atp]: "t \<in> U \<Longrightarrow> \<forall>x. \<not>True \<and> x\<le> t \<longrightarrow>  (\<exists>u\<in> U. u \<le> x)" by auto
lemma  nmi_ge[no_atp]: "t \<in> U \<Longrightarrow> \<forall>x. \<not>False \<and> t\<le> x \<longrightarrow>  (\<exists>u\<in> U. u \<le> x)" by auto
lemma  nmi_eq[no_atp]: "t \<in> U \<Longrightarrow> \<forall>x. \<not>False \<and>  x = t \<longrightarrow>  (\<exists>u\<in> U. u \<le> x)" by auto
lemma  nmi_neq[no_atp]: "t \<in> U \<Longrightarrow>\<forall>x. \<not>True \<and> x \<noteq> t \<longrightarrow>  (\<exists>u\<in> U. u \<le> x)" by auto
lemma  nmi_P[no_atp]: "\<forall>x. ~P \<and> P \<longrightarrow>  (\<exists>u\<in> U. u \<le> x)" by auto
lemma  nmi_conj[no_atp]: "\<lbrakk>\<forall>x. \<not>P1' \<and> P1 x \<longrightarrow>  (\<exists>u\<in> U. u \<le> x) ;
  \<forall>x. \<not>P2' \<and> P2 x \<longrightarrow>  (\<exists>u\<in> U. u \<le> x)\<rbrakk> \<Longrightarrow>
  \<forall>x. \<not>(P1' \<and> P2') \<and> (P1 x \<and> P2 x) \<longrightarrow>  (\<exists>u\<in> U. u \<le> x)" by auto
lemma  nmi_disj[no_atp]: "\<lbrakk>\<forall>x. \<not>P1' \<and> P1 x \<longrightarrow>  (\<exists>u\<in> U. u \<le> x) ;
  \<forall>x. \<not>P2' \<and> P2 x \<longrightarrow>  (\<exists>u\<in> U. u \<le> x)\<rbrakk> \<Longrightarrow>
  \<forall>x. \<not>(P1' \<or> P2') \<and> (P1 x \<or> P2 x) \<longrightarrow>  (\<exists>u\<in> U. u \<le> x)" by auto

lemma  npi_lt[no_atp]: "t \<in> U \<Longrightarrow> \<forall>x. \<not>False \<and>  x < t \<longrightarrow>  (\<exists>u\<in> U. x \<le> u)" by (auto simp add: le_less)
lemma  npi_gt[no_atp]: "t \<in> U \<Longrightarrow> \<forall>x. \<not>True \<and> t < x \<longrightarrow>  (\<exists>u\<in> U. x \<le> u)" by auto
lemma  npi_le[no_atp]: "t \<in> U \<Longrightarrow> \<forall>x. \<not>False \<and>  x \<le> t \<longrightarrow>  (\<exists>u\<in> U. x \<le> u)" by auto
lemma  npi_ge[no_atp]: "t \<in> U \<Longrightarrow> \<forall>x. \<not>True \<and> t \<le> x \<longrightarrow>  (\<exists>u\<in> U. x \<le> u)" by auto
lemma  npi_eq[no_atp]: "t \<in> U \<Longrightarrow> \<forall>x. \<not>False \<and>  x = t \<longrightarrow>  (\<exists>u\<in> U. x \<le> u)" by auto
lemma  npi_neq[no_atp]: "t \<in> U \<Longrightarrow> \<forall>x. \<not>True \<and> x \<noteq> t \<longrightarrow>  (\<exists>u\<in> U. x \<le> u )" by auto
lemma  npi_P[no_atp]: "\<forall>x. ~P \<and> P \<longrightarrow>  (\<exists>u\<in> U. x \<le> u)" by auto
lemma  npi_conj[no_atp]: "\<lbrakk>\<forall>x. \<not>P1' \<and> P1 x \<longrightarrow>  (\<exists>u\<in> U. x \<le> u) ;  \<forall>x. \<not>P2' \<and> P2 x \<longrightarrow>  (\<exists>u\<in> U. x \<le> u)\<rbrakk>
  \<Longrightarrow>  \<forall>x. \<not>(P1' \<and> P2') \<and> (P1 x \<and> P2 x) \<longrightarrow>  (\<exists>u\<in> U. x \<le> u)" by auto
lemma  npi_disj[no_atp]: "\<lbrakk>\<forall>x. \<not>P1' \<and> P1 x \<longrightarrow>  (\<exists>u\<in> U. x \<le> u) ; \<forall>x. \<not>P2' \<and> P2 x \<longrightarrow>  (\<exists>u\<in> U. x \<le> u)\<rbrakk>
  \<Longrightarrow> \<forall>x. \<not>(P1' \<or> P2') \<and> (P1 x \<or> P2 x) \<longrightarrow>  (\<exists>u\<in> U. x \<le> u)" by auto

lemma lin_dense_lt[no_atp]:
  "t \<in> U \<Longrightarrow>
    \<forall>x l u. (\<forall>t. l < t \<and> t < u \<longrightarrow> t \<notin> U) \<and> l < x \<and> x < u \<and> x < t \<longrightarrow> (\<forall>y. l < y \<and> y < u \<longrightarrow> y < t)"
proof clarsimp
  fix x l u y
  assume tU: "t \<in> U"
    and noU: "\<forall>t. l < t \<and> t < u \<longrightarrow> t \<notin> U"
    and lx: "l < x"
    and xu: "x < u"
    and px: "x < t"
    and ly: "l < y"
    and yu: "y < u"
  from tU noU ly yu have tny: "t \<noteq> y" by auto
  have False if H: "t < y"
  proof -
    from less_trans[OF lx px] less_trans[OF H yu] have "l < t \<and> t < u"
      by simp
    with tU noU show ?thesis
      by auto
  qed
  then have "\<not> t < y"
    by auto
  then have "y \<le> t"
    by (simp add: not_less)
  then show "y < t"
    using tny by (simp add: less_le)
qed

lemma lin_dense_gt[no_atp]:
  "t \<in> U \<Longrightarrow>
    \<forall>x l u. (\<forall>t. l < t \<and> t < u \<longrightarrow> t \<notin> U) \<and> l < x \<and> x < u \<and> t < x \<longrightarrow> (\<forall>y. l < y \<and> y < u \<longrightarrow> t < y)"
proof clarsimp
  fix x l u y
  assume tU: "t \<in> U"
    and noU: "\<forall>t. l < t \<and> t < u \<longrightarrow> t \<notin> U"
    and lx: "l < x"
    and xu: "x < u"
    and px: "t < x"
    and ly: "l < y"
    and yu: "y < u"
  from tU noU ly yu have tny: "t \<noteq> y" by auto
  have False if H: "y < t"
  proof -
    from less_trans[OF ly H] less_trans[OF px xu] have "l < t \<and> t < u"
      by simp
    with tU noU show ?thesis
      by auto
  qed
  then have "\<not> y < t"
    by auto
  then have "t \<le> y"
    by (auto simp add: not_less)
  then show "t < y"
    using tny by (simp add: less_le)
qed

lemma lin_dense_le[no_atp]:
  "t \<in> U \<Longrightarrow>
    \<forall>x l u. (\<forall>t. l < t \<and> t < u \<longrightarrow> t \<notin> U) \<and> l < x \<and> x < u \<and> x \<le> t \<longrightarrow> (\<forall>y. l < y \<and> y < u \<longrightarrow> y \<le> t)"
proof clarsimp
  fix x l u y
  assume tU: "t \<in> U"
    and noU: "\<forall>t. l < t \<and> t < u \<longrightarrow> t \<notin> U"
    and lx: "l < x"
    and xu: "x < u"
    and px: "x \<le> t"
    and ly: "l < y"
    and yu: "y < u"
  from tU noU ly yu have tny: "t \<noteq> y" by auto
  have False if H: "t < y"
  proof -
    from less_le_trans[OF lx px] less_trans[OF H yu]
    have "l < t \<and> t < u" by simp
    with tU noU show ?thesis by auto
  qed
  then have "\<not> t < y" by auto
  then show "y \<le> t" by (simp add: not_less)
qed

lemma lin_dense_ge[no_atp]:
  "t \<in> U \<Longrightarrow>
    \<forall>x l u. (\<forall>t. l < t \<and> t < u \<longrightarrow> t \<notin> U) \<and> l < x \<and> x < u \<and> t \<le> x \<longrightarrow> (\<forall>y. l < y \<and> y < u \<longrightarrow> t \<le> y)"
proof clarsimp
  fix x l u y
  assume tU: "t \<in> U"
    and noU: "\<forall>t. l < t \<and> t < u \<longrightarrow> t \<notin> U"
    and lx: "l < x"
    and xu: "x < u"
    and px: "t \<le> x"
    and ly: "l < y"
    and yu: "y < u"
  from tU noU ly yu have tny: "t \<noteq> y" by auto
  have False if H: "y < t"
  proof -
    from less_trans[OF ly H] le_less_trans[OF px xu]
    have "l < t \<and> t < u" by simp
    with tU noU show ?thesis by auto
  qed
  then have "\<not> y < t" by auto
  then show "t \<le> y" by (simp add: not_less)
qed

lemma lin_dense_eq[no_atp]:
  "t \<in> U \<Longrightarrow>
    \<forall>x l u. (\<forall>t. l < t \<and> t < u \<longrightarrow> t \<notin> U) \<and> l < x \<and> x < u \<and> x = t \<longrightarrow> (\<forall>y. l < y \<and> y < u \<longrightarrow> y = t)"
  by auto

lemma lin_dense_neq[no_atp]:
  "t \<in> U \<Longrightarrow>
    \<forall>x l u. (\<forall>t. l < t \<and> t < u \<longrightarrow> t \<notin> U) \<and> l < x \<and> x < u \<and> x \<noteq> t \<longrightarrow> (\<forall>y. l < y \<and> y < u \<longrightarrow> y \<noteq> t)"
  by auto

lemma lin_dense_P[no_atp]:
  "\<forall>x l u. (\<forall>t. l < t \<and> t < u \<longrightarrow> t \<notin> U) \<and> l < x \<and> x < u \<and> P \<longrightarrow> (\<forall>y. l < y \<and> y < u \<longrightarrow> P)"
  by auto

lemma lin_dense_conj[no_atp]:
  "\<lbrakk>\<forall>x l u. (\<forall>t. l < t \<and> t < u \<longrightarrow> t \<notin> U) \<and> l < x \<and> x < u \<and> P1 x
  \<longrightarrow> (\<forall>y. l < y \<and> y < u \<longrightarrow> P1 y) ;
  \<forall>x l u. (\<forall>t. l < t \<and> t < u \<longrightarrow> t \<notin> U) \<and> l < x \<and> x < u \<and> P2 x
  \<longrightarrow> (\<forall>y. l < y \<and> y < u \<longrightarrow> P2 y)\<rbrakk> \<Longrightarrow>
  \<forall>x l u. (\<forall>t. l < t \<and> t < u \<longrightarrow> t \<notin> U) \<and> l < x \<and> x < u \<and> (P1 x \<and> P2 x)
  \<longrightarrow> (\<forall>y. l < y \<and> y < u \<longrightarrow> (P1 y \<and> P2 y))"
  by blast
lemma lin_dense_disj[no_atp]:
  "\<lbrakk>\<forall>x l u. (\<forall>t. l < t \<and> t < u \<longrightarrow> t \<notin> U) \<and> l < x \<and> x < u \<and> P1 x
  \<longrightarrow> (\<forall>y. l < y \<and> y < u \<longrightarrow> P1 y) ;
  \<forall>x l u. (\<forall>t. l < t \<and> t < u \<longrightarrow> t \<notin> U) \<and> l < x \<and> x < u \<and> P2 x
  \<longrightarrow> (\<forall>y. l < y \<and> y < u \<longrightarrow> P2 y)\<rbrakk> \<Longrightarrow>
  \<forall>x l u. (\<forall>t. l < t \<and> t < u \<longrightarrow> t \<notin> U) \<and> l < x \<and> x < u \<and> (P1 x \<or> P2 x)
  \<longrightarrow> (\<forall>y. l < y \<and> y < u \<longrightarrow> (P1 y \<or> P2 y))"
  by blast

lemma npmibnd[no_atp]: "\<lbrakk>\<forall>x. \<not> MP \<and> P x \<longrightarrow> (\<exists>u\<in> U. u \<le> x); \<forall>x. \<not>PP \<and> P x \<longrightarrow> (\<exists>u\<in> U. x \<le> u)\<rbrakk>
  \<Longrightarrow> \<forall>x. \<not> MP \<and> \<not>PP \<and> P x \<longrightarrow> (\<exists>u\<in> U. \<exists>u' \<in> U. u \<le> x \<and> x \<le> u')"
  by auto

lemma finite_set_intervals[no_atp]:
  assumes px: "P x"
    and lx: "l \<le> x"
    and xu: "x \<le> u"
    and linS: "l\<in> S"
    and uinS: "u \<in> S"
    and fS:"finite S"
    and lS: "\<forall>x\<in> S. l \<le> x"
    and Su: "\<forall>x\<in> S. x \<le> u"
  shows "\<exists>a \<in> S. \<exists>b \<in> S. (\<forall>y. a < y \<and> y < b \<longrightarrow> y \<notin> S) \<and> a \<le> x \<and> x \<le> b \<and> P x"
proof -
  let ?Mx = "{y. y\<in> S \<and> y \<le> x}"
  let ?xM = "{y. y\<in> S \<and> x \<le> y}"
  let ?a = "Max ?Mx"
  let ?b = "Min ?xM"
  have MxS: "?Mx \<subseteq> S"
    by blast
  then have fMx: "finite ?Mx"
    using fS finite_subset by auto
  from lx linS have linMx: "l \<in> ?Mx"
    by blast
  then have Mxne: "?Mx \<noteq> {}"
    by blast
  have xMS: "?xM \<subseteq> S"
    by blast
  then have fxM: "finite ?xM"
    using fS finite_subset by auto
  from xu uinS have linxM: "u \<in> ?xM"
    by blast
  then have xMne: "?xM \<noteq> {}"
    by blast
  have ax: "?a \<le> x"
    using Mxne fMx by auto
  have xb: "x \<le> ?b"
    using xMne fxM by auto
  have "?a \<in> ?Mx"
    using Max_in[OF fMx Mxne] by simp
  then have ainS: "?a \<in> S"
    using MxS by blast
  have "?b \<in> ?xM"
    using Min_in[OF fxM xMne] by simp
  then have binS: "?b \<in> S"
    using xMS by blast
  have noy: "\<forall>y. ?a < y \<and> y < ?b \<longrightarrow> y \<notin> S"
  proof clarsimp
    fix y
    assume ay: "?a < y" and yb: "y < ?b" and yS: "y \<in> S"
    from yS have "y \<in> ?Mx \<or> y \<in> ?xM"
      by (auto simp add: linear)
    then show False
    proof
      assume "y \<in> ?Mx"
      then have "y \<le> ?a"
        using Mxne fMx by auto
      with ay show ?thesis
        by (simp add: not_le[symmetric])
    next
      assume "y \<in> ?xM"
      then have "?b \<le> y"
        using xMne fxM by auto
      with yb show ?thesis
        by (simp add: not_le[symmetric])
    qed
  qed
  from ainS binS noy ax xb px show ?thesis
    by blast
qed

lemma finite_set_intervals2[no_atp]:
  assumes px: "P x"
    and lx: "l \<le> x"
    and xu: "x \<le> u"
    and linS: "l\<in> S"
    and uinS: "u \<in> S"
    and fS: "finite S"
    and lS: "\<forall>x\<in> S. l \<le> x"
    and Su: "\<forall>x\<in> S. x \<le> u"
  shows "(\<exists>s\<in> S. P s) \<or> (\<exists>a \<in> S. \<exists>b \<in> S. (\<forall>y. a < y \<and> y < b \<longrightarrow> y \<notin> S) \<and> a < x \<and> x < b \<and> P x)"
proof -
  from finite_set_intervals[where P="P", OF px lx xu linS uinS fS lS Su]
  obtain a and b where as: "a \<in> S" and bs: "b \<in> S"
    and noS: "\<forall>y. a < y \<and> y < b \<longrightarrow> y \<notin> S"
    and axb: "a \<le> x \<and> x \<le> b \<and> P x"
    by auto
  from axb have "x = a \<or> x = b \<or> (a < x \<and> x < b)"
    by (auto simp add: le_less)
  then show ?thesis
    using px as bs noS by blast
qed

end

section \<open>The classical QE after Langford for dense linear orders\<close>

context unbounded_dense_linorder
begin

lemma interval_empty_iff: "{y. x < y \<and> y < z} = {} \<longleftrightarrow> \<not> x < z"
  by (auto dest: dense)

lemma dlo_qe_bnds[no_atp]:
  assumes ne: "L \<noteq> {}"
    and neU: "U \<noteq> {}"
    and fL: "finite L"
    and fU: "finite U"
  shows "(\<exists>x. (\<forall>y \<in> L. y < x) \<and> (\<forall>y \<in> U. x < y)) \<equiv> (\<forall>l \<in> L. \<forall>u \<in> U. l < u)"
proof (simp only: atomize_eq, rule iffI)
  assume H: "\<exists>x. (\<forall>y\<in>L. y < x) \<and> (\<forall>y\<in>U. x < y)"
  then obtain x where xL: "\<forall>y\<in>L. y < x" and xU: "\<forall>y\<in>U. x < y"
    by blast
  have "l < u" if l: "l \<in> L" and u: "u \<in> U" for l u
  proof -
    have "l < x" using xL l by blast
    also have "x < u" using xU u by blast
    finally show ?thesis .
  qed
  then show "\<forall>l\<in>L. \<forall>u\<in>U. l < u" by blast
next
  assume H: "\<forall>l\<in>L. \<forall>u\<in>U. l < u"
  let ?ML = "Max L"
  let ?MU = "Min U"
  from fL ne have th1: "?ML \<in> L" and th1': "\<forall>l\<in>L. l \<le> ?ML"
    by auto
  from fU neU have th2: "?MU \<in> U" and th2': "\<forall>u\<in>U. ?MU \<le> u"
    by auto
  from th1 th2 H have "?ML < ?MU"
    by auto
  with dense obtain w where th3: "?ML < w" and th4: "w < ?MU"
    by blast
  from th3 th1' have "\<forall>l \<in> L. l < w"
    by auto
  moreover from th4 th2' have "\<forall>u \<in> U. w < u"
    by auto
  ultimately show "\<exists>x. (\<forall>y\<in>L. y < x) \<and> (\<forall>y\<in>U. x < y)"
    by auto
qed

lemma dlo_qe_noub[no_atp]:
  assumes ne: "L \<noteq> {}"
    and fL: "finite L"
  shows "(\<exists>x. (\<forall>y \<in> L. y < x) \<and> (\<forall>y \<in> {}. x < y)) \<equiv> True"
proof (simp add: atomize_eq)
  from gt_ex[of "Max L"] obtain M where M: "Max L < M"
    by blast
  from ne fL have "\<forall>x \<in> L. x \<le> Max L"
    by simp
  with M have "\<forall>x\<in>L. x < M"
    by (auto intro: le_less_trans)
  then show "\<exists>x. \<forall>y\<in>L. y < x"
    by blast
qed

lemma dlo_qe_nolb[no_atp]:
  assumes ne: "U \<noteq> {}"
    and fU: "finite U"
  shows "(\<exists>x. (\<forall>y \<in> {}. y < x) \<and> (\<forall>y \<in> U. x < y)) \<equiv> True"
proof (simp add: atomize_eq)
  from lt_ex[of "Min U"] obtain M where M: "M < Min U"
    by blast
  from ne fU have "\<forall>x \<in> U. Min U \<le> x"
    by simp
  with M have "\<forall>x\<in>U. M < x"
    by (auto intro: less_le_trans)
  then show "\<exists>x. \<forall>y\<in>U. x < y"
    by blast
qed

lemma exists_neq[no_atp]: "\<exists>(x::'a). x \<noteq> t" "\<exists>(x::'a). t \<noteq> x"
  using gt_ex[of t] by auto

lemmas dlo_simps[no_atp] = order_refl less_irrefl not_less not_le exists_neq
  le_less neq_iff linear less_not_permute

lemma axiom[no_atp]: "class.unbounded_dense_linorder (op \<le>) (op <)"
  by (rule unbounded_dense_linorder_axioms)
lemma atoms[no_atp]:
  shows "TERM (less :: 'a \<Rightarrow> _)"
    and "TERM (less_eq :: 'a \<Rightarrow> _)"
    and "TERM (op = :: 'a \<Rightarrow> _)" .

declare axiom[langford qe: dlo_qe_bnds dlo_qe_nolb dlo_qe_noub gather: gather_start gather_simps atoms: atoms]
declare dlo_simps[langfordsimp]

end

(* FIXME: Move to HOL -- together with the conj_aci_rule in langford.ML *)
lemmas dnf[no_atp] = conj_disj_distribL conj_disj_distribR

lemmas weak_dnf_simps[no_atp] = simp_thms dnf

lemma nnf_simps[no_atp]:
  "(\<not> (P \<and> Q)) \<longleftrightarrow> (\<not> P \<or> \<not> Q)"
  "(\<not> (P \<or> Q)) \<longleftrightarrow> (\<not> P \<and> \<not> Q)"
  "(P \<longrightarrow> Q) \<longleftrightarrow> (\<not> P \<or> Q)"
  "(P \<longleftrightarrow> Q) \<longleftrightarrow> ((P \<and> Q) \<or> (\<not> P \<and> \<not> Q))"
  "(\<not> \<not> P) \<longleftrightarrow> P"
  by blast+

lemma ex_distrib[no_atp]: "(\<exists>x. P x \<or> Q x) \<longleftrightarrow> ((\<exists>x. P x) \<or> (\<exists>x. Q x))"
  by blast

lemmas dnf_simps[no_atp] = weak_dnf_simps nnf_simps ex_distrib

ML_file "langford.ML"
method_setup dlo = \<open>
  Scan.succeed (SIMPLE_METHOD' o Langford.dlo_tac)
\<close> "Langford's algorithm for quantifier elimination in dense linear orders"

section \<open>Contructive dense linear orders yield QE for linear arithmetic over ordered Fields\<close>

text \<open>Linear order without upper bounds\<close>

locale linorder_stupid_syntax = linorder
begin

notation
  less_eq  ("op \<sqsubseteq>") and
  less_eq  ("(_/ \<sqsubseteq> _)" [51, 51] 50) and
  less  ("op \<sqsubset>") and
  less  ("(_/ \<sqsubset> _)"  [51, 51] 50)

end

locale linorder_no_ub = linorder_stupid_syntax +
  assumes gt_ex: "\<exists>y. less x y"
begin

lemma ge_ex[no_atp]: "\<exists>y. x \<sqsubseteq> y"
  using gt_ex by auto

text \<open>Theorems for \<open>\<exists>z. \<forall>x. z \<sqsubset> x \<longrightarrow> (P x \<longleftrightarrow> P\<^sub>+\<^sub>\<infinity>)\<close>\<close>
lemma pinf_conj[no_atp]:
  assumes ex1: "\<exists>z1. \<forall>x. z1 \<sqsubset> x \<longrightarrow> (P1 x \<longleftrightarrow> P1')"
    and ex2: "\<exists>z2. \<forall>x. z2 \<sqsubset> x \<longrightarrow> (P2 x \<longleftrightarrow> P2')"
  shows "\<exists>z. \<forall>x. z \<sqsubset>  x \<longrightarrow> ((P1 x \<and> P2 x) \<longleftrightarrow> (P1' \<and> P2'))"
proof -
  from ex1 ex2 obtain z1 and z2
    where z1: "\<forall>x. z1 \<sqsubset> x \<longrightarrow> (P1 x \<longleftrightarrow> P1')"
    and z2: "\<forall>x. z2 \<sqsubset> x \<longrightarrow> (P2 x \<longleftrightarrow> P2')"
    by blast
  from gt_ex obtain z where z:"ord.max less_eq z1 z2 \<sqsubset> z"
    by blast
  from z have zz1: "z1 \<sqsubset> z" and zz2: "z2 \<sqsubset> z"
    by simp_all
  have "(P1 x \<and> P2 x) \<longleftrightarrow> (P1' \<and> P2')" if H: "z \<sqsubset> x" for x
    using less_trans[OF zz1 H] less_trans[OF zz2 H] z1 zz1 z2 zz2 by auto
  then show ?thesis
    by blast
qed

lemma pinf_disj[no_atp]:
  assumes ex1: "\<exists>z1. \<forall>x. z1 \<sqsubset> x \<longrightarrow> (P1 x \<longleftrightarrow> P1')"
    and ex2: "\<exists>z2. \<forall>x. z2 \<sqsubset> x \<longrightarrow> (P2 x \<longleftrightarrow> P2')"
  shows "\<exists>z. \<forall>x. z \<sqsubset>  x \<longrightarrow> ((P1 x \<or> P2 x) \<longleftrightarrow> (P1' \<or> P2'))"
proof-
  from ex1 ex2 obtain z1 and z2
    where z1: "\<forall>x. z1 \<sqsubset> x \<longrightarrow> (P1 x \<longleftrightarrow> P1')"
    and z2: "\<forall>x. z2 \<sqsubset> x \<longrightarrow> (P2 x \<longleftrightarrow> P2')"
    by blast
  from gt_ex obtain z where z: "ord.max less_eq z1 z2 \<sqsubset> z"
    by blast
  from z have zz1: "z1 \<sqsubset> z" and zz2: "z2 \<sqsubset> z"
    by simp_all
  have "(P1 x \<or> P2 x) \<longleftrightarrow> (P1' \<or> P2')" if H: "z \<sqsubset> x" for x
    using less_trans[OF zz1 H] less_trans[OF zz2 H] z1 zz1 z2 zz2 by auto
  then show ?thesis
    by blast
qed

lemma pinf_ex[no_atp]:
  assumes ex: "\<exists>z. \<forall>x. z \<sqsubset> x \<longrightarrow> (P x \<longleftrightarrow> P1)"
    and p1: P1
  shows "\<exists>x. P x"
proof -
  from ex obtain z where z: "\<forall>x. z \<sqsubset> x \<longrightarrow> (P x \<longleftrightarrow> P1)"
    by blast
  from gt_ex obtain x where x: "z \<sqsubset> x"
    by blast
  from z x p1 show ?thesis
    by blast
qed

end

text \<open>Linear order without upper bounds\<close>

locale linorder_no_lb = linorder_stupid_syntax +
  assumes lt_ex: "\<exists>y. less y x"
begin

lemma le_ex[no_atp]: "\<exists>y. y \<sqsubseteq> x"
  using lt_ex by auto

text \<open>Theorems for \<open>\<exists>z. \<forall>x. x \<sqsubset> z \<longrightarrow> (P x \<longleftrightarrow> P\<^sub>-\<^sub>\<infinity>)\<close>\<close>
lemma minf_conj[no_atp]:
  assumes ex1: "\<exists>z1. \<forall>x. x \<sqsubset> z1 \<longrightarrow> (P1 x \<longleftrightarrow> P1')"
    and ex2: "\<exists>z2. \<forall>x. x \<sqsubset> z2 \<longrightarrow> (P2 x \<longleftrightarrow> P2')"
  shows "\<exists>z. \<forall>x. x \<sqsubset>  z \<longrightarrow> ((P1 x \<and> P2 x) \<longleftrightarrow> (P1' \<and> P2'))"
proof -
  from ex1 ex2 obtain z1 and z2
    where z1: "\<forall>x. x \<sqsubset> z1 \<longrightarrow> (P1 x \<longleftrightarrow> P1')"
    and z2: "\<forall>x. x \<sqsubset> z2 \<longrightarrow> (P2 x \<longleftrightarrow> P2')"
    by blast
  from lt_ex obtain z where z: "z \<sqsubset> ord.min less_eq z1 z2"
    by blast
  from z have zz1: "z \<sqsubset> z1" and zz2: "z \<sqsubset> z2"
    by simp_all
  have "(P1 x \<and> P2 x) \<longleftrightarrow> (P1' \<and> P2')" if H: "x \<sqsubset> z" for x
    using less_trans[OF H zz1] less_trans[OF H zz2] z1 zz1 z2 zz2 by auto
  then show ?thesis
    by blast
qed

lemma minf_disj[no_atp]:
  assumes ex1: "\<exists>z1. \<forall>x. x \<sqsubset> z1 \<longrightarrow> (P1 x \<longleftrightarrow> P1')"
    and ex2: "\<exists>z2. \<forall>x. x \<sqsubset> z2 \<longrightarrow> (P2 x \<longleftrightarrow> P2')"
  shows "\<exists>z. \<forall>x. x \<sqsubset>  z \<longrightarrow> ((P1 x \<or> P2 x) \<longleftrightarrow> (P1' \<or> P2'))"
proof -
  from ex1 ex2 obtain z1 and z2
    where z1: "\<forall>x. x \<sqsubset> z1 \<longrightarrow> (P1 x \<longleftrightarrow> P1')"
    and z2: "\<forall>x. x \<sqsubset> z2 \<longrightarrow> (P2 x \<longleftrightarrow> P2')"
    by blast
  from lt_ex obtain z where z: "z \<sqsubset> ord.min less_eq z1 z2"
    by blast
  from z have zz1: "z \<sqsubset> z1" and zz2: "z \<sqsubset> z2"
    by simp_all
  have "(P1 x \<or> P2 x) \<longleftrightarrow> (P1' \<or> P2')" if H: "x \<sqsubset> z" for x
    using less_trans[OF H zz1] less_trans[OF H zz2] z1 zz1 z2 zz2 by auto
  then show ?thesis
    by blast
qed

lemma minf_ex[no_atp]:
  assumes ex: "\<exists>z. \<forall>x. x \<sqsubset> z \<longrightarrow> (P x \<longleftrightarrow> P1)"
    and p1: P1
  shows "\<exists>x. P x"
proof -
  from ex obtain z where z: "\<forall>x. x \<sqsubset> z \<longrightarrow> (P x \<longleftrightarrow> P1)"
    by blast
  from lt_ex obtain x where x: "x \<sqsubset> z"
    by blast
  from z x p1 show ?thesis
    by blast
qed

end

locale constr_dense_linorder = linorder_no_lb + linorder_no_ub +
  fixes between
  assumes between_less: "less x y \<Longrightarrow> less x (between x y) \<and> less (between x y) y"
    and between_same: "between x x = x"
begin

sublocale dlo: unbounded_dense_linorder
proof (unfold_locales, goal_cases)
  case (1 x y)
  then show ?case
    using between_less [of x y] by auto
next
  case 2
  then show ?case by (rule lt_ex)
next
  case 3
  then show ?case by (rule gt_ex)
qed

lemma rinf_U[no_atp]:
  assumes fU: "finite U"
    and lin_dense: "\<forall>x l u. (\<forall>t. l \<sqsubset> t \<and> t\<sqsubset> u \<longrightarrow> t \<notin> U) \<and> l\<sqsubset> x \<and> x \<sqsubset> u \<and> P x
      \<longrightarrow> (\<forall>y. l \<sqsubset> y \<and> y \<sqsubset> u \<longrightarrow> P y )"
    and nmpiU: "\<forall>x. \<not> MP \<and> \<not>PP \<and> P x \<longrightarrow> (\<exists>u\<in> U. \<exists>u' \<in> U. u \<sqsubseteq> x \<and> x \<sqsubseteq> u')"
    and nmi: "\<not> MP"  and npi: "\<not> PP"  and ex: "\<exists>x.  P x"
  shows "\<exists>u\<in> U. \<exists>u' \<in> U. P (between u u')"
proof -
  from ex obtain x where px: "P x"
    by blast
  from px nmi npi nmpiU have "\<exists>u\<in> U. \<exists>u' \<in> U. u \<sqsubseteq> x \<and> x \<sqsubseteq> u'"
    by auto
  then obtain u and u' where uU: "u\<in> U" and uU': "u' \<in> U" and ux: "u \<sqsubseteq> x" and xu': "x \<sqsubseteq> u'"
    by auto
  from uU have Une: "U \<noteq> {}"
    by auto
  let ?l = "linorder.Min less_eq U"
  let ?u = "linorder.Max less_eq U"
  have linM: "?l \<in> U"
    using fU Une by simp
  have uinM: "?u \<in> U"
    using fU Une by simp
  have lM: "\<forall>t\<in> U. ?l \<sqsubseteq> t"
    using Une fU by auto
  have Mu: "\<forall>t\<in> U. t \<sqsubseteq> ?u"
    using Une fU by auto
  have th: "?l \<sqsubseteq> u"
    using uU Une lM by auto
  from order_trans[OF th ux] have lx: "?l \<sqsubseteq> x" .
  have th: "u' \<sqsubseteq> ?u"
    using uU' Une Mu by simp
  from order_trans[OF xu' th] have xu: "x \<sqsubseteq> ?u" .
  from finite_set_intervals2[where P="P",OF px lx xu linM uinM fU lM Mu]
  consider u where "u \<in> U" "P u" |
    t1 t2 where "t1 \<in> U" "t2 \<in> U" "\<forall>y. t1 \<sqsubset> y \<and> y \<sqsubset> t2 \<longrightarrow> y \<notin> U" "t1 \<sqsubset> x" "x \<sqsubset> t2" "P x"
    by blast
  then show ?thesis
  proof cases
    case u: 1
    have "between u u = u" by (simp add: between_same)
    with u have "P (between u u)" by simp
    with u show ?thesis by blast
  next
    case 2
    note t1M = \<open>t1 \<in> U\<close> and t2M = \<open>t2\<in> U\<close>
      and noM = \<open>\<forall>y. t1 \<sqsubset> y \<and> y \<sqsubset> t2 \<longrightarrow> y \<notin> U\<close>
      and t1x = \<open>t1 \<sqsubset> x\<close> and xt2 = \<open>x \<sqsubset> t2\<close>
      and px = \<open>P x\<close>
    from less_trans[OF t1x xt2] have t1t2: "t1 \<sqsubset> t2" .
    let ?u = "between t1 t2"
    from between_less t1t2 have t1lu: "t1 \<sqsubset> ?u" and ut2: "?u \<sqsubset> t2" by auto
    from lin_dense noM t1x xt2 px t1lu ut2 have "P ?u" by blast
    with t1M t2M show ?thesis by blast
  qed
qed

theorem fr_eq[no_atp]:
  assumes fU: "finite U"
    and lin_dense: "\<forall>x l u. (\<forall>t. l \<sqsubset> t \<and> t\<sqsubset> u \<longrightarrow> t \<notin> U) \<and> l\<sqsubset> x \<and> x \<sqsubset> u \<and> P x
     \<longrightarrow> (\<forall>y. l \<sqsubset> y \<and> y \<sqsubset> u \<longrightarrow> P y )"
    and nmibnd: "\<forall>x. \<not> MP \<and> P x \<longrightarrow> (\<exists>u\<in> U. u \<sqsubseteq> x)"
    and npibnd: "\<forall>x. \<not>PP \<and> P x \<longrightarrow> (\<exists>u\<in> U. x \<sqsubseteq> u)"
    and mi: "\<exists>z. \<forall>x. x \<sqsubset> z \<longrightarrow> (P x = MP)"  and pi: "\<exists>z. \<forall>x. z \<sqsubset> x \<longrightarrow> (P x = PP)"
  shows "(\<exists>x. P x) \<equiv> (MP \<or> PP \<or> (\<exists>u \<in> U. \<exists>u'\<in> U. P (between u u')))"
  (is "_ \<equiv> (_ \<or> _ \<or> ?F)" is "?E \<equiv> ?D")
proof -
  have "?E \<longleftrightarrow> ?D"
  proof
    show ?D if px: ?E
    proof -
      consider "MP \<or> PP" | "\<not> MP" "\<not> PP" by blast
      then show ?thesis
      proof cases
        case 1
        then show ?thesis by blast
      next
        case 2
        from npmibnd[OF nmibnd npibnd]
        have nmpiU: "\<forall>x. \<not> MP \<and> \<not>PP \<and> P x \<longrightarrow> (\<exists>u\<in> U. \<exists>u' \<in> U. u \<sqsubseteq> x \<and> x \<sqsubseteq> u')" .
        from rinf_U[OF fU lin_dense nmpiU \<open>\<not> MP\<close> \<open>\<not> PP\<close> px] show ?thesis
          by blast
      qed
    qed
    show ?E if ?D
    proof -
      from that consider MP | PP | ?F by blast
      then show ?thesis
      proof cases
        case 1
        from minf_ex[OF mi this] show ?thesis .
      next
        case 2
        from pinf_ex[OF pi this] show ?thesis .
      next
        case 3
        then show ?thesis by blast
      qed
    qed
  qed
  then show "?E \<equiv> ?D" by simp
qed

lemmas minf_thms[no_atp] = minf_conj minf_disj minf_eq minf_neq minf_lt minf_le minf_gt minf_ge minf_P
lemmas pinf_thms[no_atp] = pinf_conj pinf_disj pinf_eq pinf_neq pinf_lt pinf_le pinf_gt pinf_ge pinf_P

lemmas nmi_thms[no_atp] = nmi_conj nmi_disj nmi_eq nmi_neq nmi_lt nmi_le nmi_gt nmi_ge nmi_P
lemmas npi_thms[no_atp] = npi_conj npi_disj npi_eq npi_neq npi_lt npi_le npi_gt npi_ge npi_P
lemmas lin_dense_thms[no_atp] = lin_dense_conj lin_dense_disj lin_dense_eq lin_dense_neq lin_dense_lt lin_dense_le lin_dense_gt lin_dense_ge lin_dense_P

lemma ferrack_axiom[no_atp]: "constr_dense_linorder less_eq less between"
  by (rule constr_dense_linorder_axioms)

lemma atoms[no_atp]:
  shows "TERM (less :: 'a \<Rightarrow> _)"
    and "TERM (less_eq :: 'a \<Rightarrow> _)"
    and "TERM (op = :: 'a \<Rightarrow> _)" .

declare ferrack_axiom [ferrack minf: minf_thms pinf: pinf_thms
    nmi: nmi_thms npi: npi_thms lindense:
    lin_dense_thms qe: fr_eq atoms: atoms]

declaration \<open>
let
  fun simps phi = map (Morphism.thm phi) [@{thm "not_less"}, @{thm "not_le"}]
  fun generic_whatis phi =
    let
      val [lt, le] = map (Morphism.term phi) [@{term "op \<sqsubset>"}, @{term "op \<sqsubseteq>"}]
      fun h x t =
        case Thm.term_of t of
          Const(@{const_name HOL.eq}, _)$y$z =>
            if Thm.term_of x aconv y then Ferrante_Rackoff_Data.Eq
            else Ferrante_Rackoff_Data.Nox
       | @{term "Not"}$(Const(@{const_name HOL.eq}, _)$y$z) =>
            if Thm.term_of x aconv y then Ferrante_Rackoff_Data.NEq
            else Ferrante_Rackoff_Data.Nox
       | b$y$z => if Term.could_unify (b, lt) then
                     if Thm.term_of x aconv y then Ferrante_Rackoff_Data.Lt
                     else if Thm.term_of x aconv z then Ferrante_Rackoff_Data.Gt
                     else Ferrante_Rackoff_Data.Nox
                 else if Term.could_unify (b, le) then
                     if Thm.term_of x aconv y then Ferrante_Rackoff_Data.Le
                     else if Thm.term_of x aconv z then Ferrante_Rackoff_Data.Ge
                     else Ferrante_Rackoff_Data.Nox
                 else Ferrante_Rackoff_Data.Nox
       | _ => Ferrante_Rackoff_Data.Nox
  in h end
  fun ss phi ctxt =
    simpset_of (put_simpset HOL_ss ctxt addsimps (simps phi))
in
  Ferrante_Rackoff_Data.funs  @{thm "ferrack_axiom"}
    {isolate_conv = K (K (K Thm.reflexive)), whatis = generic_whatis, simpset = ss}
end
\<close>

end

ML_file "ferrante_rackoff.ML"

method_setup ferrack = \<open>
  Scan.succeed (SIMPLE_METHOD' o FerranteRackoff.dlo_tac)
\<close> "Ferrante and Rackoff's algorithm for quantifier elimination in dense linear orders"

subsection \<open>Ferrante and Rackoff algorithm over ordered fields\<close>

lemma neg_prod_lt:
  fixes c :: "'a::linordered_field"
  assumes "c < 0"
  shows "c * x < 0 \<equiv> x > 0"
proof -
  have "c * x < 0 \<longleftrightarrow> 0 / c < x"
    by (simp only: neg_divide_less_eq[OF \<open>c < 0\<close>] algebra_simps)
  also have "\<dots> \<longleftrightarrow> 0 < x" by simp
  finally show "PROP ?thesis" by simp
qed

lemma pos_prod_lt:
  fixes c :: "'a::linordered_field"
  assumes "c > 0"
  shows "c * x < 0 \<equiv> x < 0"
proof -
  have "c * x < 0 \<longleftrightarrow> 0 /c > x"
    by (simp only: pos_less_divide_eq[OF \<open>c > 0\<close>] algebra_simps)
  also have "\<dots> \<longleftrightarrow> 0 > x" by simp
  finally show "PROP ?thesis" by simp
qed

lemma neg_prod_sum_lt:
  fixes c :: "'a::linordered_field"
  assumes "c < 0"
  shows "c * x + t < 0 \<equiv> x > (- 1 / c) * t"
proof -
  have "c * x + t < 0 \<longleftrightarrow> c * x < - t"
    by (subst less_iff_diff_less_0 [of "c * x" "- t"]) simp
  also have "\<dots> \<longleftrightarrow> - t / c < x"
    by (simp only: neg_divide_less_eq[OF \<open>c < 0\<close>] algebra_simps)
  also have "\<dots> \<longleftrightarrow> (- 1 / c) * t < x" by simp
  finally show "PROP ?thesis" by simp
qed

lemma pos_prod_sum_lt:
  fixes c :: "'a::linordered_field"
  assumes "c > 0"
  shows "c * x + t < 0 \<equiv> x < (- 1 / c) * t"
proof -
  have "c * x + t < 0 \<longleftrightarrow> c * x < - t"
    by (subst less_iff_diff_less_0 [of "c * x" "- t"]) simp
  also have "\<dots> \<longleftrightarrow> - t / c > x"
    by (simp only: pos_less_divide_eq[OF \<open>c > 0\<close>] algebra_simps)
  also have "\<dots> \<longleftrightarrow> (- 1 / c) * t > x" by simp
  finally show "PROP ?thesis" by simp
qed

lemma sum_lt:
  fixes x :: "'a::ordered_ab_group_add"
  shows "x + t < 0 \<equiv> x < - t"
  using less_diff_eq[where a= x and b=t and c=0] by simp

lemma neg_prod_le:
  fixes c :: "'a::linordered_field"
  assumes "c < 0"
  shows "c * x \<le> 0 \<equiv> x \<ge> 0"
proof -
  have "c * x \<le> 0 \<longleftrightarrow> 0 / c \<le> x"
    by (simp only: neg_divide_le_eq[OF \<open>c < 0\<close>] algebra_simps)
  also have "\<dots> \<longleftrightarrow> 0 \<le> x" by simp
  finally show "PROP ?thesis" by simp
qed

lemma pos_prod_le:
  fixes c :: "'a::linordered_field"
  assumes "c > 0"
  shows "c * x \<le> 0 \<equiv> x \<le> 0"
proof -
  have "c * x \<le> 0 \<longleftrightarrow> 0 / c \<ge> x"
    by (simp only: pos_le_divide_eq[OF \<open>c > 0\<close>] algebra_simps)
  also have "\<dots> \<longleftrightarrow> 0 \<ge> x" by simp
  finally show "PROP ?thesis" by simp
qed

lemma neg_prod_sum_le:
  fixes c :: "'a::linordered_field"
  assumes "c < 0"
  shows "c * x + t \<le> 0 \<equiv> x \<ge> (- 1 / c) * t"
proof -
  have "c * x + t \<le> 0 \<longleftrightarrow> c * x \<le> -t"
    by (subst le_iff_diff_le_0 [of "c*x" "-t"]) simp
  also have "\<dots> \<longleftrightarrow> - t / c \<le> x"
    by (simp only: neg_divide_le_eq[OF \<open>c < 0\<close>] algebra_simps)
  also have "\<dots> \<longleftrightarrow> (- 1 / c) * t \<le> x" by simp
  finally show "PROP ?thesis" by simp
qed

lemma pos_prod_sum_le:
  fixes c :: "'a::linordered_field"
  assumes "c > 0"
  shows "c * x + t \<le> 0 \<equiv> x \<le> (- 1 / c) * t"
proof -
  have "c * x + t \<le> 0 \<longleftrightarrow> c * x \<le> - t"
    by (subst le_iff_diff_le_0 [of "c*x" "-t"]) simp
  also have "\<dots> \<longleftrightarrow> - t / c \<ge> x"
    by (simp only: pos_le_divide_eq[OF \<open>c > 0\<close>] algebra_simps)
  also have "\<dots> \<longleftrightarrow> (- 1 / c) * t \<ge> x" by simp
  finally show "PROP ?thesis" by simp
qed

lemma sum_le:
  fixes x :: "'a::ordered_ab_group_add"
  shows "x + t \<le> 0 \<equiv> x \<le> - t"
  using le_diff_eq[where a= x and b=t and c=0] by simp

lemma nz_prod_eq:
  fixes c :: "'a::linordered_field"
  assumes "c \<noteq> 0"
  shows "c * x = 0 \<equiv> x = 0"
  using assms by simp

lemma nz_prod_sum_eq:
  fixes c :: "'a::linordered_field"
  assumes "c \<noteq> 0"
  shows "c * x + t = 0 \<equiv> x = (- 1/c) * t"
proof -
  have "c * x + t = 0 \<longleftrightarrow> c * x = - t"
    by (subst eq_iff_diff_eq_0 [of "c*x" "-t"]) simp
  also have "\<dots> \<longleftrightarrow> x = - t / c"
    by (simp only: nonzero_eq_divide_eq[OF \<open>c \<noteq> 0\<close>] algebra_simps)
  finally show "PROP ?thesis" by simp
qed

lemma sum_eq:
  fixes x :: "'a::ordered_ab_group_add"
  shows "x + t = 0 \<equiv> x = - t"
  using eq_diff_eq[where a= x and b=t and c=0] by simp

interpretation class_dense_linordered_field: constr_dense_linorder
  "op \<le>" "op <" "\<lambda>x y. 1/2 * ((x::'a::linordered_field) + y)"
  by unfold_locales (dlo, dlo, auto)

declaration \<open>
let
  fun earlier [] x y = false
    | earlier (h::t) x y =
        if h aconvc y then false else if h aconvc x then true else earlier t x y;

fun dest_frac ct =
  case Thm.term_of ct of
    Const (@{const_name Rings.divide},_) $ a $ b=>
      Rat.make (snd (HOLogic.dest_number a), snd (HOLogic.dest_number b))
  | Const(@{const_name inverse}, _)$a => Rat.make(1, HOLogic.dest_number a |> snd)
  | t => Rat.of_int (snd (HOLogic.dest_number t))

fun whatis x ct = case Thm.term_of ct of
  Const(@{const_name Groups.plus}, _)$(Const(@{const_name Groups.times},_)$_$y)$_ =>
     if y aconv Thm.term_of x then ("c*x+t",[(funpow 2 Thm.dest_arg1) ct, Thm.dest_arg ct])
     else ("Nox",[])
| Const(@{const_name Groups.plus}, _)$y$_ =>
     if y aconv Thm.term_of x then ("x+t",[Thm.dest_arg ct])
     else ("Nox",[])
| Const(@{const_name Groups.times}, _)$_$y =>
     if y aconv Thm.term_of x then ("c*x",[Thm.dest_arg1 ct])
     else ("Nox",[])
| t => if t aconv Thm.term_of x then ("x",[]) else ("Nox",[]);

fun xnormalize_conv ctxt [] ct = Thm.reflexive ct
| xnormalize_conv ctxt (vs as (x::_)) ct =
   case Thm.term_of ct of
   Const(@{const_name Orderings.less},_)$_$Const(@{const_name Groups.zero},_) =>
    (case whatis x (Thm.dest_arg1 ct) of
    ("c*x+t",[c,t]) =>
       let
        val cr = dest_frac c
        val clt = Thm.dest_fun2 ct
        val cz = Thm.dest_arg ct
        val neg = cr < @0
        val cthp = Simplifier.rewrite ctxt
               (Thm.apply @{cterm "Trueprop"}
                  (if neg then Thm.apply (Thm.apply clt c) cz
                    else Thm.apply (Thm.apply clt cz) c))
        val cth = Thm.equal_elim (Thm.symmetric cthp) TrueI
        val th = Thm.implies_elim (Thm.instantiate' [SOME (Thm.ctyp_of_cterm x)] (map SOME [c,x,t])
             (if neg then @{thm neg_prod_sum_lt} else @{thm pos_prod_sum_lt})) cth
        val rth = Conv.fconv_rule (Conv.arg_conv (Conv.binop_conv
                   (Semiring_Normalizer.semiring_normalize_ord_conv ctxt (earlier vs)))) th
      in rth end
    | ("x+t",[t]) =>
       let
        val T = Thm.ctyp_of_cterm x
        val th = Thm.instantiate' [SOME T] [SOME x, SOME t] @{thm "sum_lt"}
        val rth = Conv.fconv_rule (Conv.arg_conv (Conv.binop_conv
              (Semiring_Normalizer.semiring_normalize_ord_conv ctxt (earlier vs)))) th
       in  rth end
    | ("c*x",[c]) =>
       let
        val cr = dest_frac c
        val clt = Thm.dest_fun2 ct
        val cz = Thm.dest_arg ct
        val neg = cr < @0
        val cthp = Simplifier.rewrite ctxt
               (Thm.apply @{cterm "Trueprop"}
                  (if neg then Thm.apply (Thm.apply clt c) cz
                    else Thm.apply (Thm.apply clt cz) c))
        val cth = Thm.equal_elim (Thm.symmetric cthp) TrueI
        val th = Thm.implies_elim (Thm.instantiate' [SOME (Thm.ctyp_of_cterm x)] (map SOME [c,x])
             (if neg then @{thm neg_prod_lt} else @{thm pos_prod_lt})) cth
        val rth = th
      in rth end
    | _ => Thm.reflexive ct)

|  Const(@{const_name Orderings.less_eq},_)$_$Const(@{const_name Groups.zero},_) =>
   (case whatis x (Thm.dest_arg1 ct) of
    ("c*x+t",[c,t]) =>
       let
        val T = Thm.typ_of_cterm x
        val cT = Thm.ctyp_of_cterm x
        val cr = dest_frac c
        val clt = Thm.cterm_of ctxt (Const (@{const_name ord_class.less}, T --> T --> @{typ bool}))
        val cz = Thm.dest_arg ct
        val neg = cr < @0
        val cthp = Simplifier.rewrite ctxt
               (Thm.apply @{cterm "Trueprop"}
                  (if neg then Thm.apply (Thm.apply clt c) cz
                    else Thm.apply (Thm.apply clt cz) c))
        val cth = Thm.equal_elim (Thm.symmetric cthp) TrueI
        val th = Thm.implies_elim (Thm.instantiate' [SOME cT] (map SOME [c,x,t])
             (if neg then @{thm neg_prod_sum_le} else @{thm pos_prod_sum_le})) cth
        val rth = Conv.fconv_rule (Conv.arg_conv (Conv.binop_conv
                   (Semiring_Normalizer.semiring_normalize_ord_conv ctxt (earlier vs)))) th
      in rth end
    | ("x+t",[t]) =>
       let
        val T = Thm.ctyp_of_cterm x
        val th = Thm.instantiate' [SOME T] [SOME x, SOME t] @{thm "sum_le"}
        val rth = Conv.fconv_rule (Conv.arg_conv (Conv.binop_conv
              (Semiring_Normalizer.semiring_normalize_ord_conv ctxt (earlier vs)))) th
       in  rth end
    | ("c*x",[c]) =>
       let
        val T = Thm.typ_of_cterm x
        val cT = Thm.ctyp_of_cterm x
        val cr = dest_frac c
        val clt = Thm.cterm_of ctxt (Const (@{const_name ord_class.less}, T --> T --> @{typ bool}))
        val cz = Thm.dest_arg ct
        val neg = cr < @0
        val cthp = Simplifier.rewrite ctxt
               (Thm.apply @{cterm "Trueprop"}
                  (if neg then Thm.apply (Thm.apply clt c) cz
                    else Thm.apply (Thm.apply clt cz) c))
        val cth = Thm.equal_elim (Thm.symmetric cthp) TrueI
        val th = Thm.implies_elim (Thm.instantiate' [SOME (Thm.ctyp_of_cterm x)] (map SOME [c,x])
             (if neg then @{thm neg_prod_le} else @{thm pos_prod_le})) cth
        val rth = th
      in rth end
    | _ => Thm.reflexive ct)

|  Const(@{const_name HOL.eq},_)$_$Const(@{const_name Groups.zero},_) =>
   (case whatis x (Thm.dest_arg1 ct) of
    ("c*x+t",[c,t]) =>
       let
        val T = Thm.ctyp_of_cterm x
        val cr = dest_frac c
        val ceq = Thm.dest_fun2 ct
        val cz = Thm.dest_arg ct
        val cthp = Simplifier.rewrite ctxt
            (Thm.apply @{cterm "Trueprop"}
             (Thm.apply @{cterm "Not"} (Thm.apply (Thm.apply ceq c) cz)))
        val cth = Thm.equal_elim (Thm.symmetric cthp) TrueI
        val th = Thm.implies_elim
                 (Thm.instantiate' [SOME T] (map SOME [c,x,t]) @{thm nz_prod_sum_eq}) cth
        val rth = Conv.fconv_rule (Conv.arg_conv (Conv.binop_conv
                   (Semiring_Normalizer.semiring_normalize_ord_conv ctxt (earlier vs)))) th
      in rth end
    | ("x+t",[t]) =>
       let
        val T = Thm.ctyp_of_cterm x
        val th = Thm.instantiate' [SOME T] [SOME x, SOME t] @{thm "sum_eq"}
        val rth = Conv.fconv_rule (Conv.arg_conv (Conv.binop_conv
              (Semiring_Normalizer.semiring_normalize_ord_conv ctxt (earlier vs)))) th
       in  rth end
    | ("c*x",[c]) =>
       let
        val T = Thm.ctyp_of_cterm x
        val cr = dest_frac c
        val ceq = Thm.dest_fun2 ct
        val cz = Thm.dest_arg ct
        val cthp = Simplifier.rewrite ctxt
            (Thm.apply @{cterm "Trueprop"}
             (Thm.apply @{cterm "Not"} (Thm.apply (Thm.apply ceq c) cz)))
        val cth = Thm.equal_elim (Thm.symmetric cthp) TrueI
        val rth = Thm.implies_elim
                 (Thm.instantiate' [SOME T] (map SOME [c,x]) @{thm nz_prod_eq}) cth
      in rth end
    | _ => Thm.reflexive ct);

local
  val less_iff_diff_less_0 = mk_meta_eq @{thm "less_iff_diff_less_0"}
  val le_iff_diff_le_0 = mk_meta_eq @{thm "le_iff_diff_le_0"}
  val eq_iff_diff_eq_0 = mk_meta_eq @{thm "eq_iff_diff_eq_0"}
  val ss = simpset_of @{context}
in
fun field_isolate_conv phi ctxt vs ct = case Thm.term_of ct of
  Const(@{const_name Orderings.less},_)$a$b =>
   let val (ca,cb) = Thm.dest_binop ct
       val T = Thm.ctyp_of_cterm ca
       val th = Thm.instantiate' [SOME T] [SOME ca, SOME cb] less_iff_diff_less_0
       val nth = Conv.fconv_rule
         (Conv.arg_conv (Conv.arg1_conv
              (Semiring_Normalizer.semiring_normalize_ord_conv (put_simpset ss ctxt) (earlier vs)))) th
       val rth = Thm.transitive nth (xnormalize_conv ctxt vs (Thm.rhs_of nth))
   in rth end
| Const(@{const_name Orderings.less_eq},_)$a$b =>
   let val (ca,cb) = Thm.dest_binop ct
       val T = Thm.ctyp_of_cterm ca
       val th = Thm.instantiate' [SOME T] [SOME ca, SOME cb] le_iff_diff_le_0
       val nth = Conv.fconv_rule
         (Conv.arg_conv (Conv.arg1_conv
              (Semiring_Normalizer.semiring_normalize_ord_conv (put_simpset ss ctxt) (earlier vs)))) th
       val rth = Thm.transitive nth (xnormalize_conv ctxt vs (Thm.rhs_of nth))
   in rth end

| Const(@{const_name HOL.eq},_)$a$b =>
   let val (ca,cb) = Thm.dest_binop ct
       val T = Thm.ctyp_of_cterm ca
       val th = Thm.instantiate' [SOME T] [SOME ca, SOME cb] eq_iff_diff_eq_0
       val nth = Conv.fconv_rule
         (Conv.arg_conv (Conv.arg1_conv
              (Semiring_Normalizer.semiring_normalize_ord_conv (put_simpset ss ctxt) (earlier vs)))) th
       val rth = Thm.transitive nth (xnormalize_conv ctxt vs (Thm.rhs_of nth))
   in rth end
| @{term "Not"} $(Const(@{const_name HOL.eq},_)$a$b) => Conv.arg_conv (field_isolate_conv phi ctxt vs) ct
| _ => Thm.reflexive ct
end;

fun classfield_whatis phi =
 let
  fun h x t =
   case Thm.term_of t of
     Const(@{const_name HOL.eq}, _)$y$z =>
      if Thm.term_of x aconv y then Ferrante_Rackoff_Data.Eq
      else Ferrante_Rackoff_Data.Nox
   | @{term "Not"}$(Const(@{const_name HOL.eq}, _)$y$z) =>
      if Thm.term_of x aconv y then Ferrante_Rackoff_Data.NEq
      else Ferrante_Rackoff_Data.Nox
   | Const(@{const_name Orderings.less},_)$y$z =>
       if Thm.term_of x aconv y then Ferrante_Rackoff_Data.Lt
       else if Thm.term_of x aconv z then Ferrante_Rackoff_Data.Gt
       else Ferrante_Rackoff_Data.Nox
   | Const (@{const_name Orderings.less_eq},_)$y$z =>
       if Thm.term_of x aconv y then Ferrante_Rackoff_Data.Le
       else if Thm.term_of x aconv z then Ferrante_Rackoff_Data.Ge
       else Ferrante_Rackoff_Data.Nox
   | _ => Ferrante_Rackoff_Data.Nox
 in h end;
fun class_field_ss phi ctxt =
  simpset_of (put_simpset HOL_basic_ss ctxt
    addsimps ([@{thm "linorder_not_less"}, @{thm "linorder_not_le"}])
    |> fold Splitter.add_split [@{thm "abs_split"}, @{thm "split_max"}, @{thm "split_min"}])

in
Ferrante_Rackoff_Data.funs @{thm "class_dense_linordered_field.ferrack_axiom"}
  {isolate_conv = field_isolate_conv, whatis = classfield_whatis, simpset = class_field_ss}
end
\<close>

end


(*<*)
(*
 * Domains of natural numbers.
 * (C)opyright 2009-2011, Peter Gammie, peteg42 at gmail.com.
 * License: BSD
 *)

theory Nats
imports HOLCF
begin
(*>*)

section{* Boxed Types, HOL's natural numbers hoisted. *}

subsection{* Unboxed naturals. *}

text{* We can represent the unboxed naturals as a discrete domain (every
number is equal to itself and unequal to everything else, and there is no
bottom). Think of these functions as the machine operations.

We could actually lift all HOL types and classes in this way; indeed
the HOLCF theory "Lift" does something similar, but is not as
fine-grained as this development.

Note: we default to just CPOs (not pointed CPOs) in this theory. We
adopt bothg the Isabelle syntax for overloaded arithmetic and the
notation for unboxed operators of \citet{SPJ-JL:1991}. *}

default_sort predomain

type_synonym UNat = "nat discr"

instantiation discr :: (zero) zero
begin
definition zero_discr_def: "0 \<equiv> Discr 0"
instance ..
end

lemma zero_discr[simp]: "undiscr 0 = 0" unfolding zero_discr_def by simp

instantiation discr :: (one) one
begin
definition one_discr_def: "1 \<equiv> Discr 1"
instance ..
end

lemma one_discr[simp]: "undiscr 1 = 1" unfolding one_discr_def by simp

instantiation discr :: (ord) ord
begin
definition less_def[simp]: "m < n \<equiv> (undiscr m) < (undiscr n)"
definition le_def[simp]:   "m \<le> n \<equiv> (undiscr m) \<le> (undiscr n)"
instance ..
end

definition
  uPlus :: "UNat \<rightarrow> UNat \<rightarrow> UNat" where
  "uPlus \<equiv> \<Lambda> x y. Discr (undiscr x + undiscr y)"

abbreviation
  uPlus_syn :: "UNat \<Rightarrow> UNat \<Rightarrow> UNat" (infixl "+\<^sub>#" 65) where
  "x +\<^sub># y \<equiv> uPlus\<cdot>x\<cdot>y"

instantiation discr :: (plus) plus
begin
definition plus_discr_def[simp]: "x + y \<equiv> Discr (undiscr x + undiscr y)"
instance ..
end

definition
  uMinus :: "UNat \<rightarrow> UNat \<rightarrow> UNat" where
  "uMinus \<equiv> \<Lambda> x y. Discr (undiscr x - undiscr y)"

abbreviation
  uMinus_syn :: "UNat \<Rightarrow> UNat \<Rightarrow> UNat" (infixl "-\<^sub>#" 65) where
  "x -\<^sub># y \<equiv> uMinus\<cdot>x\<cdot>y"

instantiation discr :: (minus) minus
begin
definition minus_discr_def[simp]: "x - y \<equiv> Discr (undiscr x - undiscr y)"
instance ..
end

definition
  uMult :: "UNat \<rightarrow> UNat \<rightarrow> UNat" where
  "uMult \<equiv> \<Lambda> x y. Discr (undiscr x * undiscr y)"

abbreviation
  uMult_syn :: "UNat \<Rightarrow> UNat \<Rightarrow> UNat" (infixl "*\<^sub>#" 65) where
  "x *\<^sub># y \<equiv> uMult\<cdot>x\<cdot>y"

instantiation discr :: (times) times
begin
definition times_discr_def[simp]: "x * y \<equiv> Discr (undiscr x * undiscr y)"
instance ..
end

lemma uMult_unit_left: "1 *\<^sub># (x::UNat) = x"
  unfolding uMult_def one_discr_def by simp
lemma uMult_unit_right: "(x::UNat) *\<^sub># 1 = x"
  unfolding uMult_def one_discr_def by simp

lemma uMult_assoc: "(x *\<^sub># y) *\<^sub># z = x *\<^sub># (y *\<^sub># z)"
  unfolding uMult_def by simp

lemma uMult_commute: "x *\<^sub># y = y *\<^sub># x"
  unfolding uMult_def by simp

lemma uMult_left_commute: "a *\<^sub># (b *\<^sub># c) = b *\<^sub># (a *\<^sub># c)"
  unfolding uMult_def by simp

lemmas uMult_arithmetic =
  uMult_unit_left uMult_unit_right uMult_assoc uMult_commute uMult_left_commute

subsection {* The "@{term \<bottom>}" monad. *}

text{*

As Brian Huffman helpfully observed, the "@{term "\<bottom>"}" type
constructor supports the monadic operations; it's isomorphic to
Haskell's @{term "Maybe a"}, or ML's @{typ "'a option"}.

Note that @{term "return"} is @{term "up"}.

*}

definition
  bbind :: "('a::cpo)\<^sub>\<bottom> \<rightarrow> ('a \<rightarrow> ('b::pcpo)) \<rightarrow> 'b" where
  "bbind \<equiv> \<Lambda> b g. fup\<cdot>g\<cdot>b"

abbreviation
  bbind_syn :: "('a::cpo)\<^sub>\<bottom> \<Rightarrow> ('a \<rightarrow> ('b::pcpo)) \<Rightarrow> 'b" (infixl ">>=" 65) where
  "b >>= g \<equiv> bbind\<cdot>b\<cdot>g"

lemma bbind_strict1[simp]: "bbind\<cdot>\<bottom> = \<bottom>"
  by (simp add: bbind_def)
lemma bbind_strict2[simp]: "x >>= \<bottom> = \<bottom>"
  by (cases x, simp_all add: bbind_def)

lemma bbind_leftID[simp]: "up\<cdot>a >>= f = f\<cdot>a" by (simp add: bbind_def)
lemma bbind_rightID[simp]: "m >>= up = m" by (cases m, simp_all)

lemma bbind_assoc[simp]: "f >>= g >>= h = f >>= (\<Lambda> x. g\<cdot>x >>= h)"
  by (cases f, simp_all)

lemma bbind_case_distr_strict: "f\<cdot>\<bottom> = \<bottom> \<Longrightarrow> f\<cdot>(g >>= h) = g >>= (\<Lambda> x. f\<cdot>(h\<cdot>x))"
  unfolding bbind_def by (cases g, simp_all)

text{*

Kleisli composition is sometimes helpful. It forms a monad too,
and has many useful algebraic properties. Unfortunately it is more
work than is useful to write the lemmas in a way that makes the
higher-order unifier in the simplifier happy. Seems easier just to
unfold the definition and go from there.

*}

definition
  bKleisli :: "('a::cpo \<rightarrow> ('b::cpo)\<^sub>\<bottom>) \<rightarrow> ('b \<rightarrow> ('c::cpo)\<^sub>\<bottom>) \<rightarrow> ('a \<rightarrow> 'c\<^sub>\<bottom>)" where
  "bKleisli \<equiv> \<Lambda> f g x. f\<cdot>x >>= g"

abbreviation
  bKleisli_syn :: "('a::cpo \<rightarrow> ('b::cpo)\<^sub>\<bottom>) \<Rightarrow> ('b \<rightarrow> ('c::cpo)\<^sub>\<bottom>) \<Rightarrow> ('a \<rightarrow> 'c\<^sub>\<bottom>)" (infixl ">=>" 65) where
  "b >=> g \<equiv> bKleisli\<cdot>b\<cdot>g"

lemma bKleisli_strict1[simp]: "bKleisli\<cdot>\<bottom> = \<bottom>"
  by (simp add: bKleisli_def)
lemma bKleisli_strict2[simp]: "b >=> \<bottom> = \<bottom>"
  by (rule cfun_eqI, simp add: bKleisli_def)

lemma bKleisli_bbind: "(f >>= g) >=> h = f >>= (\<Lambda> x. g\<cdot>x >=> h)"
  by (cases f, simp_all)

text {*

The "Box" type denotes computations that, when demanded, yield
either @{term "\<bottom>"} or an unboxed value. Note that the @{term "Box"}
constructor is strict, and so merely tags the lifted computation @{typ
"'a\<^sub>\<bottom>"}. @{typ "'a"} can be pointed or unpointed. This approach enables
us to distinguish the boxed values from the lifted-function-space that
models recursive functions with unboxed codomains.

*}

domain 'a Box = Box (unbox :: "'a\<^sub>\<bottom>")

definition
  box :: "('a::predomain) \<rightarrow> 'a Box" where
  "box \<equiv> Box oo up"

lemma boxI: "Box\<cdot>(up\<cdot>x) = box\<cdot>x" unfolding box_def by simp
lemma unbox_box[simp]: "unbox\<cdot>(box\<cdot>x) = up\<cdot>x" unfolding box_def by simp
lemma unbox_Box[simp]: "x \<noteq> \<bottom> \<Longrightarrow> unbox\<cdot>(Box\<cdot>x) = x" by simp

text{*

If we suceed in @{term "box"}ing something, then clearly that
something was not @{term "\<bottom>"}.

*}

lemma box_casedist[case_names bottom Box, cases type: Box]:
  assumes xbot: "x = \<bottom> \<Longrightarrow> P"
      and xbox: "\<And>u. x = box\<cdot>u \<Longrightarrow> P"
  shows "P"
proof(cases x)
  case bottom with xbot show ?thesis by simp
next
  case (Box u) with xbox show ?thesis
    by (cases u, simp_all add: box_def up_def cont_Iup bottomI[OF minimal_up])
qed

lemma bbind_leftID'[simp]: "unbox\<cdot>a >>= box = a" by (cases a, simp_all add: bbind_def)

(*<*)
text {*

The optimisations of \citet{SPJ-JL:1991}.

p11: Repeated unboxing of the same value can be done once (roughly:
store the value in a register). Their story is more general.

*}

lemma box_repeated:
  "x >>= (\<Lambda> x'. f >>= (\<Lambda> y'. x >>= body\<cdot>x'\<cdot>y'))
  = x >>= (\<Lambda> x'. f >>= (\<Lambda> y'. body\<cdot>x'\<cdot>y'\<cdot>x'))"
  by (cases x, simp_all)
(*>*)

text{* Lift binary predicates over @{typ "'a discr"} into @{typ "'a discr Box"}. *}

text {* @{term "bliftM"} and @{term "bliftM2"} encapsulate the boxing
and unboxing. *}

definition
  bliftM :: "('a::predomain \<rightarrow> 'b::predomain) \<Rightarrow> 'a Box \<rightarrow> 'b Box" where
  "bliftM f \<equiv> \<Lambda> x. unbox\<cdot>x >>= (\<Lambda> x'. box\<cdot>(f\<cdot>x'))"

lemma bliftM_strict1[simp]: "bliftM f\<cdot>\<bottom> = \<bottom>" by (simp add: bliftM_def)
lemma bliftM_op[simp]: "bliftM f\<cdot>(box\<cdot>x) = box\<cdot>(f\<cdot>x)" by (simp add: bliftM_def)

definition
  bliftM2 :: "('a::predomain \<rightarrow> 'b::predomain \<rightarrow> 'c::predomain) \<Rightarrow> 'a Box \<rightarrow> 'b Box \<rightarrow> 'c Box" where
  "bliftM2 f \<equiv> \<Lambda> x y. unbox\<cdot>x >>= (\<Lambda> x'. unbox\<cdot>y >>= (\<Lambda> y'. box\<cdot>(f\<cdot>x'\<cdot>y')))"

lemma bliftM2_strict1[simp]: "bliftM2 f\<cdot>\<bottom> = \<bottom>" by (rule cfun_eqI)+ (simp add: bliftM2_def)
lemma bliftM2_strict2[simp]: "bliftM2 f\<cdot>x\<cdot>\<bottom> = \<bottom>" by (cases x, simp_all add: bliftM2_def)
lemma bliftM2_op[simp]: "bliftM2 f\<cdot>(box\<cdot>x)\<cdot>(box\<cdot>y) = box\<cdot>(f\<cdot>x\<cdot>y)" by (simp add: bliftM2_def)

text{*

Define the arithmetic operations. We need extra continuity lemmas as
we're using the full function space, so we can re-use the conventional
operators. The goal is to work at this level.

*}

instantiation Box :: ("{predomain,plus}") plus
begin
definition plus_Box_def: "x + y \<equiv> bliftM2 (\<Lambda> a b. a + b)\<cdot>x\<cdot>y"
instance ..
end

lemma plus_Box_cont[simp, cont2cont]:
  "\<lbrakk>cont g; cont h\<rbrakk> \<Longrightarrow> cont (\<lambda>x. (g x :: 'a :: {predomain, plus} Box) + h x)"
  unfolding plus_Box_def by simp

lemma plus_Box_strict1[simp]: "\<bottom> + (y :: 'a::{predomain, plus} Box) = \<bottom>"
  unfolding plus_Box_def by simp
lemma plus_Box_strict2[simp]: "(x :: 'a::{predomain, plus} Box) + \<bottom> = \<bottom>"
  unfolding plus_Box_def by simp

instantiation Box :: ("{predomain,minus}") minus
begin
definition minus_Box_def: "x - y \<equiv> bliftM2 (\<Lambda> a b. a - b)\<cdot>x\<cdot>y"
instance ..
end

lemma minus_Box_cont[simp, cont2cont]:
  "\<lbrakk>cont g; cont h\<rbrakk> \<Longrightarrow> cont (\<lambda>x. (g x :: 'a :: {predomain, minus} Box) - h x)"
  unfolding minus_Box_def by simp

lemma minus_Box_strict1[simp]: "\<bottom> - (y :: 'a::{predomain, minus} Box) = \<bottom>"
  unfolding minus_Box_def by simp
lemma minus_Box_strict2[simp]: "(x :: 'a::{predomain, minus} Box) - \<bottom> = \<bottom>"
  unfolding minus_Box_def by simp

instantiation Box :: ("{predomain,times}") times
begin
definition times_Box_def: "x * y \<equiv> bliftM2 (\<Lambda> a b. a * b)\<cdot>x\<cdot>y"
instance ..
end

lemma times_Box_cont[simp, cont2cont]:
  "\<lbrakk>cont g; cont h\<rbrakk> \<Longrightarrow> cont (\<lambda>x. (g x :: 'a :: {predomain, times} Box) * h x)"
  unfolding times_Box_def by simp

lemma times_Box_strict1[simp]: "\<bottom> * (y :: 'a::{predomain, times} Box) = \<bottom>"
  unfolding times_Box_def by simp
lemma times_Box_strict2[simp]: "(x :: 'a::{predomain, times} Box) * \<bottom> = \<bottom>"
  unfolding times_Box_def by simp

definition
  bpred :: "('a::countable discr \<Rightarrow> 'a discr \<Rightarrow> bool) \<Rightarrow> 'a discr Box \<rightarrow> 'a discr Box \<rightarrow> tr" where
  "bpred p \<equiv> \<Lambda> x y. unbox\<cdot>x >>= (\<Lambda> x'. unbox\<cdot>y >>= (\<Lambda> y'. if p x' y' then TT else FF))"

lemma bpred_strict1[simp]: "bpred p\<cdot>\<bottom> = \<bottom>" unfolding bpred_def by (rule cfun_eqI, simp)
lemma bpred_strict2[simp]: "bpred p\<cdot>x\<cdot>\<bottom> = \<bottom>" unfolding bpred_def by (cases x, simp_all)

lemma bpred_eval[simp]: "bpred p\<cdot>(box\<cdot>x)\<cdot>(box\<cdot>y) = (if p x y then TT else FF)"
  unfolding bpred_def by simp

abbreviation
  beq_syn :: "'a::countable discr Box \<Rightarrow> 'a discr Box \<Rightarrow> tr" (infix "=\<^sub>B" 50) where
  "x =\<^sub>B y \<equiv> bpred (op =)\<cdot>x\<cdot>y"

abbreviation
  ble_syn :: "'a::{countable,ord} discr Box \<Rightarrow> 'a discr Box \<Rightarrow> tr" (infix "\<le>\<^sub>B" 50) where
  "x \<le>\<^sub>B y \<equiv> bpred (op \<le>)\<cdot>x\<cdot>y"

abbreviation
  blt_syn :: "'a::{countable,ord} discr Box \<Rightarrow> 'a discr Box \<Rightarrow> tr" (infix "<\<^sub>B" 50) where
  "x <\<^sub>B y \<equiv> bpred (op <)\<cdot>x\<cdot>y"

subsection{* The flat domain of natural numbers *}

text{* Lift arithmetic to the boxed naturals. Define some things that make
playing with boxed naturals more convenient. *}

type_synonym Nat = "UNat Box"

instantiation Box :: ("{predomain, zero}") zero
begin
definition zero_Nat_def: "0 \<equiv> box\<cdot>0"
instance ..
end

instantiation Box :: ("{predomain, one}") one
begin
definition one_Nat_def: "1 \<equiv> box\<cdot>1"
instance ..
end

text {* We need to know the underlying operations are continuous for these to work. *}

lemma plus_Nat_eval[simp]: "(box\<cdot>x :: Nat) + box\<cdot>y = box\<cdot>(x + y)" unfolding plus_Box_def by simp
lemma minus_Nat_eval[simp]: "(box\<cdot>x :: Nat) - box\<cdot>y = box\<cdot>(x - y)" unfolding minus_Box_def by simp
lemma times_Nat_eval[simp]: "(box\<cdot>x :: Nat) * box\<cdot>y = box\<cdot>(x * y)" unfolding times_Box_def by simp

definition
  Nat_case :: "'a::domain \<rightarrow> (Nat \<rightarrow> 'a) \<rightarrow> Nat \<rightarrow> 'a" where
  "Nat_case \<equiv> \<Lambda> z s n. unbox\<cdot>n >>= (\<Lambda> n'. case_nat z (\<lambda>n''. s\<cdot>(box\<cdot>(Discr n''))) (undiscr n'))"

lemma cont_case_nat[simp]:
  "\<lbrakk>cont (\<lambda>x. f x); \<And>n. cont (\<lambda>x. g x n) \<rbrakk> \<Longrightarrow> cont (\<lambda>x. case_nat (f x) (g x) n)"
  by (cases n, simp_all)

lemma Nat_case_strict[simp]: "Nat_case\<cdot>z\<cdot>s\<cdot>\<bottom> = \<bottom>" by (simp add: Nat_case_def)
lemma Nat_case_zero[simp]: "Nat_case\<cdot>z\<cdot>s\<cdot>0 = z" by (simp add: Nat_case_def zero_Nat_def zero_discr_def)

lemma Nat_case_add_1[simp]:
  assumes ndef: "n \<noteq> \<bottom>"
  shows "Nat_case\<cdot>z\<cdot>s\<cdot>(n + 1) = s\<cdot>n"
proof -
  from ndef obtain nu where nu: "n = box\<cdot>nu"
    unfolding box_def
    apply (cases "n" rule: Box.exhaust)
    apply simp
    apply (case_tac "u")
    apply simp_all
    done
  then obtain u where "nu = Discr u"
    unfolding box_def
    apply (cases nu)
    apply simp
    done
  with nu show ?thesis unfolding one_Nat_def by simp
qed

lemma Nat_case_case_nat: "Nat_case\<cdot>z\<cdot>s\<cdot>(box\<cdot>(Discr n)) = case_nat z (\<lambda>n'. s\<cdot>(box\<cdot>(Discr n'))) n"
  by (simp add: Nat_case_def)

lemma Nat_casedist[case_names bottom zero Suc]:
  fixes x :: Nat
  assumes xbot: "x = \<bottom> \<Longrightarrow> P"
      and xzero: "x = 0 \<Longrightarrow> P"
      and xsuc: "\<And>n. x = n + 1 \<Longrightarrow> P"
  shows "P"
proof(cases x rule: Box.exhaust)
  case bottom with xbot show ?thesis by simp
next
  case (Box u) hence xu: "x = Box\<cdot>u" and ubottom: "u \<noteq> \<bottom>" .
  from ubottom obtain n where ndn: "u = up\<cdot>(Discr n)" apply (cases u) apply simp_all apply (case_tac x) apply simp done
  show ?thesis
  proof(cases n)
    case 0 with ndn xu xzero show ?thesis unfolding zero_Nat_def by (simp add: boxI zero_discr_def)
  next
    case (Suc m) with ndn xu xsuc[where n="box\<cdot>(Discr m)"]
    show ?thesis
      unfolding plus_Box_def unfolding one_Nat_def by (simp add: boxI one_discr_def)
  qed
qed

lemma cont_Nat_case[simp]:
  "\<lbrakk>cont (\<lambda>x. f x); \<And>n. cont (\<lambda>x. g x\<cdot>n) \<rbrakk> \<Longrightarrow> cont (\<lambda>x. Nat_case\<cdot>(f x)\<cdot>(g x)\<cdot>n)"
  apply (cases n rule: Nat_casedist)
    apply simp_all
  apply (case_tac na rule: Box.exhaust)
   apply simp_all
  done

lemma Nat_induct[case_names bottom zero Suc]:
  fixes P :: "Nat \<Rightarrow> bool"
  assumes xbot: "P \<bottom>"
      and xzero: "P 0"
      and xsuc: "\<And>n. \<lbrakk>n \<noteq> \<bottom>; P n \<rbrakk> \<Longrightarrow> P (n + 1)"
  shows "P x"
proof(cases x rule: box_casedist)
  case bottom with xbot show ?thesis by simp
next
  case (Box u)
  then obtain n where un: "u = Discr n" by (cases u, simp)
  {
    fix n
    have "\<And>x. x = box\<cdot>(Discr n) \<Longrightarrow> P x"
    proof(induct n)
      case 0 with xzero show ?case unfolding zero_Nat_def zero_discr_def by simp
    next
      case (Suc n)
      hence "P (box\<cdot>(Discr n))" by simp
      with xsuc[where n="box\<cdot>(Discr n)"] have "P (box\<cdot>(Discr n) + 1)" unfolding box_def by simp
      with Suc show ?case unfolding one_Nat_def one_discr_def plus_Box_def by simp
    qed
  }
  with un Box show ?thesis by simp
qed

lemma plus_commute: "(x :: Nat) + y = y + x"
proof -
  have dc: "\<And>u v. (undiscr (u::nat discr) + undiscr v) = (undiscr v + undiscr u)"
    by simp
  thus ?thesis
    apply (cases x)
     apply simp
    apply (cases y)
    by (simp_all add: dc plus_Box_def)
qed

lemma mult_unit: "(x::Nat) * 1 = x"
  unfolding times_Box_def one_Nat_def by (cases x, simp_all)

lemma mult_commute: "(x :: Nat) * y = y * x"
proof -
  have dc: "\<And>u v. (undiscr (u::nat discr) * undiscr v) = (undiscr v * undiscr u)"
    by simp
  show ?thesis
    apply (cases x)
     apply simp
    apply (cases y)
    by (simp_all add: dc)
qed

lemma mult_assoc: "((x :: Nat) * y) * z = x * (y * z)"
proof -
  have ac: "\<And>u v w. undiscr (u::nat discr) * (undiscr v * undiscr w)
                   =  (undiscr u * undiscr v) * undiscr w" by simp
  show ?thesis
    apply (cases x)
     apply simp
    apply (cases y)
     apply simp
    apply (cases z)
     apply simp
    by (simp add: ac)
qed

text{* Restore the HOLCF default sort. *}

default_sort "domain"

(*<*)
end
(*>*)


(*  Title:      Jinja/Common/Basis.thy

    Author:     David von Oheimb, Tobias Nipkow
    Copyright   1999 TU Muenchen
*)

chapter \<open>Jinja Source Language \label{cha:j}\<close>

section \<open>Auxiliary Definitions\<close>

theory Auxiliary imports Main begin
(* FIXME move and possibly turn into a general simproc *)
lemma nat_add_max_le[simp]:
  "((n::nat) + max i j \<le> m) = (n + i \<le> m \<and> n + j \<le> m)"
 (*<*)by arith(*>*)

lemma Suc_add_max_le[simp]:
  "(Suc(n + max i j) \<le> m) = (Suc(n + i) \<le> m \<and> Suc(n + j) \<le> m)"
(*<*)by arith(*>*)

notation Some  ("(\<lfloor>_\<rfloor>)")

(*<*)
declare
 option.splits[split]
 Let_def[simp]
 subset_insertI2 [simp]
 Cons_eq_map_conv [iff]
(*>*)

subsection \<open>\<open>distinct_fst\<close>\<close>

definition distinct_fst  :: "('a \<times> 'b) list \<Rightarrow> bool"
where
  "distinct_fst  \<equiv>  distinct \<circ> map fst"

lemma distinct_fst_Nil [simp]:
  "distinct_fst []"
 (*<*)
by (unfold distinct_fst_def) (simp (no_asm))
(*>*)

lemma distinct_fst_Cons [simp]:
  "distinct_fst ((k,x)#kxs) = (distinct_fst kxs \<and> (\<forall>y. (k,y) \<notin> set kxs))"
(*<*)
by (unfold distinct_fst_def) (auto simp:image_def)
(*>*)
(*
lemma distinct_fst_append:
 "\<lbrakk> distinct_fst kxs'; distinct_fst kxs; \<forall>(k,x) \<in> set kxs. \<forall>(k',x') \<in> set kxs'. k' \<noteq> k \<rbrakk>
  \<Longrightarrow> distinct_fst(kxs @ kxs')"
by (induct kxs) (auto dest: fst_in_set_lemma)

lemma distinct_fst_map_inj:
  "\<lbrakk> distinct_fst kxs; inj f \<rbrakk> \<Longrightarrow> distinct_fst (map (\<lambda>(k,x). (f k, g k x)) kxs)"
by (induct kxs) (auto dest: fst_in_set_lemma simp: inj_eq)
*)

lemma map_of_SomeI:
  "\<lbrakk> distinct_fst kxs; (k,x) \<in> set kxs \<rbrakk> \<Longrightarrow> map_of kxs k = Some x"
(*<*)by (induct kxs) (auto simp:fun_upd_apply)(*>*)

subsection \<open>Using @{term list_all2} for relations\<close>

definition fun_of :: "('a \<times> 'b) set \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> bool"
where
  "fun_of S \<equiv> \<lambda>x y. (x,y) \<in> S"

text \<open>Convenience lemmas\<close>
(*<*)
declare fun_of_def [simp]
(*>*)
lemma rel_list_all2_Cons [iff]:
  "list_all2 (fun_of S) (x#xs) (y#ys) =
   ((x,y) \<in> S \<and> list_all2 (fun_of S) xs ys)"
  (*<*)by simp(*>*)

lemma rel_list_all2_Cons1:
  "list_all2 (fun_of S) (x#xs) ys =
  (\<exists>z zs. ys = z#zs \<and> (x,z) \<in> S \<and> list_all2 (fun_of S) xs zs)"
  (*<*)by (cases ys) auto(*>*)

lemma rel_list_all2_Cons2:
  "list_all2 (fun_of S) xs (y#ys) =
  (\<exists>z zs. xs = z#zs \<and> (z,y) \<in> S \<and> list_all2 (fun_of S) zs ys)"
  (*<*)by (cases xs) auto(*>*)

lemma rel_list_all2_refl:
  "(\<And>x. (x,x) \<in> S) \<Longrightarrow> list_all2 (fun_of S) xs xs"
  (*<*)by (simp add: list_all2_refl)(*>*)

lemma rel_list_all2_antisym:
  "\<lbrakk> (\<And>x y. \<lbrakk>(x,y) \<in> S; (y,x) \<in> T\<rbrakk> \<Longrightarrow> x = y);
     list_all2 (fun_of S) xs ys; list_all2 (fun_of T) ys xs \<rbrakk> \<Longrightarrow> xs = ys"
  (*<*)by (rule list_all2_antisym) auto(*>*)

lemma rel_list_all2_trans:
  "\<lbrakk> \<And>a b c. \<lbrakk>(a,b) \<in> R; (b,c) \<in> S\<rbrakk> \<Longrightarrow> (a,c) \<in> T;
    list_all2 (fun_of R) as bs; list_all2 (fun_of S) bs cs\<rbrakk>
  \<Longrightarrow> list_all2 (fun_of T) as cs"
  (*<*)by (rule list_all2_trans) auto(*>*)

lemma rel_list_all2_update_cong:
  "\<lbrakk> i<size xs; list_all2 (fun_of S) xs ys; (x,y) \<in> S \<rbrakk>
  \<Longrightarrow> list_all2 (fun_of S) (xs[i:=x]) (ys[i:=y])"
  (*<*)by (simp add: list_all2_update_cong)(*>*)

lemma rel_list_all2_nthD:
  "\<lbrakk> list_all2 (fun_of S) xs ys; p < size xs \<rbrakk> \<Longrightarrow> (xs!p,ys!p) \<in> S"
  (*<*)by (drule list_all2_nthD) auto(*>*)

lemma rel_list_all2I:
  "\<lbrakk> length a = length b; \<And>n. n < length a \<Longrightarrow> (a!n,b!n) \<in> S \<rbrakk> \<Longrightarrow> list_all2 (fun_of S) a b"
  (*<*)by (erule list_all2_all_nthI) simp(*>*)

(*<*)declare fun_of_def [simp del](*>*)

end


section \<open>Program statements, Hoare and refinement rules\<close>

theory Statements
imports Assertion_Algebra
begin

text \<open>In this section we introduce assume, if, and while program statements
as well as Hoare triples, and data refienment. We prove Hoare correctness
rules for the program statements and we prove some theorems linking Hoare
correctness statement to (data) refinement. Most of the theorems assume
a monotonic boolean transformers algebra. The theorem stating the
equivalence between a Hoare
correctness triple and a refinement statement holds under the
assumption that we have a monotonic boolean transformers algebra with
post condition statement.\<close>

definition
  "assume" :: "'a::mbt_algebra Assertion \<Rightarrow> 'a"  ("[\<cdot> _ ]" [0] 1000) where
  "[\<cdot>p] =  {\<cdot>p} ^ o"

lemma [simp]: "[\<cdot>p] * x \<squnion> {\<cdot>-p} * \<top> = [\<cdot>p] * x"
  by (simp add: assume_def  uminus_Assertion_def)

lemma [simp]: "{\<cdot>p} * \<top> \<squnion> [\<cdot>-p] * x = [\<cdot>-p] * x"
  by (simp add: assume_def  uminus_Assertion_def)

lemma assert_sup: "{\<cdot>p \<squnion> q} = {\<cdot>p} \<squnion> {\<cdot>q}"
  by (simp add: sup_Assertion_def)

lemma assert_inf: "{\<cdot>p \<sqinter> q} = {\<cdot>p} \<sqinter> {\<cdot>q}"
  by (simp add: inf_Assertion_def)

lemma assert_neg: "{\<cdot>-p} = neg_assert {\<cdot>p}"
  by (simp add: uminus_Assertion_def)

lemma assert_false [simp]: "{\<cdot>\<bottom>} = \<bottom>"
  by (simp add: bot_Assertion_def)

lemma if_Assertion_assumption: "({\<cdot>p} * x) \<squnion> ({\<cdot>-p} * y) = ([\<cdot>p] * x) \<sqinter> ([\<cdot>-p] * y)"
proof -
    have "({\<cdot>p} * x) \<squnion> {\<cdot>-p} * y = ({\<cdot>p} * \<top> \<sqinter> [\<cdot>p]) * x \<squnion> ({\<cdot>-p} * \<top> \<sqinter> [\<cdot>-p]) * y" by simp
    also have "\<dots> = ({\<cdot>p} * \<top> \<sqinter> ([\<cdot>p] * x)) \<squnion> ({\<cdot>-p} * \<top> \<sqinter> ([\<cdot>-p] * y))" by (unfold inf_comp, simp)
    also have "\<dots> = (({\<cdot>p} * \<top> \<sqinter> ([\<cdot>p] * x)) \<squnion> ({\<cdot>-p} * \<top>)) \<sqinter> (({\<cdot>p} * \<top> \<sqinter> ([\<cdot>p] * x)) \<squnion> ([\<cdot>-p] * y))" by (simp add: sup_inf_distrib)
    also have "\<dots> = (({\<cdot>p} * \<top>  \<squnion> ({\<cdot>-p} * \<top>)) \<sqinter> (([\<cdot>p] * x))) \<sqinter> (([\<cdot>-p] * y) \<sqinter> (([\<cdot>p] * x) \<squnion> ([\<cdot>-p] * y)))"
      by (simp add: sup_inf_distrib2)
    also have "\<dots> = ([\<cdot>p] * x) \<sqinter>  ([\<cdot>-p] * y) \<sqinter> (([\<cdot>p] * x) \<squnion> ([\<cdot>-p] * y))"
      apply (simp add: sup_comp [THEN sym] )
      by (simp add: assert_sup [THEN sym] inf_assoc)
    also have "\<dots> = ([\<cdot>p] * x) \<sqinter>  ([\<cdot>-p] * y)"
      by (rule antisym, simp_all add: inf_assoc)
    finally show ?thesis .
  qed

definition
  "wp x p = abs_wpt (x * {\<cdot>p})"

lemma wp_assume: "wp [\<cdot>p] q = -p \<squnion> q"
  apply (simp add: wp_def abs_wpt_def)
  apply (rule assert_injective)
  apply simp
  by (simp add: assert_sup assert_neg assume_def wpt_dual_assertion_comp)

lemma assert_commute: "y \<in> conjunctive \<Longrightarrow> y * {\<cdot>p} = {\<cdot> wp y p } * y"
  apply (simp add: wp_def abs_wpt_def)
  by (rule assertion_commute, simp_all)

lemma wp_assert: "wp {\<cdot>p} q = p \<sqinter> q"
  by (simp add: wp_def assertion_inf_comp_eq [THEN sym] assert_inf [THEN sym])

lemma wp_mono [simp]: "mono (wp x)"
  apply (simp add: le_fun_def wp_def abs_wpt_def less_eq_Assertion_def mono_def)
  apply (simp add: wpt_def, safe)
  apply (rule_tac y = " x * {\<cdot> xa } * \<top>" in order_trans, simp_all)
  apply (rule le_comp_right)
  by (rule le_comp, simp)

lemma wp_fun_mono [simp]: "mono wp"
  apply (simp add: le_fun_def wp_def abs_wpt_def less_eq_Assertion_def mono_def)
  apply (simp add: wpt_def, safe)
  apply (rule_tac y = " x * {\<cdot> xa } * \<top>" in order_trans, simp_all)
  apply (rule le_comp_right)
  by (rule le_comp_right, simp)

lemma wp_fun_mono2: "x \<le> y \<Longrightarrow> wp x p \<le> wp y p"
  apply (cut_tac wp_fun_mono)
  apply (unfold mono_def)
  apply (simp add: le_fun_def)
  by blast

lemma wp_comp: "wp (x * y) p = wp x (wp y p)"
  apply (simp add: wp_def abs_wpt_def)
  by (unfold wpt_comp_2 [THEN sym] mult.assoc, simp)

lemma wp_choice: "wp (x \<sqinter> y) = wp x \<sqinter> wp y"
  apply (simp add: fun_eq_iff wp_def inf_fun_def inf_comp inf_Assertion_def abs_wpt_def)
  by (simp add: wpt_choice)

lemma [simp]: "wp 1 = id"
  apply (unfold fun_eq_iff, safe)
  apply (rule assert_injective)
  by (simp add: wp_def abs_wpt_def)

lemma wp_omega_fix: "wp (x ^ \<omega>) p = wp x (wp (x ^ \<omega>) p) \<sqinter> p"
  apply (subst omega_fix)
  by (simp add: wp_choice wp_comp)

lemma wp_omega_least: "(wp x r) \<sqinter> p \<le> r \<Longrightarrow> wp (x ^ \<omega>) p \<le> r"
  apply (simp add: wp_def abs_wpt_def inf_Assertion_def less_eq_Assertion_def)
  apply (simp add: wpt_def)
  apply (rule_tac y = "{\<cdot>r} * \<top> \<sqinter> 1" in order_trans)
  apply simp
  apply (rule_tac y = "x ^ \<omega> * {\<cdot> p } * \<top>" in order_trans, simp)
  apply (simp add: mult.assoc)
  apply (rule omega_least)
  apply (drule_tac z = \<top> in le_comp_right)
  apply (simp add: inf_comp mult.assoc [THEN sym])
  by (simp add: assertion_prop)

lemma Assertion_wp: "{\<cdot>wp x p} = (x * {\<cdot>p} * \<top>) \<sqinter> 1"
  apply (simp add: wp_def abs_wpt_def)
  by (simp add: wpt_def)

definition
  "hoare p S q = (p \<le> wp S q)"

definition
  "grd x = - (wp x \<bottom>)"

lemma grd_comp: "[\<cdot>grd x] * x = x"
  apply (simp add: grd_def wp_def uminus_Assertion_def assume_def neg_assert_def abs_wpt_def dual_sup sup_comp)
  apply (simp add: wpt_def dual_inf sup_comp dual_comp bot_Assertion_def)
  by (rule antisym, simp_all)

lemma assert_assume: "{\<cdot>p} * [\<cdot>p] = {\<cdot> p}"
  by (simp add: assume_def)

lemma dual_assume: "[\<cdot>p] ^ o = {\<cdot>p}"
  by (simp add: assume_def)

lemma assume_prop: "([\<cdot>p] * \<bottom>) \<squnion> 1 = [\<cdot>p]"
  by (simp add: assume_def dual_assertion_prop)

text\<open>An alternative definition of a Hoare triple\<close>

definition "hoare1 p S q = ([\<cdot> p ] * S * [\<cdot> -q ] = \<top>)"

lemma "hoare1  p S q = hoare p S q"
  apply (simp add: hoare1_def dual_inf dual_comp)
  apply (simp add: hoare_def wp_def less_eq_Assertion_def abs_wpt_def)
  apply (simp add: wpt_def)
  apply safe
  proof -
    assume A: "[\<cdot> p ] * S * [\<cdot> - q ] = \<top>"
    have "{\<cdot>p} \<le> {\<cdot>p} * \<top>" by simp
    also have "... \<le> {\<cdot>p} * \<top> * \<bottom>" by (unfold mult.assoc, simp)
    also have "... = {\<cdot>p} * [\<cdot> p ] * S * [\<cdot> - q ] * \<bottom>" by (subst A [THEN sym], simp add: mult.assoc)
    also have "... = {\<cdot>p} * S * [\<cdot> - q ] * \<bottom>" by (simp add: assert_assume)
    also have "... \<le> {\<cdot>p} * S * {\<cdot> q } * \<top>"
      apply (simp add: mult.assoc)
      apply (rule le_comp, rule le_comp)
      apply (simp add: assume_def uminus_Assertion_def)
      by (simp add: neg_assert_def dual_inf dual_comp sup_comp)
    also have "... \<le> S * {\<cdot> q } * \<top>" by (simp add: mult.assoc)
    finally show "{\<cdot>p} \<le> S * {\<cdot> q } * \<top>" .
  next
    assume A: "{\<cdot> p } \<le> S * {\<cdot> q } * \<top>"
    have "\<top> = ((S * {\<cdot>q}) ^ o) * \<bottom> \<squnion> S * {\<cdot>q} * \<top>" by simp
    also have "\<dots> \<le> [\<cdot>p] * \<bottom> \<squnion> S * {\<cdot>q} * \<top>"
      apply (simp del: dual_neg_top)
      apply (rule_tac y = "[\<cdot>p] * \<bottom>" in order_trans, simp_all)
      apply (subst dual_le)
      apply (simp add: dual_comp dual_assume)
      apply (cut_tac x = "{\<cdot>p}" and y = "S * {\<cdot>q} * \<top>" and z = \<top> in le_comp_right)
      apply (rule A)
      by (simp add: mult.assoc)
    also have "\<dots> = [\<cdot>p] * S * ({\<cdot>q} * \<top>)"
      apply (subst (2) assume_prop [THEN sym])
      by (simp_all add: sup_comp mult.assoc)
    also have "\<dots> \<le> [\<cdot>p] * S * ({\<cdot>q} * \<top> \<squnion> 1)"
      by (rule le_comp, simp)
    also have "\<dots> = [\<cdot>p] * S * [\<cdot>-q]"
      apply (simp add: assume_def uminus_Assertion_def)
      by (simp add: neg_assert_def dual_inf dual_comp)
    finally show "[\<cdot>p] * S * [\<cdot> - q] = \<top>"
      by (rule_tac antisym, simp_all)
  qed

lemma hoare_choice: "hoare p (x \<sqinter> y) q = ((hoare p) x q & (hoare p y q))"
  apply (unfold hoare_def wp_choice inf_fun_def)
  by auto

definition
  if_stm:: "'a::mbt_algebra Assertion \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" ("(If (_)/ then (_)/ else (_))" [0, 0, 10] 10) where
  "if_stm b x y = (([\<cdot> b ] * x) \<sqinter> ([\<cdot> -b ] * y))"

lemma if_assertion: "(If p then x else y) = {\<cdot>p} * x \<squnion> {\<cdot> -p} * y"
  by (simp add: if_stm_def if_Assertion_assumption)

lemma (in boolean_algebra) sup_neg_inf:
  "(p \<le> q \<squnion> r) = (p \<sqinter> -q \<le> r)"
  apply (safe)
  apply(cut_tac a = p and c = "q \<squnion> r" and b = "-q" and d = "-q" in inf_mono)
  apply simp apply simp apply (simp add: inf_sup_distrib2)
  apply(cut_tac b = "p \<sqinter> - q" and d = "r" and a = "q" and c = "q" in sup_mono)
  apply simp apply simp  by (simp add: sup_inf_distrib)

lemma hoare_if: "hoare p (If b then x else y) q = (hoare (p \<sqinter> b) x q \<and> hoare (p \<sqinter> -b) y q)"
  by (simp add: hoare_def if_stm_def wp_choice inf_fun_def wp_comp wp_assume sup_neg_inf)

lemma hoare_comp: "hoare p (x * y) q = (\<exists> r . (hoare p x r) \<and> (hoare r y q))"
   apply (simp add: hoare_def wp_comp)
   apply safe
   apply (rule_tac x = "wp y q" in exI, simp)
   apply (rule_tac y = "wp x r" in order_trans, simp)
   apply (rule_tac f = "wp x" in monoD)
   by simp_all

lemma hoare_refinement: "hoare p S q = ({\<cdot>p} * (post {\<cdot>q}) \<le> S)"
  apply (simp add: hoare_def less_eq_Assertion_def Assertion_wp)
  proof
    assume A: "{\<cdot>p} \<le> S * {\<cdot>q} * \<top>"
    have "{\<cdot>p} * post {\<cdot>q} = ({\<cdot>p} * \<top> \<sqinter> 1) * post {\<cdot>q}" by (simp add: assertion_prop)
    also have "\<dots> = {\<cdot>p} * \<top> \<sqinter> post {\<cdot>q}" by (simp add: inf_comp)
    also have "\<dots> \<le> S * {\<cdot>q} * \<top> \<sqinter> post {\<cdot>q}" apply simp
      apply (rule_tac y = "{\<cdot>p} * \<top>" in order_trans, simp_all)
      apply (cut_tac x = "{\<cdot>p}" and y = "S * {\<cdot>q} * \<top>" and z = \<top> in le_comp_right)
      by (rule A, simp)
    also have "\<dots> \<le> S" by (simp add: post_2)
    finally show "{\<cdot>p} * post {\<cdot>q} \<le> S".
  next
    assume A: "{\<cdot>p} * post {\<cdot>q} \<le> S"
    have "{\<cdot>p} = {\<cdot>p} * \<top> \<sqinter> 1" by (simp add: assertion_prop)
    also have "\<dots> = {\<cdot>p} * ((post {\<cdot>q}) * {\<cdot>q} * \<top>) \<sqinter> 1" by (simp add: post_1)
    also have "\<dots> \<le> {\<cdot>p} * ((post {\<cdot>q}) * {\<cdot>q} * \<top>)" by simp
    also have "\<dots> \<le> S * {\<cdot>q} * \<top>"
      apply (cut_tac x = "{\<cdot>p} * post {\<cdot>q}" and y = S and z = "{\<cdot>q} * \<top>" in le_comp_right)
      apply (simp add: A)
      by (simp add: mult.assoc)
    finally show "{\<cdot>p} \<le> S * {\<cdot>q} * \<top>" .
  qed

 theorem hoare_fixpoint_mbt:
  "F x = x
     \<Longrightarrow> (!! (w::'a::well_founded) f . (\<And>v. v < w \<Longrightarrow> hoare (p v) f q) \<Longrightarrow> hoare (p w) (F f) q)
     \<Longrightarrow> hoare (p u) x q"
  apply (rule less_induct1)
  proof -
    fix xa
    assume A: "\<And> w f. (\<And> v . v < w \<Longrightarrow> hoare (p v) f q) \<Longrightarrow> hoare (p w) (F f) q"
    assume B: "F x  = x"
    assume C: "\<And>y . y < xa \<Longrightarrow> hoare (p y) x q"
    have D: "hoare (p xa) (F x) q"
      apply (rule A)
      by (rule C, simp)
    show "hoare (p xa) x q"
      by (cut_tac D, simp add: B)
    qed

lemma hoare_Sup: "hoare (Sup P) x q = (\<forall> p \<in> P . hoare p x q)"
  apply (simp add: hoare_def)
  apply auto
  apply (rule_tac y = "Sup P" in order_trans, simp_all add: Sup_upper)
  apply (rule Sup_least)
  by simp

theorem hoare_fixpoint_complete_mbt:
  "F x = x
     \<Longrightarrow> (!! w f . hoare (Sup_less p w) f q \<Longrightarrow> hoare (p w) (F f) q)
     \<Longrightarrow> hoare (Sup (range p)) x q"
  apply (simp add: hoare_Sup Sup_less_def, safe)
  apply (rule_tac F = F in hoare_fixpoint_mbt)
  by auto

definition
  while:: "'a::mbt_algebra Assertion \<Rightarrow> 'a \<Rightarrow> 'a" ("(While (_)/ do (_))" [0, 10] 10) where
  "while p x = ([\<cdot> p] * x) ^ \<omega> * [\<cdot> -p ]"

lemma while_false: "(While \<bottom> do x) = 1"
  apply (unfold while_def)
  apply (subst omega_fix)
  by (simp_all add: assume_def)

lemma while_true: "(While \<top> do 1) = \<bottom>"
  apply (unfold while_def)
  by (rule antisym, simp_all add: assume_def)

lemma hoare_wp [simp]: "hoare (wp x q) x q"
  by (simp add: hoare_def)

lemma hoare_comp_wp: "hoare p (x * y) q = hoare p x (wp y q)"
  apply (unfold hoare_comp, safe)
  apply (simp add: hoare_def)
  apply (rule_tac y = "wp x r" in order_trans, simp)
  apply (rule wp_mono2, simp)
  by (rule_tac x = "wp y q" in exI, simp)

lemma (in mbt_algebra) hoare_assume: "hoare p [\<cdot>b] q = (p \<sqinter> b \<le> q)"
  by (simp add: hoare_def wp_assume sup_neg_inf)

lemma hoare_while_mbt:
  "(\<forall> (w::'b::well_founded) r . (\<forall> v . v < w \<longrightarrow> p v \<le> r) \<longrightarrow> hoare ((p w) \<sqinter> b) x r) \<Longrightarrow>
       (\<forall> u . p u \<le> q) \<Longrightarrow> hoare  (p w) (While b do x) (q \<sqinter> -b)"
  apply (unfold while_def)
  apply (rule_tac F = "\<lambda>z. [\<cdot> b ] * x * z \<sqinter> [\<cdot> - b ]" in hoare_fixpoint_mbt)
  apply (simp add: mult.assoc [THEN sym])
  apply (simp add: omega_comp_fix)
  apply (unfold hoare_choice)
  apply safe
  apply (subst hoare_comp_wp)
  apply (subst hoare_assume_comp)
  apply (drule_tac x = w in spec)
  apply (drule_tac x = "wp f (q \<sqinter> - b)" in spec)
  apply (auto simp add: hoare_def) [1]
  apply (auto simp add: hoare_assume)
  apply (rule_tac y = "p w" in order_trans)
  by simp_all

lemma hoare_while_complete_mbt:
  "(\<forall> w::'b::well_founded . hoare ((p w) \<sqinter> b) x (Sup_less p w)) \<Longrightarrow>
       hoare  (Sup (range p)) (While b do x) ((Sup (range p)) \<sqinter> -b)"
  apply (simp add: hoare_Sup, safe)
  apply (rule hoare_while_mbt)
  apply safe
  apply (drule_tac x = w in spec)
  apply (simp add: hoare_def)
  apply (rule_tac y = "wp x (Sup_less p w)" in order_trans, simp_all)
  apply (rule wp_mono2)
  apply (simp add: Sup_less_def)
  apply (rule Sup_least, auto)
  by (rule SUP_upper, simp)

definition
  "datarefin S S1 D D1 = (D * S \<le> S1 * D1)"

lemma "hoare p S q \<Longrightarrow> datarefin S S1 D D1 \<Longrightarrow> hoare (wp D p) S1 (wp D1 q)"
  apply (simp add: hoare_def datarefin_def)
  apply (simp add: wp_comp [THEN sym] mult.assoc [THEN sym])
  apply (rule_tac y = "wp (D * S) q" in order_trans)
  apply (subst wp_comp)
  apply (rule monoD, simp_all)
  by (rule wp_fun_mono2, simp_all)

lemma "hoare p S q \<Longrightarrow> datarefin ({\<cdot>p} * S) S1 D D1 \<Longrightarrow> hoare (wp D p) S1 (wp D1 q)"
  apply (simp add: hoare_def datarefin_def)
  apply (rule_tac y = "wp (D * {\<cdot>p} * S) q" in order_trans)
  apply (simp add: mult.assoc)
  apply (subst wp_comp)
  apply (rule monoD, simp_all)
  apply (subst wp_comp)
  apply (unfold wp_assert, simp)
  apply (unfold wp_comp [THEN sym])
  apply (rule wp_fun_mono2)
  by (simp add: mult.assoc)

lemma inf_pres_conj: "x \<in> conjunctive \<Longrightarrow> y \<in> conjunctive \<Longrightarrow> x \<sqinter> y \<in> conjunctive"
  apply (subst conjunctive_def, safe)
  apply (simp add: inf_comp conjunctiveD)
  by (metis (hide_lams, no_types) inf_assoc inf_left_commute)

lemma sup_pres_disj: "x \<in> disjunctive \<Longrightarrow> y \<in> disjunctive \<Longrightarrow> x \<squnion> y \<in> disjunctive"
  apply (subst disjunctive_def, safe)
  apply (simp add: sup_comp disjunctiveD)
  by (metis (hide_lams, no_types) sup_assoc sup_left_commute)

lemma assumption_conjuncive [simp]: "[\<cdot>p] \<in> conjunctive"
  by (simp add: assume_def dual_disjunctive assertion_disjunctive)

lemma assumption_disjuncive [simp]: "[\<cdot>p] \<in> disjunctive"
  by (simp add: assume_def dual_conjunctive assertion_conjunctive)

lemma if_pres_conj: "x \<in> conjunctive \<Longrightarrow> y \<in> conjunctive \<Longrightarrow> (If p then x else y) \<in> conjunctive"
  apply (unfold if_stm_def)
  by (simp add: inf_pres_conj comp_pres_conj)

lemma if_pres_disj: "x \<in> disjunctive \<Longrightarrow> y \<in> disjunctive \<Longrightarrow> (If p then x else y) \<in> disjunctive"
  apply (unfold if_assertion)
  by (simp add: sup_pres_disj comp_pres_disj assertion_disjunctive)

lemma while_dual_star: "(While p do (x::'a::mbt_algebra)) = (({\<cdot> p} * x)^\<otimes> * {\<cdot> -p })"
  apply (simp add: while_def)
  apply (rule antisym)
  apply (rule omega_least)
   proof -
     have "([\<cdot> p] * x * (({\<cdot> p} * x)^\<otimes> * {\<cdot>-p}) \<sqinter> [\<cdot>-p]) = ({\<cdot> p} * x * (({\<cdot> p} * x)^\<otimes> * {\<cdot>-p})) \<squnion> {\<cdot>-p}"
        apply (unfold mult.assoc)
        by (cut_tac p = p and x = "(x * (({\<cdot> p } * x)^\<otimes> * {\<cdot> -p }))" and y = 1 in if_Assertion_assumption, simp)
     also have "\<dots> = ({\<cdot> p} * x)^\<otimes> * {\<cdot>-p}"
        by (simp add: mult.assoc [THEN sym], simp add: dual_star_comp_fix [THEN sym])
     finally show "[\<cdot> p ] * x * (({\<cdot> p } * x)^\<otimes> * {\<cdot> - p }) \<sqinter> [\<cdot> - p ] \<le> ({\<cdot> p } * x)^\<otimes> * {\<cdot> - p }" by simp
   next
     show "({\<cdot> p } * x)^\<otimes> * {\<cdot> - p } \<le> ([\<cdot> p ] * x) ^ \<omega> * [\<cdot> - p ]"
       apply (rule dual_star_least)
       proof -
        have "{\<cdot> p } * x * (([\<cdot> p ] * x) ^ \<omega> * [\<cdot> - p ]) \<squnion> {\<cdot> - p } = [\<cdot> p ] * x * (([\<cdot> p ] * x) ^ \<omega> * [\<cdot> - p ]) \<sqinter> [\<cdot> - p ]"
        apply (unfold mult.assoc)
        by (cut_tac p = p and x = "(x * (([\<cdot>p] * x)^\<omega> * [\<cdot>-p]))" and y = 1 in if_Assertion_assumption, simp)
        also have "... = ([\<cdot> p ] * x) ^ \<omega> * [\<cdot> - p ]"
          apply (simp add: mult.assoc [THEN sym])
          by (metis omega_comp_fix)
        finally show "{\<cdot> p } * x * (([\<cdot> p ] * x) ^ \<omega> * [\<cdot> - p ]) \<squnion> {\<cdot> - p } \<le> ([\<cdot> p ] * x) ^ \<omega> * [\<cdot> - p ] " by simp
     qed
   qed

lemma while_pres_disj: "(x::'a::mbt_algebra) \<in> disjunctive \<Longrightarrow> (While p do x) \<in> disjunctive"
  apply (unfold while_dual_star)
  apply (rule comp_pres_disj)
  apply (rule dual_star_pres_disj)
  by (rule comp_pres_disj, simp_all add: assertion_disjunctive)

lemma while_pres_conj: "(x::'a::mbt_algebra_fusion) \<in> conjunctive \<Longrightarrow> (While p do x) \<in> conjunctive"
  apply(unfold while_def)
  by (simp add: comp_pres_conj omega_pres_conj)

no_notation
  bot  ("\<bottom>") and
  top  ("\<top>") and
  inf  (infixl "\<sqinter>" 70) and
  sup  (infixl "\<squnion>" 65) and
  Inf  ("\<Sqinter>_" [900] 900) and
  Sup  ("\<Squnion>_" [900] 900)

no_syntax
  "_INF1"     :: "pttrns \<Rightarrow> 'b \<Rightarrow> 'b"           ("(3\<Sqinter>_./ _)" [0, 10] 10)
  "_INF"      :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b \<Rightarrow> 'b"  ("(3\<Sqinter>_\<in>_./ _)" [0, 0, 10] 10)
  "_SUP1"     :: "pttrns \<Rightarrow> 'b \<Rightarrow> 'b"           ("(3\<Squnion>_./ _)" [0, 10] 10)
  "_SUP"      :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b \<Rightarrow> 'b"  ("(3\<Squnion>_\<in>_./ _)" [0, 0, 10] 10)

end