import Euclid.tarski_6
open classical set
namespace Euclidean_plane
variables {point : Type} [Euclidean_plane point]

local attribute [instance] prop_decidable

theorem col_of_perp {a b p q : point} : p ≠ q → R a p q → R b p q → col p a b :=
λ h h1 h2, not_3dim (seven12b h) (seven5 p q).2 h1 h2

theorem coplanar {a : point} (b : point) {A : set point} : line A → a ∉ A → b ∈ pl A a :=
begin
intros h h1,
cases exists_of_exists_unique (eight17 h h1) with p hp,
by_cases h2 : b ∈ A,
  exact or.inr (or.inl h2),
cases ten15 h hp.1 h2 with c hc,
suffices : col p a c,
  by_cases h_1 : B c p a,
    apply (or.inr (or.inr ((nine8 _).2 hc.2).symm)),
    exact ⟨h, (nine11 hc.2).2.1, h1, p, hp.1, h_1⟩,
  apply or.inl (hc.2.symm.trans _),
  exact nine12 h hp.1 (six4.2 ⟨(four11 this).2.2.2.1, h_1⟩) (nine11 hc.2).2.1,
rcases six22 h hp.1 with ⟨q, h3, h4⟩,
subst h4,
apply col_of_perp h3,
  suffices : xperp p (l p q) (l a p),
    exact (this.2.2.2.2 (six17b p q) (six17a a p)).symm,
  exact eight15 hp.2 (six17a p q) (six17b a p),
suffices : xperp p (l p q) (l c p),
  exact (this.2.2.2.2 (six17b p q) (six17a c p)).symm,
exact eight15 hc.1 (six17a p q) (six17b c p)
end

def P : set point := planeof (P1 : point) P2 P3

theorem planeP : plane (P : set point) := ⟨P1, P2, P3, six24, rfl⟩

theorem in_P {a : point} : a ∈ (P : set point) :=
coplanar a (six14 (six26 six24).1) six24

theorem unique_plane {Q : set point} : plane Q → Q = P :=
begin
rintros ⟨x, y, z, h, h1⟩,
subst h1,
exact (nine26 h planeP in_P in_P in_P).symm
end

def dpar (A B : set point) : Prop := line A ∧ line B ∧ ¬∃ x, x ∈ A ∧ x ∈ B

def par (A B : set point) : Prop := dpar A B ∨ line A ∧ A = B

theorem line_of_par {A B : set point} : par A B → line A ∧ line B :=
λ h, h.elim (λ h, ⟨h.1, h.2.1⟩) (λ h, ⟨h.1, h.2 ▸ h.1⟩)

theorem twelve1 {A B : set point} : dpar A B → A ≠ B :=
begin
intros h h1,
rcases h.1 with ⟨x, y, h2, h3⟩,
subst_vars,
exact h.2.2 ⟨x, six17a x y, six17a x y⟩
end

theorem twelve2 {A B : set point} {a : point} : dpar A B → a ∈ A → a ∉ B :=
λ h h1 h2, h.2.2 ⟨a, h1, h2⟩

theorem twelve3 {a b c : point} : par (l a b) (l a c) → col a b c :=
begin
intro h,
cases h,
  exact (h.2.2 ⟨a, six17a a b, six17a a c⟩).elim,
change c ∈ l a b,
simp [h.2]
end

theorem par.refl {A : set point} : line A → par A A :=
λ h, or.inr ⟨h, rfl⟩

theorem dpar.symm {A B : set point} : dpar A B → dpar B A :=
λ h, ⟨h.2.1, h.1, λ ⟨x, hx⟩, h.2.2 ⟨x, hx.symm⟩⟩

theorem par.symm {A B : set point} : par A B → par B A :=
λ h, h.elim (λ h, or.inl h.symm) (λ h, or.inr ⟨h.2 ▸ h.1, h.2.symm⟩)

theorem twelve5 {A B : set point} {x : point} : par A B → x ∈ A → x ∈ B → A = B :=
λ h h1 h2, h.elim (λ h, (h.2.2 ⟨x, h1, h2⟩).elim) (and.right)

