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

section {* Dense linear order without endpoints
  and a quantifier elimination procedure in Ferrante and Rackoff style *}

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{* Theorems for @{text "\<exists>z. \<forall>x. x < z \<longrightarrow> (P x \<longleftrightarrow> P\<^sub>-\<^sub>\<infinity>)"}*}
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{* Theorems for @{text "\<exists>z. \<forall>x. x < z \<longrightarrow> (P x \<longleftrightarrow> P\<^sub>+\<^sub>\<infinity>)"}*}
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
  { assume H: "t < y"
    from less_trans[OF lx px] less_trans[OF H yu]
    have "l < t \<and> t < u" by simp
    with tU noU have "False" by auto }
  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
  { assume H: "y< t"
    from less_trans[OF ly H] less_trans[OF px xu] have "l < t \<and> t < u" by simp
    with tU noU have "False" by auto }
  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
  { assume H: "t < y"
    from less_le_trans[OF lx px] less_trans[OF H yu]
    have "l < t \<and> t < u" by simp
    with tU noU have "False" by auto }
  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
  { assume H: "y< t"
    from less_trans[OF ly H] le_less_trans[OF px xu]
    have "l < t \<and> t < u" by simp
    with tU noU have "False" by auto }
  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
  hence fMx: "finite ?Mx" using fS finite_subset by auto
  from lx linS have linMx: "l \<in> ?Mx" by blast
  hence Mxne: "?Mx \<noteq> {}" by blast
  have xMS: "?xM \<subseteq> S" by blast
  hence fxM: "finite ?xM" using fS finite_subset by auto
  from xu uinS have linxM: "u \<in> ?xM" by blast
  hence 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 hence ainS: "?a \<in> S" using MxS by blast
  have "?b \<in> ?xM" using Min_in[OF fxM xMne] by simp hence 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)
    moreover {
      assume "y \<in> ?Mx"
      hence "y \<le> ?a" using Mxne fMx by auto
      with ay have "False" by (simp add: not_le[symmetric])
    }
    moreover {
      assume "y \<in> ?xM"
      hence "?b \<le> y" using xMne fxM by auto
      with yb have "False" by (simp add: not_le[symmetric])
    }
    ultimately show False by blast
  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)
  thus ?thesis using px as bs noS by blast
qed

end

section {* The classical QE after Langford for dense linear orders *}

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
  { fix l u assume l: "l \<in> L" and u: "u \<in> U"
    have "l < x" using xL l by blast
    also have "x < u" using xU u by blast
    finally (less_trans) have "l < u" . }
  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)
  thus "\<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)
  thus "\<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)) = (\<not>P \<or> \<not>Q)" "(\<not>(P \<or> Q)) = (\<not>P \<and> \<not>Q)" "(P \<longrightarrow> Q) = (\<not>P \<or> Q)"
    "(P = Q) = ((P \<and> Q) \<or> (\<not>P \<and> \<not> Q))" "(\<not> \<not>(P)) = 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 = {*
  Scan.succeed (SIMPLE_METHOD' o Langford.dlo_tac)
*} "Langford's algorithm for quantifier elimination in dense linear orders"

section {* Contructive dense linear orders yield QE for linear arithmetic over ordered Fields *}

text {* Linear order without upper bounds *}

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 {* Theorems for @{text "\<exists>z. \<forall>x. z \<sqsubset> x \<longrightarrow> (P x \<longleftrightarrow> P\<^sub>+\<^sub>\<infinity>)"} *}
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
  { fix x assume H: "z \<sqsubset> x"
    from less_trans[OF zz1 H] less_trans[OF zz2 H]
    have "(P1 x \<and> P2 x) \<longleftrightarrow> (P1' \<and> P2')"  using z1 zz1 z2 zz2 by auto
  }
  thus ?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
  { fix x assume H: "z \<sqsubset> x"
    from less_trans[OF zz1 H] less_trans[OF zz2 H]
    have "(P1 x \<or> P2 x) \<longleftrightarrow> (P1' \<or> P2')"  using z1 zz1 z2 zz2 by auto
  }
  thus ?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 {* Linear order without upper bounds *}

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 {* Theorems for @{text "\<exists>z. \<forall>x. x \<sqsubset> z \<longrightarrow> (P x \<longleftrightarrow> P\<^sub>-\<^sub>\<infinity>)"} *}
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
  { fix x assume H: "x \<sqsubset> z"
    from less_trans[OF H zz1] less_trans[OF H zz2]
    have "(P1 x \<and> P2 x) \<longleftrightarrow> (P1' \<and> P2')"  using z1 zz1 z2 zz2 by auto
  }
  thus ?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
  { fix x assume H: "x \<sqsubset> z"
    from less_trans[OF H zz1] less_trans[OF H zz2]
    have "(P1 x \<or> P2 x) \<longleftrightarrow> (P1' \<or> P2')"  using z1 zz1 z2 zz2 by auto
  }
  thus ?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
  apply unfold_locales
  using gt_ex lt_ex between_less
  apply auto
  apply (rule_tac x="between x y" in exI)
  apply simp
  done

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]
  have "(\<exists> s\<in> U. P s) \<or>
      (\<exists> t1\<in> U. \<exists> t2 \<in> U. (\<forall> y. t1 \<sqsubset> y \<and> y \<sqsubset> t2 \<longrightarrow> y \<notin> U) \<and> t1 \<sqsubset> x \<and> x \<sqsubset> t2 \<and> P x)" .
  moreover {
    fix u assume um: "u\<in>U" and pu: "P u"
    have "between u u = u" by (simp add: between_same)
    with um pu have "P (between u u)" by simp
    with um have ?thesis by blast }
  moreover {
    assume "\<exists> t1\<in> U. \<exists> t2 \<in> U. (\<forall> y. t1 \<sqsubset> y \<and> y \<sqsubset> t2 \<longrightarrow> y \<notin> U) \<and> t1 \<sqsubset> x \<and> x \<sqsubset> t2 \<and> P x"
    then obtain t1 and t2 where t1M: "t1 \<in> U" and t2M: "t2\<in> U"
      and noM: "\<forall> y. t1 \<sqsubset> y \<and> y \<sqsubset> t2 \<longrightarrow> y \<notin> U"
      and t1x: "t1 \<sqsubset> x" and xt2: "x \<sqsubset> t2" and px: "P x" by blast
    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 have ?thesis by blast
  }
  ultimately show ?thesis by blast
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 -
  { assume px: "\<exists> x. P x"
    have "MP \<or> PP \<or> (\<not> MP \<and> \<not> PP)" by blast
    moreover { assume "MP \<or> PP" hence "?D" by blast }
    moreover {
      assume nmi: "\<not> MP" and npi: "\<not> PP"
      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 nmi npi px] have "?D" by blast }
    ultimately have "?D" by blast }
  moreover
  { assume "?D"
    moreover { assume m:"MP" from minf_ex[OF mi m] have "?E" . }
    moreover { assume p: "PP" from pinf_ex[OF pi p] have "?E" . }
    moreover { assume f:"?F" hence "?E" by blast }
    ultimately have "?E" by blast }
  ultimately have "?E = ?D" by blast thus "?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 {*
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 term_of t of
          Const(@{const_name HOL.eq}, _)$y$z =>
            if 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 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 term_of x aconv y then Ferrante_Rackoff_Data.Lt
                     else if term_of x aconv z then Ferrante_Rackoff_Data.Gt
                     else Ferrante_Rackoff_Data.Nox
                 else if Term.could_unify (b, le) then
                     if term_of x aconv y then Ferrante_Rackoff_Data.Le
                     else if 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 =
    simpset_of (put_simpset HOL_ss @{context} addsimps (simps phi))
in
  Ferrante_Rackoff_Data.funs  @{thm "ferrack_axiom"}
    {isolate_conv = K (K (K Thm.reflexive)), whatis = generic_whatis, simpset = ss}
end
*}

end

ML_file "ferrante_rackoff.ML"

