import topology.basic
import topology.compact_open
import data.nat.prime
import data.real.basic
import data.real.irrational
import data.complex.basic
import data.fin.basic
import geometry.euclidean.basic
import analysis.inner_product_space.pi_L2
import algebra.group.defs
import algebra.field.basic
import combinatorics.configuration
import ring_theory.polynomial.basic
import group_theory.free_group
import combinatorics.simple_graph.basic
import ring_theory.integral_closure
import data.fintype.card
import category_theory.category.basic
import ring_theory.discrete_valuation_ring
import group_theory.torsion
import linear_algebra.matrix.charpoly.basic
import algebra.order.absolute_value
import analysis.convex.basic
import topology.uniform_space.uniform_convergence_topology
import topology.sequences
import analysis.normed.group.infinite_sum
import data.nat.choose.sum
import group_theory.specific_groups.cyclic
import group_theory.order_of_element
import analysis.mean_inequalities
import analysis.normed_space.banach
import topology.algebra.continuous_monoid_hom
import linear_algebra.matrix.symmetric
import analysis.inner_product_space.spectrum
import ring_theory.class_group
import ring_theory.dedekind_domain.basic
import ring_theory.principal_ideal_domain
import model_theory.satisfiability
import probability.integration
import ring_theory.simple_module
import category_theory.preadditive.schur
import representation_theory.maschke
import topology.paracompact
import combinatorics.simple_graph.coloring
/- FEW SHOT PROMPTS TO CODEX(START)
/--`theorem`
Power Set is Closed under Intersection
Let $S$ be a set.

Let $\powerset S$ be the power set of $S$.

Then:
:$\forall A, B \in \powerset S: A \cap B \in \powerset S$
`proof`
Let $A, B \in \powerset S$.

Then by the definition of power set, $A \subseteq S$ and $B \subseteq S$.

From Intersection is Subset we have that $A \cap B \subseteq A$.

It follows from Subset Relation is Transitive that $A \cap B \subseteq S$.

Thus $A \cap B \in \powerset S$ and closure is proved.
{{qed}}
-/
theorem power_set_intersection_closed {α : Type*} (S : set α) : ∀ A B ∈ 𝒫 S, (A ∩ B) ∈ 𝒫 S :=
begin
  -- $A$ and $B$ are sets. $A$ and $B$ belong to power set of $S$
  assume (A : set α) (hA : A ∈ 𝒫 S) (B : set α) (hB : B ∈ 𝒫 S),
  -- Then $A ⊆ S$ and $B ⊆ S$, by power set definition
  have h1 : (A ⊆ S) ∧ (B ⊆ S), from by auto [set.subset_of_mem_powerset, set.subset_of_mem_powerset],
  -- Then $(A ∩ B) ⊆ A$, by intersection of set is a subset
  have h2 : (A ∩ B) ⊆ A, from by auto [set.inter_subset_left],
  -- Then $(A ∩ B) ⊆ S$, by subset relation is transitive
  have h3 : (A ∩ B) ⊆ S, from by auto [set.subset.trans],
  -- Hence $(A ∩ B) ∈  𝒫 S$, by power set definition
  show (A ∩ B) ∈  𝒫 S, from by auto [set.mem_powerset],
end

/--`theorem`
Square of Sum
 :$\forall x, y \in \R: \paren {x + y}^2 = x^2 + 2 x y + y^2$
`proof`
Follows from the distribution of multiplication over addition:

{{begin-eqn}}
{{eqn | l = \left({x + y}\right)^2
      | r = \left({x + y}\right) \cdot \left({x + y}\right)
}}
{{eqn | r = x \cdot \left({x + y}\right) + y \cdot \left({x + y}\right)
      | c = Real Multiplication Distributes over Addition
}}
{{eqn | r = x \cdot x + x \cdot y + y \cdot x + y \cdot y
      | c = Real Multiplication Distributes over Addition
}}
{{eqn | r = x^2 + 2xy + y^2
      | c =
}}
{{end-eqn}}
{{qed}}
-/
theorem square_of_sum (x y : ℝ) : (x + y)^2 = (x^2 + 2*x*y + y^2)
begin
  -- expand the power
  calc (x + y)^2 = (x+y)*(x+y) : by auto [sq]
  -- distributive property of multiplication over addition gives:
  ... = x*(x+y) + y*(x+y) : by auto [add_mul]
  -- applying the above property further gives:
  ... = x*x + x*y + y*x + y*y : by auto [mul_comm, add_mul] using [ring]
  -- rearranging the terms using commutativity and adding gives:
  ... = x^2 + 2*x*y + y^2 : by auto [sq, mul_comm] using [ring]
end

/--`theorem`
Identity of Group is Unique
Let $\struct {G, \circ}$ be a group. Then there is a unique identity element $e \in G$.
`proof`
From Group has Latin Square Property, there exists a unique $x \in G$ such that:
:$a x = b$

and there exists a unique $y \in G$ such that:
:$y a = b$

Setting $b = a$, this becomes:

There exists a unique $x \in G$ such that:
:$a x = a$

and there exists a unique $y \in G$ such that:
:$y a = a$

These $x$ and $y$ are both $e$, by definition of identity element.
{{qed}}
-/
theorem group_identity_unique {G : Type*} [group G] : ∃! e : G, ∀ a : G, e * a = a ∧ a * e = a :=
begin
  -- Group has Latin Square Property
  have h1 : ∀ a b : G, ∃! x : G, a * x = b, from by auto using [use (a⁻¹ * b)],
  have h2 : ∀ a b : G, ∃! y : G, y * a = b, from by auto using [use b * a⁻¹],

  -- Setting $b = a$, this becomes:
  have h3 : ∀ a : G, ∃! x : G, a * x = a, from by auto [h1],
  have h4 : ∀ a : G, ∃! y : G, y * a = a, from by auto [h2],

  -- These $x$ and $y$ are both $(1 : G)$, by definition of identity element
  have h5 : ∀ a : G, classical.some (h3 a).exists = (1 : G), from by auto [exists_unique.unique, h3, classical.some_spec, exists_unique.exists, mul_one],
  have h6 : ∀ a : G, classical.some (h4 a).exists = (1 : G), from by auto [exists_unique.unique, h4, classical.some_spec, exists_unique.exists, one_mul],

  show ∃! e : G, ∀ a : G, e * a = a ∧ a * e = a, from by auto [h3, h4, exists_unique.unique, classical.some_spec, exists_unique.exists] using [use (1 : G)],
end

/--`theorem`
Schur's Inequality Short Simpler
Let $x, y, z \in \R_{\ge 0}$ be positive real numbers such that $x \ge y \ge z \ge 0$.

Let $t \in \R, t > 0$ be a (strictly) positive real number.

Then:
:$x^t \paren {x - y} \paren {x - z} + y^t \paren {y - z} \paren {y - x} + z^t \paren {z - x} \paren {z - y} \ge 0$

`proof`

Consider the expression:
:$\paren {x - y} \paren {x^t \paren {x - z} - y^t \paren {y - z}} + z^t \paren {x - z} \paren {y - z}$

We see that every term in the above is non-negative. So, directly:
:$(1): \quad \paren {x - y} \paren {x^t \paren {x - z} - y^t \paren {y - z}} + z^t \paren {x - z} \paren {y - z} \ge 0$

$(1) can be rearranged to Schur's inequality.
{{qed}}
-/
theorem
FEW SHOT PROMPTS TO CODEX(END)-/
--OUTPUT 1
theorem schur_inequality_short_simpler (x y z : ℝ) (h1 : x ≥ y) (h2 : y ≥ z) (h3 : z ≥ 0) (t : ℝ) (h4 : t > 0) : x^t * (x - y) * (x - z) + y^t * (y - z) * (y - x) + z^t * (z - x) * (z - y) ≥ 0 :=
begin
  -- Consider the expression:
  have h5 : (x - y) * (x^t * (x - z) - y^t * (y - z)) + z^t * (x - z) * (y - z) ≥ 0,
  {
    -- We see that every term in the above is non-negative. So, directly:
    show (x - y) * (x^t * (x - z) - y^t * (y - z)) + z^t * (x - z) * (y - z) ≥ 0, from by auto [h1, h2, h3, h4, pow_pos, mul_nonneg, sub_nonneg, sub_nonneg_of_le, mul_nonneg, mul_nonneg, add_nonneg],
  },

  -- $(1) can be rearranged to Schur's inequality.
  show x^t * (x - y) * (x - z) + y^t * (y - z) * (y - x) + z^t * (z - x) * (z - y) ≥ 0, from by auto [h1, h2, h3, h4, pow_pos, mul_nonneg, sub_nonneg, sub_nonneg_of_le, mul_nonneg, mul_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg, add_nonneg,
end --Needs more than 2000 tokens!


/-
Copyright (c) 2019 Sébastien Gouëzel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Sébastien Gouëzel

! This file was ported from Lean 3 source module tactic.field_simp
! leanprover-community/mathlib commit 24a09b317861fb5aa3850cfd1254acf729b0a398
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Tactic.Interactive
import Mathbin.Tactic.NormNum

/-!
# `field_simp` tactic

Tactic to clear denominators in algebraic expressions, based on `simp` with a specific simpset.
-/

namespace Tactic

/- ./././Mathport/Syntax/Translate/Expr.lean:330:4: warning: unsupported (TODO): `[tacs] -/
-- failed to format: unknown constant 'term.pseudo.antiquot'
/--
      Try to prove a goal of the form `x ≠ 0` by calling `assumption`, or `norm_num1` if `x` is
      a numeral. -/
    unsafe
  def
    field_simp.ne_zero
    : tactic Unit
    :=
      do
        let goal ← tactic.target
          match
            goal
            with
            | q( $ ( e ) ≠ 0 ) => assumption <|> do let n ← e sorry
              | _ => tactic.fail "goal should be of the form `x ≠ 0`"
#align tactic.field_simp.ne_zero tactic.field_simp.ne_zero

namespace Interactive

/- ./././Mathport/Syntax/Translate/Tactic/Mathlib/Core.lean:38:34: unsupported: setup_tactic_parser -/
/--
The goal of `field_simp` is to reduce an expression in a field to an expression of the form `n / d`
where neither `n` nor `d` contains any division symbol, just using the simplifier (with a carefully
crafted simpset named `field_simps`) to reduce the number of division symbols whenever possible by
iterating the following steps:

- write an inverse as a division
- in any product, move the division to the right
- if there are several divisions in a product, group them together at the end and write them as a
  single division
- reduce a sum to a common denominator

If the goal is an equality, this simpset will also clear the denominators, so that the proof
can normally be concluded by an application of `ring` or `ring_exp`.

`field_simp [hx, hy]` is a short form for
`simp [-one_div, -mul_eq_zero, hx, hy] with field_simps {discharger := tactic.field_simp.ne_zero}`

Note that this naive algorithm will not try to detect common factors in denominators to reduce the
complexity of the resulting expression. Instead, it relies on the ability of `ring` to handle
complicated expressions in the next step.

As always with the simplifier, reduction steps will only be applied if the preconditions of the
lemmas can be checked. This means that proofs that denominators are nonzero should be included. The
fact that a product is nonzero when all factors are, and that a power of a nonzero number is
nonzero, are included in the simpset, but more complicated assertions (especially dealing with sums)
should be given explicitly. If your expression is not completely reduced by the simplifier
invocation, check the denominators of the resulting expression and provide proofs that they are
nonzero to enable further progress.

To check that denominators are nonzero, `field_simp` will look for facts in the context, and
will try to apply `norm_num` to close numerical goals.

The invocation of `field_simp` removes the lemma `one_div` from the simpset, as this lemma
works against the algorithm explained above. It also removes
`mul_eq_zero : x * y = 0 ↔ x = 0 ∨ y = 0`, as `norm_num` can not work on disjunctions to
close goals of the form `24 ≠ 0`, and replaces it with `mul_ne_zero : x ≠ 0 → y ≠ 0 → x * y ≠ 0`
creating two goals instead of a disjunction.

For example,
```lean
example (a b c d x y : ℂ) (hx : x ≠ 0) (hy : y ≠ 0) :
  a + b / x + c / x^2 + d / x^3 = a + x⁻¹ * (y * b / y + (d / x + c) / x) :=
begin
  field_simp,
  ring
end
```

Moreover, the `field_simp` tactic can also take care of inverses of units in
a general (commutative) monoid/ring and partial division `/ₚ`, see `algebra.group.units`
for the definition. Analogue to the case above, the lemma `one_divp` is removed from the simpset
as this works against the algorithm. If you have objects with a `is_unit x` instance like
`(x : R) (hx : is_unit x)`, you should lift them with
`lift x to Rˣ using id hx, rw is_unit.unit_of_coe_units, clear hx`
before using `field_simp`.

See also the `cancel_denoms` tactic, which tries to do a similar simplification for expressions
that have numerals in denominators.
The tactics are not related: `cancel_denoms` will only handle numeric denominators, and will try to
entirely remove (numeric) division from the expression by multiplying by a factor.
-/
unsafe def field_simp (no_dflt : parse only_flag) (hs : parse simp_arg_list)
    (attr_names : parse with_ident_list) (locat : parse location)
    (cfg : simp_config_ext := { discharger := field_simp.ne_zero }) : tactic Unit :=
  let attr_names := `field_simps :: attr_names
  let hs :=
    simp_arg_type.except `one_div ::
      simp_arg_type.except `mul_eq_zero :: simp_arg_type.except `one_divp :: hs
  propagate_tags (simp_core cfg.toSimpConfig cfg.discharger no_dflt hs attr_names locat >> skip)
#align tactic.interactive.field_simp tactic.interactive.field_simp

add_tactic_doc
  { Name := "field_simp"
    category := DocCategory.tactic
    declNames := [`tactic.interactive.field_simp]
    tags := ["simplification", "arithmetic"] }

end Interactive

end Tactic


import main
import split_cycle

open_locale classical

variables {V X : Type}

