(*
Author:  Jérémy Dubut (2019)
Author:  Akihisa Yamada (2019)
License: LGPL (see file COPYING.LESSER)
*)
section \<open>Knaster--Tarski-Style Fixed-Point Theorem\<close>

theory Fixed_Points
  imports Complete_Relations
begin

text \<open>Given a monotone map
$f : A \to A$ on a complete lattice $\tp{A,\SLE}$,
the Knaster--Tarski theorem~\cite{tarski55} states that
\begin{enumerate}
\item $f$ has a fixed point in $A$, and
\item the set of fixed points forms a complete lattice.
\end{enumerate}
Stauti and Maaden \cite{SM13} generalized statement (1) where $\tp{A,\SLE}$
is a complete \emph{trellis}---a complete pseudo-order---%
relaxing transitivity.
They also proved a restricted version of (2),
namely there exists a least (and by duality a greatest) fixed point in $A$.

In the following Section~\ref{sec:qfp-exists} we further generalize claim (1)
so that any complete relation
admits a \emph{quasi-fixed point} $f(x) \sim x$, that is, $f(x) \SLE x$ and $x \SLE f(x)$.
Quasi-fixed points are fixed points for antisymmetric relations;
hence the Stauti--Maaden theorem is further generalized by relaxing reflexivity.

In Section \ref{sec:qfp-complete}
we also generalize claim (2) so that only a mild condition, which we call \emph{attractivity},
is assumed. In this attractive setting quasi-fixed points are complete.
Since attractivity is implied by either of transitivity or antisymmetry,
in particular fixed points are complete in complete trellis,
thus completing Stauti and Maaden's result. We then further generalize the result, proving that
antisymmetry is sufficient for \emph{strict} fixed points
$f(x) = x$ to be complete.\<close>

subsection \<open>Completeness of a Subset\<close>

text \<open>We start by formalizing what it means for a subset to have an extreme bound inside
a set, and for this subset to be complete. We prove that this completeness is also auto-dual.\<close>

context
  fixes less_eq :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<sqsubseteq>" 50)
begin

interpretation less_eq_dualize.

abbreviation "extreme_bound_in S X \<equiv> extreme (\<sqsupseteq>) {b \<in> S. bound (\<sqsubseteq>) X b}"

lemma extreme_bound_inI[intro]:
  assumes "\<And>b. bound (\<sqsubseteq>) X b \<Longrightarrow> b \<in> S \<Longrightarrow> s \<sqsubseteq> b" and "s \<in> S" and "\<And>x. x \<in> X \<Longrightarrow> x \<sqsubseteq> s"
  shows "extreme_bound_in S X s"
  using assms by auto

definition "complete_in S \<equiv> \<forall>X \<subseteq> S. Ex (extreme_bound_in S X)"

lemma complete_inE[elim]:
  assumes "complete_in S" and "(\<And>X. X \<subseteq> S \<Longrightarrow> Ex (extreme_bound_in S X)) \<Longrightarrow> thesis"
  shows "thesis"
  using assms by (auto simp: complete_in_def)

lemma complete_inD:
  shows "complete_in S \<Longrightarrow> X \<subseteq> S \<Longrightarrow> Ex (extreme_bound_in S X)"
  by (auto simp: complete_in_def)

lemma complete_inI[intro?]:
  assumes "\<And>X. X \<subseteq> S \<Longrightarrow> Ex (extreme_bound_in S X)"
  shows "complete_in S"
  using assms by (auto simp: complete_in_def)

end

context
  fixes less_eq :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<sqsubseteq>" 50)
begin

interpretation less_eq_dualize.

lemma complete_in_dual:
  assumes complete: "complete_in (\<sqsubseteq>) S" shows "complete_in (\<sqsupseteq>) S"
proof
  fix A :: "'a set"
  assume AS: "A \<subseteq> S"
  define B where "B \<equiv> {b\<in>S. bound (\<sqsupseteq>) A b}"
  then have "B \<subseteq> S" by auto
  then obtain b where "extreme_bound_in (\<sqsubseteq>) S B b"
    using complete by force
  with AS show "Ex (extreme_bound_in (\<sqsupseteq>) S A)"
    apply (intro exI[of _ b], unfold extreme_def B_def) by auto
qed

end

subsection \<open>Existence of Quasi-Fixed Points\<close>
text \<open>\label{sec:qfp-exists}\<close>

text \<open>The following proof is simplified and generalized from
  Stouti--Maaden \cite{SM13}. We generalize so that the underlying
relation is not even reflexive or antisymmetric.\<close>

locale fixed_point_proof = less_eq_dualize
begin

context
  fixes f :: "'a \<Rightarrow> 'a" and S :: "'a set"
  assumes mono: "monotone (\<sqsubseteq>) (\<sqsubseteq>) f"
  assumes f_closed_S: "f ` S \<subseteq> S"
  assumes S_comp: "complete_in (\<sqsubseteq>) S"
begin

