/-
Who knows how much of this we need.

Lemma 10.16.2. Let R be a ring.

    The spectrum of a ring R is empty if and only if R is the zero ring.
    Every nonzero ring has a maximal ideal.
    Every nonzero ring has a minimal prime ideal.
    Given an ideal I⊂R and a prime ideal I⊂𝔭 there exists a prime I⊂𝔮⊂𝔭 such that 𝔮 is minimal over I.
  (5)  If T⊂R, and if (T) is the ideal generated by T in R, then V((T))=V(T).
    If I is an ideal and I√ is its radical, see basic notion (27), then V(I)=V(I√).
    Given an ideal I of R we have I√=⋂I⊂𝔭𝔭.
  (8)  If I is an ideal then V(I)=∅ if and only if I is the unit ideal.
    If I, J are ideals of R then V(I)∪V(J)=V(I∩J).
    If (Ia)a∈A is a set of ideals of R then ∩a∈AV(Ia)=V(∪a∈AIa).
    If f∈R, then D(f)⨿V(f)=Spec(R).
    If f∈R then D(f)=∅ if and only if f is nilpotent.
    If f=uf′ for some unit u∈R, then D(f)=D(f′).
    If I⊂R is an ideal, and 𝔭 is a prime of R with 𝔭∉V(I), then there exists an f∈R such that 𝔭∈D(f), and D(f)∩V(I)=∅.
  (15)  If f,g∈R, then D(fg)=D(f)∩D(g).
  (16)  If fi∈R for i∈I, then ⋃i∈ID(fi) is the complement of V({fi}i∈I) in Spec(R).
    If f∈R and D(f)=Spec(R), then f is a unit.

Proof. We address each part in the corresponding item below.

    This is a direct consequence of (2) or (3).
    Let 𝔄 be the set of all proper ideals of R. This set is ordered by inclusion and is non-empty, since (0)∈𝔄 is a proper ideal. Let A be a totally ordered subset of 𝔄. Then ⋃I∈AI is in fact an ideal. Since 1 ∉I for all I∈A, the union does not contain 1 and thus is proper. Hence ⋃I∈AI is in 𝔄 and is an upper bound for the set A. Thus by Zorn's lemma 𝔄 has a maximal element, which is the sought-after maximal ideal.
    Since R is nonzero, it contains a maximal ideal which is a prime ideal. Thus the set 𝔄 of all prime ideals of R is nonempty. 𝔄 is ordered by reverse-inclusion. Let A be a totally ordered subset of 𝔄. It's pretty clear that J=⋂I∈AI is in fact an ideal. Not so clear, however, is that it is prime. Let xy∈J. Then xy∈I for all I∈A. Now let B={I∈A|y∈I}. Let K=⋂I∈BI. Since A is totally ordered, either K=J (and we're done, since then y∈J) or K⊃J and for all I∈A such that I is properly contained in K, we have y∉I. But that means that for all those I,x∈I, since they are prime. Hence x∈J. In either case, J is prime as desired. Hence by Zorn's lemma we get a maximal element which in this case is a minimal prime ideal.
    This is the same exact argument as (3) except you only consider prime ideals contained in 𝔭 and containing I.
    (T) is the smallest ideal containing T. Hence if T⊂I, some ideal, then (T)⊂I as well. Hence if I∈V(T), then I∈V((T)) as well. The other inclusion is obvious.
    Since I⊂I√,V(I√)⊂V(I). Now let 𝔭∈V(I). Let x∈I√. Then xn∈I for some n. Hence xn∈𝔭. But since 𝔭 is prime, a boring induction argument gets you that x∈𝔭. Hence I√⊂𝔭 and 𝔭∈V(I√).
    Let f∈R∖I√. Then fn∉I for all n. Hence S={1,f,f2,…} is a multiplicative subset, not containing 0. Take a prime ideal 𝔭¯⊂S−1R containing S−1I. Then the pull-back 𝔭 in R of 𝔭¯ is a prime ideal containing I that does not intersect S. This shows that ⋂I⊂𝔭𝔭⊂I√. Now if a∈I√, then an∈I for some n. Hence if I⊂𝔭, then an∈𝔭. But since 𝔭 is prime, we have a∈𝔭. Thus the equality is shown.
    I is not the unit ideal if and only if I is contained in some maximal ideal (to see this, apply (2) to the ring R/I) which is therefore prime.
    If 𝔭∈V(I)∪V(J), then I⊂𝔭 or J⊂𝔭 which means that I∩J⊂𝔭. Now if I∩J⊂𝔭, then IJ⊂𝔭 and hence either I of J is in 𝔭, since 𝔭 is prime.
    𝔭∈⋂a∈AV(Ia)⇔Ia⊂𝔭,∀a∈A⇔𝔭∈V(∪a∈AIa)
    If 𝔭 is a prime ideal and f∈R, then either f∈𝔭 or f∉𝔭 (strictly) which is what the disjoint union says.
    If a∈R is nilpotent, then an=0 for some n. Hence an∈𝔭 for any prime ideal. Thus a∈𝔭 as can be shown by induction and D(f)=∅. Now, as shown in (7), if a∈R is not nilpotent, then there is a prime ideal that does not contain it.
    f∈𝔭⇔uf∈𝔭, since u is invertible.
    If 𝔭∉V(I), then ∃f∈I∖𝔭. Then f∉𝔭 so 𝔭∈D(f). Also if 𝔮∈D(f), then f∉𝔮 and thus I is not contained in 𝔮. Thus D(f)∩V(I)=∅.
    If fg∈𝔭, then f∈𝔭 or g∈𝔭. Hence if f∉𝔭 and g∉𝔭, then fg∉𝔭. Since 𝔭 is an ideal, if fg∉𝔭, then f∉𝔭 and g∉𝔭.
    𝔭∈⋃i∈ID(fi)⇔∃i∈I,fi∉𝔭⇔𝔭∈Spec(R)∖V({fi}i∈I)
    If D(f)=Spec(R), then V(f)=∅ and hence fR=R, so f is a unit.

\begin{lemma}
\label{lemma-Zariski-topology}
Let $R$ be a ring.
\begin{enumerate}
\item The spectrum of a ring $R$ is empty if and only if $R$
is the zero ring.
\item Every nonzero ring has a maximal ideal.
\item Every nonzero ring has a minimal prime ideal.
\item Given an ideal $I \subset R$ and a prime ideal
$I \subset \mathfrak p$ there exists a prime
$I \subset \mathfrak q \subset \mathfrak p$ such
that $\mathfrak q$ is minimal over $I$.
\item If $T \subset R$, and if $(T)$ is the ideal generated by
$T$ in $R$, then $V((T)) = V(T)$.
\item If $I$ is an ideal and $\sqrt{I}$ is its radical,
see basic notion (\ref{item-radical-ideal}), then $V(I) = V(\sqrt{I})$.
\item Given an ideal $I$ of $R$ we have $\sqrt{I} =
\bigcap_{I \subset \mathfrak p} \mathfrak p$.
\item If $I$ is an ideal then $V(I) = \emptyset$ if and only
if $I$ is the unit ideal.
\item If $I$, $J$ are ideals of $R$ then $V(I) \cup V(J) =
V(I \cap J)$.
\item If $(I_a)_{a\in A}$ is a set of ideals of $R$ then
$\cap_{a\in A} V(I_a) = V(\cup_{a\in A} I_a)$.
\item If $f \in R$, then $D(f) \amalg V(f) = \Spec(R)$.
\item If $f \in R$ then $D(f) = \emptyset$ if and only if $f$
is nilpotent.
\item If $f = u f'$ for some unit $u \in R$, then $D(f) = D(f')$.
\item If $I \subset R$ is an ideal, and $\mathfrak p$ is a prime of
$R$ with $\mathfrak p \not\in V(I)$, then there exists an $f \in R$
such that $\mathfrak p \in D(f)$, and $D(f) \cap V(I) = \emptyset$.
\item If $f, g \in R$, then $D(fg) = D(f) \cap D(g)$.
\item If $f_i \in R$ for $i \in I$, then
$\bigcup_{i\in I} D(f_i)$ is the complement of $V(\{f_i \}_{i\in I})$
in $\Spec(R)$.
\item If $f \in R$ and $D(f) = \Spec(R)$, then $f$ is a unit.
\end{enumerate}
\end{lemma}

\begin{proof}
We address each part in the corresponding item below.
\begin{enumerate}
\item This is a direct consequence of (2) or (3).
\item Let $\mathfrak{A}$ be the set of all proper ideals of $R$. This set is
ordered by inclusion and is non-empty, since $(0) \in \mathfrak{A}$ is a proper
ideal. Let $A$ be a totally ordered subset of $\mathfrak A$.
Then $\bigcup_{I \in A} I$ is in
fact an ideal. Since 1 $\notin I$ for all $I \in A$, the union does not contain
1 and thus is proper. Hence $\bigcup_{I \in A} I$ is in $\mathfrak{A}$ and is
an upper bound for the set $A$. Thus by Zorn's lemma $\mathfrak{A}$ has a
maximal element, which is the sought-after maximal ideal.
\item Since $R$ is nonzero, it contains a maximal ideal which is a prime ideal.
Thus the set $\mathfrak{A}$ of all prime ideals of $R$ is nonempty.
$\mathfrak{A}$ is ordered by reverse-inclusion. Let $A$ be a totally ordered
subset of $\mathfrak{A}$. It's pretty clear that $J = \bigcap_{I \in A} I$ is
in fact an ideal. Not so clear, however, is that it is prime. Let $xy \in J$.
Then $xy \in I$ for all $I \in A$. Now let $B = \{I \in A | y \in I\}$. Let $K
= \bigcap_{I \in B} I$. Since $A$ is totally ordered, either $K = J$ (and we're
done, since then $y \in J$) or $K \supset J$ and for all $I \in A$ such that
$I$ is properly contained in $K$, we have $y \notin I$. But that means that for
all those $I, x \in I$, since they are prime. Hence $x \in J$. In either case,
$J$ is prime as desired. Hence by Zorn's lemma we get a maximal element which
in this case is a minimal prime ideal.
\item This is the same exact argument as (3) except you only consider prime
ideals contained in $\mathfrak{p}$ and containing $I$.
\item $(T)$ is the smallest ideal containing $T$. Hence if $T \subset I$, some
ideal, then $(T) \subset I$ as well. Hence if $I \in V(T)$, then $I \in V((T))$
as well. The other inclusion is obvious.
\item Since $I \subset \sqrt{I}, V(\sqrt{I}) \subset V(I)$. Now let
$\mathfrak{p} \in V(I)$. Let $x \in \sqrt{I}$. Then $x^n \in I$ for some $n$.
Hence $x^n \in \mathfrak{p}$. But since $\mathfrak{p}$ is prime, a boring
induction argument gets you that $x \in \mathfrak{p}$. Hence $\sqrt{I} \subset
\mathfrak{p}$ and $\mathfrak{p} \in V(\sqrt{I})$.
\item Let $f \in R \setminus \sqrt{I}$. Then $f^n \notin I$ for all $n$. Hence
$S = \{1, f, f^2, \ldots\}$ is a multiplicative subset, not containing $0$.
Take a
prime ideal $\bar{\mathfrak{p}} \subset S^{-1}R$ containing $S^{-1}I$. Then the
pull-back $\mathfrak{p}$ in $R$ of $\bar{\mathfrak{p}}$ is a prime ideal
containing $I$ that does not intersect $S$. This shows that $\bigcap_{I \subset
\mathfrak p} \mathfrak p \subset \sqrt{I}$. Now if $a \in \sqrt{I}$, then $a^n
\in I$ for some $n$. Hence if $I \subset \mathfrak{p}$, then $a^n \in
\mathfrak{p}$. But since $\mathfrak{p}$ is prime, we have $a \in \mathfrak{p}$.
Thus the equality is shown.
\item $I$ is not the unit ideal if and only if $I$
is contained in some maximal ideal (to
see this, apply (2) to the ring $R/I$) which is therefore prime.
\item If $\mathfrak{p} \in V(I) \cup V(J)$, then $I \subset \mathfrak{p}$ or $J
\subset \mathfrak{p}$ which means that $I \cap J \subset \mathfrak{p}$. Now if
$I \cap J \subset \mathfrak{p}$, then $IJ \subset \mathfrak{p}$ and hence
either $I$ of $J$ is in $\mathfrak{p}$, since $\mathfrak{p}$ is prime.
\item $\mathfrak{p} \in \bigcap_{a \in A} V(I_a) \Leftrightarrow I_a \subset
\mathfrak{p}, \forall a \in A \Leftrightarrow \mathfrak{p} \in V(\cup_{a\in A}
I_a)$
\item If $\mathfrak{p}$ is a prime ideal and $f \in R$, then either $f \in
\mathfrak{p}$ or $f \notin \mathfrak{p}$ (strictly) which is what the disjoint
union says.
\item If $a \in R$ is nilpotent, then $a^n = 0$ for some $n$. Hence $a^n \in
\mathfrak{p}$ for any prime ideal. Thus $a \in \mathfrak{p}$ as can be shown by
induction and $D(f) = \emptyset$. Now, as shown in (7), if $a \in R$ is not
nilpotent, then there is a prime ideal that does not contain it.
\item $f \in \mathfrak{p} \Leftrightarrow uf \in \mathfrak{p}$, since $u$ is
invertible.
\item If $\mathfrak{p} \notin V(I)$, then $\exists f \in I \setminus
\mathfrak{p}$. Then $f \notin \mathfrak{p}$ so $\mathfrak{p} \in D(f)$. Also if
$\mathfrak{q} \in D(f)$, then $f \notin \mathfrak{q}$ and thus $I$ is not
contained in $\mathfrak{q}$. Thus $D(f) \cap V(I) = \emptyset$.
\item If $fg \in \mathfrak{p}$, then $f \in \mathfrak{p}$ or $g \in
\mathfrak{p}$. Hence if $f \notin \mathfrak{p}$ and $g \notin \mathfrak{p}$,
then $fg \notin \mathfrak{p}$. Since $\mathfrak{p}$ is an ideal, if $fg \notin
\mathfrak{p}$, then $f \notin \mathfrak{p}$ and $g \notin \mathfrak{p}$.
\item $\mathfrak{p} \in \bigcup_{i \in I} D(f_i) \Leftrightarrow \exists i \in
I, f_i \notin \mathfrak{p} \Leftrightarrow \mathfrak{p} \in \Spec(R)
\setminus V(\{f_i\}_{i \in I})$
\item If $D(f) = \Spec(R)$, then $V(f) = \emptyset$ and
hence $fR = R$, so $f$ is a unit.
\end{enumerate}
\end{proof}
-/

