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

import algebra.char_p.basic
import algebra.ne_zero
import ring_theory.ideal.operations
import tactic.fin_cases

/-!
# Integers mod `n`

Definition of the integers mod n, and the field structure on the integers mod p.

## Definitions

* `zmod n`, which is for integers modulo a nat `n : ℕ`

* `val a` is defined as a natural number:
  - for `a : zmod 0` it is the absolute value of `a`
  - for `a : zmod n` with `0 < n` it is the least natural number in the equivalence class

* `val_min_abs` returns the integer closest to zero in the equivalence class.

* A coercion `cast` is defined from `zmod n` into any ring.
This is a ring hom if the ring has characteristic dividing `n`

-/

namespace fin

/-!
## Ring structure on `fin n`

We define a commutative ring structure on `fin n`, but we do not register it as instance.
Afterwords, when we define `zmod n` in terms of `fin n`, we use these definitions
to register the ring structure on `zmod n` as type class instance.
-/

open nat.modeq int

/-- Multiplicative commutative semigroup structure on `fin (n+1)`. -/
instance (n : ℕ) : comm_semigroup (fin (n+1)) :=
{ mul_assoc := λ ⟨a, ha⟩ ⟨b, hb⟩ ⟨c, hc⟩, fin.eq_of_veq
    (calc ((a * b) % (n+1) * c) ≡ a * b * c [MOD (n+1)] : (nat.mod_modeq _ _).mul_right _
      ... ≡ a * (b * c) [MOD (n+1)] : by rw mul_assoc
      ... ≡ a * (b * c % (n+1)) [MOD (n+1)] : (nat.mod_modeq _ _).symm.mul_left _),
  mul_comm := λ ⟨a, _⟩ ⟨b, _⟩,
    fin.eq_of_veq (show (a * b) % (n+1) = (b * a) % (n+1), by rw mul_comm),
  ..fin.has_mul }

private lemma left_distrib_aux (n : ℕ) : ∀ a b c : fin (n+1), a * (b + c) = a * b + a * c :=
λ ⟨a, ha⟩ ⟨b, hb⟩ ⟨c, hc⟩, fin.eq_of_veq
(calc a * ((b + c) % (n+1)) ≡ a * (b + c) [MOD (n+1)] : (nat.mod_modeq _ _).mul_left _
  ... ≡ a * b + a * c [MOD (n+1)] : by rw mul_add
  ... ≡ (a * b) % (n+1) + (a * c) % (n+1) [MOD (n+1)] :
        (nat.mod_modeq _ _).symm.add (nat.mod_modeq _ _).symm)

/-- Commutative ring structure on `fin (n+1)`. -/
instance (n : ℕ) : comm_ring (fin (n+1)) :=
{ one_mul := fin.one_mul,
  mul_one := fin.mul_one,
  left_distrib := left_distrib_aux n,
  right_distrib := λ a b c, by rw [mul_comm, left_distrib_aux, mul_comm _ b, mul_comm]; refl,
  ..fin.add_monoid_with_one,
  ..fin.add_comm_group n,
  ..fin.comm_semigroup n }

end fin

/-- The integers modulo `n : ℕ`. -/
def zmod : ℕ → Type
| 0     := ℤ
| (n+1) := fin (n+1)

namespace zmod

instance fintype : Π (n : ℕ) [fact (0 < n)], fintype (zmod n)
| 0     h := (lt_irrefl _ h.1).elim
| (n+1) _ := fin.fintype (n+1)

instance fintype' (n : ℕ) [ne_zero n] : fintype (zmod n) :=
@zmod.fintype n ⟨ne_zero.pos n⟩

instance infinite : infinite (zmod 0) :=
int.infinite

@[simp] lemma card (n : ℕ) [fintype (zmod n)] : fintype.card (zmod n) = n :=
begin
  casesI n,
  { exact (not_fintype (zmod 0)).elim },
  { convert fintype.card_fin (n+1) }
end

instance decidable_eq : Π (n : ℕ), decidable_eq (zmod n)
| 0     := int.decidable_eq
| (n+1) := fin.decidable_eq _

instance has_repr : Π (n : ℕ), has_repr (zmod n)
| 0     := int.has_repr
| (n+1) := fin.has_repr _

/- We define each field by cases, to ensure that the eta-expanded `zmod.comm_ring` is defeq to the
original, this helps avoid diamonds with instances coming from classes extending `comm_ring` such as
field. -/
instance comm_ring (n : ℕ) : comm_ring (zmod n) :=
{ add := nat.cases_on n ((@has_add.add) int _) (λ n, @has_add.add (fin n.succ) _),
  add_assoc := nat.cases_on n (@add_assoc int _) (λ n, @add_assoc (fin n.succ) _),
  zero := nat.cases_on n (0 : int) (λ n, (0 : fin n.succ)),
  zero_add := nat.cases_on n (@zero_add int _) (λ n, @zero_add (fin n.succ) _),
  add_zero := nat.cases_on n (@add_zero int _) (λ n, @add_zero (fin n.succ) _),
  neg := nat.cases_on n ((@has_neg.neg) int _) (λ n, @has_neg.neg (fin n.succ) _),
  sub := nat.cases_on n ((@has_sub.sub) int _) (λ n, @has_sub.sub (fin n.succ) _),
  sub_eq_add_neg := nat.cases_on n (@sub_eq_add_neg int _) (λ n, @sub_eq_add_neg (fin n.succ) _),
  zsmul := nat.cases_on n ((@comm_ring.zsmul) int _) (λ n, @comm_ring.zsmul (fin n.succ) _),
  zsmul_zero' := nat.cases_on n (@comm_ring.zsmul_zero' int _)
    (λ n, @comm_ring.zsmul_zero' (fin n.succ) _),
  zsmul_succ' := nat.cases_on n (@comm_ring.zsmul_succ' int _)
    (λ n, @comm_ring.zsmul_succ' (fin n.succ) _),
  zsmul_neg' := nat.cases_on n (@comm_ring.zsmul_neg' int _)
    (λ n, @comm_ring.zsmul_neg' (fin n.succ) _),
  nsmul := nat.cases_on n ((@comm_ring.nsmul) int _) (λ n, @comm_ring.nsmul (fin n.succ) _),
  nsmul_zero' := nat.cases_on n (@comm_ring.nsmul_zero' int _)
    (λ n, @comm_ring.nsmul_zero' (fin n.succ) _),
  nsmul_succ' := nat.cases_on n (@comm_ring.nsmul_succ' int _)
    (λ n, @comm_ring.nsmul_succ' (fin n.succ) _),
  add_left_neg := by { cases n, exacts [@add_left_neg int _, @add_left_neg (fin n.succ) _] },
  add_comm := nat.cases_on n (@add_comm int _) (λ n, @add_comm (fin n.succ) _),
  mul := nat.cases_on n ((@has_mul.mul) int _) (λ n, @has_mul.mul (fin n.succ) _),
  mul_assoc := nat.cases_on n (@mul_assoc int _) (λ n, @mul_assoc (fin n.succ) _),
  one := nat.cases_on n (1 : int) (λ n, (1 : fin n.succ)),
  one_mul := nat.cases_on n (@one_mul int _) (λ n, @one_mul (fin n.succ) _),
  mul_one := nat.cases_on n (@mul_one int _) (λ n, @mul_one (fin n.succ) _),
  nat_cast := nat.cases_on n (coe : ℕ → ℤ) (λ n, (coe : ℕ → fin n.succ)),
  nat_cast_zero := nat.cases_on n (@nat.cast_zero int _) (λ n, @nat.cast_zero (fin n.succ) _),
  nat_cast_succ := nat.cases_on n (@nat.cast_succ int _) (λ n, @nat.cast_succ (fin n.succ) _),
  int_cast := nat.cases_on n (coe : ℤ → ℤ) (λ n, (coe : ℤ → fin n.succ)),
  int_cast_of_nat := nat.cases_on n (@int.cast_of_nat int _) (λ n, @int.cast_of_nat (fin n.succ) _),
  int_cast_neg_succ_of_nat := nat.cases_on n (@int.cast_neg_succ_of_nat int _)
    (λ n, @int.cast_neg_succ_of_nat (fin n.succ) _),
  left_distrib := nat.cases_on n (@left_distrib int _ _ _) (λ n, @left_distrib (fin n.succ) _ _ _),
  right_distrib :=
    nat.cases_on n (@right_distrib int _ _ _) (λ n, @right_distrib (fin n.succ) _ _ _),
  mul_comm := nat.cases_on n (@mul_comm int _) (λ n, @mul_comm (fin n.succ) _) }

instance inhabited (n : ℕ) : inhabited (zmod n) := ⟨0⟩

instance : char_zero (zmod 0) := (by apply_instance : char_zero ℤ)

/-- `val a` is a natural number defined as:
  - for `a : zmod 0` it is the absolute value of `a`
  - for `a : zmod n` with `0 < n` it is the least natural number in the equivalence class

See `zmod.val_min_abs` for a variant that takes values in the integers.
-/
def val : Π {n : ℕ}, zmod n → ℕ
| 0     := int.nat_abs
| (n+1) := (coe : fin (n + 1) → ℕ)

lemma val_lt {n : ℕ} [fact (0 < n)] (a : zmod n) : a.val < n :=
begin
  casesI n,
  { exfalso, exact nat.not_lt_zero 0 (fact.out _) },
  exact fin.is_lt a
end

lemma val_le {n : ℕ} [fact (0 < n)] (a : zmod n) : a.val ≤ n :=
a.val_lt.le

@[simp] lemma val_zero : ∀ {n}, (0 : zmod n).val = 0
| 0     := rfl
| (n+1) := rfl

@[simp] lemma val_one' : (1 : zmod 0).val = 1 := rfl
@[simp] lemma val_neg' {n : zmod 0} : (-n).val = n.val := by simp [val]
@[simp] lemma val_mul' {m n : zmod 0} : (m * n).val = m.val * n.val :=
by simp [val, int.nat_abs_mul]

lemma val_nat_cast {n : ℕ} (a : ℕ) : (a : zmod n).val = a % n :=
begin
  casesI n,
  { rw [nat.mod_zero],
    exact int.nat_abs_of_nat a, },
  rw ← fin.of_nat_eq_coe,
  refl
end

instance (n : ℕ) : char_p (zmod n) n :=
{ cast_eq_zero_iff :=
  begin
    intro k,
    cases n,
    { simp only [zero_dvd_iff, int.coe_nat_eq_zero], },
    rw [fin.eq_iff_veq],
    show (k : zmod (n+1)).val = (0 : zmod (n+1)).val ↔ _,
    rw [val_nat_cast, val_zero, nat.dvd_iff_mod_eq_zero],
  end }

/-- We have that `ring_char (zmod n) = n`. -/
lemma ring_char_zmod_n (n : ℕ) : ring_char (zmod n) = n :=
by { rw ring_char.eq_iff, exact zmod.char_p n, }

@[simp] lemma nat_cast_self (n : ℕ) : (n : zmod n) = 0 :=
char_p.cast_eq_zero (zmod n) n

@[simp] lemma nat_cast_self' (n : ℕ) : (n + 1 : zmod (n + 1)) = 0 :=
by rw [← nat.cast_add_one, nat_cast_self (n + 1)]

section universal_property

variables {n : ℕ} {R : Type*}

section
variables [add_group_with_one R]

/-- Cast an integer modulo `n` to another semiring.
This function is a morphism if the characteristic of `R` divides `n`.
See `zmod.cast_hom` for a bundled version. -/
def cast : Π {n : ℕ}, zmod n → R
| 0     := int.cast
| (n+1) := λ i, i.val

-- see Note [coercion into rings]
@[priority 900] instance (n : ℕ) : has_coe_t (zmod n) R := ⟨cast⟩

@[simp] lemma cast_zero : ((0 : zmod n) : R) = 0 :=
by cases n; simp

variables {S : Type*} [add_group_with_one S]

@[simp] lemma _root_.prod.fst_zmod_cast (a : zmod n) : (a : R × S).fst = a :=
by cases n; simp

@[simp] lemma _root_.prod.snd_zmod_cast (a : zmod n) : (a : R × S).snd = a :=
by cases n; simp

end

/-- So-named because the coercion is `nat.cast` into `zmod`. For `nat.cast` into an arbitrary ring,
see `zmod.nat_cast_val`. -/
lemma nat_cast_zmod_val {n : ℕ} [fact (0 < n)] (a : zmod n) : (a.val : zmod n) = a :=
begin
  casesI n,
  { exfalso, exact nat.not_lt_zero 0 (fact.out _) },
  { apply fin.coe_coe_eq_self }
end

lemma nat_cast_right_inverse [fact (0 < n)] : function.right_inverse val (coe : ℕ → zmod n) :=
nat_cast_zmod_val

lemma nat_cast_zmod_surjective [fact (0 < n)] : function.surjective (coe : ℕ → zmod n) :=
nat_cast_right_inverse.surjective

/-- So-named because the outer coercion is `int.cast` into `zmod`. For `int.cast` into an arbitrary
ring, see `zmod.int_cast_cast`. -/
lemma int_cast_zmod_cast (a : zmod n) : ((a : ℤ) : zmod n) = a :=
begin
  cases n,
  { rw [int.cast_id a, int.cast_id a], },
  { rw [coe_coe, int.cast_coe_nat, fin.coe_coe_eq_self] }
end

lemma int_cast_right_inverse : function.right_inverse (coe : zmod n → ℤ) (coe : ℤ → zmod n) :=
int_cast_zmod_cast

lemma int_cast_surjective : function.surjective (coe : ℤ → zmod n) :=
int_cast_right_inverse.surjective

@[norm_cast]
lemma cast_id : ∀ n (i : zmod n), ↑i = i
| 0     i := int.cast_id i
| (n+1) i := nat_cast_zmod_val i

@[simp]
lemma cast_id' : (coe : zmod n → zmod n) = id := funext (cast_id n)

variables (R) [ring R]

/-- The coercions are respectively `nat.cast` and `zmod.cast`. -/
@[simp] lemma nat_cast_comp_val [fact (0 < n)] :
  (coe : ℕ → R) ∘ (val : zmod n → ℕ) = coe :=
begin
  casesI n,
  { exfalso, exact nat.not_lt_zero 0 (fact.out _) },
  refl
end