definition AA where "AA \<equiv>
  {A. A \<subseteq> S \<and> f ` A \<subseteq> A \<and> (\<forall>B \<subseteq> A. \<forall>b. extreme_bound_in (\<sqsubseteq>) S B b \<longrightarrow> b \<in> A)}"
definition C where "C \<equiv> \<Inter> AA"

qualified lemma S_AA: "S \<in> AA" by (auto simp: AA_def f_closed_S)

qualified lemma C_AA: "C \<in> AA"
proof (unfold  AA_def, intro CollectI conjI allI impI)
  show "C \<subseteq> S" using C_def S_AA f_closed_S by auto
  show "f ` C \<subseteq> C" unfolding C_def AA_def by auto
  fix B b assume BC: "B \<subseteq> C" and EBS: "extreme_bound_in (\<sqsubseteq>) S B b"
  { fix X assume "X \<in> AA"
    with EBS have "b\<in>X"
      apply (unfold AA_def,safe) by (metis BC C_def Inf_lower subset_trans)
  }
  then show "b \<in> C" by (auto simp: C_def AA_def)
qed

lemma quasi_fixed_point_in_C: "\<exists>c \<in> C. f c \<sim> c"
proof-
  obtain c where c: "extreme_bound_in (\<sqsubseteq>) S C c"
    using S_comp unfolding complete_in_def C_def
    by (metis InterE S_AA subset_iff)
  then have cS: "c \<in> S" by auto
  show "\<exists>c \<in> C. f c \<sim> c"
  proof (intro conjI bexI)
    show cCS: "c \<in> C" using AA_def C_AA c by auto
    then have "f c \<in> C" using AA_def C_AA by auto
    then show "f c \<sqsubseteq> c" using f_closed_S cS c by auto
    show "c \<sqsubseteq> f c"
    proof-
      define D where "D \<equiv> {x \<in> C. x \<sqsubseteq> f c}"
      have "D \<in> AA"
      proof (unfold  AA_def, intro CollectI conjI allI impI)
        show "D \<subseteq> S"
          unfolding D_def C_def using S_AA f_closed_S by auto
        have fxC: "x \<in> C \<Longrightarrow> x \<sqsubseteq> f c \<Longrightarrow> f x \<in> C" for x using C_AA by (auto simp: AA_def)
        show "f ` D \<subseteq> D"
        proof (unfold D_def, safe intro!: fxC)
          fix x assume xC: "x \<in> C"
          have "x \<sqsubseteq> c" using c xC by auto
          then show "f x \<sqsubseteq> f c" using mono by (auto dest:monotoneD)
        qed
        have DC: "D \<subseteq> C" unfolding D_def by auto
        fix B b assume BD: "B \<subseteq> D" and BS: "extreme_bound_in (\<sqsubseteq>) S B b"
        have "B \<subseteq> C" using DC BD by auto
        then have bC: "b \<in> C" using C_AA BS by (auto simp: AA_def)
        have bfc: "\<forall>a\<in>B. a \<sqsubseteq> f c" using BD unfolding D_def by auto
        with f_closed_S cS BS
        have "b \<sqsubseteq> f c" by (auto simp: extreme_def image_subset_iff)
        with bC show "b \<in> D" unfolding D_def by auto
      qed
      then have "C \<subseteq> D" unfolding C_def by auto
      then show "c \<sqsubseteq> f c" using cCS unfolding D_def by auto
    qed
  qed
qed

lemma quasi_fixed_point: "\<exists>s \<in> S. f s \<sim> s" using quasi_fixed_point_in_C S_AA C_def by auto

lemma ex_extreme_quasi_fixed_point:
  assumes attract: "\<forall>q x. f q \<sim> q \<longrightarrow> x \<sqsubseteq> f q \<longrightarrow> x \<sqsubseteq> q"
  shows "Ex (extreme (\<sqsupseteq>) {q \<in> S. f q \<sim> q})"
proof-
  define A where "A \<equiv> {a \<in> S. \<forall>s \<in> S. f s \<sim> s \<longrightarrow> a \<sqsubseteq> s}"
  have "A \<in> AA"
  proof (unfold AA_def, intro CollectI conjI allI impI)
    show AS: "A \<subseteq> S" unfolding A_def by auto
    { fix x assume xA: "x \<in> A"
      have "f x \<in> A"
      proof (unfold A_def, intro CollectI conjI)
        have "x \<in> S" using xA unfolding A_def by auto
        then show "f x \<in> S" using f_closed_S by auto
        { fix s assume sS: "s \<in> S" and sf: "f s \<sim> s"
          then have "x \<sqsubseteq> s" using xA sS sf A_def by auto
          then have "f x \<sqsubseteq> s" using attract mono
            unfolding A_def by (meson monotoneD sf)
        }
        then show "\<forall>s\<in>S. f s \<sim> s \<longrightarrow> f x \<sqsubseteq> s" by auto
      qed
    }
    then show "f ` A \<subseteq> A" by auto
    fix B b assume BA: "B \<subseteq> A" and b: "extreme_bound_in (\<sqsubseteq>) S B b"
    then have "B \<subseteq> S" unfolding A_def using BA AS by auto
    with BA b have bS: "b \<in> S" by auto
    { fix s assume sS: "s \<in> S" and sf: "f s \<sim> s"
      have "bound (\<sqsubseteq>) B s"  using sS BA b A_def sf by auto
    }
    with b have "\<forall>s\<in>S. f s \<sim> s \<longrightarrow> b \<sqsubseteq> s" by auto
    then show "b \<in> A" using bS by (auto simp: A_def)
  qed
  then have "C \<subseteq> A" by (simp add: C_def Inf_lower)
  then have "\<exists>a \<in> A. f a \<sim> a"
    using quasi_fixed_point_in_C by auto
  then obtain a where aA: "a \<in> A" and faa: "f a \<sim> a" by auto
  with aA A_def have "extreme (\<sqsupseteq>) {q \<in> S. f q \<sim> q} a" by (auto simp: extreme_def)
  then show ?thesis by auto
qed

end

end

context complete begin

lemma complete_in_UNIV[intro!]: "complete_in (\<sqsubseteq>) UNIV"
  unfolding complete_in_def using complete by auto

interpretation fixed_point_proof.

theorem monotone_imp_ex_quasi_fixed_point:
  assumes mono: "monotone (\<sqsubseteq>) (\<sqsubseteq>) f"
  shows "\<exists>s. f s \<sim> s"
proof-
  have Ucl: "f ` UNIV \<subseteq> UNIV" by auto
  obtain s where sC: "s \<in> C f UNIV" and fss: "f s \<sim> s"
    using quasi_fixed_point_in_C[OF mono Ucl complete_in_UNIV] by auto
  show "\<exists>s. f s \<sim> s" using fss by auto
qed

end

context complete_antisymmetric begin

corollary monotone_imp_ex_fixed_point:
  assumes mono: "monotone (\<sqsubseteq>) (\<sqsubseteq>) f"
  shows "\<exists>s. f s = s"
  using monotone_imp_ex_quasi_fixed_point[OF mono] by auto

end

subsection \<open>Completeness of Quasi-Fixed Points\<close>
text \<open>\label{sec:qfp-complete}\<close>

text \<open>We now show that fixed points are complete in a complete trellis,
which strengthens the existing result by Stouti and Maaden who showed the existence of
the least fixed point. Below we derive an even more general result by dropping reflexivity.\<close>

text \<open>We first prove that, under attractivity, the set of quasi-fixed points is complete.\<close>

context fixed_point_proof begin

lemma attract_imp_qfp_complete:
  assumes comp: "complete (\<sqsubseteq>)"
  assumes mono: "monotone (\<sqsubseteq>) (\<sqsubseteq>) f"
  assumes attract: "\<forall>q x. f q \<sim> q \<longrightarrow> x \<sqsubseteq> f q \<longrightarrow> x \<sqsubseteq> q"
  assumes dual_attract: "\<forall>q x. f q \<sim> q \<longrightarrow> f q \<sqsubseteq> x \<longrightarrow> q \<sqsubseteq> x"
  shows "complete_in (\<sqsubseteq>) {s. f s \<sim> s}"
proof (intro complete_inI)
  interpret complete using comp.
  fix A assume Afix: "A \<subseteq> {s. f s \<sim> s}"
  define S where "S \<equiv> {s. \<forall>a \<in> A. a \<sqsubseteq> s}"
  { fix s a assume as: "\<forall>a \<in> A. a \<sqsubseteq> s" and aA: "a \<in> A"
    have "a \<sqsubseteq> f s"
    proof (rule dual_attract[rule_format])
      have "a \<sqsubseteq> s" using as aA by auto
      then show "f a \<sqsubseteq> f s" using mono by (simp add: monotone_def)
      show "f a \<sim> a" using Afix aA by auto
    qed
  }
  then have f_closed_S: "f ` S \<subseteq> S" unfolding S_def by auto
  have comp_S_dual: "complete_in (\<sqsupseteq>) S"
  proof (unfold complete_in_def, intro allI impI)
    fix B assume BS: "B \<subseteq> S"
    then obtain b where bB: "extreme_bound (\<sqsupseteq>) B b" using dual.complete by auto
    show "Ex (extreme_bound_in (\<sqsupseteq>) S B)"
    proof (intro exI extreme_bound_inI)
      { fix a assume aA: "a \<in> A"
        then have "\<forall>c \<in> B. a \<sqsubseteq> c" using BS aA S_def by auto
        then have "a \<sqsubseteq> b" using bB by blast
      }
      then show "b \<in> S" unfolding S_def by auto
      show "x \<in> B \<Longrightarrow> b \<sqsubseteq> x" for x using bB by auto
      fix c assume "bound (\<sqsupseteq>) B c"
      then show "c \<sqsubseteq> b" using bB by blast
    qed
  qed
  then have comp_S: "complete_in (\<sqsubseteq>) S" using complete_in_dual by auto
  then obtain L where LefpS: "extreme (\<sqsupseteq>) {q \<in> S. f q \<sim> q} L"
    using ex_extreme_quasi_fixed_point[OF mono f_closed_S comp_S attract]
    by auto
  show "Ex (extreme_bound_in (\<sqsubseteq>) {s. f s \<sim> s} A)"
  proof (intro exI extreme_bound_inI)
    show "L \<in> {s. f s \<sim> s}" using LefpS by auto
    fix a assume "a \<in> A"
    with LefpS show "a \<sqsubseteq> L" by (auto simp: S_def)
  next
    fix c assume c: "bound (\<sqsubseteq>) A c" and cfix: "c \<in> {s. f s \<sim> s}"
    from c have "c \<in> S" by (auto simp: S_def)
    with cfix show "L \<sqsubseteq> c" using LefpS c by auto
  qed
qed

end

context complete_attractive begin

interpretation fixed_point_proof.

theorem monotone_imp_quasi_fixed_points_complete:
  assumes mono: "monotone (\<sqsubseteq>) (\<sqsubseteq>) f"
  shows "complete_in (\<sqsubseteq>) {s. f s \<sim> s}"
  by (rule attract_imp_qfp_complete[OF complete_axioms mono], auto dest: attract dual.attract)

end

text \<open>The next lemma shows that in a complete relation, two related sets of
strict fixed points have a quasi-fixed point in between.\<close>

context fixed_point_proof begin

lemma qfp_interpolant:
  assumes comp: "complete (\<sqsubseteq>)" and mono: "monotone (\<sqsubseteq>) (\<sqsubseteq>) f"
    and AB: "\<forall>a \<in> A. \<forall>b \<in> B. a \<sqsubseteq> b"
    and Afp: "\<forall>a \<in> A. f a = a"
    and Bfp: "\<forall>b \<in> B. f b = b"
  shows "\<exists>t. (f t \<sim> t) \<and> (\<forall>a \<in> A. a \<sqsubseteq> t) \<and> (\<forall>b \<in> B. t \<sqsubseteq> b)"
proof-
  interpret complete using comp.
  define T where "T \<equiv> {t. (\<forall>a \<in> A. a \<sqsubseteq> t) \<and> (\<forall>b \<in> B. t \<sqsubseteq> b)}"
  have f_closed_T: "f ` T \<subseteq> T"
  proof safe
    fix t assume tT: "t \<in> T"
    show "f t \<in> T"
    proof (unfold T_def, safe)
      fix a assume aA: "a \<in> A"
      with tT monotoneD[OF mono]
      have "f a \<sqsubseteq> f t" by (auto simp: T_def)
      with Afp aA show "a \<sqsubseteq> f t" by auto
    next
      fix b assume bB: "b \<in> B"
      with tT monotoneD[OF mono]
      have "f t \<sqsubseteq> f b" by (auto simp: T_def)
      with Bfp bB show "f t \<sqsubseteq> b" by auto
    qed
  qed
  have T_comp: "complete_in (\<sqsubseteq>) T"
  proof
    fix U assume UT: "U \<subseteq> T"
    obtain k where k: "extreme_bound (\<sqsubseteq>) (U \<union> A) k" using complete by auto
    have "extreme_bound_in (\<sqsubseteq>) T U k"
    proof (intro extreme_bound_inI)
      { fix b assume "b \<in> B"
        with AB T_def UT have "\<forall>x \<in> U \<union> A. x \<sqsubseteq> b" by auto
        with k have "k \<sqsubseteq> b" by auto
      }
      with k T_def show "k \<in> T" by auto
    next
      fix x assume "x \<in> U"
      with k show "x \<sqsubseteq> k" by auto
    next
      fix l
      assume "bound (\<sqsubseteq>) U l" and "l \<in> T"
      then have "\<forall>a \<in> U \<union> A. a \<sqsubseteq> l" by (auto simp: T_def)
      with k show "k \<sqsubseteq> l" by auto
    qed
    then show "Ex (extreme_bound_in (\<sqsubseteq>) T U)" by auto
  qed
  obtain t where "t \<in> T" and "f t \<sim> t"
    using quasi_fixed_point
    by (meson T_comp f_closed_T mono)
  then show ?thesis by (auto simp: T_def)
qed

end

text \<open>From this, we deduce that the set of strict fixed-points is also complete, assuming
only antisymmetry and attractivity.\<close>

context complete_antisymmetric begin

interpretation fixed_point_proof.

context
  fixes f assumes mono: "monotone (\<sqsubseteq>) (\<sqsubseteq>) f"
begin

theorem monotone_imp_fixed_points_complete:
  shows "complete_in (\<sqsubseteq>) {s. f s = s}"
proof
  fix A assume "A \<subseteq> {s. f s = s}"
  then have Afp: "\<forall>a\<in>A. f a = a" by auto
  define S where "S \<equiv> {s. \<forall>a \<in> A. a \<sqsubseteq> s}"
  have f_closed_S: "f ` S \<subseteq> S"
  proof safe
    fix s assume sS: "s \<in> S"
    show "f s \<in> S"
    proof(unfold S_def, safe)
      fix a assume aA: "a \<in> A"
      then have "f a \<sqsubseteq> f s" using S_def sS mono by (auto dest:monotoneD)
      then show "a \<sqsubseteq> f s" using Afp aA by auto
    qed
  qed
  have "complete_in (\<sqsupseteq>) S"
  proof
    fix B assume BS: "B \<subseteq> S"
    obtain L where BL: "extreme_bound (\<sqsupseteq>) B L" using  dual.complete by blast
    have "extreme_bound_in (\<sqsupseteq>) S B L"
    proof (intro extreme_bound_inI)
      { fix a assume aA: "a \<in> A"
        then have "\<forall>s \<in> B. a \<sqsubseteq> s" using BS S_def by auto
      }
      then have "\<forall>a \<in> A. a \<sqsubseteq> L" using BL by (simp add: extreme_bound_iff)
      then show "L \<in> S" using S_def by auto
      show "b \<in> B \<Longrightarrow> L \<sqsubseteq> b" for b using BL by auto
      show "\<And>c. bound (\<sqsupseteq>) B c \<Longrightarrow> c \<sqsubseteq> L" using BL by (auto elim!: boundE)
    qed
    then show "Ex (extreme_bound_in (\<sqsupseteq>) S B)" by auto
  qed
  then have comp_S: "complete_in (\<sqsubseteq>) S" using complete_in_dual by auto
  have "Ex (extreme (\<sqsupseteq>) {q \<in> S. f q \<sim> q})"
    apply (rule ex_extreme_quasi_fixed_point[OF mono f_closed_S comp_S])
    by auto
  then obtain q where q: "extreme (\<sqsupseteq>) {q \<in> S. f q \<sqsubseteq> q \<and> q \<sqsubseteq> f q} q" by auto
  have "extreme_bound_in (\<sqsubseteq>) {s. f s = s} A q"
  proof (intro extreme_bound_inI)
    show qfp: "q \<in> {s. f s = s}" using q by auto
    show Aq: "\<And>a. a \<in> A \<Longrightarrow> a \<sqsubseteq> q" using q S_def by auto
    fix c assume "bound (\<sqsubseteq>) A c" and "c \<in> {s. f s = s}"
    then have cfp: "f c = c" and Ac: "\<forall>a \<in> A. a \<sqsubseteq> c" by auto
    define D where [simp]: "D \<equiv> {c,q}"
    have AD: "\<forall>a \<in> A. \<forall>d \<in> D. a \<sqsubseteq> d" using Aq Ac by auto
    then have Dfp: "\<forall>d\<in>D. f d = d" using qfp cfp by auto
    then obtain t where t: "(f t \<sim> t) \<and> (\<forall>a \<in> A. a \<sqsubseteq> t) \<and> (\<forall>d \<in> D. t \<sqsubseteq> d)"
      using qfp_interpolant[OF complete_axioms mono AD Afp Dfp]
      by auto
    then have tq: "t \<sqsubseteq> q" by auto
    have "q \<sqsubseteq> t" using t q by (auto simp: S_def)
    with tq have "q = t" by auto
    also have "t \<sqsubseteq> c" using t by auto
    finally show "q \<sqsubseteq> c".
  qed
  then show "Ex (extreme_bound_in (\<sqsubseteq>) {s. f s = s} A)" by auto
qed

corollary monotone_imp_ex_extreme_fixed_point:
  shows "Ex (extreme (\<sqsupseteq>) {s. f s = s})"
  using complete_inD[OF monotone_imp_fixed_points_complete, of "{}"]
  by auto

end

end

section \<open>Kleene-Style Fixed Point Theorem\<close>

text \<open>Kleene's fixed-point theorem states that,
for a pointed directed complete partial order $\tp{A,\SLE}$
and a Scott-continuous map $f: A \to A$,
the supremum of $\set{f^n(\bot) \mid n\in\Nat}$ exists in $A$ and is a least
fixed point.
Mashburn \cite{mashburn83} generalized the result so that
$\tp{A,\SLE}$ is a $\omega$-complete partial order
and $f$ is $\omega$-continuous.

In this section we further generalize the result and show that
for $\omega$-complete relation $\tp{A,\SLE}$
and for every bottom element $\bot \in A$,
the set $\set{f^n(\bot) \mid n\in\Nat}$ has suprema (not necessarily unique, of
course) and,
they are quasi-fixed points.
Moreover, if $(\SLE)$ is attractive, then the suprema are precisely the least
quasi-fixed points.\<close>

subsection \<open>Scott Continuity, $\omega$-Completeness, $\omega$-Continuity\<close>

text \<open>In this Section, we formalize $\omega$-completeness, Scott continuity and $\omega$-continuity.
We then prove that a Scott continuous map is $\omega$-continuous and that an $\omega$-continuous
map is ``nearly'' monotone.\<close>

context
  fixes less_eq :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<sqsubseteq>" 50)
begin

definition "omega_continuous f \<equiv> \<forall>c :: nat \<Rightarrow> 'a. \<forall> b.
  monotone (\<le>) (\<sqsubseteq>) c \<longrightarrow>
  extreme_bound (\<sqsubseteq>) (range c) b \<longrightarrow> extreme_bound (\<sqsubseteq>) (f ` range c) (f b)"

lemma omega_continuousI[intro?]:
  assumes "\<And>c :: nat \<Rightarrow> 'a. \<And> b.
   monotone (\<le>) (\<sqsubseteq>) c \<Longrightarrow>
   extreme_bound (\<sqsubseteq>) (range c) b \<Longrightarrow> extreme_bound (\<sqsubseteq>) (f ` range c) (f b)"
  shows "omega_continuous f"
  using assms by (auto simp: omega_continuous_def)

lemma omega_continuousE[elim]:
  assumes "omega_continuous f"
    and "(\<And>c :: nat \<Rightarrow> 'a. \<And> b. monotone (\<le>) (\<sqsubseteq>) c \<Longrightarrow>
         extreme_bound (\<sqsubseteq>) (range c) b \<Longrightarrow> extreme_bound (\<sqsubseteq>) (f ` range c) (f b)
         ) \<Longrightarrow> thesis"
  shows "thesis"
  using assms by (auto simp: omega_continuous_def)

lemma omega_continuous_imp_mono_refl:
  assumes cont: "omega_continuous f"
    and xy: "x \<sqsubseteq> y" and xx: "x \<sqsubseteq> x" and yy: "y \<sqsubseteq> y"
  shows "f x \<sqsubseteq> f y"
proof-
  define c :: "nat \<Rightarrow> 'a" where "c \<equiv> \<lambda>i. if i = 0 then x else y"
  from xx xy yy have monoc: "monotone (\<le>) (\<sqsubseteq>) c"
    by (auto simp: c_def intro!: monotoneI)
  have "extreme_bound (\<sqsubseteq>) (range c) y" using xy yy by (auto simp: c_def)
  then have fboy: "extreme_bound (\<sqsubseteq>) (f ` range c) (f y)" using monoc cont by auto
  then show "f x \<sqsubseteq> f y" by (auto simp: c_def)
qed

definition "scott_continuous f \<equiv>
  \<forall>D b. directed (\<sqsubseteq>) D \<longrightarrow> extreme_bound (\<sqsubseteq>) D b \<longrightarrow> extreme_bound (\<sqsubseteq>) (f ` D) (f b)"

lemma scott_continuousI[intro?]:
  assumes "\<And>D b. directed (\<sqsubseteq>) D \<Longrightarrow> extreme_bound (\<sqsubseteq>) D b \<Longrightarrow> extreme_bound (\<sqsubseteq>) (f ` D) (f b)"
  shows "scott_continuous f"
  using assms by (auto simp: scott_continuous_def)

lemma scott_continuousE[elim]:
  assumes "scott_continuous f"
    and "(\<And>D b. directed (\<sqsubseteq>) D \<Longrightarrow>
         extreme_bound (\<sqsubseteq>) D b \<Longrightarrow> extreme_bound (\<sqsubseteq>) (f ` D) (f b)) \<Longrightarrow> thesis"
  shows "thesis"
  using assms by (auto simp: scott_continuous_def)

lemma scott_continuous_imp_mono_refl:
  assumes scott: "scott_continuous f"
    and xy: "x \<sqsubseteq> y" and yy: "y \<sqsubseteq> y"
  shows "f x \<sqsubseteq> f y"
proof-
  define D where "D \<equiv> {x,y}"
  from xy yy have dir_D
: "directed (\<sqsubseteq>) D" by (auto simp: D_def intro!: bexI[of _ y])
  have "extreme_bound (\<sqsubseteq>) D y" using xy yy by (auto simp: D_def)
  then have fboy: "extreme_bound (\<sqsubseteq>) (f ` D) (f y)" using dir_D scott by auto
  then show "f x \<sqsubseteq> f y" by (auto simp: D_def)
qed

lemma scott_continuous_imp_omega_continuous:
  assumes scott: "scott_continuous f" shows "omega_continuous f"
proof
  fix c :: "nat \<Rightarrow> 'a"
  assume "monotone (\<le>) (\<sqsubseteq>) c"
  from monotone_directed_image[OF this order.dual.dual.directed_UNIV] scott
  show "extreme_bound (\<sqsubseteq>) (range c) b \<Longrightarrow> extreme_bound (\<sqsubseteq>) (f ` range c) (f b)" for b
    by auto
qed

end

subsection \<open>Kleene's Fixed-Point Theorem\<close>

text \<open>The first part of Kleene's theorem demands to prove that the set
$\set{f^n(\bot) \mid n \in \Nat}$ has a supremum and
that all such are quasi-fixed points. We prove this claim without assuming
anything on the relation $\SLE$ besides $\omega$-completeness and one bottom element.\<close>

context fixed_point_proof begin

context
  fixes f
  assumes comp: "omega_complete (\<sqsubseteq>)"
  assumes cont: "omega_continuous (\<sqsubseteq>) f"
  fixes bot ("\<^bold>\<bottom>")
  assumes bot: "\<forall>q. \<^bold>\<bottom> \<sqsubseteq> q"
begin

interpretation omega_complete "(\<sqsubseteq>)" using comp.

abbreviation(input) fn where "fn n \<equiv> (f ^^ n) \<^bold>\<bottom>"

abbreviation(input) "Fn \<equiv> range fn"

lemma fn_ref: "fn n \<sqsubseteq> fn n"
  using omega_continuous_imp_mono_refl[OF cont] bot by (induct n, auto)

lemma fn_monotone: "monotone (\<le>) (\<sqsubseteq>) fn"
proof
  fix n m :: nat
  assume "n \<le> m"
  from le_Suc_ex[OF this] obtain k where m: "m = n + k" by auto
  from bot fn_ref omega_continuous_imp_mono_refl[OF cont]
  show "fn n \<sqsubseteq> fn m" by (unfold m, induct n, auto)
qed

lemma ex_kleene_fixed_point:
  shows "Ex (extreme_bound (\<sqsubseteq>) Fn)"
  using monotone_seq_complete[OF fn_monotone] by auto

lemma kleene_fixed_point_is_fixed:
  assumes q: "extreme_bound (\<sqsubseteq>) Fn q"
  shows "f q \<sim> q"
proof
  have fq: "extreme_bound (\<sqsubseteq>) (f ` Fn) (f q)"
    using q cont fn_monotone by auto
  with bot have nq: "fn n \<sqsubseteq> f q" for n
    by(induct n, auto simp: extreme_bound_iff)
  then show "q \<sqsubseteq> f q" using q by blast
  have "f (fn n) \<in> range fn" for n by (auto intro!: range_eqI[of _ _ "Suc n"])
  then have "f ` Fn \<subseteq> Fn" by auto
  then show "f q \<sqsubseteq> q" using q fq
    by (metis (no_types, lifting) bound_cmono extreme_def mem_Collect_eq)
qed

lemma kleene_fixed_point_is_dual_extreme:
  assumes attract: "\<forall>q x. f q \<sim> q \<longrightarrow> x \<sqsubseteq> f q \<longrightarrow> x \<sqsubseteq> q"
  assumes q: "extreme_bound (\<sqsubseteq>) Fn q"
  shows "extreme (\<sqsupseteq>) {s. f s \<sim> s} q"
proof(intro extremeI, unfold mem_Collect_eq, intro kleene_fixed_point_is_fixed[OF q])
  fix c assume cqfp: "f c \<sim> c"
  {
    fix n::nat
    have "fn n \<sqsubseteq> c"
    proof(induct n)
      case 0
      show ?case using bot by auto
    next
      case IH: (Suc n)
      have "c \<sqsubseteq> c" using attract cqfp by blast
      with IH have "fn (Suc n) \<sqsubseteq> f c"
        using omega_continuous_imp_mono_refl[OF cont] fn_ref by auto
      then show ?case using attract cqfp by blast
    qed
  }
  then show "q \<sqsubseteq> c" using q by blast
qed

lemma kleene_fixed_point_iff_dual_extreme:
  assumes attract: "\<forall>q x. f q \<sim> q \<longrightarrow> x \<sqsubseteq> f q \<longrightarrow> x \<sqsubseteq> q"
  assumes dual_attract: "\<forall>p q x. p \<sim> q \<longrightarrow> q \<sqsubseteq> x \<longrightarrow> p \<sqsubseteq> x"
  shows "extreme_bound (\<sqsubseteq>) Fn = extreme (\<sqsupseteq>) {s. f s \<sim> s}"
proof (intro ext iffI kleene_fixed_point_is_dual_extreme[OF attract])
  fix q
  assume q: "extreme (\<sqsupseteq>) {s. f s \<sim> s} q"
  from q have fqq: "f q \<sim> q" by auto
  from ex_kleene_fixed_point obtain k where k: "extreme_bound (\<sqsubseteq>) Fn k" by auto
  have qk: "q \<sim> k"
  proof
    from kleene_fixed_point_is_fixed[OF k] q
    show "q \<sqsubseteq> k" by auto
    from kleene_fixed_point_is_dual_extreme[OF _ k] q attract
    show "k \<sqsubseteq> q" by blast
  qed
  show "extreme_bound (\<sqsubseteq>) Fn q"
  proof (intro extreme_boundI,safe)
    fix n
    show "(f ^^ n) \<^bold>\<bottom> \<sqsubseteq> q"
      apply (induct n, auto intro: bot[rule_format])
      by (meson attract fn_ref fqq omega_continuous_imp_mono_refl[OF cont])
  next
    fix x
    assume "bound (\<sqsubseteq>) Fn x"
    with k have kx: "k \<sqsubseteq> x" by auto
    with dual_attract[rule_format, OF qk]
    show "q \<sqsubseteq> x" by auto
  qed
qed

end

end

context omega_complete begin

interpretation fixed_point_proof.

theorem kleene_quasi_fixed_point:
  assumes "omega_continuous (\<sqsubseteq>) f" and "\<forall>x. bo \<sqsubseteq> x"
  shows "\<exists>p. extreme_bound (\<sqsubseteq>) {(f ^^ n) bo |. n :: nat} p"
    and "extreme_bound (\<sqsubseteq>) {(f ^^ n) bo |. n :: nat} p \<Longrightarrow> f p \<sim> p"
  using ex_kleene_fixed_point[OF omega_complete_axioms assms]
  using kleene_fixed_point_is_fixed[OF omega_complete_axioms assms].

end

text \<open>Kleene's theorem also states that the quasi-fixed point found this way is a least one.
Again, attractivity is needed to prove this statement.\<close>

context attractive begin

interpretation fixed_point_proof.

corollary kleene_quasi_fixed_point_dual_extreme:
  assumes "omega_complete (\<sqsubseteq>)" and "omega_continuous (\<sqsubseteq>) f" and "\<forall>x. bo \<sqsubseteq> x"
  shows "extreme_bound (\<sqsubseteq>) {(f ^^ n) bo |. n :: nat} = extreme (\<sqsupseteq>) {s. f s \<sim> s}"
  apply (rule kleene_fixed_point_iff_dual_extreme[OF assms])
  by (auto dest: attract dual.attract)

end

context antisymmetric begin

interpretation fixed_point_proof.

corollary kleene_fixed_point_is_fixed:
  assumes "omega_complete (\<sqsubseteq>)" and "omega_continuous (\<sqsubseteq>) f" and "\<forall>x. bo \<sqsubseteq> x"
    and "extreme_bound (\<sqsubseteq>) {(f ^^ n) bo |. n :: nat} p"
  shows "f p = p"
  using kleene_fixed_point_is_fixed[OF assms] by auto

end

end


(*  Title:      HOL/Algebra/Order.thy
    Author:     Clemens Ballarin, started 7 November 2003
    Copyright:  Clemens Ballarin

Most congruence rules by Stephan Hohe.
With additional contributions from Alasdair Armstrong and Simon Foster.
*)

theory Order
  imports
    Congruence
begin

section \<open>Orders\<close>

subsection \<open>Partial Orders\<close>

record 'a gorder = "'a eq_object" +
  le :: "['a, 'a] => bool" (infixl "\<sqsubseteq>\<index>" 50)

abbreviation inv_gorder :: "_ \<Rightarrow> 'a gorder" where
  "inv_gorder L \<equiv>
   \<lparr> carrier = carrier L,
     eq = (.=\<^bsub>L\<^esub>),
     le = (\<lambda> x y. y \<sqsubseteq>\<^bsub>L \<^esub>x) \<rparr>"

lemma inv_gorder_inv:
  "inv_gorder (inv_gorder L) = L"
  by simp

locale weak_partial_order = equivalence L for L (structure) +
  assumes le_refl [intro, simp]:
      "x \<in> carrier L \<Longrightarrow> x \<sqsubseteq> x"
    and weak_le_antisym [intro]:
      "\<lbrakk>x \<sqsubseteq> y; y \<sqsubseteq> x; x \<in> carrier L; y \<in> carrier L\<rbrakk> \<Longrightarrow> x .= y"
    and le_trans [trans]:
      "\<lbrakk>x \<sqsubseteq> y; y \<sqsubseteq> z; x \<in> carrier L; y \<in> carrier L; z \<in> carrier L\<rbrakk> \<Longrightarrow> x \<sqsubseteq> z"
    and le_cong:
      "\<lbrakk>x .= y; z .= w; x \<in> carrier L; y \<in> carrier L; z \<in> carrier L; w \<in> carrier L\<rbrakk> \<Longrightarrow>
      x \<sqsubseteq> z \<longleftrightarrow> y \<sqsubseteq> w"

definition
  lless :: "[_, 'a, 'a] => bool" (infixl "\<sqsubset>\<index>" 50)
  where "x \<sqsubset>\<^bsub>L\<^esub> y \<longleftrightarrow> x \<sqsubseteq>\<^bsub>L\<^esub> y \<and> x .\<noteq>\<^bsub>L\<^esub> y"

subsubsection \<open>The order relation\<close>

context weak_partial_order
begin

lemma le_cong_l [intro, trans]:
  "\<lbrakk>x .= y; y \<sqsubseteq> z; x \<in> carrier L; y \<in> carrier L; z \<in> carrier L\<rbrakk> \<Longrightarrow> x \<sqsubseteq> z"
  by (auto intro: le_cong [THEN iffD2])

lemma le_cong_r [intro, trans]:
  "\<lbrakk>x \<sqsubseteq> y; y .= z; x \<in> carrier L; y \<in> carrier L; z \<in> carrier L\<rbrakk> \<Longrightarrow> x \<sqsubseteq> z"
  by (auto intro: le_cong [THEN iffD1])

lemma weak_refl [intro, simp]: "\<lbrakk>x .= y; x \<in> carrier L; y \<in> carrier L\<rbrakk> \<Longrightarrow> x \<sqsubseteq> y"
  by (simp add: le_cong_l)

end

lemma weak_llessI:
  fixes R (structure)
  assumes "x \<sqsubseteq> y" and "\<not>(x .= y)"
  shows "x \<sqsubset> y"
  using assms unfolding lless_def by simp

lemma lless_imp_le:
  fixes R (structure)
  assumes "x \<sqsubset> y"
  shows "x \<sqsubseteq> y"
  using assms unfolding lless_def by simp

lemma weak_lless_imp_not_eq:
  fixes R (structure)
  assumes "x \<sqsubset> y"
  shows "\<not> (x .= y)"
  using assms unfolding lless_def by simp

lemma weak_llessE:
  fixes R (structure)
  assumes p: "x \<sqsubset> y" and e: "\<lbrakk>x \<sqsubseteq> y; \<not> (x .= y)\<rbrakk> \<Longrightarrow> P"
  shows "P"
  using p by (blast dest: lless_imp_le weak_lless_imp_not_eq e)

lemma (in weak_partial_order) lless_cong_l [trans]:
  assumes xx': "x .= x'"
    and xy: "x' \<sqsubset> y"
    and carr: "x \<in> carrier L" "x' \<in> carrier L" "y \<in> carrier L"
  shows "x \<sqsubset> y"
  using assms unfolding lless_def by (auto intro: trans sym)

lemma (in weak_partial_order) lless_cong_r [trans]:
  assumes xy: "x \<sqsubset> y"
    and  yy': "y .= y'"
    and carr: "x \<in> carrier L" "y \<in> carrier L" "y' \<in> carrier L"
  shows "x \<sqsubset> y'"
  using assms unfolding lless_def by (auto intro: trans sym)  (*slow*)

lemma (in weak_partial_order) lless_antisym:
  assumes "a \<in> carrier L" "b \<in> carrier L"
    and "a \<sqsubset> b" "b \<sqsubset> a"
  shows "P"
  using assms
  by (elim weak_llessE) auto

lemma (in weak_partial_order) lless_trans [trans]:
  assumes "a \<sqsubset> b" "b \<sqsubset> c"
    and carr[simp]: "a \<in> carrier L" "b \<in> carrier L" "c \<in> carrier L"
  shows "a \<sqsubset> c"
  using assms unfolding lless_def by (blast dest: le_trans intro: sym)

lemma weak_partial_order_subset:
  assumes "weak_partial_order L" "A \<subseteq> carrier L"
  shows "weak_partial_order (L\<lparr> carrier := A \<rparr>)"
proof -
  interpret L: weak_partial_order L
    by (simp add: assms)
  interpret equivalence "(L\<lparr> carrier := A \<rparr>)"
    by (simp add: L.equivalence_axioms assms(2) equivalence_subset)
  show ?thesis
    apply (unfold_locales, simp_all)
    using assms(2) apply auto[1]
    using assms(2) apply auto[1]
    apply (meson L.le_trans assms(2) contra_subsetD)
    apply (meson L.le_cong assms(2) subsetCE)
  done
qed

subsubsection \<open>Upper and lower bounds of a set\<close>

definition
  Upper :: "[_, 'a set] => 'a set"
  where "Upper L A = {u. (\<forall>x. x \<in> A \<inter> carrier L \<longrightarrow> x \<sqsubseteq>\<^bsub>L\<^esub> u)} \<inter> carrier L"

definition
  Lower :: "[_, 'a set] => 'a set"
  where "Lower L A = {l. (\<forall>x. x \<in> A \<inter> carrier L \<longrightarrow> l \<sqsubseteq>\<^bsub>L\<^esub> x)} \<inter> carrier L"

lemma Lower_dual [simp]:
  "Lower (inv_gorder L) A = Upper L A"
  by (simp add:Upper_def Lower_def)

lemma Upper_dual [simp]:
  "Upper (inv_gorder L) A = Lower L A"
  by (simp add:Upper_def Lower_def)

lemma (in weak_partial_order) equivalence_dual: "equivalence (inv_gorder L)"
  by (rule equivalence.intro) (auto simp: intro: sym trans)

lemma  (in weak_partial_order) dual_weak_order: "weak_partial_order (inv_gorder L)"
  by intro_locales (auto simp add: weak_partial_order_axioms_def le_cong intro: equivalence_dual le_trans)

lemma (in weak_partial_order) dual_eq_iff [simp]: "A {.=}\<^bsub>inv_gorder L\<^esub> A' \<longleftrightarrow> A {.=} A'"
  by (auto simp: set_eq_def elem_def)

lemma dual_weak_order_iff:
  "weak_partial_order (inv_gorder A) \<longleftrightarrow> weak_partial_order A"
proof
  assume "weak_partial_order (inv_gorder A)"
  then interpret dpo: weak_partial_order "inv_gorder A"
  rewrites "carrier (inv_gorder A) = carrier A"
  and   "le (inv_gorder A)      = (\<lambda> x y. le A y x)"
  and   "eq (inv_gorder A)      = eq A"
    by (simp_all)
  show "weak_partial_order A"
    by (unfold_locales, auto intro: dpo.sym dpo.trans dpo.le_trans)
next
  assume "weak_partial_order A"
  thus "weak_partial_order (inv_gorder A)"
    by (metis weak_partial_order.dual_weak_order)
qed

lemma Upper_closed [iff]:
  "Upper L A \<subseteq> carrier L"
  by (unfold Upper_def) clarify

lemma Upper_memD [dest]:
  fixes L (structure)
  shows "\<lbrakk>u \<in> Upper L A; x \<in> A; A \<subseteq> carrier L\<rbrakk> \<Longrightarrow> x \<sqsubseteq> u \<and> u \<in> carrier L"
  by (unfold Upper_def) blast

lemma (in weak_partial_order) Upper_elemD [dest]:
  "\<lbrakk>u .\<in> Upper L A; u \<in> carrier L; x \<in> A; A \<subseteq> carrier L\<rbrakk> \<Longrightarrow> x \<sqsubseteq> u"
  unfolding Upper_def elem_def
  by (blast dest: sym)

lemma Upper_memI:
  fixes L (structure)
  shows "\<lbrakk>!! y. y \<in> A \<Longrightarrow> y \<sqsubseteq> x; x \<in> carrier L\<rbrakk> \<Longrightarrow> x \<in> Upper L A"
  by (unfold Upper_def) blast

lemma (in weak_partial_order) Upper_elemI:
  "\<lbrakk>!! y. y \<in> A \<Longrightarrow> y \<sqsubseteq> x; x \<in> carrier L\<rbrakk> \<Longrightarrow> x .\<in> Upper L A"
  unfolding Upper_def by blast

lemma Upper_antimono:
  "A \<subseteq> B \<Longrightarrow> Upper L B \<subseteq> Upper L A"
  by (unfold Upper_def) blast

lemma (in weak_partial_order) Upper_is_closed [simp]:
  "A \<subseteq> carrier L \<Longrightarrow> is_closed (Upper L A)"
  by (rule is_closedI) (blast intro: Upper_memI)+

lemma (in weak_partial_order) Upper_mem_cong:
  assumes  "a' \<in> carrier L" "A \<subseteq> carrier L" "a .= a'" "a \<in> Upper L A"
  shows "a' \<in> Upper L A"
  by (metis assms Upper_closed Upper_is_closed closure_of_eq complete_classes)

lemma (in weak_partial_order) Upper_semi_cong:
  assumes "A \<subseteq> carrier L" "A {.=} A'"
  shows "Upper L A \<subseteq> Upper L A'"
  unfolding Upper_def
   by clarsimp (meson assms equivalence.refl equivalence_axioms le_cong set_eqD2 subset_eq)

lemma (in weak_partial_order) Upper_cong:
  assumes "A \<subseteq> carrier L" "A' \<subseteq> carrier L" "A {.=} A'"
  shows "Upper L A = Upper L A'"
  using assms by (simp add: Upper_semi_cong set_eq_sym subset_antisym)

lemma Lower_closed [intro!, simp]:
  "Lower L A \<subseteq> carrier L"
  by (unfold Lower_def) clarify

lemma Lower_memD [dest]:
  fixes L (structure)
  shows "\<lbrakk>l \<in> Lower L A; x \<in> A; A \<subseteq> carrier L\<rbrakk> \<Longrightarrow> l \<sqsubseteq> x \<and> l \<in> carrier L"
  by (unfold Lower_def) blast

lemma Lower_memI:
  fixes L (structure)
  shows "\<lbrakk>!! y. y \<in> A \<Longrightarrow> x \<sqsubseteq> y; x \<in> carrier L\<rbrakk> \<Longrightarrow> x \<in> Lower L A"
  by (unfold Lower_def) blast

lemma Lower_antimono:
  "A \<subseteq> B \<Longrightarrow> Lower L B \<subseteq> Lower L A"
  by (unfold Lower_def) blast

lemma (in weak_partial_order) Lower_is_closed [simp]:
  "A \<subseteq> carrier L \<Longrightarrow> is_closed (Lower L A)"
  by (rule is_closedI) (blast intro: Lower_memI dest: sym)+

lemma (in weak_partial_order) Lower_mem_cong:
  assumes "a' \<in> carrier L"  "A \<subseteq> carrier L" "a .= a'" "a \<in> Lower L A"
  shows "a' \<in> Lower L A"
  by (meson assms Lower_closed Lower_is_closed is_closed_eq subsetCE)

lemma (in weak_partial_order) Lower_cong:
  assumes "A \<subseteq> carrier L" "A' \<subseteq> carrier L" "A {.=} A'"
  shows "Lower L A = Lower L A'"
  unfolding Upper_dual [symmetric]
  by (rule weak_partial_order.Upper_cong [OF dual_weak_order]) (simp_all add: assms)

text \<open>Jacobson: Theorem 8.1\<close>

lemma Lower_empty [simp]:
  "Lower L {} = carrier L"
  by (unfold Lower_def) simp

lemma Upper_empty [simp]:
  "Upper L {} = carrier L"
  by (unfold Upper_def) simp

subsubsection \<open>Least and greatest, as predicate\<close>

definition
  least :: "[_, 'a, 'a set] => bool"
  where "least L l A \<longleftrightarrow> A \<subseteq> carrier L \<and> l \<in> A \<and> (\<forall>x\<in>A. l \<sqsubseteq>\<^bsub>L\<^esub> x)"

definition
  greatest :: "[_, 'a, 'a set] => bool"
  where "greatest L g A \<longleftrightarrow> A \<subseteq> carrier L \<and> g \<in> A \<and> (\<forall>x\<in>A. x \<sqsubseteq>\<^bsub>L\<^esub> g)"

text (in weak_partial_order) \<open>Could weaken these to \<^term>\<open>l \<in> carrier L \<and> l .\<in> A\<close> and \<^term>\<open>g \<in> carrier L \<and> g .\<in> A\<close>.\<close>

lemma least_dual [simp]:
  "least (inv_gorder L) x A = greatest L x A"
  by (simp add:least_def greatest_def)

lemma greatest_dual [simp]:
  "greatest (inv_gorder L) x A = least L x A"
  by (simp add:least_def greatest_def)

lemma least_closed [intro, simp]:
  "least L l A \<Longrightarrow> l \<in> carrier L"
  by (unfold least_def) fast

lemma least_mem:
  "least L l A \<Longrightarrow> l \<in> A"
  by (unfold least_def) fast

lemma (in weak_partial_order) weak_least_unique:
  "\<lbrakk>least L x A; least L y A\<rbrakk> \<Longrightarrow> x .= y"
  by (unfold least_def) blast

lemma least_le:
  fixes L (structure)
  shows "\<lbrakk>least L x A; a \<in> A\<rbrakk> \<Longrightarrow> x \<sqsubseteq> a"
  by (unfold least_def) fast

lemma (in weak_partial_order) least_cong:
  "\<lbrakk>x .= x'; x \<in> carrier L; x' \<in> carrier L; is_closed A\<rbrakk> \<Longrightarrow> least L x A = least L x' A"
  unfolding least_def
  by (meson is_closed_eq is_closed_eq_rev le_cong local.refl subset_iff)

abbreviation is_lub :: "[_, 'a, 'a set] => bool"
where "is_lub L x A \<equiv> least L x (Upper L A)"

text (in weak_partial_order) \<open>\<^const>\<open>least\<close> is not congruent in the second parameter for
  \<^term>\<open>A {.=} A'\<close>\<close>

lemma (in weak_partial_order) least_Upper_cong_l:
  assumes "x .= x'"
    and "x \<in> carrier L" "x' \<in> carrier L"
    and "A \<subseteq> carrier L"
  shows "least L x (Upper L A) = least L x' (Upper L A)"
  apply (rule least_cong) using assms by auto

lemma (in weak_partial_order) least_Upper_cong_r:
  assumes "A \<subseteq> carrier L" "A' \<subseteq> carrier L" "A {.=} A'"
  shows "least L x (Upper L A) = least L x (Upper L A')"
  using Upper_cong assms by auto

lemma least_UpperI:
  fixes L (structure)
  assumes above: "!! x. x \<in> A \<Longrightarrow> x \<sqsubseteq> s"
    and below: "!! y. y \<in> Upper L A \<Longrightarrow> s \<sqsubseteq> y"
    and L: "A \<subseteq> carrier L"  "s \<in> carrier L"
  shows "least L s (Upper L A)"
proof -
  have "Upper L A \<subseteq> carrier L" by simp
  moreover from above L have "s \<in> Upper L A" by (simp add: Upper_def)
  moreover from below have "\<forall>x \<in> Upper L A. s \<sqsubseteq> x" by fast
  ultimately show ?thesis by (simp add: least_def)
qed

lemma least_Upper_above:
  fixes L (structure)
  shows "\<lbrakk>least L s (Upper L A); x \<in> A; A \<subseteq> carrier L\<rbrakk> \<Longrightarrow> x \<sqsubseteq> s"
  by (unfold least_def) blast

lemma greatest_closed [intro, simp]:
  "greatest L l A \<Longrightarrow> l \<in> carrier L"
  by (unfold greatest_def) fast

lemma greatest_mem:
  "greatest L l A \<Longrightarrow> l \<in> A"
  by (unfold greatest_def) fast

lemma (in weak_partial_order) weak_greatest_unique:
  "\<lbrakk>greatest L x A; greatest L y A\<rbrakk> \<Longrightarrow> x .= y"
  by (unfold greatest_def) blast

lemma greatest_le:
  fixes L (structure)
  shows "\<lbrakk>greatest L x A; a \<in> A\<rbrakk> \<Longrightarrow> a \<sqsubseteq> x"
  by (unfold greatest_def) fast

lemma (in weak_partial_order) greatest_cong:
  "\<lbrakk>x .= x'; x \<in> carrier L; x' \<in> carrier L; is_closed A\<rbrakk> \<Longrightarrow>
  greatest L x A = greatest L x' A"
  unfolding greatest_def
  by (meson is_closed_eq_rev le_cong_r local.sym subset_eq)

abbreviation is_glb :: "[_, 'a, 'a set] => bool"
where "is_glb L x A \<equiv> greatest L x (Lower L A)"

text (in weak_partial_order) \<open>\<^const>\<open>greatest\<close> is not congruent in the second parameter for
  \<^term>\<open>A {.=} A'\<close> \<close>

lemma (in weak_partial_order) greatest_Lower_cong_l:
  assumes "x .= x'"
    and "x \<in> carrier L" "x' \<in> carrier L"
  shows "greatest L x (Lower L A) = greatest L x' (Lower L A)"
proof -
  have "\<forall>A. is_closed (Lower L (A \<inter> carrier L))"
    by simp
  then show ?thesis
    by (simp add: Lower_def assms greatest_cong)
qed

lemma (in weak_partial_order) greatest_Lower_cong_r:
  assumes "A \<subseteq> carrier L" "A' \<subseteq> carrier L" "A {.=} A'"
  shows "greatest L x (Lower L A) = greatest L x (Lower L A')"
  using Lower_cong assms by auto

lemma greatest_LowerI:
  fixes L (structure)
  assumes below: "!! x. x \<in> A \<Longrightarrow> i \<sqsubseteq> x"
    and above: "!! y. y \<in> Lower L A \<Longrightarrow> y \<sqsubseteq> i"
    and L: "A \<subseteq> carrier L"  "i \<in> carrier L"
  shows "greatest L i (Lower L A)"
proof -
  have "Lower L A \<subseteq> carrier L" by simp
  moreover from below L have "i \<in> Lower L A" by (simp add: Lower_def)
  moreover from above have "\<forall>x \<in> Lower L A. x \<sqsubseteq> i" by fast
  ultimately show ?thesis by (simp add: greatest_def)
qed

lemma greatest_Lower_below:
  fixes L (structure)
  shows "\<lbrakk>greatest L i (Lower L A); x \<in> A; A \<subseteq> carrier L\<rbrakk> \<Longrightarrow> i \<sqsubseteq> x"
  by (unfold greatest_def) blast

subsubsection \<open>Intervals\<close>

definition
  at_least_at_most :: "('a, 'c) gorder_scheme \<Rightarrow> 'a => 'a => 'a set" ("(1\<lbrace>_.._\<rbrace>\<index>)")
  where "\<lbrace>l..u\<rbrace>\<^bsub>A\<^esub> = {x \<in> carrier A. l \<sqsubseteq>\<^bsub>A\<^esub> x \<and> x \<sqsubseteq>\<^bsub>A\<^esub> u}"

context weak_partial_order
begin

  lemma at_least_at_most_upper [dest]:
    "x \<in> \<lbrace>a..b\<rbrace> \<Longrightarrow> x \<sqsubseteq> b"
    by (simp add: at_least_at_most_def)

  lemma at_least_at_most_lower [dest]:
    "x \<in> \<lbrace>a..b\<rbrace> \<Longrightarrow> a \<sqsubseteq> x"
    by (simp add: at_least_at_most_def)

  lemma at_least_at_most_closed: "\<lbrace>a..b\<rbrace> \<subseteq> carrier L"
    by (auto simp add: at_least_at_most_def)

  lemma at_least_at_most_member [intro]:
    "\<lbrakk>x \<in> carrier L; a \<sqsubseteq> x; x \<sqsubseteq> b\<rbrakk> \<Longrightarrow> x \<in> \<lbrace>a..b\<rbrace>"
    by (simp add: at_least_at_most_def)

end

subsubsection \<open>Isotone functions\<close>

definition isotone :: "('a, 'c) gorder_scheme \<Rightarrow> ('b, 'd) gorder_scheme \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> bool"
  where
  "isotone A B f \<equiv>
   weak_partial_order A \<and> weak_partial_order B \<and>
   (\<forall>x\<in>carrier A. \<forall>y\<in>carrier A. x \<sqsubseteq>\<^bsub>A\<^esub> y \<longrightarrow> f x \<sqsubseteq>\<^bsub>B\<^esub> f y)"

lemma isotoneI [intro?]:
  fixes f :: "'a \<Rightarrow> 'b"
  assumes "weak_partial_order L1"
          "weak_partial_order L2"
          "(\<And>x y. \<lbrakk>x \<in> carrier L1; y \<in> carrier L1; x \<sqsubseteq>\<^bsub>L1\<^esub> y\<rbrakk>
                   \<Longrightarrow> f x \<sqsubseteq>\<^bsub>L2\<^esub> f y)"
  shows "isotone L1 L2 f"
  using assms by (auto simp add:isotone_def)

