(* Author: Alexander Bentkamp, Universität des Saarlandes
*)
section \<open>Fundamental Theorem of Network Capacity\<close>

theory DL_Fundamental_Theorem_Network_Capacity
  imports DL_Rank_CP_Rank DL_Deep_Model_Poly Lebesgue_Zero_Set
  Jordan_Normal_Form.DL_Rank_Submatrix "HOL-Analysis.Complete_Measure" DL_Shallow_Model
begin

context deep_model_correct_params_y
begin

definition "polynomial_f w = det (submatrix (matricize {n. even n} (A w)) rows_with_1 rows_with_1)"

lemma polyfun_polynomial:
  shows "polyfun {..<weight_space_dim} polynomial_f"
unfolding polynomial_f_def using polyfun_det_deep_model unfolding witness_submatrix_def A'_def .

definition "polynomial_p = (SOME p. vars p \<subseteq> {..<weight_space_dim} \<and> (\<forall>x. insertion x p = polynomial_f x))"

lemma
polynomial_p_not_0: "polynomial_p\<noteq>0" and
vars_polynomial_p: "vars polynomial_p \<subseteq> {..<weight_space_dim}" and
polynomial_pf: "\<And>w. insertion w polynomial_p = polynomial_f w"
proof -
  have "vars polynomial_p \<subseteq> {..<weight_space_dim} \<and> (\<forall>x. insertion x polynomial_p = polynomial_f x)" unfolding polynomial_p_def
    using someI_ex[OF polyfun_polynomial[unfolded polyfun_def]] .
  then show "vars polynomial_p \<subseteq> {..<weight_space_dim}" "\<And>w. insertion w polynomial_p = polynomial_f w" by auto
  show "polynomial_p\<noteq>0" using A'_def Aw'_def' \<open>\<And>w. insertion w polynomial_p = polynomial_f w\<close> polynomial_f_def witness_det by auto
qed

