/-
Copyright (c) 2021 Andrew Yang. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Andrew Yang
-/
import category_theory.sites.limits
import category_theory.functor.flat
import category_theory.limits.preserves.filtered

/-!
# Cover-preserving functors between sites.

We define cover-preserving functors between sites as functors that push covering sieves to
covering sieves. A cover-preserving and compatible-preserving functor `G : C ⥤ D` then pulls
sheaves on `D` back to sheaves on `C` via `G.op ⋙ -`.

## Main definitions

* `category_theory.cover_preserving`: a functor between sites is cover-preserving if it
pushes covering sieves to covering sieves
* `category_theory.compatible_preserving`: a functor between sites is compatible-preserving
if it pushes compatible families of elements to compatible families.
* `category_theory.pullback_sheaf`: the pullback of a sheaf along a cover-preserving and
compatible-preserving functor.
* `category_theory.sites.pullback`: the induced functor `Sheaf K A ⥤ Sheaf J A` for a
cover-preserving and compatible-preserving functor `G : (C, J) ⥤ (D, K)`.

## Main results

- `category_theory.sites.whiskering_left_is_sheaf_of_cover_preserving`: If `G : C ⥤ D` is
cover-preserving and compatible-preserving, then `G ⋙ -` (`uᵖ`) as a functor
`(Dᵒᵖ ⥤ A) ⥤ (Cᵒᵖ ⥤ A)` of presheaves maps sheaves to sheaves.

## References

* [Elephant]: *Sketches of an Elephant*, P. T. Johnstone: C2.3.
* https://stacks.math.columbia.edu/tag/00WW

-/

universes w v₁ v₂ v₃ u₁ u₂ u₃
noncomputable theory

open category_theory
open opposite
open category_theory.presieve.family_of_elements
open category_theory.presieve
open category_theory.limits

namespace category_theory
variables {C : Type u₁} [category.{v₁} C] {D : Type u₂} [category.{v₂} D]
variables {A : Type u₃} [category.{v₃} A]
variables (J : grothendieck_topology C) (K : grothendieck_topology D)
variables {L : grothendieck_topology A}

/--
A functor `G : (C, J) ⥤ (D, K)` between sites is *cover-preserving*
if for all covering sieves `R` in `C`, `R.pushforward_functor G` is a covering sieve in `D`.
-/
@[nolint has_nonempty_instance]
structure cover_preserving (G : C ⥤ D) : Prop :=
(cover_preserve : ∀ {U : C} {S : sieve U} (hS : S ∈ J U), S.functor_pushforward G ∈ K (G.obj U))

/-- The identity functor on a site is cover-preserving. -/
lemma id_cover_preserving : cover_preserving J J (𝟭 _) := ⟨λ U S hS, by simpa using hS⟩

variables (J) (K)

/-- The composition of two cover-preserving functors is cover-preserving. -/
lemma cover_preserving.comp {F} (hF : cover_preserving J K F) {G} (hG : cover_preserving K L G) :
  cover_preserving J L (F ⋙ G) := ⟨λ U S hS,
begin
  rw sieve.functor_pushforward_comp,
  exact hG.cover_preserve (hF.cover_preserve hS)
end⟩

/--
A functor `G : (C, J) ⥤ (D, K)` between sites is called compatible preserving if for each
compatible family of elements at `C` and valued in `G.op ⋙ ℱ`, and each commuting diagram
`f₁ ≫ G.map g₁ = f₂ ≫ G.map g₂`, `x g₁` and `x g₂` coincide when restricted via `fᵢ`.
This is actually stronger than merely preserving compatible families because of the definition of
`functor_pushforward` used.
-/
@[nolint has_nonempty_instance]
structure compatible_preserving (K : grothendieck_topology D) (G : C ⥤ D) : Prop :=
(compatible :
  ∀ (ℱ : SheafOfTypes.{w} K) {Z} {T : presieve Z}
    {x : family_of_elements (G.op ⋙ ℱ.val) T} (h : x.compatible)
    {Y₁ Y₂} {X} (f₁ : X ⟶ G.obj Y₁) (f₂ : X ⟶ G.obj Y₂) {g₁ : Y₁ ⟶ Z} {g₂ : Y₂ ⟶ Z}
    (hg₁ : T g₁) (hg₂ : T g₂) (eq : f₁ ≫ G.map g₁ = f₂ ≫ G.map g₂),
      ℱ.val.map f₁.op (x g₁ hg₁) = ℱ.val.map f₂.op (x g₂ hg₂))

variables {J K} {G : C ⥤ D} (hG : compatible_preserving.{w} K G) (ℱ : SheafOfTypes.{w} K) {Z : C}
variables {T : presieve Z} {x : family_of_elements (G.op ⋙ ℱ.val) T} (h : x.compatible)

include h hG

/-- `compatible_preserving` functors indeed preserve compatible families. -/
lemma presieve.family_of_elements.compatible.functor_pushforward :
  (x.functor_pushforward G).compatible :=
begin
  rintros Z₁ Z₂ W g₁ g₂ f₁' f₂' H₁ H₂ eq,
  unfold family_of_elements.functor_pushforward,
  rcases get_functor_pushforward_structure H₁ with ⟨X₁, f₁, h₁, hf₁, rfl⟩,
  rcases get_functor_pushforward_structure H₂ with ⟨X₂, f₂, h₂, hf₂, rfl⟩,
  suffices : ℱ.val.map (g₁ ≫ h₁).op (x f₁ hf₁) = ℱ.val.map (g₂ ≫ h₂).op (x f₂ hf₂),
    simpa using this,
  apply hG.compatible ℱ h _ _ hf₁ hf₂,
  simpa using eq
end

@[simp] lemma compatible_preserving.apply_map {Y : C} {f : Y ⟶ Z} (hf : T f) :
  x.functor_pushforward G (G.map f) (image_mem_functor_pushforward G T hf) = x f hf :=
begin
  unfold family_of_elements.functor_pushforward,
  rcases e₁ : get_functor_pushforward_structure (image_mem_functor_pushforward G T hf) with
    ⟨X, g, f', hg, eq⟩,
  simpa using hG.compatible ℱ h f' (𝟙 _) hg hf (by simp[eq])
end

omit h hG

open limits.walking_cospan

lemma compatible_preserving_of_flat {C : Type u₁} [category.{v₁} C] {D : Type u₁} [category.{v₁} D]
  (K : grothendieck_topology D) (G : C ⥤ D) [representably_flat G] : compatible_preserving K G :=
