/-
Copyright (c) 2020 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.algebra.char_p.default
import Mathlib.algebra.ring.pi
import Mathlib.analysis.special_functions.pow
import Mathlib.field_theory.perfect_closure
import Mathlib.ring_theory.localization
import Mathlib.ring_theory.subring
import Mathlib.ring_theory.valuation.integers
import Mathlib.PostPort

universes u₁ u₂ l u₃ u₄

namespace Mathlib

/-!
# Ring Perfection and Tilt

In this file we define the perfection of a ring of characteristic p, and the tilt of a field
given a valuation to `ℝ≥0`.

## TODO

Define the valuation on the tilt, and define a characteristic predicate for the tilt.

-/

/-- The perfection of a monoid `M`, defined to be the projective limit of `M`
using the `p`-th power maps `M → M` indexed by the natural numbers, implemented as
`{ f : ℕ → M | ∀ n, f (n + 1) ^ p = f n }`. -/
def monoid.perfection (M : Type u₁) [comm_monoid M] (p : ℕ) : submonoid (ℕ → M) :=
  submonoid.mk (set_of fun (f : ℕ → M) => ∀ (n : ℕ), f (n + 1) ^ p = f n) sorry sorry

/-- The perfection of a ring `R` with characteristic `p`,
defined to be the projective limit of `R` using the Frobenius maps `R → R`
indexed by the natural numbers, implemented as `{ f : ℕ → R | ∀ n, f (n + 1) ^ p = f n }`. -/
def ring.perfection (R : Type u₁) [comm_semiring R] (p : ℕ) [hp : fact (nat.prime p)] [char_p R p] :
    subsemiring (ℕ → R) :=
  subsemiring.mk (submonoid.carrier (monoid.perfection R p)) sorry sorry sorry sorry

namespace perfection

/-- The `n`-th coefficient of an element of the perfection. -/
def coeff (R : Type u₁) [comm_semiring R] (p : ℕ) [hp : fact (nat.prime p)] [char_p R p] (n : ℕ) :
    ↥(ring.perfection R p) →+* R :=
  ring_hom.mk (fun (f : ↥(ring.perfection R p)) => subtype.val f n) sorry sorry sorry sorry

theorem ext {R : Type u₁} [comm_semiring R] {p : ℕ} [hp : fact (nat.prime p)] [char_p R p]
    {f : ↥(ring.perfection R p)} {g : ↥(ring.perfection R p)}
    (h : ∀ (n : ℕ), coe_fn (coeff R p n) f = coe_fn (coeff R p n) g) : f = g :=
  subtype.eq (funext h)

/-- The `p`-th root of an element of the perfection. -/
def pth_root (R : Type u₁) [comm_semiring R] (p : ℕ) [hp : fact (nat.prime p)] [char_p R p] :
    ↥(ring.perfection R p) →+* ↥(ring.perfection R p) :=
  ring_hom.mk
    (fun (f : ↥(ring.perfection R p)) =>
      { val := fun (n : ℕ) => coe_fn (coeff R p (n + 1)) f, property := sorry })
    sorry sorry sorry sorry

@[simp] theorem coeff_mk {R : Type u₁} [comm_semiring R] {p : ℕ} [hp : fact (nat.prime p)]
    [char_p R p] (f : ℕ → R) (hf : f ∈ ring.perfection R p) (n : ℕ) :
    coe_fn (coeff R p n) { val := f, property := hf } = f n :=
  rfl

theorem coeff_pth_root {R : Type u₁} [comm_semiring R] {p : ℕ} [hp : fact (nat.prime p)]
    [char_p R p] (f : ↥(ring.perfection R p)) (n : ℕ) :
    coe_fn (coeff R p n) (coe_fn (pth_root R p) f) = coe_fn (coeff R p (n + 1)) f :=
  rfl

theorem coeff_pow_p {R : Type u₁} [comm_semiring R] {p : ℕ} [hp : fact (nat.prime p)] [char_p R p]
    (f : ↥(ring.perfection R p)) (n : ℕ) :
    coe_fn (coeff R p (n + 1)) (f ^ p) = coe_fn (coeff R p n) f :=
  sorry

theorem coeff_pow_p' {R : Type u₁} [comm_semiring R] {p : ℕ} [hp : fact (nat.prime p)] [char_p R p]
    (f : ↥(ring.perfection R p)) (n : ℕ) :
    coe_fn (coeff R p (n + 1)) f ^ p = coe_fn (coeff R p n) f :=
  subtype.property f n

theorem coeff_frobenius {R : Type u₁} [comm_semiring R] {p : ℕ} [hp : fact (nat.prime p)]
    [char_p R p] (f : ↥(ring.perfection R p)) (n : ℕ) :
    coe_fn (coeff R p (n + 1)) (coe_fn (frobenius (↥(ring.perfection R p)) p) f) =
        coe_fn (coeff R p n) f :=
  sorry

theorem coeff_iterate_frobenius {R : Type u₁} [comm_semiring R] {p : ℕ} [hp : fact (nat.prime p)]
    [char_p R p] (f : ↥(ring.perfection R p)) (n : ℕ) (m : ℕ) :
    coe_fn (coeff R p (n + m)) (nat.iterate (⇑(frobenius (↥(ring.perfection R p)) p)) m f) =
        coe_fn (coeff R p n) f :=
  sorry

theorem coeff_iterate_frobenius' {R : Type u₁} [comm_semiring R] {p : ℕ} [hp : fact (nat.prime p)]
    [char_p R p] (f : ↥(ring.perfection R p)) (n : ℕ) (m : ℕ) (hmn : m ≤ n) :
    coe_fn (coeff R p n) (nat.iterate (⇑(frobenius (↥(ring.perfection R p)) p)) m f) =
        coe_fn (coeff R p (n - m)) f :=
  Eq.symm
    (Eq.trans (Eq.symm (coeff_iterate_frobenius f (n - m) m))
      (Eq.symm (nat.sub_add_cancel hmn) ▸ rfl))

theorem pth_root_frobenius {R : Type u₁} [comm_semiring R] {p : ℕ} [hp : fact (nat.prime p)]
    [char_p R p] :
    ring_hom.comp (pth_root R p) (frobenius (↥(ring.perfection R p)) p) =
        ring_hom.id ↥(ring.perfection R p) :=
  sorry

theorem frobenius_pth_root {R : Type u₁} [comm_semiring R] {p : ℕ} [hp : fact (nat.prime p)]
    [char_p R p] :
    ring_hom.comp (frobenius (↥(ring.perfection R p)) p) (pth_root R p) =
        ring_hom.id ↥(ring.perfection R p) :=
  sorry

theorem coeff_add_ne_zero {R : Type u₁} [comm_semiring R] {p : ℕ} [hp : fact (nat.prime p)]
    [char_p R p] {f : ↥(ring.perfection R p)} {n : ℕ} (hfn : coe_fn (coeff R p n) f ≠ 0) (k : ℕ) :
    coe_fn (coeff R p (n + k)) f ≠ 0 :=
  sorry

theorem coeff_ne_zero_of_le {R : Type u₁} [comm_semiring R] {p : ℕ} [hp : fact (nat.prime p)]
    [char_p R p] {f : ↥(ring.perfection R p)} {m : ℕ} {n : ℕ} (hfm : coe_fn (coeff R p m) f ≠ 0)
    (hmn : m ≤ n) : coe_fn (coeff R p n) f ≠ 0 :=
  sorry

protected instance perfect_ring (R : Type u₁) [comm_semiring R] (p : ℕ) [hp : fact (nat.prime p)]
    [char_p R p] : perfect_ring (↥(ring.perfection R p)) p :=
  perfect_ring.mk ⇑(pth_root R p) sorry sorry

protected instance ring (p : ℕ) [hp : fact (nat.prime p)] (R : Type u₁) [comm_ring R] [char_p R p] :
    ring ↥(ring.perfection R p) :=
  subring.to_ring (subsemiring.to_subring (ring.perfection R p) sorry)

protected instance comm_ring (p : ℕ) [hp : fact (nat.prime p)] (R : Type u₁) [comm_ring R]
    [char_p R p] : comm_ring ↥(ring.perfection R p) :=
  subring.to_comm_ring (subsemiring.to_subring (ring.perfection R p) sorry)

/-- Given rings `R` and `S` of characteristic `p`, with `R` being perfect,
any homomorphism `R →+* S` can be lifted to a homomorphism `R →+* perfection S p`. -/
@[simp] theorem lift_symm_apply (p : ℕ) [hp : fact (nat.prime p)] (R : Type u₁) [comm_semiring R]
    [char_p R p] [perfect_ring R p] (S : Type u₂) [comm_semiring S] [char_p S p]
    (hmn : R →+* ↥(ring.perfection S p)) :
    coe_fn (equiv.symm (lift p R S)) hmn = ring_hom.comp (coeff S p 0) hmn :=
  Eq.refl (coe_fn (equiv.symm (lift p R S)) hmn)

theorem hom_ext (p : ℕ) [hp : fact (nat.prime p)] {R : Type u₁} [comm_semiring R] [char_p R p]
    [perfect_ring R p] {S : Type u₂} [comm_semiring S] [char_p S p]
    {f : R →+* ↥(ring.perfection S p)} {g : R →+* ↥(ring.perfection S p)}
    (hfg : ∀ (x : R), coe_fn (coeff S p 0) (coe_fn f x) = coe_fn (coeff S p 0) (coe_fn g x)) :
    f = g :=
  equiv.injective (equiv.symm (lift p R S)) (ring_hom.ext hfg)

/-- A ring homomorphism `R →+* S` induces `perfection R p →+* perfection S p` -/
@[simp] theorem map_apply_coe {R : Type u₁} [comm_semiring R] (p : ℕ) [hp : fact (nat.prime p)]
    [char_p R p] {S : Type u₂} [comm_semiring S] [char_p S p] (φ : R →+* S)
    (f : ↥(ring.perfection R p)) (n : ℕ) :
    coe (coe_fn (map p φ) f) n = coe_fn φ (coe_fn (coeff R p n) f) :=
  Eq.refl (coe (coe_fn (map p φ) f) n)

theorem coeff_map {R : Type u₁} [comm_semiring R] (p : ℕ) [hp : fact (nat.prime p)] [char_p R p]
    {S : Type u₂} [comm_semiring S] [char_p S p] (φ : R →+* S) (f : ↥(ring.perfection R p))
    (n : ℕ) : coe_fn (coeff S p n) (coe_fn (map p φ) f) = coe_fn φ (coe_fn (coeff R p n) f) :=
  rfl

end perfection

/-- A perfection map to a ring of characteristic `p` is a map that is isomorphic
to its perfection. -/
structure perfection_map (p : ℕ) [fact (nat.prime p)] {R : Type u₁} [comm_semiring R] [char_p R p]
    {P : Type u₂} [comm_semiring P] [char_p P p] [perfect_ring P p] (π : P →+* R)
    where
  injective :
    ∀ {x y : P},
      (∀ (n : ℕ),
          coe_fn π (nat.iterate (⇑(pth_root P p)) n x) =
            coe_fn π (nat.iterate (⇑(pth_root P p)) n y)) →
        x = y
  surjective :
    ∀ (f : ℕ → R),
      (∀ (n : ℕ), f (n + 1) ^ p = f n) →
        ∃ (x : P), ∀ (n : ℕ), coe_fn π (nat.iterate (⇑(pth_root P p)) n x) = f n

namespace perfection_map

