/-
Copyright (c) 2018 Chris Hughes. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Chris Hughes, Abhimanyu Pallavi Sudhir, Jean Lo, Calle Sönne, Sébastien Gouëzel,
  Rémy Degenne

! This file was ported from Lean 3 source module analysis.special_functions.pow_deriv
! leanprover-community/mathlib commit da1d134ab55eb58347924920695d8200f4740694
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Analysis.SpecialFunctions.Pow
import Mathbin.Analysis.SpecialFunctions.Complex.LogDeriv
import Mathbin.Analysis.Calculus.ExtendDeriv
import Mathbin.Analysis.SpecialFunctions.Log.Deriv
import Mathbin.Analysis.SpecialFunctions.Trigonometric.Deriv

/-!
# Derivatives of power function on `ℂ`, `ℝ`, `ℝ≥0`, and `ℝ≥0∞`

We also prove differentiability and provide derivatives for the power functions `x ^ y`.
-/

noncomputable section

open Classical Real Topology NNReal ENNReal Filter

open Filter

namespace Complex

theorem hasStrictFderivAt_cpow {p : ℂ × ℂ} (hp : 0 < p.1.re ∨ p.1.im ≠ 0) :
    HasStrictFderivAt (fun x : ℂ × ℂ => x.1 ^ x.2)
      ((p.2 * p.1 ^ (p.2 - 1)) • ContinuousLinearMap.fst ℂ ℂ ℂ +
        (p.1 ^ p.2 * log p.1) • ContinuousLinearMap.snd ℂ ℂ ℂ)
      p :=
  by
  have A : p.1 ≠ 0 := by
    intro h
    simpa [h, lt_irrefl] using hp
  have : (fun x : ℂ × ℂ => x.1 ^ x.2) =ᶠ[𝓝 p] fun x => exp (log x.1 * x.2) :=
    ((is_open_ne.preimage continuous_fst).eventually_mem A).mono fun p hp =>
      cpow_def_of_ne_zero hp _
  rw [cpow_sub _ _ A, cpow_one, mul_div_left_comm, mul_smul, mul_smul, ← smul_add]
  refine' HasStrictFderivAt.congr_of_eventuallyEq _ this.symm
  simpa only [cpow_def_of_ne_zero A, div_eq_mul_inv, mul_smul, add_comm] using
    ((has_strict_fderiv_at_fst.clog hp).mul hasStrictFderivAt_snd).cexp
#align complex.has_strict_fderiv_at_cpow Complex.hasStrictFderivAt_cpow

theorem hasStrictFderivAt_cpow' {x y : ℂ} (hp : 0 < x.re ∨ x.im ≠ 0) :
    HasStrictFderivAt (fun x : ℂ × ℂ => x.1 ^ x.2)
      ((y * x ^ (y - 1)) • ContinuousLinearMap.fst ℂ ℂ ℂ +
        (x ^ y * log x) • ContinuousLinearMap.snd ℂ ℂ ℂ)
      (x, y) :=
  @hasStrictFderivAt_cpow (x, y) hp
#align complex.has_strict_fderiv_at_cpow' Complex.hasStrictFderivAt_cpow'

theorem hasStrictDerivAt_const_cpow {x y : ℂ} (h : x ≠ 0 ∨ y ≠ 0) :
    HasStrictDerivAt (fun y => x ^ y) (x ^ y * log x) y :=
  by
  rcases em (x = 0) with (rfl | hx)
  · replace h := h.neg_resolve_left rfl
    rw [log_zero, MulZeroClass.mul_zero]
    refine' (hasStrictDerivAt_const _ 0).congr_of_eventuallyEq _
    exact (is_open_ne.eventually_mem h).mono fun y hy => (zero_cpow hy).symm
  ·
    simpa only [cpow_def_of_ne_zero hx, mul_one] using
      ((hasStrictDerivAt_id y).const_mul (log x)).cexp
#align complex.has_strict_deriv_at_const_cpow Complex.hasStrictDerivAt_const_cpow

theorem hasFderivAt_cpow {p : ℂ × ℂ} (hp : 0 < p.1.re ∨ p.1.im ≠ 0) :
    HasFderivAt (fun x : ℂ × ℂ => x.1 ^ x.2)
      ((p.2 * p.1 ^ (p.2 - 1)) • ContinuousLinearMap.fst ℂ ℂ ℂ +
        (p.1 ^ p.2 * log p.1) • ContinuousLinearMap.snd ℂ ℂ ℂ)
      p :=
  (hasStrictFderivAt_cpow hp).HasFderivAt
#align complex.has_fderiv_at_cpow Complex.hasFderivAt_cpow

end Complex

section fderiv

open Complex

variable {E : Type _} [NormedAddCommGroup E] [NormedSpace ℂ E] {f g : E → ℂ} {f' g' : E →L[ℂ] ℂ}
  {x : E} {s : Set E} {c : ℂ}

theorem HasStrictFderivAt.cpow (hf : HasStrictFderivAt f f' x) (hg : HasStrictFderivAt g g' x)
    (h0 : 0 < (f x).re ∨ (f x).im ≠ 0) :
    HasStrictFderivAt (fun x => f x ^ g x)
      ((g x * f x ^ (g x - 1)) • f' + (f x ^ g x * log (f x)) • g') x :=
  by convert(@has_strict_fderiv_at_cpow ((fun x => (f x, g x)) x) h0).comp x (hf.prod hg)
#align has_strict_fderiv_at.cpow HasStrictFderivAt.cpow

