/-
  Specifications file for signature_spec.cairo

  Do not modify the constant definitions, structure definitions, or automatic specifications.
  Do not change the name or arguments of the user specifications and soundness theorems.

  You may freely move the definitions around in the file.
  You may add definitions and theorems wherever you wish in this file.
-/
import starkware.cairo.lean.semantics.soundness.prelude
import starkware.cairo.common.cairo_secp.ec_spec
import starkware.cairo.common.cairo_secp.bigint_spec
import starkware.cairo.common.cairo_secp.constants_spec
import starkware.cairo.common.cairo_secp.field_spec
import starkware.cairo.common.math_spec

open starkware.cairo.common.cairo_secp.ec
open starkware.cairo.common.cairo_secp.bigint
open starkware.cairo.common.cairo_secp.constants
open starkware.cairo.common.cairo_secp.field
open starkware.cairo.common.math

namespace starkware.cairo.common.cairo_secp.signature

variables {F : Type} [field F] [decidable_eq F] [prelude_hyps F]

--variables {secpF : Type} [secp_field secpF]

-- End of automatically generated prelude.

/-
-- Function: get_generator_point
-/

/- get_generator_point autogenerated specification -/

def gen_point (F : Type) [field F] : EcPoint F :=
  ⟨⟨17117865558768631194064792,
    12501176021340589225372855,
    9198697782662356105779718⟩,
   ⟨6441780312434748884571320,
     57953919405111227542741658,
     5457536640262350763842127⟩⟩

def gen_point_data (F : Type) [field F] [decidable_eq F] [prelude_hyps F]
    (secpF : Type) [secp_field secpF]:
  BddECPointData secpF (gen_point F) :=
{ ix := ⟨17117865558768631194064792,
         12501176021340589225372855,
         9198697782662356105779718⟩,
  iy := ⟨6441780312434748884571320,
         57953919405111227542741658,
         5457536640262350763842127⟩,
  ixbdd := begin
             rw [bigint3.bounded, BASE], simp_int_casts,
             repeat { rw [abs_of_nonneg] },
             repeat { norm_num }
            end,
  iybdd := begin
             rw [bigint3.bounded, BASE], simp_int_casts,
             repeat { rw [abs_of_nonneg] },
             repeat { norm_num }
            end,
  ptxeq := by { rw [gen_point, bigint3.toBigInt3], simp_int_casts, exact ⟨rfl, rfl, rfl⟩ },
  ptyeq := by { rw [gen_point, bigint3.toBigInt3], simp_int_casts, exact ⟨rfl, rfl, rfl⟩ },
  onEC :=
    begin
      right,
      rw [←int.cast_pow, ←int.cast_pow, (show (7 : secpF) = (7 : int), by simp_int_casts),
        ←int.cast_add, char_p.int_coe_eq_int_coe_iff secpF SECP_PRIME, bigint3.val, bigint3.val,
        SECP_PRIME_eq, int.modeq, BASE, SECP_REM],
      dsimp, simp_int_casts, norm_num,
    end }

-- Do not change this definition.
def auto_spec_get_generator_point (mem : F → F) (κ : ℕ) (ρ_point : EcPoint F) : Prop :=
  7 ≤ κ ∧
  ρ_point = {
    x := { d0 := 17117865558768631194064792, d1 := 12501176021340589225372855, d2 := 9198697782662356105779718 },
    y := { d0 := 6441780312434748884571320, d1 := 57953919405111227542741658, d2 := 5457536640262350763842127 }
  }

-- You may change anything in this definition except the name and arguments.
def spec_get_generator_point (mem : F → F) (κ : ℕ) (ρ_point : EcPoint F) : Prop :=
  ρ_point = gen_point F

/- get_generator_point soundness theorem -/

-- Do not change the statement of this theorem. You may change the proof.
theorem sound_get_generator_point
    {mem : F → F}
    (κ : ℕ)
    (ρ_point : EcPoint F)
    (h_auto : auto_spec_get_generator_point mem κ ρ_point) :
  spec_get_generator_point mem κ ρ_point :=
begin
  exact h_auto.2
end

-- Function: div_mod_n

/- div_mod_n autogenerated specification -/

-- Do not change this definition.
def auto_spec_div_mod_n (mem : F → F) (κ : ℕ) (range_check_ptr : F) (a b : BigInt3 F) (ρ_range_check_ptr : F) (ρ_res : BigInt3 F) : Prop :=
  ∃ (κ₁ : ℕ) (range_check_ptr₁ : F) (res : BigInt3 F), spec_nondet_bigint3 mem κ₁ range_check_ptr range_check_ptr₁ res ∧
  ∃ (κ₂ : ℕ) (range_check_ptr₂ : F) (k : BigInt3 F), spec_nondet_bigint3 mem κ₂ range_check_ptr₁ range_check_ptr₂ k ∧
  ∃ (κ₃ : ℕ) (res_b : UnreducedBigInt5 F), spec_bigint_mul mem κ₃ res b res_b ∧
  ∃ n : BigInt3 F, n = {
    d0 := N0,
    d1 := N1,
    d2 := N2
  } ∧
  ∃ (κ₄ : ℕ) (k_n : UnreducedBigInt5 F), spec_bigint_mul mem κ₄ k n k_n ∧
  ∃ carry1 : F, carry1 = (res_b.d0 - k_n.d0 - a.d0) / (BASE : ℤ) ∧
  mem (range_check_ptr₂ + 0) = carry1 + 2 ^ 127 ∧
  is_range_checked (rc_bound F) (carry1 + 2 ^ 127) ∧
  ∃ carry2 : F, carry2 = (res_b.d1 - k_n.d1 - a.d1 + carry1) / (BASE : ℤ) ∧
  mem (range_check_ptr₂ + 1) = carry2 + 2 ^ 127 ∧
  is_range_checked (rc_bound F) (carry2 + 2 ^ 127) ∧
  ∃ carry3 : F, carry3 = (res_b.d2 - k_n.d2 - a.d2 + carry2) / (BASE : ℤ) ∧
  mem (range_check_ptr₂ + 2) = carry3 + 2 ^ 127 ∧
  is_range_checked (rc_bound F) (carry3 + 2 ^ 127) ∧
  ∃ carry4 : F, carry4 = (res_b.d3 - k_n.d3 + carry3) / (BASE : ℤ) ∧
  mem (range_check_ptr₂ + 3) = carry4 + 2 ^ 127 ∧
  is_range_checked (rc_bound F) (carry4 + 2 ^ 127) ∧
  res_b.d4 - k_n.d4 + carry4 = 0 ∧
  ∃ range_check_ptr₃ : F, range_check_ptr₃ = range_check_ptr₂ + 4 ∧
  κ₁ + κ₂ + κ₃ + κ₄ + 48 ≤ κ ∧
  ρ_range_check_ptr = range_check_ptr₃ ∧
  ρ_res = res

-- You may change anything in this definition except the name and arguments.
def spec_div_mod_n (mem : F → F) (κ : ℕ) (range_check_ptr : F) (a b : BigInt3 F) (ρ_range_check_ptr : F) (ρ_res : BigInt3 F) : Prop :=
  ∀ ia : bigint3,
    ia.bounded (3 * BASE - 1) →
    a = ia.toBigInt3 →
  ∀ ib : bigint3,
    ib.bounded (3 * BASE - 1) →
    b = ib.toBigInt3 →
  ∃ ires : bigint3,
    ires.bounded (3 * BASE - 1) ∧
    ρ_res = ires.toBigInt3 ∧
    ires.val * ib.val ≡ ia.val [ZMOD secp_n]

/- div_mod_n soundness theorem -/

def iN0 : ℤ := N0
def iN1 : ℤ := N1
def iN2 : ℤ := N2

def secp_in : bigint3 := ⟨iN0, iN1, iN2⟩

def nBASE := BASE

--theorem secp_in_toBigInt3 : secp_in.toBigInt3 = secp_n := rfl

-- Do not change the statement of this theorem. You may change the proof.
theorem sound_div_mod_n
    {mem : F → F}
    (κ : ℕ)
    (range_check_ptr : F) (a b : BigInt3 F) (ρ_range_check_ptr : F) (ρ_res : BigInt3 F)
    (h_auto : auto_spec_div_mod_n mem κ range_check_ptr a b ρ_range_check_ptr ρ_res) :
  spec_div_mod_n mem κ range_check_ptr a b ρ_range_check_ptr ρ_res :=