/-- Create a `perfection_map` from an isomorphism to the perfection. -/
theorem mk' {p : ℕ} [fact (nat.prime p)] {R : Type u₁} [comm_semiring R] [char_p R p] {P : Type u₃}
    [comm_semiring P] [char_p P p] [perfect_ring P p] {f : P →+* R}
    (g : P ≃+* ↥(ring.perfection R p)) (hfg : coe_fn (perfection.lift p P R) f = ↑g) :
    perfection_map p f :=
  sorry

/-- The canonical perfection map from the perfection of a ring. -/
theorem of (p : ℕ) [fact (nat.prime p)] (R : Type u₁) [comm_semiring R] [char_p R p] :
    perfection_map p (perfection.coeff R p 0) :=
  mk' (ring_equiv.refl ↥(ring.perfection R p))
    (iff.mpr (equiv.apply_eq_iff_eq_symm_apply (perfection.lift p (↥(ring.perfection R p)) R)) rfl)

/-- For a perfect ring, it itself is the perfection. -/
theorem id (p : ℕ) [fact (nat.prime p)] (R : Type u₁) [comm_semiring R] [char_p R p]
    [perfect_ring R p] : perfection_map p (ring_hom.id R) :=
  sorry

/-- A perfection map induces an isomorphism to the prefection. -/
def equiv {p : ℕ} [fact (nat.prime p)] {R : Type u₁} [comm_semiring R] [char_p R p] {P : Type u₃}
    [comm_semiring P] [char_p P p] [perfect_ring P p] {π : P →+* R} (m : perfection_map p π) :
    P ≃+* ↥(ring.perfection R p) :=
  ring_equiv.of_bijective (coe_fn (perfection.lift p P R) π) sorry

theorem equiv_apply {p : ℕ} [fact (nat.prime p)] {R : Type u₁} [comm_semiring R] [char_p R p]
    {P : Type u₃} [comm_semiring P] [char_p P p] [perfect_ring P p] {π : P →+* R}
    (m : perfection_map p π) (x : P) :
    coe_fn (equiv m) x = coe_fn (coe_fn (perfection.lift p P R) π) x :=
  rfl

theorem comp_equiv {p : ℕ} [fact (nat.prime p)] {R : Type u₁} [comm_semiring R] [char_p R p]
    {P : Type u₃} [comm_semiring P] [char_p P p] [perfect_ring P p] {π : P →+* R}
    (m : perfection_map p π) (x : P) :
    coe_fn (perfection.coeff R p 0) (coe_fn (equiv m) x) = coe_fn π x :=
  rfl

theorem comp_equiv' {p : ℕ} [fact (nat.prime p)] {R : Type u₁} [comm_semiring R] [char_p R p]
    {P : Type u₃} [comm_semiring P] [char_p P p] [perfect_ring P p] {π : P →+* R}
    (m : perfection_map p π) : ring_hom.comp (perfection.coeff R p 0) ↑(equiv m) = π :=
  ring_hom.ext fun (x : P) => rfl

theorem comp_symm_equiv {p : ℕ} [fact (nat.prime p)] {R : Type u₁} [comm_semiring R] [char_p R p]
    {P : Type u₃} [comm_semiring P] [char_p P p] [perfect_ring P p] {π : P →+* R}
    (m : perfection_map p π) (f : ↥(ring.perfection R p)) :
    coe_fn π (coe_fn (ring_equiv.symm (equiv m)) f) = coe_fn (perfection.coeff R p 0) f :=
  Eq.trans (Eq.symm (comp_equiv m (coe_fn (ring_equiv.symm (equiv m)) f)))
    (congr_arg (⇑(perfection.coeff R p 0)) (ring_equiv.apply_symm_apply (equiv m) f))

theorem comp_symm_equiv' {p : ℕ} [fact (nat.prime p)] {R : Type u₁} [comm_semiring R] [char_p R p]
    {P : Type u₃} [comm_semiring P] [char_p P p] [perfect_ring P p] {π : P →+* R}
    (m : perfection_map p π) :
    ring_hom.comp π ↑(ring_equiv.symm (equiv m)) = perfection.coeff R p 0 :=
  ring_hom.ext (comp_symm_equiv m)

/-- Given rings `R` and `S` of characteristic `p`, with `R` being perfect,
any homomorphism `R →+* S` can be lifted to a homomorphism `R →+* P`,
where `P` is any perfection of `S`. -/
@[simp] theorem lift_apply (p : ℕ) [fact (nat.prime p)] (R : Type u₁) [comm_semiring R] [char_p R p]
    [perfect_ring R p] (S : Type u₂) [comm_semiring S] [char_p S p] (P : Type u₃) [comm_semiring P]
    [char_p P p] [perfect_ring P p] (π : P →+* S) (m : perfection_map p π) (f : R →+* S) :
    coe_fn (lift p R S P π m) f =
        ring_hom.comp (↑(ring_equiv.symm (equiv m))) (coe_fn (perfection.lift p R S) f) :=
  Eq.refl (coe_fn (lift p R S P π m) f)

theorem hom_ext {p : ℕ} [fact (nat.prime p)] {R : Type u₁} [comm_semiring R] [char_p R p]
    [perfect_ring R p] {S : Type u₂} [comm_semiring S] [char_p S p] {P : Type u₃} [comm_semiring P]
    [char_p P p] [perfect_ring P p] (π : P →+* S) (m : perfection_map p π) {f : R →+* P}
    {g : R →+* P} (hfg : ∀ (x : R), coe_fn π (coe_fn f x) = coe_fn π (coe_fn g x)) : f = g :=
  equiv.injective (equiv.symm (lift p R S P π m)) (ring_hom.ext hfg)

/-- A ring homomorphism `R →+* S` induces `P →+* Q`, a map of the respective perfections -/
def map (p : ℕ) [fact (nat.prime p)] {R : Type u₁} [comm_semiring R] [char_p R p] {P : Type u₃}
    [comm_semiring P] [char_p P p] [perfect_ring P p] {S : Type u₂} [comm_semiring S] [char_p S p]
    {Q : Type u₄} [comm_semiring Q] [char_p Q p] [perfect_ring Q p] {π : P →+* R}
    (m : perfection_map p π) {σ : Q →+* S} (n : perfection_map p σ) (φ : R →+* S) : P →+* Q :=
  coe_fn (lift p P S Q σ n) (ring_hom.comp φ π)

theorem comp_map (p : ℕ) [fact (nat.prime p)] {R : Type u₁} [comm_semiring R] [char_p R p]
    {P : Type u₃} [comm_semiring P] [char_p P p] [perfect_ring P p] {S : Type u₂} [comm_semiring S]
    [char_p S p] {Q : Type u₄} [comm_semiring Q] [char_p Q p] [perfect_ring Q p] {π : P →+* R}
    (m : perfection_map p π) {σ : Q →+* S} (n : perfection_map p σ) (φ : R →+* S) :
    ring_hom.comp σ (map p m n φ) = ring_hom.comp φ π :=
  equiv.symm_apply_apply (lift p P S Q σ n) (ring_hom.comp φ π)

theorem map_map (p : ℕ) [fact (nat.prime p)] {R : Type u₁} [comm_semiring R] [char_p R p]
    {P : Type u₃} [comm_semiring P] [char_p P p] [perfect_ring P p] {S : Type u₂} [comm_semiring S]
    [char_p S p] {Q : Type u₄} [comm_semiring Q] [char_p Q p] [perfect_ring Q p] {π : P →+* R}
    (m : perfection_map p π) {σ : Q →+* S} (n : perfection_map p σ) (φ : R →+* S) (x : P) :
    coe_fn σ (coe_fn (map p m n φ) x) = coe_fn φ (coe_fn π x) :=
  iff.mp ring_hom.ext_iff (comp_map p m n φ) x

-- Why is this slow?

theorem map_eq_map (p : ℕ) [fact (nat.prime p)] {R : Type u₁} [comm_semiring R] [char_p R p]
    {S : Type u₂} [comm_semiring S] [char_p S p] (φ : R →+* S) :
    map p (of p R) (of p S) φ = perfection.map p φ :=
  sorry

end perfection_map

/-- `O/(p)` for `O`, ring of integers of `K`. -/
def mod_p (K : Type u₁) [field K] (v : valuation K nnreal) (O : Type u₂) [comm_ring O] [algebra O K]
    (hv : valuation.integers v O) (p : ℕ) :=
  ideal.quotient (ideal.span (singleton ↑p))

namespace mod_p

protected instance comm_ring (K : Type u₁) [field K] (v : valuation K nnreal) (O : Type u₂)
    [comm_ring O] [algebra O K] (hv : valuation.integers v O) (p : ℕ) :
    comm_ring (mod_p K v O hv p) :=
  ideal.quotient.comm_ring (ideal.span (singleton ↑p))

protected instance char_p (K : Type u₁) [field K] (v : valuation K nnreal) (O : Type u₂)
    [comm_ring O] [algebra O K] (hv : valuation.integers v O) (p : ℕ) [hp : fact (nat.prime p)]
    [hvp : fact (coe_fn v ↑p ≠ 1)] : char_p (mod_p K v O hv p) p :=
  char_p.quotient O p
    (mt (valuation.integers.one_of_is_unit hv)
      (Eq.symm (ring_hom.map_nat_cast (algebra_map O K) p) ▸ hvp))

protected instance nontrivial (K : Type u₁) [field K] (v : valuation K nnreal) (O : Type u₂)
    [comm_ring O] [algebra O K] (hv : valuation.integers v O) (p : ℕ) [hp : fact (nat.prime p)]
    [hvp : fact (coe_fn v ↑p ≠ 1)] : nontrivial (mod_p K v O hv p) :=
  char_p.nontrivial_of_char_ne_one (nat.prime.ne_one hp)