abbreviation Monotone :: "('a, 'b) gorder_scheme \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> bool" ("Mono\<index>")
  where "Monotone L f \<equiv> isotone L L f"

lemma use_iso1:
  "\<lbrakk>isotone A A f; x \<in> carrier A; y \<in> carrier A; x \<sqsubseteq>\<^bsub>A\<^esub> y\<rbrakk> \<Longrightarrow>
   f x \<sqsubseteq>\<^bsub>A\<^esub> f y"
  by (simp add: isotone_def)

lemma use_iso2:
  "\<lbrakk>isotone A B f; x \<in> carrier A; y \<in> carrier A; x \<sqsubseteq>\<^bsub>A\<^esub> y\<rbrakk> \<Longrightarrow>
   f x \<sqsubseteq>\<^bsub>B\<^esub> f y"
  by (simp add: isotone_def)

lemma iso_compose:
  "\<lbrakk>f \<in> carrier A \<rightarrow> carrier B; isotone A B f; g \<in> carrier B \<rightarrow> carrier C; isotone B C g\<rbrakk> \<Longrightarrow>
   isotone A C (g \<circ> f)"
  by (simp add: isotone_def, safe, metis Pi_iff)

lemma (in weak_partial_order) inv_isotone [simp]:
  "isotone (inv_gorder A) (inv_gorder B) f = isotone A B f"
  by (auto simp add:isotone_def dual_weak_order dual_weak_order_iff)