/-- The coercions are respectively `int.cast`, `zmod.cast`, and `zmod.cast`. -/
@[simp] lemma int_cast_comp_cast : (coe : ℤ → R) ∘ (coe : zmod n → ℤ) = coe :=
begin
  cases n,
  { exact congr_arg ((∘) int.cast) zmod.cast_id', },
  { ext, simp }
end

variables {R}

@[simp] lemma nat_cast_val [fact (0 < n)] (i : zmod n) : (i.val : R) = i :=
congr_fun (nat_cast_comp_val R) i

@[simp] lemma int_cast_cast (i : zmod n) : ((i : ℤ) : R) = i :=
congr_fun (int_cast_comp_cast R) i

lemma coe_add_eq_ite {n : ℕ} (a b : zmod n) :
  (↑(a + b) : ℤ) = if (n : ℤ) ≤ a + b then a + b - n else a + b :=
begin
  cases n,
  { simp },
  simp only [coe_coe, fin.coe_add_eq_ite,
             ← int.coe_nat_add, ← int.coe_nat_succ, int.coe_nat_le],
  split_ifs with h,
  { exact int.coe_nat_sub h },
  { refl }
end

section char_dvd
/-! If the characteristic of `R` divides `n`, then `cast` is a homomorphism. -/

variables {n} {m : ℕ} [char_p R m]

@[simp] lemma cast_one (h : m ∣ n) : ((1 : zmod n) : R) = 1 :=
begin
  casesI n,
  { exact int.cast_one },
  show ((1 % (n+1) : ℕ) : R) = 1,
  cases n, { rw [nat.dvd_one] at h, substI m, apply subsingleton.elim },
  rw nat.mod_eq_of_lt,
  { exact nat.cast_one },
  exact nat.lt_of_sub_eq_succ rfl
end

lemma cast_add (h : m ∣ n) (a b : zmod n) : ((a + b : zmod n) : R) = a + b :=
begin
  casesI n,
  { apply int.cast_add },
  simp only [coe_coe],
  symmetry,
  erw [fin.coe_add, ← nat.cast_add, ← sub_eq_zero, ← nat.cast_sub (nat.mod_le _ _),
      @char_p.cast_eq_zero_iff R _ m],
  exact h.trans (nat.dvd_sub_mod _),
end

lemma cast_mul (h : m ∣ n) (a b : zmod n) : ((a * b : zmod n) : R) = a * b :=
begin
  casesI n,
  { apply int.cast_mul },
  simp only [coe_coe],
  symmetry,
  erw [fin.coe_mul, ← nat.cast_mul, ← sub_eq_zero, ← nat.cast_sub (nat.mod_le _ _),
      @char_p.cast_eq_zero_iff R _ m],
  exact h.trans (nat.dvd_sub_mod _),
end

/-- The canonical ring homomorphism from `zmod n` to a ring of characteristic `n`.

See also `zmod.lift` (in `data.zmod.quotient`) for a generalized version working in `add_group`s.
-/
def cast_hom (h : m ∣ n) (R : Type*) [ring R] [char_p R m] : zmod n →+* R :=
{ to_fun := coe,
  map_zero' := cast_zero,
  map_one' := cast_one h,
  map_add' := cast_add h,
  map_mul' := cast_mul h }

@[simp] lemma cast_hom_apply {h : m ∣ n} (i : zmod n) : cast_hom h R i = i := rfl

@[simp, norm_cast]
lemma cast_sub (h : m ∣ n) (a b : zmod n) : ((a - b : zmod n) : R) = a - b :=
(cast_hom h R).map_sub a b

@[simp, norm_cast]
lemma cast_neg (h : m ∣ n) (a : zmod n) : ((-a : zmod n) : R) = -a :=
(cast_hom h R).map_neg a

@[simp, norm_cast]
lemma cast_pow (h : m ∣ n) (a : zmod n) (k : ℕ) : ((a ^ k : zmod n) : R) = a ^ k :=
(cast_hom h R).map_pow a k

@[simp, norm_cast]
lemma cast_nat_cast (h : m ∣ n) (k : ℕ) : ((k : zmod n) : R) = k :=
map_nat_cast (cast_hom h R) k

@[simp, norm_cast]
lemma cast_int_cast (h : m ∣ n) (k : ℤ) : ((k : zmod n) : R) = k :=
(cast_hom h R).map_int_cast k

end char_dvd

section char_eq
/-! Some specialised simp lemmas which apply when `R` has characteristic `n`. -/
variable [char_p R n]

@[simp] lemma cast_one' : ((1 : zmod n) : R) = 1 :=
cast_one dvd_rfl

@[simp] lemma cast_add' (a b : zmod n) : ((a + b : zmod n) : R) = a + b :=
cast_add dvd_rfl a b

@[simp] lemma cast_mul' (a b : zmod n) : ((a * b : zmod n) : R) = a * b :=
cast_mul dvd_rfl a b

@[simp] lemma cast_sub' (a b : zmod n) : ((a - b : zmod n) : R) = a - b :=
cast_sub dvd_rfl a b

@[simp] lemma cast_pow' (a : zmod n) (k : ℕ) : ((a ^ k : zmod n) : R) = a ^ k :=
cast_pow dvd_rfl a k

@[simp, norm_cast]
lemma cast_nat_cast' (k : ℕ) : ((k : zmod n) : R) = k :=
cast_nat_cast dvd_rfl k

@[simp, norm_cast]
lemma cast_int_cast' (k : ℤ) : ((k : zmod n) : R) = k :=
cast_int_cast dvd_rfl k

variables (R)

lemma cast_hom_injective : function.injective (zmod.cast_hom (dvd_refl n) R) :=
begin
  rw injective_iff_map_eq_zero,
  intro x,
  obtain ⟨k, rfl⟩ := zmod.int_cast_surjective x,
  rw [ring_hom.map_int_cast, char_p.int_cast_eq_zero_iff R n,
    char_p.int_cast_eq_zero_iff (zmod n) n],
  exact id
end

lemma cast_hom_bijective [fintype R] (h : fintype.card R = n) :
  function.bijective (zmod.cast_hom (dvd_refl n) R) :=
begin
  haveI : fact (0 < n) :=
  ⟨begin
    rw [pos_iff_ne_zero],
    intro hn,
    rw hn at h,
    exact (fintype.card_eq_zero_iff.mp h).elim' 0
  end⟩,
  rw [fintype.bijective_iff_injective_and_card, zmod.card, h, eq_self_iff_true, and_true],
  apply zmod.cast_hom_injective
end

/-- The unique ring isomorphism between `zmod n` and a ring `R`
of characteristic `n` and cardinality `n`. -/
noncomputable def ring_equiv [fintype R] (h : fintype.card R = n) : zmod n ≃+* R :=
ring_equiv.of_bijective _ (zmod.cast_hom_bijective R h)

/-- The identity between `zmod m` and `zmod n` when `m = n`, as a ring isomorphism. -/
def ring_equiv_congr {m n : ℕ} (h : m = n) : zmod m ≃+* zmod n :=
begin
  cases m; cases n,
  { exact ring_equiv.refl _ },
  { exfalso, exact n.succ_ne_zero h.symm },
  { exfalso, exact m.succ_ne_zero h },
  { exact
    { map_mul' := λ a b, begin
        rw [order_iso.to_fun_eq_coe], ext,
        rw [fin.coe_cast, fin.coe_mul, fin.coe_mul, fin.coe_cast, fin.coe_cast, ← h] end,
      map_add' := λ a b, begin
        rw [order_iso.to_fun_eq_coe], ext,
        rw [fin.coe_cast, fin.coe_add, fin.coe_add, fin.coe_cast, fin.coe_cast, ← h] end,
      ..fin.cast h } }
end

end char_eq

end universal_property

lemma int_coe_eq_int_coe_iff (a b : ℤ) (c : ℕ) :
  (a : zmod c) = (b : zmod c) ↔ a ≡ b [ZMOD c] :=
char_p.int_coe_eq_int_coe_iff (zmod c) c a b

lemma int_coe_eq_int_coe_iff' (a b : ℤ) (c : ℕ) :
  (a : zmod c) = (b : zmod c) ↔ a % c = b % c :=
zmod.int_coe_eq_int_coe_iff a b c

lemma nat_coe_eq_nat_coe_iff (a b c : ℕ) :
  (a : zmod c) = (b : zmod c) ↔ a ≡ b [MOD c] :=
by simpa [int.coe_nat_modeq_iff] using zmod.int_coe_eq_int_coe_iff a b c

lemma nat_coe_eq_nat_coe_iff' (a b c : ℕ) :
  (a : zmod c) = (b : zmod c) ↔ a % c = b % c :=
zmod.nat_coe_eq_nat_coe_iff a b c

lemma int_coe_zmod_eq_zero_iff_dvd (a : ℤ) (b : ℕ) : (a : zmod b) = 0 ↔ (b : ℤ) ∣ a :=
by rw [← int.cast_zero, zmod.int_coe_eq_int_coe_iff, int.modeq_zero_iff_dvd]

lemma int_coe_eq_int_coe_iff_dvd_sub (a b : ℤ) (c : ℕ) : (a : zmod c) = ↑b ↔ ↑c ∣ b-a :=
begin
  rw [zmod.int_coe_eq_int_coe_iff, int.modeq_iff_dvd],
end

lemma nat_coe_zmod_eq_zero_iff_dvd (a b : ℕ) : (a : zmod b) = 0 ↔ b ∣ a :=
by rw [← nat.cast_zero, zmod.nat_coe_eq_nat_coe_iff, nat.modeq_zero_iff_dvd]

lemma val_int_cast {n : ℕ} (a : ℤ) [fact (0 < n)] : ↑(a : zmod n).val = a % n :=
begin
  have hle : (0 : ℤ) ≤ ↑(a : zmod n).val := int.coe_nat_nonneg _,
  have hlt : ↑(a : zmod n).val < (n : ℤ) := int.coe_nat_lt.mpr (zmod.val_lt a),
  refine (int.mod_eq_of_lt hle hlt).symm.trans _,
  rw [←zmod.int_coe_eq_int_coe_iff', int.cast_coe_nat, zmod.nat_cast_val, zmod.cast_id],
end

lemma coe_int_cast {n : ℕ} (a : ℤ) : ↑(a : zmod n) = a % n :=
begin
  cases n,
  { rw [int.coe_nat_zero, int.mod_zero, int.cast_id, int.cast_id] },
  { rw [←val_int_cast, val, coe_coe] },
end

@[simp] lemma val_neg_one (n : ℕ) : (-1 : zmod n.succ).val = n :=
begin
  rw [val, fin.coe_neg],
  cases n,
  { rw [nat.mod_one] },
  { rw [fin.coe_one, nat.succ_add_sub_one, nat.mod_eq_of_lt (nat.lt.base _)] },
end

/-- `-1 : zmod n` lifts to `n - 1 : R`. This avoids the characteristic assumption in `cast_neg`. -/
lemma cast_neg_one {R : Type*} [ring R] (n : ℕ) : ↑(-1 : zmod n) = (n - 1 : R) :=
begin
  cases n,
  { rw [int.cast_neg, int.cast_one, nat.cast_zero, zero_sub] },
  { rw [←nat_cast_val, val_neg_one, nat.cast_succ, add_sub_cancel] },
end

lemma cast_sub_one {R : Type*} [ring R] {n : ℕ} (k : zmod n) :
  ((k - 1 : zmod n) : R) = (if k = 0 then n else k) - 1 :=
begin
  split_ifs with hk,
  { rw [hk, zero_sub, zmod.cast_neg_one] },
  { cases n,
    { rw [int.cast_sub, int.cast_one] },
    { rw [←zmod.nat_cast_val, zmod.val, fin.coe_sub_one, if_neg],
      { rw [nat.cast_sub, nat.cast_one, coe_coe],
        rwa [fin.ext_iff, fin.coe_zero, ←ne, ←nat.one_le_iff_ne_zero] at hk },
      { exact hk } } },
end

lemma nat_coe_zmod_eq_iff (p : ℕ) (n : ℕ) (z : zmod p) [fact (0 < p)] :
  ↑n = z ↔ ∃ k, n = z.val + p * k :=
begin
  split,
  { rintro rfl,
    refine ⟨n / p, _⟩,
    rw [val_nat_cast, nat.mod_add_div] },
  { rintro ⟨k, rfl⟩,
    rw [nat.cast_add, nat_cast_zmod_val, nat.cast_mul, nat_cast_self, zero_mul, add_zero] }
end

lemma int_coe_zmod_eq_iff (p : ℕ) (n : ℤ) (z : zmod p) [fact (0 < p)] :
  ↑n = z ↔ ∃ k, n = z.val + p * k :=
begin
  split,
  { rintro rfl,
    refine ⟨n / p, _⟩,
    rw [val_int_cast, int.mod_add_div] },
  { rintro ⟨k, rfl⟩,
    rw [int.cast_add, int.cast_mul, int.cast_coe_nat, int.cast_coe_nat, nat_cast_val,
      zmod.nat_cast_self, zero_mul, add_zero, cast_id] }
end

@[push_cast, simp]
lemma int_cast_mod (a : ℤ) (b : ℕ) : ((a % b : ℤ) : zmod b) = (a : zmod b) :=
begin
  rw zmod.int_coe_eq_int_coe_iff,
  apply int.mod_modeq,
end

lemma ker_int_cast_add_hom (n : ℕ) :
  (int.cast_add_hom (zmod n)).ker = add_subgroup.zmultiples n :=
by { ext, rw [int.mem_zmultiples_iff, add_monoid_hom.mem_ker,
              int.coe_cast_add_hom, int_coe_zmod_eq_zero_iff_dvd] }

lemma ker_int_cast_ring_hom (n : ℕ) :
  (int.cast_ring_hom (zmod n)).ker = ideal.span ({n} : set ℤ) :=
by { ext, rw [ideal.mem_span_singleton, ring_hom.mem_ker,
              int.coe_cast_ring_hom, int_coe_zmod_eq_zero_iff_dvd] }

local attribute [semireducible] int.nonneg

@[simp] lemma nat_cast_to_nat (p : ℕ) :
  ∀ {z : ℤ} (h : 0 ≤ z), (z.to_nat : zmod p) = z
| (n : ℕ) h := by simp only [int.cast_coe_nat, int.to_nat_coe_nat]
| -[1+n]  h := false.elim h

lemma val_injective (n : ℕ) [fact (0 < n)] :
  function.injective (zmod.val : zmod n → ℕ) :=
begin
  casesI n,
  { exfalso, exact nat.not_lt_zero 0 (fact.out _) },
  assume a b h,
  ext,
  exact h
end

lemma val_one_eq_one_mod (n : ℕ) : (1 : zmod n).val = 1 % n :=
by rw [← nat.cast_one, val_nat_cast]

lemma val_add {n : ℕ} [fact (0 < n)] (a b : zmod n) : (a + b).val = (a.val + b.val) % n :=
begin
  casesI n,
  { exfalso, exact nat.not_lt_zero 0 (fact.out _) },
  { apply fin.val_add }
end

lemma val_mul {n : ℕ} (a b : zmod n) : (a * b).val = (a.val * b.val) % n :=
begin
  cases n,
  { rw nat.mod_zero, apply int.nat_abs_mul },
  { apply fin.val_mul }
end

instance nontrivial (n : ℕ) [fact (1 < n)] : nontrivial (zmod n) :=
⟨⟨0, 1, assume h, zero_ne_one $
   calc 0 = (0 : zmod n).val : by rw val_zero
      ... = (1 : zmod n).val : congr_arg zmod.val h
      ... = 1                : val_one n ⟩⟩

/-- The inversion on `zmod n`.
It is setup in such a way that `a * a⁻¹` is equal to `gcd a.val n`.
In particular, if `a` is coprime to `n`, and hence a unit, `a * a⁻¹ = 1`. -/
def inv : Π (n : ℕ), zmod n → zmod n
| 0     i := int.sign i
| (n+1) i := nat.gcd_a i.val (n+1)

instance (n : ℕ) : has_inv (zmod n) := ⟨inv n⟩

lemma inv_zero : ∀ (n : ℕ), (0 : zmod n)⁻¹ = 0
| 0     := int.sign_zero
| (n+1) := show (nat.gcd_a _ (n+1) : zmod (n+1)) = 0,
             by { rw val_zero, unfold nat.gcd_a nat.xgcd nat.xgcd_aux, refl }

lemma mul_inv_eq_gcd {n : ℕ} (a : zmod n) :
  a * a⁻¹ = nat.gcd a.val n :=
begin
  cases n,
  { calc a * a⁻¹ = a * int.sign a  : rfl
             ... = a.nat_abs   : by rw int.mul_sign
             ... = a.val.gcd 0 : by rw nat.gcd_zero_right; refl },
  { set k := n.succ,
    calc a * a⁻¹ = a * a⁻¹ + k * nat.gcd_b (val a) k : by rw [nat_cast_self, zero_mul, add_zero]
             ... = ↑(↑a.val * nat.gcd_a (val a) k + k * nat.gcd_b (val a) k) :
                     by { push_cast, rw nat_cast_zmod_val, refl }
             ... = nat.gcd a.val k : (congr_arg coe (nat.gcd_eq_gcd_ab a.val k)).symm, }
end

@[simp] lemma nat_cast_mod (a : ℕ) (n : ℕ) : ((a % n : ℕ) : zmod n) = a :=
by conv {to_rhs, rw ← nat.mod_add_div a n}; simp

lemma eq_iff_modeq_nat (n : ℕ) {a b : ℕ} : (a : zmod n) = b ↔ a ≡ b [MOD n] :=
begin
  cases n,
  { simp only [nat.modeq, int.coe_nat_inj', nat.mod_zero], },
  { rw [fin.ext_iff, nat.modeq, ← val_nat_cast, ← val_nat_cast], exact iff.rfl, }
end

lemma coe_mul_inv_eq_one {n : ℕ} (x : ℕ) (h : nat.coprime x n) :
  (x * x⁻¹ : zmod n) = 1 :=
begin
  rw [nat.coprime, nat.gcd_comm, nat.gcd_rec] at h,
  rw [mul_inv_eq_gcd, val_nat_cast, h, nat.cast_one],
end

/-- `unit_of_coprime` makes an element of `(zmod n)ˣ` given
  a natural number `x` and a proof that `x` is coprime to `n`  -/
def unit_of_coprime {n : ℕ} (x : ℕ) (h : nat.coprime x n) : (zmod n)ˣ :=
⟨x, x⁻¹, coe_mul_inv_eq_one x h, by rw [mul_comm, coe_mul_inv_eq_one x h]⟩

@[simp] lemma coe_unit_of_coprime {n : ℕ} (x : ℕ) (h : nat.coprime x n) :
  (unit_of_coprime x h : zmod n) = x := rfl

lemma val_coe_unit_coprime {n : ℕ} (u : (zmod n)ˣ) :
  nat.coprime (u : zmod n).val n :=
begin
  cases n,
  { rcases int.units_eq_one_or u with rfl|rfl; simp },
  apply nat.coprime_of_mul_modeq_one ((u⁻¹ : units (zmod (n+1))) : zmod (n+1)).val,
  have := units.ext_iff.1 (mul_right_inv u),
  rw [units.coe_one] at this,
  rw [← eq_iff_modeq_nat, nat.cast_one, ← this], clear this,
  rw [← nat_cast_zmod_val ((u * u⁻¹ : units (zmod (n+1))) : zmod (n+1))],
  rw [units.coe_mul, val_mul, nat_cast_mod],
end

@[simp] lemma inv_coe_unit {n : ℕ} (u : (zmod n)ˣ) :
  (u : zmod n)⁻¹ = (u⁻¹ : (zmod n)ˣ) :=
begin
  have := congr_arg (coe : ℕ → zmod n) (val_coe_unit_coprime u),
  rw [← mul_inv_eq_gcd, nat.cast_one] at this,
  let u' : (zmod n)ˣ := ⟨u, (u : zmod n)⁻¹, this, by rwa mul_comm⟩,
  have h : u = u', { apply units.ext, refl },
  rw h,
  refl
end

lemma mul_inv_of_unit {n : ℕ} (a : zmod n) (h : is_unit a) :
  a * a⁻¹ = 1 :=
begin
  rcases h with ⟨u, rfl⟩,
  rw [inv_coe_unit, u.mul_inv],
end

lemma inv_mul_of_unit {n : ℕ} (a : zmod n) (h : is_unit a) :
  a⁻¹ * a = 1 :=
by rw [mul_comm, mul_inv_of_unit a h]

/-- Equivalence between the units of `zmod n` and
the subtype of terms `x : zmod n` for which `x.val` is comprime to `n` -/
def units_equiv_coprime {n : ℕ} [fact (0 < n)] :
  (zmod n)ˣ ≃ {x : zmod n // nat.coprime x.val n} :=
{ to_fun := λ x, ⟨x, val_coe_unit_coprime x⟩,
  inv_fun := λ x, unit_of_coprime x.1.val x.2,
  left_inv := λ ⟨_, _, _, _⟩, units.ext (nat_cast_zmod_val _),
  right_inv := λ ⟨_, _⟩, by simp }

/-- The **Chinese remainder theorem**. For a pair of coprime natural numbers, `m` and `n`,
  the rings `zmod (m * n)` and `zmod m × zmod n` are isomorphic.

See `ideal.quotient_inf_ring_equiv_pi_quotient` for the Chinese remainder theorem for ideals in any
ring.
-/
def chinese_remainder {m n : ℕ} (h : m.coprime n) :
  zmod (m * n) ≃+* zmod m × zmod n :=
let to_fun : zmod (m * n) → zmod m × zmod n :=
  zmod.cast_hom (show m.lcm n ∣ m * n, by simp [nat.lcm_dvd_iff]) (zmod m × zmod n) in
let inv_fun : zmod m × zmod n → zmod (m * n) :=
  λ x, if m * n = 0
    then if m = 1
      then ring_hom.snd _ _ x
      else ring_hom.fst _ _ x
    else nat.chinese_remainder h x.1.val x.2.val in
have inv : function.left_inverse inv_fun to_fun ∧ function.right_inverse inv_fun to_fun :=
  if hmn0 : m * n = 0
    then begin
      rcases h.eq_of_mul_eq_zero hmn0 with ⟨rfl, rfl⟩ | ⟨rfl, rfl⟩;
      simp [inv_fun, to_fun, function.left_inverse, function.right_inverse,
        ring_hom.eq_int_cast, prod.ext_iff]
    end
    else
      begin
        haveI : fact (0 < (m * n)) := ⟨nat.pos_of_ne_zero hmn0⟩,
        haveI : fact (0 < m) := ⟨nat.pos_of_ne_zero $ left_ne_zero_of_mul hmn0⟩,
        haveI : fact (0 < n) := ⟨nat.pos_of_ne_zero $ right_ne_zero_of_mul hmn0⟩,
        have left_inv : function.left_inverse inv_fun to_fun,
        { intro x,
          dsimp only [dvd_mul_left, dvd_mul_right, zmod.cast_hom_apply, coe_coe, inv_fun, to_fun],
          conv_rhs { rw ← zmod.nat_cast_zmod_val x },
          rw [if_neg hmn0, zmod.eq_iff_modeq_nat, ← nat.modeq_and_modeq_iff_modeq_mul h,
            prod.fst_zmod_cast, prod.snd_zmod_cast],
          refine
            ⟨(nat.chinese_remainder h (x : zmod m).val (x : zmod n).val).2.left.trans _,
            (nat.chinese_remainder h (x : zmod m).val (x : zmod n).val).2.right.trans _⟩,
          { rw [← zmod.eq_iff_modeq_nat, zmod.nat_cast_zmod_val, zmod.nat_cast_val] },
          { rw [← zmod.eq_iff_modeq_nat, zmod.nat_cast_zmod_val, zmod.nat_cast_val] } },
        exact ⟨left_inv, left_inv.right_inverse_of_card_le (by simp)⟩,
      end,
{ to_fun := to_fun,
  inv_fun := inv_fun,
  map_mul' := ring_hom.map_mul _,
  map_add' := ring_hom.map_add _,
  left_inv := inv.1,
  right_inv := inv.2 }

instance subsingleton_units : subsingleton ((zmod 2)ˣ) :=
⟨λ x y, begin
  ext1,
  cases x with x xi hx1 hx2,
  cases y with y yi hy1 hy2,
  revert hx1 hx2 hy1 hy2,
  fin_cases x; fin_cases y; simp
end⟩

lemma le_div_two_iff_lt_neg (n : ℕ) [hn : fact ((n : ℕ) % 2 = 1)]
  {x : zmod n} (hx0 : x ≠ 0) : x.val ≤ (n / 2 : ℕ) ↔ (n / 2 : ℕ) < (-x).val :=
begin
  haveI npos : fact (0 < n) := ⟨by
  { apply (nat.eq_zero_or_pos n).resolve_left,
    unfreezingI { rintro rfl },
    simpa [fact_iff] using hn, }⟩,
  have hn2 : (n : ℕ) / 2 < n := nat.div_lt_of_lt_mul
    ((lt_mul_iff_one_lt_left npos.1).2 dec_trivial),
  have hn2' : (n : ℕ) - n / 2 = n / 2 + 1,
  { conv {to_lhs, congr, rw [← nat.succ_sub_one n, nat.succ_sub npos.1]},
    rw [← nat.two_mul_odd_div_two hn.1, two_mul, ← nat.succ_add, add_tsub_cancel_right], },
  have hxn : (n : ℕ) - x.val < n,
  { rw [tsub_lt_iff_tsub_lt x.val_le le_rfl, tsub_self],
    rw ← zmod.nat_cast_zmod_val x at hx0,
    exact nat.pos_of_ne_zero (λ h, by simpa [h] using hx0) },
  by conv {to_rhs, rw [← nat.succ_le_iff, nat.succ_eq_add_one, ← hn2', ← zero_add (- x),
    ← zmod.nat_cast_self, ← sub_eq_add_neg, ← zmod.nat_cast_zmod_val x,
    ← nat.cast_sub x.val_le,
    zmod.val_nat_cast, nat.mod_eq_of_lt hxn, tsub_le_tsub_iff_left x.val_le] }
end

lemma ne_neg_self (n : ℕ) [hn : fact ((n : ℕ) % 2 = 1)] {a : zmod n} (ha : a ≠ 0) : a ≠ -a :=
λ h, have a.val ≤ n / 2 ↔ (n : ℕ) / 2 < (-a).val := le_div_two_iff_lt_neg n ha,
by rwa [← h, ← not_lt, not_iff_self] at this

lemma neg_one_ne_one {n : ℕ} [fact (2 < n)] :
  (-1 : zmod n) ≠ 1 :=
char_p.neg_one_ne_one (zmod n) n

lemma neg_eq_self_mod_two (a : zmod 2) : -a = a :=
by fin_cases a; ext; simp [fin.coe_neg, int.nat_mod]; norm_num

@[simp] lemma nat_abs_mod_two (a : ℤ) : (a.nat_abs : zmod 2) = a :=
begin
  cases a,
  { simp only [int.nat_abs_of_nat, int.cast_coe_nat, int.of_nat_eq_coe] },
  { simp only [neg_eq_self_mod_two, nat.cast_succ, int.nat_abs, int.cast_neg_succ_of_nat] }
end

@[simp] lemma val_eq_zero : ∀ {n : ℕ} (a : zmod n), a.val = 0 ↔ a = 0
| 0     a := int.nat_abs_eq_zero
| (n+1) a := by { rw fin.ext_iff, exact iff.rfl }

lemma val_cast_of_lt {n : ℕ} {a : ℕ} (h : a < n) : (a : zmod n).val = a :=
by rw [val_nat_cast, nat.mod_eq_of_lt h]

lemma neg_val' {n : ℕ} [fact (0 < n)] (a : zmod n) : (-a).val = (n - a.val) % n :=
calc (-a).val = val (-a)    % n : by rw nat.mod_eq_of_lt ((-a).val_lt)
          ... = (n - val a) % n : nat.modeq.add_right_cancel' _ (by rw [nat.modeq, ←val_add,
                  add_left_neg, tsub_add_cancel_of_le a.val_le, nat.mod_self, val_zero])

lemma neg_val {n : ℕ} [fact (0 < n)] (a : zmod n) : (-a).val = if a = 0 then 0 else n - a.val :=
begin
  rw neg_val',
  by_cases h : a = 0, { rw [if_pos h, h, val_zero, tsub_zero, nat.mod_self] },
  rw if_neg h,
  apply nat.mod_eq_of_lt,
  apply nat.sub_lt (fact.out (0 < n)),
  contrapose! h,
  rwa [nat.le_zero_iff, val_eq_zero] at h,
end

/-- `val_min_abs x` returns the integer in the same equivalence class as `x` that is closest to `0`,
  The result will be in the interval `(-n/2, n/2]`. -/
def val_min_abs : Π {n : ℕ}, zmod n → ℤ
| 0       x := x
| n@(_+1) x := if x.val ≤ n / 2 then x.val else (x.val : ℤ) - n

@[simp] lemma val_min_abs_def_zero (x : zmod 0) : val_min_abs x = x := rfl

lemma val_min_abs_def_pos {n : ℕ} [fact (0 < n)] (x : zmod n) :
  val_min_abs x = if x.val ≤ n / 2 then x.val else x.val - n :=
begin
  casesI n,
  { exfalso, exact nat.not_lt_zero 0 (fact.out (0 < 0)) },
  { refl }
end

@[simp] lemma coe_val_min_abs : ∀ {n : ℕ} (x : zmod n), (x.val_min_abs : zmod n) = x
| 0       x := int.cast_id x
| k@(n+1) x :=
begin
  rw val_min_abs_def_pos,
  split_ifs,
  { rw [int.cast_coe_nat, nat_cast_zmod_val] },
  { rw [int.cast_sub, int.cast_coe_nat, nat_cast_zmod_val, int.cast_coe_nat, nat_cast_self,
      sub_zero] }
end

lemma nat_abs_val_min_abs_le {n : ℕ} [fact (0 < n)] (x : zmod n) : x.val_min_abs.nat_abs ≤ n / 2 :=
begin
  rw zmod.val_min_abs_def_pos,
  split_ifs with h, { exact h },
  have : (x.val - n : ℤ) ≤ 0,
  { rw [sub_nonpos, int.coe_nat_le], exact x.val_le, },
  rw [← int.coe_nat_le, int.of_nat_nat_abs_of_nonpos this, neg_sub],
  conv_lhs { congr, rw [← nat.mod_add_div n 2, int.coe_nat_add, int.coe_nat_mul,
    int.coe_nat_bit0, int.coe_nat_one] },
  suffices : ((n % 2 : ℕ) + (n / 2) : ℤ) ≤ (val x),
  { rw ← sub_nonneg at this ⊢, apply le_trans this (le_of_eq _), ring },
  norm_cast,
  calc (n : ℕ) % 2 + n / 2 ≤ 1 + n / 2 :
    nat.add_le_add_right (nat.le_of_lt_succ (nat.mod_lt _ dec_trivial)) _
                       ... ≤ x.val     :
    by { rw add_comm, exact nat.succ_le_of_lt (lt_of_not_ge h) }
end

@[simp] lemma val_min_abs_zero : ∀ n, (0 : zmod n).val_min_abs = 0
| 0     := by simp only [val_min_abs_def_zero]
| (n+1) := by simp only [val_min_abs_def_pos, if_true, int.coe_nat_zero, zero_le, val_zero]

@[simp] lemma val_min_abs_eq_zero {n : ℕ} (x : zmod n) :
  x.val_min_abs = 0 ↔ x = 0 :=
begin
  cases n, { simp },
  split,
  { simp only [val_min_abs_def_pos, int.coe_nat_succ],
    split_ifs with h h; assume h0,
    { apply val_injective, rwa [int.coe_nat_eq_zero] at h0, },
    { apply absurd h0, rw sub_eq_zero, apply ne_of_lt, exact_mod_cast x.val_lt } },
  { rintro rfl, rw val_min_abs_zero }
end

lemma nat_cast_nat_abs_val_min_abs {n : ℕ} [fact (0 < n)] (a : zmod n) :
  (a.val_min_abs.nat_abs : zmod n) = if a.val ≤ (n : ℕ) / 2 then a else -a :=
begin
  have : (a.val : ℤ) - n ≤ 0,
    by { erw [sub_nonpos, int.coe_nat_le], exact a.val_le, },
  rw [zmod.val_min_abs_def_pos],
  split_ifs,
  { rw [int.nat_abs_of_nat, nat_cast_zmod_val] },
  { rw [← int.cast_coe_nat, int.of_nat_nat_abs_of_nonpos this, int.cast_neg, int.cast_sub],
    rw [int.cast_coe_nat, int.cast_coe_nat, nat_cast_self, sub_zero, nat_cast_zmod_val], }
end

@[simp] lemma nat_abs_val_min_abs_neg {n : ℕ} (a : zmod n) :
  (-a).val_min_abs.nat_abs = a.val_min_abs.nat_abs :=
begin
  cases n, { simp only [int.nat_abs_neg, val_min_abs_def_zero], },
  by_cases ha0 : a = 0, { rw [ha0, neg_zero] },
  by_cases haa : -a = a, { rw [haa] },
  suffices hpa : (n+1 : ℕ) - a.val ≤ (n+1) / 2 ↔ (n+1 : ℕ) / 2 < a.val,
  { rw [val_min_abs_def_pos, val_min_abs_def_pos],
    rw ← not_le at hpa,
    simp only [if_neg ha0, neg_val, hpa, int.coe_nat_sub a.val_le],
    split_ifs,
    all_goals { rw [← int.nat_abs_neg], congr' 1, ring } },
  suffices : (((n+1 : ℕ) % 2) + 2 * ((n + 1) / 2)) - a.val ≤ (n+1) / 2 ↔ (n+1 : ℕ) / 2 < a.val,
  by rwa [nat.mod_add_div] at this,
  suffices : (n + 1) % 2 + (n + 1) / 2 ≤ val a ↔ (n + 1) / 2 < val a,
  by rw [tsub_le_iff_tsub_le, two_mul, ← add_assoc, add_tsub_cancel_right, this],
  cases (n + 1 : ℕ).mod_two_eq_zero_or_one with hn0 hn1,
  { split,
    { assume h,
      apply lt_of_le_of_ne (le_trans (nat.le_add_left _ _) h),
      contrapose! haa,
      rw [← zmod.nat_cast_zmod_val a, ← haa, neg_eq_iff_add_eq_zero, ← nat.cast_add],
      rw [char_p.cast_eq_zero_iff (zmod (n+1)) (n+1)],
      rw [← two_mul, ← zero_add (2 * _), ← hn0, nat.mod_add_div] },
    { rw [hn0, zero_add], exact le_of_lt } },
  { rw [hn1, add_comm, nat.succ_le_iff] }
end

lemma val_eq_ite_val_min_abs {n : ℕ} [fact (0 < n)] (a : zmod n) :
  (a.val : ℤ) = a.val_min_abs + if a.val ≤ n / 2 then 0 else n :=
by { rw [zmod.val_min_abs_def_pos], split_ifs; simp only [add_zero, sub_add_cancel] }

lemma prime_ne_zero (p q : ℕ) [hp : fact p.prime] [hq : fact q.prime] (hpq : p ≠ q) :
  (q : zmod p) ≠ 0 :=
by rwa [← nat.cast_zero, ne.def, eq_iff_modeq_nat, nat.modeq_zero_iff_dvd,
  ← hp.1.coprime_iff_not_dvd, nat.coprime_primes hp.1 hq.1]

end zmod

namespace zmod

variables (p : ℕ) [fact p.prime]

private lemma mul_inv_cancel_aux (a : zmod p) (h : a ≠ 0) : a * a⁻¹ = 1 :=
begin
  obtain ⟨k, rfl⟩ := nat_cast_zmod_surjective a,
  apply coe_mul_inv_eq_one,
  apply nat.coprime.symm,
  rwa [nat.prime.coprime_iff_not_dvd (fact.out p.prime), ← char_p.cast_eq_zero_iff (zmod p)]
end

/-- Field structure on `zmod p` if `p` is prime. -/
instance : field (zmod p) :=
{ mul_inv_cancel := mul_inv_cancel_aux p,
  inv_zero := inv_zero p,
  .. zmod.comm_ring p,
  .. zmod.has_inv p,
  .. zmod.nontrivial p }

/-- `zmod p` is an integral domain when `p` is prime. -/
instance (p : ℕ) [hp : fact p.prime] : is_domain (zmod p) :=
begin
  -- We need `cases p` here in order to resolve which `comm_ring` instance is being used.
  unfreezingI { cases p, { exact (nat.not_prime_zero hp.out).elim }, },
  exact @field.is_domain (zmod _) (zmod.field _)
end

end zmod

lemma ring_hom.ext_zmod {n : ℕ} {R : Type*} [semiring R] (f g : (zmod n) →+* R) : f = g :=
begin
  ext a,
  obtain ⟨k, rfl⟩ := zmod.int_cast_surjective a,
  let φ : ℤ →+* R := f.comp (int.cast_ring_hom (zmod n)),
  let ψ : ℤ →+* R := g.comp (int.cast_ring_hom (zmod n)),
  show φ k = ψ k,
  rw φ.ext_int ψ,
end

namespace zmod
variables {n : ℕ} {R : Type*}

instance subsingleton_ring_hom [semiring R] : subsingleton ((zmod n) →+* R) :=
⟨ring_hom.ext_zmod⟩

instance subsingleton_ring_equiv [semiring R] : subsingleton (zmod n ≃+* R) :=
⟨λ f g, by { rw ring_equiv.coe_ring_hom_inj_iff, apply ring_hom.ext_zmod _ _ }⟩

@[simp] lemma ring_hom_map_cast [ring R] (f : R →+* (zmod n)) (k : zmod n) :
  f k = k :=
by { cases n; simp }

lemma ring_hom_right_inverse [ring R] (f : R →+* (zmod n)) :
  function.right_inverse (coe : zmod n → R) f :=
ring_hom_map_cast f

lemma ring_hom_surjective [ring R] (f : R →+* (zmod n)) : function.surjective f :=
(ring_hom_right_inverse f).surjective

lemma ring_hom_eq_of_ker_eq [comm_ring R] (f g : R →+* (zmod n))
  (h : f.ker = g.ker) : f = g :=
begin
  have := f.lift_of_right_inverse_comp _ (zmod.ring_hom_right_inverse f) ⟨g, le_of_eq h⟩,
  rw subtype.coe_mk at this,
  rw [←this, ring_hom.ext_zmod (f.lift_of_right_inverse _ _ ⟨g, _⟩) _, ring_hom.id_comp],
end

section lift

variables (n) {A : Type*} [add_group A]

/-- The map from `zmod n` induced by `f : ℤ →+ A` that maps `n` to `0`. -/
@[simps]
def lift : {f : ℤ →+ A // f n = 0} ≃ (zmod n →+ A) :=
(equiv.subtype_equiv_right $ begin
  intro f,
  rw ker_int_cast_add_hom,
  split,
  { rintro hf _ ⟨x, rfl⟩,
    simp only [f.map_zsmul, zsmul_zero, f.mem_ker, hf] },
  { intro h,
    refine h (add_subgroup.mem_zmultiples _) }
end).trans $ ((int.cast_add_hom (zmod n)).lift_of_right_inverse coe int_cast_zmod_cast)

variables (f : {f : ℤ →+ A // f n = 0})

@[simp] lemma lift_coe (x : ℤ) :
  lift n f (x : zmod n) = f x :=
add_monoid_hom.lift_of_right_inverse_comp_apply _ _ _ _ _

lemma lift_cast_add_hom (x : ℤ) :
  lift n f (int.cast_add_hom (zmod n) x) = f x :=
add_monoid_hom.lift_of_right_inverse_comp_apply _ _ _ _ _

@[simp] lemma lift_comp_coe : zmod.lift n f ∘ coe = f :=
funext $ lift_coe _ _

@[simp] lemma lift_comp_cast_add_hom :
  (zmod.lift n f).comp (int.cast_add_hom (zmod n)) = f :=
add_monoid_hom.ext $ lift_cast_add_hom _ _

end lift

end zmod


/-
Copyright (c) 2020 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau, Johan Commelin, Patrick Massot
-/

import algebra.order.group
import tactic.abel

/-!
# Linearly ordered commutative groups and monoids with a zero element adjoined

This file sets up a special class of linearly ordered commutative monoids
that show up as the target of so-called “valuations” in algebraic number theory.

Usually, in the informal literature, these objects are constructed
by taking a linearly ordered commutative group Γ and formally adjoining a zero element: Γ ∪ {0}.

The disadvantage is that a type such as `nnreal` is not of that form,
whereas it is a very common target for valuations.
The solutions is to use a typeclass, and that is exactly what we do in this file.

Note that to avoid issues with import cycles, `linear_ordered_comm_monoid_with_zero` is defined
in another file. However, the lemmas about it are stated here.
-/

set_option old_structure_cmd true

/-- A linearly ordered commutative group with a zero element. -/
class linear_ordered_comm_group_with_zero (α : Type*)
  extends linear_ordered_comm_monoid_with_zero α, comm_group_with_zero α

variables {α : Type*}
variables {a b c d x y z : α}

instance [linear_ordered_add_comm_monoid_with_top α] :
  linear_ordered_comm_monoid_with_zero (multiplicative (order_dual α)) :=
{ zero := multiplicative.of_add (⊤ : α),
  zero_mul := top_add,
  mul_zero := add_top,
  zero_le_one := (le_top : (0 : α) ≤ ⊤),
  ..multiplicative.ordered_comm_monoid,
  ..multiplicative.linear_order }

instance [linear_ordered_add_comm_group_with_top α] :
  linear_ordered_comm_group_with_zero (multiplicative (order_dual α)) :=
{ inv_zero := linear_ordered_add_comm_group_with_top.neg_top,
  mul_inv_cancel := linear_ordered_add_comm_group_with_top.add_neg_cancel,
  ..multiplicative.div_inv_monoid,
  ..multiplicative.linear_ordered_comm_monoid_with_zero,
  ..multiplicative.nontrivial }

section monoid
variable [monoid α]

section preorder
variable [preorder α]

section left
variable [covariant_class α α (*) (≤)]

lemma left.one_le_pow_of_le : ∀ {n : ℕ} {x : α}, 1 ≤ x → 1 ≤ x^n
| 0       x _ := (pow_zero x).symm.le
| (n + 1) x H := calc 1 ≤ x          : H
                    ... = x * 1      : (mul_one x).symm
                    ... ≤ x * x ^ n  : mul_le_mul_left' (left.one_le_pow_of_le H) x
                    ... = x ^ n.succ : (pow_succ x n).symm

end left

section right
variable [covariant_class α α (function.swap (*)) (≤)]

lemma right.one_le_pow_of_le {x : α} (H : 1 ≤ x) :
  ∀ {n : ℕ}, 1 ≤ x^n
| 0       := (pow_zero _).symm.le
| (n + 1) := calc 1 ≤ x          : H
                ... = 1 * x      : (one_mul x).symm
                ... ≤ x ^ n * x  : mul_le_mul_right' right.one_le_pow_of_le x
                ... = x ^ n.succ : (pow_succ' x n).symm

lemma right.pow_le_one_of_le {x : α} (H : x ≤ 1) :
  ∀ {n : ℕ}, x^n ≤ 1
| 0       := (pow_zero _).le
| (n + 1) := calc x ^ n.succ = x ^ n * x : pow_succ' x n
                         ... ≤ 1 * x     : mul_le_mul_right' right.pow_le_one_of_le x
                         ... = x         : one_mul x
                         ... ≤ 1         : H

end right

lemma pow_le_pow_of_le [covariant_class α α (*) (≤)] [covariant_class α α (function.swap (*)) (≤)]
  {x y : α} (H : x ≤ y) :
  ∀ {n : ℕ} , x^n ≤ y^n
| 0       := (pow_zero _).le.trans (pow_zero _).symm.le
| (n + 1) := calc  x ^ n.succ = x * x ^ n  : pow_succ x n
                          ... ≤ y * x ^ n  : mul_le_mul_right' H (x ^ n)
                          ... ≤ y * y ^ n  : mul_le_mul_left' pow_le_pow_of_le y
                          ... = y ^ n.succ : (pow_succ y n).symm

lemma left.pow_lt_one_of_lt [covariant_class α α (*) (<)] {n : ℕ} {x : α} (n0 : 0 < n) (H : x < 1) :
  x^n < 1 :=
begin
  refine nat.le_induction ((pow_one _).le.trans_lt H) (λ n n1 hn, _) _ (nat.succ_le_iff.mpr n0),
  calc x ^ (n + 1) = x * x ^ n : pow_succ x n
               ... < x * 1     : mul_lt_mul_left' hn x
               ... = x         : mul_one x
               ... < 1         : H
end

lemma left.pow_lt_one_iff {α: Type*} [monoid α] [linear_order α]
  [covariant_class α α (*) (<)] {n : ℕ} {x : α} (n0 : 0 < n) :
  x^n < 1 ↔ x < 1 :=
⟨λ H, not_le.mp (λ k, not_le.mpr H (by
  { haveI := has_mul.to_covariant_class_left α,
    exact left.one_le_pow_of_le k})), left.pow_lt_one_of_lt n0⟩

lemma right.pow_lt_one_of_lt [covariant_class α α (function.swap (*)) (<)] {n : ℕ} {x : α}
  (n0 : 0 < n) (H : x < 1) :
  x^n < 1 :=
begin
  refine nat.le_induction ((pow_one _).le.trans_lt H) (λ n n1 hn, _) _ (nat.succ_le_iff.mpr n0),
  calc x ^ (n + 1) = x ^ n * x : pow_succ' x n
               ... < 1 * x     : mul_lt_mul_right' hn x
               ... = x         : one_mul x
               ... < 1         : H
end

lemma right.pow_lt_one_iff {α: Type*} [monoid α] [linear_order α]
  [covariant_class α α (function.swap (*)) (<)] {n : ℕ} {x : α} (n0 : 0 < n) :
  x^n < 1 ↔ x < 1 :=
⟨λ H, not_le.mp (λ k, not_le.mpr H (by
  { haveI := has_mul.to_covariant_class_right α,
    exact right.one_le_pow_of_le k})), right.pow_lt_one_of_lt n0⟩

end preorder

section left_right
variables [linear_order α]
  [covariant_class α α (*) (≤)] [covariant_class α α (function.swap (*)) (≤)]

end left_right

end monoid
instance [linear_ordered_comm_monoid α] :
  linear_ordered_comm_monoid_with_zero (with_zero α) :=
{ mul_le_mul_left := λ x y, mul_le_mul_left',
  zero_le_one     := with_zero.zero_le _,
  ..with_zero.linear_order,
  ..with_zero.comm_monoid_with_zero }

instance [linear_ordered_comm_group α] :
  linear_ordered_comm_group_with_zero (with_zero α) :=
{ ..with_zero.linear_ordered_comm_monoid_with_zero,
  ..with_zero.comm_group_with_zero }

section linear_ordered_comm_monoid

variables [linear_ordered_comm_monoid_with_zero α]
/-
The following facts are true more generally in a (linearly) ordered commutative monoid.
-/

/-- Pullback a `linear_ordered_comm_monoid_with_zero` under an injective map.
See note [reducible non-instances]. -/
@[reducible]
def function.injective.linear_ordered_comm_monoid_with_zero {β : Type*}
  [has_zero β] [has_one β] [has_mul β]
  (f : β → α) (hf : function.injective f) (zero : f 0 = 0) (one : f 1 = 1)
  (mul : ∀ x y, f (x * y) = f x * f y) :
  linear_ordered_comm_monoid_with_zero β :=
{ zero_le_one := show f 0 ≤ f 1, by simp only [zero, one,
    linear_ordered_comm_monoid_with_zero.zero_le_one],
  ..linear_order.lift f hf,
  ..hf.ordered_comm_monoid f one mul,
  ..hf.comm_monoid_with_zero f zero one mul }

lemma zero_le_one' : (0 : α) ≤ 1 :=
linear_ordered_comm_monoid_with_zero.zero_le_one

@[simp] lemma zero_le' : 0 ≤ a :=
by simpa only [mul_zero, mul_one] using mul_le_mul_left' (@zero_le_one' α _) a

@[simp] lemma not_lt_zero' : ¬a < 0 :=
not_lt_of_le zero_le'

@[simp] lemma le_zero_iff : a ≤ 0 ↔ a = 0 :=
⟨λ h, le_antisymm h zero_le', λ h, h ▸ le_rfl⟩

lemma zero_lt_iff : 0 < a ↔ a ≠ 0 :=
⟨ne_of_gt, λ h, lt_of_le_of_ne zero_le' h.symm⟩

lemma ne_zero_of_lt (h : b < a) : a ≠ 0 :=
λ h1, not_lt_zero' $ show b < 0, from h1 ▸ h

lemma pow_pos_iff [no_zero_divisors α] {n : ℕ} (hn : 0 < n) : 0 < a ^ n ↔ 0 < a :=
by simp_rw [zero_lt_iff, pow_ne_zero_iff hn]

instance : linear_ordered_add_comm_monoid_with_top (additive (order_dual α)) :=
{ top := (0 : α),
  top_add' := λ a, (zero_mul a : (0 : α) * a = 0),
  le_top := λ _, zero_le',
  ..additive.ordered_add_comm_monoid,
  ..additive.linear_order }

end linear_ordered_comm_monoid

variables [linear_ordered_comm_group_with_zero α]

lemma zero_lt_one₀ : (0 : α) < 1 :=
lt_of_le_of_ne zero_le_one' zero_ne_one

lemma le_of_le_mul_right (h : c ≠ 0) (hab : a * c ≤ b * c) : a ≤ b :=
by simpa only [mul_inv_cancel_right₀ h] using (mul_le_mul_right' hab c⁻¹)

lemma le_mul_inv_of_mul_le (h : c ≠ 0) (hab : a * c ≤ b) : a ≤ b * c⁻¹ :=
le_of_le_mul_right h (by simpa [h] using hab)

lemma mul_inv_le_of_le_mul (h : c ≠ 0) (hab : a ≤ b * c) : a * c⁻¹ ≤ b :=
le_of_le_mul_right h (by simpa [h] using hab)

lemma le_mul_inv_iff₀ (hc : c ≠ 0) : a ≤ b * c⁻¹ ↔ a * c ≤ b :=
⟨λ h, inv_inv₀ c ▸ mul_inv_le_of_le_mul (inv_ne_zero hc) h, le_mul_inv_of_mul_le hc⟩

lemma mul_inv_le_iff₀ (hc : c ≠ 0) : a * c⁻¹ ≤ b ↔ a ≤ b * c :=
⟨λ h, inv_inv₀ c ▸ le_mul_inv_of_mul_le (inv_ne_zero hc) h, mul_inv_le_of_le_mul hc⟩

lemma div_le_div₀ (a b c d : α) (hb : b ≠ 0) (hd : d ≠ 0) :
  a * b⁻¹ ≤ c * d⁻¹ ↔ a * d ≤ c * b :=
if ha : a = 0 then by simp [ha] else
if hc : c = 0 then by simp [inv_ne_zero hb, hc, hd] else
show (units.mk0 a ha) * (units.mk0 b hb)⁻¹ ≤ (units.mk0 c hc) * (units.mk0 d hd)⁻¹ ↔
  (units.mk0 a ha) * (units.mk0 d hd) ≤ (units.mk0 c hc) * (units.mk0 b hb),
from mul_inv_le_mul_inv_iff'

@[simp] lemma units.zero_lt (u : αˣ) : (0 : α) < u :=
zero_lt_iff.2 $ u.ne_zero

lemma mul_lt_mul_of_lt_of_le₀ (hab : a ≤ b) (hb : b ≠ 0) (hcd : c < d) : a * c < b * d :=
have hd : d ≠ 0 := ne_zero_of_lt hcd,
if ha : a = 0 then by { rw [ha, zero_mul, zero_lt_iff], exact mul_ne_zero hb hd } else
if hc : c = 0 then by { rw [hc, mul_zero, zero_lt_iff], exact mul_ne_zero hb hd } else
show (units.mk0 a ha) * (units.mk0 c hc) < (units.mk0 b hb) * (units.mk0 d hd),
from mul_lt_mul_of_le_of_lt hab hcd

lemma mul_lt_mul₀ (hab : a < b) (hcd : c < d) : a * c < b * d :=
mul_lt_mul_of_lt_of_le₀ hab.le (ne_zero_of_lt hab) hcd

lemma mul_inv_lt_of_lt_mul₀ (h : x < y * z) : x * z⁻¹ < y :=
have hz : z ≠ 0 := (mul_ne_zero_iff.1 $ ne_zero_of_lt h).2,
by { contrapose! h, simpa only [inv_inv₀] using mul_inv_le_of_le_mul (inv_ne_zero hz) h }

lemma inv_mul_lt_of_lt_mul₀ (h : x < y * z) : y⁻¹ * x < z :=
by { rw mul_comm at *, exact mul_inv_lt_of_lt_mul₀ h }

lemma mul_lt_right₀ (c : α) (h : a < b) (hc : c ≠ 0) : a * c < b * c :=
by { contrapose! h, exact le_of_le_mul_right hc h }

lemma pow_lt_pow_succ {x : α} {n : ℕ} (hx : 1 < x) : x ^ n < x ^ n.succ :=
by { rw [← one_mul (x ^ n), pow_succ],
exact mul_lt_right₀ _ hx (pow_ne_zero _ $ ne_of_gt (lt_trans zero_lt_one₀ hx)) }

lemma pow_lt_pow₀ {x : α} {m n : ℕ} (hx : 1 < x) (hmn : m < n) : x ^ m < x ^ n :=
by { induction hmn with n hmn ih, exacts [pow_lt_pow_succ hx, lt_trans ih (pow_lt_pow_succ hx)] }

lemma inv_lt_inv₀ (ha : a ≠ 0) (hb : b ≠ 0) : a⁻¹ < b⁻¹ ↔ b < a :=
show (units.mk0 a ha)⁻¹ < (units.mk0 b hb)⁻¹ ↔ (units.mk0 b hb) < (units.mk0 a ha),
from inv_lt_inv_iff

lemma inv_le_inv₀ (ha : a ≠ 0) (hb : b ≠ 0) : a⁻¹ ≤ b⁻¹ ↔ b ≤ a :=
show (units.mk0 a ha)⁻¹ ≤ (units.mk0 b hb)⁻¹ ↔ (units.mk0 b hb) ≤ (units.mk0 a ha),
from inv_le_inv_iff

lemma lt_of_mul_lt_mul_of_le₀ (h : a * b < c * d) (hc : 0 < c) (hh : c ≤ a) : b < d :=
begin
  have ha : a ≠ 0 := ne_of_gt (lt_of_lt_of_le hc hh),
  simp_rw ← inv_le_inv₀ ha (ne_of_gt hc) at hh,
  have := mul_lt_mul_of_lt_of_le₀ hh (inv_ne_zero (ne_of_gt hc)) h,
  simpa [inv_mul_cancel_left₀ ha, inv_mul_cancel_left₀ (ne_of_gt hc)] using this,
end

lemma mul_le_mul_right₀ (hc : c ≠ 0) : a * c ≤ b * c ↔ a ≤ b :=
⟨le_of_le_mul_right hc, λ hab, mul_le_mul_right' hab _⟩

lemma div_le_div_right₀ (hc : c ≠ 0) : a/c ≤ b/c ↔ a ≤ b :=
by rw [div_eq_mul_inv, div_eq_mul_inv, mul_le_mul_right₀ (inv_ne_zero hc)]

lemma le_div_iff₀ (hc : c ≠ 0) : a ≤ b/c ↔ a*c ≤ b :=
by rw [div_eq_mul_inv, le_mul_inv_iff₀ hc]

lemma div_le_iff₀ (hc : c ≠ 0) : a/c ≤ b ↔ a ≤ b*c :=
by rw [div_eq_mul_inv, mul_inv_le_iff₀ hc]

instance : linear_ordered_add_comm_group_with_top (additive (order_dual α)) :=
{ neg_top := inv_zero,
  add_neg_cancel := λ a ha, mul_inv_cancel ha,
  ..additive.sub_neg_monoid,
  ..additive.linear_ordered_add_comm_monoid_with_top,
  ..additive.nontrivial }

namespace monoid_hom

variables {R : Type*} [ring R] (f : R →* α)

theorem map_neg_one : f (-1) = 1 :=
(pow_eq_one_iff (nat.succ_ne_zero 1)).1 $
  calc f (-1) ^ 2 = f (-1) * f(-1) : sq _
              ... = f ((-1) * - 1) : (f.map_mul _ _).symm
              ... = f ( - - 1)     : congr_arg _ (neg_one_mul _)
              ... = f 1            : congr_arg _ (neg_neg _)
              ... = 1              : map_one f

@[simp] lemma map_neg (x : R) : f (-x) = f x :=
calc f (-x) = f (-1 * x)   : congr_arg _ (neg_one_mul _).symm
        ... = f (-1) * f x : map_mul _ _ _
        ... = 1 * f x      : _root_.congr_arg (λ g, g * (f x)) (map_neg_one f)
        ... = f x          : one_mul _

lemma map_sub_swap (x y : R) : f (x - y) = f (y - x) :=
calc f (x - y) = f (-(y - x)) : congr_arg _ (neg_sub _ _).symm
           ... = _            : map_neg _ _

end monoid_hom


import data.set.pointwise.smul
import mathlib.equiv
import mathlib.logic
import phase0.params

/-!
# Litters, near-litters

In this file, we define litters and near-litters.

Litters are the parts of an indexed partition of `con_nf.atom`. Their precise definition can be
considered opaque, as we only care about the fact that their cardinality is `κ`.

## Main declarations

* `con_nf.litter`: The `i`-th litter.
* `con_nf.is_near_litter`: A set is a `i`-near-litter if it is near the `i`-th litter.
-/

open cardinal cardinal.is_regular equiv equiv.perm function set
open_locale cardinal pointwise

universe u

namespace con_nf
variables [params.{u}] {α β : Type u}

variables {i j : litter} {s t : set atom}

/-- The set corresponding to the `i`-th litter.

We define a litter as the set of elements of the base type `τ₋₁` where the first element of the pair
is `i`. However, as noted above, the definition can be viewed as opaque, since its cardinality is
the only interesting feature. -/
def litter_set (i : litter) : set atom := {p | p.1 = i}

@[simp] lemma mem_litter_set {a : atom} {i : litter} : a ∈ litter_set i ↔ a.1 = i := iff.rfl

def litter_set_equiv (L : litter) : litter_set L ≃ κ :=
⟨λ x, x.1.2, λ k, ⟨(L, k), rfl⟩, λ x, subtype.ext $ prod.ext x.2.symm rfl, λ k, rfl⟩

/-- Each litter has cardinality `κ`. -/
@[simp] lemma mk_litter_set (i : litter) : #(litter_set i) = #κ :=
cardinal.eq.2 ⟨litter_set_equiv i⟩

/-- Two litters with different indices are disjoint. -/
lemma pairwise_disjoint_litter_set : pairwise (disjoint on litter_set) :=
λ i j h, disjoint_left.2 $ λ x hi hj, h $ hi.symm.trans hj

lemma eq_of_mem_litter_set_of_mem_litter_set {a : atom} (hi : a ∈ litter_set i)
  (hj : a ∈ litter_set j) : i = j :=
pairwise_disjoint_litter_set.eq $ not_disjoint_iff.2 ⟨_, hi, hj⟩

lemma litter_set_symm_diff_litter_set (h : i ≠ j) :
  litter_set i ∆ litter_set j = litter_set i ∪ litter_set j :=
(pairwise_disjoint_litter_set h).symm_diff_eq_sup

def litter_set_rel_iso (L : litter) : ((<) : litter_set L → litter_set L → Prop) ≃r κr :=
begin
  refine ⟨litter_set_equiv L, _⟩,
  rintros ⟨⟨La, a⟩, ha⟩ ⟨⟨Lb, b⟩, hb⟩,
  cases ha,
  cases hb,
  split,
  { intro h,
    exact prod.lex.right L h, },
  { rintro (⟨_, _, hL⟩ | ⟨_, hab⟩),
    cases lt_irrefl _ hL,
    exact hab, },
end

noncomputable def litter_set_order_iso (L : litter) : litter_set L ≃o κ :=
order_iso.of_rel_iso_lt (litter_set_rel_iso L)

/-- The order type of a litter is `κ`. -/
lemma litter.ordinal_type (L : litter) :
  ordinal.type ((<) : litter_set L → litter_set L → Prop) = (#κ).ord :=
by rw [← κ_ord, ordinal.type_eq]; exact ⟨litter_set_rel_iso L⟩

/-- A `i`-near-litter is a set of small symmetric difference to the `i`-th litter. In other words,
it is near the `i`-th litter.

Note that here we keep track of which litter a set is near; a set cannot be merely a near-litter, it
must be an `i`-near-litter for some `i`. A priori, a set could be an `i`-near-litter and also a
`j`-near-litter, but this is not the case. -/
def is_near_litter (i : litter) (s : set atom) : Prop := is_near (litter_set i) s

/-- Litter `i` is a near-litter to litter `i`.
Note that the type of litters is `set atom`, and the type of objects that can be near-litters
is also `set atom`. There is therefore no type-level distinction between elements of a litter
and elements of a near-litter. -/
lemma is_near_litter_litter_set (i : litter) : is_near_litter i (litter_set i) := is_near_rfl

@[simp] lemma is_near_litter_set : is_near (litter_set i) s ↔ is_near_litter i s := iff.rfl

/-- If two sets are `i`-near-litters, they are near each other.
This is because they are both near litter `i`, and nearness is transitive. -/
lemma is_near_litter.near (hs : is_near_litter i s) (ht : is_near_litter i t) : is_near s t :=
hs.symm.trans ht

lemma is_near_litter.mk_eq_κ (hs : is_near_litter i s) : #s = #κ :=
((le_mk_diff_add_mk _ _).trans $ add_le_of_le κ_regular.aleph_0_le
  (hs.mono $ subset_union_right _ _).lt.le (mk_litter_set _).le).eq_of_not_lt $ λ h,
    ((mk_litter_set _).symm.trans_le $ le_mk_diff_add_mk _ _).not_lt $
      add_lt_of_lt κ_regular.aleph_0_le (hs.mono $ subset_union_left _ _) h

protected lemma is_near_litter.nonempty (hs : is_near_litter i s) : s.nonempty :=
by { rw [←nonempty_coe_sort, ←mk_ne_zero_iff, hs.mk_eq_κ], exact κ_regular.pos.ne' }

/-- A litter is only a near-litter to itself. -/
@[simp] lemma is_near_litter_litter_set_iff : is_near_litter i (litter_set j) ↔ i = j :=
begin
  refine ⟨λ h, _, _⟩,
  { by_contra',
    refine ((mk_litter_set i).symm.trans_le $ mk_le_mk_of_subset _).not_lt h,
    change litter_set i ≤ _,
    exact (le_symm_diff_iff_left _ _).2 (pairwise_disjoint_litter_set this) },
  { rintro rfl,
    exact is_near_litter_litter_set _ }
end

/-- A set is near at most one litter. -/
lemma is_near_litter.unique {s : set atom} (hi : is_near_litter i s) (hj : is_near_litter j s) :
  i = j :=
is_near_litter_litter_set_iff.1 $ hi.trans hj.symm

/-- There are `μ` near-litters near the `i`-th litter. -/
@[simp] lemma mk_near_litter' (i : litter) : #{s // is_near_litter i s} = #μ :=
begin
  refine (le_antisymm _ _).trans mk_atom,
  { refine le_of_le_of_eq _
     (mk_subset_mk_lt_cof $ by { simp_rw mk_atom, exact μ_strong_limit.2 }),
    rw mk_atom,
    exact (cardinal.mk_congr $ subtype_equiv
      ((symm_diff_right_involutive $ litter_set i).to_perm _) $ λ s, iff.rfl).trans_le
        ⟨subtype.imp_embedding _ _ $ λ s, κ_le_μ_cof.trans_lt'⟩ },
  refine ⟨⟨λ a, ⟨litter_set i ∆ {a}, _⟩, λ a b h, _⟩⟩,
  { rw [is_near_litter, is_near, small, symm_diff_symm_diff_cancel_left, mk_singleton],
    exact one_lt_aleph_0.trans_le κ_regular.aleph_0_le },
  { exact singleton_injective (symm_diff_right_injective _ $ by convert congr_arg subtype.val h) }
end

/-- The type of near-litters. -/
def near_litter : Type* := Σ i, {s // is_near_litter i s}

namespace near_litter
variables {N₁ N₂ : near_litter}

instance : set_like near_litter atom :=
{ coe := λ N, N.2,
  coe_injective' :=
    by { rintro ⟨i, N₁, h₁⟩ ⟨j, N₂, h₂⟩ (rfl : N₁ = N₂), have := h₁.unique h₂, subst this } }

@[simp] lemma coe_mk (i : litter) (s : {s // is_near_litter i s}) :
  @coe near_litter (set atom) _ ⟨i, s⟩ = s := rfl

@[ext] lemma ext (h₁ : N₁.1 = N₂.1) (h₂ : (N₁ : set atom) = N₂) : N₁ = N₂ :=
by { cases N₁, cases N₂, dsimp at h₁, subst h₁, rw set_like.coe_injective h₂ }

/-- Reinterpret a near-litter as a product of a litter and a set of atoms. -/
@[simps]
def to_prod (N : near_litter) : litter × set atom := (N.1, N.2)

lemma to_prod_injective : injective to_prod :=
by { rintro ⟨i, s⟩ ⟨j, t⟩ h, rw prod.ext_iff at h, exact ext h.1 h.2 }

@[simp] protected lemma is_near_litter (N : near_litter) (i : litter) :
  is_near_litter i N ↔ N.fst = i :=
⟨is_near_litter.unique N.snd.prop, by { rintro rfl, exact N.2.2 }⟩

end near_litter

namespace litter

/-- Consider a litter as a near-litter. -/
def to_near_litter (i : litter) : near_litter := ⟨i, litter_set i, is_near_litter_litter_set i⟩

noncomputable instance : inhabited near_litter := ⟨(default : litter).to_near_litter⟩

@[simp] lemma to_near_litter_fst (i : litter) : i.to_near_litter.fst = i := rfl
@[simp] lemma coe_to_near_litter (i : litter) : (i.to_near_litter : set atom) = litter_set i := rfl

lemma to_near_litter_injective : injective litter.to_near_litter :=
λ i j hij, by { cases hij, refl }

end litter

/-- There are `μ` near-litters in total. -/
@[simp] lemma mk_near_litter : #near_litter = #μ :=
by { simp only [near_litter, mk_sigma, mk_near_litter', sum_const, mk_litter, lift_id],
  exact mul_eq_left (κ_regular.aleph_0_le.trans κ_le_μ) le_rfl μ_strong_limit.ne_zero }

/-- The *local cardinal* of a litter is the set of all near-litters to that litter. -/
def local_cardinal (i : litter) : set near_litter := {N : near_litter | N.1 = i}

@[simp] lemma mem_local_cardinal {i : litter} {N : near_litter} : N ∈ local_cardinal i ↔ N.1 = i :=
iff.rfl

lemma local_cardinal_nonempty (i : litter) : (local_cardinal i).nonempty :=
⟨⟨i, litter_set _, is_near_litter_litter_set _⟩, rfl⟩

lemma local_cardinal_disjoint : pairwise (disjoint on local_cardinal) :=
λ i j h, disjoint_left.2 $ λ N hi hj, h $ hi.symm.trans hj

lemma local_cardinal_injective : injective local_cardinal :=
begin
  intros i j hij,
  by_contradiction,
  have := (local_cardinal_disjoint h).inter_eq,
  rw [hij, inter_self] at this,
  exact (local_cardinal_nonempty _).ne_empty this,
end

lemma litter.to_near_litter_mem_local_cardinal (i : litter) : i.to_near_litter ∈ local_cardinal i :=
by exact rfl

@[simp] lemma mk_local_cardinal (i : litter) : #(local_cardinal i) = #μ :=
begin
  refine eq.trans (cardinal.eq.2 ⟨⟨_, λ x, ⟨⟨i, x⟩, rfl⟩, _, _⟩⟩) (mk_near_litter' i),
  { rintro ⟨x, (rfl : x.1 = i)⟩,
    exact x.snd },
  { rintro ⟨⟨j, S⟩, (rfl : j = i)⟩,
    refl },
  { exact λ x, rfl }
end

inductive near_litter.is_litter : near_litter → Prop
| mk (L : litter) : near_litter.is_litter L.to_near_litter

lemma near_litter.is_litter.eq_fst_to_near_litter {N : near_litter} (h : N.is_litter) :
  N = N.fst.to_near_litter := by cases h; refl

lemma near_litter.is_litter.litter_set_eq {N : near_litter} (h : N.is_litter) :
  litter_set N.fst = N.snd := by cases h; refl

lemma near_litter.is_litter.exists_litter_eq {N : near_litter} (h : N.is_litter) :
  ∃ (L : litter), N = L.to_near_litter := by obtain ⟨L⟩ := h; exact ⟨L, rfl⟩

lemma near_litter.not_is_litter {N : near_litter} (h : ¬N.is_litter) :
  litter_set N.fst ≠ N.snd :=
begin
  contrapose! h,
  obtain ⟨L, S, hS⟩ := N,
  simp only [subtype.coe_mk] at h,
  cases h,
  exact near_litter.is_litter.mk _,
end

lemma near_litter.inter_nonempty_of_fst_eq_fst {N₁ N₂ : near_litter} (h : N₁.fst = N₂.fst) :
  (N₁ ∩ N₂ : set atom).nonempty :=
begin
  by_contradiction h',
  rw set.not_nonempty_iff_eq_empty at h',
  have := N₁.2.prop,
  simp_rw h at this,
  have := small.mono (subset_union_left _ _) (N₂.2.prop.symm.trans this),
  -- Easy to solve with a couple of lemmas such as `#N = #κ`.
  sorry,
end

/--
A near-litter permutation is a permutation of the base type which sends near-litters to
near-litters. It turns out that the images of near-litters near the same litter are themselves near
the same litter. Hence a near-litter permutation induces a permutation of litters, and we keep that
as data for simplicity.

In the paper, this is called a -1-allowable permutation.
The proposition `near` can be interpreted as saying that if `s` is an `i`-near-litter, then its
image under the permutation (`atom_perm`) is near the litter that `i` is mapped to under the litter
permutation (`litter_perm`).

The definition `⇑atom_perm⁻¹ ⁻¹' s` is used instead of `⇑atom_perm '' s` because it has better
definitional properties. For instance, `x ∈ atom_perm⁻¹ ⁻¹' s` is definitionally equal to
`atom_perm x ∈ s`.
-/
structure near_litter_perm : Type u :=
(atom_perm : perm atom)
(litter_perm : perm litter)
(near ⦃i : litter⦄ ⦃s : set atom⦄ :
  is_near_litter i s → is_near_litter (litter_perm i) (⇑atom_perm⁻¹ ⁻¹' s))

/-- This is the condition that relates the `atom_perm` and the `litter_perm`. This is essentially
the field `near` in the structure `near_litter_perm`, but presented here as a lemma. -/
lemma is_near_litter.map {f : near_litter_perm} {s : set atom} (h : is_near_litter i s) :
  is_near_litter (f.litter_perm i) (⇑f.atom_perm⁻¹ ⁻¹' s) :=
f.near h

namespace near_litter_perm
variables {f g : near_litter_perm}

/-- The map from the type of near-litter permutations to the type of permutations of `τ₋₁` is
injective. That is, if two near-litter permutations have the same action on the base type, they are
equal. -/
lemma atom_perm_injective : injective near_litter_perm.atom_perm :=
begin
  rintro ⟨f, f', hf⟩ ⟨g, g', hg⟩ (h : f = g),
  suffices : f' = g',
  { subst h,
    subst this },
  ext i : 1,
  exact is_near_litter_litter_set_iff.1 (((hf $ is_near_litter_litter_set _).trans $ by rw h).trans
    (hg $ is_near_litter_litter_set _).symm),
end

/-- An extensionality result for near-litter permutations.
If two near-litter permutations have the same action on the base type, they are equal. -/
@[ext] lemma ext (h : f.atom_perm = g.atom_perm) : f = g := atom_perm_injective h

/-!
We are going to show that the set of near-litter permutations forms a group.
To do this, we construct several instances, such as the existence of an identity
element or inverse elements.
-/

/-- The identity near-litter permutation. -/
instance : has_one near_litter_perm := ⟨⟨1, 1, λ i s, id⟩⟩

/-- Any near-litter permutation admits an inverse, which is also a near-litter permutation. -/
instance : has_inv near_litter_perm :=
⟨λ f, ⟨f.atom_perm⁻¹, f.litter_perm⁻¹, λ i s h, begin
  have : is_near (⇑f.atom_perm⁻¹ ⁻¹' litter_set (f.litter_perm⁻¹ i)) s,
  { exact (f.near $ is_near_litter_litter_set _).near (by rwa apply_inv_self) },
  simpa only [preimage_inv, perm.image_inv, preimage_image] using this.image ⇑f.atom_perm⁻¹,
end⟩⟩

/-- Near-litter permutations can be composed. -/
instance : has_mul near_litter_perm :=
⟨λ f g, ⟨f.atom_perm * g.atom_perm, f.litter_perm * g.litter_perm, λ i s h, h.map.map⟩⟩

/-- Dividing two permutations `f / g` can be interpreted as `f⁻¹ * g`. -/
instance : has_div near_litter_perm :=
⟨λ f g, ⟨f.atom_perm / g.atom_perm, f.litter_perm / g.litter_perm,
  by { simp_rw [div_eq_mul_inv], exact (f * g⁻¹).near }⟩⟩

/-- We can raise near-litter permutations to a natural power since we can do this to
permutations of the base type and the type of litters. -/
instance has_pow : has_pow near_litter_perm ℕ :=
⟨λ f n, ⟨f.atom_perm ^ n, f.litter_perm ^ n, begin
  induction n with d hd,
  { exact (1 : near_litter_perm).near },
  { exact (f * ⟨f.atom_perm ^ d, f.litter_perm ^ d, hd⟩).near }
end⟩⟩

/-- We can raise near-litter permutations to an integer power since we can do this to
permutations of the base type and the type of litters. -/
instance has_zpow : has_pow near_litter_perm ℤ :=
⟨λ f n, ⟨f.atom_perm ^ n, f.litter_perm ^ n, begin
  cases n,
  { exact (f ^ n).near },
  { exact (f ^ (n + 1))⁻¹.near }
end⟩⟩

instance : inhabited near_litter_perm := ⟨1⟩

/-!
The following lemmas describe how the group of near-litter permutations interacts with the group of
base type permutations and the group of litter permutations. In particular, many group operations,
such as taking the inverse, can be moved out of the near-litter context and into the (simpler) base
permutation or litter permutation context.

The `@[simp]` attribute teaches these results to the `simp` tactic. This means that `simp` will (for
example) prefer group operations to be applied after extracting the base permutation, not before.
-/

@[simp] lemma atom_perm_one : (1 : near_litter_perm).atom_perm = 1 := rfl
@[simp] lemma atom_perm_inv (f : near_litter_perm) : f⁻¹.atom_perm = f.atom_perm⁻¹ := rfl
@[simp] lemma atom_perm_mul (f g : near_litter_perm) :
  (f * g).atom_perm = f.atom_perm * g.atom_perm := rfl
@[simp] lemma atom_perm_div (f g : near_litter_perm) :
  (f / g).atom_perm = f.atom_perm / g.atom_perm := rfl
@[simp] lemma atom_perm_pow (f : near_litter_perm) (n : ℕ) : (f ^ n).atom_perm = f.atom_perm ^ n :=
rfl
@[simp] lemma atom_perm_zpow (f : near_litter_perm) (n : ℤ) : (f ^ n).atom_perm = f.atom_perm ^ n :=
rfl

@[simp] lemma litter_perm_one : (1 : near_litter_perm).litter_perm = 1 := rfl
@[simp] lemma litter_perm_inv (f : near_litter_perm) : f⁻¹.litter_perm = f.litter_perm⁻¹ := rfl
@[simp] lemma litter_perm_mul (f g : near_litter_perm) :
  (f * g).litter_perm = f.litter_perm * g.litter_perm := rfl
@[simp] lemma litter_perm_div (f g : near_litter_perm) :
  (f / g).litter_perm = f.litter_perm / g.litter_perm := rfl
@[simp] lemma litter_perm_pow (f : near_litter_perm) (n : ℕ) :
  (f ^ n).litter_perm = f.litter_perm ^ n := rfl
@[simp] lemma litter_perm_zpow (f : near_litter_perm) (n : ℤ) :
  (f ^ n).litter_perm = f.litter_perm ^ n := rfl

/-- Near-litter permutations form a group. -/
instance : group near_litter_perm :=
atom_perm_injective.group _ atom_perm_one atom_perm_mul atom_perm_inv atom_perm_div atom_perm_pow
  atom_perm_zpow

/-- Near-litter permutations act on the base type via the base permutation. -/
instance : mul_action near_litter_perm atom :=
{ smul := λ f, f.atom_perm, one_smul := λ _, rfl, mul_smul := λ _ _ _, rfl }

/-- Near-litter permutations act on litters via the litter permutation. -/
instance : mul_action near_litter_perm litter :=
{ smul := λ f, f.litter_perm, one_smul := λ _, rfl, mul_smul := λ _ _ _, rfl }

lemma near_smul (f : near_litter_perm) (h : is_near_litter i s) : is_near_litter (f • i) (f • s) :=
by { convert f.near h, exact (preimage_inv _ _).symm }

instance : has_smul near_litter_perm near_litter :=
⟨λ f N, ⟨f • N.1, f • N, f.near_smul N.2.2⟩⟩

@[simp] lemma to_prod_smul (f : near_litter_perm) (N : near_litter) :
  (f • N).to_prod = f • N.to_prod := rfl

/-- Near-litter permutations act on near-litters. -/
instance : mul_action near_litter_perm near_litter :=
near_litter.to_prod_injective.mul_action _ to_prod_smul

@[simp] lemma smul_fst (π : near_litter_perm) (N : near_litter) : (π • N).fst = π • N.fst := rfl
@[simp] lemma coe_smul (π : near_litter_perm) (N : near_litter) :
  (↑(π • N) : set atom) = π • N := rfl

@[simp] lemma smul_local_cardinal (π : near_litter_perm) (i : litter) :
  π • local_cardinal i = local_cardinal (π • i) :=
by { ext N, simp [mem_smul_set, ←eq_inv_smul_iff] }

@[simp] lemma near_litter.mem_snd_iff (N : near_litter) (a : atom) :
  a ∈ (N.snd : set atom) ↔ a ∈ N := iff.rfl

@[simp] lemma near_litter.not_mem_snd_iff (N : near_litter) (a : atom) :
  a ∉ (N.snd : set atom) ↔ a ∉ N := iff.rfl

lemma smul_near_litter_eq_smul_symm_diff_smul (π : near_litter_perm) (N : near_litter) :
  (π • N : set atom) = (π • N.fst.to_near_litter) ∆ (π • (litter_set N.fst ∆ N.snd)) :=
begin
  ext a : 1,
  simp only [litter.coe_to_near_litter, mem_symm_diff, mem_smul_set_iff_inv_smul_mem,
    set_like.mem_coe, mem_litter_set, near_litter.mem_snd_iff, near_litter.not_mem_snd_iff],
  by_cases (π⁻¹ • a).fst = N.fst;
  simp only [h, eq_self_iff_true, true_and, and_true, not_true, and_false, false_and,
    or_false, false_or, not_not, not_false_iff],
end

end near_litter_perm
end con_nf


import .fv

namespace tts ------------------------------------------------------------------
namespace exp ------------------------------------------------------------------
variables {V : Type} -- Type of variable names
variables {x y : tagged V} -- Variable names
variables {e ex : exp V} -- Expressions

variables [decidable_eq V]

open occurs

/-- Substitute a free variable for an expression in an expression -/
def subst (x : tagged V) (ex : exp V) : exp V → exp V
| (var bound y)  := var bound y
| (var free y)   := if x = y then ex else var free y
| (app ef ea)    := app (subst ef) (subst ea)
| (lam v eb)     := lam v (subst eb)
| (let_ v ed eb) := let_ v (subst ed) (subst eb)

@[simp] theorem subst_var_bound : subst x ex (var bound y) = var bound y :=
rfl

@[simp] theorem subst_var_free_eq (h : x = y) :
  subst x ex (var free y) = ex :=
by simp [subst, h]

@[simp] theorem subst_var_free_ne (h : x ≠ y) :
  subst x ex (var free y) = var free y :=
by simp [subst, h]

@[simp] theorem subst_app {ef ea : exp V} :
  subst x ex (app ef ea) = app (subst x ex ef) (subst x ex ea) :=
rfl

@[simp] theorem subst_lam {v} {eb : exp V} :
  subst x ex (lam v eb) = lam v (subst x ex eb) :=
rfl

@[simp] theorem subst_let_ {v} {ed eb : exp V} :
  subst x ex (let_ v ed eb) = let_ v (subst x ex ed) (subst x ex eb) :=
rfl

@[simp] theorem subst_fresh (h : x ∉ fv e) : subst x ex e = e :=
by induction e with o; try {cases o}; try {simp at h}; try {cases h}; simp *

end /- namespace -/ exp --------------------------------------------------------
end /- namespace -/ tts --------------------------------------------------------


/-
Copyright (c) 2020 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta
-/
import category_theory.whiskering
import category_theory.functor.fully_faithful
import category_theory.natural_isomorphism

/-!
# Disjoint union of categories

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

We define the category structure on a sigma-type (disjoint union) of categories.
-/

namespace category_theory
namespace sigma

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

variables {I : Type w₁} {C : I → Type u₁} [Π i, category.{v₁} (C i)]

/--
The type of morphisms of a disjoint union of categories: for `X : C i` and `Y : C j`, a morphism
`(i, X) ⟶ (j, Y)` if `i = j` is just a morphism `X ⟶ Y`, and if `i ≠ j` there are no such morphisms.
-/
inductive sigma_hom : (Σ i, C i) → (Σ i, C i) → Type (max w₁ v₁ u₁)
| mk : Π {i : I} {X Y : C i}, (X ⟶ Y) → sigma_hom ⟨i, X⟩ ⟨i, Y⟩

namespace sigma_hom

/-- The identity morphism on an object. -/
def id : Π (X : Σ i, C i), sigma_hom X X
| ⟨i, X⟩ := mk (𝟙 _)

instance (X : Σ i, C i) : inhabited (sigma_hom X X) := ⟨id X⟩

/-- Composition of sigma homomorphisms. -/
def comp : Π {X Y Z : Σ i, C i}, sigma_hom X Y → sigma_hom Y Z → sigma_hom X Z
| _ _ _ (mk f) (mk g) := mk (f ≫ g)

instance : category_struct (Σ i, C i) :=
{ hom := sigma_hom,
  id := id,
  comp := λ X Y Z f g, comp f g }

@[simp]
lemma comp_def (i : I) (X Y Z : C i) (f : X ⟶ Y) (g : Y ⟶ Z) :
  comp (mk f) (mk g) = mk (f ≫ g) :=
rfl

lemma assoc : ∀ (X Y Z W : Σ i, C i) (f : X ⟶ Y) (g : Y ⟶ Z) (h : Z ⟶ W), (f ≫ g) ≫ h = f ≫ g ≫ h
| _ _ _ _ (mk f) (mk g) (mk h) := congr_arg mk (category.assoc _ _ _)

lemma id_comp : ∀ (X Y : Σ i, C i) (f : X ⟶ Y), 𝟙 X ≫ f = f
| _ _ (mk f) := congr_arg mk (category.id_comp _)

lemma comp_id : ∀ (X Y : Σ i, C i) (f : X ⟶ Y), f ≫ 𝟙 Y = f
| _ _ (mk f) := congr_arg mk (category.comp_id _)

end sigma_hom

instance sigma : category (Σ i, C i) :=
{ id_comp' := sigma_hom.id_comp,
  comp_id' := sigma_hom.comp_id,
  assoc' := sigma_hom.assoc }

/-- The inclusion functor into the disjoint union of categories. -/
@[simps map]
def incl (i : I) : C i ⥤ Σ i, C i :=
{ obj := λ X, ⟨i, X⟩,
  map := λ X Y, sigma_hom.mk }

@[simp] lemma incl_obj {i : I} (X : C i) : (incl i).obj X = ⟨i, X⟩ := rfl

instance (i : I) : full (incl i : C i ⥤ Σ i, C i) :=
{ preimage := λ X Y ⟨f⟩, f,
  witness' := λ X Y ⟨f⟩, rfl }.

instance (i : I) : faithful (incl i : C i ⥤ Σ i, C i) := {}.

section
variables {D : Type u₂} [category.{v₂} D] (F : Π i, C i ⥤ D)

/--
To build a natural transformation over the sigma category, it suffices to specify it restricted to
each subcategory.
-/
def nat_trans {F G : (Σ i, C i) ⥤ D} (h : Π (i : I), incl i ⋙ F ⟶ incl i ⋙ G) : F ⟶ G :=
{ app := λ ⟨j, X⟩, (h j).app X,
  naturality' := by { rintro ⟨j, X⟩ ⟨_, _⟩ ⟨f⟩, apply (h j).naturality } }

@[simp]

/-- (Implementation). An auxiliary definition to build the functor `desc`. -/
def desc_map : ∀ (X Y : Σ i, C i), (X ⟶ Y) → ((F X.1).obj X.2 ⟶ (F Y.1).obj Y.2)
| _ _ (sigma_hom.mk g) := (F _).map g

/--
Given a collection of functors `F i : C i ⥤ D`, we can produce a functor `(Σ i, C i) ⥤ D`.

The produced functor `desc F` satisfies: `incl i ⋙ desc F ≅ F i`, i.e. restricted to just the
subcategory `C i`, `desc F` agrees with `F i`, and it is unique (up to natural isomorphism) with
this property.

This witnesses that the sigma-type is the coproduct in Cat.
-/
@[simps obj]
def desc : (Σ i, C i) ⥤ D :=
{ obj := λ X, (F X.1).obj X.2,
  map := λ X Y g, desc_map F X Y g,
  map_id' := by { rintro ⟨i, X⟩, apply (F i).map_id },
  map_comp' := by { rintro ⟨i, X⟩ ⟨_, Y⟩ ⟨_, Z⟩ ⟨f⟩ ⟨g⟩, apply (F i).map_comp } }

@[simp]
lemma desc_map_mk {i : I} (X Y : C i) (f : X ⟶ Y) :
  (desc F).map (sigma_hom.mk f) = (F i).map f :=
rfl

/--
This shows that when `desc F` is restricted to just the subcategory `C i`, `desc F` agrees with
`F i`.
-/
-- We hand-generate the simp lemmas about this since they come out cleaner.
def incl_desc (i : I) : incl i ⋙ desc F ≅ F i :=
nat_iso.of_components (λ X, iso.refl _) (by tidy)

@[simp]
lemma incl_desc_hom_app (i : I) (X : C i) :
  (incl_desc F i).hom.app X = 𝟙 ((F i).obj X) :=
rfl

@[simp]
lemma incl_desc_inv_app (i : I) (X : C i) :
  (incl_desc F i).inv.app X = 𝟙 ((F i).obj X) :=
rfl

/--
If `q` when restricted to each subcategory `C i` agrees with `F i`, then `q` is isomorphic to
`desc F`.
-/
def desc_uniq (q : (Σ i, C i) ⥤ D) (h : Π i, incl i ⋙ q ≅ F i) : q ≅ desc F :=
nat_iso.of_components (λ ⟨i, X⟩, (h i).app X) $
  by { rintro ⟨i, X⟩ ⟨_, _⟩ ⟨f⟩, apply (h i).hom.naturality f }

@[simp]
lemma desc_uniq_hom_app (q : (Σ i, C i) ⥤ D) (h : Π i, incl i ⋙ q ≅ F i) (i : I) (X : C i) :
  (desc_uniq F q h).hom.app ⟨i, X⟩ = (h i).hom.app X :=
rfl

@[simp]
lemma desc_uniq_inv_app (q : (Σ i, C i) ⥤ D) (h : Π i, incl i ⋙ q ≅ F i) (i : I) (X : C i) :
  (desc_uniq F q h).inv.app ⟨i, X⟩ = (h i).inv.app X :=
rfl

/--
If `q₁` and `q₂` when restricted to each subcategory `C i` agree, then `q₁` and `q₂` are isomorphic.
-/
@[simps]
def nat_iso {q₁ q₂ : (Σ i, C i) ⥤ D} (h : Π i, incl i ⋙ q₁ ≅ incl i ⋙ q₂) :
  q₁ ≅ q₂ :=
{ hom := nat_trans (λ i, (h i).hom),
  inv := nat_trans (λ i, (h i).inv) }

end

section

variables (C) {J : Type w₂} (g : J → I)

/-- A function `J → I` induces a functor `Σ j, C (g j) ⥤ Σ i, C i`. -/
def map : (Σ (j : J), C (g j)) ⥤ (Σ (i : I), C i) :=
desc (λ j, incl (g j))

@[simp] lemma map_obj (j : J) (X : C (g j)) : (sigma.map C g).obj ⟨j, X⟩ = ⟨g j, X⟩ := rfl
@[simp] lemma map_map {j : J} {X Y : C (g j)} (f : X ⟶ Y) :
  (sigma.map C g).map (sigma_hom.mk f) = sigma_hom.mk f :=
rfl

/--
The functor `sigma.map C g` restricted to the subcategory `C j` acts as the inclusion of `g j`.
-/
@[simps]
def incl_comp_map (j : J) : incl j ⋙ map C g ≅ incl (g j) := iso.refl _

variable (I)

/-- The functor `sigma.map` applied to the identity function is just the identity functor. -/
@[simps]
def map_id : map C (id : I → I) ≅ 𝟭 (Σ i, C i) :=
nat_iso (λ i, nat_iso.of_components (λ X, iso.refl _) (by tidy))

variables {I} {K : Type w₃}

/-- The functor `sigma.map` applied to a composition is a composition of functors. -/
@[simps]
def map_comp (f : K → J) (g : J → I) : map (C ∘ g) f ⋙ (map C g : _) ≅ map C (g ∘ f) :=
desc_uniq _ _ $ λ k,
  (iso_whisker_right (incl_comp_map (C ∘ g) f k) (map C g : _) : _) ≪≫ incl_comp_map _ _ _

end

namespace functor

variables {C}
variables {D : I → Type u₁} [∀ i, category.{v₁} (D i)]

/--
Assemble an `I`-indexed family of functors into a functor between the sigma types.
-/
def sigma (F : Π i, C i ⥤ D i) : (Σ i, C i) ⥤ (Σ i, D i) :=
desc (λ i, F i ⋙ incl i)

end functor

namespace nat_trans

variables {C}
variables {D : I → Type u₁} [∀ i, category.{v₁} (D i)]
variables {F G : Π i, C i ⥤ D i}

/--
Assemble an `I`-indexed family of natural transformations into a single natural transformation.
-/
def sigma (α : Π i, F i ⟶ G i) : functor.sigma F ⟶ functor.sigma G :=
{ app := λ f, sigma_hom.mk ((α f.1).app _),
  naturality' :=
  begin
    rintro ⟨i, X⟩ ⟨_, _⟩ ⟨f⟩,
    change sigma_hom.mk _ = sigma_hom.mk _,
    rw (α i).naturality,
  end }

end nat_trans

end sigma
end category_theory


import SciLean.Core.Attributes
import SciLean.Core.Defs
import SciLean.Core.Meta.FunctionProperty
import SciLean.Core.Meta.RewriteBy

import SciLean.Tactic.AutoDiff

namespace SciLean

--------------------------------------------------------------------------------
-- isSmooth
--------------------------------------------------------------------------------

syntax "isSmooth" bracketedBinder* (":=" term)? : argProp

open Lean Parser.Term in
macro_rules
| `(function_property $id:ident $parms:bracketedBinder* $[: $retType:term]? argument $arg:argSpec isSmooth $extraAssumptions:bracketedBinder* $[:= $proof:term]?) => do

  let data ← FunctionPropertyData.parse id parms retType arg

  let instanceId := mkIdent $ data.funPropNamespace.append "isSmooth"

  let instanceType ← `(IsSmoothN $data.mainArgNumLit $(← data.mkLambda))
  let finalCommand ←
    match proof with
    | none =>
      `(instance (priority:=mid) $instanceId $data.contextBinders* $extraAssumptions* : $instanceType := by first | infer_instance | apply IsSmoothN.mk | (unfold $id; apply IsSmoothN.mk); done)
    | some proof =>
      `(instance (priority:=mid) $instanceId $data.contextBinders* $extraAssumptions* : $instanceType := $proof)

  return finalCommand

--------------------------------------------------------------------------------
-- isLin
--------------------------------------------------------------------------------

syntax "isLin" bracketedBinder* (":=" term)? : argProp

open Lean Parser.Term in
macro_rules
| `(function_property $id:ident $parms:bracketedBinder* $[: $retType:term]? argument $arg:argSpec isLin $extraAssumptions:bracketedBinder* $[:= $proof:term]?) => do

  let data ← FunctionPropertyData.parse id parms retType arg

  let instanceId := mkIdent $ data.funPropNamespace.append "isLin"

  let instanceType ← `(IsLinN $data.mainArgNumLit $(← data.mkLambda))
  let finalCommand ←
    match proof with
    | none =>
      `(instance (priority:=mid) $instanceId $data.contextBinders* $extraAssumptions* : $instanceType := by first | infer_instance | apply IsLinN.mk | (unfold $id; apply IsLinN.mk); done)
    | some proof =>
      `(instance (priority:=mid) $instanceId $data.contextBinders* $extraAssumptions* : $instanceType := $proof)

  return finalCommand

--------------------------------------------------------------------------------
-- hasAdjoint
--------------------------------------------------------------------------------

syntax "hasAdjoint" bracketedBinder* (":=" term)? : argProp

open Lean Parser.Term in
macro_rules
| `(function_property $id:ident $parms:bracketedBinder* $[: $retType:term]?
    argument $arg:argSpec
      hasAdjoint $extraAssumptions:bracketedBinder* $[:= $proof:term]?) => do

  let data ← FunctionPropertyData.parse id parms retType arg

  let instanceId := mkIdent $ data.funPropNamespace.append "hasAdjoint"

  let instanceType ← `(HasAdjointN $data.mainArgNumLit $(← data.mkLambda))
  let finalCommand ←
    match proof with
    | none =>
      `(instance (priority:=mid) $instanceId $data.contextBinders* $extraAssumptions* : $instanceType := by first | infer_instance | apply HasAdjointN.mk | (unfold $id; apply HasAdjointN.mk); done)
    | some proof =>
      `(instance (priority:=mid) $instanceId $data.contextBinders* $extraAssumptions* : $instanceType := $proof)

  return finalCommand

--------------------------------------------------------------------------------
-- hasAdjDiff
--------------------------------------------------------------------------------

theorem HasAdjDiffN.mk' {X Y : Type} {Xs Y' : Type} [SemiHilbert Xs] [SemiHilbert Y']
  {n : Nat} {f : X → Y} [Prod.Uncurry n (X → Y) Xs Y'] [IsSmoothT (uncurryN n f)]
  : (∀ x, HasAdjointT $ ∂ (uncurryN n f) x) → HasAdjDiffN n f
  := λ h => by
    have : HasAdjDiffNT n f := by constructor; infer_instance; infer_instance;
    apply HasAdjDiffN.mk

syntax "hasAdjDiff" bracketedBinder* (":=" term)? : argProp

open Lean Parser.Term in
macro_rules
| `(function_property $id:ident $parms:bracketedBinder* $[: $retType:term]?
    argument $arg:argSpec
      hasAdjDiff $extraAssumptions:bracketedBinder* $[:= $proof:term]?) => do

  let data ← FunctionPropertyData.parse id parms retType arg

  let instanceId := mkIdent $ data.funPropNamespace.append "hasAdjDiff"

  let instanceType ← `(HasAdjDiffN $data.mainArgNumLit $(← data.mkLambda))
  let finalCommand ←
    match proof with
    | none =>
      `(instance (priority:=mid) $instanceId $data.contextBinders* $extraAssumptions* : $instanceType := by apply HasAdjDiffN.mk'; symdiff; infer_instance; done)
    | some proof =>
      `(instance (priority:=mid) $instanceId $data.contextBinders* $extraAssumptions* : $instanceType := $proof)

  return finalCommand

--------------------------------------------------------------------------------

open Lean.Parser.Tactic.Conv

syntax defOrAbbrev := "def" <|> "abbrev"
syntax byConvTactic := "by" convSeq
syntax termAndProof := ":=" term "by" tacticSeq
syntax termWithProofOrConvTactic := termAndProof <|> byConvTactic

--------------------------------------------------------------------------------
-- ∂
--------------------------------------------------------------------------------

theorem tangentMap_auto_proof {X Y} [Vec X] [Vec Y]
  {f : X → Y} {df : X → X → Y} (h : ∂ f = df)
  : 𝒯 f = λ x dx => (f x, df x dx) := by simp[tangentMap, h]; done

syntax maybeTangentMap := "𝒯"
syntax defOrAbbrev "∂" (maybeTangentMap)? bracketedBinder* (mainArg)? (termWithProofOrConvTactic)? : argProp

open Lean Parser.Term in
macro_rules
| `(function_property $id:ident $parms:bracketedBinder* $[: $retType:term]?
    argument $arg:argSpec
      $doa:defOrAbbrev ∂ $[$doTanMap:maybeTangentMap]? $extraAssumptions:bracketedBinder* $[$dargs:mainArg]? $tpc:termWithProofOrConvTactic) => do

  let data ← FunctionPropertyData.parse id parms retType arg

  let lhs   := Syntax.mkCApp ``differential #[← data.mkUncurryLambda]
  let lhsTM := Syntax.mkCApp ``tangentMap #[← data.mkUncurryLambda]

  let mainBinder ← data.mainFunBinder

  let diffBinder ←
    match dargs with
    | none => data.mainBinders.mapM (λ b => b.modifyIdent λ ident => mkIdent <| ident.getId.appendBefore "d")
              >>= mkProdFunBinder
    | some _ => Macro.throwError "Specifying custom names is currently unsupported!"
  let trailingBinders ← data.trailingFunBinders

  let funVal ← data.mkApp

  let (rhs, proof, rhsTM) ←
    match tpc with
    | `(termWithProofOrConvTactic| := $df:term by $prf:tacticSeq) =>
      let rhs ← `(λ $mainBinder $diffBinder $trailingBinders* => $df)
      let proof ← `(by $prf)
      let rhsTM ←
        if trailingBinders.size = 0 then
          `(λ $mainBinder $diffBinder => ($funVal, $df))
        else
          `(λ $mainBinder $diffBinder => (λ $trailingBinders* => $funVal, λ  $trailingBinders* => $df))
      pure (rhs, proof, rhsTM)

    | `(termWithProofOrConvTactic| by $c:convSeq) =>
      let rhs ← `($lhs rewrite_by $c)
      let proof ← `(by apply AutoImpl.impl_eq_spec)
      if doTanMap.isSome then
        Macro.throwError "Using conv tactic to generate tangentMap is currently unsupported!"
      let rhsTM ← `($lhs rewrite_by $c)
      pure (rhs, proof, rhsTM)

    | _ =>  Macro.throwUnsupported

  let definition_name   := mkIdent $ data.funPropNamespace.append "diff"
  let simp_theorem_name := mkIdent $ data.funPropNamespace.append "diff_simp"

  let diff_command ←
    match doa with
    | `(defOrAbbrev| def) =>
      `(def $definition_name $data.contextBinders* := $rhs
        @[diff] theorem $simp_theorem_name $data.contextBinders* $extraAssumptions* : $lhs = $(data.mkAppContext definition_name) := $proof)
    | `(defOrAbbrev| abbrev) =>
      `(@[diff] theorem $simp_theorem_name $data.contextBinders* $extraAssumptions* : $lhs = $rhs := $proof)
    | _ => Macro.throwUnsupported

  if doTanMap.isNone then
    return diff_command

  let tangentMapProof := Syntax.mkCApp ``tangentMap_auto_proof #[data.mkAppContext simp_theorem_name]

  let definition_name   := mkIdent $ data.funPropNamespace.append "tangentMap"
  let simp_theorem_name := mkIdent $ data.funPropNamespace.append "tangentMap_simp"

  let tangentMap_command : TSyntax `command ←
    match doa with
    | `(defOrAbbrev| def) =>
      `(def $definition_name $data.contextBinders* := $rhsTM
        @[diff] theorem $simp_theorem_name $data.contextBinders* $extraAssumptions* : $lhsTM = $(data.mkAppContext definition_name) := $proof)
    | `(defOrAbbrev| abbrev) =>
      `(@[diff] theorem $simp_theorem_name $data.contextBinders* $extraAssumptions* : $lhsTM = $rhsTM := $tangentMapProof)
    | _ => Macro.throwUnsupported

  `($diff_command:command
    $tangentMap_command:command)

--------------------------------------------------------------------------------
-- 𝒯
--------------------------------------------------------------------------------

syntax defOrAbbrev "𝒯" bracketedBinder* (mainArg)? (termWithProofOrConvTactic)? : argProp

open Lean Parser.Term in
macro_rules
| `(function_property $id:ident $parms:bracketedBinder* $[: $retType:term]?
    argument $arg:argSpec
      $doa:defOrAbbrev 𝒯 $extraAssumptions:bracketedBinder* $[$dargs:mainArg]? $tpc:termWithProofOrConvTactic) => do

  let data ← FunctionPropertyData.parse id parms retType arg

  let lhs := Syntax.mkCApp ``tangentMap #[← data.mkUncurryLambda]

  let mainBinder ← data.mainFunBinder

  let diffBinder ←
    match dargs with
    | none => data.mainBinders.mapM (λ b => b.modifyIdent λ ident => mkIdent <| ident.getId.appendBefore "d")
              >>= mkProdFunBinder
    | some _ => Macro.throwError "Specifying custom names is currently unsupported!"
  let trailingBinders ← data.trailingFunBinders

  let (rhs, proof) ←
    match tpc with
    | `(termWithProofOrConvTactic| := $Tf:term by $proof:tacticSeq) =>
      let rhs ←
        `(λ $mainBinder $diffBinder => $Tf)
      let proof ← `(by $proof)
      pure (rhs, proof)

    | `(termWithProofOrConvTactic| by $c:convSeq) =>
      let rhs ← `($lhs rewrite_by $c)
      let proof ← `(by apply AutoImpl.impl_eq_spec)
      pure (rhs, proof)

    | _ =>  Macro.throwUnsupported

  let definition_name   := mkIdent $ data.funPropNamespace.append "tangentMap"
  let simp_theorem_name := mkIdent $ data.funPropNamespace.append "tangentMap_simp"

  match doa with
  | `(defOrAbbrev| def) =>
    `(
    def $definition_name $data.contextBinders* := $rhs
    @[diff] theorem $simp_theorem_name $data.contextBinders* $extraAssumptions* : $lhs = $(data.mkAppContext definition_name) := $proof
    #print $definition_name
    #check $simp_theorem_name
    )
  | `(defOrAbbrev| abbrev) =>
    `(
    @[diff] theorem $simp_theorem_name $data.contextBinders* $extraAssumptions* : $lhs = $rhs := $proof
    #check $simp_theorem_name
    )
  | _ => Macro.throwUnsupported

--------------------------------------------------------------------------------
-- †
--------------------------------------------------------------------------------

syntax defOrAbbrev "†" bracketedBinder* (mainArg)? (termWithProofOrConvTactic)? : argProp

open Lean Parser.Term in
macro_rules
| `(function_property $id:ident $parms:bracketedBinder* $[: $retType:term]?
    argument $arg:argSpec
      $doa:defOrAbbrev † $extraAssumptions:bracketedBinder* $[$dargs:mainArg]? $tpc:termWithProofOrConvTactic) => do

  let data ← FunctionPropertyData.parse id parms retType arg

  let lhs := Syntax.mkCApp ``adjoint #[← data.mkUncurryLambda]

  let mainBinder ← data.mainFunBinder

  let x' := mkIdent s!"{data.mainArgString}'"
  let adjBinder : TSyntax ``funBinder ← `(($x'))

  let (rhs, proof) ←
    match tpc with
    | `(termWithProofOrConvTactic| := $ft:term by $prf:tacticSeq) =>
      let mainType ← data.mainArgType
      let rhs ← `(λ $adjBinder => (($ft) : $mainType))
      let proof ← `(by $prf)

      pure (rhs, proof)

    | `(termWithProofOrConvTactic| by $c:convSeq) =>
      let rhs ← `($lhs rewrite_by $c)
      let proof ← `(by apply AutoImpl.impl_eq_spec)

      pure (rhs, proof)

    | _ =>  Macro.throwUnsupported

  let definition_name   := mkIdent $ data.funPropNamespace.append "adjoint"
  let simp_theorem_name := mkIdent $ data.funPropNamespace.append "adjoint_simp"

  match doa with
  | `(defOrAbbrev| def) =>
    `(
    def $definition_name $data.contextBinders* := $rhs
    @[diff] theorem $simp_theorem_name $data.contextBinders* $extraAssumptions* : $lhs = $(data.mkAppContext definition_name) := $proof
    #print $definition_name
    #check $simp_theorem_name
    )
  | `(defOrAbbrev| abbrev) =>
    `(
    @[diff] theorem $simp_theorem_name $data.contextBinders* $extraAssumptions* : $lhs = $rhs := $proof
    #check $simp_theorem_name
    )
  | _ => Macro.throwUnsupported

--------------------------------------------------------------------------------

theorem revDiff_auto_proof {X Y} [SemiHilbert X] [SemiHilbert Y]
  {f : X → Y} {df' : X → Y → X} (h : ∂† f = df')
  : ℛ f = λ x => (f x, λ dy => df' x dy) := by simp[reverseDifferential, h]; done

syntax maybeRevDiff := "ℛ"
syntax defOrAbbrev "∂†" (maybeRevDiff)? bracketedBinder* (mainArg)? (termWithProofOrConvTactic)? : argProp

open Lean Parser.Term in
macro_rules
| `(function_property $id:ident $parms:bracketedBinder* $[: $retType:term]?
    argument $arg:argSpec
      $doa:defOrAbbrev ∂† $[$doRevDiff:maybeRevDiff]? $extraAssumptions:bracketedBinder* $[$dargs:mainArg]? $tpc:termWithProofOrConvTactic) => do

  let data ← FunctionPropertyData.parse id parms retType arg

  let lhs := Syntax.mkCApp ``adjointDifferential #[← data.mkUncurryLambda]
  let lhsRD := Syntax.mkCApp ``reverseDifferential #[← data.mkUncurryLambda]

  let mainBinder ← data.mainFunBinder

  let x' := mkIdent s!"d{data.mainArgString}'"
  let adjBinder : TSyntax ``funBinder ←
    match retType with
    | .some T => `(($x' : $T))
    | .none => `(($x'))

  let funVal ← data.mkApp

  dbg_trace (← data.mainArgType).raw.prettyPrint

  let (rhs, proof, rhsRD, proofRD) ←
    match tpc with
    | `(termWithProofOrConvTactic| := $ft:term by $prf:tacticSeq) =>
      let mainType ← data.mainArgType
      let rhs ← `(λ $mainBinder $adjBinder => (($ft) : $mainType))
      let proof ← `(by $prf)

      let rhsRD ← `(λ $mainBinder => ($funVal, λ $adjBinder => (($ft) : $mainType)))
      let proofRD ← `(by $prf)

      pure (rhs, proof, rhsRD, proofRD)

    | `(termWithProofOrConvTactic| by $c:convSeq) =>
      let rhs ← `($lhs rewrite_by $c)
      let proof ← `(by apply AutoImpl.impl_eq_spec)

      if doRevDiff.isSome then
        Macro.throwError "Using conv tactic to generate reverse differential is currently unsupported!"
      let rhsRD ← `($lhs rewrite_by $c)
      let proofRD ← `(by apply AutoImpl.impl_eq_spec)

      pure (rhs, proof, rhsRD, proofRD)

    | _ =>  Macro.throwUnsupported

  let definition_name   := mkIdent $ data.funPropNamespace.append "adjDiff"
  let simp_theorem_name := mkIdent $ data.funPropNamespace.append "adjDiff_simp"

  let adjDiff_command ←
    match doa with
    | `(defOrAbbrev| def) =>
      `(def $definition_name $data.contextBinders* := $rhs
        @[diff] theorem $simp_theorem_name $data.contextBinders* $extraAssumptions* : $lhs = $(data.mkAppContext definition_name) := $proof)
    | `(defOrAbbrev| abbrev) =>
      `(@[diff] theorem $simp_theorem_name $data.contextBinders* $extraAssumptions* : $lhs = $rhs := $proof)
    | _ => Macro.throwUnsupported

  if doRevDiff.isNone then
    return adjDiff_command

  let revDiffProof := Syntax.mkCApp ``revDiff_auto_proof #[data.mkAppContext simp_theorem_name]

  let definition_name   := mkIdent $ data.funPropNamespace.append "revDiff"
  let simp_theorem_name := mkIdent $ data.funPropNamespace.append "revDiff_simp"

  let revDiff_command ←
    match doa with
    | `(defOrAbbrev| def) =>
      `(def $definition_name $data.contextBinders* := $rhsRD
        @[diff] theorem $simp_theorem_name $data.contextBinders* $extraAssumptions* : $lhsRD = $(data.mkAppContext definition_name) := $proofRD)
    | `(defOrAbbrev| abbrev) =>
      `(@[diff] theorem $simp_theorem_name $data.contextBinders* $extraAssumptions* : $lhsRD = $rhsRD := $revDiffProof)
    | _ => Macro.throwUnsupported

  `($adjDiff_command:command
    $revDiff_command:command)
--------------------------------------------------------------------------------

syntax defOrAbbrev "ℛ" bracketedBinder* (mainArg)? (termWithProofOrConvTactic)? : argProp

open Lean Parser.Term in
macro_rules
| `(function_property $id:ident $parms:bracketedBinder* $[: $retType:term]?
    argument $arg:argSpec
      $doa:defOrAbbrev ℛ $extraAssumptions:bracketedBinder* $[$dargs:mainArg]? $tpc:termWithProofOrConvTactic) => do

  let data ← FunctionPropertyData.parse id parms retType arg

  let lhs := Syntax.mkCApp ``reverseDifferential #[← data.mkUncurryLambda]

  let mainBinder ← data.mainFunBinder

  dbg_trace (← data.mainArgType).raw.prettyPrint

  let (rhs, proof) ←
    match tpc with
    | `(termWithProofOrConvTactic| := $Rf:term by $proof:tacticSeq) =>
      let mainType ← data.mainArgType
      let rhs ← `(λ $mainBinder => $Rf)
      let proof ← `(by $proof)
      pure (rhs, proof)

    | `(termWithProofOrConvTactic| by $c:convSeq) =>
      let rhs ← `($lhs rewrite_by $c)
      let proof ← `(by apply AutoImpl.impl_eq_spec)
      pure (rhs, proof)

    | _ =>  Macro.throwUnsupported

  let definition_name   := mkIdent $ data.funPropNamespace.append "revDiff"
  let simp_theorem_name := mkIdent $ data.funPropNamespace.append "revDiff_simp"

  dbg_trace lhs.raw.prettyPrint
  dbg_trace rhs.raw.prettyPrint

  match doa with
  | `(defOrAbbrev| def) =>
    `(
    def $definition_name $data.contextBinders* := $rhs
    @[diff] theorem $simp_theorem_name $data.contextBinders* $extraAssumptions* : $lhs = $(data.mkAppContext definition_name) := $proof
    #print $definition_name
    #check $simp_theorem_name
    )
  | `(defOrAbbrev| abbrev) =>
    `(
    @[diff] theorem $simp_theorem_name $data.contextBinders* $extraAssumptions* : $lhs = $rhs := $proof
    #check $simp_theorem_name
    )
  | _ => Macro.throwUnsupported

-- variable [SemiHilbert X] [Hilbert X]