def minus_voter (P : Prof V X) (i : V) : Prof {v : V // v ≠ i} X := λ v x y, P v.val x y
-- use strict preference.
def positive_involvement (F : VSCC) (P : Prof V X) : Prop := ∀ (x : X) (i : V), x ∈ F {v : V // v ≠ i} X (minus_voter P i) → (∀ y, y ≠ x → P i x y) → x ∈ F V X P

def negative_involvement (F : VSCC) (P : Prof V X) : Prop := ∀ (x : X) (i : V), x ∉ F {v : V // v ≠ i} X (minus_voter P i) → (∀ y, y ≠ x → P i y x) → x ∉ F V X P

lemma minus_voter_margin_eq [fintype V] (i : V) [fintype {v // v ≠ i}] (P : Prof V X) [profile_asymmetric P] (z x : X) (p : P i x z) : margin (minus_voter P i) z x = margin P z x + 1 :=
begin
  have asymm := _inst_3.asymmetric,
  unfold margin,
  have meq : ((finset.filter (λ (x_1 : {v // v ≠ i}), minus_voter P i x_1 z x) finset.univ).card) = ((finset.filter (λ (x_1 : V), P x_1 z x) finset.univ).card),
    {apply eq.symm,
    have f : (finset.filter (λ (x_1 : V), P x_1 z x) finset.univ) = (finset.map ⟨(λ (s : {v // v ≠ i}), s.val), begin
      obviously,
    end⟩ (finset.filter (λ (x_1 : {v // v ≠ i}), minus_voter P i x_1 z x) finset.univ)),
      {simp, ext1, obviously,
      rw ←ᾰ_1 at p,
      exact (asymm a z x ᾰ) p, }, -- require asymmetry
      rw f,
      simp,},
  rw meq,
  have o : ∀ a b c : ℤ, c = b + 1 → a - b = a - c + 1 := by omega,
  apply o (↑((finset.filter (λ (x_1 : V), P x_1 z x) finset.univ).card)) (↑((finset.filter (λ (x_1 : {v // v ≠ i}), minus_voter P i x_1 x z) finset.univ).card)) (↑((finset.filter (λ (x_1 : V), P x_1 x z) finset.univ).card)),
  norm_cast,
  rw finset.card_eq_succ,
  use i, use (finset.filter (λ (x_1 : V), x_1 ≠ i ∧ P x_1 x z) finset.univ),
  have nmem : i ∉ (finset.filter (λ (x_1 : V), x_1 ≠ i ∧ P x_1 x z) finset.univ),
    {obviously,},

  use nmem,
  split,
  ext1,
  simp only [true_and, finset.mem_univ, ne.def, finset.mem_insert, finset.mem_filter],

  split,
    {intro m,
    cases m,
    rw m,
    exact p,
    exact and.right m,},
    {intro m,
    by_cases a = i,
    use h,
    apply or.inr,
    exact ⟨h, m⟩,},

  refine finset.card_congr _ _ _ _,
    {intro a,
    intro a_spec,
    simp at a_spec,
    exact ⟨a, and.left a_spec⟩,},
    {intro a, intro ha, simp at ha, simp,
    unfold minus_voter, simp, exact and.right ha,},
    {intros a b ha hb, simp at ha, simp at hb,
    simp, },
    {intros b hb, simp at hb, simp,
    use b.val, simp, use b.property, unfold minus_voter at hb,
    exact hb,},
end

lemma minus_voter_margin_le [fintype V] (i : V) [fintype {v // v ≠ i}] (P : Prof V X) [profile_asymmetric P] (a b : X) : margin (minus_voter P i) a b ≤ margin P a b + 1 :=
begin
  by_cases P i b a,
    {have m := minus_voter_margin_eq i P a b h,
    exact le_of_eq m,},

  unfold margin,

  have meq : ((finset.filter (λ (x_1 : {v // v ≠ i}), minus_voter P i x_1 b a) finset.univ).card) = ((finset.filter (λ (x_1 : V), P x_1 b a) finset.univ).card),
    {refine finset.card_congr _ _ _ _,
      {intros a a_spec,
      exact a.val,},
      {intros a_1 ha, simp, simp at ha, unfold minus_voter at ha, exact ha, },
      {intros a_1 b_1 ha hb, simp, obviously,},
      {intros b_1 b_spec, simp at b_spec,
      let h2 := h,
      by_cases b_1 = i,
      exfalso, rw h at b_spec, exact h2 b_spec,
      use ⟨b_1, h⟩,
      split, simp, simp, unfold minus_voter, exact b_spec,},
    },

  rw meq,
  have o : ∀ a b c : ℤ, a ≤ c → a - b ≤ c - b + 1 := by omega,
  apply o (↑((finset.filter (λ (x_1 : {v // v ≠ i}), minus_voter P i x_1 a b) finset.univ).card)) (↑((finset.filter (λ (x_1 : V), P x_1 b a) finset.univ).card)) (↑((finset.filter (λ (x_1 : V), P x_1 a b) finset.univ).card)),

  norm_cast,
  refine finset.card_le_card_of_inj_on _ _ _,
  exact (λ v, v.val),
  intros a_1 a_spec,
  simp, simp at a_spec,
  unfold minus_voter at a_spec,
  exact a_spec,

  intros a1 a1_spec a2 a2_spec,
  obviously,
end

theorem positive_involvement_split_cycle [fintype V] (P : Prof V X) [profile_asymmetric P] : positive_involvement split_cycle P :=
begin
  unfold positive_involvement,
  intros x i w p,
  unfold split_cycle, unfold max_el_VSCC, unfold split_cycle_VCCR, simp,
  unfold split_cycle at w, unfold max_el_VSCC at w, unfold split_cycle_VCCR at w,
  unfold split_cycle_CCR at w, simp at w,
  intro y,
  unfold split_cycle_CCR,
  push_neg,
  use _inst_1,
  intro m,
  specialize w y,

  casesI w with _inst_3 w,

  have ynx := ne_of_margin_pos m,

  have mxy := minus_voter_margin_eq i P y x (p y ynx),

  have mp : margin_pos (minus_voter P i) y x,
    {unfold margin_pos, rw mxy,
    have o : ∀ a : ℤ, a > 0 → 0 < a + 1 := by omega,
    exact o (margin P y x) m,},

  specialize w mp,
  cases w with c w,
  cases w with x_mem w,
  cases w with y_mem w,

  use c, use x_mem, use y_mem,

  refine cycle_of_cycle_imp _ w,
  intros a b mab,
  have o : ∀ a b c d : ℤ, a ≤ b → a = c + 1 → b ≤ d + 1 → c ≤ d := by omega,

  apply (o (margin (minus_voter P i) y x) (margin (minus_voter P i) a b) (margin P y x) (margin P a b) mab mxy ),

  exact minus_voter_margin_le i P a b,
end

lemma minus_voter_margin_eq2 [fintype V] (i : V) [fintype {v // v ≠ i}] (P : Prof V X) [profile_asymmetric P] (z x : X) (p : P i z x) : margin (minus_voter P i) z x + 1 = margin P z x :=
begin
  have asymm := _inst_3.asymmetric,
  unfold margin,
  have meq : ((finset.filter (λ (x_1 : {v // v ≠ i}), minus_voter P i x_1 x z) finset.univ).card) = ((finset.filter (λ (x_1 : V), P x_1 x z) finset.univ).card),
    {apply eq.symm,
    have f : (finset.filter (λ (x_1 : V), P x_1 x z) finset.univ) = (finset.map ⟨(λ (s : {v // v ≠ i}), s.val), begin
      obviously,
    end⟩ (finset.filter (λ (x_1 : {v // v ≠ i}), minus_voter P i x_1 x z) finset.univ)),
      {simp, ext1, obviously,
      rw ←ᾰ_1 at p,
      exact (asymm a x z ᾰ) p, }, -- require asymmetry
      rw f,
      simp,},
  rw meq,
  have o : ∀ a b c : ℤ, c = a + 1 → a - b + 1 = c - b := by omega,
  apply o (↑((finset.filter (λ (x_1 : {v // v ≠ i}), minus_voter P i x_1 z x) finset.univ).card)) (↑((finset.filter (λ (x_1 : V), P x_1 x z) finset.univ).card)) (↑((finset.filter (λ (x_1 : V), P x_1 z x) finset.univ).card)),
  norm_cast,
  rw finset.card_eq_succ,
  use i, use (finset.filter (λ (x_1 : V), x_1 ≠ i ∧ P x_1 z x) finset.univ),
  have nmem : i ∉ (finset.filter (λ (x_1 : V), x_1 ≠ i ∧ P x_1 z x) finset.univ),
    {obviously,},

  use nmem,
  split,
  ext1,
  simp only [true_and, finset.mem_univ, ne.def, finset.mem_insert, finset.mem_filter],

  split,
    {intro m,
    cases m,
    rw m,
    exact p,
    exact and.right m,},
    {intro m,
    by_cases a = i,
    use h,
    apply or.inr,
    exact ⟨h, m⟩,},

  refine finset.card_congr _ _ _ _,
    {intro a,
    intro a_spec,
    simp at a_spec,
    exact ⟨a, and.left a_spec⟩,},
    {intro a, intro ha, simp at ha, simp,
    unfold minus_voter, simp, exact and.right ha,},
    {intros a b ha hb, simp at ha, simp at hb,
    simp, },
    {intros b hb, simp at hb, simp,
    use b.val, simp, use b.property, unfold minus_voter at hb,
    exact hb,},
end

lemma minus_voter_margin_le2 [fintype V] (i : V) [fintype {v // v ≠ i}] (P : Prof V X) [profile_asymmetric P] (a b : X) : margin P a b ≤ margin (minus_voter P i) a b + 1 :=
begin
  by_cases P i a b,
    {have m := minus_voter_margin_eq2 i P a b h,
    exact le_of_eq m.symm,},

  unfold margin,

  have meq : ((finset.filter (λ (x_1 : {v // v ≠ i}), minus_voter P i x_1 a b) finset.univ).card) = ((finset.filter (λ (x_1 : V), P x_1 a b) finset.univ).card),
    {refine finset.card_congr _ _ _ _,
      {intros a a_spec,
      exact a.val,},
      {intros a_1 ha, simp, simp at ha, unfold minus_voter at ha, exact ha, },
      {intros a_1 b_1 ha hb, simp, obviously,},
      {intros b_1 b_spec, simp at b_spec,
      let h2 := h,
      by_cases b_1 = i,
      exfalso, rw h at b_spec, exact h2 b_spec,
      use ⟨b_1, h⟩,
      split, simp, simp, unfold minus_voter, exact b_spec,},
    },

  rw meq,
  have o : ∀ a b c : ℤ, c ≤ b → a - b ≤ a - c + 1 := by omega,
  apply o (↑((finset.filter (λ (x_1 : V), P x_1 a b) finset.univ).card)) (↑((finset.filter (λ (x_1 : V), P x_1 b a) finset.univ).card)) (↑((finset.filter (λ (x_1 : {v // v ≠ i}), minus_voter P i x_1 b a) finset.univ).card)),

  norm_cast,
  refine finset.card_le_card_of_inj_on _ _ _,
  exact (λ v, v.val),
  intros a_1 a_spec,
  simp, simp at a_spec,
  unfold minus_voter at a_spec,
  exact a_spec,

  intros a1 a1_spec a2 a2_spec,
  obviously,
end

theorem negative_involvement_split_cycle [fintype V] (P : Prof V X) [profile_asymmetric P] : negative_involvement split_cycle P :=
begin
  intros x i w p,
  unfold split_cycle, unfold max_el_VSCC, unfold split_cycle_VCCR, simp,
  unfold split_cycle at w, unfold max_el_VSCC at w, unfold split_cycle_VCCR at w,
  unfold split_cycle_CCR at w, simp at w,
  cases w with y w,
  use y,
  introI _inst_3,
  specialize w (subtype.fintype (λ v, v ≠ i)),
  cases w with m w,

  have ynx := ne_of_margin_pos m,
  have mxy := minus_voter_margin_eq2 i P y x (p y ynx),

  have o : ∀ a b : ℤ, 0 < a → a + 1 = b → 0 < b := by omega,
  use o (margin (minus_voter P i) y x) (margin P y x) m mxy,
  push_neg,
  intros l x_mem y_mem,
  specialize w l, specialize w x_mem, specialize w y_mem,
  contrapose w,
  push_neg,
  push_neg at w,

  refine cycle_of_cycle_imp _ w,
  intros a b mab,

  have o : ∀ a b c d : ℤ, a ≤ b → c + 1 = a → b ≤ d + 1 → c ≤ d := by omega,

  apply (o (margin P y x) (margin P a b) (margin (minus_voter P i) y x) (margin (minus_voter P i) a b) mab mxy ),

  exact minus_voter_margin_le2 i P a b,
end


import ..bin_tree
import ..nonempty_list

open util.data.nonempty_list
open util.data.bin_tree'
open util.data.bin_tree'.bin_tree'

universes u v

variable {α : Type u}

-- https://ncatlab.org/nlab/show/Mac+Lane%27s+proof+of+the+coherence+theorem+for+monoidal+categories

-- TODO(tim): do we really need two definitions of the congruence closure or can we just delete this one?
inductive cong_clos' (R : bin_tree' α → bin_tree' α → Type u) : bin_tree' α → bin_tree' α → Type u
| lift : Π s t, R s t → cong_clos' s t
| refl : Π t, cong_clos' t t
| trans : Π r s t, cong_clos' r s → cong_clos' s t → cong_clos' r t
| cong : Π l₁ r₁ l₂ r₂, cong_clos' l₁ l₂ → cong_clos' r₁ r₂ → cong_clos' (branch l₁ r₁) (branch l₂ r₂)

namespace cong_clos'

variable {R : bin_tree' α → bin_tree' α → Type u}

def sym (R_sym : Π s t, R s t → R t s)
    : Π {s t}, cong_clos' R s t → cong_clos' R t s
| ._ ._ (lift _ _ p)       := lift _ _ (R_sym _ _ p)
| ._ ._ (refl ._ t)        := refl R t
| ._ ._ (trans _ _ _ p q)  := trans _ _ _ (sym q) (sym p)
| ._ ._ (cong _ _ _ _ l r) := cong _ _ _ _ (sym l) (sym r)

def transport {S : bin_tree' α → bin_tree' α → Type u} (f : Π s t, R s t → S s t)
    : Π {s t}, cong_clos' R s t → cong_clos' S s t
| ._ ._ (lift _ _ p)       := lift _ _ (f _ _ p)
| ._ ._ (refl ._ t)        := refl S t
| ._ ._ (trans _ _ _ p q)  := trans _ _ _ (transport p) (transport q)
| ._ ._ (cong _ _ _ _ l r) := cong _ _ _ _ (transport l) (transport r)

lemma respects_to_list (R_to_list : Π s t, R s t → s.to_list = t.to_list)
    : Π {s t}, cong_clos' R s t → s.to_list = t.to_list
| ._ ._ (lift _ _ p)           := R_to_list _ _ p
| ._ ._ (refl ._ _)            := eq.refl _
| ._ ._ (trans _ _ _ p q)      := eq.trans (respects_to_list p) (respects_to_list q)
| ._ ._ (cong l₁ r₁ l₂ r₂ l r) :=
    begin
      unfold bin_tree'.to_list,
      rewrite (respects_to_list l),
      rewrite (respects_to_list r)
    end

end cong_clos'

inductive cong_clos_step (R : bin_tree' α → bin_tree' α → Type u) : bin_tree' α → bin_tree' α → Type u
| lift  : Π s t, R s t → cong_clos_step s t
| left  : Π l₁ l₂ r, cong_clos_step l₁ l₂ → cong_clos_step (branch l₁ r) (branch l₂ r)
| right : Π l r₁ r₂, cong_clos_step r₁ r₂ → cong_clos_step (branch l r₁) (branch l r₂)

namespace cong_clos_step

variable {R : bin_tree' α → bin_tree' α → Type u}

-- the equation compiler somehow can't handle the next definitions ~> turn it off
-- TODO(tim): report bug
set_option eqn_compiler.lemmas false

def sym (R_sym : Π s t, R s t → R t s)
    : Π {s t}, cong_clos_step R s t → cong_clos_step R t s
| ._ ._ (lift _ _ p)    := lift _ _ (R_sym _ _ p)
| ._ ._ (left _ _ _ l)  := left _ _ _ (sym l)
| ._ ._ (right _ _ _ r) := right _ _ _ (sym r)

def transport {S : bin_tree' α → bin_tree' α → Type u} (f : Π s t, R s t → S s t)
    : Π {s t}, cong_clos_step R s t → cong_clos_step S s t
| ._ ._ (lift _ _ p)    := lift _ _ (f _ _ p)
| ._ ._ (left _ _ _ l)  := left _ _ _ (transport l)
| ._ ._ (right _ _ _ r) := right _ _ _ (transport r)

lemma respects_to_list (R_to_list : Π s t, R s t → s.to_list = t.to_list)
    : Π {s t}, cong_clos_step R s t → s.to_list = t.to_list
| ._ ._ (lift _ _ p)    := R_to_list _ _ p
| ._ ._ (left _ _ _ l)  := by unfold bin_tree'.to_list; rewrite (respects_to_list l)
| ._ ._ (right _ _ _ r) := by unfold bin_tree'.to_list; rewrite (respects_to_list r)

lemma respects_lopsided
    (R_to_list : Π s t, R s t → s.to_list = t.to_list)
    {s t} (p : cong_clos_step R s t)
    : s.lopsided = t.lopsided
  := by unfold lopsided; rewrite respects_to_list R_to_list p

set_option eqn_compiler.lemmas true

end cong_clos_step

-- smallest reflexive, transitive, congruent (but not necessarily symmetric) relation that includes R
inductive cong_clos (R : bin_tree' α → bin_tree' α → Type u) : bin_tree' α → bin_tree' α → Type u
| refl : Π t, cong_clos t t
| step : Π r s t, cong_clos_step R r s → cong_clos s t → cong_clos r t

namespace cong_clos

variable {R : bin_tree' α → bin_tree' α → Type u}

open cong_clos_step

def lift {s t : bin_tree' α} (p : R s t) : cong_clos R s t :=
  step _ _ _ (cong_clos_step.lift _ _ p) (refl R _)

def trans : Π {r s t : bin_tree' α}, cong_clos R r s → cong_clos R s t → cong_clos R r t
| ._ ._ _ (refl ._ t)       qs := qs
| ._ ._ _ (step _ _ _ p ps) qs := step _ _ _ p (trans ps qs)

lemma trans_refl_right : Π {s t : bin_tree' α} (p : cong_clos R s t), trans p (refl R t) = p
| ._ ._ (refl ._ t)       := by reflexivity
| ._ ._ (step _ _ _ p ps) := by unfold trans; rewrite (trans_refl_right ps)

def inject_left (r : bin_tree' α) : Π {l₁ l₂ : bin_tree' α}, cong_clos R l₁ l₂ → cong_clos R (branch l₁ r) (branch l₂ r)
| ._ ._ (refl ._ t)       := refl R _
| ._ ._ (step _ _ _ p ps) := step _ _ _ (left _ _ _ p) (inject_left ps)

def inject_right (l : bin_tree' α) : Π {r₁ r₂ : bin_tree' α}, cong_clos R r₁ r₂ → cong_clos R (branch l r₁) (branch l r₂)
| ._ ._ (refl ._ _)       := refl R _
| ._ ._ (step _ _ _ p ps) := step _ _ _ (right _ _ _ p) (inject_right ps)

def cong {l₁ l₂ r₁ r₂ : bin_tree' α} (l : cong_clos R l₁ l₂) (r : cong_clos R r₁ r₂) : cong_clos R (branch l₁ r₁) (branch l₂ r₂) :=
  trans (inject_left _ l) (inject_right _ r)

def convert : Π (s t : bin_tree' α), cong_clos' R s t → cong_clos R s t
| ._ ._ (cong_clos'.refl ._ _)        := refl R _
| ._ ._ (cong_clos'.lift _ _ p)       := lift p
| ._ ._ (cong_clos'.trans _ _ _ p q)  := trans (convert _ _ p) (convert _ _ q)
| ._ ._ (cong_clos'.cong _ _ _ _ l r) := cong (convert _ _ l) (convert _ _ r)

def sym_helper (R_sym : Π s t, R s t → R t s)
    : Π {s t u}, cong_clos R s t → cong_clos R s u → cong_clos R t u
| ._ ._ _ (refl ._ t)       qs := qs
| ._ ._ _ (step _ _ _ p ps) qs := sym_helper ps (step _ _ _ (cong_clos_step.sym R_sym p) qs)

def sym (R_sym : Π s t, R s t → R t s) {s t} (ps : cong_clos R s t) : cong_clos R t s :=
  sym_helper R_sym ps (refl R _)

def transport {S : bin_tree' α → bin_tree' α → Type u} (f : Π s t, R s t → S s t)
    : Π {s t}, cong_clos R s t → cong_clos S s t
| ._ ._ (refl ._ t)       := refl S t
| ._ ._ (step _ _ _ p ps) := step _ _ _ (cong_clos_step.transport f p) (transport ps)

lemma respects_to_list (R_to_list : Π s t, R s t → s.to_list = t.to_list)
    : Π {s t}, cong_clos R s t → s.to_list = t.to_list
| ._ ._ (refl ._ t)       := by reflexivity
| ._ ._ (step r s t p ps) :=
  begin
    transitivity,
      exact (cong_clos_step.respects_to_list R_to_list p),
      exact (respects_to_list ps)
  end

lemma respects_lopsided
    (R_to_list : Π s t, R s t → s.to_list = t.to_list)
    {s t} (p : cong_clos R s t)
    : s.lopsided = t.lopsided
  := by unfold lopsided; rewrite respects_to_list R_to_list p

end cong_clos


import tactic
import compile_fast

class NatLt (m n : ℕ) := (proof : m < n)
instance NatLt.one (n : ℕ) : NatLt 0 (n+1) := ⟨nat.succ_pos _⟩
instance NatLt.trans (m n : ℕ) [h : NatLt m n] : NatLt (m+1) (n+1) :=
⟨nat.succ_lt_succ h.proof⟩

-- instance i1 : NatLt 3 2 := infer_instance -- no
instance i2 : NatLt 1 3 := infer_instance

universes u v

class Atomic (α : Type u) .

class Rectangle (Gen : ℕ → Type* → Type*) :=
  (map {α β : Type*} (i : ℕ) : (α → β) → Gen i α → Gen i β)
  (repl {α : Type*}  (i : ℕ) : α → Gen i α)

open Rectangle

class Merge (α β : Type*) (γ : out_param Type*) :=
  (merge1 : α → γ)
  (merge2 : β → γ)

open Merge

class NestedMap (α β γ δ : Type*) :=
  (map : (β → γ) → α → δ)

section Instances
variables
{Gen : ℕ → Type u → Type v}
{View : ℕ → Type u → Type v}
[Rectangle Gen]
variables {α β γ : Type u}

instance Gen.Merge.one {ρ} [Atomic ρ] : Merge ρ ρ ρ := ⟨id, id⟩
instance Gen.Merge.succ {i : ℕ} [Merge α β γ] : Merge (Gen i α) (Gen i β) (Gen i γ) :=
⟨map i (merge1 β), map i (merge2 α)⟩
instance Gen.Merge.scalar_r {i : ℕ} {ρ} [Atomic ρ] [Merge α ρ α] : Merge (Gen i α) ρ (Gen i α) :=
⟨id, repl i ∘ merge2 α⟩
instance Gen.Merge.lt {i j : ℕ} [NatLt i j] [Merge α (Gen j β) γ]
: Merge (Gen i α) (Gen j β) (Gen i γ) :=
⟨map i (merge1 (Gen j β)), repl i ∘ merge2 α⟩
instance Gen.Merge.scalar_l {j : ℕ} {ρ} [Atomic ρ] [Merge ρ β β] : Merge ρ (Gen j β) (Gen j β) :=
⟨repl j ∘ merge1 β, id⟩
instance Gen.merge.gt {i j : ℕ} [NatLt j i] [Merge (Gen i α) β γ] : Merge (Gen i α) (Gen j β) (Gen j γ) :=
⟨repl j ∘ merge1 β, map j (merge2 (Gen i α))⟩

def merge {α β γ} [Merge α β γ] : α → β → (γ × γ) := λ a b, (merge1 β a, merge2 α b)

instance Gen.NestedMap.Eq {i : ℕ} {α β} : NestedMap (Gen i α) α β (Gen i β) := ⟨Rectangle.map i⟩
instance Gen.NestedMap.Lt {i j : ℕ} {α β γ δ} [NatLt i j] [NestedMap α β γ δ] : NestedMap (Gen i α) β γ (Gen i δ) :=
⟨λ f, Rectangle.map i (NestedMap.map f)⟩

end Instances

def Fun (i : ℕ) (α : Type*) := ℕ → α
def Fun.to_fun {i α} : Fun i α → ℕ → α := id
def map {α β : Type} (m : ℕ) : (α → β) → Fun m α → Fun m β := λ f v, f ∘ v
def repl {α : Type} (m : ℕ) : α → Fun m α := λ v _, v

instance : Rectangle Fun :=
  { map := λ _ _, map, repl := λ _, repl }

instance nat.Atomic : Atomic ℕ := ⟨⟩

example : Merge ℕ ℕ ℕ := infer_instance
example {i : ℕ} : Merge (Fun i ℕ) ℕ (Fun i ℕ) := infer_instance
example {i : ℕ} : Merge (Fun i ℕ) (Fun i ℕ) (Fun i ℕ) := infer_instance
example {i : ℕ} : Merge (Fun i ℕ) ℕ (Fun i ℕ) := infer_instance
example {i j : ℕ} [NatLt i j] : Merge ℕ (Fun j ℕ) (Fun j ℕ) := infer_instance
example {i j : ℕ} [NatLt i j] : Merge (Fun i ℕ) (Fun j ℕ) (Fun i (Fun j ℕ)) := infer_instance
example {i j k : ℕ} [NatLt i j] : Merge (Fun i (Fun j ℕ)) (Fun j (Fun k ℕ)) (Fun i (Fun j (Fun k ℕ))) := infer_instance

@[reducible] def i := 1
@[reducible] def j := 2
@[reducible] def k := 3
@[reducible] def l := 4
@[reducible] def V := ℕ

instance hmul_of_Merge {α β γ : Type}  [has_mul γ] [Merge α β γ] : has_hmul α β γ :=
⟨λ a b, merge1 β a * merge2 α b⟩

-- demo with functions:
instance Fun.mul {i : ℕ} {α : Type} [has_mul α] : has_mul (Fun i α) :=
⟨λ a b i, a.to_fun i * b.to_fun i⟩
example {i : ℕ} : has_hmul (Fun i ℕ) ℕ (Fun i ℕ) := infer_instance

def v1 : Fun i (Fun j V) := λ i j, i+j
def v2 : Fun j (Fun k V) := λ i j, i*j
def v3 : (Fun l V) := λ i, i

--set_option trace.class_instances true
--set_option class.instance_max_depth 20
--set_option pp.all true

section Streams

def Ind (i : ℕ) := E
inductive Stream (n : ℕ) (α : Type)
| view (v : View (Ind n) α) : Stream
| gen  (g : G (Ind n) α)    : Stream

instance {n} : functor (Stream n) :=
{ map := λ _ _ f g, match g with
  | Stream.view v := Stream.view { v with value := f ∘ v.value }
  | Stream.gen  g := Stream.gen  { g with value := f g.value }
  end }

instance : Rectangle Stream :=
{ map  := λ _ _ _, functor.map,
  repl := λ _ m v, Stream.view ⟨λ _, v⟩ }
instance : Atomic E := ⟨⟩

def foo1 : Merge (Stream i E) (Stream j E) (Stream i (Stream j E)) := infer_instance

variables {ι α β γ : Type}
(n : ℕ)

instance G.Ind.hmul {i : ℕ} [has_hmul α β γ] : has_hmul (G (Ind i) α) (G (Ind i) β) (G (Ind i) γ) := ⟨G.mul⟩

instance [inhabited α] : inhabited (Stream n α) := ⟨Stream.view ⟨λ _, default⟩⟩
instance [inhabited ι] [inhabited α] : inhabited (G ι α) := ⟨G.empty⟩

-- instance Stream.has_mul {α} {i} [has_mul α] : has_mul (StreamGen' i α) := ⟨StreamGen.mul⟩
instance Stream.has_mul {γ} {i} [inhabited γ] [has_mul γ] : has_mul (Stream i γ) := ⟨λ a b,
match a, b with
| Stream.view a, Stream.view b := arbitrary _ -- Stream.view $ a⋆b
| Stream.gen a, Stream.view b := Stream.gen $ a⋆b
| Stream.view a, Stream.gen b := Stream.gen $ a⋆b
| Stream.gen a, Stream.gen b := Stream.gen $ a⋆b
end⟩

variables (a : Stream i E) (b : Stream j E)

example : has_mul (Stream i (Stream j E)) := infer_instance
example : Stream i (Stream j E) := a ⋆ b

instance : has_coe (G E E) (Stream n E) := ⟨Stream.gen⟩
instance coe_stream [has_coe α β] : has_coe (G E α) (Stream n β) := ⟨Stream.gen ∘ functor.map has_coe.coe⟩

class of_stream (α β : Type) := (coe : α → β)
instance base.of_stream : of_stream α α := ⟨id⟩
def Stream.to_g {n} [inhabited α] : (Stream n α) → (G E α) := λ s, match s with
| Stream.view _ := arbitrary _
| Stream.gen a := a
end

instance [inhabited β] [of_stream α β] : of_stream (Stream n α) (G E β) := ⟨λ s, match s with
| Stream.view _ := arbitrary _
| Stream.gen a := of_stream.coe <$> a
end⟩

def Stream.of [of_stream α β] : α → β := of_stream.coe

infixr ` →ₛ `:24 := Stream

--def Stream.to_stream {n} [of_stream α β] : Stream n α → G E β := of_stream.coe

-- instance s_level.eval [of_stream γ β] [Ev α (G E β)] : Ev α (Stream i γ) :=
-- ⟨ λ l r, exec l (of_stream.coe r : G E β) ⟩
-- instance stream.level.eval' (n : ℕ) [Ev α (G E β)] : Ev α (Stream n β) :=
-- ⟨ λ l r, exec l $ r.to_g _ ⟩

class Sum (n : ℕ) (α : Type) (β : out_param Type) := (sum : α → β)
instance sum_eq (n : ℕ) [inhabited α] : Sum n (Stream n α) (G unit α) := ⟨G.contract ∘ Stream.to_g⟩
instance sum_lt (m n : ℕ) [NatLt n m] [Sum m α β] : Sum m (Stream n α) (Stream n β) := ⟨functor.map $ Sum.sum m⟩

abbreviation R := E

prefix ` Σ ` := Sum.sum

def mmul1'  := Σ i $ Σ j $ Σ k $ (A : i →ₛ j →ₛ E) ⋆ (B : j →ₛ k →ₛ E)
def mmul2'  := Σ i $ Σ j $ Σ k $ (A : i →ₛ k →ₛ E) ⋆ (B : j →ₛ k →ₛ E)
def ttv'    := Σ i $ Σ j $ Σ k $ (C : i →ₛ j →ₛ k →ₛ R) ⋆ (v : k →ₛ R)
def ttm'    := Σ i $ Σ j $ Σ k $ Σ l $ (C : i →ₛ j →ₛ l →ₛ R) ⋆ (A : k →ₛ l →ₛ R)
def mttkrp' := Σ i $ Σ j $ Σ k $ Σ l $ (C : i →ₛ j →ₛ k →ₛ R) ⋆ (A : j →ₛ l →ₛ R) ⋆ (B : k →ₛ l →ₛ R)
def inner3' := Σ i $ Σ j $ Σ k $ (C : i →ₛ j →ₛ k →ₛ R) ⋆ (D : i →ₛ j →ₛ k →ₛ R)

example : Sum i (Stream i E) (G unit E) := infer_instance
example : Sum j (Stream i (Stream j E)) (Stream i (G unit E)) := infer_instance

def inner : Stream i (Stream j (G unit E)) :=
  Sum.sum k $ (A : i →ₛ k →ₛ E) ⋆ (B : j →ₛ k →ₛ E)

def eg_mmul1 :=
  [me $ exec out mmul1'] ++
  [ta $ Prog.inline_code "taco_ijk_sum();"]

def eg_mmul2 :=
  [me $ exec out mmul2'] ++
  [ta $ Prog.inline_code "mmul2_compute();"]

def eg_ttv :=
  [me $ exec out $ G.contract $ View.to_gen "foo" 30 $ constView E $ ttv'] ++
  [ta $ exec out $ G.contract $ View.to_gen "foo" 30 $ constView E $ E.inline_code "ttv_compute();"]

def eg_ttm :=
  [me $ exec out ttm'] ++
  [ta $ Prog.inline_code "ttm_compute();"]

def eg_mttkrp :=
  [me $ exec out mttkrp'] ++
  [ta $ Prog.inline_code "mttkrp_compute();"]

def eg_inner3 :=
  [me $ exec out inner3'] ++
  [ta $ Prog.inline_code "inner3_compute();"]

def eg_inner3' :=
  [me $ exec out $ G.contract $ View.to_gen "foo" 200 $ constView E $ inner3'] ++
  [ta $ exec out $ G.contract $ View.to_gen "foo" 200 $ constView E $ E.inline_code "inner3_compute();"]

def compile_with_load (v : list Prog) := compile $ load ++ v

def tests :=
  /- 1 -/ eg_mmul1 ++
  /- 2 -/ eg_mmul2 ++
  /- 3 -/ eg_ttv ++
  /- 4 -/ eg_ttm ++
  /- 5 -/ eg_mttkrp ++
  /- 6 -/ eg_inner3'

def run_comparisons := compile_with_load tests

-- main comparison script:
-- #eval run_comparisons

end Streams


/-
Copyright (c) 2021 Adam Topaz. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Adam Topaz
-/
import category_theory.sites.compatible_plus
import category_theory.sites.sheafification

/-!

In this file, we prove that sheafification is compatible with functors which
preserve the correct limits and colimits.

-/

namespace category_theory.grothendieck_topology

open category_theory
open category_theory.limits
open opposite

universes w₁ w₂ v u
variables {C : Type u} [category.{v} C] (J : grothendieck_topology C)
variables {D : Type w₁} [category.{max v u} D]
variables {E : Type w₂} [category.{max v u} E]
variables (F : D ⥤ E)

noncomputable theory

variables [∀ (α β : Type (max v u)) (fst snd : β → α),
  has_limits_of_shape (walking_multicospan fst snd) D]
variables [∀ (α β : Type (max v u)) (fst snd : β → α),
  has_limits_of_shape (walking_multicospan fst snd) E]
variables [∀ (X : C), has_colimits_of_shape (J.cover X)ᵒᵖ D]
variables [∀ (X : C), has_colimits_of_shape (J.cover X)ᵒᵖ E]
variables [∀ (X : C), preserves_colimits_of_shape (J.cover X)ᵒᵖ F]
variables [∀ (X : C) (W : J.cover X) (P : Cᵒᵖ ⥤ D), preserves_limit (W.index P).multicospan F]

variables (P : Cᵒᵖ ⥤ D)

/-- The isomorphism between the sheafification of `P` composed with `F` and
the sheafification of `P ⋙ F`.

Use the lemmas `whisker_right_to_sheafify_sheafify_comp_iso_hom`,
`to_sheafify_comp_sheafify_comp_iso_inv` and `sheafify_comp_iso_inv_eq_sheafify_lift` to reduce
the components of this isomorphisms to a state that can be handled using the universal property
of sheafification. -/
def sheafify_comp_iso : J.sheafify P ⋙ F ≅ J.sheafify (P ⋙ F) :=
J.plus_comp_iso _ _ ≪≫ (J.plus_functor _).map_iso (J.plus_comp_iso _ _)

/-- The isomorphism between the sheafification of `P` composed with `F` and
the sheafification of `P ⋙ F`, functorially in `F`. -/
def sheafification_whisker_left_iso (P : Cᵒᵖ ⥤ D)
  [∀ (F : D ⥤ E) (X : C), preserves_colimits_of_shape (J.cover X)ᵒᵖ F]
  [∀ (F : D ⥤ E) (X : C) (W : J.cover X) (P : Cᵒᵖ ⥤ D),
    preserves_limit (W.index P).multicospan F] :
  (whiskering_left _ _ E).obj (J.sheafify P) ≅
  (whiskering_left _ _ _).obj P ⋙ J.sheafification E :=
begin
  refine J.plus_functor_whisker_left_iso _ ≪≫ _ ≪≫ functor.associator _ _ _,
  refine iso_whisker_right _ _,
  refine J.plus_functor_whisker_left_iso _,
end

@[simp]
lemma sheafification_whisker_left_iso_hom_app (P : Cᵒᵖ ⥤ D) (F : D ⥤ E)
  [∀ (F : D ⥤ E) (X : C), preserves_colimits_of_shape (J.cover X)ᵒᵖ F]
  [∀ (F : D ⥤ E) (X : C) (W : J.cover X) (P : Cᵒᵖ ⥤ D),
    preserves_limit (W.index P).multicospan F] :
  (sheafification_whisker_left_iso J P).hom.app F = (J.sheafify_comp_iso F P).hom :=
begin
  dsimp [sheafification_whisker_left_iso, sheafify_comp_iso],
  rw category.comp_id,
end

@[simp]
lemma sheafification_whisker_left_iso_inv_app (P : Cᵒᵖ ⥤ D) (F : D ⥤ E)
  [∀ (F : D ⥤ E) (X : C), preserves_colimits_of_shape (J.cover X)ᵒᵖ F]
  [∀ (F : D ⥤ E) (X : C) (W : J.cover X) (P : Cᵒᵖ ⥤ D),
    preserves_limit (W.index P).multicospan F] :
  (sheafification_whisker_left_iso J P).inv.app F = (J.sheafify_comp_iso F P).inv :=
begin
  dsimp [sheafification_whisker_left_iso, sheafify_comp_iso],
  erw category.id_comp,
end

/-- The isomorphism between the sheafification of `P` composed with `F` and
the sheafification of `P ⋙ F`, functorially in `P`. -/
def sheafification_whisker_right_iso :
  J.sheafification D ⋙ (whiskering_right _ _ _).obj F ≅
  (whiskering_right _ _ _).obj F ⋙ J.sheafification E :=
begin
  refine functor.associator _ _ _ ≪≫ _,
  refine iso_whisker_left (J.plus_functor D) (J.plus_functor_whisker_right_iso _) ≪≫ _,
  refine _ ≪≫ functor.associator _ _ _,
  refine (functor.associator _ _ _).symm ≪≫ _,
  exact iso_whisker_right (J.plus_functor_whisker_right_iso _) (J.plus_functor E),
end

@[simp]
lemma sheafification_whisker_right_iso_hom_app :
  (J.sheafification_whisker_right_iso F).hom.app P = (J.sheafify_comp_iso F P).hom :=
begin
  dsimp [sheafification_whisker_right_iso, sheafify_comp_iso],
  simp only [category.id_comp, category.comp_id],
  erw category.id_comp,
end

@[simp]
lemma sheafification_whisker_right_iso_inv_app :
  (J.sheafification_whisker_right_iso F).inv.app P = (J.sheafify_comp_iso F P).inv :=
begin
  dsimp [sheafification_whisker_right_iso, sheafify_comp_iso],
  simp only [category.id_comp, category.comp_id],
  erw category.id_comp,
end

@[simp, reassoc]
lemma whisker_right_to_sheafify_sheafify_comp_iso_hom :
  whisker_right (J.to_sheafify _) _ ≫ (J.sheafify_comp_iso F P).hom = J.to_sheafify _ :=
begin
  dsimp [sheafify_comp_iso],
  erw [whisker_right_comp, category.assoc],
  slice_lhs 2 3 { rw plus_comp_iso_whisker_right },
  rw [category.assoc, ← J.plus_map_comp,
    whisker_right_to_plus_comp_plus_comp_iso_hom, ← category.assoc,
    whisker_right_to_plus_comp_plus_comp_iso_hom],
  refl,
end

@[simp, reassoc]
lemma to_sheafify_comp_sheafify_comp_iso_inv :
  J.to_sheafify _ ≫ (J.sheafify_comp_iso F P).inv = whisker_right (J.to_sheafify _) _ :=
by { rw iso.comp_inv_eq, simp }

section

-- We will sheafify `D`-valued presheaves in this section.
variables
  [concrete_category.{max v u} D]
  [preserves_limits (forget D)]
  [∀ (X : C), preserves_colimits_of_shape (J.cover X)ᵒᵖ (forget D)]
  [reflects_isomorphisms (forget D)]

@[simp]
lemma sheafify_comp_iso_inv_eq_sheafify_lift : (J.sheafify_comp_iso F P).inv =
  J.sheafify_lift (whisker_right (J.to_sheafify _) _) ((J.sheafify_is_sheaf _).comp _) :=
begin
  apply J.sheafify_lift_unique,
  rw iso.comp_inv_eq,
  simp,
end

end

end category_theory.grothendieck_topology


import free_pfpng.setup

.

noncomputable theory

open_locale classical

open category_theory
open opposite

universe u

lemma Profinite.mono_free'_to_condensed_free_pfpng_aux
  (S B : Profinite.{u}) (b : B) (T : discrete_quotient S)
  (t : S.to_Condensed.val.obj (op B) →₀ ℤ) :
let e : S.to_Condensed.val.obj (op B) →
    S.condensed_free_pfpng.val.obj (op B) :=
    λ f, (S.to_condensed_free_pfpng.val.app (op B) f),
    ι : S.to_Condensed.val.obj (op B) → S :=
      λ f, (ulift.down f).1 b in
    ((limits.limit.π (S.fintype_diagram ⋙ forget Fintype ⋙
      AddCommGroup.free' ⋙ Ab.ulift) T)
      (S.condensed_free_pfpng_specialize B b (free'_lift e t))).down
  = t.map_domain (T.proj ∘ ι) :=
begin
  dsimp,
  revert t,
  rw ← function.funext_iff,
  dsimp,
  change ulift.down ∘ _ = _,
  apply finsupp.fun_ext,
  { intros, simp only [function.comp_app, map_add, ulift.add_down,
      eq_self_iff_true, forall_const] },
  { intros, simp only [function.comp_app, map_zero, ulift.zero_down,
      finsupp.map_domain_add] },
  { intros,
    simp only [function.comp_app, finsupp.map_domain_single,
      free'_lift_eq_finsupp_lift],
    dsimp [Profinite.condensed_free_pfpng_specialize],
    simp only [← comp_apply],
    erw limits.limit.lift_π,
    simp only [finsupp.sum_single_index, zero_smul, one_zsmul],
    ext i,
    dsimp [Profinite.condensed_free_pfpng_specialize_cone,
      finsupp.single, Profinite.free_pfpng_π, Profinite.to_free_pfpng],
    erw ProFiltPseuNormGrp₁.limit_π_coe_eq,
    simp only [← comp_apply, category.assoc],
    dsimp [Profinite.free_pfpng_level_iso,
      limits.is_limit.cone_point_unique_up_to_iso],
    simp only [← comp_apply, category.assoc],
    erw (limits.is_limit_of_preserves (ProFiltPseuNormGrp₁.level.obj 1)
      (limits.limit.is_limit (S.fintype_diagram ⋙ free_pfpng_functor))).fac,
    erw limits.limit.lift_π,
    refl },
end

lemma Profinite.specialization_eq_zero_of_eq_zero (S B : Profinite.{u}) (b : B)
  (t : S.to_Condensed.val.obj (op B) →₀ ℤ)
  (ht : free'_lift (S.to_condensed_free_pfpng.val.app (op B)) t = 0) :
  t.map_domain (λ f, (ulift.down f).1 b) = 0 :=
begin
  apply free_pfpng.discrete_quotient_separates_points' S,
  intros T,
  apply_fun (λ e, S.condensed_free_pfpng_specialize B b e) at ht,
  rw add_monoid_hom.map_zero at ht,
  apply_fun (λ e, limits.limit.π (S.fintype_diagram ⋙ forget Fintype ⋙
    AddCommGroup.free' ⋙ Ab.ulift) T e) at ht,
  rw add_monoid_hom.map_zero at ht,
  apply_fun ulift.down at ht,
  dsimp [AddCommGroup.free'],
  rw ← finsupp.map_domain_comp,
  have := S.mono_free'_to_condensed_free_pfpng_aux B b T t,
  dsimp at this, erw ← this, exact ht
end

lemma Profinite.adj'_hom_equiv_symm_eq_free'_lift (S B : Profinite.{u}) :
    (((AddCommGroup.adj'.whisker_right Profinite.{u}ᵒᵖ).hom_equiv
      S.to_Condensed.val S.condensed_free_pfpng.val).symm
      S.to_condensed_free_pfpng.val).app (op B) =
    free'_lift (S.to_condensed_free_pfpng.val.app (op B)) :=
begin
  ext u v, dsimp [free'_lift],
  simp only [adjunction.hom_equiv_counit, whiskering_right_obj_map,
    nat_trans.comp_app, whisker_right_app,
    adjunction.whisker_right_counit_app_app],
end

open_locale big_operators
lemma finsupp.map_domain_ne_zero_of_ne_zero_of_inj_on {α β γ : Type*} [add_comm_group β]
  (t : α →₀ β) (ht : t ≠ 0) (f : α → γ)
  (hinj : set.inj_on f t.support) :
  t.map_domain f ≠ 0 :=
begin
  contrapose! ht,
  have : ∀ (e : γ) (he : e ∈ (t.map_domain f).support), ∃ (q : α) (hq : q ∈ t.support), f q = e,
  { intros e he, by_contra c, push_neg at c,
    simp only [finsupp.mem_support_iff, ne.def] at he,
    apply he,
    erw finset.sum_apply',
    apply finset.sum_eq_zero,
    intros a ha,
    dsimp [finsupp.single], rw if_neg, apply c, exact ha },
  choose q hq hh using this,
  let ι : (t.map_domain f).support → t.support :=
    λ e, ⟨q e.1 e.2, hq e.1 e.2⟩,
  have hι : function.surjective ι,
  { rintros ⟨e,he⟩, use f e,
    { simp only [finsupp.mem_support_iff, ne.def],
      rw finsupp.map_domain_apply' _ _ (set.subset.refl _) hinj he,
      simpa using he },
    { ext, dsimp,
      apply hinj, apply hq, apply he, apply hh } },
  have : (t.map_domain f).support = ∅, by simpa using ht,
  suffices : t.support = ∅, by simpa using this,
  by_contra c, change _ ≠ _ at c,
  erw ← finset.nonempty_iff_ne_empty at c,
  obtain ⟨c,hc⟩ := c, obtain ⟨⟨c,hc⟩,ee⟩ := hι ⟨c,hc⟩,
  rw this at hc, simpa using hc,
end

lemma finsupp.lift_map_domain {γ α β : Type*} [add_comm_group β]
  (f : α → β) (ι : γ → α) :
  (finsupp.lift _ ℤ _ f) ∘ finsupp.map_domain ι = finsupp.lift _ ℤ _ (f ∘ ι) :=
begin
  apply finsupp.fun_ext,
  { intros x y,
    dsimp only [function.comp_apply],
    simp only [finsupp.map_domain_add],
    erw ((finsupp.lift β ℤ α) f).to_add_monoid_hom.map_add, refl },
  { intros x y,
    erw ((finsupp.lift β ℤ γ) (f ∘ ι)).to_add_monoid_hom.map_add, refl },
  { intros x, simp },
end

lemma finsupp.lift_map_domain_apply {γ α β : Type*} [add_comm_group β]
  (f : α → β) (ι : γ → α) (e : γ →₀ ℤ) :
  (finsupp.lift _ ℤ _ f).to_add_monoid_hom (e.map_domain ι) =
  finsupp.lift _ ℤ _ (f ∘ ι) e :=
begin
  rw ← finsupp.lift_map_domain, refl,
end

lemma finsupp.card_supp_map_domain_lt {α β γ : Type*} [add_comm_group γ]
  (f : α → β) (t : α →₀ γ) (u v : α)
  (huv : u ≠ v) (hu : u ∈ t.support) (hv : v ∈ t.support)
  (hf : f u = f v) : (t.map_domain f).support.card < t.support.card :=
begin
  classical,
  have key : (finsupp.map_domain f t).support ⊆ _ := finsupp.map_domain_support,
  have : (finsupp.map_domain f t).support.card ≤ (t.support.image f).card :=
    finset.card_le_of_subset key,
  refine lt_of_le_of_lt this _,
  have key' : (t.support.image f).card ≤ t.support.card := finset.card_image_le,
  apply lt_of_le_of_ne key',
  change ¬ _,
  rw finset.card_image_iff,
  dsimp [set.inj_on],
  push_neg, use [u, hu, v, hv, hf],
end

lemma Profinite.mono_free'_to_condensed_free_pfpng_induction_aux (n : ℕ) :
  ∀ (S B : Profinite.{u}) (t : S.to_Condensed.val.obj (op B) →₀ ℤ),
    t.support.card ≤ n →
    (free'_lift (S.to_condensed_free_pfpng.val.app (op B))) t = 0 →
  (∀ (b : ↥B), finsupp.map_domain (λ f : S.to_Condensed.val.obj (op B),
    (ulift.down f).1 b) t = 0) →
  (∃ (α : Type u) [_inst_1 : fintype α] (X : α → Profinite) (π : Π (a : α), X a ⟶ B)
    (surj : ∀ (b : ↥B), ∃ (a : α) (x : ↥(X a)), (π a) x = b),
    ∀ (a : α), finsupp.map_domain (S.to_Condensed.val.map (π a).op) t = 0) :=
begin
  /-
  TODO: This proof is very slow. It would be better to pull out a few
  of the `have` statements into separate lemmas to (hopefully)
  speed this up.
  -/
  induction n,
  case nat.zero
  { intros S B t ht, simp at ht, rw ht, intros h1 h2,
    use [punit, infer_instance, λ _, B, λ _, 𝟙 _],
    split, { intros b, use [punit.star, b], refl },
    { intros _, rw finsupp.map_domain_zero, } },
  case nat.succ : n hn
  { intros S B t ht1 ht2 H,
    by_cases ht1' : t.support.card = n+1, swap,
    { apply hn, exact nat.le_of_lt_succ (nat.lt_of_le_and_ne ht1 ht1'),
      assumption' },
    clear ht1,
    let F := t.support,
    let e : F → (B ⟶ S) := λ f, f.1.1,
    obtain ⟨Q,h1,h2,ee,-⟩ : ∃ (α : Type u) (hα1 : fintype α)
      (hα2 : linear_order α) (ee : α ≃ F), true,
    { refine ⟨ulift (fin (fintype.card F)), infer_instance,
        is_well_order.linear_order well_ordering_rel,
        equiv.ulift.trans (fintype.equiv_fin _).symm, trivial⟩, },
    resetI,
    let E₀ := { a : Q × Q | a.1 < a.2 },
    let X₀ : E₀ → Profinite.{u} := λ i, Profinite.equalizer (e (ee i.1.1)) (e (ee i.1.2)),
    let π₀ : Π (i : E₀), X₀ i ⟶ B := λ i, Profinite.equalizer.ι _ _,

    have surj₀ : ∀ (b : B), ∃ (e₀ : E₀) (x : X₀ e₀), π₀ _ x = b,
    { intro b, specialize H b,
      contrapose! H,
      have key : ∀ (i j : Q) (h : i < j), e (ee i) b ≠ e (ee j) b,
      { intros i j h, specialize H ⟨⟨i,j⟩, h⟩, intro c,
        specialize H, dsimp [X₀] at H, specialize H ⟨b, c⟩,
        apply H, refl },
      apply finsupp.map_domain_ne_zero_of_ne_zero_of_inj_on,
      { intro c, rw c at ht1', simpa using ht1' },
      { intros x hx y hy hxy, dsimp at hxy,
        let i : Q := ee.symm ⟨x,hx⟩,
        let j : Q := ee.symm ⟨y,hy⟩,
        rcases lt_trichotomy i j with (hhh|hhh|hhh),
        { specialize key i j hhh, contrapose hxy, convert key,
          { dsimp [i], rw ee.apply_symm_apply, refl },
          { dsimp [j], rw ee.apply_symm_apply, refl } },
        { apply_fun (λ q, (ee q).1) at hhh, dsimp [i,j] at hhh,
          simp_rw ee.apply_symm_apply at hhh, exact hhh },
        { specialize key j i hhh, contrapose hxy, convert key.symm,
          { dsimp [j], rw ee.apply_symm_apply, refl },
          { dsimp [i], rw ee.apply_symm_apply, refl } } } },

    let f₀ : Π (i : E₀), S.to_Condensed.val.obj (op B) → S.to_Condensed.val.obj (op (X₀ i)) :=
      λ i, S.to_Condensed.val.map (π₀ i).op,

    let t₀ : Π (i : E₀), S.to_Condensed.val.obj (op (X₀ i)) →₀ ℤ :=
      λ i, t.map_domain (f₀ i),

    have card₀ : ∀ (i : E₀), (t₀ i).support.card ≤ n,
    { intros i, suffices : (t₀ i).support.card < n + 1,
        by exact nat.lt_succ_iff.mp this,
      rw ← ht1',
      fapply finsupp.card_supp_map_domain_lt,
      refine (ee i.1.1).1,
      refine (ee i.1.2).1,
      { change ¬ _,
        erw ← subtype.ext_iff,
        apply ee.injective.ne,
        apply ne_of_lt,
        exact i.2 },
      refine (ee i.1.1).2,
      refine (ee i.1.2).2,
      { dsimp [f₀, π₀, Profinite.to_Condensed], ext1, dsimp,
        -- missing Profinite.equalizer.condition
        ext t, exact t.2 } },

    have lift₀ : ∀ (i : E₀), free'_lift (S.to_condensed_free_pfpng.val.app (op (X₀ i))) (t₀ i) = 0,
    { intros i, rw free'_lift_eq_finsupp_lift, dsimp only [t₀, f₀],
      apply_fun (λ q, S.condensed_free_pfpng.val.map (π₀ i).op q) at ht2,
      rw [add_monoid_hom.map_zero, free'_lift_eq_finsupp_lift] at ht2,
      convert ht2,
      rw finsupp.lift_map_domain_apply,
      dsimp [finsupp.lift],
      rw (S.condensed_free_pfpng.val.map (π₀ i).op).map_finsupp_sum,
      refl },

    have map₀ : ∀ (i : E₀) (b : ↥(X₀ i)),
        finsupp.map_domain
          (λ (f : S.to_Condensed.val.obj (op (X₀ i))), f.down.to_fun b) (t₀ i) = 0,
    { intros i b, dsimp [t₀], rw ← finsupp.map_domain_comp,
      exact H (π₀ i b) },

    have key := λ i, hn S (X₀ i) (t₀ i) (card₀ i) (lift₀ i) (map₀ i),

    choose A hA X₁ π₁ surj₁ key using key, resetI,

    let E := Σ (e : E₀), A e,
    let X : E → Profinite.{u} := λ i, X₁ i.1 i.2,
    let π : Π (e : E), X e ⟶ B := λ e, π₁ e.1 e.2 ≫ π₀ e.1,

    use [E, infer_instance, X, π], split,

    { intros b,
      obtain ⟨e₀,x,hx⟩ := surj₀ b,
      obtain ⟨i,q,hq⟩ := surj₁ e₀ x,
      use [⟨e₀,i⟩,q], dsimp [π], rw [hq, hx] },
    { intros a,
      dsimp [π], rw functor.map_comp,
      erw finsupp.map_domain_comp,
      apply key } },
end

instance Profinite.mono_free'_to_condensed_free_pfpng
  (S : Profinite.{u}) : mono S.free'_to_condensed_free_pfpng :=
begin
  apply presheaf_to_Condensed_Ab_map_mono_of_exists, intros B t ht,
  let e : S.to_Condensed.val.obj (op B) →
    S.condensed_free_pfpng.val.obj (op B) :=
    λ f, (S.to_condensed_free_pfpng.val.app (op B) f),
  dsimp at t ht,
  replace ht : free'_lift e t = 0, by rwa ← S.adj'_hom_equiv_symm_eq_free'_lift,
  let ι : Π b : B, S.to_Condensed.val.obj (op B) → S :=
    λ b f, (ulift.down f).1 b,
  have aux : ∀ b : B, t.map_domain (ι b) = 0 :=
    λ b, S.specialization_eq_zero_of_eq_zero B b t ht,
  dsimp,
  apply Profinite.mono_free'_to_condensed_free_pfpng_induction_aux,
  refl,
  assumption',
end


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

! This file was ported from Lean 3 source module category_theory.limits.constructions.finite_products_of_binary_products
! leanprover-community/mathlib commit 69c6a5a12d8a2b159f20933e60115a4f2de62b58
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.CategoryTheory.Limits.Preserves.Shapes.BinaryProducts
import Mathbin.CategoryTheory.Limits.Preserves.Shapes.Products
import Mathbin.CategoryTheory.Limits.Shapes.BinaryProducts
import Mathbin.CategoryTheory.Limits.Shapes.FiniteProducts
import Mathbin.Logic.Equiv.Fin

/-!
# Constructing finite products from binary products and terminal.

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

If a category has binary products and a terminal object then it has finite products.
If a functor preserves binary products and the terminal object then it preserves finite products.

# TODO

Provide the dual results.
Show the analogous results for functors which reflect or create (co)limits.
-/

universe v v' u u'

noncomputable section

open CategoryTheory CategoryTheory.Category CategoryTheory.Limits

namespace CategoryTheory

variable {J : Type v} [SmallCategory J]

variable {C : Type u} [Category.{v} C]

variable {D : Type u'} [Category.{v'} D]

/- warning: category_theory.extend_fan -> CategoryTheory.extendFan is a dubious translation:
lean 3 declaration is
  forall {C : Type.{u2}} [_inst_2 : CategoryTheory.Category.{u1, u2} C] {n : Nat} {f : (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (OfNat.ofNat.{0} Nat 1 (OfNat.mk.{0} Nat 1 (One.one.{0} Nat Nat.hasOne))))) -> C} (c₁ : CategoryTheory.Limits.Fan.{0, u1, u2} (Fin n) C _inst_2 (fun (i : Fin n) => f (Fin.succ n i))), (CategoryTheory.Limits.BinaryFan.{u1, u2} C _inst_2 (f (OfNat.ofNat.{0} (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (One.one.{0} Nat Nat.hasOne))) 0 (OfNat.mk.{0} (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (One.one.{0} Nat Nat.hasOne))) 0 (Zero.zero.{0} (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (One.one.{0} Nat Nat.hasOne))) (Fin.hasZeroOfNeZero (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (One.one.{0} Nat Nat.hasOne)) (NeZero.succ n)))))) (CategoryTheory.Limits.Cone.pt.{0, u1, 0, u2} (CategoryTheory.Discrete.{0} (Fin n)) (CategoryTheory.discreteCategory.{0} (Fin n)) C _inst_2 (CategoryTheory.Discrete.functor.{u1, 0, u2} C _inst_2 (Fin n) (fun (i : Fin n) => f (Fin.succ n i))) c₁)) -> (CategoryTheory.Limits.Fan.{0, u1, u2} (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (OfNat.ofNat.{0} Nat 1 (OfNat.mk.{0} Nat 1 (One.one.{0} Nat Nat.hasOne))))) C _inst_2 f)
but is expected to have type
  forall {C : Type.{u2}} [_inst_2 : CategoryTheory.Category.{u1, u2} C] {n : Nat} {f : (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) n (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1)))) -> C} (c₁ : CategoryTheory.Limits.Fan.{0, u1, u2} (Fin n) C _inst_2 (fun (i : Fin n) => f (Fin.succ n i))), (CategoryTheory.Limits.BinaryFan.{u1, u2} C _inst_2 (f (OfNat.ofNat.{0} (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) n (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1)))) 0 (Fin.instOfNatFin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) n (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1))) 0 (NeZero.succ n)))) (CategoryTheory.Limits.Cone.pt.{0, u1, 0, u2} (CategoryTheory.Discrete.{0} (Fin n)) (CategoryTheory.discreteCategory.{0} (Fin n)) C _inst_2 (CategoryTheory.Discrete.functor.{u1, 0, u2} C _inst_2 (Fin n) (fun (i : Fin n) => f (Fin.succ n i))) c₁)) -> (CategoryTheory.Limits.Fan.{0, u1, u2} (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) n (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1)))) C _inst_2 f)
Case conversion may be inaccurate. Consider using '#align category_theory.extend_fan CategoryTheory.extendFanₓ'. -/
/--
Given `n+1` objects of `C`, a fan for the last `n` with point `c₁.X` and a binary fan on `c₁.X` and
`f 0`, we can build a fan for all `n+1`.

In `extend_fan_is_limit` we show that if the two given fans are limits, then this fan is also a
limit.
-/
@[simps (config := { rhsMd := semireducible })]
def extendFan {n : ℕ} {f : Fin (n + 1) → C} (c₁ : Fan fun i : Fin n => f i.succ)
    (c₂ : BinaryFan (f 0) c₁.pt) : Fan f :=
  Fan.mk c₂.pt
    (by
      refine' Fin.cases _ _
      · apply c₂.fst
      · intro i
        apply c₂.snd ≫ c₁.π.app ⟨i⟩)
#align category_theory.extend_fan CategoryTheory.extendFan

/- warning: category_theory.extend_fan_is_limit -> CategoryTheory.extendFanIsLimit is a dubious translation:
lean 3 declaration is
  forall {C : Type.{u2}} [_inst_2 : CategoryTheory.Category.{u1, u2} C] {n : Nat} (f : (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (OfNat.ofNat.{0} Nat 1 (OfNat.mk.{0} Nat 1 (One.one.{0} Nat Nat.hasOne))))) -> C) {c₁ : CategoryTheory.Limits.Fan.{0, u1, u2} (Fin n) C _inst_2 (fun (i : Fin n) => f (Fin.succ n i))} {c₂ : CategoryTheory.Limits.BinaryFan.{u1, u2} C _inst_2 (f (OfNat.ofNat.{0} (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (One.one.{0} Nat Nat.hasOne))) 0 (OfNat.mk.{0} (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (One.one.{0} Nat Nat.hasOne))) 0 (Zero.zero.{0} (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (One.one.{0} Nat Nat.hasOne))) (Fin.hasZeroOfNeZero (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (One.one.{0} Nat Nat.hasOne)) (NeZero.succ n)))))) (CategoryTheory.Limits.Cone.pt.{0, u1, 0, u2} (CategoryTheory.Discrete.{0} (Fin n)) (CategoryTheory.discreteCategory.{0} (Fin n)) C _inst_2 (CategoryTheory.Discrete.functor.{u1, 0, u2} C _inst_2 (Fin n) (fun (i : Fin n) => f (Fin.succ n i))) c₁)}, (CategoryTheory.Limits.IsLimit.{0, u1, 0, u2} (CategoryTheory.Discrete.{0} (Fin n)) (CategoryTheory.discreteCategory.{0} (Fin n)) C _inst_2 (CategoryTheory.Discrete.functor.{u1, 0, u2} C _inst_2 (Fin n) (fun (i : Fin n) => f (Fin.succ n i))) c₁) -> (CategoryTheory.Limits.IsLimit.{0, u1, 0, u2} (CategoryTheory.Discrete.{0} CategoryTheory.Limits.WalkingPair) (CategoryTheory.discreteCategory.{0} CategoryTheory.Limits.WalkingPair) C _inst_2 (CategoryTheory.Limits.pair.{u1, u2} C _inst_2 (f (OfNat.ofNat.{0} (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (One.one.{0} Nat Nat.hasOne))) 0 (OfNat.mk.{0} (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (One.one.{0} Nat Nat.hasOne))) 0 (Zero.zero.{0} (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (One.one.{0} Nat Nat.hasOne))) (Fin.hasZeroOfNeZero (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (One.one.{0} Nat Nat.hasOne)) (NeZero.succ n)))))) (CategoryTheory.Limits.Cone.pt.{0, u1, 0, u2} (CategoryTheory.Discrete.{0} (Fin n)) (CategoryTheory.discreteCategory.{0} (Fin n)) C _inst_2 (CategoryTheory.Discrete.functor.{u1, 0, u2} C _inst_2 (Fin n) (fun (i : Fin n) => f (Fin.succ n i))) c₁)) c₂) -> (CategoryTheory.Limits.IsLimit.{0, u1, 0, u2} (CategoryTheory.Discrete.{0} (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (OfNat.ofNat.{0} Nat 1 (OfNat.mk.{0} Nat 1 (One.one.{0} Nat Nat.hasOne)))))) (CategoryTheory.discreteCategory.{0} (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (OfNat.ofNat.{0} Nat 1 (OfNat.mk.{0} Nat 1 (One.one.{0} Nat Nat.hasOne)))))) C _inst_2 (CategoryTheory.Discrete.functor.{u1, 0, u2} C _inst_2 (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (OfNat.ofNat.{0} Nat 1 (OfNat.mk.{0} Nat 1 (One.one.{0} Nat Nat.hasOne))))) f) (CategoryTheory.extendFan.{u1, u2} C _inst_2 n f c₁ c₂))
but is expected to have type
  forall {C : Type.{u2}} [_inst_2 : CategoryTheory.Category.{u1, u2} C] {n : Nat} (f : (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) n (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1)))) -> C) {c₁ : CategoryTheory.Limits.Fan.{0, u1, u2} (Fin n) C _inst_2 (fun (i : Fin n) => f (Fin.succ n i))} {c₂ : CategoryTheory.Limits.BinaryFan.{u1, u2} C _inst_2 (f (OfNat.ofNat.{0} (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) n (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1)))) 0 (Fin.instOfNatFin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) n (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1))) 0 (NeZero.succ n)))) (CategoryTheory.Limits.Cone.pt.{0, u1, 0, u2} (CategoryTheory.Discrete.{0} (Fin n)) (CategoryTheory.discreteCategory.{0} (Fin n)) C _inst_2 (CategoryTheory.Discrete.functor.{u1, 0, u2} C _inst_2 (Fin n) (fun (i : Fin n) => f (Fin.succ n i))) c₁)}, (CategoryTheory.Limits.IsLimit.{0, u1, 0, u2} (CategoryTheory.Discrete.{0} (Fin n)) (CategoryTheory.discreteCategory.{0} (Fin n)) C _inst_2 (CategoryTheory.Discrete.functor.{u1, 0, u2} C _inst_2 (Fin n) (fun (i : Fin n) => f (Fin.succ n i))) c₁) -> (CategoryTheory.Limits.IsLimit.{0, u1, 0, u2} (CategoryTheory.Discrete.{0} CategoryTheory.Limits.WalkingPair) (CategoryTheory.discreteCategory.{0} CategoryTheory.Limits.WalkingPair) C _inst_2 (CategoryTheory.Limits.pair.{u1, u2} C _inst_2 (f (OfNat.ofNat.{0} (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) n (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1)))) 0 (Fin.instOfNatFin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) n (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1))) 0 (NeZero.succ n)))) (CategoryTheory.Limits.Cone.pt.{0, u1, 0, u2} (CategoryTheory.Discrete.{0} (Fin n)) (CategoryTheory.discreteCategory.{0} (Fin n)) C _inst_2 (CategoryTheory.Discrete.functor.{u1, 0, u2} C _inst_2 (Fin n) (fun (i : Fin n) => f (Fin.succ n i))) c₁)) c₂) -> (CategoryTheory.Limits.IsLimit.{0, u1, 0, u2} (CategoryTheory.Discrete.{0} (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) n (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1))))) (CategoryTheory.discreteCategory.{0} (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) n (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1))))) C _inst_2 (CategoryTheory.Discrete.functor.{u1, 0, u2} C _inst_2 (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) n (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1)))) f) (CategoryTheory.extendFan.{u1, u2} C _inst_2 n f c₁ c₂))
Case conversion may be inaccurate. Consider using '#align category_theory.extend_fan_is_limit CategoryTheory.extendFanIsLimitₓ'. -/
/-- Show that if the two given fans in `extend_fan` are limits, then the constructed fan is also a
limit.
-/
def extendFanIsLimit {n : ℕ} (f : Fin (n + 1) → C) {c₁ : Fan fun i : Fin n => f i.succ}
    {c₂ : BinaryFan (f 0) c₁.pt} (t₁ : IsLimit c₁) (t₂ : IsLimit c₂) : IsLimit (extendFan c₁ c₂)
    where
  lift s := by
    apply (binary_fan.is_limit.lift' t₂ (s.π.app ⟨0⟩) _).1
    apply t₁.lift ⟨_, discrete.nat_trans fun ⟨i⟩ => s.π.app ⟨i.succ⟩⟩
  fac := fun s ⟨j⟩ => by
    apply Fin.inductionOn j
    · apply (binary_fan.is_limit.lift' t₂ _ _).2.1
    · rintro i -
      dsimp only [extend_fan_π_app]
      rw [Fin.cases_succ, ← assoc, (binary_fan.is_limit.lift' t₂ _ _).2.2, t₁.fac]
      rfl
  uniq s m w := by
    apply binary_fan.is_limit.hom_ext t₂
    · rw [(binary_fan.is_limit.lift' t₂ _ _).2.1]
      apply w ⟨0⟩
    · rw [(binary_fan.is_limit.lift' t₂ _ _).2.2]
      apply t₁.uniq ⟨_, _⟩
      rintro ⟨j⟩
      rw [assoc]
      dsimp only [discrete.nat_trans_app, extend_fan_is_limit._match_1]
      rw [← w ⟨j.succ⟩]
      dsimp only [extend_fan_π_app]
      rw [Fin.cases_succ]
#align category_theory.extend_fan_is_limit CategoryTheory.extendFanIsLimit

section

variable [HasBinaryProducts C] [HasTerminal C]

/-- If `C` has a terminal object and binary products, then it has a product for objects indexed by
`fin n`.
This is a helper lemma for `has_finite_products_of_has_binary_and_terminal`, which is more general
than this.
-/
private theorem has_product_fin : ∀ (n : ℕ) (f : Fin n → C), HasProduct f
  | 0 => fun f =>
    by
    letI : has_limits_of_shape (discrete (Fin 0)) C :=
      has_limits_of_shape_of_equivalence (Discrete.equivalence.{0} fin_zero_equiv'.symm)
    infer_instance
  | n + 1 => fun f => by
    haveI := has_product_fin n
    apply has_limit.mk ⟨_, extend_fan_is_limit f (limit.is_limit _) (limit.is_limit _)⟩
#align category_theory.has_product_fin category_theory.has_product_fin

#print CategoryTheory.hasFiniteProducts_of_has_binary_and_terminal /-
/-- If `C` has a terminal object and binary products, then it has finite products. -/
theorem hasFiniteProducts_of_has_binary_and_terminal : HasFiniteProducts C :=
  by
  refine' ⟨fun n => ⟨fun K => _⟩⟩
  letI := has_product_fin n fun n => K.obj ⟨n⟩
  let this : (discrete.functor fun n => K.obj ⟨n⟩) ≅ K := discrete.nat_iso fun ⟨i⟩ => iso.refl _
  apply has_limit_of_iso this
#align category_theory.has_finite_products_of_has_binary_and_terminal CategoryTheory.hasFiniteProducts_of_has_binary_and_terminal
-/

end

section Preserves

variable (F : C ⥤ D)

variable [PreservesLimitsOfShape (Discrete WalkingPair) F]

variable [PreservesLimitsOfShape (Discrete.{0} PEmpty) F]

variable [HasFiniteProducts.{v} C]

/- warning: category_theory.preserves_fin_of_preserves_binary_and_terminal -> CategoryTheory.preservesFinOfPreservesBinaryAndTerminalₓ is a dubious translation:
lean 3 declaration is
  forall {C : Type.{u3}} [_inst_2 : CategoryTheory.Category.{u1, u3} C] {D : Type.{u4}} [_inst_3 : CategoryTheory.Category.{u2, u4} D] (F : CategoryTheory.Functor.{u1, u2, u3, u4} C _inst_2 D _inst_3) [_inst_4 : CategoryTheory.Limits.PreservesLimitsOfShape.{0, 0, u1, u2, u3, u4} C _inst_2 D _inst_3 (CategoryTheory.Discrete.{0} CategoryTheory.Limits.WalkingPair) (CategoryTheory.discreteCategory.{0} CategoryTheory.Limits.WalkingPair) F] [_inst_5 : CategoryTheory.Limits.PreservesLimitsOfShape.{0, 0, u1, u2, u3, u4} C _inst_2 D _inst_3 (CategoryTheory.Discrete.{0} PEmpty.{1}) (CategoryTheory.discreteCategory.{0} PEmpty.{1}) F] [_inst_6 : CategoryTheory.Limits.HasFiniteProducts.{u1, u3} C _inst_2] (n : Nat) (f : (Fin n) -> C), CategoryTheory.Limits.PreservesLimit.{0, 0, u1, u2, u3, u4} C _inst_2 D _inst_3 (CategoryTheory.Discrete.{0} (Fin n)) (CategoryTheory.discreteCategory.{0} (Fin n)) (CategoryTheory.Discrete.functor.{u1, 0, u3} C _inst_2 (Fin n) f) F
but is expected to have type
  forall {C : Type.{u1}} [_inst_2 : CategoryTheory.Category.{u3, u1} C] {D : Type.{u2}} [_inst_3 : CategoryTheory.Category.{u4, u2} D] (F : CategoryTheory.Functor.{u3, u4, u1, u2} C _inst_2 D _inst_3) [_inst_4 : CategoryTheory.Limits.PreservesLimitsOfShape.{0, 0, u3, u4, u1, u2} C _inst_2 D _inst_3 (CategoryTheory.Discrete.{0} CategoryTheory.Limits.WalkingPair) (CategoryTheory.discreteCategory.{0} CategoryTheory.Limits.WalkingPair) F] [_inst_5 : CategoryTheory.Limits.PreservesLimitsOfShape.{0, 0, u3, u4, u1, u2} C _inst_2 D _inst_3 (CategoryTheory.Discrete.{0} PEmpty.{1}) (CategoryTheory.discreteCategory.{0} PEmpty.{1}) F] [_inst_6 : CategoryTheory.Limits.HasFiniteProducts.{u3, u1} C _inst_2] (n : Nat) (f : (Fin n) -> C), CategoryTheory.Limits.PreservesLimit.{0, 0, u3, u4, u1, u2} C _inst_2 D _inst_3 (CategoryTheory.Discrete.{0} (Fin n)) (CategoryTheory.discreteCategory.{0} (Fin n)) (CategoryTheory.Discrete.functor.{u3, 0, u1} C _inst_2 (Fin n) f) F
Case conversion may be inaccurate. Consider using '#align category_theory.preserves_fin_of_preserves_binary_and_terminal CategoryTheory.preservesFinOfPreservesBinaryAndTerminalₓₓ'. -/
/-- If `F` preserves the terminal object and binary products, then it preserves products indexed by
`fin n` for any `n`.
-/
noncomputable def preservesFinOfPreservesBinaryAndTerminal :
    ∀ (n : ℕ) (f : Fin n → C), PreservesLimit (Discrete.functor f) F
  | 0 => fun f =>
    by
    letI : preserves_limits_of_shape (discrete (Fin 0)) F :=
      preservesLimitsOfShapeOfEquiv.{0, 0} (discrete.equivalence fin_zero_equiv'.symm) _
    infer_instance
  | n + 1 => by
    haveI := preserves_fin_of_preserves_binary_and_terminal n
    intro f
    refine'
      preserves_limit_of_preserves_limit_cone
        (extend_fan_is_limit f (limit.is_limit _) (limit.is_limit _)) _
    apply (is_limit_map_cone_fan_mk_equiv _ _ _).symm _
    let this :=
      extend_fan_is_limit (fun i => F.obj (f i)) (is_limit_of_has_product_of_preserves_limit F _)
        (is_limit_of_has_binary_product_of_preserves_limit F _ _)
    refine' is_limit.of_iso_limit this _
    apply cones.ext _ _
    apply iso.refl _
    rintro ⟨j⟩
    apply Fin.inductionOn j
    · apply (category.id_comp _).symm
    · rintro i -
      dsimp only [extend_fan_π_app, iso.refl_hom, fan.mk_π_app]
      rw [Fin.cases_succ, Fin.cases_succ]
      change F.map _ ≫ _ = 𝟙 _ ≫ _
      rw [id_comp, ← F.map_comp]
      rfl
#align category_theory.preserves_fin_of_preserves_binary_and_terminal CategoryTheory.preservesFinOfPreservesBinaryAndTerminalₓ

#print CategoryTheory.preservesShapeFinOfPreservesBinaryAndTerminal /-
/-- If `F` preserves the terminal object and binary products, then it preserves limits of shape
`discrete (fin n)`.
-/
def preservesShapeFinOfPreservesBinaryAndTerminal (n : ℕ) :
    PreservesLimitsOfShape (Discrete (Fin n)) F
    where PreservesLimit K :=
    by
    let this : (discrete.functor fun n => K.obj ⟨n⟩) ≅ K := discrete.nat_iso fun ⟨i⟩ => iso.refl _
    haveI := preserves_fin_of_preserves_binary_and_terminal F n fun n => K.obj ⟨n⟩
    apply preserves_limit_of_iso_diagram F this
#align category_theory.preserves_shape_fin_of_preserves_binary_and_terminal CategoryTheory.preservesShapeFinOfPreservesBinaryAndTerminal
-/

#print CategoryTheory.preservesFiniteProductsOfPreservesBinaryAndTerminal /-
/-- If `F` preserves the terminal object and binary products then it preserves finite products. -/
def preservesFiniteProductsOfPreservesBinaryAndTerminal (J : Type) [Fintype J] :
    PreservesLimitsOfShape (Discrete J) F := by
  classical
    let e := Fintype.equivFin J
    haveI := preserves_shape_fin_of_preserves_binary_and_terminal F (Fintype.card J)
    apply preservesLimitsOfShapeOfEquiv.{0, 0} (discrete.equivalence e).symm
#align category_theory.preserves_finite_products_of_preserves_binary_and_terminal CategoryTheory.preservesFiniteProductsOfPreservesBinaryAndTerminal
-/

end Preserves

/- warning: category_theory.extend_cofan -> CategoryTheory.extendCofan is a dubious translation:
lean 3 declaration is
  forall {C : Type.{u2}} [_inst_2 : CategoryTheory.Category.{u1, u2} C] {n : Nat} {f : (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (OfNat.ofNat.{0} Nat 1 (OfNat.mk.{0} Nat 1 (One.one.{0} Nat Nat.hasOne))))) -> C} (c₁ : CategoryTheory.Limits.Cofan.{0, u1, u2} (Fin n) C _inst_2 (fun (i : Fin n) => f (Fin.succ n i))), (CategoryTheory.Limits.BinaryCofan.{u1, u2} C _inst_2 (f (OfNat.ofNat.{0} (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (One.one.{0} Nat Nat.hasOne))) 0 (OfNat.mk.{0} (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (One.one.{0} Nat Nat.hasOne))) 0 (Zero.zero.{0} (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (One.one.{0} Nat Nat.hasOne))) (Fin.hasZeroOfNeZero (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (One.one.{0} Nat Nat.hasOne)) (NeZero.succ n)))))) (CategoryTheory.Limits.Cocone.pt.{0, u1, 0, u2} (CategoryTheory.Discrete.{0} (Fin n)) (CategoryTheory.discreteCategory.{0} (Fin n)) C _inst_2 (CategoryTheory.Discrete.functor.{u1, 0, u2} C _inst_2 (Fin n) (fun (i : Fin n) => f (Fin.succ n i))) c₁)) -> (CategoryTheory.Limits.Cofan.{0, u1, u2} (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (OfNat.ofNat.{0} Nat 1 (OfNat.mk.{0} Nat 1 (One.one.{0} Nat Nat.hasOne))))) C _inst_2 f)
but is expected to have type
  forall {C : Type.{u2}} [_inst_2 : CategoryTheory.Category.{u1, u2} C] {n : Nat} {f : (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) n (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1)))) -> C} (c₁ : CategoryTheory.Limits.Cofan.{0, u1, u2} (Fin n) C _inst_2 (fun (i : Fin n) => f (Fin.succ n i))), (CategoryTheory.Limits.BinaryCofan.{u1, u2} C _inst_2 (f (OfNat.ofNat.{0} (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) n (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1)))) 0 (Fin.instOfNatFin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) n (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1))) 0 (NeZero.succ n)))) (CategoryTheory.Limits.Cocone.pt.{0, u1, 0, u2} (CategoryTheory.Discrete.{0} (Fin n)) (CategoryTheory.discreteCategory.{0} (Fin n)) C _inst_2 (CategoryTheory.Discrete.functor.{u1, 0, u2} C _inst_2 (Fin n) (fun (i : Fin n) => f (Fin.succ n i))) c₁)) -> (CategoryTheory.Limits.Cofan.{0, u1, u2} (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) n (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1)))) C _inst_2 f)
Case conversion may be inaccurate. Consider using '#align category_theory.extend_cofan CategoryTheory.extendCofanₓ'. -/
/-- Given `n+1` objects of `C`, a cofan for the last `n` with point `c₁.X`
and a binary cofan on `c₁.X` and `f 0`, we can build a cofan for all `n+1`.

In `extend_cofan_is_colimit` we show that if the two given cofans are colimits,
then this cofan is also a colimit.
-/
@[simps (config := { rhsMd := semireducible })]
def extendCofan {n : ℕ} {f : Fin (n + 1) → C} (c₁ : Cofan fun i : Fin n => f i.succ)
    (c₂ : BinaryCofan (f 0) c₁.pt) : Cofan f :=
  Cofan.mk c₂.pt
    (by
      refine' Fin.cases _ _
      · apply c₂.inl
      · intro i
        apply c₁.ι.app ⟨i⟩ ≫ c₂.inr)
#align category_theory.extend_cofan CategoryTheory.extendCofan

/- warning: category_theory.extend_cofan_is_colimit -> CategoryTheory.extendCofanIsColimit is a dubious translation:
lean 3 declaration is
  forall {C : Type.{u2}} [_inst_2 : CategoryTheory.Category.{u1, u2} C] {n : Nat} (f : (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (OfNat.ofNat.{0} Nat 1 (OfNat.mk.{0} Nat 1 (One.one.{0} Nat Nat.hasOne))))) -> C) {c₁ : CategoryTheory.Limits.Cofan.{0, u1, u2} (Fin n) C _inst_2 (fun (i : Fin n) => f (Fin.succ n i))} {c₂ : CategoryTheory.Limits.BinaryCofan.{u1, u2} C _inst_2 (f (OfNat.ofNat.{0} (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (One.one.{0} Nat Nat.hasOne))) 0 (OfNat.mk.{0} (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (One.one.{0} Nat Nat.hasOne))) 0 (Zero.zero.{0} (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (One.one.{0} Nat Nat.hasOne))) (Fin.hasZeroOfNeZero (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (One.one.{0} Nat Nat.hasOne)) (NeZero.succ n)))))) (CategoryTheory.Limits.Cocone.pt.{0, u1, 0, u2} (CategoryTheory.Discrete.{0} (Fin n)) (CategoryTheory.discreteCategory.{0} (Fin n)) C _inst_2 (CategoryTheory.Discrete.functor.{u1, 0, u2} C _inst_2 (Fin n) (fun (i : Fin n) => f (Fin.succ n i))) c₁)}, (CategoryTheory.Limits.IsColimit.{0, u1, 0, u2} (CategoryTheory.Discrete.{0} (Fin n)) (CategoryTheory.discreteCategory.{0} (Fin n)) C _inst_2 (CategoryTheory.Discrete.functor.{u1, 0, u2} C _inst_2 (Fin n) (fun (i : Fin n) => f (Fin.succ n i))) c₁) -> (CategoryTheory.Limits.IsColimit.{0, u1, 0, u2} (CategoryTheory.Discrete.{0} CategoryTheory.Limits.WalkingPair) (CategoryTheory.discreteCategory.{0} CategoryTheory.Limits.WalkingPair) C _inst_2 (CategoryTheory.Limits.pair.{u1, u2} C _inst_2 (f (OfNat.ofNat.{0} (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (One.one.{0} Nat Nat.hasOne))) 0 (OfNat.mk.{0} (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (One.one.{0} Nat Nat.hasOne))) 0 (Zero.zero.{0} (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (One.one.{0} Nat Nat.hasOne))) (Fin.hasZeroOfNeZero (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (One.one.{0} Nat Nat.hasOne)) (NeZero.succ n)))))) (CategoryTheory.Limits.Cocone.pt.{0, u1, 0, u2} (CategoryTheory.Discrete.{0} (Fin n)) (CategoryTheory.discreteCategory.{0} (Fin n)) C _inst_2 (CategoryTheory.Discrete.functor.{u1, 0, u2} C _inst_2 (Fin n) (fun (i : Fin n) => f (Fin.succ n i))) c₁)) c₂) -> (CategoryTheory.Limits.IsColimit.{0, u1, 0, u2} (CategoryTheory.Discrete.{0} (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (OfNat.ofNat.{0} Nat 1 (OfNat.mk.{0} Nat 1 (One.one.{0} Nat Nat.hasOne)))))) (CategoryTheory.discreteCategory.{0} (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (OfNat.ofNat.{0} Nat 1 (OfNat.mk.{0} Nat 1 (One.one.{0} Nat Nat.hasOne)))))) C _inst_2 (CategoryTheory.Discrete.functor.{u1, 0, u2} C _inst_2 (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (OfNat.ofNat.{0} Nat 1 (OfNat.mk.{0} Nat 1 (One.one.{0} Nat Nat.hasOne))))) f) (CategoryTheory.extendCofan.{u1, u2} C _inst_2 n f c₁ c₂))
but is expected to have type
  forall {C : Type.{u2}} [_inst_2 : CategoryTheory.Category.{u1, u2} C] {n : Nat} (f : (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) n (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1)))) -> C) {c₁ : CategoryTheory.Limits.Cofan.{0, u1, u2} (Fin n) C _inst_2 (fun (i : Fin n) => f (Fin.succ n i))} {c₂ : CategoryTheory.Limits.BinaryCofan.{u1, u2} C _inst_2 (f (OfNat.ofNat.{0} (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) n (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1)))) 0 (Fin.instOfNatFin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) n (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1))) 0 (NeZero.succ n)))) (CategoryTheory.Limits.Cocone.pt.{0, u1, 0, u2} (CategoryTheory.Discrete.{0} (Fin n)) (CategoryTheory.discreteCategory.{0} (Fin n)) C _inst_2 (CategoryTheory.Discrete.functor.{u1, 0, u2} C _inst_2 (Fin n) (fun (i : Fin n) => f (Fin.succ n i))) c₁)}, (CategoryTheory.Limits.IsColimit.{0, u1, 0, u2} (CategoryTheory.Discrete.{0} (Fin n)) (CategoryTheory.discreteCategory.{0} (Fin n)) C _inst_2 (CategoryTheory.Discrete.functor.{u1, 0, u2} C _inst_2 (Fin n) (fun (i : Fin n) => f (Fin.succ n i))) c₁) -> (CategoryTheory.Limits.IsColimit.{0, u1, 0, u2} (CategoryTheory.Discrete.{0} CategoryTheory.Limits.WalkingPair) (CategoryTheory.discreteCategory.{0} CategoryTheory.Limits.WalkingPair) C _inst_2 (CategoryTheory.Limits.pair.{u1, u2} C _inst_2 (f (OfNat.ofNat.{0} (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) n (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1)))) 0 (Fin.instOfNatFin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) n (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1))) 0 (NeZero.succ n)))) (CategoryTheory.Limits.Cocone.pt.{0, u1, 0, u2} (CategoryTheory.Discrete.{0} (Fin n)) (CategoryTheory.discreteCategory.{0} (Fin n)) C _inst_2 (CategoryTheory.Discrete.functor.{u1, 0, u2} C _inst_2 (Fin n) (fun (i : Fin n) => f (Fin.succ n i))) c₁)) c₂) -> (CategoryTheory.Limits.IsColimit.{0, u1, 0, u2} (CategoryTheory.Discrete.{0} (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) n (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1))))) (CategoryTheory.discreteCategory.{0} (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) n (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1))))) C _inst_2 (CategoryTheory.Discrete.functor.{u1, 0, u2} C _inst_2 (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) n (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1)))) f) (CategoryTheory.extendCofan.{u1, u2} C _inst_2 n f c₁ c₂))
Case conversion may be inaccurate. Consider using '#align category_theory.extend_cofan_is_colimit CategoryTheory.extendCofanIsColimitₓ'. -/
/-- Show that if the two given cofans in `extend_cofan` are colimits,
then the constructed cofan is also a colimit.
-/
def extendCofanIsColimit {n : ℕ} (f : Fin (n + 1) → C) {c₁ : Cofan fun i : Fin n => f i.succ}
    {c₂ : BinaryCofan (f 0) c₁.pt} (t₁ : IsColimit c₁) (t₂ : IsColimit c₂) :
    IsColimit (extendCofan c₁ c₂)
    where
  desc s := by
    apply (binary_cofan.is_colimit.desc' t₂ (s.ι.app ⟨0⟩) _).1
    apply t₁.desc ⟨_, discrete.nat_trans fun i => s.ι.app ⟨i.as.succ⟩⟩
  fac s := by
    rintro ⟨j⟩
    apply Fin.inductionOn j
    · apply (binary_cofan.is_colimit.desc' t₂ _ _).2.1
    · rintro i -
      dsimp only [extend_cofan_ι_app]
      rw [Fin.cases_succ, assoc, (binary_cofan.is_colimit.desc' t₂ _ _).2.2, t₁.fac]
      rfl
  uniq s m w := by
    apply binary_cofan.is_colimit.hom_ext t₂
    · rw [(binary_cofan.is_colimit.desc' t₂ _ _).2.1]
      apply w ⟨0⟩
    · rw [(binary_cofan.is_colimit.desc' t₂ _ _).2.2]
      apply t₁.uniq ⟨_, _⟩
      rintro ⟨j⟩
      dsimp only [discrete.nat_trans_app]
      rw [← w ⟨j.succ⟩]
      dsimp only [extend_cofan_ι_app]
      rw [Fin.cases_succ, assoc]
#align category_theory.extend_cofan_is_colimit CategoryTheory.extendCofanIsColimit

section

variable [HasBinaryCoproducts C] [HasInitial C]

/--
If `C` has an initial object and binary coproducts, then it has a coproduct for objects indexed by
`fin n`.
This is a helper lemma for `has_cofinite_products_of_has_binary_and_terminal`, which is more general
than this.
-/
private theorem has_coproduct_fin : ∀ (n : ℕ) (f : Fin n → C), HasCoproduct f
  | 0 => fun f =>
    by
    letI : has_colimits_of_shape (discrete (Fin 0)) C :=
      has_colimits_of_shape_of_equivalence (Discrete.equivalence.{0} fin_zero_equiv'.symm)
    infer_instance
  | n + 1 => fun f => by
    haveI := has_coproduct_fin n
    apply
      has_colimit.mk ⟨_, extend_cofan_is_colimit f (colimit.is_colimit _) (colimit.is_colimit _)⟩
#align category_theory.has_coproduct_fin category_theory.has_coproduct_fin

#print CategoryTheory.hasFiniteCoproducts_of_has_binary_and_initial /-
/-- If `C` has an initial object and binary coproducts, then it has finite coproducts. -/
theorem hasFiniteCoproducts_of_has_binary_and_initial : HasFiniteCoproducts C :=
  by
  refine' ⟨fun n => ⟨fun K => _⟩⟩
  letI := has_coproduct_fin n fun n => K.obj ⟨n⟩
  let this : K ≅ discrete.functor fun n => K.obj ⟨n⟩ := discrete.nat_iso fun ⟨i⟩ => iso.refl _
  apply has_colimit_of_iso this
#align category_theory.has_finite_coproducts_of_has_binary_and_initial CategoryTheory.hasFiniteCoproducts_of_has_binary_and_initial
-/

end

section Preserves

variable (F : C ⥤ D)

variable [PreservesColimitsOfShape (Discrete WalkingPair) F]

variable [PreservesColimitsOfShape (Discrete.{0} PEmpty) F]

variable [HasFiniteCoproducts.{v} C]

/- warning: category_theory.preserves_fin_of_preserves_binary_and_initial -> CategoryTheory.preservesFinOfPreservesBinaryAndInitialₓ is a dubious translation:
lean 3 declaration is
  forall {C : Type.{u3}} [_inst_2 : CategoryTheory.Category.{u1, u3} C] {D : Type.{u4}} [_inst_3 : CategoryTheory.Category.{u2, u4} D] (F : CategoryTheory.Functor.{u1, u2, u3, u4} C _inst_2 D _inst_3) [_inst_4 : CategoryTheory.Limits.PreservesColimitsOfShape.{0, 0, u1, u2, u3, u4} C _inst_2 D _inst_3 (CategoryTheory.Discrete.{0} CategoryTheory.Limits.WalkingPair) (CategoryTheory.discreteCategory.{0} CategoryTheory.Limits.WalkingPair) F] [_inst_5 : CategoryTheory.Limits.PreservesColimitsOfShape.{0, 0, u1, u2, u3, u4} C _inst_2 D _inst_3 (CategoryTheory.Discrete.{0} PEmpty.{1}) (CategoryTheory.discreteCategory.{0} PEmpty.{1}) F] [_inst_6 : CategoryTheory.Limits.HasFiniteCoproducts.{u1, u3} C _inst_2] (n : Nat) (f : (Fin n) -> C), CategoryTheory.Limits.PreservesColimit.{0, 0, u1, u2, u3, u4} C _inst_2 D _inst_3 (CategoryTheory.Discrete.{0} (Fin n)) (CategoryTheory.discreteCategory.{0} (Fin n)) (CategoryTheory.Discrete.functor.{u1, 0, u3} C _inst_2 (Fin n) f) F
but is expected to have type
  forall {C : Type.{u1}} [_inst_2 : CategoryTheory.Category.{u3, u1} C] {D : Type.{u2}} [_inst_3 : CategoryTheory.Category.{u4, u2} D] (F : CategoryTheory.Functor.{u3, u4, u1, u2} C _inst_2 D _inst_3) [_inst_4 : CategoryTheory.Limits.PreservesColimitsOfShape.{0, 0, u3, u4, u1, u2} C _inst_2 D _inst_3 (CategoryTheory.Discrete.{0} CategoryTheory.Limits.WalkingPair) (CategoryTheory.discreteCategory.{0} CategoryTheory.Limits.WalkingPair) F] [_inst_5 : CategoryTheory.Limits.PreservesColimitsOfShape.{0, 0, u3, u4, u1, u2} C _inst_2 D _inst_3 (CategoryTheory.Discrete.{0} PEmpty.{1}) (CategoryTheory.discreteCategory.{0} PEmpty.{1}) F] [_inst_6 : CategoryTheory.Limits.HasFiniteCoproducts.{u3, u1} C _inst_2] (n : Nat) (f : (Fin n) -> C), CategoryTheory.Limits.PreservesColimit.{0, 0, u3, u4, u1, u2} C _inst_2 D _inst_3 (CategoryTheory.Discrete.{0} (Fin n)) (CategoryTheory.discreteCategory.{0} (Fin n)) (CategoryTheory.Discrete.functor.{u3, 0, u1} C _inst_2 (Fin n) f) F
Case conversion may be inaccurate. Consider using '#align category_theory.preserves_fin_of_preserves_binary_and_initial CategoryTheory.preservesFinOfPreservesBinaryAndInitialₓₓ'. -/
/-- If `F` preserves the initial object and binary coproducts, then it preserves products indexed by
`fin n` for any `n`.
-/
noncomputable def preservesFinOfPreservesBinaryAndInitial :
    ∀ (n : ℕ) (f : Fin n → C), PreservesColimit (Discrete.functor f) F
  | 0 => fun f =>
    by
    letI : preserves_colimits_of_shape (discrete (Fin 0)) F :=
      preservesColimitsOfShapeOfEquiv.{0, 0} (discrete.equivalence fin_zero_equiv'.symm) _
    infer_instance
  | n + 1 => by
    haveI := preserves_fin_of_preserves_binary_and_initial n
    intro f
    refine'
      preserves_colimit_of_preserves_colimit_cocone
        (extend_cofan_is_colimit f (colimit.is_colimit _) (colimit.is_colimit _)) _
    apply (is_colimit_map_cocone_cofan_mk_equiv _ _ _).symm _
    let this :=
      extend_cofan_is_colimit (fun i => F.obj (f i))
        (is_colimit_of_has_coproduct_of_preserves_colimit F _)
        (is_colimit_of_has_binary_coproduct_of_preserves_colimit F _ _)
    refine' is_colimit.of_iso_colimit this _
    apply cocones.ext _ _
    apply iso.refl _
    rintro ⟨j⟩
    apply Fin.inductionOn j
    · apply category.comp_id
    · rintro i -
      dsimp only [extend_cofan_ι_app, iso.refl_hom, cofan.mk_ι_app]
      rw [Fin.cases_succ, Fin.cases_succ]
      erw [comp_id, ← F.map_comp]
      rfl
#align category_theory.preserves_fin_of_preserves_binary_and_initial CategoryTheory.preservesFinOfPreservesBinaryAndInitialₓ

#print CategoryTheory.preservesShapeFinOfPreservesBinaryAndInitial /-
/-- If `F` preserves the initial object and binary coproducts, then it preserves colimits of shape
`discrete (fin n)`.
-/
def preservesShapeFinOfPreservesBinaryAndInitial (n : ℕ) :
    PreservesColimitsOfShape (Discrete (Fin n)) F
    where PreservesColimit K :=
    by
    let this : (discrete.functor fun n => K.obj ⟨n⟩) ≅ K := discrete.nat_iso fun ⟨i⟩ => iso.refl _
    haveI := preserves_fin_of_preserves_binary_and_initial F n fun n => K.obj ⟨n⟩
    apply preserves_colimit_of_iso_diagram F this
#align category_theory.preserves_shape_fin_of_preserves_binary_and_initial CategoryTheory.preservesShapeFinOfPreservesBinaryAndInitial
-/

#print CategoryTheory.preservesFiniteCoproductsOfPreservesBinaryAndInitial /-
/-- If `F` preserves the initial object and binary coproducts then it preserves finite products. -/
def preservesFiniteCoproductsOfPreservesBinaryAndInitial (J : Type) [Fintype J] :
    PreservesColimitsOfShape (Discrete J) F := by
  classical
    let e := Fintype.equivFin J
    haveI := preserves_shape_fin_of_preserves_binary_and_initial F (Fintype.card J)
    apply preservesColimitsOfShapeOfEquiv.{0, 0} (discrete.equivalence e).symm
#align category_theory.preserves_finite_coproducts_of_preserves_binary_and_initial CategoryTheory.preservesFiniteCoproductsOfPreservesBinaryAndInitial
-/

end Preserves

end CategoryTheory


import data.complex.basic
import number_theory.divisors

theorem AMC_2021_A_25 (N:ℕ)(f:ℕ → ℝ)(h:∀(n:ℕ), f n = (finset.card (nat.divisors n))/(n^(1/3)))(hN:∀(n:ℕ),n≠N → (f N > f n)):
N=2520
:=
begin
  sorry
end


import Smt
import Smt.Data.BitVec

theorem append_eq_shl_or_2 (x y : BitVec 2)
    : x ++ y = (x.zeroExtend 2 <<< 2) ||| y.zeroExtend 2 := by
  smt
  sorry

theorem append_eq_shl_or_3 (x y : BitVec 3)
    : x ++ y = (x.zeroExtend 3 <<< 3) ||| y.zeroExtend 3 := by
  smt
  sorry