subsubsection \<open>Idempotent functions\<close>

definition idempotent ::
  "('a, 'b) gorder_scheme \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> bool" ("Idem\<index>") where
  "idempotent L f \<equiv> \<forall>x\<in>carrier L. f (f x) .=\<^bsub>L\<^esub> f x"

lemma (in weak_partial_order) idempotent:
  "\<lbrakk>Idem f; x \<in> carrier L\<rbrakk> \<Longrightarrow> f (f x) .= f x"
  by (auto simp add: idempotent_def)

subsubsection \<open>Order embeddings\<close>

definition order_emb :: "('a, 'c) gorder_scheme \<Rightarrow> ('b, 'd) gorder_scheme \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> bool"
  where
  "order_emb A B f \<equiv> weak_partial_order A
                   \<and> weak_partial_order B
                   \<and> (\<forall>x\<in>carrier A. \<forall>y\<in>carrier A. f x \<sqsubseteq>\<^bsub>B\<^esub> f y \<longleftrightarrow> x \<sqsubseteq>\<^bsub>A\<^esub> y )"

lemma order_emb_isotone: "order_emb A B f \<Longrightarrow> isotone A B f"
  by (auto simp add: isotone_def order_emb_def)

subsubsection \<open>Commuting functions\<close>

definition commuting :: "('a, 'c) gorder_scheme \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> bool" where
"commuting A f g = (\<forall>x\<in>carrier A. (f \<circ> g) x .=\<^bsub>A\<^esub> (g \<circ> f) x)"

