import new.unordered.C
import data.nat.parity
import algebra.category.Group.colimits
import lemmas.lemmas
import algebra.big_operators

noncomputable theory

section

open topological_space Top Top.sheaf
open category_theory
open opposite
open nat

open_locale big_operators

universe u
variables {X : Top.{u}} (𝓕 : sheaf Ab X) (U : X.oc)
variable (n : ℕ)

section

variables {n 𝓕 U}

/--
`α = (i₀,⋯,i_{n+1})` then if `k` is even,
we write `f (i_0, ..., i_{k-1}, i_{k+1}, ..., i_{n+1}) ∈ 𝓕(U_0 ∩ ... ∩ U_{k-1} ∩ U_{k+1} ∩ ... ∩ U_{n+1})` restricted to `U_0 ∩ ... ∩ U_{n+1}`
-/
def d.to_fun.component' (α : fin (n + 1) → U.ι) (k : fin (n + 1)) (f : C.pre 𝓕 U n)  :
  𝓕.1.obj (op (face α)) :=
(ite (even k.1) id (has_neg.neg)) $
  𝓕.1.map (hom_of_le $ face.le_ignore α k).op $ f (ignore α k)

lemma map_congr.vec_eq (f : C.pre 𝓕 U n) {α β : fin n → U.ι} (EQ : α = β) :
  f α = 𝓕.1.map (eq_to_hom $ by rw EQ).op (f β) :=
begin
  subst EQ,
  rw [eq_to_hom_op, eq_to_hom_map],
  refl,
end

def d.to_fun.component (k : fin (n + 1)) :
  C.pre 𝓕 U n → C.pre 𝓕 U (n + 1) :=
λ f α, d.to_fun.component' α k f

def d.to_fun (f : C.pre 𝓕 U n) (α : fin (n + 1) → U.ι) : 𝓕.1.obj (op (face α)) :=
∑ (k : fin (n + 1)), d.to_fun.component k f α

end

-- instance {n : ℕ} : add_comm_group (C.pre 𝓕 U n) := by apply_instance
def d : (C 𝓕 U n) ⟶ (C 𝓕 U (n+1)) :=
{ to_fun := λ f α, d.to_fun f α,
  map_zero' := begin
    ext1 α,
    simp only [C_pre.zero_apply],
    change ∑ _, _ = _,
    rw finset.sum_eq_zero,
    intros i _,
    change (ite _ id _) _ = _,
    split_ifs,
    { rw [id, C_pre.zero_apply, map_zero], },
    { rw [C_pre.zero_apply, map_zero, neg_zero], },
  end,
  map_add' := λ f g, begin
    ext1 α,
    dsimp only,
    change ∑ _, _ = ∑ _, _ + ∑ _, _,
    rw ← finset.sum_add_distrib,
    rw finset.sum_congr rfl,
    intros i _,
    change (ite _ id _) _ = (ite _ id _) _ + (ite _ id _) _,
    split_ifs,
    { rw [id, id, id, C_pre.add_apply, map_add], },
    { rw [C_pre.add_apply, map_add, neg_add], },
  end }

abbreviation dd : C 𝓕 U n ⟶ C 𝓕 U (n + 2) := d 𝓕 U n ≫ d 𝓕 U (n + 1)

namespace dd_aux

lemma d_def (f : C 𝓕 U n) (α : fin (n + 1) → U.ι) :
  d 𝓕 U n f α =
  ∑ (i : fin (n+1)),
    (ite (even i.1) id has_neg.neg)
      𝓕.1.map (hom_of_le $ face.le_ignore α i).op (f (ignore α i)) :=
begin
  rw [d],
  simp only [add_monoid_hom.coe_mk, fin.val_eq_coe],
  change ∑ _, _ = _,
  rw finset.sum_congr rfl,
  intros i _,
  change (ite _ id _) _ = _,
  split_ifs,
  { rw [id, id], },
  { simp, },
end

lemma eq1 (f : C 𝓕 U n) (α : fin (n + 2) → U.ι) :
  dd 𝓕 U n f α =
  d 𝓕 U (n + 1) (d 𝓕 U n f) α := rfl

lemma eq2 (f : C 𝓕 U n) (α : fin (n + 2) → U.ι) :
  dd 𝓕 U n f α =
  ∑ (i : fin (n + 2)),
    (ite (even i.1) id has_neg.neg)
      (𝓕.1.map (hom_of_le (face.le_ignore α i)).op (d 𝓕 U n f (ignore α i))) :=
begin
  rw [eq1, d_def, finset.sum_congr rfl],
  intros i _,
  split_ifs,
  { simp },
  { simp },
end

lemma eq3 (f : C 𝓕 U n) (α : fin (n + 2) → U.ι) :
  dd 𝓕 U n f α =
  ∑ (i : fin (n + 2)),
    (ite (even i.1) id has_neg.neg)
      (𝓕.1.map (hom_of_le (face.le_ignore α i)).op
        (∑ (j : fin (n + 1)),
          (ite (even j.1) id has_neg.neg)
            (𝓕.1.map (hom_of_le (face.le_ignore (ignore α i) j)).op (f (ignore (ignore α i) j))))) :=
begin
  rw [eq2, finset.sum_congr rfl],
  intros i _,
  rw [d_def],
  split_ifs,
  { simp only [id.def],
    rw [add_monoid_hom.map_sum, add_monoid_hom.map_sum, finset.sum_congr rfl],
    intros j _,
    split_ifs,
    { rw [id, id], },
    { simp only [pi.neg_apply, add_monoid_hom.neg_apply], }, },
  { congr' 2,
    rw [finset.sum_congr rfl],
    intros j _,
    split_ifs,
    { rw [id, id], },
    { simp } },
end

lemma eq4 (f : C 𝓕 U n) (α : fin (n + 2) → U.ι) :
  dd 𝓕 U n f α =
  ∑ (i : fin (n + 2)),
    (ite (even i.1) id has_neg.neg)
      (∑ (j : fin (n + 1)),
        𝓕.1.map (hom_of_le (face.le_ignore α i)).op
          ((ite (even j.1) id has_neg.neg)
            𝓕.1.map (hom_of_le (face.le_ignore (ignore α i) j)).op
              (f (ignore (ignore α i) j)))) :=
begin
  rw [eq3, finset.sum_congr rfl],
  intros i _,
  split_ifs,
  { rw [add_monoid_hom.map_sum, id, id, finset.sum_congr rfl],
    intros j _,
    split_ifs,
    { rw [id, id], },
    { simp }, },
  { rw [add_monoid_hom.map_sum, finset.neg_sum, finset.neg_sum, finset.sum_congr rfl],
    intros j _,
    split_ifs,
    { rw [id, id], },
    { simp }, },
end

lemma eq5 (f : C 𝓕 U n) (α : fin (n + 2) → U.ι) :
  dd 𝓕 U n f α =
  ∑ (i : fin (n + 2)),
    (ite (even i.1) id has_neg.neg)
      (∑ (j : fin (n + 1)),
        (ite (even j.1) id has_neg.neg)
        (𝓕.1.map (hom_of_le (face.le_ignore α i)).op
          (𝓕.1.map (hom_of_le (face.le_ignore (ignore α i) j)).op
            (f (ignore (ignore α i) j))))) :=
begin
  rw [eq4, finset.sum_congr rfl],
  intros i _,
  split_ifs,
  { rw [id, id, finset.sum_congr rfl],
    intros j _,
    split_ifs,
    { rw [id, id], },
    { simp }, },
  { rw [finset.neg_sum, finset.neg_sum, finset.sum_congr rfl],
    intros j _,
    split_ifs,
    { rw [id, id], },
    { simp, }, },
end

lemma eq6₀ (f : C 𝓕 U n) (α : fin (n + 2) → U.ι) :
  dd 𝓕 U n f α =
  ∑ (i : fin (n + 2)),
    (ite (even i.1) id has_neg.neg)
      (∑ (j : fin (n + 1)),
        (ite (even j.1) id has_neg.neg)
        (𝓕.1.map ((hom_of_le (face.le_ignore (ignore α i) j)).op ≫ (hom_of_le (face.le_ignore α i)).op)
            (f (ignore (ignore α i) j)))) :=
begin
  rw [eq5, finset.sum_congr rfl],
  intros i _,
  split_ifs,
  { rw [id, id, finset.sum_congr rfl],
    intros j _,
    split_ifs,
    { rw [id, id, 𝓕.1.map_comp, comp_apply], },
    { rw [𝓕.1.map_comp, comp_apply] }, },
  { rw [finset.neg_sum, finset.neg_sum, finset.sum_congr rfl],
    intros j _,
    split_ifs,
    { rw [id, id, 𝓕.1.map_comp, comp_apply] },
    { rw [neg_neg, neg_neg, 𝓕.1.map_comp, comp_apply] }, }
end

lemma eq6₁ (f : C 𝓕 U n) (α : fin (n + 2) → U.ι) :
  dd 𝓕 U n f α =
  ∑ (i : fin (n + 2)),
    (ite (even i.1) id has_neg.neg)
      (∑ (j : fin (n + 1)),
        (ite (even j.1) id has_neg.neg)
        (𝓕.1.map (hom_of_le (face.le_ignore α i) ≫ hom_of_le (face.le_ignore (ignore α i) j)).op)
            (f (ignore (ignore α i) j))) :=
begin
  rw [eq6₀, finset.sum_congr rfl],
  intros i _,
  split_ifs,
  { rw [id, id, finset.sum_congr rfl],
    intros j _,
    split_ifs,
    { rw [id, id, op_comp], },
    { rw [op_comp],
      simp }, },
  { rw [finset.neg_sum, finset.neg_sum, finset.sum_congr rfl],
    intros j _,
    split_ifs,
    { rw [id, id, op_comp] },
    { rw [op_comp],
      simp }, }
end

lemma eq6₂ (f : C 𝓕 U n) (α : fin (n + 2) → U.ι) :
  dd 𝓕 U n f α =
  ∑ (i : fin (n + 2)),
    (ite (even i.1) id has_neg.neg)
      (∑ (j : fin (n + 1)),
        (ite (even j.1) id has_neg.neg)
        (𝓕.1.map (hom_of_le (face.le_ignore₂ α i j)).op)
            (f (ignore₂ α i j))) :=
begin
  rw [eq6₁, finset.sum_congr rfl],
  intros i _,
  split_ifs,
  { rw [id, id, finset.sum_congr rfl],
    intros j _,
    split_ifs,
    { rw [id, id], congr, },
    { congr, }, },
  { rw [finset.neg_sum, finset.neg_sum, finset.sum_congr rfl],
    intros j _,
    split_ifs,
    { rw [id, id], congr, },
    { congr }, },
end

lemma eq7 (f : C 𝓕 U n) (α : fin (n + 2) → U.ι) :
  dd 𝓕 U n f α =
  ∑ (i : fin (n + 2)), ∑ (j : fin (n + 1)),
    (ite (even i.1) id has_neg.neg)
      (ite (even j.1) id has_neg.neg)
        (𝓕.1.map (hom_of_le (face.le_ignore₂ α i j)).op)
            (f (ignore₂ α i j)) :=
begin
  rw [eq6₂, finset.sum_congr rfl],
  intros i _,
  split_ifs,
  { rw [id, finset.sum_congr rfl],
    intros j _,
    split_ifs,
    { rw [id, id, id], },
    { rw [id], }, },
  { rw [finset.neg_sum, finset.sum_congr rfl],
    intros j _,
    split_ifs,
    { rw [id, pi.neg_apply, id], congr, },
    { rw [pi.neg_apply, neg_neg, add_monoid_hom.neg_apply, neg_neg], }, },
end

lemma eq8 (f : C 𝓕 U n) (α : fin (n + 2) → U.ι) :
  dd 𝓕 U n f α =
  ∑ (i : fin (n + 2)), ∑ (j : fin (n + 1)),
    (ite (even (i.1 + j.1)) id has_neg.neg)
        (𝓕.1.map (hom_of_le (face.le_ignore₂ α i j)).op)
            (f (ignore₂ α i j)) :=
begin
  rw [eq7, finset.sum_congr rfl],
  intros i _,
  rw [finset.sum_congr rfl],
  intros j _,
  split_ifs with h1 h2 h12,
  { refl, },
  { exfalso,
    apply h12,
    exact even.add_even h1 h2 },
  { exfalso,
    rw ← nat.odd_iff_not_even at h2,
    have := even.add_odd h1 h2,
    rw nat.odd_iff_not_even at this,
    apply this,
    exact h, },
  { rw [id], },
  { rw ← nat.odd_iff_not_even at h1,
    have := odd.add_even h1 h,
    rw nat.odd_iff_not_even at this,
    exfalso,
    apply this,
    assumption, },
  { rw [pi.neg_apply, id], },
  { rw [pi.neg_apply, neg_neg, id], },
  { rw ← nat.odd_iff_not_even at *,
    have := odd.add_odd h1 h,
    rw nat.even_iff_not_odd at this,
    exfalso,
    apply this,
    assumption },
end

lemma eq9 (f : C 𝓕 U n) (α : fin (n + 2) → U.ι) :
  dd 𝓕 U n f α =
  ∑ (i : fin (n + 2)),
    ((∑ (j : fin (n + 1)) in finset.univ.filter (λ (j : fin (n + 1)), i.1 ≤ j.1),
      (ite (even (i.1 + j.1)) id has_neg.neg)
          (𝓕.1.map (hom_of_le (face.le_ignore₂ α i j)).op)
            (f (ignore₂ α i j))) +
    (∑ (j : fin (n + 1)) in finset.univ.filter (λ (j : fin (n + 1)), j.1 < i.1),
      (ite (even (i.1 + j.1)) id has_neg.neg)
          (𝓕.1.map (hom_of_le (face.le_ignore₂ α i j)).op)
            (f (ignore₂ α i j)))) :=
begin
  rw [eq8, finset.sum_congr rfl],
  intros i _,
  have :
    (finset.univ.filter (λ (j : fin (n + 1)), j.1 < i.val)) =
    (finset.univ.filter (λ (j : fin (n + 1)), i.val ≤ j.val))ᶜ,
  { ext1 k,
    split;
    intros hk;
    simp only [finset.compl_filter, not_le, finset.mem_filter, finset.mem_univ, true_and] at hk ⊢;
    assumption, },
  rw [this, finset.sum_add_sum_compl],
end