/-- For a field `K` with valuation `v : K → ℝ≥0` and ring of integers `O`,
a function `O/(p) → ℝ≥0` that sends `0` to `0` and `x + (p)` to `v(x)` as long as `x ∉ (p)`. -/
def pre_val (K : Type u₁) [field K] (v : valuation K nnreal) (O : Type u₂) [comm_ring O]
    [algebra O K] (hv : valuation.integers v O) (p : ℕ) (x : mod_p K v O hv p) : nnreal :=
  ite (x = 0) 0 (coe_fn v (coe_fn (algebra_map O K) (quotient.out' x)))

theorem pre_val_mk {K : Type u₁} [field K] {v : valuation K nnreal} {O : Type u₂} [comm_ring O]
    [algebra O K] {hv : valuation.integers v O} {p : ℕ} {x : O}
    (hx : coe_fn (ideal.quotient.mk (ideal.span (singleton ↑p))) x ≠ 0) :
    pre_val K v O hv p (coe_fn (ideal.quotient.mk (ideal.span (singleton ↑p))) x) =
        coe_fn v (coe_fn (algebra_map O K) x) :=
  sorry

theorem pre_val_zero {K : Type u₁} [field K] {v : valuation K nnreal} {O : Type u₂} [comm_ring O]
    [algebra O K] {hv : valuation.integers v O} {p : ℕ} : pre_val K v O hv p 0 = 0 :=
  if_pos rfl

theorem pre_val_mul {K : Type u₁} [field K] {v : valuation K nnreal} {O : Type u₂} [comm_ring O]
    [algebra O K] {hv : valuation.integers v O} {p : ℕ} {x : mod_p K v O hv p}
    {y : mod_p K v O hv p} (hxy0 : x * y ≠ 0) :
    pre_val K v O hv p (x * y) = pre_val K v O hv p x * pre_val K v O hv p y :=
  sorry

theorem pre_val_add {K : Type u₁} [field K] {v : valuation K nnreal} {O : Type u₂} [comm_ring O]
    [algebra O K] {hv : valuation.integers v O} {p : ℕ} (x : mod_p K v O hv p)
    (y : mod_p K v O hv p) :
    pre_val K v O hv p (x + y) ≤ max (pre_val K v O hv p x) (pre_val K v O hv p y) :=
  sorry

theorem v_p_lt_pre_val {K : Type u₁} [field K] {v : valuation K nnreal} {O : Type u₂} [comm_ring O]
    [algebra O K] {hv : valuation.integers v O} {p : ℕ} {x : mod_p K v O hv p} :
    coe_fn v ↑p < pre_val K v O hv p x ↔ x ≠ 0 :=
  sorry

theorem pre_val_eq_zero {K : Type u₁} [field K] {v : valuation K nnreal} {O : Type u₂} [comm_ring O]
    [algebra O K] {hv : valuation.integers v O} {p : ℕ} {x : mod_p K v O hv p} :
    pre_val K v O hv p x = 0 ↔ x = 0 :=
  sorry

theorem v_p_lt_val {K : Type u₁} [field K] {v : valuation K nnreal} {O : Type u₂} [comm_ring O]
    [algebra O K] (hv : valuation.integers v O) {p : ℕ} {x : O} :
    coe_fn v ↑p < coe_fn v (coe_fn (algebra_map O K) x) ↔
        coe_fn (ideal.quotient.mk (ideal.span (singleton ↑p))) x ≠ 0 :=
  sorry

theorem mul_ne_zero_of_pow_p_ne_zero {K : Type u₁} [field K] {v : valuation K nnreal} {O : Type u₂}
    [comm_ring O] [algebra O K] {hv : valuation.integers v O} {p : ℕ} [hp : fact (nat.prime p)]
    {x : mod_p K v O hv p} {y : mod_p K v O hv p} (hx : x ^ p ≠ 0) (hy : y ^ p ≠ 0) : x * y ≠ 0 :=
  sorry

end mod_p

/-- Perfection of `O/(p)` where `O` is the ring of integers of `K`. -/
def pre_tilt (K : Type u₁) [field K] (v : valuation K nnreal) (O : Type u₂) [comm_ring O]
    [algebra O K] (hv : valuation.integers v O) (p : ℕ) [hp : fact (nat.prime p)]
    [hvp : fact (coe_fn v ↑p ≠ 1)] : subsemiring (ℕ → mod_p K v O hv p) :=
  ring.perfection (mod_p K v O hv p) p

namespace pre_tilt

protected instance comm_ring (K : Type u₁) [field K] (v : valuation K nnreal) (O : Type u₂)
    [comm_ring O] [algebra O K] (hv : valuation.integers v O) (p : ℕ) [hp : fact (nat.prime p)]
    [hvp : fact (coe_fn v ↑p ≠ 1)] : comm_ring ↥(pre_tilt K v O hv p) :=
  perfection.comm_ring p (mod_p K v O hv p)

/-- The valuation `Perfection(O/(p)) → ℝ≥0` as a function.
Given `f ∈ Perfection(O/(p))`, if `f = 0` then output `0`;
otherwise output `pre_val(f(n))^(p^n)` for any `n` such that `f(n) ≠ 0`. -/
def val_aux (K : Type u₁) [field K] (v : valuation K nnreal) (O : Type u₂) [comm_ring O]
    [algebra O K] (hv : valuation.integers v O) (p : ℕ) [hp : fact (nat.prime p)]
    [hvp : fact (coe_fn v ↑p ≠ 1)] (f : ↥(pre_tilt K v O hv p)) : nnreal :=
  dite (∃ (n : ℕ), coe_fn (perfection.coeff (mod_p K v O hv p) p n) f ≠ 0)
    (fun (h : ∃ (n : ℕ), coe_fn (perfection.coeff (mod_p K v O hv p) p n) f ≠ 0) =>
      mod_p.pre_val K v O hv p (coe_fn (perfection.coeff (mod_p K v O hv p) p (nat.find h)) f) ^
        p ^ nat.find h)
    fun (h : ¬∃ (n : ℕ), coe_fn (perfection.coeff (mod_p K v O hv p) p n) f ≠ 0) => 0

theorem coeff_nat_find_add_ne_zero {K : Type u₁} [field K] {v : valuation K nnreal} {O : Type u₂}
    [comm_ring O] [algebra O K] {hv : valuation.integers v O} {p : ℕ} [hp : fact (nat.prime p)]
    [hvp : fact (coe_fn v ↑p ≠ 1)] {f : ↥(pre_tilt K v O hv p)}
    {h : ∃ (n : ℕ), coe_fn (perfection.coeff (mod_p K v O hv p) p n) f ≠ 0} (k : ℕ) :
    coe_fn (perfection.coeff (mod_p K v O hv p) p (nat.find h + k)) f ≠ 0 :=
  perfection.coeff_add_ne_zero (nat.find_spec h) k

theorem val_aux_eq {K : Type u₁} [field K] {v : valuation K nnreal} {O : Type u₂} [comm_ring O]
    [algebra O K] {hv : valuation.integers v O} {p : ℕ} [hp : fact (nat.prime p)]
    [hvp : fact (coe_fn v ↑p ≠ 1)] {f : ↥(pre_tilt K v O hv p)} {n : ℕ}
    (hfn : coe_fn (perfection.coeff (mod_p K v O hv p) p n) f ≠ 0) :
    val_aux K v O hv p f =
        mod_p.pre_val K v O hv p (coe_fn (perfection.coeff (mod_p K v O hv p) p n) f) ^ p ^ n :=
  sorry

theorem val_aux_zero {K : Type u₁} [field K] {v : valuation K nnreal} {O : Type u₂} [comm_ring O]
    [algebra O K] {hv : valuation.integers v O} {p : ℕ} [hp : fact (nat.prime p)]
    [hvp : fact (coe_fn v ↑p ≠ 1)] : val_aux K v O hv p 0 = 0 :=
  sorry

theorem val_aux_one {K : Type u₁} [field K] {v : valuation K nnreal} {O : Type u₂} [comm_ring O]
    [algebra O K] {hv : valuation.integers v O} {p : ℕ} [hp : fact (nat.prime p)]
    [hvp : fact (coe_fn v ↑p ≠ 1)] : val_aux K v O hv p 1 = 1 :=
  sorry

theorem val_aux_mul {K : Type u₁} [field K] {v : valuation K nnreal} {O : Type u₂} [comm_ring O]
    [algebra O K] {hv : valuation.integers v O} {p : ℕ} [hp : fact (nat.prime p)]
    [hvp : fact (coe_fn v ↑p ≠ 1)] (f : ↥(pre_tilt K v O hv p)) (g : ↥(pre_tilt K v O hv p)) :
    val_aux K v O hv p (f * g) = val_aux K v O hv p f * val_aux K v O hv p g :=
  sorry

theorem val_aux_add {K : Type u₁} [field K] {v : valuation K nnreal} {O : Type u₂} [comm_ring O]
    [algebra O K] {hv : valuation.integers v O} {p : ℕ} [hp : fact (nat.prime p)]
    [hvp : fact (coe_fn v ↑p ≠ 1)] (f : ↥(pre_tilt K v O hv p)) (g : ↥(pre_tilt K v O hv p)) :
    val_aux K v O hv p (f + g) ≤ max (val_aux K v O hv p f) (val_aux K v O hv p g) :=
  sorry

/-- The valuation `Perfection(O/(p)) → ℝ≥0`.
Given `f ∈ Perfection(O/(p))`, if `f = 0` then output `0`;
otherwise output `pre_val(f(n))^(p^n)` for any `n` such that `f(n) ≠ 0`. -/
def val (K : Type u₁) [field K] (v : valuation K nnreal) (O : Type u₂) [comm_ring O] [algebra O K]
    (hv : valuation.integers v O) (p : ℕ) [hp : fact (nat.prime p)] [hvp : fact (coe_fn v ↑p ≠ 1)] :
    valuation (↥(pre_tilt K v O hv p)) nnreal :=
  valuation.mk (val_aux K v O hv p) val_aux_zero val_aux_one val_aux_mul val_aux_add

theorem map_eq_zero {K : Type u₁} [field K] {v : valuation K nnreal} {O : Type u₂} [comm_ring O]
    [algebra O K] {hv : valuation.integers v O} {p : ℕ} [hp : fact (nat.prime p)]
    [hvp : fact (coe_fn v ↑p ≠ 1)] {f : ↥(pre_tilt K v O hv p)} :
    coe_fn (val K v O hv p) f = 0 ↔ f = 0 :=
  sorry

protected instance integral_domain (K : Type u₁) [field K] (v : valuation K nnreal) (O : Type u₂)
    [comm_ring O] [algebra O K] (hv : valuation.integers v O) (p : ℕ) [hp : fact (nat.prime p)]
    [hvp : fact (coe_fn v ↑p ≠ 1)] : integral_domain ↥(pre_tilt K v O hv p) :=
  integral_domain.mk comm_ring.add sorry comm_ring.zero sorry sorry comm_ring.neg comm_ring.sub
    sorry sorry comm_ring.mul sorry comm_ring.one sorry sorry sorry sorry sorry sorry sorry

end pre_tilt

/-- The tilt of a field, as defined in Perfectoid Spaces by Peter Scholze, as in
[scholze2011perfectoid]. Given a field `K` with valuation `K → ℝ≥0` and ring of integers `O`,
this is implemented as the fraction field of the perfection of `O/(p)`. -/
def tilt (K : Type u₁) [field K] (v : valuation K nnreal) (O : Type u₂) [comm_ring O] [algebra O K]
    (hv : valuation.integers v O) (p : ℕ) [hp : fact (nat.prime p)]
    [hvp : fact (coe_fn v ↑p ≠ 1)] :=
  fraction_ring ↥(pre_tilt K v O hv p)

namespace tilt

protected instance field (K : Type u₁) [field K] (v : valuation K nnreal) (O : Type u₂)
    [comm_ring O] [algebra O K] (hv : valuation.integers v O) (p : ℕ) [hp : fact (nat.prime p)]
    [hvp : fact (coe_fn v ↑p ≠ 1)] : field (tilt K v O hv p) :=
  fraction_ring.field

end Mathlib


import Mathlib.Data.Nat.Basic
import Mathlib.Init.Algebra.Order
import Mathlib.Init.Data.Nat.Basic
import Mathlib.Init.Data.Nat.Lemmas
import Mathlib.Data.Equiv.Basic
import Mathlib.Init.Function
import Mathlib.Data.Fin.Basic
import Timelib.Util
import Timelib.NanoPrecision.Duration.SignedDuration
import Timelib.NanoPrecision.Duration.UnsignedDuration
import Lean.Data.Json

structure NaiveClockTime where
  nanos : Fin oneDayNanos
deriving DecidableEq, Ord, Hashable, Repr, Lean.ToJson, Lean.FromJson

section NaiveClockTimeStuff

variable (t : NaiveClockTime)

instance : Inhabited <| NaiveClockTime := ⟨0, Nat.zero_lt_succ _⟩

theorem NaiveClockTime.eq_of_val_eq : ∀ {t₁ t₂ : NaiveClockTime} (h : t₁.nanos = t₂.nanos), t₁ = t₂
| ⟨_, _⟩, ⟨_, _⟩, rfl => rfl

/-- Addition of a `Duration` to a `NaiveClockTime`; wraps into the next clock cycle. -/
instance : HAdd NaiveClockTime SignedDuration NaiveClockTime where
  hAdd t d := ⟨t.nanos + Fin.ofInt'' d.val⟩

instance : HAdd SignedDuration NaiveClockTime NaiveClockTime where
  hAdd t d := d + t

theorem NaiveClockTime.hAdd_signed_def (dur : SignedDuration) : t + dur = ⟨t.nanos + Fin.ofInt'' dur.val⟩ := rfl

theorem NaiveClockTime.hAdd_comm (t : NaiveClockTime) (d : SignedDuration) : t + d = d + t := rfl
theorem NaiveClockTime.hAdd_assoc (t : NaiveClockTime) (d₁ d₂ : SignedDuration) : (t + d₁) + d₂ = t + (d₁ + d₂ ):= sorry

/--
Subtraction of a `Duration` from a `NaiveClockTime`; the implementation follows
that of `Fin n`, wrapping into the previous clock cycle on underflow
-/
instance : HSub NaiveClockTime SignedDuration NaiveClockTime where
  hSub t d := ⟨t.nanos - Fin.ofInt'' d.val⟩

theorem NaiveClockTime.hSub_signed_def (dur : SignedDuration) : t - dur = ⟨t.nanos - Fin.ofInt'' dur.val⟩ := rfl

def NaiveClockTime.nanoComponent (t : NaiveClockTime) : Nat := t.nanos.val % oneSecondNanos
def NaiveClockTime.secondComponent (t : NaiveClockTime) : Nat := (t.nanos.val % oneMinuteNanos) / oneSecondNanos
def NaiveClockTime.minuteComponent (t : NaiveClockTime) : Nat := (t.nanos.val % oneHourNanos) / oneMinuteNanos
def NaiveClockTime.hourComponent (t : NaiveClockTime) : Nat := t.nanos.val / oneHourNanos
def NaiveClockTime.asNanos   : Nat := t.nanos
def NaiveClockTime.asSeconds : Nat := t.nanos / oneSecondNanos
def NaiveClockTime.asMinutes : Nat := t.nanos / oneMinuteNanos
def NaiveClockTime.asHours   : Nat := t.nanos / oneHourNanos

def NaiveClockTime.fromSignedDuration (duration : SignedDuration) : NaiveClockTime :=
  ⟨(Fin.ofInt'' duration.val) % oneDayNanos⟩

def NaiveClockTime.fromHmsn (h : Nat) (m : Nat) (s : Nat) (n : Nat) : NaiveClockTime :=
  NaiveClockTime.fromSignedDuration ⟨(h * oneHourNanos) + (m * oneMinuteNanos) + (s * oneSecondNanos) + n⟩

instance : LT NaiveClockTime where
  lt := InvImage instLTFin.lt NaiveClockTime.nanos

instance : LE NaiveClockTime where
  le := InvImage instLEFin.le NaiveClockTime.nanos

@[simp] theorem NaiveClockTime.le_def (d₁ d₂ : NaiveClockTime) : (d₁ <= d₂) = (d₁.nanos <= d₂.nanos) := rfl
@[simp] theorem NaiveClockTime.lt_def (d₁ d₂ : NaiveClockTime) : (d₁ < d₂) = (d₁.nanos < d₂.nanos) := rfl

instance instDecidableLENaiveClockTime (a b : NaiveClockTime) : Decidable (a <= b) := inferInstanceAs (Decidable (a.nanos <= b.nanos))
instance instDecidableLTNaiveClockTime (a b : NaiveClockTime) : Decidable (a < b) := inferInstanceAs (Decidable (a.nanos < b.nanos))

instance : Equiv (Fin oneDayNanos) NaiveClockTime where
  toFun := NaiveClockTime.mk
  invFun := NaiveClockTime.nanos
  left_inv := by simp [Function.LeftInverse]
  right_inv := by simp [Function.RightInverse, Function.LeftInverse]

instance : LinearOrder NaiveClockTime where
  le_refl (a) := le_refl a.nanos
  le_trans (a b c) := Nat.le_trans
  lt_iff_le_not_le (a b) := Nat.lt_iff_le_not_le
  le_antisymm (a b h1 h2) := by
    apply NaiveClockTime.eq_of_val_eq
    exact le_antisymm h1 h2
  le_total := by simp [NaiveClockTime.le_def, le_total]
  decidable_le := inferInstance

instance : ToString NaiveClockTime where
  toString t :=
    let h := String.leftpad 2 '0' (ToString.toString $ t.hourComponent)
    let m := String.leftpad 2 '0' (ToString.toString $ t.minuteComponent)
    let s := String.leftpad 2 '0' (ToString.toString $ t.secondComponent)
    let n := String.leftpad 9 '0' (ToString.toString $ t.nanoComponent)
  s!"{h}:{m}:{s}.{n}"

end NaiveClockTimeStuff


/-
Copyright (c) 2017 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Stephen Morgan, Scott Morrison, Johannes Hölzl, Reid Barton
-/
import combinatorics.quiver
import tactic.basic

/-!
# Categories

Defines a category, as a type class parametrised by the type of objects.

## Notations

Introduces notations
* `X ⟶ Y` for the morphism spaces,
* `f ≫ g` for composition in the 'arrows' convention.

Users may like to add `f ⊚ g` for composition in the standard convention, using
```lean
local notation f ` ⊚ `:80 g:80 := category.comp g f    -- type as \oo
```
-/

/--
The typeclass `category C` describes morphisms associated to objects of type `C : Type u`.

The universe levels of the objects and morphisms are independent, and will often need to be
specified explicitly, as `category.{v} C`.

Typically any concrete example will either be a `small_category`, where `v = u`,
which can be introduced as
```
universes u
variables {C : Type u} [small_category C]
```
or a `large_category`, where `u = v+1`, which can be introduced as
```
universes u
variables {C : Type (u+1)} [large_category C]
```

In order for the library to handle these cases uniformly,
we generally work with the unconstrained `category.{v u}`,
for which objects live in `Type u` and morphisms live in `Type v`.

Because the universe parameter `u` for the objects can be inferred from `C`
when we write `category C`, while the universe parameter `v` for the morphisms
can not be automatically inferred, through the category theory library
we introduce universe parameters with morphism levels listed first,
as in
```
universes v u
```
or
```
universes v₁ v₂ u₁ u₂
```
when multiple independent universes are needed.

This has the effect that we can simply write `category.{v} C`
(that is, only specifying a single parameter) while `u` will be inferred.

Often, however, it's not even necessary to include the `.{v}`.
(Although it was in earlier versions of Lean.)
If it is omitted a "free" universe will be used.
-/
library_note "category_theory universes"

universes v u

namespace category_theory

/-- A preliminary structure on the way to defining a category,
containing the data, but none of the axioms. -/
class category_struct (obj : Type u)
extends quiver.{v+1} obj : Type (max u (v+1)) :=
(id       : Π X : obj, hom X X)
(comp     : Π {X Y Z : obj}, (X ⟶ Y) → (Y ⟶ Z) → (X ⟶ Z))

notation `𝟙` := category_struct.id -- type as \b1
infixr ` ≫ `:80 := category_struct.comp -- type as \gg

/--
The typeclass `category C` describes morphisms associated to objects of type `C`.
The universe levels of the objects and morphisms are unconstrained, and will often need to be
specified explicitly, as `category.{v} C`. (See also `large_category` and `small_category`.)

See https://stacks.math.columbia.edu/tag/0014.
-/
class category (obj : Type u)
extends category_struct.{v} obj : Type (max u (v+1)) :=
(id_comp' : ∀ {X Y : obj} (f : hom X Y), 𝟙 X ≫ f = f . obviously)
(comp_id' : ∀ {X Y : obj} (f : hom X Y), f ≫ 𝟙 Y = f . obviously)
(assoc'   : ∀ {W X Y Z : obj} (f : hom W X) (g : hom X Y) (h : hom Y Z),
  (f ≫ g) ≫ h = f ≫ (g ≫ h) . obviously)

-- `restate_axiom` is a command that creates a lemma from a structure field,
-- discarding any auto_param wrappers from the type.
-- (It removes a backtick from the name, if it finds one, and otherwise adds "_lemma".)
restate_axiom category.id_comp'
restate_axiom category.comp_id'
restate_axiom category.assoc'
attribute [simp] category.id_comp category.comp_id category.assoc
attribute [trans] category_struct.comp

/--
A `large_category` has objects in one universe level higher than the universe level of
the morphisms. It is useful for examples such as the category of types, or the category
of groups, etc.
-/
abbreviation large_category (C : Type (u+1)) : Type (u+1) := category.{u} C
/--
A `small_category` has objects and morphisms in the same universe level.
-/
abbreviation small_category (C : Type u) : Type (u+1) := category.{u} C

section
variables {C : Type u} [category.{v} C] {X Y Z : C}

/-- postcompose an equation between morphisms by another morphism -/
lemma eq_whisker {f g : X ⟶ Y} (w : f = g) (h : Y ⟶ Z) : f ≫ h = g ≫ h :=
by rw w
/-- precompose an equation between morphisms by another morphism -/
lemma whisker_eq (f : X ⟶ Y) {g h : Y ⟶ Z} (w : g = h) : f ≫ g = f ≫ h :=
by rw w

infixr ` =≫ `:80 := eq_whisker
infixr ` ≫= `:80 := whisker_eq

lemma eq_of_comp_left_eq {f g : X ⟶ Y} (w : ∀ {Z : C} (h : Y ⟶ Z), f ≫ h = g ≫ h) : f = g :=
by { convert w (𝟙 Y), tidy }
lemma eq_of_comp_right_eq {f g : Y ⟶ Z} (w : ∀ {X : C} (h : X ⟶ Y), h ≫ f = h ≫ g) : f = g :=
by { convert w (𝟙 Y), tidy }

lemma eq_of_comp_left_eq' (f g : X ⟶ Y)
  (w : (λ {Z : C} (h : Y ⟶ Z), f ≫ h) = (λ {Z : C} (h : Y ⟶ Z), g ≫ h)) : f = g :=
eq_of_comp_left_eq (λ Z h, by convert congr_fun (congr_fun w Z) h)
lemma eq_of_comp_right_eq' (f g : Y ⟶ Z)
  (w : (λ {X : C} (h : X ⟶ Y), h ≫ f) = (λ {X : C} (h : X ⟶ Y), h ≫ g)) : f = g :=
eq_of_comp_right_eq (λ X h, by convert congr_fun (congr_fun w X) h)

lemma id_of_comp_left_id (f : X ⟶ X) (w : ∀ {Y : C} (g : X ⟶ Y), f ≫ g = g) : f = 𝟙 X :=
by { convert w (𝟙 X), tidy }
lemma id_of_comp_right_id (f : X ⟶ X) (w : ∀ {Y : C} (g : Y ⟶ X), g ≫ f = g) : f = 𝟙 X :=
by { convert w (𝟙 X), tidy }

lemma comp_dite {P : Prop} [decidable P]
  {X Y Z : C} (f : X ⟶ Y) (g : P → (Y ⟶ Z)) (g' : ¬P → (Y ⟶ Z)) :
  (f ≫ if h : P then g h else g' h) = (if h : P then f ≫ g h else f ≫ g' h) :=
by { split_ifs; refl }

lemma dite_comp {P : Prop} [decidable P]
  {X Y Z : C} (f : P → (X ⟶ Y)) (f' : ¬P → (X ⟶ Y)) (g : Y ⟶ Z) :
  (if h : P then f h else f' h) ≫ g = (if h : P then f h ≫ g else f' h ≫ g) :=
by { split_ifs; refl }

/--
A morphism `f` is an epimorphism if it can be "cancelled" when precomposed:
`f ≫ g = f ≫ h` implies `g = h`.

See https://stacks.math.columbia.edu/tag/003B.
-/
class epi (f : X ⟶ Y) : Prop :=
(left_cancellation : Π {Z : C} (g h : Y ⟶ Z) (w : f ≫ g = f ≫ h), g = h)

/--
A morphism `f` is a monomorphism if it can be "cancelled" when postcomposed:
`g ≫ f = h ≫ f` implies `g = h`.

See https://stacks.math.columbia.edu/tag/003B.
-/
class mono (f : X ⟶ Y) : Prop :=
(right_cancellation : Π {Z : C} (g h : Z ⟶ X) (w : g ≫ f = h ≫ f), g = h)

instance (X : C) : epi (𝟙 X) :=
⟨λ Z g h w, by simpa using w⟩
instance (X : C) : mono (𝟙 X) :=
⟨λ Z g h w, by simpa using w⟩

lemma cancel_epi (f : X ⟶ Y) [epi f]  {g h : Y ⟶ Z} : (f ≫ g = f ≫ h) ↔ g = h :=
⟨ λ p, epi.left_cancellation g h p, begin intro a, subst a end ⟩
lemma cancel_mono (f : X ⟶ Y) [mono f] {g h : Z ⟶ X} : (g ≫ f = h ≫ f) ↔ g = h :=
⟨ λ p, mono.right_cancellation g h p, begin intro a, subst a end ⟩

lemma cancel_epi_id (f : X ⟶ Y) [epi f] {h : Y ⟶ Y} : (f ≫ h = f) ↔ h = 𝟙 Y :=
by { convert cancel_epi f, simp, }
lemma cancel_mono_id (f : X ⟶ Y) [mono f] {g : X ⟶ X} : (g ≫ f = f) ↔ g = 𝟙 X :=
by { convert cancel_mono f, simp, }

lemma epi_comp {X Y Z : C} (f : X ⟶ Y) [epi f] (g : Y ⟶ Z) [epi g] : epi (f ≫ g) :=
begin
  split, intros Z a b w,
  apply (cancel_epi g).1,
  apply (cancel_epi f).1,
  simpa using w,
end
lemma mono_comp {X Y Z : C} (f : X ⟶ Y) [mono f] (g : Y ⟶ Z) [mono g] : mono (f ≫ g) :=
begin
  split, intros Z a b w,
  apply (cancel_mono f).1,
  apply (cancel_mono g).1,
  simpa using w,
end

lemma mono_of_mono {X Y Z : C} (f : X ⟶ Y) (g : Y ⟶ Z) [mono (f ≫ g)] : mono f :=
begin
  split, intros Z a b w,
  replace w := congr_arg (λ k, k ≫ g) w,
  dsimp at w,
  rw [category.assoc, category.assoc] at w,
  exact (cancel_mono _).1 w,
end

lemma mono_of_mono_fac {X Y Z : C} {f : X ⟶ Y} {g : Y ⟶ Z} {h : X ⟶ Z} [mono h] (w : f ≫ g = h) :
  mono f :=
by { substI h, exact mono_of_mono f g, }

lemma epi_of_epi {X Y Z : C} (f : X ⟶ Y) (g : Y ⟶ Z) [epi (f ≫ g)] : epi g :=
begin
  split, intros Z a b w,
  replace w := congr_arg (λ k, f ≫ k) w,
  dsimp at w,
  rw [←category.assoc, ←category.assoc] at w,
  exact (cancel_epi _).1 w,
end

lemma epi_of_epi_fac {X Y Z : C} {f : X ⟶ Y} {g : Y ⟶ Z} {h : X ⟶ Z} [epi h] (w : f ≫ g = h) :
  epi g :=
by substI h; exact epi_of_epi f g
end

section
variable (C : Type u)
variable [category.{v} C]

universe u'

instance ulift_category : category.{v} (ulift.{u'} C) :=
{ hom  := λ X Y, (X.down ⟶ Y.down),
  id   := λ X, 𝟙 X.down,
  comp := λ _ _ _ f g, f ≫ g }

-- We verify that this previous instance can lift small categories to large categories.
example (D : Type u) [small_category D] : large_category (ulift.{u+1} D) := by apply_instance
end

end category_theory

open category_theory

/-!
We now put a category instance on any preorder.

Because we do not allow the morphisms of a category to live in `Prop`,
unfortunately we need to use `plift` and `ulift` when defining the morphisms.

As convenience functions, we provide `hom_of_le` and `le_of_hom` to wrap and unwrap inequalities.
-/
namespace preorder

variables (α : Type u)

/--
The category structure coming from a preorder. There is a morphism `X ⟶ Y` if and only if `X ≤ Y`.

Because we don't allow morphisms to live in `Prop`,
we have to define `X ⟶ Y` as `ulift (plift (X ≤ Y))`.
See `category_theory.hom_of_le` and `category_theory.le_of_hom`.

See https://stacks.math.columbia.edu/tag/00D3.
-/
@[priority 100] -- see Note [lower instance priority]
instance small_category [preorder α] : small_category α :=
{ hom  := λ U V, ulift (plift (U ≤ V)),
  id   := λ X, ⟨ ⟨ le_refl X ⟩ ⟩,
  comp := λ X Y Z f g, ⟨ ⟨ le_trans _ _ _ f.down.down g.down.down ⟩ ⟩ }

end preorder

namespace category_theory

variables {α : Type u} [preorder α]

/--
Express an inequality as a morphism in the corresponding preorder category.
-/
def hom_of_le {U V : α} (h : U ≤ V) : U ⟶ V := ulift.up (plift.up h)

@[simp] lemma hom_of_le_refl {U : α} : hom_of_le (le_refl U) = 𝟙 U := rfl
@[simp] lemma hom_of_le_comp {U V W : α} (h : U ≤ V) (k : V ≤ W) :
  hom_of_le h ≫ hom_of_le k = hom_of_le (h.trans k) := rfl

/--
Extract the underlying inequality from a morphism in a preorder category.
-/
lemma le_of_hom {U V : α} (h : U ⟶ V) : U ≤ V := h.down.down

@[simp] lemma le_of_hom_hom_of_le {a b : α} (h : a ≤ b) :
  le_of_hom (hom_of_le h) = h := rfl
@[simp] lemma hom_of_le_le_of_hom {a b : α} (h : a ⟶ b) :
  hom_of_le (le_of_hom h) = h :=
by { cases h, cases h, refl, }

end category_theory

/--
Many proofs in the category theory library use the `dsimp, simp` pattern,
which typically isn't necessary elsewhere.

One would usually hope that the same effect could be achieved simply with `simp`.

The essential issue is that composition of morphisms involves dependent types.
When you have a chain of morphisms being composed, say `f : X ⟶ Y` and `g : Y ⟶ Z`,
then `simp` can operate succesfully on the morphisms
(e.g. if `f` is the identity it can strip that off).

However if we have an equality of objects, say `Y = Y'`,
then `simp` can't operate because it would break the typing of the composition operations.
We rarely have interesting equalities of objects
(because that would be "evil" --- anything interesting should be expressed as an isomorphism
and tracked explicitly),
except of course that we have plenty of definitional equalities of objects.

`dsimp` can apply these safely, even inside a composition.

After `dsimp` has cleared up the object level, `simp` can resume work on the morphism level ---
but without the `dsimp` step, because `simp` looks at expressions syntactically,
the relevant lemmas might not fire.

There's no bound on how many times you potentially could have to switch back and forth,
if the `simp` introduced new objects we again need to `dsimp`.
In practice this does occur, but only rarely, because `simp` tends to shorten chains of compositions
(i.e. not introduce new objects at all).
-/
library_note "dsimp, simp"


import GMLInit.Data.Index.Basic
import GMLInit.Data.Index.Bind
import GMLInit.Data.Index.Map

protected def List.pi {α} {β : α → Type _} (f : (x : α) → List (β x)) : (xs : List α) → List ((i : Index xs) → β i.val)
| [] => [(nomatch .)]
| x::xs => (List.pi f xs).bind (λ ys => (f x).map (λ y i => match i with | .head => y | .tail i => ys i))

namespace Index
variable {α} {β : α → Type _} {f : (x : α) → List (β x)} {xs : List α}

def pi : {xs : List α} → ((i : Index xs) → Index (f i.val)) → Index (xs.pi f)
| [], _ => head
| _::_, y => bind _ ⟨pi fun i => y i.tail, map _ (y head)⟩

def unpi : {xs : List α} → (Index (xs.pi f)) → (i : Index xs) → Index (f i.val)
| _::_, k, head =>
  match unbind _ k with | ⟨_, k⟩ => unmap _ k
| _::_, k, tail i =>
  match unbind _ k with | ⟨k, _⟩ => unpi k i

theorem unpi_pi (h : (i : Index xs) → Index (f i.val)) : unpi (pi h) = h := by
  funext i
  induction i with
  | head => rw [pi, unpi]; clean; rw [unbind_bind, unmap_map]
  | tail i ih => rw [pi, unpi]; clean; rw [unbind_bind, ih]

theorem pi_unpi (k : Index (xs.pi f)) : pi (unpi k) = k := by
  induction xs with
  | nil =>
    cases k
    · rfl
    · contradiction
  | cons x xs ih =>
    match h : unbind _ k with
    | ⟨k₁,k₂⟩ =>
      rw [unbind_eq_iff_eq_bind] at h
      cases h
      simp only [pi, unpi]
      rw [unbind_bind, ih, map_unmap]

theorem pi_eq_iff_eq_unpi (h : (i : Index xs) → Index (f i.val)) (k : Index (xs.pi f)) : pi h = k ↔ h = unpi k := by
  constr
  · intro h; rw [←h, unpi_pi]
  · intro h; rw [h, pi_unpi]

theorem unpi_eq_iff_eq_pi (k : Index (xs.pi f)) (h : (i : Index xs) → Index (f i.val)) : unpi k = h ↔ k = pi h := by
  constr
  · intro h; rw [←h, pi_unpi]
  · intro h; rw [h, unpi_pi]

def piEquiv (xs : List α) (f : (x : α) → List (β x)) : Equiv ((i : Index xs) → Index (f i.val)) (Index (xs.pi f)) where
  fwd := pi
  rev := unpi
  spec := by
    intros
    constr
    · intro | rfl => exact unpi_pi ..
    · intro | rfl => exact pi_unpi ..

end Index


import QL.FOL.semantics QL.FOL.pnf QL.FOL.language PL.semantics

universes u
open_locale logic_symbol

variables (L : fol.language.{u})
namespace fol

open subformula logic logic.Theory

@[reducible] def herbrand_universe := subterm L 0 0

instance [inhabited (L.fn 0)] : inhabited (herbrand_universe L) := ⟨subterm.function default fin.nil⟩

inductive herbrand_basis
| relation : Π {k} (r : L.pr k), (fin k → herbrand_universe L) → herbrand_basis
| equal    : herbrand_universe L → herbrand_universe L → herbrand_basis

variables {L}

namespace herbrand_basis

@[simp] def to_sentence : herbrand_basis L → sentence L
| (relation r v) := subformula.relation r v
| (equal t u)    := t =' u

end herbrand_basis

end fol

namespace pl

namespace formula
variables {L}

def to_fol' : formula (fol.herbrand_basis L) → fol.sentence L
| (atom (fol.herbrand_basis.relation r v)) := fol.subformula.relation r v
| (atom (fol.herbrand_basis.equal t u))    := (t =' u)
| ⊤                                        := ⊤
| (p ⟶ q)                                  := p.to_fol' ⟶ q.to_fol'
| (∼p)                                     := ∼p.to_fol'

def to_fol : formula (fol.herbrand_basis L) →ₗ fol.sentence L :=
{ to_fun := to_fol',
  map_neg' := by intros; refl,
  map_imply' := by intros; refl,
  map_and' := by intros; refl,
  map_or' := by intros; refl,
  map_top' := by intros; refl,
  map_bot' := by intros; refl }

@[simp] lemma to_fol_atom_relation {k} (r : L.pr k) (v : fin k → fol.herbrand_universe L) :
  to_fol (atom (fol.herbrand_basis.relation r v)) = fol.subformula.relation r v := rfl

@[simp] lemma to_fol_atom_equal (t u : fol.herbrand_universe L) :
  to_fol (atom (fol.herbrand_basis.equal t u)) = (t =' u) := rfl

@[simp] lemma to_fol_open (p : formula (fol.herbrand_basis L)) : p.to_fol.is_open :=
by induction p; try { simp* }; case atom : η { rcases η; simp }

variables (L)

end formula

open formula

inductive equal_axioms : Theory (fol.herbrand_basis L)
| eq_refl : ∀ t, equal_axioms (atom (fol.herbrand_basis.equal t t))
| eq_symm : ∀ t₁ t₂, equal_axioms (atom (fol.herbrand_basis.equal t₁ t₂) ⟶ atom (fol.herbrand_basis.equal t₂ t₁))
| eq_trans : ∀ t₁ t₂ t₃,
    equal_axioms (atom (fol.herbrand_basis.equal t₁ t₂) ⟶ atom (fol.herbrand_basis.equal t₂ t₃) ⟶ atom (fol.herbrand_basis.equal t₁ t₃))
| func_ext : ∀ {k} (f : L.fn k) (v w : fin k → fol.herbrand_universe L),
    equal_axioms ((⋀ i, atom (fol.herbrand_basis.equal (v i) (w i))) ⟶
      atom (fol.herbrand_basis.equal (fol.subterm.function f v) (fol.subterm.function f w)))
| rel_ext : ∀ {k} (r : L.pr k) (v w : fin k → fol.herbrand_universe L),
    equal_axioms ((⋀ i, atom (fol.herbrand_basis.equal (v i) (w i))) ⟶
      (atom (fol.herbrand_basis.relation r v) ⟷ atom (fol.herbrand_basis.relation r w)))

end pl

namespace fol
open subformula logic logic.Theory
variables {L}

namespace sentence
open subformula

def to_pl : ∀ p : sentence L, p.is_open → pl.formula (herbrand_basis L) :=
open_rec
  ⊤
  (λ k r v, pl.formula.atom (herbrand_basis.relation r v))
  (λ t u, pl.formula.atom (herbrand_basis.equal t u))
  (λ _ _ _ _ p q, p ⟶ q) (λ _ _ p, ∼p)

@[simp] lemma to_pl_verum (h) : to_pl (⊤ : sentence L) h = ⊤ := by simp[to_pl]

@[simp] lemma to_pl_relation {k} (r : L.pr k) (v : fin k → subterm L 0 0) (h) :
  to_pl (relation r v) h = pl.formula.atom (herbrand_basis.relation r v) := by simp[to_pl]

@[simp] lemma to_pl_equal (t u : subterm L 0 0) (h) :
  to_pl (t =' u) h = pl.formula.atom (herbrand_basis.equal t u) := by simp[to_pl]

@[simp] lemma to_pl_imply (p q : sentence L) (h) :
  to_pl (p ⟶ q) h = to_pl p (by simp at h; exact h.1) ⟶ to_pl q (by simp at h; exact h.2) := by simp[to_pl]

@[simp] lemma to_pl_neg (p : sentence L) (h) :
  to_pl (∼p) h = ∼to_pl p (by simpa using h) := by simp[to_pl]

@[simp] lemma to_fol_to_pl : ∀ (p : sentence L) (h : p.is_open), (p.to_pl h).to_fol = p :=
by apply open_rec; { intros, simp* }

@[simp] lemma to_pl_to_fol (p : pl.formula (herbrand_basis L)) (h) : p.to_fol.to_pl h = p :=
by { induction p; try { simp* }, case atom : η { rcases η; simp } }

end sentence

namespace Structure

@[simp] lemma Models_pl_equal_axioms (S : Structure L) : S ⊧ pl.formula.to_fol '' (pl.equal_axioms L) :=
begin
  simp[semantics.Models_def], intros p hp,
  cases hp; simp[sentence_models_def],
  case eq_symm : { exact eq.symm },
  case eq_trans : { exact eq.trans },
  case func_ext : k f v w { intros h, refine congr_arg _ (funext h) },
  case rel_ext : k r v w { intros h, refine iff_of_eq (congr_arg _ (funext h)) }
end

def to_pl (S : Structure L) : pl.Structure (herbrand_basis L) := ⟨λ a, S ⊧ a.to_sentence⟩
namespace to_pl
open subterm subformula
variables {S : Structure L}

@[simp] protected lemma val (a) : S.to_pl.val a ↔ S ⊧ a.to_sentence := by refl

protected lemma models {p : pl.formula (herbrand_basis L)} :
  S.to_pl ⊧ p ↔ S ⊧ p.to_fol :=
by induction p; try {simp*}; case atom : η { cases η; simp[pl.models_def] }

protected lemma Models {Γ : pl.Theory (herbrand_basis L)} :
  S.to_pl ⊧ Γ ↔ S ⊧ pl.formula.to_fol '' Γ :=
by simp[logic.semantics.Models_def, to_pl.models]

end to_pl

namespace Herbrand
open subterm subformula
variables {L} (V : pl.Structure (herbrand_basis L)) (H : V ⊧ pl.equal_axioms L)

def pl_equiv (H : V ⊧ pl.equal_axioms L) (t u : herbrand_universe L) : Prop := V.val (herbrand_basis.equal t u)

@[refl, simp] lemma pl_equiv_refl (x : herbrand_universe L) :
  pl_equiv V H x x :=
by simpa[pl.models_def] using H (pl.equal_axioms.eq_refl x)

lemma pl_equiv_equivalence : equivalence (pl_equiv V H) :=
⟨by { intros x, simp[H] },
 by { intros x y, simpa using H (pl.equal_axioms.eq_symm x y) },
 by { intros x y z, simpa using H (pl.equal_axioms.eq_trans x y z) }⟩

instance : setoid (herbrand_universe L) := ⟨pl_equiv V H, pl_equiv_equivalence V H⟩

def domain := quotient (herbrand_universe.setoid V H)

def qu (t : herbrand_universe L) : domain V H := quotient.mk' t

@[elab_as_eliminator]
protected lemma ind_on {C : domain V H → Prop} (d : domain V H)
  (h : ∀ t, C (qu V H t)) : C d := quotient.induction_on' d h

@[elab_as_eliminator, reducible]
protected def lift_on {φ : Sort*} (p : domain V H) (f : herbrand_universe L → φ)
  (h : ∀ t u, pl_equiv V H t u → f t = f u) : φ := quotient.lift_on' p f h

@[elab_as_eliminator, reducible]
protected def lift_on_finitary {φ : Sort*} {n : ℕ} (v : finitary (domain V H) n) (f : finitary (herbrand_universe L) n → φ)
  (h : ∀ v₁ v₂ : finitary (herbrand_universe L) n, (∀ i, pl_equiv V H (v₁ i) (v₂ i)) → f v₁ = f v₂) : φ :=
quotient.lift_on_finitary v f h

@[simp] protected lemma lift_on_finitary_eq {φ : Sort*} {n : ℕ}
  (v : finitary (herbrand_universe L) n) (f : finitary (herbrand_universe L) n → φ) (h) :
Herbrand.lift_on_finitary V H (λ x, qu V H (v x)) f h = f v :=
quotient.lift_on_finitary_eq v f h

@[simp] lemma of_eq_of {t u : herbrand_universe L} : qu V H t = qu V H u ↔ V.val (herbrand_basis.equal t u) :=
by simp[qu, quotient.eq']; refl

def function {k} (f : L.fn k) (v : finitary (domain V H) k) : domain V H :=
Herbrand.lift_on_finitary V H v (λ x, qu V H (subterm.function f x))
(begin
   intros v w h, simp,
   have : (∀ i, V.val (herbrand_basis.equal (v i) (w i))) → V.val (herbrand_basis.equal (function f v) (function f w)),
   by simpa[pl.models_def] using H (pl.equal_axioms.func_ext f v w),
   exact this h,
 end)

@[simp] def function_qu {k} (f : L.fn k) (v : finitary (herbrand_universe L) k) :
  function V H f (λ i, qu V H (v i)) = qu V H (subterm.function f v) :=
by simp[function]; exact (pl_equiv_equivalence V H).1 _

def relation {k} (r : L.pr k) (v : finitary (domain V H) k) : Prop :=
Herbrand.lift_on_finitary V H v (λ x, V.val (herbrand_basis.relation r x))
(begin
   intros v w h, simp,
   have : (∀ i, V.val (herbrand_basis.equal (v i) (w i))) →
     (V.val (herbrand_basis.relation r v) ↔ V.val (herbrand_basis.relation r w)),
   by simpa[pl.models_def] using H (pl.equal_axioms.rel_ext r v w),
   exact this h
 end)

@[simp] def relation_qu {k} (r : L.pr k) (v : finitary (herbrand_universe L) k) :
  relation V H r (λ i, qu V H (v i)) ↔ V.val (herbrand_basis.relation r v) :=
by simp[relation]; exact (pl_equiv_equivalence V H).1 _

end Herbrand

variables [inhabited (L.fn 0)]

@[reducible] def Herbrand (V : pl.Structure (herbrand_basis L)) (H : V ⊧ pl.equal_axioms L) : Structure L :=
{ dom := Herbrand.domain V H,
  dom_inhabited := ⟨Herbrand.function V H default fin_zero_elim⟩,
  fn := @Herbrand.function _ V H,
  pr := @Herbrand.relation _ V H, }

namespace Herbrand
variables {L} (V : pl.Structure (herbrand_basis L)) (H : V ⊧ pl.equal_axioms L)

@[simp] lemma models_val (t : herbrand_universe L) : subterm.val (Herbrand V H) fin.nil fin.nil t = qu V H t :=
by { induction t; simp[*, -of_eq_of]; { exact fin_zero_elim t } }

lemma models_relation_iff' {k} (r : L.pr k) (v : fin k → herbrand_universe L) :
  Herbrand V H ⊧ subformula.relation r v ↔ V.val (herbrand_basis.relation r v) :=
by simp[sentence_models_def, (∘)]

lemma models_relation_iff {k} (r : L.pr k) (v : fin k → herbrand_universe L) :
  Herbrand V H ⊧ subformula.relation r v ↔ V.val (herbrand_basis.relation r v) :=
by simp[sentence_models_def, (∘)]

variables {V H}

noncomputable def qu_inv (x : Herbrand V H) : herbrand_universe L := classical.epsilon (λ t, qu V H t = x)

@[simp] lemma qu_to_hu (x : Herbrand V H) : qu V H (qu_inv x) = x :=
@classical.epsilon_spec (herbrand_universe L) (λ t, qu V H t = x)
(by induction x using fol.Structure.Herbrand.ind_on; exact ⟨x, by refl⟩)

lemma subterm_subst {n} (x) : ∀ (t : subterm L 0 n),
  subterm.val (Herbrand V H) fin.nil x t = qu V H (subterm.substs (qu_inv ∘ x) t)
| #x := by simp
| &x := fin_zero_elim x
| (subterm.function f v) := by simp[λ i, subterm_subst (v i), -of_eq_of]

lemma val_iff_subst {n} (p : subformula L 0 n) (hp : p.is_open) : ∀ x,
  val (Herbrand V H) fin.nil x p ↔ V ⊧ sentence.to_pl (substs (qu_inv ∘ x) p) (by simpa using hp) :=
begin
  apply open_rec_on p hp,
  { simp },
  { intros k r v x, simp[pl.models_def, (∘), subterm_subst] },
  { intros t u x, simp[pl.models_def, subterm_subst] },
  { intros p q hp hq IHp IHq x, simp[IHp, IHq] },
  { intros p hp IH x, simp[IH] }
end

protected lemma models : ∀ {p : pl.formula (fol.herbrand_basis L)}, Herbrand V H ⊧ p.to_fol ↔ V ⊧ p
| ⊤                                               := by simp
| (pl.formula.atom (herbrand_basis.relation r v)) := by simp[sentence_models_def, (∘), pl.models_def]
| (pl.formula.atom (herbrand_basis.equal t u))    := by simp[sentence_models_def, pl.models_def]
| (p ⟶ q)                                         := by simp[@models p, @models q]
| (∼p)                                            := by simp[@models p]

lemma models_forall_iff {n} (p : subformula L 0 n) : Herbrand V H ⊧ ∀'*p ↔ ∀ x, Herbrand V H ⊧ substs x p :=
by { simp[sentence_models_def, subterm_subst, (∘)], split,
     { intros h x, simp[h] },
     { intros h x, simpa using h (λ i, qu_inv (x i)) } }

protected lemma Models {Γ : pl.Theory (herbrand_basis L)} : Herbrand V H ⊧ pl.formula.to_fol '' Γ ↔ V ⊧ Γ :=
by simp[logic.semantics.Models_def, Herbrand.models]

end Herbrand

lemma Satisfies_to_fol_iff {Γ : pl.Theory (herbrand_basis L)} :
  Satisfiable (pl.formula.to_fol '' Γ) ↔ pl.Satisfiable (Γ ∪ pl.equal_axioms L) :=
⟨by { rintros ⟨S, hS⟩, refine ⟨S.to_pl, by { simp[to_pl.Models.mpr hS], refine to_pl.Models.mpr (by simp) }⟩ },
 by { rintros ⟨V, hV⟩, simp at hV, refine ⟨Herbrand V hV.2, Herbrand.Models.mpr hV.1⟩ }⟩

namespace to_pl
variables (S : Structure L)

@[simp] lemma to_pl_equal_axioms : S.to_pl ⊧ pl.equal_axioms L := to_pl.Models.mpr (by simp)

lemma Herbran_models {S : Structure L} (p : pl.formula (fol.herbrand_basis L)):
  S ⊧ p.to_fol ↔ Herbrand (S.to_pl) (to_pl_equal_axioms S) ⊧ p.to_fol :=
to_pl.models.symm.trans Herbrand.models.symm

end to_pl

end Structure

section herbrand_universe
open Structure
variables {L} {m n : ℕ} [inhabited (L.fn 0)]

lemma valid_iff_pl_consequence_aux (p : subformula L 0 n) (p_open : p.is_open)
  (H : ∀ (w : list (fin n → herbrand_universe L)),
    ∃ V : pl.Structure (herbrand_basis L), V ⊧ pl.equal_axioms L ∧
    ∀ x ∈ w, V ⊧ sentence.to_pl (∼substs x p) (by simpa using p_open)) :
  satisfiable (∼∃'*p) :=
begin
  let T := set.range (λ x, sentence.to_pl (∼substs x p) (by simpa using p_open)),
  have : pl.Satisfiable (T ∪ pl.equal_axioms L),
  { refine pl.compactness.mpr _,
    simp[T, set.subset_range_iff_exists_image_eq, set.finite_image_iff],
    intros s s_ss s_fin,
    have : ∃ u' sₑ,
      sₑ ⊆ pl.equal_axioms L ∧
      s = (λ x, ∼sentence.to_pl (substs x p) _) '' u' ∪ sₑ,
    by simpa[set.subset_union_iff_exists, set.subset_range_iff_exists_image_eq] using s_ss,
    rcases this with ⟨u', sₑ, hsₑ, rfl⟩,
    simp at s_fin,
    have : ∃ u : finset (fin n → subterm L 0 0),
      (λ x, ∼sentence.to_pl (substs x p) (by simpa using p_open)) '' u = (λ x, ∼sentence.to_pl (substs x p) (by simpa using p_open)) '' u',
    { have : ∃ u ⊆ u', u.finite ∧ (λ x, ∼sentence.to_pl (substs x p) _) '' u = (λ x, ∼sentence.to_pl (substs x p) _) '' u',
      from set.image_finite_inversion s_fin.1,
      rcases this with ⟨u, hu, u_fin, eqn⟩,
      refine ⟨set.finite.to_finset u_fin, by simpa using eqn⟩ },
    rcases this with ⟨u, eqn⟩,
    suffices : pl.Satisfiable ((λ x, ∼sentence.to_pl (substs x p) (by simpa using p_open)) '' u ∪ sₑ),
    by simpa[eqn] using this,
    rcases H u.to_list with ⟨V, hVₑ, hVᵤ⟩,
    refine ⟨V, _⟩,
    rintros q (hq | hq),
    { simp at hq, rcases hq with ⟨x, hx, rfl⟩,
      by simpa using hVᵤ x (by simpa using hx) },
    { exact hVₑ (hsₑ hq) } },
  rcases this with ⟨V, hV⟩, simp at hV,
  have hVT : V ⊧ T, from hV.1,
  have hVeq : V ⊧ pl.equal_axioms L, from hV.2,
  refine ⟨Herbrand V hVeq, _⟩,
  simp[sentence_models_def, Herbrand.val_iff_subst p p_open], intros x,
  have : V ⊧ ∼sentence.to_pl (substs (Herbrand.qu_inv ∘ x) p) (by simpa using p_open), from hVT (by simp[T]),
  simpa using this
end

theorem valid_iff_pl_consequence (p : subformula L 0 n) (hp : p.is_open) :
  valid (∃'*p) ↔
  ∃ v : list (fin n → herbrand_universe L),
  pl.equal_axioms L ⊧ (v.map (λ t, sentence.to_pl (substs t p) (by simpa using hp))).disjunction :=
⟨ begin
    contrapose, assume h,
    have : ∀ (w : list (fin n → herbrand_universe L)),
     ∃ V : pl.Structure (herbrand_basis L), V ⊧ pl.equal_axioms L ∧
     ∀ x ∈ w, V ⊧ sentence.to_pl (∼substs x p) (by simpa using hp),
    by simpa[pl.tautology_iff, pl.models_def, pl.consequence_def] using h,
    have : satisfiable (∼∃'* p), from valid_iff_pl_consequence_aux p hp this,
    simpa using this,
  end,
  begin
    rintros ⟨v, h⟩ S, simp[sentence_models_def],
    have : ∃ x ∈ v, val S fin.nil (subterm.val S fin.nil fin.nil ∘ x) p,
    by simpa [to_pl.models, sentence_models_def] using
      pl.consequence_def.mp h S.to_pl (Structure.to_pl.to_pl_equal_axioms S),
    rcases this with ⟨x, _, h⟩,
    exact ⟨subterm.val S fin.nil fin.nil ∘ x, h⟩
  end⟩

theorem skolem_basic (p : subformula L 0 n) (hp : p.is_open) :
  valid (∼∀'*p) ↔
  ∃ v : list (fin n → herbrand_universe L),
  pl.equal_axioms L ⊧ (v.map (λ t, sentence.to_pl (∼substs t p) (by simpa using hp))).disjunction :=
begin
  have : valid (∼∀'*p) ↔ valid (∃'*∼p), by simp[valid_def, sentence_models_def],
  simpa using iff.trans this (valid_iff_pl_consequence (∼p) (by simpa using hp))
end

end herbrand_universe

end fol


import ring_theory.multiplicity algebra.big_operators tactic.default data.rat.basic

universe variables u v

open finset

lemma prod_nat_cast {α β} [comm_semiring β] (s : finset α) (f : α → ℕ) :
  ↑(s.prod f) = s.prod (λa, f a : α → β) :=
(prod_hom _).symm

instance int.coe.is_monoid_hom : is_monoid_hom (coe : ℕ → ℤ) :=
{ map_one := int.coe_nat_one, map_mul := int.coe_nat_mul }

lemma prod_nat_cast_int {α} (s : finset α) (f : α → ℕ) :
  ↑(s.prod f) = s.prod (λa, f a : α → ℤ) :=
(prod_hom _).symm

lemma nat_prime_iff_prime (n : ℕ) : nat.prime n ↔ prime n :=
by sorry

lemma int.coe_nat_prime (n : ℕ) : prime (n : ℤ) ↔ prime n :=
by sorry

lemma ne_zero_of_prime {α} [comm_semiring α] {p : α} (hp : prime p) : p ≠ 0 :=
hp.1

lemma not_unit_of_prime {α} [comm_semiring α] {p : α} (hp : prime p) : ¬ is_unit p :=
hp.2.1

namespace nat
lemma monotone_fact : monotone fact := λ n m, fact_le

lemma fact_lt {n m : ℕ} (h0 : 0 < n) (h : n < m) : n.fact < m.fact :=
begin
  have : ∀(n : ℕ), 0 < n → n.fact < n.succ.fact,
  { intros k hk, rw [fact_succ, succ_mul, lt_add_iff_pos_left],
    apply mul_pos hk (fact_pos k) },
  induction h generalizing h0,
  { exact this _ h0, },
  { refine lt_trans (h_ih h0) (this _ _), exact lt_trans h0 (lt_of_succ_le h_a) }
end

lemma fact_eq_one {n : ℕ} : n.fact = 1 ↔ n ≤ 1 :=
begin
  sorry
end

lemma fact_inj {n m : ℕ} (h0 : 1 < n.fact) : n.fact = m.fact ↔ n = m :=
begin
  sorry
end

/- The `n+1`-st triangle number is `n` more than the `n`-th triangle number -/
lemma triangle_succ (n : ℕ) : (n + 1) * ((n + 1) - 1) / 2 = n * (n - 1) / 2 + n :=
begin
  rw [← add_mul_div_left, mul_comm 2 n, ← mul_add, nat.add_sub_cancel, mul_comm],
  cases n; refl, norm_num
end

lemma ne_of_eq_monotone {α} [preorder α] {f : ℕ → α} (hf : monotone f)
  (x x' : ℕ) {y : α} (h1 : f x < y) (h2 : y < f (x + 1)) : f x' ≠ y :=
begin
  rintro rfl,

  sorry
end

end nat

/- this is also true for a ordered commutative multiplicative monoid -/
lemma prod_nonneg {α : Type u} {β : Type v} [decidable_eq α] [linear_ordered_comm_ring β]
  {s : finset α} {f : α → β} (h0 : ∀(x ∈ s), 0 ≤ f x) : 0 ≤ s.prod f :=
begin
  induction s using finset.induction with a s has ih h,
  { simp [zero_le_one] },
  { simp [has], apply mul_nonneg, apply h0 a (mem_insert_self a s),
    exact ih (λ x H, h0 x (mem_insert_of_mem H)) }
end

/- this is also true for a ordered commutative multiplicative monoid -/
lemma prod_pos {α : Type u} {β : Type v} [decidable_eq α] [linear_ordered_comm_ring β]
  {s : finset α} {f : α → β} (h0 : ∀(x ∈ s), 0 < f x) : 0 < s.prod f :=
begin
  induction s using finset.induction with a s has ih h,
  { simp [zero_lt_one] },
  { simp [has], apply mul_pos, apply h0 a (mem_insert_self a s),
    exact ih (λ x H, h0 x (mem_insert_of_mem H)) }
end

/- this is also true for a ordered commutative multiplicative monoid -/
lemma prod_le_prod {α : Type u} {β : Type v} [decidable_eq α] [linear_ordered_comm_ring β]
  {s : finset α} {f g : α → β} (h0 : ∀(x ∈ s), 0 ≤ f x) (h1 : ∀(x ∈ s), f x ≤ g x) :
  s.prod f ≤ s.prod g :=
begin
  induction s using finset.induction with a s has ih h,
  { simp },
  { simp [has], apply mul_le_mul,
      exact h1 a (mem_insert_self a s),
      apply ih (λ x H, h0 _ _) (λ x H, h1 _ _); exact (mem_insert_of_mem H),
      apply prod_nonneg (λ x H, h0 x (mem_insert_of_mem H)),
      apply le_trans (h0 a (mem_insert_self a s)) (h1 a (mem_insert_self a s)) }
end

namespace enat

open roption

instance : has_mul enat := ⟨λ x y, ⟨x.dom ∧ y.dom, λ h, get x h.1 * get y h.2⟩⟩

instance : comm_monoid enat :=
{ mul       := (*),
  one       := (1),
  mul_comm  := λ x y, roption.ext' and.comm (λ _ _, mul_comm _ _),
  one_mul   := λ x, roption.ext' (true_and _) (λ _ _, one_mul _),
  mul_one   := λ x, roption.ext' (and_true _) (λ _ _, mul_one _),
  mul_assoc := λ x y z, roption.ext' and.assoc (λ _ _, mul_assoc _ _ _) }

@[simp] lemma get_mul {x y : enat} (h : (x * y).dom) : get (x * y) h = x.get h.1 * y.get h.2 := rfl

protected lemma finset.sum {α : Type u} [decidable_eq α] (s : finset α) (f : α → ℕ) :
  s.sum (λ x, (f x : enat)) = (s.sum f : ℕ) :=
begin
  induction s using finset.induction with a s has ih h,
  { simp },
  { simp [has, ih] }
end

end enat

namespace multiplicity

section
variables {α : Type u} {β : Type v} [decidable_eq α] [integral_domain β]
  [decidable_rel ((∣) : β → β → Prop)]

lemma finset.prod {p : β} (hp : prime p) (s : finset α) (f : α → β) :
  multiplicity p (s.prod f) = s.sum (λ x, multiplicity p (f x)) :=
begin
  induction s using finset.induction with a s has ih h,
  { simp [one_right (not_unit_of_prime hp)] },
  { simp [has, multiplicity.mul hp, ih] }
end
end

section
variables {α : Type u} [integral_domain α] [decidable_rel ((∣) : α → α → Prop)]
lemma multiplicity_add_of_gt {p a b : α} (h : multiplicity p b < multiplicity p a) :
  multiplicity p (a + b) = multiplicity p b :=
sorry

lemma multiplicity_sub_of_gt {p a b : α} (h : multiplicity p b < multiplicity p a) :
  multiplicity p (a - b) = multiplicity p b :=
sorry

-- lemma multiplicity_add_eq_min {p a b : α} (h : multiplicity p a ≠ multiplicity p b) :
--   multiplicity p (a + b) = min (multiplicity p a) (multiplicity p b) :=
-- sorry

lemma multiplicity_pow {p a : α} (n : ℕ) :
  multiplicity p (a ^ n) = multiplicity p a * n :=
sorry

lemma multiplicity_pow_self {p : α} (hu : ¬ is_unit p) (h0 : p ≠ 0) (n : ℕ) :
  multiplicity p (p ^ n) = n :=
by { rw [multiplicity_pow, multiplicity_self hu h0, one_mul],  }

lemma multiplicity_pow_self_of_prime {p : α} (hp : prime p) (n : ℕ) :
  multiplicity p (p ^ n) = n :=
multiplicity_pow_self (not_unit_of_prime hp) (ne_zero_of_prime hp) n

end

variables {p : ℕ}
lemma finite_fact (hp : prime p) (n : ℕ) : finite p (n.fact) :=
sorry

protected lemma fact (hp : prime p) (n : ℕ) :
  ((multiplicity p n.fact).get (finite_fact hp n) : ℤ) =
  (range n).sum (λ i, rat.floor ((n : ℚ) / p ^ i)) :=
sorry

lemma multiplicity_two_fact_lt (n : ℕ) : multiplicity 2 n.fact < n :=
sorry

lemma multiplicity_two_fact_int_lt (n : ℕ) : multiplicity 2 (n.fact : ℤ) < n :=
by simpa [int.coe_nat_multiplicity] using multiplicity_two_fact_lt n

end multiplicity
open multiplicity

/- This proof has to be written carefully so that we don't get a timeout -/
lemma IMO2019_4_n_eq_6 : 2 ^ (6 * 6) < nat.fact (6 * (6 - 1) / 2) :=
begin
  have h1 : nat.fact (6 * (6 - 1) / 2) = 1307674368000,
  { norm_num, repeat {rw [← nat.add_one]}, norm_num },
  have h2 : 2 ^ (6 * 6) = 68719476736,
  { change 2 ^ 36 = _, repeat { rw [nat.pow_succ] }, norm_num },
  rw [h1, h2], norm_num,
end

theorem IMO2019_4_upper_bound {k n : ℕ}
  (h : (k.fact : ℤ) = (range n).prod (λ i, 2 ^ n - 2 ^ i)) : n < 6 :=
begin
  have prime_2 : prime (2 : ℤ),
  { show prime ((2:ℕ) : ℤ), rw [int.coe_nat_prime 2, ← nat_prime_iff_prime], exact nat.prime_two },
  have h2 : n * (n - 1) / 2 < k,
  { rw [← enat.coe_lt_coe], convert multiplicity_two_fact_int_lt k, symmetry,
    rw [h, multiplicity.finset.prod prime_2, ← sum_range_id, ← enat.finset.sum],
    apply sum_congr rfl, intros i hi,
    rw [multiplicity_sub_of_gt, multiplicity_pow_self_of_prime prime_2],
    rwa [multiplicity_pow_self_of_prime prime_2, multiplicity_pow_self_of_prime prime_2,
      enat.coe_lt_coe, ←mem_range],
    apply_instance },
  rw [←not_le], intro hn,
  apply ne_of_lt _ h.symm,
  suffices : ((range n).prod (λ i, 2 ^ n) : ℤ) < ↑k.fact,
  { apply lt_of_le_of_lt _ this, apply prod_le_prod,
    { intros, rw [sub_nonneg], apply pow_le_pow, norm_num, apply le_of_lt, rwa [← mem_range] },
    { intros, apply sub_le_self, apply pow_nonneg, norm_num }},
  suffices : 2 ^ (n * n) < (n * (n - 1) / 2).fact,
  { rw [prod_const, card_range, ← pow_mul], rw [← int.coe_nat_lt_coe_nat_iff] at this,
    convert lt_trans this _, norm_cast, rw [int.coe_nat_lt_coe_nat_iff],
    apply nat.fact_lt _ h2, refine nat.div_pos _ (by norm_num),
    refine le_trans _ (mul_le_mul hn (nat.pred_le_pred hn) (zero_le _) (zero_le _)),
    norm_num },
  refine nat.le_induction IMO2019_4_n_eq_6 _ n hn,
  intros n' hn' ih,
  have h5 : 1 ≤ 2 * n',
  { apply nat.succ_le_of_lt, apply mul_pos, norm_num,
    exact lt_of_lt_of_le (by norm_num) hn' },
  have : 2 ^ (2 + 2) ≤ (n' * (n' - 1) / 2).succ,
  { change nat.succ (6 * (6 - 1) / 2) ≤ _,
    apply nat.succ_le_succ, apply nat.div_le_div_right,
    exact mul_le_mul hn' (nat.pred_le_pred hn') (zero_le _) (zero_le _) },
  rw [nat.triangle_succ], apply lt_of_lt_of_le _ nat.fact_mul_pow_le_fact,
  refine lt_of_le_of_lt _ (mul_lt_mul ih (nat.pow_le_pow_of_le_left this _)
    (nat.pow_pos (by norm_num) _) (zero_le _)),
  rw [← nat.pow_mul, ← nat.pow_add], apply nat.pow_le_pow_of_le_right, norm_num,
  rw [add_mul 2 2],
  convert (add_le_add_left (add_le_add_left h5 (2 * n')) (n' * n')) using 1, ring
end

theorem IMO2019_4 {k n : ℕ} : k > 0 → n > 0 →
  ((nat.fact k : ℤ) = (range n).prod (λ i, 2 ^ n - 2 ^ i) ↔ (k, n) = (1, 1) ∨ (k, n) = (3, 2)) :=
begin
  intros hk hn, split, swap,
  { rintro (h|h); simp [prod.ext_iff] at h; rcases h with ⟨rfl, rfl⟩;
    norm_num [prod_range_succ, nat.succ_mul] },
  intro h,
  have := IMO2019_4_upper_bound h,
  rcases lt_or_eq_of_le (nat.le_of_lt_succ this) with this|rfl,
  rcases lt_or_eq_of_le (nat.le_of_lt_succ this) with this|rfl,
  rcases lt_or_eq_of_le (nat.le_of_lt_succ this) with this|rfl,
  rcases lt_or_eq_of_le (nat.le_of_lt_succ this) with this|rfl,
  rcases lt_or_eq_of_le (nat.le_of_lt_succ this) with this|rfl,
  { exfalso, apply not_le_of_lt this, exact nat.succ_le_of_lt hn },
  { left, congr, norm_num at h, norm_cast at h, rw [nat.fact_eq_one] at h, apply antisymm h,
    apply nat.succ_le_of_lt hk },
  { right, congr, norm_num [prod_range_succ] at h, norm_cast at h, rw [← nat.fact_inj], exact h,
    rw [h], norm_num },
  all_goals { exfalso, norm_num [prod_range_succ] at h, norm_cast at h, },
  { refine nat.ne_of_eq_monotone nat.monotone_fact 5 _ _ _ h,
    all_goals { norm_num, repeat {rw [← nat.add_one]}, norm_num }},
  { refine nat.ne_of_eq_monotone nat.monotone_fact 7 _ _ _ h,
    all_goals { norm_num, repeat {rw [← nat.add_one]}, norm_num }},
  { refine nat.ne_of_eq_monotone nat.monotone_fact 10 _ _ _ h,
    all_goals { norm_num, repeat {rw [← nat.add_one]}, norm_num }},
end