lemma  if_polynomial_0_rank:
assumes "polynomial_f w \<noteq> 0"
shows "r ^ N_half \<le> cprank (A w)"
proof -
  have "r ^ N_half = dim_row (submatrix (matricize {n. even n} (A w)) rows_with_1 rows_with_1)"
      by (metis (full_types) Aw'_def card_rows_with_1 dim_submatrix(1) dims_A dims_Aw dims_matricize(1) set_le_in)
  also have "... \<le> mrank (matricize {n. even n} (A w))"
    using assms vec_space.rank_gt_minor[OF carrier_matI[OF dims_A'_pow, unfolded weight_space_dim_def]]
      by (metis (full_types) A'_def dim_submatrix(1) dims_A'_pow(1) polynomial_f_def)
  also have "... \<le> cprank (A w)" using matrix_rank_le_cp_rank by blast
  finally show ?thesis .
qed

lemma  if_polynomial_0_evaluate:
assumes "polynomial_f wd \<noteq> 0"
assumes "\<forall>inputs. input_sizes (deep_model_l rs) = map dim_vec inputs \<longrightarrow> evaluate_net (insert_weights shared_weights (deep_model_l rs) wd) inputs
 = evaluate_net (insert_weights shared_weights (shallow_model (rs ! 0) Z (last rs) (2*N_half-1)) ws) inputs"
shows "Z \<ge> r ^ N_half"
proof -
  have valid1:"valid_net' (insert_weights shared_weights (deep_model_l rs) wd)"
    using remove_insert_weights valid_deep_model by presburger
  have valid2:"valid_net' (insert_weights shared_weights (shallow_model (rs ! 0) Z (last rs) (2*N_half-1)) ws)"
    by (simp add: remove_insert_weights valid_shallow_model)
  have input_sizes: "input_sizes (insert_weights shared_weights (deep_model_l rs) wd)
    = input_sizes (insert_weights shared_weights (shallow_model (rs ! 0) Z (last rs) (2 * N_half - 1)) ws)"
    using input_sizes_remove_weights input_sizes_deep_model remove_insert_weights
    by (simp add: N_half_def input_sizes_shallow_model)
  have 0:"tensors_from_net (insert_weights shared_weights (deep_model_l rs) wd)
        = tensors_from_net (insert_weights shared_weights (shallow_model (rs ! 0) Z (last rs) (2*N_half -1)) ws)"
    using tensors_from_net_eqI[OF valid1 valid2 input_sizes, unfolded input_sizes_remove_weights remove_insert_weights]
    using assms by blast
  have "cprank (tensors_from_net (insert_weights shared_weights (deep_model_l rs) wd) $ y) \<le> Z"
    unfolding 0 using y_valid cprank_shallow_model by blast
  then show ?thesis
   using if_polynomial_0_rank assms
   using A_def assms(1)  less_le_trans not_le remove_insert_weights
   by fastforce
qed

lemma  if_polynomial_0_evaluate_notex:
assumes "polynomial_f wd \<noteq> 0"
shows "\<not>(\<exists>weights_shallow Z. Z < r ^ N_half \<and> (\<forall>inputs. input_sizes (deep_model_l rs) = map dim_vec inputs \<longrightarrow>
evaluate_net (insert_weights shared_weights (deep_model_l rs) wd) inputs
 = evaluate_net (insert_weights shared_weights (shallow_model (rs ! 0) Z (last rs) (2*N_half-1)) ws) inputs))"
  using assms if_polynomial_0_evaluate not_le by blast

theorem fundamental_theorem_network_capacity:
"AE x in lborel_f weight_space_dim. r ^ N_half \<le> cprank (A x)"
using AE_I'[OF lebesgue_mpoly_zero_set[OF polynomial_p_not_0 vars_polynomial_p]]
  by (metis (mono_tags, lifting) Collect_mono if_polynomial_0_rank polynomial_pf)

theorem fundamental_theorem_network_capacity_v2:
shows "AE wd in lborel_f weight_space_dim.
   \<not>(\<exists>ws Z. Z < r ^ N_half \<and>  (\<forall>inputs. input_sizes (deep_model_l rs) = map dim_vec inputs \<longrightarrow>
evaluate_net (insert_weights shared_weights (deep_model_l rs) wd) inputs
 = evaluate_net (insert_weights shared_weights (shallow_model (rs ! 0) Z (last rs) (2*N_half-1)) ws) inputs))"
  apply (rule AE_I'[OF lebesgue_mpoly_zero_set[OF polynomial_p_not_0 vars_polynomial_p], unfolded polynomial_pf])
  apply (rule subsetI) unfolding mem_Collect_eq
  using if_polynomial_0_evaluate_notex by metis

abbreviation lebesgue_f where "lebesgue_f n \<equiv> completion (lborel_f n)"

lemma space_lebesgue_f: "space (lebesgue_f n) = Pi\<^sub>E {..<n} (\<lambda>_. UNIV)"
  by (simp add: space_lborel_f)

theorem fundamental_theorem_network_capacity_v3:
  assumes
    "S = {wd \<in> space (lebesgue_f weight_space_dim).
      \<exists>ws Z. Z < r ^ N_half \<and>  (\<forall>inputs. input_sizes (deep_model_l rs) = map dim_vec inputs \<longrightarrow>
        evaluate_net (insert_weights shared_weights (deep_model_l rs) wd) inputs
      = evaluate_net (insert_weights shared_weights (shallow_model (rs ! 0) Z (last rs) (2*N_half-1)) ws) inputs)}"
  shows "S \<in> null_sets (completion (lborel_f weight_space_dim))"
  unfolding assms
  using fundamental_theorem_network_capacity_v2[unfolded completion.AE_iff_null_sets[unfolded AE_completion_iff], unfolded not_not]
  by blast

end
end


theory Prog
imports Ifte
begin

datatype 'a prog =
Const "'a proc" |
if_then_else "'a prog" bool "'a prog" |
sequential "'a prog" "'a prog" |
nondeterm_choice "'a prog" "'a prog"

primrec prog_op where
"prog_op (Const P) = P" |
"prog_op (if_then_else P b Q) = prog_op P \<triangleleft> b \<triangleright>\<^sub>\<p> prog_op Q " |
"prog_op (sequential P Q) = prog_op P ;; prog_op Q " |
"prog_op (nondeterm_choice P Q) = prog_op P \<sqinter> prog_op Q"

(****next I hope to prove that all kinds of programs have a uniform form***)

theorem Finite_normal_form1 :
  fixes P ::" 'a prog"
    and bexp :: bool
  assumes "P = ((X := a) \<sqinter> (Y := b))"
  shows "((X := a) \<sqinter> (Y := b)) = ( \<bottom> \<triangleleft> bexp  \<triangleright>\<^sub>\<p> ( \<Sqinter>{V := e})) "

end


(*<*)
theory Basic
imports Main
begin
(*>*)

text {*
We use the same words of the creators of this tool, retrieved from their
website\footnote{Accessed 27/jan/2016: \url{https://isabelle.in.tum.de/overview.html}}:
%
\begin{citacao}
Isabelle is a generic proof assistant. It allows mathematical formulas to be expressed in a formal
language and provides tools for proving those formulas in a logical calculus.
%
The main application is the formalization of mathematical proofs and in particular formal verification,
which includes proving the correctness of computer hardware or software and proving properties of
computer languages and protocols.
\end{citacao}
*}

text {*
Isabelle/HOL\index{Isabelle/HOL} is the most widespread instance of Isabelle.
\acs{HOL} stands for \acl{HOL}.
%
Isabelle/HOL provides a \ac{HOL} proving environment ready to use, which includes: (co)datatypes,
inductive definitions, recursive functions, locales, custom syntax definition, etc.
%
Proofs can be written in both human\footnote{By human we mean that anyone with mathematics and logic
basic knowledge---it means that deep programming knowledge is not essential.} and machine-readable
language based on \ac{Isar}.
%
The tool also includes the \emph{sledgehammer}, a port to call external first-order provers to find
proofs fully automatically.
%
The user interface is based on jEdit\footnote{Accessed 27/jan/2016: \url{http://www.jedit.org/}},
which provides a text editor, syntax parser, shortcuts, etc. (see
\cref{fig:basic-symmetry-isabelle-window}).

\begin{figure}[t]
  \centering
  \includegraphicsaspectratio[0.8]{basic-symmetry-isabelle-window}
  \caption{Isabelle/HOL window, showing the basic symmetry theorem}
  \label{fig:basic-symmetry-isabelle-window}
\end{figure}

Theories on Isabelle/HOL are based on a few axioms.
%
Isabelle/HOL Library's theories---which comes with the installer---and user's theories are based on
these axioms.
%
This design decision avoids inconsistencies and paradoxes (similar as it is in \ac{Z}).

Besides the provided theories, its active community provides a comprehensive \ac{AFP}.
%
Each entry in this archive can be cited and usually contains an \emph{abstract}, a document, and a
theory file.
%
For example, \iacl{FBA} theory is available in~\cite{Huffm2010}.
%
To use it, it is enough to download and put on the same directory of your own theory files.

Bellow we show an example and explain the overall syntax of the human and machine-readable language.
*}

theorem basic_symmetry:
  assumes "x = y" -- "Assumptions"
  shows "y = x" -- "Hypothesis"
proof -
text_raw{* \newcommand{\bsproof}{%*}
  have "x = x" .. -- "Proof step"
  from assms -- "Using assumptions"
    show "y = x" .. -- "Show thesis"
text_raw{* }\\\bsproof\\*}
qed

text {*
Finally, Isabelle/HOL provides \LaTeX{} syntax sugar and allow easy document preparation: this
entire section was written in a theory file mixing Isabelle's and \LaTeX{}'s syntax).
%
The above theorem can be written using Isabelle's quotation and anti-quotations.
%
For example, we can write it using usual \LaTeX{} theorem environment:
%
\begin{Theo}[Basic symmetry]
Assuming @{thm (prem 1) basic_symmetry}, thus:

\begin{center}
@{thm (concl) basic_symmetry}
\end{center}
\end{Theo}
%
\begin{proof}
\bsproof
\end{proof}

Otherwise specified, in the next sections we will omit proofs because they are all verified using
Isabelle/HOL.
The complete listing is in \cref{app:formal-proofs-isabelle-hol}.
*}

(*<*)
end
(*>*)


(* Cancelación de las funciones sobreyectivas *)

(*<*)
theory CancelacionSobreyectiva
  imports Main "HOL-Library.LaTeXsugar" "HOL-Library.OptionalSugar"
begin
(*>*)

section \<open>Cancelación de las funciones sobreyectivas \<close>

subsection \<open>Demostración en lenguaje natural \<close>

text \<open>El siguiente teorema prueba una caracterización de las funciones
  sobreyectivas. Primero se definirá el significado de la sobreyectividad
  de una función y de la propiedad de ser cancelativa por la derecha.

\begin{definicion}
  Una función $f: A \longrightarrow B$ es sobreyectiva si
  $$\forall y \in B : \exists x \in A : f(x) = y$$
\end{definicion}

Antes de definir la propiedad de ser cancelativa por la derecha se va a
 probar la siguiente propiedad.

\begin{lema}
Sea $f$ una función $f : A \longrightarrow B$. Las siguientes condiciones son equivalentes:
\begin{enumerate}
\item   $\forall C : (\forall g,h: B \longrightarrow C) : g \circ f = h \circ f
    \Longrightarrow g = h$
\item $\forall g, h: B \longrightarrow \{0,1\} : g \circ f = h \circ f
 \Longrightarrow g = h.$
\end{enumerate}
\end{lema}

\begin{demostracion}

$1 \Longrightarrow 2$ Trivial, ya que tomando en particular $C =
 \{0,1\}$ se tiene probado.

$2 \Longrightarrow 1$ La demostración se realizará por reducción al
 absurdo, es decir, supongamos que $\exists C$ y $\exists g,h$ tales que
$g \circ f = h \circ f$ y $g \neq h.$ Como $g \neq h$ esto implica que
 $\exists b \in B$ tal que $g(b) \neq h(b).$

Definamos $r: C \longrightarrow \{0,1\}$ como:
  $$r(x)= \left\{\begin{array}{lcc}
                   0 &   si  & x \neq g(b) \\
                   1 &  si & x = g(b)
                 \end{array}
          \right.$$

Consideremos $g' = r \circ g$ y $h' = r \circ h.$ Luego se
 tiene que:
$$\begin{array}{l}
(g' \circ f)(x) \\
= (r \circ g \circ f)(x) \\
= (r \circ (g \circ f))(x) \\
= (r \circ (h \circ f))(x) @{text"H.I"} \\
= (r \circ h \circ f)(x)
= (h' \circ f)(x).
\end{array}$$

Por lo tanto, $g' \circ f = h' \circ f$. Luego por hipótesis $g' = h'.$

Veamos por otro lado que:

$$\begin{array}{l}
g'(b) \\
= r(g(b)) \\
= 1
\end{array}
\qquad \qquad
\begin{array}{l}
h'(b) \\
= r(h(b)) \\
= 0
\end{array}$$

Por lo que hemos llegado a un absurdo.
\end{demostracion}

Puesto que tenemos esta equivalencia, la definición de la propiedad de
 ser cancelativa por la derecha será:

\begin{definicion}[Cancelativa derecha]
Una función $f: A \longrightarrow B$ tiene la propiedad de ser
 cancelativa por la derecha si:

$$\forall g, h: B \longrightarrow \{0,1\} : g \circ f = h \circ f
 \Longrightarrow g = h.$$
\end{definicion}

\begin{nota}
Es adecuado usar esta definición, ya que a la hora de especificar la
 definición en Isabelle no se puede cuantificar tipos y esta definición
 no lo requiere. Sin embargo, la otra sí.
\end{nota}

  El teorema es el siguiente:

  \begin {teorema}
    Una función f es sobreyectiva si y solo si es cancelativa por la
 derecha.
  \end {teorema}

  El teorema se puede dividir en dos lemas, ya que se demuestra por una
  doble implicación.

  \begin {lema}[Condición necesaria]
    Si $f$ es sobreyectiva, entonces f es cancelativa por la derecha.
  \end {lema}

  \begin {demostracion}
  Sea $f: A \longrightarrow B$ sobreyectiva. Veamos que
 f es cancelativa por la derecha, es decir, sean $g,h : B
 \longrightarrow \{0,1\}$ tales que $g \circ f = h \circ f$ hay que
 probar que $g = h.$ Usando la definición de sobreyectividad
  $(\forall y \in Y,  \exists x | y = f(x))$ y la hipótesis,
  tenemos que:
  $$\begin{array}{l}
g(y)  \\
= g(f(x)) \\
= (g \circ f) (x) \\
= (h \circ f) (x) \\
= h(f(x)) \\
= h(y).
\end{array}$$
  \end {demostracion}

  \begin {lema}[Condición suficiente]
  Si f es cancelativa por la derecha entonces f es sobreyectiva.
  \end {lema}

  \begin {demostracion}

  La prueba se va a realizar por reducción al absurdo. Luego supongamos
  que nuestra función $f : A \longrightarrow B$ no es sobreyectiva, es decir,
  $\exists y_{1} \in B \ @{text " tal que "} \  \nexists x \in A \ :
   f(x) = y_{1}.$

  Definamos ahora las funciones $g,h: B \longrightarrow \{0,1\}$
  $$g(y) = 0 \  \forall y \in B$$
  $$h(y)= \left\{\begin{array}{lcc}
                   0 &   si  & y \neq y_1 \\
                   1 &  si & y = y_1
                 \end{array}
          \right.$$

  Entonces $g(y) \neq h(y).$ Sin embargo, por hipótesis se tiene que si
  $g \circ f = h \circ f$ entonces $h = g$. En efecto,
$$\begin{array}{l}
(g \circ f)(x) \\
 = g(f(x)) \\
= 0  \\
= h(f(x)) \\
= (h \circ f)(x).
\end{array}$$
 Por lo que $g(y) = h(y),$ con lo que hemos llegado a una contradicción.
  \end {demostracion}

\<close>
subsection \<open>Especificación en Isabelle/Hol \<close>

text \<open>Su especificación es la siguiente, que se dividirá en dos al igual
  que en la demostración a mano: \<close>

definition cancelativaDerecha :: "('a \<Rightarrow> 'b) \<Rightarrow> bool" where
  "cancelativaDerecha  f =
   (\<forall>(g :: 'b \<Rightarrow> bool)  h. (g \<circ> f = h \<circ> f \<longrightarrow> g = h))"

theorem caracterizacion_funciones_sobreyectivas:
  "surj f \<longleftrightarrow> cancelativaDerecha f"
  oops

lemma condicion_suficiente:
  "surj f \<Longrightarrow> cancelativaDerecha f"
  oops

lemma condicion_necesaria:
  "cancelativaDerecha f \<Longrightarrow> surj f"
  oops

text \<open>En la especificación anterior, @{term "surj f"} es una abreviatura de
  @{text "range f = UNIV"}, donde @{term "range f"} es el rango o imagen
  de la función f y @{term UNIV} es el conjunto universal definido en la
  teoría \href{http://bit.ly/2XtHCW6}{Set.thy} como una abreviatura de
  @{term top} que, a su vez está definido en la teoría
  \href{http://bit.ly/2Xyj9Pe}{Orderings.thy} mediante la siguiente
  propiedad
  \begin{itemize}
    \item[] @{thm[mode=Rule] ordering_top.extremum[no_vars]}
      \hfill (@{text ordering_top.extremum})
  \end{itemize}
  Además queda añadir que la teoría donde se encuentra definido
  @{term"surj f"} es en \href{http://bit.ly/2XuPQx5}{Fun.thy}. Esta
  teoría contiene la definicion @{term" surj_def"}.
  \begin{itemize}
    \item[] @{thm[mode=Rule] surj_def[no_vars]}
      \hfill (@{text surj__def})
  \end{itemize}
\<close>

subsection \<open>Demostración estructurada \<close>

text \<open>Presentaremos distintas demostraciones de los lemas. Las primeras
 son las detalladas:\<close>

lemma condicion_suficiente_detallada:
  assumes "surj f"
  shows "cancelativaDerecha f"
proof -
  have "\<forall>(g :: 'a \<Rightarrow> bool) h. (g \<circ> f = h \<circ> f \<longrightarrow> g = h)"
  proof (intro allI impI)
    fix g h :: "'a \<Rightarrow> bool"
    assume "g \<circ> f = h \<circ> f"
    show "g = h"
    proof  (rule ext)
      fix x
      have "\<exists>y. x = f y"
        using assms
        by (simp only: surjD)
      then obtain "y" where "x = f y"
        by (rule exE)
      then have "g x = g (f y)"
        by (simp only: \<open>x = f y\<close>)
      also have "\<dots> = (g \<circ> f) y"
        by (simp only: comp_apply)
      also have "\<dots> = (h \<circ> f) y"
        by (simp only: \<open>g \<circ> f = h \<circ> f\<close>)
      also have "\<dots> = h (f y)"
        by (simp only: comp_apply)
      also have "\<dots> = h x"
        by (simp only: \<open>x = f y\<close>)
      finally show "g x = h x"
        by this
    qed
  qed
  then show "cancelativaDerecha f"
    by (simp only: cancelativaDerecha_def)
qed

lemma condicion_necesaria_detallada_l1:
  assumes "\<nexists>x. y = f x"
  shows "g \<circ> f = g(y := z) \<circ> f"
proof (rule ext)
  fix a
  show "(g \<circ> f) a = (g(y := z) \<circ> f) a"
  proof -
    have "\<forall>x. y \<noteq> f x"
      using assms
      by (rule Meson.not_exD)
    then have "y \<noteq> f a"
      by (rule allE)
    then have "f a \<noteq> y"
      by (rule not_sym)
    have "(g \<circ> f) a = g (f a)"
      by (simp only: o_apply)
    also have "\<dots> = (g(y := z)) (f a)"
      using \<open>f a \<noteq> y\<close>
      by (rule fun_upd_other [THEN sym])
    also have "\<dots> = (g(y := z) \<circ> f) a"
      by (simp only: o_apply)
    finally show ?thesis
      by this
  qed
qed

lemma condicion_necesaria_detallada_l2:
  assumes "(\<lambda>x. a) = (\<lambda>x. a)(y := b)"
  shows "a = b"
proof -
  have "a = ((\<lambda>x. a)(y := b)) y"
    using assms
    by (rule fun_cong)
  also have "\<dots> = b"
    by (rule fun_upd_same)
  finally show "a = b"
    by this
qed

lemma condicion_necesaria_detallada:
  assumes "cancelativaDerecha f"
  shows "surj f"
proof -
  have "\<forall>y. \<exists>x. y = f x"
  proof (rule ccontr)
    assume "\<not> (\<forall>y. \<exists>x. y = f x)"
    then have "\<exists>y. \<nexists>x. y = f x"
      by (rule Meson.not_allD)
    then obtain y0 where "\<nexists>x. y0 = f x"
      by (rule exE)
    then have "\<forall>x. y0 \<noteq> f x"
      by (rule Meson.not_exD)
    let ?g = "(\<lambda>x. True) :: 'b \<Rightarrow> bool"
    let ?h = "?g(y0 := False)"
    have "\<forall>(g :: 'b \<Rightarrow> bool) h . g \<circ> f = h \<circ> f \<longrightarrow> g = h"
      using assms by (simp only: cancelativaDerecha_def)
    then have "\<forall>h .(?g \<circ> f = h \<circ> f) \<longrightarrow> (?g = h)"
      by (rule allE)
    then have "(?g \<circ> f = ?h \<circ> f) \<longrightarrow> (?g = ?h)"
      by (rule allE)
    moreover
    have "(?g \<circ> f = ?h \<circ> f)"
      using \<open>\<nexists>x. y0 = f x\<close>
      by (rule condicion_necesaria_detallada_l1)
    ultimately have "(?g = ?h)"
      by (rule mp)
    then have "True = False"
      by (rule condicion_necesaria_detallada_l2)
    with True_not_False show False
      by (rule notE)
  qed
  then show "surj f"
    using surj_def
    by (rule rev_iffD2)
qed

subsection \<open>Demostración teorema \<close>

text \<open>En consecuencia, la demostración del teorema es \<close>

theorem caracterizacion_funciones_sobreyectivas:
  "surj f \<longleftrightarrow> cancelativaDerecha f"
proof (rule iffI)
  show "surj f \<Longrightarrow> cancelativaDerecha f"
    by (rule condicion_suficiente_detallada)
next
  show "cancelativaDerecha f \<Longrightarrow> surj f"
    by (rule condicion_necesaria_detallada)
qed

subsection \<open> Demostración automática del teorema \<close>
theorem "surj f \<longleftrightarrow> cancelativaDerecha f"
  by (auto simp add: condicion_suficiente_detallada
                     condicion_necesaria_detallada)

(*<*)
end
(*>*)


(***********************************************************************
* HiVe theory files
*
* Copyright (C) 2015 Commonwealth of Australia as represented by Defence Science and Technology
* Group (DST Group)
*
* All rights reserved.
*
* The HiVe theory files are free software: released for redistribution and use, and/or modification,
* under the BSD License, details of which can be found in the LICENSE file included in the
* distribution.
************************************************************************)

theory
  xReal_Type

imports
  Z_Toolkit
  Metric_Class
begin

text {*

Following Royden~\cite{royden:realanal} we develop the extended reals.

The extended reals add @{text "\<plusminus>\<infinity>"}, being at the
respective extremities of the real order.

*}

datatype
  xreal = ninfty | fin real | infty

type_notation (xsymbols output)
  xreal ("\<real>\<^sub>\<zinfty>")

type_notation (zed)
  xreal ("\<xreal>")

notation (xsymbols output)
  fin ("_") and
  ninfty ("-\<zinfty>") and
  infty ("\<zinfty>")

notation (zed)
  fin ("\<^fin>{:_:}") and
  ninfty ("-\<zinfty>") and
  infty ("\<zinfty>")

text {*

The zero and one of the extended reals are the finite embeddings.
We activate binary number representations for the extended reals.

*}

instantiation xreal :: "{zero,one}"
begin

definition
  xreal_zero_def:  "0 \<defs> \<^fin>{:0:}"
definition
  xreal_one_def:  "1 \<defs> \<^fin>{:1:}"
(*
this for instantiation xreal :: number... gone!
definition
  xreal_number_of_def [simp]:
    "number_of x \<defs> \<^fin>{:(number_of x):}"
*)

instance
  by (intro_classes)

end

text {*

Addition is extended to the extremities.  The group properties of the reals
cannot be preserved in the extended reals so we simply leave the sum of the
bottom and top elements underdetermined: the result must be in the boundary
set.  With this choice we have a semigroup structure under addition; i.e., the
addition is associative.  If the result were finite then , e.g.,
@{text "\<zinfty> + (-\<zinfty> + x) = \<zinfty> + -\<zinfty> \<noteq> (\<zinfty> + -\<zinfty>) + x"}.
The following
technical lemmas show that Hilbert choice implements this restriction.

*}

lemma xreal_choose_bdy:
  "(\<some> a | a = \<zinfty> \<or> a = -\<zinfty>) = \<zinfty>
  \<or> (\<some> a | a = \<zinfty> \<or> a = -\<zinfty>) = -\<zinfty>"
  by (rule someI_ex, auto)

lemma xreal_choose_bdy2:
  "(\<some> a | a \<in> { -\<zinfty>, \<zinfty>}) = \<zinfty>
  \<or> (\<some> a | a \<in> { -\<zinfty>, \<zinfty>}) = -\<zinfty>"
  by (auto simp add: xreal_choose_bdy disj_commute)

text {*

Multiplication is also extended in the obvious way, with
@{text "0 * \<zinfty>"} set to @{text 0} by convention.  Then multiplying anything by
@{text "0"} leaves @{text "0"}.
Again, alternatives will give us problems with associativity.  If
the result were @{text "\<zinfty> * 0 = a"}, then @{text "(\<zinfty> * 0) * x = \<zinfty> * (0 * x)"}
implies that @{text "a * x = a"}.
*}

text {*

The interesting case for inverse is of course @{text 0}, where the result is
left completely undetermined.

*}

instantiation
  xreal :: "{plus,uminus,minus,times,inverse}"
begin

definition
  xreal_add_def: "x + y \<defs>
    \<case> x \<of>
      -\<zinfty> \<longrightarrow> (\<case> y \<of> -\<zinfty> \<longrightarrow>
-\<zinfty> | \<^fin>{:b:} \<longrightarrow> -\<zinfty> | \<zinfty> \<longrightarrow> (\<some> a | a \<in> { -\<zinfty>, \<zinfty>}) \<esac>)
    | \<^fin>{:a:} \<longrightarrow> (\<case> y \<of> -\<zinfty> \<longrightarrow> -\<zinfty> | \<^fin>{:b:} \<longrightarrow> \<^fin>{:(a+b):} | \<zinfty> \<longrightarrow> \<zinfty> \<esac>)
    | \<zinfty> \<longrightarrow> (\<case> y \<of> -\<zinfty> \<longrightarrow> (\<some> a | a \<in> { -\<zinfty>, \<zinfty>}) | \<^fin>{:b:} \<longrightarrow> \<zinfty> | \<zinfty> \<longrightarrow> \<zinfty> \<esac>)
    \<esac>"

definition
  xreal_mult_def: "x * y \<defs>
    \<case> x \<of>
      -\<zinfty> \<longrightarrow>
        \<case> y \<of>
          -\<zinfty> \<longrightarrow> \<zinfty>
        | \<^fin>{:b:} \<longrightarrow>
            \<if> b < 0 \<then> \<zinfty>
            \<else> \<if> b = 0 \<then> 0 \<else> -\<zinfty> \<fi>
            \<fi>
        | \<zinfty> \<longrightarrow> -\<zinfty>
        \<esac>
    | \<^fin>{:a:} \<longrightarrow>
        \<case> y \<of>
          -\<zinfty> \<longrightarrow>
            \<if> a < 0 \<then> \<zinfty>
            \<else> \<if> a = 0 \<then> 0 \<else> -\<zinfty> \<fi>
            \<fi>
        | \<^fin>{:b:} \<longrightarrow> \<^fin>{:(a*b):}
        | \<zinfty> \<longrightarrow>
            \<if> a < 0 \<then> -\<zinfty>
            \<else> \<if> a = 0 \<then> 0 \<else> \<zinfty> \<fi>
            \<fi>
        \<esac>
    | \<zinfty> \<longrightarrow>
        \<case> y \<of>
          -\<zinfty> \<longrightarrow> -\<zinfty>
        | \<^fin>{:b:} \<longrightarrow>
            \<if> b < 0 \<then> -\<zinfty>
            \<else> \<if> b = 0 \<then> 0 \<else> \<zinfty> \<fi>
            \<fi>
        | \<zinfty> \<longrightarrow> \<zinfty>
        \<esac>
    \<esac>"

definition
  xreal_uminus_def: "- x \<defs>
    \<case> x \<of>
      -\<zinfty> \<longrightarrow> \<zinfty>
    | \<^fin>{:a:} \<longrightarrow> \<^fin>{:(- a):}
    | \<zinfty> \<longrightarrow> -\<zinfty>
    \<esac>"

definition
  xreal_diff_def: "x - (y::xreal) \<defs> x + (- y)"

definition
  xreal_inverse_def: "inverse x \<defs>
    \<case> x \<of>
      -\<zinfty> \<longrightarrow> 0
    | \<^fin>{:a:} \<longrightarrow> \<if> a = 0 \<then> (\<some> b | \<True>) \<else> \<^fin>{:(inverse a):} \<fi>
    | \<zinfty> \<longrightarrow> 0
    \<esac>"

definition
  xreal_divide_def: "x / (y::xreal) \<defs> x * (inverse y)"

instance
  by (intro_classes)

end

lemma uminus_idem [simp]: "-(-(x::xreal)) = x"
  by (cases x, auto simp add: xreal_uminus_def)

text {* \section{The extended real numbers are linearly ordered} *}

instantiation xreal :: order
begin

  definition
    le_xreal_def: "x \<le> y \<defs>
    \<case> x \<of>
      -\<zinfty> \<longrightarrow>
        \<case> y \<of>
          -\<zinfty> \<longrightarrow> \<True>
        | fin b \<longrightarrow> \<True>
        | \<zinfty> \<longrightarrow> \<True>
        \<esac>
    | fin a \<longrightarrow>
        \<case> y \<of>
          -\<zinfty> \<longrightarrow> \<False>
        | fin b \<longrightarrow> a \<le> b
        | \<zinfty> \<longrightarrow> \<True>
        \<esac>
    | \<zinfty> \<longrightarrow>
        \<case> y \<of>
          -\<zinfty> \<longrightarrow> \<False>
        | fin b \<longrightarrow> \<False>
        | \<zinfty> \<longrightarrow> \<True>
        \<esac>
    \<esac>"

  definition
    lt_xreal_def: "x < (y::xreal) \<defs> x \<le> y \<and> x \<noteq> y"

  instance
  proof (intro_classes) -- reflection
    fix x::xreal
    show "x \<le> x" by (cases x, auto simp add: le_xreal_def lt_xreal_def)
  next -- transitivity
    fix x::xreal and y::xreal and z::xreal
    assume a1: "x \<le> y" and a2: "y \<le> z"
    from a1 a2 show "x \<le> z"
    by (multi_cases x y z, auto simp add: le_xreal_def lt_xreal_def)
  next -- asymmetry
    fix x::xreal and y::xreal
    assume a1: "x \<le> y" and a2: "y \<le> x"
    from a1 a2 show "x = y"
    by (multi_cases x y, auto simp add: le_xreal_def lt_xreal_def)
  next -- "lt irreflexive"
    fix x::xreal and y::xreal
    show "x < y \<Leftrightarrow> x \<le> y \<and> \<not> (y \<le> x)"
    by (multi_cases x y, auto simp add: le_xreal_def lt_xreal_def)
  qed

end

lemma le_xreal_simps:
  "-\<zinfty> \<le> r"
  "-\<zinfty> < fin a"
  "\<not>(fin a \<le> -\<zinfty>)"
  "\<not>(fin a < -\<zinfty>)"
  "fin a \<le> fin b \<Leftrightarrow> a \<le> b"
  "fin a < fin b \<Leftrightarrow> a < b"
  "fin a < \<zinfty>"
  "\<not>(\<zinfty> < fin a)"
  "\<not>(\<zinfty> \<le> fin a)"
  "r \<le> \<zinfty>"
  apply (auto simp add: le_xreal_def lt_xreal_def)
  apply (cases r, auto)+
  done

text {*

Unary negation is an order reflection.

*}

lemma uminus_amono: "-x \<le> -y \<Leftrightarrow> y \<le> (x::xreal)"
proof (cases x)
  assume a1: "x = -\<zinfty>"
  show ?thesis by (cases y, insert a1, auto simp add: xreal_uminus_def le_xreal_def lt_xreal_def)
next
  fix a assume a1: "x = fin a"
  show ?thesis by (cases y, insert a1, auto simp add: xreal_uminus_def le_xreal_def lt_xreal_def)
next
  assume a1: "x = \<zinfty>"
  show ?thesis by (cases y, insert a1, auto simp add: xreal_uminus_def le_xreal_def lt_xreal_def)
qed

text {* The embedding of reals is an order embedding.  *}

lemma fin_order_embed:
  "r \<le> r' \<Leftrightarrow> \<^fin>{:r:} \<le> \<^fin>{:r':}"
by (simp add:  le_xreal_def lt_xreal_def)

text {*

We prove linear order, and then some further arithmetic properties.

*}

instantiation xreal :: linorder
begin

  instance
  proof (intro_classes)
    fix x::xreal and y::xreal
    show "x \<le> y \<or> y \<le> x"
    by (multi_cases x y, auto simp add: le_xreal_def lt_xreal_def)
  qed

end

lemmas xreal_reduce =
  xreal_zero_def xreal_one_def
  xreal_add_def
  xreal_mult_def
  xreal_uminus_def xreal_diff_def
  xreal_inverse_def xreal_divide_def
  le_xreal_def lt_xreal_def

text{*

\subsection{Algebraic structure}

*}

instance xreal :: semigroup_add
proof intro_classes
  fix a b c :: \<xreal>
  show
  "a + b + c = a + (b + c)"
    apply (insert xreal_choose_bdy2, elim disjE)
    apply (multi_cases "a::\<xreal>" "b::\<xreal>" "c::\<xreal>")
    apply (simp_all add: xreal_reduce)
    apply (multi_cases "a::\<xreal>" "b::\<xreal>" "c::\<xreal>")
    apply (simp_all add: xreal_reduce)
  done
qed

instance xreal :: ab_semigroup_add
proof intro_classes
  fix a b :: \<xreal>
  show
  "a + b = b + a"
    apply (multi_cases "a::\<xreal>" "b::\<xreal>")
    apply (simp_all add: xreal_reduce)
  done
qed

instance xreal :: semigroup_mult
proof intro_classes
  fix a b c :: \<xreal>
  show
  "a * b * c = a * (b * c)"
    apply (multi_cases "a::\<xreal>" "b::\<xreal>" "c::\<xreal>")
    apply (simp_all add: xreal_reduce mult_neg_neg
                         linorder_not_less order_le_less
                         mult_pos_neg mult_pos_neg2 mult_pos_pos)
  done
qed

instance xreal :: ab_semigroup_mult
proof intro_classes
  fix a b :: \<xreal>
  show
  "a * b = b * a"
    apply (multi_cases "a::\<xreal>" "b::\<xreal>")
    apply (simp_all add: xreal_reduce)
  done
qed

instance xreal :: comm_monoid_add
proof intro_classes
  fix a :: \<xreal>
  show
  "0 + a = a"
    apply (cases "a")
    apply (simp_all add: xreal_reduce disj_commute)
  done
qed

instance xreal :: comm_monoid_mult
proof intro_classes
  fix a :: \<xreal>
  show
  "1 * a = a"
    apply (cases "a")
    apply (simp_all add: xreal_reduce disj_commute)
  done
qed

instance xreal :: numeral ..

(*
Note that ``cancel'' classes fails because infinity wipes out all finite.
*)

lemma xreal_add_imp_eq'1:
  "\<^fin>{:x:} + b = \<^fin>{:x:} + c \<turnstile> b = c"
  apply (multi_cases "b" "c")
  apply (auto simp add: xreal_reduce disj_commute)
done

lemma xreal_add_imp_eq'2:
  "-\<^fin>{:x:} + b = -\<^fin>{:x:} + c \<turnstile> b = c"
  apply (multi_cases "b" "c")
  apply (auto simp add: xreal_reduce disj_commute)
done

lemma xreal_add_imp_eq:
  "a + b = a + c \<turnstile> a = \<zinfty> \<or> a = -\<zinfty> \<or> b = c"
  apply (multi_cases "a" "b" "c")
  apply (auto simp add: xreal_reduce disj_commute)
done

lemma xreal_add_left_cancel1 [simp]:
     "(\<^fin>{:x:} + b = \<^fin>{:x:} + c) = (b = c)"
  by (blast intro: add_ac xreal_add_imp_eq'1)

lemma xreal_add_left_cancel2 [simp]:
     "(-\<^fin>{:x:} + b = -\<^fin>{:x:} + c) = (b = c)"
  by (blast intro: add_ac xreal_add_imp_eq'2)

lemma xreal_add_right_cancel1 [simp]:
     "(b + \<^fin>{:x:} = c + \<^fin>{:x:}) = (b = c)"
by (simp add: add_commute [where ?b = "\<^fin>{:x:}"])

lemma xreal_add_right_cancel2 [simp]:
     "(b + -\<^fin>{:x:} = c + -\<^fin>{:x:}) = (b = c)"
by (simp add: add_commute [where ?b = "-\<^fin>{:x:}"])

(*
Also, xreal is not an abelian group under addition since the inverse fails on infinity.
*)

lemma xreal_left_minus [simp]:
  "- \<^fin>{:x:} + \<^fin>{:x:} = 0"
by (simp add: xreal_reduce disj_commute)

lemma xreal_right_minus [simp]:
  "\<^fin>{:x:} + - \<^fin>{:x:} = 0"
by (simp add: xreal_reduce disj_commute)

lemma xreal_diff_minus:
  "(a::\<xreal>) - b = a + (-b)"
by (simp add: xreal_reduce disj_commute)

lemma xreal_minus_minus [simp]:
  "- (- (a::\<xreal>)) = a"
  apply (cases "a")
  apply (simp add: xreal_reduce disj_commute)+
done

lemma xreal_minus_zero [simp]: "- 0 = (0::\<xreal>)"
by (simp add: xreal_reduce disj_commute)

lemma xreal_diff_self1 [simp]: "\<^fin>{:x:} - \<^fin>{:x:} = 0"
by (simp add: xreal_reduce disj_commute)

lemma xreal_diff_self2 [simp]: "-\<^fin>{:x:} + \<^fin>{:x:} = 0"
by (simp add: xreal_reduce disj_commute)

lemma xreal_diff_0 [simp]: "(0::\<xreal>) - a = -a"
by (simp add: xreal_diff_minus)

lemma xreal_diff_0_right [simp]: "a - (0::\<xreal>) = a"
by (simp add: xreal_diff_minus)

lemma xreal_diff_minus_eq_add [simp]: "a - - b = a + (b::\<xreal>)"
by (simp add: xreal_diff_minus)

lemma xreal_neg_equal_iff_equal [simp]: "(-a = -b) = (a = (b::\<xreal>))"
proof
  assume "- a = - b"
  hence "- (- a) = - (- b)"
    by simp
  thus "a=b" by simp
next
  assume "a=b"
  thus "-a = -b" by simp
qed

lemma xreal_neg_equal_0_iff_equal [simp]: "(-a = 0) = (a = (0::\<xreal>))"
  apply (cases "a")
  apply (simp add: xreal_reduce disj_commute)+
done

lemma xreal_neg_0_equal_iff_equal [simp]: "(0 = -a) = (0 = (a::\<xreal>))"
  apply (cases "a")
  apply (simp add: xreal_reduce disj_commute)+
done

lemma xreal_minus_add_distrib1 [simp]: "- (\<^fin>{:x:} + b) = -\<^fin>{:x:} + -b"
  apply (cases "b")
  apply (simp add: xreal_reduce disj_commute)+
done

lemma xreal_minus_add_distrib2 [simp]: "- (a + \<^fin>{:y:}) = -a + -\<^fin>{:y:}"
  apply (cases "a")
  apply (simp add: xreal_reduce disj_commute)+
done

lemma xreal_minus_add_distrib3 [simp]: "- (-\<^fin>{:x:} + b) = \<^fin>{:x:} + -b"
  apply (cases "b")
  apply (simp add: xreal_reduce disj_commute)+
done

lemma xreal_minus_add_distrib4 [simp]: "- (a + -\<^fin>{:y:}) = -a + \<^fin>{:y:}"
  apply (cases "a")
  apply (simp add: xreal_reduce disj_commute)+
done

lemma xreal_minus_diff_eq1 [simp]: "- (\<^fin>{:x:} - b) = b - \<^fin>{:x:}"
  apply (cases "b")
  apply (simp add: xreal_reduce disj_commute)+
done

lemma xreal_minus_diff_eq2 [simp]: "- (a - \<^fin>{:y:}) = \<^fin>{:y:} - a"
  apply (cases "a")
  apply (simp add: xreal_reduce disj_commute)+
done

lemma xreal_minus_diff_eq3 [simp]: "- (-\<^fin>{:x:} - b) = b + \<^fin>{:x:}"
  apply (cases "b")
  apply (simp add: xreal_reduce disj_commute)+
done

lemma xreal_add_diff_eq: "a + (b - c) = (a + b) - (c::\<xreal>)"
by (simp add: xreal_diff_def add_ac)

lemma xreal_diff_add_eq: "(a - b) + c = (a + c) - (b::\<xreal>)"
by (simp add: xreal_diff_def add_ac)

lemma xreal_diff_eq_eq: "(a-\<^fin>{:x:} = c) = (a = c + \<^fin>{:x:})"
by (auto simp add: xreal_diff_def add_ac)

lemma xreal_eq_diff_eq: "(a = c-\<^fin>{:x:}) = (a + \<^fin>{:x:} = c)"
by (auto simp add: xreal_diff_def add_assoc)

lemma xreal_diff_diff_eq1a: "(a - \<^fin>{:x:}) - c = a - (\<^fin>{:x:} + c)"
by (simp add: xreal_diff_def add_ac)

lemma xreal_diff_diff_eq1b: "(a - b) - \<^fin>{:x:} = a - (b + \<^fin>{:x:})"
by (simp add: xreal_diff_def add_ac)

lemma xreal_diff_diff_eq1c: "(a - \<zinfty>) - \<zinfty> = a - (\<zinfty> + \<zinfty>)"
  apply (simp add: xreal_diff_def add_ac)
  apply (cases "a", auto simp add: xreal_reduce)
done

lemma xreal_diff_diff_eq2a: "a - (\<^fin>{:x:} - c) = (a + c) - \<^fin>{:x:}"
by (simp add: xreal_diff_def add_ac)

lemma xreal_diff_diff_eq2b: "a - (b - \<^fin>{:x:}) = (a + \<^fin>{:x:}) - b"
by (simp add: xreal_diff_def add_ac)

lemma xreal_diff_add_cancel: "a - \<^fin>{:x:} + \<^fin>{:x:} = (a::\<xreal>)"
by (simp add: xreal_diff_def add_ac)

lemma xreal_add_diff_cancel: "a + \<^fin>{:x:} - \<^fin>{:x:} = (a::\<xreal>)"
by (simp add: xreal_diff_def add_ac)

lemmas xreal_compare_rls =
  xreal_add_diff_eq
  xreal_diff_add_eq
  xreal_diff_eq_eq
  xreal_eq_diff_eq
  xreal_diff_diff_eq1a
  xreal_diff_diff_eq1b
  xreal_diff_diff_eq1c
  xreal_diff_diff_eq2a
  xreal_diff_diff_eq2b

lemmas xreal_group_eq_simps =
  mult_ac
  add_ac
  xreal_add_diff_eq
  xreal_diff_add_eq
  xreal_diff_eq_eq
  xreal_eq_diff_eq
  xreal_diff_diff_eq1a
  xreal_diff_diff_eq1b
  xreal_diff_diff_eq1c
  xreal_diff_diff_eq2a
  xreal_diff_diff_eq2b

lemma xreal_eq_iff_diff_eq_0_1: "(a = \<^fin>{:x:}) = (a-\<^fin>{:x:} = 0)"
by (simp add: xreal_compare_rls)

lemma xreal_eq_iff_diff_eq_0_2: "(\<^fin>{:x:} = a) = (\<^fin>{:x:} - a = 0)"
  apply (cases "a")
  apply (simp_all add: xreal_reduce)
done

lemmas xreal_diff_eq_0_iff_eq =
  xreal_eq_iff_diff_eq_0_1 [symmetric]
  xreal_eq_iff_diff_eq_0_2 [symmetric]

declare xreal_diff_eq_0_iff_eq [simp]

text{*

Of course, @{text "\<xreal>"} is not a field: but we can still salvage a fair bit
of the simp rules.
*}

instance xreal :: zero_neq_one
  apply intro_classes
  apply (simp add: xreal_reduce)
done

instance xreal :: no_zero_divisors
proof intro_classes
  fix a b :: \<xreal>
  assume "a \<noteq> 0" and "b \<noteq> 0"
  then show
  "(a * b) \<noteq> 0"
    apply (multi_cases "a::\<xreal>" "b::\<xreal>")
    apply (auto simp add: xreal_reduce)
  done
qed

text{*

The semiring structure is broken by the @{text "\<zinfty> - \<zinfty>"} problem.

*}

lemma xreal_left_distrib1:
  "(\<^fin>{:x:} + b) * \<^fin>{:y:} = \<^fin>{:x:} * \<^fin>{:y:} + b * \<^fin>{:y:}"
  apply (cases "b")
  apply (auto simp add: xreal_reduce Rings.distrib)
done

lemma xreal_left_distrib2:
  "(b + \<^fin>{:x:}) * \<^fin>{:y:} = \<^fin>{:x:} * \<^fin>{:y:} + b * \<^fin>{:y:}"
  apply (cases "b")
  apply (auto simp add: xreal_reduce Rings.distrib)
done

lemma xreal_left_distrib3:
  "(\<^fin>{:x:} + \<^fin>{:y:}) * \<zinfty> = \<^fin>{:x + y:} * \<zinfty>"
by (auto simp add: xreal_reduce)

lemma xreal_left_distrib4:
  "(\<^fin>{:x:} + \<^fin>{:y:}) * -\<zinfty> = - \<^fin>{:x + y:} * \<zinfty>"
by (auto simp add: xreal_reduce)

lemma xreal_right_distrib1:
  "\<^fin>{:y:} * (\<^fin>{:x:} + b)  = \<^fin>{:y:} * \<^fin>{:x:} + \<^fin>{:y:} * b"
  apply (cases "b")
  apply (auto simp add: xreal_reduce ring_distribs)
done

lemma xreal_right_distrib2:
  "\<^fin>{:y:} * (b + \<^fin>{:x:}) = \<^fin>{:y:} * \<^fin>{:x:} + \<^fin>{:y:} * b"
  apply (cases "b")
  apply (auto simp add: xreal_reduce ring_distribs)
done

lemma xreal_right_distrib3:
  "\<zinfty> * (\<^fin>{:x:} + \<^fin>{:y:}) = \<zinfty> * \<^fin>{:x + y:}"
by (auto simp add: xreal_reduce)

lemma xreal_right_distrib4:
  "-\<zinfty> * (\<^fin>{:x:} + \<^fin>{:y:}) = -\<zinfty> * \<^fin>{:x + y:}"
by (auto simp add: xreal_reduce)

lemma xreal_left_diff_distrib1:
  "(\<^fin>{:x:} - b) * \<^fin>{:y:} = \<^fin>{:x:} * \<^fin>{:y:} - b * \<^fin>{:y:}"
  apply (cases "b")
  apply (auto simp add: xreal_reduce Rings.distrib)
done

lemma xreal_left_diff_distrib2:
  "(b - \<^fin>{:x:}) * \<^fin>{:y:} = b * \<^fin>{:y:} - \<^fin>{:x:} * \<^fin>{:y:}"
  apply (cases "b")
  apply (auto simp add: xreal_reduce Rings.distrib)
done

lemma xreal_left_diff_distrib3:
  "(\<^fin>{:x:} - \<^fin>{:y:}) * \<zinfty> = \<^fin>{:x - y:} * \<zinfty>"
by (auto simp add: xreal_reduce)

lemma xreal_left_diff_distrib4:
  "(\<^fin>{:x:} - \<^fin>{:y:}) * -\<zinfty> = - \<^fin>{:x - y:} * \<zinfty>"
by (auto simp add: xreal_reduce)

lemma xreal_right_diff_distrib1:
  "\<^fin>{:y:} * (\<^fin>{:x:} - b) = \<^fin>{:y:} * \<^fin>{:x:} - \<^fin>{:y:} * b"
  apply (cases "b")
  apply (auto simp add: xreal_reduce ring_distribs)
done

lemma xreal_right_diff_distrib2:
  "\<^fin>{:y:} * (b - \<^fin>{:x:}) = \<^fin>{:y:} * b - \<^fin>{:y:} * \<^fin>{:x:}"
  apply (cases "b")
  apply (auto simp add: xreal_reduce ring_distribs)
done

lemma xreal_right_diff_distrib3:
  "\<zinfty> * (\<^fin>{:x:} - \<^fin>{:y:}) = \<zinfty> * \<^fin>{:x - y:}"
by (auto simp add: xreal_reduce)

lemma xreal_right_diff_distrib4:
  "-\<zinfty> * (\<^fin>{:x:} - \<^fin>{:y:}) = -\<zinfty> * \<^fin>{:x - y:}"
by (auto simp add: xreal_reduce)

lemmas xreal_ring_eq_simps = xreal_group_eq_simps
  xreal_left_distrib1
  xreal_left_distrib2
  xreal_left_distrib3
  xreal_left_distrib4
  xreal_right_distrib1
  xreal_right_distrib2
  xreal_right_distrib3
  xreal_right_distrib4
  xreal_left_diff_distrib1
  xreal_left_diff_distrib2
  xreal_left_diff_distrib3
  xreal_left_diff_distrib4
  xreal_right_diff_distrib1
  xreal_right_diff_distrib2
  xreal_right_diff_distrib3
  xreal_right_diff_distrib4

lemma xreal_left_inverse1 [simp]:
  "x \<noteq> 0 ==> inverse \<^fin>{:x:} * \<^fin>{:x:} = 1"
by (auto simp add: xreal_reduce)

lemma xreal_left_inverse2 [simp]:
  "inverse 0 * 0 = (0::\<xreal>)"
  apply (auto simp add: xreal_reduce)
  apply (cases "(\<some> b::\<xreal> | \<True>)")
  apply (auto simp add: xreal_reduce)
done

lemma xreal_left_inverse3 [simp]:
  "inverse \<zinfty> * \<zinfty> = (0::\<xreal>)"
by (auto simp add: xreal_reduce)

lemma xreal_left_inverse4 [simp]:
  "inverse (-\<zinfty>) * (-\<zinfty>) = (0::\<xreal>)"
by (auto simp add: xreal_reduce)

lemma xreal_right_inverse1 [simp]:
  "x \<noteq> 0 ==> \<^fin>{:x:} * inverse \<^fin>{:x:} = 1"
by (auto simp add: xreal_reduce)

lemma xreal_right_inverse2 [simp]:
  "0 * inverse 0 = (0::\<xreal>)"
  apply (auto simp add: xreal_reduce)
  apply (cases "(\<some> b::\<xreal> | \<True>)")
  apply (auto simp add: xreal_reduce)
done

lemma xreal_right_inverse3 [simp]:
  "\<zinfty> * inverse \<zinfty> = (0::\<xreal>)"
by (auto simp add: xreal_reduce)

lemma xreal_right_inverse4 [simp]:
  "(-\<zinfty>) * inverse (-\<zinfty>) = (0::\<xreal>)"
by (auto simp add: xreal_reduce)

lemma xreal_mult_zero_left [simp]:
  "0 * a = (0::\<xreal>)"
  apply (cases "a")
  apply (simp add: xreal_reduce)+
done

lemma xreal_mult_zero_right [simp]:
  "a * 0 = (0::\<xreal>)"
  apply (cases "a")
  apply (simp add: xreal_reduce)+
done

lemma xreal_field_mult_eq_0_iff [simp]:
  "(a*b = (0::\<xreal>)) = (a = 0 \<or> b = 0)"
  apply (multi_cases "a" "b")
  apply (simp add: xreal_reduce)+
done

lemma xreal_minus_mult_minus [simp]:
  "(- a) * (- b) = a * (b::\<xreal>)"
  apply (multi_cases "a" "b")
  apply (simp add: xreal_reduce)+
done

text{*

\subsection{Arithmetic of infinities}

These should be gathered up into an axclass.

*}

lemma xreal_infinity_add1 [simp]:
  "\<zinfty> + \<^fin>{:x:} = \<zinfty>"
by (simp add: xreal_reduce)

lemma xreal_infinity_add2 [simp]:
  "\<zinfty> + \<zinfty> = \<zinfty>"
by (simp add: xreal_reduce)

lemma xreal_ninfinity_add1 [simp]:
  "-\<zinfty> + \<^fin>{:x:} = -\<zinfty>"
by (simp add: xreal_reduce)

lemma xreal_ninfinity_add2 [simp]:
  "-\<zinfty> + -\<zinfty> = -\<zinfty>"
by (simp add: xreal_reduce)

lemma xreal_infinity_diff1 [simp]:
  "\<zinfty> - \<^fin>{:x:} = \<zinfty>"
by (simp add: xreal_reduce)

lemma xreal_infinity_diff2 [simp]:
  "\<^fin>{:x:} - \<zinfty> = -\<zinfty>"
by (simp add: xreal_reduce)

lemma xreal_ninfinity_diff1 [simp]:
  "-\<zinfty> - \<^fin>{:x:} = -\<zinfty>"
by (simp add: xreal_reduce)

lemma xreal_ninfinity_diff2 [simp]:
  "-\<zinfty> - \<zinfty> = -\<zinfty>"
by (simp add: xreal_reduce)

lemma xreal_infinity_mult1 [simp]:
  "\<zinfty> * \<^fin>{:x:}
  = \<if> 0 < x \<then> \<zinfty> \<else> \<if> x < 0 \<then> - \<zinfty> \<else> 0 \<fi> \<fi>"
by (simp add: xreal_reduce)

lemma xreal_infinity_mult2 [simp]:
  "\<zinfty> * -\<zinfty> = -\<zinfty>"
by (simp add: xreal_reduce)

lemma xreal_infinity_mult3 [simp]:
  "\<zinfty> * \<zinfty> = \<zinfty>"
by (simp add: xreal_reduce)

lemma xreal_ninfinity_mult1 [simp]:
  "-\<zinfty> * \<^fin>{:x:}
  = \<if> 0 < x \<then> -\<zinfty> \<elif> x < 0 \<then> \<zinfty> \<else> 0 \<fi>"
by (simp add: xreal_reduce)

lemma xreal_ninfinity_mult2 [simp]:
  "-\<zinfty> * -\<zinfty> = \<zinfty>"
by (simp add: xreal_reduce)

lemma xreal_infinity_divide1 [simp]:
  "\<zinfty> / \<^fin>{:x:}
  = \<if> 0 < x \<then> \<zinfty> \<elif> x < 0 \<then> - \<zinfty> \<else> \<zinfty> * (\<some> b | \<True>) \<fi>"
by (simp add: xreal_reduce)

lemma xreal_infinity_divide2 [simp]:
  "a / \<zinfty> = 0"
  apply (cases "a")
  apply (simp_all add: xreal_reduce)
done

lemma xreal_ninfinity_divide1 [simp]:
  "-\<zinfty> / \<^fin>{:x:}
  = \<if> 0 < x \<then> -\<zinfty> \<elif> x < 0 \<then> \<zinfty> \<else> -\<zinfty> * (\<some> b | \<True>) \<fi>"
by (simp add: xreal_reduce)

lemma xreal_ninfinity_divide2 [simp]:
  "a / -\<zinfty> = 0"
  apply (cases "a")
  apply (simp_all add: xreal_reduce)
done

lemma xreal_zero_divide [simp]:
  "(0::\<xreal>) / a = 0"
  apply (cases "a")
  apply (simp_all add: xreal_reduce)
  apply (cases "(\<some> (b::\<xreal>) | \<True>)")
  apply (simp_all add: xreal_reduce)
done

text{*

Several of these may be superseded by the following simp rules.
The simp set should be adjusted if these become problematic.

*}

lemma xreal_finite_arithmetic_reduce [simp]:
  "\<^fin>{:x:} + \<^fin>{:y:} = \<^fin>{:x + y:}"
  "\<^fin>{:x:} - \<^fin>{:y:} = \<^fin>{:x - y:}"
  "\<^fin>{:x:} * \<^fin>{:y:} = \<^fin>{:x * y:}"
  "\<^fin>{:x:} / \<^fin>{:y:} = \<^fin>{:x:} * inverse \<^fin>{:y:}"
  "inverse \<^fin>{:y:} = \<if> y \<noteq> 0 \<then> \<^fin>{:inverse y:} \<else> (\<some> b | \<True>) \<fi>"
  "\<^fin>{:0:} + a = a"
  "a + \<^fin>{:0:} = a"
  "\<^fin>{:0:} * a = \<^fin>{:0:}"
  "a * \<^fin>{:0:} = \<^fin>{:0:}"
  "\<^fin>{:0:}/a = \<^fin>{:0:}"
  "\<^fin>{:1:} * a = a"
  "a * \<^fin>{:1:} = a"
  apply (auto simp add: xreal_reduce)
  apply (cases "a",
         auto simp add: xreal_reduce)
  apply (cases "a",
         auto simp add: xreal_reduce)
  apply (cases "a",
         auto simp add: xreal_reduce)
  apply (cases "a",
         auto simp add: xreal_reduce)
  apply (multi_cases "a" "(\<some> (b::\<xreal>) | \<True>)",
         auto simp add: xreal_reduce)
  apply (cases "a",
         auto simp add: xreal_reduce)
  apply (cases "a",
         auto simp add: xreal_reduce)
done

(*
Note that arithmetic of the inifinities themselves is already included in xReal\_Type.thy.  Maybe
rationalise these.
*)

lemma xreal_infinite_arithmetic [simp]:
  "\<^fin>{:x:} + (\<zinfty> + -\<zinfty>) = (\<zinfty> + -\<zinfty>)"
  "\<^fin>{:x:} - (\<zinfty> + -\<zinfty>) = - (\<zinfty> + -\<zinfty>)"
  "\<^fin>{:x:}/ (\<zinfty> + -\<zinfty>) = 0"
  "\<^fin>{:x:} * (\<zinfty> + -\<zinfty>) = \<if> 0 < x \<then> (\<zinfty> + -\<zinfty>) \<else> \<if> x < 0 \<then> - (\<zinfty> + -\<zinfty>) \<else> 0 \<fi> \<fi>"
  "(\<zinfty> + -\<zinfty>) + \<^fin>{:x:} = (\<zinfty> + -\<zinfty>)"
  "(\<zinfty> + -\<zinfty>) - \<^fin>{:x:} = (\<zinfty> + -\<zinfty>)"
  "(\<zinfty> + -\<zinfty>) / \<^fin>{:x:} = (\<zinfty> + -\<zinfty>) * (inverse \<^fin>{:x:})"
  "(\<zinfty> + -\<zinfty>) * \<^fin>{:x:} = \<if> 0 < x \<then> (\<zinfty> + -\<zinfty>) \<else> \<if> x < 0 \<then> - (\<zinfty> + -\<zinfty>) \<else> 0 \<fi> \<fi>"
  "(\<zinfty> + -\<zinfty>) + (\<zinfty> + -\<zinfty>) = (\<zinfty> + -\<zinfty>)"
  "(\<zinfty> + -\<zinfty>) - (\<zinfty> + -\<zinfty>) = (\<zinfty> + -\<zinfty>)"
  "(\<zinfty> + -\<zinfty>) / (\<zinfty> + -\<zinfty>) = 0"

  "\<zinfty> + (\<zinfty> + -\<zinfty>)  = (\<zinfty> + -\<zinfty>)"
  "-\<zinfty> + (\<zinfty> + -\<zinfty>) = (\<zinfty> + -\<zinfty>)"

  "(\<zinfty> + -\<zinfty>) + \<zinfty> = (\<zinfty> + -\<zinfty>)"
  "(\<zinfty> + -\<zinfty>) + -\<zinfty> = (\<zinfty> + -\<zinfty>)"
  "(\<zinfty> + -\<zinfty>) - \<zinfty> = (\<zinfty> + -\<zinfty>)"
  "(\<zinfty> + -\<zinfty>) / (\<zinfty> + -\<zinfty>) = 0"
  "(\<zinfty> + -\<zinfty>) / \<zinfty> = 0"
  "(\<zinfty> + -\<zinfty>) / -\<zinfty> = 0"
  "\<zinfty> / (\<zinfty> + -\<zinfty>) = 0"
  "-\<zinfty> / (\<zinfty> + -\<zinfty>) = 0"
  "inverse (\<zinfty> + -\<zinfty>) = 0"
  "inverse \<zinfty> = 0"
  "inverse -\<zinfty> = 0"
  apply (insert xreal_choose_bdy2, elim disjE)
  apply (auto simp add: xreal_reduce)
done

(*
lemma xreal_infinite_arithmetic_reduce [simp]:
  "a + (\<zinfty> + -\<zinfty>) = (\<zinfty> + -\<zinfty>)"
  "\<^fin>{:x:} - (\<zinfty> + -\<zinfty>) = - (\<zinfty> + -\<zinfty>)"
  "a / (\<zinfty> + -\<zinfty>) = 0"
  "a / \<zinfty> = 0"
  "a / -\<zinfty> = 0"
  "\<^fin>{:x:} * (\<zinfty> + -\<zinfty>) = \<if> 0 < x \<then> (\<zinfty> + -\<zinfty>) \<else> \<if> x < 0 \<then> - (\<zinfty> + -\<zinfty>) \<else> 0 \<fi> \<fi>"
  "(\<zinfty> + -\<zinfty>) + a = (\<zinfty> + -\<zinfty>)"
  "(\<zinfty> + -\<zinfty>) - a = (\<zinfty> + -\<zinfty>)"
  "(\<zinfty> + -\<zinfty>) /  a = (\<zinfty> + -\<zinfty>) * (inverse a)"
  "(\<zinfty> + -\<zinfty>) * \<^fin>{:x:} = \<if> 0 < x \<then> (\<zinfty> + -\<zinfty>) \<else> \<if> x < 0 \<then> - (\<zinfty> + -\<zinfty>) \<else> 0 \<fi> \<fi>"
  "inverse (\<zinfty> + -\<zinfty>) = 0"
  "inverse \<zinfty> = 0"
  "inverse -\<zinfty> = 0"
  apply (insert xreal_choose_bdy, elim disjE)
  apply (cases "a",
         auto simp add: xreal_reduce)+
done;
*)

text{*

Finally, the following may be more useful in its removal!  (I.e., as
@{text "ninfty_reduce [THEN sym]"}!

*}

lemma ninfty_reduce:
  "-\<zinfty> = - \<zinfty>"
by (simp add: xreal_reduce)

text{*

\section{Embedding in the extended reals}

*}

consts
   (* overloaded constant for injecting other types into "xreal" *)
   xreal :: "'a => \<xreal>" ("\<xreal>")

instance xreal :: ordered_ab_semigroup_add
proof intro_classes
  fix a b c :: \<xreal>
  assume Aa1: "a \<le> b"
  then show
  "c + a \<le> c + b"
    apply (multi_cases "a::\<xreal>" "b::\<xreal>" c "(\<some> a | a = \<zinfty> \<or> a = -\<zinfty>)" "(\<some> a | a = -\<zinfty> \<or> a = \<zinfty>)")
    apply (simp_all add: xreal_reduce le_xreal_def)
  done
qed

lemma xreal_neg_le_iff_le: "- (b::\<xreal>) \<le> - a \<Leftrightarrow> a \<le> b"
  apply (multi_cases "a::\<xreal>" "b::\<xreal>" "(\<some> a | a = \<zinfty> \<or> a = -\<zinfty>)")
  apply (simp_all add: xreal_reduce le_xreal_def)
done

lemma xreal_neg_le_0_iff_le [simp]: "- (a::\<xreal>) \<le> 0 \<Leftrightarrow> 0 \<le> a"
by (subst xreal_neg_le_iff_le [symmetric], simp)

lemma xreal_neg_0_le_iff_le [simp]: "0 \<le> - (a::\<xreal>) \<Leftrightarrow> a \<le> 0"
by (subst xreal_neg_le_iff_le [symmetric], simp)

lemma xreal_neg_less_iff_less [simp]: "- b < - (a::\<xreal>) \<Leftrightarrow> a < b"
  apply (multi_cases "a::\<xreal>" "b::\<xreal>" "(\<some> a | a = \<zinfty> \<or> a = -\<zinfty>)")
  apply (simp_all add: xreal_reduce)
  apply auto
done

lemma xreal_neg_less_0_iff_less [simp]: "- (a::\<xreal>) < 0 \<Leftrightarrow> 0 < a"
by (subst xreal_neg_less_iff_less [symmetric], simp)

lemma xreal_neg_0_less_iff_less [simp]: "0 < - (a::\<xreal>) \<Leftrightarrow> a < 0"
by (subst xreal_neg_less_iff_less [symmetric], simp)

text {*
\section{Embedding into the reals}

We use the induced metric via mapping through ``arctan''
This is put here just to keep everything together.

*}

defs (overloaded)
  real_of_xreal_def: "real x \<defs>
    \<case> x \<of>
      -\<zinfty> \<longrightarrow> -1
    | \<^fin>{:a:} \<longrightarrow> a/(1 + (abs a))
    | \<zinfty> \<longrightarrow> 1
    \<esac>"

lemma real_of_xreal_zero [simp]: "real (0::\<xreal>) = 0"
by (simp add: real_of_xreal_def xreal_zero_def)

lemma real_of_xreal_one [simp]: "real (1::\<xreal>) = (1/2::real)"
by (simp add: real_of_xreal_def xreal_one_def)

lemma real_of_xreal_minus [simp]: "real(-x) = -real (x::\<xreal>)"
  apply (simp add: real_of_xreal_def)
  apply (cases "x", auto simp add: xreal_reduce)
done

lemma real_of_xreal_inject [iff]: "(real (x::\<xreal>) = real y) = (x = y)"
proof-
 {fix r :: \<real>
  have "r < 1 + abs r"
  by (auto simp add: abs_if)
  then have
  "1 + abs r \<noteq> r" by auto
  } note R1 = this
 {fix r :: \<real>
  have "-r < 1 + abs r"
  by (auto simp add: abs_if)
  then have
  "r \<noteq> - (1 + abs r)" by auto
  then have
  "r/(1 + abs r) \<noteq> - (1 + abs r)/(1 + abs r)" by (auto simp add: abs_if)
  then have
  "r/(1 + abs r) \<noteq> -1"
  by (subst (asm) minus_divide_left [THEN sym], simp+)
  } note R2 = this
  show ?thesis
    apply (simp add: real_of_xreal_def)
    apply (multi_cases "x" "y", simp_all)
    apply (auto simp add: R1 R2)
  proof-
    fix r r' :: \<real>
    assume Aa1: "r / (1 + abs r) = r' / (1 + abs r')"
    then have
    "r  = (r' / (1 + abs r')) * (1 + abs r)"
thm  nonzero_divide_eq_eq [THEN iffD1]
      apply (intro nonzero_divide_eq_eq [THEN iffD1])
      apply (auto simp add: abs_if)
    done
    then have
    "r  = ((r'  * (1 + abs r))/ (1 + abs r'))"  by auto
    then have Ra1:
    "(r * (1 + abs r')) = (r'  * (1 + abs r))"
      apply (intro nonzero_divide_eq_eq [THEN iffD1, THEN sym])
      apply (auto simp add: abs_if)
    done
    have
    "(0 \<le> r \<and> 0 \<le> r') \<or> (r < 0 \<and> r' < 0)"
      apply (rule Ra1 [THEN contrapos_pp])
      apply (simp add: linorder_not_le linorder_not_less)
      apply (msafe_no_assms(inference))
      apply (simp add: order_le_less) defer
      apply (simp only: order_le_less, elim disjE) defer apply simp
      apply (simp add: order_le_less)
      apply (simp only: order_le_less, elim disjE) defer apply simp
      apply (simp only: linorder_neq_iff, rule disjI2)
      apply (rule order_less_trans)
      apply (rule mult_strict_right_mono, simp, simp, simp only: mult_zero_left)
      apply (rule mult_pos_pos, simp+)
      apply (simp only: linorder_neq_iff, rule disjI1)
      apply (rule order_less_trans)
      apply (rule mult_strict_right_mono, simp, simp, simp only: mult_zero_left)
      apply (rule mult_pos_pos, simp+)
    done
    with Ra1
    show
    "r = r'"
    by (auto simp add: distrib_left linorder_not_le)
  qed
qed

lemma xreal_All:
  "(\<forall> (x::\<xreal>) \<bullet> P x) = ((P -\<zinfty>) \<and> (\<forall> r \<bullet> P \<^fin>{:r:}) \<and> (P \<zinfty>))"
proof auto
  fix x :: \<xreal>
  assume "(P -\<zinfty>)" and "(\<forall> r \<bullet> P \<^fin>{:r:})" and "(P \<zinfty>)"
  then show "P x" by (cases x, auto)
qed

lemma xreal_Ex:
  "(\<exists> (x::\<xreal>) \<bullet> P x) = ((P -\<zinfty>) \<or> (\<exists> r \<bullet> P \<^fin>{:r:}) \<or> (P \<zinfty>))"
proof auto
  apply_end (rule contrapos_pp, assumption, thin_tac "?P", simp)
  fix x :: \<xreal> and r :: \<real>
  assume "\<not> (P -\<zinfty>)" and "(\<forall> r \<bullet> \<not> (P \<^fin>{:r:}))" and "\<not> (P \<zinfty>)"
  then show "\<not> (P x)" by (cases x, auto)
qed

lemma real_of_xreal_mono:
  "(a::\<xreal>) \<le> b \<turnstile> real a \<le> real b"
proof-
  assume Aa1: "a \<le> b"
  {
  fix r :: \<real>
  have "abs r \<le> 1 + abs r"
  by auto
  }
  note R1 = this
  from Aa1 show ?thesis
    apply (multi_cases "a" "b")
    apply (auto simp add: real_of_xreal_def le_xreal_def)
    apply (subst pos_le_divide_eq, simp add: abs_if, simp add: abs_if)
    apply (subst pos_le_divide_eq)
    apply (simp add: abs_if, simp)
    apply (subst pos_divide_le_eq)
    apply (simp add: abs_if)
    apply (auto simp add: abs_if distrib_left linorder_not_less)
  proof-
    fix r r' :: \<real>
    assume Aa1: "0 \<le> r'"
    assume Aa2: "r < 0"
    from Aa1 have
    "0 < (2*r'+1)" by auto
    with Aa2 have
    "r*(2*r'+1) < r*0" by (simp only: mult_less_cancel_left_disj, simp)
    with Aa1 show
    "2 * (r*r') + r \<le> r'"
    by (auto simp add: distrib_left mult_assoc mult_left_commute)
  qed
qed

text{*
Lattice structure

*}

instantiation
  xreal :: linlat
begin

definition
  inf_xreal_def: "oinf \<defs> (\<olambda> (x::\<xreal>) y \<bullet> \<if> x \<le> y \<then> x \<else> y \<fi>)"

definition
  sup_xreal_def: "osup \<defs> (\<olambda> (x::\<xreal>) y \<bullet> \<if> x \<le> y \<then> y \<else> x \<fi>)"

instance
  apply (intro_classes)
  apply (simp_all add: inf_xreal_def sup_xreal_def)
  done

end

interpretation lattice_xreal: Lattice_Locale.lattice "\<univ>-[\<xreal>]" "op \<le>"
  by (unfold_locales)

lemma real_ex_Sup':
  assumes
    A1: "(S::real set) \<noteq> \<emptyset>" and
    A2: "\<^ubp>{:\<univ>-[\<real>]:}{:op \<le>:} S u"
  shows
    "(\<exists>\<subone> Sup \<bullet> \<^lubp>{:\<univ>-[\<real>]:}{:op \<le>:} S Sup)"
proof -
  from A1 A2 have
      "(\<exists> Sup \<bullet> isLub \<univ>-[\<real>] S Sup)"
    by (intro reals_complete, auto simp add: isUb_def setle_def is_ub_def)
  then obtain Sup where
      "\<^lubp>{:\<univ>-[\<real>]:}{:op \<le>:} S Sup"
    by (auto simp add: isLub_def isUb_def leastP_def setle_def setge_def is_lub_def is_least_def is_ub_def)
  then show
      ?thesis
    apply (intro ex1I, assumption)
    apply (rule order_class.lub_unique [of S], assumption+)
  done
qed

theorem real_ex_Inf':
  assumes A1: "(S::real set) \<noteq> \<emptyset>"
  assumes A2: "\<^lbp>{:\<univ>-[\<real>]:}{:op \<le>:} S u"
  shows
    "\<exists>\<subone> Inf \<bullet> \<^glbp>{:\<univ>-[\<real>]:}{:op \<le>:} S Inf"
proof -
txt {*
The proof relies on the observation that Infs and Sups
are dual under negation.
*}
  let ?SM = "uminus \<lparr>S\<rparr>"
  from A2 have "\<^ubp>{:\<univ>-[\<real>]:}{:op \<le>:} ?SM (-u)"
  by (auto simp add: is_ub_def is_lb_def)
  from A1 this [THEN [2] real_ex_Sup'] obtain Sup where
  "\<^lubp>{:\<univ>-[\<real>]:}{:op \<le>:} ?SM Sup"
  by auto
  then have
  "\<^glbp>{:\<univ>-[\<real>]:}{:op \<le>:} S (-Sup)"
    apply (auto simp add: is_lub_def is_least_def is_glb_def is_greatest_def )
    apply (simp add: is_ub_def is_lb_def, auto)
    apply (subst neg_le_iff_le [THEN sym])
    apply (subst minus_minus)
    apply (elim allE impE)
  defer
    apply assumption
    apply (auto simp add: is_ub_def is_lb_def)
  done
  then show ?thesis
    apply (intro ex1I, assumption)
    apply (rule order_classD [THEN partial_order.glb_unique, of S], assumption+)
  done
qed

lemma xreal_ex_Sup':
  assumes A1: "(S::xreal set) \<noteq> \<emptyset>"
  shows
    "\<exists>\<subone> Sup \<bullet> \<^lubp>{:\<univ>-[\<xreal>]:}{:op \<le>:} S Sup"
  apply (cases "\<exists> (r::\<real>) \<bullet> \<^ubp>{:\<univ>-[\<xreal>]:}{:op \<le>:} S \<^fin>{:r:}")
  apply (cases "S = {-\<zinfty>}", (msafe_no_assms(inference)))
proof-
  fix r :: \<real>
  assume Aa1: "S = {-\<zinfty>}"
  then have
  "\<^lubp>{:\<univ>-[\<xreal>]:}{:op \<le>:} S -\<zinfty>"
  by (auto simp add: isLub_def isUb_def leastP_def setle_def setge_def is_lub_def is_least_def is_ub_def)
  then show ?thesis
    apply (intro ex1I, assumption)
    apply (rule order_classD [THEN partial_order.lub_unique, of S], assumption+)
  done
next
  fix r :: \<real>
  assume Aa1: "S \<noteq> {-\<zinfty>}"
  assume Aa2: "\<^ubp>{:\<univ>-[\<xreal>]:}{:op \<le>:} S \<^fin>{:r:}"

  let ?S' = "{r' | \<^fin>{:r':} \<in> S}"
(*
  from A1 Aa1 Aa2 have
  "\<forall> x | x \<in> S - {-\<zinfty>} \<bullet> (\<exists> (r'::\<real>) \<bullet> x = \<^fin>{:r':})"
    apply (simp only: xreal_All, (msafe_no_assms(inference)))
    apply (simp add: isLub_def isUb_def leastP_def setle_def setge_def is_lub_def is_least_def is_ub_def)
    apply (intro exI, simp)
    apply (simp add: isLub_def isUb_def leastP_def setle_def setge_def is_lub_def is_least_def is_ub_def)
    apply (elim allE [where ?x = "\<zinfty>"], simp add: xreal_reduce)
  done
*)
  from Aa2 have Ra0:
  "\<zinfty> \<notin> S"
    apply (simp add: isLub_def isUb_def leastP_def setle_def setge_def is_lub_def is_least_def is_ub_def)
    apply (simp only: xreal_All, (msafe_no_assms(inference)))
    apply (simp add: xreal_reduce)
  done

  from A1 Aa1 Ra0 have Ra1:
  "S - {-\<zinfty>} = fin \<lparr>?S'\<rparr>"
    apply (subst set_eq_def)
    apply (simp add: xreal_All, (msafe_no_assms(inference)))
    apply (simp_all add: isLub_def isUb_def leastP_def setle_def setge_def is_lub_def is_least_def is_ub_def)
    apply (simp_all add: xreal_reduce image_def)
  done
  have Ra2:
  "\<^ubp>{:\<univ>-[\<real>]:}{:op \<le>:} ?S' r"
    apply (simp_all add: isLub_def isUb_def leastP_def setle_def setge_def is_lub_def is_least_def is_ub_def)
    apply (subst fin_order_embed)
    apply (msafe_no_assms(inference), intro Aa2 [THEN order_class.is_ubD], assumption)
  done
  from A1 Aa1 Ra0 have Ra3:
  "?S' \<noteq> \<emptyset>"
    apply auto
    apply (simp_all only: atomize_all atomize_imp)
    apply (simp_all only: xreal_All xreal_Ex, (msafe_no_assms(inference)))
    apply (simp_all add: image_def xreal_reduce)
  done
  from Ra2 Ra3 have "\<exists>\<subone> Sup \<bullet> \<^lubp>{:\<univ>-[\<real>]:}{:op \<le>:} ?S' Sup"
  by (intro real_ex_Sup', simp_all)
  then obtain Sup where real_lub: "\<^lubp>{:\<univ>-[\<real>]:}{:op \<le>:} ?S' Sup"
  by (auto)
  have
  "\<^lubp>{:\<univ>-[\<xreal>]:}{:op \<le>:} (fin \<lparr>?S'\<rparr>) \<^fin>{:Sup:}"
    apply (rule order_class.is_lubI, simp_all add: image_def)
    apply (auto simp add: le_xreal_def)
    apply (rule real_lub [THEN order_class.is_lubD1, THEN order_class.is_ubD])
    apply (simp_all only: atomize_all atomize_imp)
    apply (simp_all only: xreal_All xreal_Ex, (msafe_no_assms(inference)))
    apply (simp_all add: xreal_reduce)
    apply (insert Ra3, simp add: image_def)
    apply (rule real_lub [THEN order_class.is_lubD2'])
    apply (simp_all)
  done
  then have
  "\<^lubp>{:\<univ>-[\<xreal>]:}{:op \<le>:} S \<^fin>{:Sup:}"
    apply (simp add: Ra1 [THEN sym])
    apply (simp add: isLub_def isUb_def leastP_def setle_def setge_def is_lub_def is_least_def is_ub_def)
    apply (simp_all only: xreal_All xreal_Ex, (msafe_no_assms(inference)))
    apply (simp_all add: xreal_reduce)
  done
  then show ?thesis
    apply (intro ex1I, assumption)
    apply (rule order_class.lub_unique, simp_all)
  done
next
  apply_end simp
  assume Aa1: "\<forall> r \<bullet> \<not> (\<^ubp>{:\<univ>-[\<xreal>]:}{:op \<le>:} S \<^fin>{:r:})"
  then have
  "\<^lubp>{:\<univ>-[\<xreal>]:}{:op \<le>:} S \<zinfty>"
    apply (cases "\<zinfty> \<in> S")
    apply (simp_all add: isLub_def isUb_def leastP_def setle_def setge_def is_lub_def is_least_def is_ub_def le_xreal_simps not_le)
    apply (msafe_no_assms(inference))
  proof -
    assume
      c1: "\<zinfty> \<notin> S"
    fix x
    assume
      c2: "(\<forall> r \<bullet> (\<exists> y \<bullet> y \<in> S \<and> fin r < y))" and
      c3: "(\<forall> y \<bullet> y \<in> S \<Rightarrow> y \<le> x)"
    from c3 show
      "\<zinfty> \<le> x"
      apply (cases x)
      apply (simp_all)
    proof -
      assume
        d1: "(\<forall> y \<bullet> y \<in> S \<Rightarrow> y \<le> -\<zinfty>)"
      from c2 [rule_format, of "0"] obtain y where
        d2: "y \<in> S" and d3: "fin 0 < y"
        by (auto)
      from d3 have
        d4: "y \<noteq> -\<zinfty>"
        by (auto simp add: le_xreal_simps)
      from d2 d1 have
        d4': "y \<le> -\<zinfty>"
        by (auto)
      from d4 d4' show
        "\<zinfty> \<le> -\<zinfty>"
        apply (cases y)
        apply (auto simp add: le_xreal_simps)
        done
    next
      fix r
      assume
        d1: "(\<forall> y \<bullet> y \<in> S \<Rightarrow> y \<le> fin r)"
      from c2 [rule_format, of "r"] obtain y where
        d2: "y \<in> S" and d3: "fin r < y"
        by (auto)
      with d1 show
        "\<zinfty> \<le> fin r"
        by (auto simp add: le_xreal_simps)
    qed
  qed
  then show ?thesis
    apply (intro ex1I, assumption)
    apply (rule order_class.lub_unique, simp_all)
  done
qed

theorem xreal_ex_Inf':
  assumes A1: "(S::xreal set) \<noteq> \<emptyset>"
  shows
    "\<exists>\<subone> Inf \<bullet> \<^glbp>{:\<univ>-[\<xreal>]:}{:op \<le>:} S Inf"
proof -
  let ?SM = "uminus \<lparr>S\<rparr>"
  from A1 have "?SM \<noteq> \<emptyset>"
  by (auto simp add: image_def)
  from this [THEN xreal_ex_Sup'] obtain Sup where Sup_ext:
  "\<^lubp>{:\<univ>-[\<xreal>]:}{:op \<le>:} ?SM Sup"
  by auto
  have
  "\<^glbp>{:\<univ>-[\<xreal>]:}{:op \<le>:} S (-Sup)"
    apply (simp add: is_glb_def is_lb_def is_greatest_def del: le_xreal_def)
    apply (msafe_no_assms(inference))
  proof-
    fix x
    assume Aa1: "x \<in> S"
    then have "-x \<le> Sup" by (intro Sup_ext [THEN order_class.is_lubD1'], simp)
    then show "- Sup \<le> x" by (subst xreal_neg_le_iff_le [THEN sym], subst xreal_minus_minus)
  next
    fix x
    assume Aa1: "\<forall> y \<bullet> y \<in> S \<Rightarrow> x \<le> y"
    then have Ra1:
    "\<forall> y \<bullet> y \<in> uminus\<lparr>S\<rparr> \<Rightarrow> y \<le> -x"
    by (subst xreal_neg_le_iff_le [THEN sym], subst xreal_minus_minus, auto)
    then have "Sup \<le> -x" by (intro Sup_ext [THEN order_class.is_lubD2'], auto)
    then show "x \<le> - Sup" by (subst xreal_neg_le_iff_le [THEN sym], subst xreal_minus_minus)
  qed
  then show ?thesis
    apply (intro ex1I, assumption)
    apply (rule order_classD [THEN partial_order.glb_unique], assumption+)
  done
qed

theorem xreal_clattice:
"\<^clattice>{:\<univ>-[\<xreal>]:}{:op \<le>:}"
proof (rule order_classD [THEN partial_order.clatticeI])
  fix X :: "\<xreal> set"
  assume A2: "X \<subseteq> \<univ>-[\<xreal>]"
  show
  "\<exists> z \<bullet> \<^glbp>{:\<univ>-[\<xreal>]:}{:op \<le>:} X z"
  proof (cases "X = \<emptyset>")
    assume A11: "X = \<emptyset>"
    from A2 A11 show ?thesis
      apply (auto simp add: is_glb_def is_lb_def is_greatest_def)
      apply (witness "\<zinfty>")
      apply (simp only: xreal_All xreal_Ex, (msafe_no_assms(inference)))
      apply (auto simp add: xreal_reduce)
    done
  next
    assume A11: "X \<noteq> \<emptyset>"
    then have
    "\<exists>\<subone> Inf \<bullet> \<^glbp>{:\<univ>-[\<xreal>]:}{:op \<le>:} X Inf"
    by (intro xreal_ex_Inf', simp)
    then show
    "\<exists> Inf \<bullet> \<^glbp>{:\<univ>-[\<xreal>]:}{:op \<le>:} X Inf"
    by auto
  qed
next
  fix X :: "\<xreal> set"
  assume A2: "X \<subseteq> \<univ>-[\<xreal>]"
  show
  "\<exists> z \<bullet> \<^lubp>{:\<univ>-[\<xreal>]:}{:op \<le>:} X z"
  proof (cases "X = \<emptyset>")
    assume A11: "X = \<emptyset>"
    from A2 A11 show ?thesis
      apply (auto simp add: is_lub_def is_ub_def is_least_def)
      apply (witness "-\<zinfty>")
      apply (simp only: xreal_All xreal_Ex, (msafe_no_assms(inference)))
      apply (auto simp add: xreal_reduce)
    done
  next
    assume A11: "X \<noteq> \<emptyset>"
    then have
    "\<exists>\<subone> Sup \<bullet> \<^lubp>{:\<univ>-[\<xreal>]:}{:op \<le>:} X Sup"
    by (intro xreal_ex_Sup', simp)
    then show
    "\<exists> Sup \<bullet> \<^lubp>{:\<univ>-[\<xreal>]:}{:op \<le>:} X Sup"
    by auto
  qed
qed

theorem xreal_interval_clattice:
    "(a::\<xreal>) \<le> b
    \<turnstile> \<^clattice>{:\<lclose>a\<dots>b\<rclose>:}{:\<^subord>{:op \<le>:}{:\<lclose>a\<dots>b\<rclose>:}:}"
proof-
  assume A1: "a \<le> b"
  from A1 interpret
    po_interval: partial_order "\<lclose>a\<dots>b\<rclose>" "\<^subord>{:op \<le>:}{:\<lclose>a\<dots>b\<rclose>:}"
    apply (fold default_order_def)
    apply (rule default_po)
    apply (auto simp only: interval_defs)
    done
  show ?thesis
  proof (rule po_interval.clatticeI)
    fix
      X :: "\<xreal> set"
    assume
      A2: "X \<subseteq> \<lclose>a\<dots>b\<rclose>"
    show
        "(\<exists> z \<bullet> \<^glbp>{:\<lclose>a\<dots>b\<rclose>:}{:\<^subord>{:op \<le>:}{:\<lclose>a\<dots>b\<rclose>:}:} X z)"
    proof (cases "X = \<emptyset>")
      assume
        A11: "X = \<emptyset>"
      from A1 A2 A11 show
          ?thesis
        apply (auto simp only: is_glb_def is_lb_def is_greatest_def)
        apply (auto simp only: interval_defs subset_order_def op2rel_def rel2op_def)
        apply (auto simp add: eind_def)
        done
    next
      assume
        A11: "X \<noteq> \<emptyset>"
      from A11 obtain x where
        R0': "x \<in> X"
        by auto
      from A1 A2 A11 have
          "(\<exists>\<subone> Inf \<bullet> \<^glbp>{:\<univ>-[\<xreal>]:}{:op \<le>:} X Inf)"
        by (intro xreal_ex_Inf',simp)
      then obtain Inf where
        R1': "(\<forall> x | x \<in> X \<bullet> Inf \<le> x) \<and> (\<forall> l | (\<forall> x | x \<in> X \<bullet> l \<le> x) \<bullet> l \<le> Inf)"
        by (auto simp add: is_lb_def is_glb_def is_greatest_def)
      from R1' have
        R2a: "\<forall> x | x \<in> X \<bullet> Inf \<le> x"
        by (auto)
      from R1' have
        R2b: "(\<forall> l | (\<forall> x | x \<in> X \<bullet> l \<le> x) \<bullet> l \<le> Inf)"
        by (auto)
      have
        R2c: "Inf \<in> \<lclose>a\<dots>b\<rclose>"
      proof (auto simp add: interval_defs)
        from R0' have
            "Inf
            \<le> x"
          by (intro R2a [rule_format])
        also from R0' A1 A2 have "...
            \<le> b"
          by (auto simp add: interval_defs)
        finally show
            "Inf \<le> b"
          by (this)
      next
        from A1 A2 show
            "a \<le> Inf"
          by (intro R2b [rule_format], auto simp add: interval_defs)
      qed
      from A1 A2 R2c show
          ?thesis
        apply (intro exI [where ?x = "Inf"])
        apply (auto simp add: is_glb_def is_lb_def is_greatest_def)
        apply (auto simp add: subset_order_def op2rel_def rel2op_def subset_def)
        apply (intro R2a [rule_format])
        apply (auto)
        apply (intro R2b [rule_format])
        apply (auto)
        done
    qed
  next
    fix
      X :: "\<xreal> set"
    assume
      A2: "X \<subseteq> \<lclose>a\<dots>b\<rclose>"
    show
        "(\<exists> z \<bullet> \<^lubp>{:\<lclose>a\<dots>b\<rclose>:}{:\<^subord>{:op \<le>:}{:\<lclose>a\<dots>b\<rclose>:}:} X z)"
    proof (cases "X = \<emptyset>")
      assume
        A11: "X = \<emptyset>"
      from A1 A2 A11 show
          ?thesis
        apply (auto simp add: is_lub_def is_ub_def is_least_def)
        apply (auto simp add: interval_defs subset_order_def op2rel_def rel2op_def)
        done
    next
      assume
        A11: "X \<noteq> \<emptyset>"
      from A11 obtain x where
        R0': "x \<in> X"
        by auto
      from A1 A2 A11 have
          "(\<exists>\<subone> Sup \<bullet> \<^lubp>{:\<univ>-[\<xreal>]:}{:op \<le>:} X Sup)"
        by (intro xreal_ex_Sup',simp)
      then obtain Sup where
        R1': "(\<forall> x | x \<in> X \<bullet> x \<le> Sup) \<and> (\<forall> u | (\<forall> x | x \<in> X \<bullet> x \<le> u) \<bullet> Sup \<le> u)"
        by (auto simp add: is_ub_def is_lub_def is_least_def)
      from R1' have
        R2a: "(\<forall> x | x \<in> X \<bullet> x \<le> Sup)"
        by (auto)
      from R1' have
        R2b: "(\<forall> u | (\<forall> x | x \<in> X \<bullet> x \<le> u) \<bullet> Sup \<le> u)"
        by (auto)
      have
        R2c: "Sup \<in> \<lclose>a\<dots>b\<rclose>"
      proof (auto simp add: interval_defs)
        from R0' A1 A2 have
            "a
            \<le> x"
          by (auto simp add: interval_defs)
        also from R0' have "...
            \<le> Sup"
          by (intro R2a [rule_format])
        finally show
            "a \<le> Sup"
          by (this)
      next
        from A1 A2 show
            "Sup \<le> b"
          apply (intro R2b [rule_format])
          apply (auto simp add: interval_defs)
          done
      qed
      from A1 A2 R2c show
          ?thesis
        apply (intro exI [where ?x = "Sup"])
        apply (auto simp add: is_lub_def is_ub_def is_least_def)
        apply (auto simp add: subset_order_def op2rel_def rel2op_def)
        apply (intro R2a [rule_format])
        apply (auto)
        apply (intro R2b [rule_format])
        apply (auto)
        done
    qed
  qed
qed

text {* The extended real numbers are an instance of metric. *}

instantiation xreal :: metric
begin

definition
  distance_xreal_def:  "\<^mcdist>{:x::\<xreal>:}{:y:} \<defs> abs ((real x) - (real y))"

instance
  apply (intro_classes)
  apply (simp add: distance_xreal_def | (msafe_no_assms(inference)))+
  done

end

end


theory Aczel3
  imports Language
begin

fun pre :: "'a \<times> 'b \<times> 'c \<Rightarrow> 'a" where
  "pre (x, y, z) = x"

fun post :: "'a \<times> 'b \<times> 'c \<Rightarrow> 'c" where
  "post (x, y, z) = z"

coinductive consistent :: "('a \<times> 'b \<times> 'a) llist \<Rightarrow> bool" where
  EqNil [intro!]: "consistent LNil"
| EqSingle [intro!]: "consistent (LCons \<sigma> LNil)"
| EqPair [intro!]: "post \<sigma> = pre \<sigma>' \<Longrightarrow> consistent (LCons \<sigma>' t) \<Longrightarrow> consistent (LCons \<sigma> (LCons \<sigma>' t))"

lemma consistent_LConsD [dest]: "consistent (LCons \<sigma> t) \<Longrightarrow> consistent t"
  by (erule consistent.cases) auto

lemma consistent_LConsE [elim]: "consistent (LCons \<sigma> (LCons \<sigma>' t)) \<Longrightarrow> post \<sigma> = pre \<sigma>'"
  by (erule consistent.cases) auto

lemma lnth_repeat [simp]: "lnth (repeat x) n = x"
  by (induct n) simp_all

lemma inf_stutter_consistent: "consistent (repeat (\<sigma>, l, \<sigma>))"
proof -
  have "\<forall>n. post (lnth (repeat (\<sigma>, l, \<sigma>)) n) = pre (lnth (repeat (\<sigma>, l, \<sigma>)) (Suc n))"
    by (simp del: lnth_iterates)
  thus ?thesis
  proof coinduct
    case (consistent t)
    show ?case
    proof (cases t)
      assume "t = LNil"
      thus ?case by simp
    next
      fix \<sigma> t'
      assume [simp]: "t = LCons \<sigma> t'"
      hence "?EqSingle \<or> ?EqPair"
      proof (cases t')
        assume "t' = LNil"
        thus "?EqSingle \<or> ?EqPair"
          by auto (metis prod_cases3)
      next
        fix \<sigma>' t''
        assume [simp]: "t' = LCons \<sigma>' t''"
        from consistent
        have "?EqPair"
          by (auto, erule_tac x = 0 in allE, auto, erule_tac x = "Suc n" in allE, auto)
        thus "?EqSingle \<or> ?EqPair" by simp
      qed
      thus ?case by simp
    qed
  qed
qed

definition Con :: "('a \<times> 'b \<times> 'a) lan" where
  "Con = Collect consistent"

definition Aczel :: "('a \<times> 'b \<times> 'a) lan \<Rightarrow> ('a \<times> 'b \<times> 'a) lan" ("\<pi>") where
  "\<pi> X = X \<inter> Con"

lemma inf_stutter_Con [intro!]: "repeat (\<sigma>, l, \<sigma>) \<in> Con"
  by (metis Con_def inf_stutter_consistent mem_Collect_eq)

lemma Aczel_continuous: "\<pi> (\<Union>\<XX>) = \<Union>{\<pi> X |X. X \<in> \<XX>}"
  by (auto simp add: Aczel_def)

lemma Aczel_inter [simp]: "\<pi> (X \<inter> Y) = \<pi> X \<inter> \<pi> Y"
  by (metis Aczel_def Int_assoc inf_commute inf_left_idem)

lemma Aczel_union [simp]: "\<pi> (X \<union> Y) = \<pi> X \<union> \<pi> Y"
  by (auto simp add: Aczel_def)

lemma Aczel_coextensive [intro!]: "\<pi> X \<subseteq> X"
  by (auto simp add: Aczel_def)

lemma Aczel_iso [intro]: "X \<subseteq> Y \<Longrightarrow> \<pi> X \<subseteq> \<pi> Y"
  by (auto simp add: Aczel_def)

lemma Aczel_idem [simp]: "\<pi> (\<pi> X) = \<pi> X"
  by (auto simp add: Aczel_def)

lemma Aczel_zero [simp]: "\<pi> {} = {}"
  by (simp add: Aczel_def)

lemma Con_l_prod: "Con = (Con \<cdot> Con) \<inter> Con"
  by (auto simp add: Con_def l_prod_def) (metis EqNil lappend_LNil2)

lemma consistent_lappend1 [dest]:
  assumes "consistent (t \<frown> s)" shows "consistent t"
proof (cases "lfinite t")
  assume "lfinite t"
  from this and assms
  show "consistent t"
  proof (induct t rule: lfinite_induct)
    case Nil show ?case by blast
  next
    case (Cons \<sigma> t)
    thus ?case
      by (cases t) auto
  qed
next
  assume "\<not> lfinite t"
  from this and assms
  show "consistent t"
    by (metis lappend_inf)
qed

lemma consistent_lappend2 [dest]: "lfinite t \<Longrightarrow> consistent (t \<frown> s) \<Longrightarrow> consistent s"
proof (induct t rule: lfinite_induct)
  case Nil thus ?case by simp
next
  case (Cons \<sigma> t)
  thus ?case
    by (cases t) auto
qed

lemma [dest]: "xs \<frown> ys \<in> Con \<Longrightarrow> xs \<in> Con"
  by (auto simp add: Con_def)

lemma [dest]: "lfinite xs \<Longrightarrow> xs \<frown> ys \<in> Con \<Longrightarrow> ys \<in> Con"
  by (auto simp add: Con_def)

lemma [simp]: "X \<cdot> {} \<union> X \<inter> FIN = X"
  by (auto simp add: l_prod_def FIN_def)

lemma Aczel_l_prod [simp]: "\<pi> (\<pi> X \<cdot> \<pi> Y) = \<pi> (X \<cdot> Y)"
proof -
  have "\<pi> (X \<cdot> Y) = \<pi> {xs \<in> X. \<not> lfinite xs} \<union> \<pi> {xs \<frown> ys |xs ys. xs \<in> X \<and> lfinite xs \<and> ys \<in> Y}"
    by (simp add: l_prod_def)
  also have "... = \<pi> X \<cdot> {} \<union> \<pi> {xs \<frown> ys |xs ys. xs \<in> X \<and> lfinite xs \<and> ys \<in> Y}"
    by simp
  also have "... = \<pi> X \<cdot> {} \<union> \<pi> ((\<pi> X \<inter> FIN) \<cdot> \<pi> Y)"
    by (subst fin_l_prod, metis (mono_tags) inf.cobounded2, auto simp add: Aczel_def FIN_def)
  also have "... = \<pi> (\<pi> X \<cdot> {} \<union> (\<pi> X \<inter> FIN) \<cdot> \<pi> Y)"
    by (auto simp add: Aczel_def l_prod_def)
  also have "... = \<pi> (\<pi> X \<cdot> {} \<cdot> \<pi> Y \<union> (\<pi> X \<inter> FIN) \<cdot> \<pi> Y)"
    by (metis l_prod_zero seq.mult_assoc)
  also have "... = \<pi> ((\<pi> X \<cdot> {} \<union> (\<pi> X \<inter> FIN)) \<cdot> \<pi> Y)"
    by (metis l_prod_distr)
  also have "... = \<pi> (\<pi> X \<cdot> \<pi> Y)"
    by simp
  finally show ?thesis by blast
qed

lemma [simp]: "ltake \<infinity> xs = xs"
  apply (cases "lfinite xs")
  apply (induct xs rule: lfinite_induct)
  apply simp_all
  apply (subst eSuc_infinity[symmetric])
  apply (subst ltake_LCons)
  apply (simp del: eSuc_infinity)
  by (metis ltake_all not_lfinite_llength order_refl)

lemma llist_cases3:
  "P LNil \<Longrightarrow> (\<And>x. xs = LCons x LNil \<Longrightarrow> P xs) \<Longrightarrow> (\<And>x y ys. xs = LCons y (LCons x ys) \<Longrightarrow> P xs) \<Longrightarrow> P xs"
  by (metis (full_types) lhd_LCons_ltl)

lemma consistent_ltake: "consistent t \<Longrightarrow> consistent (ltake n t)"
proof (induct n, simp_all)
  fix n
  assume "consistent t"
  thus "consistent (ltake (enat n) t)"
  proof (induct n arbitrary: t)
    case 0 show ?case by (auto simp: enat_0)
  next
    case (Suc n)
    show ?case
    proof (rule llist_cases3[where xs = t])
      show "consistent (ltake (enat (Suc n)) LNil)"
        by (simp add: eSuc_enat[symmetric]) blast
    next
      fix \<sigma>
      assume "t = LCons \<sigma> LNil"
      from this and Suc.prems show "consistent (ltake (enat (Suc n)) t)"
        by (cases n) (simp_all add: enat_0 eSuc_enat[symmetric])
    next
      fix \<sigma> \<sigma>' t'
      assume "t = LCons \<sigma> (LCons \<sigma>' t')"
      from this and Suc show "consistent (ltake (enat (Suc n)) t)"
        apply (cases n)
        apply (simp_all add: eSuc_enat[symmetric] enat_0)
        apply blast
        apply (rule EqPair)
        apply (erule consistent_LConsE)
        by (metis consistent_LConsD ltake_eSuc_LCons)
    qed
  qed
qed

lemma Aczel_par: "\<pi> (\<pi> X \<parallel> \<pi> Y) \<le> \<pi> (X \<parallel> Y)"
  by (metis Aczel_coextensive Aczel_iso par.mult_isol_var)

lemma Aczel_consistent [simp]: "\<pi> X \<inter> Con = \<pi> X"
  by (simp add: Aczel_def)

lemma Aczel_UNIV [simp]: "\<pi> UNIV = Con"
  by (auto simp add: Aczel_def)

lemma lappend_consistent:
  "lfinite xs \<Longrightarrow> consistent (LCons x xs \<frown> LCons y ys) \<Longrightarrow> post (llast (LCons x xs)) = pre y"
  by (induct xs arbitrary: x rule: lfinite_induct) auto

lemma [dest!]: "consistent (LCons x xs \<frown> LCons y ys) \<Longrightarrow> lfinite xs \<longrightarrow> post (llast (LCons x xs)) = pre y"
  by (metis lappend_consistent)

lemma [simp]: "llast (LCons (\<sigma>, \<sigma>) (llist_of (replicate n (\<sigma>, \<sigma>)))) = (\<sigma>, \<sigma>)"
  by (induct n) auto

definition Aczel_mult :: "('a \<times> 'b \<times> 'a) lan \<Rightarrow> ('a \<times> 'b \<times> 'a) lan \<Rightarrow> ('a \<times> 'b \<times> 'a) lan" (infixl "\<otimes>" 75) where
  "X \<otimes> Y = \<pi> (X \<cdot> Y)"

lemma amult_distl [simp]: "X \<otimes> (Y \<union> Z) = X \<otimes> Y \<union> X \<otimes> Z"
  by (simp add: Aczel_mult_def)

lemma amult_distr [simp]: "(X \<union> Y) \<otimes> Z = X \<otimes> Z \<union> Y \<otimes> Z"
  by (simp add: Aczel_mult_def)

lemma amult_assoc: "X \<otimes> (Y \<otimes> Z) = (X \<otimes> Y) \<otimes> Z"
  by (simp add: Aczel_mult_def) (metis Aczel_def Aczel_l_prod inf_commute inf_left_idem seq.mult_assoc)

lemma consistent_replicate': "consistent (llist_of xs) \<Longrightarrow> \<forall>y\<in>set xs. \<exists>\<sigma>. y = (\<sigma>, l, \<sigma>) \<Longrightarrow> \<exists>n \<sigma>. xs = replicate n (\<sigma>, l, \<sigma>)"
proof (induct xs)
  case Nil show ?case by simp
next
  case (Cons x1 xs)
  thus ?case
  proof (induct xs)
    case Nil thus ?case
      by (rule_tac x = 1 in exI) auto
  next
    case (Cons x2 xs)
    thus ?case
      apply -
      apply simp
      apply (frule consistent_LConsD)
      apply simp
      apply (frule consistent_LConsD) back
      apply simp
      apply auto
      apply (subgoal_tac "\<exists>n \<sigma>. xs = replicate n (\<sigma>, l, \<sigma>)")
      apply simp
      apply (subgoal_tac "\<sigma>'' = \<sigma>'")
      apply simp
      apply (subgoal_tac "\<sigma>' = \<sigma>")
      apply simp
      apply (rule_tac x = "Suc n" in exI)
      apply simp
      apply (metis in_set_member in_set_replicate member_rec(1) prod.inject)
      apply (drule consistent_LConsE)
      apply simp
      apply (rule_tac x = "n - 1" in exI)
      by (metis tl.simps(2) tl_replicate)
  qed
qed

lemma replicate_finite_Con: "llist_of (replicate n (\<sigma>, l, \<sigma>)) \<in> Con"
proof (induct n)
  case 0 show ?case
    by (auto simp add: Con_def)
next
  case (Suc n) thus ?case
    by (cases n) (auto simp add: Con_def)
qed

lemma Aczel_inf [simp]: "\<pi> (x\<cdot>{}) = (\<pi> x)\<cdot>{}"
  by (auto simp add: l_prod_def Con_def)

lemma Aczel_one [simp]: "\<pi> {LNil} = {LNil}"
  by (auto simp add: Aczel_def Con_def)

primrec proj_power :: "('a \<times> 'b \<times> 'a) lan \<Rightarrow> nat \<Rightarrow> ('a \<times> 'b \<times> 'a) lan" where
  "proj_power x 0 = {LNil}"
| "proj_power x (Suc n) = \<pi> (x \<cdot> proj_power x n)"

definition proj_powers :: "('a \<times> 'b \<times> 'a) lan \<Rightarrow> ('a \<times> 'b \<times> 'a) lan set" where
  "proj_powers x  = {y. (\<exists>i. y = proj_power x i)}"

lemma power_to_proj: "\<pi> (power x i) = proj_power x i"
  apply (induct i)
  apply simp_all
  by (metis Aczel_idem Aczel_l_prod)

lemma proj_power_proj: "proj_power x i = proj_power (\<pi> x) i"
  apply (induct i)
  apply simp_all
  by (metis Aczel_l_prod Language.power.simps(2) power_to_proj proj_power.simps(2))

lemma powers_to_proj: "\<pi> ` powers x = proj_powers x"
  apply (auto simp add: proj_powers_def powers_def image_def)
  apply (metis power_to_proj)
  by (metis power_to_proj)

lemma proj_powers_proj: "proj_powers x = proj_powers (\<pi> x)"
  apply (auto simp add: proj_powers_def)
  apply (metis proj_power_proj)
  by (metis proj_power_proj)

lemma "\<Union>{\<pi> X |X. X \<in> powers (x \<inter> FIN)} = \<Union>{X. X \<in> \<pi> ` powers (x \<inter> FIN)}"
  by (auto simp add: image_def)

lemma Aczel_fin_star_lem: "\<Union>{\<pi> X |X. X \<in> powers (x \<inter> FIN)} = \<Union>{\<pi> X |X. X \<in> powers (\<pi> (x \<inter> FIN))}"
proof -
  have "\<Union>{\<pi> X |X. X \<in> powers (x \<inter> FIN)} = \<Union>{X. X \<in> \<pi> ` powers (x \<inter> FIN)}"
    by (auto simp add: image_def)
  also have "... = \<Union>{X. X \<in> proj_powers (x \<inter> FIN)}"
    by (metis powers_to_proj)
  also have "... = \<Union>{X. X \<in> proj_powers (\<pi> (x \<inter> FIN))}"
    by (metis proj_powers_proj)
  also have "... =  \<Union>{X. X \<in> \<pi> ` powers (\<pi> (x \<inter> FIN))}"
    by (metis powers_to_proj)
  also have "... = \<Union>{\<pi> X |X. X \<in> powers (\<pi> (x \<inter> FIN))}"
    by (auto simp add: image_def)
  finally show ?thesis .
qed

lemma Aczel_fin_star: "\<pi> ((x \<inter> FIN)\<^sup>\<star>) \<le> \<pi> ((\<pi> (x \<inter> FIN))\<^sup>\<star>)"
  apply (subst star_power_fin)
  apply simp
  apply (subst star_power_fin)
  apply (metis Aczel_coextensive inf.bounded_iff)
  apply (subst Aczel_continuous)+
  by (metis Aczel_fin_star_lem subset_refl)

lemma Aczel_star1: "\<pi> (x\<^sup>\<star>) \<le> \<pi> (\<pi> x\<^sup>\<star>)"
proof -
  have "\<pi> (x\<^sup>\<star>) = \<pi> ((x \<inter> FIN \<union> x\<cdot>{})\<^sup>\<star>)"
    by simp
  also have "... = \<pi> ((x \<inter> FIN)\<^sup>\<star>\<cdot>x\<cdot>{} \<union> (x \<inter> FIN)\<^sup>\<star>)"
    by (simp only: seq.inf_part_star)
  also have "... = \<pi> ((x \<inter> FIN)\<^sup>\<star> \<cdot> (x\<cdot>{} \<union> {LNil}))"
    by (metis seq.distrib_left seq.mult.right_neutral seq.mult_assoc)
  also have "... = \<pi> (\<pi> ((x \<inter> FIN)\<^sup>\<star>) \<cdot> \<pi> (x\<cdot>{} \<union> {LNil}))"
    by (metis Aczel_l_prod)
  also have "... \<le> \<pi> (\<pi> ((\<pi> (x \<inter> FIN))\<^sup>\<star>) \<cdot> \<pi> (x\<cdot>{} \<union> {LNil}))"
    by (metis (hide_lams, no_types) Aczel_fin_star Aczel_iso seq.mult_isor)
  also have "... = \<pi> (\<pi> (\<pi> (x \<inter> FIN)\<^sup>\<star>) \<cdot> (\<pi> x \<cdot> {} \<union> {LNil}))"
    by (simp only: Aczel_union Aczel_inf Aczel_one)
  also have "... = \<pi> (\<pi> (\<pi> (x \<inter> FIN)\<^sup>\<star>) \<cdot> \<pi> x \<cdot> {} \<union> \<pi> (\<pi> (x \<inter> FIN)\<^sup>\<star>))"
    by (metis seq.distrib_left seq.mult.right_neutral seq.mult_assoc)
  also have "... = \<pi> (\<pi> (x \<inter> FIN)\<^sup>\<star> \<cdot> \<pi> x \<cdot> {} \<union> \<pi> (x \<inter> FIN)\<^sup>\<star>)"
    by (metis Aczel_idem Aczel_l_prod Aczel_union)
  also have "... = \<pi> ((\<pi> (x \<inter> FIN) \<union> \<pi> x \<cdot> {})\<^sup>\<star>)"
    by (simp only: seq.inf_part_star)
  also have "... = \<pi> ((\<pi> (x \<inter> FIN \<union> x\<cdot>{}))\<^sup>\<star>)"
    by (simp only: Aczel_union Aczel_inf Aczel_idem)
  also have "... = \<pi> (\<pi> x\<^sup>\<star>)"
    by simp
  finally show ?thesis .
qed

lemma Aczel_star [simp]: "\<pi> (\<pi> x\<^sup>\<star>) = \<pi> (x\<^sup>\<star>)"
  by (metis Aczel_def Aczel_iso Aczel_star1 par.add_ub2 seq.star_iso subset_antisym sup_inf_absorb)

end