lemma eq11 (f : C 𝓕 U n) (α : fin (n + 2) → U.ι) :
  dd 𝓕 U n f α =
  (∑ (i : fin (n + 2)), ∑ (j : fin (n + 1)) in finset.univ.filter (λ (j : fin (n + 1)), i.1 ≤ j.1),
      (ite (even (i.1 + j.1)) id has_neg.neg)
          (𝓕.1.map (hom_of_le (face.le_ignore₂ α i j)).op)
            (f (ignore₂ α i j))) +
  (∑ (i : fin (n + 2)), ∑ (j : fin (n + 1)) in finset.univ.filter (λ (j : fin (n + 1)), j.1 < i.1),
    (ite (even (i.1 + j.1)) id has_neg.neg)
          (𝓕.1.map (hom_of_le (face.le_ignore₂ α i j)).op)
            (f (ignore₂ α i j))) :=
begin
  rw [eq9, finset.sum_add_distrib],
end

lemma eq13 (f : C 𝓕 U n) (α : fin (n + 2) → U.ι) :
  dd 𝓕 U n f α =
  (∑ (i : fin (n + 2)), ∑ j in (finset.Ico i.1 n.succ).attach,
      (ite (even (i.1 + j.1)) id has_neg.neg)
          (𝓕.1.map (hom_of_le (face.le_ignore₂ α i ⟨j.1, begin
            have hj := j.2,
            rw finset.mem_Ico at hj,
            exact hj.2,
          end⟩)).op)
            (f (ignore₂ α i ⟨j.1, _⟩))) +
  (∑ (i : fin (n + 2)), ∑ (j : fin (n + 1)) in finset.univ.filter (λ (j : fin (n + 1)), j.1 < i.1),
    (ite (even (i.1 + j.1)) id has_neg.neg)
          (𝓕.1.map (hom_of_le (face.le_ignore₂ α i j)).op)
            (f (ignore₂ α i j))) :=
begin
  rw [eq11],
  congr' 1,
  rw [finset.sum_congr rfl],
  intros i _,
  apply finset.sum_bij,

  work_on_goal 5
  { intros j hj,
    refine ⟨j.1, _⟩,
    rw finset.mem_Ico,
    rw finset.mem_filter at hj,
    refine ⟨hj.2, _⟩,
    exact j.2 },
  { intros j hj,
    dsimp only,
    rw finset.mem_filter at hj,
    apply finset.mem_attach, },
  { intros j hj,
    dsimp only,
    split_ifs,
    { rw [id, id],
      rw map_congr.vec_eq f (_ : ignore₂ α i j = ignore₂ α i ⟨j.1, _⟩),
      rw [← comp_apply, ← 𝓕.1.map_comp, ← op_comp],
      congr,
      congr' 1,
      rw subtype.ext_iff_val, },
    { rw [add_monoid_hom.neg_apply, add_monoid_hom.neg_apply],
      rw map_congr.vec_eq f (_ : ignore₂ α i j = ignore₂ α i ⟨j.1, _⟩),
      rw [← comp_apply, ← 𝓕.1.map_comp, ← op_comp],
      congr,
      congr' 1,
      rw subtype.ext_iff_val, }, },
  { intros j1 j2 h1 h2 H,
    dsimp only at H,
    rw subtype.ext_iff_val at *,
    assumption },
  { intros j _,
    have hj := j.2,
    rw finset.mem_Ico at hj,
    refine ⟨⟨j.1, hj.2⟩, _, _⟩,
    rw finset.mem_filter,
    refine ⟨finset.mem_univ ⟨j.val, _⟩, hj.1⟩,
    dsimp only,
    rw subtype.ext_iff_val, },
end

lemma eq14 (f : C 𝓕 U n) (α : fin (n + 2) → U.ι) :
  dd 𝓕 U n f α =
  (∑ (i : fin (n + 2)), ∑ j in (finset.Ico i.1 n.succ).attach,
      (ite (even (i.1 + j.1)) id has_neg.neg)
          (𝓕.1.map (hom_of_le (face.le_ignore₂ α i ⟨j.1, begin
            have hj := j.2,
            rw finset.mem_Ico at hj,
            exact hj.2,
          end⟩)).op)
            (f (ignore₂ α i ⟨j.1, _⟩))) +
  (∑ (i : fin (n + 2)), ∑ j in (finset.range i.1).attach,
    (ite (even (i.1 + j)) id has_neg.neg)
          (𝓕.1.map (hom_of_le (face.le_ignore₂ α i ⟨j.1, begin
            have hj := j.2,
            rw finset.mem_range at hj,
            have hi : i.1 ≤ n+1,
            { linarith [i.2], },
            linarith,
          end⟩)).op)
            (f (ignore₂ α i ⟨j.1, _⟩))) :=
begin
  rw [eq13],
  congr' 1,
  rw [finset.sum_congr rfl],
  intros i hi,
  apply finset.sum_bij',

  work_on_goal 4
  { intros j hj,
    rw finset.mem_filter at hj,
    refine ⟨j.1, _⟩,
    rw finset.mem_range,
    exact hj.2 },
  work_on_goal 5
  { intros j _,
    have hj := j.2,
    rw finset.mem_range at hj,
    refine ⟨j.1, _⟩,
    linarith [i.2], },
  { intros j hj,
    dsimp only,
    split_ifs,
    { rw [id, id],
      rw map_congr.vec_eq f (_ : ignore₂ α i j = ignore₂ α i ⟨j.1, _⟩),
      rw [← comp_apply, ← 𝓕.1.map_comp, ← op_comp],
      congr,
      congr' 1,
      rw subtype.ext_iff_val, },
    { rw [add_monoid_hom.neg_apply, add_monoid_hom.neg_apply],
      rw map_congr.vec_eq f (_ : ignore₂ α i j = ignore₂ α i ⟨j.1, _⟩),
      rw [← comp_apply, ← 𝓕.1.map_comp, ← op_comp],
      congr,
      congr' 1,
      rw subtype.ext_iff_val, }, },
  { intros j hj,
    dsimp only,
    rw subtype.ext_iff_val, },
  { intros j hj,
    rw subtype.ext_iff_val, },
  { intros j hj,
    apply finset.mem_attach, },
  { intros j _,
    have hj := j.2,
    rw finset.mem_range at hj,
    rw finset.mem_filter,
    dsimp only,
    refine ⟨_, hj⟩,
    apply finset.mem_univ, },
end

lemma eq15 (f : C 𝓕 U n) (α : fin (n + 2) → U.ι) :
  dd 𝓕 U n f α =
  (∑ (i : fin (n + 2)), ∑ j in (finset.Ico i.1 n.succ).attach,
      (ite (even (i.1 + j.1)) id has_neg.neg)
          (𝓕.1.map (hom_of_le (face.le_ignore₂ α i ⟨j.1, begin
            have hj := j.2,
            rw finset.mem_Ico at hj,
            exact hj.2,
          end⟩)).op)
            (f (ignore₂ α i ⟨j.1, _⟩))) +
  (∑ j in (finset.range n.succ).attach, ∑ i in (finset.Ico j.1.succ n.succ.succ).attach,
    (ite (even (i.1 + j.1)) id has_neg.neg)
          (𝓕.1.map (hom_of_le (face.le_ignore₂ α ⟨i.1, begin
            have hi := i.2,
            rwa finset.mem_Ico at hi,
            exact hi.2,
          end⟩ ⟨j.1, begin
            have hj := j.2,
            rwa finset.mem_range at hj,
          end⟩)).op)
            (f (ignore₂ α _ _))) :=
begin
  rw [eq14],
  congr' 1,
  rw [finset.sum_sigma', finset.sum_sigma'],
  apply finset.sum_bij',
  work_on_goal 4
  { refine λ x h, ⟨⟨x.2.1, begin
    have hx2 := x.2.2,
    have hx1 := x.1.2,
    rw finset.mem_range at hx2 ⊢,
    have : x.1.1 ≤ n + 1,
    { linarith },
    refine lt_of_lt_of_le hx2 this,
  end⟩, ⟨x.1.1, _⟩⟩, },
  work_on_goal 6
  { refine λ x h, ⟨⟨x.2.1, begin
    have hx1 := x.1.2,
    have hx2 := x.2.2,
    rw finset.mem_range at hx1,
    rw finset.mem_Ico at hx2,
    exact hx2.2,
  end⟩, ⟨x.1.1, begin
    have hx1 := x.1.2,
    have hx2 := x.2.2,
    rw finset.mem_range at hx1 ⊢,
    rw finset.mem_Ico at hx2,
    refine lt_of_le_of_lt _ hx2.1,
    refl,
  end⟩⟩, },
  { rintros ⟨⟨i, hi⟩, j⟩ h,
    dsimp only,
    congr, },
  { rintros ⟨⟨i, hi⟩, j⟩ h,
    simp only,
    split,
    refl,
    rw heq_iff_eq,
    rw subtype.ext_iff_val, },
  { rintros ⟨i, j⟩ h,
    simp only,
    split,
    rw subtype.ext_iff_val,
    rw heq_iff_eq,
    rw subtype.ext_iff_val, },
  { have hx1 := x.1.2,
    have hx2 := x.2.2,
    rw finset.mem_range at hx2,
    rw finset.mem_Ico,
    refine ⟨_, hx1⟩,
    exact hx2, },
  { rintros ⟨i, j⟩ h,
    rw finset.mem_sigma,
    split,
    apply finset.mem_attach,
    apply finset.mem_attach },
  { intros x h,
    rw finset.mem_sigma,
    split,
    apply finset.mem_univ,
    apply finset.mem_attach, },
end

lemma eq16 (f : C 𝓕 U n) (α : fin (n + 2) → U.ι) :
  dd 𝓕 U n f α =
  (∑ (i : fin (n + 2)), ∑ j in (finset.Ico i.1 n.succ).attach,
      (ite (even (i.1 + j.1)) id has_neg.neg)
          (𝓕.1.map (hom_of_le (face.le_ignore₂ α i ⟨j.1, begin
            have hj := j.2,
            rw finset.mem_Ico at hj,
            exact hj.2,
          end⟩)).op)
            (f (ignore₂ α i ⟨j.1, _⟩))) +
  (∑ i in (finset.range n.succ).attach, ∑ j in (finset.Ico i.1.succ n.succ.succ).attach,
    (ite (even (j.1 + i.1)) id has_neg.neg)
          (𝓕.1.map (hom_of_le (face.le_ignore₂ α ⟨j.1, begin
            have hi := j.2,
            rwa finset.mem_Ico at hi,
            exact hi.2,
          end⟩ ⟨i.1, begin
            have hj := i.2,
            rwa finset.mem_range at hj,
          end⟩)).op)
            (f (ignore₂ α _ _))) :=
begin
  rw [eq15],
end

lemma eq17 (f : C 𝓕 U n) (α : fin (n + 2) → U.ι) :
  dd 𝓕 U n f α =
  (∑ (i : fin (n + 2)), ∑ j in (finset.Ico i.1 n.succ).attach,
      (ite (even (i.1 + j.1)) id has_neg.neg)
          (𝓕.1.map (hom_of_le (face.le_ignore₂ α i ⟨j.1, begin
            have hj := j.2,
            rw finset.mem_Ico at hj,
            exact hj.2,
          end⟩)).op)
            (f (ignore₂ α i ⟨j.1, _⟩))) +
  (∑ i in (finset.range n.succ).attach, ∑ j in (finset.Ico i.1 n.succ).attach,
    (ite (even ((j.1 + 1) + i.1)) id has_neg.neg)
          (𝓕.1.map (hom_of_le (face.le_ignore₂ α ⟨j.1 + 1, begin
            have hi := j.2,
            rw finset.mem_Ico at hi,
            rw succ_lt_succ_iff,
            exact hi.2,
          end⟩ ⟨i.1, begin
            have hj := i.2,
            rwa finset.mem_range at hj,
          end⟩)).op)
            (f (ignore₂ α ⟨j.1 + 1, _⟩ ⟨i.1, _⟩))) :=
begin
  rw [eq16],
  congr' 1,
  rw finset.sum_congr rfl,
  intros i hi,
  apply finset.sum_bij',
  work_on_goal 4
  { intros j _, refine ⟨j.1.pred, _⟩,
    have hj := j.2,
    rw finset.mem_Ico at hj ⊢,
    rcases hj with ⟨hj1, hj2⟩,
    have ineq0 : 0 < j.1,
    { refine lt_of_lt_of_le _ hj1,
      exact nat.zero_lt_succ _, },
    have eq1 : j.1 = j.1.pred.succ,
    { rwa nat.succ_pred_eq_of_pos, },
    split,
    rw eq1 at hj1,
    rwa succ_le_succ_iff at hj1,

    rw eq1 at hj2,
    rwa succ_lt_succ_iff at hj2 },
  work_on_goal 5
  { intros j _, refine ⟨j.1 + 1, _⟩,
    have hj := j.2,
    rw finset.mem_Ico at hj ⊢,
    rcases hj with ⟨hj1, hj2⟩,
    split,

    rwa succ_le_succ_iff,
    rwa succ_lt_succ_iff,
    },
  { intros j hj,
    dsimp only,
    rw map_congr.vec_eq f (_ : ignore₂ α ⟨j.1, _⟩ ⟨i.1, _⟩ = ignore₂ α ⟨j.1.pred + 1, _⟩ ⟨i.1, _⟩),
    by_cases e1 : even (j.1 + i.1),
    { rw [if_pos e1, if_pos, id, id, ← comp_apply, ← 𝓕.1.map_comp], congr,
      rwa [← nat.succ_eq_add_one, nat.succ_pred_eq_of_pos],
      have hj := j.2,
      rw finset.mem_Ico at hj,
      refine lt_of_lt_of_le _ hj.1,
      exact nat.zero_lt_succ _, },
    { rw [if_neg e1, if_neg, add_monoid_hom.neg_apply, add_monoid_hom.neg_apply, ← comp_apply, ← 𝓕.1.map_comp],
      congr,
      rwa [← nat.succ_eq_add_one, nat.succ_pred_eq_of_pos],
      have hj := j.2,
      rw finset.mem_Ico at hj,
      refine lt_of_lt_of_le _ hj.1,
      exact nat.zero_lt_succ _, },
    congr,
    rwa [← nat.succ_eq_add_one, nat.succ_pred_eq_of_pos],
    have hj := j.2,
    rw finset.mem_Ico at hj,
    refine lt_of_lt_of_le _ hj.1,
    exact nat.zero_lt_succ _, },
  { intros j hj,
    simp only,
    rw subtype.ext_iff_val,
    dsimp only,
    rw [← nat.succ_eq_add_one, nat.succ_pred_eq_of_pos],
    have hj := j.2,
    rw finset.mem_Ico at hj,
    refine lt_of_lt_of_le _ hj.1,
    exact nat.zero_lt_succ _, },
  { intros j hj,
    simp only,
    rw subtype.ext_iff_val,
    dsimp only,
    rw nat.pred_succ, },
  { intros j hj,
    apply finset.mem_attach, },
  { intros j hj,
    apply finset.mem_attach, },