method_setup ferrack = {*
  Scan.succeed (SIMPLE_METHOD' o FerranteRackoff.dlo_tac)
*} "Ferrante and Rackoff's algorithm for quantifier elimination in dense linear orders"

subsection {* Ferrante and Rackoff algorithm over ordered fields *}

lemma neg_prod_lt:"(c\<Colon>'a\<Colon>linordered_field) < 0 \<Longrightarrow> ((c*x < 0) == (x > 0))"
proof -
  assume H: "c < 0"
  have "c*x < 0 = (0/c < x)"
    by (simp only: neg_divide_less_eq[OF H] algebra_simps)
  also have "\<dots> = (0 < x)" by simp
  finally show  "(c*x < 0) == (x > 0)" by simp
qed

lemma pos_prod_lt:"(c\<Colon>'a\<Colon>linordered_field) > 0 \<Longrightarrow> ((c*x < 0) == (x < 0))"
proof -
  assume H: "c > 0"
  then have "c*x < 0 = (0/c > x)"
    by (simp only: pos_less_divide_eq[OF H] algebra_simps)
  also have "\<dots> = (0 > x)" by simp
  finally show  "(c*x < 0) == (x < 0)" by simp
qed

lemma neg_prod_sum_lt: "(c\<Colon>'a\<Colon>linordered_field) < 0 \<Longrightarrow> ((c*x + t< 0) == (x > (- 1/c)*t))"
proof -
  assume H: "c < 0"
  have "c*x + t< 0 = (c*x < -t)"
    by (subst less_iff_diff_less_0 [of "c*x" "-t"], simp)
  also have "\<dots> = (-t/c < x)"
    by (simp only: neg_divide_less_eq[OF H] algebra_simps)
  also have "\<dots> = ((- 1/c)*t < x)" by simp
  finally show "(c*x + t < 0) == (x > (- 1/c)*t)" by simp
qed

lemma pos_prod_sum_lt:"(c\<Colon>'a\<Colon>linordered_field) > 0 \<Longrightarrow> ((c*x + t < 0) == (x < (- 1/c)*t))"
proof -
  assume H: "c > 0"
  have "c*x + t< 0 = (c*x < -t)"
    by (subst less_iff_diff_less_0 [of "c*x" "-t"], simp)
  also have "\<dots> = (-t/c > x)"
    by (simp only: pos_less_divide_eq[OF H] algebra_simps)
  also have "\<dots> = ((- 1/c)*t > x)" by simp
  finally show  "(c*x + t < 0) == (x < (- 1/c)*t)" by simp
qed

lemma sum_lt:"((x::'a::ordered_ab_group_add) + t < 0) == (x < - t)"
  using less_diff_eq[where a= x and b=t and c=0] by simp

lemma neg_prod_le:"(c\<Colon>'a\<Colon>linordered_field) < 0 \<Longrightarrow> ((c*x <= 0) == (x >= 0))"
proof -
  assume H: "c < 0"
  have "c*x <= 0 = (0/c <= x)"
    by (simp only: neg_divide_le_eq[OF H] algebra_simps)
  also have "\<dots> = (0 <= x)" by simp
  finally show  "(c*x <= 0) == (x >= 0)" by simp
qed

lemma pos_prod_le:"(c\<Colon>'a\<Colon>linordered_field) > 0 \<Longrightarrow> ((c*x <= 0) == (x <= 0))"
proof -
  assume H: "c > 0"
  hence "c*x <= 0 = (0/c >= x)"
    by (simp only: pos_le_divide_eq[OF H] algebra_simps)
  also have "\<dots> = (0 >= x)" by simp
  finally show  "(c*x <= 0) == (x <= 0)" by simp
qed

lemma neg_prod_sum_le: "(c\<Colon>'a\<Colon>linordered_field) < 0 \<Longrightarrow> ((c*x + t <= 0) == (x >= (- 1/c)*t))"
proof -
  assume H: "c < 0"
  have "c*x + t <= 0 = (c*x <= -t)"
    by (subst le_iff_diff_le_0 [of "c*x" "-t"], simp)
  also have "\<dots> = (-t/c <= x)"
    by (simp only: neg_divide_le_eq[OF H] algebra_simps)
  also have "\<dots> = ((- 1/c)*t <= x)" by simp
  finally show "(c*x + t <= 0) == (x >= (- 1/c)*t)" by simp
qed

lemma pos_prod_sum_le:"(c\<Colon>'a\<Colon>linordered_field) > 0 \<Longrightarrow> ((c*x + t <= 0) == (x <= (- 1/c)*t))"
proof -
  assume H: "c > 0"
  have "c*x + t <= 0 = (c*x <= -t)"
    by (subst le_iff_diff_le_0 [of "c*x" "-t"], simp)
  also have "\<dots> = (-t/c >= x)"
    by (simp only: pos_le_divide_eq[OF H] algebra_simps)
  also have "\<dots> = ((- 1/c)*t >= x)" by simp
  finally show "(c*x + t <= 0) == (x <= (- 1/c)*t)" by simp
qed

lemma sum_le:"((x::'a::ordered_ab_group_add) + t <= 0) == (x <= - t)"
  using le_diff_eq[where a= x and b=t and c=0] by simp

lemma nz_prod_eq:"(c\<Colon>'a\<Colon>linordered_field) \<noteq> 0 \<Longrightarrow> ((c*x = 0) == (x = 0))" by simp

lemma nz_prod_sum_eq: "(c\<Colon>'a\<Colon>linordered_field) \<noteq> 0 \<Longrightarrow> ((c*x + t = 0) == (x = (- 1/c)*t))"
proof -
  assume H: "c \<noteq> 0"
  have "c*x + t = 0 = (c*x = -t)"
    by (subst eq_iff_diff_eq_0 [of "c*x" "-t"], simp)
  also have "\<dots> = (x = -t/c)"
    by (simp only: nonzero_eq_divide_eq[OF H] algebra_simps)
  finally show  "(c*x + t = 0) == (x = (- 1/c)*t)" by simp
qed

lemma sum_eq:"((x::'a::ordered_ab_group_add) + t = 0) == (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 <=" "op <"
   "\<lambda> x y. 1/2 * ((x::'a::{linordered_field}) + y)"
  by unfold_locales (dlo, dlo, auto)

declaration{*
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 term_of ct of
    Const (@{const_name Fields.divide},_) $ a $ b=>
      Rat.rat_of_quotient (snd (HOLogic.dest_number a), snd (HOLogic.dest_number b))
  | Const(@{const_name inverse}, _)$a => Rat.rat_of_quotient(1, HOLogic.dest_number a |> snd)
  | t => Rat.rat_of_int (snd (HOLogic.dest_number t))

fun mk_frac phi cT x =
  let val (a, b) = Rat.quotient_of_rat x
  in if b = 1 then Numeral.mk_cnumber cT a
    else Thm.apply
         (Thm.apply (Drule.cterm_rule (instantiate' [SOME cT] []) @{cpat "op /"})
                     (Numeral.mk_cnumber cT a))
         (Numeral.mk_cnumber cT b)
 end

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

fun xnormalize_conv ctxt [] ct = Thm.reflexive ct
| xnormalize_conv ctxt (vs as (x::_)) ct =
   case 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 </ Rat.zero
        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 (instantiate' [SOME (ctyp_of_term 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 = ctyp_of_term x
        val th = 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 </ Rat.zero
        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 (instantiate' [SOME (ctyp_of_term 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 = ctyp_of_term x
        val cr = dest_frac c
        val clt = Drule.cterm_rule (instantiate' [SOME T] []) @{cpat "op <"}
        val cz = Thm.dest_arg ct
        val neg = cr </ Rat.zero
        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 (instantiate' [SOME T] (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 = ctyp_of_term x
        val th = 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 = ctyp_of_term x
        val cr = dest_frac c
        val clt = Drule.cterm_rule (instantiate' [SOME T] []) @{cpat "op <"}
        val cz = Thm.dest_arg ct
        val neg = cr </ Rat.zero
        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 (instantiate' [SOME (ctyp_of_term 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 = ctyp_of_term 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
                 (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 = ctyp_of_term x
        val th = 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 = ctyp_of_term 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
                 (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 term_of ct of
  Const(@{const_name Orderings.less},_)$a$b =>
   let val (ca,cb) = Thm.dest_binop ct
       val T = ctyp_of_term ca
       val th = 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 = ctyp_of_term ca
       val th = 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 = ctyp_of_term ca
       val th = 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 term_of t of
     Const(@{const_name HOL.eq}, _)$y$z => if 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 term_of x aconv y then Ferrante_Rackoff_Data.NEq
                            else Ferrante_Rackoff_Data.Nox
   | Const(@{const_name Orderings.less},_)$y$z =>
       if term_of x aconv y then Ferrante_Rackoff_Data.Lt
        else if term_of x aconv z then Ferrante_Rackoff_Data.Gt
        else Ferrante_Rackoff_Data.Nox
   | Const (@{const_name Orderings.less_eq},_)$y$z =>
         if term_of x aconv y then Ferrante_Rackoff_Data.Le
         else if 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 =
  simpset_of (put_simpset HOL_basic_ss @{context}
    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
*}
(*
lemma upper_bound_finite_set:
  assumes fS: "finite S"
  shows "\<exists>(a::'a::linorder). \<forall>x \<in> S. f x \<le> a"
proof(induct rule: finite_induct[OF fS])
  case 1 thus ?case by simp
next
  case (2 x F)
  from "2.hyps" obtain a where a:"\<forall>x \<in>F. f x \<le> a" by blast
  let ?a = "max a (f x)"
  have m: "a \<le> ?a" "f x \<le> ?a" by simp_all
  {fix y assume y: "y \<in> insert x F"
    {assume "y = x" hence "f y \<le> ?a" using m by simp}
    moreover
    {assume yF: "y\<in> F" from a[rule_format, OF yF] m have "f y \<le> ?a" by (simp add: max_def)}
    ultimately have "f y \<le> ?a" using y by blast}
  then show ?case by blast
qed

lemma lower_bound_finite_set:
  assumes fS: "finite S"
  shows "\<exists>(a::'a::linorder). \<forall>x \<in> S. f x \<ge> a"
proof(induct rule: finite_induct[OF fS])
  case 1 thus ?case by simp
next
  case (2 x F)
  from "2.hyps" obtain a where a:"\<forall>x \<in>F. f x \<ge> a" by blast
  let ?a = "min a (f x)"
  have m: "a \<ge> ?a" "f x \<ge> ?a" by simp_all
  {fix y assume y: "y \<in> insert x F"
    {assume "y = x" hence "f y \<ge> ?a" using m by simp}
    moreover
    {assume yF: "y\<in> F" from a[rule_format, OF yF] m have "f y \<ge> ?a" by (simp add: min_def)}
    ultimately have "f y \<ge> ?a" using y by blast}
  then show ?case by blast
qed

lemma bound_finite_set: assumes f: "finite S"
  shows "\<exists>a. \<forall>x \<in>S. (f x:: 'a::linorder) \<le> a"
proof-
  let ?F = "f ` S"
  from f have fF: "finite ?F" by simp
  let ?a = "Max ?F"
  {assume "S = {}" hence ?thesis by blast}
  moreover
  {assume Se: "S \<noteq> {}" hence Fe: "?F \<noteq> {}" by simp
  {fix x assume x: "x \<in> S"
    hence th0: "f x \<in> ?F" by simp
    hence "f x \<le> ?a" using Max_ge[OF fF th0] ..}
  hence ?thesis by blast}
ultimately show ?thesis by blast
qed
*)

end


\<^marker>\<open>creator "Kevin Kappelmann"\<close>
subsection \<open>Extending Functions\<close>
theory SFunctions_Extend_Restrict
  imports SFunctions_Base
begin

lemma extend_mem_dep_functionsI:
  assumes f_dep_fun: "f \<in> (x \<in> A) \<rightarrow>s (B x)"
  and "x \<notin> A"
  shows "extend x y f \<in> (x' \<in> insert x A) \<rightarrow>s (if x' = x then {y} else B x')"
    (is "?lhs \<in> dep_functions ?rhs_dom ?rhs_fun")
proof
  show "set_left_total_on (insert x A) (extend x y f)"
  proof (subst set_left_total_on_set_iff_subset_dom, rule subsetI)
    fix x' assume "x' \<in> insert x A"
    then show "x' \<in> dom (extend x y f)"
    proof (rule mem_insertE)
      assume "x' \<in> A"
      with assms have "\<langle>x', f`x'\<rangle> \<in> f" by auto
      then show "x' \<in> dom (extend x y f)" by auto
    qed auto
  qed
  show "set_right_unique_on (insert x A) (extend x y f)" using assms by blast
qed (insert assms, auto elim!: mem_dep_functionE)

lemma extend_mem_dep_functionsI':
  assumes "f \<in> (x \<in> A) \<rightarrow>s (B x)"
  and "x \<notin> A"
  and "y \<in> B x"
  shows "extend x y f \<in> (x \<in> insert x A) \<rightarrow>s (B x)"
proof (rule mem_dep_functions_covariant_codom)
  show "extend x y f \<in> (x' \<in> insert x A) \<rightarrow>s (if x' = x then {y} else B x')"
    by (fact extend_mem_dep_functionsI[OF assms(1-2)])
qed (insert assms, auto)

lemma extend_mem_functionsI:
  assumes "f \<in> A \<rightarrow>s B"
  and "x \<notin> A"
  shows "extend x y f \<in> functions (insert x A) (insert y B)"
proof (rule mem_dep_functions_covariant_codom)
  show "extend x y f \<in> (x' \<in> insert x A) \<rightarrow>s (if x' = x then {y} else B)"
    by (fact extend_mem_dep_functionsI[OF assms])
qed (insert assms, auto)

subsection \<open>Gluing\<close>

lemma glue_mem_dep_functionsI:
  fixes F defines "D \<equiv> \<Union>f \<in> F. dom f"
  assumes all_fun: "\<And>f. f \<in> F \<Longrightarrow> \<exists>A. f \<in> (x \<in> A) \<rightarrow>s B x"
  and F_right_unique: "set_right_unique_on D (glue F)"
  shows "glue F \<in> (x \<in> D) \<rightarrow>s B x"
proof (rule mem_dep_functionsI)
  show "set_left_total_on D (glue F)" unfolding D_def by auto
  show "glue F \<subseteq> \<Sum>x \<in> D. (B x)"
    unfolding D_def using all_fun
    by (intro glue_subset_dep_pairsI) (auto elim!: mem_dep_functionE)
qed (fact F_right_unique)

lemma glue_upair_mem_dep_functionsI:
  assumes f_dep_fun: "f \<in> (x \<in> A) \<rightarrow>s B x"
  and g_dep_fun: "g \<in> (x \<in> A') \<rightarrow>s B x"
  and agree_fg: "agree (A \<inter> A') {f, g}"
  shows "glue {f, g} \<in> (x \<in> A \<union> A') \<rightarrow>s B x"
proof -
  have "(\<Union>f \<in> {f, g}. dom f) = (\<Union>f \<in> {f}. dom f) \<union> (\<Union>f \<in> {g}. dom f)"
    by (rule eqI) (auto simp only: idx_union_bin_union_dom_eq_bin_union_idx_union)
  also have "... = dom f \<union> dom g" by (rule eqI) auto
  also have "... = A \<union> A'" using assms by simp
  finally have "A \<union> A' = (\<Union>f \<in> {f, g}. dom f)" by auto
  moreover have "set_right_unique_on (A \<union> A') (glue {f, g})"
  proof (subst set_right_unique_on_set_iff_set_right_unique_on,
    rule set_right_unique_onI)
    fix x y y' assume "x \<in> A \<union> A'"
      and pairs_mem: "\<langle>x, y\<rangle> \<in> glue {f, g}" "\<langle>x, y'\<rangle> \<in> glue {f, g}"
    show "y = y'"
    proof (cases "x \<in> A \<inter> A'")
      case True
      with agree_fg pairs_mem have "\<langle>x, y\<rangle> \<in> f" "\<langle>x, y'\<rangle> \<in> f"
        by (auto dest: agreeD)
      with f_dep_fun show "y = y'" by (auto dest: set_right_unique_onD)
    qed (insert f_dep_fun g_dep_fun pairs_mem,
      auto elim!: mem_dep_functionsE dest: set_right_unique_onD)
  qed
  ultimately show ?thesis using assms by (auto intro: glue_mem_dep_functionsI)
qed

subsection \<open>Restriction\<close>

lemma restrict_left_mem_dep_functions_if_mem_dep_functions_if_agree:
  assumes "agree A F"
  and "f \<in> (x \<in> A) \<rightarrow>s (B x)"
  and "f \<in> F"
  and "g \<in> F"
  shows "g\<restriction>\<^bsub>A\<^esub> \<in> (x \<in> A) \<rightarrow>s (B x)"
proof -
  from assms have "g\<restriction>\<^bsub>A\<^esub>  = f\<restriction>\<^bsub>A\<^esub>"
    by (auto elim: set_restrict_left_eq_set_restrict_left_if_agree)
  also have "... = f" using \<open>f \<in> (x \<in> A) \<rightarrow>s (B x)\<close> by auto
  finally show ?thesis using \<open>f \<in> (x \<in> A) \<rightarrow>s (B x)\<close> by simp
qed

lemma restrict_left_mem_dep_functions_collectI:
  assumes "f \<in> (x \<in> A) \<rightarrow>s (B x)"
  shows "f\<restriction>\<^bsub>P\<^esub> \<in> (x \<in> {x \<in> A | P x}) \<rightarrow>s (B x)"
proof (rule mem_dep_functionsI)
  have "set_right_unique_on A f = set_right_unique_on (mem_of A) f" by simp
  also have "... \<le> set_right_unique_on (mem_of A \<sqinter> P) f"
    by (rule antimonoD[OF antimono_set_right_unique_on_pred]) auto
  also have "... \<le> set_right_unique_on (mem_of A \<sqinter> P) f\<restriction>\<^bsub>P\<^esub>"
    by (rule antimonoD[OF antimono_set_right_unique_on_set]) auto
  also have "... = set_right_unique_on {x \<in> A | P x} f\<restriction>\<^bsub>P\<^esub>"
    unfolding inf_apply by simp
  finally have "set_right_unique_on A f \<le> set_right_unique_on {x \<in> A | P x} f\<restriction>\<^bsub>P\<^esub>" .
  moreover from assms have "set_right_unique_on A f" by blast
  ultimately show "set_right_unique_on {x \<in> A | P x} f\<restriction>\<^bsub>P\<^esub>" by auto
qed (insert assms, auto)

end


(*  Author:     Tobias Nipkow, 2007  *)

theory QEdlo_inf
imports DLO
begin

subsection "Quantifier elimination with infinitesimals"

text\<open>This section presents a new quantifier elimination procedure
for dense linear orders based on (the simulation of) infinitesimals.
It is a fairly straightforward adaptation of the analogous algorithm
by Loos and Weispfenning for linear arithmetic described in
\S\ref{sec:lin-inf}.\<close>

fun asubst_peps :: "nat \<Rightarrow> atom \<Rightarrow> atom fm" ("asubst\<^sub>+") where
"asubst_peps k (Less 0 0) = FalseF" |
"asubst_peps k (Less 0 (Suc j)) = Atom(Less k j)" |
"asubst_peps k (Less (Suc i) 0) = (if i=k then TrueF
   else Or (Atom(Less i k)) (Atom(Eq i k)))" |
"asubst_peps k (Less (Suc i) (Suc j)) = Atom(Less i j)" |
"asubst_peps k (Eq 0 0) = TrueF" |
"asubst_peps k (Eq 0 _) = FalseF" |
"asubst_peps k (Eq _ 0) = FalseF" |
"asubst_peps k (Eq (Suc i) (Suc j)) = Atom(Eq i j)"

abbreviation subst_peps :: "atom fm \<Rightarrow> nat \<Rightarrow> atom fm" ("subst\<^sub>+") where
"subst\<^sub>+ \<phi> k \<equiv> amap\<^sub>f\<^sub>m (asubst\<^sub>+ k) \<phi>"

definition "nolb \<phi> xs l x = (\<forall>y\<in>{l<..<x}. y \<notin> LB \<phi> xs)"

lemma nolb_And[simp]:
  "nolb (And \<phi>\<^sub>1 \<phi>\<^sub>2) xs l x = (nolb \<phi>\<^sub>1 xs l x \<and> nolb \<phi>\<^sub>2 xs l x)"
apply(clarsimp simp:nolb_def)
apply blast
done

lemma nolb_Or[simp]:
  "nolb (Or \<phi>\<^sub>1 \<phi>\<^sub>2) xs l x = (nolb \<phi>\<^sub>1 xs l x \<and> nolb \<phi>\<^sub>2 xs l x)"
apply(clarsimp simp:nolb_def)
apply blast
done

context notes [[simp_depth_limit=3]]
begin

lemma I_subst_peps2:
 "nqfree \<phi> \<Longrightarrow> xs!l < x \<Longrightarrow> nolb \<phi> xs (xs!l) x \<Longrightarrow> x \<notin> EQ \<phi> xs
 \<Longrightarrow> \<forall>y \<in> {xs!l <.. x}. DLO.I \<phi> (y#xs)
 \<Longrightarrow> DLO.I (subst\<^sub>+ \<phi> l) xs"
proof(induct \<phi>)
  case FalseF thus ?case
    by simp (metis antisym_conv1 linorder_neq_iff)
next
  case (Atom a)
  show ?case
  proof(cases "(l,a)" rule:asubst_peps.cases)
    case 3 thus ?thesis using Atom
      by (auto simp: nolb_def EQ_def Ball_def)
         (metis One_nat_def antisym_conv1 not_less_iff_gr_or_eq)
  qed (insert Atom, auto simp: nolb_def EQ_def Ball_def)
next
  case Or thus ?case by(simp add: Ball_def)(metis order_refl innermost_intvl)
qed simp_all

end

lemma I_subst_peps:
  "nqfree \<phi> \<Longrightarrow> DLO.I (subst\<^sub>+ \<phi> l) xs \<longrightarrow>
  (\<exists>leps>xs!l. \<forall>x. xs!l < x \<and> x \<le> leps \<longrightarrow> DLO.I \<phi> (x#xs))"
proof(induct \<phi>)
  case TrueF thus ?case by simp (metis no_ub)
next
  case (Atom a)
  show ?case
  proof (cases "(l,a)" rule: asubst_peps.cases)
    case 2 thus ?thesis using Atom
      apply(auto)
      apply(drule dense)
      apply(metis One_nat_def xt1(7))
      done
  next
    case 3 thus ?thesis using Atom
      apply(auto)
        apply (metis no_ub)
       apply (metis no_ub less_trans)
      apply (metis no_ub)
      done
  next
    case 4 thus ?thesis using Atom by(auto)(metis no_ub)
  next
    case 5 thus ?thesis using Atom by(auto)(metis no_ub)
  next
    case 8 thus ?thesis using Atom by(auto)(metis no_ub)
  qed (insert Atom, auto)
next
  case And thus ?case
    apply clarsimp
    apply(rule_tac x="min leps lepsa" in exI)
    apply simp
    done
next
  case Or thus ?case by force
qed simp_all

definition
"qe_eps\<^sub>1(\<phi>) =
(let as = DLO.atoms\<^sub>0 \<phi>; lbs = lbounds as; ebs = ebounds as
 in list_disj (inf\<^sub>- \<phi> # map (subst\<^sub>+ \<phi>) lbs @ map (subst \<phi>) ebs))"

theorem I_qe_eps1:
assumes "nqfree \<phi>" shows "DLO.I (qe_eps\<^sub>1 \<phi>) xs = (\<exists>x. DLO.I \<phi> (x#xs))"
  (is "?QE = ?EX")
proof
  let ?as = "DLO.atoms\<^sub>0 \<phi>" let ?ebs = "ebounds ?as"
  assume ?QE
  { assume "DLO.I (inf\<^sub>- \<phi>) xs"
    hence ?EX using \<open>?QE\<close> min_inf[of \<phi> xs] \<open>nqfree \<phi>\<close>
      by(auto simp add:qe_eps\<^sub>1_def amap_fm_list_disj)
  } moreover
  { assume "\<forall>i \<in> set ?ebs. \<not>DLO.I \<phi> (xs!i # xs)"
           "\<not> DLO.I (inf\<^sub>- \<phi>) xs"
    with \<open>?QE\<close> \<open>nqfree \<phi>\<close> obtain l where "DLO.I (subst\<^sub>+ \<phi> l) xs"
      by(fastforce simp: I_subst qe_eps\<^sub>1_def set_ebounds set_lbounds)
    then obtain leps where "DLO.I \<phi> (leps#xs)"
      using I_subst_peps[OF \<open>nqfree \<phi>\<close>] by fastforce
    hence ?EX .. }
  ultimately show ?EX by blast
next
  let ?as = "DLO.atoms\<^sub>0 \<phi>" let ?ebs = "ebounds ?as"
  assume ?EX
  then obtain x where x: "DLO.I \<phi> (x#xs)" ..
  { assume "DLO.I (inf\<^sub>- \<phi>) xs"
    hence ?QE using \<open>nqfree \<phi>\<close> by(auto simp:qe_eps\<^sub>1_def)
  } moreover
  { assume "\<exists>k \<in> set ?ebs. DLO.I (subst \<phi> k) xs"
    hence ?QE by(auto simp:qe_eps\<^sub>1_def) } moreover
  { assume "\<not> DLO.I (inf\<^sub>- \<phi>) xs"
    and "\<forall>k \<in> set ?ebs. \<not> DLO.I (subst \<phi> k) xs"
    hence noE: "\<forall>e \<in> EQ \<phi> xs. \<not> DLO.I \<phi> (e#xs)" using \<open>nqfree \<phi>\<close>
      by (auto simp:set_ebounds EQ_def I_subst nth_Cons' split:if_split_asm)
    hence "x \<notin> EQ \<phi> xs" using x by fastforce
    obtain l where "l \<in> LB \<phi> xs" "l < x"
      using LBex[OF \<open>nqfree \<phi>\<close> x \<open>\<not> DLO.I(inf\<^sub>- \<phi>) xs\<close> \<open>x \<notin> EQ \<phi> xs\<close>] ..
    have "\<exists>l\<in>LB \<phi> xs. l<x \<and> nolb \<phi> xs l x \<and>
            (\<forall>y. l < y \<and> y \<le> x \<longrightarrow> DLO.I \<phi> (y#xs))"
      using dense_interval[where P = "\<lambda>x. DLO.I \<phi> (x#xs)", OF finite_LB \<open>l\<in>LB \<phi> xs\<close> \<open>l<x\<close> x] x innermost_intvl[OF \<open>nqfree \<phi>\<close> _ _ \<open>x \<notin> EQ \<phi> xs\<close>]
      by (simp add:nolb_def)
    then obtain m
      where *: "Less (Suc m) 0 \<in> set ?as \<and> xs!m < x \<and> nolb \<phi> xs (xs!m) x
            \<and> (\<forall>y. xs!m < y \<and> y \<le> x \<longrightarrow> DLO.I \<phi> (y#xs))"
      by blast
    then have "DLO.I (subst\<^sub>+ \<phi> m) xs"
      using noE by(auto intro!: I_subst_peps2[OF \<open>nqfree \<phi>\<close>])
    with * have ?QE
      by(simp add:qe_eps\<^sub>1_def bex_Un set_lbounds set_ebounds) metis
  } ultimately show ?QE by blast
qed

lemma qfree_asubst_peps: "qfree (asubst\<^sub>+ k a)"
by(cases "(k,a)" rule:asubst_peps.cases) simp_all

lemma qfree_subst_peps: "nqfree \<phi> \<Longrightarrow> qfree (subst\<^sub>+ \<phi> k)"
by(induct \<phi>) (simp_all add:qfree_asubst_peps)

lemma qfree_qe_eps\<^sub>1: "nqfree \<phi> \<Longrightarrow> qfree(qe_eps\<^sub>1 \<phi>)"
apply(simp add:qe_eps\<^sub>1_def)
apply(rule qfree_list_disj)
apply (auto simp:qfree_min_inf qfree_subst_peps qfree_map_fm)
done

definition "qe_eps = DLO.lift_nnf_qe qe_eps\<^sub>1"

lemma qfree_qe_eps: "qfree(qe_eps \<phi>)"
by(simp add: qe_eps_def DLO.qfree_lift_nnf_qe qfree_qe_eps\<^sub>1)

lemma I_qe_eps: "DLO.I (qe_eps \<phi>) xs = DLO.I \<phi> xs"
by(simp add:qe_eps_def DLO.I_lift_nnf_qe qfree_qe_eps\<^sub>1 I_qe_eps1)

end


theory Stutter_Language
  imports Language
begin

inductive_set stutter :: "('a \<times> 'a) llist \<Rightarrow> ('a \<times> 'a) lan" for xs where
  self [simp, intro!]: "xs \<in> stutter xs"
| stutter_left [dest]: "ys \<frown> LCons (\<sigma>, \<sigma>') zs \<in> stutter xs \<Longrightarrow> ys \<frown> LCons (\<sigma>, \<sigma>) (LCons (\<sigma>, \<sigma>') zs) \<in> stutter xs"
| stutter_right [dest]: "ys \<frown> LCons (\<sigma>, \<sigma>') zs \<in> stutter xs \<Longrightarrow> ys \<frown> LCons (\<sigma>, \<sigma>') (LCons (\<sigma>', \<sigma>') zs) \<in> stutter xs"

definition Stutter :: "('a \<times> 'a) lan \<Rightarrow> ('a \<times> 'a) lan" ("_\<^sup>\<dagger>" [1000] 1000) where
  "X\<^sup>\<dagger> = \<Union>{stutter xs |xs. xs \<in> X}"

lemma stutter_self_eq: "xs = ys \<Longrightarrow> xs \<in> stutter ys"
  by (metis stutter.self)

lemma stutter_trans: "xs \<in> stutter ys \<Longrightarrow> ys \<in> stutter zs \<Longrightarrow> xs \<in> stutter zs"
proof (induct xs rule: stutter.induct)
  case self
  thus ?case .
next
  case (stutter_left ys \<sigma> \<sigma>' zs)
  from stutter_left(2)[OF stutter_left(3)]
  show ?case
    by (rule stutter.stutter_left)
next
  case (stutter_right ys \<sigma> \<sigma>' zs)
  from stutter_right(2)[OF stutter_right(3)]
  show ?case
    by (rule stutter.stutter_right)
qed

lemma stutter_lappend: "xs \<in> stutter xs' \<Longrightarrow> ys \<in> stutter ys' \<Longrightarrow> (xs \<frown> ys) \<in> stutter (xs' \<frown> ys')"
proof (induct xs rule: stutter.induct)
  case self
  thus ?case
  proof (induct ys rule: stutter.induct)
    case self
    show ?case
      by (metis stutter.self)
  next
    case (stutter_left ws \<sigma> \<sigma>' vs)
    thus ?case
      by (metis lappend_assoc stutter.stutter_left)
  next
    case (stutter_right ws \<sigma> \<sigma>' vs)
    thus ?case
      by (metis lappend_assoc stutter.stutter_right)
  qed
next
  case (stutter_left ws \<sigma> \<sigma>' vs)
  thus ?case
    by (metis lappend_assoc lappend_code(2) stutter.stutter_left)
next
  case (stutter_right ws \<sigma> \<sigma>' vs)
  thus ?case
    by (metis lappend_assoc lappend_code(2) stutter.stutter_right)
qed

lemma Stutter_iso: "X \<subseteq> Y \<Longrightarrow> X\<^sup>\<dagger> \<subseteq> Y\<^sup>\<dagger>"
  by (auto simp add: Stutter_def)

lemma Stutter_ext: "X \<subseteq> X\<^sup>\<dagger>"
  by (auto simp add: Stutter_def)

lemma Stutter_idem [simp]: "X\<^sup>\<dagger>\<^sup>\<dagger> = X\<^sup>\<dagger>"
proof -
  have "X\<^sup>\<dagger> \<subseteq> X\<^sup>\<dagger>\<^sup>\<dagger>"
    by (metis Stutter_ext)
  thus "X\<^sup>\<dagger>\<^sup>\<dagger> = X\<^sup>\<dagger>"
    by (auto dest: stutter_trans simp add: Stutter_def)
qed

lemma Stutter_union [simp]: "(X \<union> Y)\<^sup>\<dagger> = X\<^sup>\<dagger> \<union> Y\<^sup>\<dagger>"
  by (auto simp add: Stutter_def)

lemma Stutter_continuous: "(\<Union>\<XX>)\<^sup>\<dagger> = \<Union>{X\<^sup>\<dagger> |X. X \<in> \<XX>}"
  by (auto simp add: Stutter_def)

lemma Stutter_meet [simp]: "(X\<^sup>\<dagger> \<inter> Y\<^sup>\<dagger>)\<^sup>\<dagger> = X\<^sup>\<dagger> \<inter> Y\<^sup>\<dagger>"
  by (auto dest: stutter_trans simp add: Stutter_def)

lemma stutter_infinite [dest]: "ys \<in> stutter xs \<Longrightarrow> \<not> lfinite xs \<Longrightarrow> \<not> lfinite ys"
  by (induct ys rule: stutter.induct) auto

lemma stutter_l_prod: "stutter xs \<cdot> stutter ys \<subseteq> stutter (xs \<frown> ys)"
  apply (auto simp add: l_prod_def)
  apply (metis lappend_inf stutter.self stutter_lappend)
  by (metis stutter_lappend)

lemma stutter_LNil: "xs \<in> stutter LNil \<Longrightarrow> xs = LNil"
  by (induct rule: stutter.induct) auto

lemma Stutter_empty [simp]: "{}\<^sup>\<dagger> = {}"
  by (auto simp add: Stutter_def)

lemma llength_lefts_lappend1: "lfinite xs \<Longrightarrow> llength (\<ll> (xs \<frown> LCons (Inl y) ys)) = eSuc (llength (\<ll> (xs \<frown> ys)))"
proof (induct rule: lfinite_induct)
  case Nil show ?case by simp
next
  case (Cons x xs)
  thus ?case
    by (cases x) simp_all
qed

lemma llength_lefts_lappend2: "lfinite xs \<Longrightarrow> llength (\<ll> (xs \<frown> LCons (Inr y) ys)) = llength (\<ll> (xs \<frown> ys))"
proof (induct rule: lfinite_induct)
  case Nil show ?case by simp
next
  case (Cons x xs)
  thus ?case
    by (cases x) simp_all
qed

lemma llength_rights_lappend1: "lfinite xs \<Longrightarrow> llength (\<rr> (xs \<frown> LCons (Inr y) ys)) = eSuc (llength (\<rr> (xs \<frown> ys)))"
proof (induct rule: lfinite_induct)
  case Nil show ?case by simp
next
  case (Cons x xs)
  thus ?case
    by (cases x) simp_all
qed

lemma llength_rights_lappend2: "lfinite xs \<Longrightarrow> llength (\<rr> (xs \<frown> LCons (Inl y) ys)) = llength (\<rr> (xs \<frown> ys))"
proof (induct rule: lfinite_induct)
  case Nil show ?case by simp
next
  case (Cons x xs)
  thus ?case
    by (cases x) simp_all
qed

lemma traj_lappend [simp]: "traj (xs \<frown> ys) = traj xs \<frown> traj ys"
  by (auto simp add: traj_def lmap_lappend_distrib)

lemma ltakeWhile_traj_commute1: "traj (ltakeWhile is_right t) = ltakeWhile is_right (traj t)"
  by (simp add: ltakeWhile_lmap traj_def)

lemma ltakeWhile_traj_commute2: "traj (ltakeWhile is_left t) = ltakeWhile is_left (traj t)"
  by (simp add: ltakeWhile_lmap traj_def)

lemma ldropWhile_traj_commute1: "traj (ldropWhile is_right t) = ldropWhile is_right (traj t)"
  by (simp add: ldropWhile_lmap traj_def)

lemma ldropWhile_traj_commute2: "traj (ldropWhile is_left t) = ldropWhile is_left (traj t)"
  by (simp add: ldropWhile_lmap traj_def)

lemma llength_lefts_traj: "llength (\<ll> (traj t)) = llength (\<ll> t)"
  by (simp add: lefts_def traj_def lfilter_lmap)

lemma llength_rights_traj: "llength (\<rr> (traj t)) = llength (\<rr> t)"
  by (simp add: rights_def traj_def lfilter_lmap)

lemma [simp]: "llength (\<rr> (ltakeWhile is_right (traj t))) = llength (\<rr> (ltakeWhile is_right t))"
  by (metis llength_rights_traj ltakeWhile_traj_commute1)

lemma [simp]: "LCons x xs \<triangleright> LCons (Inl ()) t \<triangleleft> zs = LCons (Inl x) (xs \<triangleright> t \<triangleleft> zs)"
  by (metis interleave_left lhd_LCons ltl_simps(2))

lemma "x \<in> lset t \<Longrightarrow> (\<exists>t' t''. t = t' \<frown> LCons x t'')"
  by (metis split_llist_first)

lemma is_leftD: "is_left x \<Longrightarrow> (\<exists>x'. x = Inl x')"
  by (metis is_left.simps(2) swap.cases)

lemma ldropWhile_LNil_lappend: "lfinite xs \<Longrightarrow> ldropWhile is_right xs = LNil \<Longrightarrow> ldropWhile is_right (xs \<frown> ys) = ldropWhile is_right ys"
  apply (induct rule: lfinite_induct)
  apply simp_all
  by (metis ldropWhile_eq_LNil_iff llist.distinct(1) not_is_right)

lemma no_lefts_ldropWhile_is_right: "lfinite xs \<Longrightarrow> Inl () \<notin> lset xs \<Longrightarrow> ldropWhile is_right xs = LNil"
  apply (induct rule: lfinite_induct)
  apply simp_all
  by (metis (full_types) is_leftD not_is_left unit.exhaust)

lemma ldropWhile_is_right: "\<ll> t \<noteq> LNil \<Longrightarrow> ldropWhile is_right t = LCons (Inl ()) (ltl (ldropWhile is_right t))"
  apply (simp add: lefts_def)
  apply (erule bexE)
  apply (drule split_llist_first)
  apply (erule exE)+
  apply simp
  apply (drule is_leftD)
  apply (erule exE)
  apply simp
  apply (subgoal_tac "ldropWhile is_right ys = LNil")
  apply (metis (hide_lams, mono_tags) is_right.simps(2) ldropWhile_LCons ldropWhile_LNil_lappend ltl_simps(2))
  by (metis (full_types) no_lefts_ldropWhile_is_right)

lemma l_prod_fin: "(\<forall>xs\<in>X. lfinite xs) \<Longrightarrow> X \<cdot> Y = {xs \<frown> ys |xs ys. xs \<in> X \<and> ys \<in> Y}"
  by (auto simp add: l_prod_def)

lemma ltake_llength_rights:
  assumes "lfinite (ltakeWhile is_right t)"
  shows "lmap Inr (\<up> (llength (ltakeWhile is_right t)) (\<rr> t)) = \<up> (llength (ltakeWhile is_right t)) t"
proof -
  {
    fix x xs and t :: "('a + 'b) llist"
    have "LCons x xs = ltakeWhile is_right t \<Longrightarrow> xs = ltakeWhile is_right (ltl t)"
      by (metis llist.distinct(1) ltakeWhile_eq_LNil_iff ltl_ltakeWhile ltl_simps(2))
  } note helper = this

  {
    fix xs
    have "lfinite xs \<Longrightarrow> xs = ltakeWhile is_right t \<Longrightarrow> lmap Inr (\<up> (llength xs) (\<rr> t)) = \<up> (llength xs) t"
    proof (induct xs arbitrary: t rule: lfinite_induct)
      case (Nil t)
      thus ?case
        by simp
    next
      case (Cons x xs t)
      then obtain r and t' where [simp]: "t = LCons (Inr r) t'"
        by (metis is_right.simps(2) llist.discI ltakeWhile_LCons ltakeWhile_LNil sumlist_cases)
      hence [simp]: "ltl t = t'"
        by auto
      thus ?case
        by (simp add: Cons(2)[OF helper[OF Cons(3)], simplified])
    qed
  }
  from this and assms show ?thesis
    by metis
qed

lemma lefts_ldrop_rights: "\<ll> (\<down> (llength (ltakeWhile is_right t)) t) = \<ll> t"
  by (metis lappend_code(1) lappend_inf lappend_ltakeWhile_ldropWhile ldropWhile_eq_ldrop ldrop_eq_LNil lefts_LNil lefts_append lefts_ltake_right order_refl)

lemma lefts_ldrop_rights_var: "\<ll> t = LCons x (xs \<frown> LCons (\<sigma>, \<sigma>') ys) \<Longrightarrow> \<ll> (ltl (\<down> (llength (ltakeWhile is_right t)) t)) = xs \<frown> LCons (\<sigma>, \<sigma>') ys"
proof -
  assume "\<ll> t = LCons x (xs \<frown> LCons (\<sigma>, \<sigma>') ys)"
  moreover have "\<ll> (ltl (\<down> (llength (ltakeWhile is_right t)) t)) = ltl (\<ll> (\<down> (llength (ltakeWhile is_right t)) t))"
    apply (simp add: lefts_def)
    apply (subst ltl_lfilter)
    by (metis Not_is_left ldropWhile_eq_ldrop lefts_def_var lefts_ldrop_rights ltl_lfilter ltl_lmap)
  ultimately show ?thesis
    by (metis lefts_ldrop_rights ltl_simps(2))
qed

lemma lfilter_is_right_ltl_ltakeWhile:
  assumes "lfinite (ltakeWhile is_right t)"
  shows "lfilter is_right (ltl (\<down> (llength (ltakeWhile is_right t)) t)) = \<down> (llength (ltakeWhile is_right t)) (lfilter is_right t)"
proof -
  {
    fix x xs and t :: "('a + 'b) llist"
    have "LCons x xs = ltakeWhile is_right t \<Longrightarrow> xs = ltakeWhile is_right (ltl t)"
      by (metis llist.distinct(1) ltakeWhile_eq_LNil_iff ltl_ltakeWhile ltl_simps(2))
  } note helper = this

  {
    fix xs
    have "lfinite xs \<Longrightarrow> xs = ltakeWhile is_right t \<Longrightarrow> lfilter is_right (ltl (\<down> (llength xs) t)) = \<down> (llength xs) (lfilter is_right t)"
    proof (induct arbitrary: t rule: lfinite_induct)
      case (Nil t)
      thus ?case
        by simp (metis (full_types) LNil_eq_llist_map lfilter_LCons llist.case_conv_if llist.collapse ltakeWhile_eq_LNil_iff ltl_def)
    next
      case (Cons x xs t)
      then obtain r and t' where [simp]: "t = LCons (Inr r) t'"
        by (metis is_right.simps(2) llist.discI ltakeWhile_LCons ltakeWhile_LNil sumlist_cases)
      hence [simp]: "ltl t = t'"
        by auto
      thus ?case
        by (simp add: Cons(2)[OF helper[OF Cons(3)], simplified])
    qed
  }
  from this and assms show ?thesis
    by metis
qed

lemmas ldrop_to_ldropWhile[simp] = ldropWhile_eq_ldrop[symmetric]

lemma "xs \<noteq> LNil \<Longrightarrow> xs = LCons (lhd xs) (ltl xs)"
  by (metis llist.collapse)

lemma lmap_unl_to_Inl [simp]: "lmap unl (lfilter is_left xs) = ys \<longleftrightarrow> lfilter is_left xs = lmap Inl ys"
  apply (rule antisym)
  apply auto
  apply (subst lmap_lfilter_eq[where g = id])
  apply (metis DEADID.map_id is_leftD unl.simps(1))
  by simp

lemma drop_rights: "\<ll> t = LCons x xs \<Longrightarrow> ldropWhile is_right t = LCons (Inl x) (ltl (ldropWhile is_right t))"
  apply (simp add: lefts_def)
  apply (subgoal_tac "lhd (lfilter is_left t) = Inl x")
  apply simp
  apply (subst llist.collapse[symmetric])
  apply simp_all
  apply (rule_tac x = "Inl x" in bexI)
  apply auto
  apply (metis in_lset_ldropWhileD lfilter_eq_LCons lhd_LCons lhd_in_lset llist.distinct(1))
  by (metis Not_is_left lhd_LCons lhd_lfilter)

lemma drop_rights_var: "\<ll> t = LCons x xs \<Longrightarrow> \<down> (llength (ltakeWhile is_right t)) t = LCons (Inl x) (ltl (\<down> (llength (ltakeWhile is_right t)) t))"
  apply simp
  by (metis drop_rights)

lemma singleton_lappend_Inr: "lfinite xs \<Longrightarrow> t \<in> {lmap Inr xs} \<cdot> ys \<Longrightarrow> \<down> (llength xs) t \<in> ys"
  apply (induct arbitrary: t rule: lfinite_induct)
  apply simp
  apply (auto simp add: l_prod_def)
  by metis

lemma ldrop_eq_LCons: "\<down> n xs = LCons y ys \<Longrightarrow> \<down> (eSuc n) xs = ys"
  by (metis ldrop_ltl ltl_ldrop ltl_simps(2))

lemma [simp]: "llength (\<rr> (ltakeWhile is_right t)) = llength (ltakeWhile is_right t)"
  by (auto simp add: rights_def) (metis lfilter_empty_conv lfilter_left_right lset_ltakeWhileD not_is_right)

lemma [simp]: "ltakeWhile is_right (traj t) = traj (ltakeWhile is_right t)"
  by (metis ltakeWhile_traj_commute1)

lemma [simp]: "(LNil \<triangleright> traj (ltakeWhile is_right t) \<triangleleft> \<up> (llength (ltakeWhile is_right t)) ys) = lmap Inr (\<up> (llength (ltakeWhile is_right t)) ys)"
  sorry

lemma [simp]: "lfinite (ltakeWhile is_right xs) \<Longrightarrow> llength (\<ll> (traj (ltakeWhile is_right xs) \<frown> ys)) = llength (\<ll> ys)"

lemma length_ge_0_lfinite_ltakeWhile: "0 < llength (\<ll> xs) \<Longrightarrow> lfinite (ltakeWhile is_right xs)"
  by (simp add: lefts_def) (metis lfinite_ltakeWhile not_is_right)

lemma length_ge_e0_lfinite_ltakeWhile: "enat 0 < llength (\<ll> xs) \<Longrightarrow> lfinite (ltakeWhile is_right xs)"
  by (simp add: lefts_def enat_0) (metis lfinite_ltakeWhile not_is_right)

(*
lemma "enat n < llength (\<ll> xs) \<Longrightarrow> llength (\<ll> (linsertLeft_nat n x xs)) = eSuc (llength (\<ll> xs))"
proof (induct n)
  case 0
  hence "llength (\<ll> (ltakeWhile is_right xs \<frown> LCons (Inl x) (ldropWhile is_right xs))) = llength (\<ll> (LCons (Inl x) (ltakeWhile is_right xs \<frown> ldropWhile is_right xs)))"
    by (metis lefts_LConsl length_ge_0_lfinite_ltakeWhile llength_LCons llength_lefts_lappend1 zero_enat_def)
  also have "... = eSuc (llength (\<ll> xs))"
    by (metis lappend_ltakeWhile_ldropWhile lefts_LConsl llength_LCons)
  finally show ?case
    by simp
next

*)

lemma stutter_left_in_left:
  assumes "t \<in> (xs \<frown> LCons (\<sigma>,\<sigma>') ys) \<sha> zs"
  shows "lmap \<langle>id,id\<rangle> (xs \<frown> LCons (\<sigma>,\<sigma>) (LCons (\<sigma>,\<sigma>') ys) \<triangleright> linsertLeft (llength xs) () (traj t) \<triangleleft> zs) \<in> stutter (lmap \<langle>id,id\<rangle> (xs \<frown> LCons (\<sigma>,\<sigma>') ys \<triangleright> traj t \<triangleleft> zs))"
proof (cases "llength xs")
  assume "llength xs = \<infinity>"
  from this and assms
  show ?thesis
    by (auto intro: sumlist_cases[of t] simp add: traj_def interleave_left interleave_right)
next
  fix n
  assume "llength xs = enat n"
  hence xs_fin: "lfinite xs"
    by (metis lfinite_conv_llength_enat)
  from this and assms
  show ?thesis
  proof (induct xs arbitrary: t zs rule: lfinite_induct)
    case (Nil t zs)

    have t_lefts [simp]: "\<ll> t = LCons (\<sigma>, \<sigma>') ys"
      by (metis (lifting, full_types) Nil.prems lappend_code(1) mem_Collect_eq tshuffle_words_def)

    have t_rights[simp]: "\<rr> t = zs"
      by (metis (lifting, full_types) Nil.prems mem_Collect_eq tshuffle_words_def)

    have lem: "ldropWhile is_right (traj t) = LCons (Inl ()) (ltl (ldropWhile is_right (traj t)))"
      apply (rule ldropWhile_is_right)
      by (metis co.enat.discI llength_LCons llength_LNil llength_lefts_traj t_lefts)

    have "lfinite (ltakeWhile is_right (traj t))"
      apply (subst lfinite_ltakeWhile)
      apply (intro disjI2)
      apply auto
      apply (rule_tac x = "Inl ()" in bexI)
      apply simp_all
      by (metis (full_types) in_lset_ldropWhileD lem lset_intros(1))

    show ?case
      apply (simp add: enat_0[symmetric])
      apply (subst interleave_append_llength)
      apply (metis `lfinite (ltakeWhile is_right (traj t))` lappend_code(1) ldrop_to_ldropWhile lefts_LConsl lefts_append lefts_ldrop_rights lefts_ltake_right llength_LCons llength_lefts_traj ltakeWhile_traj_commute1 t_lefts)
      apply (metis `lfinite (ltakeWhile is_right (traj t))` lappend_ltakeWhile_ldropWhile llength_rights_lappend2 llength_rights_traj ltakeWhile_traj_commute1 t_rights)
      apply (simp add: llength_rights_lappend2[OF `lfinite (ltakeWhile is_right (traj t))`])
      apply simp
      apply (subst lappend_ltakeWhile_ldropWhile[symmetric, of t is_right]) back back back
      apply (simp only: traj_lappend)
      apply (subst interleave_append_llength)
      apply simp
      apply simp
      apply simp
      apply (subst lmap_lappend_distrib)
      apply (subst lmap_lappend_distrib)
      apply (rule stutter_lappend)
      apply (rule stutter_self_eq)
      apply (metis ltakeWhile_traj_commute1)
      apply (subst lem)
      apply (subst ldropWhile_traj_commute1)
      apply (subst lem) back
      apply simp
      apply (rule stutter_left[where ys = LNil, simplified])
      by (rule stutter.self)
  next
    case (Cons x xs t zs)

    have [simp]: "lfinite (ltakeWhile is_right t)"
      sorry

    have "t \<in> LCons x (xs \<frown> LCons (\<sigma>, \<sigma>') ys) \<sha> zs"
      by (metis Cons.prems lappend_code(2))
    hence "t \<in> {lmap Inr (\<up> (llength (ltakeWhile is_right t)) zs)} \<cdot> (LCons (Inl x) ` ((xs \<frown> LCons (\<sigma>, \<sigma>') ys) \<sha> (\<down> (llength (ltakeWhile is_right t)) zs)))"
      apply (auto simp add: tshuffle_words_def image_def)
      apply (subst l_prod_fin)
      apply simp
      apply (intro disjI2)
      apply (metis (hide_lams, no_types) lappend_inf lappend_ltakeWhile_ldropWhile lefts_ltake_right lfinite_llength_enat neq_LNil_conv)
      apply auto
      apply (subst ltake_llength_rights)
      apply (metis lappend_inf lappend_ltakeWhile_ldropWhile lefts_ltake_right neq_LNil_conv)
      apply (rule_tac x = "\<down> (llength (ltakeWhile is_right t)) t" in exI)
      apply (intro conjI)
      apply (metis lappend_ltake_ldrop)
      apply (rule_tac x = "ltl (\<down> (llength (ltakeWhile is_right t)) t)" in exI)
      apply (intro conjI)
      apply (metis lefts_ldrop_rights_var)
      apply (simp del: ldrop_to_ldropWhile add: rights_def)
      apply (rule arg_cong) back
      apply (rule lfilter_is_right_ltl_ltakeWhile)
      apply (metis lappend_inf lappend_ltakeWhile_ldropWhile lefts_ltake_right neq_LNil_conv)
      by (metis drop_rights_var)
    moreover from Cons(3) have "lfinite (\<up> (llength (ltakeWhile is_right t)) zs)"
      by (auto simp add: tshuffle_words_def) (metis lefts_ltake_right llength_ltakeWhile_eq_infinity neq_LNil_conv)
    ultimately obtain zs' zs''
    where "t \<in> {lmap Inr zs'} \<cdot> (LCons (Inl x) ` ((xs \<frown> LCons (\<sigma>, \<sigma>') ys) \<sha> zs''))"
    and zs'_def: "zs' = \<up> (llength (ltakeWhile is_right t)) zs"
    and zs''_def: "zs'' = \<down> (llength (ltakeWhile is_right t)) zs"
    and "lfinite zs'"
      by auto
    hence "\<down> (eSuc (llength zs')) t \<in> (xs \<frown> LCons (\<sigma>, \<sigma>') ys) \<sha> zs''"
      apply -
      apply (drule singleton_lappend_Inr[where xs = zs', OF `lfinite zs'`])
      apply (auto simp add: image_def)
      apply (metis (mono_tags) zs''_def ldrop_eq_LCons)
      by (metis (full_types) ldrop_eq_LCons)
    from Cons(2)[OF this]
    have "lmap \<langle>id,id\<rangle> (xs \<frown>  LCons (\<sigma>, \<sigma>) (LCons (\<sigma>, \<sigma>') ys) \<triangleright> linsertLeft (llength xs) () (traj (\<down> (eSuc (llength zs')) t)) \<triangleleft> zs'')
          \<in> stutter (lmap \<langle>id,id\<rangle> (xs \<frown> LCons (\<sigma>, \<sigma>') ys \<triangleright> traj (\<down> (eSuc (llength zs')) t) \<triangleleft> zs''))"
      by simp
    have "lmap \<langle>id,id\<rangle> (LCons x xs \<frown> LCons (\<sigma>, \<sigma>) (LCons (\<sigma>, \<sigma>') ys) \<triangleright> linsertLeft (llength (LCons x xs)) () (traj t) \<triangleleft> zs)
          = lmap \<langle>id,id\<rangle> (LCons x (xs \<frown> LCons (\<sigma>, \<sigma>) (LCons (\<sigma>, \<sigma>') ys)) \<triangleright> linsertLeft (llength (LCons x xs)) () (traj t) \<triangleleft> zs)"
      by (metis lappend_code(2))
    also have "... = lmap \<langle>id,id\<rangle> (LCons x (xs \<frown> LCons (\<sigma>, \<sigma>) (LCons (\<sigma>, \<sigma>') ys)) \<triangleright> linsertLeft (eSuc (llength xs)) () (traj t) \<triangleleft> zs)"
      by simp
    also have "... = lmap \<langle>id,id\<rangle> (LCons x (xs \<frown> LCons (\<sigma>, \<sigma>) (LCons (\<sigma>, \<sigma>') ys)) \<triangleright> ltakeWhile is_right (traj t) \<frown> LCons (Inl ()) (linsertLeft (llength xs) () (ltl (ldropWhile is_right (traj t)))) \<triangleleft> zs)"
      apply (simp add: linsertLeft_eSuc llist_Case_def)
      apply (subgoal_tac "ldropWhile is_right (traj t) = LCons (Inl ()) (ltl (ldropWhile is_right (traj t)))")
      apply (erule ssubst)
      apply simp
      sorry
    also have "... = lmap \<langle>id,id\<rangle> (lmap Inr (\<up> (llength (ltakeWhile is_right t)) zs) \<frown> LCons (Inl x) (xs \<frown> LCons (\<sigma>, \<sigma>) (LCons (\<sigma>, \<sigma>') ys) \<triangleright> linsertLeft (llength xs) () (ltl (ldropWhile is_right (traj t))) \<triangleleft> \<down> (llength (\<rr> (ltakeWhile is_right t))) zs))"
      apply (subst interleave_append_llength)
      apply simp_all
      sledgehammer

    show "lmap \<langle>id,id\<rangle> (LCons x xs \<frown> LCons (\<sigma>, \<sigma>) (LCons (\<sigma>, \<sigma>') ys) \<triangleright> linsertLeft (llength (LCons x xs)) () (traj t) \<triangleleft> zs)
          \<in> stutter (lmap \<langle>id,id\<rangle> (LCons x xs \<frown> LCons (\<sigma>, \<sigma>') ys \<triangleright> traj t \<triangleleft> zs))"
      sorry
  qed
qed

lemma shuffle_stutter1: "X\<^sup>\<dagger> \<parallel> Y \<subseteq> (X \<parallel> Y)\<^sup>\<dagger>"
proof -
  have "X\<^sup>\<dagger> \<parallel> Y = \<Union>(stutter ` X) \<parallel> Y"
    by (rule arg_cong, auto simp add: Stutter_def image_def)
  also have "... = \<Union>{stutter xs \<parallel> Y |xs. xs \<in> X}"
    by (subst trans[OF shuffle_comm shuffle_inf_dist], subst shuffle_comm, auto)
  also have "... = \<Union>{\<Union>{lmap \<langle>id,id\<rangle> ` (xs' \<sha> ys) |xs' ys. xs' \<in> stutter xs \<and> ys \<in> Y} |xs. xs \<in> X}"
    by (simp add: shuffle_def)
  also have "... = \<Union>{\<Union>{lmap \<langle>id,id\<rangle> ` (xs' \<sha> ys) |xs'. xs' \<in> stutter xs} |xs ys. xs \<in> X \<and> ys \<in> Y}"
    by blast
  also have "... \<subseteq> \<Union>{(lmap \<langle>id,id\<rangle> ` (xs \<sha> ys))\<^sup>\<dagger> |xs ys. xs \<in> X \<and> ys \<in> Y}"
    sorry

end


(*  Title:       Conflict analysis/Main Result
    Author:      Peter Lammich <peter.lammich@uni-muenster.de>
    Maintainer:  Peter Lammich <peter.lammich@uni-muenster.de>
*)
section "Main Result"
theory MainResult
imports ConstraintSystems
begin
text_raw \<open>\label{thy:MainResult}\<close>

text \<open>At this point everything is available to prove the main result of this project:
  {\em The constraint system @{term RUV_cs} precisely characterizes simultaneously reachable control nodes w.r.t. to our
  semantic reference point.}

  The ,,trusted base'' of this proof, that are all definitions a reader that trusts the Isabelle prover must additionally trust, is the following:
  \begin{itemize}
    \item The flowgraph and the assumptions made on it in the \<open>flowgraph\<close>- and \<open>eflowgraph\<close>-locales. Note that we show in Section~\ref{sec:Flowgraph:ex_flowgraph}
      that there is at least one non-trivial model of \<open>eflowgraph\<close>.
    \item The reference point semantics (@{term refpoint}) and the transitive closure operator (@{term trcl}).
    \item The definition of @{term atUV}.
    \item All dependencies of the above definitions in the Isabelle standard libraries.
  \end{itemize}
\<close>
theorem (in eflowgraph) RUV_is_sim_reach:
  "(\<exists>w c'. ({#[entry fg (main fg)]#},w,c')\<in>trcl (refpoint fg) \<and> atUV U V c')
    \<longleftrightarrow> (\<exists>Ml Me. (entry fg (main fg),Ml,Me)\<in>RUV_cs fg U V)"
\<comment> \<open>The proof uses the soundness and precision theorems wrt. to normalized paths (@{thm [source] flowgraph.RUV_sound}, @{thm [source] flowgraph.RUV_precise}) as well as the normalization result,
  i.e. that every reachable configuration is also reachable using a normalized path (@{thm [source] eflowgraph.normalize}) and, vice versa, that every normalized path is also a usual path (@{thm [source] ntr_is_tr}).
  Finally the conversion between our working semantics and the semantic reference point is exploited (@{thm [source] flowgraph.refpoint_eq}).\<close>
  (is "?lhs \<longleftrightarrow> ?rhs")
proof
  assume ?lhs
  then obtain w c' where C: "({#[entry fg (main fg)]#}, w, c') \<in> trcl (tr fg)" "atUV U V c'" by (auto simp add: refpoint_eq)
  from normalize[OF C(1), of "main fg", simplified] obtain ww where "({#[entry fg (main fg)]#}, ww, c') \<in> trcl (ntr fg)" by blast
  from ntrs.gtr2gtrp[where c="{#}", simplified, OF this] obtain s' ce' wwl where 1: "c'=add_mset s' ce'" "ww = map le_rem_s wwl" "(([entry fg (main fg)], {#}), wwl, s', ce') \<in> trcl (ntrp fg)" by blast
  with C(2) have 2: "atUV U V ({#s'#}+ce')" by auto
  from RUV_sound[OF 1(3) 2] show ?rhs by blast
next
  assume ?rhs
  then obtain Ml Me where C: "(entry fg (main fg), Ml, Me) \<in> RUV_cs fg U V" by blast
  from RUV_precise[OF C] obtain wwl s' c' where P: "(([entry fg (main fg)], {#}), wwl, s', c') \<in> trcl (ntrp fg)" "atUV U V ({#s'#} + c')" by blast
  from gtrp2gtr[OF P(1)] have "({# [entry fg (main fg)] #}, map le_rem_s wwl, {#s'#}+c') \<in> trcl (ntr fg)" by (auto)
  from ntr_is_tr[OF this] P(2) have "\<exists>w c'. ({#[entry fg (main fg)]#}, w, c') \<in> trcl (tr fg) \<and> atUV U V c'" by blast
  thus ?lhs by (simp add: refpoint_eq)
qed

end


(*
    Author:   Benedikt Seidl
    License:  BSD
*)

section \<open>Quotient Type Emulation for Locales\<close>

theory Quotient_Type
imports
  Main
begin

locale quotient =
  fixes
    eq :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
  and
    Rep :: "'b \<Rightarrow> 'a"
  and
    Abs :: "'a \<Rightarrow> 'b"
  assumes
    Rep_inverse: "Abs (Rep a) = a"
  and
    Abs_eq: "Abs x = Abs y \<longleftrightarrow> eq x y"
begin

lemma Rep_inject:
  "Rep x = Rep y \<longleftrightarrow> x = y"
  by (metis Rep_inverse)

lemma Rep_Abs_eq:
  "eq x (Rep (Abs x))"
  by (metis Abs_eq Rep_inverse)

end

end