subsection \<open>Partial orders where \<open>eq\<close> is the Equality\<close>

locale partial_order = weak_partial_order +
  assumes eq_is_equal: "(.=) = (=)"
begin

declare weak_le_antisym [rule del]

lemma le_antisym [intro]:
  "\<lbrakk>x \<sqsubseteq> y; y \<sqsubseteq> x; x \<in> carrier L; y \<in> carrier L\<rbrakk> \<Longrightarrow> x = y"
  using weak_le_antisym unfolding eq_is_equal .

lemma lless_eq:
  "x \<sqsubset> y \<longleftrightarrow> x \<sqsubseteq> y \<and> x \<noteq> y"
  unfolding lless_def by (simp add: eq_is_equal)

lemma set_eq_is_eq: "A {.=} B \<longleftrightarrow> A = B"
  by (auto simp add: set_eq_def elem_def eq_is_equal)

end

lemma (in partial_order) dual_order:
  "partial_order (inv_gorder L)"
proof -
  interpret dwo: weak_partial_order "inv_gorder L"
    by (metis dual_weak_order)
  show ?thesis
    by (unfold_locales, simp add:eq_is_equal)
qed

lemma dual_order_iff:
  "partial_order (inv_gorder A) \<longleftrightarrow> partial_order A"
proof
  assume assm:"partial_order (inv_gorder A)"
  then interpret po: partial_order "inv_gorder A"
  rewrites "carrier (inv_gorder A) = carrier A"
  and   "le (inv_gorder A)      = (\<lambda> x y. le A y x)"
  and   "eq (inv_gorder A)      = eq A"
    by (simp_all)
  show "partial_order A"
    apply (unfold_locales, simp_all add: po.sym)
    apply (metis po.trans)
    apply (metis po.weak_le_antisym, metis po.le_trans)
    apply (metis (full_types) po.eq_is_equal, metis po.eq_is_equal)
  done
next
  assume "partial_order A"
  thus "partial_order (inv_gorder A)"
    by (metis partial_order.dual_order)
qed

text \<open>Least and greatest, as predicate\<close>

lemma (in partial_order) least_unique:
  "\<lbrakk>least L x A; least L y A\<rbrakk> \<Longrightarrow> x = y"
  using weak_least_unique unfolding eq_is_equal .

lemma (in partial_order) greatest_unique:
  "\<lbrakk>greatest L x A; greatest L y A\<rbrakk> \<Longrightarrow> x = y"
  using weak_greatest_unique unfolding eq_is_equal .

subsection \<open>Bounded Orders\<close>

definition
  top :: "_ => 'a" ("\<top>\<index>") where
  "\<top>\<^bsub>L\<^esub> = (SOME x. greatest L x (carrier L))"

definition
  bottom :: "_ => 'a" ("\<bottom>\<index>") where
  "\<bottom>\<^bsub>L\<^esub> = (SOME x. least L x (carrier L))"

locale weak_partial_order_bottom = weak_partial_order L for L (structure) +
  assumes bottom_exists: "\<exists> x. least L x (carrier L)"
begin

lemma bottom_least: "least L \<bottom> (carrier L)"
proof -
  obtain x where "least L x (carrier L)"
    by (metis bottom_exists)

  thus ?thesis
    by (auto intro:someI2 simp add: bottom_def)
qed

lemma bottom_closed [simp, intro]:
  "\<bottom> \<in> carrier L"
  by (metis bottom_least least_mem)

lemma bottom_lower [simp, intro]:
  "x \<in> carrier L \<Longrightarrow> \<bottom> \<sqsubseteq> x"
  by (metis bottom_least least_le)

end

locale weak_partial_order_top = weak_partial_order L for L (structure) +
  assumes top_exists: "\<exists> x. greatest L x (carrier L)"
begin

lemma top_greatest: "greatest L \<top> (carrier L)"
proof -
  obtain x where "greatest L x (carrier L)"
    by (metis top_exists)

  thus ?thesis
    by (auto intro:someI2 simp add: top_def)
qed

lemma top_closed [simp, intro]:
  "\<top> \<in> carrier L"
  by (metis greatest_mem top_greatest)

lemma top_higher [simp, intro]:
  "x \<in> carrier L \<Longrightarrow> x \<sqsubseteq> \<top>"
  by (metis greatest_le top_greatest)

end

subsection \<open>Total Orders\<close>

locale weak_total_order = weak_partial_order +
  assumes total: "\<lbrakk>x \<in> carrier L; y \<in> carrier L\<rbrakk> \<Longrightarrow> x \<sqsubseteq> y \<or> y \<sqsubseteq> x"

text \<open>Introduction rule: the usual definition of total order\<close>

lemma (in weak_partial_order) weak_total_orderI:
  assumes total: "!!x y. \<lbrakk>x \<in> carrier L; y \<in> carrier L\<rbrakk> \<Longrightarrow> x \<sqsubseteq> y \<or> y \<sqsubseteq> x"
  shows "weak_total_order L"
  by unfold_locales (rule total)

subsection \<open>Total orders where \<open>eq\<close> is the Equality\<close>

locale total_order = partial_order +
  assumes total_order_total: "\<lbrakk>x \<in> carrier L; y \<in> carrier L\<rbrakk> \<Longrightarrow> x \<sqsubseteq> y \<or> y \<sqsubseteq> x"

sublocale total_order < weak?: weak_total_order
  by unfold_locales (rule total_order_total)

text \<open>Introduction rule: the usual definition of total order\<close>

lemma (in partial_order) total_orderI:
  assumes total: "!!x y. \<lbrakk>x \<in> carrier L; y \<in> carrier L\<rbrakk> \<Longrightarrow> x \<sqsubseteq> y \<or> y \<sqsubseteq> x"
  shows "total_order L"
  by unfold_locales (rule total)

end


(*
    Author:      René Thiemann
                 Akihisa Yamada
    License:     BSD
*)
(*TODO: Rename! *)
section \<open>Gauss Lemma\<close>

text \<open>We formalized Gauss Lemma, that the content of a product of two polynomials $p$ and $q$
  is the product of the contents of $p$ and $q$. As a corollary we provide an algorithm
  to convert a rational factor of an integer polynomial into an integer factor.

  In contrast to the theory on unique factorization domains -- where Gauss Lemma is also proven
   in a more generic setting --
  we are here in an executable setting and do not use the unspecified $some-gcd$ function.
  Moreover, there is a slight difference in the definition of content: in this theory it is only
  defined for integer-polynomials, whereas in the UFD theory, the content is defined for
  polynomials in the fraction field.\<close>

theory Gauss_Lemma
imports
  "HOL-Computational_Algebra.Primes"
  "HOL-Computational_Algebra.Field_as_Ring"
  Polynomial_Interpolation.Ring_Hom_Poly
  Missing_Polynomial_Factorial
begin

lemma primitive_part_alt_def:
  "primitive_part p = sdiv_poly p (content p)"
  by (simp add: primitive_part_def sdiv_poly_def)

definition common_denom :: "rat list \<Rightarrow> int \<times> int list" where
  "common_denom xs \<equiv> let
     nds = map quotient_of xs;
     denom = list_lcm (map snd nds);
     ints = map (\<lambda> (n,d). n * denom div d) nds
   in (denom, ints)"

definition rat_to_int_poly :: "rat poly \<Rightarrow> int \<times> int poly" where
  "rat_to_int_poly p \<equiv> let
     ais = coeffs p;
     d = fst (common_denom ais)
   in (d, map_poly (\<lambda> x. case quotient_of x of (p,q) \<Rightarrow> p * d div q) p)"