end

lemma eq18 (f : C 𝓕 U n) (α : fin (n + 2) → U.ι) :
  dd 𝓕 U n f α =
  (∑ (i : fin (n + 2)), ∑ j in (finset.Ico i.1 n.succ).attach,
      (ite (even (i.1 + j.1)) id has_neg.neg)
          (𝓕.1.map (hom_of_le (face.le_ignore₂ α i ⟨j.1, begin
            have hj := j.2,
            rw finset.mem_Ico at hj,
            exact hj.2,
          end⟩)).op)
            (f (ignore₂ α i ⟨j.1, _⟩))) +
  (∑ i in (finset.range n.succ).attach, ∑ j in (finset.Ico i.1 n.succ).attach,
    (ite (even ((j.1 + 1) + i.1)) id has_neg.neg)
          (𝓕.1.map (hom_of_le (face.le_ignore₂ α ⟨i.1, begin
            have hi := i.2,
            rw finset.mem_range at hi,
            refine lt_trans hi _,
            exact lt_add_one _,
          end⟩ ⟨j.1, begin
            have hj := j.2,
            rw finset.mem_Ico at hj,
            exact hj.2,
          end⟩)).op)
            (f (ignore₂ α ⟨i.1, _⟩ ⟨j.1, _⟩))) :=
begin
  rw eq17 𝓕 U n f α,
  apply congr_arg2 (+) rfl _,
  rw [finset.sum_congr rfl],
  intros i hi,
  rw [finset.sum_congr rfl],
  intros j hj,
  generalize_proofs _ h1 h2 h3 h4 h5,
  rw map_congr.vec_eq f (_ : ignore₂ α ⟨j.1 + 1, h1⟩ ⟨i.1, h2⟩ = ignore₂ α ⟨i.1, h4⟩ ⟨j.1, _⟩),
  split_ifs,
  { rw [id, id, ← comp_apply, ← 𝓕.1.map_comp],
    congr },
  { rw [add_monoid_hom.neg_apply, add_monoid_hom.neg_apply, ← comp_apply, ← 𝓕.1.map_comp],
    congr },
  have := ignore₂_symm' α i.2 j.2,
  convert ← this,
end

lemma eq19 (f : C 𝓕 U n) (α : fin (n + 2) → U.ι) :
  dd 𝓕 U n f α =
  (∑ (i : fin (n + 2)), ∑ j in (finset.Ico i.1 n.succ).attach,
      (ite (even (i.1 + j.1)) id has_neg.neg)
          (𝓕.1.map (hom_of_le (face.le_ignore₂ α i ⟨j.1, begin
            have hj := j.2,
            rw finset.mem_Ico at hj,
            exact hj.2,
          end⟩)).op)
            (f (ignore₂ α i ⟨j.1, _⟩))) +
  (∑ i in (finset.range n.succ).attach, - ∑ j in (finset.Ico i.1 n.succ).attach,
    (ite (even (j.1 + i.1)) id has_neg.neg)
          (𝓕.1.map (hom_of_le (face.le_ignore₂ α ⟨i.1, begin
            have hi := i.2,
            rw finset.mem_range at hi,
            refine lt_trans hi _,
            exact lt_add_one _,
          end⟩ ⟨j.1, begin
            have hj := j.2,
            rw finset.mem_Ico at hj,
            exact hj.2,
          end⟩)).op)
            (f (ignore₂ α ⟨i.1, _⟩ ⟨j.1, _⟩))) :=
begin
  rw [eq18],
  congr' 1,
  rw [finset.sum_congr rfl],
  intros i _,
  rw [finset.neg_sum, finset.sum_congr rfl],
  intros j _,
  split_ifs with h1 h2,
  { exfalso,
    have o1 : odd (1 : ℕ) := odd_one,
    have := even.add_odd h2 o1,
    rw nat.odd_iff_not_even at this,
    apply this,
    convert h1 using 1,
    abel, },
  { rw [id, add_monoid_hom.neg_apply, neg_neg], },
  { rw [id, add_monoid_hom.neg_apply], },
  { rw ← nat.odd_iff_not_even at h h1,
    have o1 : odd (1 : ℕ) := odd_one,
    have := odd.add_odd h o1,
    rw nat.even_iff_not_odd at this,
    exfalso,
    apply this,
    convert h1 using 1,
    abel, },
end

lemma eq20₀ (f : C 𝓕 U n) (α : fin (n + 2) → U.ι) :
  dd 𝓕 U n f α =
  (∑ i in (finset.range (n+2)).attach, ∑ j in (finset.Ico i.1 n.succ).attach,
      (ite (even (i.1 + j.1)) id has_neg.neg)
          (𝓕.1.map (hom_of_le (face.le_ignore₂ α ⟨i.1, begin
            have hi := i.2,
            exact finset.mem_range.mp hi,
          end⟩ ⟨j.1, begin
            have hj := j.2,
            rw finset.mem_Ico at hj,
            exact hj.2,
          end⟩)).op)
            (f (ignore₂ α ⟨i.1, _⟩ ⟨j.1, _⟩))) +
  (∑ i in (finset.range n.succ).attach, - ∑ j in (finset.Ico i.1 n.succ).attach,
    (ite (even (j.1 + i.1)) id has_neg.neg)
          (𝓕.1.map (hom_of_le (face.le_ignore₂ α ⟨i.1, begin
            have hi := i.2,
            rw finset.mem_range at hi,
            refine lt_trans hi _,
            exact lt_add_one _,
          end⟩ ⟨j.1, begin
            have hj := j.2,
            rw finset.mem_Ico at hj,
            exact hj.2,
          end⟩)).op)
            (f (ignore₂ α ⟨i.1, _⟩ ⟨j.1, _⟩))) :=
begin
  rw [eq19],
  congr' 1,
  rw finset.sum_fin_eq_sum_range,
  rw ← finset.sum_attach,
  rw finset.sum_congr rfl,
  intros i hi,
  rw dif_pos,
  refl,
end

lemma eq20₁ (f : C 𝓕 U n) (α : fin (n + 2) → U.ι) :
  dd 𝓕 U n f α =
  (∑ i in (finset.range (n+1)).attach, ∑ j in (finset.Ico i.1 n.succ).attach,
      (ite (even (i.1 + j.1)) id has_neg.neg)
          (𝓕.1.map (hom_of_le (face.le_ignore₂ α ⟨i.1, begin
            have hi := i.2,
            refine lt_trans (finset.mem_range.mp hi) _,
            exact lt_add_one _,
          end⟩ ⟨j.1, begin
            have hj := j.2,
            rw finset.mem_Ico at hj,
            exact hj.2,
          end⟩)).op)
            (f (ignore₂ α ⟨i.1, _⟩ ⟨j.1, _⟩))) +
  (∑ j in (finset.Ico n.succ n.succ).attach,
    (ite (even (n.succ + j.1)) id has_neg.neg)
          (𝓕.1.map (hom_of_le (face.le_ignore₂ α ⟨n.succ, begin
            exact lt_add_one _,
          end⟩ ⟨j.1, begin
            have hj := j.2,
            rw finset.mem_Ico at hj,
            exact hj.2,
          end⟩)).op)
            (f (ignore₂ α ⟨n.succ, _⟩ ⟨j.1, _⟩))) +
  (∑ i in (finset.range n.succ).attach, - ∑ j in (finset.Ico i.1 n.succ).attach,
    (ite (even (j.1 + i.1)) id has_neg.neg)
          (𝓕.1.map (hom_of_le (face.le_ignore₂ α ⟨i.1, begin
            have hi := i.2,
            rw finset.mem_range at hi,
            refine lt_trans hi _,
            exact lt_add_one _,
          end⟩ ⟨j.1, begin
            have hj := j.2,
            rw finset.mem_Ico at hj,
            exact hj.2,
          end⟩)).op)
            (f (ignore₂ α ⟨i.1, _⟩ ⟨j.1, _⟩))) :=
have eq0 :
  ∑ i in (finset.range (n+2)).attach, ∑ j in (finset.Ico i.1 n.succ).attach,
    (ite (even (i.1 + j.1)) id has_neg.neg)
        (𝓕.1.map (hom_of_le (face.le_ignore₂ α ⟨i.1, begin
          have hi := i.2,
          exact finset.mem_range.mp hi,
        end⟩ ⟨j.1, begin
          have hj := j.2,
          rw finset.mem_Ico at hj,
          exact hj.2,
        end⟩)).op)
          (f (ignore₂ α ⟨i.1, _⟩ ⟨j.1, _⟩)) =
  ∑ i in (insert n.succ (finset.range (n+1))).attach, ∑ j in (finset.Ico i.1 n.succ).attach,
    (ite (even (i.1 + j.1)) id has_neg.neg)
        (𝓕.1.map (hom_of_le (face.le_ignore₂ α ⟨i.1, begin
          have hi := i.2,
          rw finset.mem_insert at hi,
          cases hi,
          rw hi, exact lt_add_one _,

          rw finset.mem_range at hi,
          refine lt_trans hi _,
          exact lt_add_one _,
        end⟩ ⟨j.1, begin
          have hj := j.2,
          rw finset.mem_Ico at hj,
          exact hj.2,
        end⟩)).op)
          (f (ignore₂ α ⟨i.1, _⟩ ⟨j.1, _⟩)),