theorem twelve6 {A B : set point} : dpar A B → ∀ {b b'}, b ∈ B → b' ∈ B → side A b b' :=
begin
intros h b b' h1 h2,
have h3 : b ∉ A,
  intro h_1,
  exact h.2.2 ⟨b, h_1, h1⟩,
cases coplanar b' h.1 h3,
  exact h_1.symm,
cases h_1,
  exact (h.2.2 ⟨b', h_1, h2⟩).elim,
cases h_1.2.2.2 with x hx,
apply (h.2.2 ⟨x, hx.1, _⟩).elim,
suffices : B = l b b',
  rw this,
  exact or.inr (or.inl hx.2.symm),
exact six18 h.2.1 (nine2 h_1) h1 h2
end

theorem twelve7 {a b c d : point} : dpar (l a b) (l c d) ↔ side (l a b) c d ∧ ¬∃ x, col a b x ∧ col c d x :=
begin
split,
  intro h,
  refine ⟨twelve6 h (six17a c d) (six17b c d), _⟩,
  rintros ⟨x, hx⟩,
  exact h.2.2 ⟨x, hx.1, hx.2⟩,
rintros ⟨h, h1⟩,
have h2 := six13 (nine11 h).1,
have h3 : c ≠ d,
  intro h_1,
  subst d,
  exact h1 ⟨b, or.inl (three1 a b), or.inl (three3 c b)⟩,
refine ⟨six14 h2, six14 h3, λ h_1, _⟩,
cases h_1 with x hx,
exact h1 ⟨x, hx.1, hx.2⟩
end

theorem twelve8 (a : point) {L : set point} : line L → ∃! (A : set point), a ∈ A ∧ perp L A :=
begin
intro h,
by_cases h1 : a ∈ L,
  rcases six22 h h1 with ⟨b, hb, h2⟩,
  subst h2,
  cases eight25 hb.symm with c hc,
  refine ⟨l a c, ⟨six17a a c, _⟩, _⟩,
    suffices : xperp a (l a b) (l a c),
      exact ⟨a, this⟩,
    apply eight13.2,
    simp *,
    exact ⟨six14 hc.2.symm, b, six17b a b, c, six17b a c, hb.symm, hc.2, hc.1⟩,
  intros Y hy,
  rcases six22 (eight14e hy.2).2 hy.1 with ⟨x, hx, h2⟩,
  subst h2,
  apply six18 (six14 hx) hc.2.symm (six17a a x) _,
  apply col_of_perp hb _ hc.1.symm,
  have h2 := eight15 hy.2.symm (six17a a x) (six17a a b),
  exact h2.2.2.2.2 (six17b a x) (six17b a b),
have h2 := eight18 h h1,
cases exists_of_exists_unique h2 with x hx,
refine ⟨l a x, ⟨(six17a a x), hx.2⟩, _⟩,
intros Y hy,
apply six18 (eight14e hy.2).2 _ hy.1 _,
  intro h_1,
  subst h_1,
  exact h1 hx.1,
cases hy.2 with z hz,
suffices : z = x,
  subst z,
  exact hz.2.2.2.1,
apply unique_of_exists_unique h2 ⟨hz.2.2.1, _⟩ hx,
suffices : Y = l a z,
  subst Y,
  exact hy.2,
apply six18 (eight14e hy.2).2 _ hy.1 hz.2.2.2.1,
intro h_1,
subst h_1,
exact h1 hz.2.2.1
end

theorem twelve9 {A B C : set point} : line A → line B → line C → perp A C → perp B C → par A B :=
begin
intros h h1 h2 h3 h4,
by_cases h_1 : A = B,
  exact or.inr ⟨h, h_1⟩,
refine or.inl ⟨h, h1, λ h_2, _⟩,
cases h_2 with x hx,
apply h_1,
exact unique_of_exists_unique (twelve8 x h2) ⟨hx.1, h3.symm⟩ ⟨hx.2, h4.symm⟩
end

theorem twelve10 {A : set point} {a : point} : line A → ∃ B, par A B ∧ a ∈ B :=
begin
intro h,
by_cases h1 : a ∈ A,
  exact ⟨A, or.inr ⟨h, rfl⟩, h1⟩,
cases exists_of_exists_unique (twelve8 a h) with C hc,
cases exists_of_exists_unique (twelve8 a (eight14e hc.2).2) with B hb,
refine ⟨B, _, hb.1⟩,
exact twelve9 h (eight14e hb.2).2 (eight14e hc.2).2 hc.2 hb.2.symm
end

theorem twelve11 {A B C : set point} {a : point} : line A → a ∉ A → par A B → a ∈ B → par A C → a ∈ C → B = C :=
begin
intros h h1 h2 h3 h4 h5,
replace h2 : dpar A B,
  apply h2.elim (id),
  intro h_2,
  exact (h1 (h_2.2.symm ▸ h3)).elim,
replace h4 : dpar A C,
  apply h4.elim (id),
  intro h_2,
  exact (h1 (h_2.2.symm ▸ h5)).elim,
by_contradiction h_1,
rcases h with ⟨s, t, h, h6⟩,
subst h6,
suffices : ∃ c', c' ∈ C ∧ Bl t B c',
  rcases this with ⟨c', hc1, hc2⟩,
  cases hc2.2.2.2 with b hb,
  cases three14 c' a with c hc,
  cases pasch hc.1.symm hb.2 with d hd,
  have h6 : a ≠ b,
    intro h_2,
    subst b,
    suffices : c' ≠ a,
      apply twelve2 h4 (six17b s t),
      rw (six18 h4.2.1 this hc1 h5),
      exact or.inl hb.2.symm,
    intro h_2,
    subst h_2,
    exact hc2.2.2.1 h3,
  have h7 : c ∈ C,
    rw (six18 h4.2.1 _ hc1 h5),
    exact or.inl hc.1,
    intro h_2,
    subst h_2,
    exact hc2.2.2.1 h3,
  suffices : a ≠ d,
    rcases euclids hd.1 hd.2 this with ⟨x, y, hx, hy, ht⟩,
    suffices : side (l s t) a t,
      exact (nine11 this).2.2 (six17b s t),
    apply nine17a (twelve6 h2 h3 _) (twelve6 h4 h5 _) ht,
      rw six18 h2.2.1 h6 h3 hb.1,
      exact or.inl hx,
    rw six18 h4.2.1 hc.2 h5 h7,
    exact or.inl hy,
  intro h_2,
  subst h_2,
  apply h_1,
  rw [six18 h2.2.1 h6 h3 hb.1, six18 h4.2.1 hc.2 h5 h7],
  exact six16 h6 hc.2 (or.inr (or.inr hd.2.symm)),
cases six22 h4.2.1 h5 with x hx,
rw hx.2,
cases coplanar x h2.2.1 (twelve2 h2 (six17b s t)),
  refine ⟨S a x, (seven24 (six14 hx.1) (six17a a x)).1 (six17b a x), _⟩,
  exact (nine8 (nine1 h2.2.1 h3 (nine11 h_2).2.1)).2 h_2,
cases h_2,
  apply (h_1 _).elim,
  apply six21 hx.1 h2.2.1 h4.2.1 h3 h5 h_2,
  rw hx.2,
  simp,
exact ⟨x, six17b a x, h_2⟩
end

theorem twelve13 {A : set point} (a : point) : line A → ∃! B, par A B ∧ a ∈ B :=
begin
intro h,
apply exists_unique_of_exists_of_unique,
  exact twelve10 h,
intros X Y hx hy,
by_cases h_1 : a ∈ A,
  exact (twelve5 hx.1 h_1 hx.2).symm.trans (twelve5 hy.1 h_1 hy.2),
exact twelve11 h h_1 hx.1 hx.2 hy.1 hy.2
end

theorem par.trans {A B C : set point} : par A B → par B C → par A C :=
begin
intros h h1,
cases h,
  cases h1,
    rw [par, or_iff_not_and_not],
    simp [h.1],
    intro h2,
    replace h2 : ∃ x, x ∈ A ∧ x ∈ C,
      by_contradiction h_1,
      exact h2 ⟨h.1, h1.2.1, h_1⟩,
    cases h2 with x hx,
    exact twelve11 h.2.1 (twelve2 h hx.1) (or.inl h.symm) hx.1 (or.inl h1) hx.2,
  rw h1.2.symm,
  exact or.inl h,
rwa h.2
end

theorem twelve17 {a b c d p : point} : M a p c → M b p d → a ≠ b → par (l a b) (l c d) :=
begin
intros h h1 h2,
replace h := seven6 h,
replace h1 := seven6 h1,
rw [h, h1],
by_cases h3 : col a b p,
  refine or.inr ⟨six14 h2, six18 (six14 h2) (two7 (seven13 p a b) h2) _ _⟩;
  apply (seven24 (six14 h2) h3).1;
  simp,
refine or.inl ⟨six14 h2, six14 (two7 (seven13 p a b) h2), _⟩,
intro h_1,
rcases h_1 with ⟨x, hx1, hx2⟩,
have h4 : x ≠ p,
  intro h_1,
  subst p,
  exact h3 hx1,
suffices : l a b = l (S p a) (S p b),
  apply h3,
  apply (six27 (six14 h2) (six17a a b) _ (seven5 p a).1),
  simpa [this],
apply six21 (seven12b h4.symm) (six14 h2) (six14 (two7 (seven13 p a b) h2)) hx1 hx2,
  rw [←seven7 p a, ←seven7 p b],
  exact (S_of_col p).1 hx2,
exact (S_of_col p).1 hx1
end

theorem par_of_S {a b : point} (p : point) : a ≠ b → par (l a b) (l (S p a) (S p b)) :=
twelve17 (seven5 p a) (seven5 p b)

theorem twelve18 {a b c d p : point} : eqd a b c d → eqd b c d a → ¬col a b c → b ≠ d → col a p c →
col b p d → par (l a b) (l c d) ∧ par (l b c) (l d a) ∧ Bl b (l a c) d ∧ Bl a (l b d) c :=
begin
intros h h1 h2 h3 h4 h5,
have h6 := seven21 h2 h3 h h1 h4 h5,
refine ⟨twelve17 h6.1 h6.2 (six26 h2).1, twelve17 h6.2 h6.1.symm (six26 h2).2.1, _⟩,
split,
  rw seven6 h6.2,
  exact nine1 (six14 (six26 h2).2.2) (four11 h4).1 (four10 h2).1,
rw seven6 h6.1,
apply nine1 (six14 h3) (four11 h5).1,
intro h_1,
suffices : c ∈ l b d,
  exact h2 (six23.2 ⟨l b d, six14 h3, h_1, six17a b d, this⟩),
rw seven6 h6.1,
exact (seven24 (six14 h3) (four11 h5).1).1 h_1
end

theorem twelve19 {a b c d : point} : ¬col a b c → par (l a b) (l c d) → par (l b c) (l d a) →
eqd a b c d ∧ eqd b c d a ∧ Bl b (l a c) d ∧ Bl a (l b d) c :=
begin
intros h h1 h2,
generalize hp : mid a c = p,
replace hp : c = S p a,
  rw ←hp,
  exact (mid_to_Sa a c).symm,
subst c,
have h3 : eqd b (S p a) (S p b) a,
  have h4 := seven13 p b (S p a),
  simpa using h4,
have h4 := twelve18 (seven13 p a b) h3 h _ (or.inl (seven5 p a).1) (or.inl (seven5 p b).1),
  suffices : d = S p b,
    rw this,
    exact ⟨seven13 p a b, h3, h4.2.2.1, h4.2.2.2⟩,
  have h5 := twelve3 (h1.symm.trans h4.1),
  have h6 := (h2.symm.trans h4.2.1),
  rw [six17, six17 (S p b) a] at h6,
  replace h6 := twelve3 h6,
  by_contradiction h_1,
  apply h,
  rw S_of_col p,
  simp,
  exact (four11 (five4 (ne.symm h_1) (four11 h5).2.2.2.2 (four11 h6).2.2.2.2)).2.1,
apply seven12b,
intro h_1,
subst p,
exact h (or.inl (seven5 b a).1)
end

theorem twelve20 {a b c d : point} : par (l a b) (l c d) → eqd a b c d → Bl b (l a c) d →
par (l b c) (l d a) ∧ eqd b c d a ∧ Bl a (l b d) c :=
begin
intros h h1 h2,
generalize hp : mid b d = p,
replace hp : d = S p b,
  rw ←hp,
  exact (mid_to_Sa b d).symm,
subst d,
have h3 : p ∉ l a b,
  intro h_1,
  suffices : a ∈ l c (S p b),
    exact h2.2.2.1 (four11 this).2.2.2.1,
  suffices : l a b = l c (S p b),
    simpa [this.symm],
  exact twelve5 h ((seven24 (line_of_par h).1 h_1).1 (six17b a b)) (six17b c (S p b)),
have h4 : par (l b (S p a)) (l (S p b) a),
  suffices : par(l b (S p a)) (l (S p b) (S p (S p a))),
    simpa [this],
  apply par_of_S p,
  intro h_1,
  subst b,
  exact (four10 h3).1 (or.inl (seven5 p a).1),
have h5 := twelve19 (λ h_1, h3 (six27 (six14 (six26 h2.2.1).2.2) (six17a a b) h_1 (seven5 p a).1)) (par_of_S p (six26 h2.2.1).2.2) h4,
suffices : c = S p a,
  subst c,
  exact ⟨h4, h5.2.1, h5.2.2.2⟩,
have h6 := h.symm.trans (par_of_S p (six26 h2.2.1).2.2),
rw [six17, six17 (S p a)] at h6,
apply six11a (six4.2 ⟨(four11 (twelve3 h6)).2.1, _⟩) (h1.symm.flip.trans (seven13 p a b).flip),
intro h_1,
have h7 : p ∉ l a c,
  intro h_2,
  apply h2.2.1,
  apply six27 h2.1 ((seven24 h2.1 h_2).1 (six17b a c)) (six17a a c),
  rw [←seven7 p a, ←seven7 p b],
  exact (seven15 p).1 h_1,
apply nine9 h2,
suffices : side (l a c) (S p a) (S p c),
  apply side.trans _ (this.symm.trans _),
    suffices : sided a b (S p c),
      exact nine12 h2.1 (six17a a c) this h2.2.1,
    apply six7 _ (six26 h2.2.1).2.2.symm,
    rw [←seven7 p a, ←seven7 p b],
    exact (seven15 p).1 h_1.symm,
  suffices : sided c (S p b) (S p a),
    exact (nine12 h2.1 (six17b a c) this h2.2.2.1).symm,
  exact six7 h_1 (six13 (line_of_par h).2).symm,
suffices : side (l a c) p (S p a),
  apply this.symm.trans,
  apply nine12 h2.1 (six17b a c) (six7 (seven5 p c).1 _) h7,
  intro h_1,
  subst p,
  exact h7 (six17b a c),
apply nine12 h2.1 (six17a a c) (six7 (seven5 p a).1 _) h7,
intro h_1,
subst p,
exact h7 (six17a a c)
end

theorem twelve21 {a b c d : point} : Bl b (l a c) d → (par (l a b) (l c d) ↔ eqa b a c d c a) :=
begin
intro h,
cases exists_of_exists_unique (six11 (six26 h.2.2.1).2.1.symm
  (six26 h.2.1).2.2) with d' hd,
replace h : Bl b (l a c) d',
    apply ((nine8 h.symm).2 _).symm,
    exact nine12 h.1 (six17b a c) hd.1.symm h.2.2.1,
split,
  intro h1,
  rw (six16a hd.1.symm) at h1,
  suffices : eqa b a c d' c a,
    exact eleven10 this (six5 this.1) (six5 this.2.1) hd.1.symm (six5 this.2.2.2.1),
  apply eleven11 (six13 (line_of_par h1).1).symm (six13 h.1).symm,
  exact ⟨hd.2.symm.flip, eqd_refl a c, (twelve20 h1 hd.2.symm h).2.1⟩,
intro h1,
replace h1 := eleven10 h1 (six5 h1.1) (six5 h1.2.1) hd.1 (six5 h1.2.2.2.1),
rw (six16a hd.1.symm),
apply (twelve18 hd.2.symm (SAS h1 hd.2.symm.flip (eqd_refl c a)).1 (four10 h.2.1).1 (nine2 h) (or.inl (ten1 a c).1) _).1,
suffices : d' = S (mid a c) b,
  rw this,
  exact or.inl (seven5 (mid a c) b).1,
apply six11a _,
  apply hd.2.trans,
  suffices : eqd a b (S (mid a c) a) (S (mid a c) b),
    simpa [(mid_to_Sa a c)] using this,
  exact (seven13 (mid a c) a b),
apply eleven15b h.2.2.1 h.2.2.1 (eqa.refl h1.2.2.2.1 h1.2.2.1) (side.refla (four10 h.2.2.1).2.1),
  apply h1.symm.flip.trans,
  simpa [mid_to_Sa a c, mid_to_Sb a c] using (eleven12 (mid a c) h1.2.1 h1.1),
rw six17,
exact ((nine8 h.symm).1 ((nine1 h.1 (or.inr (or.inl (ten1 a c).1.symm)) h.2.1).symm)).symm
end

theorem twelve22 {a b c d p : point} : sided p a c → side (l p a) b d → (par (l a b) (l c d) ↔ eqa b a p d c p) :=
begin
intros h h1,
generalize hp : mid p a = q,
replace hp : p = S q a,
  rw ←hp,
  exact (mid_to_Sb p a).symm,
subst p,
have h2 := eleven12 q (six26 (nine11 h1).2.1).2.1.symm h.1.symm,
rw seven7 at h2,
replace h2 := eleven10 h2 (six5 h2.1) (six5 h2.2.1) (six5 h2.2.2.1) h.symm,
have h3 := par_of_S q (six26 (nine11 h1).2.1).2.1,
have h4 : Bl (S q b) (l (S q a) c) d,
  exact (six16a h) ▸ ((nine8 (nine1 (nine11 h1).1 (or.inr (or.inl (seven5 q a).1)) (nine11 h1).2.1)).2 h1).symm,
exact ⟨λ h5, h2.trans ((twelve21 h4).1 (h3.symm.trans h5)), λ h5, h3.trans ((twelve21 h4).2 (h2.symm.trans h5))⟩
end

theorem twelve23 {a b c : point} : ¬col a b c → ∃ b' c', Bl b (l a c) b' ∧ Bl c (l a b) c' ∧
B b' a c' ∧ eqa a b c b a c' ∧ eqa a c b c a b' :=
begin
intro h,
have h1 := nine1 (six14 (six26 h).2.2) (or.inr (or.inl (ten1 a c).1.symm)) (four10 h).1,
have h2 := nine1 (six14 (six26 h).1) (or.inr (or.inl (ten1 a b).1.symm)) h,
have h3 := eleven12 (mid a b) (six26 h).1 (six26 h).2.1.symm,
have h4 := eleven12 (mid a c) (six26 h).2.2 (six26 h).2.1,
simp at h3 h4,
refine ⟨S (mid a c) b, S (mid a b) c, h1, h2, _, h3, h4⟩,
have h5 : col a (S (mid a c) b) (S (mid a b) c),
  apply twelve3,
  rw six17 at h1 h2,
  suffices : par (l b c) (l a (S (mid a c) b)),
    exact this.symm.trans ((twelve21 h2).2 h3.flip),
  exact six17 c b ▸ ((twelve21 h1).2 h4.flip),
apply ((nine18 h2.1 (six17a a b) (four11 h5).2.2.1).1 _).1,
apply (nine8 h2).2 _,
apply nine15 _ (ten1 a c).1 (seven5 (mid a c) b).1,
intro h_1,
apply h,
rw ←mid_to_Sa a c,
exact (seven24 h2.1 h_1).1 (six17a a b)
end

end Euclidean_plane


import polyhedral_lattice.cosimplicial
import polyhedral_lattice.Hom
import system_of_complexes.rescale
import rescale.Tinv
import pseudo_normed_group.sum_hom

universe variables u

noncomputable theory

open_locale nnreal

local attribute [instance] type_pow

open category_theory

namespace PolyhedralLattice

open simplex_category polyhedral_lattice (conerve.L conerve.obj)

variables (Λ : PolyhedralLattice.{u}) (N : ℕ) [fact (0 < N)]
variables (r' : ℝ≥0) (M : ProFiltPseuNormGrpWithTinv.{u} r')

-- TODO: we probably want some efficient constructor for these isomorphisms,
-- because the default has a lot of redundancy in the proof obligations

lemma augmentation_eq_diagonal :
  cosimplicial_augmentation_map Λ N ≫ (Cech_conerve.obj_zero_iso _).hom =
  diagonal_embedding Λ N :=
by { rw ← iso.eq_comp_inv, refl }

def Hom_rescale_hom [fact (0 < r')] :
  polyhedral_lattice.Hom (rescale N Λ) M ≃+
  (ProFiltPseuNormGrpWithTinv.of r' $ (rescale N (polyhedral_lattice.Hom Λ M))) :=
add_equiv.refl _

lemma Hom_rescale_hom_symm_apply [fact (0 < r')] (x) :
  (Hom_rescale_hom Λ N r' M).symm x = x := rfl

lemma Hom_rescale_hom_strict [fact (0 < r')] (c : ℝ≥0) (f : polyhedral_lattice.Hom (rescale ↑N Λ) M) :
    f ∈ pseudo_normed_group.filtration (polyhedral_lattice.Hom (rescale ↑N Λ) M) c ↔
    f ∈ pseudo_normed_group.filtration
        (ProFiltPseuNormGrpWithTinv.of r' (rescale ↑N (polyhedral_lattice.Hom Λ M))) c :=
begin
  split,
  { intros hf c' l hl,
    rw mul_assoc,
    refine hf _,
    simp only [seminormed_add_comm_group.mem_filtration_iff],
    erw [rescale.nnnorm_def, mul_comm, div_eq_mul_inv],
    refine mul_le_mul' _ le_rfl,
    exact hl },
  { intros  hf c' l hl,
    apply pseudo_normed_group.filtration_mono (le_of_eq _),
    convert hf _,
    { exact ↑N * c' },
    { simp only [seminormed_add_comm_group.mem_filtration_iff] at hl ⊢,
      erw [rescale.nnnorm_def, div_eq_mul_inv] at hl,
      rwa [← inv_inv (N : ℝ≥0), ← nnreal.mul_le_iff_le_inv, mul_comm],
      apply ne_of_gt,
      rw [nnreal.inv_pos],
      have hN : 0 < N := fact.out _,
      exact_mod_cast hN },
    { rw [mul_assoc, inv_mul_cancel_left₀],
      have hN : 0 < N := fact.out _,
      exact_mod_cast hN.ne' } }
end

section open profinitely_filtered_pseudo_normed_group polyhedral_lattice
  comphaus_filtered_pseudo_normed_group

lemma Hom_rescale_hom_ctu [fact (0 < r')] (c : ℝ≥0) :
  continuous (pseudo_normed_group.level (Hom_rescale_hom Λ N r' M)
    (λ c f, (Hom_rescale_hom_strict Λ N r' M c f).1) c) :=
begin
  refine (add_monoid_hom.continuous_iff _ _ _ _ _).mpr _,
  intro l,
  haveI : fact (c * (nnnorm l * N⁻¹) ≤ c * N⁻¹ * nnnorm l) :=
    ⟨by { rw [mul_comm (nnnorm _), mul_assoc] }⟩,
  have aux1 := add_monoid_hom.incl_continuous (rescale N Λ) r' M c,
  have aux2 := (continuous_apply (rescale.of l)).comp aux1,
  exact (embedding_cast_le (c * (nnnorm l * N⁻¹)) (c * N⁻¹ * nnnorm l)).continuous_iff.mp aux2
end

end

def Hom_rescale_iso [fact (0 < r')] :
  polyhedral_lattice.Hom (rescale N Λ) M ≅
  (ProFiltPseuNormGrpWithTinv.of r' $ (rescale N (polyhedral_lattice.Hom Λ M))) :=
@ProFiltPseuNormGrpWithTinv.iso_of_equiv_of_strict' _
  (polyhedral_lattice.Hom (rescale N Λ) M)
  (ProFiltPseuNormGrpWithTinv.of r' (rescale N (polyhedral_lattice.Hom Λ M)))
  (Hom_rescale_hom Λ N r' M)
  (λ c f, Hom_rescale_hom_strict Λ N r' M c f)
  (Hom_rescale_hom_ctu Λ N r' M) (λ x, rfl)

@[simps apply symm_apply {fully_applied := ff}]
def Hom_finsupp_equiv [fact (0 < r')] :
  polyhedral_lattice.Hom (fin N →₀ Λ) M ≃+
  (ProFiltPseuNormGrpWithTinv.of r' $ ((polyhedral_lattice.Hom Λ M) ^ N)) :=
{ to_fun := λ (f : (fin N →₀ Λ) →+ M) i,
  { to_fun := λ l, f (finsupp.single i l),
    map_zero' := by rw [finsupp.single_zero, f.map_zero],
    map_add' := λ l₁ l₂, by rw [finsupp.single_add, f.map_add] },
  map_add' := λ f g,
    by { ext i l, simp only [add_monoid_hom.add_apply, add_monoid_hom.coe_mk, pi.add_apply] },
  inv_fun := λ (f : (Λ →+ M) ^ N),
  { to_fun := λ x, x.sum $ λ i l, f i l,
    map_zero' := by rw [finsupp.sum_zero_index],
    map_add' := λ x y, by simp only [finsupp.sum_add_index', map_zero, eq_self_iff_true,
      implies_true_iff, map_add, forall_3_true_iff] },
  left_inv := λ f,
  begin
    ext i l, dsimp only,
    simp only [add_monoid_hom.coe_comp, add_monoid_hom.coe_mk, add_monoid_hom.to_fun_eq_coe,
      finsupp.single_add_hom_apply, function.comp_app, add_monoid_hom.map_zero,
      finsupp.sum_single_index],
    erw [finsupp.sum_single_index],
    rw [finsupp.single_zero, add_monoid_hom.map_zero],
  end,
  right_inv := λ f,
  begin
    ext i l, dsimp only,
    simp only [add_monoid_hom.to_fun_eq_coe, add_monoid_hom.coe_mk,
      finsupp.sum_single_index, add_monoid_hom.map_zero],
  end }
.

section open profinitely_filtered_pseudo_normed_group polyhedral_lattice pseudo_normed_group
  comphaus_filtered_pseudo_normed_group

lemma Hom_finsupp_equiv_strict [fact (0 < r')]
  (c : ℝ≥0) (f : (polyhedral_lattice.Hom (fin N →₀ Λ) M)) :
  f ∈ filtration (polyhedral_lattice.Hom (fin N →₀ Λ) M) c ↔
  (Λ.Hom_finsupp_equiv N r' M) f ∈ filtration
    (ProFiltPseuNormGrpWithTinv.of r' ((polyhedral_lattice.Hom Λ M) ^ N)) c :=
begin
  split,
  { intros hf i c' l hl,
    refine hf _,
    rw [seminormed_add_comm_group.mem_filtration_iff, finsupp.nnnorm_def, finsupp.sum_single_index],
    { exact hl },
    { exact nnnorm_zero } },
  { intros hf c' l hl,
    let g := (Λ.Hom_finsupp_equiv N r' M) f,
    have hg : (Λ.Hom_finsupp_equiv N r' M).symm g = f := add_equiv.symm_apply_apply _ _,
    rw [seminormed_add_comm_group.mem_filtration_iff, finsupp.nnnorm_def, finsupp.sum_fintype] at hl,
    swap, { intro, exact nnnorm_zero },
    rw [← hg, Hom_finsupp_equiv_symm_apply, add_monoid_hom.coe_mk, finsupp.sum_fintype],
    swap, { intro, exact add_monoid_hom.map_zero _ },
    apply filtration_mono (mul_le_mul' le_rfl hl),
    rw [finset.mul_sum],
    apply sum_mem_filtration,
    rintro i hi,
    apply hf _,
    exact (seminormed_add_comm_group.mem_filtration_iff _ _).mpr rfl.le }
end

lemma Hom_finsupp_equiv_ctu [fact (0 < r')] (c : ℝ≥0) :
  continuous (level (Λ.Hom_finsupp_equiv N r' M)
    (λ c x, (Hom_finsupp_equiv_strict Λ N r' M c x).1) c) :=
begin
  rw continuous_induced_rng,
  rw continuous_pi_iff,
  intro i,
  dsimp only [function.comp],
  rw add_monoid_hom.continuous_iff,
  intro l,
  haveI : fact (c * ∥finsupp.single i l∥₊ ≤ c * ∥l∥₊) := ⟨mul_le_mul' le_rfl $ le_of_eq _⟩,
  { have aux1 := add_monoid_hom.incl_continuous (fin N →₀ Λ) r' M c,
    have aux2 := (continuous_apply (finsupp.single i l)).comp aux1,
    rwa (embedding_cast_le (c * ∥finsupp.single i l∥₊) (c * ∥l∥₊)).continuous_iff at aux2 },
  { rw [finsupp.nnnorm_def, finsupp.sum_single_index], exact nnnorm_zero }
end

end

@[simps]
def Hom_finsupp_iso [fact (0 < r')] :
  polyhedral_lattice.Hom (fin N →₀ Λ) M ≅
  (ProFiltPseuNormGrpWithTinv.of r' $ ((polyhedral_lattice.Hom Λ M) ^ N)) :=
ProFiltPseuNormGrpWithTinv.iso_of_equiv_of_strict' (Hom_finsupp_equiv _ _ _ _)
  (Hom_finsupp_equiv_strict Λ N r' M) (Hom_finsupp_equiv_ctu Λ N r' M)
  (by { intro, ext1, refl })
.

open opposite

section

variables [fact (0 < r')] (N' : ℝ≥0)

def Hom_cosimplicial_zero_iso' :
  (Hom M).obj (op $ of $ rescale N (of (fin N →₀ Λ))) ≅
  (Hom M).obj (op $ (Λ.cosimplicial N).obj (mk 0)) :=
(Hom M).map_iso $ (Cech_conerve.obj_zero_iso _).op

def Hom_cosimplicial_zero_iso_aux (h : N' = N) :
  ProFiltPseuNormGrpWithTinv.of r' (rescale N (polyhedral_lattice.Hom Λ M)) ≅
  (ProFiltPseuNormGrpWithTinv.rescale r' N').obj (polyhedral_lattice.Hom Λ M) :=
begin
  rw h, exact iso.refl _
end

@[simp] lemma Hom_cosimplicial_zero_iso_aux_rfl :
  Hom_cosimplicial_zero_iso_aux Λ N r' M N rfl = iso.refl _ := rfl

def Hom_cosimplicial_zero_iso (h : N' = N) :
  polyhedral_lattice.Hom ((Λ.cosimplicial N).obj (simplex_category.mk 0)) M ≅
  (ProFiltPseuNormGrpWithTinv.of r' (rescale N' ((polyhedral_lattice.Hom Λ M) ^ N))) :=
(Hom_cosimplicial_zero_iso' Λ N r' M).symm ≪≫
/- jmc is not very proud of this -/
(by exact iso.refl _ : _) ≪≫
(Hom_rescale_iso (of (fin N →₀ Λ)) N r' M) ≪≫
Hom_cosimplicial_zero_iso_aux _ _ _ _ _ h ≪≫
(ProFiltPseuNormGrpWithTinv.rescale r' N').map_iso (Hom_finsupp_iso Λ N r' M)

end

variables [fact (0 < r')] [fact (r' ≤ 1)]

open_locale big_operators

def unrescale (N : ℝ≥0) (M : Type*) [profinitely_filtered_pseudo_normed_group M] :
  comphaus_filtered_pseudo_normed_group_hom (rescale N M) M :=
comphaus_filtered_pseudo_normed_group_hom.mk_of_bound (add_monoid_hom.id _) N⁻¹
begin
  intro c,
  refine ⟨λ x hx, _, _⟩,
  { rwa mul_comm },
  { haveI : fact (c * N⁻¹ ≤ N⁻¹ * c) := ⟨(mul_comm _ _).le⟩,
    exact comphaus_filtered_pseudo_normed_group.continuous_cast_le (c * N⁻¹) (N⁻¹ * c) },
end

def rescale_proj (N : ℕ) (M : Type*) [profinitely_filtered_pseudo_normed_group M] (i : fin N) :
  comphaus_filtered_pseudo_normed_group_hom (rescale N (M ^ N)) M :=
(comphaus_filtered_pseudo_normed_group.pi_proj i).comp (unrescale N _)

lemma rescale_proj_bound_by
  (N : ℕ) (M : Type*) [profinitely_filtered_pseudo_normed_group M] (i : fin N) :
  (rescale_proj N M i).bound_by N⁻¹ :=
by { intros c x hx, rw [rescale.mem_filtration, mul_comm] at hx, exact hx i }

def Hom_sum :
  ProFiltPseuNormGrpWithTinv.of r' (rescale N ((Λ →+ M) ^ N)) ⟶
  ProFiltPseuNormGrpWithTinv.of r' (Λ →+ M) :=
profinitely_filtered_pseudo_normed_group_with_Tinv.sum_hom (Λ →+ M) N

lemma Hom_sum_apply (x) : Hom_sum Λ N r' M x = ∑ i, x i :=
profinitely_filtered_pseudo_normed_group_with_Tinv.sum_hom_apply _ _ _

lemma finsupp_sum_diagonal_embedding (f : (Λ →+ M) ^ N) (l : Λ) :
  finsupp.sum ((Λ.diagonal_embedding N) l) (λ i, (f i)) =
  (show Λ → M, from show Λ →+ M, from Λ.Hom_sum N r' M f) l :=
begin
  simp only [add_monoid_hom.coe_mk, Hom_sum_apply],
  rw [finsupp.sum_fintype, add_monoid_hom.finset_sum_apply, fintype.sum_congr],
  { intro i,
    dsimp only [diagonal_embedding, polyhedral_lattice_hom.coe_mk, finsupp.single_add_hom_apply,
      rescale.of, equiv.coe_refl, id],
    simp only [finset.sum_apply', finsupp.single_apply, finset.sum_ite_eq', finset.mem_univ, if_true], },
  { intro i, exact (f i).map_zero }
end

end PolyhedralLattice


/-
Copyright (c) 2021 Anne Baanen. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Anne Baanen

! This file was ported from Lean 3 source module data.fun_like.equiv
! leanprover-community/mathlib commit 448144f7ae193a8990cb7473c9e9a01990f64ac7
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Data.FunLike.Embedding

/-!
# Typeclass for a type `F` with an injective map to `A ≃ B`

> THIS FILE IS SYNCHRONIZED WITH MATHLIB4.
> Any changes to this file require a corresponding PR to mathlib4.

This typeclass is primarily for use by isomorphisms like `monoid_equiv` and `linear_equiv`.

## Basic usage of `equiv_like`

A typical type of morphisms should be declared as:
```
structure my_iso (A B : Type*) [my_class A] [my_class B]
  extends equiv A B :=
(map_op' : ∀ {x y : A}, to_fun (my_class.op x y) = my_class.op (to_fun x) (to_fun y))

namespace my_iso

variables (A B : Type*) [my_class A] [my_class B]

-- This instance is optional if you follow the "Isomorphism class" design below:
instance : equiv_like (my_iso A B) A (λ _, B) :=
{ coe := my_iso.to_equiv.to_fun,
  inv := my_iso.to_equiv.inv_fun,
  left_inv := my_iso.to_equiv.left_inv,
  right_inv := my_iso.to_equiv.right_inv,
  coe_injective' := λ f g h, by cases f; cases g; congr' }

/-- Helper instance for when there's too many metavariables to apply `equiv_like.coe` directly. -/
instance : has_coe_to_fun (my_iso A B) := to_fun.to_coe_fn

@[simp] lemma to_fun_eq_coe {f : my_iso A B} : f.to_fun = (f : A → B) := rfl

@[ext] theorem ext {f g : my_iso A B} (h : ∀ x, f x = g x) : f = g := fun_like.ext f g h

/-- Copy of a `my_iso` with a new `to_fun` equal to the old one. Useful to fix definitional
equalities. -/
protected def copy (f : my_iso A B) (f' : A → B) (f_inv : B → A) (h : f' = ⇑f) : my_iso A B :=
{ to_fun := f',
  inv_fun := f_inv,
  left_inv := h.symm ▸ f.left_inv,
  right_inv := h.symm ▸ f.right_inv,
  map_op' := h.symm ▸ f.map_op' }

end my_iso
```

This file will then provide a `has_coe_to_fun` instance and various
extensionality and simp lemmas.

## Isomorphism classes extending `equiv_like`

The `equiv_like` design provides further benefits if you put in a bit more work.
The first step is to extend `equiv_like` to create a class of those types satisfying
the axioms of your new type of isomorphisms.
Continuing the example above:

```
section
set_option old_structure_cmd true

/-- `my_iso_class F A B` states that `F` is a type of `my_class.op`-preserving morphisms.
You should extend this class when you extend `my_iso`. -/
class my_iso_class (F : Type*) (A B : out_param $ Type*) [my_class A] [my_class B]
  extends equiv_like F A (λ _, B), my_hom_class F A B.

end

-- You can replace `my_iso.equiv_like` with the below instance:
instance : my_iso_class (my_iso A B) A B :=
{ coe := my_iso.to_fun,
  inv := my_iso.inv_fun,
  left_inv := my_iso.left_inv,
  right_inv := my_iso.right_inv,
  coe_injective' := λ f g h, by cases f; cases g; congr',
  map_op := my_iso.map_op' }

-- [Insert `has_coe_to_fun`, `to_fun_eq_coe`, `ext` and `copy` here]
```

The second step is to add instances of your new `my_iso_class` for all types extending `my_iso`.
Typically, you can just declare a new class analogous to `my_iso_class`:

```
structure cooler_iso (A B : Type*) [cool_class A] [cool_class B]
  extends my_iso A B :=
(map_cool' : to_fun cool_class.cool = cool_class.cool)

section
set_option old_structure_cmd true

class cooler_iso_class (F : Type*) (A B : out_param $ Type*) [cool_class A] [cool_class B]
  extends my_iso_class F A B :=
(map_cool : ∀ (f : F), f cool_class.cool = cool_class.cool)

end

@[simp] lemma map_cool {F A B : Type*} [cool_class A] [cool_class B] [cooler_iso_class F A B]
  (f : F) : f cool_class.cool = cool_class.cool :=
my_iso_class.map_op

-- You can also replace `my_iso.equiv_like` with the below instance:
instance : cool_iso_class (cool_iso A B) A B :=
{ coe := cool_iso.to_fun,
  coe_injective' := λ f g h, by cases f; cases g; congr',
  map_op := cool_iso.map_op',
  map_cool := cool_iso.map_cool' }

-- [Insert `has_coe_to_fun`, `to_fun_eq_coe`, `ext` and `copy` here]
```

Then any declaration taking a specific type of morphisms as parameter can instead take the
class you just defined:
```
-- Compare with: lemma do_something (f : my_iso A B) : sorry := sorry
lemma do_something {F : Type*} [my_iso_class F A B] (f : F) : sorry := sorry
```

This means anything set up for `my_iso`s will automatically work for `cool_iso_class`es,
and defining `cool_iso_class` only takes a constant amount of effort,
instead of linearly increasing the work per `my_iso`-related declaration.

-/

/- warning: equiv_like -> EquivLike is a dubious translation:
lean 3 declaration is
  Sort.{u1} -> (outParam.{succ u2} Sort.{u2}) -> (outParam.{succ u3} Sort.{u3}) -> Sort.{max 1 (imax u1 u2 u3) (imax u1 u3 u2)}
but is expected to have type
  Sort.{u1} -> (outParam.{succ u2} Sort.{u2}) -> (outParam.{succ u3} Sort.{u3}) -> Sort.{max (max (max 1 u1) u2) u3}
Case conversion may be inaccurate. Consider using '#align equiv_like EquivLikeₓ'. -/
/-- The class `equiv_like E α β` expresses that terms of type `E` have an
injective coercion to bijections between `α` and `β`.

This typeclass is used in the definition of the homomorphism typeclasses,
such as `zero_equiv_class`, `mul_equiv_class`, `monoid_equiv_class`, ....
-/
class EquivLike (E : Sort _) (α β : outParam (Sort _)) where
  coe : E → α → β
  inv : E → β → α
  left_inv : ∀ e, Function.LeftInverse (inv e) (coe e)
  right_inv : ∀ e, Function.RightInverse (inv e) (coe e)
  -- The `inv` hypothesis makes this easier to prove with `congr'`
  coe_injective' : ∀ e g, coe e = coe g → inv e = inv g → e = g
#align equiv_like EquivLike

namespace EquivLike

variable {E F α β γ : Sort _} [iE : EquivLike E α β] [iF : EquivLike F β γ]

include iE

/- warning: equiv_like.inv_injective -> EquivLike.inv_injective is a dubious translation:
lean 3 declaration is
  forall {E : Sort.{u1}} {α : Sort.{u2}} {β : Sort.{u3}} [iE : EquivLike.{u1, u2, u3} E α β], Function.Injective.{u1, imax u3 u2} E (β -> α) (EquivLike.inv.{u1, u2, u3} E α β iE)
but is expected to have type
  forall {E : Sort.{u3}} {α : Sort.{u1}} {β : Sort.{u2}} [iE : EquivLike.{u3, u1, u2} E α β], Function.Injective.{u3, imax u2 u1} E (β -> α) (EquivLike.inv.{u3, u1, u2} E α β iE)
Case conversion may be inaccurate. Consider using '#align equiv_like.inv_injective EquivLike.inv_injectiveₓ'. -/
theorem inv_injective : Function.Injective (EquivLike.inv : E → β → α) := fun e g h =>
  coe_injective' e g ((right_inv e).eq_rightInverse (h.symm ▸ left_inv g)) h
#align equiv_like.inv_injective EquivLike.inv_injective

#print EquivLike.toEmbeddingLike /-
instance (priority := 100) toEmbeddingLike : EmbeddingLike E α β
    where
  coe := (coe : E → α → β)
  coe_injective' e g h := coe_injective' e g h ((left_inv e).eq_rightInverse (h.symm ▸ right_inv g))
  injective' e := (left_inv e).Injective
#align equiv_like.to_embedding_like EquivLike.toEmbeddingLike
-/

/- warning: equiv_like.injective -> EquivLike.injective is a dubious translation:
lean 3 declaration is
  forall {E : Sort.{u1}} {α : Sort.{u2}} {β : Sort.{u3}} [iE : EquivLike.{u1, u2, u3} E α β] (e : E), Function.Injective.{u2, u3} α β (coeFn.{u1, imax u2 u3} E (fun (_x : E) => α -> β) (FunLike.hasCoeToFun.{u1, u2, u3} E α (fun (_x : α) => β) (EmbeddingLike.toFunLike.{u1, u2, u3} E α β (EquivLike.toEmbeddingLike.{u1, u2, u3} E α β iE))) e)
but is expected to have type
  forall {E : Sort.{u1}} {α : Sort.{u3}} {β : Sort.{u2}} [iE : EquivLike.{u1, u3, u2} E α β] (e : E), Function.Injective.{u3, u2} α β (FunLike.coe.{u1, u3, u2} E α (fun (_x : α) => (fun (x._@.Mathlib.Data.FunLike.Embedding._hyg.19 : α) => β) _x) (EmbeddingLike.toFunLike.{u1, u3, u2} E α β (EquivLike.toEmbeddingLike.{u1, u3, u2} E α β iE)) e)
Case conversion may be inaccurate. Consider using '#align equiv_like.injective EquivLike.injectiveₓ'. -/
protected theorem injective (e : E) : Function.Injective e :=
  EmbeddingLike.injective e
#align equiv_like.injective EquivLike.injective

/- warning: equiv_like.surjective -> EquivLike.surjective is a dubious translation:
lean 3 declaration is
  forall {E : Sort.{u1}} {α : Sort.{u2}} {β : Sort.{u3}} [iE : EquivLike.{u1, u2, u3} E α β] (e : E), Function.Surjective.{u2, u3} α β (coeFn.{u1, imax u2 u3} E (fun (_x : E) => α -> β) (FunLike.hasCoeToFun.{u1, u2, u3} E α (fun (_x : α) => β) (EmbeddingLike.toFunLike.{u1, u2, u3} E α β (EquivLike.toEmbeddingLike.{u1, u2, u3} E α β iE))) e)
but is expected to have type
  forall {E : Sort.{u1}} {α : Sort.{u3}} {β : Sort.{u2}} [iE : EquivLike.{u1, u3, u2} E α β] (e : E), Function.Surjective.{u3, u2} α β (FunLike.coe.{u1, u3, u2} E α (fun (_x : α) => (fun (x._@.Mathlib.Data.FunLike.Embedding._hyg.19 : α) => β) _x) (EmbeddingLike.toFunLike.{u1, u3, u2} E α β (EquivLike.toEmbeddingLike.{u1, u3, u2} E α β iE)) e)
Case conversion may be inaccurate. Consider using '#align equiv_like.surjective EquivLike.surjectiveₓ'. -/
protected theorem surjective (e : E) : Function.Surjective e :=
  (right_inv e).Surjective
#align equiv_like.surjective EquivLike.surjective

/- warning: equiv_like.bijective -> EquivLike.bijective is a dubious translation:
lean 3 declaration is
  forall {E : Sort.{u1}} {α : Sort.{u2}} {β : Sort.{u3}} [iE : EquivLike.{u1, u2, u3} E α β] (e : E), Function.Bijective.{u2, u3} α β (coeFn.{u1, imax u2 u3} E (fun (_x : E) => α -> β) (FunLike.hasCoeToFun.{u1, u2, u3} E α (fun (_x : α) => β) (EmbeddingLike.toFunLike.{u1, u2, u3} E α β (EquivLike.toEmbeddingLike.{u1, u2, u3} E α β iE))) e)
but is expected to have type
  forall {E : Sort.{u1}} {α : Sort.{u3}} {β : Sort.{u2}} [iE : EquivLike.{u1, u3, u2} E α β] (e : E), Function.Bijective.{u3, u2} α β (FunLike.coe.{u1, u3, u2} E α (fun (_x : α) => (fun (x._@.Mathlib.Data.FunLike.Embedding._hyg.19 : α) => β) _x) (EmbeddingLike.toFunLike.{u1, u3, u2} E α β (EquivLike.toEmbeddingLike.{u1, u3, u2} E α β iE)) e)
Case conversion may be inaccurate. Consider using '#align equiv_like.bijective EquivLike.bijectiveₓ'. -/
protected theorem bijective (e : E) : Function.Bijective (e : α → β) :=
  ⟨EquivLike.injective e, EquivLike.surjective e⟩
#align equiv_like.bijective EquivLike.bijective

/- warning: equiv_like.apply_eq_iff_eq -> EquivLike.apply_eq_iff_eq is a dubious translation:
lean 3 declaration is
  forall {E : Sort.{u1}} {α : Sort.{u2}} {β : Sort.{u3}} [iE : EquivLike.{u1, u2, u3} E α β] (f : E) {x : α} {y : α}, Iff (Eq.{u3} β (coeFn.{u1, imax u2 u3} E (fun (_x : E) => α -> β) (FunLike.hasCoeToFun.{u1, u2, u3} E α (fun (_x : α) => β) (EmbeddingLike.toFunLike.{u1, u2, u3} E α β (EquivLike.toEmbeddingLike.{u1, u2, u3} E α β iE))) f x) (coeFn.{u1, imax u2 u3} E (fun (_x : E) => α -> β) (FunLike.hasCoeToFun.{u1, u2, u3} E α (fun (_x : α) => β) (EmbeddingLike.toFunLike.{u1, u2, u3} E α β (EquivLike.toEmbeddingLike.{u1, u2, u3} E α β iE))) f y)) (Eq.{u2} α x y)
but is expected to have type
  forall {E : Sort.{u2}} {α : Sort.{u1}} {β : Sort.{u3}} [iE : EquivLike.{u2, u1, u3} E α β] (f : E) {x : α} {y : α}, Iff (Eq.{u3} ((fun (x._@.Mathlib.Data.FunLike.Embedding._hyg.19 : α) => β) x) (FunLike.coe.{u2, u1, u3} E α (fun (_x : α) => (fun (x._@.Mathlib.Data.FunLike.Embedding._hyg.19 : α) => β) _x) (EmbeddingLike.toFunLike.{u2, u1, u3} E α β (EquivLike.toEmbeddingLike.{u2, u1, u3} E α β iE)) f x) (FunLike.coe.{u2, u1, u3} E α (fun (_x : α) => (fun (x._@.Mathlib.Data.FunLike.Embedding._hyg.19 : α) => β) _x) (EmbeddingLike.toFunLike.{u2, u1, u3} E α β (EquivLike.toEmbeddingLike.{u2, u1, u3} E α β iE)) f y)) (Eq.{u1} α x y)
Case conversion may be inaccurate. Consider using '#align equiv_like.apply_eq_iff_eq EquivLike.apply_eq_iff_eqₓ'. -/
theorem apply_eq_iff_eq (f : E) {x y : α} : f x = f y ↔ x = y :=
  EmbeddingLike.apply_eq_iff_eq f
#align equiv_like.apply_eq_iff_eq EquivLike.apply_eq_iff_eq

/- warning: equiv_like.injective_comp -> EquivLike.injective_comp is a dubious translation:
lean 3 declaration is
  forall {E : Sort.{u1}} {α : Sort.{u2}} {β : Sort.{u3}} {γ : Sort.{u4}} [iE : EquivLike.{u1, u2, u3} E α β] (e : E) (f : β -> γ), Iff (Function.Injective.{u2, u4} α γ (Function.comp.{u2, u3, u4} α β γ f (coeFn.{u1, imax u2 u3} E (fun (_x : E) => α -> β) (FunLike.hasCoeToFun.{u1, u2, u3} E α (fun (_x : α) => β) (EmbeddingLike.toFunLike.{u1, u2, u3} E α β (EquivLike.toEmbeddingLike.{u1, u2, u3} E α β iE))) e))) (Function.Injective.{u3, u4} β γ f)
but is expected to have type
  forall {E : Sort.{u1}} {α : Sort.{u4}} {β : Sort.{u2}} {γ : Sort.{u3}} [iE : EquivLike.{u1, u4, u2} E α β] (e : E) (f : β -> γ), Iff (Function.Injective.{u4, u3} α γ (Function.comp.{u4, u2, u3} α β γ f (FunLike.coe.{u1, u4, u2} E α (fun (_x : α) => (fun (x._@.Mathlib.Data.FunLike.Embedding._hyg.19 : α) => β) _x) (EmbeddingLike.toFunLike.{u1, u4, u2} E α β (EquivLike.toEmbeddingLike.{u1, u4, u2} E α β iE)) e))) (Function.Injective.{u2, u3} β γ f)
Case conversion may be inaccurate. Consider using '#align equiv_like.injective_comp EquivLike.injective_compₓ'. -/
@[simp]
theorem injective_comp (e : E) (f : β → γ) : Function.Injective (f ∘ e) ↔ Function.Injective f :=
  Function.Injective.of_comp_iff' f (EquivLike.bijective e)
#align equiv_like.injective_comp EquivLike.injective_comp

/- warning: equiv_like.surjective_comp -> EquivLike.surjective_comp is a dubious translation:
lean 3 declaration is
  forall {E : Sort.{u1}} {α : Sort.{u2}} {β : Sort.{u3}} {γ : Sort.{u4}} [iE : EquivLike.{u1, u2, u3} E α β] (e : E) (f : β -> γ), Iff (Function.Surjective.{u2, u4} α γ (Function.comp.{u2, u3, u4} α β γ f (coeFn.{u1, imax u2 u3} E (fun (_x : E) => α -> β) (FunLike.hasCoeToFun.{u1, u2, u3} E α (fun (_x : α) => β) (EmbeddingLike.toFunLike.{u1, u2, u3} E α β (EquivLike.toEmbeddingLike.{u1, u2, u3} E α β iE))) e))) (Function.Surjective.{u3, u4} β γ f)
but is expected to have type
  forall {E : Sort.{u1}} {α : Sort.{u4}} {β : Sort.{u2}} {γ : Sort.{u3}} [iE : EquivLike.{u1, u4, u2} E α β] (e : E) (f : β -> γ), Iff (Function.Surjective.{u4, u3} α γ (Function.comp.{u4, u2, u3} α β γ f (FunLike.coe.{u1, u4, u2} E α (fun (_x : α) => (fun (x._@.Mathlib.Data.FunLike.Embedding._hyg.19 : α) => β) _x) (EmbeddingLike.toFunLike.{u1, u4, u2} E α β (EquivLike.toEmbeddingLike.{u1, u4, u2} E α β iE)) e))) (Function.Surjective.{u2, u3} β γ f)
Case conversion may be inaccurate. Consider using '#align equiv_like.surjective_comp EquivLike.surjective_compₓ'. -/
@[simp]
theorem surjective_comp (e : E) (f : β → γ) : Function.Surjective (f ∘ e) ↔ Function.Surjective f :=
  (EquivLike.surjective e).of_comp_iff f
#align equiv_like.surjective_comp EquivLike.surjective_comp

/- warning: equiv_like.bijective_comp -> EquivLike.bijective_comp is a dubious translation:
lean 3 declaration is
  forall {E : Sort.{u1}} {α : Sort.{u2}} {β : Sort.{u3}} {γ : Sort.{u4}} [iE : EquivLike.{u1, u2, u3} E α β] (e : E) (f : β -> γ), Iff (Function.Bijective.{u2, u4} α γ (Function.comp.{u2, u3, u4} α β γ f (coeFn.{u1, imax u2 u3} E (fun (_x : E) => α -> β) (FunLike.hasCoeToFun.{u1, u2, u3} E α (fun (_x : α) => β) (EmbeddingLike.toFunLike.{u1, u2, u3} E α β (EquivLike.toEmbeddingLike.{u1, u2, u3} E α β iE))) e))) (Function.Bijective.{u3, u4} β γ f)
but is expected to have type
  forall {E : Sort.{u1}} {α : Sort.{u4}} {β : Sort.{u2}} {γ : Sort.{u3}} [iE : EquivLike.{u1, u4, u2} E α β] (e : E) (f : β -> γ), Iff (Function.Bijective.{u4, u3} α γ (Function.comp.{u4, u2, u3} α β γ f (FunLike.coe.{u1, u4, u2} E α (fun (_x : α) => (fun (x._@.Mathlib.Data.FunLike.Embedding._hyg.19 : α) => β) _x) (EmbeddingLike.toFunLike.{u1, u4, u2} E α β (EquivLike.toEmbeddingLike.{u1, u4, u2} E α β iE)) e))) (Function.Bijective.{u2, u3} β γ f)
Case conversion may be inaccurate. Consider using '#align equiv_like.bijective_comp EquivLike.bijective_compₓ'. -/
@[simp]
theorem bijective_comp (e : E) (f : β → γ) : Function.Bijective (f ∘ e) ↔ Function.Bijective f :=
  (EquivLike.bijective e).of_comp_iff f
#align equiv_like.bijective_comp EquivLike.bijective_comp

/- warning: equiv_like.inv_apply_apply -> EquivLike.inv_apply_apply is a dubious translation:
lean 3 declaration is
  forall {E : Sort.{u1}} {α : Sort.{u2}} {β : Sort.{u3}} [iE : EquivLike.{u1, u2, u3} E α β] (e : E) (a : α), Eq.{u2} α (EquivLike.inv.{u1, u2, u3} E α β iE e (coeFn.{u1, imax u2 u3} E (fun (_x : E) => α -> β) (FunLike.hasCoeToFun.{u1, u2, u3} E α (fun (_x : α) => β) (EmbeddingLike.toFunLike.{u1, u2, u3} E α β (EquivLike.toEmbeddingLike.{u1, u2, u3} E α β iE))) e a)) a
but is expected to have type
  forall {E : Sort.{u2}} {α : Sort.{u3}} {β : Sort.{u1}} [iE : EquivLike.{u2, u3, u1} E α β] (e : E) (a : α), Eq.{u3} α (EquivLike.inv.{u2, u3, u1} E α ((fun (x._@.Mathlib.Data.FunLike.Embedding._hyg.19 : α) => β) a) iE e (FunLike.coe.{u2, u3, u1} E α (fun (_x : α) => (fun (x._@.Mathlib.Data.FunLike.Embedding._hyg.19 : α) => β) _x) (EmbeddingLike.toFunLike.{u2, u3, u1} E α β (EquivLike.toEmbeddingLike.{u2, u3, u1} E α β iE)) e a)) a
Case conversion may be inaccurate. Consider using '#align equiv_like.inv_apply_apply EquivLike.inv_apply_applyₓ'. -/
/-- This lemma is only supposed to be used in the generic context, when working with instances
of classes extending `equiv_like`.
For concrete isomorphism types such as `equiv`, you should use `equiv.symm_apply_apply`
or its equivalent.

TODO: define a generic form of `equiv.symm`. -/
@[simp]
theorem inv_apply_apply (e : E) (a : α) : EquivLike.inv e (e a) = a :=
  left_inv _ _
#align equiv_like.inv_apply_apply EquivLike.inv_apply_apply

/- warning: equiv_like.apply_inv_apply -> EquivLike.apply_inv_apply is a dubious translation:
lean 3 declaration is
  forall {E : Sort.{u1}} {α : Sort.{u2}} {β : Sort.{u3}} [iE : EquivLike.{u1, u2, u3} E α β] (e : E) (b : β), Eq.{u3} β (coeFn.{u1, imax u2 u3} E (fun (_x : E) => α -> β) (FunLike.hasCoeToFun.{u1, u2, u3} E α (fun (_x : α) => β) (EmbeddingLike.toFunLike.{u1, u2, u3} E α β (EquivLike.toEmbeddingLike.{u1, u2, u3} E α β iE))) e (EquivLike.inv.{u1, u2, u3} E α β iE e b)) b
but is expected to have type
  forall {E : Sort.{u2}} {α : Sort.{u1}} {β : Sort.{u3}} [iE : EquivLike.{u2, u1, u3} E α β] (e : E) (b : β), Eq.{u3} ((fun (x._@.Mathlib.Data.FunLike.Embedding._hyg.19 : α) => β) (EquivLike.inv.{u2, u1, u3} E α β iE e b)) (FunLike.coe.{u2, u1, u3} E α (fun (_x : α) => (fun (x._@.Mathlib.Data.FunLike.Embedding._hyg.19 : α) => β) _x) (EmbeddingLike.toFunLike.{u2, u1, u3} E α β (EquivLike.toEmbeddingLike.{u2, u1, u3} E α β iE)) e (EquivLike.inv.{u2, u1, u3} E α β iE e b)) b
Case conversion may be inaccurate. Consider using '#align equiv_like.apply_inv_apply EquivLike.apply_inv_applyₓ'. -/
/-- This lemma is only supposed to be used in the generic context, when working with instances
of classes extending `equiv_like`.
For concrete isomorphism types such as `equiv`, you should use `equiv.apply_symm_apply`
or its equivalent.

TODO: define a generic form of `equiv.symm`. -/
@[simp]
theorem apply_inv_apply (e : E) (b : β) : e (EquivLike.inv e b) = b :=
  right_inv _ _
#align equiv_like.apply_inv_apply EquivLike.apply_inv_apply

omit iE

include iF

/- warning: equiv_like.comp_injective -> EquivLike.comp_injective is a dubious translation:
lean 3 declaration is
  forall {F : Sort.{u1}} {α : Sort.{u2}} {β : Sort.{u3}} {γ : Sort.{u4}} [iF : EquivLike.{u1, u3, u4} F β γ] (f : α -> β) (e : F), Iff (Function.Injective.{u2, u4} α γ (Function.comp.{u2, u3, u4} α β γ (coeFn.{u1, imax u3 u4} F (fun (_x : F) => β -> γ) (FunLike.hasCoeToFun.{u1, u3, u4} F β (fun (_x : β) => γ) (EmbeddingLike.toFunLike.{u1, u3, u4} F β γ (EquivLike.toEmbeddingLike.{u1, u3, u4} F β γ iF))) e) f)) (Function.Injective.{u2, u3} α β f)
but is expected to have type
  forall {F : Sort.{u1}} {α : Sort.{u4}} {β : Sort.{u2}} {γ : Sort.{u3}} [iF : EquivLike.{u1, u2, u3} F β γ] (f : α -> β) (e : F), Iff (Function.Injective.{u4, u3} α γ (Function.comp.{u4, u2, u3} α β γ (FunLike.coe.{u1, u2, u3} F β (fun (_x : β) => (fun (x._@.Mathlib.Data.FunLike.Embedding._hyg.19 : β) => γ) _x) (EmbeddingLike.toFunLike.{u1, u2, u3} F β γ (EquivLike.toEmbeddingLike.{u1, u2, u3} F β γ iF)) e) f)) (Function.Injective.{u4, u2} α β f)
Case conversion may be inaccurate. Consider using '#align equiv_like.comp_injective EquivLike.comp_injectiveₓ'. -/
theorem comp_injective (f : α → β) (e : F) : Function.Injective (e ∘ f) ↔ Function.Injective f :=
  EmbeddingLike.comp_injective f e
#align equiv_like.comp_injective EquivLike.comp_injective

/- warning: equiv_like.comp_surjective -> EquivLike.comp_surjective is a dubious translation:
lean 3 declaration is
  forall {F : Sort.{u1}} {α : Sort.{u2}} {β : Sort.{u3}} {γ : Sort.{u4}} [iF : EquivLike.{u1, u3, u4} F β γ] (f : α -> β) (e : F), Iff (Function.Surjective.{u2, u4} α γ (Function.comp.{u2, u3, u4} α β γ (coeFn.{u1, imax u3 u4} F (fun (_x : F) => β -> γ) (FunLike.hasCoeToFun.{u1, u3, u4} F β (fun (_x : β) => γ) (EmbeddingLike.toFunLike.{u1, u3, u4} F β γ (EquivLike.toEmbeddingLike.{u1, u3, u4} F β γ iF))) e) f)) (Function.Surjective.{u2, u3} α β f)
but is expected to have type
  forall {F : Sort.{u1}} {α : Sort.{u4}} {β : Sort.{u2}} {γ : Sort.{u3}} [iF : EquivLike.{u1, u2, u3} F β γ] (f : α -> β) (e : F), Iff (Function.Surjective.{u4, u3} α γ (Function.comp.{u4, u2, u3} α β γ (FunLike.coe.{u1, u2, u3} F β (fun (_x : β) => (fun (x._@.Mathlib.Data.FunLike.Embedding._hyg.19 : β) => γ) _x) (EmbeddingLike.toFunLike.{u1, u2, u3} F β γ (EquivLike.toEmbeddingLike.{u1, u2, u3} F β γ iF)) e) f)) (Function.Surjective.{u4, u2} α β f)
Case conversion may be inaccurate. Consider using '#align equiv_like.comp_surjective EquivLike.comp_surjectiveₓ'. -/
@[simp]
theorem comp_surjective (f : α → β) (e : F) : Function.Surjective (e ∘ f) ↔ Function.Surjective f :=
  Function.Surjective.of_comp_iff' (EquivLike.bijective e) f
#align equiv_like.comp_surjective EquivLike.comp_surjective

/- warning: equiv_like.comp_bijective -> EquivLike.comp_bijective is a dubious translation:
lean 3 declaration is
  forall {F : Sort.{u1}} {α : Sort.{u2}} {β : Sort.{u3}} {γ : Sort.{u4}} [iF : EquivLike.{u1, u3, u4} F β γ] (f : α -> β) (e : F), Iff (Function.Bijective.{u2, u4} α γ (Function.comp.{u2, u3, u4} α β γ (coeFn.{u1, imax u3 u4} F (fun (_x : F) => β -> γ) (FunLike.hasCoeToFun.{u1, u3, u4} F β (fun (_x : β) => γ) (EmbeddingLike.toFunLike.{u1, u3, u4} F β γ (EquivLike.toEmbeddingLike.{u1, u3, u4} F β γ iF))) e) f)) (Function.Bijective.{u2, u3} α β f)
but is expected to have type
  forall {F : Sort.{u1}} {α : Sort.{u4}} {β : Sort.{u2}} {γ : Sort.{u3}} [iF : EquivLike.{u1, u2, u3} F β γ] (f : α -> β) (e : F), Iff (Function.Bijective.{u4, u3} α γ (Function.comp.{u4, u2, u3} α β γ (FunLike.coe.{u1, u2, u3} F β (fun (_x : β) => (fun (x._@.Mathlib.Data.FunLike.Embedding._hyg.19 : β) => γ) _x) (EmbeddingLike.toFunLike.{u1, u2, u3} F β γ (EquivLike.toEmbeddingLike.{u1, u2, u3} F β γ iF)) e) f)) (Function.Bijective.{u4, u2} α β f)
Case conversion may be inaccurate. Consider using '#align equiv_like.comp_bijective EquivLike.comp_bijectiveₓ'. -/
@[simp]
theorem comp_bijective (f : α → β) (e : F) : Function.Bijective (e ∘ f) ↔ Function.Bijective f :=
  (EquivLike.bijective e).of_comp_iff' f
#align equiv_like.comp_bijective EquivLike.comp_bijective

#print EquivLike.subsingleton_dom /-
/-- This is not an instance to avoid slowing down every single `subsingleton` typeclass search.-/
theorem subsingleton_dom [Subsingleton β] : Subsingleton F :=
  ⟨fun f g => FunLike.ext f g fun x => (right_inv f).Injective <| Subsingleton.elim _ _⟩
#align equiv_like.subsingleton_dom EquivLike.subsingleton_dom
-/

end EquivLike


/-
Copyright (c) 2020 Adam Topaz. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Adam Topaz, Bhavik Mehta
-/

import category_theory.adjunction.reflective
import topology.stone_cech
import category_theory.monad.limits
import topology.urysohns_lemma
import topology.category.Top.limits

/-!
# The category of Compact Hausdorff Spaces

We construct the category of compact Hausdorff spaces.
The type of compact Hausdorff spaces is denoted `CompHaus`, and it is endowed with a category
instance making it a full subcategory of `Top`.
The fully faithful functor `CompHaus ⥤ Top` is denoted `CompHaus_to_Top`.

**Note:** The file `topology/category/Compactum.lean` provides the equivalence between `Compactum`,
which is defined as the category of algebras for the ultrafilter monad, and `CompHaus`.
`Compactum_to_CompHaus` is the functor from `Compactum` to `CompHaus` which is proven to be an
equivalence of categories in `Compactum_to_CompHaus.is_equivalence`.
See `topology/category/Compactum.lean` for a more detailed discussion where these definitions are
introduced.

-/

universes v u

open category_theory

/-- The type of Compact Hausdorff topological spaces. -/
structure CompHaus :=
(to_Top : Top)
[is_compact : compact_space to_Top]
[is_hausdorff : t2_space to_Top]

namespace CompHaus

instance : inhabited CompHaus := ⟨{to_Top := { α := pempty }}⟩

instance : has_coe_to_sort CompHaus Type* := ⟨λ X, X.to_Top⟩
instance {X : CompHaus} : compact_space X := X.is_compact
instance {X : CompHaus} : t2_space X := X.is_hausdorff

instance category : category CompHaus := induced_category.category to_Top

instance concrete_category : concrete_category CompHaus :=
induced_category.concrete_category _

@[simp]
lemma coe_to_Top {X : CompHaus} : (X.to_Top : Type*) = X :=
rfl

variables (X : Type*) [topological_space X] [compact_space X] [t2_space X]

/-- A constructor for objects of the category `CompHaus`,
taking a type, and bundling the compact Hausdorff topology
found by typeclass inference. -/
def of : CompHaus :=
{ to_Top := Top.of X,
  is_compact := ‹_›,
  is_hausdorff := ‹_› }

@[simp] lemma coe_of : (CompHaus.of X : Type _) = X := rfl

/-- Any continuous function on compact Hausdorff spaces is a closed map. -/
lemma is_closed_map {X Y : CompHaus.{u}} (f : X ⟶ Y) : is_closed_map f :=
λ C hC, (hC.is_compact.image f.continuous).is_closed

/-- Any continuous bijection of compact Hausdorff spaces is an isomorphism. -/
lemma is_iso_of_bijective {X Y : CompHaus.{u}} (f : X ⟶ Y) (bij : function.bijective f) :
  is_iso f :=
begin
  let E := equiv.of_bijective _ bij,
  have hE : continuous E.symm,
  { rw continuous_iff_is_closed,
    intros S hS,
    rw ← E.image_eq_preimage,
    exact is_closed_map f S hS },
  refine ⟨⟨⟨E.symm, hE⟩, _, _⟩⟩,
  { ext x,
    apply E.symm_apply_apply },
  { ext x,
    apply E.apply_symm_apply }
end

/-- Any continuous bijection of compact Hausdorff spaces induces an isomorphism. -/
noncomputable
def iso_of_bijective {X Y : CompHaus.{u}} (f : X ⟶ Y) (bij : function.bijective f) : X ≅ Y :=
by letI := is_iso_of_bijective _ bij; exact as_iso f

end CompHaus

/-- The fully faithful embedding of `CompHaus` in `Top`. -/
@[simps {rhs_md := semireducible}, derive [full, faithful]]
def CompHaus_to_Top : CompHaus.{u} ⥤ Top.{u} := induced_functor _

instance CompHaus.forget_reflects_isomorphisms : reflects_isomorphisms (forget CompHaus.{u}) :=
⟨by introsI A B f hf; exact CompHaus.is_iso_of_bijective _ ((is_iso_iff_bijective f).mp hf)⟩

/--
(Implementation) The object part of the compactification functor from topological spaces to
compact Hausdorff spaces.
-/
@[simps]
def StoneCech_obj (X : Top) : CompHaus := CompHaus.of (stone_cech X)

/--
(Implementation) The bijection of homsets to establish the reflective adjunction of compact
Hausdorff spaces in topological spaces.
-/
noncomputable def stone_cech_equivalence (X : Top.{u}) (Y : CompHaus.{u}) :
  (StoneCech_obj X ⟶ Y) ≃ (X ⟶ CompHaus_to_Top.obj Y) :=
{ to_fun := λ f,
  { to_fun := f ∘ stone_cech_unit,
    continuous_to_fun := f.2.comp (@continuous_stone_cech_unit X _) },
  inv_fun := λ f,
  { to_fun := stone_cech_extend f.2,
    continuous_to_fun := continuous_stone_cech_extend f.2 },
  left_inv :=
  begin
    rintro ⟨f : stone_cech X ⟶ Y, hf : continuous f⟩,
    ext (x : stone_cech X),
    refine congr_fun _ x,
    apply continuous.ext_on dense_range_stone_cech_unit (continuous_stone_cech_extend _) hf,
    rintro _ ⟨y, rfl⟩,
    apply congr_fun (stone_cech_extend_extends (hf.comp _)) y,
  end,
  right_inv :=
  begin
    rintro ⟨f : (X : Type*) ⟶ Y, hf : continuous f⟩,
    ext,
    exact congr_fun (stone_cech_extend_extends hf) _,
  end }

/--
The Stone-Cech compactification functor from topological spaces to compact Hausdorff spaces,
left adjoint to the inclusion functor.
-/
noncomputable def Top_to_CompHaus : Top.{u} ⥤ CompHaus.{u} :=
adjunction.left_adjoint_of_equiv stone_cech_equivalence.{u} (λ _ _ _ _ _, rfl)

lemma Top_to_CompHaus_obj (X : Top) : ↥(Top_to_CompHaus.obj X) = stone_cech X :=
rfl

/--
The category of compact Hausdorff spaces is reflective in the category of topological spaces.
-/
noncomputable instance CompHaus_to_Top.reflective : reflective CompHaus_to_Top :=
{ to_is_right_adjoint := ⟨Top_to_CompHaus, adjunction.adjunction_of_equiv_left _ _⟩ }

noncomputable instance CompHaus_to_Top.creates_limits : creates_limits CompHaus_to_Top :=
monadic_creates_limits _

instance CompHaus.has_limits : limits.has_limits CompHaus :=
has_limits_of_has_limits_creates_limits CompHaus_to_Top

instance CompHaus.has_colimits : limits.has_colimits CompHaus :=
has_colimits_of_reflective CompHaus_to_Top

namespace CompHaus

/-- An explicit limit cone for a functor `F : J ⥤ CompHaus`, defined in terms of
`Top.limit_cone`. -/
def limit_cone {J : Type v} [small_category J] (F : J ⥤ CompHaus.{max v u}) :
  limits.cone F :=
{ X :=
  { to_Top := (Top.limit_cone (F ⋙ CompHaus_to_Top)).X,
    is_compact := begin
      show compact_space ↥{u : Π j, (F.obj j) | ∀ {i j : J} (f : i ⟶ j), (F.map f) (u i) = u j},
      rw ← is_compact_iff_compact_space,
      apply is_closed.is_compact,
      have : {u : Π j, F.obj j | ∀ {i j : J} (f : i ⟶ j), F.map f (u i) = u j} =
        ⋂ (i j : J) (f : i ⟶ j), {u | F.map f (u i) = u j},
      { ext1, simp only [set.mem_Inter, set.mem_set_of_eq], },
      rw this,
      apply is_closed_Inter, intros i,
      apply is_closed_Inter, intros j,
      apply is_closed_Inter, intros f,
      apply is_closed_eq,
      { exact (continuous_map.continuous (F.map f)).comp (continuous_apply i), },
      { exact continuous_apply j, }
    end,
    is_hausdorff :=
      show t2_space ↥{u : Π j, (F.obj j) | ∀ {i j : J} (f : i ⟶ j), (F.map f) (u i) = u j},
      from infer_instance },
  π :=
  { app := λ j, (Top.limit_cone (F ⋙ CompHaus_to_Top)).π.app j,
    naturality' := by { intros _ _ _, ext ⟨x, hx⟩,
      simp only [comp_apply, functor.const_obj_map, id_apply], exact (hx f).symm, } } }

/-- The limit cone `CompHaus.limit_cone F` is indeed a limit cone. -/
def limit_cone_is_limit {J : Type v} [small_category J] (F : J ⥤ CompHaus.{max v u}) :
  limits.is_limit (limit_cone F) :=
{ lift := λ S,
    (Top.limit_cone_is_limit (F ⋙ CompHaus_to_Top)).lift (CompHaus_to_Top.map_cone S),
  uniq' := λ S m h, (Top.limit_cone_is_limit _).uniq (CompHaus_to_Top.map_cone S) _ h }

lemma epi_iff_surjective {X Y : CompHaus.{u}} (f : X ⟶ Y) : epi f ↔ function.surjective f :=
begin
  split,
  { contrapose!,
    rintros ⟨y, hy⟩ hf,
    let C := set.range f,
    have hC : is_closed C := (is_compact_range f.continuous).is_closed,
    let D := {y},
    have hD : is_closed D := is_closed_singleton,
    have hCD : disjoint C D,
    { rw set.disjoint_singleton_right, rintro ⟨y', hy'⟩, exact hy y' hy' },
    haveI : normal_space ↥(Y.to_Top) := normal_of_compact_t2,
    obtain ⟨φ, hφ0, hφ1, hφ01⟩ := exists_continuous_zero_one_of_closed hC hD hCD,
    haveI : compact_space (ulift.{u} $ set.Icc (0:ℝ) 1) := homeomorph.ulift.symm.compact_space,
    haveI : t2_space (ulift.{u} $ set.Icc (0:ℝ) 1) := homeomorph.ulift.symm.t2_space,
    let Z := of (ulift.{u} $ set.Icc (0:ℝ) 1),
    let g : Y ⟶ Z := ⟨λ y', ⟨⟨φ y', hφ01 y'⟩⟩,
      continuous_ulift_up.comp (φ.continuous.subtype_mk (λ y', hφ01 y'))⟩,
    let h : Y ⟶ Z := ⟨λ _, ⟨⟨0, set.left_mem_Icc.mpr zero_le_one⟩⟩, continuous_const⟩,
    have H : h = g,
    { rw ← cancel_epi f,
      ext x, dsimp,
      simp only [comp_apply, continuous_map.coe_mk, subtype.coe_mk, hφ0 (set.mem_range_self x),
        pi.zero_apply], },
    apply_fun (λ e, (e y).down) at H,
    dsimp at H,
    simp only [subtype.mk_eq_mk, hφ1 (set.mem_singleton y), pi.one_apply] at H,
    exact zero_ne_one H, },
  { rw ← category_theory.epi_iff_surjective,
    apply (forget CompHaus).epi_of_epi_map }
end

lemma mono_iff_injective {X Y : CompHaus.{u}} (f : X ⟶ Y) : mono f ↔ function.injective f :=
begin
  split,
  { introsI hf x₁ x₂ h,
    let g₁ : of punit ⟶ X := ⟨λ _, x₁, continuous_const⟩,
    let g₂ : of punit ⟶ X := ⟨λ _, x₂, continuous_const⟩,
    have : g₁ ≫ f = g₂ ≫ f, by { ext, exact h },
    rw cancel_mono at this,
    apply_fun (λ e, e punit.star) at this,
    exact this },
  { rw ← category_theory.mono_iff_injective,
    apply (forget CompHaus).mono_of_mono_map }
end

end CompHaus


/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.tactic.norm_num
import Mathlib.PostPort

universes u_1 l

namespace Mathlib

/-!
# The `abel` tactic

Evaluate expressions in the language of additive, commutative monoids and groups.

-/

namespace tactic

namespace abel

def term {α : Type u_1} [add_comm_monoid α] (n : ℕ) (x : α) (a : α) : α := n •ℕ x + a

def termg {α : Type u_1} [add_comm_group α] (n : ℤ) (x : α) (a : α) : α := n •ℤ x + a

theorem const_add_term {α : Type u_1} [add_comm_monoid α] (k : α) (n : ℕ) (x : α) (a : α) (a' : α)
    (h : k + a = a') : k + term n x a = term n x a' :=
  sorry

theorem const_add_termg {α : Type u_1} [add_comm_group α] (k : α) (n : ℤ) (x : α) (a : α) (a' : α)
    (h : k + a = a') : k + termg n x a = termg n x a' :=
  sorry

theorem term_add_const {α : Type u_1} [add_comm_monoid α] (n : ℕ) (x : α) (a : α) (k : α) (a' : α)
    (h : a + k = a') : term n x a + k = term n x a' :=
  sorry

theorem term_add_constg {α : Type u_1} [add_comm_group α] (n : ℤ) (x : α) (a : α) (k : α) (a' : α)
    (h : a + k = a') : termg n x a + k = termg n x a' :=
  sorry

theorem term_add_term {α : Type u_1} [add_comm_monoid α] (n₁ : ℕ) (x : α) (a₁ : α) (n₂ : ℕ) (a₂ : α)
    (n' : ℕ) (a' : α) (h₁ : n₁ + n₂ = n') (h₂ : a₁ + a₂ = a') :
    term n₁ x a₁ + term n₂ x a₂ = term n' x a' :=
  sorry

theorem term_add_termg {α : Type u_1} [add_comm_group α] (n₁ : ℤ) (x : α) (a₁ : α) (n₂ : ℤ) (a₂ : α)
    (n' : ℤ) (a' : α) (h₁ : n₁ + n₂ = n') (h₂ : a₁ + a₂ = a') :
    termg n₁ x a₁ + termg n₂ x a₂ = termg n' x a' :=
  sorry

theorem zero_term {α : Type u_1} [add_comm_monoid α] (x : α) (a : α) : term 0 x a = a := sorry

theorem zero_termg {α : Type u_1} [add_comm_group α] (x : α) (a : α) : termg 0 x a = a := sorry

theorem term_neg {α : Type u_1} [add_comm_group α] (n : ℤ) (x : α) (a : α) (n' : ℤ) (a' : α)
    (h₁ : -n = n') (h₂ : -a = a') : -termg n x a = termg n' x a' :=
  sorry

def smul {α : Type u_1} [add_comm_monoid α] (n : ℕ) (x : α) : α := n •ℕ x

def smulg {α : Type u_1} [add_comm_group α] (n : ℤ) (x : α) : α := n •ℤ x

theorem zero_smul {α : Type u_1} [add_comm_monoid α] (c : ℕ) : smul c 0 = 0 := sorry

theorem zero_smulg {α : Type u_1} [add_comm_group α] (c : ℤ) : smulg c 0 = 0 := sorry

theorem term_smul {α : Type u_1} [add_comm_monoid α] (c : ℕ) (n : ℕ) (x : α) (a : α) (n' : ℕ)
    (a' : α) (h₁ : c * n = n') (h₂ : smul c a = a') : smul c (term n x a) = term n' x a' :=
  sorry

theorem term_smulg {α : Type u_1} [add_comm_group α] (c : ℤ) (n : ℤ) (x : α) (a : α) (n' : ℤ)
    (a' : α) (h₁ : c * n = n') (h₂ : smulg c a = a') : smulg c (termg n x a) = termg n' x a' :=
  sorry

theorem term_atom {α : Type u_1} [add_comm_monoid α] (x : α) : x = term 1 x 0 := sorry

theorem term_atomg {α : Type u_1} [add_comm_group α] (x : α) : x = termg 1 x 0 := sorry

theorem unfold_sub {α : Type u_1} [add_group α] (a : α) (b : α) (c : α) (h : a + -b = c) :
    a - b = c :=
  eq.mpr (id (Eq._oldrec (Eq.refl (a - b = c)) (sub_eq_add_neg a b)))
    (eq.mpr (id (Eq._oldrec (Eq.refl (a + -b = c)) h)) (Eq.refl c))

theorem unfold_smul {α : Type u_1} [add_comm_monoid α] (n : ℕ) (x : α) (y : α) (h : smul n x = y) :
    n •ℕ x = y :=
  h

theorem unfold_smulg {α : Type u_1} [add_comm_group α] (n : ℕ) (x : α) (y : α)
    (h : smulg (Int.ofNat n) x = y) : n •ℕ x = y :=
  h

theorem unfold_gsmul {α : Type u_1} [add_comm_group α] (n : ℤ) (x : α) (y : α) (h : smulg n x = y) :
    n •ℤ x = y :=
  h

theorem subst_into_smul {α : Type u_1} [add_comm_monoid α] (l : ℕ) (r : α) (tl : ℕ) (tr : α) (t : α)
    (prl : l = tl) (prr : r = tr) (prt : smul tl tr = t) : smul l r = t :=
  sorry

theorem subst_into_smulg {α : Type u_1} [add_comm_group α] (l : ℤ) (r : α) (tl : ℤ) (tr : α) (t : α)
    (prl : l = tl) (prr : r = tr) (prt : smulg tl tr = t) : smulg l r = t :=
  sorry

inductive normalize_mode where
| raw : normalize_mode
| term : normalize_mode

protected instance normalize_mode.inhabited : Inhabited normalize_mode :=
  { default := normalize_mode.term }

end abel

namespace interactive

/-- Tactic for solving equations in the language of
*additive*, commutative monoids and groups.
This version of `abel` fails if the target is not an equality
that is provable by the axioms of commutative monoids/groups. -/
/--
Evaluate expressions in the language of *additive*, commutative monoids and groups.
It attempts to prove the goal outright if there is no `at`
specifier and the target is an equality, but if this
fails, it falls back to rewriting all monoid expressions into a normal form.
If there is an `at` specifier, it rewrites the given target into a normal form.
```lean
example {α : Type*} {a b : α} [add_comm_monoid α] : a + (b + a) = a + a + b := by abel
example {α : Type*} {a b : α} [add_comm_group α] : (a + b) - ((b + a) + a) = -a := by abel
example {α : Type*} {a b : α} [add_comm_group α] (hyp : a + a - a = b - b) : a = 0 :=
by { abel at hyp, exact hyp }
```
-/
end Mathlib


import tactic
import formula
import utils

section witness_counter

  variables {ι : Type}  {gri : ground_interpretation ι}
  local notation `𝔽` := formula ι gri
  local notation `𝕋` := type ι gri
  variables {greq : Π {i : ι}, ∥𝕏 i // gri ∥ → ∥𝕏 i // gri ∥ → 𝔽}
  local infixr `≅` : 35 := formula.eqext @greq

  namespace formula

  @[simp]
  def mwc : 𝔽 → Type × Type
  -- does not allow simply `prime p` (probably a bug in the equation compiler)
  | (@prime _ _ p _) := (unit, unit)
  | (A ⋀ B) := (A.mwc.1 × B.mwc.1, A.mwc.2 × B.mwc.2)
  | (A ⋁ B) := (A.mwc.1 ⊕ B.mwc.1, A.mwc.2 × B.mwc.2)
  | (A ⟹ B) := ((A.mwc.1 → B.mwc.2 → A.mwc.2) × ((A.mwc.1 → B.mwc.1)), A.mwc.1 × B.mwc.2)
  | (universal' σ A) := ((Π x : ∥σ∥, (A x).mwc.1), (Σ x : ∥σ∥, (A x).mwc.2))
  | (existential' σ A) := ((Σ x : ∥σ∥, (A x).mwc.1), (Π x : ∥σ∥, (A x).mwc.1 → (A x).mwc.2))

  @[reducible, simp, pp_nodot]
  def 𝕎 (A : 𝔽) : Type := A.mwc.1
  @[reducible, simp, pp_nodot]
  def ℂ (A : 𝔽) : Type := A.mwc.2

  -- mutual def 𝕎, ℂ
  -- with 𝕎 : 𝔽 → Type
  -- | (prime p) := unit
  -- | (A ⋀ B) := 𝕎 A × 𝕎 B
  -- | (A ⋁ B) := 𝕎 A ⊕ 𝕎 B
  -- | (A ⟹ B) := (𝕎 A → ℂ B → ℂ A) × (𝕎 A → 𝕎 B)
  -- | (universal' σ A) := Π x : ∥σ∥, 𝕎 (A x)
  -- | (existential' σ A) := Σ x : ∥σ∥, 𝕎 (A x)
  -- with ℂ : 𝔽 → Type
  -- | (prime p) := unit
  -- | (A ⋀ B) := ℂ A × ℂ B
  -- | (A ⋁ B) := ℂ A × ℂ B
  -- | (A ⟹ B) := 𝕎 A × ℂ B
  -- | (universal' σ A) := Σ x : ∥σ∥, 𝕎 (A x) → ℂ (A x)
  -- | (existential' σ A) := Π x : ∥σ∥, 𝕎 (A x) → ℂ (A x)

  def mwc_inh : Π A : 𝔽, A.𝕎 × A.ℂ
  | (@prime _ _ p _) := (unit.star, unit.star)
  | (A ⋀ B) := ((A.mwc_inh.1, B.mwc_inh.1), (A.mwc_inh.2, B.mwc_inh.2))
  | (A ⋁ B) := (sum.inl A.mwc_inh.1, (A.mwc_inh.2, B.mwc_inh.2)) --ugly noncanonicity
  | (A ⟹ B) := (((λ _ _, A.mwc_inh.2), (λ _, B.mwc_inh.1)), (A.mwc_inh.1, B.mwc_inh.2))
  | (universal' σ A) := ((λ x, (A x).mwc_inh.1), ⟨σ.inh, (A σ.inh).mwc_inh.2⟩)
  | (existential' σ A) := (⟨σ.inh, (A σ.inh).mwc_inh.1⟩, (λ x _, (A x).mwc_inh.2))

  def 𝕎_inh (A : 𝔽) : A.𝕎 := A.mwc_inh.1
  def ℂ_inh (A : 𝔽) : A.ℂ := A.mwc_inh.2

  def 𝕎_inh' {A : 𝔽} := 𝕎_inh A
  def ℂ_inh' {A : 𝔽} := ℂ_inh A

  end formula

end witness_counter

section dialectica

  variables {ι : Type}  {gri : ground_interpretation ι}
  local notation `𝔽` := formula ι gri
  local notation `𝕋` := type ι gri
  variables {greq : Π {i : ι}, ∥𝕏 i // gri ∥ → ∥𝕏 i // gri ∥ → 𝔽}
  local infixr `≅` : 35 := formula.eqext @greq

  namespace formula

  @[simp]
  def dia : Π (A : 𝔽), A.𝕎 → A.ℂ → Prop
  | (@prime _ _ p _) x y := p
  | (A ⋀ B) x y := (A.dia x.1 y.1) ∧ (B.dia x.2 y.2)
  | (A ⋁ B) x y :=
    match x with
    | sum.inl xA := A.dia xA y.1
    | sum.inr xB := B.dia xB y.2
    end
  | (A ⟹ B) x y := (A.dia y.1 (x.1 y.1 y.2)) → (B.dia (x.2 y.1) y.2)
  | (universal A) x y := (A y.1).dia (x y.1) y.2
  | (existential A) x y := (A x.1).dia x.2 (y x.1 x.2)

  @[reducible, simp]
  def Dia (A : 𝔽) := ∃ x : 𝕎 A, ∀ y : ℂ A, A.dia x y

  --# TODO: better name
  inductive is_gamma2 : 𝔽 → Prop
  | of_prime (p : Prop) [decidable p] : is_gamma2 (prime p)
  | of_conjunction (A B : 𝔽) : is_gamma2 A → is_gamma2 B → is_gamma2 (A ⋀ B)
  | of_disjunction (A B : 𝔽) : is_gamma2 A → is_gamma2 B → is_gamma2 (A ⋁ B)
  | of_universal {σ : 𝕋} (A : ∥σ∥ → 𝔽) : (∀ x : ∥σ∥, is_gamma2 (A x)) → is_gamma2 (universal A)

  @[reducible, simp]
  def is_gamma2_like (A : 𝔽) : Prop := A.Dia → ∥A∥

  @[simp]
  lemma dia_disj_left (A B : 𝔽) (x : A.𝕎) (y : (A ⋁ B).ℂ) : (A ⋁ B).dia (sum.inl x) y ↔ A.dia x y.1 :=
    by simp

  @[simp]
  lemma dia_disj_right (A B : 𝔽) (x : B.𝕎) (y : (A ⋁ B).ℂ) : (A ⋁ B).dia (sum.inr x) y ↔ B.dia x y.2 :=
    by simp

  end formula

  @[simp]
  def dia.realizer (A : 𝔽) := {t : A.𝕎 // ∀ y : A.ℂ, A.dia t y}

  instance dia.decidable (A : 𝔽) (x : A.𝕎) (y : A.ℂ) : decidable (A.dia x y) :=
  begin
    induction A,
    case prime
    { assumption, },
    case conjunction: A B ihA ihB
    {
      simp only [formula.dia],
      specialize ihA x.fst y.fst,
      specialize ihB x.snd y.snd,
      exact @and.decidable _ _ ihA ihB,
    },
    case disjunction: A B ihA ihB {
      simp only [formula.dia],
      dsimp only [formula.mwc, formula.𝕎] at x,
      cases x,
      case sum.inl
      { exact ihA x y.fst, },
      { exact ihB x y.snd, },
    },
    case implication: A B ihA ihB {
      simp only [formula.dia],
      specialize ihA y.fst (x.fst y.fst y.snd),
      specialize ihB (x.snd y.fst) y.snd,
      refine @implies.decidable _ _ ihA ihB,
    },
    case universal: σ A ihA {
      simp only [formula.dia],
      dsimp at x y,
      exact ihA y.fst (x y.fst) y.snd,
    },
    case existential: σ A ihA {
      simp only [formula.dia],
      dsimp at x y,
      exact ihA x.fst x.snd (y x.fst x.snd),
    }
  end

  lemma dia_not_not (A : 𝔽) (x : A.𝕎) (y : A.ℂ) : ¬¬(A.dia x y) ↔ A.dia x y :=
    iff.intro
    (λ h, if h' : A.dia x y then h' else false.elim (h h'))
    (λ h h', h' h)

  def Dia_of_realizer {A : 𝔽} : dia.realizer A → A.Dia :=
    λ r, ⟨r.val, r.property⟩

  lemma interpretation_of_gamma2_Dia {A : 𝔽} (gA : A.is_gamma2) : A.Dia → ∥A∥ :=
  begin
    induction gA; intros h,
    case of_prime: p decp {
      dsimp at *,
      simp at *,
      exact h,
    },
    case of_conjunction: B C gB gC ihB ihC {
      dsimp at *, simp at *,
      rcases h with ⟨w, ⟨w', h⟩⟩,
      refine ⟨ihB w (λ y, (h y formula.ℂ_inh').1), ihC w' (λ y, (h formula.ℂ_inh' y).2)⟩,
    },
    case of_disjunction: B C gB gC ihB ihC {
      dsimp at *, simp at *,
      cases h,
      {
        rcases h with ⟨w, h⟩,
        refine or.inl (ihB w (λ y, h y formula.ℂ_inh')),
      },
      {
        rcases h with ⟨w, h⟩,
        refine or.inr (ihC w (λ y, h formula.ℂ_inh' y)),
      }
    },
    case of_universal: σ B gB ihB {
      dsimp at *, simp at *,
      intros a,
      rcases h with ⟨w, h⟩,
      specialize h a,
      dsimp only at h,
      exact ihB a (w a) h,
    }
  end

  example (A : 𝔽) : ∥A∥ → A.Dia :=
  begin
    induction A; intros h,
    case prime: p decp {
      dsimp at *, simp at *,
      exact h,
    },
    case conjunction: B C ihB ihC {
      dsimp at *, simp at *,
      specialize ihB h.1,
      specialize ihC h.2,
      rcases ihB with ⟨wB, hB⟩,
      rcases ihC with ⟨wC, hC⟩,
      use wB, use wC,
      tidy?,
    },
    case disjunction: B C ihB ihC {
      dsimp at *, simp at *,
      cases h,
      {
        specialize ihB h,
        rcases ihB with ⟨wB, hB⟩,
        left,
        use wB,
        tidy?,
      },
      {
        specialize ihC h,
        rcases ihC with ⟨wC, hC⟩,
        right,
        use wC,
        tidy?,
      }
    },
    case universal: σ B ihB {
      dsimp at *, simp at *,
      specialize ihB h,
    }
  end

end dialectica

section kinds_of_formulas

  variables {ι : Type} {gri : ground_interpretation ι}
  local notation `𝔽` := formula ι gri
  local notation `𝕋` := type ι gri
  variables {greq : Π {i : ι}, ∥𝕏 i // gri ∥ → ∥𝕏 i // gri ∥ → 𝔽}
  local infixr `≅` : 35 := formula.eqext @greq

  section

    @[class, reducible]
    def dia_trivial (A : 𝔽) := unique A.𝕎 × unique A.ℂ

    variables {A B : 𝔽} [inst : dia_trivial A] [dia_trivial B]

    instance : unique A.𝕎 := inst.1
    instance : unique A.ℂ := inst.2

    local attribute [reducible] formula.mwc formula.𝕎 formula.ℂ

    instance dia_trivial_prime {p : Prop} [decp : decidable p] : dia_trivial (formula.prime p : 𝔽) :=
    ⟨infer_instance, infer_instance⟩

    instance dia_trivial_conjunction {A B : 𝔽} [dia_trivial A] [dia_trivial B] : dia_trivial (A ⋀ B) :=
    ⟨infer_instance, infer_instance⟩

    instance dia_trivial_implication {A B : 𝔽} [dia_trivial A] [dia_trivial B] : dia_trivial (A ⟹ B) :=
    ⟨infer_instance, infer_instance⟩

    -- immediate
    instance dia_trivial_of_qf_disj_free {A : 𝔽} (qfA : A.is_qf_disj_free) : dia_trivial A :=
    sorry

  end

  section

    def Dia_iff_interp (A : 𝔽) : Prop := A.Dia ↔ ∥A∥

    lemma Dia_iff_interp_of_dia_trivial (A : 𝔽) [dia_trivial A] : Dia_iff_interp A :=
    begin
      split; intros h,
      {
        ss [formula.Dia] at h,
      }
    end

  end

  /-
  todo:
    there is a class of formulas for which A.Dia ↔ ∥A∥
    there is a class of formulas for which unique A.𝕎 and A.ℂ

  -/

  example (A : 𝔽) : A.is_qf_disj_free → subsingleton A.𝕎 :=
  begin
    sorry, --easy
  end

  @[instance]
  lemma trivial_witness_of_purely_univ_disj_free (A : 𝔽) : A.purely_univ_disj_free → subsingleton A.𝕎 :=
  begin
    intros h,
    induction h,
    case of_qf_disj_free: B qfB {
      sorry, --easy
    },
    case of_univ: σ B qfB ih {
      simp only [formula.𝕎, formula.mwc],
      by_ext a b x,
      specialize ih x,
      exact subsingleton_iff.mp ih (a x) (b x),
    }
  end

  lemma dia_iff_interpretation_of_purely_univ_disj_free (A : 𝔽) : A.purely_univ_disj_free → ((∃ x, ∀ y, A.dia x y) ↔ ∥A∥) :=
  begin
    intros h,
    induction h,
    case of_univ: σ B univ ih {
      split,
      {
        intros a x,
        specialize ih x,
        rw ←ih,
        tidy?,
      },
      {
        intros hB,
        have : subsingleton (Π x : ∥σ∥, (B x).𝕎) :=
        begin
          by_ext a b x,
          have : subsingleton (B x).𝕎 := sorry,
          exact subsingleton_iff.mp this (a x) (b x),
        end,
        dsimp only [formula.ℂ, formula.𝕎, formula.dia],
        set w := λ x, (B x).𝕎_inh,
        use w,
        intros y,
        specialize ih y.1,
        rcases ih with ⟨ihl, ihr⟩,
        dsimp at hB,
        specialize hB y.1,
        specialize ihr hB,
        rcases ihr with ⟨w', ihr⟩,
        specialize ihr y.2,
        have : w' = w y.1 :=
        begin
          -- apply @subsingleton.elim _ (this _),
          sorry,
          -- ??? question: is it the case that
          -- subsingleton (Π x : α, β x) → ∀ x : α, subsingleton (β x) ???
        end
      }
    }

    -- induction A,
    -- case universal: σ B ih {
    --   dsimp only at ih,
    --   dsimp [formula.mwc, formula.𝕎, formula.ℂ] at *,
    --   split,
    --   {
    --     intros a x,
    --     specialize ih x sorry,
    --     rw ←ih,
    --     tidy?,
    --   },
    --   {
    --     intros a,
    --     have : subsingleton (Π (x : σ.interpret), (B x).mwc.fst) :=
    --     begin
    --       apply subsingleton.intro,
    --       intros a b,
    --       ext x,
    --       have : subsingleton (B x).𝕎 := sorry,
    --       exact subsingleton_iff.mp this (a x) (b x),
    --     end
    --   }
    -- }
  end

end kinds_of_formulas

section eqext_in_relation_to_dialectica

  variables {ι : Type} {gri : ground_interpretation ι}
  local notation `𝕋` := type ι gri
  local notation `𝔽` := formula ι gri

  structure admissible_greq (gre : Π {i : ι}, ∥𝕏 i // gri∥ → ∥𝕏 i // gri∥ → 𝔽) :=
  (trivial_witness : ∀ (i : ι) (a b : ∥𝕏 i∥), subsingleton (gre a b).𝕎)
  (gamma2 : ∀ (i : ι) (a b : ∥𝕏 i∥), (gre a b).is_gamma2)
  (greq_iff_eq : ∀ (i : ι) (a b : ∥𝕏 i∥), ∥gre a b∥ ↔ a = b)

  variables {greq : Π {i : ι}, ∥𝕏 i // gri∥ → ∥𝕏 i // gri∥ → 𝔽}
  local infixl `≅` : 35 := formula.eqext @greq

  -- local attribute [simp] formula.dia formula.mwc formula.𝕎 formula.\bbC
  lemma trivial_witness_eqext {σ : 𝕋} (x y : ∥σ∥) (admissible : admissible_greq @greq) : subsingleton (x ≅ y).𝕎 :=
  begin
    induction σ,
    case zero {
      exact punit.subsingleton,
    },
    case ground: i {
      apply admissible.trivial_witness,
    },
    case arrow: ρ τ ihρ ihτ{
      simp only [formula.mwc, formula.𝕎, formula.eqext] at *,
      dsimp only [type.interpret] at *,
      fsplit,
      intros a b,
      ext1 z,
      exact subsingleton_iff.mp (ihτ (x z) (y z)) (a z) (b z),
    },
    case times: ρ τ ihρ ihτ {
      simp only [formula.𝕎, formula.eqext, formula.mwc] at *,
      dsimp only [type.interpret] at *,
      rcases x with ⟨x₁, x₂⟩,
      rcases y with ⟨y₁, y₂⟩,
      specialize ihρ x₁ y₁,
      specialize ihτ x₂ y₂,
      dsimp only at *,
      fsplit,
      rintros ⟨a₁, a₂⟩ ⟨b₁, b₂⟩,
      simp only [prod.mk.inj_iff] at *,
      fsplit,
      { exact subsingleton_iff.mp ihρ a₁ b₁, },
      { exact subsingleton_iff.mp ihτ a₂ b₂, },
    }
  end

  lemma gamma2_eqext {σ : 𝕋} (x y : ∥σ∥) (admissible : admissible_greq @greq) : (x ≅ y).is_gamma2 :=
  begin
    induction σ,
    case ground: i {
      exact admissible.gamma2 _ _ _,
    },
    all_goals { constructor, },
    all_goals { tidy?, },
  end

  lemma eqext_iff_eq {σ : 𝕋} (x y : ∥σ∥) (admissible : admissible_greq @greq) : ∥x ≅ y∥ ↔ x = y :=
  begin
    split,
    {
      induction σ; intros h,
      case zero {
          simpa,
      },
      case ground: i {
        apply (admissible.greq_iff_eq _ _ _).1,
        simpa,
      },
      case arrow: τ ρ ihτ ihρ {
        ss at h,
        ext z,
        specialize h z,
        specialize ihρ (x z) (y z),
        exact ihρ h,
      },
      case times: τ ρ ihτ ihρ {
        simp only [formula.eqext, formula.interpret] at h,
        rcases h with ⟨h₁, h₂⟩,
        dsimp only [type.interpret] at *,
        rcases x with ⟨x₁, x₂⟩,
        rcases y with ⟨y₁, y₂⟩,
        simp only [prod.mk.inj_iff],
        simp only at h₁ h₂,
        split,
        { exact ihτ _ _ h₁, },
        { exact ihρ _ _ h₂, },
      },
    },
    {
      induction σ; intros h,
      case zero {
        simp *,
      },
      case ground: i {
        apply (admissible.greq_iff_eq _ _ _).2,
        exact h,
      },
      case arrow: τ ρ ihτ ihρ {
        subst h,
        dsimp,
        intros z,
        exact ihρ (x z) (x z) rfl,
      },
      case times: τ ρ ihτ ihρ {
        ss at *,
        dsimp' at *,
        cases x with x₁ x₂,
        cases y with y₁ y₂,
        cases h with h₁ h₂,
        ss at *,
        split,
        { exact ihτ _ _ rfl, },
        { exact ihρ _ _ rfl, },
      }
    }
  end

  -- set_option trace.simplify.rewrite true
  -- lemma eqext_Dia_iff_eq {σ : 𝕋} (a b : ∥σ∥) (admissible : admissible_greq @greq) :
  --   (a ≅ b).Dia ↔ a = b :=
  -- begin
  --   split,
  --   {
  --     induction σ,
  --     case zero {
  --       intros h,
  --       dsimp only [formula.eqext, type.interpret, formula.Dia, formula.mwc, formula.𝕎, formula.ℂ, formula.dia] at h,
  --       simp only [forall_const, exists_const] at h,
  --       exact h,
  --     },
  --     case ground: i {
  --       intros h,
  --       apply (admissible.greq_Dia_iff_eq i a b).1,
  --       exact h,
  --     },
  --     case arrow: ρ τ ihρ ihτ {
  --       intros h,
  --       dsimp at h,
  --     }
  --   }
  -- end

  -- lemma eqext_dia_iff_eq {σ : 𝕋} (a b : ∥σ∥) (admissible : admissible_greq @greq) :
  --   (∀ (x : (a ≅ b).𝕎) (y : (a ≅ b).ℂ), (a ≅ b).dia x y) ↔ a = b :=
  -- begin
  --   split,
  --   {
  --     induction σ,
  --     case zero {
  --       intros h,
  --       dsimp only [formula.ℂ, type.interpret, formula.dia, formula.𝕎, formula.eqext, formula.mwc] at *,
  --       exact h unit.star unit.star,
  --     },
  --     case ground: i {
  --       apply (admissible.greq_dia_iff_eq i a b).1,
  --     },
  --     case arrow: ρ τ ihρ ihτ {
  --       intros h,
  --       change ∀ z, _ at h,
  --       ext u,
  --       specialize ihτ (a u) (b u),
  --       apply ihτ,
  --       intros x y,
  --       specialize h (λ x, formula.𝕎_inh _),
  --       specialize h ⟨u, y⟩,
  --       dsimp only [formula.dia, formula.eqext] at h,
  --       have : x = formula.𝕎_inh _ := by {
  --         have := trivial_witness_eqext (a u) (b u) admissible,
  --         exact subsingleton_iff.mp this x (formula.eqext @greq (a u) (b u)).𝕎_inh,
  --       },
  --       rw ←this at h,
  --       apply h,
  --     }
  --   },
  --   {
  --     intros heq x y,
  --     subst heq,
  --     induction σ,
  --     case zero {
  --       dsimp,
  --       refl,
  --     },
  --     case ground: i {
  --       have := (admissible.greq_dia_iff_eq i a a).2,
  --       apply this,
  --       refl,
  --     },
  --     case arrow: ρ τ ihρ ihτ {
  --       cases y,
  --       dsimp only [formula.ℂ, formula.𝕎, formula.dia, formula.eqext, type.interpret, formula.mwc] at *,
  --       solve_by_elim,
  --     },
  --   }
  -- end

  lemma eq_of_eqext_realizer {σ : 𝕋} (admissible : admissible_greq @greq) (a b : ∥σ∥) : dia.realizer (a ≅ b) → a = b :=
  begin
    intros r,
    have p1 := Dia_of_realizer r,
    have p2 : (a ≅ b).is_gamma2 := gamma2_eqext _ _ admissible,
    have p3 := interpretation_of_gamma2_Dia p2 p1,
    exact (eqext_iff_eq _ _ admissible).1 p3,
  end

end eqext_in_relation_to_dialectica


/-
Copyright (c) 2017 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.propext
import Mathlib.Lean3Lib.init.classical

universes u

namespace Mathlib

/- Lemmas use by the congruence closure module -/

theorem iff_eq_of_eq_true_left {a : Prop} {b : Prop} (h : a = True) : (a ↔ b) = b :=
  Eq.symm h ▸ propext (true_iff b)

theorem iff_eq_of_eq_true_right {a : Prop} {b : Prop} (h : b = True) : (a ↔ b) = a :=
  Eq.symm h ▸ propext (iff_true a)

theorem iff_eq_true_of_eq {a : Prop} {b : Prop} (h : a = b) : (a ↔ b) = True :=
  h ▸ propext (iff_self a)

theorem and_eq_of_eq_true_left {a : Prop} {b : Prop} (h : a = True) : (a ∧ b) = b :=
  Eq.symm h ▸ propext (true_and b)

theorem and_eq_of_eq_true_right {a : Prop} {b : Prop} (h : b = True) : (a ∧ b) = a :=
  Eq.symm h ▸ propext (and_true a)

theorem and_eq_of_eq_false_left {a : Prop} {b : Prop} (h : a = False) : (a ∧ b) = False :=
  Eq.symm h ▸ propext (false_and b)

theorem and_eq_of_eq_false_right {a : Prop} {b : Prop} (h : b = False) : (a ∧ b) = False :=
  Eq.symm h ▸ propext (and_false a)

theorem and_eq_of_eq {a : Prop} {b : Prop} (h : a = b) : (a ∧ b) = a := h ▸ propext (and_self a)

theorem or_eq_of_eq_true_left {a : Prop} {b : Prop} (h : a = True) : (a ∨ b) = True :=
  Eq.symm h ▸ propext (true_or b)

theorem or_eq_of_eq_true_right {a : Prop} {b : Prop} (h : b = True) : (a ∨ b) = True :=
  Eq.symm h ▸ propext (or_true a)

theorem or_eq_of_eq_false_left {a : Prop} {b : Prop} (h : a = False) : (a ∨ b) = b :=
  Eq.symm h ▸ propext (false_or b)

theorem or_eq_of_eq_false_right {a : Prop} {b : Prop} (h : b = False) : (a ∨ b) = a :=
  Eq.symm h ▸ propext (or_false a)

theorem or_eq_of_eq {a : Prop} {b : Prop} (h : a = b) : (a ∨ b) = a := h ▸ propext (or_self a)

theorem imp_eq_of_eq_true_left {a : Prop} {b : Prop} (h : a = True) : (a → b) = b :=
  Eq.symm h ▸
    propext { mp := fun (h : True → b) => h trivial, mpr := fun (h₁ : b) (h₂ : True) => h₁ }

theorem imp_eq_of_eq_true_right {a : Prop} {b : Prop} (h : b = True) : (a → b) = True :=
  Eq.symm h ▸ propext { mp := fun (h : a → True) => trivial, mpr := fun (h₁ : True) (h₂ : a) => h₁ }

theorem imp_eq_of_eq_false_left {a : Prop} {b : Prop} (h : a = False) : (a → b) = True :=
  Eq.symm h ▸
    propext
      { mp := fun (h : False → b) => trivial, mpr := fun (h₁ : True) (h₂ : False) => false.elim h₂ }

theorem imp_eq_of_eq_false_right {a : Prop} {b : Prop} (h : b = False) : (a → b) = (¬a) :=
  Eq.symm h ▸ propext { mp := fun (h : a → False) => h, mpr := fun (hna : ¬a) (ha : a) => hna ha }

/- Remark: the congruence closure module will only use the following lemma is
   cc_config.em is tt. -/

theorem not_imp_eq_of_eq_false_right {a : Prop} {b : Prop} (h : b = False) : (¬a → b) = a := sorry

theorem imp_eq_true_of_eq {a : Prop} {b : Prop} (h : a = b) : (a → b) = True :=
  h ▸ propext { mp := fun (h : a → a) => trivial, mpr := fun (h : True) (ha : a) => ha }

theorem not_eq_of_eq_true {a : Prop} (h : a = True) : (¬a) = False :=
  Eq.symm h ▸ propext not_true_iff

theorem not_eq_of_eq_false {a : Prop} (h : a = False) : (¬a) = True :=
  Eq.symm h ▸ propext not_false_iff

theorem false_of_a_eq_not_a {a : Prop} (h : a = (¬a)) : False :=
  (fun (this : ¬a) => absurd (eq.mpr h this) this) fun (ha : a) => absurd ha (eq.mp h ha)

theorem if_eq_of_eq_true {c : Prop} [d : Decidable c] {α : Sort u} (t : α) (e : α) (h : c = True) :
    ite c t e = t :=
  if_pos (of_eq_true h)

theorem if_eq_of_eq_false {c : Prop} [d : Decidable c] {α : Sort u} (t : α) (e : α)
    (h : c = False) : ite c t e = e :=
  if_neg (not_of_eq_false h)

theorem if_eq_of_eq (c : Prop) [d : Decidable c] {α : Sort u} {t : α} {e : α} (h : t = e) :
    ite c t e = t :=
  sorry

theorem eq_true_of_and_eq_true_left {a : Prop} {b : Prop} (h : (a ∧ b) = True) : a = True :=
  eq_true_intro (and.left (of_eq_true h))

theorem eq_true_of_and_eq_true_right {a : Prop} {b : Prop} (h : (a ∧ b) = True) : b = True :=
  eq_true_intro (and.right (of_eq_true h))

theorem eq_false_of_or_eq_false_left {a : Prop} {b : Prop} (h : (a ∨ b) = False) : a = False :=
  eq_false_intro fun (ha : a) => false.elim (eq.mp h (Or.inl ha))

theorem eq_false_of_or_eq_false_right {a : Prop} {b : Prop} (h : (a ∨ b) = False) : b = False :=
  eq_false_intro fun (hb : b) => false.elim (eq.mp h (Or.inr hb))

theorem eq_false_of_not_eq_true {a : Prop} (h : (¬a) = True) : a = False :=
  eq_false_intro fun (ha : a) => absurd ha (eq.mpr h trivial)

/- Remark: the congruence closure module will only use the following lemma is
   cc_config.em is tt. -/

theorem eq_true_of_not_eq_false {a : Prop} (h : (¬a) = False) : a = True :=
  eq_true_intro (classical.by_contradiction fun (hna : ¬a) => eq.mp h hna)

theorem ne_of_eq_of_ne {α : Sort u} {a : α} {b : α} {c : α} (h₁ : a = b) (h₂ : b ≠ c) : a ≠ c :=
  Eq.symm h₁ ▸ h₂

theorem ne_of_ne_of_eq {α : Sort u} {a : α} {b : α} {c : α} (h₁ : a ≠ b) (h₂ : b = c) : a ≠ c :=
  h₂ ▸ h₁

end Mathlib


/-
Copyright (c) 2018 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon, Patrick Massot, Eric Wieser
-/
import algebra.group.prod
import group_theory.group_action.defs

/-!
# Prod instances for additive and multiplicative actions

This file defines instances for binary product of additive and multiplicative actions and provides
scalar multiplication as a homomorphism from `α × β` to `β`.

## Main declarations

* `smul_mul_hom`/`smul_monoid_hom`: Scalar multiplication bundled as a multiplicative/monoid
  homomorphism.
-/

variables {M N P α β : Type*}

namespace prod

section

variables [has_scalar M α] [has_scalar M β] [has_scalar N α] [has_scalar N β] (a : M) (x : α × β)

@[to_additive prod.has_vadd] instance : has_scalar M (α × β) := ⟨λa p, (a • p.1, a • p.2)⟩

@[simp, to_additive] theorem smul_fst : (a • x).1 = a • x.1 := rfl
@[simp, to_additive] theorem smul_snd : (a • x).2 = a • x.2 := rfl
@[simp, to_additive] theorem smul_mk (a : M) (b : α) (c : β) : a • (b, c) = (a • b, a • c) := rfl
@[to_additive] theorem smul_def (a : M) (x : α × β) : a • x = (a • x.1, a • x.2) := rfl

instance [has_scalar M N] [is_scalar_tower M N α] [is_scalar_tower M N β] :
  is_scalar_tower M N (α × β) :=
⟨λ x y z, mk.inj_iff.mpr ⟨smul_assoc _ _ _, smul_assoc _ _ _⟩⟩

@[to_additive] instance [smul_comm_class M N α] [smul_comm_class M N β] :
  smul_comm_class M N (α × β) :=
{ smul_comm := λ r s x, mk.inj_iff.mpr ⟨smul_comm _ _ _, smul_comm _ _ _⟩ }

instance [has_scalar Mᵐᵒᵖ α] [has_scalar Mᵐᵒᵖ β] [is_central_scalar M α] [is_central_scalar M β] :
  is_central_scalar M (α × β) :=
⟨λ r m, prod.ext (op_smul_eq_smul _ _) (op_smul_eq_smul _ _)⟩

@[to_additive has_faithful_vadd_left]
instance has_faithful_scalar_left [has_faithful_scalar M α] [nonempty β] :
  has_faithful_scalar M (α × β) :=
⟨λ x y h, let ⟨b⟩ := ‹nonempty β› in eq_of_smul_eq_smul $ λ a : α, by injection h (a, b)⟩

@[to_additive has_faithful_vadd_right]
instance has_faithful_scalar_right [nonempty α] [has_faithful_scalar M β] :
  has_faithful_scalar M (α × β) :=
⟨λ x y h, let ⟨a⟩ := ‹nonempty α› in eq_of_smul_eq_smul $ λ b : β, by injection h (a, b)⟩

end

@[to_additive]
instance smul_comm_class_both [monoid N] [monoid P] [has_scalar M N] [has_scalar M P]
  [smul_comm_class M N N] [smul_comm_class M P P] :
  smul_comm_class M (N × P) (N × P) :=
⟨λ c x y, by simp [smul_def, mul_def, mul_smul_comm]⟩

instance is_scalar_tower_both [monoid N] [monoid P] [has_scalar M N] [has_scalar M P]
  [is_scalar_tower M N N] [is_scalar_tower M P P] :
  is_scalar_tower M (N × P) (N × P) :=
⟨λ c x y, by simp [smul_def, mul_def, smul_mul_assoc]⟩

@[to_additive] instance {m : monoid M} [mul_action M α] [mul_action M β] : mul_action M (α × β) :=
{ mul_smul  := λ a₁ a₂ p, mk.inj_iff.mpr ⟨mul_smul _ _ _, mul_smul _ _ _⟩,
  one_smul  := λ ⟨b, c⟩, mk.inj_iff.mpr ⟨one_smul _ _, one_smul _ _⟩ }

instance {R M N : Type*} {r : monoid R} [add_monoid M] [add_monoid N]
  [distrib_mul_action R M] [distrib_mul_action R N] : distrib_mul_action R (M × N) :=
{ smul_add  := λ a p₁ p₂, mk.inj_iff.mpr ⟨smul_add _ _ _, smul_add _ _ _⟩,
  smul_zero := λ a, mk.inj_iff.mpr ⟨smul_zero _, smul_zero _⟩ }

instance {R M N : Type*} {r : monoid R} [monoid M] [monoid N]
  [mul_distrib_mul_action R M] [mul_distrib_mul_action R N] : mul_distrib_mul_action R (M × N) :=
{ smul_mul  := λ a p₁ p₂, mk.inj_iff.mpr ⟨smul_mul' _ _ _, smul_mul' _ _ _⟩,
  smul_one := λ a, mk.inj_iff.mpr ⟨smul_one _, smul_one _⟩ }

end prod

/-! ### Scalar multiplication as a homomorphism -/

section bundled_smul

/-- Scalar multiplication as a multiplicative homomorphism. -/
@[simps]
def smul_mul_hom [monoid α] [has_mul β] [mul_action α β] [is_scalar_tower α β β]
  [smul_comm_class α β β] :
  mul_hom (α × β) β :=
{ to_fun := λ a, a.1 • a.2,
  map_mul' := λ a b, (smul_mul_smul _ _ _ _).symm }

/-- Scalar multiplication as a monoid homomorphism. -/
@[simps]
def smul_monoid_hom [monoid α] [mul_one_class β] [mul_action α β] [is_scalar_tower α β β]
  [smul_comm_class α β β] :
  α × β →* β :=
{ map_one' := one_smul _ _,
  .. smul_mul_hom }

end bundled_smul