(*  Title:      HOL/HOLCF/IOA/Seq.thy
    Author:     Olaf Müller
*)

section \<open>Partial, Finite and Infinite Sequences (lazy lists), modeled as domain\<close>

theory Seq
imports "../HOLCF"
begin

default_sort pcpo

domain (unsafe) 'a seq = nil  ("nil") | cons (HD :: 'a) (lazy TL :: "'a seq")  (infixr "##" 65)

inductive Finite :: "'a seq \<Rightarrow> bool"
where
  sfinite_0: "Finite nil"
| sfinite_n: "Finite tr \<Longrightarrow> a \<noteq> UU \<Longrightarrow> Finite (a ## tr)"

declare Finite.intros [simp]

definition Partial :: "'a seq \<Rightarrow> bool"
  where "Partial x \<longleftrightarrow> seq_finite x \<and> \<not> Finite x"

definition Infinite :: "'a seq \<Rightarrow> bool"
  where "Infinite x \<longleftrightarrow> \<not> seq_finite x"

subsection \<open>Recursive equations of operators\<close>

subsubsection \<open>\<open>smap\<close>\<close>

fixrec smap :: "('a \<rightarrow> 'b) \<rightarrow> 'a seq \<rightarrow> 'b seq"
where
  smap_nil: "smap \<cdot> f \<cdot> nil = nil"
| smap_cons: "x \<noteq> UU \<Longrightarrow> smap \<cdot> f \<cdot> (x ## xs) = (f \<cdot> x) ## smap \<cdot> f \<cdot> xs"

lemma smap_UU [simp]: "smap \<cdot> f \<cdot> UU = UU"
  by fixrec_simp

subsubsection \<open>\<open>sfilter\<close>\<close>

fixrec sfilter :: "('a \<rightarrow> tr) \<rightarrow> 'a seq \<rightarrow> 'a seq"
where
  sfilter_nil: "sfilter \<cdot> P \<cdot> nil = nil"