import Kenny_comm_alg.maximal_ideal Kenny_comm_alg.minimal_prime_ideal
import Kenny_comm_alg.avoid_powers Kenny_comm_alg.Zariski Kenny_comm_alg.ideal_operations

noncomputable theory
local attribute [instance] classical.prop_decidable

--local infix ^ := monoid.pow

universe u

namespace tag00E0

variables (R : Type u) [comm_ring R]

lemma lemma01 : (X R → false) ↔ subsingleton R :=
⟨λ h, have h1 : (0:R) = 1,
   from classical.by_contradiction
     (λ hzo, h ⟨is_ideal.find_maximal_ideal.of_zero_ne_one hzo,
        (is_ideal.find_maximal_ideal.of_zero_ne_one.is_maximal_ideal hzo).to_is_prime_ideal⟩),
   ⟨λ x y, calc x = x * 0 : by rw [h1, mul_one]
              ... = y * 0 : by simp
              ... = y : by rw [h1, mul_one]⟩,
 λ h x, @@is_proper_ideal.ne_univ _ x.1 x.2.1 $
   set.eq_univ_of_forall $ λ z, calc
           z = z * 1 : eq.symm $ mul_one z
         ... = z * 0 : congr_arg _ (@subsingleton.elim R h 1 0)
         ... = 0 : mul_zero z
         ... ∈ x.val : @is_ideal.zero R _ x.val x.2.1.1⟩

lemma lemma02 : (0:R) ≠ 1 → ∃ S:set R, is_maximal_ideal S :=
λ hzo, ⟨is_ideal.find_maximal_ideal.of_zero_ne_one hzo,
  is_ideal.find_maximal_ideal.of_zero_ne_one.is_maximal_ideal hzo⟩

lemma lemma03 : (0:R) ≠ 1 → ∃ S:set R, is_prime_ideal S ∧ ∀ T, is_prime_ideal T → T ⊆ S → T = S :=
λ hzo, let M := is_ideal.find_maximal_ideal.of_zero_ne_one hzo in
have hm : is_maximal_ideal M := is_ideal.find_maximal_ideal.of_zero_ne_one.is_maximal_ideal hzo,
let S := @is_ideal.find_minimal_prime_ideal' R _ {0} _ M hm.to_is_prime_ideal
  (λ z hz, by simp at hz; rw hz; exact @is_ideal.zero R _ _ hm.1.1) in
have h1 : is_prime_ideal S := @is_ideal.find_minimal_prime_ideal'.is_prime_ideal R _ {0} _ M hm.to_is_prime_ideal
  (λ z hz, by simp at hz; rw hz; exact @is_ideal.zero R _ _ hm.1.1),
have h2 : ∀ T, is_prime_ideal T → {(0:R)} ⊆ T → T ⊆ S → T = S := @is_ideal.find_minimal_prime_ideal'.minimal R _ {0} _ M hm.to_is_prime_ideal
  (λ z hz, by simp at hz; rw hz; exact @is_ideal.zero R _ _ hm.1.1),
⟨S, h1, λ T ht hts, h2 T ht (λ z hz, by simp at hz; rw hz; exact ht.1.1.1.1) hts⟩

lemma lemma04 (I P : set R) [is_ideal I] [is_prime_ideal P] (hip : I ⊆ P) :
  ∃ Q:set R, is_prime_ideal Q ∧ I ⊆ Q ∧ Q ⊆ P ∧ ∀ S, is_prime_ideal S → I ⊆ S → S ⊆ Q → S = Q :=
let Q := is_ideal.find_minimal_prime_ideal I P hip in
have h1 : is_prime_ideal Q := is_ideal.find_minimal_prime_ideal.is_prime_ideal I P hip,
have h2 : I ⊆ Q := is_ideal.find_minimal_prime_ideal.ideal_contains I P hip,
have h3 : Q ⊆ P := is_ideal.find_minimal_prime_ideal.contains_prime I P hip,
have h4 : ∀ S, is_prime_ideal S → I ⊆ S → S ⊆ Q → S = Q,
  from is_ideal.find_minimal_prime_ideal.minimal I P hip,
⟨Q, h1, h2, h3, h4⟩

lemma lemma05 (T : set R) : Spec.V (span T) = Spec.V T :=
set.ext $ λ x,
⟨λ hx z hz, hx $ subset_span hz,
 λ hx z hz, span_minimal x.2.1.1.1 hx hz⟩

lemma lemma06 (I : set R) [is_ideal I] : Spec.V I = Spec.V (is_ideal.radical I) :=
set.ext $ λ x,
⟨λ hx z ⟨n, hz⟩, @@is_prime_ideal.mem_of_pow_mem _ x.2 $ hx hz,
 λ hx z hz, hx $ is_ideal.subset_radical I hz⟩

lemma lemma07 (I : set R) [is_ideal I] : is_ideal.radical I = ⋂₀ {x | is_prime_ideal x ∧ I ⊆ x} :=
set.ext $ λ f,
⟨λ ⟨n, hf⟩ x ⟨hx, hix⟩, @@is_prime_ideal.mem_of_pow_mem _ hx $ hix hf,
 λ hf, classical.by_contradiction $ λ hnf,
   have h1 : ∀ n : ℕ, f^n ∉ I,
     from λ n, nat.rec_on n
       (λ hfz, hnf ⟨0, is_ideal.mul_left hfz⟩)
       (λ n _ hfni, hnf ⟨n, hfni⟩),
   let P := is_ideal.avoid_powers f I h1 in
   have h2 : is_prime_ideal P,
     from is_ideal.avoid_powers.is_prime_ideal f I h1,
   have h3 : I ⊆ P,
     from is_ideal.avoid_powers.contains f I h1,
   have h4 : ∀ n, f^n ∉ P,
     from is_ideal.avoid_powers.avoid_powers f I h1,
   h4 1 $ by simpa using hf P ⟨h2, h3⟩⟩

lemma lemma08 (I : set R) [is_ideal I] : Spec.V I = ∅ ↔ I = set.univ :=
⟨λ h, set.eq_univ_of_forall $ classical.by_contradiction $ λ hn,
   let ⟨f, hf⟩ := not_forall.1 hn in
   have h1 : is_proper_ideal I,
     from ⟨λ hi, by rw set.eq_univ_iff_forall at hi; cc⟩,
   suffices ∃ x, x ∈ Spec.V I,
     by rw [set.eq_empty_iff_forall_not_mem] at h; cases this with x hx; exact h x hx,
   ⟨⟨@is_ideal.find_maximal_ideal R _ I h1,
    (@is_ideal.find_maximal_ideal.is_maximal_ideal R _ I h1).to_is_prime_ideal⟩,
    @is_ideal.find_maximal_ideal.contains R _ I h1⟩,
 λ h, set.eq_empty_of_subset_empty $ λ z hz,
   @is_proper_ideal.ne_univ R _ z.1 z.2.1 $
   set.eq_univ_of_univ_subset $ h ▸ hz⟩

lemma lemma09 (I J : set R) [is_ideal I] [is_ideal J] : Spec.V I ∪ Spec.V J = Spec.V (I ∩ J) :=
have h1 : generate I = I,
  from set.eq_of_subset_of_subset
    (λ z hz, hz I $ set.subset.refl I)
    (subset_generate I),
have h2 : generate J = J,
  from set.eq_of_subset_of_subset
    (λ z hz, hz J $ set.subset.refl J)
    (subset_generate J),
have h3 : Spec.V (generate I ∩ generate J) = Spec.V I ∪ Spec.V J,
  from set.ext (Zariski._match_6 R _ _ I rfl J rfl), --hack level ≥ 9000
by rw [← h3, h1, h2]

-- we don't even need the fact that they are ideals
lemma lemma10 (SS : set (set R)) : ⋂₀ (Spec.V '' SS) = Spec.V ⋃₀ SS :=
set.ext $ λ x,
⟨λ hx f ⟨I, his, hfi⟩, hx _ ⟨I, his, rfl⟩ hfi,
 λ hx S ⟨I, his, hi⟩, hi ▸ λ f hfi, hx ⟨I, his, hfi⟩⟩

lemma lemma11a (f : R) : Spec.D' f ∪ Spec.V' f = set.univ :=
by finish [set.ext_iff]

lemma lemma11b (f : R) : Spec.D' f ∩ Spec.V' f = ∅ :=
by finish [set.ext_iff]

lemma lemma12 (f : R) : Spec.D' f = ∅ ↔ ∃ n : ℕ, f^n = 0 :=
⟨λ h, classical.by_contradiction $ λ hf,
   have h1 : ∀ (n : ℕ), f ^ n ∉ ({0} : set R),
     from λ n hfn, not_exists.1 hf n $ set.mem_singleton_iff.1 hfn,
   let x := is_ideal.avoid_powers f {0} h1 in
   have h2 : is_prime_ideal x,
     from is_ideal.avoid_powers.is_prime_ideal f {0} h1,
   have h3 : ∀ n, f^n ∉ x,
     from is_ideal.avoid_powers.avoid_powers f {0} h1,
   have h4 : f ∉ x,
     by simpa using h3 1,
   set.eq_empty_iff_forall_not_mem.1 h ⟨x, h2⟩ h4,
 λ ⟨n, hfn⟩, set.eq_empty_of_subset_empty $
   λ x hx, hx $ @@is_prime_ideal.mem_of_pow_mem _ x.2
   (set.mem_of_eq_of_mem hfn $
    @@is_ideal.zero _ x.1 x.2.1.1)⟩

-- slightly modified
lemma lemma13 (f g u v : R) (hf : f = g * u) (hg : g = f * v)
  (huv : u * v = 1) : Spec.D' f = Spec.D' g :=
set.ext $ λ x, not_iff_not.2
⟨assume hfx : f ∈ x.val,
   have h1 : g * u ∈ x.val,
     from set.mem_of_eq_of_mem hf.symm hfx,
   or.cases_on
     (@@is_prime_ideal.mem_or_mem_of_mul_mem _ x.2 h1)
     id (λ hu, false.elim $
       @@is_proper_ideal.not_mem_of_mul_right_one _ x.2.1 huv hu),
 assume hgx : g ∈ x.val,
   have h1 : f * v ∈ x.val,
     from set.mem_of_eq_of_mem hg.symm hgx,
   or.cases_on
     (@@is_prime_ideal.mem_or_mem_of_mul_mem _ x.2 h1)
     id (λ hv, false.elim $
       @@is_proper_ideal.not_mem_of_mul_left_one _ x.2.1 huv hv),⟩

-- people need to stop abstracting things by existentials
lemma lemma14 (f : R) (I : set R) [is_ideal I] (hfi : f ∈ I) :
  Spec.D' f ∩ Spec.V I = ∅ :=
set.eq_empty_of_subset_empty $ λ z ⟨hzf, hzi⟩, hzf $ hzi hfi