definition rat_to_normalized_int_poly :: "rat poly \<Rightarrow> rat \<times> int poly" where
  "rat_to_normalized_int_poly p \<equiv> if p = 0 then (1,0) else case rat_to_int_poly p of (s,q)
    \<Rightarrow> (of_int (content q) / of_int s, primitive_part q)"

lemma rat_to_normalized_int_poly_code[code]:
  "rat_to_normalized_int_poly p = (if p = 0 then (1,0) else case rat_to_int_poly p of (s,q)
    \<Rightarrow> let c = content q in (of_int c / of_int s, sdiv_poly q c))"
    unfolding Let_def rat_to_normalized_int_poly_def primitive_part_alt_def ..

lemma common_denom: assumes cd: "common_denom xs = (dd,ys)"
  shows "xs = map (\<lambda> i. of_int i / of_int dd) ys" "dd > 0"
  "\<And>x. x \<in> set xs \<Longrightarrow> rat_of_int (case quotient_of x of (n, x) \<Rightarrow> n * dd div x) / rat_of_int dd = x"
proof -
  let ?nds = "map quotient_of xs"
  define nds where "nds = ?nds"
  let ?denom = "list_lcm (map snd nds)"
  let ?ints = "map (\<lambda> (n,d). n * dd div d) nds"
  from cd[unfolded common_denom_def Let_def]
  have dd: "dd = ?denom" and ys: "ys = ?ints" unfolding nds_def by auto
  show dd0: "dd > 0" unfolding dd
    by (intro list_lcm_pos(3), auto simp: nds_def quotient_of_nonzero)
  {
    fix x
    assume x: "x \<in> set xs"
    obtain p q where quot: "quotient_of x = (p,q)" by force
    from x have "(p,q) \<in> set nds" unfolding nds_def using quot by force
    hence "q \<in> set (map snd nds)" by force
    from list_lcm[OF this] have q: "q dvd dd" unfolding dd .
    show "rat_of_int (case quotient_of x of (n, x) \<Rightarrow> n * dd div x) / rat_of_int dd = x"
      unfolding quot split unfolding quotient_of_div[OF quot]
    proof -
      have f1: "q * (dd div q) = dd"
        using dvd_mult_div_cancel q by blast
      have "rat_of_int (dd div q) \<noteq> 0"
        using dd0 dvd_mult_div_cancel q by fastforce
      thus "rat_of_int (p * dd div q) / rat_of_int dd = rat_of_int p / rat_of_int q"
        using f1 by (metis (no_types) div_mult_swap mult_divide_mult_cancel_right of_int_mult q)
    qed
  } note main = this
  show "xs = map (\<lambda> i. of_int i / of_int dd) ys" unfolding ys map_map o_def nds_def
    by (rule sym, rule map_idI, rule main)
qed

lemma rat_to_int_poly: assumes "rat_to_int_poly p = (d,q)"
  shows "p = smult (inverse (of_int d)) (map_poly of_int q)" "d > 0"
proof -
  let ?f = "\<lambda> x. case quotient_of x of (pa, x) \<Rightarrow> pa * d div x"
  define f where "f = ?f"
  from assms[unfolded rat_to_int_poly_def Let_def]
    obtain xs where cd: "common_denom (coeffs p) = (d,xs)"
    and q: "q = map_poly f p" unfolding f_def by (cases "common_denom (coeffs p)", auto)
  from common_denom[OF cd] have d: "d > 0"  and
    id: "\<And> x. x \<in> set (coeffs p) \<Longrightarrow> rat_of_int (f x) / rat_of_int d = x"
    unfolding f_def by auto
  have f0: "f 0 = 0" unfolding f_def by auto
  have id: "rat_of_int (f (coeff p n)) / rat_of_int d = coeff p n" for n
    using id[of "coeff p n"] f0 range_coeff by (cases "coeff p n = 0", auto)
  show "d > 0" by fact
  show "p = smult (inverse (of_int d)) (map_poly of_int q)"
    unfolding q smult_as_map_poly using id f0
    by (intro poly_eqI, auto simp: field_simps coeff_map_poly)
qed

lemma content_ge_0_int: "content p \<ge> (0 :: int)"
  unfolding content_def
  by (cases "coeffs p", auto)

lemma abs_content_int[simp]: fixes p :: "int poly"
  shows "abs (content p) = content p" using content_ge_0_int[of p] by auto

lemma content_smult_int: fixes p :: "int poly"
  shows "content (smult a p) = abs a * content p" by simp

lemma normalize_non_0_smult: "\<exists> a. (a :: 'a :: semiring_gcd) \<noteq> 0 \<and> smult a (primitive_part p) = p"
  by (cases "p = 0", rule exI[of _ 1], simp, rule exI[of _ "content p"], auto)

lemma rat_to_normalized_int_poly: assumes "rat_to_normalized_int_poly p = (d,q)"
  shows "p = smult d (map_poly of_int q)" "d > 0" "p \<noteq> 0 \<Longrightarrow> content q = 1" "degree q = degree p"
proof -
  have "p = smult d (map_poly of_int q) \<and> d > 0 \<and> (p \<noteq> 0 \<longrightarrow> content q = 1)"
  proof (cases "p = 0")
    case True
    thus ?thesis using assms unfolding rat_to_normalized_int_poly_def
      by (auto simp: eval_poly_def)
  next
    case False
    hence p0: "p \<noteq> 0" by auto
    obtain s r where id: "rat_to_int_poly p = (s,r)" by force
    let ?cr = "rat_of_int (content r)"
    let ?s = "rat_of_int s"
    let ?q = "map_poly rat_of_int q"
    from rat_to_int_poly[OF id] have p: "p = smult (inverse ?s) (map_poly of_int r)"
    and s: "s > 0" by auto
    let ?q = "map_poly rat_of_int q"
    from p0 assms[unfolded rat_to_normalized_int_poly_def id split]
    have d: "d = ?cr / ?s" and q: "q = primitive_part r" by auto
    from content_times_primitive_part[of r, folded q] have qr: "smult (content r) q = r" .
    have "smult d ?q = smult (?cr / ?s) ?q"
      unfolding d by simp
    also have "?cr / ?s = ?cr * inverse ?s" by (rule divide_inverse)
    also have "\<dots> = inverse ?s * ?cr" by simp
    also have "smult (inverse ?s * ?cr) ?q = smult (inverse ?s) (smult ?cr ?q)" by simp
    also have "smult ?cr ?q = map_poly of_int (smult (content r) q)" by (simp add: hom_distribs)
    also have "\<dots> = map_poly of_int r" unfolding qr ..
    finally have pq: "p = smult d ?q" unfolding p by simp
    from p p0 have r0: "r \<noteq> 0" by auto
    from content_eq_zero_iff[of r] content_ge_0_int[of r] r0 have cr: "?cr > 0" by linarith
    with s have d0: "d > 0" unfolding d by auto
    from content_primitive_part[OF r0] have cq: "content q = 1" unfolding q .
    from pq d0 cq show ?thesis by auto
  qed
  thus p: "p = smult d (map_poly of_int q)" and d: "d > 0" and "p \<noteq> 0 \<Longrightarrow> content q = 1" by auto
  show "degree q = degree p" unfolding p smult_as_map_poly
    by (rule sym, subst map_poly_map_poly, force+, rule degree_map_poly, insert d, auto)
qed

lemma content_dvd_1:
  "content g = 1" if "content f = (1 :: 'a :: semiring_gcd)" "g dvd f"
proof -
  from \<open>g dvd f\<close> have "content g dvd content f"
    by (rule content_dvd_contentI)
  with \<open>content f = 1\<close> show ?thesis
    by simp
qed

lemma dvd_smult_int: fixes c :: int assumes c: "c \<noteq> 0"
  and dvd: "q dvd (smult c p)"
  shows "primitive_part q dvd p"
proof (cases "p = 0")
  case True thus ?thesis by auto
next
  case False note p0 = this
  let ?cp = "smult c p"
  from p0 c have cp0: "?cp \<noteq> 0" by auto
  from dvd obtain r where prod: "?cp = q * r" unfolding dvd_def by auto
  from prod cp0 have q0: "q \<noteq> 0" and r0: "r \<noteq> 0" by auto
  let ?c = "content :: int poly \<Rightarrow> int"
  let ?n = "primitive_part :: int poly \<Rightarrow> int poly"
  let ?pn = "\<lambda> p. smult (?c p) (?n p)"
  have cq: "(?c q = 0) = False" using content_eq_zero_iff q0 by auto
  from prod have id1: "?cp = ?pn q * ?pn r" unfolding content_times_primitive_part by simp
  from arg_cong[OF this, of content, unfolded content_smult_int content_mult
    content_primitive_part[OF r0] content_primitive_part[OF q0], symmetric]
    p0[folded content_eq_zero_iff] c
  have "abs c dvd ?c q * ?c r" unfolding dvd_def by auto
  hence "c dvd ?c q * ?c r" by auto
  then obtain d where id: "?c q * ?c r = c * d" unfolding dvd_def by auto
  have "?cp = ?pn q * ?pn r" by fact
  also have "\<dots> = smult (c * d) (?n q * ?n r)" unfolding id [symmetric]
    by (metis content_mult content_times_primitive_part primitive_part_mult)
  finally have id: "?cp = smult c (?n q * smult d (?n r))" by (simp add: mult.commute)
  interpret map_poly_inj_zero_hom "(*) c" using c by (unfold_locales, auto)
  have "p = ?n q * smult d (?n r)" using id[unfolded smult_as_map_poly[of c]] by auto
  thus dvd: "?n q dvd p" unfolding dvd_def by blast
qed

lemma irreducible\<^sub>d_primitive_part:
  fixes p :: "int poly" (* can be relaxed but primitive_part_mult has bad type constraint *)
  shows "irreducible\<^sub>d (primitive_part p) \<longleftrightarrow> irreducible\<^sub>d p" (is "?l \<longleftrightarrow> ?r")
proof (rule iffI, rule irreducible\<^sub>dI)
  assume l: ?l
  show "degree p > 0" using l by auto
  have dpp: "degree (primitive_part p) = degree p" by simp
  fix q r
  assume deg: "degree q < degree p" "degree r < degree p" and "p = q * r"
  then have pp: "primitive_part p = primitive_part q * primitive_part r" by (simp add: primitive_part_mult)
  have "\<not> irreducible\<^sub>d (primitive_part p)"
    apply (intro reducible\<^sub>dI, rule exI[of _ "primitive_part q"], rule exI[of _ "primitive_part r"], unfold dpp)
    using deg pp by auto
  with l show False by auto
next
  show "?r \<Longrightarrow> ?l" by (metis irreducible\<^sub>d_smultI normalize_non_0_smult)
qed

lemma irreducible\<^sub>d_smult_int:
  fixes c :: int assumes c: "c \<noteq> 0"
  shows "irreducible\<^sub>d (smult c p) = irreducible\<^sub>d p" (is "?l = ?r")
  using irreducible\<^sub>d_primitive_part[of "smult c p", unfolded primitive_part_smult] c
  apply (cases "c < 0", simp)
  apply (metis add.inverse_inverse add.inverse_neutral c irreducible\<^sub>d_smultI normalize_non_0_smult smult_1_left smult_minus_left)
  apply (simp add: irreducible\<^sub>d_primitive_part)
  done

lemma irreducible\<^sub>d_as_irreducible:
  fixes p :: "int poly"
  shows "irreducible\<^sub>d p \<longleftrightarrow> irreducible (primitive_part p)"
  using irreducible_primitive_connect[of "primitive_part p"]
  by (cases "p = 0", auto simp: irreducible\<^sub>d_primitive_part)

lemma rat_to_int_factor_content_1: fixes p :: "int poly"
  assumes cp: "content p = 1"
  and pgh: "map_poly rat_of_int p = g * h"
  and g: "rat_to_normalized_int_poly g = (r,rg)"
  and h: "rat_to_normalized_int_poly h = (s,sh)"
  and p: "p \<noteq> 0"
  shows "p = rg * sh"
