/-
Copyright (c) 2018 Guy Leroy. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Sangwoo Jo (aka Jason), Guy Leroy, Johannes Hölzl, Mario Carneiro
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.nat.prime
import Mathlib.PostPort

universes u_1

namespace Mathlib

/-!
# Extended GCD and divisibility over ℤ

## Main definitions

* Given `x y : ℕ`, `xgcd x y` computes the pair of integers `(a, b)` such that
  `gcd x y = x * a + y * b`. `gcd_a x y` and `gcd_b x y` are defined to be `a` and `b`,
  respectively.

## Main statements

* `gcd_eq_gcd_ab`: Bézout's lemma, given `x y : ℕ`, `gcd x y = x * gcd_a x y + y * gcd_b x y`.

-/

/-! ### Extended Euclidean algorithm -/

namespace nat

/-- Helper function for the extended GCD algorithm (`nat.xgcd`). -/
def xgcd_aux : ℕ → ℤ → ℤ → ℕ → ℤ → ℤ → ℕ × ℤ × ℤ :=
  sorry

@[simp] theorem xgcd_zero_left {s : ℤ} {t : ℤ} {r' : ℕ} {s' : ℤ} {t' : ℤ} : xgcd_aux 0 s t r' s' t' = (r', s', t') := sorry

theorem xgcd_aux_rec {r : ℕ} {s : ℤ} {t : ℤ} {r' : ℕ} {s' : ℤ} {t' : ℤ} (h : 0 < r) : xgcd_aux r s t r' s' t' = xgcd_aux (r' % r) (s' - ↑r' / ↑r * s) (t' - ↑r' / ↑r * t) r s t := sorry

/-- Use the extended GCD algorithm to generate the `a` and `b` values
  satisfying `gcd x y = x * a + y * b`. -/
def xgcd (x : ℕ) (y : ℕ) : ℤ × ℤ :=
  prod.snd (xgcd_aux x 1 0 y 0 1)

/-- The extended GCD `a` value in the equation `gcd x y = x * a + y * b`. -/
def gcd_a (x : ℕ) (y : ℕ) : ℤ :=
  prod.fst (xgcd x y)

/-- The extended GCD `b` value in the equation `gcd x y = x * a + y * b`. -/
def gcd_b (x : ℕ) (y : ℕ) : ℤ :=
  prod.snd (xgcd x y)

@[simp] theorem gcd_a_zero_left {s : ℕ} : gcd_a 0 s = 0 := sorry

@[simp] theorem gcd_b_zero_left {s : ℕ} : gcd_b 0 s = 1 := sorry

@[simp] theorem gcd_a_zero_right {s : ℕ} (h : s ≠ 0) : gcd_a s 0 = 1 := sorry

@[simp] theorem gcd_b_zero_right {s : ℕ} (h : s ≠ 0) : gcd_b s 0 = 0 := sorry

@[simp] theorem xgcd_aux_fst (x : ℕ) (y : ℕ) (s : ℤ) (t : ℤ) (s' : ℤ) (t' : ℤ) : prod.fst (xgcd_aux x s t y s' t') = gcd x y := sorry

theorem xgcd_aux_val (x : ℕ) (y : ℕ) : xgcd_aux x 1 0 y 0 1 = (gcd x y, xgcd x y) := sorry

theorem xgcd_val (x : ℕ) (y : ℕ) : xgcd x y = (gcd_a x y, gcd_b x y) := sorry

theorem xgcd_aux_P (x : ℕ) (y : ℕ) {r : ℕ} {r' : ℕ} {s : ℤ} {t : ℤ} {s' : ℤ} {t' : ℤ} : P x y (r, s, t) → P x y (r', s', t') → P x y (xgcd_aux r s t r' s' t') := sorry

/-- Bézout's lemma: given `x y : ℕ`, `gcd x y = x * a + y * b`, where `a = gcd_a x y` and
`b = gcd_b x y` are computed by the extended Euclidean algorithm.
-/
theorem gcd_eq_gcd_ab (x : ℕ) (y : ℕ) : ↑(gcd x y) = ↑x * gcd_a x y + ↑y * gcd_b x y := sorry

end nat

/-! ### Divisibility over ℤ -/

namespace int

theorem nat_abs_div (a : ℤ) (b : ℤ) (H : b ∣ a) : nat_abs (a / b) = nat_abs a / nat_abs b := sorry

theorem nat_abs_dvd_abs_iff {i : ℤ} {j : ℤ} : nat_abs i ∣ nat_abs j ↔ i ∣ j :=
  { mp := fun (H : nat_abs i ∣ nat_abs j) => iff.mp dvd_nat_abs (iff.mp nat_abs_dvd (iff.mpr coe_nat_dvd H)),
    mpr := fun (H : i ∣ j) => iff.mp coe_nat_dvd (iff.mpr dvd_nat_abs (iff.mpr nat_abs_dvd H)) }

theorem succ_dvd_or_succ_dvd_of_succ_sum_dvd_mul {p : ℕ} (p_prime : nat.prime p) {m : ℤ} {n : ℤ} {k : ℕ} {l : ℕ} (hpm : ↑(p ^ k) ∣ m) (hpn : ↑(p ^ l) ∣ n) (hpmn : ↑(p ^ (k + l + 1)) ∣ m * n) : ↑(p ^ (k + 1)) ∣ m ∨ ↑(p ^ (l + 1)) ∣ n := sorry

theorem dvd_of_mul_dvd_mul_left {i : ℤ} {j : ℤ} {k : ℤ} (k_non_zero : k ≠ 0) (H : k * i ∣ k * j) : i ∣ j :=
  dvd.elim H
    fun (l : ℤ) (H1 : k * j = k * i * l) =>
      Exists.intro l (mul_left_cancel' k_non_zero (eq.mp (Eq._oldrec (Eq.refl (k * j = k * i * l)) (mul_assoc k i l)) H1))

theorem dvd_of_mul_dvd_mul_right {i : ℤ} {j : ℤ} {k : ℤ} (k_non_zero : k ≠ 0) (H : i * k ∣ j * k) : i ∣ j :=
  dvd_of_mul_dvd_mul_left k_non_zero
    (eq.mp (Eq._oldrec (Eq.refl (k * i ∣ j * k)) (mul_comm j k))
      (eq.mp (Eq._oldrec (Eq.refl (i * k ∣ j * k)) (mul_comm i k)) H))

theorem prime.dvd_nat_abs_of_coe_dvd_pow_two {p : ℕ} (hp : nat.prime p) (k : ℤ) (h : ↑p ∣ k ^ bit0 1) : p ∣ nat_abs k := sorry

/-- ℤ specific version of least common multiple. -/
def lcm (i : ℤ) (j : ℤ) : ℕ :=
  nat.lcm (nat_abs i) (nat_abs j)

theorem lcm_def (i : ℤ) (j : ℤ) : lcm i j = nat.lcm (nat_abs i) (nat_abs j) :=
  rfl

theorem gcd_dvd_left (i : ℤ) (j : ℤ) : ↑(gcd i j) ∣ i :=
  iff.mp dvd_nat_abs (iff.mpr coe_nat_dvd (nat.gcd_dvd_left (nat_abs i) (nat_abs j)))

theorem gcd_dvd_right (i : ℤ) (j : ℤ) : ↑(gcd i j) ∣ j :=
  iff.mp dvd_nat_abs (iff.mpr coe_nat_dvd (nat.gcd_dvd_right (nat_abs i) (nat_abs j)))

theorem dvd_gcd {i : ℤ} {j : ℤ} {k : ℤ} (h1 : k ∣ i) (h2 : k ∣ j) : k ∣ ↑(gcd i j) :=
  iff.mp nat_abs_dvd (iff.mpr coe_nat_dvd (nat.dvd_gcd (iff.mpr nat_abs_dvd_abs_iff h1) (iff.mpr nat_abs_dvd_abs_iff h2)))

theorem gcd_mul_lcm (i : ℤ) (j : ℤ) : gcd i j * lcm i j = nat_abs (i * j) := sorry

theorem gcd_comm (i : ℤ) (j : ℤ) : gcd i j = gcd j i :=
  nat.gcd_comm (nat_abs i) (nat_abs j)

theorem gcd_assoc (i : ℤ) (j : ℤ) (k : ℤ) : gcd (↑(gcd i j)) k = gcd i ↑(gcd j k) :=
  nat.gcd_assoc (nat_abs i) (nat_abs j) (nat_abs k)

@[simp] theorem gcd_self (i : ℤ) : gcd i i = nat_abs i := sorry

@[simp] theorem gcd_zero_left (i : ℤ) : gcd 0 i = nat_abs i := sorry

@[simp] theorem gcd_zero_right (i : ℤ) : gcd i 0 = nat_abs i := sorry

@[simp] theorem gcd_one_left (i : ℤ) : gcd 1 i = 1 :=
  nat.gcd_one_left (nat_abs i)

@[simp] theorem gcd_one_right (i : ℤ) : gcd i 1 = 1 :=
  nat.gcd_one_right (nat_abs i)

theorem gcd_mul_left (i : ℤ) (j : ℤ) (k : ℤ) : gcd (i * j) (i * k) = nat_abs i * gcd j k := sorry

theorem gcd_mul_right (i : ℤ) (j : ℤ) (k : ℤ) : gcd (i * j) (k * j) = gcd i k * nat_abs j := sorry

theorem gcd_pos_of_non_zero_left {i : ℤ} (j : ℤ) (i_non_zero : i ≠ 0) : 0 < gcd i j :=
  nat.gcd_pos_of_pos_left (nat_abs j) (nat_abs_pos_of_ne_zero i_non_zero)

theorem gcd_pos_of_non_zero_right (i : ℤ) {j : ℤ} (j_non_zero : j ≠ 0) : 0 < gcd i j :=
  nat.gcd_pos_of_pos_right (nat_abs i) (nat_abs_pos_of_ne_zero j_non_zero)

theorem gcd_eq_zero_iff {i : ℤ} {j : ℤ} : gcd i j = 0 ↔ i = 0 ∧ j = 0 := sorry

theorem gcd_div {i : ℤ} {j : ℤ} {k : ℤ} (H1 : k ∣ i) (H2 : k ∣ j) : gcd (i / k) (j / k) = gcd i j / nat_abs k := sorry

theorem gcd_div_gcd_div_gcd {i : ℤ} {j : ℤ} (H : 0 < gcd i j) : gcd (i / ↑(gcd i j)) (j / ↑(gcd i j)) = 1 := sorry

theorem gcd_dvd_gcd_of_dvd_left {i : ℤ} {k : ℤ} (j : ℤ) (H : i ∣ k) : gcd i j ∣ gcd k j :=
  iff.mp coe_nat_dvd (dvd_gcd (dvd.trans (gcd_dvd_left i j) H) (gcd_dvd_right i j))

theorem gcd_dvd_gcd_of_dvd_right {i : ℤ} {k : ℤ} (j : ℤ) (H : i ∣ k) : gcd j i ∣ gcd j k :=
  iff.mp coe_nat_dvd (dvd_gcd (gcd_dvd_left j i) (dvd.trans (gcd_dvd_right j i) H))

theorem gcd_dvd_gcd_mul_left (i : ℤ) (j : ℤ) (k : ℤ) : gcd i j ∣ gcd (k * i) j :=
  gcd_dvd_gcd_of_dvd_left j (dvd_mul_left i k)

theorem gcd_dvd_gcd_mul_right (i : ℤ) (j : ℤ) (k : ℤ) : gcd i j ∣ gcd (i * k) j :=
  gcd_dvd_gcd_of_dvd_left j (dvd_mul_right i k)

theorem gcd_dvd_gcd_mul_left_right (i : ℤ) (j : ℤ) (k : ℤ) : gcd i j ∣ gcd i (k * j) :=
  gcd_dvd_gcd_of_dvd_right i (dvd_mul_left j k)

theorem gcd_dvd_gcd_mul_right_right (i : ℤ) (j : ℤ) (k : ℤ) : gcd i j ∣ gcd i (j * k) :=
  gcd_dvd_gcd_of_dvd_right i (dvd_mul_right j k)

theorem gcd_eq_left {i : ℤ} {j : ℤ} (H : i ∣ j) : gcd i j = nat_abs i := sorry

theorem gcd_eq_right {i : ℤ} {j : ℤ} (H : j ∣ i) : gcd i j = nat_abs j :=
  eq.mpr (id (Eq._oldrec (Eq.refl (gcd i j = nat_abs j)) (gcd_comm i j)))
    (eq.mpr (id (Eq._oldrec (Eq.refl (gcd j i = nat_abs j)) (gcd_eq_left H))) (Eq.refl (nat_abs j)))

theorem ne_zero_of_gcd {x : ℤ} {y : ℤ} (hc : gcd x y ≠ 0) : x ≠ 0 ∨ y ≠ 0 := sorry

theorem exists_gcd_one {m : ℤ} {n : ℤ} (H : 0 < gcd m n) : ∃ (m' : ℤ), ∃ (n' : ℤ), gcd m' n' = 1 ∧ m = m' * ↑(gcd m n) ∧ n = n' * ↑(gcd m n) := sorry

theorem exists_gcd_one' {m : ℤ} {n : ℤ} (H : 0 < gcd m n) : ∃ (g : ℕ), ∃ (m' : ℤ), ∃ (n' : ℤ), 0 < g ∧ gcd m' n' = 1 ∧ m = m' * ↑g ∧ n = n' * ↑g := sorry

theorem pow_dvd_pow_iff {m : ℤ} {n : ℤ} {k : ℕ} (k0 : 0 < k) : m ^ k ∣ n ^ k ↔ m ∣ n := sorry

/-! ### lcm -/

theorem lcm_comm (i : ℤ) (j : ℤ) : lcm i j = lcm j i :=
  eq.mpr (id (Eq._oldrec (Eq.refl (lcm i j = lcm j i)) (lcm.equations._eqn_1 i j)))
    (eq.mpr (id (Eq._oldrec (Eq.refl (nat.lcm (nat_abs i) (nat_abs j) = lcm j i)) (lcm.equations._eqn_1 j i)))
      (nat.lcm_comm (nat_abs i) (nat_abs j)))

theorem lcm_assoc (i : ℤ) (j : ℤ) (k : ℤ) : lcm (↑(lcm i j)) k = lcm i ↑(lcm j k) := sorry

@[simp] theorem lcm_zero_left (i : ℤ) : lcm 0 i = 0 :=
  eq.mpr (id (Eq._oldrec (Eq.refl (lcm 0 i = 0)) (lcm.equations._eqn_1 0 i))) (nat.lcm_zero_left (nat_abs i))

@[simp] theorem lcm_zero_right (i : ℤ) : lcm i 0 = 0 :=
  eq.mpr (id (Eq._oldrec (Eq.refl (lcm i 0 = 0)) (lcm.equations._eqn_1 i 0))) (nat.lcm_zero_right (nat_abs i))

@[simp] theorem lcm_one_left (i : ℤ) : lcm 1 i = nat_abs i :=
  eq.mpr (id (Eq._oldrec (Eq.refl (lcm 1 i = nat_abs i)) (lcm.equations._eqn_1 1 i))) (nat.lcm_one_left (nat_abs i))

@[simp] theorem lcm_one_right (i : ℤ) : lcm i 1 = nat_abs i :=
  eq.mpr (id (Eq._oldrec (Eq.refl (lcm i 1 = nat_abs i)) (lcm.equations._eqn_1 i 1))) (nat.lcm_one_right (nat_abs i))

@[simp] theorem lcm_self (i : ℤ) : lcm i i = nat_abs i :=
  eq.mpr (id (Eq._oldrec (Eq.refl (lcm i i = nat_abs i)) (lcm.equations._eqn_1 i i))) (nat.lcm_self (nat_abs i))

theorem dvd_lcm_left (i : ℤ) (j : ℤ) : i ∣ ↑(lcm i j) :=
  eq.mpr (id (Eq._oldrec (Eq.refl (i ∣ ↑(lcm i j))) (lcm.equations._eqn_1 i j)))
    (iff.mpr coe_nat_dvd_right (nat.dvd_lcm_left (nat_abs i) (nat_abs j)))

theorem dvd_lcm_right (i : ℤ) (j : ℤ) : j ∣ ↑(lcm i j) :=
  eq.mpr (id (Eq._oldrec (Eq.refl (j ∣ ↑(lcm i j))) (lcm.equations._eqn_1 i j)))
    (iff.mpr coe_nat_dvd_right (nat.dvd_lcm_right (nat_abs i) (nat_abs j)))

theorem lcm_dvd {i : ℤ} {j : ℤ} {k : ℤ} : i ∣ k → j ∣ k → ↑(lcm i j) ∣ k :=
  eq.mpr (id (Eq._oldrec (Eq.refl (i ∣ k → j ∣ k → ↑(lcm i j) ∣ k)) (lcm.equations._eqn_1 i j)))
    fun (hi : i ∣ k) (hj : j ∣ k) =>
      iff.mpr coe_nat_dvd_left (nat.lcm_dvd (iff.mpr nat_abs_dvd_abs_iff hi) (iff.mpr nat_abs_dvd_abs_iff hj))

end int

theorem pow_gcd_eq_one {M : Type u_1} [monoid M] (x : M) {m : ℕ} {n : ℕ} (hm : x ^ m = 1) (hn : x ^ n = 1) : x ^ nat.gcd m n = 1 := sorry


/- This file defined the R_add relation, used to prove many of the axioms for the quotient.-/

import .quotient

open mcrl2
variable {α : Type}
variable [comm_semigroup_with_zero α]

inductive R_add {x y : mcrl2 α} :
mcrl2 α → mcrl2 α → Prop
| basel : R_add x y
| baser : R_add y x
| refl {a} : R_add a a

lemma R_add.symm {x y : mcrl2 α} :
symmetric (@R_add α _ x y) :=
begin
  intros x₁ y₁ h,
  cases h,
  { exact R_add.baser},
  { exact R_add.basel},
  { assumption}
end

lemma R_add_refl {x y} : ∀x₁, (@R_add α _ x y) x₁ x₁ := by intro x₁; exact R_add.refl

lemma R_add_congr {x y : mcrl2 α} (h : ∀z a, (transition x a z) ↔ (transition y a z)) :
x ≈ y :=
begin
  apply exists.intro R_add,
  apply and.intro R_add.basel,
  apply and.intro,
  { intros x₁ y₁ x₁' a h₁ h₂,
    apply exists.intro x₁',
    cases h₁,
    { rw ←h,
      apply and.intro h₂,
      exact option.rel.refl R_add_refl},
    { rw h,
      apply and.intro h₂,
      exact option.rel.refl R_add_refl},
    { apply and.intro h₂,
      exact option.rel.refl R_add_refl}},
  { exact R_add.symm}
end


import scone.edge

-- Demo file.

open scone

/- The type of "Hausdorffness", or any other property of a topological space.
Here, to stick close to the primitives, we just represent a topology as
a collection of (open) sets, and omit the axioms. -/
def A : Type 1 := Π (X : Type), ((X → Prop) → Prop) → Prop

def edge_A : edge_ty A :=
begin
  unfold A,                     -- optional
  -- • ⊢ Π (X : Type), ((X → Prop) → Prop) → Prop) type
  refine pi_edge_ctx_ty _ type_edge_ty _,
  -- X : Type ⊢ ((X → Prop) → Prop) → Prop) type
  refine pi_edge_ctx_ty _ _ (gen_edge_ty prop_edge_ty),
  refine pi_edge_ctx_ty _ _ (gen_edge_ty prop_edge_ty),
  refine pi_edge_ctx_ty _ _ (gen_edge_ty prop_edge_ty),
  -- X : Type ⊢ X type
  -- For this we need Russell-style universes plus the variable rule.
  refine univ_ctx_ty _ _,
  -- X : Type ⊢ X : Type
  refine last_var_ctx_tm _ _,
  done
end

/- The property of being a Hausdorff space:
any two distinct points are separated by disjoint open sets. -/
def T₂ : A :=
λ X τ,
∀ (x y : X), (x = y → false) →
∃ (U V : X → Prop), τ U ∧ τ V ∧ U x ∧ V y ∧
∀ (z : X), U z → V z → false

-- TODO: By a similar process, prove
-- def edge_T₂ : edge_ctx_tm unit_edge_ctx edge_A (λ _, T₂) := sorry

variables {X Y : Type} (τX : (X → Prop) → Prop) (τY : (Y → Prop) → Prop)
variables (e : X ≃ Y) (he : ∀ (s : set X), τX s ↔ τY (e.symm ⁻¹' s))
variables {F : A} (hF : edge_ctx_tm unit_edge_ctx edge_A.{0 0} (λ _, F))
include he hF

lemma invariant : F X τX ↔ F Y τY :=
begin
  have := hF.e ⟨rfl⟩,
  swap, exact (), swap, exact (), swap, exact (),
  specialize this X Y (discrete_edge_ctx_ty _) (discrete_edge_ctx_ty _),
  specialize this ⟨e, λ x, equiv.refl _, _⟩,
  swap,
  { rintros x₀ x₁ ⟨⟩ ⟨⟩,
    -- need to check that the function `e` "preserves edges",
    -- which is automatic because `X` is discrete
    change plift (_ =[rfl] _) ≃ plift (_ =[rfl] _),
    rw [deq_iff_eq, deq_iff_eq],
    refine equiv.plift.trans ((equiv.of_iff _).trans equiv.plift.symm),
    symmetry,
    apply equiv.apply_eq_iff_eq },
  specialize this τX τY,
  -- next we need a proof that τX "preserves edges",
  -- which is automatic because `X → Prop` is discrete,
  -- and the same for τY
  specialize this _, swap,
  { fsplit,
    { rintro (s : set X) hs,
      exact ⟨⟩ },
    { rintro (s₀ : set X) (s₁ : set X) hs₀ hs₁ h,
      suffices : s₀ = s₁,
      { constructor,
        rw this },
      ext x,
      specialize h x x () () ⟨deq.refl _⟩,
      exact h.down } },
  specialize this _, swap,
  { fsplit,
    { rintro (s : set Y) hs,
      exact ⟨⟩ },
    { rintro (s₀ : set Y) (s₁ : set Y) hs₀ hs₁ h,
      suffices : s₀ = s₁,
      { constructor,
        rw this },
      ext y,
      specialize h y y () () ⟨deq.refl _⟩,
      exact h.down } },
  -- now we need to use the compatibility of `e` and `τX`, `τY`
  specialize this _, swap,
  { rintros (s : set X) (t : set Y) _ _ h,
    suffices : t = e.symm ⁻¹' s,
    { change plift (τX s ↔ τY t),
      rw this,
      exact ⟨he s⟩ },
    ext y,
    specialize h (e.symm y) y () (),
    specialize h ⟨_⟩, swap,
    { conv { whnf },
      conv_lhs { change e (e.symm y) },
      rw e.apply_symm_apply },
    exact h.down.symm },
  exact this.down
end


import ring_theory.is_tensor_product
import algebra.category.Ring.constructions
import category_theory.limits.shapes.kernel_pair

.

open category_theory

universe u

open_locale tensor_product

variables {R S : Type u} [comm_ring R] [comm_ring S]

lemma CommRing.epi_iff_bijective_include_right [algebra R S] :
  epi (CommRing.of_hom $ algebra_map R S) ↔
  function.bijective (algebra.tensor_product.include_right : S →ₐ[R] S ⊗ S) :=
begin
  let f := CommRing.of_hom (algebra_map R S),
  show epi f ↔ _,
  have : ‹algebra R S› = ring_hom.to_algebra f,
  { apply algebra.algebra_ext, intro r, refl },
  clear_value f,
  unfreezingI { subst this },
  have := (is_pushout.of_is_colimit (CommRing.pushout_cocone_is_colimit f f)).op,
  show epi f ↔ _,
  split,
  { introI _,
    exact (@@as_iso _ _ $ (is_iso_op_iff _).mp (is_kernel_pair.is_iso_of_mono this))
      .CommRing_iso_to_ring_equiv.bijective },
  { intro h,
    exact @@category_theory.unop_epi_of_mono _ _ (@@is_kernel_pair.mono_of_is_iso_fst _ this
      ((is_iso_op_iff _).mpr $ show is_iso (ring_equiv.of_bijective _ h).to_CommRing_iso.hom,
      by apply_instance)) }
end

variable (R)

lemma module.exists_is_principal_quotient_of_finite (M : Type*) [add_comm_group M] [module R M]
  [module.finite R M] [nontrivial M] :
  ∃ N : submodule R M, N ≠ ⊤ ∧ submodule.is_principal (⊤ : submodule R (M ⧸ N))  :=
begin
  obtain ⟨n, f, hf⟩ := @module.finite.exists_fin R M _ _ _ _,
  let s := { m : ℕ | submodule.span R (f '' (coe ⁻¹' (set.Iio m))) ≠ ⊤ },
  have hns : ∀ x ∈ s, x < n,
  { intros x hx, dsimp [s] at hx, rw lt_iff_not_le, intro e,
    have : (coe ⁻¹' set.Iio x : set (fin n)) = set.univ := by { ext y, simpa using y.2.trans_le e },
    simpa [this, hf] using hx },
  have hs₁ : s.nonempty := ⟨0, by { have : set.Iio 0 = ∅ := by { ext, simp }, simp [this] }⟩,
  have hs₂ : bdd_above s := ⟨n, λ x hx, (hns x hx).le⟩,
  have hs := nat.Sup_mem hs₁ hs₂,
  refine ⟨_, hs, ⟨⟨submodule.mkq _ (f ⟨_, hns _ hs⟩), _⟩⟩⟩,
  have := not_not.mp (not_mem_of_cSup_lt (order.lt_succ _) hs₂),
  rw [← set.image_singleton, ← submodule.map_span,
    ← (submodule.comap_injective_of_surjective (submodule.mkq_surjective _)).eq_iff,
    submodule.comap_map_eq, submodule.ker_mkq, submodule.comap_top, ← this, ← submodule.span_union,
    order.Iio_succ_eq_insert (Sup s), ← set.union_singleton, set.preimage_union, set.image_union,
    ← @set.image_singleton _ _ f, set.union_comm],
  { congr, ext, simp [fin.ext_iff] },
  { apply_instance }
end

lemma module.exists_surjective_quotient_of_finite (M : Type*) [add_comm_group M] [module R M]
  [module.finite R M] [nontrivial M] :
  ∃ (I : ideal R) (f : M →ₗ[R] R ⧸ I), I ≠ ⊤ ∧ function.surjective f :=
begin
  obtain ⟨N, hN, ⟨x, hx⟩⟩ := module.exists_is_principal_quotient_of_finite R M,
  let f := (linear_map.to_span_singleton R _ x).quot_ker_equiv_of_surjective
    (by rw [← linear_map.range_eq_top, ← linear_map.span_singleton_eq_range, hx]),
  refine ⟨_, f.symm.to_linear_map.comp N.mkq, _, f.symm.surjective.comp N.mkq_surjective⟩,
  intro e,
  obtain rfl : x = 0 := by simpa using linear_map.congr_fun (linear_map.ker_eq_top.mp e) 1,
  rw [ne.def, ← submodule.subsingleton_quotient_iff_eq_top, ← not_nontrivial_iff_subsingleton,
    not_not] at hN,
  resetI,
  simpa using hx,
end

variable {R}

lemma ring_hom.surjective_of_epi_of_finite (f : R →+* S) (h₁ : epi (CommRing.of_hom f))
  (h₂ : ring_hom.finite f) : function.surjective f :=
begin
  letI := f.to_algebra,
  haveI : module.finite R S := h₂,
  have h₃ := CommRing.epi_iff_bijective_include_right.mp h₁,
  let R' := (algebra.of_id R S).to_linear_map.range,
  have : subsingleton ((S ⧸ R') ⊗[R] (S ⧸ R')),
  { refine subsingleton_of_forall_eq 0 (λ y, _),
    induction y using tensor_product.induction_on with x y x y hx hy,
    { refl },
    { obtain ⟨x, rfl⟩ := R'.mkq_surjective x,
      obtain ⟨y, rfl⟩ := R'.mkq_surjective y,
      obtain ⟨z, hz⟩ := h₃.2 (x ⊗ₜ y),
      have : R'.mkq 1 = 0,
      { rw [← linear_map.mem_ker, submodule.ker_mkq], exact (algebra.of_id R S).range.one_mem },
      calc R'.mkq x ⊗ₜ R'.mkq y = tensor_product.map R'.mkq R'.mkq (x ⊗ₜ y) :
                (tensor_product.map_tmul R'.mkq R'.mkq x y).symm
        ... = tensor_product.map R'.mkq R'.mkq (algebra.tensor_product.include_right z) :
                by rw hz
        ... = R'.mkq 1 ⊗ₜ R'.mkq z : tensor_product.map_tmul R'.mkq R'.mkq 1 z
        ... = 0 ⊗ₜ R'.mkq z : by rw [this]
        ... = 0 : tensor_product.zero_tmul _ _ },
    { rw [hx, hy, zero_add] } },
  casesI subsingleton_or_nontrivial (S ⧸ R'),
  { show function.surjective (algebra.of_id R S).to_linear_map,
    rwa [← linear_map.range_eq_top, ← submodule.subsingleton_quotient_iff_eq_top] },
  haveI := module.finite.of_surjective _ R'.mkq_surjective,
  obtain ⟨I, ϕ, hI, hϕ⟩ := module.exists_surjective_quotient_of_finite R (S ⧸ R'),
  let ψ : (S ⧸ R') ⊗[R] (S ⧸ R') →ₗ[R] R ⧸ I := (algebra.tensor_product.lmul' R : _ →ₐ[R] R ⧸ I)
    .to_linear_map.comp (tensor_product.map ϕ ϕ),
  have : function.surjective ψ,
  { intro x, obtain ⟨x, rfl⟩ := hϕ x, obtain ⟨y, hy⟩ := hϕ 1, exact ⟨x ⊗ₜ y, by simp [hy]⟩ },
  have := this.subsingleton,
  rw submodule.subsingleton_quotient_iff_eq_top at this,
  contradiction
end


/-
Copyright (c) 2018 Sébastien Gouëzel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Sébastien Gouëzel, Mario Carneiro, Yury Kudryashov, Heather Macbeth
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.analysis.normed_space.basic
import Mathlib.PostPort

universes u v w u_1

namespace Mathlib

/-!
# Bounded continuous functions

The type of bounded continuous functions taking values in a metric space, with
the uniform distance.

-/

/-- The type of bounded continuous functions from a topological space to a metric space -/
def bounded_continuous_function (α : Type u) (β : Type v) [topological_space α] [metric_space β] :=
  Subtype fun (f : α → β) => continuous f ∧ ∃ (C : ℝ), ∀ (x y : α), dist (f x) (f y) ≤ C

namespace bounded_continuous_function

protected instance has_coe_to_fun {α : Type u} {β : Type v} [topological_space α] [metric_space β] : has_coe_to_fun (bounded_continuous_function α β) :=
  has_coe_to_fun.mk (fun (x : bounded_continuous_function α β) => α → β) subtype.val

theorem bounded_range {α : Type u} {β : Type v} [topological_space α] [metric_space β] {f : bounded_continuous_function α β} : metric.bounded (set.range ⇑f) :=
  iff.mpr metric.bounded_range_iff (and.right (subtype.property f))

/-- If a function is continuous on a compact space, it is automatically bounded,
and therefore gives rise to an element of the type of bounded continuous functions -/
def mk_of_compact {α : Type u} {β : Type v} [topological_space α] [metric_space β] [compact_space α] (f : α → β) (hf : continuous f) : bounded_continuous_function α β :=
  { val := f, property := sorry }

/-- If a function is bounded on a discrete space, it is automatically continuous,
and therefore gives rise to an element of the type of bounded continuous functions -/
def mk_of_discrete {α : Type u} {β : Type v} [topological_space α] [metric_space β] [discrete_topology α] (f : α → β) (hf : ∃ (C : ℝ), ∀ (x y : α), dist (f x) (f y) ≤ C) : bounded_continuous_function α β :=
  { val := f, property := sorry }

/-- The uniform distance between two bounded continuous functions -/
protected instance has_dist {α : Type u} {β : Type v} [topological_space α] [metric_space β] : has_dist (bounded_continuous_function α β) :=
  has_dist.mk
    fun (f g : bounded_continuous_function α β) =>
      Inf (set_of fun (C : ℝ) => 0 ≤ C ∧ ∀ (x : α), dist (coe_fn f x) (coe_fn g x) ≤ C)

theorem dist_eq {α : Type u} {β : Type v} [topological_space α] [metric_space β] {f : bounded_continuous_function α β} {g : bounded_continuous_function α β} : dist f g = Inf (set_of fun (C : ℝ) => 0 ≤ C ∧ ∀ (x : α), dist (coe_fn f x) (coe_fn g x) ≤ C) :=
  rfl

theorem dist_set_exists {α : Type u} {β : Type v} [topological_space α] [metric_space β] {f : bounded_continuous_function α β} {g : bounded_continuous_function α β} : ∃ (C : ℝ), 0 ≤ C ∧ ∀ (x : α), dist (coe_fn f x) (coe_fn g x) ≤ C := sorry

/-- The pointwise distance is controlled by the distance between functions, by definition. -/
theorem dist_coe_le_dist {α : Type u} {β : Type v} [topological_space α] [metric_space β] {f : bounded_continuous_function α β} {g : bounded_continuous_function α β} (x : α) : dist (coe_fn f x) (coe_fn g x) ≤ dist f g :=
  le_cInf dist_set_exists
    fun (b : ℝ) (hb : b ∈ set_of fun (C : ℝ) => 0 ≤ C ∧ ∀ (x : α), dist (coe_fn f x) (coe_fn g x) ≤ C) => and.right hb x

theorem ext {α : Type u} {β : Type v} [topological_space α] [metric_space β] {f : bounded_continuous_function α β} {g : bounded_continuous_function α β} (H : ∀ (x : α), coe_fn f x = coe_fn g x) : f = g :=
  subtype.eq (funext H)

theorem ext_iff {α : Type u} {β : Type v} [topological_space α] [metric_space β] {f : bounded_continuous_function α β} {g : bounded_continuous_function α β} : f = g ↔ ∀ (x : α), coe_fn f x = coe_fn g x :=
  { mp := fun (h : f = g) (x : α) => h ▸ rfl, mpr := ext }

/- This lemma will be needed in the proof of the metric space instance, but it will become
useless afterwards as it will be superceded by the general result that the distance is nonnegative
is metric spaces. -/

/-- The distance between two functions is controlled by the supremum of the pointwise distances -/
theorem dist_le {α : Type u} {β : Type v} [topological_space α] [metric_space β] {f : bounded_continuous_function α β} {g : bounded_continuous_function α β} {C : ℝ} (C0 : 0 ≤ C) : dist f g ≤ C ↔ ∀ (x : α), dist (coe_fn f x) (coe_fn g x) ≤ C := sorry

/-- On an empty space, bounded continuous functions are at distance 0 -/
theorem dist_zero_of_empty {α : Type u} {β : Type v} [topological_space α] [metric_space β] {f : bounded_continuous_function α β} {g : bounded_continuous_function α β} (e : ¬Nonempty α) : dist f g = 0 :=
  le_antisymm (iff.mpr (dist_le (le_refl 0)) fun (x : α) => not.elim e (Nonempty.intro x)) dist_nonneg'

/-- The type of bounded continuous functions, with the uniform distance, is a metric space. -/
protected instance metric_space {α : Type u} {β : Type v} [topological_space α] [metric_space β] : metric_space (bounded_continuous_function α β) :=
  metric_space.mk sorry sorry sorry sorry
    (fun (x y : bounded_continuous_function α β) =>
      ennreal.of_real
        ((fun (f g : bounded_continuous_function α β) =>
            Inf (set_of fun (C : ℝ) => 0 ≤ C ∧ ∀ (x : α), dist (coe_fn f x) (coe_fn g x) ≤ C))
          x y))
    (uniform_space_of_dist
      (fun (f g : bounded_continuous_function α β) =>
        Inf (set_of fun (C : ℝ) => 0 ≤ C ∧ ∀ (x : α), dist (coe_fn f x) (coe_fn g x) ≤ C))
      sorry sorry sorry)

/-- Constant as a continuous bounded function. -/
def const (α : Type u) {β : Type v} [topological_space α] [metric_space β] (b : β) : bounded_continuous_function α β :=
  { val := fun (x : α) => b, property := sorry }

@[simp] theorem coe_const {α : Type u} {β : Type v} [topological_space α] [metric_space β] (b : β) : ⇑(const α b) = function.const α b :=
  rfl

theorem const_apply {α : Type u} {β : Type v} [topological_space α] [metric_space β] (a : α) (b : β) : coe_fn (const α b) a = b :=
  rfl

/-- If the target space is inhabited, so is the space of bounded continuous functions -/
protected instance inhabited {α : Type u} {β : Type v} [topological_space α] [metric_space β] [Inhabited β] : Inhabited (bounded_continuous_function α β) :=
  { default := const α Inhabited.default }

/-- The evaluation map is continuous, as a joint function of `u` and `x` -/
theorem continuous_eval {α : Type u} {β : Type v} [topological_space α] [metric_space β] : continuous fun (p : bounded_continuous_function α β × α) => coe_fn (prod.fst p) (prod.snd p) := sorry

/- use the continuity of `f` to find a neighborhood of `x` where it varies at most by ε/2 -/

/-- In particular, when `x` is fixed, `f → f x` is continuous -/
theorem continuous_evalx {α : Type u} {β : Type v} [topological_space α] [metric_space β] {x : α} : continuous fun (f : bounded_continuous_function α β) => coe_fn f x :=
  continuous.comp continuous_eval (continuous.prod_mk continuous_id continuous_const)

/-- When `f` is fixed, `x → f x` is also continuous, by definition -/
theorem continuous_evalf {α : Type u} {β : Type v} [topological_space α] [metric_space β] {f : bounded_continuous_function α β} : continuous ⇑f :=
  and.left (subtype.property f)

/-- Bounded continuous functions taking values in a complete space form a complete space. -/
protected instance complete_space {α : Type u} {β : Type v} [topological_space α] [metric_space β] [complete_space β] : complete_space (bounded_continuous_function α β) := sorry

/-- Composition (in the target) of a bounded continuous function with a Lipschitz map again
gives a bounded continuous function -/
def comp {α : Type u} {β : Type v} {γ : Type w} [topological_space α] [metric_space β] [metric_space γ] (G : β → γ) {C : nnreal} (H : lipschitz_with C G) (f : bounded_continuous_function α β) : bounded_continuous_function α γ :=
  { val := fun (x : α) => G (coe_fn f x), property := sorry }

/-- The composition operator (in the target) with a Lipschitz map is Lipschitz -/
theorem lipschitz_comp {α : Type u} {β : Type v} {γ : Type w} [topological_space α] [metric_space β] [metric_space γ] {G : β → γ} {C : nnreal} (H : lipschitz_with C G) : lipschitz_with C (comp G H) := sorry

/-- The composition operator (in the target) with a Lipschitz map is uniformly continuous -/
theorem uniform_continuous_comp {α : Type u} {β : Type v} {γ : Type w} [topological_space α] [metric_space β] [metric_space γ] {G : β → γ} {C : nnreal} (H : lipschitz_with C G) : uniform_continuous (comp G H) :=
  lipschitz_with.uniform_continuous (lipschitz_comp H)

/-- The composition operator (in the target) with a Lipschitz map is continuous -/
theorem continuous_comp {α : Type u} {β : Type v} {γ : Type w} [topological_space α] [metric_space β] [metric_space γ] {G : β → γ} {C : nnreal} (H : lipschitz_with C G) : continuous (comp G H) :=
  lipschitz_with.continuous (lipschitz_comp H)

/-- Restriction (in the target) of a bounded continuous function taking values in a subset -/
def cod_restrict {α : Type u} {β : Type v} [topological_space α] [metric_space β] (s : set β) (f : bounded_continuous_function α β) (H : ∀ (x : α), coe_fn f x ∈ s) : bounded_continuous_function α ↥s :=
  { val := set.cod_restrict (⇑f) s H, property := sorry }

/- Arzela-Ascoli theorem asserts that, on a compact space, a set of functions sharing
a common modulus of continuity and taking values in a compact set forms a compact
subset for the topology of uniform convergence. In this section, we prove this theorem
and several useful variations around it. -/

/-- First version, with pointwise equicontinuity and range in a compact space -/
theorem arzela_ascoli₁ {α : Type u} {β : Type v} [topological_space α] [compact_space α] [metric_space β] [compact_space β] (A : set (bounded_continuous_function α β)) (closed : is_closed A) (H : ∀ (x : α) (ε : ℝ) (H : ε > 0),
  ∃ (U : set α),
    ∃ (H : U ∈ nhds x),
      ∀ (y z : α), y ∈ U → z ∈ U → ∀ (f : bounded_continuous_function α β), f ∈ A → dist (coe_fn f y) (coe_fn f z) < ε) : is_compact A := sorry

/-- Second version, with pointwise equicontinuity and range in a compact subset -/
theorem arzela_ascoli₂ {α : Type u} {β : Type v} [topological_space α] [compact_space α] [metric_space β] (s : set β) (hs : is_compact s) (A : set (bounded_continuous_function α β)) (closed : is_closed A) (in_s : ∀ (f : bounded_continuous_function α β) (x : α), f ∈ A → coe_fn f x ∈ s) (H : ∀ (x : α) (ε : ℝ) (H : ε > 0),
  ∃ (U : set α),
    ∃ (H : U ∈ nhds x),
      ∀ (y z : α), y ∈ U → z ∈ U → ∀ (f : bounded_continuous_function α β), f ∈ A → dist (coe_fn f y) (coe_fn f z) < ε) : is_compact A := sorry

/- This version is deduced from the previous one by restricting to the compact type in the target,
using compactness there and then lifting everything to the original space. -/

/-- Third (main) version, with pointwise equicontinuity and range in a compact subset, but
without closedness. The closure is then compact -/
theorem arzela_ascoli {α : Type u} {β : Type v} [topological_space α] [compact_space α] [metric_space β] (s : set β) (hs : is_compact s) (A : set (bounded_continuous_function α β)) (in_s : ∀ (f : bounded_continuous_function α β) (x : α), f ∈ A → coe_fn f x ∈ s) (H : ∀ (x : α) (ε : ℝ) (H : ε > 0),
  ∃ (U : set α),
    ∃ (H : U ∈ nhds x),
      ∀ (y z : α), y ∈ U → z ∈ U → ∀ (f : bounded_continuous_function α β), f ∈ A → dist (coe_fn f y) (coe_fn f z) < ε) : is_compact (closure A) := sorry

/- This version is deduced from the previous one by checking that the closure of A, in
addition to being closed, still satisfies the properties of compact range and equicontinuity -/

/- To apply the previous theorems, one needs to check the equicontinuity. An important
instance is when the source space is a metric space, and there is a fixed modulus of continuity
for all the functions in the set A -/

theorem equicontinuous_of_continuity_modulus {β : Type v} [metric_space β] {α : Type u} [metric_space α] (b : ℝ → ℝ) (b_lim : filter.tendsto b (nhds 0) (nhds 0)) (A : set (bounded_continuous_function α β)) (H : ∀ (x y : α) (f : bounded_continuous_function α β), f ∈ A → dist (coe_fn f x) (coe_fn f y) ≤ b (dist x y)) (x : α) (ε : ℝ) (ε0 : 0 < ε) : ∃ (U : set α),
  ∃ (H : U ∈ nhds x),
    ∀ (y z : α), y ∈ U → z ∈ U → ∀ (f : bounded_continuous_function α β), f ∈ A → dist (coe_fn f y) (coe_fn f z) < ε := sorry

/- In this section, if β is a normed group, then we show that the space of bounded
continuous functions from α to β inherits a normed group structure, by using
pointwise operations and checking that they are compatible with the uniform distance. -/

protected instance has_zero {α : Type u} {β : Type v} [topological_space α] [normed_group β] : HasZero (bounded_continuous_function α β) :=
  { zero := const α 0 }

@[simp] theorem coe_zero {α : Type u} {β : Type v} [topological_space α] [normed_group β] {x : α} : coe_fn 0 x = 0 :=
  rfl

protected instance has_norm {α : Type u} {β : Type v} [topological_space α] [normed_group β] : has_norm (bounded_continuous_function α β) :=
  has_norm.mk fun (u : bounded_continuous_function α β) => dist u 0

theorem norm_def {α : Type u} {β : Type v} [topological_space α] [normed_group β] (f : bounded_continuous_function α β) : norm f = dist f 0 :=
  rfl

/-- The norm of a bounded continuous function is the supremum of `∥f x∥`.
We use `Inf` to ensure that the definition works if `α` has no elements. -/
theorem norm_eq {α : Type u} {β : Type v} [topological_space α] [normed_group β] (f : bounded_continuous_function α β) : norm f = Inf (set_of fun (C : ℝ) => 0 ≤ C ∧ ∀ (x : α), norm (coe_fn f x) ≤ C) := sorry

theorem norm_coe_le_norm {α : Type u} {β : Type v} [topological_space α] [normed_group β] (f : bounded_continuous_function α β) (x : α) : norm (coe_fn f x) ≤ norm f := sorry

theorem dist_le_two_norm' {β : Type v} {γ : Type w} [normed_group β] {f : γ → β} {C : ℝ} (hC : ∀ (x : γ), norm (f x) ≤ C) (x : γ) (y : γ) : dist (f x) (f y) ≤ bit0 1 * C :=
  trans_rel_left LessEq (le_trans (dist_le_norm_add_norm (f x) (f y)) (add_le_add (hC x) (hC y))) (Eq.symm (two_mul C))

/-- Distance between the images of any two points is at most twice the norm of the function. -/
theorem dist_le_two_norm {α : Type u} {β : Type v} [topological_space α] [normed_group β] (f : bounded_continuous_function α β) (x : α) (y : α) : dist (coe_fn f x) (coe_fn f y) ≤ bit0 1 * norm f :=
  dist_le_two_norm' (norm_coe_le_norm f) x y

/-- The norm of a function is controlled by the supremum of the pointwise norms -/
theorem norm_le {α : Type u} {β : Type v} [topological_space α] [normed_group β] {f : bounded_continuous_function α β} {C : ℝ} (C0 : 0 ≤ C) : norm f ≤ C ↔ ∀ (x : α), norm (coe_fn f x) ≤ C := sorry

/-- Norm of `const α b` is less than or equal to `∥b∥`. If `α` is nonempty,
then it is equal to `∥b∥`. -/
theorem norm_const_le {α : Type u} {β : Type v} [topological_space α] [normed_group β] (b : β) : norm (const α b) ≤ norm b :=
  iff.mpr (norm_le (norm_nonneg b)) fun (x : α) => le_refl (norm (coe_fn (const α b) x))

@[simp] theorem norm_const_eq {α : Type u} {β : Type v} [topological_space α] [normed_group β] [h : Nonempty α] (b : β) : norm (const α b) = norm b :=
  le_antisymm (norm_const_le b) (nonempty.elim h fun (x : α) => norm_coe_le_norm (const α b) x)

/-- Constructing a bounded continuous function from a uniformly bounded continuous
function taking values in a normed group. -/
def of_normed_group {α : Type u} {β : Type v} [topological_space α] [normed_group β] (f : α → β) (Hf : continuous f) (C : ℝ) (H : ∀ (x : α), norm (f x) ≤ C) : bounded_continuous_function α β :=
  { val := fun (n : α) => f n, property := sorry }

theorem norm_of_normed_group_le {α : Type u} {β : Type v} [topological_space α] [normed_group β] {f : α → β} (hfc : continuous f) {C : ℝ} (hC : 0 ≤ C) (hfC : ∀ (x : α), norm (f x) ≤ C) : norm (of_normed_group f hfc C hfC) ≤ C :=
  iff.mpr (norm_le hC) hfC

/-- Constructing a bounded continuous function from a uniformly bounded
function on a discrete space, taking values in a normed group -/
def of_normed_group_discrete {α : Type u} {β : Type v} [topological_space α] [discrete_topology α] [normed_group β] (f : α → β) (C : ℝ) (H : ∀ (x : α), norm (f x) ≤ C) : bounded_continuous_function α β :=
  of_normed_group f sorry C H

/-- The pointwise sum of two bounded continuous functions is again bounded continuous. -/
protected instance has_add {α : Type u} {β : Type v} [topological_space α] [normed_group β] : Add (bounded_continuous_function α β) :=
  { add := fun (f g : bounded_continuous_function α β) => of_normed_group (⇑f + ⇑g) sorry (norm f + norm g) sorry }

/-- The pointwise opposite of a bounded continuous function is again bounded continuous. -/
protected instance has_neg {α : Type u} {β : Type v} [topological_space α] [normed_group β] : Neg (bounded_continuous_function α β) :=
  { neg := fun (f : bounded_continuous_function α β) => of_normed_group (-⇑f) sorry (norm f) sorry }

/-- The pointwise difference of two bounded continuous functions is again bounded continuous. -/
protected instance has_sub {α : Type u} {β : Type v} [topological_space α] [normed_group β] : Sub (bounded_continuous_function α β) :=
  { sub := fun (f g : bounded_continuous_function α β) => of_normed_group (⇑f - ⇑g) sorry (norm f + norm g) sorry }

@[simp] theorem coe_add {α : Type u} {β : Type v} [topological_space α] [normed_group β] (f : bounded_continuous_function α β) (g : bounded_continuous_function α β) : ⇑(f + g) = fun (x : α) => coe_fn f x + coe_fn g x :=
  rfl

theorem add_apply {α : Type u} {β : Type v} [topological_space α] [normed_group β] (f : bounded_continuous_function α β) (g : bounded_continuous_function α β) {x : α} : coe_fn (f + g) x = coe_fn f x + coe_fn g x :=
  rfl

@[simp] theorem coe_neg {α : Type u} {β : Type v} [topological_space α] [normed_group β] (f : bounded_continuous_function α β) : ⇑(-f) = fun (x : α) => -coe_fn f x :=
  rfl

theorem neg_apply {α : Type u} {β : Type v} [topological_space α] [normed_group β] (f : bounded_continuous_function α β) {x : α} : coe_fn (-f) x = -coe_fn f x :=
  rfl

theorem forall_coe_zero_iff_zero {α : Type u} {β : Type v} [topological_space α] [normed_group β] (f : bounded_continuous_function α β) : (∀ (x : α), coe_fn f x = 0) ↔ f = 0 :=
  iff.symm ext_iff

protected instance add_comm_group {α : Type u} {β : Type v} [topological_space α] [normed_group β] : add_comm_group (bounded_continuous_function α β) :=
  add_comm_group.mk Add.add sorry 0 sorry sorry Neg.neg Sub.sub sorry sorry

@[simp] theorem coe_sub {α : Type u} {β : Type v} [topological_space α] [normed_group β] (f : bounded_continuous_function α β) (g : bounded_continuous_function α β) : ⇑(f - g) = fun (x : α) => coe_fn f x - coe_fn g x :=
  rfl

theorem sub_apply {α : Type u} {β : Type v} [topological_space α] [normed_group β] (f : bounded_continuous_function α β) (g : bounded_continuous_function α β) {x : α} : coe_fn (f - g) x = coe_fn f x - coe_fn g x :=
  rfl

protected instance normed_group {α : Type u} {β : Type v} [topological_space α] [normed_group β] : normed_group (bounded_continuous_function α β) :=
  normed_group.mk sorry

theorem abs_diff_coe_le_dist {α : Type u} {β : Type v} [topological_space α] [normed_group β] (f : bounded_continuous_function α β) (g : bounded_continuous_function α β) {x : α} : norm (coe_fn f x - coe_fn g x) ≤ dist f g :=
  eq.mpr (id (Eq._oldrec (Eq.refl (norm (coe_fn f x - coe_fn g x) ≤ dist f g)) (dist_eq_norm f g)))
    (norm_coe_le_norm (f - g) x)

theorem coe_le_coe_add_dist {α : Type u} [topological_space α] {x : α} {f : bounded_continuous_function α ℝ} {g : bounded_continuous_function α ℝ} : coe_fn f x ≤ coe_fn g x + dist f g :=
  iff.mp sub_le_iff_le_add' (and.right (iff.mp abs_le (dist_coe_le_dist x)))

/-!
### Normed space structure

In this section, if `β` is a normed space, then we show that the space of bounded
continuous functions from `α` to `β` inherits a normed space structure, by using
pointwise operations and checking that they are compatible with the uniform distance. -/

protected instance has_scalar {α : Type u} {β : Type v} {𝕜 : Type u_1} [normed_field 𝕜] [topological_space α] [normed_group β] [normed_space 𝕜 β] : has_scalar 𝕜 (bounded_continuous_function α β) :=
  has_scalar.mk
    fun (c : 𝕜) (f : bounded_continuous_function α β) => of_normed_group (c • ⇑f) sorry (norm c * norm f) sorry

@[simp] theorem coe_smul {α : Type u} {β : Type v} {𝕜 : Type u_1} [normed_field 𝕜] [topological_space α] [normed_group β] [normed_space 𝕜 β] (c : 𝕜) (f : bounded_continuous_function α β) : ⇑(c • f) = fun (x : α) => c • coe_fn f x :=
  rfl

theorem smul_apply {α : Type u} {β : Type v} {𝕜 : Type u_1} [normed_field 𝕜] [topological_space α] [normed_group β] [normed_space 𝕜 β] (c : 𝕜) (f : bounded_continuous_function α β) (x : α) : coe_fn (c • f) x = c • coe_fn f x :=
  rfl

protected instance semimodule {α : Type u} {β : Type v} {𝕜 : Type u_1} [normed_field 𝕜] [topological_space α] [normed_group β] [normed_space 𝕜 β] : semimodule 𝕜 (bounded_continuous_function α β) :=
  semimodule.of_core (semimodule.core.mk (has_scalar.mk has_scalar.smul) sorry sorry sorry sorry)

protected instance normed_space {α : Type u} {β : Type v} {𝕜 : Type u_1} [normed_field 𝕜] [topological_space α] [normed_group β] [normed_space 𝕜 β] : normed_space 𝕜 (bounded_continuous_function α β) :=
  normed_space.mk sorry

/-!
### Normed ring structure

In this section, if `R` is a normed ring, then we show that the space of bounded
continuous functions from `α` to `R` inherits a normed ring structure, by using
pointwise operations and checking that they are compatible with the uniform distance. -/

protected instance ring {α : Type u} [topological_space α] {R : Type u_1} [normed_ring R] : ring (bounded_continuous_function α R) :=
  ring.mk add_comm_group.add sorry add_comm_group.zero sorry sorry add_comm_group.neg add_comm_group.sub sorry sorry
    (fun (f g : bounded_continuous_function α R) => of_normed_group (⇑f * ⇑g) sorry (norm f * norm g) sorry) sorry
    (const α 1) sorry sorry sorry sorry

protected instance normed_ring {α : Type u} [topological_space α] {R : Type u_1} [normed_ring R] : normed_ring (bounded_continuous_function α R) :=
  normed_ring.mk sorry sorry

/-!
### Normed commutative ring structure

In this section, if `R` is a normed commutative ring, then we show that the space of bounded
continuous functions from `α` to `R` inherits a normed commutative ring structure, by using
pointwise operations and checking that they are compatible with the uniform distance. -/

protected instance comm_ring {α : Type u} [topological_space α] {R : Type u_1} [normed_comm_ring R] : comm_ring (bounded_continuous_function α R) :=
  comm_ring.mk ring.add sorry ring.zero sorry sorry ring.neg ring.sub sorry sorry ring.mul sorry ring.one sorry sorry
    sorry sorry sorry

protected instance normed_comm_ring {α : Type u} [topological_space α] {R : Type u_1} [normed_comm_ring R] : normed_comm_ring (bounded_continuous_function α R) :=
  normed_comm_ring.mk sorry

/-!
### Normed algebra structure

In this section, if `γ` is a normed algebra, then we show that the space of bounded
continuous functions from `α` to `γ` inherits a normed algebra structure, by using
pointwise operations and checking that they are compatible with the uniform distance. -/

/-- `bounded_continuous_function.const` as a `ring_hom`. -/
def C {α : Type u} {γ : Type w} {𝕜 : Type u_1} [normed_field 𝕜] [topological_space α] [normed_ring γ] [normed_algebra 𝕜 γ] : 𝕜 →+* bounded_continuous_function α γ :=
  ring_hom.mk (fun (c : 𝕜) => const α (coe_fn (algebra_map 𝕜 γ) c)) sorry sorry sorry sorry

protected instance algebra {α : Type u} {γ : Type w} {𝕜 : Type u_1} [normed_field 𝕜] [topological_space α] [normed_ring γ] [normed_algebra 𝕜 γ] : algebra 𝕜 (bounded_continuous_function α γ) :=
  algebra.mk C sorry sorry

protected instance normed_algebra {α : Type u} {γ : Type w} {𝕜 : Type u_1} [normed_field 𝕜] [topological_space α] [normed_ring γ] [normed_algebra 𝕜 γ] [Nonempty α] : normed_algebra 𝕜 (bounded_continuous_function α γ) :=
  normed_algebra.mk sorry

/-!
### Structure as normed module over scalar functions

If `β` is a normed `𝕜`-space, then we show that the space of bounded continuous
functions from `α` to `β` is naturally a module over the algebra of bounded continuous
functions from `α` to `𝕜`. -/

protected instance has_scalar' {α : Type u} {β : Type v} {𝕜 : Type u_1} [normed_field 𝕜] [topological_space α] [normed_group β] [normed_space 𝕜 β] : has_scalar (bounded_continuous_function α 𝕜) (bounded_continuous_function α β) :=
  has_scalar.mk
    fun (f : bounded_continuous_function α 𝕜) (g : bounded_continuous_function α β) =>
      of_normed_group (fun (x : α) => coe_fn f x • coe_fn g x) sorry (norm f * norm g) sorry

protected instance module' {α : Type u} {β : Type v} {𝕜 : Type u_1} [normed_field 𝕜] [topological_space α] [normed_group β] [normed_space 𝕜 β] : module (bounded_continuous_function α 𝕜) (bounded_continuous_function α β) :=
  semimodule.of_core (semimodule.core.mk (has_scalar.mk has_scalar.smul) sorry sorry sorry sorry)

theorem norm_smul_le {α : Type u} {β : Type v} {𝕜 : Type u_1} [normed_field 𝕜] [topological_space α] [normed_group β] [normed_space 𝕜 β] (f : bounded_continuous_function α 𝕜) (g : bounded_continuous_function α β) : norm (f • g) ≤ norm f * norm g :=
  norm_of_normed_group_le (has_scalar'._proof_1 f g) (mul_nonneg (norm_nonneg f) (norm_nonneg g))
    (has_scalar'._proof_2 f g)


def inc (x : Nat) := x + 1

@[simp] theorem inc_eq : inc x = x + 1 := rfl

theorem ex (a b : Fin (inc n)) (h : a = b) : b = a := by
  simp only [inc_eq] at a
  trace_state
  exact h.symm


/-
Copyright (c) 2019 Seul Baek. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Seul Baek
-/

/-
Main procedure for linear natural number arithmetic.
-/

import tactic.omega.prove_unsats
import tactic.omega.nat.dnf
import tactic.omega.nat.neg_elim
import tactic.omega.nat.sub_elim

open tactic

namespace omega
namespace nat

open_locale omega.nat

run_cmd mk_simp_attr `sugar_nat

attribute [sugar_nat]
  ne not_le not_lt
  nat.lt_iff_add_one_le
  nat.succ_eq_add_one
  or_false false_or
  and_true true_and
  ge gt mul_add add_mul mul_comm
  one_mul mul_one
  imp_iff_not_or
  iff_iff_not_or_and_or_not

meta def desugar := `[try {simp only with sugar_nat at *}]

lemma univ_close_of_unsat_neg_elim_not (m) (p : preform) :
  (neg_elim (¬* p)).unsat → univ_close p (λ _, 0) m :=
begin
  intro h1, apply univ_close_of_valid,
  apply valid_of_unsat_not, intro h2, apply h1,
  apply preform.sat_of_implies_of_sat implies_neg_elim h2,
end

/-- Return expr of proof that argument is free of subtractions -/
meta def preterm.prove_sub_free : preterm → tactic expr
| (& m)    := return `(trivial)
| (m ** n) := return `(trivial)
| (t +* s) :=
  do x ← preterm.prove_sub_free t,
     y ← preterm.prove_sub_free s,
     return `(@and.intro (preterm.sub_free %%`(t))
       (preterm.sub_free %%`(s)) %%x %%y)
| (_ -* _) := failed

/-- Return expr of proof that argument is free of negations -/
meta def prove_neg_free : preform → tactic expr
| (t =* s) := return `(trivial)
| (t ≤* s) := return `(trivial)
| (p ∨* q) :=
  do x ← prove_neg_free p,
     y ← prove_neg_free q,
     return `(@and.intro (preform.neg_free %%`(p))
       (preform.neg_free %%`(q)) %%x %%y)
| (p ∧* q) :=
  do x ← prove_neg_free p,
     y ← prove_neg_free q,
     return `(@and.intro (preform.neg_free %%`(p))
       (preform.neg_free %%`(q)) %%x %%y)
| _        := failed

/-- Return expr of proof that argument is free of subtractions -/
meta def prove_sub_free : preform → tactic expr
| (t =* s) :=
  do x ← preterm.prove_sub_free t,
     y ← preterm.prove_sub_free s,
     return `(@and.intro (preterm.sub_free %%`(t))
       (preterm.sub_free %%`(s)) %%x %%y)
| (t ≤* s) :=
  do x ← preterm.prove_sub_free t,
     y ← preterm.prove_sub_free s,
     return `(@and.intro (preterm.sub_free %%`(t))
       (preterm.sub_free %%`(s)) %%x %%y)
| (¬*p) := prove_sub_free p
| (p ∨* q) :=
  do x ← prove_sub_free p,
     y ← prove_sub_free q,
     return `(@and.intro (preform.sub_free %%`(p))
       (preform.sub_free %%`(q)) %%x %%y)
| (p ∧* q) :=
  do x ← prove_sub_free p,
     y ← prove_sub_free q,
     return `(@and.intro (preform.sub_free %%`(p))
       (preform.sub_free %%`(q)) %%x %%y)

/-- Given a p : preform, return the expr of a term t : p.unsat, where p is subtraction- and
negation-free. -/
meta def prove_unsat_sub_free (p : preform) : tactic expr :=
do x ← prove_neg_free p,
   y ← prove_sub_free p,
   z ← prove_unsats (dnf p),
   return `(unsat_of_unsat_dnf %%`(p) %%x %%y %%z)

/-- Given a p : preform, return the expr of a term t : p.unsat, where p is negation-free. -/
meta def prove_unsat_neg_free : preform → tactic expr | p :=
match p.sub_terms with
| none         := prove_unsat_sub_free p
| (some (t,s)) :=
  do x ← prove_unsat_neg_free (sub_elim t s p),
     return `(unsat_of_unsat_sub_elim %%`(t) %%`(s) %%`(p) %%x)
end

/-- Given a (m : nat) and (p : preform), return the expr of (t : univ_close m p). -/
meta def prove_univ_close (m : nat) (p : preform) : tactic expr :=
do x ← prove_unsat_neg_free (neg_elim (¬*p)),
   to_expr ``(univ_close_of_unsat_neg_elim_not %%`(m) %%`(p) %%x)

/-- Reification to imtermediate shadow syntax that retains exprs -/
meta def to_exprterm : expr → tactic exprterm
| `(%%x * %%y) :=
  do m ← eval_expr' nat y,
     return (exprterm.exp m x)
| `(%%t1x + %%t2x) :=
  do t1 ← to_exprterm t1x,
     t2 ← to_exprterm t2x,
     return (exprterm.add t1 t2)
| `(%%t1x - %%t2x) :=
  do t1 ← to_exprterm t1x,
     t2 ← to_exprterm t2x,
     return (exprterm.sub t1 t2)
| x :=
  ( do m ← eval_expr' nat x,
       return (exprterm.cst m) ) <|>
  ( return $ exprterm.exp 1 x )

/-- Reification to imtermediate shadow syntax that retains exprs -/
meta def to_exprform : expr → tactic exprform
| `(%%tx1 = %%tx2) :=
  do t1 ← to_exprterm tx1,
     t2 ← to_exprterm tx2,
     return (exprform.eq t1 t2)
| `(%%tx1 ≤ %%tx2) :=
  do t1 ← to_exprterm tx1,
     t2 ← to_exprterm tx2,
     return (exprform.le t1 t2)
| `(¬ %%px) := do p ← to_exprform px, return (exprform.not p)
| `(%%px ∨ %%qx) :=
  do p ← to_exprform px,
     q ← to_exprform qx,
     return (exprform.or p q)
| `(%%px ∧ %%qx) :=
  do p ← to_exprform px,
     q ← to_exprform qx,
     return (exprform.and p q)
| `(_ → %%px) := to_exprform px
| x := trace "Cannot reify expr : " >> trace x >> failed

/-- List of all unreified exprs -/
meta def exprterm.exprs : exprterm → list expr
| (exprterm.cst _)   := []
| (exprterm.exp _ x) := [x]
| (exprterm.add t s) := list.union t.exprs s.exprs
| (exprterm.sub t s) := list.union t.exprs s.exprs

/-- List of all unreified exprs -/
meta def exprform.exprs : exprform → list expr
| (exprform.eq t s)  := list.union t.exprs s.exprs
| (exprform.le t s)  := list.union t.exprs s.exprs
| (exprform.not p)   := p.exprs
| (exprform.or p q)  := list.union p.exprs q.exprs
| (exprform.and p q) := list.union p.exprs q.exprs

/-- Reification to an intermediate shadow syntax which eliminates exprs,
    but still includes non-canonical terms -/
meta def exprterm.to_preterm (xs : list expr) : exprterm → tactic preterm
| (exprterm.cst k)   := return & k
| (exprterm.exp k x) :=
  let m := xs.index_of x in
  if m < xs.length
  then return (k ** m)
  else failed
| (exprterm.add xa xb) :=
  do a ← xa.to_preterm,
     b ← xb.to_preterm,
     return (a +* b)
| (exprterm.sub xa xb) :=
  do a ← xa.to_preterm,
     b ← xb.to_preterm,
     return (a -* b)

/-- Reification to an intermediate shadow syntax which eliminates exprs,
    but still includes non-canonical terms -/
meta def exprform.to_preform (xs : list expr) : exprform → tactic preform
| (exprform.eq xa xb)  :=
   do a ← xa.to_preterm xs,
      b ← xb.to_preterm xs,
      return (a =* b)
| (exprform.le xa xb)  :=
   do a ← xa.to_preterm xs,
      b ← xb.to_preterm xs,
      return (a ≤* b)
| (exprform.not xp)    :=
  do p ← xp.to_preform,
     return ¬* p
| (exprform.or xp xq)  :=
  do p ← xp.to_preform,
     q ← xq.to_preform,
     return (p ∨* q)
| (exprform.and xp xq) :=
  do p ← xp.to_preform,
     q ← xq.to_preform,
     return (p ∧* q)

/-- Reification to an intermediate shadow syntax which eliminates exprs,
    but still includes non-canonical terms. -/
meta def to_preform (x : expr) : tactic (preform × nat) :=
do xf ← to_exprform x,
   let xs := xf.exprs,
   f ← xf.to_preform xs,
   return (f, xs.length)

/-- Return expr of proof of current LNA goal -/
meta def prove : tactic expr :=
do (p,m) ← target >>= to_preform,
   trace_if_enabled `omega p,
   prove_univ_close m p

/-- Succeed iff argument is expr of ℕ -/
meta def eq_nat (x : expr) : tactic unit :=
if x = `(nat) then skip else failed

/-- Check whether argument is expr of a well-formed formula of LNA-/
meta def wff : expr → tactic unit
| `(¬ %%px)      := wff px
| `(%%px ∨ %%qx) := wff px >> wff qx
| `(%%px ∧ %%qx) := wff px >> wff qx
| `(%%px ↔ %%qx) := wff px >> wff qx
| `(%%(expr.pi _ _ px qx)) :=
  monad.cond
     (if expr.has_var px then return tt else is_prop px)
     (wff px >> wff qx)
     (eq_nat px >> wff qx)
| `(@has_lt.lt %%dx %%h _ _) := eq_nat dx
| `(@has_le.le %%dx %%h _ _) := eq_nat dx
| `(@eq %%dx _ _)            := eq_nat dx
| `(@ge %%dx %%h _ _)        := eq_nat dx
| `(@gt %%dx %%h _ _)        := eq_nat dx
| `(@ne %%dx _ _)            := eq_nat dx
| `(true)                    := skip
| `(false)                   := skip
| _                          := failed

/-- Succeed iff argument is expr of term whose type is wff -/
meta def wfx (x : expr) : tactic unit :=
infer_type x >>= wff

/-- Intro all universal quantifiers over nat -/
meta def intro_nats_core : tactic unit :=
do x ← target,
   match x with
   | (expr.pi _ _ `(nat) _) := intro_fresh >> intro_nats_core
   | _                      := skip
   end

meta def intro_nats : tactic unit :=
do (expr.pi _ _ `(nat) _) ← target,
   intro_nats_core

/-- If the goal has universal quantifiers over natural, introduce all of them.
Otherwise, revert all hypotheses that are formulas of linear natural number arithmetic. -/
meta def preprocess : tactic unit :=
intro_nats <|> (revert_cond_all wfx >> desugar)

end nat
end omega

open omega.nat

/-- The core omega tactic for natural numbers. -/
meta def omega_nat (is_manual : bool) : tactic unit :=
desugar ; (if is_manual then skip else preprocess) ; prove >>= apply >> skip


import analysis.matrix
import linear_algebra.affine_space.matrix
import analysis.normed_space.add_torsor_bases

import to_mathlib.analysis.calculus

noncomputable theory
open set function
open_locale affine matrix big_operators

section barycentric_det

variables (ι R k P : Type*) {M : Type*} [ring R] [add_comm_group M] [module R M] [affine_space M P]
include M

/-- The set of affine bases for an affine space. -/
def affine_bases : set (ι → P) :=
{ v | affine_independent R v ∧ affine_span R (range v) = ⊤ }

lemma affine_bases_findim [fintype ι] [field k] [module k M] [finite_dimensional k M]
  (h : fintype.card ι = finite_dimensional.finrank k M + 1) :
  affine_bases ι k P = { v | affine_independent k v } :=
begin
  ext v,
  simp only [affine_bases, mem_set_of_eq, and_iff_left_iff_imp],
  exact λ h_ind, h_ind.affine_span_eq_top_iff_card_eq_finrank_add_one.mpr h,
end

lemma mem_affine_bases_iff [fintype ι] [decidable_eq ι] [nontrivial R] (b : affine_basis ι R P) (v : ι → P) :
  v ∈ affine_bases ι R P ↔ is_unit (b.to_matrix v) :=
(b.is_unit_to_matrix_iff v).symm

/-- If `P` is an affine space over the ring `R`, `v : ι → P` is an affine basis (for some indexing
set `ι`) and `p : P` is a point, then `eval_barycentric_coords ι R P p v` are the barycentric
coordinates of `p` with respect to the affine basis `v`.

Actually for convenience `eval_barycentric_coords` is defined even when `v` is not an affine basis.
In this case its value should be regarded as "junk". -/
def eval_barycentric_coords [decidable_pred (∈ affine_bases ι R P)] (p : P) (v : ι → P) : ι → R :=
if h : v ∈ affine_bases ι R P then ((affine_basis.mk v h.1 h.2).coords p : ι → R) else 0

@[simp] lemma eval_barycentric_coords_apply_of_mem_bases [decidable_pred (∈ affine_bases ι R P)]
  (p : P) {v : ι → P} (h : v ∈ affine_bases ι R P) :
  eval_barycentric_coords ι R P p v = (affine_basis.mk v h.1 h.2).coords p :=
dif_pos h

@[simp] lemma eval_barycentric_coords_apply_of_not_mem_bases [decidable_pred (∈ affine_bases ι R P)]
  (p : P) {v : ι → P} (h : v ∉ affine_bases ι R P) :
  eval_barycentric_coords ι R P p v = 0 :=
dif_neg h

variables {ι R P}

lemma eval_barycentric_coords_eq_det [fintype ι] [decidable_eq ι]
  (S : Type*) [field S] [module S M] [∀ v, decidable (v ∈ affine_bases ι S P)]
  (b : affine_basis ι S P) (p : P) (v : ι → P) :
  eval_barycentric_coords ι S P p v = (b.to_matrix v).det⁻¹ • (b.to_matrix v)ᵀ.cramer (b.coords p) :=
begin
  ext i,
  by_cases h : v ∈ affine_bases ι S P,
  { simp only [eval_barycentric_coords, h, dif_pos, algebra.id.smul_eq_mul, pi.smul_apply,
               affine_basis.coords_apply],
    erw [← b.det_smul_coords_eq_cramer_coords ⟨v, h.1, h.2⟩ p],
    simp only [pi.smul_apply, affine_basis.coords_apply, algebra.id.smul_eq_mul],
    have hu := b.is_unit_to_matrix ⟨v, h.1, h.2⟩,
    rw matrix.is_unit_iff_is_unit_det at hu,
    erw [← mul_assoc, ← ring.inverse_eq_inv, ring.inverse_mul_cancel _ hu, one_mul] },
  { simp only [eval_barycentric_coords, h, algebra.id.smul_eq_mul, pi.zero_apply, inv_eq_zero,
      dif_neg, not_false_iff, zero_eq_mul, pi.smul_apply],
    left,
    rwa [mem_affine_bases_iff ι S P b v, matrix.is_unit_iff_is_unit_det,
      is_unit_iff_ne_zero, not_not] at h, },
end

end barycentric_det

namespace matrix

variables (ι k : Type*) [fintype ι] [decidable_eq ι] [nontrivially_normed_field k]

attribute [instance] matrix.normed_add_comm_group matrix.normed_space

lemma smooth_det (m : ℕ∞) :
  cont_diff k m (det : matrix ι ι k → k) :=
begin
  suffices : ∀ (n : ℕ), cont_diff k m (det : matrix (fin n) (fin n) k → k),
  { have h : (det : matrix ι ι k → k) = det ∘ reindex (fintype.equiv_fin ι) (fintype.equiv_fin ι),
    { ext, simp, },
    rw h,
    apply (this (fintype.card ι)).comp,
    exact cont_diff_pi.mpr (λ i, cont_diff_pi.mpr (λ j, cont_diff_apply_apply _ _ _ _)), },
  intros n,
  induction n with n ih,
  { rw coe_det_is_empty,
    exact cont_diff_const, },
  change cont_diff k m (λ (A : matrix (fin n.succ) (fin n.succ) k), A.det),
  simp_rw det_succ_column_zero,
  apply cont_diff.sum (λ l _, _),
  apply cont_diff.mul,
  { refine cont_diff_const.mul _,
    apply cont_diff_apply_apply, },
  { apply ih.comp,
    refine cont_diff_pi.mpr (λ i, cont_diff_pi.mpr (λ j, _)),
    simp only [submatrix_apply],
    apply cont_diff_apply_apply, },
end

end matrix

section smooth_barycentric

variables (ι 𝕜 F : Type*)
variables [fintype ι] [nontrivially_normed_field 𝕜] [complete_space 𝕜]
variables [normed_add_comm_group F] [normed_space 𝕜 F]

-- An alternative approach would be to prove the affine version of `cont_diff_at_map_inverse`
-- and prove that barycentric coordinates give a continuous affine equivalence to
-- `{ f : ι →₀ 𝕜 | f.sum = 1 }`. This should obviate the need for the finite-dimensionality assumption.
lemma smooth_barycentric [decidable_pred (∈ affine_bases ι 𝕜 F)] [finite_dimensional 𝕜 F]
  (h : fintype.card ι = finite_dimensional.finrank 𝕜 F + 1) :
  cont_diff_on 𝕜 ⊤ (uncurry (eval_barycentric_coords ι 𝕜 F)) (@univ F ×ˢ (affine_bases ι 𝕜 F)) :=
begin
  classical,
  obtain ⟨b : affine_basis ι 𝕜 F⟩ := affine_basis.exists_affine_basis_of_finite_dimensional h,
  simp_rw [uncurry_def, cont_diff_on_pi, eval_barycentric_coords_eq_det 𝕜 b],
  intros i,
  simp only [algebra.id.smul_eq_mul, pi.smul_apply, matrix.cramer_transpose_apply],
  have h_snd : cont_diff 𝕜 ⊤ (λ (x : F × (ι → F)), b.to_matrix x.snd),
  { refine cont_diff.comp _ cont_diff_snd,
    refine cont_diff_pi.mpr (λ j, cont_diff_pi.mpr (λ j', _)),
    exact (smooth_barycentric_coord b j').comp (cont_diff_apply 𝕜 F j), },
  apply cont_diff_on.mul,
  { apply ((matrix.smooth_det ι 𝕜 ⊤).comp h_snd).cont_diff_on.inv,
    rintros ⟨p, v⟩ hpv,
    have hv : is_unit (b.to_matrix v), { simpa [mem_affine_bases_iff ι 𝕜 F b v] using hpv, },
    rw [← is_unit_iff_ne_zero, ← matrix.is_unit_iff_is_unit_det],
    exact hv, },
  { refine ((matrix.smooth_det ι 𝕜 ⊤).comp _).cont_diff_on,
    refine cont_diff_pi.mpr (λ j, cont_diff_pi.mpr (λ j', _)),
    simp only [matrix.update_row_apply, affine_basis.to_matrix_apply, affine_basis.coords_apply],
    by_cases hij : j = i,
    { simp only [hij, if_true, eq_self_iff_true],
      exact (smooth_barycentric_coord b j').fst', },
    { simp only [hij, if_false],
      exact (smooth_barycentric_coord b j').comp (cont_diff_pi.mp cont_diff_snd j), }, },
end

end smooth_barycentric


import Fine.Semantics.Model
import Fine.PropositionalLanguage

def satisfies [inst : Model α] (t : α) (f : Form) : Prop :=
  match f with
    | #n => n ∈ inst.valuation t
    | ~f => ∀{p : inst.primes}, t ≤ p → ¬(satisfies (p*).val f)
    | f & g => satisfies t f ∧ satisfies t g
    | f ¦ g => ∀{p : inst.primes}, t ≤ p → satisfies p.val f ∨ satisfies p.val g
    | Form.impl f g => ∀{u : α}, satisfies u f → satisfies (t ∙ u) g
    --can't pattern match using ⊃ because of collision with set

abbrev psatisfies [inst : Model α] (p : inst.primes) (f : Form) : Prop := satisfies p.val f

infix:128 "⊨"  => psatisfies
infix:128 "⊨"  => satisfies

abbrev verifies (inst : Model α) (f : Form) : Prop := inst.identity ⊨ f

abbrev valid (f : Form) : Prop := ∀α : Type, ∀m : Model α, verifies m f

theorem upwardsClosure [inst : Model α] {s t : α} {f : Form} (h₁: s ≤ t) (h₂ : s ⊨ f) : t ⊨ f :=
  match f with
    | #n => have l₁ : inst.valuation s ⊆ inst.valuation t := inst.valMonotone s t h₁
            l₁ h₂
    | ~g => by unfold satisfies
               intros p h₃ h₄
               exact h₂ (le_trans h₁ h₃) h₄
    | f & g => by unfold satisfies
                  apply And.intro
                  case left => exact upwardsClosure h₁ h₂.left
                  case right => exact upwardsClosure h₁ h₂.right
    | f ¦ g => by unfold satisfies
                  intros p h₃
                  apply Or.elim (h₂ (le_trans' h₃ h₁))
                  case left => intro h₄; exact Or.inl h₄
                  case right => intro h₄; exact Or.inr h₄
    | Form.impl f g => by unfold satisfies
                          intros u h₃
                          have l₁ : s ∙ u ≤ t ∙ u := inst.appMonotoneRight u h₁
                          have l₂ : (s ∙ u) ⊨ g := h₂ h₃
                          exact upwardsClosure l₁ l₂

theorem primeDetermination [inst : Model α] {t : α} { f : Form } (h₁ : ∀p : inst.primes, t ≤ p → p ⊨ f) : t ⊨ f :=
  match f with
    | #n => Model.valBounding t n h₁
    | ~f => by unfold satisfies
               intros p h₂ h₃
               exact h₁ p h₂ (le_refl p.val) h₃
    | f & g => by unfold satisfies
                  apply And.intro
                  case left =>
                    have l₁ : ∀p : inst.primes, t ≤ p → p ⊨ f := by
                      intros p h₂
                      exact (h₁ p h₂).left
                    exact primeDetermination l₁
                  case right =>
                    have l₁ : ∀p : inst.primes, t ≤ p → p ⊨ g := by
                      intros p h₂
                      exact (h₁ p h₂).right
                    exact primeDetermination l₁
    | f ¦ g => by unfold satisfies
                  intros p h₂
                  cases h₁ p h₂ (le_refl p.val)
                  case inl =>
                    apply Or.inl
                    assumption
                  case inr =>
                    apply Or.inr
                    assumption
    | Form.impl f g => by unfold satisfies
                          intros u h₂
                          apply primeDetermination
                          intros p h₃
                          have ⟨q, _, l₃,_,l₄,_⟩ : ∃q r : inst.primes, t ≤ q ∧ u ≤ r ∧ (↑q ∙ u) ≤ p ∧ (t ∙ r) ≤ p.val := inst.appBounding t u p h₃
                          have l₅ : (↑q ∙ u) ⊨ g  := h₁ q l₃ h₂
                          exact upwardsClosure l₄ l₅

theorem starCompatRight [inst : Model α] {p : inst.primes} {f : Form} : p* ⊨ f → ¬(p ⊨ ~f) := by
    intro h₁ h₂
    unfold psatisfies at h₂
    unfold satisfies at h₂
    exact h₂ (le_refl p.val) h₁

theorem logicInIdentity [inst : Model α] {f g : Form} : inst.identity ⊨ f ⊃ g ↔ ∀x : α, x ⊨ f → x ⊨ g := by
  apply Iff.intro
  case mp =>
    intros h₁ x h₂
    have l₁ : (inst.identity ∙ x) ⊨ g := h₁ h₂
    rw [←inst.appLeftIdent x]
    assumption
  case mpr =>
    intro h₁
    unfold satisfies
    intro u h₂
    rw [inst.appLeftIdent u]
    exact h₁ u h₂

section

open Classical

theorem nonconstruction {α : Sort u} {p : α → Prop} (h₁ : ¬∀x : α, p x) : (∃x : α, ¬ p x) :=
  byContradiction λh₂ =>
    have l₁ : ∀x : α, p x := λx : α => byContradiction λh₃ => h₂ ⟨x, h₃⟩
    h₁ l₁

theorem starCompatLeft [inst : Model α] {p : inst.primes} {f : Form} : ¬(p ⊨ ~f) → p* ⊨ f := by
  intros h₁
  have ⟨x, l₁⟩ := nonconstruction h₁
  have ⟨l₂,l₃⟩ := nonconstruction l₁
  have l₄ := byContradiction l₃
  have l₅ := inst.starAntitone l₂
  exact upwardsClosure l₅ l₄

end


inductive Cat :=
| Set : Cat
| var (n : Nat) : Cat

open Sum

mutual

inductive Obj : Cat → Type where
| var (C : Cat) (n : Nat) : Obj C
| corepr {C : Cat} (F : Func C Cat.Set) : Obj C
| app' {C D : Cat} (F : Func' C D) (X : Obj C) : Obj D

inductive Func' : (C : Cat) → Cat → Type where
| var (C D : Cat) (n : Nat) : Func' C D
| hom (C : Cat) (X : Obj C) : Func' C Cat.Set -- X is the domain
| prod {C : Cat} (F G : Func C Cat.Set) : Func' C Cat.Set

inductive Func : Cat → Cat → Type where
| id (C : Cat) : Func C C
| comp' {C D E : Cat} (F : Func' C D) (G : Func D E) : Func C E

end

-- def Func.comp : {C D E : Cat} → (F : Func C D) → (G : Func D E) → Func C E
-- | _, _, _, Func.id _,      G => G
-- | _, _, _, Func.comp' F G, H => Func.comp' F (comp G H)
-- #print prefix Func
noncomputable def Func.comp {C D : Cat} (F : Func C D) : (E : Cat) → (G : Func D E) → Func C E :=
@Func.recOn (λ _ _ => Unit) (λ C D _ => Unit) (λ C D F => (E : Cat) → (G : Func D E) → Func C E)
  C
  D
  F
  (λ _ _ => ())
  (λ _ _ => ())
  (λ _ _ _ _ => ())
  (λ _ _ _ => ())
  (λ _ _ _ => ())
  (λ _ _ _ _ => ())
  (λ C' D' G => G)
  (λ F _ _ ih E' G => Func.comp' F (ih _ G))

-- def Func.app : {C D : Cat} → (F : Func C D) → Obj C → Obj D
-- | _, _, Func.id _,      X => X
-- | _, _, Func.comp' F G, X => app G (Obj.app' F X)

noncomputable def Func.app {C D : Cat} (F : Func C D) : (X : Obj C) → Obj D :=
@Func.recOn (λ _ _ => Unit) (λ C D _ => Unit) (λ C D _ => Obj C → Obj D)
  C
  D
  F
  (λ _ _ => ())
  (λ _ _ => ())
  (λ _ _ _ _ => ())
  (λ _ _ _ => ())
  (λ _ _ _ => ())
  (λ _ _ _ _ => ())
  (λ _ X => X)
  (λ F _ _ ih X => ih (Obj.app' F X))

theorem appInj {C₁ C₂ D : Cat} {F₁ : Func C₁ D} {F₂ : Func C₂ D}
  {X₁ : Obj C₁} {X₂ : Obj C₂}
  (h : F₁.app X₁ = F₂.app X₂) :
  C₁ = C₂ ∧ HEq F₁ F₂ ∧ HEq X₁ X₂ := sorry

--   by
-- cases F₁
-- . cases F₂
--   . cases X₁
--     . cases X₂
--       . injection h with _ n_eq
--         subst n_eq
--         exact ⟨rfl, rfl⟩
--       . injection h
--     . cases X₂
--       . injection h
--       . injection h with _ F_eq
--         subst F_eq
--         exact ⟨rfl, rfl⟩
--   . cases X₁
--     . cases X₂
--       . rw [Func.app, Func.app] at h
--         simp at h
--         injection h

@[reducible] def Func.hom {C : Cat} (X : Obj C) : Func C Cat.Set :=
Func.comp' (Func'.hom C X) (Func.id _)

def Func.var (C D : Cat) (n : Nat) : Func C D :=
Func.comp' (Func'.var C D n) (Func.id _)

def Func.prod {C : Cat} (F G : Func C Cat.Set) : Func C Cat.Set :=
Func.comp' (Func'.prod F G) (Func.id _)

@[reducible] def homm {C : Cat} (X Y : Obj C) : Obj Cat.Set :=
Obj.app' (Func'.hom C X) Y

theorem hommEqHom {C : Cat} (X Y : Obj C) : homm X Y = (Func.hom X).app Y := rfl

open Func Obj

structure Context : Type 1 :=
(elem : Obj Cat.Set → Type)
(isCorepr : {C : Cat} → Func C Set → Prop)

variable (Γ : Context)

inductive Elem : (X : Obj Cat.Set) → Type
| var (X : Obj Cat.Set) (x : Γ.elem X) : Elem X
| id {C : Cat} (X : Obj C) : Elem ((hom X).app X)
| comp {C : Cat} {X Y Z : Obj C}
  (f : Elem ((hom X).app Y))
  (g : Elem ((hom Y).app Z)) : Elem ((hom X).app Z)
| app {X Y : Obj Cat.Set} (f : Elem ((hom X).app Y)) (x : Elem X) : Elem Y
| map {C D : Cat} (F : Func C D) {X Y : Obj C} (f : Elem ((hom X).app Y)) :
  Elem (app (hom (app F X)) (app F Y))
| extend {C : Cat} (F : Func C Cat.Set) (h : Γ.isCorepr F) {X : Obj C} :
  Elem ((app (hom (app F X)) (app (hom (corepr F)) X)))
| unit {C : Cat} (F : Func C Cat.Set) (h : Γ.isCorepr F) :
  Elem (app F (corepr F))
| prodMk {C : Cat} {F G : Func C Cat.Set} {X : Obj C}
  (x : Elem (F.app X)) (y : Elem (G.app X)) :
  Elem ((F.prod G).app X)
| prodFst {C : Cat} {F G : Func C Cat.Set} {X : Obj C}
  (x : Elem ((F.prod G).app X)) : Elem (F.app X)
| prodSnd {C : Cat} {F G : Func C Cat.Set} {X : Obj C}
  (x : Elem ((F.prod G).app X)) : Elem (G.app X)

inductive Rel : {X : Obj Cat.Set} → (x y : Elem Γ X) → Prop
| refl {X : Obj Cat.Set} (x : Elem Γ X) : Rel x x
| symm {X : Obj Cat.Set} {x y : Elem Γ X} : Rel x y → Rel y x
| trans {X : Obj Cat.Set} {x y z : Elem Γ X} : Rel x y → Rel y z → Rel x z
| idComp {C : Cat} {X Y : Obj C} {f : Elem Γ ((hom X).app Y)} :
  Rel ((Elem.id X).comp f) f
| compId {C : Cat} {X Y : Obj C} {f : Elem Γ ((hom X).app Y)} :
  Rel (f.comp (Elem.id Y)) f
| compAssoc {C : Cat} {W X Y Z : Obj C} (f : Elem Γ ((hom W).app X))
  (g : Elem Γ ((hom X).app Y)) (h : Elem Γ ((hom Y).app Z)) :
  Rel ((f.comp g).comp h) (f.comp (g.comp h))
| idApp {X : Obj Cat.Set} (x : Elem Γ X) :
  Rel ((Elem.id X).app x) x
| compApp {X Y Z : Obj Cat.Set} (f : Elem Γ ((hom X).app Y))
  (g : Elem Γ ((hom Y).app Z)) (x : Elem Γ X):
  Rel ((f.comp g).app x) (g.app (f.app x))
| mapId {C D : Cat} (F : Func C D) (X : Obj C) :
  Rel (Elem.map F (Elem.id X)) (Elem.id (F.app X))
| mapComp {C D : Cat} (F : Func C D) {X Y Z : Obj C}
  (f : Elem Γ ((hom X).app Y)) (g : Elem Γ ((hom Y).app Z)) :
  Rel (Elem.map F (f.comp g)) ((Elem.map F f).comp (Elem.map F g))
| fstMk {C : Cat} (F G : Func C Cat.Set){X : Obj C}
  (x : Elem Γ (F.app X)) (y : Elem Γ (G.app X)) :
  Rel (Elem.prodFst (x.prodMk y)) x
| sndMk {C : Cat} (F G : Func C Cat.Set){X : Obj C}
  (x : Elem Γ (F.app X)) (y : Elem Γ (G.app X)) :
  Rel (Elem.prodSnd (x.prodMk y)) y
| compCongr {C : Cat} {X Y Z : Obj Cat.Set} {f₁ f₂ : Elem Γ ((hom X).app Y)}
  {g₁ g₂ : Elem Γ ((hom Y).app Z)} :
  Rel f₁ f₂ → Rel g₁ g₂ → Rel (f₁.comp g₁) (f₂.comp g₂)
| appCongr {X Y : Obj Cat.Set} {f₁ f₂ : Elem Γ ((hom X).app Y)} {x₁ x₂ : Elem Γ X} :
  Rel f₁ f₂ → Rel x₁ x₂ → Rel (f₁.app x₁) (f₂.app x₂)
| mapCongr {C D : Cat} {F : Func C D} {X Y : Obj C} {f₁ f₂ : Elem Γ ((hom X).app Y)} :
  Rel f₁ f₂ → Rel (Elem.map F f₁) (Elem.map F f₂)
| prodMkCongr {C : Cat} (F G : Func C Cat.Set) {X : Obj C}
  {x₁ x₂ : Elem Γ (F.app X)} {y₁ y₂ : Elem Γ (G.app X)} :
  Rel x₁ x₂ → Rel y₁ y₂ → Rel (x₁.prodMk y₁) (x₂.prodMk y₂)
| prodFstCongr {C : Cat} {F G : Func C Cat.Set} {X : Obj C}
  (x₁ x₂ : Elem Γ ((F.prod G).app X)) :
  Rel x₁ x₂ → Rel x₁.prodFst x₂.prodFst
| prodSndCongr {C : Cat} {F G : Func C Cat.Set} {X : Obj C}
  (x₁ x₂ : Elem Γ ((F.prod G).app X)) :
  Rel x₁ x₂ → Rel x₁.prodSnd x₂.prodSnd

inductive HeadSymbol
| VEU : HeadSymbol -- var, extend or unit
| Fst : HeadSymbol
| Snd : HeadSymbol
| ProdMk : HeadSymbol
| IC : HeadSymbol -- id, comp
| AM : HeadSymbol -- app, map

open HeadSymbol
-- Don't need composition. hom is already a functor.
inductive NormElemAux : HeadSymbol → Obj Cat.Set → Type
| var {X : Obj Cat.Set} (x : Γ.elem X) : NormElemAux VEU X
| id {C : Cat} (X : Obj C) : NormElemAux ICAM ((Func.hom X).app X)
| comp {C : Cat} {X Y Z : Obj C} {s t : HeadSymbol} (hs : s ≠ IC)
  (f : NormElemAux s ((hom X).app Y))
  (g : NormElemAux t ((hom Y).app Z)) : NormElemAux IC ((hom X).app Z)
| app {X Y : Obj Cat.Set} {s t : HeadSymbol} (hs : s ≠ IC) (f : NormElemAux s ((hom X).app Y))
  (x : NormElemAux t X) : NormElemAux AM Y
| map {C D : Cat} (F : Func C D) --shold be Func'
  {X Y : Obj C} {s : HeadSymbol} (hs : s ≠ IC)
  (f : NormElemAux s ((hom X).app Y)) :
  NormElemAux AM (app (hom (app F X)) (app F Y))
| extend {C : Cat} (F : Func C Cat.Set) (h : Γ.isCorepr F) {X : Obj C} :
  NormElemAux VEU ((app (hom (app F X)) (app (hom (corepr F)) X)))
| unit {C : Cat} (F : Func C Cat.Set)  (h : Γ.isCorepr F) :
  NormElemAux VEU (app F (corepr F))
| prodMk {C : Cat} {F G : Func C Cat.Set} {X : Obj C} {s t : HeadSymbol}
  (hst : s ≠ Fst ∨ t ≠ Snd)
  (x : NormElemAux s (F.app X)) (y : NormElemAux t (G.app X)) :
  NormElemAux ProdMk ((F.prod G).app X)
| prodFst {C : Cat} {F G : Func C Cat.Set} {X : Obj C} {s : HeadSymbol}
  (hs : s ≠ ProdMk)
  (x : NormElemAux s ((F.prod G).app X)) : NormElemAux Fst (F.app X)
| prodSnd {C : Cat} {F G : Func C Cat.Set} {X : Obj C} {s : HeadSymbol}
  (hs : s ≠ ProdMk)
  (x : NormElemAux s ((F.prod G).app X)) : NormElemAux Snd (G.app X)

def NormElem (X : Obj Cat.Set) : Type :=
(s : HeadSymbol) × NormElemAux Γ s X

/- Suppose I do reprs at the same time. -/

namespace NormElem

variable {C : Cat}
variable {Γ}

def var (X : Obj Cat.Set) (v : Γ.elem X) : NormElem Γ X :=
⟨VEU, NormElemAux.var v⟩

def id (X : Obj C) : NormElem Γ ((hom X).app X) :=
⟨IC, NormElemAux.id X⟩

noncomputable def compAux
  {A : Obj Cat.Set}
  {s : HeadSymbol}
  (f : NormElemAux Γ s A) :
  {X Y Z : Obj C} →
  (hA : A = ((hom X).app Y)) →
  {B : Obj Cat.Set} →
  (hB : B = ((hom Y).app Z)) →
  {t : HeadSymbol} →
  (g : NormElemAux Γ t B) →
  NormElem Γ ((hom X).app Z) :=
@NormElemAux.recOn Γ
  (λ s A f => (X Y Z : Obj C) → (hA : A = ((hom X).app Y)) →
    (B : Obj Cat.Set) →
    (hB : B = ((hom Y).app Z)) →
    (t : HeadSymbol) →
    (g : NormElemAux Γ t B) →
    NormElem Γ ((hom X).app Z))
  s A f
  (λ f' X Y Z hA B hB t g => show NormElem Γ (app (hom X) Z) by
    subst hA hB
    exact ⟨_, NormElemAux.comp HeadSymbol.noConfusion
      (NormElemAux.var f') g⟩)
  (λ A' X Y Z hA B hB t g => show NormElem Γ (app (hom X) Z) by
    subst hB
    injection hA with C_eq _ F_eq A_eq
    subst C_eq
    have F_eq' := eq_of_heq F_eq
    injection F_eq' with F_eq₂ A_eq₂
    subst A_eq₂
    have A_eq' := eq_of_heq A_eq
    subst A_eq'
    exact ⟨_, g⟩)
  (λ hs f' g' ihf ihg X Y Z hA B hB _ h' => show NormElem Γ (app (hom X) Z) by
    subst hB
    injection hA with C_eq _ F_eq A_eq
    subst C_eq
    have F_eq' := eq_of_heq F_eq
    injection F_eq' with F_eq₂ A_eq₂
    subst A_eq₂
    have A_eq' := eq_of_heq A_eq
    subst A_eq'
    exact ⟨_, NormElemAux.comp hs f' (ihg _ _ _ rfl _ rfl _ h').2⟩)
  (λ hs f' x ihf ihx X Y Z hA B hB t g => show NormElem Γ (app (hom X) Z) by
      subst hB hA
      exact ⟨_, NormElemAux.comp HeadSymbol.noConfusion (NormElemAux.app hs f' x) g⟩)
  (λ F X Y s hs f' ihf Z V W hA B hB t g => show NormElem Γ (app (hom Z) W) by
    subst hB
    injection hA with C_eq _ F_eq A_eq
    subst C_eq
    have F_eq' := eq_of_heq F_eq
    injection F_eq' with F_eq₂ A_eq₂
    subst A_eq₂
    have A_eq' := eq_of_heq A_eq
    subst A_eq'
    exact ⟨_, NormElemAux.comp HeadSymbol.noConfusion (NormElemAux.map F hs f') g⟩)
  (λ F hC W  X Y Z hA B hB t g => show NormElem Γ (app (hom X) Z) by
    subst hB
    injection hA with C_eq _ F_eq A_eq
    subst C_eq
    have F_eq' := eq_of_heq F_eq
    injection F_eq' with F_eq₂ A_eq₂
    subst A_eq₂
    have A_eq' := eq_of_heq A_eq
    subst A_eq'
    exact ⟨_, NormElemAux.comp HeadSymbol.noConfusion (NormElemAux.extend _ hC) g⟩)
  (λ F hC X Y Z hA B hB t g => show NormElem Γ (app (hom X) Z) by
    subst hB
    have hA₁ := (appInj hA).1
    subst hA₁
    have hA₂ := eq_of_heq (appInj hA).2.1
    subst hA₂
    have hA₃ := eq_of_heq (appInj hA).2.2
    subst hA₃
    exact ⟨_, NormElemAux.comp HeadSymbol.noConfusion (NormElemAux.unit _ hC) g⟩)
  (λ hst f₁ f₂ ih₁ ih₂ X Y Z hA B hB t g => show NormElem Γ (app (hom X) Z) by
    injection hA with C_eq _ F_eq
    subst C_eq
    have F_eq' := eq_of_heq F_eq
    injection F_eq')
  (λ hs f' ih X Y Z hA B hB t g => show NormElem Γ (app (hom X) Z) by
    subst hB
    have hA₁ := (appInj hA).1
    subst hA₁
    have hA₂ := eq_of_heq (appInj hA).2.1
    subst hA₂
    have hA₃ := eq_of_heq (appInj hA).2.2
    subst hA₃
    exact ⟨_, NormElemAux.comp HeadSymbol.noConfusion (NormElemAux.prodFst hs f') g⟩)
  (λ hs f' ih X Y Z hA B hB t g => show NormElem Γ (app (hom X) Z) by
    subst hB
    have hA₁ := (appInj hA).1
    subst hA₁
    have hA₂ := eq_of_heq (appInj hA).2.1
    subst hA₂
    have hA₃ := eq_of_heq (appInj hA).2.2
    subst hA₃
    exact ⟨_, NormElemAux.comp HeadSymbol.noConfusion (NormElemAux.prodSnd hs f') g⟩)

noncomputable def comp {X Y Z : Obj C}
  (f : NormElem Γ ((hom X).app Y))
  (g : NormElem Γ ((hom Y).app Z)) :
  NormElem Γ ((hom X).app Z) :=
compAux f.2 rfl rfl g.2

end NormElem

-- mutual

-- -- prodMk can only be applied to terms not of the form fst snd.

-- -- We have raw Elems and Elems. Elems are the closure under identity
-- -- and composition functor map and function application of raw Elems.
-- -- We can only apply or map raw homs.

-- inductive RawElem : Obj Cat.Set → Type where
-- | var (X : Obj Cat.Set) (x : Γ.elem X) : RawElem X
-- | extend {C : Cat} (F : Func C Cat.Set) (h : Γ.isCorepr F) {X : Obj C} :
--   RawElem ((app (hom (app F X)) (app (hom (corepr F)) X)))
-- | unit {C : Cat} (F : Func C Cat.Set)  (h : Γ.isCorepr F) :
--   RawElem (app F (corepr F))

-- inductive RawElemFst : Obj Cat.Set → Type where
-- | ofVar {C : Cat} {F G : Func C Cat.Set} {X : Obj C} (x : Γ.elem ((F.prod G).app X)) :
--   RawElemFst (F.app X)
-- | ofRawElemSnd {C : Cat} {F G : Func C Cat.Set} {X : Obj C}
--   (x : RawElemSnd ((F.prod G).app X)) : RawElemFst (F.app X)
-- | ofCompMapAppElem {C : Cat} {F G : Func C Cat.Set} {X : Obj C}
--   (x : CompMapAppElem ((F.prod G).app X)) : RawElemFst (F.app X)

-- inductive RawElemSnd : Obj Cat.Set → Type where
-- | ofVar {C : Cat} {F G : Func C Cat.Set} {X : Obj C} (x : Γ.elem ((F.prod G).app X)) :
--   RawElemSnd (G.app X)
-- | ofRawElemFst {C : Cat} {F G : Func C Cat.Set} {X : Obj C}
--   (x : RawElemFst ((F.prod G).app X)) : RawElemSnd (G.app X)
-- | ofCompMapAppElem {C : Cat} {F G : Func C Cat.Set} {X : Obj C}
--   (x : CompMapAppElem ((F.prod G).app X)) : RawElemFst (G.app X)

-- inductive RawElemProdMk : Obj Cat.Set → Type where
-- | ofRawElemRawElem {C : Cat} {F G : Func C Cat.Set} {X : Obj C}
--   (x : RawElem (F.app X)) (y : RawElem (G.app X)) :
--   RawElemProdMk ((F.prod G).app X)
-- | ofRawElemRawElemFst {C : Cat} {F G : Func C Cat.Set} {X : Obj C}
--   (x : RawElem (F.app X)) (y : RawElemFst (G.app X)) :
--   RawElemProdMk ((F.prod G).app X)
-- | ofRawElemRawElemSnd {C : Cat} {F G : Func C Cat.Set} {X : Obj C}
--   (x : RawElem (F.app X)) (y : RawElemSnd (G.app X)) :
--   RawElemProdMk ((F.prod G).app X)
-- | ofRawElemRawElemProdMk {C : Cat} {F G : Func C Cat.Set} {X : Obj C}
--   (x : RawElem (F.app X)) (y : RawElemProdMk (G.app X)) :
--   RawElemProdMk ((F.prod G).app X)
-- | ofRawElemElem {C : Cat} {F G : Func C Cat.Set} {X : Obj C}
--   (x : RawElem (F.app X)) (y : Elem (G.app X)) :
--   RawElemProdMk ((F.prod G).app X)

-- | ofRawElemFstRawElem {C : Cat} {F G : Func C Cat.Set} {X : Obj C}
--   (x : RawElemFst (F.app X)) (y : RawElem (G.app X)) :
--   RawElemProdMk ((F.prod G).app X)
-- | ofRawElemFstRawElemFst {C : Cat} {F G : Func C Cat.Set} {X : Obj C}
--   (x : RawElemFst (F.app X)) (y : RawElemFst (G.app X)) :
--   RawElemProdMk ((F.prod G).app X)
-- | ofRawElemFstRawElemProdMk {C : Cat} {F G : Func C Cat.Set} {X : Obj C}
--   (x : RawElemFst (F.app X)) (y : RawElemProdMk (G.app X)) :
--   RawElemProdMk ((F.prod G).app X)
-- | ofRawElemFstElem {C : Cat} {F G : Func C Cat.Set} {X : Obj C}
--   (x : RawElemFst (F.app X)) (y : Elem (G.app X)) :
--   RawElemProdMk ((F.prod G).app X)

-- | ofRawElemSndRawElem {C : Cat} {F G : Func C Cat.Set} {X : Obj C}
--   (x : RawElemSnd (F.app X)) (y : RawElem (G.app X)) :
--   RawElemProdMk ((F.prod G).app X)
-- | ofRawElemRawElemFst {C : Cat} {F G : Func C Cat.Set} {X : Obj C}
--   (x : RawElemSnd (F.app X)) (y : RawElemFst (G.app X)) :
--   RawElemProdMk ((F.prod G).app X)
-- | ofRawElemRawElemSnd {C : Cat} {F G : Func C Cat.Set} {X : Obj C}
--   (x : RawElemSnd (F.app X)) (y : RawElemSnd (G.app X)) :
--   RawElemProdMk ((F.prod G).app X)
-- | ofRawElemRawElemProdMk {C : Cat} {F G : Func C Cat.Set} {X : Obj C}
--   (x : RawElemSnd (F.app X)) (y : RawElemProdMk (G.app X)) :
--   RawElemProdMk ((F.prod G).app X)
-- | ofRawElemElem {C : Cat} {F G : Func C Cat.Set} {X : Obj C}
--   (x : RawElemSnd (F.app X)) (y : Elem (G.app X)) :
--   RawElemProdMk ((F.prod G).app X)

-- inductive CompMapAppElem : Obj Cat.Set → Type where
-- | id {C : Cat} (X : Obj C) : Elem ((Func.hom X).app X)
-- |

-- end

-- end NormElem


/-
Copyright (c) 2020 Eric Wieser. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Eric Wieser, Utensil Song.
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.algebra.ring_quot
import Mathlib.linear_algebra.tensor_algebra
import Mathlib.linear_algebra.exterior_algebra
import Mathlib.linear_algebra.quadratic_form
import Mathlib.PostPort

universes u_1 u_2 u_3

namespace Mathlib

/-!
# Clifford Algebras

We construct the Clifford algebra of a module `M` over a commutative ring `R`, equipped with
a quadratic_form `Q`.

## Notation

The Clifford algebra of the `R`-module `M` equipped with a quadratic_form `Q` is denoted as
`clifford_algebra Q`.

Given a linear morphism `f : M → A` from a semimodule `M` to another `R`-algebra `A`, such that
`cond : ∀ m, f m * f m = algebra_map _ _ (Q m)`, there is a (unique) lift of `f` to an `R`-algebra
morphism, which is denoted `clifford_algebra.lift Q f cond`.

The canonical linear map `M → clifford_algebra Q` is denoted `clifford_algebra.ι Q`.

## Theorems

The main theorems proved ensure that `clifford_algebra Q` satisfies the universal property
of the Clifford algebra.
1. `ι_comp_lift` is the fact that the composition of `ι Q` with `lift Q f cond` agrees with `f`.
2. `lift_unique` ensures the uniqueness of `lift Q f cond` with respect to 1.

Additionally, when `Q = 0` an `alg_equiv` to the `exterior_algebra` is provided as `as_exterior`.

## Implementation details

The Clifford algebra of `M` is constructed as a quotient of the tensor algebra, as follows.
1. We define a relation `clifford_algebra.rel Q` on `tensor_algebra R M`.
   This is the smallest relation which identifies squares of elements of `M` with `Q m`.
2. The Clifford algebra is the quotient of the tensor algebra by this relation.

This file is almost identical to `linear_algebra/exterior_algebra.lean`.
-/

namespace clifford_algebra

/-- `rel` relates each `ι m * ι m`, for `m : M`, with `Q m`.

The Clifford algebra of `M` is defined as the quotient modulo this relation.
-/
inductive rel {R : Type u_1} [comm_ring R] {M : Type u_2} [add_comm_group M] [module R M]
    (Q : quadratic_form R M) : tensor_algebra R M → tensor_algebra R M → Prop
    where
| of :
    ∀ (m : M),
      rel Q (coe_fn (tensor_algebra.ι R) m * coe_fn (tensor_algebra.ι R) m)
        (coe_fn (algebra_map R (tensor_algebra R M)) (coe_fn Q m))

end clifford_algebra

/--
The Clifford algebra of an `R`-module `M` equipped with a quadratic_form `Q`.
-/
def clifford_algebra {R : Type u_1} [comm_ring R] {M : Type u_2} [add_comm_group M] [module R M]
    (Q : quadratic_form R M) :=
  ring_quot sorry

namespace clifford_algebra

/--
The canonical linear map `M →ₗ[R] clifford_algebra Q`.
-/
def ι {R : Type u_1} [comm_ring R] {M : Type u_2} [add_comm_group M] [module R M]
    (Q : quadratic_form R M) : linear_map R M (clifford_algebra Q) :=
  linear_map.comp (alg_hom.to_linear_map (ring_quot.mk_alg_hom R (rel Q))) (tensor_algebra.ι R)

/-- As well as being linear, `ι Q` squares to the quadratic form -/
@[simp] theorem ι_square_scalar {R : Type u_1} [comm_ring R] {M : Type u_2} [add_comm_group M]
    [module R M] (Q : quadratic_form R M) (m : M) :
    coe_fn (ι Q) m * coe_fn (ι Q) m = coe_fn (algebra_map R (clifford_algebra Q)) (coe_fn Q m) :=
  sorry

@[simp] theorem comp_ι_square_scalar {R : Type u_1} [comm_ring R] {M : Type u_2} [add_comm_group M]
    [module R M] {Q : quadratic_form R M} {A : Type u_3} [semiring A] [algebra R A]
    (g : alg_hom R (clifford_algebra Q) A) (m : M) :
    coe_fn g (coe_fn (ι Q) m) * coe_fn g (coe_fn (ι Q) m) = coe_fn (algebra_map R A) (coe_fn Q m) :=
  sorry

/--
Given a linear map `f : M →ₗ[R] A` into an `R`-algebra `A`, which satisfies the condition:
`cond : ∀ m : M, f m * f m = Q(m)`, this is the canonical lift of `f` to a morphism of `R`-algebras
from `clifford_algebra Q` to `A`.
-/
@[simp] theorem lift_symm_apply {R : Type u_1} [comm_ring R] {M : Type u_2} [add_comm_group M]
    [module R M] (Q : quadratic_form R M) {A : Type u_3} [semiring A] [algebra R A]
    (F : alg_hom R (clifford_algebra Q) A) :
    coe_fn (equiv.symm (lift Q)) F =
        { val := linear_map.comp (alg_hom.to_linear_map F) (ι Q), property := lift._proof_2 Q F } :=
  Eq.refl (coe_fn (equiv.symm (lift Q)) F)

@[simp] theorem ι_comp_lift {R : Type u_1} [comm_ring R] {M : Type u_2} [add_comm_group M]
    [module R M] {Q : quadratic_form R M} {A : Type u_3} [semiring A] [algebra R A]
    (f : linear_map R M A)
    (cond : ∀ (m : M), coe_fn f m * coe_fn f m = coe_fn (algebra_map R A) (coe_fn Q m)) :
    linear_map.comp (alg_hom.to_linear_map (coe_fn (lift Q) { val := f, property := cond })) (ι Q) =
        f :=
  iff.mp subtype.mk_eq_mk (equiv.symm_apply_apply (lift Q) { val := f, property := cond })

@[simp] theorem lift_ι_apply {R : Type u_1} [comm_ring R] {M : Type u_2} [add_comm_group M]
    [module R M] {Q : quadratic_form R M} {A : Type u_3} [semiring A] [algebra R A]
    (f : linear_map R M A)
    (cond : ∀ (m : M), coe_fn f m * coe_fn f m = coe_fn (algebra_map R A) (coe_fn Q m)) (x : M) :
    coe_fn (coe_fn (lift Q) { val := f, property := cond }) (coe_fn (ι Q) x) = coe_fn f x :=
  iff.mp linear_map.ext_iff (ι_comp_lift f cond) x

@[simp] theorem lift_unique {R : Type u_1} [comm_ring R] {M : Type u_2} [add_comm_group M]
    [module R M] {Q : quadratic_form R M} {A : Type u_3} [semiring A] [algebra R A]
    (f : linear_map R M A)
    (cond : ∀ (m : M), coe_fn f m * coe_fn f m = coe_fn (algebra_map R A) (coe_fn Q m))
    (g : alg_hom R (clifford_algebra Q) A) :
    linear_map.comp (alg_hom.to_linear_map g) (ι Q) = f ↔
        g = coe_fn (lift Q) { val := f, property := cond } :=
  sorry

@[simp] theorem lift_comp_ι {R : Type u_1} [comm_ring R] {M : Type u_2} [add_comm_group M]
    [module R M] {Q : quadratic_form R M} {A : Type u_3} [semiring A] [algebra R A]
    (g : alg_hom R (clifford_algebra Q) A) :
    coe_fn (lift Q)
          { val := linear_map.comp (alg_hom.to_linear_map g) (ι Q),
            property := comp_ι_square_scalar g } =
        g :=
  sorry

/-- See note [partially-applied ext lemmas]. -/
theorem hom_ext {R : Type u_1} [comm_ring R] {M : Type u_2} [add_comm_group M] [module R M]
    {Q : quadratic_form R M} {A : Type u_3} [semiring A] [algebra R A]
    {f : alg_hom R (clifford_algebra Q) A} {g : alg_hom R (clifford_algebra Q) A} :
    linear_map.comp (alg_hom.to_linear_map f) (ι Q) =
          linear_map.comp (alg_hom.to_linear_map g) (ι Q) →
        f = g :=
  sorry

/-- A Clifford algebra with a zero quadratic form is isomorphic to an `exterior_algebra` -/
def as_exterior {R : Type u_1} [comm_ring R] {M : Type u_2} [add_comm_group M] [module R M] :
    alg_equiv R (clifford_algebra 0) (exterior_algebra R M) :=
  alg_equiv.of_alg_hom (coe_fn (lift 0) { val := exterior_algebra.ι R, property := sorry })
    (coe_fn (exterior_algebra.lift R) { val := ι 0, property := sorry }) sorry sorry

end clifford_algebra

namespace tensor_algebra

/-- The canonical image of the `tensor_algebra` in the `clifford_algebra`, which maps
`tensor_algebra.ι R x` to `clifford_algebra.ι Q x`. -/
def to_clifford {R : Type u_1} [comm_ring R] {M : Type u_2} [add_comm_group M] [module R M]
    {Q : quadratic_form R M} : alg_hom R (tensor_algebra R M) (clifford_algebra Q) :=
  coe_fn (lift R) (clifford_algebra.ι Q)

@[simp] theorem to_clifford_ι {R : Type u_1} [comm_ring R] {M : Type u_2} [add_comm_group M]
    [module R M] {Q : quadratic_form R M} (m : M) :
    coe_fn to_clifford (coe_fn (ι R) m) = coe_fn (clifford_algebra.ι Q) m :=
  sorry

end Mathlib


import tactic
import data.real.basic
import measure_theory.function.locally_integrable
import measure_theory.measure.lebesgue
import measure_theory.integral.interval_integral
import measure_theory.group.measure
import TechnicalStuff

noncomputable def μ := real.measure_space.volume

structure edgeflow (τ : ℝ) (ν : ℝ):=
  (τnn : τ ≥ 0)
  (νpos : ν > 0)
  (fp : ℝ →ₘ[μ] ℝ)
  (h_fp_locint : measure_theory.locally_integrable fp μ)
  (h_fp_0_before_0 : ∀ᵐ θ, θ < 0 → fp θ = 0)
  (fm : ℝ →ₘ[μ] ℝ)
  (h_fm_locint : measure_theory.locally_integrable fm μ)
  (h_fm_0_before_0 : ∀ᵐ θ, θ < 0 → fm θ = 0)

namespace edgeflow
  variables {τ : ℝ} {ν : ℝ} (f : edgeflow τ ν)

  noncomputable def Fp : ℝ → ℝ := λ θ, ∫ z in 0..θ, f.fp z ∂μ
  noncomputable def Fm : ℝ → ℝ := λ θ, ∫ z in 0..θ, f.fm z ∂μ

  noncomputable def q : ℝ → ℝ := λ θ, (f.Fp θ) - (f.Fm (θ + τ))

  noncomputable def c : ℝ → ℝ := λ θ, τ + (f.q θ) / ν

  def weak_flowconservation : Prop := ∀ θ : ℝ, f.Fm (θ + τ) ≤ f.Fp θ

  def flow_respects_capacity : Prop :=
    ∀ᵐ θ : ℝ, f.fm (θ + τ) ≤ ν

  def queue_operates_at_capacity_at (θ : ℝ) : Prop :=
    if f.q θ > 0 then f.fm (θ + τ) = ν else f.fm (θ + τ) = min (f.fp θ) ν

  def queue_operates_at_capacity : Prop :=
    ∀ᵐ θ : ℝ, f.queue_operates_at_capacity_at θ

  def queue_operates_at_capacity_cum : Prop :=
    ∀ θ : ℝ, f.Fm (θ + f.c θ) = f.Fp θ

  lemma weak_flowconservation_iff_queue_nonnegative :
    weak_flowconservation f ↔ ∀ θ : ℝ, f.q θ ≥ 0 :=
  begin
    split,
    {
      -- Show that weak flow conservation implies that the queue is nonnegative
      intros hweak_fc θ,
      specialize hweak_fc θ,
      have h : (f.Fp θ) - (f.Fm (θ + τ)) ≥ 0 := begin
        linarith,
      end,
      assumption,
    },
    {
      -- Show that a nonnegative queue implies weak flow conservation
      intros hqnonneg θ,
      specialize hqnonneg θ,
      calc f.Fm (θ + τ) = f.Fp θ - (f.Fp θ - f.Fm (θ + τ)) : by ring
                ...     = f.Fp θ - (f.q θ) : by refl
                ...     ≤  f.Fp θ : by linarith,
    }
  end

  lemma respects_cap_of_queue_op_at_cap:
    queue_operates_at_capacity f → flow_respects_capacity f :=
  begin
    apply ae_of_implies_and_ae,
    intros θ hqatcap,
    unfold queue_operates_at_capacity_at at hqatcap,
    split_ifs at hqatcap,
    {
      apply le_of_eq,
      assumption,
    },
    rw hqatcap,
    exact min_le_right _ _,
  end

  lemma weak_flowconservation_of_queue_op_at_cap:
    queue_operates_at_capacity f → weak_flowconservation f :=
  begin
    sorry,
  end

  lemma queue_depletes_fast_of_respects_capacity {θ : ℝ}:
    flow_respects_capacity f → ∀ θ', θ ≤ θ' ∧ θ' < θ + (f.q θ)/ν → f.q θ' > 0 :=
  begin
    sorry,
  end

  lemma queue_op_at_cap_cum_of_queue_op_at_cap:
    queue_operates_at_capacity f → queue_operates_at_capacity_cum f :=
  begin
    intros hatcap θ,
    have hq_depletes_slow : ∀ θ', θ ≤ θ' ∧ θ' < θ + (f.q θ)/ν → f.q θ' > 0 :=
    begin
      apply queue_depletes_fast_of_respects_capacity,
      apply respects_cap_of_queue_op_at_cap,
      assumption,
    end,
    have hmaxoutflow : ∀ᵐ z : ℝ ∂μ, z ∈ set.interval_oc (θ + τ) (θ + f.c θ) → f.fm z = (λ θ, ν) z :=
    begin
      have h' : μ ({z : ℝ | ¬f.queue_operates_at_capacity_at (z - τ)} ∪ {θ + f.c θ}) = 0 :=
      begin
        apply measure_theory.outer_measure.union_null,
        {
          rw ← lebesgue_measure_translation_invariant (λ a, ¬f.queue_operates_at_capacity_at a),
          simp,
          unfold queue_operates_at_capacity at hatcap,
          rw measure_theory.ae_iff at hatcap,
          exact hatcap,
        },
        exact real.volume_singleton,
      end,
      apply measure_theory.ae_iff.2,
      simp,
      have h'' : {a : ℝ | a ∈ set.interval_oc (θ + τ) (θ + f.c θ) ∧ ¬f.fm a = ν} ⊆ {z : ℝ | ¬f.queue_operates_at_capacity_at (z - τ)} ∪ {θ + f.c θ} :=
      begin
        intros x hx,
        by_cases x = θ + f.c θ,
        {
          right,
          rw h,
          simp,
        },
        left,
        cases hx with hx1 hx2,
        have g : θ + τ ≤ θ + f.c θ :=
        begin
          unfold c,
          have k : f.q θ ≥ 0 :=
          begin
            apply (weak_flowconservation_iff_queue_nonnegative f).1 _ θ,
            apply weak_flowconservation_of_queue_op_at_cap f,
            exact hatcap
          end,
          rw ge_iff_le at k,
          rw ← div_le_div_right f.νpos at k,
          simp at k,
          linarith,
        end,
        rw set.interval_oc_of_le g at hx1,
        rw set.mem_Ioc at hx1,
        have g1 : θ ≤ x - τ :=
        begin
          linarith
        end,
        have g2 : x - τ < θ + f.q θ / ν :=
        begin
          unfold c at hx1,
          unfold c at h,
          rw sub_lt_iff_lt_add,
          rw add_assoc,
          rw add_comm _ τ,
          apply lt_of_le_of_ne,
          exact hx1.2,
          exact h,
        end,
        specialize hq_depletes_slow (x - τ) ⟨g1, g2⟩,
        intro g'',
        unfold queue_operates_at_capacity_at at g'',
        split_ifs at g'',
        rw sub_add_cancel at g'',
        exact hx2 g'',
      end,
      exact measure_theory.outer_measure.mono_null _ h'' h',
    end,
    have hνpos : ν ≠ 0 :=
    begin
      have h' : ν > 0 := f.νpos,
      linarith,
    end,

    calc f.Fm (θ + f.c θ) = ∫ z in 0..θ + f.c θ, f.fm z ∂μ : by refl
            ... = ∫ z in 0..θ + τ, f.fm z ∂μ + ∫ z in θ + τ..θ + f.c θ, f.fm z ∂μ :
                    by rw ← interval_integral.integral_add_adjacent_intervals
                      (interval_integrable_of_locally_integrable f.fm 0 (θ + τ) f.h_fm_locint)
                      (interval_integrable_of_locally_integrable f.fm (θ + τ) (θ + f.c θ) f.h_fm_locint)
            ... = f.Fm (θ + τ) + ∫ z in θ + τ..θ + f.c θ, f.fm z ∂μ : by refl
            ... = f.Fm (θ + τ) + ∫ z in θ + τ..θ + f.c θ, (λ z', (λ θ, ν) z') z ∂μ :
                    by rw interval_integral.integral_congr_ae hmaxoutflow
            ... = f.Fm (θ + τ) + ∫ z in θ + τ..θ + f.c θ, ν : by refl
            ... = f.Fm (θ + τ) + (θ + f.c θ - (θ + τ)) • ν :
                    by rw interval_integral.integral_const
            ... = f.Fm (θ + τ) + (θ + (τ + f.q θ / ν) - (θ + τ)) • ν : by refl
            ... = f.Fm (θ + τ) + (f.q θ / ν) • ν : by ring_nf
            ... = f.Fm (θ + τ) + f.q θ : by finish
            ... = f.Fm (θ + τ) + (f.Fp θ - f.Fm (θ + τ)) : by refl
            ... = f.Fp θ : by ring_nf,
  end
end edgeflow


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

import category_theory.isomorphism

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

namespace category_theory

variables {C : Type u₁} [𝒞 : category.{u₁ v₁} C] {D : Type u₂} [𝒟 : category.{u₂ v₂} D]
include 𝒞 𝒟

class full (F : C ⥤ D) :=
(preimage : ∀ {X Y : C} (f : (F X) ⟶ (F Y)), X ⟶ Y)
(witness'  : ∀ {X Y : C} (f : (F X) ⟶ (F Y)), F.map (preimage f) = f . obviously)

restate_axiom full.witness'
attribute [simp] full.witness

class faithful (F : C ⥤ D) : Prop :=
(injectivity' : ∀ {X Y : C} {f g : X ⟶ Y} (p : F.map f = F.map g), f = g . obviously)

restate_axiom faithful.injectivity'

namespace functor
def injectivity (F : C ⥤ D) [faithful F] {X Y : C} {f g : X ⟶ Y} (p : F.map f = F.map g) : f = g :=
faithful.injectivity F p

def preimage (F : C ⥤ D) [full F] {X Y : C} (f : F X ⟶ F Y) : X ⟶ Y := full.preimage.{u₁ v₁ u₂ v₂}  f
@[simp] lemma image_preimage (F : C ⥤ D) [full F] {X Y : C} (f : F X ⟶ F Y) : F.map (preimage F f) = f := begin unfold preimage, obviously end
end functor

section
variables {F : C ⥤ D} [full F] [faithful F] {X Y : C}
def preimage_iso (f : (F X) ≅ (F Y)) : X ≅ Y :=
{ hom := F.preimage (f : F X ⟶ F Y),
  inv := F.preimage (f.symm : F Y ⟶ F X),
  hom_inv_id' := begin apply @faithful.injectivity _ _ _ _ F, obviously, end,
  inv_hom_id' := begin apply @faithful.injectivity _ _ _ _ F, obviously, end, }

@[simp] lemma preimage_iso_coe (f : (F X) ≅ (F Y)) : ((preimage_iso f) : X ⟶ Y) = F.preimage (f : F X ⟶ F Y) := rfl
@[simp] lemma preimage_iso_symm_coe (f : (F X) ≅ (F Y)) : ((preimage_iso f).symm : Y ⟶ X) = F.preimage (f.symm : F Y ⟶ F X) := rfl
end

class embedding (F : C ⥤ D) extends (full F), (faithful F).
end category_theory

namespace category_theory

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

instance full.id : full (functor.id C) :=
{ preimage := λ _ _ f, f }

instance : faithful (functor.id C) := by obviously

instance : embedding (functor.id C) := { ((by apply_instance) : full (functor.id C)) with }

variables {D : Type u₂} [𝒟 : category.{u₂ v₂} D] {E : Type u₃} [ℰ : category.{u₃ v₃} E]
include 𝒟 ℰ
variables (F : C ⥤ D) (G : D ⥤ E)

instance faithful.comp [faithful F] [faithful G] : faithful (F ⋙ G) :=
{ injectivity' := λ _ _ _ _ p, F.injectivity (G.injectivity p) }
instance full.comp [full F] [full G] : full (F ⋙ G) :=
{ preimage := λ _ _ f, F.preimage (G.preimage f) }

end category_theory