begin
  intros ia iabdd aeq ib ibbdd beq,
  rcases h_auto with ⟨_, _, res, hres, _, _, k, hk, _, res_b, hres_b, n, neq, _, k_n, hk_n,
    carry1, carry1eq, _, hcarry1,
    carry2, carry2eq, _, hcarry2,
    carry3, carry3eq, _, hcarry3,
    carry4, carry4eq, _, hcarry4,
    diff_eq, _, _, _, _, ρ_res_eq⟩,
  rcases nondet_bigint3_corr hres with ⟨ires, reseq, ires_bdd⟩,
  rcases nondet_bigint3_corr hk with ⟨ik, keq, ik_bdd⟩,
  change _ = _ at hres_b,
  change _ = _ at hk_n,
  rcases rc_to_int hcarry1 with ⟨icarry1, carry1eq', carry1_bdd⟩,
  rcases rc_to_int hcarry2 with ⟨icarry2, carry2eq', carry2_bdd⟩,
  rcases rc_to_int hcarry3 with ⟨icarry3, carry3eq', carry3_bdd⟩,
  rcases rc_to_int hcarry4 with ⟨icarry4, carry4eq', carry4_bdd⟩,
  have BASEnonneg : 0 ≤ (BASE : ℤ) := int.coe_zero_le BASE,
  have iN0nonneg : 0 ≤ iN0 := int.coe_zero_le _,
  have iN1nonneg : 0 ≤ iN1 := int.coe_zero_le _,
  have iN2nonneg : 0 ≤ iN2 := int.coe_zero_le _,
  have absBASEeq : abs (BASE : ℤ) = BASE := abs_of_nonneg BASEnonneg,
  have BASEnz : ((BASE : ℤ) : F) ≠ 0,
  { suffices : ((2 : ℤ) : F) ≠ 0,
      by simpa using this,
    haveI : char_p F PRIME := prelude_hyps.charF,
    rw [ne, char_p.int_cast_eq_zero_iff F PRIME, PRIME],
    simp_int_casts, norm_num },
  have aux3 : ∀ {x y : F}, x = y / (BASE : ℤ) → x * 2 ^ 86 = y,
  { intros x y xeq,
    rw [eq_div_iff BASEnz, int.cast_coe_nat, BASE] at xeq,
    simp only [nat.cast_bit0, nat.cast_one, nat.cast_pow] at xeq,
    exact xeq },
  have secp_in_toBigInt3 : secp_in.toBigInt3 = n,
  { rw [neq, bigint3.toBigInt3, secp_in], dsimp,
    rw [iN0, iN1, iN2, int.cast_coe_nat, int.cast_coe_nat, int.cast_coe_nat] },
  have : (((((ires.bigint5_mul ib).sub (ik.bigint5_mul secp_in)).sub ia.to_bigint5).add
          ⟨0, icarry1, icarry2, icarry3, 0⟩).toUnreducedBigInt5 : UnreducedBigInt5 F) =
      bigint5.toUnreducedBigInt5
        (⟨icarry1*BASE, icarry2*BASE, icarry3*BASE, icarry4*BASE, -icarry4⟩),
  { rw [bigint5.toUnreducedBigInt5_add, bigint5.toUnreducedBigInt5_sub,
        bigint5.toUnreducedBigInt5_sub, bigint3.bigint5_mul_toUnreducedBigInt5,
        bigint3.bigint5_mul_toUnreducedBigInt5],
    conv { to_rhs, rw [bigint5.toUnreducedBigInt5], simp },
    rw [←carry1eq', aux3 carry1eq, ←carry2eq', aux3 carry2eq, ←carry3eq', aux3 carry3eq,
      ←carry4eq', aux3 carry4eq, ←reseq, ←keq, ←beq, ←hres_b, secp_in_toBigInt3, ←hk_n,
      bigint3.to_bigint5_to_Unreduced_BigInt5, ←aeq],
    simp [UnreducedBigInt5.sub, UnreducedBigInt5.add,
      starkware.cairo.common.cairo_secp.bigint.bigint3.to_bigint5, bigint5.toUnreducedBigInt5,
        BigInt3.toUnreducedBigInt5],
    simp [carry1eq', carry2eq', carry3eq', eq_sub_of_add_eq diff_eq] },
  have eq :  ((((ires.bigint5_mul ib).sub (ik.bigint5_mul secp_in)).sub ia.to_bigint5).add
          ⟨0, icarry1, icarry2, icarry3, 0⟩) =
        ⟨icarry1*BASE, icarry2*BASE, icarry3*BASE, icarry4*BASE, -icarry4⟩,
  { apply bigint5.toUnreducedBigInt5_eq_of_sub_bounded this,
    have : (2^127 : ℤ) * BASE + (3 * (3 * BASE - 1)^2 +
      (3 * (3 * (BASE - 1))^2) + (3 * BASE - 1) + 2^127) ≤ PRIME - 1,
    { rw [PRIME, BASE], simp_int_casts, norm_num },
    apply bigint5.bounded_of_bounded_of_le _ this,
    apply bigint5.bounded_sub,
    { simp [bigint5.bounded, abs_mul, absBASEeq],
      use [carry1_bdd, carry2_bdd, carry3_bdd, carry4_bdd],
      apply le_trans carry4_bdd, norm_num },
    apply bigint5.bounded_add, swap,
    { simp [bigint5.bounded],
      use [carry1_bdd, carry2_bdd, carry3_bdd] },
    apply bigint5.bounded_sub _ (bigint3.to_bigint5_bounded iabdd),
    apply bigint5.bounded_sub,
    apply bigint3.bounded_bigint5_mul (bigint3.bounded_of_bounded_of_le ires_bdd bound_slack) ibbdd,
    apply bigint3.bounded_bigint5_mul ik_bdd,
    rw [secp_in, bigint3.bounded], dsimp,
    simp [abs_of_nonneg iN0nonneg, abs_of_nonneg iN1nonneg, abs_of_nonneg iN2nonneg],
    simp [iN0, iN1, iN2],
    norm_num,  },
  have : ires.val * ib.val = ik.val * secp_n + ia.val,
  { simp only [bigint3.val, secp_n, int.cast_add, int.coe_nat_add, int.coe_nat_mul],
    rw [int.coe_nat_pow BASE 2],
    set iBASE := (BASE : ℤ),
    simp only [bigint3.bigint5_mul, bigint5.add, bigint5.sub, bigint3.to_bigint5, secp_in, add_zero, sub_zero] at eq,
    rcases eq with ⟨eq1, eq2, eq3, eq4, eq5⟩,
    rw [←iN0, ←iN1, ←iN2],
    transitivity (ires.i2 * ib.i2 * iBASE * iBASE * iBASE * iBASE) +
      (ires.i2 * iBASE ^ 2 * (ib.i1 * iBASE + ib.i0)) +
      (ires.i1 * iBASE + ires.i0) * (ib.i2 * iBASE ^ 2 + ib.i1 * iBASE + ib.i0),
    rw [pow_two], ring,
    rw [eq_add_of_sub_eq eq5, add_mul, add_mul, add_mul],
    rw [←neg_mul_eq_neg_mul, ←eq4, neg_add],
    simp only [add_mul _ _ iBASE],
    rw [←neg_mul_eq_neg_mul icarry3, ←eq3, neg_add],
    simp only [add_mul _ _ iBASE],
    rw [←neg_mul_eq_neg_mul icarry2, ←eq2, neg_add],
    simp only [add_mul _ _ iBASE],
    rw [←neg_mul_eq_neg_mul icarry1, ←eq1],
    ring },
  use ires,
  split, apply bigint3.bounded_of_bounded_of_le ires_bdd bound_slack,
  use ρ_res_eq.trans reseq,
  rw [this, int.modeq, add_comm, int.add_mul_mod_self]
end

/-
-- Function: get_point_from_x
-/

/- get_point_from_x autogenerated specification -/

-- Do not change this definition.
def auto_spec_get_point_from_x (mem : F → F) (κ : ℕ) (range_check_ptr : F) (x : BigInt3 F) (v ρ_range_check_ptr : F) (ρ_point : EcPoint F) : Prop :=
  ∃ (κ₁ : ℕ) (range_check_ptr₁ : F), spec_assert_nn mem κ₁ range_check_ptr v range_check_ptr₁ ∧
  ∃ (κ₂ : ℕ) (x_square : UnreducedBigInt3 F), spec_unreduced_sqr mem κ₂ x x_square ∧
  ∃ (κ₃ : ℕ) (range_check_ptr₂ : F) (x_square_reduced : BigInt3 F), spec_reduce mem κ₃ range_check_ptr₁ x_square range_check_ptr₂ x_square_reduced ∧
  ∃ (κ₄ : ℕ) (x_cube : UnreducedBigInt3 F), spec_unreduced_mul mem κ₄ x x_square_reduced x_cube ∧
  ∃ (κ₅ : ℕ) (range_check_ptr₃ : F) (y : BigInt3 F), spec_nondet_bigint3 mem κ₅ range_check_ptr₂ range_check_ptr₃ y ∧
  ∃ (κ₆ : ℕ) (range_check_ptr₄ : F), spec_validate_reduced_field_element mem κ₆ range_check_ptr₃ y range_check_ptr₄ ∧
  ∃ (κ₇ : ℕ) (range_check_ptr₅ : F), spec_assert_nn mem κ₇ range_check_ptr₄ ((y.d0 + v) / (2 : ℤ)) range_check_ptr₅ ∧
  ∃ (κ₈ : ℕ) (y_square : UnreducedBigInt3 F), spec_unreduced_sqr mem κ₈ y y_square ∧
  ∃ (κ₉ : ℕ) (range_check_ptr₆ : F), spec_verify_zero mem κ₉ range_check_ptr₅ {
    d0 := x_cube.d0 + BETA - y_square.d0,
    d1 := x_cube.d1 - y_square.d1,
    d2 := x_cube.d2 - y_square.d2
  } range_check_ptr₆ ∧
  κ₁ + κ₂ + κ₃ + κ₄ + κ₅ + κ₆ + κ₇ + κ₈ + κ₉ + 54 ≤ κ ∧
  ρ_range_check_ptr = range_check_ptr₆ ∧
  ρ_point = {
    x := x,
    y := y
  }

theorem aux {a b c : ℕ} (h : a + b = 2 * c) : a % 2 = b % 2 :=
begin
  have : a + 2 * b = 2 * c + b,
  { nth_rewrite 0 (two_mul b),
    rw [←add_assoc, h] },
  have h' := congr_arg (λ n : ℕ, n % 2) this,
  dsimp at h',
  rw [nat.add_mul_mod_self_left, add_comm, nat.add_mul_mod_self_left] at h',
  exact h'
end

-- You may change anything in this definition except the name and arguments.
def spec_get_point_from_x (mem : F → F) (κ : ℕ) (range_check_ptr : F) (x : BigInt3 F) (v ρ_range_check_ptr : F) (ρ_point : EcPoint F) : Prop :=
   ∀ (secpF : Type) [hsecp : secp_field secpF],
   by exactI
      x ≠ ⟨0, 0, 0⟩ →
      ∀ ix : bigint3,
        ix.bounded (3 * BASE - 1) →
        x = ix.toBigInt3 →
        ∃ nv : ℕ,
          nv < rc_bound F ∧
          v = ↑nv ∧
        ∃ iyval : ℕ,
          iyval < SECP_PRIME ∧
          nv % 2 = iyval % 2 ∧
        ∃ h : @on_ec secpF _ (ix.val, iyval),
        ∃ hres : BddECPointData secpF ρ_point,
          hres.toECPoint = ECPoint.AffinePoint ⟨_, _, h⟩

/- get_point_from_x soundness theorem -/

-- Do not change the statement of this theorem. You may change the proof.
theorem sound_get_point_from_x
    {mem : F → F}
    (κ : ℕ)
    (range_check_ptr : F) (x : BigInt3 F) (v ρ_range_check_ptr : F) (ρ_point : EcPoint F)
    (h_auto : auto_spec_get_point_from_x mem κ range_check_ptr x v ρ_range_check_ptr ρ_point) :
  spec_get_point_from_x mem κ range_check_ptr x v ρ_range_check_ptr ρ_point :=
begin
  intros secpF _,
  resetI,
  intros xnez ix ixbdd xeq,
  rcases h_auto with
    ⟨_, _, h_nn_v,
    _, x_square, h_x_square,
    _, _, x_square_reduced, h_x_square_reduced,
    _, x_cube, h_x_cube,
    _, _, y, h_nondet_bigint3_y,
    _, _, h_validate_reduced_y,
    _, _, h_nn_y_v_div,
    _, y_square, h_unreduced_y_square,
    _, _, h_verify_zero,
    _, _, ρ_point_eq⟩,
  rcases h_nn_v with ⟨nv, nvlt, veq⟩,
  have x_square_eq := h_x_square ix xeq,
  have : ix.sqr.bounded (2 ^ 249),
  { apply bigint3.bounded_of_bounded_of_le
      (bigint3.bounded_sqr ixbdd),
    rw [BASE, SECP_REM], simp_int_casts, norm_num },
  rcases h_x_square_reduced ix.sqr this x_square_eq with
    ⟨ixsqr', ixsqr'bdd, hixsqr', x_square_reduced_eq⟩,
  have x_cube_eq := h_x_cube ix ixsqr' xeq x_square_reduced_eq,
  rcases nondet_bigint3_corr h_nondet_bigint3_y with ⟨iy, yeq, iybdd⟩,
  rcases h_validate_reduced_y with ⟨n0, n1, n2, n0le, n1le, n2le, yvallt, yeq'⟩,
  rcases h_nn_y_v_div with ⟨nydiv, nydivlt, ydiveq⟩,
  have : y.d0 + v = ↑(2 * nydiv),
  { rw [mul_comm, nat.cast_mul],
    symmetry, simp,
    rw [← (eq_div_iff (PRIME.two_ne_zero F)), ← ydiveq],
    simp },
  have : n0 + nv = 2 * nydiv,
  { rw [yeq', veq, ← nat.cast_add] at this,
    apply nat.cast_inj_of_lt_char _ _ this,
    apply lt_of_le_of_lt (add_le_add n0le (le_of_lt nvlt)),
    apply lt_of_le_of_lt (add_le_add_left (rc_bound_hyp F) _),
    rw [BASE, PRIME.char_eq, PRIME],
    norm_num,
    apply lt_of_le_of_lt,
    apply nat.mul_le_mul_left 2
      (le_trans (le_of_lt nydivlt) (rc_bound_hyp F)),
    rw [PRIME.char_eq, PRIME], norm_num },
  have n02eqmv2 : n0 % 2 = nv % 2 := aux this,
  let  iy' : bigint3 := ⟨n0, n1, n2⟩,
  have iy'bdd : iy'.bounded (3 * ↑BASE - 1),
  { suffices : iy'.bounded BASE,
    { apply bigint3.bounded_of_bounded_of_le this,
      rw BASE, simp_int_casts, norm_num },
    simp only [bigint3.bounded, int.coe_nat_abs, int.coe_nat_le],
    split, { apply le_trans n0le tsub_le_self },
    split, { apply le_trans n1le tsub_le_self },
    apply le_trans n2le,
    norm_num [P2, BASE] },
  have yeq'' : y = iy'.toBigInt3,
  { rw [yeq', bigint3.toBigInt3], dsimp [iy'],
    simp only [int.cast_coe_nat, eq_self_iff_true, and_self] },
  have y_square_eq := h_unreduced_y_square iy' yeq'',
  let idiff := ((ix.mul ixsqr').add ⟨7,0,0⟩).sub iy'.sqr,
  have hidiff1 : idiff.toUnreducedBigInt3 = ⟨x_cube.d0 + ↑BETA - y_square.d0, x_cube.d1 - y_square.d1, x_cube.d2 - y_square.d2⟩,
  { simp [idiff, BETA, bigint3.toUnreducedBigInt3_add, bigint3.toUnreducedBigInt3_sub, ←x_cube_eq, ←y_square_eq],
    simp [bigint3.toUnreducedBigInt3, UnreducedBigInt3.add, UnreducedBigInt3.sub] },
  have hidiff2 : idiff.bounded (2 ^ 250),
  { suffices : idiff.bounded ((3 * BASE - 1)^2 * (8 * SECP_REM + 1) + 7 +
      (3 * BASE - 1)^2 * (8 * SECP_REM + 1)),
    { apply bigint3.bounded_of_bounded_of_le this,
     rw [BASE, SECP_REM], simp_int_casts, norm_num },
    apply bigint3.bounded_sub,
    apply bigint3.bounded_add,
    apply bigint3.bounded_mul ixbdd (bigint3.bounded_of_bounded_of_le ixsqr'bdd bound_slack),
    { simp [bigint3.bounded], rw abs_of_nonneg; norm_num },
    apply bigint3.bounded_sqr iy'bdd },
  have := h_verify_zero idiff hidiff1.symm hidiff2,
  have h_on_ec : on_ec ((ix.val : secpF), iy'.val),
  { simp [on_ec],
    suffices : (↑(iy'.val ^ 2) : secpF) = ↑(ix.val ^ 3 + 7),
    { simpa using this },
    rw [char_p.int_coe_eq_int_coe_iff secpF SECP_PRIME, int.modeq],
    symmetry,
    rw [int.mod_eq_mod_iff_mod_sub_eq_zero, ←this],
    dsimp [idiff],
    rw [bigint3.sub_val, bigint3.add_val],
    apply int.modeq.sub,
    apply int.modeq.add,
    rw [pow_succ],
    apply int.modeq.symm,
    apply int.modeq.trans,
    apply bigint3.mul_val,
    apply int.modeq.mul_left,
    apply int.modeq.trans hixsqr',
    apply bigint3.sqr_val,
    { simp [bigint3.val] },
    apply int.modeq.symm,
    apply bigint3.sqr_val },
  have iy'valeq : (↑(n2 * BASE ^ 2 + n1 * BASE + n0) : secpF) = iy'.val,
  { dsimp [iy'], simp [bigint3.val] },
  use [nv, nvlt, veq, n2 * BASE ^ 2 + n1 * BASE + n0, yvallt],
  split,
  { rw [←n02eqmv2, nat.add_mod, nat.add_mod (n2 * _), nat.mul_mod, BASE],
    norm_num,
    rw [nat.add_mod, nat.mul_mod],
    norm_num },
  rw iy'valeq,
  use h_on_ec,
  rw ρ_point_eq,
  use ⟨ix, iy', ixbdd, iy'bdd, xeq, yeq'', or.inr h_on_ec⟩,
  simp [BddECPointData.toECPoint, dif_neg xnez]
end

/-
-- Function: recover_public_key
-/

/- recover_public_key autogenerated specification -/

-- Do not change this definition.
def auto_spec_recover_public_key (mem : F → F) (κ : ℕ) (range_check_ptr : F) (msg_hash r s : BigInt3 F) (v ρ_range_check_ptr : F) (ρ_public_key_point : EcPoint F) : Prop :=
  ∃ (κ₁ : ℕ) (range_check_ptr₁ : F) (r_point : EcPoint F), spec_get_point_from_x mem κ₁ range_check_ptr r v range_check_ptr₁ r_point ∧
  ∃ (κ₂ : ℕ) (generator_point : EcPoint F), spec_get_generator_point mem κ₂  generator_point ∧
  ∃ (κ₃ : ℕ) (range_check_ptr₂ : F) (u1 : BigInt3 F), spec_div_mod_n mem κ₃ range_check_ptr₁ msg_hash r range_check_ptr₂ u1 ∧
  ∃ (κ₄ : ℕ) (range_check_ptr₃ : F) (u2 : BigInt3 F), spec_div_mod_n mem κ₄ range_check_ptr₂ s r range_check_ptr₃ u2 ∧
  ∃ (κ₅ : ℕ) (range_check_ptr₄ : F) (point1 : EcPoint F), spec_ec_mul mem κ₅ range_check_ptr₃ generator_point u1 range_check_ptr₄ point1 ∧
  ∃ (κ₆ : ℕ) (range_check_ptr₅ : F) (minus_point1 : EcPoint F), spec_ec_negate mem κ₆ range_check_ptr₄ point1 range_check_ptr₅ minus_point1 ∧
  ∃ (κ₇ : ℕ) (range_check_ptr₆ : F) (point2 : EcPoint F), spec_ec_mul mem κ₇ range_check_ptr₅ r_point u2 range_check_ptr₆ point2 ∧
  ∃ (κ₈ : ℕ) (range_check_ptr₇ : F) (public_key_point : EcPoint F), spec_ec_add mem κ₈ range_check_ptr₆ minus_point1 point2 range_check_ptr₇ public_key_point ∧
  κ₁ + κ₂ + κ₃ + κ₄ + κ₅ + κ₆ + κ₇ + κ₈ + 77 ≤ κ ∧
  ρ_range_check_ptr = range_check_ptr₇ ∧
  ρ_public_key_point = public_key_point

-- You may change anything in this definition except the name and arguments.
def spec_recover_public_key (mem : F → F) (κ : ℕ) (range_check_ptr : F) (msg_hash r s : BigInt3 F) (v ρ_range_check_ptr : F) (ρ_public_key_point : EcPoint F) : Prop :=
  ∀ (secpF : Type) [secp_field secpF], by exactI
  r ≠ ⟨0, 0, 0⟩ →
  ∀ ir : bigint3,
    ir.bounded (3 * BASE - 1) →
    r = ir.toBigInt3 →
  ∀ is : bigint3,
    is.bounded (3 * BASE - 1) →
    s = is.toBigInt3 →
  ∀ imsg : bigint3,
    imsg.bounded (3 * BASE - 1) →
    msg_hash = imsg.toBigInt3 →
  ∃ nv : ℕ,
    nv < rc_bound F ∧
    v = ↑nv ∧
  ∃ iu1 iu2 : ℤ,
    iu1 * ir.val ≡ imsg.val [ZMOD secp_n] ∧
    iu2 * ir.val ≡ is.val [ZMOD secp_n] ∧
  ∃ ny : ℕ,
    ny < SECP_PRIME ∧
    nv ≡ ny [MOD 2] ∧
  ∃ h_on_ec : @on_ec secpF _ (ir.val, ny),
  ∃ hpoint  : BddECPointData secpF ρ_public_key_point,
    hpoint.toECPoint =
      -(iu1 • (gen_point_data F secpF).toECPoint) +
        iu2 • ECPoint.AffinePoint ⟨ir.val, ny, h_on_ec⟩

/- recover_public_key soundness theorem -/

-- Do not change the statement of this theorem. You may change the proof.
theorem sound_recover_public_key
    {mem : F → F}
    (κ : ℕ)
    (range_check_ptr : F) (msg_hash r s : BigInt3 F) (v ρ_range_check_ptr : F) (ρ_public_key_point : EcPoint F)
    (h_auto : auto_spec_recover_public_key mem κ range_check_ptr msg_hash r s v ρ_range_check_ptr ρ_public_key_point) :
  spec_recover_public_key mem κ range_check_ptr msg_hash r s v ρ_range_check_ptr ρ_public_key_point :=
begin
  intros secpF _ rnez ir irbdd req is isbdd iseq imsg imsgbdd msgeq,
  resetI,
  rcases h_auto with ⟨_, _, r_point, hr_point,
    _, generator, hgenerator,
    _, _, u1, hu1,
    _, _, u2, hu2,
    _, _, point1, hpoint1,
    _, _, minus_point1, hminus_point1,
    _, _, point2, hpoint2,
    _, _, public_key_point, hpublic_key_point,
    _, _, rfl⟩,
  rcases hr_point secpF rnez ir irbdd req with ⟨nv, nvlt, veq, iy, iybdd, iy2, hiy, hr_point', ireq⟩,
  rw spec_get_generator_point at hgenerator,
  subst hgenerator,
  rcases hu1 imsg imsgbdd msgeq ir irbdd req with ⟨iu1, iu1bdd, u1eq, hu1'⟩,
  rcases hu2 is isbdd iseq ir irbdd req with ⟨iu2, iu2bdd, u2eq, hu2'⟩,
  have : (gen_point F).x ≠ ⟨0, 0, 0⟩,
  { simp [gen_point],
    intros eq _ _,
    suffices : (17117865558768631194064792 : ℤ) = 0,
    { norm_num at this },
    haveI : char_p F PRIME := prelude_hyps.charF,
    apply int.cast_eq_zero_of_lt_char F PRIME,
    { simp_int_casts, exact eq },
    rw [abs_of_nonneg, PRIME],
    simp_int_casts, norm_num, norm_num },
  rcases hpoint1 secpF this (gen_point_data F secpF) with
    ⟨n10, n10lt, n10eq, n11, n11lt, n11eq, n12, n12lt, n12eq, hpoint1', hpoint1eq⟩,
  rcases spec_ec_negate'_of_spec_ec_negate hminus_point1 secpF hpoint1' with
    ⟨hminus_point1', hminus_point1_eq⟩,
  have : r_point.x ≠ ⟨0, 0, 0⟩,
  { intro hcontr,
    rw [BddECPointData.toECPoint, dif_pos hcontr] at ireq,
    contradiction },
  rcases hpoint2 secpF this hr_point' with
    ⟨n20, n20lt, n20eq, n21, n21lt, n21eq, n22, n22lt, n22eq, hpoint2', hpoint2eq⟩,
  rcases hpublic_key_point secpF hminus_point1' hpoint2' with ⟨hret, hreteq⟩,
  refine ⟨nv, nvlt, veq, _, _, hu1', hu2', iy, iybdd, iy2, hiy, hret, _⟩,
  rw [hreteq, hminus_point1_eq, hpoint1eq, hpoint2eq, ireq],
  have aux : ∀ {i : ℤ} {n : ℕ}, abs i ≤ 3 * BASE - 1 → n < 2^86 → (i : F) = (n : F) → i = n,
  { intros i n hi hn hin,
    have : (i : F) = ((n : ℤ) : F),
    { rw hin, simp },
    apply PRIME.int_coe_inj this,
    have : (2^86 : ℤ) + (3 * BASE - 1) < PRIME,
    { simp only [PRIME], simp_int_casts, norm_num },
    apply lt_of_le_of_lt _ this,
    apply le_trans,
    apply abs_sub,
    apply add_le_add _ hi,
    rw abs_of_nonneg (int.coe_zero_le _),
    apply le_of_lt,
    norm_cast, exact hn },
  simp [u1eq, u2eq, bigint3.toBigInt3] at n10eq n11eq n12eq n20eq n21eq n22eq,
  have : iu1.val = ↑(2 ^ 172 * n12 + 2 ^ 86 * n11 + n10),
  { rw [bigint3.val], simp,
    rw [aux iu1bdd.1 n10lt n10eq, aux iu1bdd.2.1 n11lt n11eq,
        aux iu1bdd.2.2 (lt_of_lt_of_le n12lt (by norm_num)) n12eq ],
        ring },
  rw [this, nsmul_eq_smul_cast ℤ],
  have : iu2.val = ↑(2 ^ 172 * n22 + 2 ^ 86 * n21 + n20),
  { rw [bigint3.val], simp,
    rw [aux iu2bdd.1 n20lt n20eq, aux iu2bdd.2.1 n21lt n21eq,
        aux iu2bdd.2.2 (lt_of_lt_of_le n22lt (by norm_num)) n22eq ],
        ring },
  rw [this, nsmul_eq_smul_cast ℤ]
end

end starkware.cairo.common.cairo_secp.signature


import topology.filter
import measure_theory.measure.null_measurable
import measure_theory.measurable_space
import measure_theory.measure.measure_space
import number_theory.well_approximable
import topology.algebra.order.liminf_limsup

open set filter (hiding map) function measurable_space topological_space (second_countable_topology)
open_locale classical big_operators filter ennreal nnreal interval measure_theory

namespace measure_theory

variables {α : Type*} {m : measurable_space α} {μ : measure α}

/-
Want to state using `well_approximate`:
For a function ψ : ℕ → ℝ≥0 such that ∑ q, (φ q * ψ q) / q < ∞, μ W = 0
-/

/- Gallagher's Ergodic Theorem -/
example {T : ℝ} [hT : fact (0 < T)] (δ : ℕ → ℝ) (hδ : tendsto δ at_top (nhds 0)) :
(∀ᵐ (x : add_circle T), ¬add_well_approximable (add_circle T) δ x) ∨
 ∀ᵐ (x : add_circle T), add_well_approximable (add_circle T) δ x := sorry

/- Borel-Cantelli Theorem -/
example {p : ℕ → α → Prop} (hp : ∑' i, μ {x | p i x} ≠ ∞) : μ {x | ∃ᶠ n in at_top, p n x} = 0 :=
sorry

/- Duffin-Schaeffer Theorem (Implication) -/
example (α : ℝ) (ψ : ℕ → ℝ≥0) (h : {q : ℚ | |α - q| ≤ ψ (q.denom) / q.denom}.infinite) : _ := sorry

end measure_theory


import analysis.calculus.inverse
import analysis.calculus.cont_diff
import analysis.inner_product_space.calculus
import analysis.inner_product_space.dual

import to_mathlib.analysis.calculus
import to_mathlib.analysis.normed_space.operator_norm

noncomputable theory

open_locale topology filter
open function

section
universes u₁ u₂ u₃ u₄ u₅

open continuous_linear_map

variables {𝕜 : Type u₁} [nontrivially_normed_field 𝕜]
  {M₁ : Type u₂} [normed_add_comm_group M₁] [normed_space 𝕜 M₁]
  {M₂ : Type u₃} [normed_add_comm_group M₂] [normed_space 𝕜 M₂]
  {M₃ : Type u₄} [normed_add_comm_group M₃] [normed_space 𝕜 M₃]
  {M₄ : Type u₅} [normed_add_comm_group M₄] [normed_space 𝕜 M₄]

-- The next definition won't be used here, it's practice before the next one.

/-- Defines continuous linear maps between two products by blocks:
given `(A : M₁ →L[𝕜] M₃)`, `(B : M₂ →L[𝕜] M₃)`, `(C : M₁ →L[𝕜] M₄)` and `(D : M₂ →L[𝕜] M₄)`,
construct the continuous linear map with "matrix":
A B
C D. -/
def continuous_linear_map.blocks (A : M₁ →L[𝕜] M₃) (B : M₂ →L[𝕜] M₃)
  (C : M₁ →L[𝕜] M₄) (D : M₂ →L[𝕜] M₄) : (M₁ × M₂) →L[𝕜] (M₃ × M₄) :=
(A.coprod B).prod (C.coprod D)

/-- Given `(A : M₁ ≃L[𝕜] M₃)`, `(C : M₁ →L[𝕜] M₄)` and `(D : M₂ ≃L[𝕜] M₄)`,
construct the continuous linear equiv with "matrix"
A 0
C D.
  -/
def continuous_linear_equiv.lower_triangular (A : M₁ ≃L[𝕜] M₃)
  (C : M₁ →L[𝕜] M₄) (D : M₂ ≃L[𝕜] M₄) : (M₁ × M₂) ≃L[𝕜] (M₃ × M₄) :=
continuous_linear_equiv.equiv_of_inverse (((A : M₁ →L[𝕜] M₃).comp (fst 𝕜 M₁ M₂)).prod (C.coprod D))
(((A.symm : M₃ →L[𝕜] M₁).comp (fst 𝕜 M₃ M₄)).prod
((-((D.symm : M₄ →L[𝕜] M₂).comp C).comp (A.symm : M₃ →L[𝕜] M₁)).coprod D.symm))
(λ ⟨x, y⟩, by simp only [prod_apply, coe_comp', continuous_linear_equiv.coe_coe, coe_fst', comp_app,
           coprod_apply, continuous_linear_equiv.symm_apply_apply, neg_apply,
           continuous_linear_equiv.map_add, neg_add_cancel_left])
(λ ⟨x, y⟩, by simp only [prod_apply, coe_comp', continuous_linear_equiv.coe_coe, coe_fst', comp_app,
           coprod_apply, neg_apply, continuous_linear_equiv.apply_symm_apply,
           continuous_linear_equiv.map_add, continuous_linear_equiv.map_neg, add_neg_cancel_left])

lemma continuous_linear_equiv.continuous_lower_triangular {X : Type*} [topological_space X]
  {A : X → M₁ ≃L[𝕜] M₃} {C : X → M₁ →L[𝕜] M₄} {D : X → M₂ ≃L[𝕜] M₄}
  (hA : continuous (λ x, (A x : M₁ →L[𝕜] M₃))) (hC : continuous C)
  (hD : continuous (λ x, (D x : M₂ →L[𝕜] M₄))) :
  continuous (λ x, ((A x).lower_triangular (C x) (D x) : (M₁ × M₂) →L[𝕜] (M₃ × M₄))) :=
(hA.compL continuous_const).prodL (hC.coprodL hD)

end

section
variables (𝕜 : Type*) [nontrivially_normed_field 𝕜]
  {E : Type*} [normed_add_comm_group E] [normed_space 𝕜 E]
  {F : Type*} [normed_add_comm_group F] [normed_space 𝕜 F]
  {G : Type*} [normed_add_comm_group G] [normed_space 𝕜 G]
  {n : ℕ∞}

-- The next two definitions aren't used in the end, but they may still go to mathlib

/-- The proposition that a function between two normed spaces has a strict derivative at a given
point. -/
def strict_differentiable_at (f : E → F) (x) :=
∃ φ : E →L[𝕜] F, has_strict_fderiv_at f φ x

/-- The proposition that a function between two normed spaces has a strict derivative at every
point. -/
def strict_differentiable (f : E → F) :=
∀ x, strict_differentiable_at 𝕜 f x

variables {𝕜}

lemma strict_differentiable_at.differentiable_at {f : E → F} {x : E}
  (h : strict_differentiable_at 𝕜 f x) : differentiable_at 𝕜 f x :=
exists.elim h (λ φ hφ, ⟨φ, hφ.has_fderiv_at⟩)

-- PR to linear_algebra.prod
@[simp]
lemma linear_map.coprod_comp_inl_inr {R : Type*} {M : Type*} {M₂ : Type*} {M₃ : Type*} [semiring R]
  [add_comm_monoid M] [add_comm_monoid M₂] [add_comm_monoid M₃] [module R M]
  [module R M₂] [module R M₃] (f : M × M₂ →ₗ[R] M₃) :
  (f.comp (linear_map.inl R M M₂)).coprod (f.comp (linear_map.inr R M M₂)) = f :=
by rw [← linear_map.comp_coprod, linear_map.coprod_inl_inr, linear_map.comp_id]

-- PR to topology.algebra.module.basic
@[simp]
lemma continuous_linear_map.coprod_comp_inl_inr {R₁ : Type*} [semiring R₁] {M₁ : Type*} [topological_space M₁]
  [add_comm_monoid M₁] {M₂ : Type*} [topological_space M₂] [add_comm_monoid M₂]
  {M₃ : Type*} [topological_space M₃] [add_comm_monoid M₃] [module R₁ M₁]
  [module R₁ M₂] [module R₁ M₃] [has_continuous_add M₃] (f : M₁ × M₂ →L[R₁] M₃) :
  (f.comp (continuous_linear_map.inl R₁ M₁ M₂)).coprod (f.comp (continuous_linear_map.inr R₁ M₁ M₂)) = f :=
continuous_linear_map.coe_injective (f : M₁ × M₂ →ₗ[R₁] M₃).coprod_comp_inl_inr

lemma differentiable_at.has_fderiv_at_coprod_partial {f : E → F → G} {x : E} {y : F}
  (hf : differentiable_at 𝕜 (uncurry f) (x, y)) :
  has_fderiv_at (uncurry f)
                ((partial_fderiv_fst 𝕜 f x y).coprod (partial_fderiv_snd 𝕜 f x y)) (x, y) :=
begin
  rcases hf with ⟨θ, hθ⟩,
  rwa [fderiv_partial_fst hθ, fderiv_partial_snd hθ, θ.coprod_comp_inl_inr]
end

lemma differentiable_at.has_fderiv_at_coprod {f : E → F → G} {x : E} {y : F}
  (hf : differentiable_at 𝕜 (uncurry f) (x, y)) {φ : E →L[𝕜] G} {ψ : F →L[𝕜] G}
  (hφ : has_fderiv_at (λ p, f p y) φ x) (hψ : has_fderiv_at (f x) ψ y) :
  has_fderiv_at (uncurry f) (φ.coprod ψ) (x, y) :=
begin
  rw [hφ.unique hf.has_fderiv_at_partial_fst, hψ.unique hf.has_fderiv_at_partial_snd],
  exact hf.has_fderiv_at_coprod_partial
end

variables [complete_space E]

lemma homeomorph.cont_diff_at_symm (f : homeomorph E F) {f₀' : E ≃L[𝕜] F} {a : F}
  (hf' : has_fderiv_at f (f₀' : E →L[𝕜] F) (f.symm a)) (hf : cont_diff_at 𝕜 n f (f.symm a)) :
  cont_diff_at 𝕜 n (f.symm) a :=
f.to_local_homeomorph.cont_diff_at_symm trivial hf' hf

lemma equiv.continuous_symm_of_cont_diff (φ : E ≃ F) {Dφ : E → E ≃L[𝕜] F}
  (hφ : ∀ x, has_strict_fderiv_at φ (Dφ x : E →L[𝕜] F) x) :
  continuous φ.symm :=
begin
  rw continuous_iff_continuous_at,
  intros x,
  let y := φ.symm x,
  let g := (hφ y).local_inverse φ (Dφ y) y,
  rw ← φ.apply_symm_apply x,
  have ev_eq : g =ᶠ[𝓝 (φ y)] φ.symm,
  { apply (hφ y).eventually_right_inverse.mono,
    rintros x (hx : φ (g x) = x),
    exact (equiv.eq_symm_apply φ).mpr hx },
  apply continuous_at.congr _ ev_eq,
  apply (hφ y).local_inverse_continuous_at
end

/-- A bijection that is strictly differentiable at every point is a homeomorphism. -/
def equiv.to_homeomorph_of_cont_diff (φ : E ≃ F) {Dφ : E → E ≃L[𝕜] F}
  (hφ : ∀ x, has_strict_fderiv_at φ (Dφ x : E →L[𝕜] F) x) : E ≃ₜ F :=
{ continuous_to_fun := differentiable.continuous (λ x, (hφ x).differentiable_at),
  continuous_inv_fun := φ.continuous_symm_of_cont_diff hφ,
  ..φ}

end

section
variables {𝕜 : Type*} [is_R_or_C 𝕜]
  {E : Type*} [normed_add_comm_group E] [normed_space 𝕜 E]
  {F : Type*} [normed_add_comm_group F] [normed_space 𝕜 F]
  {G : Type*} [normed_add_comm_group G] [normed_space 𝕜 G]
  {n : ℕ∞}

local notation `∂₁` := partial_fderiv_fst 𝕜
local notation `∂₂` := partial_fderiv_snd 𝕜

lemma cont_diff_parametric_symm [complete_space E] [complete_space F]
  {f : E → F ≃ G} {f' : E → F → F ≃L[𝕜] G}
  (hf : cont_diff 𝕜 ⊤ (λ p : E × F, f p.1 p.2))
  (hf' : ∀ x y, ∂₂ (λ x y, f x y) x y = f' x y) :
  cont_diff 𝕜 ⊤ (λ p : E × G, (f p.1).symm p.2) :=
begin
  let φ₀ : (E × F) ≃ (E × G) :=
  { to_fun := λ p : E × F, (p.1, f p.1 p.2),
    inv_fun := λ p : E × G, (p.1, (f p.1).symm p.2),
    left_inv := λ x, by simp,
    right_inv := λ x, by simp },
  let ff := λ x y, f x y,
  have hff : cont_diff 𝕜 ⊤ (uncurry ff) := hf,
  let d₁f := ∂₁ ff,
  let Dφ : E × F → (E × F) ≃L[𝕜] E × G :=
    λ x, (continuous_linear_equiv.refl 𝕜 E).lower_triangular (d₁f x.1 x.2) (f' x.1 x.2),
  let Dφ' : E × F → (E × F) →L[𝕜] E × G := λ x, Dφ x,
  have hderiv : ∀ (x : E × F), has_strict_fderiv_at φ₀ (Dφ' x) x,
  { rintros p,
    apply has_strict_fderiv_at_of_has_fderiv_at_of_continuous_at,
    { apply filter.eventually_of_forall,
      rintros ⟨x, y⟩,
      apply has_fderiv_at.prod,
      { simp only [continuous_linear_equiv.coe_refl, continuous_linear_map.id_comp,
        has_fderiv_at_fst] },
      have diff : differentiable 𝕜 (uncurry $ λ x y, f x y) := hf.differentiable le_top,
      rw show (λ (x : E × F), (f x.fst) x.snd) = uncurry (λ x y, f x y), by { ext, refl },
      apply differentiable_at.has_fderiv_at_coprod,
      { apply (hf.differentiable le_top) },
      { dsimp [d₁f],
        exact diff.differentiable_at.has_fderiv_at_partial_fst },
      { rw ← hf' x y,
        dsimp,
        exact diff.differentiable_at.has_fderiv_at_partial_snd } },
    { apply continuous.continuous_at,
      apply continuous_linear_equiv.continuous_lower_triangular,
      { exact continuous_const },
      { exact hff.cont_diff_top_partial_fst.continuous },
      { simp_rw ← hf',
        exact hff.cont_diff_top_partial_snd.continuous } } },
  let φ := φ₀.to_homeomorph_of_cont_diff hderiv,
  exact cont_diff_snd.comp (φ.cont_diff_symm (λ x, (hderiv x).has_fderiv_at)
    (cont_diff_fst.prod hf)),
end

end

section
variables {E : Type*} [normed_add_comm_group E] [normed_space ℝ E] [complete_space E]

lemma cont_diff_parametric_symm_of_deriv_pos {f : E → ℝ → ℝ} (hf : cont_diff ℝ ⊤ ↿f)
  (hderiv : ∀ x t, 0 < partial_deriv_snd f x t) (hsurj : ∀ x, surjective $ f x) :
  cont_diff ℝ ⊤  (λ p : E × ℝ, (strict_mono.order_iso_of_surjective (f p.1)
                                (strict_mono_of_deriv_pos $ hderiv p.1) (hsurj p.1)).symm p.2) :=
begin
  have hmono := λ x, strict_mono_of_deriv_pos (hderiv x),
  let F := λ x, (strict_mono.order_iso_of_surjective (f x) (hmono x) $ hsurj x).to_equiv,
  change cont_diff ℝ ⊤ (λ (p : E × ℝ), (F p.1).symm p.snd),
  refine cont_diff_parametric_symm hf _,
  exact λ x t, continuous_linear_equiv.units_equiv_aut ℝ (units.mk0 (deriv (f x) t) $ ne_of_gt (hderiv x t)) ,
  intros x t,
  suffices : partial_fderiv_snd ℝ f x t 1 = partial_deriv_snd f x t,
  { ext v,
    simpa only [rel_iso.coe_fn_to_equiv, continuous_linear_equiv.coe_coe,
      continuous_linear_equiv.units_equiv_aut_apply, units.coe_mk0, one_mul] },
  apply partial_fderiv_snd_one
end

end

section
variables (𝕜 : Type*) [nontrivially_normed_field 𝕜]

lemma cont_diff_to_span_singleton (E : Type*) [normed_add_comm_group E] [normed_space 𝕜 E] :
  cont_diff 𝕜 ⊤ (continuous_linear_map.to_span_singleton 𝕜 : E → 𝕜 →L[𝕜] E) :=
(continuous_linear_map.lsmul 𝕜 𝕜 : 𝕜 →L[𝕜] E →L[𝕜] E).flip.cont_diff

end

section
variables {𝕜 : Type*} [is_R_or_C 𝕜]
variables {E : Type*} [normed_add_comm_group E] [inner_product_space 𝕜 E] [complete_space E]

-- variant of `orthogonal_projection_singleton`
lemma orthogonal_projection_singleton' {v : E} :
  (𝕜 ∙ v).subtypeL.comp (orthogonal_projection (𝕜 ∙ v))
  = (1 / ‖v‖ ^ 2 : 𝕜) • (continuous_linear_map.to_span_singleton 𝕜 v)
    ∘L inner_product_space.to_dual 𝕜 E v :=
begin
  ext w,
  simp [continuous_linear_map.to_span_singleton_apply, orthogonal_projection_singleton, ← mul_smul],
  congr' 1,
  field_simp,
end

end

section
variables {E : Type*} [normed_add_comm_group E] [inner_product_space ℝ E] [complete_space E]

/-- The orthogonal projection onto a vector in a real inner product space `E`, considered as a map
from `E` to `E →L[ℝ] E`, is smooth away from 0. -/
lemma cont_diff_at_orthogonal_projection_singleton {v₀ : E} (hv₀ : v₀ ≠ 0) :
  cont_diff_at ℝ ⊤ (λ v : E, (ℝ ∙ v).subtypeL.comp (orthogonal_projection (ℝ ∙ v))) v₀ :=
begin
  suffices :  cont_diff_at ℝ ⊤
    (λ v : E, (1 / ‖v‖ ^ 2) • continuous_linear_map.to_span_singleton ℝ v
    ∘L inner_product_space.to_dual ℝ E v) v₀,
  { refine this.congr_of_eventually_eq _,
    refine filter.eventually_of_forall (λ v, _),
    dsimp,
    rw orthogonal_projection_singleton',
    refl },
  refine cont_diff_at.smul _ _,
  { refine cont_diff_at_const.div (cont_diff_norm_sq ℝ).cont_diff_at _,
    apply pow_ne_zero,
    exact norm_ne_zero_iff.mpr hv₀ },
  exact (cont_diff.clm_comp (cont_diff_to_span_singleton ℝ E)
    (inner_product_space.to_dual ℝ E).cont_diff).cont_diff_at,
end

end

section arithmetic

variables {𝕜 : Type*} [nontrivially_normed_field 𝕜]
  {E : Type*} [normed_add_comm_group E] [normed_space 𝕜 E]
  {𝔸 : Type*} [normed_ring 𝔸] [normed_algebra 𝕜 𝔸]
  {n : ℕ∞} {f : E → 𝔸} {s : set E} {x : E}

lemma cont_diff_within_at.mul_const (hf : cont_diff_within_at 𝕜 n f s x) {c : 𝔸} :
  cont_diff_within_at 𝕜 n (λ (x : E), f x * c) s x :=
hf.mul cont_diff_within_at_const

theorem cont_diff_at.mul_const (hf : cont_diff_at 𝕜 n f x) {c : 𝔸} :
  cont_diff_at 𝕜 n (λ (x : E), f x * c) x :=
hf.mul cont_diff_at_const

theorem cont_diff_on.mul_const (hf : cont_diff_on 𝕜 n f s) {c : 𝔸} :
  cont_diff_on 𝕜 n (λ (x : E), f x * c) s :=
hf.mul cont_diff_on_const

theorem cont_diff.mul_const (hf : cont_diff 𝕜 n f) {c : 𝔸} :
  cont_diff 𝕜 n (λ (x : E), f x * c) :=
hf.mul cont_diff_const

end arithmetic


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

! This file was ported from Lean 3 source module data.multiset.dedup
! leanprover-community/mathlib commit 9003f28797c0664a49e4179487267c494477d853
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Data.Multiset.Nodup

/-!
# Erasing duplicates in a multiset.
-/

namespace Multiset

open List

variable {α β : Type _} [DecidableEq α]

/-! ### dedup -/

/-- `dedup s` removes duplicates from `s`, yielding a `nodup` multiset. -/
def dedup (s : Multiset α) : Multiset α :=
  Quot.liftOn s (fun l => (l.dedup : Multiset α)) fun _ _ p => Quot.sound p.dedup
#align multiset.dedup Multiset.dedup

@[simp]
theorem coe_dedup (l : List α) : @dedup α _ l = l.dedup :=
  rfl
#align multiset.coe_dedup Multiset.coe_dedup

@[simp]
theorem dedup_zero : @dedup α _ 0 = 0 :=
  rfl
#align multiset.dedup_zero Multiset.dedup_zero

@[simp]
theorem mem_dedup {a : α} {s : Multiset α} : a ∈ dedup s ↔ a ∈ s :=
  Quot.induction_on s fun _ => List.mem_dedup
#align multiset.mem_dedup Multiset.mem_dedup

@[simp]
theorem dedup_cons_of_mem {a : α} {s : Multiset α} : a ∈ s → dedup (a ::ₘ s) = dedup s :=
  Quot.induction_on s fun _ m => @congr_arg _ _ _ _ ofList <| List.dedup_cons_of_mem m
#align multiset.dedup_cons_of_mem Multiset.dedup_cons_of_mem

@[simp]
theorem dedup_cons_of_not_mem {a : α} {s : Multiset α} : a ∉ s → dedup (a ::ₘ s) = a ::ₘ dedup s :=
  Quot.induction_on s fun _ m => congr_arg ofList <| List.dedup_cons_of_not_mem m
#align multiset.dedup_cons_of_not_mem Multiset.dedup_cons_of_not_mem

theorem dedup_le (s : Multiset α) : dedup s ≤ s :=
  Quot.induction_on s fun _ => (dedup_sublist _).subperm
#align multiset.dedup_le Multiset.dedup_le

theorem dedup_subset (s : Multiset α) : dedup s ⊆ s :=
  subset_of_le <| dedup_le _
#align multiset.dedup_subset Multiset.dedup_subset

theorem subset_dedup (s : Multiset α) : s ⊆ dedup s := fun _ => mem_dedup.2
#align multiset.subset_dedup Multiset.subset_dedup

@[simp]
theorem dedup_subset' {s t : Multiset α} : dedup s ⊆ t ↔ s ⊆ t :=
  ⟨Subset.trans (subset_dedup _), Subset.trans (dedup_subset _)⟩
#align multiset.dedup_subset' Multiset.dedup_subset'

@[simp]
theorem subset_dedup' {s t : Multiset α} : s ⊆ dedup t ↔ s ⊆ t :=
  ⟨fun h => Subset.trans h (dedup_subset _), fun h => Subset.trans h (subset_dedup _)⟩
#align multiset.subset_dedup' Multiset.subset_dedup'

@[simp]
theorem nodup_dedup (s : Multiset α) : Nodup (dedup s) :=
  Quot.induction_on s List.nodup_dedup
#align multiset.nodup_dedup Multiset.nodup_dedup

theorem dedup_eq_self {s : Multiset α} : dedup s = s ↔ Nodup s :=
  ⟨fun e => e ▸ nodup_dedup s, Quot.induction_on s fun _ h => congr_arg ofList h.dedup⟩
#align multiset.dedup_eq_self Multiset.dedup_eq_self

alias dedup_eq_self ↔ _ Nodup.dedup
#align multiset.nodup.dedup Multiset.Nodup.dedup

theorem count_dedup (m : Multiset α) (a : α) : m.dedup.count a = if a ∈ m then 1 else 0 :=
  Quot.induction_on m fun _ => by
    simp only [quot_mk_to_coe'', coe_dedup, mem_coe, List.mem_dedup, coe_nodup, coe_count]
    apply List.count_dedup _ _
#align multiset.count_dedup Multiset.count_dedup

@[simp]
theorem dedup_idempotent {m : Multiset α} : m.dedup.dedup = m.dedup :=
  Quot.induction_on m fun _ => @congr_arg _ _ _ _ ofList List.dedup_idempotent
#align multiset.dedup_idempotent Multiset.dedup_idempotent

@[simp]
theorem dedup_bind_dedup [DecidableEq β] (m : Multiset α) (f : α → Multiset β) :
    (m.dedup.bind f).dedup = (m.bind f).dedup := by
  ext x
  -- Porting note: was `simp_rw [count_dedup, mem_bind, mem_dedup]`
  simp_rw [count_dedup]
  refine if_congr ?_ rfl rfl
  simp
#align multiset.dedup_bind_dedup Multiset.dedup_bind_dedup

theorem dedup_eq_zero {s : Multiset α} : dedup s = 0 ↔ s = 0 :=
  ⟨fun h => eq_zero_of_subset_zero <| h ▸ subset_dedup _, fun h => h.symm ▸ dedup_zero⟩
#align multiset.dedup_eq_zero Multiset.dedup_eq_zero

@[simp]
theorem dedup_singleton {a : α} : dedup ({a} : Multiset α) = {a} :=
  (nodup_singleton _).dedup
#align multiset.dedup_singleton Multiset.dedup_singleton

theorem le_dedup {s t : Multiset α} : s ≤ dedup t ↔ s ≤ t ∧ Nodup s :=
  ⟨fun h => ⟨le_trans h (dedup_le _), nodup_of_le h (nodup_dedup _)⟩,
   fun ⟨l, d⟩ => (le_iff_subset d).2 <| Subset.trans (subset_of_le l) (subset_dedup _)⟩
#align multiset.le_dedup Multiset.le_dedup

theorem le_dedup_self {s : Multiset α} : s ≤ dedup s ↔ Nodup s := by
  rw [le_dedup, and_iff_right le_rfl]
#align multiset.le_dedup_self Multiset.le_dedup_self

theorem dedup_ext {s t : Multiset α} : dedup s = dedup t ↔ ∀ a, a ∈ s ↔ a ∈ t := by
  simp [Nodup.ext]
#align multiset.dedup_ext Multiset.dedup_ext

theorem dedup_map_dedup_eq [DecidableEq β] (f : α → β) (s : Multiset α) :
    dedup (map f (dedup s)) = dedup (map f s) := by
  simp [dedup_ext]
#align multiset.dedup_map_dedup_eq Multiset.dedup_map_dedup_eq

@[simp]
theorem dedup_nsmul {s : Multiset α} {n : ℕ} (h0 : n ≠ 0) : (n • s).dedup = s.dedup := by
  ext a
  by_cases h : a ∈ s <;> simp [h, h0]
#align multiset.dedup_nsmul Multiset.dedup_nsmul

theorem Nodup.le_dedup_iff_le {s t : Multiset α} (hno : s.Nodup) : s ≤ t.dedup ↔ s ≤ t := by
  simp [le_dedup, hno]
#align multiset.nodup.le_dedup_iff_le Multiset.Nodup.le_dedup_iff_le

end Multiset

theorem Multiset.Nodup.le_nsmul_iff_le {α : Type _} {s t : Multiset α} {n : ℕ} (h : s.Nodup)
    (hn : n ≠ 0) : s ≤ n • t ↔ s ≤ t := by
  classical
    rw [← h.le_dedup_iff_le, Iff.comm, ← h.le_dedup_iff_le]
    simp [hn]
#align multiset.nodup.le_nsmul_iff_le Multiset.Nodup.le_nsmul_iff_le


/-
Copyright (c) 2021 Andrew Yang. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Andrew Yang

! This file was ported from Lean 3 source module category_theory.sites.cover_preserving
! leanprover-community/mathlib commit e2e38c005fc6f715502490da6cb0ec84df9ed228
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.CategoryTheory.Sites.Limits
import Mathbin.CategoryTheory.Functor.Flat
import Mathbin.CategoryTheory.Limits.Preserves.Filtered

/-!
# Cover-preserving functors between sites.

We define cover-preserving functors between sites as functors that push covering sieves to
covering sieves. A cover-preserving and compatible-preserving functor `G : C ⥤ D` then pulls
sheaves on `D` back to sheaves on `C` via `G.op ⋙ -`.

## Main definitions

* `category_theory.cover_preserving`: a functor between sites is cover-preserving if it
pushes covering sieves to covering sieves
* `category_theory.compatible_preserving`: a functor between sites is compatible-preserving
if it pushes compatible families of elements to compatible families.
* `category_theory.pullback_sheaf`: the pullback of a sheaf along a cover-preserving and
compatible-preserving functor.
* `category_theory.sites.pullback`: the induced functor `Sheaf K A ⥤ Sheaf J A` for a
cover-preserving and compatible-preserving functor `G : (C, J) ⥤ (D, K)`.

## Main results

- `category_theory.sites.whiskering_left_is_sheaf_of_cover_preserving`: If `G : C ⥤ D` is
cover-preserving and compatible-preserving, then `G ⋙ -` (`uᵖ`) as a functor
`(Dᵒᵖ ⥤ A) ⥤ (Cᵒᵖ ⥤ A)` of presheaves maps sheaves to sheaves.

## References

* [Elephant]: *Sketches of an Elephant*, P. T. Johnstone: C2.3.
* https://stacks.math.columbia.edu/tag/00WW

-/

universe w v₁ v₂ v₃ u₁ u₂ u₃

noncomputable section

open CategoryTheory

open Opposite

open CategoryTheory.Presieve.FamilyOfElements

open CategoryTheory.Presieve

open CategoryTheory.Limits

namespace CategoryTheory

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

variable {A : Type u₃} [Category.{v₃} A]

variable (J : GrothendieckTopology C) (K : GrothendieckTopology D)

variable {L : GrothendieckTopology A}

/-- A functor `G : (C, J) ⥤ (D, K)` between sites is *cover-preserving*
if for all covering sieves `R` in `C`, `R.pushforward_functor G` is a covering sieve in `D`.
-/
@[nolint has_nonempty_instance]
structure CoverPreserving (G : C ⥤ D) : Prop where
  cover_preserve : ∀ {U : C} {S : Sieve U} (hS : S ∈ J U), S.functorPushforward G ∈ K (G.obj U)
#align category_theory.cover_preserving CategoryTheory.CoverPreserving

/-- The identity functor on a site is cover-preserving. -/
theorem idCoverPreserving : CoverPreserving J J (𝟭 _) :=
  ⟨fun U S hS => by simpa using hS⟩
#align category_theory.id_cover_preserving CategoryTheory.idCoverPreserving

variable (J) (K)

/-- The composition of two cover-preserving functors is cover-preserving. -/
theorem CoverPreserving.comp {F} (hF : CoverPreserving J K F) {G} (hG : CoverPreserving K L G) :
    CoverPreserving J L (F ⋙ G) :=
  ⟨fun U S hS => by
    rw [sieve.functor_pushforward_comp]
    exact hG.cover_preserve (hF.cover_preserve hS)⟩
#align category_theory.cover_preserving.comp CategoryTheory.CoverPreserving.comp

/-- A functor `G : (C, J) ⥤ (D, K)` between sites is called compatible preserving if for each
compatible family of elements at `C` and valued in `G.op ⋙ ℱ`, and each commuting diagram
`f₁ ≫ G.map g₁ = f₂ ≫ G.map g₂`, `x g₁` and `x g₂` coincide when restricted via `fᵢ`.
This is actually stronger than merely preserving compatible families because of the definition of
`functor_pushforward` used.
-/
@[nolint has_nonempty_instance]
structure CompatiblePreserving (K : GrothendieckTopology D) (G : C ⥤ D) : Prop where
  Compatible :
    ∀ (ℱ : SheafOfTypes.{w} K) {Z} {T : Presieve Z} {x : FamilyOfElements (G.op ⋙ ℱ.val) T}
      (h : x.Compatible) {Y₁ Y₂} {X} (f₁ : X ⟶ G.obj Y₁) (f₂ : X ⟶ G.obj Y₂) {g₁ : Y₁ ⟶ Z}
      {g₂ : Y₂ ⟶ Z} (hg₁ : T g₁) (hg₂ : T g₂) (eq : f₁ ≫ G.map g₁ = f₂ ≫ G.map g₂),
      ℱ.val.map f₁.op (x g₁ hg₁) = ℱ.val.map f₂.op (x g₂ hg₂)
#align category_theory.compatible_preserving CategoryTheory.CompatiblePreserving

variable {J K} {G : C ⥤ D} (hG : CompatiblePreserving.{w} K G) (ℱ : SheafOfTypes.{w} K) {Z : C}

variable {T : Presieve Z} {x : FamilyOfElements (G.op ⋙ ℱ.val) T} (h : x.Compatible)

include h hG

/-- `compatible_preserving` functors indeed preserve compatible families. -/
theorem Presieve.FamilyOfElements.Compatible.functorPushforward :
    (x.functorPushforward G).Compatible :=
  by
  rintro Z₁ Z₂ W g₁ g₂ f₁' f₂' H₁ H₂ eq
  unfold family_of_elements.functor_pushforward
  rcases get_functor_pushforward_structure H₁ with ⟨X₁, f₁, h₁, hf₁, rfl⟩
  rcases get_functor_pushforward_structure H₂ with ⟨X₂, f₂, h₂, hf₂, rfl⟩
  suffices : ℱ.val.map (g₁ ≫ h₁).op (x f₁ hf₁) = ℱ.val.map (g₂ ≫ h₂).op (x f₂ hf₂)
  simpa using this
  apply hG.compatible ℱ h _ _ hf₁ hf₂
  simpa using Eq
#align category_theory.presieve.family_of_elements.compatible.functor_pushforward CategoryTheory.Presieve.FamilyOfElements.Compatible.functorPushforward

@[simp]
theorem CompatiblePreserving.apply_map {Y : C} {f : Y ⟶ Z} (hf : T f) :
    x.functorPushforward G (G.map f) (image_mem_functorPushforward G T hf) = x f hf :=
  by
  unfold family_of_elements.functor_pushforward
  rcases e₁ : get_functor_pushforward_structure (image_mem_functor_pushforward G T hf) with
    ⟨X, g, f', hg, eq⟩
  simpa using hG.compatible ℱ h f' (𝟙 _) hg hf (by simp [Eq])
#align category_theory.compatible_preserving.apply_map CategoryTheory.CompatiblePreserving.apply_map

omit h hG

open Limits.WalkingCospan

theorem compatiblePreservingOfFlat {C : Type u₁} [Category.{v₁} C] {D : Type u₁} [Category.{v₁} D]
    (K : GrothendieckTopology D) (G : C ⥤ D) [RepresentablyFlat G] : CompatiblePreserving K G :=
  by
  constructor
  intro ℱ Z T x hx Y₁ Y₂ X f₁ f₂ g₁ g₂ hg₁ hg₂ e
  -- First, `f₁` and `f₂` form a cone over `cospan g₁ g₂ ⋙ u`.
  let c : cone (cospan g₁ g₂ ⋙ G) :=
    (cones.postcompose (diagram_iso_cospan (cospan g₁ g₂ ⋙ G)).inv).obj (pullback_cone.mk f₁ f₂ e)
  /-
    This can then be viewed as a cospan of structured arrows, and we may obtain an arbitrary cone
    over it since `structured_arrow W u` is cofiltered.
    Then, it suffices to prove that it is compatible when restricted onto `u(c'.X.right)`.
    -/
  let c' := is_cofiltered.cone (structured_arrow_cone.to_diagram c ⋙ structured_arrow.pre _ _ _)
  have eq₁ : f₁ = (c'.X.hom ≫ G.map (c'.π.app left).right) ≫ eq_to_hom (by simp) :=
    by
    erw [← (c'.π.app left).w]
    dsimp
    simp
  have eq₂ : f₂ = (c'.X.hom ≫ G.map (c'.π.app right).right) ≫ eq_to_hom (by simp) :=
    by
    erw [← (c'.π.app right).w]
    dsimp
    simp
  conv_lhs => rw [eq₁]
  conv_rhs => rw [eq₂]
  simp only [op_comp, functor.map_comp, types_comp_apply, eq_to_hom_op, eq_to_hom_map]
  congr 1
  /-
    Since everything now falls in the image of `u`,
    the result follows from the compatibility of `x` in the image of `u`.
    -/
  injection c'.π.naturality walking_cospan.hom.inl with _ e₁
  injection c'.π.naturality walking_cospan.hom.inr with _ e₂
  exact hx (c'.π.app left).right (c'.π.app right).right hg₁ hg₂ (e₁.symm.trans e₂)
#align category_theory.compatible_preserving_of_flat CategoryTheory.compatiblePreservingOfFlat

theorem compatiblePreservingOfDownwardsClosed (F : C ⥤ D) [Full F] [Faithful F]
    (hF : ∀ {c : C} {d : D} (f : d ⟶ F.obj c), Σc', F.obj c' ≅ d) : CompatiblePreserving K F :=
  by
  constructor
  introv hx he
  obtain ⟨X', e⟩ := hF f₁
  apply (ℱ.1.mapIso e.op).toEquiv.Injective
  simp only [iso.op_hom, iso.to_equiv_fun, ℱ.1.mapIso_hom, ← functor_to_types.map_comp_apply]
  simpa using
    hx (F.preimage <| e.hom ≫ f₁) (F.preimage <| e.hom ≫ f₂) hg₁ hg₂
      (F.map_injective <| by simpa using he)
#align category_theory.compatible_preserving_of_downwards_closed CategoryTheory.compatiblePreservingOfDownwardsClosed

/-- If `G` is cover-preserving and compatible-preserving,
then `G.op ⋙ _` pulls sheaves back to sheaves.

This result is basically <https://stacks.math.columbia.edu/tag/00WW>.
-/
theorem pullback_isSheaf_of_coverPreserving {G : C ⥤ D} (hG₁ : CompatiblePreserving.{v₃} K G)
    (hG₂ : CoverPreserving J K G) (ℱ : Sheaf K A) : Presheaf.IsSheaf J (G.op ⋙ ℱ.val) :=
  by
  intro X U S hS x hx
  change family_of_elements (G.op ⋙ ℱ.val ⋙ coyoneda.obj (op X)) _ at x
  let H := ℱ.2 X _ (hG₂.cover_preserve hS)
  let hx' := hx.functor_pushforward hG₁ (sheaf_over ℱ X)
  constructor; swap
  · apply H.amalgamate (x.functor_pushforward G)
    exact hx'
  constructor
  · intro V f hf
    convert H.is_amalgamation hx' (G.map f) (image_mem_functor_pushforward G S hf)
    rw [hG₁.apply_map (sheaf_over ℱ X) hx]
  · intro y hy
    refine'
      H.is_separated_for _ y _ _ (H.is_amalgamation (hx.functor_pushforward hG₁ (sheaf_over ℱ X)))
    rintro V f ⟨Z, f', g', h, rfl⟩
    erw [family_of_elements.comp_of_compatible (S.functor_pushforward G) hx'
        (image_mem_functor_pushforward G S h) g']
    dsimp
    simp [hG₁.apply_map (sheaf_over ℱ X) hx h, ← hy f' h]
#align category_theory.pullback_is_sheaf_of_cover_preserving CategoryTheory.pullback_isSheaf_of_coverPreserving

/-- The pullback of a sheaf along a cover-preserving and compatible-preserving functor. -/
def pullbackSheaf {G : C ⥤ D} (hG₁ : CompatiblePreserving K G) (hG₂ : CoverPreserving J K G)
    (ℱ : Sheaf K A) : Sheaf J A :=
  ⟨G.op ⋙ ℱ.val, pullback_isSheaf_of_coverPreserving hG₁ hG₂ ℱ⟩
#align category_theory.pullback_sheaf CategoryTheory.pullbackSheaf

variable (A)

/-- The induced functor from `Sheaf K A ⥤ Sheaf J A` given by `G.op ⋙ _`
if `G` is cover-preserving and compatible-preserving.
-/
@[simps]
def Sites.pullback {G : C ⥤ D} (hG₁ : CompatiblePreserving K G) (hG₂ : CoverPreserving J K G) :
    Sheaf K A ⥤ Sheaf J A where
  obj ℱ := pullbackSheaf hG₁ hG₂ ℱ
  map _ _ f := ⟨((whiskeringLeft _ _ _).obj G.op).map f.val⟩
  map_id' ℱ := by
    ext1
    apply ((whiskering_left _ _ _).obj G.op).map_id
  map_comp' _ _ _ f g := by
    ext1
    apply ((whiskering_left _ _ _).obj G.op).map_comp
#align category_theory.sites.pullback CategoryTheory.Sites.pullback

end CategoryTheory


import Architectural.ArchWithContracts
import Architectural.ArchitectureDecomp
import tactic

variables {Φ Var : Type} [fintype Var] [decidable_eq Var] [AssertionLang Φ Var]

@[reducible]
def list_conj : list Φ → Φ
| [] := ⊤
| (h::t) := AssertionLang.conj Var (h) (list_conj t)

theorem list_conj_iff (l : list Φ) (σ : Trace Var) : (σ ∈ (@AssertionLang.sem Φ Var _ _ _ (@list_conj Φ Var _ _ _ l))) ↔ (∀ φ ∈ l, σ ∈ (@AssertionLang.sem Φ Var _ _ _ φ)) :=
begin
  split,
  intro H1,
  intros φ H2,
  induction l with hd tl IH,
  exfalso, assumption,
  cases H2,rw H2,
  unfold list_conj at H1,
  rw AssertionLang.conj_def at H1,
  cases H1 with H11 H22, exact H11,
  apply IH,
  unfold list_conj at H1,
  rw AssertionLang.conj_def at H1,
  exact H1.2, assumption,

  intros H,
  induction l with hd tl IH,
  unfold list_conj, rw AssertionLang.T_def, simp,
  obtain H1 := H hd,
  unfold list_conj,
  rw AssertionLang.conj_def,
  split,
  apply H1,
  simp,
  apply IH,
  intros φ H',
  have : φ ∈ hd::tl, from list.mem_cons_of_mem hd H',
  cases this,
  rw this, apply H, exact list.mem_cons_self hd tl,
  apply H φ, exact list.mem_cons_of_mem hd H',
end

@[reducible]
def get_nfs {S : Component Var} (A : ArchitectureWithContracts Φ S) : list Φ :=
  (A.subs.map (λ C, (A.contracts.find_val C).iget)).map (λ C, C.nf)

def RPO_fst {S : Component Var} (A : ArchitectureWithContracts Φ S): Prop :=
  ∀ σ , σ ∈ (@AssertionLang.sem Φ Var _ _ _  (@AssertionLang.Impl Φ Var _ _ _ (@list_conj Φ Var _ _ _ (get_nfs A)) (A.parent.nf)))

def RPO_snd {S : Component Var}  (A : ArchitectureWithContracts Φ S) : Prop :=
  ∀ S' ∈ A.subs,
  ∀ σ, σ ∈ (@AssertionLang.sem Φ Var _ _ _
  (@AssertionLang.Impl Φ Var _ _ _
  (AssertionLang.conj Var A.parent.A (@list_conj Φ Var _ _ _ (list.map (λ C : Component Var,  (A.contracts.find_val C).iget.nf) (A.subs.erase S')))) (A.contracts.find_val S').iget.A)
  )

def RPO {S : Component Var}  (A : ArchitectureWithContracts Φ S) : Prop := RPO_fst A ∧ RPO_snd A

variables S : Component Var

variables IMPLEMENTATIONS : Π (U : Component Var),  Impl Var

variable CURRENT_ENVIRONMENT : Env Var

def isCorrectImplementation (C : Component Var) (I : Impl Var) (Ctr : Contract Φ Var) : Claim (Trace Var) :=
{
  X := I,
  P := λ σ, σ ∈ (@AssertionLang.sem Φ Var _ _ _ Ctr.A) → σ ∈
                (@AssertionLang.sem Φ Var _ _ _ Ctr.G)
}

def isGoodEnv (E : Env Var) (C : Contract Φ Var) : Claim (Trace Var) :=
{
  X := E,
  P := λ s, s ∈ (@AssertionLang.sem Φ Var _ _ _ C.A)
}

namespace Contract

def to_arch_components
{S : Component Var}
 (A : ArchitectureWithContracts Φ S)
(IMPLEMENTATIONS : Implementations A.to_Architecture) :
Π (a : Component Var), (λ (C : Component Var), C ∈ A.to_Architecture.subs) a → Claim (Trace Var) :=
λ a h, isCorrectImplementation a  (IMPLEMENTATIONS a h) (A.contracts.find_val a).iget

def strategy
 {S : Component Var}
 (A : ArchitectureWithContracts Φ S)
 (Is : Implementations A.to_Architecture)
 (CURRENT_ENVIRONMENT : Env Var) : Strategy (Trace Var) :=
{ parent := Claim.correctDecomposition A Is CURRENT_ENVIRONMENT,
  decomp := λ _,
  (@list.pmap (Component Var) (Claim (Trace Var)) (λ C, C ∈ A.subs)
  (λ a h, isCorrectImplementation a (Is a h) (A.contracts.find_val a).iget) A.subs (by {simp,}))++[isGoodEnv CURRENT_ENVIRONMENT A.parent]

}

def mk_strategy {S : Component Var}
 (A : ArchitectureWithContracts Φ S) : Strategy (Trace Var) := Contract.strategy A (λ e h, set.univ) (set.univ)

def strat_is_deductive
{S : Component Var}
(A : ArchitectureWithContracts Φ S) : Prop := ∀ Is : Implementations A.to_Architecture, ∀ E : Env Var,
deductive (Trace Var) (Contract.strategy A Is E)

end Contract

lemma subclaims_meaning_env
 {S : Component Var}
 (A : ArchitectureWithContracts Φ S)
 (IMPLEMENTATIONS : Implementations A.to_Architecture)
 (CURRENT_ENVIRONMENT : Env Var)
 :
  (∀ clm ∈ (Contract.strategy A IMPLEMENTATIONS CURRENT_ENVIRONMENT).subclaims, ⟦clm⟧) →
 ⟦isGoodEnv CURRENT_ENVIRONMENT A.parent⟧ :=
begin
 intros H₁,
 replace H₁ := H₁ (isGoodEnv CURRENT_ENVIRONMENT A.parent),
 rw Contract.strategy at H₁, rw Strategy.subclaims at H₁,
  simp at H₁,
  exact H₁,
end

lemma subclaims_meaning_impl
 {S : Component Var}
 (A : ArchitectureWithContracts Φ S)
 (IMPLEMENTATIONS : Implementations A.to_Architecture)
 (CURRENT_ENVIRONMENT : Env Var):
  (∀ clm ∈ (Contract.strategy A IMPLEMENTATIONS CURRENT_ENVIRONMENT).subclaims, ⟦clm⟧) →
 ∀ C ∈ A.subs, ⟦isCorrectImplementation C (IMPLEMENTATIONS C H) (A.contracts.find_val C).iget⟧ :=
begin
 intros H₁,
 rw Contract.strategy at H₁, rw Strategy.subclaims at H₁,
 simp at H₁,
 intros C mem,
 replace H₁ := H₁ (isCorrectImplementation C (IMPLEMENTATIONS C mem) (Map.find_val C A.contracts).iget),
 apply H₁,
 clear H₁,
 left, use C,
 split, refl, assumption,
end

lemma subclaims_meaning
  {S : Component Var}
 (A : ArchitectureWithContracts Φ S)
 (IMPLEMENTATIONS : Implementations A.to_Architecture)
 (CURRENT_ENVIRONMENT : Env Var) :
  (∀ clm ∈ (Contract.strategy A IMPLEMENTATIONS CURRENT_ENVIRONMENT).subclaims, ⟦clm⟧) →
  ⟦isGoodEnv CURRENT_ENVIRONMENT A.parent⟧ ∧
 ∀ C ∈ A.subs, ⟦isCorrectImplementation C (IMPLEMENTATIONS C H) (A.contracts.find_val C).iget⟧ :=
begin
  intros H₁,
  split, apply subclaims_meaning_env, assumption,
  apply subclaims_meaning_impl, assumption,
end

-- theorem validity : deductive (Trace PORTS) (Contract.strategy IMPLEMENTATIONS CURRENT_ENVIRONMENT) :=
-- begin
--   intro H,
--   replace H := subclaims_meaning _ _ H,
--   cases H with Henv Himpl,
--   rw Contract.strategy,
--   simp,
--   rw Claim.correctDecomposition,
--   rw meaning,
--   simp,
--   intros σ,
--   split, {
--     rw Claim.correctDecompositionImpl,
--     intros H₁ H₂,
--     rw CI at H₂,
--     simp at H₂,
--     sorry
--   }
-- end

-- def LACU_ARCH_WITH_CONTRACTS : ArchitectureWithContracts lt_eq_assertions LACU :=

theorem via_rpo
{S : Component Var}
{A : ArchitectureWithContracts Φ S}
(E :  Env Var)
(Is :Implementations A.to_Architecture)
: RPO A → deductive (Trace Var) (Contract.strategy A Is E) :=
begin
  rintros ⟨H₁, H₂⟩,
  intros H,
  replace H := subclaims_meaning _ _  _ H,
  cases H with H₃ H₄,
  intros σ mem,
  rw Contract.strategy, rw Claim.correctDecomposition,
  simp, split, {
  clear H₂ H₃,
  rw Claim.correctDecompositionImpl, simp,
  intros H₂ H₃ H₅,
  rw CompositeImplementation at H₃,
  simp at H₃,
  rw RPO_fst at H₁,
  replace H₁ := H₁ σ,
  rw AssertionLang.impl_def at H₁,
  have : σ ∈ AssertionLang.sem (list_conj (get_nfs A)) := by
  {
    rw list_conj_iff,
    rw get_nfs,
    simp,
    intros S' Hmem,
    have : Map.find_val S' A.contracts ≠ none, from A.all_components S' Hmem,
    have opt : ∃ C : Contract Φ Var, Map.find_val S' A.contracts = some C, by
      {exact option.ne_none_iff_exists'.mp this,},
    cases opt with C H₆,
    have further : (Map.find_val S' A.contracts).iget = C, by {exact (congr_arg option.iget H₆).trans rfl,},
    simp [further] at *,
    replace H₄ := H₄ S' Hmem,
    rw isCorrectImplementation at H₄,
    rw meaning at H₄, simp at H₄,
    replace H₃ := H₃ S' S',
    unfold set.Inter at H₃,
    unfold infi at H₃,
    unfold Inf at H₃,
    simp at H₃,
    replace H₄ := H₄ σ (H₃ Hmem),
    have further : (Map.find_val S' A.contracts).iget = C, by {exact (congr_arg option.iget H₆).trans rfl,},
    simp [further] at *, clear further,
    rw AssertionLang.disj_def,
    have EM : σ ∈ @AssertionLang.sem Φ Var _ _ _ (AssertionLang.compl Var C.A) ∨ σ ∉ AssertionLang.sem (AssertionLang.compl Var C.A), from or_not,
    cases EM,
    left, assumption,
    right, apply H₄,
    rw AssertionLang.compl_def at EM,
    simp at EM, exact EM,
  },
  replace H₁ := H₁ this,
  rw AssertionLang.disj_def at H₁,
  cases H₁,
  rw AssertionLang.compl_def at H₁,
  simp at H₁,
  contradiction,
  exact H₁,},
  { clear H₁,
    rw Claim.correctDecompositionEnv,
    intros  _ S' EnvSat H₅ H₈ H₆,
    rw CompositeEnvironment at H₆,
    simp at H₆, cases H₆ with H₆ H₇,
    rw RPO_snd at H₂,
    replace H₂ := H₂ S' EnvSat σ,
    rw AssertionLang.impl_def at H₂,
    apply H₂, clear H₂, simp,
    rw AssertionLang.conj_def, split,
    rw Env.satisfiesContract at H₅,
    apply H₅, apply H₆,
    rw list_conj_iff,
    dsimp at *,
    intros φ hφ, simp at *,
    cases hφ with w h,
    cases h with h1 h2,
    have opt : ∃ C : Contract Φ Var, Map.find_val w A.contracts = some C, by
      {exact option.ne_none_iff_exists'.mp (A.all_components w (list.mem_of_mem_erase h1)),},
    cases opt with C H₆,
    have further : (Map.find_val w A.contracts).iget = C, by {exact (congr_arg option.iget H₆).trans rfl,},
    simp [further] at *,
    rw ← h2, rw AssertionLang.disj_def, tidy,
    replace H₄ := H₄ w (list.mem_of_mem_erase h1),
    rw meaning at H₄, rw isCorrectImplementation at H₄, replace H₄ := H₄ σ,simp at H₄,
    replace H₇ := (H₇ w w (h1)),
    rw H₆_1 at *,
    replace H₄ := H₄ H₇,
    rw AssertionLang.compl_def,
    simp at *,
    rwa ← imp_iff_not_or,
  }
end


/-
Copyright (c) 2017 Daniel Selsam. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Daniel Selsam

The actual graph produced by the naive variational auto-encoder code in aevb/prog.lean.

Note: we include this file as an optimization, to avoid repeatedly simplifying the
program into the graph.
-/
import ..program ..prove_model_ok .util .prog

namespace certigrad
namespace aevb

section nodes

open det rand.op label tactic certigrad.tactic

#print "Defining graph_naive..."

def graph_naive : Π (a : arch) (x_data : T [a^.n_in, a^.n_x]), graph
| a x_data :=
graph.mk [⟨(ID.nat 0, [a^.ne, a^.bs]), [(ID.str W_encode₁, [a^.ne, a^.n_in]), (ID.str x, [a^.n_in, a^.bs])], operator.det $ ops.gemm _ _ _⟩,
          ⟨(ID.nat 1, [a^.ne, a^.bs]), [(ID.nat 0, [a^.ne, a^.bs])], operator.det $ ops.softplus _⟩,
          ⟨(ID.nat 2, [a^.ne, a^.bs]), [(ID.str W_encode₂, [a^.ne, a^.ne]), (ID.nat 1, [a^.ne, a^.bs])], operator.det $ ops.gemm _ _ _⟩,
          ⟨(ID.str h_encode, [a^.ne, a^.bs]), [(ID.nat 2, [a^.ne, a^.bs])], operator.det $ ops.softplus _⟩,
          ⟨(ID.str μ, [a^.nz, a^.bs]), [(ID.str W_encode_μ, [a^.nz, a^.ne]), (ID.str h_encode, [a^.ne, a^.bs])], operator.det $ ops.gemm _ _ _⟩,
          ⟨(ID.nat 5, [a^.nz, a^.bs]), [(ID.str W_encode_logσ₂, [a^.nz, a^.ne]), (ID.str h_encode, [a^.ne, a^.bs])], operator.det $ ops.gemm _ _ _⟩,
          ⟨(ID.nat 6, [a^.nz, a^.bs]), [(ID.nat 5, [a^.nz, a^.bs])], operator.det $ ops.exp _⟩,
          ⟨(ID.str σ, [a^.nz, a^.bs]), [(ID.nat 6, [a^.nz, a^.bs])], operator.det $ ops.sqrt _⟩,
          ⟨(ID.str z, [a^.nz, a^.bs]), [(ID.str μ, [a^.nz, a^.bs]), (ID.str σ, [a^.nz, a^.bs])], operator.rand $ mvn _⟩,
          ⟨(ID.str encoding_loss, []), [(ID.str μ, [a^.nz, a^.bs]), (ID.str σ, [a^.nz, a^.bs]), (ID.str z, [a^.nz, a^.bs])], operator.det $ op.mvn_empirical_kl _⟩,
          ⟨(ID.nat 10, [a^.nd, a^.bs]), [(ID.str W_decode₁, [a^.nd, a^.nz]), (ID.str z, [a^.nz, a^.bs])], operator.det $ ops.gemm _ _ _⟩,
          ⟨(ID.nat 11, [a^.nd, a^.bs]), [(ID.nat 10, [a^.nd, a^.bs])], operator.det $ ops.softplus _⟩,
          ⟨(ID.nat 12, [a^.nd, a^.bs]), [(ID.str W_decode₂, [a^.nd, a^.nd]), (ID.nat 11, [a^.nd, a^.bs])], operator.det $ ops.gemm _ _ _⟩,
          ⟨(ID.str h_decode, [a^.nd, a^.bs]), [(ID.nat 12, [a^.nd, a^.bs])], operator.det $ ops.softplus _⟩,
          ⟨(ID.nat 14, [a^.n_in, a^.bs]), [(ID.str W_decode_p, [a^.n_in, a^.nd]), (ID.str h_decode, [a^.nd, a^.bs])], operator.det $ ops.gemm _ _ _⟩,
          ⟨(ID.str p, [a^.n_in, a^.bs]), [(ID.nat 14, [a^.n_in, a^.bs])], operator.det $ ops.sigmoid _⟩,
          ⟨(ID.str decoding_loss, []), [(ID.str p, [a^.n_in, a^.bs]), (ID.str x, [a^.n_in, a^.bs])], operator.det $ ops.bernoulli_neglogpdf _⟩]
         [ID.str encoding_loss, ID.str decoding_loss]
         [(ID.str W_encode₁, [a^.ne, a^.n_in]), (ID.str W_encode₂, [a^.ne, a^.ne]), (ID.str W_encode_μ, [a^.nz, a^.ne]), (ID.str W_encode_logσ₂, [a^.nz, a^.ne]),
          (ID.str W_decode₁, [a^.nd, a^.nz]), (ID.str W_decode₂, [a^.nd, a^.nd]), (ID.str W_decode_p, [a^.n_in, a^.nd])]
         [(ID.str x, [a^.n_in, a^.bs]),
          (ID.str W_encode₁, [a^.ne, a^.n_in]), (ID.str W_encode₂, [a^.ne, a^.ne]), (ID.str W_encode_μ, [a^.nz, a^.ne]), (ID.str W_encode_logσ₂, [a^.nz, a^.ne]),
          (ID.str W_decode₁, [a^.nd, a^.nz]), (ID.str W_decode₂, [a^.nd, a^.nd]), (ID.str W_decode_p, [a^.n_in, a^.nd])]

attribute [cgsimp] graph_naive

open tactic certigrad.tactic

#print "proving naive_aevb_as_graph..."
@[cgsimp] lemma naive_aevb_as_graph (a : arch) (x_data : T [a^.n_in, a^.n_x]) : naive_aevb a x_data = graph_naive a x_data :=
by { dunfold naive_aevb, cgsimp, dcgsimp, cgsimp, reflexivity }

end nodes

end aevb
end certigrad


import Std

def List.enum' (L : List α) : List (Fin L.length × α) :=
  let rec go (rest : List α) (i : Nat)
              (h : i + rest.length = L.length) :=
    match rest, h with
    | [], _ => []
    | (x :: xs), h =>
      (⟨i, (h.symm ▸ Nat.lt_add_of_pos_right (Nat.zero_lt_succ _))⟩, x)
      :: go xs (i+1) (by
        simp [←h, Nat.add_succ, Nat.succ_add])
  go L 0 (by simp)

def Fin.last (n : Nat) (_ : 0 < n) : Fin n :=
  match n with
  | 0 => by contradiction
  | n+1 => ⟨n, Nat.le_refl _⟩

def Fin.pred? : Fin n → Option (Fin n)
| ⟨0, _⟩ => none
| ⟨i+1,h⟩ => some ⟨i, Nat.le_of_succ_le h⟩

def Fin.succ? : {n : Nat} → Fin n → Option (Fin n)
| 0, i => i.elim0
| n+1, ⟨i,_⟩ =>
  if h : i < n
  then some ⟨i+1, Nat.succ_le_succ h⟩
  else none

def Function.iterate (f : α → α) : Nat → (α → α)
| 0 => id
| n+1 => iterate f n ∘ f

def Array.init (n : Nat) (f : Fin n → α) : Array α := Id.run do
  let mut A := Array.mkEmpty n
  for h:i in [0:n] do
    A := A.push (f ⟨i,h.2⟩)
  return A

def Array.initM [Monad m] (n : Nat) (f : Fin n → m α) : m (Array α) := do
  let mut A := Array.mkEmpty n
  for h:i in [0:n] do
    A := A.push (← f ⟨i,h.2⟩)
  return A

theorem Array.init_zero : Array.init 0 f = #[] := by
  simp [init, Id.run, forIn', Std.Range.forIn']
  unfold Std.Range.forIn'.loop
  simp

theorem Array.init_succ {f : Fin n.succ → α}
  : Array.init n.succ f = (
      Array.init n (fun i => f ⟨i,Nat.lt_trans i.isLt (by exact Nat.le_refl _)⟩)
    ).push (f ⟨n, by exact Nat.le_refl _⟩)
  := by
  simp [init, Id.run, forIn', Std.Range.forIn']
  suffices ∀ i (hi : i ≤ n) o (_ : o.size = n-i),
    Std.Range.forIn'.loop (m := Id) 0 n.succ 1
      (fun i h r => ForInStep.yield (push r (f ⟨i, h.2⟩)))
      i.succ (n-i)
      (Nat.zero_le _)
      o
    = push (Std.Range.forIn'.loop (m := Id) 0 n 1
      (fun i h r => ForInStep.yield (push r (f ⟨i, Nat.le_step h.2⟩)))
      i (n-i)
      (Nat.zero_le _)
      o) (f ⟨n, Nat.lt_succ_self n⟩)
    by
    have := this n (Nat.le_refl _) #[] (by simp)
    simp at this
    exact this
  intro i hi o ho
  induction i generalizing o with
  | zero =>
    unfold Std.Range.forIn'.loop
    unfold Std.Range.forIn'.loop
    simp
  | succ i ih =>
    conv => lhs; unfold Std.Range.forIn'.loop
    conv => rhs; unfold Std.Range.forIn'.loop
    simp
    have hn := Nat.sub_lt_of_pos_le _ _ (Nat.succ_pos _) hi
    have hn' : n - Nat.succ i < Nat.succ n := Nat.le_step hn
    simp [hn, hn']
    have : n - Nat.succ i + 1 = n - i := by
      simp [Nat.sub_succ]
      rw [Nat.add_one, Nat.succ_pred_eq_of_pos (Nat.zero_lt_sub_of_lt hi)]
    suffices ∀ j, j = n - Nat.succ i + 1 →
      Std.Range.forIn'.loop (m := Id)  _ _ _ _ _ j (Nat.zero_le _) _
      = push (Std.Range.forIn'.loop (m := Id) _ _ _ _ _ j (Nat.zero_le _) _) _
      from this _ rfl
    intro j hj
    rw [this] at hj
    cases hj
    apply ih
    exact Nat.le_of_lt hi
    simp [ho, this]

@[simp]
theorem Array.size_init : (Array.init n f).size = n := by
  induction n
  . simp [size, init_zero]
  . next ih =>
    simp [init_succ]; exact ih

@[simp]
theorem Array.get_init {i : Nat} {h} : (Array.init n f)[i]'h = f ⟨i, @size_init n _ f ▸ h⟩ := by
  induction n generalizing i with
  | zero => simp at h; exact False.elim <| Nat.not_lt_zero _ h
  | succ n ih =>
    simp [init_succ, get_push]
    split
    next h =>
      have := @ih (fun i => f ⟨i,Nat.lt_trans i.isLt (by exact Nat.le_refl _)⟩) i (by simp; assumption)
      simp at this ⊢
      rw [this]
    next h' =>
      simp at h'
      have : i = n := Nat.le_antisymm
        (Nat.le_of_succ_le_succ (by rw [size_init] at h; exact h))
        h'
      cases this
      congr

def List.distinct [DecidableEq α] (L : List α) : List α :=
  L.foldl (·.insert ·) []

def List.isDistinct [BEq α] : List α → Bool
| [] => true
| x::xs => !xs.contains x && xs.isDistinct

def List.fins (n : Nat) : List (Fin n) :=
  finsAux n (Nat.le_refl _) []
where
  finsAux : (i : Nat) → i ≤ n → List (Fin n) → List (Fin n)
  | 0, _, acc => acc
  | i+1, h, acc => finsAux i (Nat.le_of_lt h) (⟨i,h⟩ :: acc)

/- Better parallelism primitive, that is actually like Scala's Future -/
def TaskIO (α) := IO (Task (Except IO.Error α))

namespace TaskIO

instance : Monad TaskIO where
  pure a := pure (f := IO) <| Task.pure (Except.ok a)
  bind a f := bind (m := IO) a (fun task =>
    IO.bindTask task (fun res => do
      let res ← ofExcept res
      f res))

instance : MonadLift IO TaskIO where
  monadLift io := io.map (fun a => Task.pure (Except.ok a))

def wait (task : TaskIO α) : IO α := do
  let task ← task
  let x ← IO.wait task
  ofExcept x

instance : MonadExceptOf IO.Error TaskIO where
  throw e := show IO _ from throw e
  tryCatch a f := bind (m := IO) a (IO.bindTask · fun
    | .ok a => show TaskIO _ from pure a
    | .error e => f e)

def par [ForIn IO σ α] (xs : σ) (f : α → TaskIO β)
    : TaskIO (List β) := show IO _ from do
  let mut tasks := #[]
  for x in xs do
    tasks := tasks.push (← (f x))
  let task ← IO.mapTasks (fun bs => do
    return ←bs.mapM (fun b => ofExcept b)
  ) tasks.toList
  return task

def parUnit [ForIn IO σ α] (xs : σ) (f : α → TaskIO Unit)
    : TaskIO Unit := do
  let _allUnits ← par xs f
  return ()

def parTasks [ForIn IO σ α] (xs : σ) (f : α → IO β)
    : TaskIO (List β) := do
  par xs (fun a => liftM (n := IO) <| IO.asTask (do f a))

def parTasksUnit [ForIn IO σ α] (xs : σ) (f : α → IO Unit)
    : TaskIO Unit := do
  parUnit xs (fun a => liftM (n := IO) <| IO.asTask (do f a))

end TaskIO

def Option.forIn [Monad m] (o : Option α) (b : β) (f : α → β → m (ForInStep β)) : m β := do
  match o with
  | none => return b
  | some a =>
  match ← f a b with
  | .done b => return b
  | .yield b => return b

instance : ForIn m (Option α) α where
  forIn := Option.forIn

def IO.timeMs (prog : IO α) : IO (Nat × α) := do
  let start ← IO.monoMsNow
  let res ← prog
  let end_ ← IO.monoMsNow

  return (end_ - start, res)

instance : GetElem String Nat Char (fun s i => i < s.length) where
  getElem | xs, i, _ => xs.get (String.Pos.mk i)

def randFin (n) (_h : n > 0) : IO (Fin n) := do
  let i ← IO.rand 0 n.pred
  if h : i < n then
    return ⟨i,h⟩
  else
    panic! s!"failed to get random number {i} < {n}"

/- Generate a random permutation of the list.
Implementation is quadratic in length of L. -/
def IO.randPerm (L : List α) : IO (List α) :=
  randPermTR L [] 0
where randPermTR (L acc n) := do
  match L with
  | [] => return acc
  | x::xs =>
    let idx ← IO.rand 0 n
    let acc' := acc.insertNth idx x
    randPermTR xs acc' (n+1)

@[simp]
theorem List.sizeOf_filter [SizeOf α] (f) (L : List α)
  : sizeOf (List.filter f L) ≤ sizeOf L
  := by
  induction L <;> simp [filter]
  split
  . simp
    apply Nat.add_le_add_left
    assumption
  . simp
    apply Nat.le_trans ?_ (Nat.le_add_left _ _)
    assumption

theorem List.sizeOf_filter_lt_of_ne [SizeOf α] (f) (L : List α)
    (h : List.filter f L ≠ L)
  : sizeOf (List.filter f L) < sizeOf L
  := by
  induction L <;> simp [filter] at *
  next hd tl ih =>
  split
  next hHd =>
    simp [hHd] at h
    simp [_sizeOf_1]
    apply Nat.add_lt_add_left
    apply ih
    assumption
  next hHd =>
    clear h hHd
    apply Nat.lt_of_le_of_lt (sizeOf_filter _ _)
    rw [Nat.add_comm, Nat.add_comm 1, Nat.add_one, Nat.add_succ]
    apply Nat.succ_le_succ
    apply Nat.le_add_right

@[simp] theorem List.find?_map (p : β → Bool) (f : α → β) (L : List α)
  : List.find? p (List.map f L) = Option.map f (List.find? (p ∘ f) L)
  := by induction L <;> simp; split <;> simp [*]

@[simp]
def Std.AssocList.ofList : List (α × β) → Std.AssocList α β
| [] => .nil
| (a,b)::tail => .cons a b (ofList tail)

@[simp] theorem Std.AssocList.toList_ofList (L : List (α × β))
  : toList (ofList L) = L
  := by induction L <;> simp [*]

@[simp]
theorem Std.HashMap.find?_ofList {B : BEq α} {H : Hashable α} (a : List (α × β)) (k : α)
  : (@Std.HashMap.ofList _ B H _ a |>.find? k) = (Std.AssocList.ofList a |>.find? k)
  := sorry

@[inline]
def Option.expectSome (err : Unit → ε) : Option α → Except ε α
| none => .error (err ())
| some a => .ok a

structure NonemptyList (α) where
  hd : α
  tl : List α

@[inline]
def List.expectNonempty (err : Unit → ε) : List α → Except ε (NonemptyList α)
| [] => .error (err ())
| hd::tl => .ok ⟨hd,tl⟩

def PrinterM := StateM String
def PrinterM.putStr : String → PrinterM Unit :=
  fun string state => ((), state.append string)
def PrinterM.run : PrinterM Unit → String := (StateT.run · "" |>.2)

instance : Monad PrinterM := show Monad (StateM String) from inferInstance

def IO.FS.withTempFile (f : System.FilePath → IO α) : IO α := do
  let mut file := ".tmp"
  while ← System.FilePath.pathExists file do
    file := file ++ toString (← IO.rand 0 999999)

  IO.FS.writeFile file ""
  let res ← f file
  if ← System.FilePath.pathExists file then
    IO.FS.removeFile file

  return res


import .sous_foncteur
import category_theory.elements
import .A2
open category_theory
open A2
open int
-- universes  v u
lemma int_commute_with_morph  {A B :Type }[comm_ring A][comm_ring B](f : A →  B)[is_ring_hom  f](n : ℕ) : ∀ x : A, f( n*x ) = n *(f x) := λ x,
    nat.rec_on n (show  f(0*x) = 0* (f x), {rw [zero_mul,zero_mul], exact is_ring_hom.map_zero f, })
        (assume n, assume rec_hyp : f(n * x) = n *(f x),
            show f( (n+1)*x) = (n+1)*(f(x)),{
                rw [right_distrib,right_distrib,one_mul,one_mul,← rec_hyp,is_ring_hom.map_add f],
            })
structure A2_disc(R : Type )[comm_ring R] :=
(ζ : A2 R)
(inv_disc : R)
(certif_disc : (ζ.a * ζ.a - ↑4 * ζ.b ) * inv_disc = 1)
namespace A2_disc
section
variables {R : Type } [comm_ring R]
--- idée faire des lemmes simplificateurs !
lemma disc :  ∀ {ζ1 ζ2 : A2_disc R}, ζ1.ζ = ζ2.ζ → ((ζ1.ζ.a = ζ2.ζ.a) ∧ (ζ1.ζ.b = ζ2.ζ.b)) :=
begin
    intros ζ1 ζ2,
    intro h,
    split,
    apply congr_arg, assumption,
    apply congr_arg, assumption,
end
lemma disc_ :  ∀ {ζ1 ζ2 : A2_disc R}, ζ1.ζ = ζ2.ζ  →  (ζ1.ζ.a * ζ1.ζ.a - ↑4 * ζ1.ζ.b ) = (ζ2.ζ.a * ζ2.ζ.a - ↑4 * ζ2.ζ.b ) :=
begin
    intros ζ1 ζ2,
    intro h,
    have H : ((ζ1.ζ.a = ζ2.ζ.a) ∧ (ζ1.ζ.b = ζ2.ζ.b)),
        apply disc,
        assumption,
    rw H.1,
    rw H.2,
end
    lemma inverse_unique (a b c d: R) : a * c = 1 → d * b = 1 → a = d → c = b := λ h1 h2 h3, begin  --- remettre dans l'ordre
        have : c = (a * b) * c,
            rw h3,
            rw h2,
            rw one_mul c,
        rw this,
        rw [mul_assoc, mul_comm b c,← mul_assoc,h1, one_mul],
        end
    @[ext] lemma ext :  ∀ {ζ1 ζ2 : A2_disc R}, (ζ1.ζ  = ζ2.ζ)  → ζ1 = ζ2 := λ ζ1 ζ2,
        begin
            intro h,
            cases ζ1,
            cases ζ2,
            congr ; try { assumption },
            apply inverse_unique,
            exact ζ1_certif_disc,
            exact ζ2_certif_disc,
            exact  disc_ h,
        end
open is_ring_hom
def map_A2_disc {A B :Type }[comm_ring A][comm_ring B](f : A →  B)[is_ring_hom  f] : A2_disc A → A2_disc B := λ η,  begin
    have  h : ((f η.ζ.a) * (f η.ζ.a)  - (  ↑4 * (f η.ζ.b ))) * (f η.inv_disc) = 1,
            have j :    f( ↑4* η.ζ.b) = ↑4 * (f η.ζ.b ),
                exact int_commute_with_morph f (4) (η.ζ.b),
            rw [← j,← map_mul f,← map_sub f,← map_mul f,η.certif_disc],
            exact map_one f,
    exact { ζ := {a := f η.ζ.a, b := f η.ζ.b},
          inv_disc :=  f η.inv_disc,
          certif_disc :=  h,},
    end
lemma map_comp_a {A B :Type }[comm_ring A][comm_ring B](f : A →  B)[is_ring_hom  f] (ζ : A2_disc (A) ) : (map_A2_disc f ζ).ζ.a = f ζ.ζ.a := rfl
lemma map_comp_b {A B :Type }[comm_ring A][comm_ring B](f : A →  B)[is_ring_hom  f] (ζ : A2_disc (A) ) : (map_A2_disc f ζ).ζ.b = f ζ.ζ.b := rfl
lemma map_comp_inv_disc {A B :Type }[comm_ring A][comm_ring B](f : A →  B)[is_ring_hom  f] (ζ : A2_disc (A) ) : (map_A2_disc f ζ).inv_disc = f ζ.inv_disc := rfl
def 𝔸2_disc: CommRing ⥤ Type  :=
{ obj := λ R, A2_disc R,
  map := λ R R' f, map_A2_disc f,
}

-- def A :=   (functor.elements) (𝔸2_disc)
end
end A2_disc


import Lib.Data.Array
import Lib.Data.Nat
import Lib.Data.DecSubtype
import Lib.Data.OrdMap
import Lib.Logic.Classical

namespace Nat

theorem lt_mul_iff_div_lt {x y k : Nat} (h : 1 ≤ k) :
  x < y*k ↔ x / k < y := by
rw [← Classical.not_iff_not, ← le_iff_not_lt, mul_le_iff_le_div, le_iff_not_lt]
 <;> auto

end Nat

inductive InfArrayBuf (α : Type u) : Nat → Type u where
  | default : α → n > 0 → InfArrayBuf α n
  | node : Buffer n α → InfArrayBuf α (n*2) → InfArrayBuf α n

namespace InfArrayBuf

theorem is_pos (ar : InfArrayBuf α n) : n > 0 := by
induction ar with
| default x h => exact h
| node buf ar ih =>
  simp [Nat.lt_mul_iff_div_lt] at ih
  auto

def mk (x : α) (h : n > 0) : InfArrayBuf α n :=
default x h

def get : InfArrayBuf α n → Nat → α
| default x _, _ => x
| ar@(node buf ar'), i =>
  if h : i < n then
    buf.get ⟨i, h⟩
  else
    get ar' (i - n)
def set : InfArrayBuf α n → Nat → α → InfArrayBuf α n
| default x h, i, y =>
  let buf := Buffer.mkFilled x
  have h'' : n*2 > 0 := by
    simp [Nat.lt_mul_iff_div_lt]; auto
  if h' : i < n then
    node (buf.set ⟨i, h'⟩ y) (default x h'')
  else
    have h₂ : 0 < i := Nat.lt_of_lt_of_le h (Nat.le_of_not_gt h')
    have h₃ : i - n < i := Nat.sub_lt h₂ h
    node buf (set (default x h'') (i - n) y)
| ar@(node buf ar'), i, x =>
  if h' : i < n then
    node (buf.set ⟨i, h'⟩ x) ar'
  else
    have h'' : n*2 > 0 := ar'.is_pos
    have h   : n > 0 := ar.is_pos
    have h₂ : 0 < i := Nat.lt_of_lt_of_le h (Nat.le_of_not_gt h')
    have h₃ : i - n < i := Nat.sub_lt h₂ h
    node buf (set ar' (i - n) x)
termination_by _ i _ => i

def size : InfArrayBuf α n → Nat
| default _ _ => 0
| node _ ar => n + ar.size

def toList : InfArrayBuf α n → Nat → List α
| default x h, n => List.replicate n x
| node buf ar, m =>
  if m ≤ n then buf.cells.toList.take m
  else buf.cells.foldr (. :: .) (toList ar (m - n))

def dropHead : InfArrayBuf α n → InfArrayBuf α (n*2)
| default x h => default x <| by simp [Nat.lt_mul_iff_div_lt]; auto
| node buf ar => ar

end InfArrayBuf

structure InfArray (α : Type u) where
mkImpl ::
  bufSize : Nat
  buffers : InfArrayBuf α bufSize

namespace InfArray

def mkFilled (x : α) : InfArray α where
  bufSize := 10
  buffers := InfArrayBuf.node (Buffer.mkFilled x)
    (InfArrayBuf.default x <| by auto)

def size (ar : InfArray α) : Nat :=
ar.buffers.size

def get (ar : InfArray α) (i : Nat) : α :=
ar.buffers.get i

def set (ar : InfArray α) (i : Nat) (x : α) : InfArray α where
  buffers := ar.buffers.set i x

def toList (ar : InfArray α) (n : Nat) : List α :=
ar.buffers.toList n

def dropHead (ar : InfArray α) : InfArray α where
  buffers := ar.buffers.dropHead

end InfArray

def Heap := OrdMap

namespace Heap
open Std.AssocList
variable [LT α]

def takeMin (h : Heap α β) : Option (α × β × Heap α β) :=
match h' : h.vals with
| nil => none
| cons k v xs =>
  let xs' :=
    { vals := xs
      sorted := by
        have h'' := h.sorted
        simp [h', keys] at h''
        cases h''; assumption }
  -- let z := h.insert
  some (k, v, xs')

def nonEmpty (h : Heap α β) : Bool :=
match h.vals with
| nil => false
| cons k v xs => true

def empty : Heap α β where
  vals := nil
  sorted := by constructor

end Heap

def NEHeap (α) [LT α] (β) :=
DecSubtype (Heap.nonEmpty (α := α) (β := β))

namespace NEHeap
open Std.AssocList
variable [LT α]

def takeMin (h : NEHeap α β) : α × β × Heap α β :=
match h' : h with
| ⟨ ⟨cons k v xs, hxs ⟩, rfl ⟩ =>
  let xs' :=
    { vals := xs
      sorted := by
        have h'' := h.val.sorted
        simp [h', keys] at h''
        cases h''; assumption }
  (k, v, xs')

def head (h : NEHeap α β) : α :=
match h' : h with
| ⟨ ⟨cons k v xs, hxs ⟩, rfl ⟩ => k

end NEHeap

namespace OrdMap

variable [LE k] [DecidableTotalOrder k]
variable (f : k → α → α → α)

def insertWith (x : k) (v : α) :
  OrdMap k α → OrdMap k α :=
unionWith f (singleton x v)

end OrdMap

namespace Heap
open Std.AssocList
variable [LE α] [DecidableTotalOrder α]
variable (f : α → β → β → β)

def insertWith' (h : Heap α β) (k : α) (v : β) : NEHeap α β where
  val := h.insertWith f k v
  property := by
    cases h' : h.vals <;>
    simp [OrdMap.insertWith, OrdMap.unionWith, OrdMap.unionWith, OrdMap.mergeWith] <;>
    simp [OrdMap.singleton, h', zipWith, mapFilter, nonEmpty]
    next k v k' v' tail =>
      cases compare k k' <;> simp

end Heap

structure SieveEntry where
mkImpl ::
  key : Nat
  prime : Nat
  coef : Nat
  cached_key : key = prime * coef
  le_coef : prime ≤ coef

instance : ToString SieveEntry where
  toString x := toString (x.prime, x.coef)

namespace SieveEntry

def mk (n : Nat) : SieveEntry where
  key := n * n
  prime := n
  coef := n
  le_coef := Nat.le_refl _
  cached_key := rfl

def step' (s : SieveEntry) : SieveEntry where
  key := s.key + s.prime + s.prime
  prime := s.prime
  coef := s.coef + 2
  le_coef := by trans _; apply s.le_coef; auto
  cached_key := by simp [Nat.mul_succ, s.cached_key]

def step (s : SieveEntry) : Nat × SieveEntry :=
let s' := s.step'
(s'.key, s')

end SieveEntry

def List.nonEmpty : List α → Bool
| [] => false
| _ :: _ => true

def NEList (α) := DecSubtype (List.nonEmpty (α := α))

namespace NEList

def append : NEList α → NEList α → NEList α
| ⟨x :: xs, rfl⟩, ⟨ys, _⟩ => ⟨x :: (xs ++ ys), rfl⟩

instance : Append (NEList α) := ⟨ append ⟩

instance [Repr α] : Repr (NEList α) where
  reprPrec x n := reprPrec x.1 n

instance [ToString α] : ToString (NEList α) where
  toString x := toString x.1

end NEList

structure SieveState where
  cursor : NEHeap Nat (NEList SieveEntry)
  -- offset : Nat
  -- flags : InfArray Bool
  next : Nat
  primes : Array Nat

namespace SieveState

def pushPrime (n : Nat) (h : Heap Nat (NEList SieveEntry)) :
  NEHeap Nat (NEList SieveEntry) :=
let e := SieveEntry.mk n
h.insertWith' (λ _ => (. ++ .)) e.key ⟨ [e], rfl ⟩

-- def toList (s : SieveState) (n : Nat) : List (Nat × Bool) :=
-- s.flags.toList n |>.enumFrom s.offset |>.map <| Prod.map (. *2 +1) id

def init : SieveState where
  cursor := pushPrime 3 Heap.empty
  -- offset := 0
  -- flags := InfArray.mkFilled true
  next := 2 -- we consider only next * 2 + 1
  primes := #[2,3]

def next' (s : SieveState) : Nat := s.next*2 + 1

-- def index (s : SieveState) (c : Nat) : Nat :=
-- (((c - 1) / 2) - s.offset)

def insert (h : Heap Nat (NEList SieveEntry)) (e : SieveEntry) :
  NEHeap Nat (NEList SieveEntry) :=
h.insertWith' (λ _ => (. ++ .)) e.key ⟨[e],rfl⟩

def steps (h : Heap Nat (NEList SieveEntry)) :
  NEList SieveEntry →
  NEHeap Nat (NEList SieveEntry)
| ⟨e::es, rfl⟩ =>
  let (c', e') := e.step
  let h' := insert h e'
  es.foldl (λ h e => insert h.1 e.step') h'
   -- match es with
  -- | [] => h'
  -- | ys@(e' :: es) =>
    -- have : ys.length < xs.length := sorry
    -- steps h'.val ⟨e':: es, rfl ⟩
-- termination_by _ es => es.val.length

def step' (s : SieveState) : SieveState :=
let (c, es, cursor') := s.cursor.takeMin
-- let (c', e') := e.step
-- let i := s.index c
let cursor' := steps cursor' es
-- let flags' := s.flags.set i false
{ cursor := cursor'
  -- offset := s.offset
  -- flags := flags'
  next := s.next
  primes := s.primes
}

-- def condition (s : SieveState) : Bool × Nat × Nat :=
-- ( s.next' < s.cursor.head ∧ s.flags.get (s.index s.next),
--  s.index s.next,
--  s.next
-- )

-- def toList (s : SieveState) : List (Nat × Bool) :=

def step (s : SieveState) : SieveState :=
-- if s.offset + s.flags.bufSize ≤ s.next then
  -- { s with
    -- offset := s.offset + s.flags.bufSize
    -- flags := s.flags.dropHead }
if s.next' < s.cursor.head then
  let p := s.next'
  -- let i := s.next - s.offset
  -- let i := s'.next
  let cursor' := pushPrime p s.cursor.1
  let primes' := s.primes.push p
  { s with
           next := s.next + 1
           cursor := cursor'
           primes := primes' }
else if s.next' = s.cursor.head then
  { s.step' with next := s.next + 1 }
else
  s.step'

def test : IO Unit := do
  let mut s := init
  for i in [0:79] do
    s := step s
  print_vars![s.next', s.primes,
              s.cursor.val.vals.toList]

-- #eval test

end SieveState


/-
Copyright (c) 2018 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Bhavik Mehta
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.limits.limits
import Mathlib.category_theory.discrete_category
import Mathlib.PostPort

universes v u u_1 u₂

namespace Mathlib

namespace category_theory.limits

-- We don't need an analogue of `pair` (for binary products), `parallel_pair` (for equalizers),

-- or `(co)span`, since we already have `discrete.functor`.

/-- A fan over `f : β → C` consists of a collection of maps from an object `P` to every `f b`. -/
/-- A cofan over `f : β → C` consists of a collection of maps from every `f b` to an object `P`. -/
def fan {β : Type v} {C : Type u} [category C] (f : β → C) := cone (discrete.functor f)

def cofan {β : Type v} {C : Type u} [category C] (f : β → C) := cocone (discrete.functor f)

/-- A fan over `f : β → C` consists of a collection of maps from an object `P` to every `f b`. -/
@[simp] theorem fan.mk_X {β : Type v} {C : Type u} [category C] {f : β → C} (P : C)
    (p : (b : β) → P ⟶ f b) : cone.X (fan.mk P p) = P :=
  Eq.refl (cone.X (fan.mk P p))

/-- A cofan over `f : β → C` consists of a collection of maps from every `f b` to an object `P`. -/
@[simp] theorem cofan.mk_X {β : Type v} {C : Type u} [category C] {f : β → C} (P : C)
    (p : (b : β) → f b ⟶ P) : cocone.X (cofan.mk P p) = P :=
  Eq.refl (cocone.X (cofan.mk P p))

/-- An abbreviation for `has_limit (discrete.functor f)`. -/
def has_product {β : Type v} {C : Type u} [category C] (f : β → C) := has_limit (discrete.functor f)

/-- An abbreviation for `has_colimit (discrete.functor f)`. -/
def has_coproduct {β : Type v} {C : Type u} [category C] (f : β → C) :=
  has_colimit (discrete.functor f)

/-- An abbreviation for `has_limits_of_shape (discrete f)`. -/
/-- An abbreviation for `has_colimits_of_shape (discrete f)`. -/
def has_products_of_shape (β : Type v) (C : Type u_1) [category C] :=
  has_limits_of_shape (discrete β)

def has_coproducts_of_shape (β : Type v) (C : Type u_1) [category C] :=
  has_colimits_of_shape (discrete β)

/-- `pi_obj f` computes the product of a family of elements `f`. (It is defined as an abbreviation
   for `limit (discrete.functor f)`, so for most facts about `pi_obj f`, you will just use general facts
   about limits.) -/
/-- `sigma_obj f` computes the coproduct of a family of elements `f`. (It is defined as an abbreviation
def pi_obj {β : Type v} {C : Type u} [category C] (f : β → C) [has_product f] : C :=
  limit (discrete.functor f)

   for `colimit (discrete.functor f)`, so for most facts about `sigma_obj f`, you will just use general facts
   about colimits.) -/
def sigma_obj {β : Type v} {C : Type u} [category C] (f : β → C) [has_coproduct f] : C :=
  colimit (discrete.functor f)

prefix:20 "∏ " => Mathlib.category_theory.limits.pi_obj

prefix:20 "∐ " => Mathlib.category_theory.limits.sigma_obj

/-- The `b`-th projection from the pi object over `f` has the form `∏ f ⟶ f b`. -/
def pi.π {β : Type v} {C : Type u} [category C] (f : β → C) [has_product f] (b : β) : ∏ f ⟶ f b :=
  limit.π (discrete.functor f) b

/-- The `b`-th inclusion into the sigma object over `f` has the form `f b ⟶ ∐ f`. -/
def sigma.ι {β : Type v} {C : Type u} [category C] (f : β → C) [has_coproduct f] (b : β) :
    f b ⟶ ∐ f :=
  colimit.ι (discrete.functor f) b

/-- The fan constructed of the projections from the product is limiting. -/
def product_is_product {β : Type v} {C : Type u} [category C] (f : β → C) [has_product f] :
    is_limit (fan.mk (∏ f) (pi.π f)) :=
  is_limit.of_iso_limit (limit.is_limit (discrete.functor f))
    (cones.ext (iso.refl (cone.X (limit.cone (discrete.functor fun (b : β) => f b)))) sorry)

/-- A collection of morphisms `P ⟶ f b` induces a morphism `P ⟶ ∏ f`. -/
def pi.lift {β : Type v} {C : Type u} [category C] {f : β → C} [has_product f] {P : C}
    (p : (b : β) → P ⟶ f b) : P ⟶ ∏ f :=
  limit.lift (discrete.functor fun (b : β) => f b) (fan.mk P p)

/-- A collection of morphisms `f b ⟶ P` induces a morphism `∐ f ⟶ P`. -/
def sigma.desc {β : Type v} {C : Type u} [category C] {f : β → C} [has_coproduct f] {P : C}
    (p : (b : β) → f b ⟶ P) : ∐ f ⟶ P :=
  colimit.desc (discrete.functor fun (b : β) => f b) (cofan.mk P p)

/--
Construct a morphism between categorical products (indexed by the same type)
from a family of morphisms between the factors.
-/
def pi.map {β : Type v} {C : Type u} [category C] {f : β → C} {g : β → C} [has_product f]
    [has_product g] (p : (b : β) → f b ⟶ g b) : ∏ f ⟶ ∏ g :=
  lim_map (discrete.nat_trans p)

/--
Construct an isomorphism between categorical products (indexed by the same type)
from a family of isomorphisms between the factors.
-/
def pi.map_iso {β : Type v} {C : Type u} [category C] {f : β → C} {g : β → C}
    [has_products_of_shape β C] (p : (b : β) → f b ≅ g b) : ∏ f ≅ ∏ g :=
  functor.map_iso lim (discrete.nat_iso p)

/--
Construct a morphism between categorical coproducts (indexed by the same type)
from a family of morphisms between the factors.
-/
def sigma.map {β : Type v} {C : Type u} [category C] {f : β → C} {g : β → C} [has_coproduct f]
    [has_coproduct g] (p : (b : β) → f b ⟶ g b) : ∐ f ⟶ ∐ g :=
  colim_map (discrete.nat_trans p)

/--
Construct an isomorphism between categorical coproducts (indexed by the same type)
from a family of isomorphisms between the factors.
-/
def sigma.map_iso {β : Type v} {C : Type u} [category C] {f : β → C} {g : β → C}
    [has_coproducts_of_shape β C] (p : (b : β) → f b ≅ g b) : ∐ f ≅ ∐ g :=
  functor.map_iso colim (discrete.nat_iso p)

-- TODO: show this is an iso iff G preserves the product of f.

/-- The comparison morphism for the product of `f`. -/
def pi_comparison {β : Type v} {C : Type u} [category C] {D : Type u₂} [category D] (G : C ⥤ D)
    (f : β → C) [has_product f] [has_product fun (b : β) => functor.obj G (f b)] :
    functor.obj G (∏ f) ⟶ ∏ fun (b : β) => functor.obj G (f b) :=
  pi.lift fun (b : β) => functor.map G (pi.π f b)

@[simp] theorem pi_comparison_comp_π_assoc {β : Type v} {C : Type u} [category C] {D : Type u₂}
    [category D] (G : C ⥤ D) (f : β → C) [has_product f]
    [has_product fun (b : β) => functor.obj G (f b)] (b : β) {X' : D}
    (f' : functor.obj G (f b) ⟶ X') :
    pi_comparison G f ≫ pi.π (fun (b : β) => functor.obj G (f b)) b ≫ f' =
        functor.map G (pi.π f b) ≫ f' :=
  sorry

@[simp] theorem map_lift_pi_comparison_assoc {β : Type v} {C : Type u} [category C] {D : Type u₂}
    [category D] (G : C ⥤ D) (f : β → C) [has_product f]
    [has_product fun (b : β) => functor.obj G (f b)] (P : C) (g : (j : β) → P ⟶ f j) {X' : D}
    (f' : (∏ fun (b : β) => functor.obj G (f b)) ⟶ X') :
    functor.map G (pi.lift g) ≫ pi_comparison G f ≫ f' =
        (pi.lift fun (j : β) => functor.map G (g j)) ≫ f' :=
  sorry

-- TODO: show this is an iso iff G preserves the coproduct of f.

/-- The comparison morphism for the coproduct of `f`. -/
def sigma_comparison {β : Type v} {C : Type u} [category C] {D : Type u₂} [category D] (G : C ⥤ D)
    (f : β → C) [has_coproduct f] [has_coproduct fun (b : β) => functor.obj G (f b)] :
    (∐ fun (b : β) => functor.obj G (f b)) ⟶ functor.obj G (∐ f) :=
  sigma.desc fun (b : β) => functor.map G (sigma.ι f b)

@[simp] theorem ι_comp_sigma_comparison_assoc {β : Type v} {C : Type u} [category C] {D : Type u₂}
    [category D] (G : C ⥤ D) (f : β → C) [has_coproduct f]
    [has_coproduct fun (b : β) => functor.obj G (f b)] (b : β) {X' : D}
    (f' : functor.obj G (∐ f) ⟶ X') :
    sigma.ι (fun (b : β) => functor.obj G (f b)) b ≫ sigma_comparison G f ≫ f' =
        functor.map G (sigma.ι f b) ≫ f' :=
  sorry

@[simp] theorem sigma_comparison_map_desc {β : Type v} {C : Type u} [category C] {D : Type u₂}
    [category D] (G : C ⥤ D) (f : β → C) [has_coproduct f]
    [has_coproduct fun (b : β) => functor.obj G (f b)] (P : C) (g : (j : β) → f j ⟶ P) :
    sigma_comparison G f ≫ functor.map G (sigma.desc g) =
        sigma.desc fun (j : β) => functor.map G (g j) :=
  sorry

/-- An abbreviation for `Π J, has_limits_of_shape (discrete J) C` -/
/-- An abbreviation for `Π J, has_colimits_of_shape (discrete J) C` -/
def has_products (C : Type u) [category C] := ∀ (J : Type v), has_limits_of_shape (discrete J) C

def has_coproducts (C : Type u) [category C] := ∀ (J : Type v), has_colimits_of_shape (discrete J) C

end Mathlib