lemma lemma15 (f g : R) : Spec.D' (f * g) = Spec.D' f ∩ Spec.D' g :=
set.ext $ λ x,
⟨λ hx, ⟨λ hfx, hx $ @@is_ideal.mul_right _ x.2.1.1 hfx,
   λ hgx, hx $ @@is_ideal.mul_left _ x.2.1.1 hgx⟩,
 λ ⟨hfx, hgx⟩ hx, or.cases_on
   (@@is_prime_ideal.mem_or_mem_of_mul_mem _ x.2 hx)
   hfx hgx⟩

lemma lemma16 (F : set R) : ⋃₀ ((Spec.D') '' F) = -Spec.V F :=
set.ext $ λ x,
⟨λ ⟨S, ⟨f, hff, hfs⟩, hx⟩ h,
   have h1 : x ∈ Spec.D' f, by rwa ← hfs at hx,
   h1 $ h hff,
 λ hx, let ⟨f, hf⟩ := not_forall.1 hx in
   let ⟨hff, hfx⟩ := not_imp.1 hf in
   ⟨_, ⟨f, hff, rfl⟩, hfx⟩⟩

lemma lemma17 (f : R) (hf : Spec.D' f = set.univ) : ∃ g, f * g = 1 :=
have h1 : Spec.V' f = ∅,
  from set.eq_empty_of_subset_empty $
    λ x hx, by rw [set.eq_univ_iff_forall] at hf; specialize hf x; exact hf hx,
have h2 : Spec.V {f} = Spec.V' f,
  by simp [Spec.V, Spec.V'],
have h3 : _,
  from @lemma05 R _ {f},
have h4 : _,
  from @lemma08 R _ (span {f}) is_ideal_span,
have h5 : _,
  from (set.eq_univ_iff_forall.1 $ h4.1 $ h3.trans $ h2.trans h1) 1,
begin
  rw span_singleton at h5,
  cases h5 with g hg,
  existsi g,
  rw mul_comm,
  exact hg
end

-- corollary of 14

lemma cor_to_14 (T : set R) (U : set (X R)) (HT : Spec.V T = -U) (P : X R) (HPU : P ∈ U) :
  ∃ h : R, P ∈ Spec.D' h ∧ Spec.D' h ⊆ U :=
have h1 : P ∉ Spec.V T, by rw HT; simp [HPU],
let ⟨h, h2, h3⟩ := set.not_subset.1 h1 in
⟨h, h3, λ f hf, have h3 : f ∉ Spec.V T, from λ h4, hf $ h4 h2, by rw HT at h3; simpa using h3⟩

end tag00E0


import ring_theory.adjoin_root order.zorn data.equiv.algebra algebra.direct_limit
import field_theory.subfield

universes u v w
open polynomial zorn set
variables (K : Type u) [discrete_field K]
noncomputable theory

def big_type := set (ℕ × polynomial K)

instance equiv.is_ring_hom {α β : Type*} [ring β] (e : α ≃ β) :
  @is_ring_hom α β (equiv.ring e) _ e :=
by split; simp [equiv.mul_def, equiv.add_def, equiv.one_def]

instance equiv.is_ring_hom.symm {α β : Type*} [ring β] (e : α ≃ β) :
  @is_ring_hom β α _ (equiv.ring e) e.symm :=
by letI := equiv.ring e; exact (show α ≃r β, from ⟨e, equiv.is_ring_hom e⟩).symm.2

local attribute [instance, priority 0] classical.dec

def big_type_map {L : Type*} [discrete_field L] (i : K → L) [is_ring_hom i]
  (h : ∀ l : L, algebraic K i l) (x : L) : ℕ × polynomial K :=
let f := classical.some (h x) in
⟨list.index_of x (quotient.out ((f.map i).roots.1)), f⟩

lemma list.index_of_inj {α : Type*} [decidable_eq α] {l : list α} {x y : α}
  (hx : x ∈ l) (hy : y ∈ l) (h : list.index_of x l = list.index_of y l) : x = y :=
have list.nth_le l (list.index_of x l) (list.index_of_lt_length.2 hx) =
    list.nth_le l (list.index_of y l) (list.index_of_lt_length.2 hy),
  by simp [h],
by simpa

lemma big_type_map_injective {L : Type*} [discrete_field L] (i : K → L) [is_ring_hom i]
  (h : ∀ l : L, algebraic K i l) : function.injective (big_type_map K i h) :=
λ x y hxy,
let f := classical.some (h x) in
let g := classical.some (h y) in
have hf : f ≠ 0 ∧ f.eval₂ i x = 0, from classical.some_spec (h x),
have hg : g ≠ 0 ∧ g.eval₂ i y = 0, from classical.some_spec (h y),
have hfg : f = g, from (prod.ext_iff.1 hxy).2,
have hfg' : list.index_of x (quotient.out ((f.map i).roots.1)) =
    list.index_of y (quotient.out ((f.map i).roots.1)),
  from (prod.ext_iff.1 hxy).1.trans (hfg.symm ▸ rfl),
have hx : x ∈ quotient.out ((f.map i).roots.1),
  from multiset.mem_coe.1 begin
    show x ∈ quotient.mk _,
    rw [quotient.out_eq, ← finset.mem_def, mem_roots (mt (map_eq_zero i).1 hf.1),
      is_root.def, eval_map, hf.2]
  end,
have hy : y ∈ quotient.out ((f.map i).roots.1),
  from multiset.mem_coe.1 begin
    show y ∈ quotient.mk _,
    rw [quotient.out_eq, ← finset.mem_def, mem_roots (mt (map_eq_zero i).1 hf.1),
      is_root.def, eval_map, hfg, hg.2]
  end,
list.index_of_inj hx hy hfg'

def embedding : K ↪ big_type K :=
⟨λ a, show set _, from {(0, X - C a)}, λ a b, by simp [C_inj]⟩

instance : discrete_field (set.range (embedding K)) :=
equiv.discrete_field (equiv.set.range _ (embedding K).2).symm

structure extensions : Type u :=
(carrier : set (big_type K))
[field : discrete_field ↥carrier]
(range_subset : set.range (embedding K) ⊆ carrier)
[is_ring_hom : is_ring_hom (inclusion (range_subset))]
(algebraic : ∀ x, algebraic _ (inclusion (range_subset)) x)
-- (lift : Π {α : Type u} [integral_domain α] (i : K → α)
--   [by exactI _root_.is_ring_hom i]
--   (h : by exactI ∀ f : polynomial K, 0 < degree f → ∃ x : α, f.eval₂ i x = 0),
--   carrier → α)
-- [lift_is_ring_hom : Π {α : Type u} [integral_domain α] (i : K → α)
--   [by exactI _root_.is_ring_hom i]
--   (h : by exactI ∀ f : polynomial K, 0 < degree f → ∃ x : α, f.eval₂ i x = 0),
--   by exactI is_ring_hom (lift i h)]

local attribute [instance] extensions.field extensions.is_ring_hom

instance : preorder (extensions K) :=
{ le := λ s t, ∃ hst : s.carrier ⊆ t.carrier, is_ring_hom (inclusion hst),
  le_refl := λ _, ⟨by refl, by simp [inclusion]; exact is_ring_hom.id⟩,
  le_trans := λ s t u ⟨hst₁, hst₂⟩ ⟨htu₁, htu₂⟩,
    ⟨set.subset.trans hst₁ htu₁,
      by resetI; convert is_ring_hom.comp (inclusion hst₁) (inclusion htu₁)⟩ }

private structure chain' (c : set (extensions K)) : Prop :=
(chain : chain (≤) c)

local attribute [class] chain'

lemma is_chain (c : set (extensions K)) [chain' _ c]: chain (≤) c :=
chain'.chain (by apply_instance)

section

variables (c : set (extensions K)) [hcn : nonempty c]
include c  hcn

variable [hcn' : chain' _ c]
include hcn'

instance chain_directed_order : directed_preorder c :=
⟨λ ⟨i, hi⟩ ⟨j, hj⟩, let ⟨k, hkc, hk⟩ := chain.directed_on
  (is_chain _ c) i hi j hj in ⟨⟨k, hkc⟩, hk⟩⟩

def chain_map (i j : c) (hij : i ≤ j) : i.1.carrier → j.1.carrier :=
inclusion (exists.elim hij (λ h _, h))

instance chain_ring_hom (i j : c) (hij : i ≤ j) : is_ring_hom (chain_map _ c i j hij) :=
exists.elim hij (λ _, id)

instance chain_directed_system : directed_system (λ i : c, i.1.carrier) (chain_map _ c) :=
by split; intros; simp [chain_map]

def chain_limit : Type u :=
  ring.direct_limit (λ i : c, i.1.carrier) (chain_map _ c)

lemma of_eq_of (x : big_type K) (i j : c) (hi : x ∈ i.1.carrier) (hj : x ∈ j.1.carrier) :
  ring.direct_limit.of (λ i : c, i.1.carrier) (chain_map _ c) i ⟨x, hi⟩ =
  ring.direct_limit.of (λ i : c, i.1.carrier) (chain_map _ c) j ⟨x, hj⟩ :=
have hij : i ≤ j ∨ j ≤ i,
  from show i.1 ≤ j.1 ∨ j.1 ≤ i.1, from chain.total (is_chain _ c) i.2 j.2,
hij.elim
  (λ hij, begin
    rw ← @ring.direct_limit.of_f c _ _ _ (λ i : c, i.1.carrier) _ _ (chain_map _ c) _
      _ _ _ hij,
    simp [chain_map, inclusion]
  end)
  (λ hij, begin
    rw ← @ring.direct_limit.of_f c _ _ _ (λ i : c, i.1.carrier) _ _ (chain_map _ c) _
      _ _ _ hij,
    simp [chain_map, inclusion]
  end)

lemma injective_aux (i j : c)
  (x y : ⋃ i : c, i.1.carrier) (hx : x.1 ∈ i.1.carrier) (hy : y.1 ∈ j.1.carrier) :
  ring.direct_limit.of (λ i : c, i.1.carrier) (chain_map _ c) i ⟨x, hx⟩ =
  ring.direct_limit.of (λ i : c, i.1.carrier) (chain_map _ c) j ⟨y, hy⟩ →
  x = y :=
have hij : i ≤ j ∨ j ≤ i,
  from show i.1 ≤ j.1 ∨ j.1 ≤ i.1, from chain.total (is_chain _ c) i.2 j.2,
have hinj : ∀ (i j : c) (hij : i ≤ j), function.injective (chain_map _ c i j hij),
  from λ _ _ _, inclusion_injective _,
hij.elim
  (λ hij h, begin
    rw ← @ring.direct_limit.of_f c _ _ _ (λ i : c, i.1.carrier) _ _ (chain_map _ c) _
      _ _ _ hij at h,
    simpa [chain_map, inclusion, subtype.coe_ext.symm] using ring.direct_limit.of_inj hinj j h,
  end)
  (λ hji h, begin
    rw ← @ring.direct_limit.of_f c _ _ _ (λ i : c, i.1.carrier) _ _ (chain_map _ c) _
      _ _ _ hji at h,
    simpa [chain_map, inclusion, subtype.coe_ext.symm] using ring.direct_limit.of_inj hinj i h,
  end)

def equiv_direct_limit : (⋃ (i : c), i.1.carrier) ≃
  ring.direct_limit (λ i : c, i.1.carrier) (chain_map _ c) :=
@equiv.of_bijective (⋃ i : c, i.1.carrier)
  (ring.direct_limit (λ i : c, i.1.carrier) (chain_map _ c))
  (λ x, ring.direct_limit.of _ _ (classical.some (set.mem_Union.1 x.2))
    ⟨_, classical.some_spec (set.mem_Union.1 x.2)⟩)
  ⟨λ x y, injective_aux _ _ _ _ _ _ _ _,
    λ x, let ⟨i, ⟨y, hy⟩, hy'⟩ := ring.direct_limit.exists_of x in
      ⟨⟨y, _, ⟨i, rfl⟩, hy⟩, begin
        convert hy',
        exact of_eq_of _ _ _ _ _ _ _
      end⟩⟩

instance Union_ring : discrete_field (⋃ i : c, i.1.carrier) :=
@equiv.discrete_field _ _ (equiv_direct_limit _ c)
  (field.direct_limit.discrete_field _ _)

instance is_ring_hom_Union (i : c) : is_ring_hom
  (inclusion (set.subset_Union (λ i : c, i.1.carrier) i)) :=
suffices inclusion (set.subset_Union (λ i : c, i.1.carrier) i) =
    ((equiv_direct_limit K c).symm ∘
    ring.direct_limit.of (λ i : c, i.1.carrier) (chain_map _ c) i),
  by rw this; exact is_ring_hom.comp _ _,
funext $ λ ⟨_, _⟩,
  (equiv_direct_limit _ c).injective $
    by rw [function.comp_app, equiv.apply_symm_apply];
      exact of_eq_of _ _ _ _ _ _ _

instance is_ring_hom_range_Union [hc : nonempty c]
  (h : set.range (embedding K) ⊆ ⋃ i : c, i.1.carrier) :
  is_ring_hom (inclusion h) :=
let ⟨i⟩ := hc in
have h₁ : i.1.carrier ⊆ ⋃ i : c, i.1.carrier, from set.subset_Union _ i,
have h₂ : set.range (embedding K) ⊆ i.1.carrier, from i.1.range_subset,
have inclusion h = inclusion h₁ ∘ inclusion h₂, by simp [function.comp],
by rw this; exact is_ring_hom.comp _ _

end

lemma exists_algebraic_closure : ∃ m : extensions K, ∀ a, m ≤ a → a ≤ m :=
zorn
  (λ c hc, if h : nonempty c
    then by letI : chain' K c := ⟨hc⟩; exact
      ⟨⟨⋃ (i : c), i.1.carrier,
        let ⟨i⟩ := h in
        have hi : set.range (embedding K) ⊆ i.1.carrier,
          from extensions.range_subset _,
        set.subset.trans hi (set.subset_Union (λ i : c, i.1.carrier) i),
          begin
            rintros ⟨x, hx⟩,
            cases set.mem_Union.1 hx with i hi,
            convert @algebraic_comp (set.range (embedding K)) _ i.1.carrier
              (⋃ i : c, i.1.carrier) _ _
              (inclusion i.1.range_subset)
              (inclusion (set.subset_Union (λ i : c, i.1.carrier) (i : c))) _ _ _
              (i.1.algebraic ⟨x, hi⟩)
          end⟩,
        λ e he, ⟨set.subset_Union (λ i : c, i.1.carrier) ⟨e, he⟩,
          by apply_instance⟩⟩
    else
      have is_ring_hom (inclusion (set.subset.refl (set.range (embedding K)))) :=
      by convert is_ring_hom.id; funext; simp,
      by exactI ⟨⟨set.range (embedding K), by refl, λ _, by convert algebraic_id _ _; funext; simp⟩,
       λ a ha, (h ⟨⟨a, ha⟩⟩).elim⟩)
  (λ _ _ _, le_trans)

def algebraic_closure : Type u := (classical.some (exists_algebraic_closure K)).carrier

namespace algebraic_closure

instance : discrete_field (algebraic_closure K) :=
(classical.some (exists_algebraic_closure K)).field

def of : K → algebraic_closure K :=
inclusion (classical.some (exists_algebraic_closure K)).range_subset ∘
  (equiv.set.range _ (embedding K).2)

instance : is_ring_hom (of K) :=
by have h₁ := (classical.some (exists_algebraic_closure K)).is_ring_hom;
  have h₂ := equiv.is_ring_hom.symm (equiv.set.range _ (embedding K).2).symm;
  unfold of; exact @is_ring_hom.comp _ _ _ _ _ h₂ _ _ _ h₁

lemma of_algebraic (x : algebraic_closure K) : algebraic K (of K) x :=
let ⟨f, hf⟩ := (classical.some (exists_algebraic_closure K)).algebraic x in
⟨f.map (equiv.set.range _ (embedding K).2).symm,
  by rw [eval₂_map, of, function.comp]; simpa only [equiv.apply_symm_apply] using hf⟩

structure subfield_with_hom (L : Type v) (M : Type w) [discrete_field L]
  [discrete_field M] (f : K → L) (g : K → M) : Type (max u v w) :=
(carrier : set L)
[is_subfield : is_subfield carrier]
(map : carrier → M)
[is_ring_hom : by exactI is_ring_hom map]

local attribute [instance] subfield_with_hom.is_subfield subfield_with_hom.is_ring_hom

instance (L M f g) [discrete_field L] [discrete_field M] : preorder (subfield_with_hom K L M f g) :=
{ le := λ s t, ∃ h : s.carrier ⊆ t.carrier, ∀ x, t.map (inclusion h x) = s.map x,
  le_refl := λ _, ⟨set.subset.refl _, λ ⟨_, _⟩, rfl⟩,
  le_trans := λ s t u ⟨hst₁, hst₂⟩ ⟨htu₁, htu₂⟩,
    ⟨set.subset.trans hst₁ htu₁,
      λ _, by rw [← hst₂, ← htu₂, inclusion_inclusion]⟩ }

def thing {L : Type v} {M : Type w} [discrete_field L] [discrete_field M]
  (i : K → L) (j : K → M) [is_ring_hom i] [is_ring_hom j]
  (hL : ∀ x, algebraic K i x) (hM : ∀ f : polynomial K, 0 < degree f → ∃ x, f.eval₂ i x = 0) :
  ∃ s : subfield_with_hom K L M i j, ∀ t, s ≤ t → t ≤ s :=
zorn
  (λ c hc, if hcn : c = ∅
    then ⟨{ carrier := set.range i,
        map := j ∘ (ring_equiv.set.range i (is_field_hom.injective _)).symm.to_equiv,
        is_ring_hom := is_ring_hom.comp _ _ },
      by simp [hcn]⟩
    else let ⟨i, hi⟩ := set.exists_mem_of_ne_empty hcn in
      have nonempty c, from ⟨⟨i, hi⟩⟩,
      ⟨{ carrier := ⋃ i : c, i.1.carrier,
        is_subfield := by exactI is_subfield_Union_of_directed _
          (begin
            rintros ⟨i, hi⟩ ⟨j, hj⟩,
            cases hc.directed hi hj with z hz,
            exact ⟨⟨z, hz.1⟩, hz.2.1.fst, hz.2.2.fst⟩
          end),
        map := λ x, (classical.some (set.mem_Union.1 x.2)).1.map
          ⟨x, classical.some_spec (set.mem_Union.1 x.2)⟩,
        is_ring_hom :=
          { map_one := _,
            map_mul := begin
              assume x y,

            end,
            map_add := _ } }, _⟩)
  (λ _ _ _, le_trans)

end algebraic_closure


/-
Copyright (c) 2018 Patrick Massot. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Patrick Massot, Johannes Hölzl
-/
import topology.uniform_space.abstract_completion

/-!
# Hausdorff completions of uniform spaces

The goal is to construct a left-adjoint to the inclusion of complete Hausdorff uniform spaces
into all uniform spaces. Any uniform space `α` gets a completion `completion α` and a morphism
(ie. uniformly continuous map) `coe : α → completion α` which solves the universal
mapping problem of factorizing morphisms from `α` to any complete Hausdorff uniform space `β`.
It means any uniformly continuous `f : α → β` gives rise to a unique morphism
`completion.extension f : completion α → β` such that `f = completion.extension f ∘ coe`.
Actually `completion.extension f` is defined for all maps from `α` to `β` but it has the desired
properties only if `f` is uniformly continuous.

Beware that `coe` is not injective if `α` is not Hausdorff. But its image is always
dense. The adjoint functor acting on morphisms is then constructed by the usual abstract nonsense.
For every uniform spaces `α` and `β`, it turns `f : α → β` into a morphism
  `completion.map f : completion α → completion β`
such that
  `coe ∘ f = (completion.map f) ∘ coe`
provided `f` is uniformly continuous. This construction is compatible with composition.

In this file we introduce the following concepts:

* `Cauchy α` the uniform completion of the uniform space `α` (using Cauchy filters). These are not
  minimal filters.

* `completion α := quotient (separation_setoid (Cauchy α))` the Hausdorff completion.

## References

This formalization is mostly based on
  N. Bourbaki: General Topology
  I. M. James: Topologies and Uniformities
From a slightly different perspective in order to reuse material in topology.uniform_space.basic.
-/

noncomputable theory
open filter set
universes u v w x

open_locale uniformity classical topological_space filter

/-- Space of Cauchy filters

This is essentially the completion of a uniform space. The embeddings are the neighbourhood filters.
This space is not minimal, the separated uniform space (i.e. quotiented on the intersection of all
entourages) is necessary for this.
-/
def Cauchy (α : Type u) [uniform_space α] : Type u := { f : filter α // cauchy f }

namespace Cauchy

section
parameters {α : Type u} [uniform_space α]
variables {β : Type v} {γ : Type w}
variables [uniform_space β] [uniform_space γ]

def gen (s : set (α × α)) : set (Cauchy α × Cauchy α) :=
{p | s ∈ p.1.val ×ᶠ p.2.val }

lemma monotone_gen : monotone gen :=
monotone_set_of $ assume p, @monotone_mem_sets (α×α) (p.1.val ×ᶠ p.2.val)

private lemma symm_gen : map prod.swap ((𝓤 α).lift' gen) ≤ (𝓤 α).lift' gen :=
calc map prod.swap ((𝓤 α).lift' gen) =
  (𝓤 α).lift' (λs:set (α×α), {p | s ∈ p.2.val ×ᶠ p.1.val }) :
  begin
    delta gen,
    simp [map_lift'_eq, monotone_set_of, monotone_mem_sets,
          function.comp, image_swap_eq_preimage_swap, -subtype.val_eq_coe]
  end
  ... ≤ (𝓤 α).lift' gen :
    uniformity_lift_le_swap
      (monotone_principal.comp (monotone_set_of $ assume p,
        @monotone_mem_sets (α×α) (p.2.val ×ᶠ  p.1.val)))
      begin
        have h := λ(p:Cauchy α×Cauchy α), @filter.prod_comm _ _ (p.2.val) (p.1.val),
        simp [function.comp, h, -subtype.val_eq_coe],
        exact le_refl _
      end

private lemma comp_rel_gen_gen_subset_gen_comp_rel {s t : set (α×α)} : comp_rel (gen s) (gen t) ⊆
  (gen (comp_rel s t) : set (Cauchy α × Cauchy α)) :=
assume ⟨f, g⟩ ⟨h, h₁, h₂⟩,
let ⟨t₁, (ht₁ : t₁ ∈ f.val), t₂, (ht₂ : t₂ ∈ h.val), (h₁ : set.prod t₁ t₂ ⊆ s)⟩ :=
  mem_prod_iff.mp h₁ in
let ⟨t₃, (ht₃ : t₃ ∈ h.val), t₄, (ht₄ : t₄ ∈ g.val), (h₂ : set.prod t₃ t₄ ⊆ t)⟩ :=
  mem_prod_iff.mp h₂ in
have t₂ ∩ t₃ ∈ h.val,
  from inter_mem_sets ht₂ ht₃,
let ⟨x, xt₂, xt₃⟩ :=
  h.property.left.nonempty_of_mem this in
(f.val ×ᶠ g.val).sets_of_superset
  (prod_mem_prod ht₁ ht₄)
  (assume ⟨a, b⟩ ⟨(ha : a ∈ t₁), (hb : b ∈ t₄)⟩,
    ⟨x,
      h₁ (show (a, x) ∈ set.prod t₁ t₂, from ⟨ha, xt₂⟩),
      h₂ (show (x, b) ∈ set.prod t₃ t₄, from ⟨xt₃, hb⟩)⟩)

private lemma comp_gen :
  ((𝓤 α).lift' gen).lift' (λs, comp_rel s s) ≤ (𝓤 α).lift' gen :=
calc ((𝓤 α).lift' gen).lift' (λs, comp_rel s s) =
    (𝓤 α).lift' (λs, comp_rel (gen s) (gen s)) :
  begin
    rw [lift'_lift'_assoc],
    exact monotone_gen,
    exact (monotone_comp_rel monotone_id monotone_id)
  end
  ... ≤ (𝓤 α).lift' (λs, gen $ comp_rel s s) :
    lift'_mono' $ assume s hs, comp_rel_gen_gen_subset_gen_comp_rel
  ... = ((𝓤 α).lift' $ λs:set(α×α), comp_rel s s).lift' gen :
  begin
    rw [lift'_lift'_assoc],
    exact (monotone_comp_rel monotone_id monotone_id),
    exact monotone_gen
  end
  ... ≤ (𝓤 α).lift' gen : lift'_mono comp_le_uniformity (le_refl _)

instance : uniform_space (Cauchy α) :=
uniform_space.of_core
{ uniformity  := (𝓤 α).lift' gen,
  refl        := principal_le_lift' $ assume s hs ⟨a, b⟩ (a_eq_b : a = b),
    a_eq_b ▸ a.property.right hs,
  symm        := symm_gen,
  comp        := comp_gen }

theorem mem_uniformity {s : set (Cauchy α × Cauchy α)} :
  s ∈ 𝓤 (Cauchy α) ↔ ∃ t ∈ 𝓤 α, gen t ⊆ s :=
mem_lift'_sets monotone_gen

theorem mem_uniformity' {s : set (Cauchy α × Cauchy α)} :
  s ∈ 𝓤 (Cauchy α) ↔ ∃ t ∈ 𝓤 α, ∀ f g : Cauchy α, t ∈ f.1 ×ᶠ g.1 → (f, g) ∈ s :=
mem_uniformity.trans $ bex_congr $ λ t h, prod.forall

/-- Embedding of `α` into its completion `Cauchy α` -/
def pure_cauchy (a : α) : Cauchy α :=
⟨pure a, cauchy_pure⟩

lemma uniform_inducing_pure_cauchy : uniform_inducing (pure_cauchy : α → Cauchy α) :=
⟨have (preimage (λ (x : α × α), (pure_cauchy (x.fst), pure_cauchy (x.snd))) ∘ gen) = id,
      from funext $ assume s, set.ext $ assume ⟨a₁, a₂⟩,
        by simp [preimage, gen, pure_cauchy, prod_principal_principal],
    calc comap (λ (x : α × α), (pure_cauchy (x.fst), pure_cauchy (x.snd))) ((𝓤 α).lift' gen)
          = (𝓤 α).lift'
              (preimage (λ (x : α × α), (pure_cauchy (x.fst), pure_cauchy (x.snd))) ∘ gen) :
        comap_lift'_eq monotone_gen
      ... = 𝓤 α : by simp [this]⟩

lemma uniform_embedding_pure_cauchy : uniform_embedding (pure_cauchy : α → Cauchy α) :=
{ inj := assume a₁ a₂ h, pure_injective $ subtype.ext_iff_val.1 h,
  ..uniform_inducing_pure_cauchy }

lemma dense_range_pure_cauchy : dense_range pure_cauchy :=
assume f,
have h_ex : ∀ s ∈ 𝓤 (Cauchy α), ∃y:α, (f, pure_cauchy y) ∈ s, from
  assume s hs,
  let ⟨t'', ht''₁, (ht''₂ : gen t'' ⊆ s)⟩ := (mem_lift'_sets monotone_gen).mp hs in
  let ⟨t', ht'₁, ht'₂⟩ := comp_mem_uniformity_sets ht''₁ in
  have t' ∈ f.val ×ᶠ f.val,
    from f.property.right ht'₁,
  let ⟨t, ht, (h : set.prod t t ⊆ t')⟩ := mem_prod_same_iff.mp this in
  let ⟨x, (hx : x ∈ t)⟩ := f.property.left.nonempty_of_mem ht in
  have t'' ∈ f.val ×ᶠ pure x,
    from mem_prod_iff.mpr ⟨t, ht, {y:α | (x, y) ∈ t'},
      h $ mk_mem_prod hx hx,
      assume ⟨a, b⟩ ⟨(h₁ : a ∈ t), (h₂ : (x, b) ∈ t')⟩,
        ht'₂ $ prod_mk_mem_comp_rel (@h (a, x) ⟨h₁, hx⟩) h₂⟩,
  ⟨x, ht''₂ $ by dsimp [gen]; exact this⟩,
begin
  simp only [closure_eq_cluster_pts, cluster_pt, nhds_eq_uniformity, lift'_inf_principal_eq,
    set.inter_comm _ (range pure_cauchy), mem_set_of_eq],
  exact (lift'_ne_bot_iff $ monotone_inter monotone_const monotone_preimage).mpr
    (assume s hs,
      let ⟨y, hy⟩ := h_ex s hs in
      have pure_cauchy y ∈ range pure_cauchy ∩ {y : Cauchy α | (f, y) ∈ s},
        from ⟨mem_range_self y, hy⟩,
      ⟨_, this⟩)
end

lemma dense_inducing_pure_cauchy : dense_inducing pure_cauchy :=
uniform_inducing_pure_cauchy.dense_inducing dense_range_pure_cauchy

lemma dense_embedding_pure_cauchy : dense_embedding pure_cauchy :=
uniform_embedding_pure_cauchy.dense_embedding dense_range_pure_cauchy

lemma nonempty_Cauchy_iff : nonempty (Cauchy α) ↔ nonempty α :=
begin
  split ; rintro ⟨c⟩,
  { have := eq_univ_iff_forall.1 dense_embedding_pure_cauchy.to_dense_inducing.closure_range c,
    obtain ⟨_, ⟨_, a, _⟩⟩ := mem_closure_iff.1 this _ is_open_univ trivial,
    exact ⟨a⟩ },
  { exact ⟨pure_cauchy c⟩ }
end

section
set_option eqn_compiler.zeta true
instance : complete_space (Cauchy α) :=
complete_space_extension
  uniform_inducing_pure_cauchy
  dense_range_pure_cauchy $
  assume f hf,
  let f' : Cauchy α := ⟨f, hf⟩ in
  have map pure_cauchy f ≤ (𝓤 $ Cauchy α).lift' (preimage (prod.mk f')),
    from le_lift' $ assume s hs,
    let ⟨t, ht₁, (ht₂ : gen t ⊆ s)⟩ := (mem_lift'_sets monotone_gen).mp hs in
    let ⟨t', ht', (h : set.prod t' t' ⊆ t)⟩ := mem_prod_same_iff.mp (hf.right ht₁) in
    have t' ⊆ { y : α | (f', pure_cauchy y) ∈ gen t },
      from assume x hx, (f ×ᶠ pure x).sets_of_superset (prod_mem_prod ht' hx) h,
    f.sets_of_superset ht' $ subset.trans this (preimage_mono ht₂),
  ⟨f', by simp [nhds_eq_uniformity]; assumption⟩
end

instance [inhabited α] : inhabited (Cauchy α) :=
⟨pure_cauchy $ default α⟩

instance [h : nonempty α] : nonempty (Cauchy α) :=
h.rec_on $ assume a, nonempty.intro $ Cauchy.pure_cauchy a

section extend

def extend (f : α → β) : (Cauchy α → β) :=
if uniform_continuous f then
  dense_inducing_pure_cauchy.extend f
else
  λ x, f (classical.inhabited_of_nonempty $ nonempty_Cauchy_iff.1 ⟨x⟩).default

variables [separated_space β]

lemma extend_pure_cauchy {f : α → β} (hf : uniform_continuous f) (a : α) :
  extend f (pure_cauchy a) = f a :=
begin
  rw [extend, if_pos hf],
  exact uniformly_extend_of_ind uniform_inducing_pure_cauchy dense_range_pure_cauchy hf _
end

variables [_root_.complete_space β]

lemma uniform_continuous_extend {f : α → β} : uniform_continuous (extend f) :=
begin
  by_cases hf : uniform_continuous f,
  { rw [extend, if_pos hf],
    exact uniform_continuous_uniformly_extend uniform_inducing_pure_cauchy
      dense_range_pure_cauchy hf },
  { rw [extend, if_neg hf],
    exact uniform_continuous_of_const (assume a b, by congr) }
end

end extend

end

theorem Cauchy_eq {α : Type*} [inhabited α] [uniform_space α] [complete_space α]
  [separated_space α] {f g : Cauchy α} :
  Lim f.1 = Lim g.1 ↔ (f, g) ∈ separation_rel (Cauchy α) :=
begin
  split,
  { intros e s hs,
    rcases Cauchy.mem_uniformity'.1 hs with ⟨t, tu, ts⟩,
    apply ts,
    rcases comp_mem_uniformity_sets tu with ⟨d, du, dt⟩,
    refine mem_prod_iff.2
      ⟨_, f.2.le_nhds_Lim (mem_nhds_right (Lim f.1) du),
       _, g.2.le_nhds_Lim (mem_nhds_left (Lim g.1) du), λ x h, _⟩,
    cases x with a b, cases h with h₁ h₂,
    rw ← e at h₂,
    exact dt ⟨_, h₁, h₂⟩ },
  { intros H,
    refine separated_def.1 (by apply_instance) _ _ (λ t tu, _),
    rcases mem_uniformity_is_closed tu with ⟨d, du, dc, dt⟩,
    refine H {p | (Lim p.1.1, Lim p.2.1) ∈ t}
      (Cauchy.mem_uniformity'.2 ⟨d, du, λ f g h, _⟩),
    rcases mem_prod_iff.1 h with ⟨x, xf, y, yg, h⟩,
    have limc : ∀ (f : Cauchy α) (x ∈ f.1), Lim f.1 ∈ closure x,
    { intros f x xf,
      rw closure_eq_cluster_pts,
      exact f.2.1.mono
        (le_inf f.2.le_nhds_Lim (le_principal_iff.2 xf)) },
    have := dc.closure_subset_iff.2 h,
    rw closure_prod_eq at this,
    refine dt (this ⟨_, _⟩); dsimp; apply limc; assumption }
end

section
local attribute [instance] uniform_space.separation_setoid

lemma separated_pure_cauchy_injective {α : Type*} [uniform_space α] [s : separated_space α] :
  function.injective (λa:α, ⟦pure_cauchy a⟧) | a b h :=
separated_def.1 s _ _ $ assume s hs,
let ⟨t, ht, hts⟩ :=
  by rw [← (@uniform_embedding_pure_cauchy α _).comap_uniformity, filter.mem_comap_sets] at hs;
    exact hs in
have (pure_cauchy a, pure_cauchy b) ∈ t, from quotient.exact h t ht,
@hts (a, b) this

end

end Cauchy

local attribute [instance] uniform_space.separation_setoid

open Cauchy set

namespace uniform_space
variables (α : Type*) [uniform_space α]
variables {β : Type*} [uniform_space β]
variables {γ : Type*} [uniform_space γ]

instance complete_space_separation [h : complete_space α] :
  complete_space (quotient (separation_setoid α)) :=
⟨assume f, assume hf : cauchy f,
  have cauchy (f.comap (λx, ⟦x⟧)), from
    hf.comap' comap_quotient_le_uniformity $ hf.left.comap_of_surj (surjective_quotient_mk _),
  let ⟨x, (hx : f.comap (λx, ⟦x⟧) ≤ 𝓝 x)⟩ := complete_space.complete this in
  ⟨⟦x⟧, (comap_le_comap_iff $ by simp).1
    (hx.trans $ map_le_iff_le_comap.1 continuous_quotient_mk.continuous_at)⟩⟩

/-- Hausdorff completion of `α` -/
def completion := quotient (separation_setoid $ Cauchy α)

namespace completion

instance [inhabited α] : inhabited (completion α) :=
by unfold completion; apply_instance

@[priority 50]
instance : uniform_space (completion α) := by dunfold completion ; apply_instance

instance : complete_space (completion α) := by dunfold completion ; apply_instance

instance : separated_space (completion α) := by dunfold completion ; apply_instance

instance : regular_space (completion α) := separated_regular

/-- Automatic coercion from `α` to its completion. Not always injective. -/
instance : has_coe_t α (completion α) := ⟨quotient.mk ∘ pure_cauchy⟩ -- note [use has_coe_t]

protected lemma coe_eq : (coe : α → completion α) = quotient.mk ∘ pure_cauchy := rfl

lemma comap_coe_eq_uniformity :
  (𝓤 _).comap (λ(p:α×α), ((p.1 : completion α), (p.2 : completion α))) = 𝓤 α :=
begin
  have : (λx:α×α, ((x.1 : completion α), (x.2 : completion α))) =
    (λx:(Cauchy α)×(Cauchy α), (⟦x.1⟧, ⟦x.2⟧)) ∘ (λx:α×α, (pure_cauchy x.1, pure_cauchy x.2)),
  { ext ⟨a, b⟩; simp; refl },
  rw [this, ← filter.comap_comap],
  change filter.comap _ (filter.comap _ (𝓤 $ quotient $ separation_setoid $ Cauchy α)) = 𝓤 α,
  rw [comap_quotient_eq_uniformity, uniform_embedding_pure_cauchy.comap_uniformity]
end

lemma uniform_inducing_coe : uniform_inducing  (coe : α → completion α) :=
⟨comap_coe_eq_uniformity α⟩

variables {α}

lemma dense_range_coe : dense_range (coe : α → completion α) :=
dense_range_pure_cauchy.quotient

variables (α)

def cpkg {α : Type*} [uniform_space α] : abstract_completion α :=
{ space := completion α,
  coe := coe,
  uniform_struct := by apply_instance,
  complete := by apply_instance,
  separation := by apply_instance,
  uniform_inducing := completion.uniform_inducing_coe α,
  dense := completion.dense_range_coe }

instance abstract_completion.inhabited : inhabited (abstract_completion α) :=
⟨cpkg⟩

local attribute [instance]
abstract_completion.uniform_struct abstract_completion.complete abstract_completion.separation

lemma nonempty_completion_iff : nonempty (completion α) ↔ nonempty α :=
cpkg.dense.nonempty_iff.symm

lemma uniform_continuous_coe : uniform_continuous (coe : α → completion α) :=
cpkg.uniform_continuous_coe

lemma continuous_coe : continuous (coe : α → completion α) :=
cpkg.continuous_coe

variable {α}

lemma dense_inducing_coe : dense_inducing (coe : α → completion α) :=
{ dense := dense_range_coe,
  ..(uniform_inducing_coe α).inducing }

open topological_space

instance separable_space_completion [separable_space α] : separable_space (completion α) :=
completion.dense_inducing_coe.separable_space

lemma dense_embedding_coe [separated_space α]: dense_embedding (coe : α → completion α) :=
{ inj := separated_pure_cauchy_injective,
  ..dense_inducing_coe }

lemma dense_range_coe₂ :
  dense_range (λx:α × β, ((x.1 : completion α), (x.2 : completion β))) :=
dense_range_coe.prod_map dense_range_coe

lemma dense_range_coe₃ :
  dense_range (λx:α × (β × γ),
    ((x.1 : completion α), ((x.2.1 : completion β), (x.2.2 : completion γ)))) :=
dense_range_coe.prod_map dense_range_coe₂

@[elab_as_eliminator]
lemma induction_on {p : completion α → Prop}
  (a : completion α) (hp : is_closed {a | p a}) (ih : ∀a:α, p a) : p a :=
is_closed_property dense_range_coe hp ih a

@[elab_as_eliminator]
lemma induction_on₂ {p : completion α → completion β → Prop}
  (a : completion α) (b : completion β)
  (hp : is_closed {x : completion α × completion β | p x.1 x.2})
  (ih : ∀(a:α) (b:β), p a b) : p a b :=
have ∀x : completion α × completion β, p x.1 x.2, from
  is_closed_property dense_range_coe₂ hp $ assume ⟨a, b⟩, ih a b,
this (a, b)

@[elab_as_eliminator]
lemma induction_on₃ {p : completion α → completion β → completion γ → Prop}
  (a : completion α) (b : completion β) (c : completion γ)
  (hp : is_closed {x : completion α × completion β × completion γ | p x.1 x.2.1 x.2.2})
  (ih : ∀(a:α) (b:β) (c:γ), p a b c) : p a b c :=
have ∀x : completion α × completion β × completion γ, p x.1 x.2.1 x.2.2, from
  is_closed_property dense_range_coe₃ hp $ assume ⟨a, b, c⟩, ih a b c,
this (a, b, c)

lemma ext [t2_space β] {f g : completion α → β} (hf : continuous f) (hg : continuous g)
  (h : ∀a:α, f a = g a) : f = g :=
cpkg.funext hf hg h

section extension
variables {f : α → β}

/-- "Extension" to the completion. It is defined for any map `f` but
returns an arbitrary constant value if `f` is not uniformly continuous -/
protected def extension (f : α → β) : completion α → β :=
cpkg.extend f

variables [separated_space β]

@[simp]lemma extension_coe (hf : uniform_continuous f) (a : α) :
  (completion.extension f) a = f a :=
cpkg.extend_coe hf a

variables [complete_space β]

lemma uniform_continuous_extension : uniform_continuous (completion.extension f) :=
cpkg.uniform_continuous_extend

lemma continuous_extension : continuous (completion.extension f) :=
cpkg.continuous_extend

lemma extension_unique (hf : uniform_continuous f) {g : completion α → β}
  (hg : uniform_continuous g) (h : ∀ a : α, f a = g (a : completion α)) :
  completion.extension f = g :=
cpkg.extend_unique hf hg h

@[simp] lemma extension_comp_coe {f : completion α → β} (hf : uniform_continuous f) :
  completion.extension (f ∘ coe) = f :=
cpkg.extend_comp_coe hf
end extension

section map
variables {f : α → β}

/-- Completion functor acting on morphisms -/
protected def map (f : α → β) : completion α → completion β :=
cpkg.map cpkg f

lemma uniform_continuous_map : uniform_continuous (completion.map f) :=
cpkg.uniform_continuous_map cpkg f

lemma continuous_map : continuous (completion.map f) :=
cpkg.continuous_map cpkg f

@[simp] lemma map_coe (hf : uniform_continuous f) (a : α) : (completion.map f) a = f a :=
cpkg.map_coe cpkg hf a

lemma map_unique {f : α → β} {g : completion α → completion β}
  (hg : uniform_continuous g) (h : ∀a:α, ↑(f a) = g a) : completion.map f = g :=
cpkg.map_unique cpkg hg h

@[simp] lemma map_id : completion.map (@id α) = id :=
cpkg.map_id

lemma extension_map [complete_space γ] [separated_space γ] {f : β → γ} {g : α → β}
  (hf : uniform_continuous f) (hg : uniform_continuous g) :
  completion.extension f ∘ completion.map g = completion.extension (f ∘ g) :=
completion.ext (continuous_extension.comp continuous_map) continuous_extension $
  by intro a; simp only [hg, hf, hf.comp hg, (∘), map_coe, extension_coe]

lemma map_comp {g : β → γ} {f : α → β} (hg : uniform_continuous g) (hf : uniform_continuous f) :
  completion.map g ∘ completion.map f = completion.map (g ∘ f) :=
extension_map ((uniform_continuous_coe _).comp hg) hf

end map

/- In this section we construct isomorphisms between the completion of a uniform space and the
completion of its separation quotient -/
section separation_quotient_completion

def completion_separation_quotient_equiv (α : Type u) [uniform_space α] :
  completion (separation_quotient α) ≃ completion α :=
begin
  refine ⟨completion.extension (separation_quotient.lift (coe : α → completion α)),
    completion.map quotient.mk, _, _⟩,
  { assume a,
    refine induction_on a (is_closed_eq (continuous_map.comp continuous_extension) continuous_id) _,
    rintros ⟨a⟩,
    show completion.map quotient.mk
      (completion.extension (separation_quotient.lift coe) ↑⟦a⟧) = ↑⟦a⟧,
    rw [extension_coe (separation_quotient.uniform_continuous_lift _),
      separation_quotient.lift_mk (uniform_continuous_coe α),
      completion.map_coe uniform_continuous_quotient_mk] ; apply_instance },
  { assume a,
    refine completion.induction_on a
      (is_closed_eq (continuous_extension.comp continuous_map) continuous_id) (λ a, _),
    rw [map_coe uniform_continuous_quotient_mk,
      extension_coe (separation_quotient.uniform_continuous_lift _),
      separation_quotient.lift_mk (uniform_continuous_coe α) _] ; apply_instance }
end

lemma uniform_continuous_completion_separation_quotient_equiv :
  uniform_continuous ⇑(completion_separation_quotient_equiv α) :=
uniform_continuous_extension

lemma uniform_continuous_completion_separation_quotient_equiv_symm :
  uniform_continuous ⇑(completion_separation_quotient_equiv α).symm :=
uniform_continuous_map

end separation_quotient_completion

section extension₂
variables (f : α → β → γ)
open function

protected def extension₂ (f : α → β → γ) : completion α → completion β → γ :=
cpkg.extend₂ cpkg f

variables [separated_space γ] {f}

@[simp] lemma extension₂_coe_coe (hf : uniform_continuous₂ f) (a : α) (b : β) :
  completion.extension₂ f a b = f a b :=
cpkg.extension₂_coe_coe cpkg hf a b

variables [complete_space γ] (f)

lemma uniform_continuous_extension₂ : uniform_continuous₂ (completion.extension₂ f) :=
cpkg.uniform_continuous_extension₂ cpkg f

end extension₂

section map₂
open function

protected def map₂ (f : α → β → γ) : completion α → completion β → completion γ :=
cpkg.map₂ cpkg cpkg f

lemma uniform_continuous_map₂ (f : α → β → γ) : uniform_continuous₂ (completion.map₂ f) :=
cpkg.uniform_continuous_map₂ cpkg cpkg f

lemma continuous_map₂ {δ} [topological_space δ] {f : α → β → γ}
  {a : δ → completion α} {b : δ → completion β} (ha : continuous a) (hb : continuous b) :
  continuous (λd:δ, completion.map₂ f (a d) (b d)) :=
cpkg.continuous_map₂ cpkg cpkg ha hb

lemma map₂_coe_coe (a : α) (b : β) (f : α → β → γ) (hf : uniform_continuous₂ f) :
  completion.map₂ f (a : completion α) (b : completion β) = f a b :=
cpkg.map₂_coe_coe cpkg cpkg a b f hf

end map₂
end completion
end uniform_space


/-
Copyright (c) 2020 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta
-/
import category_theory.natural_isomorphism
import category_theory.eq_to_hom
import data.sigma.basic
import category_theory.pi.basic

/-!
# Disjoint union of categories

We define the category structure on a sigma-type (disjoint union) of categories.
-/

namespace category_theory
namespace sigma

universes w₁ w₂ w₃ v₁ v₂ u₁ u₂

variables {I : Type w₁} {C : I → Type u₁} [Π i, category.{v₁} (C i)]

/--
The type of morphisms of a disjoint union of categories: for `X : C i` and `Y : C j`, a morphism
`(i, X) ⟶ (j, Y)` if `i = j` is just a morphism `X ⟶ Y`, and if `i ≠ j` there are no such morphisms.
-/
inductive sigma_hom : (Σ i, C i) → (Σ i, C i) → Type (max w₁ v₁ u₁)
| mk : Π {i : I} {X Y : C i}, (X ⟶ Y) → sigma_hom ⟨i, X⟩ ⟨i, Y⟩

namespace sigma_hom

/-- The identity morphism on an object. -/
def id : Π (X : Σ i, C i), sigma_hom X X
| ⟨i, X⟩ := mk (𝟙 _)

instance (X : Σ i, C i) : inhabited (sigma_hom X X) := ⟨id X⟩

/-- Composition of sigma homomorphisms. -/
def comp : Π {X Y Z : Σ i, C i}, sigma_hom X Y → sigma_hom Y Z → sigma_hom X Z
| _ _ _ (mk f) (mk g) := mk (f ≫ g)

instance : category_struct (Σ i, C i) :=
{ hom := sigma_hom,
  id := id,
  comp := λ X Y Z f g, comp f g }

@[simp]
lemma comp_def (i : I) (X Y Z : C i) (f : X ⟶ Y) (g : Y ⟶ Z) :
  comp (mk f) (mk g) = mk (f ≫ g) :=
rfl

lemma assoc : ∀ (X Y Z W : Σ i, C i) (f : X ⟶ Y) (g : Y ⟶ Z) (h : Z ⟶ W), (f ≫ g) ≫ h = f ≫ g ≫ h
| _ _ _ _ (mk f) (mk g) (mk h) := congr_arg mk (category.assoc _ _ _)

lemma id_comp : ∀ (X Y : Σ i, C i) (f : X ⟶ Y), 𝟙 X ≫ f = f
| _ _ (mk f) := congr_arg mk (category.id_comp _)

lemma comp_id : ∀ (X Y : Σ i, C i) (f : X ⟶ Y), f ≫ 𝟙 Y = f
| _ _ (mk f) := congr_arg mk (category.comp_id _)

end sigma_hom

instance sigma : category (Σ i, C i) :=
{ id_comp' := sigma_hom.id_comp,
  comp_id' := sigma_hom.comp_id,
  assoc' := sigma_hom.assoc }

/-- The inclusion functor into the disjoint union of categories. -/
@[simps map]
def incl (i : I) : C i ⥤ Σ i, C i :=
{ obj := λ X, ⟨i, X⟩,
  map := λ X Y, sigma_hom.mk }

@[simp] lemma incl_obj {i : I} (X : C i) : (incl i).obj X = ⟨i, X⟩ := rfl

instance (i : I) : full (incl i : C i ⥤ Σ i, C i) :=
{ preimage := λ X Y ⟨f⟩, f,
  witness' := λ X Y ⟨f⟩, rfl }.

instance (i : I) : faithful (incl i : C i ⥤ Σ i, C i) := {}.

section
variables {D : Type u₂} [category.{v₂} D] (F : Π i, C i ⥤ D)

/--
To build a natural transformation over the sigma category, it suffices to specify it restricted to
each subcategory.
-/
def nat_trans {F G : (Σ i, C i) ⥤ D} (h : Π (i : I), incl i ⋙ F ⟶ incl i ⋙ G) : F ⟶ G :=
{ app := λ ⟨j, X⟩, (h j).app X,
  naturality' := by { rintro ⟨j, X⟩ ⟨_, _⟩ ⟨_, _, Y, f⟩, apply (h j).naturality } }

@[simp]

/-- (Implementation). An auxiliary definition to build the functor `desc`. -/
def desc_map : ∀ (X Y : Σ i, C i), (X ⟶ Y) → ((F X.1).obj X.2 ⟶ (F Y.1).obj Y.2)
| _ _ (sigma_hom.mk g) := (F _).map g

/--
Given a collection of functors `F i : C i ⥤ D`, we can produce a functor `(Σ i, C i) ⥤ D`.

The produced functor `desc F` satisfies: `incl i ⋙ desc F ≅ F i`, i.e. restricted to just the
subcategory `C i`, `desc F` agrees with `F i`, and it is unique (up to natural isomorphism) with
this property.

This witnesses that the sigma-type is the coproduct in Cat.
-/
@[simps obj]
def desc : (Σ i, C i) ⥤ D :=
{ obj := λ X, (F X.1).obj X.2,
  map := λ X Y g, desc_map F X Y g,
  map_id' := by { rintro ⟨i, X⟩, apply (F i).map_id },
  map_comp' := by { rintro ⟨i, X⟩ ⟨_, Y⟩ ⟨_, Z⟩ ⟨i, _, Y, f⟩ ⟨_, _, Z, g⟩, apply (F i).map_comp } }

@[simp]
lemma desc_map_mk {i : I} (X Y : C i) (f : X ⟶ Y) :
  (desc F).map (sigma_hom.mk f) = (F i).map f :=
rfl

/--
This shows that when `desc F` is restricted to just the subcategory `C i`, `desc F` agrees with
`F i`.
-/
-- We hand-generate the simp lemmas about this since they come out cleaner.
def incl_desc (i : I) : incl i ⋙ desc F ≅ F i :=
nat_iso.of_components (λ X, iso.refl _) (by tidy)

@[simp]
lemma incl_desc_hom_app (i : I) (X : C i) :
  (incl_desc F i).hom.app X = 𝟙 ((F i).obj X) :=
rfl

@[simp]
lemma incl_desc_inv_app (i : I) (X : C i) :
  (incl_desc F i).inv.app X = 𝟙 ((F i).obj X) :=
rfl

/--
If `q` when restricted to each subcategory `C i` agrees with `F i`, then `q` is isomorphic to
`desc F`.
-/
def desc_uniq (q : (Σ i, C i) ⥤ D) (h : Π i, incl i ⋙ q ≅ F i) : q ≅ desc F :=
nat_iso.of_components (λ ⟨i, X⟩, (h i).app X) $
  by { rintro ⟨i, X⟩ ⟨_, _⟩ ⟨_, _, Y, f⟩, apply (h i).hom.naturality f }

@[simp]
lemma desc_uniq_hom_app (q : (Σ i, C i) ⥤ D) (h : Π i, incl i ⋙ q ≅ F i) (i : I) (X : C i) :
  (desc_uniq F q h).hom.app ⟨i, X⟩ = (h i).hom.app X :=
rfl

@[simp]
lemma desc_uniq_inv_app (q : (Σ i, C i) ⥤ D) (h : Π i, incl i ⋙ q ≅ F i) (i : I) (X : C i) :
  (desc_uniq F q h).inv.app ⟨i, X⟩ = (h i).inv.app X :=
rfl

/--
If `q₁` and `q₂` when restricted to each subcategory `C i` agree, then `q₁` and `q₂` are isomorphic.
-/
@[simps]
def nat_iso {q₁ q₂ : (Σ i, C i) ⥤ D} (h : Π i, incl i ⋙ q₁ ≅ incl i ⋙ q₂) :
  q₁ ≅ q₂ :=
{ hom := nat_trans (λ i, (h i).hom),
  inv := nat_trans (λ i, (h i).inv) }

end

section

variables (C) {J : Type w₂} (g : J → I)

/-- A function `J → I` induces a functor `Σ j, C (g j) ⥤ Σ i, C i`. -/
def map : (Σ (j : J), C (g j)) ⥤ (Σ (i : I), C i) :=
desc (λ j, incl (g j))

@[simp] lemma map_obj (j : J) (X : C (g j)) : (sigma.map C g).obj ⟨j, X⟩ = ⟨g j, X⟩ := rfl
@[simp] lemma map_map {j : J} {X Y : C (g j)} (f : X ⟶ Y) :
  (sigma.map C g).map (sigma_hom.mk f) = sigma_hom.mk f :=
rfl

/--
The functor `sigma.map C g` restricted to the subcategory `C j` acts as the inclusion of `g j`.
-/
@[simps]
def incl_comp_map (j : J) : incl j ⋙ map C g ≅ incl (g j) := iso.refl _

variable (I)

/-- The functor `sigma.map` applied to the identity function is just the identity functor. -/
@[simps]
def map_id : map C (id : I → I) ≅ 𝟭 (Σ i, C i) :=
nat_iso (λ i, nat_iso.of_components (λ X, iso.refl _) (by tidy))

variables {I} {K : Type w₃}

/-- The functor `sigma.map` applied to a composition is a composition of functors. -/
@[simps]
def map_comp (f : K → J) (g : J → I) : map (C ∘ g) f ⋙ (map C g : _) ≅ map C (g ∘ f) :=
desc_uniq _ _ $ λ k,
  (iso_whisker_right (incl_comp_map (C ∘ g) f k) (map C g : _) : _) ≪≫ incl_comp_map _ _ _

end

namespace functor

variables {C}
variables {D : I → Type u₁} [∀ i, category.{v₁} (D i)]

/--
Assemble an `I`-indexed family of functors into a functor between the sigma types.
-/
def sigma (F : Π i, C i ⥤ D i) : (Σ i, C i) ⥤ (Σ i, D i) :=
desc (λ i, F i ⋙ incl i)

end functor

namespace nat_trans

variables {C}
variables {D : I → Type u₁} [∀ i, category.{v₁} (D i)]
variables {F G : Π i, C i ⥤ D i}

/--
Assemble an `I`-indexed family of natural transformations into a single natural transformation.
-/
def sigma (α : Π i, F i ⟶ G i) : functor.sigma F ⟶ functor.sigma G :=
{ app := λ f, sigma_hom.mk ((α f.1).app _),
  naturality' :=
  begin
    rintro ⟨i, X⟩ ⟨_, _⟩ ⟨_, _, Y, f⟩,
    change sigma_hom.mk _ = sigma_hom.mk _,
    rw (α i).naturality,
  end }

end nat_trans

end sigma
end category_theory


import for_mathlib.is_locally_constant
import locally_constant.analysis

/-!
# Extending a locally constant map to larger profinite sets

In this file, we prove that, given a topological embedding `e : X → Y` from a non-empty
compact topological space to a profinite set (ie. compact Hausdorff totally disconnected space),
every locally constant map `f` from `X` to any type `Z` "extends" to a locally constant map
from `Y` to `Z`, ie. there exists `g : Y → Z` locally constant such that `f = g ∘ e`.

     e
  X ↪-→ Y
  |    /
f |   / h
  ↓ ↙
  Z

Notes:
* this wouldn't work if `X` and `Z` were empty and `Y` weren't. The minimal assumption
  would be assuming `Z` isn't empty, I'll refactor this soon.
* Everything is stated assuming only `X` is compact but the existence of `f` ensures `X` is
  profinite, we're just saving type-class search (and nothing in the construction or proofs
  directly use `X` is profinite).

The main definition is `embedding.extend {e : X → Y} (he : embedding e) (f : X → Z) : Y → Z`
It assumes `X` is compact (and non-empty) and assumes `Y` is profinite but doesn't
assume `f` is locally constant, it is simply defined as a constant map if `f` isn't.

The announced properties of this extension are `embedding.extend_extends` and
`embedding.is_locally_constant_extend`.
-/

variables {X : Type*} [topological_space X]

noncomputable theory
open set

variables [compact_space X]
  {Y : Type*} [topological_space Y] [t2_space Y] [compact_space Y] [totally_disconnected_space Y]

lemma embedding.preimage_clopen {f : X → Y} (hf : embedding f) {U : set X} (hU : is_clopen U) :
  ∃ V : set Y, is_clopen V ∧ U = f ⁻¹' V :=
begin
  cases hU with hU hU',
  have hfU : is_compact (f '' U),
    from hU'.is_compact.image hf.continuous,
  obtain ⟨W, W_op, hfW⟩ : ∃ W : set Y, is_open W ∧ f ⁻¹' W = U,
  { rw hf.to_inducing.induced at hU,
    exact is_open_induced_iff.mp hU },
  obtain ⟨ι, Z : ι → set Y, hWZ : W = ⋃ i, Z i, hZ : ∀ i, is_clopen $ Z i⟩ :=
    is_topological_basis_clopen.open_eq_Union W_op,
  have : f '' U ⊆ ⋃ i, Z i,
  { rw [image_subset_iff, ← hWZ, hfW] },
  obtain ⟨I, hI⟩ : ∃ I : finset ι, f '' U ⊆ ⋃ i ∈ I, Z i,
    from hfU.elim_finite_subcover _ (λ i, (hZ i).1) this,
  refine ⟨⋃ i ∈ I, Z i, _, _⟩,
  { apply is_clopen_bUnion, apply finset.finite_to_set,
    tauto },
  { apply subset.antisymm,
    exact image_subset_iff.mp hI,
    have : (⋃ i ∈ I, Z i) ⊆ ⋃ i, Z i,
      from Union₂_subset_Union _ _,
    rw [← hfW, hWZ],
    mono },
end

lemma embedding.ex_discrete_quotient [nonempty X] {f : X → Y} (hf : embedding f) (S : discrete_quotient X) :
  ∃ (S' : discrete_quotient Y) (g : S ≃ S'), S'.proj ∘ f = g ∘ S.proj :=
begin
  classical,
  inhabit X,
  haveI : fintype S := discrete_quotient.fintype S,
  have : ∀ s : S, ∃ V : set Y, is_clopen V ∧ S.proj ⁻¹' {s} = f ⁻¹' V,
    from λ s, hf.preimage_clopen (S.fiber_clopen {s}),
  choose V hV using this,
  rw forall_and_distrib at hV,
  cases hV with V_cl hV,
  let s₀ := S.proj default,
  let W : S → set Y := λ s, (V s) \ (⋃ s' (h : s' ≠ s), V s'),
  have W_dis : ∀ {s s'}, s ≠ s' → disjoint (W s) (W s'),
  { rintros s s' hss x ⟨⟨hxs_in, hxs_out⟩, ⟨hxs'_in, hxs'_out⟩⟩,
    apply hxs'_out,
    rw mem_Union₂,
    exact ⟨s, hss, hxs_in⟩ },
  have hfW : ∀ x, f x ∈ W (S.proj x),
  { intro x,
    split,
    { change x ∈ f ⁻¹' (V $ S.proj x),
      rw ← hV (S.proj x),
      exact mem_singleton _ },
    { intro h,
      rcases mem_Union₂.mp h with ⟨s', hss', hfx : x ∈ f ⁻¹' (V s')⟩,
      rw ← hV s' at hfx,
      exact hss' hfx.symm } },
  have W_nonempty : ∀ s, (W s).nonempty,
  { intro s,
    obtain ⟨x, hx : S.proj x = s⟩ := S.proj_surjective s,
    use f x,
    rw ← hx,
    apply hfW,
     },
  let R : S → set Y := λ s, if s = s₀ then W s₀ ∪ (⋃ s, W s)ᶜ else W s,
  have W_cl : ∀ s, is_clopen (W s),
  { intro s,
    apply (V_cl s).diff,
    apply is_clopen_Union,
    intro s',
    by_cases h : s' = s,
    simp [h, is_clopen_empty],
    simp [h, V_cl s'] },
  have R_cl : ∀ s, is_clopen (R s),
  { intro s,
    dsimp [R],
    split_ifs,
    { apply (W_cl s₀).union,
      apply is_clopen.compl,
      exact is_clopen_Union W_cl },
    { exact W_cl _ }, },
  let R_part : indexed_partition R,
  { apply indexed_partition.mk',
    { rintros s s' hss x ⟨hxs, hxs'⟩,
      dsimp [R] at hxs hxs',
      split_ifs at hxs hxs' with hs hs',
      { exact (hss (hs.symm ▸ hs' : s = s')).elim },
      { cases hxs' with hx hx,
        { exact W_dis hs' ⟨hxs, hx⟩ },
        { apply hx,
          rw mem_Union,
          exact ⟨s, hxs⟩ } },
      { cases hxs with hx hx,
        { exact W_dis hs ⟨hxs', hx⟩ },
        { apply hx,
          rw mem_Union,
          exact ⟨s', hxs'⟩ } },
      { exact W_dis hss ⟨hxs, hxs'⟩ } },
    { intro s,
      dsimp [R],
      split_ifs,
      { use (W_nonempty s₀).some,
        left,
        exact (W_nonempty s₀).some_mem },
      { apply W_nonempty } },
    { intro y,
      by_cases hy : ∃ s, y ∈ W s,
      { cases hy with s hys,
        use s,
        dsimp [R],
        split_ifs,
        { left,
          rwa h at hys },
        { exact hys } },
      { use s₀,
        simp only [R, if_pos rfl],
        right,
        rwa [mem_compl_iff, mem_Union] } } },
  let S' := R_part.discrete_quotient R_cl,
  let g := R_part.discrete_quotient_equiv R_cl,
  have hR : ∀ x, f x ∈ R (S.proj x),
  { intros x,
    by_cases hx : S.proj x = s₀,
    { simp only [hx, R, if_pos rfl],
      left,
      rw ← hx,
      apply hfW },
    { simp only [R, if_neg hx],
      apply hfW }, },
  use [S', g],
  ext x,
  change f x ∈ S'.proj ⁻¹' {g (S.proj x)},
  rw R_part.discrete_quotient_fiber R_cl,
  simpa using hR x,
end

def embedding.discrete_quotient_map [nonempty X] {f : X → Y} (hf : embedding f) (S : discrete_quotient X) :
discrete_quotient Y := (hf.ex_discrete_quotient S).some

def embedding.discrete_quotient_equiv [nonempty X] {f : X → Y} (hf : embedding f) (S : discrete_quotient X) :
  S ≃ hf.discrete_quotient_map S :=
(hf.ex_discrete_quotient S).some_spec.some

lemma embedding.discrete_quotient_spec [nonempty X] {f : X → Y} (hf : embedding f) (S : discrete_quotient X) :
(hf.discrete_quotient_map S).proj ∘ f = (hf.discrete_quotient_equiv S) ∘ S.proj :=
(hf.ex_discrete_quotient S).some_spec.some_spec

variables {Z : Type*} [inhabited Z]

open_locale classical

def embedding.extend {e : X → Y} (he : embedding e) (f : X → Z) : Y → Z :=
if h : is_locally_constant f ∧ nonempty X then
by {
  haveI := h.2,
  let ff : locally_constant X Z := ⟨f,h.1⟩,
  let T := he.discrete_quotient_map ff.discrete_quotient,
  let ee : ff.discrete_quotient ≃ T := he.discrete_quotient_equiv ff.discrete_quotient,
  exact ff.lift ∘ ee.symm ∘ T.proj }
else λ y, default

/- lemma embedding.extend_eq {e : X → Y} (he : embedding e) {f : X → Z} (hf : is_locally_constant f) :
  he.extend f = (hf.discrete_quotient_map) ∘ (he.discrete_quotient_equiv hf.discrete_quotient).symm ∘ (he.discrete_quotient_map hf.discrete_quotient).proj
  := dif_pos hf -/

lemma embedding.extend_extends {e : X → Y} (he : embedding e) {f : X → Z} (hf : is_locally_constant f) :
∀ x, he.extend f (e x) = f x :=
begin
  intro x,
  haveI : nonempty X := ⟨x⟩,
  let ff : locally_constant X Z := ⟨f,hf⟩,
  let S := ff.discrete_quotient,
  let S' := he.discrete_quotient_map S,
  let barf : S → Z := ff.lift,
  let g : S ≃ S' := he.discrete_quotient_equiv S,
  unfold embedding.extend,
  have h : is_locally_constant f ∧ nonempty X := ⟨hf, ⟨x⟩⟩,
  rw [dif_pos h],
  change (barf ∘ g.symm ∘ (S'.proj ∘ e)) x = f x,
  suffices : (barf ∘ S.proj) x = f x, by simpa [he.discrete_quotient_spec],
  simpa,
end

lemma embedding.is_locally_constant_extend {e : X → Y} (he : embedding e) {f : X → Z} :
  is_locally_constant (he.extend f) :=
begin
  unfold embedding.extend,
  split_ifs,
  { apply is_locally_constant.comp,
    apply is_locally_constant.comp,
    exact discrete_quotient.proj_is_locally_constant _ },
  { apply is_locally_constant.const },
end

lemma embedding.range_extend {e : X → Y} (he : embedding e)
  [nonempty X] {Z : Type*} [inhabited Z] {f : X → Z} (hf : is_locally_constant f) :
  range (he.extend f) = range f :=
begin
  ext z,
  split,
  { rintro ⟨y, rfl⟩,
    let ff : locally_constant _ _ := ⟨f,hf⟩,
    let T := he.discrete_quotient_map ff.discrete_quotient,
    let ee : ff.discrete_quotient ≃ T := he.discrete_quotient_equiv ff.discrete_quotient,
    dsimp only [embedding.extend],
    rw dif_pos,
    swap, { exact ⟨hf, ‹_›⟩ },
    change ff.lift (ee.symm (T.proj y)) ∈ _,
    rcases ff.discrete_quotient.proj_surjective (ee.symm (T.proj y)) with ⟨w,hz⟩,
    use w,
    rw ← hz,
    refl },
  { rintro ⟨x, rfl⟩,
    exact ⟨e x, he.extend_extends hf _⟩ }
end

def embedding.locally_constant_extend {e : X → Y} (he : embedding e) (f : locally_constant X Z) :
  locally_constant Y Z :=
⟨he.extend f, he.is_locally_constant_extend⟩

@[simp]
lemma embedding.locally_constant_extend_extends {e : X → Y} (he : embedding e)
  (f : locally_constant X Z) (x : X) : he.locally_constant_extend f (e x) = f x :=
he.extend_extends f.2 x

lemma embedding.comap_locally_constant_extend {e : X → Y} (he : embedding e)
  (f : locally_constant X Z) : (he.locally_constant_extend f).comap e = f :=
begin
  ext x,
  rw locally_constant.coe_comap _ _ he.continuous,
  exact he.locally_constant_extend_extends f x
end

lemma embedding.range_locally_constant_extend {e : X → Y} (he : embedding e)
  [nonempty X] {Z : Type*} [inhabited Z] (f : locally_constant X Z) :
  range (he.locally_constant_extend f) = range f :=
he.range_extend f.2

-- version avec comap_hom pour Z normed group ?


import data.list
open list nat

namespace PDL

inductive pdl_type
| Fml | Prg

open pdl_type

attribute [reducible]
def PropVar := nat

attribute [reducible]
def ProgVar := nat

inductive pdl : pdl_type → Type
| Var (n : PropVar)                 : pdl Fml
| Neg (φ : pdl Fml)                 : pdl Fml
| And (φ : pdl Fml) (ψ : pdl Fml)   : pdl Fml
| Or  (φ : pdl Fml) (ψ : pdl Fml)   : pdl Fml
| EX (a : pdl Prg) (φ : pdl Fml)    : pdl Fml
| AX (a : pdl Prg) (φ : pdl Fml)    : pdl Fml
| Atom (n : ProgVar)                : pdl Prg
| Test (φ : pdl Fml)                : pdl Prg
| Cons (a : pdl Prg) (b : pdl Prg)  : pdl Prg
| Nd (a : pdl Prg) (b : pdl Prg)    : pdl Prg
| Star (a : pdl Prg)                : pdl Prg

-- inductive pdl_u : pdl_type → Type
-- | Var (n : PropVar)                              : pdl_u Fml
-- | Neg (φ : pdl Fml)                              : pdl_u Fml
-- | And (φ : pdl Fml) (ψ : pdl Fml)                : pdl_u Fml
-- | Or  (φ : pdl Fml) (ψ : pdl Fml)                : pdl_u Fml
-- | EX (a : pdl Prg) (φ : pdl Fml)                 : pdl_u Fml
-- | EU (a : pdl Prg) (φ : pdl Fml) (ψ : pdl Fml)   : pdl_u Fml
-- | EG (a : pdl Prg) (φ : pdl Fml)                 : pdl_u Fml
-- | Atom (n : ProgVar)                             : pdl_u Prg

open pdl

notation `#`:max P:max := Var P
notation A ∨ B         := Or A B
notation A ∧ B         := And A B
notation ~ A           := Neg A
notation `⟨` a `⟩` φ      := EX a φ
notation `[` a `]` φ      := AX a φ
notation φ `??`        := Test φ
notation a `;` b      := Cons a b
notation a `∪` b     := Nd a b
notation a `⋆`        := Star a

notation A ` ⇒ ` B     := Neg A ∨ B
def BiImpl A B  := A ⇒ B ∧ B ⇒ A
infixr `⇔`:27 := BiImpl

section

-- Using these definitions and notations, we can express formulae of PDL
-- naturally.

variables (φ ψ p: pdl Fml) (a b: pdl Prg)

check [a](φ ⇒ ψ) ⇒ ([a]φ ⇒ [a]ψ)
check [(a;b)]φ ⇔ [a][b]φ
check [a⋆]φ ⇔ φ ∧ [a][a⋆]φ
check [φ??]ψ ⇔ (φ ⇒ ψ)

-- Induction principle
check φ ∧ [a⋆](φ ⇒ [a]φ) ⇒ [a⋆]φ

-- Some eventualities and other examples
check ⟨a⟩⟨a⋆⟩[a]p
check ⟨b⟩⟨b⋆⟩⟨(a⋆;b⋆)⋆⟩p
check [(a∪b)⋆]~p

end

-- A simpler definition of Kripke structures for PDL.
structure kripke :=
(prop_eval : ℕ → PropVar → Prop)
(prog_eval : ProgVar → ℕ → ℕ → Prop)

-- This is a more general definition of kripke structures.

-- structure kripke :=
-- (world : Type)
-- (prop_eval : world → PropVar → bool)
-- (prog_eval : ProgVar → world → world → bool)

section
-- This says only propositions 0,1,2,3 are true in every world.
private def f (w : ℕ) (p : PropVar) : Prop := if p > 4 then false else true
-- This says worlds 0,1,2,3 are fully connected via atomic program 2. No other
-- worlds are connected together.
private def g (a : ProgVar) (w₁ w₂: ℕ) : Prop :=
if a = 2 ∧ w₁ ≤ 3 ∧ w₂ ≤ 3 then true else false
-- Now we have a kripke structure where worlds 0,1,2,3 are are fully connected
-- via atomic program 2, and propostions 0,1,2,3 are true in these worlds.
private def my_model : kripke := kripke.mk f g

end

section ith

variable {T : Type}
definition ith : Π (l : list T) (i : nat), i < length l → T
| nil     i        h := absurd h (not_lt_zero i)
| (x::xs) 0        h := x
| (x::xs) (succ i) h := ith xs i (lt_of_succ_lt_succ h)

end ith

-- The following defs require well-founded recursion and mutually recursive
-- definition which have not been implemented in Lean 3 yet. To handle the
-- mutual definition, we simply cheat by making the semantics of Test
-- unrelatd to prog_eval. To handle well-founded recursion, we can mark
-- these as meta definitions.

def Acc (M : kripke) : ℕ → ℕ → pdl Prg → Prop
| w₁ w₂ (Atom n)      := kripke.prog_eval M n w₁ w₂
| w₁ w₂ (Test φ)      := false
| w₁ w₂ (Cons γ δ)    := ∃ y, Acc w₁ y γ ∧ Acc y w₂ δ
| w₁ w₂ (Nd γ δ)      := Acc w₁ w₂ γ ∨ Acc w₁ w₂ δ
| w₁ w₂ (Star γ)      := ∃ n : ℕ, ∃ l : list ℕ, length l = n ∧
                         head l = w₁ ∧ head (reverse l) = w₂ ∧
                         ∀i, ∀ h : i + 1 < length l,
                         Acc (ith l i (lt_of_succ_lt h))
                         (ith l (i+1) h) γ

def Satisfies (M : kripke) : ℕ → pdl Fml → Prop
| w (# P)         := kripke.prop_eval M w P
| w (~ φ)         := ¬ (Satisfies w φ)
| w (And φ ψ)     := Satisfies w φ ∧ Satisfies w ψ
| w (Or φ ψ)      := Satisfies w φ ∨ Satisfies w ψ
| w (EX a φ)      := ∃ y, Acc M w y a ∧ Satisfies y φ
| w (AX a φ)      := ∀ y, Acc M w y a → Satisfies y φ

-- Satisfiability

notation M ` & ` w ` ⊨ ` p := Satisfies M w p

def Satisfiable (φ : pdl Fml) : Prop := ∃ M w, M & w ⊨ φ

def Valid (φ : pdl Fml) : Prop := ∀ M w, M & w ⊨ φ

end PDL

-- Some experiments.

-- constant Kripke_model : Type
-- constant valuation : Kripke_model → Type

-- constant semantic_type : Kripke_model → pdl_type → Type

-- open pdl

-- noncomputable def semantics (K : Kripke_model) (v : valuation K) :
--   Π t : pdl_type, Π e : pdl t, semantic_type K t
-- | ._  (var  n)    := sorry
-- | ._  (fneg φ)    := sorry
-- | ._  (event γ φ) := sorry

-- mutual inductive pdlfml, pdlprg
-- with pdlfml : Type
-- | var (n : ℕ) : pdlfml
-- | event (γ : pdlprg) (φ : pdlfml) : pdlfml
-- with pdlprg : Type
-- | atom (n : ℕ) : pdlprg

-- inductive tree : Type
-- | mk : list tree → tree

-- print _nest_1_1.tree

-- print pdlfml
-- print pdlfml._mut_

-- def fake (n : ℕ) : Prop := if n < 4 then true else false

-- check @if_pos

-- theorem thm : fake 0 := trivial

-- example : true := by trivial