theorem HasStrictFderivAt.const_cpow (hf : HasStrictFderivAt f f' x) (h0 : c ≠ 0 ∨ f x ≠ 0) :
    HasStrictFderivAt (fun x => c ^ f x) ((c ^ f x * log c) • f') x :=
  (hasStrictDerivAt_const_cpow h0).comp_hasStrictFderivAt x hf
#align has_strict_fderiv_at.const_cpow HasStrictFderivAt.const_cpow

theorem HasFderivAt.cpow (hf : HasFderivAt f f' x) (hg : HasFderivAt g g' x)
    (h0 : 0 < (f x).re ∨ (f x).im ≠ 0) :
    HasFderivAt (fun x => f x ^ g x) ((g x * f x ^ (g x - 1)) • f' + (f x ^ g x * log (f x)) • g')
      x :=
  by convert(@Complex.hasFderivAt_cpow ((fun x => (f x, g x)) x) h0).comp x (hf.prod hg)
#align has_fderiv_at.cpow HasFderivAt.cpow

theorem HasFderivAt.const_cpow (hf : HasFderivAt f f' x) (h0 : c ≠ 0 ∨ f x ≠ 0) :
    HasFderivAt (fun x => c ^ f x) ((c ^ f x * log c) • f') x :=
  (hasStrictDerivAt_const_cpow h0).HasDerivAt.comp_hasFderivAt x hf
#align has_fderiv_at.const_cpow HasFderivAt.const_cpow

theorem HasFderivWithinAt.cpow (hf : HasFderivWithinAt f f' s x) (hg : HasFderivWithinAt g g' s x)
    (h0 : 0 < (f x).re ∨ (f x).im ≠ 0) :
    HasFderivWithinAt (fun x => f x ^ g x)
      ((g x * f x ^ (g x - 1)) • f' + (f x ^ g x * log (f x)) • g') s x :=
  by
  convert(@Complex.hasFderivAt_cpow ((fun x => (f x, g x)) x) h0).comp_hasFderivWithinAt x
      (hf.prod hg)
#align has_fderiv_within_at.cpow HasFderivWithinAt.cpow

theorem HasFderivWithinAt.const_cpow (hf : HasFderivWithinAt f f' s x) (h0 : c ≠ 0 ∨ f x ≠ 0) :
    HasFderivWithinAt (fun x => c ^ f x) ((c ^ f x * log c) • f') s x :=
  (hasStrictDerivAt_const_cpow h0).HasDerivAt.comp_hasFderivWithinAt x hf
#align has_fderiv_within_at.const_cpow HasFderivWithinAt.const_cpow

theorem DifferentiableAt.cpow (hf : DifferentiableAt ℂ f x) (hg : DifferentiableAt ℂ g x)
    (h0 : 0 < (f x).re ∨ (f x).im ≠ 0) : DifferentiableAt ℂ (fun x => f x ^ g x) x :=
  (hf.HasFderivAt.cpow hg.HasFderivAt h0).DifferentiableAt
#align differentiable_at.cpow DifferentiableAt.cpow

theorem DifferentiableAt.const_cpow (hf : DifferentiableAt ℂ f x) (h0 : c ≠ 0 ∨ f x ≠ 0) :
    DifferentiableAt ℂ (fun x => c ^ f x) x :=
  (hf.HasFderivAt.const_cpow h0).DifferentiableAt
#align differentiable_at.const_cpow DifferentiableAt.const_cpow

theorem DifferentiableWithinAt.cpow (hf : DifferentiableWithinAt ℂ f s x)
    (hg : DifferentiableWithinAt ℂ g s x) (h0 : 0 < (f x).re ∨ (f x).im ≠ 0) :
    DifferentiableWithinAt ℂ (fun x => f x ^ g x) s x :=
  (hf.HasFderivWithinAt.cpow hg.HasFderivWithinAt h0).DifferentiableWithinAt
#align differentiable_within_at.cpow DifferentiableWithinAt.cpow

theorem DifferentiableWithinAt.const_cpow (hf : DifferentiableWithinAt ℂ f s x)
    (h0 : c ≠ 0 ∨ f x ≠ 0) : DifferentiableWithinAt ℂ (fun x => c ^ f x) s x :=
  (hf.HasFderivWithinAt.const_cpow h0).DifferentiableWithinAt
#align differentiable_within_at.const_cpow DifferentiableWithinAt.const_cpow

end fderiv

section deriv

open Complex

variable {f g : ℂ → ℂ} {s : Set ℂ} {f' g' x c : ℂ}

/-- A private lemma that rewrites the output of lemmas like `has_fderiv_at.cpow` to the form
expected by lemmas like `has_deriv_at.cpow`. -/
private theorem aux :
    ((g x * f x ^ (g x - 1)) • (1 : ℂ →L[ℂ] ℂ).smul_right f' +
          (f x ^ g x * log (f x)) • (1 : ℂ →L[ℂ] ℂ).smul_right g')
        1 =
      g x * f x ^ (g x - 1) * f' + f x ^ g x * log (f x) * g' :=
  by
  simp only [Algebra.id.smul_eq_mul, one_mul, ContinuousLinearMap.one_apply,
    ContinuousLinearMap.smulRight_apply, ContinuousLinearMap.add_apply, Pi.smul_apply,
    ContinuousLinearMap.coe_smul']
#align aux aux

theorem HasStrictDerivAt.cpow (hf : HasStrictDerivAt f f' x) (hg : HasStrictDerivAt g g' x)
    (h0 : 0 < (f x).re ∨ (f x).im ≠ 0) :
    HasStrictDerivAt (fun x => f x ^ g x) (g x * f x ^ (g x - 1) * f' + f x ^ g x * log (f x) * g')
      x :=
  by simpa only [aux] using (hf.cpow hg h0).HasStrictDerivAt
#align has_strict_deriv_at.cpow HasStrictDerivAt.cpow

theorem HasStrictDerivAt.const_cpow (hf : HasStrictDerivAt f f' x) (h : c ≠ 0 ∨ f x ≠ 0) :
    HasStrictDerivAt (fun x => c ^ f x) (c ^ f x * log c * f') x :=
  (hasStrictDerivAt_const_cpow h).comp x hf
#align has_strict_deriv_at.const_cpow HasStrictDerivAt.const_cpow

theorem Complex.hasStrictDerivAt_cpow_const (h : 0 < x.re ∨ x.im ≠ 0) :
    HasStrictDerivAt (fun z : ℂ => z ^ c) (c * x ^ (c - 1)) x := by
  simpa only [MulZeroClass.mul_zero, add_zero, mul_one] using
    (hasStrictDerivAt_id x).cpow (hasStrictDerivAt_const x c) h
#align complex.has_strict_deriv_at_cpow_const Complex.hasStrictDerivAt_cpow_const

theorem HasStrictDerivAt.cpow_const (hf : HasStrictDerivAt f f' x)
    (h0 : 0 < (f x).re ∨ (f x).im ≠ 0) :
    HasStrictDerivAt (fun x => f x ^ c) (c * f x ^ (c - 1) * f') x :=
  (Complex.hasStrictDerivAt_cpow_const h0).comp x hf
#align has_strict_deriv_at.cpow_const HasStrictDerivAt.cpow_const

theorem HasDerivAt.cpow (hf : HasDerivAt f f' x) (hg : HasDerivAt g g' x)
    (h0 : 0 < (f x).re ∨ (f x).im ≠ 0) :
    HasDerivAt (fun x => f x ^ g x) (g x * f x ^ (g x - 1) * f' + f x ^ g x * log (f x) * g') x :=
  by simpa only [aux] using (hf.has_fderiv_at.cpow hg h0).HasDerivAt
#align has_deriv_at.cpow HasDerivAt.cpow

theorem HasDerivAt.const_cpow (hf : HasDerivAt f f' x) (h0 : c ≠ 0 ∨ f x ≠ 0) :
    HasDerivAt (fun x => c ^ f x) (c ^ f x * log c * f') x :=
  (hasStrictDerivAt_const_cpow h0).HasDerivAt.comp x hf
#align has_deriv_at.const_cpow HasDerivAt.const_cpow

theorem HasDerivAt.cpow_const (hf : HasDerivAt f f' x) (h0 : 0 < (f x).re ∨ (f x).im ≠ 0) :
    HasDerivAt (fun x => f x ^ c) (c * f x ^ (c - 1) * f') x :=
  (Complex.hasStrictDerivAt_cpow_const h0).HasDerivAt.comp x hf
#align has_deriv_at.cpow_const HasDerivAt.cpow_const

theorem HasDerivWithinAt.cpow (hf : HasDerivWithinAt f f' s x) (hg : HasDerivWithinAt g g' s x)
    (h0 : 0 < (f x).re ∨ (f x).im ≠ 0) :
    HasDerivWithinAt (fun x => f x ^ g x) (g x * f x ^ (g x - 1) * f' + f x ^ g x * log (f x) * g')
      s x :=
  by simpa only [aux] using (hf.has_fderiv_within_at.cpow hg h0).HasDerivWithinAt
#align has_deriv_within_at.cpow HasDerivWithinAt.cpow

theorem HasDerivWithinAt.const_cpow (hf : HasDerivWithinAt f f' s x) (h0 : c ≠ 0 ∨ f x ≠ 0) :
    HasDerivWithinAt (fun x => c ^ f x) (c ^ f x * log c * f') s x :=
  (hasStrictDerivAt_const_cpow h0).HasDerivAt.comp_hasDerivWithinAt x hf
#align has_deriv_within_at.const_cpow HasDerivWithinAt.const_cpow

theorem HasDerivWithinAt.cpow_const (hf : HasDerivWithinAt f f' s x)
    (h0 : 0 < (f x).re ∨ (f x).im ≠ 0) :
    HasDerivWithinAt (fun x => f x ^ c) (c * f x ^ (c - 1) * f') s x :=
  (Complex.hasStrictDerivAt_cpow_const h0).HasDerivAt.comp_hasDerivWithinAt x hf
#align has_deriv_within_at.cpow_const HasDerivWithinAt.cpow_const

/-- Although `λ x, x ^ r` for fixed `r` is *not* complex-differentiable along the negative real
line, it is still real-differentiable, and the derivative is what one would formally expect. -/
theorem hasDerivAt_of_real_cpow {x : ℝ} (hx : x ≠ 0) {r : ℂ} (hr : r ≠ -1) :
    HasDerivAt (fun y : ℝ => (y : ℂ) ^ (r + 1) / (r + 1)) (x ^ r) x :=
  by
  rw [Ne.def, ← add_eq_zero_iff_eq_neg, ← Ne.def] at hr
  rcases lt_or_gt_of_ne hx.symm with (hx | hx)
  · -- easy case : `0 < x`
    convert(((hasDerivAt_id (x : ℂ)).cpow_const _).div_const (r + 1)).comp_of_real
    · rw [add_sub_cancel, id.def, mul_one, mul_comm, mul_div_cancel _ hr]
    · rw [id.def, of_real_re]
      exact Or.inl hx
  · -- harder case : `x < 0`
    have :
      ∀ᶠ y : ℝ in nhds x,
        (y : ℂ) ^ (r + 1) / (r + 1) = (-y : ℂ) ^ (r + 1) * exp (π * I * (r + 1)) / (r + 1) :=
      by
      refine' Filter.eventually_of_mem (Iio_mem_nhds hx) fun y hy => _
      rw [of_real_cpow_of_nonpos (le_of_lt hy)]
    refine' HasDerivAt.congr_of_eventuallyEq _ this
    rw [of_real_cpow_of_nonpos (le_of_lt hx)]
    suffices
      HasDerivAt (fun y : ℝ => (-↑y) ^ (r + 1) * exp (↑π * I * (r + 1)))
        ((r + 1) * (-↑x) ^ r * exp (↑π * I * r)) x
      by
      convert this.div_const (r + 1) using 1
      conv_rhs => rw [mul_assoc, mul_comm, mul_div_cancel _ hr]
    rw [mul_add ((π : ℂ) * _), mul_one, exp_add, exp_pi_mul_I, mul_comm (_ : ℂ) (-1 : ℂ),
      neg_one_mul]
    simp_rw [mul_neg, ← neg_mul, ← of_real_neg]
    suffices HasDerivAt (fun y : ℝ => ↑(-y) ^ (r + 1)) (-(r + 1) * ↑(-x) ^ r) x
      by
      convert this.neg.mul_const _
      ring
    suffices HasDerivAt (fun y : ℝ => ↑y ^ (r + 1)) ((r + 1) * ↑(-x) ^ r) (-x)
      by
      convert@HasDerivAt.scomp ℝ _ ℂ _ _ x ℝ _ _ _ _ _ _ _ _ this (hasDerivAt_neg x) using 1
      rw [real_smul, of_real_neg 1, of_real_one]
      ring
    suffices HasDerivAt (fun y : ℂ => y ^ (r + 1)) ((r + 1) * ↑(-x) ^ r) ↑(-x) by
      exact this.comp_of_real
    conv in ↑_ ^ _ => rw [(by ring : r = r + 1 - 1)]
    convert(hasDerivAt_id ((-x : ℝ) : ℂ)).cpow_const _ using 1
    · simp
    · left
      rwa [id.def, of_real_re, neg_pos]
#align has_deriv_at_of_real_cpow hasDerivAt_of_real_cpow

end deriv

namespace Real

variable {x y z : ℝ}

/-- `(x, y) ↦ x ^ y` is strictly differentiable at `p : ℝ × ℝ` such that `0 < p.fst`. -/
theorem hasStrictFderivAt_rpow_of_pos (p : ℝ × ℝ) (hp : 0 < p.1) :
    HasStrictFderivAt (fun x : ℝ × ℝ => x.1 ^ x.2)
      ((p.2 * p.1 ^ (p.2 - 1)) • ContinuousLinearMap.fst ℝ ℝ ℝ +
        (p.1 ^ p.2 * log p.1) • ContinuousLinearMap.snd ℝ ℝ ℝ)
      p :=
  by
  have : (fun x : ℝ × ℝ => x.1 ^ x.2) =ᶠ[𝓝 p] fun x => exp (log x.1 * x.2) :=
    (continuous_at_fst.eventually (lt_mem_nhds hp)).mono fun p hp => rpow_def_of_pos hp _
  refine' HasStrictFderivAt.congr_of_eventuallyEq _ this.symm
  convert((has_strict_fderiv_at_fst.log hp.ne').mul hasStrictFderivAt_snd).exp
  rw [rpow_sub_one hp.ne', ← rpow_def_of_pos hp, smul_add, smul_smul, mul_div_left_comm,
    div_eq_mul_inv, smul_smul, smul_smul, mul_assoc, add_comm]
#align real.has_strict_fderiv_at_rpow_of_pos Real.hasStrictFderivAt_rpow_of_pos

/-- `(x, y) ↦ x ^ y` is strictly differentiable at `p : ℝ × ℝ` such that `p.fst < 0`. -/
theorem hasStrictFderivAt_rpow_of_neg (p : ℝ × ℝ) (hp : p.1 < 0) :
    HasStrictFderivAt (fun x : ℝ × ℝ => x.1 ^ x.2)
      ((p.2 * p.1 ^ (p.2 - 1)) • ContinuousLinearMap.fst ℝ ℝ ℝ +
        (p.1 ^ p.2 * log p.1 - exp (log p.1 * p.2) * sin (p.2 * π) * π) •
          ContinuousLinearMap.snd ℝ ℝ ℝ)
      p :=
  by
  have : (fun x : ℝ × ℝ => x.1 ^ x.2) =ᶠ[𝓝 p] fun x => exp (log x.1 * x.2) * cos (x.2 * π) :=
    (continuous_at_fst.eventually (gt_mem_nhds hp)).mono fun p hp => rpow_def_of_neg hp _
  refine' HasStrictFderivAt.congr_of_eventuallyEq _ this.symm
  convert((has_strict_fderiv_at_fst.log hp.ne).mul hasStrictFderivAt_snd).exp.mul
      (has_strict_fderiv_at_snd.mul_const _).cos using
    1
  simp_rw [rpow_sub_one hp.ne, smul_add, ← add_assoc, smul_smul, ← add_smul, ← mul_assoc,
    mul_comm (cos _), ← rpow_def_of_neg hp]
  rw [div_eq_mul_inv, add_comm]
  congr 2 <;> ring
#align real.has_strict_fderiv_at_rpow_of_neg Real.hasStrictFderivAt_rpow_of_neg

/-- The function `λ (x, y), x ^ y` is infinitely smooth at `(x, y)` unless `x = 0`. -/
theorem contDiffAt_rpow_of_ne (p : ℝ × ℝ) (hp : p.1 ≠ 0) {n : ℕ∞} :
    ContDiffAt ℝ n (fun p : ℝ × ℝ => p.1 ^ p.2) p :=
  by
  cases' hp.lt_or_lt with hneg hpos
  exacts[(((cont_diff_at_fst.log hneg.ne).mul contDiffAt_snd).exp.mul
          (cont_diff_at_snd.mul contDiffAt_const).cos).congr_of_eventuallyEq
      ((continuous_at_fst.eventually (gt_mem_nhds hneg)).mono fun p hp => rpow_def_of_neg hp _),
    ((cont_diff_at_fst.log hpos.ne').mul contDiffAt_snd).exp.congr_of_eventuallyEq
      ((continuous_at_fst.eventually (lt_mem_nhds hpos)).mono fun p hp => rpow_def_of_pos hp _)]
#align real.cont_diff_at_rpow_of_ne Real.contDiffAt_rpow_of_ne

theorem differentiableAt_rpow_of_ne (p : ℝ × ℝ) (hp : p.1 ≠ 0) :
    DifferentiableAt ℝ (fun p : ℝ × ℝ => p.1 ^ p.2) p :=
  (contDiffAt_rpow_of_ne p hp).DifferentiableAt le_rfl
#align real.differentiable_at_rpow_of_ne Real.differentiableAt_rpow_of_ne

theorem HasStrictDerivAt.rpow {f g : ℝ → ℝ} {f' g' : ℝ} (hf : HasStrictDerivAt f f' x)
    (hg : HasStrictDerivAt g g' x) (h : 0 < f x) :
    HasStrictDerivAt (fun x => f x ^ g x) (f' * g x * f x ^ (g x - 1) + g' * f x ^ g x * log (f x))
      x :=
  by
  convert(has_strict_fderiv_at_rpow_of_pos ((fun x => (f x, g x)) x) h).comp_hasStrictDerivAt _
      (hf.prod hg) using
    1
  simp [mul_assoc, mul_comm, mul_left_comm]
#align has_strict_deriv_at.rpow HasStrictDerivAt.rpow

theorem hasStrictDerivAt_rpow_const_of_ne {x : ℝ} (hx : x ≠ 0) (p : ℝ) :
    HasStrictDerivAt (fun x => x ^ p) (p * x ^ (p - 1)) x :=
  by
  cases' hx.lt_or_lt with hx hx
  · have :=
      (has_strict_fderiv_at_rpow_of_neg (x, p) hx).comp_hasStrictDerivAt x
        ((hasStrictDerivAt_id x).Prod (hasStrictDerivAt_const _ _))
    convert this
    simp
  · simpa using (hasStrictDerivAt_id x).rpow (hasStrictDerivAt_const x p) hx
#align real.has_strict_deriv_at_rpow_const_of_ne Real.hasStrictDerivAt_rpow_const_of_ne

theorem hasStrictDerivAt_const_rpow {a : ℝ} (ha : 0 < a) (x : ℝ) :
    HasStrictDerivAt (fun x => a ^ x) (a ^ x * log a) x := by
  simpa using (hasStrictDerivAt_const _ _).rpow (hasStrictDerivAt_id x) ha
#align real.has_strict_deriv_at_const_rpow Real.hasStrictDerivAt_const_rpow

/-- This lemma says that `λ x, a ^ x` is strictly differentiable for `a < 0`. Note that these
values of `a` are outside of the "official" domain of `a ^ x`, and we may redefine `a ^ x`
for negative `a` if some other definition will be more convenient. -/
theorem hasStrictDerivAt_const_rpow_of_neg {a x : ℝ} (ha : a < 0) :
    HasStrictDerivAt (fun x => a ^ x) (a ^ x * log a - exp (log a * x) * sin (x * π) * π) x := by
  simpa using
    (has_strict_fderiv_at_rpow_of_neg (a, x) ha).comp_hasStrictDerivAt x
      ((hasStrictDerivAt_const _ _).Prod (hasStrictDerivAt_id _))
#align real.has_strict_deriv_at_const_rpow_of_neg Real.hasStrictDerivAt_const_rpow_of_neg

end Real

namespace Real

variable {z x y : ℝ}

theorem hasDerivAt_rpow_const {x p : ℝ} (h : x ≠ 0 ∨ 1 ≤ p) :
    HasDerivAt (fun x => x ^ p) (p * x ^ (p - 1)) x :=
  by
  rcases ne_or_eq x 0 with (hx | rfl)
  · exact (has_strict_deriv_at_rpow_const_of_ne hx _).HasDerivAt
  replace h : 1 ≤ p := h.neg_resolve_left rfl
  apply
    hasDerivAt_of_hasDerivAt_of_ne fun x hx =>
      (has_strict_deriv_at_rpow_const_of_ne hx p).HasDerivAt
  exacts[continuous_at_id.rpow_const (Or.inr (zero_le_one.trans h)),
    continuous_at_const.mul (continuous_at_id.rpow_const (Or.inr (sub_nonneg.2 h)))]
#align real.has_deriv_at_rpow_const Real.hasDerivAt_rpow_const

theorem differentiable_rpow_const {p : ℝ} (hp : 1 ≤ p) : Differentiable ℝ fun x : ℝ => x ^ p :=
  fun x => (hasDerivAt_rpow_const (Or.inr hp)).DifferentiableAt
#align real.differentiable_rpow_const Real.differentiable_rpow_const

theorem deriv_rpow_const {x p : ℝ} (h : x ≠ 0 ∨ 1 ≤ p) :
    deriv (fun x : ℝ => x ^ p) x = p * x ^ (p - 1) :=
  (hasDerivAt_rpow_const h).deriv
#align real.deriv_rpow_const Real.deriv_rpow_const

theorem deriv_rpow_const' {p : ℝ} (h : 1 ≤ p) :
    (deriv fun x : ℝ => x ^ p) = fun x => p * x ^ (p - 1) :=
  funext fun x => deriv_rpow_const (Or.inr h)
#align real.deriv_rpow_const' Real.deriv_rpow_const'

theorem contDiffAt_rpow_const_of_ne {x p : ℝ} {n : ℕ∞} (h : x ≠ 0) :
    ContDiffAt ℝ n (fun x => x ^ p) x :=
  (contDiffAt_rpow_of_ne (x, p) h).comp x (contDiffAt_id.Prod contDiffAt_const)
#align real.cont_diff_at_rpow_const_of_ne Real.contDiffAt_rpow_const_of_ne

theorem contDiff_rpow_const_of_le {p : ℝ} {n : ℕ} (h : ↑n ≤ p) : ContDiff ℝ n fun x : ℝ => x ^ p :=
  by
  induction' n with n ihn generalizing p
  · exact contDiff_zero.2 (continuous_id.rpow_const fun x => by exact_mod_cast Or.inr h)
  · have h1 : 1 ≤ p := le_trans (by simp) h
    rw [Nat.cast_succ, ← le_sub_iff_add_le] at h
    rw [contDiff_succ_iff_deriv, deriv_rpow_const' h1]
    refine' ⟨differentiable_rpow_const h1, cont_diff_const.mul (ihn h)⟩
#align real.cont_diff_rpow_const_of_le Real.contDiff_rpow_const_of_le

theorem contDiffAt_rpow_const_of_le {x p : ℝ} {n : ℕ} (h : ↑n ≤ p) :
    ContDiffAt ℝ n (fun x : ℝ => x ^ p) x :=
  (contDiff_rpow_const_of_le h).ContDiffAt
#align real.cont_diff_at_rpow_const_of_le Real.contDiffAt_rpow_const_of_le

theorem contDiffAt_rpow_const {x p : ℝ} {n : ℕ} (h : x ≠ 0 ∨ ↑n ≤ p) :
    ContDiffAt ℝ n (fun x : ℝ => x ^ p) x :=
  h.elim contDiffAt_rpow_const_of_ne contDiffAt_rpow_const_of_le
#align real.cont_diff_at_rpow_const Real.contDiffAt_rpow_const

theorem hasStrictDerivAt_rpow_const {x p : ℝ} (hx : x ≠ 0 ∨ 1 ≤ p) :
    HasStrictDerivAt (fun x => x ^ p) (p * x ^ (p - 1)) x :=
  ContDiffAt.has_strict_deriv_at' (contDiffAt_rpow_const (by rwa [Nat.cast_one]))
    (hasDerivAt_rpow_const hx) le_rfl
#align real.has_strict_deriv_at_rpow_const Real.hasStrictDerivAt_rpow_const

end Real

section Differentiability

open Real

section fderiv

variable {E : Type _} [NormedAddCommGroup E] [NormedSpace ℝ E] {f g : E → ℝ} {f' g' : E →L[ℝ] ℝ}
  {x : E} {s : Set E} {c p : ℝ} {n : ℕ∞}

theorem HasFderivWithinAt.rpow (hf : HasFderivWithinAt f f' s x) (hg : HasFderivWithinAt g g' s x)
    (h : 0 < f x) :
    HasFderivWithinAt (fun x => f x ^ g x)
      ((g x * f x ^ (g x - 1)) • f' + (f x ^ g x * log (f x)) • g') s x :=
  (hasStrictFderivAt_rpow_of_pos (f x, g x) h).HasFderivAt.comp_hasFderivWithinAt x (hf.Prod hg)
#align has_fderiv_within_at.rpow HasFderivWithinAt.rpow

theorem HasFderivAt.rpow (hf : HasFderivAt f f' x) (hg : HasFderivAt g g' x) (h : 0 < f x) :
    HasFderivAt (fun x => f x ^ g x) ((g x * f x ^ (g x - 1)) • f' + (f x ^ g x * log (f x)) • g')
      x :=
  (hasStrictFderivAt_rpow_of_pos (f x, g x) h).HasFderivAt.comp x (hf.Prod hg)
#align has_fderiv_at.rpow HasFderivAt.rpow

theorem HasStrictFderivAt.rpow (hf : HasStrictFderivAt f f' x) (hg : HasStrictFderivAt g g' x)
    (h : 0 < f x) :
    HasStrictFderivAt (fun x => f x ^ g x)
      ((g x * f x ^ (g x - 1)) • f' + (f x ^ g x * log (f x)) • g') x :=
  (hasStrictFderivAt_rpow_of_pos (f x, g x) h).comp x (hf.Prod hg)
#align has_strict_fderiv_at.rpow HasStrictFderivAt.rpow

theorem DifferentiableWithinAt.rpow (hf : DifferentiableWithinAt ℝ f s x)
    (hg : DifferentiableWithinAt ℝ g s x) (h : f x ≠ 0) :
    DifferentiableWithinAt ℝ (fun x => f x ^ g x) s x :=
  (differentiableAt_rpow_of_ne (f x, g x) h).comp_differentiableWithinAt x (hf.Prod hg)
#align differentiable_within_at.rpow DifferentiableWithinAt.rpow

theorem DifferentiableAt.rpow (hf : DifferentiableAt ℝ f x) (hg : DifferentiableAt ℝ g x)
    (h : f x ≠ 0) : DifferentiableAt ℝ (fun x => f x ^ g x) x :=
  (differentiableAt_rpow_of_ne (f x, g x) h).comp x (hf.Prod hg)
#align differentiable_at.rpow DifferentiableAt.rpow

theorem DifferentiableOn.rpow (hf : DifferentiableOn ℝ f s) (hg : DifferentiableOn ℝ g s)
    (h : ∀ x ∈ s, f x ≠ 0) : DifferentiableOn ℝ (fun x => f x ^ g x) s := fun x hx =>
  (hf x hx).rpow (hg x hx) (h x hx)
#align differentiable_on.rpow DifferentiableOn.rpow

theorem Differentiable.rpow (hf : Differentiable ℝ f) (hg : Differentiable ℝ g) (h : ∀ x, f x ≠ 0) :
    Differentiable ℝ fun x => f x ^ g x := fun x => (hf x).rpow (hg x) (h x)
#align differentiable.rpow Differentiable.rpow

theorem HasFderivWithinAt.rpow_const (hf : HasFderivWithinAt f f' s x) (h : f x ≠ 0 ∨ 1 ≤ p) :
    HasFderivWithinAt (fun x => f x ^ p) ((p * f x ^ (p - 1)) • f') s x :=
  (hasDerivAt_rpow_const h).comp_hasFderivWithinAt x hf
#align has_fderiv_within_at.rpow_const HasFderivWithinAt.rpow_const

theorem HasFderivAt.rpow_const (hf : HasFderivAt f f' x) (h : f x ≠ 0 ∨ 1 ≤ p) :
    HasFderivAt (fun x => f x ^ p) ((p * f x ^ (p - 1)) • f') x :=
  (hasDerivAt_rpow_const h).comp_hasFderivAt x hf
#align has_fderiv_at.rpow_const HasFderivAt.rpow_const

theorem HasStrictFderivAt.rpow_const (hf : HasStrictFderivAt f f' x) (h : f x ≠ 0 ∨ 1 ≤ p) :
    HasStrictFderivAt (fun x => f x ^ p) ((p * f x ^ (p - 1)) • f') x :=
  (hasStrictDerivAt_rpow_const h).comp_hasStrictFderivAt x hf
#align has_strict_fderiv_at.rpow_const HasStrictFderivAt.rpow_const

theorem DifferentiableWithinAt.rpow_const (hf : DifferentiableWithinAt ℝ f s x)
    (h : f x ≠ 0 ∨ 1 ≤ p) : DifferentiableWithinAt ℝ (fun x => f x ^ p) s x :=
  (hf.HasFderivWithinAt.rpow_const h).DifferentiableWithinAt
#align differentiable_within_at.rpow_const DifferentiableWithinAt.rpow_const

@[simp]
theorem DifferentiableAt.rpow_const (hf : DifferentiableAt ℝ f x) (h : f x ≠ 0 ∨ 1 ≤ p) :
    DifferentiableAt ℝ (fun x => f x ^ p) x :=
  (hf.HasFderivAt.rpow_const h).DifferentiableAt
#align differentiable_at.rpow_const DifferentiableAt.rpow_const

theorem DifferentiableOn.rpow_const (hf : DifferentiableOn ℝ f s) (h : ∀ x ∈ s, f x ≠ 0 ∨ 1 ≤ p) :
    DifferentiableOn ℝ (fun x => f x ^ p) s := fun x hx => (hf x hx).rpow_const (h x hx)
#align differentiable_on.rpow_const DifferentiableOn.rpow_const

theorem Differentiable.rpow_const (hf : Differentiable ℝ f) (h : ∀ x, f x ≠ 0 ∨ 1 ≤ p) :
    Differentiable ℝ fun x => f x ^ p := fun x => (hf x).rpow_const (h x)
#align differentiable.rpow_const Differentiable.rpow_const

theorem HasFderivWithinAt.const_rpow (hf : HasFderivWithinAt f f' s x) (hc : 0 < c) :
    HasFderivWithinAt (fun x => c ^ f x) ((c ^ f x * log c) • f') s x :=
  (hasStrictDerivAt_const_rpow hc (f x)).HasDerivAt.comp_hasFderivWithinAt x hf
#align has_fderiv_within_at.const_rpow HasFderivWithinAt.const_rpow

theorem HasFderivAt.const_rpow (hf : HasFderivAt f f' x) (hc : 0 < c) :
    HasFderivAt (fun x => c ^ f x) ((c ^ f x * log c) • f') x :=
  (hasStrictDerivAt_const_rpow hc (f x)).HasDerivAt.comp_hasFderivAt x hf
#align has_fderiv_at.const_rpow HasFderivAt.const_rpow

theorem HasStrictFderivAt.const_rpow (hf : HasStrictFderivAt f f' x) (hc : 0 < c) :
    HasStrictFderivAt (fun x => c ^ f x) ((c ^ f x * log c) • f') x :=
  (hasStrictDerivAt_const_rpow hc (f x)).comp_hasStrictFderivAt x hf
#align has_strict_fderiv_at.const_rpow HasStrictFderivAt.const_rpow

theorem ContDiffWithinAt.rpow (hf : ContDiffWithinAt ℝ n f s x) (hg : ContDiffWithinAt ℝ n g s x)
    (h : f x ≠ 0) : ContDiffWithinAt ℝ n (fun x => f x ^ g x) s x :=
  (contDiffAt_rpow_of_ne (f x, g x) h).comp_contDiffWithinAt x (hf.Prod hg)
#align cont_diff_within_at.rpow ContDiffWithinAt.rpow

theorem ContDiffAt.rpow (hf : ContDiffAt ℝ n f x) (hg : ContDiffAt ℝ n g x) (h : f x ≠ 0) :
    ContDiffAt ℝ n (fun x => f x ^ g x) x :=
  (contDiffAt_rpow_of_ne (f x, g x) h).comp x (hf.Prod hg)
#align cont_diff_at.rpow ContDiffAt.rpow

theorem ContDiffOn.rpow (hf : ContDiffOn ℝ n f s) (hg : ContDiffOn ℝ n g s) (h : ∀ x ∈ s, f x ≠ 0) :
    ContDiffOn ℝ n (fun x => f x ^ g x) s := fun x hx => (hf x hx).rpow (hg x hx) (h x hx)
#align cont_diff_on.rpow ContDiffOn.rpow

theorem ContDiff.rpow (hf : ContDiff ℝ n f) (hg : ContDiff ℝ n g) (h : ∀ x, f x ≠ 0) :
    ContDiff ℝ n fun x => f x ^ g x :=
  contDiff_iff_contDiffAt.mpr fun x => hf.ContDiffAt.rpow hg.ContDiffAt (h x)
#align cont_diff.rpow ContDiff.rpow

theorem ContDiffWithinAt.rpow_const_of_ne (hf : ContDiffWithinAt ℝ n f s x) (h : f x ≠ 0) :
    ContDiffWithinAt ℝ n (fun x => f x ^ p) s x :=
  hf.rpow contDiffWithinAt_const h
#align cont_diff_within_at.rpow_const_of_ne ContDiffWithinAt.rpow_const_of_ne

theorem ContDiffAt.rpow_const_of_ne (hf : ContDiffAt ℝ n f x) (h : f x ≠ 0) :
    ContDiffAt ℝ n (fun x => f x ^ p) x :=
  hf.rpow contDiffAt_const h
#align cont_diff_at.rpow_const_of_ne ContDiffAt.rpow_const_of_ne

theorem ContDiffOn.rpow_const_of_ne (hf : ContDiffOn ℝ n f s) (h : ∀ x ∈ s, f x ≠ 0) :
    ContDiffOn ℝ n (fun x => f x ^ p) s := fun x hx => (hf x hx).rpow_const_of_ne (h x hx)
#align cont_diff_on.rpow_const_of_ne ContDiffOn.rpow_const_of_ne

theorem ContDiff.rpow_const_of_ne (hf : ContDiff ℝ n f) (h : ∀ x, f x ≠ 0) :
    ContDiff ℝ n fun x => f x ^ p :=
  hf.rpow contDiff_const h
#align cont_diff.rpow_const_of_ne ContDiff.rpow_const_of_ne

variable {m : ℕ}

theorem ContDiffWithinAt.rpow_const_of_le (hf : ContDiffWithinAt ℝ m f s x) (h : ↑m ≤ p) :
    ContDiffWithinAt ℝ m (fun x => f x ^ p) s x :=
  (contDiffAt_rpow_const_of_le h).comp_contDiffWithinAt x hf
#align cont_diff_within_at.rpow_const_of_le ContDiffWithinAt.rpow_const_of_le

theorem ContDiffAt.rpow_const_of_le (hf : ContDiffAt ℝ m f x) (h : ↑m ≤ p) :
    ContDiffAt ℝ m (fun x => f x ^ p) x :=
  by
  rw [← contDiffWithinAt_univ] at *
  exact hf.rpow_const_of_le h
#align cont_diff_at.rpow_const_of_le ContDiffAt.rpow_const_of_le

theorem ContDiffOn.rpow_const_of_le (hf : ContDiffOn ℝ m f s) (h : ↑m ≤ p) :
    ContDiffOn ℝ m (fun x => f x ^ p) s := fun x hx => (hf x hx).rpow_const_of_le h
#align cont_diff_on.rpow_const_of_le ContDiffOn.rpow_const_of_le

theorem ContDiff.rpow_const_of_le (hf : ContDiff ℝ m f) (h : ↑m ≤ p) :
    ContDiff ℝ m fun x => f x ^ p :=
  contDiff_iff_contDiffAt.mpr fun x => hf.ContDiffAt.rpow_const_of_le h
#align cont_diff.rpow_const_of_le ContDiff.rpow_const_of_le

end fderiv

section deriv

variable {f g : ℝ → ℝ} {f' g' x y p : ℝ} {s : Set ℝ}

theorem HasDerivWithinAt.rpow (hf : HasDerivWithinAt f f' s x) (hg : HasDerivWithinAt g g' s x)
    (h : 0 < f x) :
    HasDerivWithinAt (fun x => f x ^ g x) (f' * g x * f x ^ (g x - 1) + g' * f x ^ g x * log (f x))
      s x :=
  by
  convert(hf.has_fderiv_within_at.rpow hg.has_fderiv_within_at h).HasDerivWithinAt using 1
  dsimp; ring
#align has_deriv_within_at.rpow HasDerivWithinAt.rpow

theorem HasDerivAt.rpow (hf : HasDerivAt f f' x) (hg : HasDerivAt g g' x) (h : 0 < f x) :
    HasDerivAt (fun x => f x ^ g x) (f' * g x * f x ^ (g x - 1) + g' * f x ^ g x * log (f x)) x :=
  by
  rw [← hasDerivWithinAt_univ] at *
  exact hf.rpow hg h
#align has_deriv_at.rpow HasDerivAt.rpow

theorem HasDerivWithinAt.rpow_const (hf : HasDerivWithinAt f f' s x) (hx : f x ≠ 0 ∨ 1 ≤ p) :
    HasDerivWithinAt (fun y => f y ^ p) (f' * p * f x ^ (p - 1)) s x :=
  by
  convert(has_deriv_at_rpow_const hx).comp_hasDerivWithinAt x hf using 1
  ring
#align has_deriv_within_at.rpow_const HasDerivWithinAt.rpow_const

theorem HasDerivAt.rpow_const (hf : HasDerivAt f f' x) (hx : f x ≠ 0 ∨ 1 ≤ p) :
    HasDerivAt (fun y => f y ^ p) (f' * p * f x ^ (p - 1)) x :=
  by
  rw [← hasDerivWithinAt_univ] at *
  exact hf.rpow_const hx
#align has_deriv_at.rpow_const HasDerivAt.rpow_const

theorem derivWithin_rpow_const (hf : DifferentiableWithinAt ℝ f s x) (hx : f x ≠ 0 ∨ 1 ≤ p)
    (hxs : UniqueDiffWithinAt ℝ s x) :
    derivWithin (fun x => f x ^ p) s x = derivWithin f s x * p * f x ^ (p - 1) :=
  (hf.HasDerivWithinAt.rpow_const hx).derivWithin hxs
#align deriv_within_rpow_const derivWithin_rpow_const

@[simp]
theorem deriv_rpow_const (hf : DifferentiableAt ℝ f x) (hx : f x ≠ 0 ∨ 1 ≤ p) :
    deriv (fun x => f x ^ p) x = deriv f x * p * f x ^ (p - 1) :=
  (hf.HasDerivAt.rpow_const hx).deriv
#align deriv_rpow_const deriv_rpow_const

end deriv

end Differentiability

section Limits

open Real Filter

/-- The function `(1 + t/x) ^ x` tends to `exp t` at `+∞`. -/
theorem tendsto_one_plus_div_rpow_exp (t : ℝ) :
    Tendsto (fun x : ℝ => (1 + t / x) ^ x) atTop (𝓝 (exp t)) :=
  by
  apply ((real.continuous_exp.tendsto _).comp (tendsto_mul_log_one_plus_div_at_top t)).congr' _
  have h₁ : (1 : ℝ) / 2 < 1 := by linarith
  have h₂ : tendsto (fun x : ℝ => 1 + t / x) at_top (𝓝 1) := by
    simpa using (tendsto_inv_at_top_zero.const_mul t).const_add 1
  refine' (eventually_ge_of_tendsto_gt h₁ h₂).mono fun x hx => _
  have hx' : 0 < 1 + t / x := by linarith
  simp [mul_comm x, exp_mul, exp_log hx']
#align tendsto_one_plus_div_rpow_exp tendsto_one_plus_div_rpow_exp

/-- The function `(1 + t/x) ^ x` tends to `exp t` at `+∞` for naturals `x`. -/
theorem tendsto_one_plus_div_pow_exp (t : ℝ) :
    Tendsto (fun x : ℕ => (1 + t / (x : ℝ)) ^ x) atTop (𝓝 (Real.exp t)) :=
  ((tendsto_one_plus_div_rpow_exp t).comp tendsto_nat_cast_atTop_atTop).congr (by simp)
#align tendsto_one_plus_div_pow_exp tendsto_one_plus_div_pow_exp

end Limits


import algebra.module.ordered
import order.conditionally_complete_lattice
import o_minimal.sheaf.pfun
import o_minimal.sheaf.quantifiers
import .order
import ..oqm
-- import ..tame

-- Definable choice in 1 dimension.

section

-- TODO: for_mathlib order.bounds
-- also add mem_lower_bounds/is_least_def/etc.

lemma is_lub_def {α : Type*} [preorder α] (s : set α) (x : α) :
  is_lub s x ↔ (∀ a ∈ s, a ≤ x) ∧ (∀ y, (∀ a ∈ s, a ≤ y) → x ≤ y) :=
iff.rfl

lemma is_glb_def {α : Type*} [preorder α] (s : set α) (x : α) :
  is_glb s x ↔ (∀ a ∈ s, x ≤ a) ∧ (∀ y, (∀ a ∈ s, y ≤ a) → y ≤ x) :=
iff.rfl

end

local infixr ` <|| `:2 := roption.orelse_pure
local notation x ` >>* `:55 f:55 := f <$> x

open o_minimal

universe u

instance {R : Type u} {S : struc R} : is_definable S punit :=
begin
  constructor,
  convert S.definable_univ 0,
  apply set.eq_univ_of_forall,
  intro x,
  use ⟨⟩,
  ext i,
  fin_cases i
end

variables {R : Type u} [OQM R]

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

variables {S : struc R} [o_minimal_add S]
variables {Y : Type u} [has_coordinates R Y] [definable_rep S Y]

/-
lemma def_fun.rat_smul (q : ℚ) : def_fun S (λ (r : R), q • r) :=
begin
  unfold def_fun,
  induction q using rat.num_denom_cases_on' with n d hd,
  -- need to clear denominators to get {p : R × R | n • p.fst = d • p.snd},
  -- prove definability of nsmul by constant
  sorry
end
-/

lemma half_add_half {a : R} : ½ • a + ½ • a = a :=
by { rw ←add_smul, norm_num }

lemma def_fun.half : def_fun S (λ (r : R), ½ • r) :=
begin
  unfold def_fun,
  have : def_set S {p : R × R | p.1 = p.2 + p.2} :=
    def_set_eq def_fun.fst (definable.add def_fun.snd def_fun.snd),
  convert this,
  ext ⟨x, y⟩,
  dsimp,
  split; intro h,
  { subst y,
    rw half_add_half },
  { subst x,
    rw [smul_add, half_add_half] }
end

noncomputable def one : has_one R :=
⟨classical.some (no_top 0)⟩

local attribute [instance] one

/-
let's try to prove:
axiom definable_choice_1 {s : set (Y × R)} (hs : def_set S s) (h : prod.fst '' s = set.univ) :
  ∃ g : Y → R, def_fun S g ∧ ∀ y, (y, g y) ∈ s
-/

variables (S)

-- Goal: Prove the following type is inhabited.
def definable_choice_function : Type u :=
{choice : set R →. R //
 definable S choice ∧ choice.dom = set.nonempty ∧ ∀ X H, tame X → (choice X).get H ∈ X}

variables {S}

/-- Construct a definable partial function on sets from a definable relation.
This is sensible when the relation is single-valued:
`r` s.t. `rel X r` is unique if it exists.
We ask for the proof of uniqueness now to avoid having to write it later. -/
noncomputable def pfun_of_rel (rel : set R → R → Prop)
  (uni : ∀ X r r', rel X r → rel X r' → r = r') : set R →. R := λ X,
{ dom := ∃ r, rel X r,
  get := λ h, classical.some h }

lemma mem_pfun_of_rel_iff {rel : set R → R → Prop} (uni : ∀ X r r', rel X r → rel X r' → r = r')
  (X : set R) (r : R) : r ∈ pfun_of_rel rel uni X ↔ rel X r :=
begin
  split; intro H,
  { rcases H with ⟨H, rfl⟩,
    apply classical.some_spec },
  { exact ⟨⟨r, H⟩, uni _ _ _ (classical.some_spec _) H⟩ }
end

lemma get_pfun_of_rel_eq_of_rel {rel : set R → R → Prop} {uni}
  {X : set R} {r : R} (h : rel X r) {H} : (pfun_of_rel rel uni X).get H = r :=
uni X _ _ (classical.some_spec _) h

lemma def_pfun_of_rel {rel : set R → R → Prop} {uni}
  (drel : definable S rel) : definable S (pfun_of_rel rel uni) :=
begin
  apply definable_pfun_of_graph,
  rw definable_iff_uncurry at drel,
  convert drel,
  ext ⟨x, y⟩,
  apply mem_pfun_of_rel_iff uni
end

noncomputable def the_least : set R →. R :=
pfun_of_rel is_least (λ _ _ _, is_least.unique)

@[simp] lemma the_least_dom {X : set R} : (the_least X).dom = ∃ e, is_least X e := rfl

lemma def_is_least : definable S (is_least : set R → R → Prop) :=
show definable S (λ X (r : R), r ∈ X ∧ ∀ x ∈ X, r ≤ x),
begin [defin]
  intro X,
  intro r,
  app, app, exact definable.and.definable _,
  app, app, exact definable.mem.definable _, var, var,
  all x,
  imp,
  app, app, exact definable.mem.definable _, var, var,
  app, app, exact (definable_iff_def_rel₂.mpr definable_le').definable _, var, var
end

lemma def_the_least : definable S (the_least : set R →. R) :=
def_pfun_of_rel def_is_least

-- Now repeat for inf, sup.

noncomputable def the_inf : set R →. R :=
pfun_of_rel is_glb (λ _ _ _, is_glb.unique)

noncomputable def the_sup : set R →. R :=
pfun_of_rel is_lub (λ _ _ _, is_lub.unique)

@[simp] lemma the_inf_dom {X : set R} : (the_inf X).dom = ∃ a, is_glb X a := rfl
@[simp] lemma the_sup_dom {X : set R} : (the_sup X).dom = ∃ b, is_lub X b := rfl

lemma def_the_inf : definable S (the_inf : set R →. R) :=
begin
  refine def_pfun_of_rel _,
  begin [defin]
    intro X,
    intro r,
    app, app, exact definable.and.definable _,
    { all x,
      imp,
      app, app, exact definable.mem.definable _, var, var,
      app, app, exact (definable_iff_def_rel₂.mpr definable_le').definable _, var, var },
    { all y,
      imp,
      { all x,
        imp,
        app, app, exact definable.mem.definable _, var, var,
        app, app, exact (definable_iff_def_rel₂.mpr definable_le').definable _, var, var },
      { app, app, exact (definable_iff_def_rel₂.mpr definable_le').definable _, var, var } }
  end
end

lemma def_the_sup : definable S (the_sup : set R →. R) :=
begin
  refine def_pfun_of_rel _,
  begin [defin]
    intro X,
    intro r,
    app, app, exact definable.and.definable _,
    { all x,
      imp,
      app, app, exact definable.mem.definable _, var, var,
      app, app, exact (definable_iff_def_rel₂.mpr definable_le').definable _, var, var },
    { all y,
      imp,
      { all x,
        imp,
        app, app, exact definable.mem.definable _, var, var,
        app, app, exact (definable_iff_def_rel₂.mpr definable_le').definable _, var, var },
      { app, app, exact (definable_iff_def_rel₂.mpr definable_le').definable _, var, var } }
  end
end

-- TODO: "generalize" core library's `guard` to return `punit`?
-- TODO: super hack: we return 0 (ignored) instead of `punit`
-- just to be able to use `def_pfun_set.bind` in its current form;
-- but we could generalize the types involved in `def_pfun_set` to
-- arbitrary definable types to avoid this
-- TODO: We might have already generalized it enough.
def zero_when_nonempty : set R →. R :=
λ X, { dom := X.nonempty, get := λ _, (0 : R) }

noncomputable def chosen_one : set R → R :=
λ X,
the_least X <||
(the_inf X >>* λ a,
  (the_sup {b | a < b ∧ set.Ioo a b ⊆ X} >>* λ b, ½ • (a + b)) <||
  a + 1) <||
(the_sup {b | set.Iio b ⊆ X} >>* λ b, b - 1) <||
0

open_locale classical

lemma nonempty_of_not_tame {s : set R} (h : ¬ tame s) : s.nonempty :=
begin
  rw ← set.ne_empty_iff_nonempty,
  contrapose! h,
  subst s,
  exact tame_empty
end

noncomputable def chosen_one' : set R → R :=
λ X, if h : tame X then chosen_one X else classical.some (nonempty_of_not_tame h)

lemma def_zero_when_nonempty : definable S (zero_when_nonempty : set R →. R) :=
begin
  apply definable_pfun_of_graph,
  change definable S {p : set R × R | ∃ (H : p.1.nonempty), 0 = p.2},
  simp_rw exists_prop,
  begin [defin]
    intro p,
    app, app, exact definable.and.definable _,
    { app, exact definable_nonempty.definable _,
      app, exact definable.fst.definable _, var },
    { app, app, swap, exact def_fun_const,
      exact definable_sheaf.eq,
      app, exact definable.snd.definable _, var }
  end
end

lemma definable_chosen_one : definable S (chosen_one : set R → R) :=
begin
  unfold chosen_one,
  simp only [sub_eq_add_neg],
  begin [defin]
    intro X,
    app, app, exact definable_orelse_pure.definable _,
    { app, exact def_the_least.definable _, var },
    app, app, exact definable_orelse_pure.definable _,
    { app, app, exact definable_roption_map.definable _, swap,
      { app, exact def_the_inf.definable _, var },
      intro a,
      app, app, exact definable_orelse_pure.definable _,
      { app, app, exact definable_roption_map.definable _, swap,
        app, exact def_the_sup.definable _,
        { intro b,
          app, app, exact definable.and.definable _,
          -- TODO: sheafy order classes
          app, app, exact (definable_iff_def_rel₂.mpr definable_lt').definable _,
          var, var,
          app, app, exact definable_subset.definable _,
          app, app, exact definable_Ioo.definable _, var, var,
          var },
        { intro b,
          app,
          exact (definable_iff_def_fun.mpr def_fun.half).definable _,
          -- TODO: sheafy algebra classes
          app, app, exact (definable_iff_def_fun₂.mpr definable_add).definable _,
          var, var } },
      { app, app, exact (definable_iff_def_fun₂.mpr definable_add).definable _,
        var,
        -- TODO: this is abstraction-breaking
        exact def_fun_const } },
    app, app, exact definable_orelse_pure.definable _,
    { app, app, exact definable_roption_map.definable _, swap,
      app, exact def_the_sup.definable _,
      { intro b,
        app, app, exact definable_subset.definable _,
        app, exact definable_Iio.definable _, var,
        var },
      { intro b,
        app, app, exact (definable_iff_def_fun₂.mpr definable_add).definable _,
        var,
        exact def_fun_const } },
    exact def_fun_const
  end
end

-- STILL TO DO (done in other files):
-- * Prove that, when `X` is tame and nonempty, `chosen_one X` is an element of `X`.
-- Hopefully it's not too hard to reason about what `chosen_one` will produce;
-- but it still requires understanding the local behavior of tame sets.


import system_of_complexes.basic
import pseudo_normed_group.Tinv
import pseudo_normed_group.category

/-!

# The system of complexes in Theorem 9.4 of `analytic.pdf`

Theorem 9.4 is about a system of complexes built from Breen-Deligne data,
a seminormed group `V` with `T⁻¹` (scaling by `r`) and a (certain explicit) profinitely filtered
pseudo-normed group `M` with `T⁻¹` (scaling by `r'`). We do not specialise to Scholze's
`𝓜-bar_r'(S)` in this file, but allow general profinitely filtered `M`. This file
contains the construction of the system of complexes from this data.

## Main definitions

Let `BD = (n₁ ⟶ n₂ ⟶ …)` be Breen-Deligne data, `κ` a sequence of non-negative reals which are
suitable for `BD`, and say `r,c≥0` and `V` is a normed group with `T⁻¹` scaling by `r`.

- `BD.complex κ r V r' c`: the functor taking a profinitely filtered pseudo-normed group `M`
  to the cochain complex `V-hat(M_{≤c}^n₁)^{T⁻¹} ⟶ V-hat(M_{≤c_1c}^n₂)^{T⁻¹} ⟶ …`
  induced by the data.

- `BD.system κ r V r'`: the functor sending a profinitely filtered pseudo-normed group `M`
  to the system of complexes whose component at `c`
  is `V-hat(M_{≤c})^{T⁻¹} ⟶ V-hat(M_{≤c_1c}^2)^{T⁻¹} ⟶ …`

-/
open_locale classical nnreal
noncomputable theory

open opposite pseudo_normed_group category_theory category_theory.limits breen_deligne

universe variable u

namespace breen_deligne
namespace data

section
variables (BD : breen_deligne.data) (κ : ℕ → ℝ≥0)
variables (r : ℝ≥0) (V : SemiNormedGroup) [normed_with_aut r V] [fact (0 < r)]
variables (r' : ℝ≥0) [fact (0 < r')] [fact (r' ≤ 1)]
variables (M : ProFiltPseuNormGrpWithTinv.{u} r') (c : ℝ≥0)

/-- The object for the complex of seminormed groups
`V-hat(M_{≤c})^{T⁻¹} ⟶ V-hat(M_{≤c_1c}^2)^{T⁻¹} ⟶ …` -/
def complex₂_X (a b : ℕ → ℝ≥0) [∀ i, fact (b i ≤ r' * a i)] (i : ℕ) :
  (ProFiltPseuNormGrpWithTinv r')ᵒᵖ ⥤ SemiNormedGroup :=
CLCFPTinv₂ r V r' (a i) (b i) (BD.X i)

/-- The object for the complex of seminormed groups
`V-hat(M_{≤c})^{T⁻¹} ⟶ V-hat(M_{≤c_1c}^2)^{T⁻¹} ⟶ …` -/
def complex_X (i : ℕ) : (ProFiltPseuNormGrpWithTinv r')ᵒᵖ ⥤ SemiNormedGroup :=
complex₂_X BD r V r' (λ i, c * κ i) (λ i, r' * (c * κ i)) i

variables [BD.suitable κ]

/-- The differential for the complex of seminormed groups
`V-hat(M_{≤c})^{T⁻¹} ⟶ V-hat(M_{≤c_1c}^2)^{T⁻¹} ⟶ …` -/
def complex₂_d (a b : ℕ → ℝ≥0) [∀ i, fact (b i ≤ r' * a i)]
  [BD.suitable a] [BD.suitable b] (i j : ℕ) :
  BD.complex₂_X r V r' a b i ⟶ BD.complex₂_X r V r' a b j :=
(BD.d j i).eval_CLCFPTinv₂ r V r' _ _ _ _

/-- The differential for the complex of seminormed groups
`V-hat(M_{≤c})^{T⁻¹} ⟶ V-hat(M_{≤c_1c}^2)^{T⁻¹} ⟶ …` -/
def complex_d (i j : ℕ) : BD.complex_X κ r V r' c i ⟶ BD.complex_X κ r V r' c j :=
(BD.d j i).eval_CLCFPTinv r V r' (c * κ i) (c * κ j)

lemma complex_d_comp_d (i j k : ℕ) :
  BD.complex_d κ r V r' c i j ≫ BD.complex_d κ r V r' c j k = 0 :=
by simp only [complex_d, ← universal_map.eval_CLCFPTinv_comp, BD.d_comp_d,
    universal_map.eval_CLCFPTinv_zero]

end

section

open homological_complex

variables (BD : breen_deligne.data) (κ : ℕ → ℝ≥0) [BD.suitable κ]
variables (r : ℝ≥0) (V : SemiNormedGroup) [normed_with_aut r V] [fact (0 < r)]
variables (r' : ℝ≥0) [fact (0 < r')] [fact (r' ≤ 1)] (c : ℝ≥0)

/-- The complex of seminormed groups `V-hat(M_{≤c})^{T⁻¹} ⟶ V-hat(M_{≤c_1c}^2)^{T⁻¹} ⟶ …` -/
@[simps]
def complex₂ (r : ℝ≥0) (V : SemiNormedGroup) [normed_with_aut r V] [fact (0 < r)]
  (r' : ℝ≥0) [fact (0 < r')] [fact (r' ≤ 1)]
   (a b : ℕ → ℝ≥0) [∀ i, fact (b i ≤ r' * a i)] [BD.suitable a] [BD.suitable b] :
  (ProFiltPseuNormGrpWithTinv.{u} r')ᵒᵖ ⥤ cochain_complex SemiNormedGroup ℕ :=
{ obj := λ M,
  { X := λ i, (BD.complex₂_X r V r' a b i).obj M,
    d := λ i j, (BD.complex₂_d r V r' a b i j).app M,
    d_comp_d' := λ i j k _ _,
    begin
      rw [← nat_trans.comp_app],
      simp only [complex₂_d, ← universal_map.eval_CLCFPTinv₂_comp, BD.d_comp_d,
        universal_map.eval_CLCFPTinv₂_zero],
      refl
    end,
    shape' := λ i j hij,
    begin
      simp only [complex₂_d, ← universal_map.eval_CLCFPTinv₂_comp, BD.shape _ _ hij,
        universal_map.eval_CLCFPTinv₂_zero],
      refl
    end },
  map := λ M₁ M₂ f,
  { f := λ i, ((CLCFPTinv₂ r V r' (a i) (b i) (BD.X i)).map f : _),
    comm' := λ i j _, nat_trans.naturality _ _ },
  map_id' := λ M, by { ext i : 2, apply category_theory.functor.map_id, },
  map_comp' := λ M₁ M₂ M₃ f g, by { ext i : 2, apply category_theory.functor.map_comp } }

/-- The complex of seminormed groups `V-hat(M_{≤c})^{T⁻¹} ⟶ V-hat(M_{≤c_1c}^2)^{T⁻¹} ⟶ …` -/
def complex (r : ℝ≥0) (V : SemiNormedGroup) [normed_with_aut r V] [fact (0 < r)]
  (r' : ℝ≥0) [fact (0 < r')] [fact (r' ≤ 1)] (c : ℝ≥0) :
  (ProFiltPseuNormGrpWithTinv.{u} r')ᵒᵖ ⥤ cochain_complex SemiNormedGroup ℕ :=
BD.complex₂ r V r' (λ i, c * κ i) (λ i, r' * (c * κ i))

namespace complex

lemma map_norm_noninc {M₁ M₂} (f : M₁ ⟶ M₂) (n : ℕ) :
  (((BD.complex κ r V r' c).map f).f n).norm_noninc :=
CLCFPTinv.map_norm_noninc _ _ _ _ _ _

end complex

lemma complex_obj_d (r : ℝ≥0) (V : SemiNormedGroup) [normed_with_aut r V] [fact (0 < r)]
  (r' : ℝ≥0) [fact (0 < r')] [fact (r' ≤ 1)] (c : ℝ≥0) (i j : ℕ) (M) :
  ((BD.complex κ r V r' c).obj M).d i j =
    ((BD.d j i).eval_CLCFPTinv r V r' _ _).app M :=
rfl

theorem comm_sq_app {C D} [category C] [category D]
  {X₁ X₂ Y₁ Y₂ : C ⥤ D} {f₁ : X₁ ⟶ Y₁} {f₂ : X₂ ⟶ Y₂} {φ : X₁ ⟶ X₂} {ψ : Y₁ ⟶ Y₂}
  (hf : f₁ ≫ ψ = φ ≫ f₂) (c : C) : f₁.app c ≫ ψ.app c = φ.app c ≫ f₂.app c :=
by rw [← nat_trans.comp_app, ← nat_trans.comp_app, hf]

/-- The system of complexes
`V-hat(M_{≤c}^{n₁})^{T⁻¹} ⟶ V-hat(M_{≤c_1c}^{n₂})^{T⁻¹} ⟶ ...`
occurring in Theorems 9.4 and 9.5 of [Analytic], as a functor in `M`. -/
@[simps obj map]
def system (r : ℝ≥0) (V : SemiNormedGroup) [normed_with_aut r V] [fact (0 < r)]
  (r' : ℝ≥0) [fact (0 < r')] [fact (r' ≤ 1)] :
  (ProFiltPseuNormGrpWithTinv r')ᵒᵖ ⥤ system_of_complexes :=
functor.flip {
  obj := λ c, BD.complex κ r V r' (unop c),
  map := λ c₂ c₁ h,
    { app := λ M, begin
        haveI : fact ((unop c₁ : ℝ≥0) ≤ (unop c₂ : ℝ≥0)) := ⟨h.unop.down.down⟩,
        refine
        { f := λ i, (CLCFPTinv₂.res r V r' _ _ _ _ (BD.X i)).app _,
          comm' := _ },
        { intros i j _, apply comm_sq_app,
          apply universal_map.res_comp_eval_CLCFPTinv₂ },
      end,
      naturality' := λ M N f, begin
        ext i : 2,
        erw [comp_f, comp_f],
        apply nat_trans.naturality,
      end },
  map_id' := by {
    intro c, ext M i : 4,
    refine nat_trans.congr_app (CLCFPTinv₂.res_refl r V r' _ _ _) M },
  map_comp' := begin
    intros c₃ c₂ c₁ h h',
    haveI H' : fact ((unop c₁ : ℝ≥0) ≤ (unop c₂ : ℝ≥0)) := ⟨h'.unop.down.down⟩,
    haveI H : fact ((unop c₂ : ℝ≥0) ≤ (unop c₃ : ℝ≥0)) := ⟨h.unop.down.down⟩,
    haveI : fact ((unop c₁ : ℝ≥0) ≤ (unop c₃ : ℝ≥0)) := ⟨H'.out.trans H.out⟩,
    ext M i : 4, symmetry,
    exact nat_trans.congr_app (CLCFPTinv₂.res_comp_res r V r' _ _ _ _ _ _ _) _,
  end }
.

-- move this
instance fact_unop_op {c₁ c₂ : ℝ≥0} [fact (c₂ ≤ c₁)] :
  fact ((unop (op c₂)) ≤ (unop (op c₁))) :=
by { dsimp, apply_assumption }

lemma system_res_def (r : ℝ≥0) (V : SemiNormedGroup) [normed_with_aut r V] [fact (0 < r)]
  (r' : ℝ≥0) [fact (0 < r')] [fact (r' ≤ 1)] {M}
  {c₁ c₂ : ℝ≥0} {i : ℕ} [h : fact (c₂ ≤ c₁)] :
  @system_of_complexes.res ((BD.system κ r V r').obj M) c₁ c₂ i _ =
    (CLCFPTinv.res r V r' _ _ _).app M :=
rfl

lemma system_obj_d (r : ℝ≥0) (V : SemiNormedGroup) [normed_with_aut r V] [fact (0 < r)]
  (r' : ℝ≥0) [fact (0 < r')] [fact (r' ≤ 1)] {M}
  (c : ℝ≥0) (i j : ℕ) :
  @system_of_complexes.d ((BD.system κ r V r').obj M) c i j =
    ((BD.d j i).eval_CLCFPTinv r V r' _ _).app M :=
rfl

lemma system_map_iso_isometry {M₁ M₂ : (ProFiltPseuNormGrpWithTinv r')ᵒᵖ}
  (f : M₁ ≅ M₂) (i : ℕ) :
  isometry ((((BD.system κ r V r').map_iso f).hom.app (op c)).f i) :=
begin
  simp only [← iso.app_hom, ← homological_complex.hom.iso_app_hom],
  apply SemiNormedGroup.iso_isometry_of_norm_noninc;
  apply complex.map_norm_noninc,
end

instance system.separated_space (c : ℝ≥0) (i : ℕ) (M) :
  separated_space (((BD.system κ r V r').obj M) c i) :=
CLCFPTinv₂.separated_space _ _ _ _ _ _ _

instance system.complete_space (c : ℝ≥0) (i : ℕ) (M) :
  complete_space (((BD.system κ r V r').obj M) c i) :=
CLCFPTinv₂.complete_space _ _ _ _ _ _ _

end

section

variables (BD : breen_deligne.data)
variables (r : ℝ≥0) (V : SemiNormedGroup) [normed_with_aut r V] [fact (0 < r)]
variables (r' : ℝ≥0) [fact (0 < r')] [fact (r' ≤ 1)]
variables (κ : ℕ → ℝ≥0) [BD.very_suitable r r' κ]

variables {r V r' κ}

lemma system_admissible {M} : ((BD.system κ r V r').obj M).admissible :=
{ d_norm_noninc' := λ c i j hij,
  begin
    haveI : universal_map.very_suitable (BD.d j i) r r' (unop (op c) * κ j) (unop (op c) * κ i) :=
    by { dsimp only [unop_op], apply_instance },
    exact universal_map.eval_CLCFPTinv_norm_noninc _ _ _ _ _ _ _,
  end,
  res_norm_noninc := λ c₁ c₂ i h, CLCFPTinv.res_norm_noninc _ _ _ _ _ _ _, }

end

end data

end breen_deligne

#lint- only unused_arguments def_lemma doc_blame


import .basic

universes u v

variables (M N : Type u) [monoid M] [monoid N]
variables (G H : Type u) [group G] [group H]
variables {K : Type v} [monoid K]

def bicoprod_monoid_aux (b : bool) : monoid (cond b M N) :=
{ mul := bool.cases_on b ((*) : N → N → N) ((*) : M → M → M),
  one := bool.cases_on b (1 : N) (1 : M),
  mul_assoc := bool.cases_on b (@mul_assoc N _) (@mul_assoc M _),
  one_mul := bool.cases_on b (@one_mul N _) (@one_mul M _),
  mul_one := bool.cases_on b (@mul_one N _) (@mul_one M _) }

local attribute [instance] bicoprod_monoid_aux

def bicoprod := coprod (λ b : bool, cond b M N)

namespace bicoprod

variables [decidable_eq M] [decidable_eq N] [decidable_eq G] [decidable_eq H]

infixr ` ⋆ `: 30 := bicoprod

def bicoprod_group_aux (b : bool) :
  group (cond b G H) :=
let I : group (cond b G H) := by cases b; dunfold cond; apply_instance in
{ inv := bool.cases_on b (@has_inv.inv H _) (@has_inv.inv G _),
  mul_left_inv := bool.cases_on b (@mul_left_inv H _) (@mul_left_inv G _),
  ..bicoprod_monoid_aux G H b }

def bicoprod_dec_eq_aux (b : bool) :
  decidable_eq (cond b M N) := by cases b; dunfold cond; apply_instance

local attribute [instance] bicoprod_group_aux bicoprod_dec_eq_aux

instance : monoid (M ⋆ N) := coprod.monoid

instance : group (G ⋆ H) := @coprod.group bool (λ b, cond b G H) _ _ _

variables {M N}

def inl : M →* M ⋆ N :=
{ to_fun := @coprod.of bool (λ b, cond b M N) _ _ _ tt,
  map_one' := by simp,
  map_mul' := by simp }

def inr : N →* M ⋆ N :=
{ to_fun := @coprod.of bool (λ b, cond b M N) _ _ _ ff,
  map_one' := by simp,
  map_mul' := by simp }

def lift (f : M →* K) (g : N →* K) : M ⋆ N →* K :=
{ to_fun := coprod.lift (λ b, show cond b M N →* K,
    from bool.rec_on b ⟨g, by simp, by simp⟩ ⟨f, by simp, by simp⟩ ),
  map_one' := by simp,
  map_mul' := by simp }

@[simp] lemma lift_inl (f₁ : M →* K) (f₂ : N →* K) (m : M) :
  (lift f₁ f₂) (inl m) = f₁ m :=
@coprod.lift_of bool (λ b, cond b M N) _ _ _ _ _ _ tt m

@[simp] lemma lift_inr (f₁ : M →* K) (f₂ : N →* K) (n : N) :
  (lift f₁ f₂) (inr n) = f₂ n :=
@coprod.lift_of bool (λ b, cond b M N) _ _ _ _ _ _ ff n

@[simp] lemma lift_comp_inl (f₁ : G →* M) (f₂ : H →* M) :
  (lift f₁ f₂).comp inl = f₁ :=
monoid_hom.ext (lift_inl _ _)

@[simp] lemma lift_comp_inr (f₁ : G →* M) (f₂ : H →* M) :
  (lift f₁ f₂).comp inr = f₂ :=
monoid_hom.ext (lift_inr _ _)

end bicoprod


import implementation.model.envelope
import implementation.model.protocol
import tactic.basic
import data.set.basic

-- A sys_state contains both the state of all processes and the set of messages
-- sent by each process.
structure sys_state (pid_t pstate_t msg_t : Type)
  [protocol pid_t pstate_t msg_t] : Type :=
  (procs : pid_t → pstate_t) (network : pid_t → set(envelope pid_t msg_t))

namespace sys_state

variables {pid_t pstate_t msg_t : Type} [protocol pid_t pstate_t msg_t]

-- is_initial states that the system state matches the initial state specified
-- by the protocol.
def is_initial (s : sys_state pid_t pstate_t msg_t) : Prop :=
  ∀ p : pid_t, protocol.init p = (s.procs p, s.network p)

-- possible_next states that we can reach the state `after` from the state
-- `before` by delivering an envelope's message to one of the processes that may
-- receive the envelope. The state and network of the receiver are updated
-- accordingly, and all other states/networks are unchanged.
def possible_next (before after : sys_state pid_t pstate_t msg_t) : Prop :=
  ∃ (receiver sender : pid_t) (e ∈ before.network sender),
      envelope.deliverable_to e receiver
    ∧ after.procs receiver = (protocol.handler receiver (before.procs receiver) (envelope.msg e) sender).fst
    ∧ after.network receiver = before.network receiver ∪ (protocol.handler receiver (before.procs receiver) (envelope.msg e) sender).snd
    ∧ (∀ (p ≠ receiver), after.procs p = before.procs p)
    ∧ (∀ (p ≠ receiver), after.network p = before.network p)

lemma eq_iff_fields_eq {s1 s2 : sys_state pid_t pstate_t msg_t} :
  s1 = s2 ↔ (∀ (p : pid_t), s1.procs p  = s2.procs p) ∧
            (∀ (p : pid_t), s1.network p = s2.network p) :=
begin
split,
{ intro identical,
  rw identical,
  split; intro p; refl },
cases s1; cases s2;
intro both_eq,
unfold sys_state.procs sys_state.network at both_eq,
rwa [ (show s1_procs = s2_procs, by exact function.funext_iff.mpr both_eq.left),
      (show s1_network = s2_network, by exact function.funext_iff.mpr both_eq.right) ]
end

-- `reachable_in n s` says that s is at most `n` steps away from an initial
-- state, according to the relation `possible_next`.
def reachable_in : ℕ → sys_state pid_t pstate_t msg_t → Prop
| nat.zero     := sys_state.is_initial
| (nat.succ j) :=
    (λ (v : sys_state pid_t pstate_t msg_t),
      (∃ (u : sys_state pid_t pstate_t msg_t),
        reachable_in j u ∧ u.possible_next v) ∨ reachable_in j v)

def reachable (s : sys_state pid_t pstate_t msg_t) :=
  ∃ (num_steps : ℕ), s.reachable_in num_steps

variable [decidable_eq pid_t]

-- Messages are only added to the network sets.
lemma ntwk_subset {e : envelope pid_t msg_t} {u v : sys_state pid_t pstate_t msg_t} {p : pid_t} :
  (e ∈ u.network p) → (u.possible_next v) → (e ∈ v.network p) :=
begin
intro he,
rintros ⟨receiver, sender, _, _, _, _, ntwk_change, _, same⟩,
cases decidable.em (p = receiver),
{ rw h at he ⊢, rw ntwk_change, left, exact he },
rw same p h, exact he
end

end sys_state


import .bvm_extras

open lattice

universe u

local infix ` ⟹ `:65 := lattice.imp

local infix ` ⇔ `:50 := lattice.biimp

local infix `≺`:75 := (λ x y, -(bSet.larger_than x y))

local infix `≼`:75 := (λ x y, bSet.injects_into x y)

namespace bSet

section lemmas
variables {𝔹 : Type u} [nontrivial_complete_boolean_algebra 𝔹] {Γ : 𝔹}

lemma prod_subset {x₁ x₂ y₁ y₂ : bSet 𝔹} (H_sub₁ : Γ ≤ x₁ ⊆ᴮ x₂) (H_sub₂ : Γ ≤ y₁ ⊆ᴮ y₂) : Γ ≤ prod x₁ y₁ ⊆ᴮ prod x₂ y₂ :=
begin
  rw subset_unfold', bv_intro pr, bv_imp_intro Hpr,
  rw mem_prod_iff₂ at Hpr ⊢, rcases Hpr with ⟨v,Hv,w,Hw,H_eq⟩,
  have Hv' := mem_of_mem_subset H_sub₁ Hv,
  have Hw' := mem_of_mem_subset H_sub₂ Hw,
  exact ⟨v,‹_›,w,‹_›,‹_›⟩
end

lemma prod_subset_left {x₁ x₂ y : bSet 𝔹} (H_sub : Γ ≤ x₁ ⊆ᴮ x₂) : Γ ≤ prod x₁ y ⊆ᴮ prod x₂ y :=
prod_subset H_sub subset_self

lemma prod_subset_right {x y₁ y₂ : bSet 𝔹} (H_sub : Γ ≤ y₁ ⊆ᴮ y₂) : Γ ≤ prod x y₁ ⊆ᴮ prod x y₂ :=
prod_subset subset_self H_sub

end lemmas

section inj_inverse_surj
variables {𝔹 : Type u} [nontrivial_complete_boolean_algebra 𝔹] {x y f : bSet 𝔹} {Γ : 𝔹}
  (H_func : Γ ≤ is_func' x y f) (H_inj : Γ ≤ is_inj f)

lemma inj_inverse.is_total_surj (H_surj : Γ ≤ is_surj x y f) : Γ ≤ is_total y x (inj_inverse H_func H_inj) :=
begin
  have := bv_symm (image_eq_codomain_of_surj H_surj),
  apply @bv_rw' _ _ _ _ _ this (λ z, is_total z x (inj_inverse H_func H_inj)), simp,
  apply inj_inverse.is_total
end

lemma inj_inverse.is_function_surj (H_surj : Γ ≤ is_surj x y f) : Γ ≤ is_function y x (inj_inverse H_func H_inj) :=
begin
  have := bv_symm (image_eq_codomain_of_surj H_surj),
  apply @bv_rw' _ _ _ _ _ this (λ z, is_function z x (inj_inverse H_func H_inj)), simp,
  apply inj_inverse.is_function
end

lemma inj_inverse.is_surj_surj (H_surj : Γ ≤ is_surj x y f) : Γ ≤ is_surj y x (inj_inverse H_func H_inj) :=
begin
  apply @bv_rw' _ _ _ _ _ (bv_symm (image_eq_codomain_of_surj H_surj))
          (λ z, is_surj z x (inj_inverse H_func H_inj)), simp,
  apply inj_inverse.is_surj
end

end inj_inverse_surj

section Ord
variables {𝔹 : Type u} [nontrivial_complete_boolean_algebra 𝔹] {Γ : 𝔹}

lemma subset_of_mem_Ord {x y : bSet 𝔹} {Γ} (H_mem : Γ ≤ x ∈ᴮ y) (H_Ord : Γ ≤ Ord y) : Γ ≤ x ⊆ᴮ y :=
subset_of_mem_transitive (bv_and.right ‹_›) ‹_›

lemma mem_of_mem_Ord {x y z : bSet 𝔹} {Γ} (H_mem : Γ ≤ x ∈ᴮ y) (H_mem' : Γ ≤ y ∈ᴮ z) (H_ord₂ : Γ ≤ Ord z) : Γ ≤ x ∈ᴮ z :=
begin
  refine mem_of_mem_subset _ H_mem, apply subset_of_mem_Ord; from ‹_›
end

-- @[reducible]def Ord_max {x y : bSet 𝔹} {Γ : 𝔹} (H₁ : Γ ≤ Ord x) (H₂ : Γ ≤ Ord y) : bSet 𝔹 :=
-- succ (binary_union x y)

lemma transitive_union {u : bSet 𝔹} {Γ : 𝔹} (Hu : Γ ≤ ⨅z, z ∈ᴮ u ⟹ is_transitive z) : Γ ≤ is_transitive (bv_union u) :=
begin
  bv_intro x, bv_imp_intro H_mem, rw mem_bv_union_iff at H_mem,
  bv_cases_at H_mem y Hy, bv_split_at Hy,
  rw subset_unfold', bv_intro w, bv_imp_intro Hw,
  rw mem_bv_union_iff, apply bv_use y, refine le_inf ‹_› _,
  simp only [is_transitive] at Hu,
  exact mem_of_mem_subset (Hu y ‹_› x ‹_›) ‹_›
end

lemma transitive_binary_inter {x y : bSet 𝔹} {Γ} (H₁ : Γ ≤ Ord x) (H₂ : Γ ≤ Ord y) : Γ ≤ is_transitive (x ∩ᴮ y) :=
begin
  bv_intro z, bv_imp_intro H_mem, rw mem_binary_inter_iff at H_mem, cases H_mem with H_mem₁ H_mem₂,
    rw subset_unfold', bv_intro w, bv_imp_intro Hw, rw mem_binary_inter_iff, refine ⟨_,_⟩,
      { have := (bv_and.right H₁), unfold is_transitive at this, exact mem_of_mem_subset (this z ‹_›) ‹_› },
      { have := (bv_and.right H₂), unfold is_transitive at this, exact mem_of_mem_subset (this z ‹_›) ‹_› }
end

lemma epsilon_trichotomy_binary_inter {x y : bSet 𝔹} {Γ} (H₁ : Γ ≤ Ord x) : Γ ≤ epsilon_trichotomy (x ∩ᴮ y) :=
begin
  bv_intro w, bv_imp_intro Hw_mem, bv_intro z, bv_imp_intro Hz_mem,
  rw mem_binary_inter_iff at Hw_mem Hz_mem, cases Hz_mem with Hz_mem_x Hz_mem_y,
  cases Hw_mem with Hw_mem_x Hw_mem_y,
  exact epsilon_trichotomy_of_Ord Hw_mem_x Hz_mem_x ‹_›
end

lemma epsilon_well_founded_binary_inter {x y : bSet 𝔹} {Γ} (H₁ : Γ ≤ Ord x) :
  Γ ≤ epsilon_well_founded (x ∩ᴮ y) :=
begin
  bv_intro w, bv_imp_intro Hw_sub, bv_imp_intro H_nonempty,
  rcases subset_binary_inter_iff.mp Hw_sub with ⟨Hw_sub₁, Hw_sub₂⟩,
  exact (bv_and.right (bv_and.left H₁) w) Hw_sub₁ ‹_›,
end

lemma Ord_binary_inter {x y : bSet 𝔹} {Γ} (H₁ : Γ ≤ Ord x) (H₂ : Γ ≤ Ord y) : Γ ≤ Ord (binary_inter x y) :=
begin
  refine le_inf _ _,
    { from le_inf (epsilon_trichotomy_binary_inter H₁) (epsilon_well_founded_binary_inter ‹_›) },
    { bv_intro z, bv_imp_intro H_mem, rw mem_binary_inter_iff at H_mem, cases H_mem with H_mem₁ H_mem₂,
      rw subset_unfold', bv_intro w, bv_imp_intro Hw, rw mem_binary_inter_iff, refine ⟨_,_⟩,
        { have := (bv_and.right H₁), unfold is_transitive at this, exact mem_of_mem_subset (this z ‹_›) ‹_› },
        { have := (bv_and.right H₂), unfold is_transitive at this, exact mem_of_mem_subset (this z ‹_›) ‹_› }}
end

section compl

def compl (x y : bSet 𝔹) := comprehend (λ z, - (z ∈ᴮ y)) x

lemma compl_subset {x y : bSet 𝔹} : Γ ≤ compl x y ⊆ᴮ x :=
by {rw compl, apply comprehend_subset, simp}

lemma mem_compl_iff {x y : bSet 𝔹} {z} : Γ ≤ z ∈ᴮ compl x y ↔ (Γ ≤ z ∈ᴮ x ∧ Γ ≤ -(z ∈ᴮ y)) :=
begin
  unfold compl,
  refine ⟨_,_⟩; intro H,
    { rw mem_comprehend_iff₂ at H, refine ⟨_,_⟩,
      { bv_cases_at H w Hw, bv_split, bv_split, bv_cc },
      { bv_cases_at H w Hw, bv_split, bv_split, apply bv_rw' Hw_right_left, simp, from ‹_› },
      { simp }  },
    { rw mem_comprehend_iff₂, cases H with H₁ H₂, apply bv_use z,
      refine le_inf ‹_› (le_inf bv_refl _), from ‹_›, simp }
end

lemma compl_empty_of_subset {x y : bSet 𝔹} (H_sub : Γ ≤ x ⊆ᴮ y) : Γ ≤ compl x y =ᴮ ∅ :=
begin
  apply bv_by_contra, bv_imp_intro H_contra, rw nonempty_iff_exists_mem at H_contra, bv_cases_at H_contra w Hw,
  rw mem_compl_iff at Hw, cases Hw with Hw₁ Hw₂,
  suffices : Γ_2 ≤ w ∈ᴮ y, by bv_contradiction,
  from mem_of_mem_subset ‹_› ‹_›
end

lemma nonempty_compl_of_ne {x y : bSet 𝔹} (H_ne : Γ ≤ - ( x=ᴮ y)) : Γ ≤ (- ((compl x y) =ᴮ ∅)) ⊔ (- ((compl y x) =ᴮ ∅)) :=
begin
  rw bv_eq_unfold' at H_ne, simp only with bv_push_neg at H_ne, bv_or_elim_at H_ne,
    { refine bv_or_left _, rw nonempty_iff_exists_mem, bv_cases_at H_ne.left z Hz, apply bv_use z,
      rw mem_compl_iff, bv_split, from ⟨‹_›,‹_›⟩ },
    { refine bv_or_right _, rw nonempty_iff_exists_mem, bv_cases_at H_ne.right z Hz, apply bv_use z,
      rw mem_compl_iff, bv_split, from ⟨‹_›,‹_›⟩ }
end

end compl

lemma eq_iff_not_mem_of_Ord {x y z : bSet 𝔹} (H_mem₁ : Γ ≤ x ∈ᴮ z) (H_mem₂ : Γ ≤ y ∈ᴮ z) (H_ord : Γ ≤ Ord z) : Γ ≤ x =ᴮ y ↔ (Γ ≤ -(x ∈ᴮ y) ∧ Γ ≤ -(y ∈ᴮ x)) :=
begin
  have H_tri := epsilon_trichotomy_of_Ord H_mem₁ H_mem₂ H_ord,
  refine ⟨_,_⟩; intro H,
    { refine ⟨_,_⟩,
      { apply bv_rw' H, simp, rw ←imp_bot, bv_imp_intro H', from bot_of_mem_self' ‹_› },
      { apply bv_rw' H, simp, rw ←imp_bot, bv_imp_intro H', from bot_of_mem_self' ‹_› }},
    { cases H with H₁ H₂, bv_or_elim_at H_tri, bv_or_elim_at H_tri.left,
        { from ‹_› },
        { apply bv_exfalso, bv_contradiction },
        { apply bv_exfalso, bv_contradiction }}
end

lemma Ord.lt_of_ne_and_le {x y : bSet 𝔹} (H₁ : Γ ≤ Ord x) (H₂ : Γ ≤ Ord y) (H_ne : Γ ≤ -(x =ᴮ y)) (H_le : Γ ≤ x ⊆ᴮ y) : Γ ≤ x ∈ᴮ y :=
begin
  have H_compl_nonempty : Γ ≤ - (compl y x =ᴮ ∅),
    by { have this₁ := nonempty_compl_of_ne H_ne,
         have this₂ := compl_empty_of_subset H_le,
         bv_or_elim_at this₁,
           { apply bv_exfalso, from bv_absurd _ this₂ ‹_› },
           { from ‹_› } },
  have H_ex_min := bSet_axiom_of_regularity _ H_compl_nonempty,
  bv_cases_at H_ex_min z Hz, bv_split_at Hz,
  cases mem_compl_iff.mp Hz_left with Hz₁ Hz₂,
  suffices H_eq : Γ_1 ≤ x =ᴮ z, by bv_cc,
  rw bv_eq_unfold', refine le_inf _ _,
         { bv_intro a, bv_imp_intro Ha, have this' := epsilon_trichotomy_of_Ord (mem_of_mem_subset H_le Ha) ‹_› ‹_›,
           bv_or_elim_at this', bv_or_elim_at this'.left,
             { apply bv_exfalso, exact bv_absurd (z ∈ᴮ x) (by bv_cc) ‹_› },
             { from ‹_› },
             { apply bv_exfalso, refine bv_absurd (z ∈ᴮ x) _ ‹_›,
               apply mem_of_mem_Ord this'.right ‹_› ‹_› }},
         { bv_intro a, bv_imp_intro Ha, apply bv_by_contra, bv_imp_intro H_contra,
           have Ha' : Γ_3 ≤ a ∈ᴮ y,
             by {refine mem_of_mem_Ord Ha ‹_› H₂, },
           have : Γ_3 ≤ a ∈ᴮ y ∧ Γ_3 ≤ -(a ∈ᴮ x) := ⟨‹_›,‹_›⟩,
           rw ←mem_compl_iff at this,
           refine bv_absurd _ Ha _,
           exact Hz_right a ‹_› }
end

lemma Ord.le_or_le {x y : bSet 𝔹} (H₁ : Γ ≤ Ord x) (H₂ : Γ ≤ Ord y) : Γ ≤ x ⊆ᴮ y ⊔ y ⊆ᴮ x :=
begin
  let w := x ∩ᴮ y,
  have w_Ord : Γ ≤ Ord w := Ord_binary_inter H₁ H₂,
  have : Γ ≤ w =ᴮ x ⊔ w =ᴮ y,
    by { apply bv_by_contra, bv_imp_intro H_contra, simp only with bv_push_neg at H_contra,
         suffices : Γ_1 ≤ w ∈ᴮ x ∧ Γ_1 ≤ w ∈ᴮ y,
           by { suffices : Γ_1 ≤ w ∈ᴮ w, from bot_of_mem_self' ‹_›,
                rwa mem_binary_inter_iff }, bv_split_at H_contra,
                refine ⟨_,_⟩,
                  { apply Ord.lt_of_ne_and_le w_Ord, repeat {assumption}, from binary_inter_subset_left },
                  { apply Ord.lt_of_ne_and_le w_Ord, repeat {assumption}, from binary_inter_subset_right }},
  bv_or_elim_at this,
    { refine bv_or_left _, apply bv_rw' (bv_symm this.left), simp,
      exact binary_inter_subset_right },
    { refine bv_or_right _, apply bv_rw' (bv_symm this.right), simp,
      exact binary_inter_subset_left }
end

lemma Ord.trichotomy {x y : bSet 𝔹} (H₁ : Γ ≤ Ord x) (H₂ : Γ ≤ Ord y) : Γ ≤ x =ᴮ y ⊔ x ∈ᴮ y ⊔ y ∈ᴮ x :=
begin
  have := Ord.le_or_le H₁ H₂,
  bv_or_elim_at this,
    { bv_cases_on x =ᴮ y,
       { from bv_or_left (bv_or_left ‹_›) },
       { refine bv_or_left (bv_or_right _), apply Ord.lt_of_ne_and_le, repeat {assumption} }},
    { bv_cases_on x =ᴮ y,
       { from bv_or_left (bv_or_left ‹_›) },
       { refine bv_or_right _, rw bv_eq_symm at H.right, apply Ord.lt_of_ne_and_le, repeat {assumption} }}
end

lemma Ord.eq_iff_not_mem {x y : bSet 𝔹} (H₁ : Γ ≤ Ord x) (H₂ : Γ ≤ Ord y) : Γ ≤ x =ᴮ y  ↔ (Γ ≤ -(x ∈ᴮ y) ∧ Γ ≤ -(y ∈ᴮ x)) :=
begin
  refine ⟨_,_⟩; intro H,
    { refine ⟨_,_⟩,
        { rw ←imp_bot, bv_imp_intro H_contra, apply bot_of_mem_self', show bSet 𝔹, from y,
          bv_cc  },
        { rw ←imp_bot, bv_imp_intro H_contra, apply bot_of_mem_self', show bSet 𝔹, from y,
          bv_cc } },
    { cases H with H₁' H₂', have := Ord.trichotomy H₁ H₂,
      bv_or_elim_at this, bv_or_elim_at this.left,
      all_goals { assumption <|> {apply bv_exfalso; bv_contradiction} } }
end

lemma Ord.eq_of_not_mem {x y : bSet 𝔹} (H₁ : Γ ≤ Ord x) (H₂ : Γ ≤ Ord y) (H_nmem₁ : Γ ≤ -(x ∈ᴮ y)) (H_nmem₂ : Γ ≤ -(y ∈ᴮ x)) : Γ ≤ x =ᴮ y :=
by { rw Ord.eq_iff_not_mem; simp* }

lemma Ord.le_iff_lt_or_eq {x y : bSet 𝔹} (H₁ : Γ ≤ Ord x) (H₂ : Γ ≤ Ord y) : Γ ≤ x ⊆ᴮ y ↔ (Γ ≤ x ∈ᴮ y ⊔ x =ᴮ y) :=
begin
  refine ⟨_,_⟩; intro H,
    { bv_cases_on x =ᴮ y,
        { exact bv_or_right ‹_› },
        { refine bv_or_left _, apply Ord.lt_of_ne_and_le ‹_› H₂ ‹_› ‹_› } },
    { bv_or_elim_at H,
      { from subset_of_mem_Ord ‹_› ‹_› },
      { apply bv_rw' H.right, simp, from subset_self }}
end

lemma Ord.lt_of_not_le {x y : bSet 𝔹} (H₁ : Γ ≤ Ord x) (H₂ : Γ ≤ Ord y) : Γ ≤ -(x ⊆ᴮ y) → Γ ≤ y ∈ᴮ x :=
begin
  intro H_not_le, apply bv_by_contra, bv_imp_intro H_contra, rw ←imp_bot at H_not_le, refine H_not_le _,
  rw Ord.le_iff_lt_or_eq,
    { have := Ord.trichotomy H₁ H₂,
      bv_or_elim_at this,
        { rwa sup_comm },
        { apply bv_exfalso, bv_contradiction } },
    { from ‹_› },
    { from ‹_› }
end

lemma Ord.resolve_lt {x y : bSet 𝔹} (H₁ : Γ ≤ Ord x) (H₂ : Γ ≤ Ord y) : Γ ≤ -(x ∈ᴮ y) → Γ ≤ (y ∈ᴮ x) ⊔ (y =ᴮ x) :=
begin
  intro H_not_mem, have := Ord.trichotomy H₁ H₂,
  bv_or_elim_at this, bv_or_elim_at this.left,
    { from bv_or_right (bv_symm ‹_›) },
    { from bv_exfalso (by bv_contradiction) },
    { from bv_or_left ‹_› }
end

lemma epsilon_trichotomy_of_sub_Ord {Γ : 𝔹} (u : bSet 𝔹) (H_ord : Γ ≤ ⨅ x, x ∈ᴮ u ⟹ Ord x)
  : Γ ≤ (⨅y, y∈ᴮ u ⟹ (⨅z, z ∈ᴮ u ⟹ (y =ᴮ z ⊔ y ∈ᴮ z ⊔ z ∈ᴮ y))) :=
begin
  bv_intro y, bv_imp_intro Hy, bv_intro z, bv_imp_intro Hz,
  have H₁ : Γ_2 ≤ Ord y := H_ord y ‹_›,
  have H₂ : Γ_2 ≤ Ord z := H_ord z ‹_›,
  exact Ord.trichotomy H₁ H₂
end

lemma epsilon_wf_of_sub_Ord {Γ : 𝔹} (u : bSet 𝔹) : Γ ≤ (⨅x, x ⊆ᴮ u ⟹ (- (x =ᴮ ∅) ⟹ ⨆y, y∈ᴮ x ⊓ (⨅z', z' ∈ᴮ x ⟹ (- (z' ∈ᴮ y))))) :=
begin
  bv_intro x, bv_imp_intro Hsub, bv_imp_intro H_nonempty,
  exact bSet_axiom_of_regularity _ H_nonempty,
end

def exists_two (η : bSet 𝔹) : 𝔹 := (⨅x, x ∈ᴮ η ⟹ ⨆ z, z ∈ᴮ η ⊓ (x ∈ᴮ z ⊔ z ∈ᴮ x))

@[simp]lemma B_ext_exists_two : B_ext (exists_two : bSet 𝔹 → 𝔹) :=
begin
  unfold B_ext, unfold exists_two, change B_ext _, simp
end

lemma one_mem_of_not_zero_and_not_one {η : bSet 𝔹} {Γ : 𝔹} (H_ord : Γ ≤ Ord η) (H_not_zero : Γ ≤ -(η =ᴮ 0)) (H_not_one : Γ ≤ -(η =ᴮ 1)) : Γ ≤ 1 ∈ᴮ η :=
begin
  have := Ord.trichotomy (H_ord) Ord_one,
  bv_or_elim_at this, bv_or_elim_at this.left,
    { apply bv_exfalso, bv_contradiction },
    { suffices : Γ_2 ≤ η =ᴮ 0, by apply bv_exfalso; bv_contradiction,
      exact eq_zero_of_mem_one this.left.right },
    { from ‹_› }
end

lemma exists_two_iff { η : bSet 𝔹 } { Γ : 𝔹 } (H_ord : Γ ≤ Ord η): Γ ≤ exists_two η ↔ Γ ≤ (- (η =ᴮ 1)) :=
begin
  refine ⟨_,_⟩; intro H,
    { rw ←imp_bot, bv_imp_intro H_contra,
      have : Γ_1 ≤ 0 ∈ᴮ η,
        by { apply bv_rw' H_contra, simp, simp },
      unfold exists_two at H, replace H := H (0 : bSet 𝔹) ‹_›,
      bv_cases_at H w Hw, bv_split_at Hw, bv_or_elim_at Hw_right,
      { suffices : Γ_3 ≤ 0 ∈ᴮ 0,
          by exact bot_of_mem_self' ‹_›,
        suffices : Γ_3 ≤ w =ᴮ 0,
          by bv_cc,
        exact eq_zero_of_mem_one (by bv_cc) },
      { suffices : Γ_3 ≤ 0 ∈ᴮ 0,
          by exact bot_of_mem_self' ‹_›,
        suffices : Γ_3 ≤ w =ᴮ 0,
          by bv_cc,
        exact eq_zero_of_mem_one (by bv_cc) } },
  { bv_cases_on η =ᴮ 0,
      { apply bv_rw' H_1.left, simp, apply bv_rw' zero_eq_empty, simp, apply forall_empty },
      { suffices : Γ_1 ≤ 1 ∈ᴮ η,
          by { bv_intro z, bv_imp_intro Hz_mem,
               have this' := Ord.trichotomy (Ord_of_mem_Ord Hz_mem H_ord) (Ord_one),
               bv_or_elim_at this',
               bv_or_elim_at this'.left,
                 { apply bv_use (0 : bSet 𝔹), refine le_inf _ (bv_or_right _),
                   { exact mem_of_mem_Ord (zero_mem_one) ‹_› ‹_› },
                   { apply bv_rw' ‹_ ≤ z =ᴮ 1›, simp, exact zero_mem_one } },
                 { apply bv_use (1 : bSet 𝔹), exact le_inf ‹_› (bv_or_left ‹_›) },
                 { apply bv_use (1 : bSet 𝔹), refine le_inf ‹_› (bv_or_right ‹_›) }},
        exact one_mem_of_not_zero_and_not_one ‹_› ‹_› ‹_› }}
end

end Ord

section eps_iso
variables {𝔹 : Type u} [nontrivial_complete_boolean_algebra 𝔹]

@[reducible]def strong_eps_hom (x y f : bSet 𝔹) : 𝔹 := (⨅ z₁, z₁ ∈ᴮ x ⟹ ⨅ z₂, z₂ ∈ᴮ x ⟹ ⨅ w₁, w₁ ∈ᴮ y ⟹ ⨅ w₂, w₂ ∈ᴮ y ⟹ (pair z₁ w₁ ∈ᴮ f ⟹ (pair z₂ w₂ ∈ᴮ f ⟹ (z₁ ∈ᴮ z₂ ⇔ w₁ ∈ᴮ w₂))))

lemma strong_eps_hom_iff {x y f : bSet 𝔹} {Γ} : Γ ≤ strong_eps_hom x y f ↔ ∀ {Γ'} (H_le : Γ' ≤ Γ), ∀ z₁ (Hz₁_mem : Γ' ≤ z₁ ∈ᴮ x) (z₂) (Hz₂_mem : Γ' ≤ z₂ ∈ᴮ x) (w₁) (Hw₁_mem : Γ' ≤ w₁ ∈ᴮ y) (w₂) (Hw₂_mem : Γ' ≤ w₂ ∈ᴮ y) (Hpr₁_mem : Γ' ≤ pair z₁ w₁ ∈ᴮ f) (Hpr₂_mem : Γ' ≤ pair z₂ w₂ ∈ᴮ f), Γ' ≤ z₁ ∈ᴮ z₂ ↔ Γ' ≤ w₁ ∈ᴮ w₂ :=
begin
  refine ⟨_,_⟩; intro H,
    { intros, have := (le_trans H_le H) z₁ ‹_› z₂ ‹_› w₁ ‹_› w₂ ‹_› ‹_› ‹_›,
       rw bv_biimp_iff at this, apply this, refl },
    { rw strong_eps_hom, bv_intro z₁, bv_imp_intro' Hz₁_mem, bv_intro z₂, bv_imp_intro Hz₂_mem,
  bv_intro w₁, bv_imp_intro Hw₁_mem, bv_intro w₁, bv_imp_intro Hw₂_mem, bv_imp_intro Hpr₁_mem,
  bv_imp_intro HPr₂_mem, rw bv_biimp_iff, intros Γ' H_Γ', apply_all le_trans H_Γ',
  apply H,
  refine le_trans H_Γ' (by { dsimp[Γ_6,Γ_5,Γ_4,Γ_3,Γ_2,Γ_1], tidy_context }),
  repeat { assumption } }
end

lemma strong_eps_hom_unfold {x y f : bSet 𝔹} {Γ} : Γ ≤ strong_eps_hom x y f → ∀ z₁ (Hz₁_mem : Γ ≤ z₁ ∈ᴮ x) (z₂) (Hz₂_mem : Γ ≤ z₂ ∈ᴮ x) (w₁) (Hw₁_mem : Γ ≤ w₁ ∈ᴮ y) (w₂) (Hw₂_mem : Γ ≤ w₂ ∈ᴮ y) (Hpr₁_mem : Γ ≤ pair z₁ w₁ ∈ᴮ f) (Hpr₂_mem : Γ ≤ pair z₂ w₂ ∈ᴮ f), Γ ≤ z₁ ∈ᴮ z₂ ↔ Γ ≤ w₁ ∈ᴮ w₂ := λ H,
begin
  intros, have := H z₁ ‹_› z₂ ‹_› w₁ ‹_› w₂ ‹_› ‹_› ‹_›,
  rw bv_biimp_iff at this, apply this, refl
end

def eps_iso (x y f : bSet 𝔹) : 𝔹 := is_function x y f ⊓ (strong_eps_hom x y f) ⊓ is_surj x y f

lemma is_surj_of_eps_iso {x y f : bSet 𝔹} {Γ} (H_eps_iso : Γ ≤ eps_iso x y f) : Γ ≤ is_surj x y f :=
bv_and.right ‹_›

lemma is_function_of_eps_iso {x y f : bSet 𝔹} {Γ} (H_eps_iso : Γ ≤ eps_iso x y f) : Γ ≤ is_function x y f :=
bv_and.left (bv_and.left ‹_›)

lemma strong_eps_hom_of_eps_iso {x y f : bSet 𝔹} {Γ} (H_eps_iso : Γ ≤ eps_iso x y f) : Γ ≤ strong_eps_hom x y f :=
by {bv_split_at H_eps_iso, from bv_and.right ‹_›}

lemma eps_iso_mem {x y f z₁ z₂ : bSet 𝔹} {Γ} (H₂ : Γ ≤ eps_iso x y f) (H_mem : Γ ≤ z₁ ∈ᴮ x) (H_mem' : Γ ≤ z₂ ∈ᴮ x) (H_mem'' : Γ ≤ z₁ ∈ᴮ z₂) {w₁} (H_mem''' : Γ ≤ w₁ ∈ᴮ y) (H_mem_pr₁ : Γ ≤ pair z₁ w₁ ∈ᴮ f) {w₂} (H_mem'''' : Γ ≤ w₂ ∈ᴮ y) (H_mem_pr₂ : Γ ≤ pair z₂ w₂ ∈ᴮ f) : Γ ≤ w₁ ∈ᴮ w₂ :=
by rwa ←(strong_eps_hom_unfold (strong_eps_hom_of_eps_iso ‹_›) z₁ ‹_› z₂ ‹_› w₁ ‹_› w₂ ‹_› ‹_› ‹_›)

lemma eps_iso_mem' {x y f z₁ z₂ : bSet 𝔹} {Γ} (H₂ : Γ ≤ eps_iso x y f) (H_mem : Γ ≤ z₁ ∈ᴮ x) (H_mem' : Γ ≤ z₂ ∈ᴮ x) {w₁} (H_mem''' : Γ ≤ w₁ ∈ᴮ y) (H_mem_pr₁ : Γ ≤ pair z₁ w₁ ∈ᴮ f) {w₂} (H_mem'''' : Γ ≤ w₂ ∈ᴮ y) (H_mem_pr₂ : Γ ≤ pair z₂ w₂ ∈ᴮ f) (H_mem'' : Γ ≤ w₁ ∈ᴮ w₂) : Γ ≤ z₁ ∈ᴮ z₂ :=
by rwa (strong_eps_hom_unfold (strong_eps_hom_of_eps_iso ‹_›) z₁ ‹_› z₂ ‹_› w₁ ‹_› w₂ ‹_› ‹_› ‹_›)

lemma eps_iso_not_mem {x y f z₁ z₂ : bSet 𝔹} {Γ} (H₂ : Γ ≤ eps_iso x y f) (H_mem : Γ ≤ z₁ ∈ᴮ x) (H_mem' : Γ ≤ z₂ ∈ᴮ x) (H_mem'' : Γ ≤ -(z₁ ∈ᴮ z₂)) {w₁} (H_mem''' : Γ ≤ w₁ ∈ᴮ y) (H_mem_pr₁ : Γ ≤ pair z₁ w₁ ∈ᴮ f) {w₂} (H_mem'''' : Γ ≤ w₂ ∈ᴮ y) (H_mem_pr₂ : Γ ≤ pair z₂ w₂ ∈ᴮ f) : Γ ≤ -(w₁ ∈ᴮ w₂) :=
begin
  rw ←imp_bot at ⊢ H_mem'', bv_imp_intro Hw_mem, refine H_mem'' _,
  rwa (strong_eps_hom_unfold (strong_eps_hom_of_eps_iso ‹_›) z₁ ‹_› z₂ ‹_› w₁ ‹_› w₂ ‹_› ‹_› ‹_›)
end

lemma eps_iso_not_mem' {x y f z₁ z₂ : bSet 𝔹} {Γ} (H₂ : Γ ≤ eps_iso x y f) (H_mem : Γ ≤ z₁ ∈ᴮ x) (H_mem' : Γ ≤ z₂ ∈ᴮ x) {w₁} (H_mem''' : Γ ≤ w₁ ∈ᴮ y) (H_mem_pr₁ : Γ ≤ pair z₁ w₁ ∈ᴮ f) {w₂} (H_mem'''' : Γ ≤ w₂ ∈ᴮ y) (H_mem_pr₂ : Γ ≤ pair z₂ w₂ ∈ᴮ f) (H_mem'' : Γ ≤ -(w₁ ∈ᴮ w₂)) : Γ ≤ -(z₁ ∈ᴮ z₂) :=
begin
  rw ←imp_bot at ⊢ H_mem'', bv_imp_intro Hw_mem, refine H_mem'' _,
  rwa ←(strong_eps_hom_unfold (strong_eps_hom_of_eps_iso ‹_›) z₁ ‹_› z₂ ‹_› w₁ ‹_› w₂ ‹_› ‹_› ‹_›)
end

lemma eps_iso_inj_of_Ord {x y f : bSet 𝔹} {Γ} (H₁ : Γ ≤ Ord x) (H₂ : Γ ≤ Ord y) (H₃ : Γ ≤ eps_iso x y f) : Γ ≤ is_inj f :=
begin
  bv_intro w₁, bv_intro w₂, bv_intro v₁, bv_intro v₂, bv_imp_intro H,
  bv_split_at H, bv_split_at H_left,
  have H_function := is_function_of_eps_iso ‹_›,
  have Hw₁_mem : Γ_1 ≤ w₁ ∈ᴮ x := mem_domain_of_is_function ‹_› ‹_›,
  have Hw₂_mem : Γ_1 ≤ w₂ ∈ᴮ x := mem_domain_of_is_function ‹_› ‹_›,
  have Hv₁_mem : Γ_1 ≤ v₁ ∈ᴮ y := mem_codomain_of_is_function ‹_› ‹_›,
  have Hv₂_mem : Γ_1 ≤ v₂ ∈ᴮ y := mem_codomain_of_is_function ‹_› ‹_›,
  have Hw₁_ord : Γ_1 ≤ Ord w₁ := Ord_of_mem_Ord ‹_› ‹_›,
  have Hw₂_ord : Γ_1 ≤ Ord w₂ := Ord_of_mem_Ord ‹_› ‹_›,
  have Hv₁_ord : Γ_1 ≤ Ord v₁ := Ord_of_mem_Ord ‹_› ‹_›,
  have Hv₂_ord : Γ_1 ≤ Ord v₂ := Ord_of_mem_Ord ‹_› ‹_›,
  suffices : Γ_1 ≤ - (w₁ ∈ᴮ w₂) ∧ Γ_1 ≤ -(w₂ ∈ᴮ w₁),
    by { refine Ord.eq_of_not_mem ‹_› ‹_› this.left this.right } ,
  rw Ord.eq_iff_not_mem at H_right,
    { cases H_right with H_nmem₁ H_nmem₂, refine ⟨_,_⟩,
      { exact eps_iso_not_mem' ‹_› Hw₁_mem Hw₂_mem Hv₁_mem ‹_› Hv₂_mem ‹_› ‹_›,  },
      { exact eps_iso_not_mem' ‹_› Hw₂_mem Hw₁_mem Hv₂_mem  ‹_› Hv₁_mem ‹_› ‹_› } },
    { from ‹_› },
    { from ‹_› }
end

def eps_iso_inv {x y f : bSet 𝔹} {Γ} (H₁ : Γ ≤ Ord x) (H₂ : Γ ≤ Ord y) (H₃ : Γ ≤ eps_iso x y f) : bSet 𝔹 := inj_inverse (is_func'_of_is_function (bv_and.left $ bv_and.left H₃)) (eps_iso_inj_of_Ord H₁ H₂ H₃)

lemma eps_iso_inv_surj {x y f : bSet 𝔹} {Γ} {H₁ : Γ ≤ Ord x} {H₂ : Γ ≤ Ord y} {H₃ : Γ ≤ eps_iso x y f} : Γ ≤ is_surj y x (eps_iso_inv H₁ H₂ H₃) :=
inj_inverse.is_surj_surj _ _ (is_surj_of_eps_iso ‹_›)

lemma eps_iso_inv_is_function {x y f : bSet 𝔹} {Γ} {H₁ : Γ ≤ Ord x} {H₂ : Γ ≤ Ord y} {H₃ : Γ ≤ eps_iso x y f} : Γ ≤ is_function y x (eps_iso_inv H₁ H₂ H₃) :=
begin
  apply inj_inverse.is_function_surj, from is_surj_of_eps_iso ‹_›
end

lemma eps_iso_inv_strong_eps_hom {x y f : bSet 𝔹} {Γ} {H₁ : Γ ≤ Ord x} {H₂ : Γ ≤ Ord y} {H₃ : Γ ≤ eps_iso x y f} : Γ ≤ strong_eps_hom y x (eps_iso_inv H₁ H₂ H₃) :=
begin
  have := (strong_eps_hom_of_eps_iso ‹_›),
  rw strong_eps_hom, bv_intro z₁, bv_imp_intro' Hz₁_mem, bv_intro z₂, bv_imp_intro Hz₂_mem,
  bv_intro w₁, bv_imp_intro Hw₁_mem, bv_intro w₂, bv_imp_intro Hw₂_mem, bv_imp_intro Hpr₁_mem,
  bv_imp_intro Hpr₂_mem, rw biimp_symm,
  have Hpr₁_mem' : Γ_6 ≤ pair w₁ z₁ ∈ᴮ f,
    by { erw mem_inj_inverse_iff at Hpr₁_mem, simp* },
  have Hpr₂_mem' : Γ_6 ≤ pair w₂ z₂ ∈ᴮ f,
    by { erw mem_inj_inverse_iff at Hpr₂_mem, simp* },
  rw strong_eps_hom_iff at this,
  rw bv_biimp_iff, intros Γ' H_Γ', apply_all le_trans H_Γ',
  specialize @this Γ' (by refine le_trans H_Γ' _; dsimp[Γ_6, Γ_5, Γ_4, Γ_3, Γ_2, Γ_1]; tidy_context),
  apply this, repeat {assumption}
end

lemma eps_iso_eps_iso_inv {x y f : bSet 𝔹} {Γ} {H₁ : Γ ≤ Ord x} {H₂ : Γ ≤ Ord y} {H₃ : Γ ≤ eps_iso x y f}
  : Γ ≤ eps_iso y x (eps_iso_inv H₁ H₂ H₃) :=
le_inf (le_inf eps_iso_inv_is_function eps_iso_inv_strong_eps_hom) (eps_iso_inv_surj)

lemma eps_iso_symm {x y : bSet 𝔹} {Γ} (H₁ : Γ ≤ Ord x) (H₂ : Γ ≤ Ord y) : (Γ ≤ ⨆ f, eps_iso x y f) ↔ (Γ ≤ ⨆ f, eps_iso y x f) :=
begin
  refine ⟨_,_⟩; intro H; bv_cases_at H f Hf,
    { apply bv_use (eps_iso_inv H₁ H₂ ‹_›), from eps_iso_eps_iso_inv },
    { apply bv_use (eps_iso_inv H₂ H₁ ‹_›), from eps_iso_eps_iso_inv }
end

lemma eps_iso_mono {x y z f : bSet 𝔹} {Γ} (H₁ : Γ ≤ Ord y) (H₂ : Γ ≤ z ⊆ᴮ y) (H₃ : Γ ≤ eps_iso y z f) (H₄ : Γ ≤ x ∈ᴮ y) (w' : bSet 𝔹) (Hw' : Γ ≤ pair x w' ∈ᴮ f) : Γ ≤ x ⊆ᴮ w' :=
begin
  suffices : Γ ≤ (comprehend (λ v, ⨅ w, pair v w ∈ᴮ f ⟹ w ∈ᴮ v) y) =ᴮ ∅,
    by { apply bv_by_contra, bv_imp_intro H_contra,
         suffices : Γ_1 ≤ -(comprehend (λ (v : bSet 𝔹), ⨅ (w : bSet 𝔹), pair v w ∈ᴮ f ⟹ w ∈ᴮ v) y =ᴮ ∅),
           by bv_contradiction,
         apply nonempty_of_exists_mem, apply bv_use x,
         rw mem_comprehend_iff₂, apply bv_use x,
         refine le_inf ‹_› (le_inf bv_refl _),
           { bv_intro w, bv_imp_intro Hw,
             have := Ord.lt_of_not_le _ _ H_contra,
             suffices : Γ_2 ≤ w =ᴮ w', by bv_cc,
             apply eq_of_is_function_of_eq (bv_and.left $ bv_and.left ‹_›), from (bv_refl : _ ≤ x =ᴮ x),
             from ‹_›, from ‹_›,
               { exact Ord_of_mem_Ord H₄ ‹_› },
               { refine Ord_of_mem_Ord (_ : _ ≤ w' ∈ᴮ y) ‹_›, refine mem_of_mem_subset H₂ _,
                 exact mem_codomain_of_is_function ‹_› (bv_and.left $ bv_and.left ‹_›) } },
           { simp }, },
  apply bv_by_contra, bv_imp_intro H_contra,
  replace H_contra := bSet_axiom_of_regularity _ H_contra,
  bv_cases_at H_contra a Ha, bv_split_at Ha,
  refine bv_absurd _ Ha_right _, simp only with bv_push_neg,
  have H_total := is_total_of_is_function (bv_and.left $ bv_and.left ‹_›),
  rw mem_comprehend_iff₂ at Ha_left,
    {bv_cases_at Ha_left a' Ha', bv_split_at Ha', bv_split_at Ha'_right,
    have a_mem_y : Γ_3 ≤ a ∈ᴮ y := by bv_cc,
    replace H_total := H_total a a_mem_y, bv_cases_at H_total wa Hwa, bv_split_at Hwa,
    have pair_a'_mem : Γ_4 ≤ pair a' wa ∈ᴮ f,
      by { apply bv_rw' (bv_symm Ha'_right_left), from B_ext_pair_mem_left, from ‹_› },
    have wa_mem_a : Γ_4 ≤ wa ∈ᴮ a,
      by { suffices : Γ_4 ≤ wa ∈ᴮ a', by bv_cc,
           from Ha'_right_right wa pair_a'_mem  },
    apply bv_use wa, refine le_inf _ _,
      { rw mem_comprehend_iff₂,
        { apply bv_use wa,
          have wa_mem_y : Γ_4 ≤ wa ∈ᴮ y,
            by { exact mem_of_mem_subset H₂ ‹_› },
          refine le_inf ‹_› (le_inf bv_refl _),
            { bv_intro wa', bv_imp_intro Hwa', refine eps_iso_mem ‹_› wa_mem_y a_mem_y wa_mem_a _ ‹_› ‹_› ‹_›,
              from mem_codomain_of_is_function Hwa' (bv_and.left $ bv_and.left H₃) } },
        { simp } },
      { from ‹_› } },
    { simp }
end

lemma eq_of_Ord_eps_iso_aux {x y : bSet 𝔹} {Γ} (Hx_ord : Γ ≤ Ord x) (Hy_ord : Γ ≤ Ord y) (H_eps_iso : Γ ≤ ⨆ f, eps_iso y x f) (H_mem : Γ ≤ x ∈ᴮ y) : Γ ≤ ⊥ :=
begin
  bv_cases_at H_eps_iso f Hf,
  have H_function := bv_and.left (bv_and.left Hf),
  have H_total := is_total_of_is_function H_function,
  replace H_total := H_total x ‹_›,
  bv_cases_at H_total w Hw, bv_split_at Hw,
  refine bot_of_mem_mem' _ _ _ Hw_left,
  have x_sub_y : Γ_2 ≤ x ⊆ᴮ y,
    by {apply subset_of_mem_Ord ‹_› ‹_›},
  suffices x_sub_w : Γ_2 ≤ x ⊆ᴮ w,
    by {rw Ord.le_iff_lt_or_eq at x_sub_w, bv_or_elim_at x_sub_w,
          {from ‹_›},
          { apply bv_exfalso,
            suffices : Γ_3 ≤ w ∈ᴮ w,
              by { exact bot_of_mem_self' ‹_› },
            bv_cc },
          from ‹_›, from Ord_of_mem_Ord ‹_› Hx_ord },
  apply eps_iso_mono Hy_ord x_sub_y, repeat { assumption  }
end

lemma eq_of_Ord_eps_iso {x y : bSet 𝔹} {Γ} (Hx_ord : Γ ≤ Ord x) (Hy_ord : Γ ≤ Ord y) (H_eps_iso : Γ ≤ ⨆ f, eps_iso x y f) : Γ ≤ x =ᴮ y :=
begin
  have := Ord.trichotomy Hx_ord Hy_ord,
  bv_or_elim_at this,
    { bv_or_elim_at this.left,
      { from ‹_› },
      { rw eps_iso_symm at H_eps_iso, apply bv_exfalso,
        from eq_of_Ord_eps_iso_aux Hx_ord Hy_ord ‹_› ‹_›, repeat {from ‹_›} }},
    { apply bv_exfalso, from eq_of_Ord_eps_iso_aux Hy_ord Hx_ord ‹_› ‹_› }
end

end eps_iso

variables {𝔹 : Type*} [nontrivial_complete_boolean_algebra 𝔹]

def is_limit (η : bSet 𝔹) : 𝔹 := (∅ ∈ᴮ η) ⊓ (⨅ x, x ∈ᴮ η ⟹ ⨆y, y ∈ᴮ η ⊓ x ∈ᴮ y)

lemma is_epsilon_well_founded {x : bSet 𝔹} {Γ : 𝔹}  : Γ ≤ epsilon_well_founded x :=
by { bv_intro x, bv_imp_intro Hsub, bv_imp_intro H_nonempty, exact bSet_axiom_of_regularity _ H_nonempty }

lemma Ord_succ {η : bSet 𝔹} {Γ : 𝔹} (H_Ord : Γ ≤ Ord η) : Γ ≤ Ord (succ η) :=
begin
  refine le_inf (le_inf _ _) _,
    { bv_intro y, bv_imp_intro H_mem,
      bv_intro z, bv_imp_intro Hz,
      erw mem_insert1 at H_mem Hz,
      bv_or_elim_at Hz; bv_or_elim_at H_mem,
        { exact bv_or_left (bv_or_left (by bv_cc)) },
        { exact bv_or_left (bv_or_right (by bv_cc)) },
        { exact bv_or_right (by bv_cc) },
        { exact epsilon_trichotomy_of_Ord H_mem.right Hz.right H_Ord }},
    { bv_intro x, bv_imp_intro Hsub, bv_imp_intro H_nonempty, exact bSet_axiom_of_regularity _ H_nonempty },
    { bv_intro z, bv_imp_intro Hz, erw mem_insert1 at Hz, bv_or_elim_at Hz,
      { apply bv_rw' Hz.left, simp, simp  },
      { refine subset_trans' (subset_of_mem_Ord Hz.right ‹_›) _, simp }},
end

lemma Ord.succ_le_of_lt {η ρ : bSet 𝔹} {Γ : 𝔹} (H_Ord' : Γ ≤ Ord ρ) (H_lt : Γ ≤ η ∈ᴮ ρ) : Γ ≤ succ η ⊆ᴮ ρ :=
begin
  rw subset_unfold',
  bv_intro w, bv_imp_intro Hw,
  erw mem_insert1 at Hw, bv_or_elim_at Hw,
    { bv_cc },
    { refine mem_of_mem_Ord Hw.right ‹_› ‹_› }
end

lemma omega_least_is_limit {Γ : 𝔹} : Γ ≤ ⨅ η, Ord η ⟹ ((is_limit η) ⟹ omega ⊆ᴮ η) :=
begin
  bv_intro η, bv_imp_intro H_η, bv_imp_intro H_limit,
  bv_intro x, bv_imp_intro Hx,
  induction x,
  induction x with x ih,
    { dsimp, change _ ≤ 0 ∈ᴮ _, change _ ≤ (λ z, z ∈ᴮ η) _,apply bv_rw' zero_eq_empty, simp,
      from bv_and.left ‹_› },
    { dsimp at *, change _ ≤ bSet.of_nat _ ∈ᴮ _, rw check_succ_eq_succ_check,
      specialize ih H_η ‹_› (le_top),
      bv_split_at H_limit,
      rcases exists_convert (H_limit_right (of_nat x) ‹_›) with ⟨y,Hy⟩,
      bv_split_at Hy,
      have H_y_Ord := Ord_of_mem_Ord Hy_left ‹_›,
      bv_cases_on y =ᴮ (succ (of_nat x)),
        { bv_cc }, -- bv_cc
        { have := Ord.succ_le_of_lt _ Hy_right,
          rw Ord.le_iff_lt_or_eq at this,
          bv_or_elim_at this,
          { apply mem_of_mem_Ord this.left ‹_› ‹_›, },
          { bv_cc },
          { apply Ord_succ, apply Ord_of_nat },
          { exact H_y_Ord },
          { exact H_y_Ord }}}
end

end bSet


/-
Copyright (c) 2022 Markus Himmel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Markus Himmel
-/
import category_theory.limits.preserves.shapes.terminal
import category_theory.limits.shapes.zero_morphisms

/-!
# Preservation of zero objects and zero morphisms

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

We define the class `preserves_zero_morphisms` and show basic properties.

## Main results

We provide the following results:
* Left adjoints and right adjoints preserve zero morphisms;
* full functors preserve zero morphisms;
* if both categories involved have a zero object, then a functor preserves zero morphisms if and
  only if it preserves the zero object;
* functors which preserve initial or terminal objects preserve zero morphisms.

-/

universes v₁ v₂ u₁ u₂

noncomputable theory

open category_theory
open category_theory.limits

namespace category_theory.functor
variables {C : Type u₁} [category.{v₁} C] {D : Type u₂} [category.{v₂} D]

section zero_morphisms
variables [has_zero_morphisms C] [has_zero_morphisms D]

/-- A functor preserves zero morphisms if it sends zero morphisms to zero morphisms. -/
class preserves_zero_morphisms (F : C ⥤ D) : Prop :=
(map_zero' : ∀ (X Y : C), F.map (0 : X ⟶ Y) = 0 . obviously)

@[simp]
protected lemma map_zero (F : C ⥤ D) [preserves_zero_morphisms F] (X Y : C) :
  F.map (0 : X ⟶ Y) = 0 :=
preserves_zero_morphisms.map_zero' _ _

lemma zero_of_map_zero (F : C ⥤ D) [preserves_zero_morphisms F] [faithful F] {X Y : C}
  (f : X ⟶ Y) (h : F.map f = 0) : f = 0 :=
F.map_injective $ h.trans $ eq.symm $ F.map_zero _ _

lemma map_eq_zero_iff (F : C ⥤ D) [preserves_zero_morphisms F] [faithful F] {X Y : C} {f : X ⟶ Y} :
  F.map f = 0 ↔ f = 0 :=
⟨F.zero_of_map_zero _, by { rintro rfl, exact F.map_zero _ _ }⟩

@[priority 100]
instance preserves_zero_morphisms_of_is_left_adjoint (F : C ⥤ D) [is_left_adjoint F] :
  preserves_zero_morphisms F :=
{ map_zero' := λ X Y, let adj := adjunction.of_left_adjoint F in
  begin
    calc F.map (0 : X ⟶ Y) = F.map 0 ≫ F.map (adj.unit.app Y) ≫ adj.counit.app (F.obj Y) : _
    ... = F.map 0 ≫ F.map ((right_adjoint F).map (0 : F.obj X ⟶ _)) ≫ adj.counit.app (F.obj Y) : _
    ... = 0 : _,
    { rw adjunction.left_triangle_components, exact (category.comp_id _).symm },
    { simp only [← category.assoc, ← F.map_comp, zero_comp] },
    { simp only [adjunction.counit_naturality, comp_zero] }
  end }

@[priority 100]
instance preserves_zero_morphisms_of_is_right_adjoint (G : C ⥤ D) [is_right_adjoint G] :
  preserves_zero_morphisms G :=
{ map_zero' := λ X Y, let adj := adjunction.of_right_adjoint G in
  begin
    calc G.map (0 : X ⟶ Y) = adj.unit.app (G.obj X) ≫ G.map (adj.counit.app X) ≫ G.map 0 : _
    ... = adj.unit.app (G.obj X) ≫ G.map ((left_adjoint G).map (0 : _ ⟶ G.obj X)) ≫ G.map 0 : _
    ... = 0 : _,
    { rw adjunction.right_triangle_components_assoc },
    { simp only [← G.map_comp, comp_zero] },
    { simp only [adjunction.unit_naturality_assoc, zero_comp] }
  end }

@[priority 100]
instance preserves_zero_morphisms_of_full (F : C ⥤ D) [full F] : preserves_zero_morphisms F :=
{ map_zero' := λ X Y, calc
  F.map (0 : X ⟶ Y) = F.map (0 ≫ (F.preimage (0 : F.obj Y ⟶ F.obj Y))) : by rw zero_comp
                ... = 0 : by rw [F.map_comp, F.image_preimage, comp_zero] }

end zero_morphisms

section zero_object
variables [has_zero_object C] [has_zero_object D]

open_locale zero_object

variables [has_zero_morphisms C] [has_zero_morphisms D] (F : C ⥤ D)

/-- A functor that preserves zero morphisms also preserves the zero object. -/
@[simps] def map_zero_object [preserves_zero_morphisms F] : F.obj 0 ≅ 0 :=
{ hom := 0,
  inv := 0,
  hom_inv_id' := by rw [← F.map_id, id_zero, F.map_zero, zero_comp],
  inv_hom_id' := by rw [id_zero, comp_zero] }

variables {F}

lemma preserves_zero_morphisms_of_map_zero_object (i : F.obj 0 ≅ 0) : preserves_zero_morphisms F :=
{ map_zero' := λ X Y, calc
  F.map (0 : X ⟶ Y) = F.map (0 : X ⟶ 0) ≫ F.map 0 : by rw [← functor.map_comp, comp_zero]
                ... = F.map 0 ≫ (i.hom ≫ i.inv) ≫ F.map 0
                        : by rw [iso.hom_inv_id, category.id_comp]
                ... = 0 : by simp only [zero_of_to_zero i.hom, zero_comp, comp_zero] }

@[priority 100]
instance preserves_zero_morphisms_of_preserves_initial_object
  [preserves_colimit (functor.empty.{0} C) F] : preserves_zero_morphisms F :=
preserves_zero_morphisms_of_map_zero_object $
  F.map_iso has_zero_object.zero_iso_initial
  ≪≫ preserves_initial.iso F ≪≫ has_zero_object.zero_iso_initial.symm

@[priority 100]
instance preserves_zero_morphisms_of_preserves_terminal_object
  [preserves_limit (functor.empty.{0} C) F] : preserves_zero_morphisms F :=
preserves_zero_morphisms_of_map_zero_object $
  F.map_iso has_zero_object.zero_iso_terminal
  ≪≫ preserves_terminal.iso F ≪≫ has_zero_object.zero_iso_terminal.symm

variables (F)

/-- Preserving zero morphisms implies preserving terminal objects. -/
def preserves_terminal_object_of_preserves_zero_morphisms
  [preserves_zero_morphisms F] : preserves_limit (functor.empty C) F :=
preserves_terminal_of_iso F $
  F.map_iso has_zero_object.zero_iso_terminal.symm
  ≪≫ map_zero_object F ≪≫ has_zero_object.zero_iso_terminal

/-- Preserving zero morphisms implies preserving terminal objects. -/
def preserves_initial_object_of_preserves_zero_morphisms
  [preserves_zero_morphisms F] : preserves_colimit (functor.empty C) F :=
preserves_initial_of_iso F $
  has_zero_object.zero_iso_initial.symm ≪≫ (map_zero_object F).symm
  ≪≫ (F.map_iso has_zero_object.zero_iso_initial.symm).symm

end zero_object

end category_theory.functor


/-
Copyright (c) 2020 Jannis Limperg. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jannis Limperg
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.list.basic
import Mathlib.data.list.defs
import Mathlib.logic.basic
import Mathlib.PostPort

universes u v u_1

namespace Mathlib

namespace list

/-- Specification of `foldr_with_index_aux`. -/
def foldr_with_index_aux_spec {α : Type u} {β : Type v} (f : ℕ → α → β → β) (start : ℕ) (b : β)
    (as : List α) : β :=
  foldr (function.uncurry f) b (enum_from start as)

theorem foldr_with_index_aux_spec_cons {α : Type u} {β : Type v} (f : ℕ → α → β → β) (start : ℕ)
    (b : β) (a : α) (as : List α) :
    foldr_with_index_aux_spec f start b (a :: as) =
        f start a (foldr_with_index_aux_spec f (start + 1) b as) :=
  rfl

theorem foldr_with_index_aux_eq_foldr_with_index_aux_spec {α : Type u} {β : Type v}
    (f : ℕ → α → β → β) (start : ℕ) (b : β) (as : List α) :
    foldr_with_index_aux f start b as = foldr_with_index_aux_spec f start b as :=
  sorry

theorem foldr_with_index_eq_foldr_enum {α : Type u} {β : Type v} (f : ℕ → α → β → β) (b : β)
    (as : List α) : foldr_with_index f b as = foldr (function.uncurry f) b (enum as) :=
  sorry

theorem indexes_values_eq_filter_enum {α : Type u} (p : α → Prop) [decidable_pred p] (as : List α) :
    indexes_values p as = filter (p ∘ prod.snd) (enum as) :=
  sorry

theorem find_indexes_eq_map_indexes_values {α : Type u} (p : α → Prop) [decidable_pred p]
    (as : List α) : find_indexes p as = map prod.fst (indexes_values p as) :=
  sorry

/-- Specification of `foldl_with_index_aux`. -/
def foldl_with_index_aux_spec {α : Type u} {β : Type v} (f : ℕ → α → β → α) (start : ℕ) (a : α)
    (bs : List β) : α :=
  foldl (fun (a : α) (p : ℕ × β) => f (prod.fst p) a (prod.snd p)) a (enum_from start bs)

theorem foldl_with_index_aux_spec_cons {α : Type u} {β : Type v} (f : ℕ → α → β → α) (start : ℕ)
    (a : α) (b : β) (bs : List β) :
    foldl_with_index_aux_spec f start a (b :: bs) =
        foldl_with_index_aux_spec f (start + 1) (f start a b) bs :=
  rfl

theorem foldl_with_index_aux_eq_foldl_with_index_aux_spec {α : Type u} {β : Type v}
    (f : ℕ → α → β → α) (start : ℕ) (a : α) (bs : List β) :
    foldl_with_index_aux f start a bs = foldl_with_index_aux_spec f start a bs :=
  sorry

theorem foldl_with_index_eq_foldl_enum {α : Type u} {β : Type v} (f : ℕ → α → β → α) (a : α)
    (bs : List β) :
    foldl_with_index f a bs =
        foldl (fun (a : α) (p : ℕ × β) => f (prod.fst p) a (prod.snd p)) a (enum bs) :=
  sorry

theorem mfoldr_with_index_eq_mfoldr_enum {m : Type u → Type v} [Monad m] {α : Type u_1} {β : Type u}
    (f : ℕ → α → β → m β) (b : β) (as : List α) :
    mfoldr_with_index f b as = mfoldr (function.uncurry f) b (enum as) :=
  sorry

theorem mfoldl_with_index_eq_mfoldl_enum {m : Type u → Type v} [Monad m] [is_lawful_monad m]
    {α : Type u_1} {β : Type u} (f : ℕ → β → α → m β) (b : β) (as : List α) :
    mfoldl_with_index f b as =
        mfoldl (fun (b : β) (p : ℕ × α) => f (prod.fst p) b (prod.snd p)) b (enum as) :=
  sorry

/-- Specification of `mmap_with_index_aux`. -/
def mmap_with_index_aux_spec {m : Type u → Type v} [Applicative m] {α : Type u_1} {β : Type u}
    (f : ℕ → α → m β) (start : ℕ) (as : List α) : m (List β) :=
  list.traverse (function.uncurry f) (enum_from start as)

-- Note: `traverse` the class method would require a less universe-polymorphic

-- `m : Type u → Type u`.

theorem mmap_with_index_aux_spec_cons {m : Type u → Type v} [Applicative m] {α : Type u_1}
    {β : Type u} (f : ℕ → α → m β) (start : ℕ) (a : α) (as : List α) :
    mmap_with_index_aux_spec f start (a :: as) =
        List.cons <$> f start a <*> mmap_with_index_aux_spec f (start + 1) as :=
  rfl

theorem mmap_with_index_aux_eq_mmap_with_index_aux_spec {m : Type u → Type v} [Applicative m]
    {α : Type u_1} {β : Type u} (f : ℕ → α → m β) (start : ℕ) (as : List α) :
    mmap_with_index_aux f start as = mmap_with_index_aux_spec f start as :=
  sorry

theorem mmap_with_index_eq_mmap_enum {m : Type u → Type v} [Applicative m] {α : Type u_1}
    {β : Type u} (f : ℕ → α → m β) (as : List α) :
    mmap_with_index f as = list.traverse (function.uncurry f) (enum as) :=
  sorry

theorem mmap_with_index'_aux_eq_mmap_with_index_aux {m : Type u → Type v} [Applicative m]
    [is_lawful_applicative m] {α : Type u_1} (f : ℕ → α → m PUnit) (start : ℕ) (as : List α) :
    mmap_with_index'_aux f start as = mmap_with_index_aux f start as *> pure PUnit.unit :=
  sorry

theorem mmap_with_index'_eq_mmap_with_index {m : Type u → Type v} [Applicative m]
    [is_lawful_applicative m] {α : Type u_1} (f : ℕ → α → m PUnit) (as : List α) :
    mmap_with_index' f as = mmap_with_index f as *> pure PUnit.unit :=
  mmap_with_index'_aux_eq_mmap_with_index_aux f 0 as

end Mathlib