begin
  rw finset.sum_bij',
  work_on_goal 4
  { intros a _,
    refine ⟨a.1, _⟩,
    rw finset.mem_insert,
    have ha := a.2,
    by_cases a.1 = n.succ,
    left, assumption,
    right,
    rw finset.mem_range at ha ⊢,
    contrapose! h,
    have ha' : a.1 ≤ n+1,
    linarith,
    refine le_antisymm ha' h, },
  work_on_goal 5
  { intros a _,
    refine ⟨a.1, _⟩,
    have ha := a.2,
    rw finset.mem_insert at ha,
    rw finset.mem_range at ha ⊢,
    cases ha,
    rw ha, exact lt_add_one _,
    linarith, },
  { intros, simp only, },
  { intros, simp only, rw subtype.ext_iff_val, },
  { intros, simp only, rw subtype.ext_iff_val, },
  { intros, simp only,
    apply finset.mem_attach },
  { intros, apply finset.mem_attach },
end,
begin
  rw [eq20₀],
  apply congr_arg2 (+) _ rfl,
  rw eq0,
  rw finset.attach_insert,
  rw finset.sum_insert,
  conv_lhs { simp only [add_comm] },
  congr' 1,
  { simp only [finset.sum_image, subtype.forall, subtype.coe_mk, imp_self, implies_true_iff], },
  { rw finset.mem_image,
    push_neg,
    intros a _,
    have ha := a.2,
    rw finset.mem_range at ha,
    intro r,
    rw r at ha,
    apply lt_irrefl _ ha, },
end

lemma eq21 (f : C 𝓕 U n) (α : fin (n + 2) → U.ι) :
  dd 𝓕 U n f α =
  (∑ i in (finset.range (n+1)).attach, ∑ j in (finset.Ico i.1 n.succ).attach,
      (ite (even (i.1 + j.1)) id has_neg.neg)
          (𝓕.1.map (hom_of_le (face.le_ignore₂ α ⟨i.1, begin
            have hi := i.2,
            refine lt_trans (finset.mem_range.mp hi) _,
            exact lt_add_one _,
          end⟩ ⟨j.1, begin
            have hj := j.2,
            rw finset.mem_Ico at hj,
            exact hj.2,
          end⟩)).op)
            (f (ignore₂ α ⟨i.1, _⟩ ⟨j.1, _⟩))) +
  (∑ i in (finset.range n.succ).attach, - ∑ j in (finset.Ico i.1 n.succ).attach,
    (ite (even (j.1 + i.1)) id has_neg.neg)
          (𝓕.1.map (hom_of_le (face.le_ignore₂ α ⟨i.1, begin
            have hi := i.2,
            rw finset.mem_range at hi,
            refine lt_trans hi _,
            exact lt_add_one _,
          end⟩ ⟨j.1, begin
            have hj := j.2,
            rw finset.mem_Ico at hj,
            exact hj.2,
          end⟩)).op)
            (f (ignore₂ α ⟨i.1, _⟩ ⟨j.1, _⟩))) +
  (∑ j in (finset.Ico n.succ n.succ).attach,
    (ite (even (n.succ + j.1)) id has_neg.neg)
          (𝓕.1.map (hom_of_le (face.le_ignore₂ α ⟨n.succ, begin
            exact lt_add_one _,
          end⟩ ⟨j.1, begin
            have hj := j.2,
            rw finset.mem_Ico at hj,
            exact hj.2,
          end⟩)).op)
            (f (ignore₂ α ⟨n.succ, _⟩ ⟨j.1, _⟩))) :=
begin
  rw [eq20₁],
  abel,
end

lemma eq22 (f : C 𝓕 U n) (α : fin (n + 2) → U.ι) :
  dd 𝓕 U n f α =
  (∑ i in (finset.range (n+1)).attach,
    ((∑ j in (finset.Ico i.1 n.succ).attach,
      (ite (even (i.1 + j.1)) id has_neg.neg)
          (𝓕.1.map (hom_of_le (face.le_ignore₂ α ⟨i.1, begin
            have hi := i.2,
            refine lt_trans (finset.mem_range.mp hi) _,
            exact lt_add_one _,
          end⟩ ⟨j.1, begin
            have hj := j.2,
            rw finset.mem_Ico at hj,
            exact hj.2,
          end⟩)).op)
            (f (ignore₂ α ⟨i.1, _⟩ ⟨j.1, _⟩))) +
    (- ∑ j in (finset.Ico i.1 n.succ).attach,
      (ite (even (j.1 + i.1)) id has_neg.neg)
          (𝓕.1.map (hom_of_le (face.le_ignore₂ α ⟨i.1, begin
            have hi := i.2,
            rw finset.mem_range at hi,
            refine lt_trans hi _,
            exact lt_add_one _,
          end⟩ ⟨j.1, begin
            have hj := j.2,
            rw finset.mem_Ico at hj,
            exact hj.2,
          end⟩)).op)
            (f (ignore₂ α ⟨i.1, _⟩ ⟨j.1, _⟩))))) +
  (∑ j in (finset.Ico n.succ n.succ).attach,
    (ite (even (n.succ + j.1)) id has_neg.neg)
          (𝓕.1.map (hom_of_le (face.le_ignore₂ α ⟨n.succ, begin
            exact lt_add_one _,
          end⟩ ⟨j.1, begin
            have hj := j.2,
            rw finset.mem_Ico at hj,
            exact hj.2,
          end⟩)).op)
            (f (ignore₂ α ⟨n.succ, _⟩ ⟨j.1, _⟩))) :=
begin
  rw [eq21, finset.sum_add_distrib],
end

lemma eq23 (f : C 𝓕 U n) (α : fin (n + 2) → U.ι) :
  dd 𝓕 U n f α =
  (∑ i in (finset.range (n+1)).attach, 0) +
  (∑ j in (finset.Ico n.succ n.succ).attach,
    (ite (even (n.succ + j.1)) id has_neg.neg)
          (𝓕.1.map (hom_of_le (face.le_ignore₂ α ⟨n.succ, begin
            exact lt_add_one _,
          end⟩ ⟨j.1, begin
            have hj := j.2,
            rw finset.mem_Ico at hj,
            exact hj.2,
          end⟩)).op)
            (f (ignore₂ α ⟨n.succ, _⟩ ⟨j.1, _⟩))) :=
begin
  rw [eq22],
  congr' 1,
  rw finset.sum_congr rfl,
  intros i _,
  simp_rw [add_comm],
  rw add_neg_eq_zero,
end

lemma eq24 (f : C 𝓕 U n) (α : fin (n + 2) → U.ι) :
  dd 𝓕 U n f α = 0 +
  (∑ j in (finset.Ico n.succ n.succ).attach,
    (ite (even (n.succ + j.1)) id has_neg.neg)
          (𝓕.1.map (hom_of_le (face.le_ignore₂ α ⟨n.succ, begin
            exact lt_add_one _,
          end⟩ ⟨j.1, begin
            have hj := j.2,
            rw finset.mem_Ico at hj,
            exact hj.2,
          end⟩)).op)
            (f (ignore₂ α ⟨n.succ, _⟩ ⟨j.1, _⟩))) :=
begin
  rw [eq23],
  congr',
  rw finset.sum_eq_zero,
  intros, refl,
end

lemma eq_zero (f : C 𝓕 U n) (α : fin (n + 2) → U.ι) :
  dd 𝓕 U n f α = 0 :=
begin
  rw [eq24, zero_add],
  convert finset.sum_empty,
  rw finset.Ico_self,
  rw finset.attach_empty
end

end dd_aux

lemma dd_eq_zero' (n : ℕ) : dd 𝓕 U n = 0 :=
begin
  ext f α,
  convert dd_aux.eq_zero 𝓕 U n f α,
end

lemma dd_eq_zero (n : ℕ) (f α) :
  d 𝓕 U (n+1) (d 𝓕 U n f) α = 0 :=
begin
  have : dd 𝓕 U n f α = 0,
  { rw dd_eq_zero',
    simp },
  convert this,
end

end


/-
Copyright (c) 2020 Robert Y. Lewis. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Robert Y. Lewis
-/

import tactic.linarith.elimination
import tactic.linarith.parsing

/-!
# Deriving a proof of false

`linarith` uses an untrusted oracle to produce a certificate of unsatisfiability.
It needs to do some proof reconstruction work to turn this into a proof term.
This file implements the reconstruction.

## Main declarations

The public facing declaration in this file is `prove_false_by_linarith`.
-/

namespace linarith

open ineq tactic native

/-! ### Auxiliary functions for assembling proofs -/

/--
`mul_expr n e` creates a `pexpr` representing `n*e`.
When elaborated, the coefficient will be a native numeral of the same type as `e`.
-/
meta def mul_expr (n : ℕ) (e : expr) : pexpr :=
if n = 1 then ``(%%e) else
``(%%(nat.to_pexpr n) * %%e)

private meta def add_exprs_aux : pexpr → list pexpr → pexpr
| p [] := p
| p [a] := ``(%%p + %%a)
| p (h::t) := add_exprs_aux ``(%%p + %%h) t

/--
`add_exprs l` creates a `pexpr` representing the sum of the elements of `l`, associated left.
If `l` is empty, it will be the `pexpr` 0. Otherwise, it does not include 0 in the sum.
-/
meta def add_exprs : list pexpr → pexpr
| [] := ``(0)
| (h::t) := add_exprs_aux h t

/--
If our goal is to add together two inequalities `t1 R1 0` and `t2 R2 0`,
`ineq_const_nm R1 R2` produces the strength of the inequality in the sum `R`,
along with the name of a lemma to apply in order to conclude `t1 + t2 R 0`.
-/
meta def ineq_const_nm : ineq → ineq → (name × ineq)
| eq eq := (``eq_of_eq_of_eq, eq)
| eq le := (``le_of_eq_of_le, le)
| eq lt := (``lt_of_eq_of_lt, lt)
| le eq := (``le_of_le_of_eq, le)
| le le := (`add_nonpos, le)
| le lt := (`add_lt_of_le_of_neg, lt)
| lt eq := (``lt_of_lt_of_eq, lt)
| lt le := (`add_lt_of_neg_of_le, lt)
| lt lt := (`left.add_neg, lt)

/--
`mk_lt_zero_pf_aux c pf npf coeff` assumes that `pf` is a proof of `t1 R1 0` and `npf` is a proof
of `t2 R2 0`. It uses `mk_single_comp_zero_pf` to prove `t1 + coeff*t2 R 0`, and returns `R`
along with this proof.
-/
meta def mk_lt_zero_pf_aux (c : ineq) (pf npf : expr) (coeff : ℕ) : tactic (ineq × expr) :=
do (iq, h') ← mk_single_comp_zero_pf coeff npf,
   let (nm, niq) := ineq_const_nm c iq,
   prod.mk niq <$> mk_app nm [pf, h']

/--
`mk_lt_zero_pf coeffs pfs` takes a list of proofs of the form `tᵢ Rᵢ 0`,
paired with coefficients `cᵢ`.
It produces a proof that `∑cᵢ * tᵢ R 0`, where `R` is as strong as possible.
-/
meta def mk_lt_zero_pf : list (expr × ℕ) → tactic expr
| [] := fail "no linear hypotheses found"
| [(h, c)] := prod.snd <$> mk_single_comp_zero_pf c h
| ((h, c)::t) :=
  do (iq, h') ← mk_single_comp_zero_pf c h,
     prod.snd <$> t.mfoldl (λ pr ce, mk_lt_zero_pf_aux pr.1 pr.2 ce.1 ce.2) (iq, h')

/-- If `prf` is a proof of `t R s`, `term_of_ineq_prf prf` returns `t`. -/
meta def term_of_ineq_prf (prf : expr) : tactic expr :=
prod.fst <$> (infer_type prf >>= get_rel_sides)

/-- If `prf` is a proof of `t R s`, `ineq_prf_tp prf` returns the type of `t`. -/
meta def ineq_prf_tp (prf : expr) : tactic expr :=
term_of_ineq_prf prf >>= infer_type

/--
`mk_neg_one_lt_zero_pf tp` returns a proof of `-1 < 0`,
where the numerals are natively of type `tp`.
-/
meta def mk_neg_one_lt_zero_pf (tp : expr) : tactic expr :=
do h ← mk_mapp `linarith.zero_lt_one [tp, none, none],
   mk_app `neg_neg_of_pos [h]

/--
If `e` is a proof that `t = 0`, `mk_neg_eq_zero_pf e` returns a proof that `-t = 0`.
-/
meta def mk_neg_eq_zero_pf (e : expr) : tactic expr :=
to_expr ``(neg_eq_zero.mpr %%e)

/--
`prove_eq_zero_using tac e` tries to use `tac` to construct a proof of `e = 0`.
-/
meta def prove_eq_zero_using (tac : tactic unit) (e : expr) : tactic expr :=
do tgt ← to_expr ``(%%e = 0),
   prod.snd <$> solve_aux tgt (tac >> done)

/--
`add_neg_eq_pfs l` inspects the list of proofs `l` for proofs of the form `t = 0`. For each such
proof, it adds a proof of `-t = 0` to the list.
-/
meta def add_neg_eq_pfs : list expr → tactic (list expr)
| [] := return []
| (h::t) :=
  do some (iq, tp) ← parse_into_comp_and_expr <$> infer_type h,
  match iq with
  | ineq.eq := do nep ← mk_neg_eq_zero_pf h, tl ← add_neg_eq_pfs t, return $ h::nep::tl
  | _ := list.cons h <$> add_neg_eq_pfs t
  end

/-! #### The main method -/

/--
`prove_false_by_linarith` is the main workhorse of `linarith`.
Given a list `l` of proofs of `tᵢ Rᵢ 0`,
it tries to derive a contradiction from `l` and use this to produce a proof of `false`.

An oracle is used to search for a certificate of unsatisfiability.
In the current implementation, this is the Fourier Motzkin elimination routine in
`elimination.lean`, but other oracles could easily be swapped in.

The returned certificate is a map `m` from hypothesis indices to natural number coefficients.
If our set of hypotheses has the form  `{tᵢ Rᵢ 0}`,
then the elimination process should have guaranteed that
1.\ `∑ (m i)*tᵢ = 0`,
with at least one `i` such that `m i > 0` and `Rᵢ` is `<`.

We have also that
2.\ `∑ (m i)*tᵢ < 0`,
since for each `i`, `(m i)*tᵢ ≤ 0` and at least one is strictly negative.
So we conclude a contradiction `0 < 0`.

It remains to produce proofs of (1) and (2). (1) is verified by calling the `discharger` tactic
of the `linarith_config` object, which is typically `ring`. We prove (2) by folding over the
set of hypotheses.
-/
meta def prove_false_by_linarith (cfg : linarith_config) : list expr → tactic expr
| [] := fail "no args to linarith"
| l@(h::t) := do
    -- for the elimination to work properly, we must add a proof of `-1 < 0` to the list,
    -- along with negated equality proofs.
    l' ← add_neg_eq_pfs l,
    hz ← ineq_prf_tp h >>= mk_neg_one_lt_zero_pf,
    let inputs := hz::l',
    -- perform the elimination and fail if no contradiction is found.
    (comps, max_var) ← linear_forms_and_max_var cfg.transparency inputs,
    certificate ← cfg.oracle.get_or_else fourier_motzkin.produce_certificate comps max_var
      <|> fail "linarith failed to find a contradiction",
    linarith_trace "linarith has found a contradiction",
    let enum_inputs := inputs.enum,
    -- construct a list pairing nonzero coeffs with the proof of their corresponding comparison
    let zip := enum_inputs.filter_map $ λ ⟨n, e⟩, prod.mk e <$> certificate.find n,
    mls ← zip.mmap (λ ⟨e, n⟩, do e ← term_of_ineq_prf e, return (mul_expr n e)),
    -- `sm` is the sum of input terms, scaled to cancel out all variables.
    sm ← to_expr $ add_exprs mls,
    pformat! "The expression\n  {sm}\nshould be both 0 and negative" >>= linarith_trace,
    -- we prove that `sm = 0`, typically with `ring`.
    sm_eq_zero ← prove_eq_zero_using cfg.discharger sm,
    linarith_trace "We have proved that it is zero",
    -- we also prove that `sm < 0`.
    sm_lt_zero ← mk_lt_zero_pf zip,
    linarith_trace "We have proved that it is negative",
    -- this is a contradiction.
    pftp ← infer_type sm_lt_zero,
    (_, nep, _) ← rewrite_core sm_eq_zero pftp,
    pf' ← mk_eq_mp nep sm_lt_zero,
    mk_app `lt_irrefl [pf']

end linarith


/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Mario Carneiro

A computable model of hereditarily finite sets with atoms
(ZFA without infinity). This is useful for calculations in naive
set theory.
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.list.basic
import Mathlib.data.sigma.default
import Mathlib.PostPort

universes u l u_1 u_2 u_3

namespace Mathlib

inductive lists' (α : Type u) : Bool → Type u where
| atom : α → lists' α false
| nil : lists' α tt
| cons' : {b : Bool} → lists' α b → lists' α tt → lists' α tt

def lists (α : Type u_1) := sigma fun (b : Bool) => lists' α b

namespace lists'

protected instance inhabited {α : Type u_1} [Inhabited α] (b : Bool) : Inhabited (lists' α b) :=
  sorry

def cons {α : Type u_1} : lists α → lists' α tt → lists' α tt := sorry

@[simp] def to_list {α : Type u_1} {b : Bool} : lists' α b → List (lists α) := sorry

@[simp] theorem to_list_cons {α : Type u_1} (a : lists α) (l : lists' α tt) :
    to_list (cons a l) = a :: to_list l :=
  sorry

@[simp] def of_list {α : Type u_1} : List (lists α) → lists' α tt := sorry

@[simp] theorem to_of_list {α : Type u_1} (l : List (lists α)) : to_list (of_list l) = l := sorry

@[simp] theorem of_to_list {α : Type u_1} (l : lists' α tt) : of_list (to_list l) = l := sorry

end lists'

def lists'.subset {α : Type u_1} : lists' α tt → lists' α tt → Prop :=
  fun (ᾰ ᾰ_1 : lists' α tt) =>
    lists.equiv._mut_
      ((fun (idx : psigma fun (ᾰ : lists' α tt) => psigma fun (ᾰ : lists' α tt) => Unit) =>
          psum.inr idx)
        ((fun (ᾰ ᾰ_2 : lists' α tt) => psigma.mk ᾰ (psigma.mk ᾰ_2 Unit.unit)) ᾰ ᾰ_1))

namespace lists'

protected instance has_subset {α : Type u_1} : has_subset (lists' α tt) := has_subset.mk subset

protected instance has_mem {α : Type u_1} {b : Bool} : has_mem (lists α) (lists' α b) :=
  has_mem.mk
    fun (a : lists α) (l : lists' α b) => ∃ (a' : lists α), ∃ (H : a' ∈ to_list l), lists.equiv a a'

theorem mem_def {α : Type u_1} {b : Bool} {a : lists α} {l : lists' α b} :
    a ∈ l ↔ ∃ (a' : lists α), ∃ (H : a' ∈ to_list l), lists.equiv a a' :=
  iff.rfl

@[simp] theorem mem_cons {α : Type u_1} {a : lists α} {y : lists α} {l : lists' α tt} :
    a ∈ cons y l ↔ lists.equiv a y ∨ a ∈ l :=
  sorry

theorem cons_subset {α : Type u_1} {a : lists α} {l₁ : lists' α tt} {l₂ : lists' α tt} :
    cons a l₁ ⊆ l₂ ↔ a ∈ l₂ ∧ l₁ ⊆ l₂ :=
  sorry

theorem of_list_subset {α : Type u_1} {l₁ : List (lists α)} {l₂ : List (lists α)} (h : l₁ ⊆ l₂) :
    of_list l₁ ⊆ of_list l₂ :=
  sorry

theorem subset.refl {α : Type u_1} {l : lists' α tt} : l ⊆ l :=
  eq.mpr (id (Eq._oldrec (Eq.refl (l ⊆ l)) (Eq.symm (of_to_list l))))
    (of_list_subset (list.subset.refl (to_list l)))

theorem subset_nil {α : Type u_1} {l : lists' α tt} : l ⊆ nil → l = nil := sorry

theorem mem_of_subset' {α : Type u_1} {a : lists α} {l₁ : lists' α tt} {l₂ : lists' α tt}
    (s : l₁ ⊆ l₂) (h : a ∈ to_list l₁) : a ∈ l₂ :=
  sorry

theorem subset_def {α : Type u_1} {l₁ : lists' α tt} {l₂ : lists' α tt} :
    l₁ ⊆ l₂ ↔ ∀ (a : lists α), a ∈ to_list l₁ → a ∈ l₂ :=
  sorry

end lists'

namespace lists

def atom {α : Type u_1} (a : α) : lists α := sigma.mk false (lists'.atom a)

def of' {α : Type u_1} (l : lists' α tt) : lists α := sigma.mk tt l

@[simp] def to_list {α : Type u_1} : lists α → List (lists α) := sorry

def is_list {α : Type u_1} (l : lists α) := ↥(sigma.fst l)

def of_list {α : Type u_1} (l : List (lists α)) : lists α := of' (lists'.of_list l)

theorem is_list_to_list {α : Type u_1} (l : List (lists α)) : is_list (of_list l) :=
  Eq.refl (sigma.fst (of_list l))

theorem to_of_list {α : Type u_1} (l : List (lists α)) : to_list (of_list l) = l := sorry

theorem of_to_list {α : Type u_1} {l : lists α} : is_list l → of_list (to_list l) = l := sorry

protected instance inhabited {α : Type u_1} : Inhabited (lists α) := { default := of' lists'.nil }

protected instance decidable_eq {α : Type u_1} [DecidableEq α] : DecidableEq (lists α) :=
  eq.mpr sorry fun (a b : sigma fun (b : Bool) => lists' α b) => sigma.decidable_eq a b

protected instance has_sizeof {α : Type u_1} [SizeOf α] : SizeOf (lists α) :=
  eq.mpr sorry (sigma.has_sizeof Bool fun (b : Bool) => lists' α b)

def induction_mut {α : Type u_1} (C : lists α → Sort u_2) (D : lists' α tt → Sort u_3)
    (C0 : (a : α) → C (atom a)) (C1 : (l : lists' α tt) → D l → C (of' l)) (D0 : D lists'.nil)
    (D1 : (a : lists α) → (l : lists' α tt) → C a → D l → D (lists'.cons a l)) :
    PProd ((l : lists α) → C l) ((l : lists' α tt) → D l) :=
  { fst := fun (_x : lists α) => sorry,
    snd :=
      fun (l : lists' α tt) =>
        pprod.snd
          ((fun (b : Bool) (l : lists' α b) =>
              lists'.rec (fun (a : α) => { fst := C0 a, snd := PUnit.unit })
                { fst := C1 lists'.nil D0, snd := D0 }
                (fun {b : Bool} (a : lists' α b) (l : lists' α tt)
                  (IH₁ : PProd (C (sigma.mk b a)) sorry) (IH₂ : PProd (C (sigma.mk tt l)) sorry) =>
                  { fst :=
                      C1 (lists'.cons' a l) (D1 (sigma.mk b a) l (pprod.fst IH₁) (pprod.snd IH₂)),
                    snd := D1 (sigma.mk b a) l (pprod.fst IH₁) (pprod.snd IH₂) })
                l)
            tt l) }

def mem {α : Type u_1} (a : lists α) : lists α → Prop := sorry

protected instance has_mem {α : Type u_1} : has_mem (lists α) (lists α) := has_mem.mk mem

theorem is_list_of_mem {α : Type u_1} {a : lists α} {l : lists α} : a ∈ l → is_list l := sorry

theorem equiv.antisymm_iff {α : Type u_1} {l₁ : lists' α tt} {l₂ : lists' α tt} :
    equiv (of' l₁) (of' l₂) ↔ l₁ ⊆ l₂ ∧ l₂ ⊆ l₁ :=
  sorry

theorem equiv_atom {α : Type u_1} {a : α} {l : lists α} : equiv (atom a) l ↔ atom a = l := sorry

theorem equiv.symm {α : Type u_1} {l₁ : lists α} {l₂ : lists α} (h : equiv l₁ l₂) : equiv l₂ l₁ :=
  sorry

theorem equiv.trans {α : Type u_1} {l₁ : lists α} {l₂ : lists α} {l₃ : lists α} :
    equiv l₁ l₂ → equiv l₂ l₃ → equiv l₁ l₃ :=
  sorry

protected instance setoid {α : Type u_1} : setoid (lists α) := setoid.mk equiv sorry

@[simp] def equiv.decidable_meas {α : Type u_1} :
    psum (psigma fun (l₁ : lists α) => lists α)
          (psum (psigma fun (l₁ : lists' α tt) => lists' α tt)
            (psigma fun (a : lists α) => lists' α tt)) →
        ℕ :=
  sorry

theorem sizeof_pos {α : Type u_1} {b : Bool} (l : lists' α b) : 0 < sizeof l := sorry

theorem lt_sizeof_cons' {α : Type u_1} {b : Bool} (a : lists' α b) (l : lists' α tt) :
    sizeof (sigma.mk b a) < sizeof (lists'.cons' a l) :=
  sorry

instance mem.decidable {α : Type u_1} [DecidableEq α] (a : lists α) (l : lists' α tt) :
    Decidable (a ∈ l) :=
  sorry

end lists

namespace lists'

theorem mem_equiv_left {α : Type u_1} {l : lists' α tt} {a : lists α} {a' : lists α} :
    lists.equiv a a' → (a ∈ l ↔ a' ∈ l) :=
  sorry

theorem mem_of_subset {α : Type u_1} {a : lists α} {l₁ : lists' α tt} {l₂ : lists' α tt}
    (s : l₁ ⊆ l₂) : a ∈ l₁ → a ∈ l₂ :=
  sorry

theorem subset.trans {α : Type u_1} {l₁ : lists' α tt} {l₂ : lists' α tt} {l₃ : lists' α tt}
    (h₁ : l₁ ⊆ l₂) (h₂ : l₂ ⊆ l₃) : l₁ ⊆ l₃ :=
  iff.mpr subset_def
    fun (a₁ : lists α) (m₁ : a₁ ∈ to_list l₁) => mem_of_subset h₂ (mem_of_subset' h₁ m₁)

end lists'

def finsets (α : Type u_1) := quotient lists.setoid

namespace finsets

protected instance has_emptyc {α : Type u_1} : has_emptyc (finsets α) :=
  has_emptyc.mk (quotient.mk (lists.of' lists'.nil))

protected instance inhabited {α : Type u_1} : Inhabited (finsets α) := { default := ∅ }

protected instance decidable_eq {α : Type u_1} [DecidableEq α] : DecidableEq (finsets α) :=
  eq.mpr sorry fun (a b : quotient lists.setoid) => quotient.decidable_eq a b

end Mathlib


import set_theory.surreal

namespace pgame
open pgame

theorem foo : Π {x X y Y : pgame} (ox : x.numeric) (oX : X.numeric) (oy : y.numeric) (oY : Y.numeric),
(x < X → y < Y → x * Y + X * y < x * y + X * Y)
∧
(x ≤ X → y ≤ Y → x * Y + X * y ≤ x * y + X * Y)
| (mk xl xr xL xR) (mk Xl Xr XL XR) (mk yl yr yL yR) (mk Yl Yr YL YR) ox oX oy oY :=
begin
  let x := (mk xl xr xL xR),
  let X := (mk Xl Xr XL XR),
  let y := (mk yl yr yL yR),
  let Y := (mk Yl Yr YL YR),
  split,
  {
    intros hxX hyY,
    obtain ⟨i, hi⟩ := lt_def_le.1 hxX;
    obtain ⟨j, hj⟩ := lt_def_le.1 hyY,
    {
      rw lt_def_le,
      left,
      use sum.inr (sum.inl (i, j)),
      change x * Y + X * y ≤ x * y + (XL i * Y + X * YL j - XL i * YL j),
      have := (foo (oX.2.1 i) oX (oY.2.1 j) oY).2 (oX.move_left_le i) (oY.move_left_le j),
    repeat {sorry},
    },
    repeat {sorry},
  },
  repeat {sorry},
end
-- theorem foo : Π (x X y Y : pgame) (ox : x.numeric) (oX : X.numeric) (oy : y.numeric) (oY : Y.numeric),
-- (x < X → y < Y → x * Y + X * y < x * y + X * Y)
-- -- ∧
-- -- (x ≤ X → y ≤ Y → x * Y + y * X ≤ x * X + y * Y)
-- | (mk xl xr xL xR) (mk Xl Xr XL XR) (mk yl yr yL yR) (mk Yl Yr YL YR) ox oX oy oY :=
-- begin
--   let x := (mk xl xr xL xR),
--   let X := (mk Xl Xr XL XR),
--   let y := (mk yl yr yL yR),
--   let Y := (mk Yl Yr YL YR),
--   -- split,
--   {
--     intros hxX hyY,
--     -- have hxX' := le_of_lt ox oX hxX,
--     -- have hyY' := le_of_lt oy oY hyY,
--     obtain ⟨i, hi₁, hi₂⟩ := lt_def.1 hxX,
--     obtain ⟨j, hj₁, hj₂⟩ := lt_def.1 hyY,
--     {
--       rw lt_def,
--       left,
--       use sum.inr (sum.inl (i, j)),
--       split,
--       {
--         rintro (⟨⟨i', j'⟩ | ⟨i', j'⟩⟩ | ⟨i', j'⟩ | ⟨i', j'⟩),
--         {
-- -- change (x * Y).move_left(sum.inl (i', j')) + mk Xl Xr XL XR * mk yl yr yL yR <
-- --     (mk xl xr xL xR * mk yl yr yL yR + mk Xl Xr XL XR * mk Yl Yr YL YR).move_left (sum.inr (sum.inl (i, j))),
--            change
--            (xL i' * Y + x * YL j' - xL i' * YL j') + X * y < x * y + (XL i * Y + X * YL j - XL i * YL j),
--           specialize hi₁ i',
--           clear hi₂ hj₁ hj₂,
--           have := foo (xL i') (XL i) y Y (ox.2.1 i') (oX.2.1 i) oy oY hi₁ hyY,
--           repeat {sorry},
--         },
--         repeat {sorry},
--       },
--       rintro k,
--       change x * Y + X * y <
--     (x * y + (XL i * Y + X * YL j - XL i * YL j)).move_right k,
--       repeat {sorry} },
--     repeat {sorry}
--     },
-- end

-- theorem foo : Π (x X y Y : pgame) (ox : x.numeric) (oX : X.numeric) (oy : y.numeric) (oY : Y.numeric),
-- x < X → y < Y → x * Y + y * X < x * X + y * Y
-- | (mk xl xr xL xR) (mk Xl Xr XL XR) (mk yl yr yL yR) (mk Yl Yr YL YR) ox oX oy oY :=
-- begin
--   set x := (mk xl xr xL xR),
--   set X := (mk Xl Xr XL XR),
--   set y := (mk yl yr yL yR),
--   set Y := (mk Yl Yr YL YR),
--   intros hxX hyY,
--   rw lt_def at *,
--   dsimp at *,
--   rcases hxX, rcases hyY,
--   {
--     obtain ⟨i, hi₁, hi₂⟩ := hxX,
--     obtain ⟨j, hj₁, hj₂⟩ := hyY,
--     right,
--     sorry,
--   },
--   repeat {sorry},
-- end
#check lt_def
-- ⊢ ?m_1 < ?m_2 ↔
--     (∃ (i : ?m_2.left_moves),
--          (∀ (i' : ?m_1.left_moves), ?m_1.move_left i' < ?m_2.move_left i) ∧
--            ∀ (j : (?m_2.move_left i).right_moves), ?m_1 < (?m_2.move_left i).move_right j) ∨
--       ∃ (j : ?m_1.right_moves),
--         (∀ (i : (?m_1.move_right j).left_moves), (?m_1.move_right j).move_left i < ?m_2) ∧
--           ∀ (j' : ?m_2.right_moves), ?m_1.move_right j < ?m_2.move_right j'
end pgame


/-
Copyright (c) 2022 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import Lean
import Std.Lean.Parser

/-! # `simp_intro` tactic -/

namespace Mathlib.Tactic
open Lean Meta Elab Tactic

/--
Main loop of the `simp_intro` tactic.
* `g`: the original goal
* `ctx`: the simp context, which is extended with local variables as we enter the binders
* `discharge?`: the discharger
* `more`: if true, we will keep introducing binders as long as we can
* `ids`: the list of binder identifiers
-/
partial def simpIntroCore (g : MVarId) (ctx : Simp.Context) (discharge? : Option Simp.Discharge)
    (more : Bool) (ids : List (TSyntax ``binderIdent)) : TermElabM (Option MVarId) := do
  let done := return (← simpTargetCore g ctx discharge?).1
  let (transp, var, ids') ← match ids with
    | [] => if more then pure (.reducible, mkHole (← getRef), []) else return ← done
    | v::ids => pure (.default, v.raw[0], ids)
  let t ← withTransparency transp g.getType'
  let n := if var.isIdent then var.getId else `_
  let withFVar := fun (fvar, g) ↦ g.withContext do
    Term.addLocalVarInfo var (mkFVar fvar)
    let simpTheorems ← ctx.simpTheorems.addTheorem (.fvar fvar) (.fvar fvar)
    simpIntroCore g { ctx with simpTheorems } discharge? more ids'
  match t with
  | .letE .. => withFVar (← g.intro n)
  | .forallE (body := body) .. =>
    let (fvar, g) ← g.intro n
    if body.hasLooseBVars then withFVar (fvar, g) else
    match (← simpLocalDecl g fvar ctx discharge?).1 with
    | none =>
      g.withContext <| Term.addLocalVarInfo var (mkFVar fvar)
      return none
    | some g' => withFVar g'
  | _ =>
    if more && ids.isEmpty then done else
    throwErrorAt var "simp_intro failed to introduce {var}\n{g}"

open Parser.Tactic
/--
The `simp_intro` tactic is a combination of `simp` and `intro`: it will simplify the types of
variables as it introduces them and uses the new variables to simplify later arguments
and the goal.
* `simp_intro x y z` introduces variables named `x y z`
* `simp_intro x y z ..` introduces variables named `x y z` and then keeps introducing `_` binders
* `simp_intro (config := cfg) (discharger := tac) x y .. only [h₁, h₂]`:
  `simp_intro` takes the same options as `simp` (see `simp`)
```
example : x + 0 = y → x = z := by
  simp_intro h
  -- h: x = y ⊢ y = z
  sorry
```
-/
elab "simp_intro" cfg:(config)? disch:(discharger)?
    ids:(ppSpace colGt binderIdent)* more:" .."? only:(&" only")? args:(simpArgs)? : tactic => do
  let args := args.map fun args ↦ ⟨args.raw[1].getArgs⟩
  let stx ← `(tactic| simp $(cfg)? $(disch)? $[only%$only]? $[[$args,*]]?)
  let { ctx, dischargeWrapper } ← withMainContext <| mkSimpContext stx (eraseLocal := false)
  dischargeWrapper.with fun discharge? ↦ do
    let g ← getMainGoal
    g.checkNotAssigned `simp_intro
    g.withContext do
      let g? ← simpIntroCore g ctx discharge? more.isSome ids.toList
      replaceMainGoal <| if let some g := g? then [g] else []


import number_theory.class_number.admissible_abs
import number_theory.class_number_computing
import number_theory.farey
import number_theory.ideal_norm
import ring_theory.ideal.norm
import ring_theory.localization.module

open class_group ring real
open quad_ring

variables {R S ι : Type*} [euclidean_domain R] [comm_ring S] [algebra R S]
variables (K L : Type*) (abv : absolute_value R ℤ) (bS : basis ι R S)
  [is_domain S] [field K] [field L] [algebra R K] [is_fraction_ring R K] [algebra K L]
  [finite_dimensional K L] [algRL : algebra R L] [is_scalar_tower R K L]
  [algebra S L]

open_locale big_operators
open_locale non_zero_divisors
open_locale quad_ring

section to_mathlib

@[simp]
lemma ideal.span_singleton_le_iff {R : Type*} [semiring R] {x : R} {I : ideal R} :
  ideal.span {x} ≤ I ↔ x ∈ I :=
submodule.span_singleton_le_iff_mem x I

lemma ideal.span_insert_eq_span {R : Type*} [semiring R] {x : R} {s : set R}
  (h : x ∈ ideal.span s) :
  ideal.span (insert x s) = ideal.span s :=
submodule.span_insert_eq_span h

@[simp] lemma absolute_value.coe_abs {S : Type*} [linear_ordered_ring S] :
  (absolute_value.abs : S → S) = abs := rfl

/-- The coordinates of `f x` in a basis `f ∘ b` are given by the coordinates of `x` in basis `b`.

This is mostly an auxiliary lemma for `basis.mk_comp_repr_self`.

In case `hf : function.injective f`, we can choose
`hli := ((f.linear_independent_iff hf).mpr b.linear_independent)`.
-/
lemma basis.mk_comp_repr_comp_self {ι R M N : Type*}
  [comm_ring R] [add_comm_group M] [add_comm_group N] [module R M] [module R N]
  (b : basis ι R M)
  (f : M →ₗ[R] N) (hli : linear_independent R (f ∘ b)) (hsp : submodule.span R (set.range (f ∘ b)) = ⊤) :
  ((basis.mk hli hsp.ge).repr :
    N →ₗ[R] (ι →₀ R)) ∘ₗ f = b.repr :=
begin
  refine b.ext (λ i, _),
  rw [linear_map.comp_apply, linear_equiv.coe_coe, linear_equiv.coe_coe, basis.repr_self],
  convert basis.repr_self _ i,
  rw basis.mk_apply,
end

/-- The coordinates of `f x` in a basis `f ∘ b` are given by the coordinates of `x` in basis `b`.

In case `hf : function.injective f`, we can choose
`hli := ((f.linear_independent_iff hf).mpr b.linear_independent)`.
-/
@[simp] lemma basis.mk_comp_repr_self {ι R M N : Type*}
  [comm_ring R] [add_comm_group M] [add_comm_group N] [module R M] [module R N]
  (b : basis ι R M) (f : M →ₗ[R] N)
  (hli : linear_independent R (f ∘ b)) (hsp : submodule.span R (set.range (f ∘ b)) = ⊤) (x : M) :
  (basis.mk hli hsp.ge).repr (f x) = b.repr x :=
by rw [← b.repr.coe_coe, ← b.mk_comp_repr_comp_self f hli hsp, linear_map.comp_apply,
       linear_equiv.coe_coe]

/- Promote a basis for `S` over `R` to a basis for `Frac(S)` over `Frac(R)`.

From the hypotheses the existence of such a basis already follows,
this is just a strengthening where the bases coincide (up to coercion).
-/
noncomputable def basis.fraction_ring {R S ι K L : Type*}
  [comm_ring R] [is_domain R] [comm_ring S] [is_domain S] [field K] [field L]
  [algebra R K] [algebra S L] [algebra R S] [algebra K L] [algebra R L]
  [is_scalar_tower R K L] [is_scalar_tower R S L]
  [is_fraction_ring R K] [is_fraction_ring S L]
  -- TODO: can we weaken the hypotheses in the following lines?
  [is_integral_closure S R L] (hKL : algebra.is_algebraic K L) (b : basis ι R S) :
  basis ι K L :=
basis.mk
  (show linear_independent K (λ i, algebra_map S L (b i)),
    from ((((algebra.linear_map S L).restrict_scalars R).linear_independent_iff
        (by simpa only [linear_map.ker_eq_bot, linear_map.coe_restrict_scalars,
            algebra.coe_linear_map]
          using is_fraction_ring.injective S L)).mpr
      b.linear_independent).localization _ (R⁰))
  (begin
    have injRL : function.injective (algebra_map R L),
    { rw is_scalar_tower.algebra_map_eq R K L,
      exact (ring_hom.injective _).comp (is_fraction_ring.injective _ _) },
    have injRS : function.injective (algebra_map R S),
    { refine function.injective.of_comp (show function.injective (algebra_map S L ∘ _), from _),
      rwa [is_scalar_tower.algebra_map_eq R S L, ring_hom.coe_comp] at injRL },
    convert le_refl _,
    rw [eq_top_iff, set_like.le_def],
    rintros x -,
    obtain ⟨x, y, rfl⟩ := is_localization.mk'_surjective S⁰ x,
    -- Write `x / y : L` as `x' / y'` with `y' ∈ R⁰`.
    have : algebra.is_algebraic R L := is_fraction_ring.comap_is_algebraic_iff.mpr hKL,
    obtain ⟨x', y', hy', h⟩ :=
      is_integral_closure.exists_smul_eq_mul this injRL x (non_zero_divisors.ne_zero y.prop),
    refine (is_localization.mem_span_iff R⁰).mpr ⟨algebra_map S _ x', _, ⟨⟨y', _⟩, _⟩⟩,
    { rw [set.range_comp, ← algebra.coe_linear_map, ← linear_map.coe_restrict_scalars R,
        submodule.span_image],
      exact submodule.mem_map_of_mem (b.mem_span _),
      repeat { apply_instance } },
    { exact mem_non_zero_divisors_of_ne_zero hy' },
    { rw [algebra.smul_def, is_fraction_ring.mk'_eq_div, is_fraction_ring.mk'_eq_div],
      simp only [subtype.coe_mk, map_one, one_div, map_mul, map_inv₀ (algebra_map K L),
         ← is_scalar_tower.algebra_map_apply R K L],
      have hy0 := is_localization.to_map_ne_zero_of_mem_non_zero_divisors L le_rfl y.prop,
      have hy'0 := is_localization.to_map_ne_zero_of_mem_non_zero_divisors L le_rfl
        (map_mem_non_zero_divisors _ injRS (mem_non_zero_divisors_of_ne_zero hy')),
      rw [div_eq_iff hy0, mul_assoc, is_scalar_tower.algebra_map_apply R S L,
          eq_inv_mul_iff_mul_eq₀ hy'0, ← map_mul, ← algebra.smul_def, h, mul_comm, map_mul] },
  end)

@[simp]
lemma basis.fraction_ring_apply {R S ι K L : Type*}
  [comm_ring R] [is_domain R] [comm_ring S] [is_domain S] [field K] [field L]
  [algebra R K] [algebra S L] [algebra R S] [algebra K L] [algebra R L]
  [is_scalar_tower R K L] [is_scalar_tower R S L]
  [is_fraction_ring R K] [is_fraction_ring S L]
  -- TODO: can we weaken the hypotheses in the following lines?
  [is_integral_closure S R L] (hKL : algebra.is_algebraic K L)
  (b : basis ι R S) (i : ι) :
  b.fraction_ring hKL i = algebra_map _ _ (b i) :=
by rw [basis.fraction_ring, basis.coe_mk]

@[simp]
lemma basis.fraction_ring_repr_comp_algebra_map {R S ι K L : Type*}
  [comm_ring R] [is_domain R] [comm_ring S] [is_domain S] [field K] [field L]
  [algebra R K] [algebra S L] [algebra R S] [algebra K L] [algebra R L]
  [is_scalar_tower R K L] [is_scalar_tower R S L]
  [is_fraction_ring R K] [is_fraction_ring S L]
  -- TODO: can we weaken the hypotheses in the following lines?
  [is_integral_closure S R L] (hKL : algebra.is_algebraic K L)
  (b : basis ι R S) :
  ((b.fraction_ring hKL).repr.restrict_scalars R : L →ₗ[R] (ι →₀ K)) ∘ₗ
      ((algebra.linear_map S L).restrict_scalars R) =
    (finsupp.map_range.linear_map (algebra.linear_map R K)) ∘ₗ (b.repr : S →ₗ[R] (ι →₀ R)) :=
begin
  refine b.ext (λ i, _),
  rw [linear_map.comp_apply, linear_map.restrict_scalars_apply, algebra.linear_map_apply,
      linear_equiv.coe_coe, linear_equiv.restrict_scalars_apply, linear_map.comp_apply,
      linear_equiv.coe_coe, basis.repr_self, finsupp.map_range.linear_map_apply,
      finsupp.map_range_single, algebra.linear_map_apply, map_one,
      ← b.fraction_ring_apply hKL, basis.repr_self],
end

@[simp]
lemma basis.fraction_ring_repr_algebra_map {R S ι K L : Type*}
  [comm_ring R] [is_domain R] [comm_ring S] [is_domain S] [field K] [field L]
  [algebra R K] [algebra S L] [algebra R S] [algebra K L] [algebra R L]
  [is_scalar_tower R K L] [is_scalar_tower R S L]
  [is_fraction_ring R K] [is_fraction_ring S L]
  -- TODO: can we weaken the hypotheses in the following lines?
  [is_integral_closure S R L] (hKL : algebra.is_algebraic K L)
  (b : basis ι R S) (x : S) (i : ι) :
  (b.fraction_ring hKL).repr (algebra_map S L x) i = algebra_map R K (b.repr x i) :=
calc (b.fraction_ring hKL).repr (algebra_map S L x) i
  = (((b.fraction_ring hKL).repr.restrict_scalars R : L →ₗ[R] (ι →₀ K)) ∘ₗ
      ((algebra.linear_map S L).restrict_scalars R)) x i : rfl
... = ((finsupp.map_range.linear_map (algebra.linear_map R K)) ∘ₗ (b.repr : S →ₗ[R] (ι →₀ R))) x i
  : by rw basis.fraction_ring_repr_comp_algebra_map
... = algebra_map R K (b.repr x i) : rfl

lemma is_fraction_ring.map_left_mul_matrix (R K S L : Type*)
  [comm_ring R] [is_domain R] [comm_ring S] [is_domain S] [field K] [field L]
  [algebra R K] [algebra S L] [algebra R S] [algebra K L] [algebra R L]
  [is_scalar_tower R K L] [is_scalar_tower R S L]
  [is_fraction_ring R K] [is_fraction_ring S L]
  -- TODO: can we weaken the hypotheses in the following lines?
  [is_integral_closure S R L] (hKL : algebra.is_algebraic K L)
  [fintype ι] [decidable_eq ι] (b : basis ι R S) (x : S) :
  (algebra_map R K).map_matrix (algebra.left_mul_matrix b x) =
    algebra.left_mul_matrix (b.fraction_ring hKL) (algebra_map S L x) :=
begin
  ext i j,
  rw [ring_hom.map_matrix_apply, matrix.map_apply, algebra.left_mul_matrix_eq_repr_mul,
    algebra.left_mul_matrix_eq_repr_mul, basis.fraction_ring_apply, ← map_mul,
    basis.fraction_ring_repr_algebra_map],
end

lemma norm_fraction_ring (R K S L : Type*)
  [comm_ring R] [is_domain R] [comm_ring S] [is_domain S] [field K] [field L]
  [algebra R K] [algebra S L] [algebra R S] [algebra K L] [algebra R L]
  [is_scalar_tower R K L] [is_scalar_tower R S L]
  [is_fraction_ring R K] [is_fraction_ring S L]
  -- TODO: can we weaken the hypotheses in the following lines?
  [finite ι] [is_integral_closure S R L] (hKL : algebra.is_algebraic K L)
  (b : basis ι R S) (x : S) :
  algebra.norm K (algebra_map S L x) = algebra_map R K (algebra.norm R x) :=
begin
  classical,
  casesI nonempty_fintype ι,
  rw [algebra.norm_eq_matrix_det b, ring_hom.map_det,
      is_fraction_ring.map_left_mul_matrix R K S L hKL, ← algebra.norm_eq_matrix_det]
end

/-- Let `M` be a finite set of nonzero elements of `S`, so that we can approximate `a / b : L`
with `q / r`, where `r` has finitely many options for `L`.
Then each class in the class group contains an ideal `J` such that `Π m ∈ M` is in `J`.

This is a generalization of `class_group.exists_mk0_eq_mk0`, replacing `finset_approx`
with an arbitrary set `M` that satisfies the conditions.
-/
theorem exists_mk0_eq_mk0'' [is_dedekind_domain S]
  (I : (ideal S)⁰) (M : finset R) (prodM : R) (hprodM : ∀ m ∈ M, m ∣ prodM)
  (hprodMnz : algebra_map R S prodM ≠ 0)
  (hex : ∀ (a : S) {b : S}, b ≠ 0 → (∃ (q : S) (r : R) (H : r ∈ M),
    abv (algebra.norm R (r • a - q * b)) < abv (algebra.norm R b))) :
  ∃ (J : (ideal S)⁰), class_group.mk0 I = class_group.mk0 J ∧
    algebra_map _ _ prodM ∈ (J : ideal S) :=
begin
  classical,
  obtain ⟨b, b_mem, b_ne_zero, b_min⟩ := exists_min abv I,
  suffices : ideal.span {b} ∣ ideal.span {algebra_map _ _ prodM} * I.1,
  { obtain ⟨J, hJ⟩ := this,
    refine ⟨⟨J, _⟩, _, _⟩,
    { rw mem_non_zero_divisors_iff_ne_zero,
      rintro rfl,
      rw [ideal.zero_eq_bot, ideal.mul_bot] at hJ,
      exact hprodMnz (ideal.span_singleton_eq_bot.mp (I.2 _ hJ)) },
    { rw class_group.mk0_eq_mk0_iff,
      exact ⟨algebra_map _ _ prodM, b, hprodMnz, b_ne_zero, hJ⟩ },
    rw [← set_like.mem_coe, ← set.singleton_subset_iff, ← ideal.span_le, ← ideal.dvd_iff_le],
    refine (mul_dvd_mul_iff_left _).mp _,
    swap, { exact mt ideal.span_singleton_eq_bot.mp b_ne_zero },
    rw [subtype.coe_mk, ideal.dvd_iff_le, ← hJ, mul_comm],
    apply ideal.mul_mono le_rfl,
    rw [ideal.span_le, set.singleton_subset_iff],
    exact b_mem },
  rw [ideal.dvd_iff_le, ideal.mul_le],
  intros r' hr' a ha,
  rw ideal.mem_span_singleton at ⊢ hr',
  obtain ⟨q, r, r_mem, lt⟩ := hex a b_ne_zero,
  apply @dvd_of_mul_left_dvd _ _ q,
  simp only [algebra.smul_def] at lt,
  rw ← sub_eq_zero.mp (b_min _ (I.1.sub_mem (I.1.mul_mem_left _ ha) (I.1.mul_mem_left _ b_mem)) lt),
  refine mul_dvd_mul_right (dvd_trans (ring_hom.map_dvd _ _) hr') _,
  exact hprodM _ r_mem,
end

theorem exists_mk0_eq_mk0' [is_dedekind_domain S]
  (I : (ideal S)⁰) (M : finset R) (hM : ∀ m ∈ M, algebra_map R S m ≠ 0)
  (hex : ∀ (a : S) {b : S}, b ≠ 0 → (∃ (q : S) (r : R) (H : r ∈ M),
    abv (algebra.norm R (r • a - q * b)) < abv (algebra.norm R b))) :
  ∃ (J : (ideal S)⁰), class_group.mk0 I = class_group.mk0 J ∧
    algebra_map _ _ (∏ m in M, m) ∈ (J : ideal S) :=
begin
  have hMn : algebra_map R S (∏ m in M, m) ≠ 0,
  { simpa only [ne.def, ring_hom.map_prod, finset.prod_eq_zero_iff, not_exists], },
  exact exists_mk0_eq_mk0'' abv I M (∏ m in M, m) (λ m, finset.dvd_prod_of_mem _) hMn hex,
end

@[simp] lemma class_group.mk0_top {R : Type*} [comm_ring R] [is_domain R] [is_dedekind_domain R]
  (h : ⊤ ∈ (ideal R)⁰ := mem_non_zero_divisors_of_ne_zero bot_lt_top.ne') :
  class_group.mk0 ⟨(⊤ : ideal R), h⟩ = 1 :=
(class_group.mk0_eq_one_iff _).mpr ⟨⟨1, ideal.span_one.symm⟩⟩

end to_mathlib

include bS

/-- Translate norms in the ring of integers to norms in the field of fractions. -/
lemma exists_lt_norm_iff_exists_le_one
  (abv' : absolute_value K ℚ) [finite ι]
  (habv' : ∀ x, abv' (algebra_map R K x) = abv x) [algebra R L] [is_scalar_tower R S L]
  [is_scalar_tower R K L] [is_integral_closure S R L]
  [is_fraction_ring S L] (M : finset R) :
  (∀ (a : S) {b : S}, b ≠ 0 → ∃ (q : S) (r : R) (H : r ∈ M),
    abv (algebra.norm R (r • a - q * b)) < abv (algebra.norm R b)) ↔
  (∀ (γ : L), ∃ (q : S) (r : R) (H : r ∈ M),
    abv' (algebra.norm K (r • γ - algebra_map S L q)) < 1) :=
begin
  haveI : no_zero_smul_divisors R L := no_zero_smul_divisors.trans R K L,
  have hnorm := norm_fraction_ring R K S L (algebra.is_algebraic_of_finite K L) bS,
  have norm_eq_zero : ∀ {x : S}, algebra.norm R x = 0 → x = 0,
  { intros x hx,
    apply_fun algebra_map R K at hx,
    rw [← hnorm, map_zero, algebra.norm_eq_zero_iff] at hx,
    exact ((injective_iff_map_eq_zero (algebra_map S L)).mp (is_fraction_ring.injective S L) x) hx },
  have norm_ne_zero : ∀ {x : S}, x ≠ 0 → algebra.norm R x ≠ 0 := λ x, mt norm_eq_zero,
  split,
  { intros h γ,
    obtain ⟨n : S, d : S, hd, rfl⟩ := @is_fraction_ring.div_surjective S _ _ _ _ _ _ γ,
    rw mem_non_zero_divisors_iff_ne_zero at hd,
    have hd' : algebra_map S L d ≠ 0 := mt
      ((injective_iff_map_eq_zero (algebra_map S L)).mp (is_fraction_ring.injective S L) d) hd,
    rcases h n hd with ⟨q, r, H, hlt⟩,
    rw [← @int.cast_lt ℚ] at hlt,
    refine ⟨q, r, H,
      (mul_lt_mul_right (abv'.pos (show algebra_map R K (algebra.norm R d) ≠ 0, from _))).mp _⟩,
    { rwa [ne.def, ← hnorm, algebra.norm_eq_zero_iff] },
    { rw [one_mul, ← map_mul, ← hnorm, ← map_mul, sub_mul, smul_mul_assoc, div_mul_cancel _ hd'],
      simpa only [← habv', ← hnorm, algebra.smul_def, map_sub, map_mul,
        ← is_scalar_tower.algebra_map_apply] using hlt } },
  { intros h a b hb,
    obtain ⟨q, r, H, hqr⟩ := h (algebra_map _ _ a / algebra_map _ _ b),
    have hb' : algebra_map S L b ≠ 0 := mt
      ((injective_iff_map_eq_zero (algebra_map S L)).mp (is_fraction_ring.injective S L) b) hb,
    refine ⟨q, r, H, _⟩,
    have := (mul_lt_mul_right (abv'.pos (mt algebra.norm_eq_zero_iff.mp hb'))).mpr hqr,
    rw [one_mul, ← map_mul, ← map_mul, hnorm, sub_mul, smul_mul_assoc, div_mul_cancel _ hb']
      at this,
    simpa only [← @int.cast_lt ℚ, ← habv', ← hnorm, algebra.smul_def, map_sub, map_mul,
      ← is_scalar_tower.algebra_map_apply] using this },
end

omit bS

lemma sub_round_sq {K : Type*} [linear_ordered_field K] [floor_ring K]
  (a : K) : (a - round a)^2 ≤ 1/4 :=
calc (a - round a)^2 = |a - round a|^2 : (pow_bit0_abs _ _).symm
                 ... ≤ (1/2) ^ 2 : sq_le_sq.mpr
  (by simpa only [abs_abs, abs_eq_self.mpr (show 0 ≤ (1/2 : K), by norm_num)]
    using abs_sub_round a)
                 ... = 1/4 : by norm_num

namespace quad_ring

/-- Any `γ : ℚ(√d)` can be approximated by a whole, or half, of some `q : ℤ[√d]`,
when `-6 ≤ d ≤ 0`. -/
theorem sqrt_neg.exists_q_r {d : ℤ} {d' : ℚ} [hdd' : fact $ algebra_map ℤ ℚ d = d']
  (d_nonpos : d ≤ 0) (hdge : -6 ≤ d) (γ : quad_ring ℚ 0 d') :
  ∃ (q : quad_ring ℤ 0 d) (r ∈ ({1, 2} : finset ℤ)),
    absolute_value.abs (algebra.norm ℚ (r • γ - algebra_map ℤ[√d] ℚ(√d') q)) < 1 :=
begin
  have d'_nonpos : d' ≤ 0,
  { simpa only [← hdd'.out, int.cast_nonpos, eq_int_cast] using d_nonpos },
  have hd'ge : -6 ≤ d',
  { simpa only [← hdd'.out, eq_int_cast, int.cast_bit0, int.cast_bit1, int.cast_one, int.cast_neg]
      using (@int.cast_le ℚ _ _ _ _).mpr hdge },

  let n := round γ.b1,
  let m := round γ.b2,
  -- If the imaginary component is small enough, `γ` is close to an integral element.
  by_cases hb2 : (γ.b2 - m)^2 ≤ 1/9,
  { use [⟨n,m⟩, 1, finset.mem_insert_self 1 {2}],
    have norm_nonneg : 0 ≤ (γ.b1 - ↑n) ^ 2 - d' * (γ.b2 - ↑m) ^ 2,
    { simpa only [quad_ring.norm_eq, zero_mul, add_zero] using norm_nonneg d'_nonpos (γ - ⟨n, m⟩) },
    simp only [quad_ring.norm_eq, zsmul_eq_mul, int.cast_one, one_mul, algebra_map_mk,
      sub_b1, sub_b2, absolute_value.coe_abs, abs_of_nonneg norm_nonneg, zero_mul, add_zero],
    -- Help `linarith` with the nonlinear part of the inequality
    have : (γ.b1 - ↑n) ^ 2 ≤ 1/4 := sub_round_sq γ.b1,
    have := mul_le_mul_of_nonpos_left hb2 d'_nonpos,
    linarith },
  -- Otherwise we have to choose a point halfway between integral elements.
  -- The value of `m'` is not quite as easy to put in a formula, so we'll work with its properties.
  let n' := round (2 * γ.b1),
  rsuffices ⟨m', hm'⟩ : ∃ m' : ℤ, (2 * γ.b2 - m')^2 ≤ 1/9,
  { refine ⟨⟨n', m'⟩, 2, finset.mem_insert_of_mem (finset.mem_singleton_self _), _⟩,
    have norm_nonneg : 0 ≤ (2 * γ.b1 - n') ^ 2 - d' * (2 * γ.b2 - m') ^ 2,
    { simpa only [quad_ring.norm_eq, zero_mul, add_zero, quad_ring.sub_b1, quad_ring.sub_b2, quad_ring.smul_b1,
          quad_ring.smul_b2, smul_eq_mul]
        using quad_ring.norm_nonneg d'_nonpos ((2 : ℚ) • γ - ⟨n', m'⟩) },
    simp only [zsmul_eq_mul, int.cast_bit0, int.cast_one, algebra_map_mk, norm_eq,
      sub_b1, mul_b1, bit0_b1, one_b1, bit0_b2, one_b2, bit0_zero, zero_mul,
      add_zero, sub_b2, mul_b2, zero_add, absolute_value.coe_abs, abs_of_nonneg norm_nonneg],
    -- Help `linarith` with the nonlinear part of the inequality
    have : (2 * γ.b1 - n') ^ 2 ≤ 1/4 := sub_round_sq (2 * γ.b1),
    have := mul_le_mul_of_nonpos_left hm' d'_nonpos,
    linarith },
  -- Let's modify the equations into a more linear form:
  obtain ⟨half_le, le_half⟩ : - (1/2) ≤ γ.b2 - m ∧ γ.b2 - m ≤ 1/2 := abs_le.mp (abs_sub_round γ.b2),
  have third_sq : (1/3 : ℚ)^2 = 1/9, { norm_num },
  have abs_third : |(1/3 : ℚ)| = 1/3, { norm_num },
  simp only [← third_sq, abs_third, sq_le_sq, abs_le] at ⊢,
  simp only [not_le, ← third_sq, abs_third, sq_lt_sq, lt_abs] at hb2,
  -- Depending on the difference between `γ.b2` and `m`, round up or down:
  cases hb2 with hb2_lt hb2_gt,
  { use 2 * m + 1,
    simp only [int.cast_mul, int.cast_add, int.cast_bit0, int.cast_one, ← sub_sub, ← mul_sub],
    split; linarith },
  { use 2 * m - 1,
    simp only [int.cast_mul, int.cast_sub, int.cast_bit0, int.cast_one, ← sub_add, ← mul_sub],
    split; linarith },
end

.

section missing
variables {α : Type*} [linear_ordered_ring α] [floor_ring α]

open int

@[simp] lemma fract_add_nat (a : α) (m : ℕ) : fract (a + m) = fract a :=
by { rw fract, simp }

@[simp] lemma ceil_add_nat (a : α) (n : ℕ) : ⌈a + n⌉ = ⌈a⌉ + n :=
by rw [← int.cast_coe_nat, ceil_add_int]

@[simp] lemma ceil_sub_nat (a : α) (z : ℕ) : ⌈a - z⌉ = ⌈a⌉ - z :=
by convert ceil_sub_int a z using 1; simp

@[simp] lemma floor_sub_one (a : α) : ⌊a - 1⌋ = ⌊a⌋ - 1 :=
by rw [eq_sub_iff_add_eq, ← floor_add_one, sub_add_cancel]

end missing

section round_lemmas

variables {α : Type*} [linear_ordered_ring α] [floor_ring α]

@[simp]
lemma round_add_int (x : α) (y : ℤ) : round (x + y) = round x + y :=
by rw [round, round, int.fract_add_int, int.floor_add_int, int.ceil_add_int, ← apply_ite2, if_t_t]

@[simp]
lemma round_add_one (a : α) : round (a + 1) = round a + 1 :=
by { convert round_add_int a 1, exact int.cast_one.symm }

@[simp]
lemma round_sub_int (x : α) (y : ℤ) : round (x - y) = round x - y :=
by { rw [sub_eq_add_neg], norm_cast, rw [round_add_int, sub_eq_add_neg] }

@[simp]
lemma round_sub_one (a : α) : round (a - 1) = round a - 1 :=
by { convert round_sub_int a 1, exact int.cast_one.symm }

@[simp]
lemma round_add_nat (x : α) (y : ℕ) : round (x + y) = round x + y :=
by rw [round, round, fract_add_nat, int.floor_add_nat, ceil_add_nat, ← apply_ite2, if_t_t]

@[simp]
lemma round_sub_nat (x : α) (y : ℕ) : round (x - y) = round x - y :=
by { rw [sub_eq_add_neg, ← int.cast_coe_nat], norm_cast, rw [round_add_int, sub_eq_add_neg] }

@[simp]
lemma round_int_add (x : α) (y : ℤ) : round ((y : α) + x) = y + round x :=
by { rw [add_comm, round_add_int, add_comm] }

@[simp]
lemma round_nat_add (x : α) (y : ℕ) : round ((y : α) + x) = y + round x :=
by { rw [add_comm, round_add_nat, add_comm] }

end round_lemmas

section general_statement
open floor_semiring

lemma one_dim'_special {x : ℚ} (hx : int.fract x ≤ 1/2) : ∃ r : ℕ, r ≤ 4 ∧ 1 ≤ r ∧
  |↑r * x - ↑(round (↑r * x))| ≤ 6/25 :=
begin
  have h₀ : 0 ≤ int.fract x := int.fract_nonneg x,
  rw ← int.floor_add_fract x,
  simp only [mul_add],
  norm_cast,
  simp only [round_int_add, int.cast_add, add_sub_add_left_eq_sub],
  simp_rw abs_sub_round_eq_min,
  by_cases h₁ : int.fract x < 1/5,
  { use [1, by norm_num, by norm_num],
    simp only [nat.cast_one, one_mul, int.fract_fract, min_le_iff],
    left,
    linarith only [h₁],
    },
  by_cases h₂ : int.fract x < 1/4,
  { use [4, by norm_num, by norm_num],
    simp only [nat.cast_one, nat.cast_bit0, min_le_iff, tsub_le_iff_right],
    right,
    rw int.fract_eq_self.mpr,
    linarith only [h₁],
    split,
    linarith only [h₁],
    linarith only [h₂],
    },
  by_cases h₃ : int.fract x < 3/10,
  { use [4, by norm_num, by norm_num],
    simp only [nat.cast_one, nat.cast_bit0, min_le_iff, tsub_le_iff_right],
    left,
    rw ((int.fract_eq_iff).mpr _ : int.fract (4 * int.fract x) = 4 * int.fract x - 1),
    linarith only [h₃],
    split,
    linarith only [h₂],
    split,
    linarith only [h₃],
    use 1,
    simp, },
  by_cases h₄ : int.fract x < 1/3,
  { use [3, by norm_num, by norm_num],
    simp only [nat.cast_one, nat.cast_bit1, nat.cast_bit0, min_le_iff, tsub_le_iff_right],
    right,
    rw ((int.fract_eq_iff).mpr _ : int.fract (3 * int.fract x) = 3 * int.fract x),
    linarith only [h₃],
    split,
    linarith only [h₃],
    split,
    linarith only [h₄],
    use 0,
    simp, },
  by_cases h₅ : int.fract x < 2/5,
  { use [3, by norm_num, by norm_num],
    simp only [nat.cast_one, nat.cast_bit1, nat.cast_bit0, min_le_iff, tsub_le_iff_right],
    left,
    rw ((int.fract_eq_iff).mpr _ : int.fract (3 * int.fract x) = 3 * int.fract x - 1),
    linarith only [h₅],
    split,
    linarith only [h₄],
    split,
    linarith only [h₅],
    use 1,
    simp, },
  by_cases h₆ : int.fract x < 1/2,
  { use [2, by norm_num, by norm_num],
    simp only [nat.cast_one, nat.cast_bit1, nat.cast_bit0, min_le_iff, tsub_le_iff_right],
    right,
    rw ((int.fract_eq_iff).mpr _ : int.fract (2 * int.fract x) = 2 * int.fract x),
    linarith only [h₅],
    split,
    linarith only [h₅],
    split,
    linarith only [h₆],
    use 0,
    simp, },
  { use [2, by norm_num, by norm_num],
    have : int.fract x = 1 / 2, linarith only [hx, h₆],
    norm_num [this], },
end

lemma int.fract_neg {R : Type*} [linear_ordered_ring R] [floor_ring R] {x : R} (hx : int.fract x ≠ 0) :
  int.fract (-x) = 1 - int.fract x :=
begin
  rw int.fract_eq_iff,
  split,
  { rw [le_sub_iff_add_le, zero_add],
    exact (int.fract_lt_one x).le, },
  refine ⟨sub_lt_self _ (lt_of_le_of_ne' (int.fract_nonneg x) hx), -⌊x⌋ - 1, _⟩,
  simp only [sub_sub_eq_add_sub, int.cast_sub, int.cast_neg, int.cast_one, sub_left_inj],
  conv in (-x) {rw ← int.floor_add_fract x},
  simp [-int.floor_add_fract],
end

@[simp]
lemma int.fract_neg_eq_zero {R : Type*} [linear_ordered_ring R] [floor_ring R] {x : R} :
  int.fract (-x) = 0 ↔ int.fract x = 0 :=
begin
  simp only [int.fract_eq_iff, le_refl, zero_lt_one, tsub_zero, true_and],
  split; rintros ⟨z, hz⟩; use [-z]; simp [← hz],
end

lemma one_dim' (x : ℚ) : ∃ r : ℕ, r ≤ 4 ∧ 1 ≤ r ∧
  |↑r * x - ↑(round (↑r * x))| ≤ 6/25 :=
begin
  by_cases h : int.fract x ≤ 1/2,
  { exact one_dim'_special h, },
  { simp only [not_le] at h,
    have : int.fract (-x) < 1/2,
    { rw int.fract_neg, linarith, linarith, },
    have := one_dim'_special this.le,
    apply Exists.imp _ this,
    intro r,
    simp only [mul_neg, and_imp],
    intros hr1 hr2 h,
    simp only [abs_sub_round_eq_min, hr1, hr2, min_le_iff, tsub_le_iff_right, true_and] at h ⊢,
    cases h with h h;
    by_cases hz : int.fract (-(↑r * x)) = 0;
    try { rw int.fract_neg_eq_zero at hz, simp [hz], left, norm_num, };
    have := int.fract_neg hz;
    simp only [neg_neg] at this;
    rw this;
    [right, left];
    linarith, },
end

.

theorem quad_ring.exists_q_r_thirteen (γ : quad_ring ℚ 0 (-13)) :
  ∃ (q : quad_ring ℤ 0 (-13)) (r ∈ finset.Icc (1 : ℤ) 4),
    absolute_value.abs (algebra.norm ℚ (r • γ - algebra_map (quad_ring ℤ 0 (-13)) (quad_ring ℚ 0 (-13)) q)) < 1 :=
begin
  rcases one_dim' γ.b2 with ⟨r, hl, hr, hb⟩,
  refine ⟨⟨round ((r : ℚ) * γ.b1) , round ((r : ℚ) * γ.b2)⟩, r, _, _⟩,
  { simp only [nat.one_le_cast, one_div, finset.mem_Icc, hl, hr, true_and],
    exact_mod_cast hl, },

  have hb' := (mul_le_mul_left (show (0 : ℚ) < 13, by norm_num)).mpr (@pow_le_pow_of_le_left ℚ _ _ _ (abs_nonneg _) hb 2),
  rw pow_bit0_abs at hb',

  simp only [zsmul_eq_mul, algebra_map_mk, norm_eq, sub_b1, mul_b1, coe_int_b1, coe_int_b2,
    zero_mul, add_zero, sub_b2, mul_b2, zero_add],
  refine (abs_sub _ _).trans_lt _,
  simp only [abs_mul, abs_pow, pow_bit0_abs, abs_neg, int.cast_coe_nat,
      abs_eq_self.mpr (show (0 : ℚ) ≤ 13, by norm_num)],
  refine (add_le_add (sub_round_sq (↑r * γ.b1)) hb').trans_lt (add_lt_of_lt_sub_right _),
  norm_num,
end

end general_statement

section

instance fact.or_left {P Q : Prop} [fact P] : fact $ P ∨ Q := fact.mk (or.inl $ fact.out _)
instance fact.or_right {P Q : Prop} [fact Q] : fact $ P ∨ Q := fact.mk (or.inr $ fact.out _)

 -- `d` is a free variable so this can't be an instance
local attribute [instance] fact_not_square'_of_eq_two_or_three_mod_four

/-- Every class in the class group contains an ideal which includes `2`. -/
lemma sqrt_neg.exists_J {d : ℤ} [fact $ d % 4 = 2 ∨ d % 4 = 3] [fact $ squarefree d]
  (d_nonpos : d ≤ 0) (hd' : -6 ≤ d) (I : (ideal (quad_ring ℤ 0 d))⁰) :
  ∃ (J : (ideal (quad_ring ℤ 0 d))⁰),
    class_group.mk0 I = class_group.mk0 J ∧ (2 : ℤ[√d]) ∈ (J : ideal (quad_ring ℤ 0 d)) :=
begin
  refine exists_mk0_eq_mk0' absolute_value.abs I ({1, 2} : finset ℤ) _ _,
  { rintro m (H | H | _ | _); simp only [H, eq_int_cast, quad_ring.coe_one, int.cast_bit0],
    { exact one_ne_zero },
    { exact two_ne_zero } },
  rw exists_lt_norm_iff_exists_le_one ℚ ℚ(√d) absolute_value.abs (quad_ring.basis ℤ 0 d)
    absolute_value.abs _ _,
  { exact sqrt_neg.exists_q_r d_nonpos hd' },
  { intros x, rw [absolute_value.coe_abs, absolute_value.coe_abs, int.cast_abs, eq_int_cast] },
end

-- TODO rename
/-- Every class in the class group contains an ideal which includes `2`. -/
lemma sqrt_neg.exists_J' {d : ℤ} [fact $ d % 4 = 2 ∨ d % 4 = 3] [fact $ squarefree d]
  (d_nonpos : d ≤ 0) (hd' : -6 ≤ d) (I : class_group (quad_ring ℤ 0 d)) :
  ∃ (J : (ideal (quad_ring ℤ 0 d))⁰), I = class_group.mk0 J ∧
    (2 : ℤ[√d]) ∈ (J : ideal (quad_ring ℤ 0 d)) :=
begin
  obtain ⟨I, rfl⟩ := class_group.mk0_surjective I,
  exact sqrt_neg.exists_J d_nonpos hd' I,
end
end

open_locale classical

@[simp] lemma abs_norm_eq_of_abs_norm_sq_eq_sq [infinite S]
  [_root_.module.free ℤ S] [_root_.module.finite ℤ S]
  [is_dedekind_domain S] {I : ideal S} {n : ℕ} (h : (I^2).abs_norm = n^2) :
  I.abs_norm = n :=
begin
  rw [pow_two, pow_two, map_mul, ← pow_two, ← pow_two] at h,
  exact @nat.pow_left_injective 2 (by norm_num) _ _ h
end

-- `d` is a free variable so this can't be an instance
local attribute [instance] fact_not_square'_of_eq_two_or_three_mod_four

/-- The square root of 2 is a prime element of the monoid of ideals. -/
lemma sqrt_2_prime (d : ℤ) [fact $ d % 4 = 2 ∨ d % 4 = 3] [hsq : fact $ squarefree d] :
  prime (sqrt_2 d : ideal ℤ[√d]) :=
begin
  rw ← unique_factorization_monoid.irreducible_iff_prime,
  refine irreducible_of_map_irreducible ideal.abs_norm
    (λ x hx, by rwa [ideal.one_eq_top, ← ideal.abs_norm_eq_one_iff])
    _,
  have : ideal.abs_norm (sqrt_2 d : ideal (quad_ring ℤ 0 d)) = 2,
  { refine abs_norm_eq_of_abs_norm_sq_eq_sq _, -- TODO: compute this directly
    rw [sqrt_2_pow_two _, ideal.abs_norm_span_singleton],
    norm_num },
  norm_num [this, irreducible_iff_nat_prime],
end

/-- For `-6 ≤ d ≤ 0`, the class group of `ℚ(√d)` consists of at most two elements. -/
theorem class_group_eq {d : ℤ} [fact $ d % 4 = 2 ∨ d % 4 = 3] [hsq : fact $ squarefree d]
  (d_nonpos : d ≤ 0) (hd' : -6 ≤ d) (I : class_group (quad_ring ℤ 0 d)) :
  I ∈ ({1, class_group.sqrt_2 d} : finset (class_group (quad_ring ℤ 0 d))) :=
begin
  simp only [finset.mem_insert, finset.mem_singleton],
  obtain ⟨⟨J, hJ0⟩, rfl, hJ⟩ := sqrt_neg.exists_J' d_nonpos hd' I,
  -- TODO: do this by showing the class group is generated by the primes dividing 2 (in this case)
  have hJ2 : J ∣ ideal.span {2},
  { simpa only [set_like.coe_mk, ideal.dvd_iff_le, ideal.span_singleton_le_iff] using hJ },
  rw [← sqrt_2_pow_two, dvd_prime_pow (sqrt_2_prime d)] at hJ2,
  obtain ⟨n, hn, J_eq⟩ := hJ2,
  rcases associated_iff_eq.mp J_eq with rfl,
  have hn' : n < 3 := hn.trans_lt (by norm_num),
  have := n.zero_le,
  interval_cases using this hn',
  { simp only [true_or, eq_self_iff_true, class_group.mk0_top, ideal.one_eq_top, pow_zero] },
  { simp only [set_like.eta, class_group.sqrt_2, eq_self_iff_true, pow_one, or_true] },
  { left,
    refine (class_group.mk0_eq_one_iff _).mpr ⟨⟨2, _⟩⟩,
    rw [sqrt_2_pow_two, ideal.submodule_span_eq] },
end

noncomputable instance {d : ℤ} [fact $ d % 4 = 2 ∨ d % 4 = 3] [hsq : fact $ squarefree d] :
  fintype (class_group (quad_ring ℤ 0 d)) :=
class_group.fintype_of_admissible_of_finite ℚ (quad_ring ℚ 0 d) absolute_value.abs_is_admissible

lemma univ_eq {d : ℤ}
  [fact $ d % 4 = 2 ∨ d % 4 = 3] [hsq : fact $ squarefree d]
  (d_nonpos : d ≤ 0) (hd' : -6 ≤ d) :
  finset.univ = ({1, class_group.sqrt_2 d} : finset (class_group (quad_ring ℤ 0 d))) :=
symm $ eq_top_iff.mpr $ λ I _, class_group_eq d_nonpos hd' I

end quad_ring