| sfilter_cons:
    "x \<noteq> UU \<Longrightarrow>
      sfilter \<cdot> P \<cdot> (x ## xs) =
      (If P \<cdot> x then x ## (sfilter \<cdot> P \<cdot> xs) else sfilter \<cdot> P \<cdot> xs)"

lemma sfilter_UU [simp]: "sfilter \<cdot> P \<cdot> UU = UU"
  by fixrec_simp

subsubsection \<open>\<open>sforall2\<close>\<close>

fixrec sforall2 :: "('a \<rightarrow> tr) \<rightarrow> 'a seq \<rightarrow> tr"
where
  sforall2_nil: "sforall2 \<cdot> P \<cdot> nil = TT"
| sforall2_cons: "x \<noteq> UU \<Longrightarrow> sforall2 \<cdot> P \<cdot> (x ## xs) = ((P \<cdot> x) andalso sforall2 \<cdot> P \<cdot> xs)"

lemma sforall2_UU [simp]: "sforall2 \<cdot> P \<cdot> UU = UU"
  by fixrec_simp

definition "sforall P t \<longleftrightarrow> sforall2 \<cdot> P \<cdot> t \<noteq> FF"

subsubsection \<open>\<open>stakewhile\<close>\<close>

fixrec stakewhile :: "('a \<rightarrow> tr) \<rightarrow> 'a seq \<rightarrow> 'a seq"
where
  stakewhile_nil: "stakewhile \<cdot> P \<cdot> nil = nil"
| stakewhile_cons:
    "x \<noteq> UU \<Longrightarrow> stakewhile \<cdot> P \<cdot> (x ## xs) = (If P \<cdot> x then x ## (stakewhile \<cdot> P \<cdot> xs) else nil)"

lemma stakewhile_UU [simp]: "stakewhile \<cdot> P \<cdot> UU = UU"
  by fixrec_simp

subsubsection \<open>\<open>sdropwhile\<close>\<close>

fixrec sdropwhile :: "('a \<rightarrow> tr) \<rightarrow> 'a seq \<rightarrow> 'a seq"
where
  sdropwhile_nil: "sdropwhile \<cdot> P \<cdot> nil = nil"
| sdropwhile_cons:
    "x \<noteq> UU \<Longrightarrow> sdropwhile \<cdot> P \<cdot> (x ## xs) = (If P \<cdot> x then sdropwhile \<cdot> P \<cdot> xs else x ## xs)"

lemma sdropwhile_UU [simp]: "sdropwhile \<cdot> P \<cdot> UU = UU"
  by fixrec_simp

subsubsection \<open>\<open>slast\<close>\<close>

fixrec slast :: "'a seq \<rightarrow> 'a"
where
  slast_nil: "slast \<cdot> nil = UU"
| slast_cons: "x \<noteq> UU \<Longrightarrow> slast \<cdot> (x ## xs) = (If is_nil \<cdot> xs then x else slast \<cdot> xs)"

lemma slast_UU [simp]: "slast \<cdot> UU = UU"
  by fixrec_simp

subsubsection \<open>\<open>sconc\<close>\<close>

fixrec sconc :: "'a seq \<rightarrow> 'a seq \<rightarrow> 'a seq"
where
  sconc_nil: "sconc \<cdot> nil \<cdot> y = y"
| sconc_cons': "x \<noteq> UU \<Longrightarrow> sconc \<cdot> (x ## xs) \<cdot> y = x ## (sconc \<cdot> xs \<cdot> y)"

abbreviation sconc_syn :: "'a seq \<Rightarrow> 'a seq \<Rightarrow> 'a seq"  (infixr "@@" 65)
  where "xs @@ ys \<equiv> sconc \<cdot> xs \<cdot> ys"

lemma sconc_UU [simp]: "UU @@ y = UU"
  by fixrec_simp

lemma sconc_cons [simp]: "(x ## xs) @@ y = x ## (xs @@ y)"
  by (cases "x = UU") simp_all

declare sconc_cons' [simp del]

subsubsection \<open>\<open>sflat\<close>\<close>

fixrec sflat :: "'a seq seq \<rightarrow> 'a seq"
where
  sflat_nil: "sflat \<cdot> nil = nil"
| sflat_cons': "x \<noteq> UU \<Longrightarrow> sflat \<cdot> (x ## xs) = x @@ (sflat \<cdot> xs)"

lemma sflat_UU [simp]: "sflat \<cdot> UU = UU"
  by fixrec_simp

lemma sflat_cons [simp]: "sflat \<cdot> (x ## xs) = x @@ (sflat \<cdot> xs)"
  by (cases "x = UU") simp_all

declare sflat_cons' [simp del]

subsubsection \<open>\<open>szip\<close>\<close>

fixrec szip :: "'a seq \<rightarrow> 'b seq \<rightarrow> ('a \<times> 'b) seq"
where
  szip_nil: "szip \<cdot> nil \<cdot> y = nil"
| szip_cons_nil: "x \<noteq> UU \<Longrightarrow> szip \<cdot> (x ## xs) \<cdot> nil = UU"
| szip_cons: "x \<noteq> UU \<Longrightarrow> y \<noteq> UU \<Longrightarrow> szip \<cdot> (x ## xs) \<cdot> (y ## ys) = (x, y) ## szip \<cdot> xs \<cdot> ys"

lemma szip_UU1 [simp]: "szip \<cdot> UU \<cdot> y = UU"
  by fixrec_simp

lemma szip_UU2 [simp]: "x \<noteq> nil \<Longrightarrow> szip \<cdot> x \<cdot> UU = UU"
  by (cases x) (simp_all, fixrec_simp)

subsection \<open>\<open>scons\<close>, \<open>nil\<close>\<close>

lemma scons_inject_eq: "x \<noteq> UU \<Longrightarrow> y \<noteq> UU \<Longrightarrow> x ## xs = y ## ys \<longleftrightarrow> x = y \<and> xs = ys"
  by simp

lemma nil_less_is_nil: "nil \<sqsubseteq> x \<Longrightarrow> nil = x"
  by (cases x) simp_all

subsection \<open>\<open>sfilter\<close>, \<open>sforall\<close>, \<open>sconc\<close>\<close>

lemma if_and_sconc [simp]:
  "(if b then tr1 else tr2) @@ tr = (if b then tr1 @@ tr else tr2 @@ tr)"
  by simp

lemma sfiltersconc: "sfilter \<cdot> P \<cdot> (x @@ y) = (sfilter \<cdot> P \<cdot> x @@ sfilter \<cdot> P \<cdot> y)"
  apply (induct x)
  text \<open>adm\<close>
  apply simp
  text \<open>base cases\<close>
  apply simp
  apply simp
  text \<open>main case\<close>
  apply (rule_tac p = "P\<cdot>a" in trE)
  apply simp
  apply simp
  apply simp
  done

lemma sforallPstakewhileP: "sforall P (stakewhile \<cdot> P \<cdot> x)"
  apply (simp add: sforall_def)
  apply (induct x)
  text \<open>adm\<close>
  apply simp
  text \<open>base cases\<close>
  apply simp
  apply simp
  text \<open>main case\<close>
  apply (rule_tac p = "P\<cdot>a" in trE)
  apply simp
  apply simp
  apply simp
  done

lemma forallPsfilterP: "sforall P (sfilter \<cdot> P \<cdot> x)"
  apply (simp add: sforall_def)
  apply (induct x)
  text \<open>adm\<close>
  apply simp
  text \<open>base cases\<close>
  apply simp
  apply simp
  text \<open>main case\<close>
  apply (rule_tac p="P\<cdot>a" in trE)
  apply simp
  apply simp
  apply simp
  done

subsection \<open>Finite\<close>

(*
  Proofs of rewrite rules for Finite:
    1. Finite nil    (by definition)
    2. \<not> Finite UU
    3. a \<noteq> UU \<Longrightarrow> Finite (a ## x) = Finite x
*)

lemma Finite_UU_a: "Finite x \<longrightarrow> x \<noteq> UU"
  apply (rule impI)
  apply (erule Finite.induct)
   apply simp
  apply simp
  done

lemma Finite_UU [simp]: "\<not> Finite UU"
  using Finite_UU_a [where x = UU] by fast

lemma Finite_cons_a: "Finite x \<longrightarrow> a \<noteq> UU \<longrightarrow> x = a ## xs \<longrightarrow> Finite xs"
  apply (intro strip)
  apply (erule Finite.cases)
  apply fastforce
  apply simp
  done

lemma Finite_cons: "a \<noteq> UU \<Longrightarrow> Finite (a##x) \<longleftrightarrow> Finite x"
  apply (rule iffI)
  apply (erule (1) Finite_cons_a [rule_format])
  apply fast
  apply simp
  done

lemma Finite_upward: "Finite x \<Longrightarrow> x \<sqsubseteq> y \<Longrightarrow> Finite y"
  apply (induct arbitrary: y set: Finite)
  apply (case_tac y, simp, simp, simp)
  apply (case_tac y, simp, simp)
  apply simp
  done

lemma adm_Finite [simp]: "adm Finite"
  by (rule adm_upward) (rule Finite_upward)

subsection \<open>Induction\<close>

text \<open>Extensions to Induction Theorems.\<close>

lemma seq_finite_ind_lemma:
  assumes "\<And>n. P (seq_take n \<cdot> s)"
  shows "seq_finite s \<longrightarrow> P s"
  apply (unfold seq.finite_def)
  apply (intro strip)
  apply (erule exE)
  apply (erule subst)
  apply (rule assms)
  done

lemma seq_finite_ind:
  assumes "P UU"
    and "P nil"
    and "\<And>x s1. x \<noteq> UU \<Longrightarrow> P s1 \<Longrightarrow> P (x ## s1)"
  shows "seq_finite s \<longrightarrow> P s"
  apply (insert assms)
  apply (rule seq_finite_ind_lemma)
  apply (erule seq.finite_induct)
   apply assumption
  apply simp
  done

end


(*  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 \<open>langford_data.ML\<close>
ML_file \<open>ferrante_rackoff_data.ML\<close>

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 (\<le>) (<)"
  by (rule unbounded_dense_linorder_axioms)
lemma atoms[no_atp]:
  shows "TERM (less :: 'a \<Rightarrow> _)"
    and "TERM (less_eq :: 'a \<Rightarrow> _)"
    and "TERM ((=) :: '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 \<open>langford.ML\<close>
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  ("'(\<sqsubseteq>')") and
  less_eq  ("(_/ \<sqsubseteq> _)" [51, 51] 50) and
  less  ("'(\<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 ((=) :: '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>\<open>(\<sqsubset>)\<close>, \<^term>\<open>(\<sqsubseteq>)\<close>]
      fun h x t =
        case Thm.term_of t of
          \<^Const_>\<open>HOL.eq _ for y z\<close> =>
            if Thm.term_of x aconv y then Ferrante_Rackoff_Data.Eq
            else Ferrante_Rackoff_Data.Nox
       | \<^Const_>\<open>Not for \<^Const>\<open>HOL.eq _ for y z\<close>\<close> =>
            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 \<open>ferrante_rackoff.ML\<close>

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
  "(\<le>)" "(<)" "\<lambda>x y. 1/2 * ((x::'a::linordered_field) + y)"
  by unfold_locales (dlo, dlo, auto)

declaration \<open>
let
  fun earlier [] _ = 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 earlier_ord vs (x, y) =
    if x aconvc y then EQUAL
    else if earlier vs (x, y) then LESS
    else GREATER;

fun dest_frac ct =
  case Thm.term_of ct of
    \<^Const_>\<open>Rings.divide _ for a b\<close> =>
      Rat.make (snd (HOLogic.dest_number a), snd (HOLogic.dest_number b))
  | \<^Const_>\<open>inverse _ for a\<close> => 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_>\<open>plus _ for \<^Const_>\<open>times _ for _ y\<close> _\<close> =>
     if y aconv Thm.term_of x then ("c*x+t",[(funpow 2 Thm.dest_arg1) ct, Thm.dest_arg ct])
     else ("Nox",[])
| \<^Const_>\<open>plus _ for y _\<close> =>
     if y aconv Thm.term_of x then ("x+t",[Thm.dest_arg ct])
     else ("Nox",[])
| \<^Const_>\<open>times _ for _ y\<close> =>
     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_>\<open>less _ for _ \<^Const_>\<open>zero_class.zero _\<close>\<close> =>
    (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>\<open>Trueprop\<close>
                  (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_ord 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_ord 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>\<open>Trueprop\<close>
                  (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_>\<open>less_eq _ for _ \<^Const_>\<open>zero_class.zero _\<close>\<close> =>
   (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>\<open>less T\<close>
        val cz = Thm.dest_arg ct
        val neg = cr < @0
        val cthp = Simplifier.rewrite ctxt
               (Thm.apply \<^cterm>\<open>Trueprop\<close>
                  (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_ord 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_ord 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>\<open>less T\<close>
        val cz = Thm.dest_arg ct
        val neg = cr < @0
        val cthp = Simplifier.rewrite ctxt
               (Thm.apply \<^cterm>\<open>Trueprop\<close>
                  (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_>\<open>HOL.eq _ for _ \<^Const_>\<open>zero_class.zero _\<close>\<close> =>
   (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>\<open>Trueprop\<close>
             (Thm.apply \<^cterm>\<open>Not\<close> (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_ord 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_ord 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>\<open>Trueprop\<close>
             (Thm.apply \<^cterm>\<open>Not\<close> (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_>\<open>less _ for a b\<close> =>
   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_ord vs)))) th
       val rth = Thm.transitive nth (xnormalize_conv ctxt vs (Thm.rhs_of nth))
   in rth end
| \<^Const_>\<open>less_eq _ for a b\<close> =>
   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_ord vs)))) th
       val rth = Thm.transitive nth (xnormalize_conv ctxt vs (Thm.rhs_of nth))
   in rth end

| \<^Const_>\<open>HOL.eq _ for a b\<close> =>
   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_ord vs)))) th
       val rth = Thm.transitive nth (xnormalize_conv ctxt vs (Thm.rhs_of nth))
   in rth end
| \<^Const_>\<open>Not for \<^Const_>\<open>HOL.eq _ for a b\<close>\<close> => 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_>\<open>HOL.eq _ for y z\<close> =>
      if Thm.term_of x aconv y then Ferrante_Rackoff_Data.Eq
      else Ferrante_Rackoff_Data.Nox
   | \<^Const_>\<open>Not for \<^Const_>\<open>HOL.eq _ for y z\<close>\<close> =>
      if Thm.term_of x aconv y then Ferrante_Rackoff_Data.NEq
      else Ferrante_Rackoff_Data.Nox
   | \<^Const_>\<open>less _ for y z\<close> =>
       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_>\<open>less_eq _ for y z\<close> =>
       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


(*  Title:      HOL/HOLCF/Up.thy
    Author:     Franz Regensburger
    Author:     Brian Huffman
*)

section \<open>The type of lifted values\<close>

theory Up
  imports Cfun
begin

default_sort cpo

subsection \<open>Definition of new type for lifting\<close>

datatype 'a u  ("(_\<^sub>\<bottom>)" [1000] 999) = Ibottom | Iup 'a

primrec Ifup :: "('a \<rightarrow> 'b::pcpo) \<Rightarrow> 'a u \<Rightarrow> 'b"
  where
    "Ifup f Ibottom = \<bottom>"
  | "Ifup f (Iup x) = f\<cdot>x"

subsection \<open>Ordering on lifted cpo\<close>

instantiation u :: (cpo) below
begin

definition below_up_def:
  "(\<sqsubseteq>) \<equiv>
    (\<lambda>x y.
      (case x of
        Ibottom \<Rightarrow> True
      | Iup a \<Rightarrow> (case y of Ibottom \<Rightarrow> False | Iup b \<Rightarrow> a \<sqsubseteq> b)))"

instance ..

end

lemma minimal_up [iff]: "Ibottom \<sqsubseteq> z"
  by (simp add: below_up_def)

lemma not_Iup_below [iff]: "Iup x \<notsqsubseteq> Ibottom"
  by (simp add: below_up_def)

lemma Iup_below [iff]: "(Iup x \<sqsubseteq> Iup y) = (x \<sqsubseteq> y)"
  by (simp add: below_up_def)

subsection \<open>Lifted cpo is a partial order\<close>

instance u :: (cpo) po
proof
  fix x :: "'a u"
  show "x \<sqsubseteq> x"
    by (simp add: below_up_def split: u.split)
next
  fix x y :: "'a u"
  assume "x \<sqsubseteq> y" "y \<sqsubseteq> x"
  then show "x = y"
    by (auto simp: below_up_def split: u.split_asm intro: below_antisym)
next
  fix x y z :: "'a u"
  assume "x \<sqsubseteq> y" "y \<sqsubseteq> z"
  then show "x \<sqsubseteq> z"
    by (auto simp: below_up_def split: u.split_asm intro: below_trans)
qed

subsection \<open>Lifted cpo is a cpo\<close>

lemma is_lub_Iup: "range S <<| x \<Longrightarrow> range (\<lambda>i. Iup (S i)) <<| Iup x"
  by (auto simp: is_lub_def is_ub_def ball_simps below_up_def split: u.split)

lemma up_chain_lemma:
  assumes Y: "chain Y"
  obtains "\<forall>i. Y i = Ibottom"
  | A k where "\<forall>i. Iup (A i) = Y (i + k)" and "chain A" and "range Y <<| Iup (\<Squnion>i. A i)"
proof (cases "\<exists>k. Y k \<noteq> Ibottom")
  case True
  then obtain k where k: "Y k \<noteq> Ibottom" ..
  define A where "A i = (THE a. Iup a = Y (i + k))" for i
  have Iup_A: "\<forall>i. Iup (A i) = Y (i + k)"
  proof
    fix i :: nat
    from Y le_add2 have "Y k \<sqsubseteq> Y (i + k)" by (rule chain_mono)
    with k have "Y (i + k) \<noteq> Ibottom" by (cases "Y k") auto
    then show "Iup (A i) = Y (i + k)"
      by (cases "Y (i + k)", simp_all add: A_def)
  qed
  from Y have chain_A: "chain A"
    by (simp add: chain_def Iup_below [symmetric] Iup_A)
  then have "range A <<| (\<Squnion>i. A i)"
    by (rule cpo_lubI)
  then have "range (\<lambda>i. Iup (A i)) <<| Iup (\<Squnion>i. A i)"
    by (rule is_lub_Iup)
  then have "range (\<lambda>i. Y (i + k)) <<| Iup (\<Squnion>i. A i)"
    by (simp only: Iup_A)
  then have "range (\<lambda>i. Y i) <<| Iup (\<Squnion>i. A i)"
    by (simp only: is_lub_range_shift [OF Y])
  with Iup_A chain_A show ?thesis ..
next
  case False
  then have "\<forall>i. Y i = Ibottom" by simp
  then show ?thesis ..
qed

instance u :: (cpo) cpo
proof
  fix S :: "nat \<Rightarrow> 'a u"
  assume S: "chain S"
  then show "\<exists>x. range (\<lambda>i. S i) <<| x"
  proof (rule up_chain_lemma)
    assume "\<forall>i. S i = Ibottom"
    then have "range (\<lambda>i. S i) <<| Ibottom"
      by (simp add: is_lub_const)
    then show ?thesis ..
  next
    fix A :: "nat \<Rightarrow> 'a"
    assume "range S <<| Iup (\<Squnion>i. A i)"
    then show ?thesis ..
  qed
qed

subsection \<open>Lifted cpo is pointed\<close>

instance u :: (cpo) pcpo
  by intro_classes fast

text \<open>for compatibility with old HOLCF-Version\<close>
lemma inst_up_pcpo: "\<bottom> = Ibottom"
  by (rule minimal_up [THEN bottomI, symmetric])

subsection \<open>Continuity of \emph{Iup} and \emph{Ifup}\<close>

text \<open>continuity for \<^term>\<open>Iup\<close>\<close>

lemma cont_Iup: "cont Iup"
  apply (rule contI)
  apply (rule is_lub_Iup)
  apply (erule cpo_lubI)
  done

text \<open>continuity for \<^term>\<open>Ifup\<close>\<close>

lemma cont_Ifup1: "cont (\<lambda>f. Ifup f x)"
  by (induct x) simp_all

lemma monofun_Ifup2: "monofun (\<lambda>x. Ifup f x)"
  apply (rule monofunI)
  apply (case_tac x, simp)
  apply (case_tac y, simp)
  apply (simp add: monofun_cfun_arg)
  done

lemma cont_Ifup2: "cont (\<lambda>x. Ifup f x)"
proof (rule contI2)
  fix Y
  assume Y: "chain Y" and Y': "chain (\<lambda>i. Ifup f (Y i))"
  from Y show "Ifup f (\<Squnion>i. Y i) \<sqsubseteq> (\<Squnion>i. Ifup f (Y i))"
  proof (rule up_chain_lemma)
    fix A and k
    assume A: "\<forall>i. Iup (A i) = Y (i + k)"
    assume "chain A" and "range Y <<| Iup (\<Squnion>i. A i)"
    then have "Ifup f (\<Squnion>i. Y i) = (\<Squnion>i. Ifup f (Iup (A i)))"
      by (simp add: lub_eqI contlub_cfun_arg)
    also have "\<dots> = (\<Squnion>i. Ifup f (Y (i + k)))"
      by (simp add: A)
    also have "\<dots> = (\<Squnion>i. Ifup f (Y i))"
      using Y' by (rule lub_range_shift)
    finally show ?thesis by simp
  qed simp
qed (rule monofun_Ifup2)

subsection \<open>Continuous versions of constants\<close>

definition up  :: "'a \<rightarrow> 'a u"
  where "up = (\<Lambda> x. Iup x)"

definition fup :: "('a \<rightarrow> 'b::pcpo) \<rightarrow> 'a u \<rightarrow> 'b"
  where "fup = (\<Lambda> f p. Ifup f p)"

translations
  "case l of XCONST up\<cdot>x \<Rightarrow> t" \<rightleftharpoons> "CONST fup\<cdot>(\<Lambda> x. t)\<cdot>l"
  "case l of (XCONST up :: 'a)\<cdot>x \<Rightarrow> t" \<rightharpoonup> "CONST fup\<cdot>(\<Lambda> x. t)\<cdot>l"
  "\<Lambda>(XCONST up\<cdot>x). t" \<rightleftharpoons> "CONST fup\<cdot>(\<Lambda> x. t)"

text \<open>continuous versions of lemmas for \<^typ>\<open>('a)u\<close>\<close>

lemma Exh_Up: "z = \<bottom> \<or> (\<exists>x. z = up\<cdot>x)"
  by (induct z) (simp add: inst_up_pcpo, simp add: up_def cont_Iup)

lemma up_eq [simp]: "(up\<cdot>x = up\<cdot>y) = (x = y)"
  by (simp add: up_def cont_Iup)

lemma up_inject: "up\<cdot>x = up\<cdot>y \<Longrightarrow> x = y"
  by simp

lemma up_defined [simp]: "up\<cdot>x \<noteq> \<bottom>"
  by (simp add: up_def cont_Iup inst_up_pcpo)

lemma not_up_less_UU: "up\<cdot>x \<notsqsubseteq> \<bottom>"
  by simp (* FIXME: remove? *)

lemma up_below [simp]: "up\<cdot>x \<sqsubseteq> up\<cdot>y \<longleftrightarrow> x \<sqsubseteq> y"
  by (simp add: up_def cont_Iup)

lemma upE [case_names bottom up, cases type: u]: "\<lbrakk>p = \<bottom> \<Longrightarrow> Q; \<And>x. p = up\<cdot>x \<Longrightarrow> Q\<rbrakk> \<Longrightarrow> Q"
  by (cases p) (simp add: inst_up_pcpo, simp add: up_def cont_Iup)

lemma up_induct [case_names bottom up, induct type: u]: "P \<bottom> \<Longrightarrow> (\<And>x. P (up\<cdot>x)) \<Longrightarrow> P x"
  by (cases x) simp_all

text \<open>lifting preserves chain-finiteness\<close>

lemma up_chain_cases:
  assumes Y: "chain Y"
  obtains "\<forall>i. Y i = \<bottom>"
  | A k where "\<forall>i. up\<cdot>(A i) = Y (i + k)" and "chain A" and "(\<Squnion>i. Y i) = up\<cdot>(\<Squnion>i. A i)"
  by (rule up_chain_lemma [OF Y]) (simp_all add: inst_up_pcpo up_def cont_Iup lub_eqI)

lemma compact_up: "compact x \<Longrightarrow> compact (up\<cdot>x)"
  apply (rule compactI2)
  apply (erule up_chain_cases)
   apply simp
  apply (drule (1) compactD2, simp)
  apply (erule exE)
  apply (drule_tac f="up" and x="x" in monofun_cfun_arg)
  apply (simp, erule exI)
  done

lemma compact_upD: "compact (up\<cdot>x) \<Longrightarrow> compact x"
  unfolding compact_def
  by (drule adm_subst [OF cont_Rep_cfun2 [where f=up]], simp)

lemma compact_up_iff [simp]: "compact (up\<cdot>x) = compact x"
  by (safe elim!: compact_up compact_upD)

instance u :: (chfin) chfin
  apply intro_classes
  apply (erule compact_imp_max_in_chain)
  apply (rule_tac p="\<Squnion>i. Y i" in upE, simp_all)
  done

text \<open>properties of fup\<close>

lemma fup1 [simp]: "fup\<cdot>f\<cdot>\<bottom> = \<bottom>"
  by (simp add: fup_def cont_Ifup1 cont_Ifup2 inst_up_pcpo cont2cont_LAM)

lemma fup2 [simp]: "fup\<cdot>f\<cdot>(up\<cdot>x) = f\<cdot>x"
  by (simp add: up_def fup_def cont_Iup cont_Ifup1 cont_Ifup2 cont2cont_LAM)

lemma fup3 [simp]: "fup\<cdot>up\<cdot>x = x"
  by (cases x) simp_all

end


(*  Title:      JinjaThreads/Basic/Aux.thy
    Author:     Andreas Lochbihler, David von Oheimb, Tobias Nipkow

    Based on the Jinja theory Common/Aux.thy by David von Oheimb and Tobias Nipkow
*)

section \<open>Auxiliary Definitions and Lemmata\<close>

theory Auxiliary
imports
  Complex_Main
  "HOL-Library.Transitive_Closure_Table"
  "HOL-Library.Predicate_Compile_Alternative_Defs"
  "HOL-Library.Monad_Syntax"
  "HOL-Library.Infinite_Set"
  FinFun.FinFun
begin

unbundle finfun_syntax

(* 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(*>*)

lemma less_min_eq1:
  "(a :: 'a :: order) < b \<Longrightarrow> min a b = a"
by(auto simp add: min_def order_less_imp_le)

lemma less_min_eq2:
  "(a :: 'a :: order) > b \<Longrightarrow> min a b = b"
by(auto simp add: min_def order_less_imp_le)

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

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

declare not_Cons_self [no_atp]

lemma Option_bind_eq_None_conv:
  "x \<bind> y = None \<longleftrightarrow> x = None \<or> (\<exists>x'. x = Some x' \<and> y x' = None)"
by(cases x) simp_all

lemma map_upds_xchg_snd:
  "\<lbrakk> length xs \<le> length ys; length xs \<le> length zs; \<forall>i. i < length xs \<longrightarrow> ys ! i = zs ! i \<rbrakk>
  \<Longrightarrow> f(xs [\<mapsto>] ys) = f(xs [\<mapsto>] zs)"
proof(induct xs arbitrary: ys zs f)
  case Nil thus ?case by simp
next
  case (Cons x xs)
  note IH = \<open>\<And>f ys zs. \<lbrakk> length xs \<le> length ys; length xs \<le> length zs; \<forall>i<length xs. ys ! i = zs ! i\<rbrakk>
             \<Longrightarrow> f(xs [\<mapsto>] ys) = f(xs [\<mapsto>] zs)\<close>
  note leny = \<open>length (x # xs) \<le> length ys\<close>
  note lenz = \<open>length (x # xs) \<le> length zs\<close>
  note nth = \<open>\<forall>i<length (x # xs). ys ! i = zs ! i\<close>
  from lenz obtain z zs' where zs [simp]: "zs = z # zs'" by(cases zs, auto)
  from leny obtain y ys' where ys [simp]: "ys = y # ys'" by(cases ys, auto)
  from lenz leny nth have "(f(x \<mapsto> y))(xs [\<mapsto>] ys') = (f(x \<mapsto> y))(xs [\<mapsto>] zs')"
    by-(rule IH, auto)
  moreover from nth have "y = z" by auto
  ultimately show ?case by(simp add: map_upds_def)
qed

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 []"
 (*<*)
apply (unfold distinct_fst_def)
apply (simp (no_asm))
done
(*>*)

lemma distinct_fst_Cons [simp]:
  "distinct_fst ((k,x)#kxs) = (distinct_fst kxs \<and> (\<forall>y. (k,y) \<notin> set kxs))"
(*<*)
apply (unfold distinct_fst_def)
apply (auto simp:image_def)
done
(*>*)

lemma distinct_fstD: "\<lbrakk> distinct_fst xs; (x, y) \<in> set xs; (x, z) \<in> set xs \<rbrakk> \<Longrightarrow> y = z"
by(induct xs) auto

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)(*>*)

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](*>*)

lemma list_all2_split:
  assumes major: "list_all2 P xs ys"
  and split: "\<And>x y. P x y \<Longrightarrow> \<exists>z. Q x z \<and> R z y"
  shows "\<exists>zs. list_all2 Q xs zs \<and> list_all2 R zs ys"
using major
by(induct rule: list_all2_induct)(auto dest: split)

lemma list_all2_op_eq [simp]:
  "list_all2 (=) xs ys \<longleftrightarrow> xs = ys"
by(induct xs arbitrary: ys)(auto simp add: list_all2_Cons1)

lemmas filter_replicate_conv = filter_replicate

lemma length_greater_Suc_0_conv: "Suc 0 < length xs \<longleftrightarrow> (\<exists>x x' xs'. xs = x # x' # xs')"
by(cases xs, auto simp add: neq_Nil_conv)

lemmas zip_same_conv = zip_same_conv_map

lemma f_nth_set:
  "\<lbrakk> f (xs ! n) = v; n < length xs \<rbrakk> \<Longrightarrow> v \<in> f ` set xs"
unfolding set_conv_nth by auto

lemma nth_concat_eqI:
  "\<lbrakk> n = sum_list (map length (take i xss)) + k; i < length xss; k < length (xss ! i); x = xss ! i ! k \<rbrakk>
  \<Longrightarrow> concat xss ! n = x"
apply(induct xss arbitrary: n i k)
 apply simp
apply simp
apply(case_tac i)
 apply(simp add: nth_append)
apply(simp add: nth_append)
done

lemma replicate_eq_append_conv:
  "(replicate n x = xs @ ys) = (\<exists>m\<le>n. xs = replicate m x \<and> ys = replicate (n-m) x)"
proof(induct n arbitrary: xs ys)
  case 0 thus ?case by simp
next
  case (Suc n xs ys)
  have IH: "\<And>xs ys. (replicate n x = xs @ ys) = (\<exists>m\<le>n. xs = replicate m x \<and> ys = replicate (n - m) x)" by fact
  show ?case
  proof(unfold replicate_Suc, rule iffI)
    assume a: "x # replicate n x = xs @ ys"
    show "\<exists>m\<le>Suc n. xs = replicate m x \<and> ys = replicate (Suc n - m) x"
    proof(cases xs)
      case Nil
      thus ?thesis using a
        by(auto)
    next
      case (Cons X XS)
      with a have x: "x = X" and "replicate n x = XS @ ys" by auto
      hence "\<exists>m\<le>n. XS = replicate m x \<and> ys = replicate (n - m) x"
        by -(rule IH[THEN iffD1])
      then obtain m where "m \<le> n" and XS: "XS = replicate m x" and ys: "ys = replicate (n - m) x" by blast
      with x Cons show ?thesis
        by(fastforce)
    qed
  next
    assume "\<exists>m\<le>Suc n. xs = replicate m x \<and> ys = replicate (Suc n - m) x"
    then obtain m where m: "m \<le> Suc n" and xs: "xs = replicate m x" and ys: "ys = replicate (Suc n - m) x" by blast
    thus "x # replicate n x = xs @ ys"
      by(simp add: replicate_add[THEN sym])
  qed
qed

lemma replicate_Suc_snoc:
  "replicate (Suc n) x = replicate n x @ [x]"
by (metis replicate_Suc replicate_append_same)

lemma map_eq_append_conv:
  "map f xs = ys @ zs \<longleftrightarrow> (\<exists>ys' zs'. map f ys' = ys \<and> map f zs' = zs \<and> xs = ys' @ zs')"
apply(rule iffI)
 apply(metis append_eq_conv_conj append_take_drop_id drop_map take_map)
by(clarsimp)

lemma append_eq_map_conv:
  "ys @ zs = map f xs \<longleftrightarrow> (\<exists>ys' zs'. map f ys' = ys \<and> map f zs' = zs \<and> xs = ys' @ zs')"
unfolding map_eq_append_conv[symmetric]
by auto

lemma map_eq_map_conv:
  "map f xs = map g ys \<longleftrightarrow> list_all2 (\<lambda>x y. f x = g y) xs ys"
apply(induct xs arbitrary: ys)
apply(auto simp add: list_all2_Cons1 Cons_eq_map_conv)
done

lemma map_eq_all_nth_conv:
  "map f xs = ys \<longleftrightarrow> length xs = length ys \<and> (\<forall>n < length xs. f (xs ! n) = ys ! n)"
apply(induct xs arbitrary: ys)
apply(fastforce simp add: nth_Cons Suc_length_conv split: nat.splits)+
done

lemma take_eq_take_le_eq:
  "\<lbrakk> take n xs = take n ys; m \<le> n \<rbrakk> \<Longrightarrow> take m xs = take m ys"
by(metis min.absorb_iff1 take_take)

lemma set_tl_subset: "set (tl xs) \<subseteq> set xs"
by(cases xs) auto

lemma tl_conv_drop: "tl xs = drop 1 xs"
by(cases xs) simp_all

lemma takeWhile_eq_Nil_dropWhile_eq_Nil_imp_Nil:
  "\<lbrakk> takeWhile P xs = []; dropWhile P xs = [] \<rbrakk> \<Longrightarrow> xs = []"
by (metis dropWhile_eq_drop drop_0 list.size(3))

lemma dropWhile_append1': "dropWhile P xs \<noteq> [] \<Longrightarrow> dropWhile P (xs @ ys) = dropWhile P xs @ ys"
by(cases xs) auto

lemma dropWhile_append2': "dropWhile P xs = [] \<Longrightarrow> dropWhile P (xs @ ys) = dropWhile P ys"
by(simp)

lemma takeWhile_append1': "dropWhile P xs \<noteq> [] \<Longrightarrow> takeWhile P (xs @ ys) = takeWhile P xs"
by auto

lemma dropWhile_eq_ConsD:
  "dropWhile P xs = y # ys \<Longrightarrow> y \<in> set xs \<and> \<not> P y"
by(induct xs)(auto split: if_split_asm)

lemma dropWhile_eq_hd_conv: "dropWhile P xs = hd xs # rest \<longleftrightarrow> xs \<noteq> [] \<and> rest = tl xs \<and> \<not> P (hd xs)"
by (metis append_Nil dropWhile_eq_Cons_conv list.sel(1) neq_Nil_conv takeWhile_dropWhile_id takeWhile_eq_Nil_iff list.sel(3))

lemma subset_code [code_unfold]:
  "set xs \<subseteq> set ys \<longleftrightarrow> (\<forall>x \<in> set xs. x \<in> set ys)"
by(rule Set.subset_eq)

lemma eval_bot [simp]:
  "Predicate.eval bot = (\<lambda>_. False)"
by(auto simp add: fun_eq_iff)

lemma not_is_emptyE:
  assumes "\<not> Predicate.is_empty P"
  obtains x where "Predicate.eval P x"
using assms
by(fastforce simp add: Predicate.is_empty_def bot_pred_def intro!: pred_iffI)

lemma is_emptyD:
  assumes "Predicate.is_empty P"
  shows "Predicate.eval P x \<Longrightarrow> False"
using assms
by(simp add: Predicate.is_empty_def bot_pred_def bot_apply Set.empty_def)

lemma eval_bind_conv:
  "Predicate.eval (P \<bind> R) y = (\<exists>x. Predicate.eval P x \<and> Predicate.eval (R x) y)"
by(blast elim: bindE intro: bindI)

lemma eval_single_conv: "Predicate.eval (Predicate.single a) b \<longleftrightarrow> a = b"
by(blast intro: singleI elim: singleE)

lemma conj_asm_conv_imp:
  "(A \<and> B \<Longrightarrow> PROP C) \<equiv> (A \<Longrightarrow> B \<Longrightarrow> PROP C)"
apply(rule equal_intr_rule)
 apply(erule meta_mp)
 apply(erule (1) conjI)
apply(erule meta_impE)
 apply(erule conjunct1)
apply(erule meta_mp)
apply(erule conjunct2)
done

lemma meta_all_eq_conv: "(\<And>a. a = b \<Longrightarrow> PROP P a) \<equiv> PROP P b"
apply(rule equal_intr_rule)
 apply(erule meta_allE)
 apply(erule meta_mp)
 apply(rule refl)
apply(hypsubst)
apply assumption
done

lemma meta_all_eq_conv2: "(\<And>a. b = a \<Longrightarrow> PROP P a) \<equiv> PROP P b"
apply(rule equal_intr_rule)
 apply(erule meta_allE)
 apply(erule meta_mp)
 apply(rule refl)
apply(hypsubst)
apply assumption
done

lemma disj_split:
  "P (a \<or> b) \<longleftrightarrow> (a \<longrightarrow> P True) \<and> (b \<longrightarrow> P True) \<and> (\<not> a \<and> \<not> b \<longrightarrow> P False)"
apply(cases a)
apply(case_tac [!] b)
apply auto
done

lemma disj_split_asm:
  "P (a \<or> b) \<longleftrightarrow> \<not> (a \<and> \<not> P True \<or> b \<and> \<not> P True \<or> \<not> a \<and> \<not> b \<and> \<not> P False)"
apply(auto simp add: disj_split[of P])
done

lemma disjCE:
  assumes "P \<or> Q"
  obtains P | "Q" "\<not> P"
using assms by blast

lemma case_option_conv_if:
  "(case v of None \<Rightarrow> f | Some x \<Rightarrow> g x) = (if \<exists>a. v = Some a then g (the v) else f)"
by(simp)

lemma LetI: "(\<And>x. x = t \<Longrightarrow> P x) \<Longrightarrow> let x = t in P x"
by(simp)

(* rearrange parameters and premises to allow application of one-point-rules *)
(* adapted from Tools/induct.ML and Isabelle Developer Workshop 2010 *)

simproc_setup rearrange_eqs ("Pure.all t") = \<open>
let
  fun swap_params_conv ctxt i j cv =
    let
      fun conv1 0 ctxt = Conv.forall_conv (cv o snd) ctxt
        | conv1 k ctxt =
            Conv.rewr_conv @{thm swap_params} then_conv
            Conv.forall_conv (conv1 (k - 1) o snd) ctxt
      fun conv2 0 ctxt = conv1 j ctxt
        | conv2 k ctxt = Conv.forall_conv (conv2 (k - 1) o snd) ctxt
    in conv2 i ctxt end;

  fun swap_prems_conv 0 = Conv.all_conv
    | swap_prems_conv i =
        Conv.implies_concl_conv (swap_prems_conv (i - 1)) then_conv
        Conv.rewr_conv Drule.swap_prems_eq;

  fun find_eq ctxt t =
    let
      val l = length (Logic.strip_params t);
      val Hs = Logic.strip_assums_hyp t;
      fun find (i, (_ $ (Const ("HOL.eq", _) $ Bound j $ _))) = SOME (i, j)
        | find (i, (_ $ (Const ("HOL.eq", _) $ _ $ Bound j))) = SOME (i, j)
        | find _ = NONE
    in
      (case get_first find (map_index I Hs) of
        NONE => NONE
      | SOME (0, 0) => NONE
      | SOME (i, j) => SOME (i, l - j - 1, j))
    end;

  fun mk_swap_rrule ctxt ct =
    (case find_eq ctxt (Thm.term_of ct) of
      NONE => NONE
    | SOME (i, k, j) => SOME (swap_params_conv ctxt k j (K (swap_prems_conv i)) ct))
in
  fn _ => mk_swap_rrule
end
\<close>
declare [[simproc del: rearrange_eqs]]
lemmas meta_onepoint = meta_all_eq_conv meta_all_eq_conv2

lemma meta_all2_eq_conv: "(\<And>a b. a = c \<Longrightarrow> PROP P a b) \<equiv> (\<And>b. PROP P c b)"
apply(rule equal_intr_rule)
 apply(erule meta_allE)+
 apply(erule meta_mp)
 apply(rule refl)
apply(erule meta_allE)
apply simp
done

lemma meta_all3_eq_conv: "(\<And>a b c. a = d \<Longrightarrow> PROP P a b c) \<equiv> (\<And>b c. PROP P d b c)"
apply(rule equal_intr_rule)
 apply(erule meta_allE)+
 apply(erule meta_mp)
 apply(rule refl)
apply(erule meta_allE)+
apply simp
done

lemma meta_all4_eq_conv: "(\<And>a b c d. a = e \<Longrightarrow> PROP P a b c d) \<equiv> (\<And>b c d. PROP P e b c d)"
apply(rule equal_intr_rule)
 apply(erule meta_allE)+
 apply(erule meta_mp)
 apply(rule refl)
apply(erule meta_allE)+
apply simp
done

lemma meta_all5_eq_conv: "(\<And>a b c d e. a = f \<Longrightarrow> PROP P a b c d e) \<equiv> (\<And>b c d e. PROP P f b c d e)"
apply(rule equal_intr_rule)
 apply(erule meta_allE)+
 apply(erule meta_mp)
 apply(rule refl)
apply(erule meta_allE)+
apply simp
done

lemma sum_upto_add_nat:
  "a \<le> b \<Longrightarrow> sum f {..<(a :: nat)} + sum f {a..<b} = sum f {..<b}"
by (metis atLeast0LessThan le0 sum.atLeastLessThan_concat)

lemma nat_fun_sum_eq_conv:
  fixes f :: "'a \<Rightarrow> nat"
  shows "(\<lambda>a. f a + g a) = (\<lambda>a. 0) \<longleftrightarrow> f = (\<lambda>a .0) \<and> g = (\<lambda>a. 0)"
by(auto simp add: fun_eq_iff)

lemma in_ran_conv: "v \<in> ran m \<longleftrightarrow> (\<exists>k. m k = Some v)"
by(simp add: ran_def)

lemma map_le_dom_eq_conv_eq:
  "\<lbrakk> m \<subseteq>\<^sub>m m'; dom m = dom m' \<rbrakk> \<Longrightarrow> m = m'"
by (metis map_le_antisym map_le_def)

lemma map_leI:
  "(\<And>k v. f k = Some v \<Longrightarrow> g k = Some v) \<Longrightarrow> f \<subseteq>\<^sub>m g"
unfolding map_le_def by auto

lemma map_le_SomeD: "\<lbrakk> m \<subseteq>\<^sub>m m'; m x = \<lfloor>y\<rfloor> \<rbrakk> \<Longrightarrow> m' x = \<lfloor>y\<rfloor>"
by(auto simp add: map_le_def dest: bspec)

lemma map_le_same_upd:
  "f x = None \<Longrightarrow> f \<subseteq>\<^sub>m f(x \<mapsto> y)"
by(auto simp add: map_le_def)

lemma map_upd_map_add: "X(V \<mapsto> v) = (X ++ [V \<mapsto> v])"
by(simp)

lemma foldr_filter_conv:
  "foldr f (filter P xs) = foldr (\<lambda>x s. if P x then f x s else s) xs"
by(induct xs)(auto intro: ext)

lemma foldr_insert_conv_set:
  "foldr insert xs A = A \<union> set xs"
by(induct xs arbitrary: A) auto

lemma snd_o_Pair_conv_id: "snd o Pair a = id"
by(simp add: o_def id_def)

lemma if_intro:
  "\<lbrakk> P \<Longrightarrow> A; \<not> P \<Longrightarrow> B \<rbrakk> \<Longrightarrow> if P then A else B"
by(auto)

lemma ex_set_conv: "(\<exists>x. x \<in> set xs) \<longleftrightarrow> xs \<noteq> []"
apply(auto)
apply(auto simp add: neq_Nil_conv)
done

lemma subset_Un1: "A \<subseteq> B \<Longrightarrow> A \<subseteq> B \<union> C" by blast
lemma subset_Un2: "A \<subseteq> C \<Longrightarrow> A \<subseteq> B \<union> C" by blast
lemma subset_insert: "A \<subseteq> B \<Longrightarrow> A \<subseteq> insert a B" by blast
lemma UNION_subsetD: "\<lbrakk> (\<Union>x\<in>A. f x) \<subseteq> B; a \<in> A \<rbrakk> \<Longrightarrow> f a \<subseteq> B" by blast

lemma Collect_eq_singleton_conv:
  "{a. P a} = {a} \<longleftrightarrow> P a \<and> (\<forall>a'. P a' \<longrightarrow> a = a')"
by(auto)

lemma Collect_conv_UN_singleton: "{f x|x. x \<in> P} = (\<Union>x\<in>P. {f x})"
by blast

lemma if_else_if_else_eq_if_else [simp]:
  "(if b then x else if b then y else z) = (if b then x else z)"
by(simp)

lemma rec_prod_split [simp]: "old.rec_prod = case_prod"
by(simp add: fun_eq_iff)

lemma inj_Pair_snd [simp]: "inj (Pair x)"
by(rule injI) auto

lemma rtranclp_False [simp]: "(\<lambda>a b. False)\<^sup>*\<^sup>* = (=)"
by(auto simp add: fun_eq_iff elim: rtranclp_induct)

lemmas rtranclp_induct3 =
  rtranclp_induct[where a="(ax, ay, az)" and b="(bx, by, bz)", split_rule, consumes 1, case_names refl step]

lemmas tranclp_induct3 =
  tranclp_induct[where a="(ax, ay, az)" and b="(bx, by, bz)", split_rule, consumes 1, case_names refl step]

lemmas rtranclp_induct4 =
  rtranclp_induct[where a="(ax, ay, az, aw)" and b="(bx, by, bz, bw)", split_rule, consumes 1, case_names refl step]

lemmas tranclp_induct4 =
  tranclp_induct[where a="(ax, ay, az, aw)" and b="(bx, by, bz, bw)", split_rule, consumes 1, case_names refl step]

lemmas converse_tranclp_induct2 =
  converse_tranclp_induct [of _ "(ax,ay)" "(bx,by)", split_rule,
                 consumes 1, case_names base step]

lemma wfP_induct' [consumes 1, case_names wfP]:
  "\<lbrakk>wfP r; \<And>x. (\<And>y. r y x \<Longrightarrow> P y) \<Longrightarrow> P x\<rbrakk> \<Longrightarrow> P a"
by(blast intro: wfP_induct)

lemma wfP_induct2 [consumes 1, case_names wfP]:
  "\<lbrakk>wfP r; \<And>x x'. (\<And>y y'. r (y, y') (x, x') \<Longrightarrow> P y y') \<Longrightarrow> P x x' \<rbrakk> \<Longrightarrow> P x x'"
by(drule wfP_induct'[where P="\<lambda>(x, y). P x y"]) blast+

lemma wfP_minimalE:
  assumes "wfP r"
  and "P x"
  obtains z where "P z" "r^** z x" "\<And>y. r y z \<Longrightarrow> \<not> P y"
proof -
  let ?Q = "\<lambda>x'. P x' \<and> r^** x' x"
  from \<open>P x\<close> have "?Q x" by blast
  from \<open>wfP r\<close> have "\<And>Q. x \<in> Q \<longrightarrow> (\<exists>z\<in>Q. \<forall>y. r y z \<longrightarrow> y \<notin> Q)"
    unfolding wfP_eq_minimal by blast
  from this[rule_format, of "Collect ?Q"] \<open>?Q x\<close>
  obtain z where "?Q z" and min: "\<And>y. r y z \<Longrightarrow> \<not> ?Q y" by auto
  from \<open>?Q z\<close> have "P z" "r^** z x" by auto
  moreover
  { fix y
    assume "r y z"
    hence "\<not> ?Q y" by(rule min)
    moreover from \<open>r y z\<close> \<open>r^** z x\<close> have "r^** y x"
      by(rule converse_rtranclp_into_rtranclp)
    ultimately have "\<not> P y" by blast }
  ultimately show thesis ..
qed

lemma coinduct_set_wf [consumes 3, case_names coinduct, case_conclusion coinduct wait step]:
  assumes "mono f" "wf r" "(a, b) \<in> X"
  and step: "\<And>x b. (x, b) \<in> X \<Longrightarrow> (\<exists>b'. (b', b) \<in> r \<and> (x, b') \<in> X) \<or> (x \<in> f (fst ` X \<union> gfp f))"
  shows "a \<in> gfp f"
proof -
  from \<open>(a, b) \<in> X\<close> have "a \<in> fst ` X" by(auto intro: rev_image_eqI)
  moreover
  { fix a b
    assume "(a, b) \<in> X"
    with \<open>wf r\<close> have "a \<in> f (fst ` X \<union> gfp f)"
      by(induct)(blast dest: step) }
  hence "fst ` X \<subseteq> f (fst ` X \<union> gfp f)" by(auto)
  ultimately show ?thesis by(rule coinduct_set[OF \<open>mono f\<close>])
qed

subsection \<open>reflexive transitive closure for label relations\<close>

inductive converse3p :: "('a \<Rightarrow> 'b \<Rightarrow> 'c \<Rightarrow> bool) \<Rightarrow> 'c \<Rightarrow> 'b \<Rightarrow> 'a \<Rightarrow> bool"
  for r :: "'a \<Rightarrow> 'b \<Rightarrow> 'c \<Rightarrow> bool"
where
  converse3pI: "r a b c \<Longrightarrow> converse3p r c b a"

lemma converse3p_converse3p: "converse3p (converse3p r) = r"
by(auto intro: converse3pI intro!: ext elim: converse3p.cases)

lemma converse3pD: "converse3p r c b a \<Longrightarrow> r a b c"
by(auto elim: converse3p.cases)

inductive rtrancl3p :: "('a \<Rightarrow> 'b \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'b list \<Rightarrow> 'a \<Rightarrow> bool"
  for r :: "'a \<Rightarrow> 'b \<Rightarrow> 'a \<Rightarrow> bool"
  where
  rtrancl3p_refl [intro!, simp]: "rtrancl3p r a [] a"
| rtrancl3p_step: "\<lbrakk> rtrancl3p r a bs a'; r a' b a'' \<rbrakk> \<Longrightarrow> rtrancl3p r a (bs @ [b]) a''"

lemmas rtrancl3p_induct3 =
  rtrancl3p.induct[of _ "(ax,ay,az)" _ "(cx,cy,cz)", split_format (complete),
                 consumes 1, case_names refl step]

lemmas rtrancl3p_induct4 =
  rtrancl3p.induct[of _ "(ax,ay,az,aw)" _ "(cx,cy,cz,cw)", split_format (complete),
                 consumes 1, case_names refl step]

lemma rtrancl3p_induct4' [consumes 1, case_names refl step]:
  assumes major: "rtrancl3p r (ax, (ay, az), aw) bs (cx, (cy, cz), cw)"
  and refl: "\<And>a aa b ba. P a aa b ba [] a aa b ba"
  and step: "\<And>a aa b ba bs ab ac bb bc bd ad ae be bf.
       \<lbrakk> rtrancl3p r (a, (aa, b), ba) bs (ab, (ac, bb), bc);
         P a aa b ba bs ab ac bb bc; r (ab, (ac, bb), bc) bd (ad, (ae, be), bf) \<rbrakk>
       \<Longrightarrow> P a aa b ba (bs @ [bd]) ad ae be bf"
  shows "P ax ay az aw bs cx cy cz cw"
using major
apply -
apply(drule_tac P="\<lambda>(a, (aa, b), ba) bs (cx, (cy, cz), cw). P a aa b ba bs cx cy cz cw" in rtrancl3p.induct)
by(auto intro: refl step)

lemma rtrancl3p_induct1:
  "\<lbrakk> rtrancl3p r a bs c; P a; \<And>bs c b d. \<lbrakk> rtrancl3p r a bs c; r c b d; P c \<rbrakk> \<Longrightarrow> P d \<rbrakk> \<Longrightarrow> P c"
apply(induct rule: rtrancl3p.induct)
apply(auto)
done

inductive_cases rtrancl3p_cases:
  "rtrancl3p r x [] y"
  "rtrancl3p r x (b # bs) y"

lemma rtrancl3p_trans [trans]:
  assumes one: "rtrancl3p r a bs a'"
  and two: "rtrancl3p r a' bs' a''"
  shows "rtrancl3p r a (bs @ bs') a''"
using two one
proof(induct rule: rtrancl3p.induct)
  case rtrancl3p_refl thus ?case by simp
next
  case rtrancl3p_step thus ?case
    by(auto simp only: append_assoc[symmetric] intro: rtrancl3p.rtrancl3p_step)
qed

lemma rtrancl3p_step_converse:
  assumes step: "r a b a'"
  and stepify: "rtrancl3p r a' bs a''"
  shows "rtrancl3p r a (b # bs) a''"
using stepify step
proof(induct rule: rtrancl3p.induct)
  case rtrancl3p_refl
  with rtrancl3p.rtrancl3p_refl[where r=r and a=a] show ?case
    by(auto dest: rtrancl3p.rtrancl3p_step simp del: rtrancl3p.rtrancl3p_refl)
next
  case rtrancl3p_step thus ?case
    unfolding append_Cons[symmetric]
    by -(rule rtrancl3p.rtrancl3p_step)
qed

lemma converse_rtrancl3p_step:
  "rtrancl3p r a (b # bs) a'' \<Longrightarrow> \<exists>a'. r a b a' \<and> rtrancl3p r a' bs a''"
apply(induct bs arbitrary: a'' rule: rev_induct)
 apply(erule rtrancl3p.cases)
  apply(clarsimp)+
 apply(erule rtrancl3p.cases)
  apply(clarsimp)
  apply(rule_tac x="a''a" in exI)
  apply(clarsimp)
 apply(clarsimp)
apply(erule rtrancl3p.cases)
 apply(clarsimp)
apply(clarsimp)
by(fastforce intro: rtrancl3p_step)

lemma converse_rtrancl3pD:
  "rtrancl3p (converse3p r) a' bs a \<Longrightarrow> rtrancl3p r a (rev bs) a'"
apply(induct rule: rtrancl3p.induct)
 apply(fastforce intro: rtrancl3p.intros)
apply(auto dest: converse3pD intro: rtrancl3p_step_converse)
done

lemma rtrancl3p_converse_induct [consumes 1, case_names refl step]:
  assumes ih: "rtrancl3p r a bs a''"
  and refl: "\<And>a. P a [] a"
  and step: "\<And>a b a' bs a''. \<lbrakk> rtrancl3p r a' bs a''; r a b a'; P a' bs a'' \<rbrakk> \<Longrightarrow> P a (b # bs) a''"
  shows "P a bs a''"
  using ih
proof(induct bs arbitrary: a a'')
  case Nil thus ?case
    by(auto elim: rtrancl3p.cases intro: refl)
next
  case Cons thus ?case
    by(auto dest!: converse_rtrancl3p_step intro: step)
qed

lemma rtrancl3p_converse_induct' [consumes 1, case_names refl step]:
  assumes ih: "rtrancl3p r a bs a''"
  and refl: "P a'' []"
  and step: "\<And>a b a' bs. \<lbrakk> rtrancl3p r a' bs a''; r a b a'; P a' bs \<rbrakk> \<Longrightarrow> P a (b # bs)"
  shows "P a bs"
using rtrancl3p_converse_induct[OF ih, where P="\<lambda>a bs a'. a' = a'' \<longrightarrow> P a bs"]
by(auto intro: refl step)

lemma rtrancl3p_converseE[consumes 1, case_names refl step]:
  "\<lbrakk> rtrancl3p r a bs a'';
     \<lbrakk> a = a''; bs = [] \<rbrakk> \<Longrightarrow> thesis;
     \<And>bs' b a'. \<lbrakk> bs = b # bs'; r a b a'; rtrancl3p r a' bs' a'' \<rbrakk> \<Longrightarrow> thesis \<rbrakk>
  \<Longrightarrow> thesis"
by(induct rule: rtrancl3p_converse_induct)(auto)

lemma rtrancl3p_induct' [consumes 1, case_names refl step]:
  assumes major: "rtrancl3p r a bs c"
  and refl: "P a [] a"
  and step: "\<And>bs a' b a''. \<lbrakk> rtrancl3p r a bs a'; P a bs a'; r a' b a'' \<rbrakk>
             \<Longrightarrow> P a (bs @ [b]) a''"
  shows "P a bs c"
proof -
  from major have "(P a [] a \<and> (\<forall>bs a' b a''. rtrancl3p r a bs a' \<and> P a bs a' \<and> r a' b a'' \<longrightarrow> P a (bs @ [b]) a'')) \<longrightarrow> P a bs c"
    by-(erule rtrancl3p.induct, blast+)
  with refl step show ?thesis by blast
qed

lemma r_into_rtrancl3p:
  "r a b a' \<Longrightarrow> rtrancl3p r a [b] a'"
by(rule rtrancl3p_step_converse) auto

lemma rtrancl3p_appendE:
  assumes "rtrancl3p r a (bs @ bs') a''"
  obtains a' where "rtrancl3p r a bs a'" "rtrancl3p r a' bs' a''"
using assms
apply(induct a "bs @ bs'" arbitrary: bs rule: rtrancl3p_converse_induct')
apply(fastforce intro: rtrancl3p_step_converse simp add: Cons_eq_append_conv)+
done

lemma rtrancl3p_Cons:
  "rtrancl3p r a (b # bs) a' \<longleftrightarrow> (\<exists>a''. r a b a'' \<and> rtrancl3p r a'' bs a')"
by(auto intro: rtrancl3p_step_converse converse_rtrancl3p_step)

lemma rtrancl3p_Nil:
  "rtrancl3p r a [] a' \<longleftrightarrow> a = a'"
by(auto elim: rtrancl3p_cases)

definition invariant3p :: "('a \<Rightarrow> 'b \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a set \<Rightarrow> bool"
where "invariant3p r I \<longleftrightarrow> (\<forall>s tl s'. s \<in> I \<longrightarrow> r s tl s' \<longrightarrow> s' \<in> I)"

lemma invariant3pI: "(\<And>s tl s'. \<lbrakk> s \<in> I; r s tl s' \<rbrakk> \<Longrightarrow> s' \<in> I) \<Longrightarrow> invariant3p r I"
unfolding invariant3p_def by blast

lemma invariant3pD: "\<And>tl. \<lbrakk> invariant3p r I; r s tl s'; s \<in> I \<rbrakk> \<Longrightarrow> s' \<in> I"
unfolding invariant3p_def by(blast)

lemma invariant3p_rtrancl3p:
  assumes inv: "invariant3p r I"
  and rtrancl: "rtrancl3p r a bs a'"
  and start: "a \<in> I"
  shows "a' \<in> I"
using rtrancl start by(induct)(auto dest: invariant3pD[OF inv])

lemma invariant3p_UNIV [simp, intro!]:
  "invariant3p r UNIV"
by(blast intro: invariant3pI)

lemma invarinat3p_empty [simp, intro!]:
  "invariant3p r {}"
by(blast intro: invariant3pI)

lemma invariant3p_IntI [simp, intro]:
  "\<lbrakk> invariant3p r I; invariant3p r J \<rbrakk> \<Longrightarrow> invariant3p r (I \<inter> J)"
by(blast dest: invariant3pD intro: invariant3pI)

subsection \<open>Concatenation for @{typ String.literal}\<close>

definition concat :: "String.literal list \<Rightarrow> String.literal"
  where [code_abbrev, code del]: "concat = sum_list"

lemma explode_add [simp]:
  "String.explode (s + t) = String.explode s @ String.explode t"
  by (fact plus_literal.rep_eq)

code_printing
  constant concat \<rightharpoonup>
    (SML) "String.concat"
    and (Haskell) "concat"
    and (OCaml) "String.concat \"\""

hide_const (open) concat

end