begin
  constructor,
  intros ℱ Z T x hx Y₁ Y₂ X f₁ f₂ g₁ g₂ hg₁ hg₂ e,

  /- First, `f₁` and `f₂` form a cone over `cospan g₁ g₂ ⋙ u`. -/
  let c : cone (cospan g₁ g₂ ⋙ G) :=
    (cones.postcompose (diagram_iso_cospan (cospan g₁ g₂ ⋙ G)).inv).obj
      (pullback_cone.mk f₁ f₂ e),

  /-
  This can then be viewed as a cospan of structured arrows, and we may obtain an arbitrary cone
  over it since `structured_arrow W u` is cofiltered.
  Then, it suffices to prove that it is compatible when restricted onto `u(c'.X.right)`.
  -/
  let c' := is_cofiltered.cone (structured_arrow_cone.to_diagram c ⋙ structured_arrow.pre _ _ _),
  have eq₁ : f₁ = (c'.X.hom ≫ G.map (c'.π.app left).right) ≫ eq_to_hom (by simp),
  { erw ← (c'.π.app left).w, dsimp, simp },
  have eq₂ : f₂ = (c'.X.hom ≫ G.map (c'.π.app right).right) ≫ eq_to_hom (by simp),
  { erw ← (c'.π.app right).w, dsimp, simp },
  conv_lhs { rw eq₁ },
  conv_rhs { rw eq₂ },
  simp only [op_comp, functor.map_comp, types_comp_apply, eq_to_hom_op, eq_to_hom_map],
  congr' 1,

  /-
  Since everything now falls in the image of `u`,
  the result follows from the compatibility of `x` in the image of `u`.
  -/
  injection c'.π.naturality walking_cospan.hom.inl with _ e₁,
  injection c'.π.naturality walking_cospan.hom.inr with _ e₂,
  exact hx (c'.π.app left).right (c'.π.app right).right hg₁ hg₂ (e₁.symm.trans e₂)
end

lemma compatible_preserving_of_downwards_closed (F : C ⥤ D) [full F] [faithful F]
  (hF : Π {c : C} {d : D} (f : d ⟶ F.obj c), Σ c', F.obj c' ≅ d) : compatible_preserving K F :=
begin
  constructor,
  introv hx he,
  obtain ⟨X', e⟩ := hF f₁,
  apply (ℱ.1.map_iso e.op).to_equiv.injective,
  simp only [iso.op_hom, iso.to_equiv_fun, ℱ.1.map_iso_hom, ← functor_to_types.map_comp_apply],
  simpa using hx (F.preimage $ e.hom ≫ f₁) (F.preimage $ e.hom ≫ f₂) hg₁ hg₂
    (F.map_injective $ by simpa using he),
end

/--
If `G` is cover-preserving and compatible-preserving,
then `G.op ⋙ _` pulls sheaves back to sheaves.

This result is basically <https://stacks.math.columbia.edu/tag/00WW>.
-/
theorem pullback_is_sheaf_of_cover_preserving {G : C ⥤ D} (hG₁ : compatible_preserving.{v₃} K G)
  (hG₂ : cover_preserving J K G) (ℱ : Sheaf K A) :
  presheaf.is_sheaf J (G.op ⋙ ℱ.val) :=
begin
  intros X U S hS x hx,
  change family_of_elements (G.op ⋙ ℱ.val ⋙ coyoneda.obj (op X)) _ at x,
  let H := ℱ.2 X _ (hG₂.cover_preserve hS),
  let hx' := hx.functor_pushforward hG₁ (sheaf_over ℱ X),
  split, swap,
  { apply H.amalgamate (x.functor_pushforward G),
    exact hx' },
  split,
  { intros V f hf,
    convert H.is_amalgamation hx' (G.map f) (image_mem_functor_pushforward G S hf),
    rw hG₁.apply_map (sheaf_over ℱ X) hx },
  { intros y hy,
    refine H.is_separated_for _ y _ _
      (H.is_amalgamation (hx.functor_pushforward hG₁ (sheaf_over ℱ X))),
    rintros V f ⟨Z, f', g', h, rfl⟩,
    erw family_of_elements.comp_of_compatible (S.functor_pushforward G)
      hx' (image_mem_functor_pushforward G S h) g',
    dsimp,
    simp [hG₁.apply_map (sheaf_over ℱ X) hx h, ←hy f' h] }
end

/-- The pullback of a sheaf along a cover-preserving and compatible-preserving functor. -/
def pullback_sheaf {G : C ⥤ D} (hG₁ : compatible_preserving K G)
  (hG₂ : cover_preserving J K G) (ℱ : Sheaf K A) : Sheaf J A :=
⟨G.op ⋙ ℱ.val, pullback_is_sheaf_of_cover_preserving hG₁ hG₂ ℱ⟩

variable (A)

/--
The induced functor from `Sheaf K A ⥤ Sheaf J A` given by `G.op ⋙ _`
if `G` is cover-preserving and compatible-preserving.
-/
@[simps] def sites.pullback {G : C ⥤ D} (hG₁ : compatible_preserving K G)
  (hG₂ : cover_preserving J K G) : Sheaf K A ⥤ Sheaf J A :=
{ obj := λ ℱ, pullback_sheaf hG₁ hG₂ ℱ,
  map := λ _ _ f, ⟨(((whiskering_left _ _ _).obj G.op)).map f.val⟩,
  map_id' := λ ℱ, by { ext1, apply (((whiskering_left _ _ _).obj G.op)).map_id },
  map_comp' := λ _ _ _ f g, by { ext1, apply (((whiskering_left _ _ _).obj G.op)).map_comp } }

end category_theory


lemma maze (P Q R S T U: Prop)
(p : P)
(h : P → Q)
(i : Q → R)
(j : Q → T)
(k : S → T)
(l : T → U)
: U :=
begin
exact l(j(h(p))),
end


/-
Copyright (c) 2015 Robert Y. Lewis. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Robert Y. Lewis
The real numbers, constructed as equivalence classes of Cauchy sequences of rationals.
This construction follows Bishop and Bridges (1985).

At this point, we no longer proceed constructively: this file makes heavy use of decidability,
excluded middle, and Hilbert choice. Two sets of definitions of Cauchy sequences, convergence,
etc are available in the libray, one with rates and one without. The definitions here, with rates,
 are amenable to be used constructively if and when that development takes place. The second set of
definitions available in /library/theories/analysis/metric_space.lean are the usual classical ones.

Here, we show that ℝ is complete. The proofs of Cauchy completeness and the supremum property
are independent of each other.
-/

import data.real.basic data.real.order data.real.division data.rat data.nat data.pnat
open rat
local postfix ⁻¹ := pnat.inv
open eq.ops pnat classical

namespace rat_seq

theorem rat_approx {s : seq} (H : regular s) :
        ∀ n : ℕ+, ∃ q : ℚ, ∃ N : ℕ+, ∀ m : ℕ+, m ≥ N → abs (s m - q) ≤ n⁻¹ :=
  begin
    intro n,
    existsi (s (2 * n)),
    existsi 2 * n,
    intro m Hm,
    apply le.trans,
    apply H,
    rewrite -(pnat.add_halves n),
    apply add_le_add_right,
    apply inv_ge_of_le Hm
  end

theorem rat_approx_seq {s : seq} (H : regular s) :
        ∀ n : ℕ+, ∃ q : ℚ, s_le (s_abs (sadd s (sneg (const q)))) (const n⁻¹) :=
  begin
    intro m,
    rewrite ↑s_le,
    cases rat_approx H m with [q, Hq],
    cases Hq with [N, HN],
    existsi q,
    apply nonneg_of_bdd_within,
    repeat (apply reg_add_reg | apply reg_neg_reg | apply abs_reg_of_reg | apply const_reg
             | assumption),
    intro n,
    existsi N,
    intro p Hp,
    rewrite ↑[sadd, sneg, s_abs, const],
    apply le.trans,
    rotate 1,
    rewrite -sub_eq_add_neg,
    apply sub_le_sub_left,
    apply HN,
    apply le.trans,
    apply Hp,
    rewrite -*pnat.mul_assoc,
    apply pnat.mul_le_mul_left,
    rewrite [sub_self, -neg_zero],
    apply neg_le_neg,
    apply rat.le_of_lt,
    apply pnat.inv_pos
  end

theorem r_rat_approx (s : reg_seq) :
        ∀ n : ℕ+, ∃ q : ℚ, r_le (r_abs (radd s (rneg (r_const q)))) (r_const n⁻¹) :=
  rat_approx_seq (reg_seq.is_reg s)

theorem const_bound {s : seq} (Hs : regular s) (n : ℕ+) :
        s_le (s_abs (sadd s (sneg (const (s n))))) (const n⁻¹) :=
  begin
    rewrite ↑[s_le, nonneg, s_abs, sadd, sneg, const],
    intro m,
    rewrite -sub_eq_add_neg,
    apply iff.mp !le_add_iff_neg_le_sub_left,
    apply le.trans,
    apply Hs,
    apply add_le_add_right,
    rewrite -*pnat.mul_assoc,
    apply inv_ge_of_le,
    apply pnat.mul_le_mul_left
  end

theorem abs_const (a : ℚ) : const (abs a) ≡ s_abs (const a) :=
  by apply equiv.refl

theorem r_abs_const (a : ℚ) : requiv (r_const (abs a) ) (r_abs (r_const a)) := abs_const a

theorem equiv_abs_of_ge_zero {s : seq} (Hs : regular s) (Hz : s_le zero s) : s_abs s ≡ s :=
  begin
    apply eq_of_bdd,
    apply abs_reg_of_reg Hs,
    apply Hs,
    intro j,
    rewrite ↑s_abs,
    let Hz' := s_nonneg_of_ge_zero Hs Hz,
    existsi 2 * j,
    intro n Hn,
    cases em (s n ≥ 0) with [Hpos, Hneg],
    rewrite [abs_of_nonneg Hpos, sub_self, abs_zero],
    apply rat.le_of_lt,
    apply pnat.inv_pos,
    let Hneg' := lt_of_not_ge Hneg,
    have Hsn : -s n - s n > 0, from add_pos (neg_pos_of_neg Hneg') (neg_pos_of_neg Hneg'),
    rewrite [abs_of_neg Hneg', abs_of_pos Hsn],
    apply le.trans,
    apply add_le_add,
    repeat (apply neg_le_neg; apply Hz'),
    rewrite neg_neg,
    apply le.trans,
    apply add_le_add,
    repeat (apply inv_ge_of_le; apply Hn),
    krewrite pnat.add_halves,
  end

theorem equiv_neg_abs_of_le_zero {s : seq} (Hs : regular s) (Hz : s_le s zero) : s_abs s ≡ sneg s :=
  begin
    apply eq_of_bdd,
    apply abs_reg_of_reg Hs,
    apply reg_neg_reg Hs,
    intro j,
    rewrite [↑s_abs, ↑s_le at Hz],
    have Hz' : nonneg (sneg s), begin
      apply nonneg_of_nonneg_equiv,
      rotate 3,
      apply Hz,
      rotate 2,
      apply s_zero_add,
      repeat (apply Hs | apply zero_is_reg | apply reg_neg_reg | apply reg_add_reg)
    end,
    existsi 2 * j,
    intro n Hn,
    cases em (s n ≥ 0) with [Hpos, Hneg],
    have Hsn : s n + s n ≥ 0, from add_nonneg Hpos Hpos,
    rewrite [abs_of_nonneg Hpos, ↑sneg, sub_neg_eq_add, abs_of_nonneg Hsn],
    rewrite [↑nonneg at Hz', ↑sneg at Hz'],
    apply le.trans,
    apply add_le_add,
    repeat apply (le_of_neg_le_neg !Hz'),
    apply le.trans,
    apply add_le_add,
    repeat (apply inv_ge_of_le; apply Hn),
    krewrite pnat.add_halves,
    let Hneg' := lt_of_not_ge Hneg,
    rewrite [abs_of_neg Hneg', ↑sneg, sub_neg_eq_add, neg_add_eq_sub, sub_self,
                abs_zero],
    apply rat.le_of_lt,
    apply pnat.inv_pos
  end

theorem r_equiv_abs_of_ge_zero {s : reg_seq} (Hz : r_le r_zero s) : requiv (r_abs s) s :=
  equiv_abs_of_ge_zero (reg_seq.is_reg s) Hz

theorem r_equiv_neg_abs_of_le_zero {s : reg_seq} (Hz : r_le s r_zero) : requiv (r_abs s) (-s) :=
  equiv_neg_abs_of_le_zero (reg_seq.is_reg s) Hz

end rat_seq

namespace real
open [class] rat_seq

private theorem rewrite_helper9 (a b c : ℝ) : b - c = (b - a) - (c - a) :=
  by rewrite [-sub_add_eq_sub_sub_swap, sub_add_cancel]

private theorem rewrite_helper10 (a b c d : ℝ) : c - d = (c - a) + (a - b) + (b - d) :=
  by rewrite [*add_sub, *sub_add_cancel]

noncomputable definition rep (x : ℝ) : rat_seq.reg_seq := some (quot.exists_rep x)

definition re_abs (x : ℝ) : ℝ :=
  quot.lift_on x (λ a, quot.mk (rat_seq.r_abs a))
    (take a b Hab, quot.sound (rat_seq.r_abs_well_defined Hab))

theorem r_abs_nonneg {x : ℝ} : zero ≤ x → re_abs x = x :=
  quot.induction_on x (λ a Ha, quot.sound  (rat_seq.r_equiv_abs_of_ge_zero Ha))

theorem r_abs_nonpos {x : ℝ} : x ≤ zero → re_abs x = -x :=
  quot.induction_on x (λ a Ha, quot.sound (rat_seq.r_equiv_neg_abs_of_le_zero Ha))

private theorem abs_const' (a : ℚ) : of_rat (abs a) = re_abs (of_rat a) :=
  quot.sound (rat_seq.r_abs_const a)

private theorem re_abs_is_abs : re_abs = abs := funext
  (begin
    intro x,
    apply eq.symm,
    cases em (zero ≤ x) with [Hor1, Hor2],
    rewrite [abs_of_nonneg Hor1, r_abs_nonneg Hor1],
    have Hor2' : x ≤ zero, from le_of_lt (lt_of_not_ge Hor2),
    rewrite [abs_of_neg (lt_of_not_ge Hor2), r_abs_nonpos Hor2']
  end)

theorem abs_const (a : ℚ) : of_rat (abs a) = abs (of_rat a) :=
  by  rewrite -re_abs_is_abs

private theorem rat_approx' (x : ℝ) : ∀ n : ℕ+, ∃ q : ℚ, re_abs (x - of_rat q) ≤ of_rat n⁻¹ :=
  quot.induction_on x (λ s n, rat_seq.r_rat_approx s n)

theorem rat_approx (x : ℝ) : ∀ n : ℕ+, ∃ q : ℚ, abs (x - of_rat q) ≤ of_rat n⁻¹ :=
  by rewrite -re_abs_is_abs; apply rat_approx'

noncomputable definition approx (x : ℝ) (n : ℕ+) := some (rat_approx x n)

theorem approx_spec (x : ℝ) (n : ℕ+) : abs (x - (of_rat (approx x n))) ≤ of_rat n⁻¹ :=
  some_spec (rat_approx x n)

theorem approx_spec' (x : ℝ) (n : ℕ+) : abs ((of_rat (approx x n)) - x) ≤ of_rat n⁻¹ :=
  by rewrite abs_sub; apply approx_spec

theorem ex_rat_pos_lower_bound_of_pos {x : ℝ} (H : x > 0) : ∃ q : ℚ, q > 0 ∧ of_rat q ≤ x :=
  if Hgeo : x ≥ 1 then
    exists.intro 1 (and.intro zero_lt_one Hgeo)
  else
    have Hdp : 1 / x > 0, from one_div_pos_of_pos H,
    begin
      cases rat_approx (1 / x) 2 with q Hq,
      have Hqp : q > 0, begin
        apply lt_of_not_ge,
        intro Hq2,
        note Hx' := one_div_lt_one_div_of_lt H (lt_of_not_ge Hgeo),
        rewrite div_one at Hx',
        have Horqn : of_rat q ≤ 0, begin
          krewrite -of_rat_zero,
          apply of_rat_le_of_rat_of_le Hq2
        end,
        have Hgt1 : 1 / x - of_rat q > 1, from calc
          1 / x - of_rat q = 1 / x + -of_rat q : sub_eq_add_neg
                       ... ≥ 1 / x             : le_add_of_nonneg_right (neg_nonneg_of_nonpos Horqn)
                       ... > 1                 : Hx',
        have Hpos : 1 / x - of_rat q > 0, from gt.trans Hgt1 zero_lt_one,
        rewrite [abs_of_pos Hpos at Hq],
        apply not_le_of_gt Hgt1,
        apply le.trans,
        apply Hq,
        krewrite -of_rat_one,
        apply of_rat_le_of_rat_of_le,
        apply inv_le_one
      end,
      existsi 1 / (2⁻¹ + q),
      split,
      apply div_pos_of_pos_of_pos,
      exact zero_lt_one,
      apply add_pos,
      apply pnat.inv_pos,
      exact Hqp,
      note Hle2 := sub_le_of_abs_sub_le_right Hq,
      note Hle3 := le_add_of_sub_left_le Hle2,
      note Hle4 := one_div_le_of_one_div_le_of_pos H Hle3,
      rewrite [of_rat_divide, of_rat_add],
      exact Hle4
    end

theorem ex_rat_neg_upper_bound_of_neg {x : ℝ} (H : x < 0) : ∃ q : ℚ, q < 0 ∧ x ≤ of_rat q :=
  have H' : -x > 0, from neg_pos_of_neg H,
  obtain q [Hq1 Hq2], from ex_rat_pos_lower_bound_of_pos H',
  exists.intro (-q) (and.intro
    (neg_neg_of_pos Hq1)
    (le_neg_of_le_neg Hq2))

notation `r_seq` := ℕ+ → ℝ

noncomputable definition converges_to_with_rate (X : r_seq) (a : ℝ) (N : ℕ+ → ℕ+) :=
  ∀ k : ℕ+, ∀ n : ℕ+, n ≥ N k → abs (X n - a) ≤ of_rat k⁻¹

noncomputable definition cauchy_with_rate (X : r_seq) (M : ℕ+ → ℕ+) :=
  ∀ k : ℕ+, ∀ m n : ℕ+, m ≥ M k → n ≥ M k → abs (X m - X n) ≤ of_rat k⁻¹

theorem cauchy_with_rate_of_converges_to_with_rate {X : r_seq} {a : ℝ} {N : ℕ+ → ℕ+}
    (Hc : converges_to_with_rate X a N) :
        cauchy_with_rate X (λ k, N (2 * k)) :=
  begin
    intro k m n Hm Hn,
    rewrite (rewrite_helper9 a),
    apply le.trans,
    apply abs_add_le_abs_add_abs,
    apply le.trans,
    apply add_le_add,
    apply Hc,
    apply Hm,
    krewrite abs_neg,
    apply Hc,
    apply Hn,
    xrewrite -of_rat_add,
    apply of_rat_le_of_rat_of_le,
    krewrite pnat.add_halves,
  end

private definition Nb (M : ℕ+ → ℕ+) := λ k, max (3 * k) (M (2 * k))

private theorem Nb_spec_right (M : ℕ+ → ℕ+) (k : ℕ+) : M (2 * k) ≤ Nb M k := !le_max_right

private theorem Nb_spec_left (M : ℕ+ → ℕ+) (k : ℕ+) : 3 * k ≤ Nb M k := !le_max_left

section lim_seq
parameter {X : r_seq}
parameter {M : ℕ+ → ℕ+}
hypothesis Hc : cauchy_with_rate X M
include Hc

noncomputable definition lim_seq : ℕ+ → ℚ :=
  λ k, approx (X (Nb M k)) (2 * k)

private theorem lim_seq_reg_helper {m n : ℕ+} (Hmn : M (2 * n) ≤M (2 * m)) :
           abs (of_rat (lim_seq m) - X (Nb M m)) + abs (X (Nb M m) - X (Nb M n)) + abs
            (X (Nb M n) - of_rat (lim_seq n)) ≤ of_rat (m⁻¹ + n⁻¹) :=
  begin
    apply le.trans,
    apply add_le_add_three,
    apply approx_spec',
    rotate 1,
    apply approx_spec,
    rotate 1,
    apply Hc,
    rotate 1,
    apply Nb_spec_right,
    rotate 1,
    apply le.trans,
    apply Hmn,
    apply Nb_spec_right,
    krewrite [-+of_rat_add],
    change of_rat ((2 * m)⁻¹ + (2 * n)⁻¹ + (2 * n)⁻¹) ≤ of_rat (m⁻¹ + n⁻¹),
    rewrite [add.assoc],
    krewrite pnat.add_halves,
    apply of_rat_le_of_rat_of_le,
    apply add_le_add_right,
    apply inv_ge_of_le,
    apply pnat.mul_le_mul_left
  end

theorem lim_seq_reg : rat_seq.regular lim_seq :=
  begin
    rewrite ↑rat_seq.regular,
    intro m n,
    apply le_of_of_rat_le_of_rat,
    rewrite [abs_const, of_rat_sub, (rewrite_helper10 (X (Nb M m)) (X (Nb M n)))],
    apply le.trans,
    apply abs_add_three,
    cases em (M (2 * m) ≥ M (2 * n)) with [Hor1, Hor2],
    apply lim_seq_reg_helper Hor1,
    let Hor2' := le_of_lt (lt_of_not_ge Hor2),
    krewrite [abs_sub (X (Nb M n)), abs_sub (X (Nb M m)), abs_sub,
             rat.add_comm, add_comm_three],
    apply lim_seq_reg_helper Hor2'
  end

theorem lim_seq_spec (k : ℕ+) :
        rat_seq.s_le (rat_seq.s_abs (rat_seq.sadd lim_seq
            (rat_seq.sneg (rat_seq.const (lim_seq k))))) (rat_seq.const k⁻¹) :=
  by apply rat_seq.const_bound; apply lim_seq_reg

private noncomputable definition r_lim_seq : rat_seq.reg_seq :=
  rat_seq.reg_seq.mk lim_seq lim_seq_reg

private theorem r_lim_seq_spec (k : ℕ+) : rat_seq.r_le
        (rat_seq.r_abs ((rat_seq.radd r_lim_seq (rat_seq.rneg
            (rat_seq.r_const ((rat_seq.reg_seq.sq r_lim_seq) k))))))
        (rat_seq.r_const k⁻¹) :=
  lim_seq_spec k

noncomputable definition lim : ℝ :=
  quot.mk r_lim_seq

theorem re_lim_spec (k : ℕ+) : re_abs (lim - (of_rat (lim_seq k))) ≤ of_rat k⁻¹ :=
  r_lim_seq_spec k

theorem lim_spec' (k : ℕ+) : abs (lim - (of_rat (lim_seq k))) ≤ of_rat k⁻¹ :=
  by rewrite -re_abs_is_abs; apply re_lim_spec

theorem lim_spec (k : ℕ+) :
        abs ((of_rat (lim_seq k)) - lim) ≤ of_rat k⁻¹ :=
  by rewrite abs_sub; apply lim_spec'

theorem converges_to_with_rate_of_cauchy_with_rate : converges_to_with_rate X lim (Nb M) :=
  begin
    intro k n Hn,
    rewrite (rewrite_helper10 (X (Nb M n)) (of_rat (lim_seq n))),
    apply le.trans,
    apply abs_add_three,
    apply le.trans,
    apply add_le_add_three,
    apply Hc,
    apply le.trans,
    rotate 1,
    apply Hn,
    rotate_right 1,
    apply Nb_spec_right,
    have HMk : M (2 * k) ≤ Nb M n, begin
      apply le.trans,
      apply Nb_spec_right,
      apply le.trans,
      apply Hn,
      apply le.trans,
      apply pnat.mul_le_mul_left 3,
      apply Nb_spec_left
    end,
    apply HMk,
    rewrite ↑lim_seq,
    apply approx_spec,
    apply lim_spec,
    krewrite [-+of_rat_add],
    change of_rat ((2 * k)⁻¹ + (2 * n)⁻¹ + n⁻¹) ≤ of_rat k⁻¹,
    apply of_rat_le_of_rat_of_le,
    apply le.trans,
    apply add_le_add_three,
    apply rat.le_refl,
    apply inv_ge_of_le,
    apply pnat_mul_le_mul_left',
    apply le.trans,
    rotate 1,
    apply Hn,
    rotate_right 1,
    apply Nb_spec_left,
    apply inv_ge_of_le,
    apply le.trans,
    rotate 1,
    apply Hn,
    rotate_right 1,
    apply Nb_spec_left,
    rewrite -*pnat.mul_assoc,
    krewrite pnat.p_add_fractions,
  end

end lim_seq
-------------------------------------------
-- int embedding theorems
-- archimedean properties, integer floor and ceiling
section ints

open int

theorem archimedean_upper (x : ℝ) : ∃ z : ℤ, x ≤ of_int z :=
  begin
    apply quot.induction_on x,
    intro s,
    cases rat_seq.bdd_of_regular (rat_seq.reg_seq.is_reg s) with [b, Hb],
    existsi ubound b,
    have H : rat_seq.s_le (rat_seq.reg_seq.sq s) (rat_seq.const (rat.of_nat (ubound b))), begin
      apply rat_seq.s_le_of_le_pointwise (rat_seq.reg_seq.is_reg s),
      apply rat_seq.const_reg,
      intro n,
      apply le.trans,
      apply Hb,
      apply ubound_ge
    end,
    apply H
  end

theorem archimedean_upper_strict (x : ℝ) : ∃ z : ℤ, x < of_int z :=
  begin
    cases archimedean_upper x with [z, Hz],
    existsi z + 1,
    apply lt_of_le_of_lt,
    apply Hz,
    apply of_int_lt_of_int_of_lt,
    apply lt_add_of_pos_right,
    apply dec_trivial
  end

theorem archimedean_lower (x : ℝ) : ∃ z : ℤ, x ≥ of_int z :=
  begin
    cases archimedean_upper (-x) with [z, Hz],
    existsi -z,
    rewrite [of_int_neg],
    apply iff.mp !neg_le_iff_neg_le Hz
  end

theorem archimedean_lower_strict (x : ℝ) : ∃ z : ℤ, x > of_int z :=
  begin
    cases archimedean_upper_strict (-x) with [z, Hz],
    existsi -z,
    rewrite [of_int_neg],
    apply iff.mp !neg_lt_iff_neg_lt Hz
  end

private definition ex_floor (x : ℝ) :=
  (@exists_greatest_of_bdd (λ z, x ≥ of_int z) _
    (begin
      existsi some (archimedean_upper_strict x),
      let Har := some_spec (archimedean_upper_strict x),
      intros z Hz,
      apply not_le_of_gt,
      apply lt_of_lt_of_le,
      apply Har,
      have H : of_int (some (archimedean_upper_strict x)) ≤ of_int z, begin
        apply of_int_le_of_int_of_le,
        apply Hz
      end,
      exact H
    end)
    (by existsi some (archimedean_lower x); apply some_spec (archimedean_lower x)))

noncomputable definition floor (x : ℝ) : ℤ :=
  some (ex_floor x)

noncomputable definition ceil (x : ℝ) : ℤ := - floor (-x)

theorem floor_le (x : ℝ) : floor x ≤ x :=
  and.left (some_spec (ex_floor x))

theorem lt_of_floor_lt {x : ℝ} {z : ℤ} (Hz : floor x < z) : x < z :=
  begin
    apply lt_of_not_ge,
    cases some_spec (ex_floor x),
    apply a_1 _ Hz
  end

theorem le_ceil (x : ℝ) : x ≤ ceil x :=
  begin
    rewrite [↑ceil, of_int_neg],
    apply iff.mp !le_neg_iff_le_neg,
    apply floor_le
  end

theorem lt_of_lt_ceil {x : ℝ} {z : ℤ} (Hz : z < ceil x) : z < x :=
  begin
    rewrite ↑ceil at Hz,
    note Hz' := lt_of_floor_lt (iff.mp !lt_neg_iff_lt_neg Hz),
    rewrite [of_int_neg at Hz'],
    apply lt_of_neg_lt_neg Hz'
  end

theorem floor_succ (x : ℝ) : floor (x + 1) = floor x + 1 :=
  begin
    apply by_contradiction,
    intro H,
    cases lt_or_gt_of_ne H with [Hgt, Hlt],
    note Hl := lt_of_floor_lt Hgt,
    rewrite [of_int_add at Hl],
    apply not_le_of_gt (lt_of_add_lt_add_right Hl) !floor_le,
    note Hl := lt_of_floor_lt (iff.mp !add_lt_iff_lt_sub_right Hlt),
    rewrite [of_int_sub at Hl],
    apply not_le_of_gt (iff.mpr !add_lt_iff_lt_sub_right Hl) !floor_le
  end

theorem floor_sub_one_lt_floor (x : ℝ) : floor (x - 1) < floor x :=
  begin

    apply @lt_of_add_lt_add_right ℤ _ _ 1,
    rewrite [-floor_succ (x - 1), sub_add_cancel],
    apply lt_add_of_pos_right dec_trivial
  end

theorem ceil_lt_ceil_succ (x : ℝ) : ceil x < ceil (x + 1) :=
  begin
    rewrite [↑ceil, neg_add],
    apply neg_lt_neg,
    apply floor_sub_one_lt_floor
  end
open nat

theorem archimedean_small {ε : ℝ} (H : ε > 0) : ∃ (n : ℕ), 1 / succ n < ε :=
let n := int.nat_abs (ceil (2 / ε)) in
have int.of_nat n ≥ ceil (2 / ε),
  by rewrite of_nat_nat_abs; apply le_abs_self,
have int.of_nat (succ n) ≥ ceil (2 / ε),
  begin apply le.trans, exact this, apply int.of_nat_le_of_nat_of_le, apply le_succ end,
have H₁ : int.succ n ≥ ceil (2 / ε), from of_int_le_of_int_of_le this,
have H₂ : succ n ≥ 2 / ε, from !le.trans !le_ceil H₁,
have H₃ : 2 / ε > 0, from div_pos_of_pos_of_pos two_pos H,
have 1 / succ n < ε, from calc
  1 / succ n ≤ 1 / (2 / ε) : one_div_le_one_div_of_le H₃ H₂
    ... = ε / 2       : one_div_div
    ... < ε           : div_two_lt_of_pos H,
exists.intro n this

end ints
--------------------------------------------------
-- supremum property
-- this development roughly follows the proof of completeness done in Isabelle.
-- It does not depend on the previous proof of Cauchy completeness. Much of the same
-- machinery can be used to show that Cauchy completeness implies the supremum property.

section supremum
open prod nat
local postfix `~` := nat_of_pnat

-- The top part of this section could be refactored. What is the appropriate place to define
-- bounds, supremum, etc? In algebra/ordered_field? They potentially apply to more than just ℝ.
parameter X : ℝ → Prop

definition ub (x : ℝ) := ∀ y : ℝ, X y → y ≤ x
definition is_sup (x : ℝ) := ub x ∧ ∀ y : ℝ, ub y → x ≤ y

definition lb (x : ℝ) := ∀ y : ℝ, X y → x ≤ y
definition is_inf (x : ℝ) := lb x ∧ ∀ y : ℝ, lb y → y ≤ x

parameter elt : ℝ
hypothesis inh :  X elt
parameter bound : ℝ
hypothesis bdd : ub bound

include inh bdd

private definition avg (a b : ℚ) := a / 2 + b / 2

private noncomputable definition bisect (ab : ℚ × ℚ) :=
  if ub (avg (pr1 ab) (pr2 ab)) then
    (pr1 ab, (avg (pr1 ab) (pr2 ab)))
  else
    (avg (pr1 ab) (pr2 ab), pr2 ab)

private noncomputable definition under : ℚ := rat.of_int (floor (elt - 1))

private theorem under_spec1 : of_rat under < elt :=
  have H : of_rat under < of_int (floor elt), begin
    apply of_int_lt_of_int_of_lt,
    apply floor_sub_one_lt_floor
  end,
  lt_of_lt_of_le H !floor_le

private theorem under_spec : ¬ ub under :=
  begin
    rewrite ↑ub,
    apply not_forall_of_exists_not,
    existsi elt,
    apply iff.mpr !not_implies_iff_and_not,
    apply and.intro,
    apply inh,
    apply not_le_of_gt under_spec1
  end

private noncomputable definition over : ℚ := rat.of_int (ceil (bound + 1)) -- b

private theorem over_spec1 : bound < of_rat over :=
  have H : of_int (ceil bound) < of_rat over, begin
    apply of_int_lt_of_int_of_lt,
    apply ceil_lt_ceil_succ
  end,
  lt_of_le_of_lt !le_ceil H

private theorem over_spec : ub over :=
  begin
    rewrite ↑ub,
    intro y Hy,
    apply le_of_lt,
    apply lt_of_le_of_lt,
    apply bdd,
    apply Hy,
    apply over_spec1
  end

private noncomputable definition under_seq := λ n : ℕ, pr1 (iterate bisect n (under, over)) -- A

private noncomputable definition over_seq := λ n : ℕ, pr2 (iterate bisect n (under, over)) -- B

private noncomputable definition avg_seq := λ n : ℕ, avg (over_seq n) (under_seq n) -- C

private theorem avg_symm (n : ℕ) : avg_seq n = avg (under_seq n) (over_seq n) :=
  by rewrite [↑avg_seq, ↑avg, add.comm]

private theorem over_0 : over_seq 0 = over := rfl

private theorem under_0 : under_seq 0 = under := rfl

private theorem succ_helper (n : ℕ) :
        avg (pr1 (iterate bisect n (under, over))) (pr2 (iterate bisect n (under, over))) = avg_seq n :=
   by rewrite avg_symm

private theorem under_succ (n : ℕ) : under_seq (succ n) =
        (if ub (avg_seq n) then under_seq n else avg_seq n) :=
  begin
    cases em (ub (avg_seq n)) with [Hub, Hub],
    rewrite [if_pos Hub],
    have H :  pr1 (bisect (iterate bisect n (under, over))) = under_seq n, by
      rewrite [↑under_seq, ↑bisect at {2}, -succ_helper at Hub, if_pos Hub],
    apply H,
    rewrite [if_neg Hub],
    have H : pr1 (bisect (iterate bisect n (under, over))) = avg_seq n, by
      rewrite [↑bisect at {2}, -succ_helper at Hub, if_neg Hub, avg_symm],
    apply H
  end

private theorem over_succ (n : ℕ) : over_seq (succ n) =
        (if ub (avg_seq n) then avg_seq n else over_seq n) :=
  begin
    cases em (ub (avg_seq n)) with [Hub, Hub],
    rewrite [if_pos Hub],
    have H : pr2 (bisect (iterate bisect n (under, over))) = avg_seq n, by
      rewrite [↑bisect at {2}, -succ_helper at Hub, if_pos Hub, avg_symm],
    apply H,
    rewrite [if_neg Hub],
    have H : pr2 (bisect (iterate bisect n (under, over))) = over_seq n, by
      rewrite [↑over_seq, ↑bisect at {2}, -succ_helper at Hub, if_neg Hub],
    apply H
  end

private theorem nat.zero_eq_0 : (zero : ℕ) = 0 := rfl

private theorem width (n : ℕ) : over_seq n - under_seq n = (over - under) / ((2^n) : ℚ) :=
  nat.induction_on n
    (by xrewrite [nat.zero_eq_0, over_0, under_0, pow_zero, div_one])
    (begin
      intro a Ha,
      rewrite [over_succ, under_succ],
      let Hou := calc
        (over_seq a) / 2 - (under_seq a) / 2 = ((over - under) / 2^a) / 2 :
                                               by rewrite [div_sub_div_same, Ha]
        ... = (over - under) / ((2^a) * 2) : by rewrite div_div_eq_div_mul
        ... = (over - under) / 2^(a + 1) : by rewrite pow_add,
      cases em (ub (avg_seq a)),
      rewrite [*if_pos a_1, -add_one, -Hou, ↑avg_seq, ↑avg, sub_eq_add_neg, add.assoc, -sub_eq_add_neg, div_two_sub_self],
      rewrite [*if_neg a_1, -add_one, -Hou, ↑avg_seq, ↑avg, sub_add_eq_sub_sub,
              sub_self_div_two]
    end)

private theorem width_narrows : ∃ n : ℕ, over_seq n - under_seq n ≤ 1 :=
  begin
    cases binary_bound (over - under) with [a, Ha],
    existsi a,
    rewrite (width a),
    apply div_le_of_le_mul,
    apply pow_pos dec_trivial,
    rewrite rat.mul_one,
    apply Ha
  end

private noncomputable definition over' := over_seq (some width_narrows)

private noncomputable definition under' := under_seq (some width_narrows)

private noncomputable definition over_seq' := λ n, over_seq (n + some width_narrows)

private noncomputable definition under_seq' := λ n, under_seq (n + some width_narrows)

private theorem over_seq'0 : over_seq' 0 = over' :=
  by rewrite [↑over_seq', nat.zero_add]

private theorem under_seq'0 : under_seq' 0 = under' :=
  by rewrite [↑under_seq', nat.zero_add]

private theorem under_over' : over' - under' ≤ 1 := some_spec width_narrows

private theorem width' (n : ℕ) : over_seq' n - under_seq' n ≤ 1 / 2^n :=
  nat.induction_on n
    (begin
      xrewrite [nat.zero_eq_0, over_seq'0, under_seq'0, pow_zero, div_one],
      apply under_over'
    end)
    (begin
      intros a Ha,
      rewrite [↑over_seq' at *, ↑under_seq' at *, *succ_add at *, width at *,
              -add_one, -(add_one a), pow_add, pow_add _ a 1, *pow_one],
      apply div_mul_le_div_mul_of_div_le_div_pos' Ha dec_trivial
    end)

private theorem PA (n : ℕ) : ¬ ub (under_seq n) :=
  nat.induction_on n
    (by rewrite under_0; apply under_spec)
    (begin
      intro a Ha,
      rewrite under_succ,
      cases em (ub (avg_seq a)),
      rewrite (if_pos a_1),
      assumption,
      rewrite (if_neg a_1),
      assumption
    end)

private theorem PB (n : ℕ) : ub (over_seq n) :=
  nat.induction_on n
    (by rewrite over_0; apply over_spec)
    (begin
      intro a Ha,
      rewrite over_succ,
      cases em (ub (avg_seq a)),
      rewrite (if_pos a_1),
      assumption,
      rewrite (if_neg a_1),
      assumption
    end)

private theorem under_lt_over : under < over :=
  begin
    cases exists_not_of_not_forall under_spec with [x, Hx],
    cases and_not_of_not_implies Hx with [HXx, Hxu],
    apply lt_of_of_rat_lt_of_rat,
    apply lt_of_lt_of_le,
    apply lt_of_not_ge Hxu,
    apply over_spec _ HXx
  end

private theorem under_seq_lt_over_seq : ∀ m n : ℕ, under_seq m < over_seq n :=
  begin
    intros,
    cases exists_not_of_not_forall (PA m) with [x, Hx],
    cases iff.mp !not_implies_iff_and_not Hx with [HXx, Hxu],
    apply lt_of_of_rat_lt_of_rat,
    apply lt_of_lt_of_le,
    apply lt_of_not_ge Hxu,
    apply PB,
    apply HXx
  end

private theorem under_seq_lt_over_seq_single : ∀ n : ℕ, under_seq n < over_seq n :=
  by intros; apply under_seq_lt_over_seq

private theorem under_seq'_lt_over_seq' : ∀ m n : ℕ, under_seq' m < over_seq' n :=
  by intros; apply under_seq_lt_over_seq

private theorem under_seq'_lt_over_seq'_single : ∀ n : ℕ, under_seq' n < over_seq' n :=
  by intros; apply under_seq_lt_over_seq

private theorem under_seq_mono_helper (i k : ℕ) : under_seq i ≤ under_seq (i + k) :=
  (nat.induction_on k
    (by rewrite nat.add_zero; apply rat.le_refl)
    (begin
      intros a Ha,
      rewrite [add_succ, under_succ],
      cases em (ub (avg_seq (i + a))) with [Havg, Havg],
      rewrite (if_pos Havg),
      apply Ha,
      rewrite [if_neg Havg, ↑avg_seq, ↑avg],
      apply le.trans,
      apply Ha,
      rewrite -(add_halves (under_seq (i + a))) at {1},
      apply add_le_add_right,
      apply div_le_div_of_le_of_pos,
      apply rat.le_of_lt,
      apply under_seq_lt_over_seq,
      apply dec_trivial
    end))

private theorem under_seq_mono (i j : ℕ) (H : i ≤ j) : under_seq i ≤ under_seq j :=
  begin
    cases le.elim H with [k, Hk'],
    rewrite -Hk',
    apply under_seq_mono_helper
  end

private theorem over_seq_mono_helper (i k : ℕ) : over_seq (i + k) ≤ over_seq i :=
  nat.induction_on k
    (by rewrite nat.add_zero; apply rat.le_refl)
    (begin
      intros a Ha,
      rewrite [add_succ, over_succ],
      cases em (ub (avg_seq (i + a))) with [Havg, Havg],
      rewrite [if_pos Havg, ↑avg_seq, ↑avg],
      apply le.trans,
      rotate 1,
      apply Ha,
      rotate 1,
      apply add_le_of_le_sub_left,
      rewrite sub_self_div_two,
      apply div_le_div_of_le_of_pos,
      apply rat.le_of_lt,
      apply under_seq_lt_over_seq,
      apply dec_trivial,
      rewrite [if_neg Havg],
      apply Ha
    end)

private theorem over_seq_mono (i j : ℕ) (H : i ≤ j) : over_seq j ≤ over_seq i :=
  begin
    cases le.elim H with [k, Hk'],
    rewrite -Hk',
    apply over_seq_mono_helper
  end

private theorem rat_power_two_inv_ge (k : ℕ+) : 1 / 2^k~ ≤ k⁻¹ :=
  one_div_le_one_div_of_le !rat_of_pnat_is_pos !rat_power_two_le

open rat_seq
private theorem regular_lemma_helper {s : seq} {m n : ℕ+} (Hm : m ≤ n)
        (H : ∀ n i : ℕ+, i ≥ n → under_seq' n~ ≤ s i ∧ s i ≤ over_seq' n~) :
        abs (s m - s n) ≤ m⁻¹ + n⁻¹ :=
  begin
    cases H m n Hm with [T1under, T1over],
    cases H m m (!le.refl) with [T2under, T2over],
    apply le.trans,
    apply dist_bdd_within_interval,
    apply under_seq'_lt_over_seq'_single,
    rotate 1,
    repeat assumption,
    apply le.trans,
    apply width',
    apply le.trans,
    apply rat_power_two_inv_ge,
    apply le_add_of_nonneg_right,
    apply rat.le_of_lt (!pnat.inv_pos)
  end

private theorem regular_lemma (s : seq) (H : ∀ n i : ℕ+, i ≥ n → under_seq' n~ ≤ s i ∧ s i ≤ over_seq' n~) :
        regular s :=
  begin
    rewrite ↑regular,
    intros,
    cases em (m ≤ n) with [Hm, Hn],
    apply regular_lemma_helper Hm H,
    note T := regular_lemma_helper (le_of_lt (lt_of_not_ge Hn)) H,
    rewrite [abs_sub at T, {n⁻¹ + _}add.comm at T],
    exact T
  end

private noncomputable definition p_under_seq : seq := λ n : ℕ+, under_seq' n~

private noncomputable definition p_over_seq : seq := λ n : ℕ+, over_seq' n~

private theorem under_seq_regular : regular p_under_seq :=
  begin
    apply regular_lemma,
    intros n i Hni,
    apply and.intro,
    apply under_seq_mono,
    apply add_le_add_right,
    apply Hni,
    apply rat.le_of_lt,
    apply under_seq_lt_over_seq
  end

private theorem over_seq_regular : regular p_over_seq :=
  begin
    apply regular_lemma,
    intros n i Hni,
    apply and.intro,
    apply rat.le_of_lt,
    apply under_seq_lt_over_seq,
    apply over_seq_mono,
    apply add_le_add_right,
    apply Hni
  end

private noncomputable definition sup_over : ℝ := quot.mk (reg_seq.mk p_over_seq over_seq_regular)

private noncomputable definition sup_under : ℝ := quot.mk (reg_seq.mk p_under_seq under_seq_regular)

private theorem over_bound : ub sup_over :=
  begin
    rewrite ↑ub,
    intros y Hy,
    apply le_of_le_reprs,
    intro n,
    apply PB,
    apply Hy
  end

private theorem under_lowest_bound : ∀ y : ℝ, ub y → sup_under ≤ y :=
  begin
    intros y Hy,
    apply le_of_reprs_le,
    intro n,
    cases exists_not_of_not_forall (PA _) with [x, Hx],
    cases and_not_of_not_implies Hx with [HXx, Hxn],
    apply le.trans,
    apply le_of_lt,
    apply lt_of_not_ge Hxn,
    apply Hy,
    apply HXx
  end

private theorem under_over_equiv : p_under_seq ≡ p_over_seq :=
  begin
    intros,
    apply le.trans,
    have H : p_under_seq n < p_over_seq n, from !under_seq_lt_over_seq,
    rewrite [abs_of_neg (iff.mpr !sub_neg_iff_lt H), neg_sub],
    apply width',
    apply le.trans,
    apply rat_power_two_inv_ge,
    apply le_add_of_nonneg_left,
    apply rat.le_of_lt !pnat.inv_pos
  end

private theorem under_over_eq : sup_under = sup_over := quot.sound under_over_equiv

theorem exists_is_sup_of_inh_of_bdd : ∃ x : ℝ, is_sup x :=
  exists.intro sup_over (and.intro over_bound (under_over_eq ▸ under_lowest_bound))

end supremum
definition bounding_set (X : ℝ → Prop) (x : ℝ) : Prop := ∀ y : ℝ, X y → x ≤ y

theorem exists_is_inf_of_inh_of_bdd (X : ℝ → Prop) (elt : ℝ) (inh : X elt) (bound : ℝ)
        (bdd : lb X bound) : ∃ x : ℝ, is_inf X x :=
  begin
    have Hinh : bounding_set X bound, begin
      intros y Hy,
      apply bdd,
      apply Hy
    end,
    have Hub : ub (bounding_set X) elt, begin
      intros y Hy,
      apply Hy,
      apply inh
    end,
    cases exists_is_sup_of_inh_of_bdd _ _ Hinh _ Hub with [supr, Hsupr],
    existsi supr,
    cases Hsupr with [Hubs1, Hubs2],
    apply and.intro,
    intros,
    apply Hubs2,
    intros z Hz,
    apply Hz,
    apply a,
    intros y Hlby,
    apply Hubs1,
    intros z Hz,
    apply Hlby,
    apply Hz
  end

end real


import morphisms.separated
import morphisms.integral

open category_theory category_theory.limits

namespace algebraic_geometry

universe u

variables {X Y Z : Scheme.{u}} (f : X ⟶ Y) (g : Y ⟶ Z)

@[mk_iff]
class proper extends separated f, universally_closed f, locally_of_finite_type f : Prop.

example [proper f] : quasi_compact f := infer_instance

lemma proper_eq : @proper = @separated ⊓ @universally_closed ⊓ @locally_of_finite_type :=
by { ext, rw [proper_iff, ← and_assoc], refl }

instance [proper f] [proper g] : proper (f ≫ g) := ⟨⟩

lemma proper_stable_under_composition :
  morphism_property.stable_under_composition @proper :=
λ _ _ _ _ _ _ _, by exactI infer_instance

instance finite.to_proper [finite f] : proper f := ⟨⟩

lemma proper_respects_iso :
  morphism_property.respects_iso @proper :=
proper_stable_under_composition.respects_iso (λ _ _ _, ⟨⟩)

lemma proper_is_local_at_target :
  property_is_local_at_target @proper :=
begin
  rw proper_eq,
  exact (separated.is_local_at_target.inf universally_closed_is_local_at_target).inf
    locally_of_finite_type_is_local_at_target,
end

lemma proper_stable_under_base_change :
  morphism_property.stable_under_base_change @proper :=
begin
  introsI X Y Y' S f g f' g' H Hg,
  exact @@proper.mk (separated_stable_under_base_change H infer_instance)
    (universally_closed_stable_under_base_change H infer_instance)
    (locally_of_finite_type_stable_under_base_change H infer_instance),
end

lemma finite_eq_proper_inf_affine :
  @finite = @proper ⊓ @affine :=
begin
  rw [proper_eq, finite_eq_integral_inf_locally_of_finite_type,
    integral_eq_affine_inf_universally_closed],
  conv_lhs { rw [← inf_eq_right.mpr affine_le_separated] },
  simp only [inf_comm, inf_assoc, inf_left_comm],
end

lemma proper.open_cover_iff {X Y : Scheme.{u}} (𝒰 : Scheme.open_cover.{u} Y)
  (f : X ⟶ Y) :
  proper f ↔ ∀ i, proper (pullback.snd : pullback f (𝒰.map i) ⟶ _) :=
proper_is_local_at_target.open_cover_iff f 𝒰

instance {X Y S : Scheme} (f : X ⟶ S) (g : Y ⟶ S) [proper g] :
  proper (pullback.fst : pullback f g ⟶ X) :=
proper_stable_under_base_change.fst f g infer_instance

instance {X Y S : Scheme} (f : X ⟶ S) (g : Y ⟶ S) [proper f] :
  proper (pullback.snd : pullback f g ⟶ Y) :=
proper_stable_under_base_change.snd f g infer_instance

lemma universally_closed.of_comp [universally_closed (f ≫ g)] [separated g] :
  universally_closed f :=
by { rw [← pullback.lift_comp_snd f g], apply_instance }

lemma proper.of_comp [proper (f ≫ g)] [separated g] : proper f :=
by { rw [← pullback.lift_comp_snd f g], apply_instance }

end algebraic_geometry


-- /-
-- Copyright (c) 2019 The Flypitch Project. All rights reserved.
-- Released under Apache 2.0 license as described in the file LICENSE.
-- Author(s): Jesse Michael Han, Floris van Doorn

-- Parsing formulas from Lean expressions.
-- -/

-- import .fol' tactic data.list

-- universe u

-- /- toy example by Mario -/
-- section fmla
-- @[derive has_reflect]
-- inductive fmla
-- | var : nat → fmla
-- | pi : fmla → fmla

-- meta def to_fmla : pexpr → option fmla
-- | (expr.var n) := some (fmla.var n)
-- | (expr.pi _ _ _ e) := fmla.pi <$> to_fmla e
-- | _ := none

-- end fmla

-- namespace tactic
-- namespace interactive

-- section parse_fmla
-- open interactive interactive.types expr

-- meta def parse_fmla (e : parse texpr) : tactic unit :=
-- do f <- to_fmla e, tactic.exact `(f)

-- end parse_fmla
-- end interactive
-- end tactic

-- def foo : fmla := by parse_fmla (∀ x : ℕ, x)
-- -- #print foo -- fmla.pi (fmla.var 0)
-- /- end toy example -/

-- open fol
-- meta instance preterm.reflect {L : Language.{0}} [reflected L] [∀ n, has_reflect (L.functions n)] :
--   ∀{n}, has_reflect (preterm L n)
-- | _ &k          := `(&k)
-- | _ (func f)    := `(func f)
-- | _ (app t₁ t₂) := (`(λ x y, app x y).subst (preterm.reflect t₁)).subst (preterm.reflect t₂)

-- meta instance preformula.reflect {L : Language.{0}} [reflected L] [∀ n, has_reflect (L.functions n)]
--   [∀ n, has_reflect (L.relations n)] : ∀{n}, has_reflect (preformula L n)
-- | _ falsum           := `(falsum)
-- | _ (equal t₁ t₂)    := (`(λ x₁ x₂, equal x₁ x₂).subst (preterm.reflect t₁)).subst (preterm.reflect t₂)
-- | _ (rel R)          := `(λ x, preformula.rel x).subst `(R)
-- | _ (apprel f t)     := (`(λ x₁ x₂, apprel x₁ x₂).subst (preformula.reflect f)).subst (preterm.reflect t)
-- | _ (imp f₁ f₂)      := (`(λ x₁ x₂, imp x₁ x₂).subst (preformula.reflect f₁)).subst (preformula.reflect f₂)
-- | _ (all f)          := `(λ x, all x).subst (preformula.reflect f)

-- meta instance L_empty.reflect : reflected L_empty := by apply_instance
-- meta instance L_empty_functions_reflect : ∀ n, has_reflect (L_empty.functions n) :=
-- λ _ _, empty.elim ‹_›

-- meta instance L_empty_relations_reflect : ∀ n, has_reflect (L_empty.relations n) :=
-- λ _ _, empty.elim ‹_›

-- section L_empty_parse

-- meta def to_term_empty : Π {n : ℕ}, expr → option (preterm L_empty n)
-- | 0     (expr.var k)    := some (var k)
-- | _     _               := none

-- -- TODO(jesse) insert a case analysis on whether e' : Prop to determine whether or not to use imp
-- meta def to_formula_empty : Π {n : ℕ}, expr → option (preformula L_empty n)
-- | 0 (expr.pi _ _ e' e)     := ((to_formula_empty e) >>= (λ f, return (all f)))
-- | 0 `(%%a = %%b)          := do e₁ <- to_term_empty a, e₂ <- to_term_empty b,
--                                return $ equal e₁ e₂
-- -- | 0 `(%%a → %%b)          := do e₁ <- to_formula_empty a, e₂ <- to_formula_empty b,
-- --                                return $ imp e₁ e₂ -- equation compiler thinks this case
--                                    -- is redundant since a → b compiles to Π _ : a, b
-- | 0 `(false)              := return (falsum)
-- | 0  _                    := none
-- | (n+1) _                 := none

-- end L_empty_parse
-- namespace tactic
-- namespace interactive

-- open interactive interactive.types expr
-- meta def parse_formula (t : parse texpr) : tactic unit :=
--   do f <- ((@to_formula_empty 0) <$> (to_expr t)),
--      match f with
--      | (some ϕ) := tactic.exact `(ϕ)
--      | none     := tactic.fail "to_formula_empty failed to parse"
--      end

-- end interactive
-- end tactic

-- -- meta def test : expr := `(true → true)

-- -- meta def test' : expr := `(∀ x : ℕ, x = 0)

-- -- #eval (@expr.to_raw_fmt tt test).to_string

-- -- #eval (@expr.to_raw_fmt tt test').to_string

-- def my_little_formula : preformula L_empty 0 :=
-- by parse_formula (∀ x : ℕ, x = x)

-- def my_larger_formula : preformula L_empty _ :=
-- by parse_formula (∀ x y : ℕ, (x = y))

-- -- #reduce my_little_formula -- it works!
-- -- ∀'(&0 ≃ &0)

-- -- #reduce my_larger_formula -- it still works!
-- -- ∀'∀'(&1 ≃ &0)


/-
Copyright (c) 2022 Yaël Dillies. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies
-/
import category_theory.concrete_category.basic

/-!
# The category of pointed types

This defines `Pointed`, the category of pointed types.

## TODO

* Monoidal structure
* Upgrade `Type_to_Pointed` to an equivalence
-/

open category_theory

universes u
variables {α β : Type*}

/-- The category of pointed types. -/
structure Pointed : Type.{u + 1} :=
(X : Type.{u})
(point : X)

namespace Pointed

instance : has_coe_to_sort Pointed Type* := ⟨X⟩

attribute [protected] Pointed.X

/-- Turns a point into a pointed type. -/
def of {X : Type*} (point : X) : Pointed := ⟨X, point⟩

@[simp] lemma coe_of {X : Type*} (point : X) : ↥(of point) = X := rfl

alias of ← _root_.prod.Pointed

instance : inhabited Pointed := ⟨of ((), ())⟩

/-- Morphisms in `Pointed`. -/
@[ext] protected structure hom (X Y : Pointed.{u}) : Type u :=
(to_fun : X → Y)
(map_point : to_fun X.point = Y.point)

namespace hom

/-- The identity morphism of `X : Pointed`. -/
@[simps] def id (X : Pointed) : hom X X := ⟨id, rfl⟩

instance (X : Pointed) : inhabited (hom X X) := ⟨id X⟩

/-- Composition of morphisms of `Pointed`. -/
@[simps] def comp {X Y Z : Pointed.{u}} (f : hom X Y) (g : hom Y Z) : hom X Z :=
⟨g.to_fun ∘ f.to_fun, by rw [function.comp_apply, f.map_point, g.map_point]⟩

end hom

instance large_category : large_category Pointed :=
{ hom := hom,
  id := hom.id,
  comp := @hom.comp,
  id_comp' := λ _ _ _, hom.ext _ _ rfl,
  comp_id' := λ _ _ _, hom.ext _ _ rfl,
  assoc' := λ _ _ _ _ _ _ _, hom.ext _ _ rfl }

instance concrete_category : concrete_category Pointed :=
{ forget := { obj := Pointed.X, map := @hom.to_fun },
  forget_faithful := ⟨@hom.ext⟩ }

/-- Constructs a isomorphism between pointed types from an equivalence that preserves the point
between them. -/
@[simps] def iso.mk {α β : Pointed} (e : α ≃ β) (he : e α.point = β.point) : α ≅ β :=
{ hom := ⟨e, he⟩,
  inv := ⟨e.symm, e.symm_apply_eq.2 he.symm⟩,
  hom_inv_id' := Pointed.hom.ext _ _ e.symm_comp_self,
  inv_hom_id' := Pointed.hom.ext _ _ e.self_comp_symm }

end Pointed

/-- `option` as a functor from types to pointed types. This is the free functor. -/
@[simps] def Type_to_Pointed : Type.{u} ⥤ Pointed.{u} :=
{ obj := λ X, ⟨option X, none⟩,
  map := λ X Y f, ⟨option.map f, rfl⟩,
  map_id' := λ X, Pointed.hom.ext _ _ option.map_id,
  map_comp' := λ X Y Z f g, Pointed.hom.ext _ _ (option.map_comp_map _ _).symm }

/-- `Type_to_Pointed` is the free functor. -/
def Type_to_Pointed_forget_adjunction : Type_to_Pointed ⊣ forget Pointed :=
adjunction.mk_of_hom_equiv
{ hom_equiv := λ X Y, { to_fun := λ f, f.to_fun ∘ option.some,
                        inv_fun := λ f, ⟨λ o, o.elim Y.point f, rfl⟩,
                        left_inv := λ f, by { ext, cases x, exact f.map_point.symm, refl },
                        right_inv := λ f, funext $ λ _, rfl },
  hom_equiv_naturality_left_symm' := λ X' X Y f g, by { ext, cases x; refl }, }


/-
Copyright (c) 2018 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Jannis Limperg

Facts about `ulift` and `plift`.
-/

universes u v

namespace plift

variables {α : Sort u} {β : Sort v}

/-- Functorial action. -/
@[simp] protected def map (f : α → β) : plift α → plift β
| (up a) := up (f a)

/-- Embedding of pure values. -/
@[simp] protected def pure : α → plift α := up

/-- Applicative sequencing. -/
@[simp] protected def seq : plift (α → β) → plift α → plift β
| (up f) (up a) := up (f a)

/-- Monadic bind. -/
@[simp] protected def bind : plift α → (α → plift β) → plift β
| (up a) f := f a

instance : monad plift :=
{ map := @plift.map,
  pure := @plift.pure,
  seq := @plift.seq,
  bind := @plift.bind }

instance : is_lawful_functor plift :=
{ id_map := λ α ⟨x⟩, rfl,
  comp_map := λ α β γ g h ⟨x⟩, rfl }

instance : is_lawful_applicative plift :=
{ pure_seq_eq_map := λ α β g ⟨x⟩, rfl,
  map_pure := λ α β g x, rfl,
  seq_pure := λ α β ⟨g⟩ x, rfl,
  seq_assoc := λ α β γ ⟨x⟩ ⟨g⟩ ⟨h⟩, rfl }

instance : is_lawful_monad plift :=
{ bind_pure_comp_eq_map := λ α β f ⟨x⟩, rfl,
  bind_map_eq_seq := λ α β ⟨a⟩ ⟨b⟩, rfl,
  pure_bind := λ α β x f, rfl,
  bind_assoc := λ α β γ ⟨x⟩ f g, rfl }

@[simp] lemma rec.constant {α : Sort u} {β : Type v} (b : β) :
  @plift.rec α (λ _, β) (λ _, b) = λ _, b :=
funext (λ x, plift.cases_on x (λ a, eq.refl (plift.rec (λ a', b) {down := a})))

end plift

namespace ulift

variables {α : Type u} {β : Type v}

/-- Functorial action. -/
@[simp] protected def map (f : α → β) : ulift α → ulift β
| (up a) := up (f a)

/-- Embedding of pure values. -/
@[simp] protected def pure : α → ulift α := up

/-- Applicative sequencing. -/
@[simp] protected def seq : ulift (α → β) → ulift α → ulift β
| (up f) (up a) := up (f a)

/-- Monadic bind. -/
@[simp] protected def bind : ulift α → (α → ulift β) → ulift β
| (up a) f := up (down (f a))
-- The `up ∘ down` gives us more universe polymorphism than simply `f a`.

instance : monad ulift :=
{ map := @ulift.map,
  pure := @ulift.pure,
  seq := @ulift.seq,
  bind := @ulift.bind }

instance : is_lawful_functor ulift :=
{ id_map := λ α ⟨x⟩, rfl,
  comp_map := λ α β γ g h ⟨x⟩, rfl }

instance : is_lawful_applicative ulift :=
{ pure_seq_eq_map := λ α β g ⟨x⟩, rfl,
  map_pure := λ α β g x, rfl,
  seq_pure := λ α β ⟨g⟩ x, rfl,
  seq_assoc := λ α β γ ⟨x⟩ ⟨g⟩ ⟨h⟩, rfl }

instance : is_lawful_monad ulift :=
{ bind_pure_comp_eq_map := λ α β f ⟨x⟩, rfl,
  bind_map_eq_seq := λ α β ⟨a⟩ ⟨b⟩, rfl,
  pure_bind := λ α β x f,
    by { dsimp only [bind, pure, ulift.pure, ulift.bind], cases (f x), refl },
  bind_assoc := λ α β γ ⟨x⟩ f g,
    by { dsimp only [bind, pure, ulift.pure, ulift.bind], cases (f x), refl } }

@[simp] lemma rec.constant {α : Type u} {β : Sort v} (b : β) :
  @ulift.rec α (λ _, β) (λ _, b) = λ _, b :=
funext (λ x, ulift.cases_on x (λ a, eq.refl (ulift.rec (λ a', b) {down := a})))

end ulift


/-
Copyright (c) 2019 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Bhavik Mehta
-/
import category_theory.monad.basic
import category_theory.adjunction.basic
import category_theory.reflects_isomorphisms

/-!
# Eilenberg-Moore (co)algebras for a (co)monad

This file defines Eilenberg-Moore (co)algebras for a (co)monad,
and provides the category instance for them.

Further it defines the adjoint pair of free and forgetful functors, respectively
from and to the original category, as well as the adjoint pair of forgetful and
cofree functors, respectively from and to the original category.

## References
* [Riehl, *Category theory in context*, Section 5.2.4][riehl2017]
-/

namespace category_theory
open category

universes v₁ u₁ -- morphism levels before object levels. See note [category_theory universes].

variables {C : Type u₁} [category.{v₁} C]

namespace monad

/-- An Eilenberg-Moore algebra for a monad `T`.
    cf Definition 5.2.3 in [Riehl][riehl2017]. -/
structure algebra (T : monad C) : Type (max u₁ v₁) :=
(A : C)
(a : (T : C ⥤ C).obj A ⟶ A)
(unit' : T.η.app A ≫ a = 𝟙 A . obviously)
(assoc' : T.μ.app A ≫ a = (T : C ⥤ C).map a ≫ a . obviously)

restate_axiom algebra.unit'
restate_axiom algebra.assoc'
attribute [reassoc] algebra.unit algebra.assoc

namespace algebra
variables {T : monad C}

/-- A morphism of Eilenberg–Moore algebras for the monad `T`. -/
@[ext] structure hom (A B : algebra T) :=
(f : A.A ⟶ B.A)
(h' : (T : C ⥤ C).map f ≫ B.a = A.a ≫ f . obviously)

restate_axiom hom.h'
attribute [simp, reassoc] hom.h

namespace hom

/-- The identity homomorphism for an Eilenberg–Moore algebra. -/
def id (A : algebra T) : hom A A :=
{ f := 𝟙 A.A }

instance (A : algebra T) : inhabited (hom A A) := ⟨{ f := 𝟙 _ }⟩

/-- Composition of Eilenberg–Moore algebra homomorphisms. -/
def comp {P Q R : algebra T} (f : hom P Q) (g : hom Q R) : hom P R :=
{ f := f.f ≫ g.f }

end hom

instance : category_struct (algebra T) :=
{ hom := hom,
  id := hom.id,
  comp := @hom.comp _ _ _ }

@[simp] lemma comp_eq_comp {A A' A'' : algebra T} (f : A ⟶ A') (g : A' ⟶ A'') :
  algebra.hom.comp f g = f ≫ g := rfl
@[simp] lemma id_eq_id (A : algebra T) :
  algebra.hom.id A = 𝟙 A := rfl

@[simp]

/-- The category of Eilenberg-Moore algebras for a monad.
    cf Definition 5.2.4 in [Riehl][riehl2017]. -/
instance EilenbergMoore : category (algebra T) := {}.

/--
To construct an isomorphism of algebras, it suffices to give an isomorphism of the carriers which
commutes with the structure morphisms.
-/
@[simps]
def iso_mk {A B : algebra T} (h : A.A ≅ B.A) (w : (T : C ⥤ C).map h.hom ≫ B.a = A.a ≫ h.hom) :
  A ≅ B :=
{ hom := { f := h.hom },
  inv :=
  { f := h.inv,
    h' := by { rw [h.eq_comp_inv, category.assoc, ←w, ←functor.map_comp_assoc], simp } } }

end algebra

variables (T : monad C)

/-- The forgetful functor from the Eilenberg-Moore category, forgetting the algebraic structure. -/
@[simps] def forget : algebra T ⥤ C :=
{ obj := λ A, A.A,
  map := λ A B f, f.f }

/-- The free functor from the Eilenberg-Moore category, constructing an algebra for any object. -/
@[simps] def free : C ⥤ algebra T :=
{ obj := λ X,
  { A := T.obj X,
    a := T.μ.app X,
    assoc' := (T.assoc _).symm },
  map := λ X Y f,
  { f := T.map f,
    h' := T.μ.naturality _ } }

instance [inhabited C] : inhabited (algebra T) :=
⟨(free T).obj (default C)⟩

/-- The adjunction between the free and forgetful constructions for Eilenberg-Moore algebras for
  a monad. cf Lemma 5.2.8 of [Riehl][riehl2017]. -/
-- The other two `simps` projection lemmas can be derived from these two, so `simp_nf` complains if
-- those are added too
@[simps unit counit]
def adj : T.free ⊣ T.forget :=
adjunction.mk_of_hom_equiv
{ hom_equiv := λ X Y,
  { to_fun := λ f, T.η.app X ≫ f.f,
    inv_fun := λ f,
    { f := T.map f ≫ Y.a,
      h' := by { dsimp, simp [←Y.assoc, ←T.μ.naturality_assoc] } },
    left_inv := λ f, by { ext, dsimp, simp },
    right_inv := λ f,
    begin
      dsimp only [forget_obj, monad_to_functor_eq_coe],
      rw [←T.η.naturality_assoc, Y.unit],
      apply category.comp_id,
    end }}

/--
Given an algebra morphism whose carrier part is an isomorphism, we get an algebra isomorphism.
-/
lemma algebra_iso_of_iso {A B : algebra T} (f : A ⟶ B) [is_iso f.f] : is_iso f :=
⟨⟨{ f := inv f.f,
    h' := by { rw [is_iso.eq_comp_inv f.f, category.assoc, ← f.h], simp } }, by tidy⟩⟩

instance forget_reflects_iso : reflects_isomorphisms T.forget :=
{ reflects := λ A B, algebra_iso_of_iso T }

instance forget_faithful : faithful T.forget := {}

instance : is_right_adjoint T.forget := ⟨T.free, T.adj⟩
@[simp] lemma left_adjoint_forget : left_adjoint T.forget = T.free := rfl
@[simp] lemma of_right_adjoint_forget : adjunction.of_right_adjoint T.forget = T.adj := rfl

/--
Given a monad morphism from `T₂` to `T₁`, we get a functor from the algebras of `T₁` to algebras of
`T₂`.
-/
@[simps]
def algebra_functor_of_monad_hom {T₁ T₂ : monad C} (h : T₂ ⟶ T₁) :
  algebra T₁ ⥤ algebra T₂ :=
{ obj := λ A,
  { A := A.A,
    a := h.app A.A ≫ A.a,
    unit' := by { dsimp, simp [A.unit] },
    assoc' := by { dsimp, simp [A.assoc] } },
  map := λ A₁ A₂ f,
  { f := f.f } }

/--
The identity monad morphism induces the identity functor from the category of algebras to itself.
-/
@[simps {rhs_md := semireducible}]
def algebra_functor_of_monad_hom_id {T₁ : monad C} :
  algebra_functor_of_monad_hom (𝟙 T₁) ≅ 𝟭 _ :=
nat_iso.of_components
  (λ X, algebra.iso_mk (iso.refl _) (by { dsimp, simp, }))
  (λ X Y f, by { ext, dsimp, simp })

/--
A composition of monad morphisms gives the composition of corresponding functors.
-/
@[simps {rhs_md := semireducible}]
def algebra_functor_of_monad_hom_comp {T₁ T₂ T₃ : monad C} (f : T₁ ⟶ T₂) (g : T₂ ⟶ T₃) :
  algebra_functor_of_monad_hom (f ≫ g) ≅
    algebra_functor_of_monad_hom g ⋙ algebra_functor_of_monad_hom f :=
nat_iso.of_components
  (λ X, algebra.iso_mk (iso.refl _) (by { dsimp, simp }))
  (λ X Y f, by { ext, dsimp, simp })

/--
If `f` and `g` are two equal morphisms of monads, then the functors of algebras induced by them
are isomorphic.
We define it like this as opposed to using `eq_to_iso` so that the components are nicer to prove
lemmas about.
-/
@[simps {rhs_md := semireducible}]
def algebra_functor_of_monad_hom_eq {T₁ T₂ : monad C} {f g : T₁ ⟶ T₂} (h : f = g) :
  algebra_functor_of_monad_hom f ≅ algebra_functor_of_monad_hom g :=
nat_iso.of_components
  (λ X, algebra.iso_mk (iso.refl _) (by { dsimp, simp [h] }))
  (λ X Y f, by { ext, dsimp, simp })

/--
Isomorphic monads give equivalent categories of algebras. Furthermore, they are equivalent as
categories over `C`, that is, we have `algebra_equiv_of_iso_monads h ⋙ forget = forget`.
-/
@[simps]
def algebra_equiv_of_iso_monads {T₁ T₂ : monad C} (h : T₁ ≅ T₂) :
  algebra T₁ ≌ algebra T₂ :=
{ functor := algebra_functor_of_monad_hom h.inv,
  inverse := algebra_functor_of_monad_hom h.hom,
  unit_iso :=
    algebra_functor_of_monad_hom_id.symm ≪≫
    algebra_functor_of_monad_hom_eq (by simp) ≪≫
    algebra_functor_of_monad_hom_comp _ _,
  counit_iso :=
    (algebra_functor_of_monad_hom_comp _ _).symm ≪≫
    algebra_functor_of_monad_hom_eq (by simp) ≪≫
    algebra_functor_of_monad_hom_id }

@[simp] lemma algebra_equiv_of_iso_monads_comp_forget {T₁ T₂ : monad C} (h : T₁ ⟶ T₂) :
  algebra_functor_of_monad_hom h ⋙ forget _ = forget _ :=
rfl

end monad

namespace comonad

/-- An Eilenberg-Moore coalgebra for a comonad `T`. -/
@[nolint has_inhabited_instance]
structure coalgebra (G : comonad C) : Type (max u₁ v₁) :=
(A : C)
(a : A ⟶ (G : C ⥤ C).obj A)
(counit' : a ≫ G.ε.app A = 𝟙 A . obviously)
(coassoc' : a ≫ G.δ.app A = a ≫ G.map a . obviously)

restate_axiom coalgebra.counit'
restate_axiom coalgebra.coassoc'
attribute [reassoc] coalgebra.counit coalgebra.coassoc

namespace coalgebra
variables {G : comonad C}

/-- A morphism of Eilenberg-Moore coalgebras for the comonad `G`. -/
@[ext, nolint has_inhabited_instance] structure hom (A B : coalgebra G) :=
(f : A.A ⟶ B.A)
(h' : A.a ≫ (G : C ⥤ C).map f = f ≫ B.a . obviously)

restate_axiom hom.h'
attribute [simp, reassoc] hom.h

namespace hom

/-- The identity homomorphism for an Eilenberg–Moore coalgebra. -/
def id (A : coalgebra G) : hom A A :=
{ f := 𝟙 A.A }

/-- Composition of Eilenberg–Moore coalgebra homomorphisms. -/
def comp {P Q R : coalgebra G} (f : hom P Q) (g : hom Q R) : hom P R :=
{ f := f.f ≫ g.f }

end hom

/-- The category of Eilenberg-Moore coalgebras for a comonad. -/
instance : category_struct (coalgebra G) :=
{ hom := hom,
  id := hom.id,
  comp := @hom.comp _ _ _ }

@[simp] lemma comp_eq_comp {A A' A'' : coalgebra G} (f : A ⟶ A') (g : A' ⟶ A'') :
  coalgebra.hom.comp f g = f ≫ g := rfl
@[simp] lemma id_eq_id (A : coalgebra G) :
  coalgebra.hom.id A = 𝟙 A := rfl

@[simp] lemma id_f (A : coalgebra G) : (𝟙 A : A ⟶ A).f = 𝟙 A.A := rfl
@[simp] lemma comp_f {A A' A'' : coalgebra G} (f : A ⟶ A') (g : A' ⟶ A'') :
  (f ≫ g).f = f.f ≫ g.f := rfl

/-- The category of Eilenberg-Moore coalgebras for a comonad. -/
instance EilenbergMoore : category (coalgebra G) := {}.

/--
To construct an isomorphism of coalgebras, it suffices to give an isomorphism of the carriers which
commutes with the structure morphisms.
-/
@[simps]
def iso_mk {A B : coalgebra G} (h : A.A ≅ B.A) (w : A.a ≫ (G : C ⥤ C).map h.hom = h.hom ≫ B.a) :
  A ≅ B :=
{ hom := { f := h.hom },
  inv :=
  { f := h.inv,
    h' := by { rw [h.eq_inv_comp, ←reassoc_of w, ←functor.map_comp], simp } } }

end coalgebra

variables (G : comonad C)

/-- The forgetful functor from the Eilenberg-Moore category, forgetting the coalgebraic
structure. -/
@[simps] def forget : coalgebra G ⥤ C :=
{ obj := λ A, A.A,
  map := λ A B f, f.f }

/-- The cofree functor from the Eilenberg-Moore category, constructing a coalgebra for any
object. -/
@[simps] def cofree : C ⥤ coalgebra G :=
{ obj := λ X,
  { A := G.obj X,
    a := G.δ.app X,
    coassoc' := (G.coassoc _).symm },
  map := λ X Y f,
  { f := G.map f,
    h' := (G.δ.naturality _).symm } }

/--
The adjunction between the cofree and forgetful constructions for Eilenberg-Moore coalgebras
for a comonad.
-/
-- The other two `simps` projection lemmas can be derived from these two, so `simp_nf` complains if
-- those are added too
@[simps unit counit]
def adj : G.forget ⊣ G.cofree :=
adjunction.mk_of_hom_equiv
{ hom_equiv := λ X Y,
  { to_fun := λ f,
    { f := X.a ≫ G.map f,
      h' := by { dsimp, simp [←coalgebra.coassoc_assoc] } },
    inv_fun := λ g, g.f ≫ G.ε.app Y,
    left_inv := λ f,
      by { dsimp, rw [category.assoc, G.ε.naturality, functor.id_map, X.counit_assoc] },
    right_inv := λ g,
    begin
      ext1, dsimp,
      rw [functor.map_comp, g.h_assoc, cofree_obj_a, comonad.right_counit],
      apply comp_id,
    end }}

/--
Given a coalgebra morphism whose carrier part is an isomorphism, we get a coalgebra isomorphism.
-/
lemma coalgebra_iso_of_iso {A B : coalgebra G} (f : A ⟶ B) [is_iso f.f] : is_iso f :=
⟨⟨{ f := inv f.f,
    h' := by { rw [is_iso.eq_inv_comp f.f, ←f.h_assoc], simp } }, by tidy⟩⟩

instance forget_reflects_iso : reflects_isomorphisms G.forget :=
{ reflects := λ A B, coalgebra_iso_of_iso G }

instance forget_faithful : faithful (forget G) := {}

instance : is_left_adjoint G.forget := ⟨_, G.adj⟩
@[simp] lemma right_adjoint_forget : right_adjoint G.forget = G.cofree := rfl
@[simp] lemma of_left_adjoint_forget : adjunction.of_left_adjoint G.forget = G.adj := rfl

end comonad

end category_theory


import o_minimal.sheaf.yoneda
import .choice3
import .choice4

open o_minimal

universe u

variables {R : Type u} [OQM R]
variables {S : struc R} [o_minimal_add S]

-- We need Y and R to live in the same universe to apply `def_graph`.
-- Is this really necessary?

-- jmc: ↑ is now obsolete

variables {Y : Type*} [has_coordinates R Y] [is_definable S Y]

local notation `½` := (1/2 : ℚ)

lemma definable_choice_1 {s : set (Y × R)} (ds : def_set S s) (h : prod.fst '' s = set.univ) :
  ∃ g : Y → R, def_fun S g ∧ ∀ y, (y, g y) ∈ s :=
begin
  have ne : ∀ y, set.nonempty {r | (y, r) ∈ s},
  { intro y,
    change ∃ r, (y, r) ∈ s,
    { have : y ∈ prod.fst '' s := by { rw h, trivial },
      obtain ⟨⟨y', x⟩, h, rfl⟩ := this,
      exact ⟨x, h⟩ } },
  refine ⟨λ y, (chosen_one {r | (y, r) ∈ s}), _, _⟩,
  { unfold def_fun,
    letI : definable_sheaf S Y := definable_sheaf.rep,
    letI : definable_rep S Y := ⟨λ _ _, iff.rfl⟩,
    rw ←definable_iff_def_set,
    begin [defin]
      intro p,
      app, app, exact definable_sheaf.eq,
      swap,
      { app, exact definable.snd.definable _, var },
      { app, exact definable_chosen_one.definable _,
        intro r,
        app, app, exact definable.mem.definable _,
        app, app, exact definable.prod_mk.definable _,
        app, exact definable.fst.definable _, var, var,
        exact (definable_iff_def_set.mpr ds).definable _ }
    end },
  { intro y,
    let X := {r | (y, r) ∈ s},
    have nX : X.nonempty := ne y,
    have tX : tame X,
    { apply tame_of_def S,
      refine def_fun.preimage _ ds,
      exact def_fun.prod' def_fun_const def_fun.id },
    apply chosen_one_mem nX tX }
end
.

variables {X X₁ X₂ : Type*} [definable_sheaf S X] [definable_sheaf S X₁] [definable_sheaf S X₂]

def fibre_1 (s : set (X × R)) : X → set R := λ x, {r | (x, r) ∈ s}

lemma definable_fibre_1 {s : set (X × R)} (ds : definable S s) : definable S (fibre_1 s) :=
begin [defin]
  intro x,
  intro r,
  app, app, exact definable.mem.definable _,
  app, app, exact definable.prod_mk.definable _,
  var, var, exact ds.definable _
end

lemma definable_of_forall_definable_eq (f g : X₁ → X₂) (hf : definable S f) (H : ∀ x : X₁, definable S x → f x = g x) :
  definable S g :=
begin
  constructor,
  intros K L φ hφ,
  convert hf.definable K L φ hφ using 1,
  ext1,
  dsimp [function.uncurry],
  rw [H],
  rw ← definable_yoneda at hφ,
  begin [defin]
    app, exact definable.snd.definable _,
    app, exact hφ.definable _,
    exact def_fun_const
  end
end

lemma definable_chosen_one' : definable S (chosen_one' : set R → R) :=
begin
  refine definable_of_forall_definable_eq chosen_one _ definable_chosen_one _,
  intros s hs,
  unfold chosen_one chosen_one',
  rw dif_pos,
  apply tame_of_def S,
  rwa definable_iff_def_set at hs
end

noncomputable
def chosen_n' : Π {n : ℕ}, set (finvec n R) → finvec n R
| 0     s := fin_zero_elim
| (n+1) s :=
let t : set (finvec n R) := finvec.init '' s,
    a : finvec n R       := chosen_n' t,
    X : set R            := {r | a.snoc r ∈ s}
in a.snoc (chosen_one' X)

lemma chosen_n'_mem : ∀ {n : ℕ} {s : set (finvec n R)} (hs : s.nonempty), chosen_n' s ∈ s
| 0     s hs := by { obtain ⟨x, hx⟩ := hs, convert hx }
| (n+1) s hs :=
let t : set (finvec n R) := finvec.init '' s,
    a : finvec n R       := chosen_n' t,
    X : set R            := {r | a.snoc r ∈ s}
in
begin
  have ht : t.nonempty, by { rwa set.nonempty_image_iff },
  have hat : a ∈ t := chosen_n'_mem ht,
  have hX : X.nonempty,
  { obtain ⟨v, hv, H⟩ := hat, rw [← finvec.init_snoc_last v, H] at hv, exact ⟨v.last, hv⟩ },
  have := chosen_one'_mem hX,
  rwa [chosen_n']
end

instance (n : ℕ) : definable_sheaf S (finvec n R) :=
definable_sheaf.rep

instance (n : ℕ) : definable_rep S (finvec n R) :=
⟨λ _ _, iff.rfl⟩

lemma definable_chosen_n' : ∀ (n : ℕ), definable S (chosen_n' : set (finvec n R) → finvec n R)
| 0     :=
begin [defin]
  intro s,
  exact (show definable_sheaf.definable (λ (i : ↥Γ), fin_zero_elim), by exact def_fun_const)
end
| (n+1) :=
begin
  show (definable S (λ s, chosen_n' s)),
  conv { congr, funext, rw [chosen_n'] },
  dsimp [set_of],
begin [defin]
  intro s,
  app, app, exact sorry,
  app, exact (definable_chosen_n' n).definable _,
  app, app, exact sorry, exact sorry,
  var,
  app, exact definable_chosen_one'.definable _,
  intro r,
  app, app, exact definable.mem.definable _,
  app, app, exact sorry,
  app, exact (definable_chosen_n' n).definable _,
  app, app, exact sorry, exact sorry,
  var, var, var,
  end
end

noncomputable
def chosen_1 (s : set (X × R)) : X → R := chosen_one' ∘ (fibre_1 s)

lemma chosen_1_mem (s : set (X × R)) (h : prod.fst '' s = set.univ) (x : X) : (x, chosen_1 s x) ∈ s :=
begin
  suffices ne : ∀ x, set.nonempty {r | (x, r) ∈ s},
  by exact chosen_one'_mem (ne x),
  intro x,
  change ∃ r, (x, r) ∈ s,
  obtain ⟨⟨x', x⟩, h, rfl⟩ : x ∈ prod.fst '' s := by { rw h, trivial },
  exact ⟨x, h⟩
end

lemma definable_chosen_1 {s : set (X × R)} (ds : definable S s) : definable S (chosen_1 s) :=
begin [defin]
  intro x,
  app, exact definable_chosen_one'.definable _,
  app, exact (definable_fibre_1 ds).definable _,
  var
end

lemma definable_choice_1' {s : set (X × R)} (ds : definable S s) (h : prod.fst '' s = set.univ) :
  ∃ g : X → R, definable S g ∧ ∀ x, (x, g x) ∈ s :=
⟨chosen_1 s, definable_chosen_1 ds, chosen_1_mem s h⟩

-- new proof of `definable_choice_1` using `definable_rep` instead of `is_definable`
example {Y : Type*} [has_coordinates R Y] [definable_rep S Y]
  {s : set (Y × R)} (ds : def_set S s) (h : prod.fst '' s = set.univ) :
  ∃ g : Y → R, def_fun S g ∧ ∀ y, (y, g y) ∈ s :=
begin
  refine ⟨chosen_1 s, _, chosen_1_mem s h⟩,
  rw ← definable_iff_def_set at ds,
  rw ← definable_iff_def_fun,
  exact definable_chosen_1 ds
end


import FOL.translation

universes u v

namespace fol
open_locale logic_symbol
open term formula

variables {L L₁ L₂ L₃ : language.{u}}

namespace language
variables {C : Type u} [decidable_eq C]

namespace extension

lemma sum_inl_eq_coe_fn {n} (f : L.fn n) : sum.inl f = (↑f : (L + consts C).fn n) := rfl

lemma sum_inl_eq_coe_pr {n} (r : L.pr n) : sum.inl r = (↑r : (L + consts C).pr n) := rfl

lemma term.exists_of_le_coe {t : term (L + consts C)} {u : term L} (le : t ≤ (↑u : term (L + consts C))) :
  ∃ t₀ : term L, t = ↑t₀ :=
begin
  induction u generalizing t,
  case var : n
  { rcases eq_or_lt_of_le le with (rfl | lt), { refine ⟨#n, rfl⟩ }, simp at lt, contradiction },
  case app : n f v IH
  { rcases eq_or_lt_of_le le with (rfl | lt),
    { refine ⟨app f v, rfl⟩ },
    { simp at lt, rcases lt with ⟨i, le⟩, exact IH i le } }
end

lemma formula.exists_of_mem_coe {t : term (L + consts C)} {p : formula L} (mem : t ∈ (↑p : formula (L + consts C))) :
  ∃ t₀ : term L, t = ↑t₀ :=
begin
  induction p generalizing t,
  case app : n r v { simp at mem, rcases mem with ⟨i, le⟩, exact term.exists_of_le_coe le },
  case equal : t₁ t₂ { simp at mem, rcases mem with (le | le), { exact term.exists_of_le_coe le }, { exact term.exists_of_le_coe le } },
  case verum { simp at mem, contradiction },
  case imply : p q IH_p IH_q { simp at mem, rcases mem, { exact IH_p mem }, { exact IH_q mem } },
  case neg : p IH { simp at mem, exact IH mem },
  case fal : p IH { simp at mem, exact IH mem }
end

end extension

@[simp] def consts_of_t : term (L + consts C) → list C
| (#n)                      := []
| (@term.app _ n f v)       :=
  have h : ∀ i, (v i).complexity < (⨆ᶠ i, (v i).complexity) + 1, from λ i, nat.lt_succ_iff.mpr (le_fintype_sup (λ i, (v i).complexity) i),
  by { cases f, { exact list.Sup (λ i, consts_of_t (v i)) }, { cases n, exact [f], rcases f, } }

noncomputable def consts_of_p (p : formula (L + consts C)) : list C :=
(list.map consts_of_t ((formula.mem_finite p).to_finset.to_list)).join.dedup

@[simp] lemma consts_of_t_coe_eq_nil (t : term L) : consts_of_t (↑t : term (L + consts C)) = [] :=
by { simp[list.eq_nil_iff_forall_not_mem], induction t,
     case var { simp },
     case app : n f v IH
     { simp[←extension.sum_inl_eq_coe_fn, list.eq_nil_iff_forall_not_mem], intros c i, exact IH i c } }

@[simp] lemma consts_of_p_coe_eq_nil (p : formula L) : consts_of_p (↑p : formula (L + consts C)) = [] :=
by { simp[list.eq_nil_iff_forall_not_mem, consts_of_p], intros c t mem, rcases extension.formula.exists_of_mem_coe mem with ⟨t, rfl⟩, simp }

lemma mem_of_consts_of_t_rew (t : term (L + consts C)) (s) {c : C} (mem : c ∈ consts_of_t (t.rew s)) :
  c ∈ consts_of_t t ∨ ∃ n, c ∈ consts_of_t (s n) :=
begin
  induction t generalizing s c,
  case var : n { simp at mem, refine or.inr ⟨n, mem⟩ },
  case app : n f v IH
  { cases f,
    { simp at mem ⊢, rcases mem with ⟨i, mem⟩, rcases IH i s mem with (mem | mem),
      refine or.inl ⟨i, mem⟩, exact or.inr mem },
    { cases n, { simp at mem ⊢, simp[mem] }, { rcases f } } }
end

lemma mem_of_consts_of_t_subst (t u : term (L + consts C)) (k) {c : C} (mem : c ∈ consts_of_t (t.rew ı[k ⇝ u])) :
  c ∈ consts_of_t t ∨ c ∈ consts_of_t u :=
begin
  rcases mem_of_consts_of_t_rew _ _ mem with (mem | ⟨n, mem⟩),
  { exact or.inl mem },
  { have : n < k ∨ n = k ∨ k < n, from trichotomous n k, rcases this with (lt | rfl | lt),
    { simp[lt] at mem, contradiction }, { simp at mem, exact or.inr mem }, { simp[lt] at mem, contradiction } }
end

@[simp] lemma eq_of_consts_of_t_coe {c d : C} :
  c ∈ consts_of_t (d : term (L + consts C)) ↔ c = d :=
begin
  simp[consts.coe_def, show (↑(consts.c d) : (L + consts C).fn 0) = sum.inr (consts.c d), from rfl], refl
end

namespace add_consts
open language_translation language_translation_coe extension
  proof provable axiomatic_classical_logic' axiomatic_classical_logic

variables (Γ : list C) (b : ℕ)

def consts_to_var : C → ℕ := λ c, (list.index_of c Γ)

lemma consts_to_var_lt_Γ_of_mem {Γ : list C} {c : C} (mem : c ∈ Γ) : consts_to_var Γ c < Γ.length :=
by { simp[consts_to_var], exact list.index_of_lt_length.mpr mem }

@[simp] def elim_aux_t : term (L + consts C) → term L
| (#n)                      := if n < b then #n else #(Γ.length + n)
| (@term.app _ n f v)       :=
    by { cases f, { exact app f (λ i, elim_aux_t (v i)) },
         { rcases n, { exact #(consts_to_var Γ f + b) }, { rcases f } } }

@[simp] def elim_aux_f : ℕ → formula (L + consts C) → formula L
| b (app r v)                          := by { rcases r, { refine app r (λ i, elim_aux_t Γ b (v i)) }, { rcases r } }
| b ((t₁ : term (L + consts C)) =' t₂)  := elim_aux_t Γ b t₁ =' elim_aux_t Γ b t₂
| b ⊤                                  := ⊤
| b (p ⟶ q)                            := elim_aux_f b p ⟶ elim_aux_f b q
| b (∼p)                               := ∼elim_aux_f b p
| b (∀.p)                              := ∀.elim_aux_f (b + 1) p

def var_to_consts : ℕ → term (consts C) := λ n, if h : n < Γ.length then Γ.nth_le n h else #(n - Γ.length)

def formula_elim : formula (L + consts C) → formula L := λ p, ∀.[Γ.length] elim_aux_f Γ 0 p

@[simp] lemma term_elim_coe : ∀ (t : term L),
  elim_aux_t Γ b (t : term (L + consts C)) = t.rew (λ x, if x < b then #x else #(Γ.length + x))
| (#n)                      := by simp
| (@term.app _ n f v) := by { simp[coe_fn₁], funext i, exact term_elim_coe (v i) }

lemma formula_elim_coe : ∀ (b : ℕ) (p : formula L),
  elim_aux_f Γ b (p : formula (L + consts C)) = p.rew (λ x, if x < b then #x else #(Γ.length + x))
| b (app r v) := by simp[coe_pr₁]
| b (equal t u) := by simp
| b ⊤ := by simp
| b (p ⟶ q) := by simp[formula_elim_coe b p, formula_elim_coe b q]
| b (∼p) := by simp[formula_elim_coe b p]
| b (∀.p) := by { simp[formula_elim_coe (b + 1) p],
    have : (λ x, ite (x < b) #x #(Γ.length + x) : ℕ → term L)^1 = (λ x, ite (x < b + 1) #x #(Γ.length + x)),
    { funext x, simp[rewriting_sf_itr.pow_eq'],
      rcases x; simp[←nat.add_one], by_cases C : x < b; simp[C, nat.add_assoc] },
    simp[this] }

@[simp] lemma formula_elim_coe_0 (p : formula L) :
  elim_aux_f Γ 0 (p : formula (L + consts C)) = p^Γ.length :=
by simp[formula_elim_coe, formula.pow_eq, show ∀ x, Γ.length + x = x + Γ.length, from λ x, nat.add_comm (list.length Γ) x]

@[reducible] def shifting : ℕ → term L :=
λ x, if x ≤ Γ.length + b then if x = Γ.length + b then #b else if b ≤ x then #(x + 1) else #x else #x

variables {Γ}

lemma elim_aux_t_rew (b : ℕ) (t : term (L + consts C)) (hΓ : consts_of_t t ⊆ Γ) :
  (elim_aux_t Γ b t).rew (shifting Γ b) = elim_aux_t Γ (b + 1) t :=
begin
  induction t,
  case var : n
  { simp, have C : n < b ∨ n = b ∨ b < n, exact trichotomous n b,
    rcases C with (lt | rfl | lt),
    { simp[lt, nat.lt.step lt, show ¬b ≤ n, from not_le.mpr lt], rintros h rfl, simp at lt, contradiction  },
    { simp[shifting] },
    { simp[lt, show ¬n < b + 1, by simp[nat.lt_succ_iff.symm, ←nat.add_one, lt], show ¬ n < b, from asymm lt, show ¬ n ≤ b, from not_le.mpr lt] } },
  case app : n f v IH
  { rcases f,
    { simp at hΓ ⊢, ext i, refine IH i (set.subset.trans (list.ss_Sup _ i) hΓ) },
    { rcases n,
      { simp[shifting] at hΓ ⊢,
        have : consts_to_var Γ f < Γ.length, from consts_to_var_lt_Γ_of_mem hΓ,
        simp[le_of_lt this, ne_of_lt this, add_assoc] },  { rcases f } } }
end

lemma elim_aux_f_rew (b : ℕ) (p : formula (L + consts C)) (hΓ : ∀ t ∈ p, consts_of_t t ⊆ Γ):
  (elim_aux_f Γ b p).rew (shifting Γ b) = elim_aux_f Γ (b + 1) p :=
begin
  induction p generalizing b,
  case verum { simp },
  case app : n r v { rcases r; simp, { funext i, exact elim_aux_t_rew b (v i) (hΓ (v i) (by {simp, refine ⟨i, by simp⟩ })) }, { rcases r } },
  case equal : t u { simp, refine ⟨elim_aux_t_rew b t (hΓ t (by simp)), elim_aux_t_rew b u (hΓ u (by simp))⟩ },
  case imply : p q IHp IHq { simp, refine ⟨IHp (λ t mem, hΓ t (by simp[mem])) b, IHq (λ t mem, hΓ t (by simp[mem])) b⟩ },
  case neg : p IH { simp, exact IH (λ t mem, hΓ t (by simp[mem])) b },
  case fal : p IH
  { have : (shifting Γ b : ℕ → term L)^1 = shifting Γ (b + 1),
    { funext x, simp[rewriting_sf_itr.pow_eq', shifting], rcases x; simp[←nat.add_one, ←add_assoc, show 0 ≠ Γ.length + b + 1, by omega] },
    simp[this],
    exact IH (λ t mem, hΓ t (by simp[mem])) (b + 1) }
end

lemma formula_elim_equiv_self (T) (p : formula L) : T ⊢ formula_elim Γ ↑p ⟷ p :=
by simp[formula_elim]

def prf' (L : language) := Σ (T : Theory L) (k : ℕ) (p : formula L), T^k ⟹ p

variables (Γ)

private lemma elim_aux_t_subst (t u : term (L + consts C)) (s : ℕ) :
  elim_aux_t Γ s (t.rew ı[s ⇝ u]) = (elim_aux_t Γ (s + 1) t).rew ı[s ⇝ elim_aux_t Γ s u] :=
begin
  induction t,
  case var : n { simp, have : n < s ∨ n = s ∨ s < n, exact trichotomous n s,
    rcases this with (lt | rfl | lt),
    { simp[lt, show n < s + 1, from nat.lt.step lt] },
    { simp },
    { cases n, { simp at lt, contradiction },
      simp[←nat.add_one, lt, show ¬n < s, by omega, show s < Γ.length + (n + 1), by omega] } },
  case app : n f v IH
  { rcases f,
    { simp, funext i, exact IH i },
    { rcases n,
      { simp[←add_assoc, show s < consts_to_var Γ f + s + 1, by omega] }, { rcases f } } }
end

private lemma elim_aux_t_succ_pow (t : term (L + consts C)) (s : ℕ) (k : ℕ) :
  (elim_aux_t Γ s t)^k =  elim_aux_t Γ (s + k) (t^k) :=
begin
  induction t,
  case var : n { simp[add_assoc] },
  case app : n f v IH
  { rcases f,
    { simp, funext i, exact IH i },
    { rcases n, { simp[add_assoc] }, { rcases f } } }
end

private lemma elim_aux_t_succ_pow' (t : term (L + consts C)) (s : ℕ) (k : ℕ) :
  (elim_aux_t Γ s t)^k =  elim_aux_t Γ (s + k) (t^k) :=
begin
  induction t,
  case var : n { simp[add_assoc] },
  case app : n f v IH
  { rcases f,
    { simp, funext i, exact IH i },
    { rcases n, { simp[add_assoc] }, { rcases f } } }
end

private lemma  elim_aux_f_subst (p : formula (L + consts C)) (u : term (L + consts C)) (s : ℕ) :
  elim_aux_f Γ s (p.rew ı[s ⇝ u]) = (elim_aux_f Γ (s + 1) p).rew ı[s ⇝ elim_aux_t Γ s u] :=
begin
  induction p generalizing s u,
  case verum { simp },
  case app : n r v { rcases r, { simp[elim_aux_t_subst] }, { rcases r } },
  case equal : t u { simp[elim_aux_t_subst] },
  case imply : p q IH_p IH_q { simp, exact ⟨IH_p s u, IH_q s u⟩ },
  case neg : p IH { simp, exact IH s u },
  case fal : p IH { simp[subst_pow, elim_aux_t_succ_pow], exact IH (s + 1) (u^1) },
end

private lemma elim_aux_t_succ_pow_aux (t : term (L + consts C)) (s k : ℕ) :
  (elim_aux_t Γ s t).rew ((λ x, #(x + k))^s) =  elim_aux_t Γ (s + k) (t.rew ((λ x, #(x + k))^s)) :=
begin
  induction t generalizing s k,
  case var : n
  { simp, have : n < s ∨ s ≤ n, exact lt_or_ge n s,
    rcases this; simp[this],
    { simp[show n < s + k, from nat.lt_add_right n s k this] },
    { simp[show ¬n < s, from not_lt.mpr this, show n - s + k + s = n + k, by omega, show s ≤ Γ.length + n, from le_add_left this],
      show Γ.length + n - s + k + s = Γ.length + (n + k), omega } },
  case app : n f v IH
  { rcases f,
    { simp, funext i, exact IH i s k },
    { rcases n, { simp, omega }, { rcases f } } }
end

private lemma elim_aux_f_succ_pow_aux (p : formula (L + consts C)) (s k : ℕ) :
  (elim_aux_f Γ s p).rew ((λ x, #(x + k))^s) =  elim_aux_f Γ (s + k) (p.rew ((λ x, #(x + k))^s)) :=
begin
  induction p generalizing s k,
  case app : n r v
  { rcases r, { simp, funext i, exact elim_aux_t_succ_pow_aux Γ (v i) s k }, { rcases r } },
  case equal : t u { simp, exact ⟨elim_aux_t_succ_pow_aux Γ t s k, elim_aux_t_succ_pow_aux Γ u s k⟩ },
  case verum { simp },
  case imply : p q IH_p IH_q { simp* },
  case neg : p IH { simp* },
  case fal : p IH { simp, simp[rewriting_sf_itr.pow_add, IH (s + 1) k, show s + 1 + k = s + k + 1, by omega] },
end

private lemma elim_aux_f_succ_pow (p : formula (L + consts C)) (k : ℕ) :
  (elim_aux_f Γ 0 p)^k =  elim_aux_f Γ k (p^k) :=
begin
  simp[formula.pow_eq],
  have := elim_aux_f_succ_pow_aux Γ p 0 k, simp at this, exact this,
end

variables {Γ}

def prf'_to_prf (b : prf' L) : prf L := by { rcases b with ⟨T, k, p, b⟩, refine ⟨T^k, p, b⟩ }

private lemma  eq_axiom4_coe {n} (f : L.fn n) : eq_axiom4 (↑f : (L + consts C).fn n) = ↑(eq_axiom4 f) :=
by simp[eq_axiom4]

private lemma  eq_axiom5_coe {n} (r : L.pr n) : eq_axiom5 (↑r : (L + consts C).pr n) = ↑(eq_axiom5 r) :=
by simp[eq_axiom5]

lemma provable_formula_elim_of_proof_aux : ∀ {T : Theory L} {p : formula (L + consts C)} (B : ↑T ⟹ p)
  (hΓ : ∀ (t : term (L + consts C)) (h : t ∈ᵗ B), consts_of_t t ⊆ Γ), T ⊢ formula_elim Γ p :=
begin
  suffices : ∀ (T : Theory (L + consts C)) (p : formula (L + consts C)) (k : ℕ) (B : T^k ⟹ p)
    (hΓ : ∀ (t : term (L + consts C)) (h : t ∈ᵗ B), consts_of_t t ⊆ Γ) (T₀ : Theory L) (eqn : ↑T₀ = T),
    T₀^k ⊢ formula_elim Γ p,
  { intros T p B hΓ, exact this ↑T p 0 B hΓ T rfl },
  intros T' p' k' B',
  let C : Π (k : ℕ) (p : formula (L + consts C)) (b : T'^k ⟹ p), Prop :=
    (λ k p b, (∀ (t : term (L + consts C)), t ∈ᵗ b → consts_of_t t ⊆ Γ) →
      Π T₀, ↑T₀ = T' → T₀ ^ k ⊢ formula_elim Γ p),
  refine proof.rec''_on C k' p' B' _ _ _ _ _ _ _ _ _ _ _ _ _ _ _,
  { rintros k p B IH hΓ T rfl,
    simp[formula_elim] at IH ⊢,
    have : T^k ⊢ ∀.formula_elim Γ p, from (generalize (IH (λ t h, hΓ t (by simp[h])) T rfl)),
    have : T^k ⊢ ∀.[Γ.length + 1] elim_aux_f Γ 0 p, from this,
    have : T^k ⊢ ∀.[Γ.length + 1] (elim_aux_f Γ 0 p).rew (shifting Γ 0),
    { have := provable.nfal_rew (λ x, if x = Γ.length + 0 then #0 else if 0 ≤ x then #(x + 1) else #x) ⨀ this,
      simp only [nat.lt_succ_iff] at this, exact this },
    simp[elim_aux_f_rew 0 p (λ t h, hΓ t (by { simp, exact proof.mem_trans h (by simp) }))] at this,
    exact this },
  { rintros k p q B₁ B₂ IH₁ IH₂ hΓ T rfl,
    have IH₁ : T^k ⊢ formula_elim Γ (p ⟶ q), from IH₁ (λ t h, hΓ t (by simp[h])) T rfl,
    have IH₂ : T^k ⊢ formula_elim Γ p, from IH₂ (λ t h, hΓ t (by simp[h])) T rfl,
    simp[formula_elim] at IH₁ IH₂ ⊢,
    exact (provable.nfal_K _ _ _ ⨀ IH₁ ⨀ IH₂) },
  { rintros k p mem hΓ T rfl, simp[formula_elim] at mem ⊢,
    have : T^k ⊢ ∀.[Γ.length] elim_aux_f Γ 0 p,
    { have : ∃ (p' ∈ T), p = ↑p' ^ k, from Theory_mem_coe_pow_iff.mp mem, rcases this with ⟨p, p_mem, rfl⟩,
      rw ← coe_pow_formula, simp[-coe_pow_formula],
      show T^k ⊢ ∀.[Γ.length] (p ^ k) ^ Γ.length,
      have lmm₁ : T^k ⊢ p^k ⟶ (∀.[Γ.length] (p^k)^Γ.length), from (axiomatic_classical_logic'.iff_equiv.mp nfal_pow_equiv_self).2,
      have lmm₂ : T^k ⊢ p^k, exact sf_itr_sf_itr.mpr (by_axiom' p_mem),
      exact lmm₁ ⨀ lmm₂ },
    exact this },
  { rintros,  refine generalize_itr _, simp[formula_elim] },
  { rintros, refine generalize_itr _, simp[formula_elim] },
  { rintros, refine generalize_itr _, simp[formula_elim] },
  { rintros, refine generalize_itr _, simp[formula_elim] },
  { rintros, refine generalize_itr _, simp[formula_elim, elim_aux_f_subst] },
  { rintros, refine generalize_itr _, simp[formula_elim] },
  { rintros, refine generalize_itr _, simp[formula_elim, ←elim_aux_f_succ_pow] },
  { rintros, refine generalize_itr _, simp[formula_elim] },
  { rintros, refine generalize_itr _, simp[formula_elim] },
  { rintros, refine generalize_itr _, simp[formula_elim] },
  { rintros k m f hΓ T rfl, refine generalize_itr _, simp[formula_elim],
    rcases f,
    { simp[sum_inl_eq_coe_fn, eq_axiom4_coe] },
    { cases m, { simp[eq_axiom4] }, { rcases f } } },
  { rintros k m r hΓ T rfl, refine generalize_itr _, simp[formula_elim],
    rcases r,
    { simp[sum_inl_eq_coe_pr, eq_axiom5_coe] },
    { rcases r } }
end

noncomputable def consts_of {T : Theory (L + consts C)} {p : formula (L + consts C)} (b : T ⟹ p) : list C :=
(list.map consts_of_t ((proof.term_mem_finite b).to_finset.to_list)).join.dedup

lemma consts_list_spec {T : Theory (L + consts C)} {p : formula (L + consts C)}
  (b : T ⟹ p) (t : term (L + consts C)) (h : t ∈ᵗ b) : consts_of_t t ⊆ consts_of b := λ c mem,
by simp[consts_of]; refine ⟨t, h, mem⟩

theorem provable_formula_elim_of_proof {T : Theory L} {p : formula (L + consts C)} (b : ↑T ⟹ p) :
  T ⊢ formula_elim (consts_of b) p :=
provable_formula_elim_of_proof_aux b (consts_list_spec b)

theorem provable_iff {T : Theory L} {p : formula L} :
  ↑T ⊢ (↑p : formula (L + consts C)) ↔ T ⊢ p:=
⟨begin
  rintros ⟨b⟩,
  have lmm₁ : T ⊢ ∀.[(consts_of b).length] p^(consts_of b).length,
  { have := provable_formula_elim_of_proof b,
    simp[formula_elim] at this, exact this },
  have lmm₂ : T ⊢ (∀.[(consts_of b).length] p^(consts_of b).length) ⟶ p, from (axiomatic_classical_logic'.iff_equiv.mp nfal_pow_equiv_self).1,
  exact lmm₂ ⨀ lmm₁
end, provability⟩

theorem consistent_iff {T : Theory L} :
  (↑T : Theory (L + consts C)).consistent ↔ T.consistent :=
begin
  have : (↑T : Theory (L + consts C)) ⊢ ⊥ ↔ T ⊢ ⊥,
  { have : (↑T : Theory (L + consts C)) ⊢ ↑(⊥ : formula L) ↔ T ⊢ ⊥, from provable_iff,
    simp at this, exact this },
  simp[logic.Theory.consistent_iff_bot, this],
end

end add_consts

namespace consts_pelimination
open language_translation language_translation_coe extension
  proof provable axiomatic_classical_logic' axiomatic_classical_logic

variables (Γ : list C) (b : ℕ)

def consts_to_var (Γ : list C) : {c : C | c ∈ Γ} → ℕ := λ ⟨c, _⟩, (list.index_of c Γ : ℕ)

lemma consts_to_var_lt_Γ_of_mem {Γ : list C} {c : C} (mem : c ∈ Γ) : consts_to_var Γ ⟨c, mem⟩ < Γ.length :=
by { simp[consts_to_var], exact list.index_of_lt_length.mpr mem }

@[simp] def pelim_aux_t : term (L + consts C) → term (L + consts C)
| (#n)                      := if n < b then #n else #(Γ.length + n)
| (@term.app _ n f v)       :=
    by { cases f, { exact app ↑f (λ i, pelim_aux_t (v i)) },
         { rcases n, { by_cases h : f ∈ Γ, { exact #(consts_to_var Γ ⟨f, h⟩ + b) },
         { exact app ↑f finitary.nil } }, { rcases f } } }

@[simp] def pelim_aux_f : ℕ → formula (L + consts C) → formula (L + consts C)
| b (app r v)                          := by { rcases r, { refine app ↑r (λ i, pelim_aux_t Γ b (v i)) }, { rcases r } }
| b ((t₁ : term (L + consts C)) =' t₂)  := pelim_aux_t Γ b t₁ =' pelim_aux_t Γ b t₂
| b ⊤                                  := ⊤
| b (p ⟶ q)                            := pelim_aux_f b p ⟶ pelim_aux_f b q
| b (∼p)                               := ∼pelim_aux_f b p
| b (∀.p)                              := ∀.pelim_aux_f (b + 1) p

def formula_elim : formula (L + consts C) → formula (L + consts C) := λ p, ∀.[Γ.length] pelim_aux_f Γ 0 p

private lemma pelim_aux_t_pow_aux (t : term (L + consts C)) (i s k : ℕ) (le : s ≤ i) :
  pelim_aux_t Γ (i + k) (t.rew ((λ x, #(x + k))^s)) = (pelim_aux_t Γ i t).rew ((λ x, #(x + k)) ^ s) :=
begin
  induction t generalizing s k,
  case var : n
  { simp, have hn : n < s ∨ s ≤ n, exact lt_or_ge n s,
    rcases hn; simp[hn],
    { simp[hn, show n < i, from (gt_of_ge_of_gt le hn), show n < i + k, from nat.lt_add_right _ _ _ (gt_of_ge_of_gt le hn)] },
    { simp[show n - s + k + s = n + k, by omega],
      have hi : n < i ∨ i ≤ n, exact lt_or_ge n i,
      rcases hi, { simp[hi, hn], omega },
      { simp[show ¬n < i, from not_lt.mpr hi, show s ≤ Γ.length + n, from le_add_left hn], omega } } },
  case app : n f v IH
  { rcases f,
    { simp, funext i, exact IH i s k le },
    { rcases n,
      { by_cases mem : f ∈ Γ; simp[mem, le],
        { simp[show s ≤ consts_to_var Γ ⟨f, mem⟩ + i, from le_add_left le], omega } }, { rcases f } } }
end

private lemma pelim_aux_t_pow (t : term (L + consts C)) (i k : ℕ) :
  pelim_aux_t Γ (i + k) (t^k) = (pelim_aux_t Γ i t)^k :=
by { have :=  pelim_aux_t_pow_aux Γ t i 0 k (by simp), simp at this,
     simp[term.pow_eq], exact this }

lemma pelim_aux_t_subst (t u : term (L + consts C)) {s m : ℕ} (le : m ≤ s) :
  pelim_aux_t Γ s (t.rew ı[m ⇝ u]) = (pelim_aux_t Γ (s + 1) t).rew ı[m ⇝ pelim_aux_t Γ s u] :=
begin
  induction t generalizing s m,
  case var : n { simp,
    have hn : n < m ∨ n = m ∨ m < n, from trichotomous n m, rcases hn with (hn | rfl | hn),
    { simp[hn, show n < s, from gt_of_ge_of_gt le hn, show n < s + 1, from nat.lt.step (gt_of_ge_of_gt le hn)] },
    { simp[show n < s + 1, from nat.lt_succ_iff.mpr le] },
    { simp[hn], rcases n;simp[←nat.add_one] at hn ⊢, { contradiction },
      { have hn' : n < s ∨ s ≤ n, from lt_or_ge n s, rcases hn' with (hn' | hn'),
      { simp[hn', hn] }, { simp[show ¬n < s, from not_lt.mpr hn', show m < Γ.length + (n + 1), from nat.lt_add_left m _ _ hn] } } } },
  case app : n f v IH {
    rcases f,
    { simp, funext i, exact IH i le },
    { cases n,
      { by_cases mem : f ∈ Γ; simp[mem, le],
        { simp[show m < consts_to_var Γ ⟨f, mem⟩ + (s + 1), by omega] } }, { rcases f } } }
end

lemma pelim_aux_t_subst' (t u : term (L + consts C)) {s : ℕ} :
  pelim_aux_t Γ s (t.rew ı[s ⇝ u]) = (pelim_aux_t Γ (s + 1) t).rew ı[s ⇝ pelim_aux_t Γ s u] :=
pelim_aux_t_subst Γ t u (by refl)

private def pelimination_aux : formula_homomorphism (L + consts C) (L + consts C) :=
{ to_fun := pelim_aux_f Γ,
  map_verum := by simp,
  map_imply := by simp,
  map_neg := by simp,
  map_univ := by simp }

lemma pelimination_aux_app (p : formula (L + consts C)) (k) : pelimination_aux Γ k p = pelim_aux_f Γ k p := rfl

def pelimination : (L + consts C) ↝ (L + consts C) :=
formula_homonorphism.mk_translation (pelimination_aux Γ)
  (λ n r v l s k le, by { rcases r,
      { simp[pelimination_aux_app], funext i, exact pelim_aux_t_pow_aux Γ (v i) l s k le },
      { rcases r } })
  (λ t u l s k le, by { simp[pelimination_aux_app], refine ⟨pelim_aux_t_pow_aux Γ t l s k le, pelim_aux_t_pow_aux Γ u l s k le⟩ })

lemma pelimination_app (p : formula (L + consts C)) (k) : pelimination Γ k p = pelim_aux_f Γ k p := rfl

def pelimination' : term_formula_translation (L + consts C) (L + consts C) :=
{ p := pelimination Γ,
  t := pelim_aux_t Γ,
  chr := λ n, id,
  equal := λ t u k, by simp[pelimination_app],
  app := λ k n r v, by { rcases r, { simp, refl }, { rcases r } },
  map_pow := λ t s, by { exact pelim_aux_t_pow Γ t s 1 } }

@[simp] lemma pelimination'_t_eq_pelim_aux_t (t : term (L + consts C)) (s : ℕ) :
  (pelimination' Γ).t s t = pelim_aux_t Γ s t := rfl

lemma pelimination'_subst (p : formula (L + consts C)) (t) (s : ℕ) :
  (pelimination' Γ).p s (p.rew ı[s ⇝ t]) = ((pelimination' Γ).p (s + 1) p).rew ı[s ⇝ pelim_aux_t Γ s t] :=
term_formula_translation.tr_subst_of_subst (pelimination' Γ) (pelim_aux_t_subst Γ) p t s s (by refl)

instance pelimination_conservative : (pelimination Γ : (L + consts C) ↝ (L + consts C)).conservative :=
term_formula_translation.conservative_of (pelimination' Γ : term_formula_translation (L + consts C) (L + consts C))
(λ t u s m le, by { simp[pelimination', pelim_aux_t_subst Γ t u le], })
  (λ s n f T k, by { rcases f,
    { simp[eq_axiom4, pelimination'],
      simp[pelimination_app, show ∀ i : fin n, ↑i < s + k + 2 * n, { rintros ⟨i, lt⟩, simp, omega },
      show ∀ i : fin n, n + i < s + k + 2 * n, { rintros ⟨i, lt⟩, simp, omega } ], exact function_ext _ },
    { cases n,
      { simp[eq_axiom4, pelimination'], simp[pelimination_app] }, { rcases f } } })
  (λ s n r T k, by { rcases r,
    { simp[eq_axiom5, pelimination'],
    simp[pelimination_app, show ∀ i : fin n, ↑i < s + k + 2 * n, { rintros ⟨i, lt⟩, simp, omega },
      show ∀ i : fin n, n + i < s + k + 2 * n, { rintros ⟨i, lt⟩, simp, omega } ], exact predicate_ext _ },
    { rcases r } })

def disjoint (p : formula (L + consts C)) : Prop := ∀ c ∈ Γ, c ∉ consts_of_p p

lemma pelim_aux_t_eq_pow_of_disjoint_aux (t : term (L + consts C)) (h : ∀ c ∈ Γ, c ∉ consts_of_t t) (s : ℕ) :
  pelim_aux_t Γ s t = t.rew ((λ x, #(Γ.length + x))^s) :=
begin
  induction t generalizing s,
  case var { simp, by_cases C : t < s; simp[C], { simp[show s ≤ t, from not_lt.mp C], omega } },
  case app : n f v IH
  { rcases f,
    { simp, refine ⟨rfl, _⟩, funext i, exact IH i (λ c mem, by { have := h c mem, simp at this, exact this i }) s },
    { rcases n,
      { have : f ∉ Γ, { intros mem, have := h f mem, simp [consts_of_t] at this, contradiction }, simp[this], refl }, { rcases f } } }
end

lemma pelimination_eq_pow_aux_of_disjoint (p : formula (L + consts C)) (h : disjoint Γ p) (s : ℕ) :
  pelimination Γ s p = p.rew ((λ x, #(Γ.length + x))^s) :=
begin
  induction p generalizing s,
  case app : n r v { rcases r,
    { simp[pelimination_app], refine ⟨rfl, _⟩, funext i,
      exact pelim_aux_t_eq_pow_of_disjoint_aux Γ (v i) (λ c mem, by { have := h c mem, simp[consts_of_p] at this, refine this (v i) i (by refl) }) s },
    { rcases r } },
  case equal : t u
  { simp[pelimination_app],
    refine ⟨pelim_aux_t_eq_pow_of_disjoint_aux Γ t (λ c mem, by { have := h c mem, simp[consts_of_p] at this, refine this t (by simp) }) s,
      pelim_aux_t_eq_pow_of_disjoint_aux Γ u (λ c mem, by { have := h c mem, simp[consts_of_p] at this, refine this u (by simp) }) s⟩,   },
  case verum { simp },
  case imply : p q IH_p IH_q
  { simp, refine
    ⟨IH_p (λ c mem mem_p, by { have := h c mem, simp[consts_of_p] at this mem_p, rcases mem_p with ⟨t, ht, mem_t⟩, exact this t (by simp[ht]) mem_t }) s,
     IH_q (λ c mem mem_p, by { have := h c mem, simp[consts_of_p] at this mem_p, rcases mem_p with ⟨t, ht, mem_t⟩, exact this t (by simp[ht]) mem_t }) s⟩ },
  case neg : p IH
  { simp, refine IH (λ c mem mem_p, by { have := h c mem, simp[consts_of_p] at this mem_p, rcases mem_p with ⟨t, ht, mem_t⟩, exact this t (by simp[ht]) mem_t }) s },
  case fal : p IH { simp[rewriting_sf_itr.pow_add], exact IH (λ c mem mem_p, by { have := h c mem, simp[consts_of_p] at this mem_p, rcases mem_p with ⟨t, ht, mem_t⟩,refine this t ht mem_t }) (s + 1) },
end

lemma pelimination_eq_pow_of_disjoint (p : formula (L + consts C)) (h : disjoint Γ p) :
  pelimination Γ 0 p = p^Γ.length :=
by { have := pelimination_eq_pow_aux_of_disjoint Γ p h 0, simp at this,
     simp[formula.pow_eq, show ∀ x, x + Γ.length = Γ.length + x, from λ x, add_comm _ _], exact this }

theorem provable_pelimination_of_disjoint (T : Theory (L + consts C)) (p : formula (L + consts C))
  (disj : ∀ p ∈ T, disjoint Γ p) : T ⊢ p → T ⊢ ∀.[Γ.length] (pelimination' Γ).p 0 p := λ b,
begin
  have lmm₁ : tr_Theory (pelimination Γ) 0 T ⊢ (pelimination Γ) 0 p, from translation.provability (pelimination Γ) T p 0 b,
  have : tr_Theory (pelimination Γ) 0 T = T^Γ.length,
  { ext q, simp[tr_Theory, Theory_sf_itr_eq], split,
    { rintros ⟨q, q_mem, rfl⟩, refine ⟨q, q_mem, pelimination_eq_pow_of_disjoint Γ q (disj q q_mem)⟩ },
    { rintros ⟨q, q_mem, rfl⟩, refine ⟨q, q_mem, pelimination_eq_pow_of_disjoint Γ q (disj q q_mem)⟩ } },
  rw this at lmm₁,
  exact generalize_itr lmm₁
end

@[simp] lemma disjoint_coe (p : formula L) : disjoint Γ (↑p : formula (L + consts C)) :=
λ c mem, by simp

lemma pelimination_coe_eq_pow_coe_aux (p : formula L) (s : ℕ) :
  (pelimination' Γ).p s (↑p : formula (L + consts C)) = (↑p : formula (L + consts C)).rew ((λ x, #(Γ.length + x))^s) :=
pelimination_eq_pow_aux_of_disjoint Γ (↑p : formula (L + consts C)) (disjoint_coe Γ p) s

@[simp] lemma pelim_aux_t_consts_of_Γ (c : C) (h : c ∈ Γ) (s : ℕ) :
  (pelim_aux_t Γ s c : term (L + consts C)) = #(Γ.index_of c + s) :=
by simp[consts.coe_def, show (↑(consts.c c) : (L + consts C).fn 0) = sum.inr (consts.c c), from rfl]; simp[consts.c, h]; refl

end consts_pelimination

end language

end fol