proof -
  let ?r = "rat_of_int"
  let ?rp = "map_poly ?r"
  from p have rp0: "?rp p \<noteq> 0" by simp
  with pgh have g0: "g \<noteq> 0" and h0: "h \<noteq> 0" by auto
  from rat_to_normalized_int_poly[OF g] g0
  have r: "r > 0" "r \<noteq> 0" and g: "g = smult r (?rp rg)" and crg: "content rg = 1" by auto
  from rat_to_normalized_int_poly[OF h] h0
  have s: "s > 0" "s \<noteq> 0" and h: "h = smult s (?rp sh)" and csh: "content sh = 1" by auto
  let ?irs = "inverse (r * s)"
  from r s have irs0: "?irs \<noteq> 0" by (auto simp: field_simps)
  have "?rp (rg * sh) = ?rp rg * ?rp sh" by (simp add: hom_distribs)
  also have "\<dots> = smult ?irs (?rp p)" unfolding pgh g h using r s
    by (simp add: field_simps)
  finally have id: "?rp (rg * sh) = smult ?irs (?rp p)" by auto
  have rsZ: "?irs \<in> \<int>"
  proof (rule ccontr)
    assume not: "\<not> ?irs \<in> \<int>"
    obtain n d where irs': "quotient_of ?irs = (n,d)" by force
    from quotient_of_denom_pos[OF irs'] have "d > 0" .
    from not quotient_of_div[OF irs'] have "d \<noteq> 1" "d \<noteq> 0" and irs: "?irs = ?r n / ?r d" by auto
    with irs0 have n0: "n \<noteq> 0" by auto
    from \<open>d > 0\<close> \<open>d \<noteq> 1\<close> have "d \<ge> 2" and "\<not> d dvd 1" by auto
    with content_iff[of d p, unfolded cp] obtain c where
      c: "c \<in> set (coeffs p)" and dc: "\<not> d dvd c"
      by auto
    from c range_coeff[of p] obtain i where "c = coeff p i" by auto
    from arg_cong[OF id, of "\<lambda> p. coeff p i",
      unfolded coeff_smult of_int_hom.coeff_map_poly_hom this[symmetric] irs]
    have "?r n / ?r d * ?r c \<in> \<int>" by (metis Ints_of_int)
    also have "?r n / ?r d * ?r c = ?r (n * c) / ?r d" by simp
    finally have inZ: "?r (n * c) / ?r d \<in> \<int>" .
    have cop: "coprime n d" by (rule quotient_of_coprime[OF irs'])
    (* now there comes tedious reasoning that `coprime n d` `\<not> d dvd c` ` nc / d \<in> \<int>` yields a
       contradiction *)
    define prod where "prod = ?r (n * c) / ?r d"
    obtain n' d' where quot: "quotient_of prod = (n',d')" by force
    have qr: "\<And> x. quotient_of (?r x) = (x, 1)"
      using Rat.of_int_def quotient_of_int by auto
    from quotient_of_denom_pos[OF quot] have "d' > 0" .
    with quotient_of_div[OF quot] inZ[folded prod_def] have "d' = 1"
      by (metis Ints_cases Rat.of_int_def old.prod.inject quot quotient_of_int)
    with quotient_of_div[OF quot] have "prod = ?r n'" by auto
    from arg_cong[OF this, of quotient_of, unfolded prod_def rat_divide_code qr Let_def split]
    have "Rat.normalize (n * c, d) = (n',1)" by simp
    from normalize_crossproduct[OF \<open>d \<noteq> 0\<close>, of 1 "n * c" n', unfolded this]
    have id: "n * c = n' * d" by auto
    from quotient_of_coprime[OF irs'] have "coprime n d" .
    with id have "d dvd c"
      by (metis coprime_commute coprime_dvd_mult_right_iff dvd_triv_right)
    with dc show False ..
  qed
  then obtain irs where irs: "?irs = ?r irs" unfolding Ints_def by blast
  from id[unfolded irs, folded hom_distribs, unfolded of_int_poly_hom.eq_iff]
  have p: "rg * sh = smult irs p" by auto
  have "content (rg * sh) = 1" unfolding content_mult crg csh by auto
  from this[unfolded p content_smult_int cp] have "abs irs = 1" by simp
  hence "abs ?irs = 1" using irs by auto
  with r s have "?irs = 1" by auto
  with irs have "irs = 1" by auto
  with p show p: "p = rg * sh" by auto
qed

lemma rat_to_int_factor_explicit: fixes p :: "int poly"
  assumes pgh: "map_poly rat_of_int p = g * h"
  and g: "rat_to_normalized_int_poly g = (r,rg)"
  shows "\<exists> r. p = rg * smult (content p) r"
proof -
  show ?thesis
  proof (cases "p = 0")
    case True
    show ?thesis unfolding True
      by (rule exI[of _ 0], auto simp: degree_monom_eq)
  next
    case False
    hence p: "p \<noteq> 0" by auto
    let ?r = "rat_of_int"
    let ?rp = "map_poly ?r"
    define q where "q = primitive_part p"
    from content_times_primitive_part[of p, folded q_def] content_eq_zero_iff[of p] p
      obtain a where a: "a \<noteq> 0" and pq: "p = smult a q" and acp: "content p = a" by metis
    from a pq p have ra: "?r a \<noteq> 0" and q0: "q \<noteq> 0" by auto
    from content_primitive_part[OF p, folded q_def] have cq: "content q = 1" by auto
    obtain s sh where h: "rat_to_normalized_int_poly (smult (inverse (?r a)) h) = (s,sh)" by force
    from arg_cong[OF pgh[unfolded pq], of "smult (inverse (?r a))"] ra
    have "?rp q = g * smult (inverse (?r a)) h" by (auto simp: hom_distribs)
    from rat_to_int_factor_content_1[OF cq this g h q0]
    have qrs: "q = rg * sh" .
    show ?thesis unfolding acp unfolding pq qrs
      by (rule exI[of _ sh], auto)
  qed
qed

lemma rat_to_int_factor: fixes p :: "int poly"
  assumes pgh: "map_poly rat_of_int p = g * h"
  shows "\<exists> g' h'. p = g' * h' \<and> degree g' = degree g \<and> degree h' = degree h"
proof(cases "p = 0")
  case True
  with pgh have "g = 0 \<or> h = 0" by auto
  then show ?thesis
    by (metis True degree_0 mult_hom.hom_zero mult_zero_left rat_to_normalized_int_poly(4) surj_pair)
next
  case False
  obtain r rg where ri: "rat_to_normalized_int_poly (smult (1 / of_int (content p)) g) = (r,rg)" by force
  obtain q qh where ri2: "rat_to_normalized_int_poly h = (q,qh)" by force
  show ?thesis
  proof (intro exI conjI)
    have "of_int_poly (primitive_part p) = smult (1 / of_int (content p)) (g * h)"
      apply (auto simp: primitive_part_def pgh[symmetric] smult_map_poly map_poly_map_poly o_def intro!: map_poly_cong)
      by (metis (no_types, lifting) content_dvd_coeffs div_by_0 dvd_mult_div_cancel floor_of_int nonzero_mult_div_cancel_left of_int_hom.hom_zero of_int_mult)
    also have "\<dots> = smult (1 / of_int (content p)) g * h" by simp
    finally have "of_int_poly (primitive_part p) = \<dots>".
    note main = rat_to_int_factor_content_1[OF _ this ri ri2, simplified, OF False]
    show "p = smult (content p) rg * qh" by (simp add: main[symmetric])
    from ri2 show "degree qh = degree h" by (fact rat_to_normalized_int_poly)
    from rat_to_normalized_int_poly(4)[OF ri] False
    show "degree (smult (content p) rg) = degree g" by auto
  qed
qed

lemma rat_to_int_factor_normalized_int_poly: fixes p :: "rat poly"
  assumes pgh: "p = g * h"
  and p: "rat_to_normalized_int_poly p = (i,ip)"
  shows "\<exists> g' h'. ip = g' * h' \<and> degree g' = degree g"
proof -
  from rat_to_normalized_int_poly[OF p]
  have p: "p = smult i (map_poly rat_of_int ip)" and i: "i \<noteq> 0" by auto
  from arg_cong[OF p, of "smult (inverse i)", unfolded pgh] i
  have "map_poly rat_of_int ip = g * smult (inverse i) h" by auto
  from rat_to_int_factor[OF this] show ?thesis by auto
qed

(* TODO: move *)
lemma irreducible_smult [simp]:
  fixes c :: "'a :: field"
  shows "irreducible (smult c p) \<longleftrightarrow> irreducible p \<and> c \<noteq> 0"
  using irreducible_mult_unit_left[of "[:c:]", simplified] by force

text \<open>A polynomial with integer coefficients is
   irreducible over the rationals, if it is irreducible over the integers.\<close>
theorem irreducible\<^sub>d_int_rat: fixes p :: "int poly"
  assumes p: "irreducible\<^sub>d p"
  shows "irreducible\<^sub>d (map_poly rat_of_int p)"
proof (rule irreducible\<^sub>dI)
  from irreducible\<^sub>dD[OF p]
  have p: "degree p \<noteq> 0" and irr: "\<And> q r. degree q < degree p \<Longrightarrow> degree r < degree p \<Longrightarrow> p \<noteq> q * r" by auto
  let ?r = "rat_of_int"
  let ?rp = "map_poly ?r"
  from p show rp: "degree (?rp p) > 0" by auto
  from p have p0: "p \<noteq> 0" by auto
  fix g h :: "rat poly"
  assume deg: "degree g > 0" "degree g < degree (?rp p)" "degree h > 0" "degree h < degree (?rp p)" and pgh: "?rp p = g * h"
  from rat_to_int_factor[OF pgh] obtain g' h' where p: "p = g' * h'" and dg: "degree g' = degree g" "degree h' = degree h"
    by auto
  from irr[of g' h'] deg[unfolded dg]
  show False using degree_mult_eq[of g' h'] by (auto simp: p dg)
qed

corollary irreducible\<^sub>d_rat_to_normalized_int_poly:
  assumes rp: "rat_to_normalized_int_poly rp = (a, ip)"
  and ip: "irreducible\<^sub>d ip"
  shows "irreducible\<^sub>d rp"
proof -
  from rat_to_normalized_int_poly[OF rp]
  have rp: "rp = smult a (map_poly rat_of_int ip)" and a: "a \<noteq> 0" by auto
  with irreducible\<^sub>d_int_rat[OF ip] show ?thesis by auto
qed

lemma dvd_content_dvd: assumes dvd: "content f dvd content g" "primitive_part f dvd primitive_part g"
  shows "f dvd g"
proof -
  let ?cf = "content f" let ?nf = "primitive_part f"
  let ?cg = "content g" let ?ng = "primitive_part g"
  have "f dvd g = (smult ?cf ?nf dvd smult ?cg ?ng)"
    unfolding content_times_primitive_part by auto
  from dvd(1) obtain ch where cg: "?cg = ?cf * ch" unfolding dvd_def by auto
  from dvd(2) obtain nh where ng: "?ng = ?nf * nh" unfolding dvd_def by auto
  have "f dvd g = (smult ?cf ?nf dvd smult ?cg ?ng)"
    unfolding content_times_primitive_part[of f] content_times_primitive_part[of g] by auto
  also have "\<dots> = (smult ?cf ?nf dvd smult ?cf ?nf * smult ch nh)" unfolding cg ng
    by (metis mult.commute mult_smult_right smult_smult)
  also have "\<dots>" by (rule dvd_triv_left)
  finally show ?thesis .
qed

lemma sdiv_poly_smult: "c \<noteq> 0 \<Longrightarrow> sdiv_poly (smult c f) c = f"
  by (intro poly_eqI, unfold coeff_sdiv_poly coeff_smult, auto)

lemma primitive_part_smult_int: fixes f :: "int poly" shows
  "primitive_part (smult d f) = smult (sgn d) (primitive_part f)"
proof (cases "d = 0 \<or> f = 0")
  case False
  obtain cf where cf: "content f = cf" by auto
  with False have 0: "d \<noteq> 0" "f \<noteq> 0" "cf \<noteq> 0" by auto
  show ?thesis
  proof (rule poly_eqI, unfold primitive_part_alt_def coeff_sdiv_poly content_smult_int coeff_smult cf)
    fix n
    consider (pos) "d > 0" | (neg) "d < 0" using 0(1) by linarith
    thus "d * coeff f n div (\<bar>d\<bar> * cf) = sgn d * (coeff f n div cf)"
    proof cases
      case neg
      hence "?thesis = (d * coeff f n div - (d * cf) = - (coeff f n div cf))" by auto
      also have "d * coeff f n div - (d * cf) = - (d * coeff f n div (d * cf))"
        by (subst dvd_div_neg, insert 0(1), auto simp: cf[symmetric])
      also have "d * coeff f n div (d * cf) = coeff f n div cf" using 0(1) by auto
      finally show ?thesis by simp
    qed auto
  qed
qed auto

lemma gcd_smult_left: assumes "c \<noteq> 0"
  shows "gcd (smult c f) g = gcd f (g :: 'b :: {field_gcd} poly)"
proof -
  from assms have "normalize c = 1"
    by (meson dvd_field_iff is_unit_normalize)
  then show ?thesis
    by (metis (no_types) Polynomial.normalize_smult gcd.commute gcd.left_commute gcd_left_idem gcd_self smult_1_left)
qed

lemma gcd_smult_right: "c \<noteq> 0 \<Longrightarrow> gcd f (smult c g) = gcd f (g :: 'b :: {field_gcd} poly)"
  using gcd_smult_left[of c g f] by (simp add: gcd.commute)

end


(*  Title:      HOL/Metis_Examples/Abstraction.thy
    Author:     Lawrence C. Paulson, Cambridge University Computer Laboratory
    Author:     Jasmin Blanchette, TU Muenchen

Example featuring Metis's support for lambda-abstractions.
*)

section \<open>Example Featuring Metis's Support for Lambda-Abstractions\<close>

theory Abstraction
  imports "HOL-Library.FuncSet"
begin

(* For Christoph Benzmüller *)
lemma "x < 1 \<and> ((=) = (=)) \<Longrightarrow> ((=) = (=)) \<and> x < (2::nat)"
by (metis nat_1_add_1 trans_less_add2)

lemma "(=) = (\<lambda>x y. y = x)"
by metis

consts
  monotone :: "['a => 'a, 'a set, ('a *'a)set] => bool"
  pset  :: "'a set => 'a set"
  order :: "'a set => ('a * 'a) set"

lemma "a \<in> {x. P x} \<Longrightarrow> P a"
proof -
  assume "a \<in> {x. P x}"
  thus "P a" by (metis mem_Collect_eq)
qed

lemma Collect_triv: "a \<in> {x. P x} \<Longrightarrow> P a"
by (metis mem_Collect_eq)

lemma "a \<in> {x. P x --> Q x} \<Longrightarrow> a \<in> {x. P x} \<Longrightarrow> a \<in> {x. Q x}"
by (metis Collect_imp_eq ComplD UnE)

lemma "(a, b) \<in> Sigma A B \<Longrightarrow> a \<in> A \<and> b \<in> B a"
proof -
  assume A1: "(a, b) \<in> Sigma A B"
  hence F1: "b \<in> B a" by (metis mem_Sigma_iff)
  have F2: "a \<in> A" by (metis A1 mem_Sigma_iff)
  have "b \<in> B a" by (metis F1)
  thus "a \<in> A \<and> b \<in> B a" by (metis F2)
qed

lemma Sigma_triv: "(a, b) \<in> Sigma A B \<Longrightarrow> a \<in> A & b \<in> B a"
by (metis SigmaD1 SigmaD2)

lemma "(a, b) \<in> (SIGMA x:A. {y. x = f y}) \<Longrightarrow> a \<in> A \<and> a = f b"
by (metis (full_types, lifting) CollectD SigmaD1 SigmaD2)

lemma "(a, b) \<in> (SIGMA x:A. {y. x = f y}) \<Longrightarrow> a \<in> A \<and> a = f b"
proof -
  assume A1: "(a, b) \<in> (SIGMA x:A. {y. x = f y})"
  hence F1: "a \<in> A" by (metis mem_Sigma_iff)
  have "b \<in> {R. a = f R}" by (metis A1 mem_Sigma_iff)
  hence "a = f b" by (metis (full_types) mem_Collect_eq)
  thus "a \<in> A \<and> a = f b" by (metis F1)
qed

lemma "(cl, f) \<in> CLF \<Longrightarrow> CLF = (SIGMA cl: CL.{f. f \<in> pset cl}) \<Longrightarrow> f \<in> pset cl"
by (metis Collect_mem_eq SigmaD2)

lemma "(cl, f) \<in> CLF \<Longrightarrow> CLF = (SIGMA cl: CL.{f. f \<in> pset cl}) \<Longrightarrow> f \<in> pset cl"
proof -
  assume A1: "(cl, f) \<in> CLF"
  assume A2: "CLF = (SIGMA cl:CL. {f. f \<in> pset cl})"
  have "\<forall>v u. (u, v) \<in> CLF \<longrightarrow> v \<in> {R. R \<in> pset u}" by (metis A2 mem_Sigma_iff)
  hence "\<forall>v u. (u, v) \<in> CLF \<longrightarrow> v \<in> pset u" by (metis mem_Collect_eq)
  thus "f \<in> pset cl" by (metis A1)
qed

lemma
  "(cl, f) \<in> (SIGMA cl: CL. {f. f \<in> pset cl \<rightarrow> pset cl}) \<Longrightarrow>
   f \<in> pset cl \<rightarrow> pset cl"
by (metis (no_types) Collect_mem_eq Sigma_triv)

lemma
  "(cl, f) \<in> (SIGMA cl: CL. {f. f \<in> pset cl \<rightarrow> pset cl}) \<Longrightarrow>
   f \<in> pset cl \<rightarrow> pset cl"
proof -
  assume A1: "(cl, f) \<in> (SIGMA cl:CL. {f. f \<in> pset cl \<rightarrow> pset cl})"
  have "f \<in> {R. R \<in> pset cl \<rightarrow> pset cl}" using A1 by simp
  thus "f \<in> pset cl \<rightarrow> pset cl" by (metis mem_Collect_eq)
qed

lemma
  "(cl, f) \<in> (SIGMA cl: CL. {f. f \<in> pset cl \<inter> cl}) \<Longrightarrow>
   f \<in> pset cl \<inter> cl"
by (metis (no_types) Collect_conj_eq Int_def Sigma_triv inf_idem)

lemma
  "(cl, f) \<in> (SIGMA cl: CL. {f. f \<in> pset cl \<inter> cl}) \<Longrightarrow>
   f \<in> pset cl \<inter> cl"
proof -
  assume A1: "(cl, f) \<in> (SIGMA cl:CL. {f. f \<in> pset cl \<inter> cl})"
  have "f \<in> {R. R \<in> pset cl \<inter> cl}" using A1 by simp
  hence "f \<in> Id_on cl `` pset cl" by (metis Int_commute Image_Id_on mem_Collect_eq)
  hence "f \<in> cl \<inter> pset cl" by (metis Image_Id_on)
  thus "f \<in> pset cl \<inter> cl" by (metis Int_commute)
qed

lemma
  "(cl, f) \<in> (SIGMA cl: CL. {f. f \<in> pset cl \<rightarrow> pset cl & monotone f (pset cl) (order cl)}) \<Longrightarrow>
   (f \<in> pset cl \<rightarrow> pset cl)  &  (monotone f (pset cl) (order cl))"
by auto

lemma
  "(cl, f) \<in> CLF \<Longrightarrow>
   CLF \<subseteq> (SIGMA cl: CL. {f. f \<in> pset cl \<inter> cl}) \<Longrightarrow>
   f \<in> pset cl \<inter> cl"
by (metis (lifting) CollectD Sigma_triv subsetD)

lemma
  "(cl, f) \<in> CLF \<Longrightarrow>
   CLF = (SIGMA cl: CL. {f. f \<in> pset cl \<inter> cl}) \<Longrightarrow>
   f \<in> pset cl \<inter> cl"
by (metis (lifting) CollectD Sigma_triv)

lemma
  "(cl, f) \<in> CLF \<Longrightarrow>
   CLF \<subseteq> (SIGMA cl': CL. {f. f \<in> pset cl' \<rightarrow> pset cl'}) \<Longrightarrow>
   f \<in> pset cl \<rightarrow> pset cl"
by (metis (lifting) CollectD Sigma_triv subsetD)

lemma
  "(cl, f) \<in> CLF \<Longrightarrow>
   CLF = (SIGMA cl: CL. {f. f \<in> pset cl \<rightarrow> pset cl}) \<Longrightarrow>
   f \<in> pset cl \<rightarrow> pset cl"
by (metis (lifting) CollectD Sigma_triv)

lemma
  "(cl, f) \<in> CLF \<Longrightarrow>
   CLF = (SIGMA cl: CL. {f. f \<in> pset cl \<rightarrow> pset cl & monotone f (pset cl) (order cl)}) \<Longrightarrow>
   (f \<in> pset cl \<rightarrow> pset cl) & (monotone f (pset cl) (order cl))"
by auto

lemma "map (\<lambda>x. (f x, g x)) xs = zip (map f xs) (map g xs)"
apply (induct xs)
 apply (metis list.map(1) zip_Nil)
by auto

lemma
  "map (\<lambda>w. (w \<rightarrow> w, w \<times> w)) xs =
   zip (map (\<lambda>w. w \<rightarrow> w) xs) (map (\<lambda>w. w \<times> w) xs)"
apply (induct xs)
 apply (metis list.map(1) zip_Nil)
by auto

lemma "(\<lambda>x. Suc (f x)) ` {x. even x} \<subseteq> A \<Longrightarrow> \<forall>x. even x --> Suc (f x) \<in> A"
by (metis mem_Collect_eq image_eqI subsetD)

lemma
  "(\<lambda>x. f (f x)) ` ((\<lambda>x. Suc(f x)) ` {x. even x}) \<subseteq> A \<Longrightarrow>
   (\<forall>x. even x --> f (f (Suc(f x))) \<in> A)"
by (metis mem_Collect_eq imageI rev_subsetD)

lemma "f \<in> (\<lambda>u v. b \<times> u \<times> v) ` A \<Longrightarrow> \<forall>u v. P (b \<times> u \<times> v) \<Longrightarrow> P(f y)"
by (metis (lifting) imageE)

lemma image_TimesA: "(\<lambda>(x, y). (f x, g y)) ` (A \<times> B) = (f ` A) \<times> (g ` B)"
by (metis map_prod_def map_prod_surj_on)

lemma image_TimesB:
    "(\<lambda>(x, y, z). (f x, g y, h z)) ` (A \<times> B \<times> C) = (f ` A) \<times> (g ` B) \<times> (h ` C)"
by force

lemma image_TimesC:
  "(\<lambda>(x, y). (x \<rightarrow> x, y \<times> y)) ` (A \<times> B) =
   ((\<lambda>x. x \<rightarrow> x) ` A) \<times> ((\<lambda>y. y \<times> y) ` B)"
by (metis image_TimesA)

end


section \<open>Very Basic LTS Formalization\<close>
theory LTS
imports CAVA_Automata.Digraph
begin

  (* TODO: transition labeled automata, not supported by CAVA automata library *)

  locale LTS =
    fixes step :: "'s \<Rightarrow> 'l \<Rightarrow> 's \<Rightarrow> bool"
  begin
    primrec path :: "'s \<Rightarrow> 'l list \<Rightarrow> 's \<Rightarrow> bool" where
      "path s [] s' \<longleftrightarrow> s'=s"
    | "path s (l#ls) s' \<longleftrightarrow> (\<exists>sh. step s l sh \<and> path sh ls s')"

    lemma path_append[simp]:
      "path s (p@p') s' \<longleftrightarrow> (\<exists>sh. path s p sh \<and> path sh p' s')"
      by (induction p arbitrary: s) auto

    lemma path_trans[trans]:
      "step s l sh \<Longrightarrow> step sh l' s' \<Longrightarrow> path s [l,l'] s'"
      "step s l sh \<Longrightarrow> path sh p s' \<Longrightarrow> path s (l#p) s'"
      "path s p sh \<Longrightarrow> step sh l s' \<Longrightarrow> path s (p@[l]) s'"
      "path s p sh \<Longrightarrow> path sh p' s' \<Longrightarrow> path s (p@p') s'"
      by auto

    lemma path_sngI: "step s a s' \<Longrightarrow> path s [a] s'" by auto
    lemma path_emptyI: "path s [] s" by auto

    definition "reachable s s' \<equiv> \<exists>p. path s p s'"
    lemma reachableI: "path s p s' \<Longrightarrow> reachable s s'"
      unfolding reachable_def by auto

    lemma reachable_trans[trans]:
      "reachable s sh \<Longrightarrow> step sh l s' \<Longrightarrow> reachable s s'"
      "reachable s sh \<Longrightarrow> path sh p s' \<Longrightarrow> reachable s s'"
      "path s p sh \<Longrightarrow> reachable sh s' \<Longrightarrow> reachable s s'"
      "step s l sh \<Longrightarrow> reachable sh s' \<Longrightarrow> reachable s s'"
      unfolding reachable_def
      by (auto dest: path_trans)

  end

  locale asystem =
    lts: LTS astep
    for init :: "'c \<Rightarrow> bool"
    and astep :: "'c \<Rightarrow> 'a \<Rightarrow> 'c \<Rightarrow> bool"
  begin

    definition step :: "'c digraph"
      where "step \<equiv> {(c, c'). \<exists> a. astep c a c'}"

    definition G :: "'c graph_rec"
      where "G \<equiv> \<lparr> g_V = UNIV, g_E = step, g_V0 = Collect init \<rparr>"

    lemma G_simps[simp]:
      "g_V G = UNIV"
      "g_E G = step"
      "g_V0 G = Collect init"
      unfolding G_def by simp+

    sublocale graph G by unfold_locales auto

    lemma path_is_step: "lts.path c p c' \<Longrightarrow> (c, c') \<in> step\<^sup>*"
      unfolding step_def
      apply (induction p arbitrary: c)
      apply auto
      by (metis (mono_tags, lifting) case_prod_conv converse_rtrancl_into_rtrancl mem_Collect_eq)

    lemma step_is_path: "(c, c') \<in> step\<^sup>* \<Longrightarrow> \<exists>p. lts.path c p c'"
    proof (induction rule: converse_rtrancl_induct, safe)
      fix c
      show "\<exists>p. lts.path c p c"
        apply (rule exI[where x="[]"])
        by auto
    next
      fix c ch p
      assume "(c, ch) \<in> step" and 1: "lts.path ch p c'"
      then obtain a where "astep c a ch" by (auto simp: step_def)
      with 1 show "\<exists>p. lts.path c p c'"
        apply (rule_tac exI[where x="a#p"]) by auto
    qed

    lemma step_path_conv: "(c, c') \<in> step\<^sup>* \<longleftrightarrow> (\<exists>p. lts.path c p c')"
      using path_is_step step_is_path by blast

  end

end


theory Continuity imports LangCompSimple
begin

(* Scott continuity-like definitions *)

(* directed set. pairs or arbitrary sets? *)

definition dirset :: "('a :: Pord) set \<Rightarrow> bool" where
"dirset S \<equiv>
  (\<forall> x y . x \<in> S \<longrightarrow>
           y \<in> S \<longrightarrow>
           (\<exists> z . is_ub {x, y} z \<and> z \<in> S))"

(* literal translation of wikipedia *)

definition scont :: "('a :: Pord \<Rightarrow> 'b :: Pord) \<Rightarrow> bool" where
"scont f =
  (\<forall> D supr . dirset D \<longrightarrow>
   is_sup D supr \<longrightarrow>
   is_sup (f ` D) (f supr))"

definition scross :: "('a \<Rightarrow> 'b) set \<Rightarrow> 'a set \<Rightarrow> 'b set" where
"scross Fs Xs =
  { x . \<exists> f y . f \<in> Fs \<and> y \<in> Xs \<and> x = f y }"

lemma scross_inI :
  assumes Hf : "f \<in> Fs"
  assumes Hx : "x \<in> Xs"
  assumes Heq : "res = f x"
  shows "res \<in> scross Fs Xs" using assms
  unfolding scross_def
  by blast

lemma scross_inD  :
  assumes "res \<in> scross Fs Xs"
  shows "\<exists> f y . f \<in> Fs \<and> y \<in> Xs \<and> res = f y" using assms
  unfolding scross_def
  by blast

(* TODO: do we really need the nonemptiness requirement for Fs'? *)
(* TODO: unlike scott continuity, we don't have the "closure" property
   here (that the set is closed under LUBs
*)
(* binary sups_pres
   (f1, x1) (f2, x2)
*)
definition sups_pres_new ::
  "('a \<Rightarrow> ('b :: Mergeable) \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> bool" where
"sups_pres_new f1 f2 =
  (\<forall> x y syn supr .
     is_sup {x, y} supr \<longrightarrow>
     (\<exists> supr' . is_sup {f1 syn x, f2 syn y} supr' \<and>
        is_sup {f1 syn supr, f2 syn supr} supr'))"

end


theory T69
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, meet(y, z)) = meet(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(x, meet(y, z)) = join(over(x, y), over(x, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(x, join(y, z)) = join(undr(x, y), undr(x, z)))
"
nitpick[card nat=4,timeout=86400]
oops
end