import number_theory.cyclotomic.galois_action_on_cyclo
import number_theory.cyclotomic.cyclotomic_units
import ring_theory.roots_of_unity
import number_theory.number_field.embeddings
import number_theory.cyclotomic.zeta_sub_one_prime

variables {p : ℕ+} {K : Type*} [field K]
variables {ζ : K} (hζ : is_primitive_root ζ p)

open_locale big_operators non_zero_divisors number_field
open is_cyclotomic_extension number_field polynomial

local notation `R` := 𝓞 K

--The whole file is now for a generic primitive root ζ, quite a lot of names should be changed.

lemma coe_life (u : Rˣ) : ((u : R) : K)⁻¹ = ((u⁻¹ : Rˣ) : R) :=
begin
  rw [←coe_coe, ←coe_coe, inv_eq_one_div],
  symmetry,
  rw [eq_div_iff],
  { cases u with u₁ u₂ hmul hinv,
    simp only [units.inv_mk, coe_coe, units.coe_mk],
    rw [← mul_mem_class.coe_mul _ u₂, hinv],
    simp },
  { intro h,
    simp only [coe_coe] at h,
    norm_cast at h,
    exact units.ne_zero _ h }
end

@[simp, norm_cast] --generalize coe_zpow to allow group with zero
lemma coe_zpow' (u : Rˣ) (n : ℤ) : (((u ^ n : Rˣ) : R) : K) = (u : K) ^ n :=
begin
  induction n with n hn,
  { simp },
  { simp [← coe_life] }
end

lemma auxil (a b c d : Rˣ) (h : a * b⁻¹ = c * d ) : a * d⁻¹ = b * c :=
begin
  rw mul_inv_eq_iff_eq_mul at *,
  rw h,
  apply symm,
  rw mul_assoc,
  rw mul_comm,
end

local attribute [instance] is_cyclotomic_extension.number_field
universe u
noncomputable theory

/-- zeta now as a unit in the ring of integers. This way there are no coe issues-/
@[simps {attrs := [`simp, `norm_cast]}] def is_primitive_root.unit' {p : ℕ+} {K : Type*}
  [field K] {ζ : K} (hζ : is_primitive_root ζ p) : (𝓞 K)ˣ :=
{ val := (⟨ζ, hζ.is_integral p.pos⟩ : 𝓞 K),
  inv:= (⟨ζ⁻¹, hζ.inv.is_integral p.pos⟩ : 𝓞 K),
  val_inv := subtype.ext $ mul_inv_cancel $ hζ.ne_zero p.ne_zero,
  inv_val := subtype.ext $ inv_mul_cancel $ hζ.ne_zero p.ne_zero }

local notation `ζ1` := (hζ.unit' - 1 : 𝓞 K)
local notation `I` := ((ideal.span ({ζ1} : set (𝓞 K)) : ideal (𝓞 K)))

lemma is_primitive_root.unit'_pow : hζ.unit' ^ (p : ℕ) = 1 :=
units.ext $ subtype.ext $ by simpa using hζ.pow_eq_one

lemma zeta_runity_pow_even (hpo : odd (p : ℕ)) (n : ℕ) : ∃ (m : ℕ),
  hζ.unit' ^ n = hζ.unit' ^ (2 * m) :=
begin
  rcases eq_or_ne n 0 with rfl | h,
  { use 0,
    simp only [mul_zero] },
  obtain ⟨r, hr⟩ := hpo,
  have he : 2 * (r + 1) * n = p * n + n, by {rw hr, ring},
  use (r + 1) * n,
  rw [←mul_assoc, he, pow_add],
  convert (one_mul _).symm,
  rw [pow_mul, hζ.unit'_pow, one_pow]
end

variables [number_field K]

lemma is_primitive_root.unit'_coe : is_primitive_root (hζ.unit' : R) p :=
begin
 have z1 := hζ,
 have : (algebra_map R K) (hζ.unit' : R) = ζ := rfl,
 rw ← this at z1,
 exact z1.of_map_of_injective (is_fraction_ring.injective _ _),
end

variable (p)

/-- `is_gal_conj_real x` means that `x` is real. -/
def is_gal_conj_real (x : K) [is_cyclotomic_extension {p} ℚ K] : Prop := gal_conj K p x = x

variable {p}

lemma contains_two_primitive_roots {p q : ℕ} {x y : K} [finite_dimensional ℚ K]
  (hx : is_primitive_root x p) (hy : is_primitive_root y q) :
  (lcm p q ).totient ≤ (finite_dimensional.finrank ℚ K) :=
begin
  classical,
  let k := lcm p q,
  rcases nat.eq_zero_or_pos p with rfl | hppos,
  { simp },
  rcases nat.eq_zero_or_pos q with rfl | hqpos,
  { simp },
  let k := lcm p q,
  have hkpos : 0 < k := nat.pos_of_ne_zero (nat.lcm_ne_zero  hppos.ne' hqpos.ne'),
  set xu := is_unit.unit (hx.is_unit hppos) with hxu,
  let yu := is_unit.unit (hy.is_unit hqpos),
  have hxmem : xu ∈ roots_of_unity ⟨k, hkpos⟩ K,
  { rw [mem_roots_of_unity, pnat.mk_coe, ← units.coe_eq_one, units.coe_pow, is_unit.unit_spec],
    exact (hx.pow_eq_one_iff_dvd _).2 (dvd_lcm_left _ _) },
  have hymem : yu ∈ roots_of_unity ⟨k, hkpos⟩ K,
  { rw [mem_roots_of_unity, pnat.mk_coe, ← units.coe_eq_one, units.coe_pow, is_unit.unit_spec],
    exact (hy.pow_eq_one_iff_dvd _).2 (dvd_lcm_right _ _) },
  have hxuord : order_of (⟨xu, hxmem⟩ : roots_of_unity ⟨k, hkpos⟩ K) = p,
  { rw [← order_of_injective (roots_of_unity ⟨k, hkpos⟩ K).subtype subtype.coe_injective,
      subgroup.coe_subtype, subgroup.coe_mk, ← order_of_units, is_unit.unit_spec],
    exact hx.eq_order_of.symm },
  have hyuord : order_of (⟨yu, hymem⟩ : roots_of_unity ⟨k, hkpos⟩ K) = q,
  { rw [← order_of_injective (roots_of_unity ⟨k, hkpos⟩ K).subtype subtype.coe_injective,
      subgroup.coe_subtype, subgroup.coe_mk, ← order_of_units, is_unit.unit_spec],
    exact hy.eq_order_of.symm },
  obtain ⟨g : roots_of_unity ⟨k, hkpos⟩ K, hg⟩ := is_cyclic.exists_monoid_generator,
  obtain ⟨nx, hnx⟩ := hg ⟨xu, hxmem⟩,
  obtain ⟨ny, hny⟩ := hg ⟨yu, hymem⟩,
  obtain ⟨p₁, hp₁⟩ := dvd_lcm_left p q,
  obtain ⟨q₁, hq₁⟩ := dvd_lcm_left p q,
  have H : order_of g = k,
  { refine nat.dvd_antisymm (order_of_dvd_of_pow_eq_one _) (nat.lcm_dvd _ _),
    { have := (mem_roots_of_unity _ _).1 g.2,
      simp only [subtype.val_eq_coe, pnat.mk_coe] at this,
      exact_mod_cast this },
    { rw [← hxuord, ← hnx, order_of_pow],
      exact nat.div_dvd_of_dvd ((order_of g).gcd_dvd_left nx), },
    { rw [← hyuord, ← hny, order_of_pow],
      exact nat.div_dvd_of_dvd ((order_of g).gcd_dvd_left ny) } },
  have hroot := is_primitive_root.order_of g,
  rw [H, ← is_primitive_root.coe_submonoid_class_iff, ← is_primitive_root.coe_units_iff,
    ← coe_coe] at hroot,
  conv at hroot { congr, skip,
    rw [show k = (⟨k, hkpos⟩ : ℕ+), by simp] },
  haveI := is_primitive_root.adjoin_is_cyclotomic_extension ℚ hroot,
  convert submodule.finrank_le (algebra.adjoin ℚ ({g} : set K)).to_submodule,
  simpa using (is_cyclotomic_extension.finrank (algebra.adjoin ℚ ({g} : set K))
    (cyclotomic.irreducible_rat (pnat.pos ⟨k, hkpos⟩))).symm,
  all_goals { apply_instance }
end

lemma totient_le_one_dvd_two {a : ℕ} (han : 0 < a) (ha : a.totient ≤ 1) : a ∣ 2 :=
begin
 cases nat.totient_eq_one_iff.1 (show a.totient = 1, by linarith [nat.totient_pos han]) with h h;
  simp [h]
end

lemma eq_one_mod_one_sub {A : Type*} [comm_ring A] {t : A} :
  algebra_map A (A ⧸ ideal.span ({t - 1} : set A)) t = 1 :=
begin
  rw [←map_one $ algebra_map A $ A ⧸ ideal.span ({t - 1} : set A), ←sub_eq_zero, ←map_sub,
      ideal.quotient.algebra_map_eq, ideal.quotient.eq_zero_iff_mem],
  apply ideal.subset_span,
  exact set.mem_singleton _
end

lemma is_primitive_root.eq_one_mod_sub_of_pow {A : Type*} [comm_ring A] [is_domain A] {ζ : A}
  (hζ : is_primitive_root ζ p) {μ : A} (hμ : μ ^ (p : ℕ) = 1) :
  algebra_map A (A ⧸ ideal.span ({ζ - 1} : set A)) μ = 1 :=
begin
  obtain ⟨k, -, rfl⟩ := hζ.eq_pow_of_pow_eq_one hμ p.pos,
  rw [map_pow, eq_one_mod_one_sub, one_pow]
end

lemma aux {t} {l : 𝓞 K} {f : fin t → ℤ} {μ : K} (hμ : is_primitive_root μ p)
          (h : ∑ (x : fin t), f x • (⟨μ, hμ.is_integral p.pos⟩ : 𝓞 K) ^ (x : ℕ) = l) :
  algebra_map (𝓞 K) (𝓞 K ⧸ I) l = ∑ (x : fin t), f x :=
begin
  apply_fun algebra_map (𝓞 K) ((𝓞 K) ⧸ I) at h,
  simp only [map_sum, map_zsmul] at h,
  convert h.symm,
  funext x,
  convert (zsmul_one (f x)).symm,
  obtain ⟨k, -, rfl⟩ := hζ.eq_pow_of_pow_eq_one hμ.pow_eq_one p.pos,
  convert_to (1 : (𝓞 K) ⧸ I) ^ (x : ℕ) = 1,
  swap, { exact one_pow _ },
  rw [one_pow, hζ.unit'_coe.eq_one_mod_sub_of_pow], -- this file seriously needs tidying
  ext,
  push_cast,
  rw [subtype.coe_mk, ←pow_mul, ←pow_mul, ←mul_rotate', pow_mul, hζ.pow_eq_one, one_pow]
end

lemma is_primitive_root.p_mem_one_sub_zeta [hp : fact ((p : ℕ).prime)] :
  (p : 𝓞 K) ∈ I :=
begin
  classical,
  have key : _ = (p : 𝓞 K) := @@polynomial.eval_one_cyclotomic_prime _ hp,
  rw [cyclotomic_eq_prod_X_sub_primitive_roots hζ.unit'_coe, eval_prod] at key,
  simp only [eval_sub, eval_X, eval_C] at key,
  have : {↑hζ.unit'} ⊆ primitive_roots p (𝓞 K),
  { simpa using hζ.unit'_coe },
  rw [←finset.prod_sdiff this, finset.prod_singleton] at key,
  rw ←key,
  have := I .neg_mem_iff.mpr (ideal.subset_span (set.mem_singleton ζ1)),
  rw neg_sub at this,
  exact ideal.mul_mem_left _ _ this,
end

variable [is_cyclotomic_extension {p} ℚ K]

lemma roots_of_unity_in_cyclo_aux {x : K} {n l : ℕ}
  (hl : l ∈ n.divisors) (hx : x ∈ R) (hhl : (cyclotomic l R).is_root ⟨x, hx⟩)
  {ζ : K} (hζ : is_primitive_root ζ p) : l ∣ 2 * p :=
begin
by_contra,
  have hpl': is_primitive_root (⟨x, hx⟩ : R) l,
    { rw is_root_cyclotomic_iff.symm,
      apply hhl,
      apply_instance,
      refine ⟨λ hzero, _⟩,
      rw [← subalgebra.coe_eq_zero] at hzero,
      simp only [subring_class.coe_nat_cast, nat.cast_eq_zero] at hzero,
      simpa [hzero] using hl },
  have hpl: is_primitive_root x l, by {have : (algebra_map R K) (⟨x, hx⟩) = x, by{refl},
  have h4 := is_primitive_root.map_of_injective hpl', rw ← this,
  apply h4,
  apply is_fraction_ring.injective, },
  have KEY := contains_two_primitive_roots hpl hζ,
  have hirr : irreducible (cyclotomic p ℚ), by {exact cyclotomic.irreducible_rat p.prop},
  have hrank:= is_cyclotomic_extension.finrank K hirr,
  rw hrank at KEY,
  have pdivlcm : (p : ℕ) ∣ lcm l p := dvd_lcm_right l ↑p,
  cases pdivlcm,
  have ineq1 := nat.totient_super_multiplicative (p: ℕ) pdivlcm_w,
  rw ←pdivlcm_h at ineq1,
  have KEY3 := (mul_le_iff_le_one_right (nat.totient_pos p.prop)).mp (le_trans ineq1 KEY),
  have pdiv_ne_zero : 0 < pdivlcm_w, by {by_contra,
  simp only [not_lt, le_zero_iff] at h,
  rw h at pdivlcm_h,
  simp only [mul_zero, lcm_eq_zero_iff, pnat.ne_zero, or_false] at pdivlcm_h,
  apply absurd pdivlcm_h (ne_of_gt (nat.pos_of_mem_divisors hl)),},
  have K5 := (nat.dvd_prime nat.prime_two).1 (totient_le_one_dvd_two pdiv_ne_zero KEY3),
  cases K5,
  rw K5 at pdivlcm_h,
  simp only [mul_one] at pdivlcm_h,
  rw lcm_eq_right_iff at pdivlcm_h,
  have K6 : (p : ℕ) ∣ 2*(p : ℕ) := dvd_mul_left ↑p 2,
  apply absurd (dvd_trans pdivlcm_h K6) h,
  simp only [eq_self_iff_true, normalize_eq, pnat.coe_inj],
  rw K5 at pdivlcm_h,
  rw mul_comm at pdivlcm_h,
  have := dvd_lcm_left l (p : ℕ),
  simp_rw pdivlcm_h at this,
  apply absurd this h,
end

--do more generally
lemma roots_of_unity_in_cyclo (hpo : odd (p : ℕ)) (x : K)
  (h : ∃ (n : ℕ) (h : 0 < n), x^(n: ℕ) = 1) :
  ∃ (m : ℕ) (k : ℕ+), x = (-1) ^ (k : ℕ) * hζ.unit' ^ (m : ℕ) :=
begin
  obtain ⟨n, hn0, hn⟩ := h,
  have hx : x ∈ R, by {rw mem_ring_of_integers,
  refine ⟨(X ^ n - 1),_⟩,
  split,
  { exact (monic_X_pow_sub_C 1 (ne_of_lt hn0).symm) },
  { simp only [hn, eval₂_one, eval₂_X_pow, eval₂_sub,
      sub_self] },},
  have hxu : (⟨x, hx⟩ : R)^n = 1, by {ext, simp [hn] },
  have H: ∃ (m : ℕ) (k: ℕ+), (⟨x, hx⟩ : R) = (-1)^(k : ℕ) * hζ.unit' ^ (m : ℕ),
  by {obtain ⟨l, hl, hhl⟩ := ((_root_.is_root_of_unity_iff hn0 _).1 hxu),
  have hlp := roots_of_unity_in_cyclo_aux hl hx hhl hζ,
  simp only [is_root.def] at hhl,
  have isPrimRoot : is_primitive_root (hζ.unit' : R) p := hζ.unit'_coe,
  have hxl : (⟨x, hx⟩: R)^l =1 , by {apply is_root_of_unity_of_root_cyclotomic _ hhl,
    simp only [nat.mem_divisors, dvd_refl, ne.def, true_and],
   apply (pos_iff_ne_zero.1 (nat.pos_of_mem_divisors hl))},
  have hxp' : (⟨x, hx⟩: R) ^ (2* p : ℕ) = 1,
  { cases hlp,
    rw [hlp_h, pow_mul, hxl], simp only [one_pow] },
  have hxp'': (⟨x, hx⟩: R)^(p : ℕ) = 1 ∨ (⟨x, hx⟩: R)^(p : ℕ) = -1,
  by {rw mul_comm at hxp', rw pow_mul at hxp',
  apply eq_or_eq_neg_of_sq_eq_sq (⟨x, hx⟩^(p : ℕ) : R) 1 _,
  simp only [submonoid_class.mk_pow, one_pow],
  apply hxp',},
  cases hxp'',
  obtain ⟨i, hi,Hi⟩ := (is_primitive_root.eq_pow_of_pow_eq_one isPrimRoot hxp'' p.prop),
  refine ⟨i, 2, _⟩,
  simp only [pnat.coe_bit0, pnat.one_coe, neg_one_sq, one_mul],
  apply Hi.symm,
  have hone : (-1 : R)^(p : ℕ)= (-1 : R), by {apply odd.neg_one_pow hpo,},
  have hxp3 : (-1 * ⟨x, hx⟩: R)^( p : ℕ) = 1, by {rw [mul_pow, hone, hxp''],
  simp only [mul_neg, mul_one, neg_neg],},
  obtain ⟨i, hi,Hi⟩ := (is_primitive_root.eq_pow_of_pow_eq_one isPrimRoot hxp3 p.prop),
  refine ⟨i, 1, _⟩,
  simp_rw Hi,
  simp only [pnat.one_coe, pow_one, neg_mul, one_mul, neg_neg] },
  obtain ⟨m, k, hmk⟩ := H,
  refine ⟨m, k, _⟩,
  have eq : ((⟨x, hx⟩ : R) : K) = x := rfl,
  rw [←eq, hmk],
  norm_cast,
  rw [subalgebra.coe_mul],
  congr' 1,
  { push_cast },
  { rw coe_coe,
    push_cast }
end

lemma norm_cast_ne_two (h : p ≠ 2) : (p : ℕ) ≠ 2 :=
begin
  contrapose! h,
  exact pnat.coe_injective h
end

include hζ

lemma is_primitive_root.is_prime_one_sub_zeta [hp : fact ((p : ℕ).prime)] (h : p ≠ 2) :
  (I : ideal (𝓞 K)).is_prime :=
begin
  rw ideal.span_singleton_prime,
  { exact is_cyclotomic_extension.rat.zeta_sub_one_prime' hζ h },
  apply_fun (coe : (𝓞 K) → K),
  push_cast,
  rw [ne.def, sub_eq_zero],
  rintro rfl,
  exact hp.1.ne_one (hζ.unique is_primitive_root.one)
end

lemma is_primitive_root.two_not_mem_one_sub_zeta [hp : fact ((p : ℕ).prime)] (h : p ≠ 2) :
  (2 : 𝓞 K) ∉ I :=
begin
  have hpm := hζ.p_mem_one_sub_zeta,
  obtain ⟨k, hk⟩ := hp.1.odd_of_ne_two (norm_cast_ne_two h),
  apply_fun (coe : ℕ → 𝓞 K) at hk,
  rw [nat.cast_add, nat.cast_mul, nat.cast_two, nat.cast_one, ←coe_coe, add_comm] at hk,
  intro h2m,
  have := I .sub_mem hpm (I .mul_mem_right ↑k h2m),
  rw [sub_eq_of_eq_add hk] at this,
  exact (hζ.is_prime_one_sub_zeta h).ne_top (I .eq_top_of_is_unit_mem this is_unit_one)
end

omit hζ

lemma unit_inv_conj_not_neg_zeta_runity (h : p ≠ 2) (u : Rˣ) (n : ℕ) (hp : (p : ℕ).prime) :
  u * (unit_gal_conj K p u)⁻¹ ≠ -hζ.unit' ^ n :=
begin
  by_contra H,
  haveI := fact.mk hp,
  have hu := hζ.integral_power_basis'.basis.sum_repr u,
  set a := hζ.integral_power_basis'.basis.repr with ha,
  set φn := hζ.integral_power_basis'.dim with hφn,
  simp_rw [power_basis.basis_eq_pow, is_primitive_root.integral_power_basis'_gen] at hu,
  have hu' := congr_arg (int_gal ↑(gal_conj K p)) hu,
  replace hu' :
    (∑ (x : fin φn), (a u) x • (int_gal ↑(gal_conj K p)) (⟨ζ, hζ.is_integral p.pos⟩ ^ (x : ℕ))) =
    (unit_gal_conj K p u),
  { refine eq.trans _ hu',
    rw map_sum,
    congr' 1,
    ext x,
    congr' 1,
    rw map_zsmul },
  -- todo: probably swap `is_primitive_root.inv` and `is_primitive_root.inv'`.
  have : ∀ x : fin φn, int_gal ↑(gal_conj K p) (⟨ζ, hζ.is_integral p.pos⟩ ^ (x : ℕ)) =
                        ⟨ζ⁻¹, hζ.inv.is_integral p.pos⟩ ^ (x : ℕ),
  { intro x,
    ext,
    simp only [int_gal_apply_coe, map_pow, subsemiring_class.coe_pow, subtype.coe_mk],
    rw [←map_pow, alg_equiv.coe_alg_hom, gal_conj_zeta_runity_pow hζ] },
    conv_lhs at hu' { congr, congr, funext, rw [this x] },
  set u' := (unit_gal_conj K p) u,
  replace hu := aux hζ hζ hu,
  replace hu' := aux hζ hζ.inv hu', -- cool fact: `aux hζ _ hu'` works!
  rw mul_inv_eq_iff_eq_mul at H,
  -- subst H seems to be broken
  nth_rewrite 0 H at hu,
  push_cast at hu,
  rw [map_mul, map_neg, hζ.unit'_coe.eq_one_mod_sub_of_pow, neg_one_mul] at hu,
  swap,
  { rw [←pow_mul, mul_comm, pow_mul, hζ.unit'_coe.pow_eq_one, one_pow] },
  have key := hu'.trans hu.symm,
  have hI := hζ.is_prime_one_sub_zeta h,
  rw [←sub_eq_zero, sub_neg_eq_add, ←map_add, ←two_mul, ideal.quotient.algebra_map_eq,
      ideal.quotient.eq_zero_iff_mem, hI.mul_mem_iff_mem_or_mem] at key,
  cases key,
  { exact hζ.two_not_mem_one_sub_zeta h key },
  { exact hI.ne_top (I .eq_top_of_is_unit_mem key u'.is_unit) }
end

-- this proof has mild coe annoyances rn
lemma unit_inv_conj_is_root_of_unity (h : p ≠ 2) (hp : (p : ℕ).prime) (u : Rˣ) :
  ∃ m : ℕ, u * (unit_gal_conj K p u)⁻¹ = (hζ.unit' ^ m)^2 :=
begin
  have hpo : odd (p : ℕ) := hp.odd_of_ne_two (norm_cast_ne_two h),
  haveI : normed_algebra ℚ ℂ := normed_algebra_rat,
  have := @number_field.embeddings.pow_eq_one_of_norm_eq_one K _ _ ℂ _ _ _
    (u * (unit_gal_conj K p u)⁻¹ : K) _ _,
  have H := roots_of_unity_in_cyclo hζ hpo ((u * (unit_gal_conj K p u)⁻¹ : K)) this,
  obtain ⟨n, k, hz⟩ := H,
  simp_rw ← pow_mul,
  have hk := nat.even_or_odd k,
  cases hk,
  {simp only [hk.neg_one_pow, coe_coe, one_mul] at hz,
  simp_rw coe_life at hz,
  rw [←subalgebra.coe_mul, ←units.coe_mul, ←subalgebra.coe_pow, ←units.coe_pow] at hz,
  norm_cast at hz,
  rw hz,
  refine (exists_congr $ λ a, _).mp (zeta_runity_pow_even hζ hpo n),
  { rw mul_comm } },
  { by_contra hc,
    simp only [hk.neg_one_pow, coe_coe, neg_mul, one_mul] at hz,
    rw [coe_life, ← subalgebra.coe_mul, ← units.coe_mul, ← subalgebra.coe_pow,
      ← units.coe_pow] at hz,
    norm_cast at hz,
    simpa [hz] using unit_inv_conj_not_neg_zeta_runity hζ h u n hp },
  { apply is_integral_mul,
    exact number_field.ring_of_integers.is_integral_coe (coe_b u),
    rw (_ : ((unit_gal_conj K p u)⁻¹ : K) = (↑(unit_gal_conj K p u⁻¹))),
    exact number_field.ring_of_integers.is_integral_coe (coe_b _),
    simpa only [coe_coe, coe_life] },
  { exact unit_lemma_val_one K p u, },
end

lemma unit_lemma_gal_conj (h : p ≠ 2) (hp : (p : ℕ).prime) (u : Rˣ) :
  ∃ (x : Rˣ) (n : ℤ), (is_gal_conj_real p (x : K)) ∧ (u : 𝓞 K) = x * (hζ.unit' ^ n : (𝓞 K)ˣ) :=
begin
  have := unit_inv_conj_is_root_of_unity hζ h hp u,
  obtain ⟨m, hm⟩ := this,
  let xuu:=u * (hζ.unit'⁻¹ ^ (m)),
  use [xuu, m],
   rw is_gal_conj_real,
  have hy : u * (hζ.unit' ^ m)⁻¹ = (unit_gal_conj K p u) * hζ.unit' ^ ( m),
  by {rw pow_two at hm,
  have := auxil u (unit_gal_conj K p u) (hζ.unit' ^ m) (hζ.unit' ^ m),
  apply this hm},
  dsimp,
  simp only [inv_pow, alg_hom.map_mul],
  have hz: gal_conj K p (hζ.unit' ^ m)⁻¹ =(hζ.unit' ^ m),
  { simp [gal_conj_zeta_runity_pow hζ] },
  rw ← coe_coe,
  rw ← coe_coe,
  split,
  rw (_ : (↑(hζ.unit' ^ m)⁻¹ : K) = (hζ.unit' ^ m : K)⁻¹),
  rw [map_mul, hz],
  have hzz := unit_gal_conj_spec K p u,
  simp only [coe_coe],
  rw hzz,
  rw [←subalgebra.coe_pow, ←units.coe_pow, ←subalgebra.coe_mul, ←units.coe_mul],
  rw ← hy,
  simp only [subalgebra.coe_pow, subalgebra.coe_eq_zero, mul_eq_mul_left_iff,
  units.ne_zero, or_false, subalgebra.coe_mul, units.coe_pow, units.coe_mul],
  rw ← coe_life,
  simp only [subalgebra.coe_pow, units.coe_pow],
  simp_rw ← inv_pow,
  simp only [inv_pow, coe_coe],
  rw ← coe_life,
  simp only [subalgebra.coe_pow, units.coe_pow],
  simp only [zpow_coe_nat, units.coe_pow],
  norm_cast,
  simp,
end

/-
lemma unit_lemma (u : RRˣ) :
  ∃ (x : RRˣ) (n : ℤ), element_is_real (x : KK) ∧ (u : KK) = x * (zeta_runity p ℚ) ^ n :=
begin
  have := mem_roots_of_unity_of_abs_eq_one (u * (unit_gal_conj p u)⁻¹ : KK) _ _,
  { have : ∃ m : ℕ, u * (unit_gal_conj p u)⁻¹ = (zeta_runity p ℚ) ^ (2 * m),
    admit, --follows from above with some work
          -- what we have shows its +- a power of zeta_runity
    obtain ⟨m, hm⟩ := this,
    use [u * (zeta_runity p ℚ)⁻¹ ^ m, m],
    split,
    { rw element_is_real,
      intro φ,
      have := congr_arg (conj ∘ φ ∘ coe) hm,
      simp at this,
      simp [alg_hom.map_inv],
      rw ← coe_coe,
      rw ← coe_coe, -- TODO this is annoying
      rw (_ : (↑(zeta_runity p ℚ ^ m)⁻¹ : KK) = (zeta_runity p ℚ ^ m : KK)⁻¹),
      rw alg_hom.map_inv,
      rw ring_hom.map_inv,
      rw mul_inv_eq_iff_eq_mul₀,
      simp,
      admit, -- wow we should really have some more structure and simp lemmas to tame this beast
      admit, -- similar silly goal to below
      admit,
       },
    { simp only [mul_assoc, inv_pow, subalgebra.coe_mul, coe_coe, units.coe_mul, zpow_coe_nat],
      norm_cast,
      simp, }, },
  { exact unit_lemma_val_one p u, },
  { apply is_integral_mul,
    exact number_field.ring_of_integers.is_integral_coe (coe_b u),
    rw (_ : ((unit_gal_conj p u)⁻¹ : KK) = (↑(unit_gal_conj p u⁻¹))),
    exact number_field.ring_of_integers.is_integral_coe (coe_b _),
    simp,
    admit, -- tis a silly goal
     },
end
-/


import category_theory.preadditive.additive_functor

import system_of_complexes.basic

/-!

# Truncation

In this file we define a truncation functors for (systems of) complexes of seminormed groups.
This operation takes a complex `C` indexed by `ℕ`, and creates a new complex whose objects are
* in degree `0`:   the cokernel of `d : C 0 ⟶ C 1`
* in degree `n+1`: the object `C (n+2)`

Various lemmas are proved about how this construction preserves or reflects
various notions of bounded exactness.

-/

universes u

noncomputable theory
open_locale nnreal

open category_theory category_theory.limits

namespace SemiNormedGroup
open quotient_add_group

namespace truncate

variables (C : cochain_complex SemiNormedGroup.{u} ℕ)

open category_theory.preadditive

def X : ℕ → SemiNormedGroup.{u}
| 0     := explicit_cokernel (C.d 0 1)
| (n+1) := C.X (n+2)

def d : Π i j, X C i ⟶ X C j
| 0     1     := explicit_cokernel_desc (C.d_comp_d 0 1 2)
| (i+1) (j+1) := C.d (i+2) (j+2)
| _     _     := 0

lemma d_eq_zero : ∀ ⦃i j : ℕ⦄, ¬(complex_shape.up ℕ).rel i j → d C i j = 0
| 0     0     h := rfl
| 0     (j+2) h := rfl
| (i+1) 0     h := rfl
| 0     1     h := (h rfl).elim
| (i+1) (j+1) h := C.shape _ _ $ λ H, h $ nat.succ_injective $ H

lemma d_comp_d : Π i j k, i + 1 = j → j + 1 = k → d C i j ≫ d C j k = 0
| 0     1     2     rfl rfl := explicit_cokernel_desc_comp_eq_zero _ (C.d_comp_d _ _ _)
| (i+1) (j+1) (k+1) rfl rfl := C.d_comp_d _ _ _

@[simps]
def obj : cochain_complex SemiNormedGroup ℕ :=
{ X := X C,
  d := d C,
  shape' := d_eq_zero C,
  d_comp_d' := d_comp_d C }

lemma obj_d_add_one (C : cochain_complex SemiNormedGroup ℕ) (i j : ℕ) :
  (obj C).d (i+1) (j+1) = d C (i+1) (j+1) :=
rfl

def map_f {C₁ C₂ : cochain_complex SemiNormedGroup ℕ} (f : C₁ ⟶ C₂) :
  Π i:ℕ, X C₁ i ⟶ X C₂ i
| 0     := explicit_cokernel.map (f.comm 0 1).symm
| (i+1) := f.f (i+2)

lemma map_comm {C₁ C₂ : cochain_complex SemiNormedGroup.{u} ℕ} (f : C₁ ⟶ C₂) :
  Π i j, i + 1 = j → map_f f i ≫ d C₂ i j = d C₁ i j ≫ map_f f j
| 0     1     rfl := (explicit_coker.map_desc (f.comm 1 2).symm).symm
| (i+1) (j+1) rfl := f.comm (i+2) (j+2)

@[simps]
def map {C₁ C₂ : cochain_complex SemiNormedGroup.{u} ℕ} (f : C₁ ⟶ C₂) :
  obj C₁ ⟶ obj C₂ :=
{ f := map_f f,
  comm' := map_comm f }

end truncate

@[simps]
def truncate : cochain_complex SemiNormedGroup.{u} ℕ ⥤ cochain_complex SemiNormedGroup.{u} ℕ :=
{ obj := λ C, truncate.obj C,
  map := λ C₁ C₂ f, truncate.map f,
  map_id' := λ C, by ext (n|n) ⟨x⟩; refl,
  map_comp' := λ C₁ C₂ C₃ f g, by ext (n|n) ⟨x⟩; refl }

instance truncate.additive : truncate.additive :=
{ map_add' := by { intros, ext (_|n) ⟨⟩;
    simp only [truncate_map, truncate.map_f_2, homological_complex.add_f_apply, preadditive.comp_add,
      truncate.map_f, explicit_cokernel.map, preadditive.add_comp, explicit_cokernel_π_desc], } }

end SemiNormedGroup

namespace system_of_complexes

open category_theory

variables (C : system_of_complexes.{u})

@[simps]
def truncate : system_of_complexes ⥤ system_of_complexes :=
(whiskering_right _ _ _).obj $ SemiNormedGroup.truncate

@[simp] lemma truncate_obj_d_zero_one (c : ℝ≥0) (y : C c 1) :
  (truncate.obj C).d 0 1 (SemiNormedGroup.explicit_cokernel_π _ y) = C.d 1 2 y := rfl

@[simp] lemma truncate_obj_d_succ_succ (c : ℝ≥0) (i j : ℕ) (x: truncate.obj C c (i+1)) :
  (truncate.obj C).d (i+1) (j+1) x = C.d (i+2) (j+2) x := rfl

lemma truncate_admissible (hC : C.admissible) :
  (truncate.obj C).admissible :=
{ d_norm_noninc' :=
  begin
    rintro c (i|i) j rfl,
    { apply SemiNormedGroup.explicit_cokernel_desc_norm_noninc,
      exact hC.d_norm_noninc _ _ 1 2 },
    { exact hC.d_norm_noninc _ _ (i+2) (i+3) }
  end,
  res_norm_noninc :=
  begin
    rintro c₁ c₂ (i|i) h x,
    { apply SemiNormedGroup.explicit_cokernel_desc_norm_noninc _,
      exact (SemiNormedGroup.norm_noninc_explicit_cokernel_π _).comp (hC.res_norm_noninc _ _ _ _) },
    { exact hC.res_norm_noninc _ _ _ _ x }
  end }

variables {k K : ℝ≥0} (m' m : ℕ) [hk : fact (1 ≤ k)] (c₀ : ℝ≥0)
include hk

lemma truncate_is_weak_bounded_exact (hC : C.is_weak_bounded_exact k K (m+1) c₀) :
  (truncate.obj C).is_weak_bounded_exact k K m c₀
| c hc 0 hi x ε hε :=
begin
  let π := λ c, SemiNormedGroup.explicit_cokernel_π (@d C c 0 1),
  obtain ⟨x, rfl⟩ : ∃ x', π _ x' = x := SemiNormedGroup.explicit_cokernel_π_surjective x,
  obtain ⟨i₀, -, hi₀, rfl, y, hy⟩ := hC c hc _ (nat.succ_le_succ hi) x ε hε,
  obtain rfl : i₀ = 0, { rwa nat.sub_self at hi₀ }, clear hi,
  refine ⟨0, _, rfl, rfl, 0, _⟩,
  simp only [map_zero, sub_zero, map_neg, truncate_obj_d_zero_one, norm_neg],
  calc _ = ∥π c (res x - C.d 0 1 y)∥ : _
  ... ≤ ∥res x - C.d 0 1 y∥ : SemiNormedGroup.norm_noninc_explicit_cokernel_π _ _
  ... ≤ _ : hy,
  have hπy : π c (C.d 0 1 y) = 0,
  { show (C.d 0 1 ≫ π c) y = 0, rw [SemiNormedGroup.comp_explicit_cokernel_π], refl },
  simp only [_root_.map_sub, hπy, sub_zero], refl
end
| c hc (i+1) hi x ε hε :=
begin
  obtain ⟨_, _, rfl, rfl, y, hy⟩ := hC c hc _ (nat.succ_le_succ hi) x ε hε,
  refine ⟨i, _, rfl, rfl, _⟩,
  cases i; [exact ⟨SemiNormedGroup.explicit_cokernel_π _ y, hy⟩, exact ⟨y, hy⟩],
end

lemma is_weak_bounded_exact_of_truncate (IH : C.is_weak_bounded_exact k K m c₀)
  (hC : (truncate.obj C).is_weak_bounded_exact k K m c₀) :
  C.is_weak_bounded_exact k K (m+1) c₀
| c hc 0 hi x ε hε := IH c hc 0 (nat.zero_le _) x ε hε
| c hc 1 hi x ε hε :=
begin
  let π := λ c, SemiNormedGroup.explicit_cokernel_π (@d C c 0 1),
  let δ := ε / 2,
  have hδε : δ + δ = ε, { dsimp [δ], rw [← add_div, half_add_self] },
  have hδ : 0 < δ := div_pos hε zero_lt_two,
  obtain ⟨x', Hxx', Hx'⟩ : ∃ x', π c x' = π c (res x) ∧ ∥x'∥ < ∥π c (res x)∥ + δ :=
    (SemiNormedGroup.is_quotient_explicit_cokernel_π _).norm_lift hδ _,
  obtain ⟨y, hy⟩ : ∃ y : C c 0, C.d 0 1 y = res x - x',
  { erw [quotient_add_group.eq, add_comm, ← sub_eq_add_neg, set.mem_range] at Hxx',
    exact Hxx' },
  obtain ⟨_, _, rfl, rfl, y', H⟩ := hC c hc _ (nat.zero_le m) (π _ x) δ hδ,
  refine ⟨0, 2, rfl, rfl, y, _⟩,
  simp only [d_self_apply, map_zero, sub_zero, truncate_obj_d_zero_one, norm_neg] at H ⊢,
  calc ∥res x - (C.d 0 1) y∥ ≤ ∥x'∥ : by rw [hy, sub_sub_cancel]
  ... ≤ ∥π c (res x)∥ + δ : Hx'.le
  ... ≤ ↑K * ∥C.d 1 2 x∥ + δ + δ : add_le_add_right H _
  ... ≤ ↑K * ∥C.d 1 2 x∥ + ε : by rw [add_assoc, hδε]
end
| c hc (i+2) hi x ε hε :=
begin
  obtain ⟨_, _, rfl, rfl, y, hy⟩ := hC c hc (i+1) (nat.pred_le_pred hi) x ε hε,
  refine ⟨i+1, _, rfl, rfl, _⟩,
  cases i,
  { let π := λ c, SemiNormedGroup.explicit_cokernel_π (@d C c 0 1),
    obtain ⟨y, rfl⟩ : ∃ y', π _ y' = y := SemiNormedGroup.explicit_cokernel_π_surjective y,
    exact ⟨y, hy⟩ },
  { exact ⟨y, hy⟩ },
end

lemma truncate_is_weak_bounded_exact_iff (hC : C.is_weak_bounded_exact k K m c₀) :
  (truncate.obj C).is_weak_bounded_exact k K m c₀ ↔ C.is_weak_bounded_exact k K (m+1) c₀ :=
⟨is_weak_bounded_exact_of_truncate C m c₀ hC, truncate_is_weak_bounded_exact C m c₀⟩

omit hk

end system_of_complexes


import data.nat.modeq data.set.finite data.real.basic
open nat
local attribute [instance, priority 0] classical.prop_decidable
namespace set
open function
universe u
variable α : Type u
-- Author: Chris Hughes

-- Two lemmas courtesy of Johannes Hölzl via gitter, due to be added to mathlib
lemma infinite_univ_nat1 : infinite (univ : set ℕ) :=
 assume (h : finite (univ : set ℕ)),
 let ⟨n, hn⟩ := finset.exists_nat_subset_range h.to_finset in
 have n ∈ finset.range n, from finset.subset_iff.mpr hn $ by simp,
 by simp * at *

lemma not_injective_nat_fintype1 [fintype α] [decidable_eq α] {f : ℕ → α} : ¬ injective f :=
 assume (h : injective f),
 have finite (f '' univ),
   from finite_subset (finset.finite_to_set $ fintype.elems α) (assume a h, fintype.complete a),
 have finite (univ : set ℕ), from finite_of_finite_image h this,
 infinite_univ_nat this

end set

noncomputable instance subtype.fintype_le_nat (n : ℕ) : fintype {i : ℕ // i ≤ n} :=
  classical.choice $ set.finite_le_nat n

theorem sheet_7_2e (f : ℕ → ℕ) (d) : d > 0 → ∃ a b, a ≠ b ∧ f a ≡ f b [MOD d]:= sorry


namespace Reynold_operator
namespace Group.tools
open equiv
def to_equiv {G : Type u}[group G](g : G) : perm G := { to_fun := λ s, g*s,
  inv_fun := λ s, g⁻¹ *s,
  left_inv := begin dsimp, intros x,rw ← mul_assoc, rw inv_mul_self, rw one_mul,  end,
  right_inv :=  begin dsimp, intros x,rw ← mul_assoc, rw mul_inv_self, rw one_mul, end}
end Group.tools
open morphism
variables {G : Type u} [group G] [fintype G]{R : Type v}[comm_ring R] {M : Type w}  [add_comm_group M] [module R M]
          {M' : Type w'} [add_comm_group M'] [module R M']
          {f : G → (M →ₗ[R] M)}
notation  `Sum` := finset.sum finset.univ

constants (a: R)[hyp : a * ((fintype.card G) : R) = 1]

lemma Reynold_invariant (g : G) (h1 : G → M→ₗ[R]M') : Sum h1 =  Sum ( λ z, h1(Group.tools.to_equiv g z))  :=
 Sum_permutation h1 (Group.tools.to_equiv g)

def Reynold {G : Type u} [group G][fintype G](f : G → (M →ₗ[R] M'))  : M→ₗ[R]M' :=   Sum f

notation `ℳ `  := Reynold
variables (h1 h2 : M→ₗ[R] M')
#check a • h1+h2
lemma Reynold.add (h1 h2 : G  → M→ₗ[R] M') : ℳ (h1 + h2) =  ℳ h1  + ℳ h2 :=
begin

sorry, end
lemma Reynold.mul (a : R )(h1  : G  → M→ₗ[R] M') : ℳ ( a • h1 )= a •  ℳ h1   :=
begin
sorry,
 end
def mul_left (g : G) (h1 : G → M→ₗ[R]M') : G → M→ₗ[R]M' := λ s, h1 (s* g)
open technical
lemma Reynold_permutation (g : G) (h1 : G → M→ₗ[R]M') : ℳ ( λ z, h1(Group.tools.to_equiv g z)) = ℳ h1 :=
 begin
       unfold Reynold, erw ← Sum_permutation,
end
/--
    Let `ρ and π` two representation on `M` and `M'`. Let `f : M →ₗ[R] M'` a `linear_map`.
    Let  `ℒ f := Σ_{g ∈ G} π g⁻¹ ∘ f ∘ ρ  g`,   then  `ℒ f` is a morphism `ρ ⟶ π`.
    Proof :  `∀ t ∈ G,  ρ t ∘ ℒ f ∘ π t⁻¹  := ∑ ρ t g⁻¹  ∘ f ∘ π g t  = ∑  t'⁻¹  ∘  f ∘ π t'`
-/
def ℒ (ρ : group_representation G R M) (ρ'  : group_representation G R M') (f : M→ₗ[R]M') := Sum (λ g : G, (ρ' g⁻¹ : M' →ₗ[R] M')  * f * (ρ g : M →ₗ[R]M ))
#check @ℒ
open equiv function fintype finset
theorem pre_morphism (ρ : group_representation G R M) (ρ'  : group_representation G R M') (f : M→ₗ[R]M')
 (s : G) :  ρ' s  ∘   (ℒ  ρ ρ' f)
  = ℒ ρ ρ' f  ∘  ρ s  := begin
    ext, rw function.comp_apply,dunfold ℒ at ⊢,dsimp, sorry,
  end

#check ℳ
end Reynold_operator

namespace TEST
variables {G : Type u} [group G][fintype G]  {R : Type v}[comm_ring R] {M : Type w}  [add_comm_group M] [module R M]
          {M' : Type w'} [add_comm_group M'] [module R M']
          (φ : G → (M →ₗ[R]M'))
          (f : M' →ₗ[R]M')
lemma hello  :  f *  (finset.sum finset.univ φ) = finset.sum finset.univ (λ g, f * (φ g)) := begin
    ext,simp,
end


import pca
import re

namespace pca

universe variable u
variables {α : Type u}
variables [pca α]

namespace reducibility

def m_reducible (f g : α) : Prop := ∃ e : α, e ∈ (ℛ₀ : set α) ∧ (∀ x, ↓e * ↓g * ↓x = ↓f * ↓x)
def i_reducible (f g : α) : Prop :=
  ∃ e : α, e ∈ (ℛ₀ : set α) ∧ (∀ x, ↓e * ↓g * ↓x = ↓f * ↓x) ∧ (∀ x y, ↓e * ↓x = ↓e * ↓y → x = y)
infix ` ≤ₘ `:80 := m_reducible
infix ` ≡ₘ `:80 := λ f g, f ≤ₘ g ∧ g ≤ₘ f
infix ` ≤₁ `:80 := i_reducible
infix ` ≡₁ `:80 := λ f g, f ≤₁ g ∧ g ≤₁ f
def T_reducible (f g : α) : Prop := ∃ e : α, e ∈ (ℳ₀ : set α) ∧ ↓e * ↓g = ↓f
infix ` ≤ₜ `:80 := T_reducible
infix ` <ₜ `:80 := λ f g, f ≤ₜ g ∧ ¬g ≤ₜ f
infix ` ≡ₜ `:80 := λ f g, f ≤ₜ g ∧ g ≤ₜ f

@[refl] lemma T_reducible.refl (a : α) : a ≤ₜ a :=
by { use i, split, exact submodel.i, simp, }

@[trans] lemma T_reducible.trans (a b c : α) (hab : a ≤ₜ b) (hbc : b ≤ₜ c) : a ≤ₜ c :=
begin
  rcases hab with ⟨e_ab, ⟨e_ab_pr, heab⟩⟩,
  rcases hbc with ⟨e_bc, ⟨e_bc_pr, hebc⟩⟩,
  let e_ac := (0 →∅ &e_ab_pr * (&e_bc_pr * #0)),
  use e_ac,
  split,
  { show e_ac ∈ ℳ₀, simp, },
  { show ↓e_ac * ↓c = ↓a, simp [lam, expr, heab, hebc], },
end

end reducibility

end pca


/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Mario Carneiro
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.set_theory.ordinal_arithmetic
import Mathlib.PostPort

universes l u_1

namespace Mathlib

/-!
# Ordinal notations

constructive ordinal arithmetic for ordinals `< ε₀`.
-/

/-- Recursive definition of an ordinal notation. `zero` denotes the
  ordinal 0, and `oadd e n a` is intended to refer to `ω^e * n + a`.
  For this to be valid Cantor normal form, we must have the exponents
  decrease to the right, but we can't state this condition until we've
  defined `repr`, so it is a separate definition `NF`. -/
inductive onote
where
| zero : onote
| oadd : onote → ℕ+ → onote → onote

namespace onote

/-- Notation for 0 -/
protected instance has_zero : HasZero onote :=
  { zero := zero }

@[simp] theorem zero_def : zero = 0 :=
  rfl

protected instance inhabited : Inhabited onote :=
  { default := 0 }

/-- Notation for 1 -/
protected instance has_one : HasOne onote :=
  { one := oadd 0 1 0 }

/-- Notation for ω -/
def omega : onote :=
  oadd 1 1 0

/-- The ordinal denoted by a notation -/
@[simp] def repr : onote → ordinal :=
  sorry

/-- Auxiliary definition to print an ordinal notation -/
def to_string_aux1 (e : onote) (n : ℕ) (s : string) : string :=
  ite (e = 0) (to_string n)
    (ite (e = 1) (string.str string.empty (char.of_nat (bit1 (bit0 (bit0 (bit1 (bit0 (bit0 (bit1 (bit1 (bit1 1)))))))))))
        (string.str
              (string.str
                (string.str string.empty (char.of_nat (bit1 (bit0 (bit0 (bit1 (bit0 (bit0 (bit1 (bit1 (bit1 1)))))))))))
                (char.of_nat (bit0 (bit1 (bit1 (bit1 (bit1 (bit0 1))))))))
              (char.of_nat (bit0 (bit0 (bit0 (bit1 (bit0 1)))))) ++
            s ++
          string.str string.empty (char.of_nat (bit1 (bit0 (bit0 (bit1 (bit0 1))))))) ++
      ite (n = 1) string.empty
        (string.str string.empty (char.of_nat (bit0 (bit1 (bit0 (bit1 (bit0 1)))))) ++ to_string n))

/-- Print an ordinal notation -/
def to_string : onote → string :=
  sorry

/-- Print an ordinal notation -/
def repr' : onote → string :=
  sorry

protected instance has_to_string : has_to_string onote :=
  has_to_string.mk to_string

protected instance has_repr : has_repr onote :=
  has_repr.mk repr'

protected instance preorder : preorder onote :=
  preorder.mk (fun (x y : onote) => repr x ≤ repr y) (fun (x y : onote) => repr x < repr y) sorry sorry

theorem lt_def {x : onote} {y : onote} : x < y ↔ repr x < repr y :=
  iff.rfl

theorem le_def {x : onote} {y : onote} : x ≤ y ↔ repr x ≤ repr y :=
  iff.rfl

/-- Convert a `nat` into an ordinal -/
@[simp] def of_nat : ℕ → onote :=
  sorry

@[simp] theorem of_nat_one : of_nat 1 = 1 :=
  rfl

@[simp] theorem repr_of_nat (n : ℕ) : repr (of_nat n) = ↑n := sorry

@[simp] theorem repr_one : repr 1 = 1 := sorry

theorem omega_le_oadd (e : onote) (n : ℕ+) (a : onote) : ordinal.omega ^ repr e ≤ repr (oadd e n a) := sorry

theorem oadd_pos (e : onote) (n : ℕ+) (a : onote) : 0 < oadd e n a :=
  lt_of_lt_of_le (ordinal.power_pos (repr e) ordinal.omega_pos) (omega_le_oadd e n a)

/-- Compare ordinal notations -/
def cmp : onote → onote → ordering :=
  sorry

theorem eq_of_cmp_eq {o₁ : onote} {o₂ : onote} : cmp o₁ o₂ = ordering.eq → o₁ = o₂ := sorry

theorem zero_lt_one : 0 < 1 :=
  eq.mpr (id (Eq._oldrec (Eq.refl (0 < 1)) (propext lt_def)))
    (eq.mpr (id (Eq._oldrec (Eq.refl (repr 0 < repr 1)) repr.equations._eqn_1))
      (eq.mpr (id (Eq._oldrec (Eq.refl (0 < repr 1)) repr_one)) ordinal.zero_lt_one))

/-- `NF_below o b` says that `o` is a normal form ordinal notation
  satisfying `repr o < ω ^ b`. -/
inductive NF_below : onote → ordinal → Prop
where
| zero : ∀ {b : ordinal}, NF_below 0 b
| oadd' : ∀ {e : onote} {n : ℕ+} {a : onote} {eb b : ordinal},
  NF_below e eb → NF_below a (repr e) → repr e < b → NF_below (oadd e n a) b

/-- A normal form ordinal notation has the form

     ω ^ a₁ * n₁ + ω ^ a₂ * n₂ + ... ω ^ aₖ * nₖ
  where `a₁ > a₂ > ... > aₖ` and all the `aᵢ` are
  also in normal form.

  We will essentially only be interested in normal form
  ordinal notations, but to avoid complicating the algorithms
  we define everything over general ordinal notations and
  only prove correctness with normal form as an invariant. -/
def NF (o : onote) :=
  Exists (NF_below o)

protected instance NF.zero : NF 0 :=
  Exists.intro 0 NF_below.zero

theorem NF_below.oadd {e : onote} {n : ℕ+} {a : onote} {b : ordinal} : NF e → NF_below a (repr e) → repr e < b → NF_below (oadd e n a) b := sorry

theorem NF_below.fst {e : onote} {n : ℕ+} {a : onote} {b : ordinal} (h : NF_below (oadd e n a) b) : NF e := sorry

theorem NF.fst {e : onote} {n : ℕ+} {a : onote} : NF (oadd e n a) → NF e :=
  fun (ᾰ : NF (oadd e n a)) =>
    Exists.dcases_on ᾰ fun (ᾰ_w : ordinal) (ᾰ_h : NF_below (oadd e n a) ᾰ_w) => idRhs (NF e) (NF_below.fst ᾰ_h)

theorem NF_below.snd {e : onote} {n : ℕ+} {a : onote} {b : ordinal} (h : NF_below (oadd e n a) b) : NF_below a (repr e) := sorry

theorem NF.snd' {e : onote} {n : ℕ+} {a : onote} : NF (oadd e n a) → NF_below a (repr e) :=
  fun (ᾰ : NF (oadd e n a)) =>
    Exists.dcases_on ᾰ
      fun (ᾰ_w : ordinal) (ᾰ_h : NF_below (oadd e n a) ᾰ_w) => idRhs (NF_below a (repr e)) (NF_below.snd ᾰ_h)

theorem NF.snd {e : onote} {n : ℕ+} {a : onote} (h : NF (oadd e n a)) : NF a :=
  Exists.intro (repr e) (NF.snd' h)

theorem NF.oadd {e : onote} {a : onote} (h₁ : NF e) (n : ℕ+) (h₂ : NF_below a (repr e)) : NF (oadd e n a) :=
  Exists.intro (ordinal.succ (repr e)) (NF_below.oadd h₁ h₂ (ordinal.lt_succ_self (repr e)))

protected instance NF.oadd_zero (e : onote) (n : ℕ+) [h : NF e] : NF (oadd e n 0) :=
  NF.oadd h n NF_below.zero

theorem NF_below.lt {e : onote} {n : ℕ+} {a : onote} {b : ordinal} (h : NF_below (oadd e n a) b) : repr e < b := sorry

theorem NF_below_zero {o : onote} : NF_below o 0 ↔ o = 0 := sorry

theorem NF.zero_of_zero {e : onote} {n : ℕ+} {a : onote} (h : NF (oadd e n a)) (e0 : e = 0) : a = 0 := sorry

theorem NF_below.repr_lt {o : onote} {b : ordinal} (h : NF_below o b) : repr o < ordinal.omega ^ b := sorry

theorem NF_below.mono {o : onote} {b₁ : ordinal} {b₂ : ordinal} (bb : b₁ ≤ b₂) (h : NF_below o b₁) : NF_below o b₂ := sorry

theorem NF.below_of_lt {e : onote} {n : ℕ+} {a : onote} {b : ordinal} (H : repr e < b) : NF (oadd e n a) → NF_below (oadd e n a) b := sorry

theorem NF.below_of_lt' {o : onote} {b : ordinal} : repr o < ordinal.omega ^ b → NF o → NF_below o b := sorry

theorem NF_below_of_nat (n : ℕ) : NF_below (of_nat n) 1 :=
  nat.cases_on n (idRhs (NF_below 0 1) NF_below.zero)
    fun (n : ℕ) =>
      idRhs (NF_below (oadd 0 (nat.succ_pnat n) 0) 1) (NF_below.oadd NF.zero NF_below.zero ordinal.zero_lt_one)

protected instance NF_of_nat (n : ℕ) : NF (of_nat n) :=
  Exists.intro 1 (NF_below_of_nat n)

protected instance NF_one : NF 1 :=
  eq.mpr (id (Eq._oldrec (Eq.refl (NF 1)) (Eq.symm of_nat_one))) (onote.NF_of_nat 1)

theorem oadd_lt_oadd_1 {e₁ : onote} {n₁ : ℕ+} {o₁ : onote} {e₂ : onote} {n₂ : ℕ+} {o₂ : onote} (h₁ : NF (oadd e₁ n₁ o₁)) (h : e₁ < e₂) : oadd e₁ n₁ o₁ < oadd e₂ n₂ o₂ :=
  lt_of_lt_of_le (NF_below.repr_lt (NF.below_of_lt h h₁)) (omega_le_oadd e₂ n₂ o₂)

theorem oadd_lt_oadd_2 {e : onote} {o₁ : onote} {o₂ : onote} {n₁ : ℕ+} {n₂ : ℕ+} (h₁ : NF (oadd e n₁ o₁)) (h : ↑n₁ < ↑n₂) : oadd e n₁ o₁ < oadd e n₂ o₂ := sorry

theorem oadd_lt_oadd_3 {e : onote} {n : ℕ+} {a₁ : onote} {a₂ : onote} (h : a₁ < a₂) : oadd e n a₁ < oadd e n a₂ := sorry

theorem cmp_compares (a : onote) (b : onote) [NF a] [NF b] : ordering.compares (cmp a b) a b := sorry

theorem repr_inj {a : onote} {b : onote} [NF a] [NF b] : repr a = repr b ↔ a = b := sorry

theorem NF.of_dvd_omega_power {b : ordinal} {e : onote} {n : ℕ+} {a : onote} (h : NF (oadd e n a)) (d : ordinal.omega ^ b ∣ repr (oadd e n a)) : b ≤ repr e ∧ ordinal.omega ^ b ∣ repr a := sorry

theorem NF.of_dvd_omega {e : onote} {n : ℕ+} {a : onote} (h : NF (oadd e n a)) : ordinal.omega ∣ repr (oadd e n a) → repr e ≠ 0 ∧ ordinal.omega ∣ repr a := sorry

/-- `top_below b o` asserts that the largest exponent in `o`, if
  it exists, is less than `b`. This is an auxiliary definition
  for decidability of `NF`. -/
def top_below (b : onote) : onote → Prop :=
  sorry

protected instance decidable_top_below : DecidableRel top_below :=
  id
    fun (b o : onote) =>
      onote.cases_on o (id decidable.true)
        fun (o_ᾰ : onote) (o_ᾰ_1 : ℕ+) (o_ᾰ_2 : onote) => id (ordering.decidable_eq (cmp o_ᾰ b) ordering.lt)

theorem NF_below_iff_top_below {b : onote} [NF b] {o : onote} : NF_below o (repr b) ↔ NF o ∧ top_below b o := sorry

protected instance decidable_NF : decidable_pred NF :=
  sorry

/-- Addition of ordinal notations (correct only for normal input) -/
def add : onote → onote → onote :=
  sorry

protected instance has_add : Add onote :=
  { add := add }

@[simp] theorem zero_add (o : onote) : 0 + o = o :=
  rfl

theorem oadd_add (e : onote) (n : ℕ+) (a : onote) (o : onote) : oadd e n a + o = add._match_1 e n (a + o) :=
  rfl

/-- Subtraction of ordinal notations (correct only for normal input) -/
def sub : onote → onote → onote :=
  sorry

protected instance has_sub : Sub onote :=
  { sub := sub }

theorem add_NF_below {b : ordinal} {o₁ : onote} {o₂ : onote} : NF_below o₁ b → NF_below o₂ b → NF_below (o₁ + o₂) b := sorry

protected instance add_NF (o₁ : onote) (o₂ : onote) [NF o₁] [NF o₂] : NF (o₁ + o₂) :=
  sorry

@[simp] theorem repr_add (o₁ : onote) (o₂ : onote) [NF o₁] [NF o₂] : repr (o₁ + o₂) = repr o₁ + repr o₂ := sorry

theorem sub_NF_below {o₁ : onote} {o₂ : onote} {b : ordinal} : NF_below o₁ b → NF o₂ → NF_below (o₁ - o₂) b := sorry

protected instance sub_NF (o₁ : onote) (o₂ : onote) [NF o₁] [NF o₂] : NF (o₁ - o₂) :=
  sorry

@[simp] theorem repr_sub (o₁ : onote) (o₂ : onote) [NF o₁] [NF o₂] : repr (o₁ - o₂) = repr o₁ - repr o₂ := sorry

/-- Multiplication of ordinal notations (correct only for normal input) -/
def mul : onote → onote → onote :=
  sorry

protected instance has_mul : Mul onote :=
  { mul := mul }

@[simp] theorem zero_mul (o : onote) : 0 * o = 0 :=
  onote.cases_on o (Eq.refl (0 * zero))
    fun (o_ᾰ : onote) (o_ᾰ_1 : ℕ+) (o_ᾰ_2 : onote) => Eq.refl (0 * oadd o_ᾰ o_ᾰ_1 o_ᾰ_2)

@[simp] theorem mul_zero (o : onote) : o * 0 = 0 :=
  onote.cases_on o (Eq.refl (zero * 0))
    fun (o_ᾰ : onote) (o_ᾰ_1 : ℕ+) (o_ᾰ_2 : onote) => Eq.refl (oadd o_ᾰ o_ᾰ_1 o_ᾰ_2 * 0)

theorem oadd_mul (e₁ : onote) (n₁ : ℕ+) (a₁ : onote) (e₂ : onote) (n₂ : ℕ+) (a₂ : onote) : oadd e₁ n₁ a₁ * oadd e₂ n₂ a₂ = ite (e₂ = 0) (oadd e₁ (n₁ * n₂) a₁) (oadd (e₁ + e₂) n₂ (oadd e₁ n₁ a₁ * a₂)) :=
  rfl

theorem oadd_mul_NF_below {e₁ : onote} {n₁ : ℕ+} {a₁ : onote} {b₁ : ordinal} (h₁ : NF_below (oadd e₁ n₁ a₁) b₁) {o₂ : onote} {b₂ : ordinal} : NF_below o₂ b₂ → NF_below (oadd e₁ n₁ a₁ * o₂) (repr e₁ + b₂) := sorry

protected instance mul_NF (o₁ : onote) (o₂ : onote) [NF o₁] [NF o₂] : NF (o₁ * o₂) :=
  sorry

@[simp] theorem repr_mul (o₁ : onote) (o₂ : onote) [NF o₁] [NF o₂] : repr (o₁ * o₂) = repr o₁ * repr o₂ := sorry

/-- Calculate division and remainder of `o` mod ω.
  `split' o = (a, n)` means `o = ω * a + n`. -/
def split' : onote → onote × ℕ :=
  sorry

/-- Calculate division and remainder of `o` mod ω.
  `split o = (a, n)` means `o = a + n`, where `ω ∣ a`. -/
def split : onote → onote × ℕ :=
  sorry

/-- `scale x o` is the ordinal notation for `ω ^ x * o`. -/
def scale (x : onote) : onote → onote :=
  sorry

/-- `mul_nat o n` is the ordinal notation for `o * n`. -/
def mul_nat : onote → ℕ → onote :=
  sorry

/-- Auxiliary definition to compute the ordinal notation for the ordinal
exponentiation in `power` -/
def power_aux (e : onote) (a0 : onote) (a : onote) : ℕ → ℕ → onote :=
  sorry

/-- `power o₁ o₂` calculates the ordinal notation for
  the ordinal exponential `o₁ ^ o₂`. -/
def power (o₁ : onote) (o₂ : onote) : onote :=
  sorry

protected instance has_pow : has_pow onote onote :=
  has_pow.mk power

theorem power_def (o₁ : onote) (o₂ : onote) : o₁ ^ o₂ = power._match_1 o₂ (split o₁) :=
  rfl

theorem split_eq_scale_split' {o : onote} {o' : onote} {m : ℕ} [NF o] : split' o = (o', m) → split o = (scale 1 o', m) := sorry

theorem NF_repr_split' {o : onote} {o' : onote} {m : ℕ} [NF o] : split' o = (o', m) → NF o' ∧ repr o = ordinal.omega * repr o' + ↑m := sorry

theorem scale_eq_mul (x : onote) [NF x] (o : onote) [NF o] : scale x o = oadd x 1 0 * o := sorry

protected instance NF_scale (x : onote) [NF x] (o : onote) [NF o] : NF (scale x o) :=
  eq.mpr (id (Eq._oldrec (Eq.refl (NF (scale x o))) (scale_eq_mul x o))) (onote.mul_NF (oadd x 1 0) o)

@[simp] theorem repr_scale (x : onote) [NF x] (o : onote) [NF o] : repr (scale x o) = ordinal.omega ^ repr x * repr o := sorry

theorem NF_repr_split {o : onote} {o' : onote} {m : ℕ} [NF o] (h : split o = (o', m)) : NF o' ∧ repr o = repr o' + ↑m := sorry

theorem split_dvd {o : onote} {o' : onote} {m : ℕ} [NF o] (h : split o = (o', m)) : ordinal.omega ∣ repr o' := sorry

theorem split_add_lt {o : onote} {e : onote} {n : ℕ+} {a : onote} {m : ℕ} [NF o] (h : split o = (oadd e n a, m)) : repr a + ↑m < ordinal.omega ^ repr e := sorry

@[simp] theorem mul_nat_eq_mul (n : ℕ) (o : onote) : mul_nat o n = o * of_nat n := sorry

protected instance NF_mul_nat (o : onote) [NF o] (n : ℕ) : NF (mul_nat o n) :=
  eq.mpr
    (id ((fun (o o_1 : onote) (e_1 : o = o_1) => congr_arg NF e_1) (mul_nat o n) (o * of_nat n) (mul_nat_eq_mul n o)))
    (onote.mul_NF o (of_nat n))

protected instance NF_power_aux (e : onote) (a0 : onote) (a : onote) [NF e] [NF a0] [NF a] (k : ℕ) (m : ℕ) : NF (power_aux e a0 a k m) :=
  sorry

protected instance NF_power (o₁ : onote) (o₂ : onote) [NF o₁] [NF o₂] : NF (o₁ ^ o₂) := sorry

theorem scale_power_aux (e : onote) (a0 : onote) (a : onote) [NF e] [NF a0] [NF a] (k : ℕ) (m : ℕ) : repr (power_aux e a0 a k m) = ordinal.omega ^ repr e * repr (power_aux 0 a0 a k m) := sorry

theorem repr_power_aux₁ {e : onote} {a : onote} [Ne : NF e] [Na : NF a] {a' : ordinal} (e0 : repr e ≠ 0) (h : a' < ordinal.omega ^ repr e) (aa : repr a = a') (n : ℕ+) : (ordinal.omega ^ repr e * ↑↑n + a') ^ ordinal.omega = (ordinal.omega ^ repr e) ^ ordinal.omega := sorry

theorem repr_power_aux₂ {a0 : onote} {a' : onote} [N0 : NF a0] [Na' : NF a'] (m : ℕ) (d : ordinal.omega ∣ repr a') (e0 : repr a0 ≠ 0) (h : repr a' + ↑m < ordinal.omega ^ repr a0) (n : ℕ+) (k : ℕ) : let R : ordinal := repr (power_aux 0 a0 (oadd a0 n a' * of_nat m) k m);
(k ≠ 0 → R < (ordinal.omega ^ repr a0) ^ ordinal.succ ↑k) ∧
  (ordinal.omega ^ repr a0) ^ ↑k * (ordinal.omega ^ repr a0 * ↑↑n + repr a') + R =
    (ordinal.omega ^ repr a0 * ↑↑n + repr a' + ↑m) ^ ordinal.succ ↑k := sorry

theorem repr_power (o₁ : onote) (o₂ : onote) [NF o₁] [NF o₂] : repr (o₁ ^ o₂) = repr o₁ ^ repr o₂ := sorry

end onote

/-- The type of normal ordinal notations. (It would have been
  nicer to define this right in the inductive type, but `NF o`
  requires `repr` which requires `onote`, so all these things
  would have to be defined at once, which messes up the VM
  representation.) -/
def nonote :=
  Subtype fun (o : onote) => onote.NF o

protected instance nonote.decidable_eq : DecidableEq nonote :=
  eq.mpr sorry fun (a b : Subtype fun (o : onote) => onote.NF o) => subtype.decidable_eq a b

namespace nonote

protected instance NF (o : nonote) : onote.NF (subtype.val o) :=
  subtype.property o

/-- Construct a `nonote` from an ordinal notation
  (and infer normality) -/
def mk (o : onote) [h : onote.NF o] : nonote :=
  { val := o, property := h }

/-- The ordinal represented by an ordinal notation.
  (This function is noncomputable because ordinal
  arithmetic is noncomputable. In computational applications
  `nonote` can be used exclusively without reference
  to `ordinal`, but this function allows for correctness
  results to be stated.) -/
def repr (o : nonote) : ordinal :=
  onote.repr (subtype.val o)

protected instance has_to_string : has_to_string nonote :=
  has_to_string.mk fun (x : nonote) => onote.to_string (subtype.val x)

protected instance has_repr : has_repr nonote :=
  has_repr.mk fun (x : nonote) => onote.repr' (subtype.val x)

protected instance preorder : preorder nonote :=
  preorder.mk (fun (x y : nonote) => repr x ≤ repr y) (fun (x y : nonote) => repr x < repr y) sorry sorry

protected instance has_zero : HasZero nonote :=
  { zero := { val := 0, property := onote.NF.zero } }

protected instance inhabited : Inhabited nonote :=
  { default := 0 }

/-- Convert a natural number to an ordinal notation -/
def of_nat (n : ℕ) : nonote :=
  { val := onote.of_nat n, property := sorry }

/-- Compare ordinal notations -/
def cmp (a : nonote) (b : nonote) : ordering :=
  onote.cmp (subtype.val a) (subtype.val b)

theorem cmp_compares (a : nonote) (b : nonote) : ordering.compares (cmp a b) a b := sorry

protected instance linear_order : linear_order nonote :=
  linear_order_of_compares cmp cmp_compares

/-- Asserts that `repr a < ω ^ repr b`. Used in `nonote.rec_on` -/
def old_below (a : nonote) (b : nonote) :=
  onote.NF_below (subtype.val a) (repr b)

/-- The `oadd` pseudo-constructor for `nonote` -/
def oadd (e : nonote) (n : ℕ+) (a : nonote) (h : old_below a e) : nonote :=
  { val := onote.oadd (subtype.val e) n (subtype.val a), property := sorry }

/-- This is a recursor-like theorem for `nonote` suggesting an
  inductive definition, which can't actually be defined this
  way due to conflicting dependencies. -/
def rec_on {C : nonote → Sort u_1} (o : nonote) (H0 : C 0) (H1 : (e : nonote) → (n : ℕ+) → (a : nonote) → (h : old_below a e) → C e → C a → C (oadd e n a h)) : C o :=
  subtype.cases_on o
    fun (o : onote) (h : onote.NF o) =>
      onote.rec (fun (h : onote.NF onote.zero) => H0)
        (fun (e : onote) (n : ℕ+) (a : onote) (IHe : (h : onote.NF e) → C { val := e, property := h })
          (IHa : (h : onote.NF a) → C { val := a, property := h }) (h : onote.NF (onote.oadd e n a)) =>
          H1 { val := e, property := onote.NF.fst h } n { val := a, property := onote.NF.snd h } (onote.NF.snd' h)
            (IHe (onote.NF.fst h)) (IHa (onote.NF.snd h)))
        o h

/-- Addition of ordinal notations -/
protected instance has_add : Add nonote :=
  { add := fun (x y : nonote) => mk (subtype.val x + subtype.val y) }

theorem repr_add (a : nonote) (b : nonote) : repr (a + b) = repr a + repr b :=
  onote.repr_add (subtype.val a) (subtype.val b)

/-- Subtraction of ordinal notations -/
protected instance has_sub : Sub nonote :=
  { sub := fun (x y : nonote) => mk (subtype.val x - subtype.val y) }

theorem repr_sub (a : nonote) (b : nonote) : repr (a - b) = repr a - repr b :=
  onote.repr_sub (subtype.val a) (subtype.val b)

/-- Multiplication of ordinal notations -/
protected instance has_mul : Mul nonote :=
  { mul := fun (x y : nonote) => mk (subtype.val x * subtype.val y) }

theorem repr_mul (a : nonote) (b : nonote) : repr (a * b) = repr a * repr b :=
  onote.repr_mul (subtype.val a) (subtype.val b)

/-- Exponentiation of ordinal notations -/
def power (x : nonote) (y : nonote) : nonote :=
  mk (onote.power (subtype.val x) (subtype.val y))

theorem repr_power (a : nonote) (b : nonote) : repr (power a b) = ordinal.power (repr a) (repr b) :=
  onote.repr_power (subtype.val a) (subtype.val b)


import .lovelib

/-! # LoVe Homework 7: Metaprogramming

Homework must be done individually. -/

set_option pp.beta true
set_option pp.generalized_field_notation false

namespace LoVe

/-! ## Question 1 (9 points): A `mindless` Tactic

We develop a tactic that automates some of the mindless `intro`/`apply`
proofs that formed the core of lecture 2.

We proceed in three steps.

1.1 (6 points). Develop a `mindless_safe` tactic that applies the
introduction rules for `true`, `∧`, and `↔`, that invokes `tactic.intro` (or
`tactic.intro1`) for `→`/`∀`, and that invokes `tactic.assumption`, repeatedly
on all goals. The tactic generalizes `intro_ands` from the exercise.

Hint: You can use the `<|>` operator between the rules/tactics used for
different symbols. -/

#check tactic.repeat
#check tactic.applyc
#check tactic.intro
#check tactic.intro1

meta def mindless_safe : tactic unit :=
sorry

lemma abcd (a b c d : Prop) (hc : c) :
  a → ¬ b ∧ (c ↔ d) :=
begin
  mindless_safe,
  /- The proof state should be roughly as follows:

  a b c d : Prop,
  hc : c,
  a_1 : a,
  a_2 : b
  ⊢ false

  a b c d : Prop,
  hc : c,
  a_1 : a,
  a_2 : c
  ⊢ d -/
  repeat { sorry }
end

/-! 1.2 (3 points). Develop a `mindless_unsafe` tactic that works on the current
goal. For each hypothesis in turn:

1. It first tries to apply the hypothesis in turn using `tactic.apply`.

2. If this does not fail, it invokes some `continue` tactic, which is passed as
   argument.

3. If this does not fail, it invokes `tactic.done`, which succeeds only if there
   are no goals left.

Once a hypothesis has been found for which steps 1 to 3 succeed,
`mindless_unsafe` succeeds. -/

meta def mindless_unsafe (continue : tactic unit) : tactic unit :=
sorry

/-! A few tests follow. -/

lemma modus_ponens (a b : Prop) (ha : a) (hab : a → b) :
  b :=
by mindless_unsafe tactic.assumption

lemma junky_modus_ponens (a b c d : Prop) (ha : a) (hcb : c → b) (hab : a → b)
    (hdb : d → b) :
  b :=
by mindless_unsafe tactic.assumption

lemma refl_modus_ponens (n : ℕ) (b : Prop) (hnnb : n = n → b) :
  b :=
by mindless_unsafe tactic.reflexivity

/-! Finally, everything comes together with the `mindless` tactic below. The
tactic performs a depth-bounded search for a proof, applying `mindless_safe`
and `mindless_unsafe` on all goals in alternation. The bound is necessary to
eventually backtrack. -/

meta def mindless : ℕ → tactic unit
| 0           := mindless_safe
| (depth + 1) :=
  do
    mindless_safe,
    tactic.all_goals (tactic.try (mindless_unsafe (mindless depth))),
    pure ()

/-! Some tests are provided below. All should succeed. -/

lemma I (a : Prop) :
  a → a :=
by mindless 0

lemma K (a b : Prop) :
  a → b → b :=
by mindless 0

lemma C (a b c : Prop) :
  (a → b → c) → b → a → c :=
by mindless 1

lemma proj_1st (a : Prop) :
  a → a → a :=
by mindless 0

lemma some_nonsense (a b c : Prop) :
  (a → b → c) → a → (a → c) → b → c :=
by mindless 1

lemma contrapositive (a b : Prop) :
  (a → b) → ¬ b → ¬ a :=
by mindless 2

lemma B (a b c : Prop) :
  (a → b) → (c → a) → c → b :=
by mindless 2

lemma S (a b c : Prop) :
  (a → b → c) → (a → b) → a → c :=
by mindless 2

lemma more_nonsense (a b c : Prop) :
  (c → (a → b) → a) → c → b → a :=
by mindless 1

lemma even_more_nonsense (a b c : Prop) :
  (a → a → b) → (b → c) → a → b → c :=
by mindless 1

lemma weak_peirce (a b : Prop) :
  ((((a → b) → a) → a) → b) → b :=
by mindless 3

lemma one_for_the_road (a c : Prop) (ha : a) (hccc : c → c → c) (hac : a → c) :
  c :=
by mindless 1

/-! ## Question 2 (2 bonus points): An `auto` Tactic

2.1 (1 bonus point). Develop an Isabelle-style `auto` tactic.

This tactic would apply all harmless introduction and elimination rules. In
addition, it would try potentially harmful rules (such as `or.intro_left` and
`false.elim`) but backtrack at some point (or try several possibilities in
parallel). Iterative deepening may be a valid approach, or best-first search, or
breadth-first search. The tactic should also attempt to apply assumptions whose
conclusion matches the goal, but backtrack if necessary.

See also "Automatic Proof and Disproof in Isabelle/HOL"
(https://www.cs.vu.nl/~jbe248/frocos2011-dis-proof.pdf) by Blanchette, Bulwahn,
and Nipkow, and the references they give.

2.2 (1 bonus point). Test your tactic on some benchmarks.

You can try your tactic on logic puzzles of the kinds we proved in exercise 2
and homework 2. Please include these below. -/

end LoVe


import tactic.apply
import topology.instances.real
       -- algebra.pi_instances

example : ∀ n m : ℕ, n + m = m + n :=
begin
  apply' nat.rec,
  -- refine nat.rec _ _,
  { intro m, ring },
  { intros n h m,
    ring, },
end

instance : partial_order unit :=
{ le := λ _ _, ∀ (x : ℕ), x = x,
  lt := λ _ _, false,
  le_refl := λ _ _, rfl,
  le_trans := λ _ _ _ _ _ _, rfl,
  lt_iff_le_not_le := λ _ _, by simp,
  le_antisymm := λ ⟨⟩ ⟨⟩ _ _, rfl }

example : unit.star ≤ unit.star :=
begin
  have u : unit := unit.star,
  apply' le_trans,
  -- refine le_trans _ _,
  -- exact unit.star,
  do { gs ← tactic.get_goals, guard (gs.length = 3) },
  change () ≤ u,
  all_goals { cases u, refl', } ,
  -- refine le_rfl, refine le_rfl,
end

example {α β : Type*} [partial_order β] (x y z : α → β) (h₀ : x ≤ y) (h₁ : y ≤ z) : x ≤ z :=
begin
  transitivity',
  do { gs ← tactic.get_goals, guard (gs.length = 2) },
  exact h₀, exact h₁,
end
example : continuous (λ (x : ℝ), x + x) :=
begin
  apply' continuous.add,
  guard_target' continuous (λ (x : ℝ), x), apply @continuous_id ℝ _,
  guard_target' continuous (λ (x : ℝ), x), apply @continuous_id ℝ _,
  -- guard_target' has_continuous_add ℝ, admit,
end

example (y : ℝ) : continuous (λ (x : ℝ), x + y) :=
begin
  apply' continuous.add,
  guard_target' continuous (λ (x : ℝ), x), apply @continuous_id ℝ _,
  guard_target' continuous (λ (x : ℝ), y), apply @continuous_const ℝ _ _,
  -- guard_target' has_continuous_add ℝ, admit,
end


/-
Copyright (c) 2021 Kalle Kytölä. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kalle Kytölä
-/
import portmanteau_definitions
import portmanteau_topological_lemmas
import portmanteau_proba_lemmas

noncomputable theory
open measure_theory
open filter

namespace portmanteau

section portmanteau_open_equiv_closed

variables {α : Type} [topological_space α]

notation `borel_measure`(α) := @measure_theory.measure α (borel α)
notation `borel_set`(α) E := (borel α).measurable_set' E

lemma portmanteau_open_imp_closed_cond
  (μseq : ℕ → (borel_measure(α)))
  (μseq_fin : ∀ (n : ℕ) , @probability_measure α (borel(α)) (μseq(n)))
  (μ : borel_measure(α)) (μ_fin : @probability_measure α (borel(α)) μ) :
  portmanteau_open μseq μ → portmanteau_closed μseq μ :=
begin
  intros hopcond F F_clos ,
  set G := Fᶜ with hG ,
  have G_open : is_open G := is_open_compl_iff.mpr F_clos ,
  specialize hopcond G G_open ,
  rw hG at hopcond ,
  have eq : μ Fᶜ = 1 - μ F := @proba_compl α (borel(α)) F μ μ_fin (closed_imp_borel F_clos) ,
  have eq_seq : (λ n , (μseq(n)) Fᶜ) = (λ n , 1 - (μseq(n)) F) ,
  { funext n ,
    exact @proba_compl α (borel(α)) F (μseq(n)) (μseq_fin(n)) (closed_imp_borel F_clos) , } ,
  rw [eq , eq_seq] at hopcond ,
  rw liminf_const_sub 1 (ennreal.one_ne_top) at hopcond ,
  have le₁ : μ(F) ≤ 1 := proba_le_one μ F ,
  have le₂ : limsup_enn (λ n , (μseq(n))(F)) ≤ 1 := limsup_le_of_le_ennreal (λ n , proba_le_one (μseq(n)) F) ,
  exact le_of_self_sub_le_self_sub_ennreal 1 _ _ ennreal.one_ne_top le₁ le₂ hopcond ,
end

lemma portmanteau_closed_imp_open_cond
  (μseq : ℕ → (borel_measure(α)))
  (μseq_fin : ∀ (n : ℕ) , @probability_measure α (borel(α)) (μseq(n)))
  (μ : borel_measure(α)) (μ_fin : @probability_measure α (borel(α)) μ) :
  portmanteau_closed μseq μ → portmanteau_open μseq μ :=
begin
  intros hclcond G G_open ,
  set F := Gᶜ with hF ,
  have F_closed : is_closed F := is_closed_compl_iff.mpr G_open ,
  specialize hclcond F F_closed ,
  rw hF at hclcond ,
  have eq : μ Gᶜ = 1 - μ G := @proba_compl α (borel(α)) G μ μ_fin (open_imp_borel G_open) ,
  have eq_seq : (λ n , (μseq(n)) Gᶜ) = (λ n , 1 - (μseq(n)) G) ,
  { funext n ,
    exact @proba_compl α (borel(α)) G (μseq(n)) (μseq_fin(n)) (open_imp_borel G_open) , } ,
  rw [eq , eq_seq] at hclcond ,
  rw limsup_const_sub 1 (ennreal.one_ne_top) at hclcond ,
  have le₁ : μ(G) ≤ 1 := proba_le_one μ G ,
  have le₂ : liminf_enn (λ n , (μseq(n))(G)) ≤ 1 := liminf_le_of_le_ennreal (λ n , proba_le_one (μseq(n)) G) ,
  exact le_of_self_sub_le_self_sub_ennreal 1 _ _ ennreal.one_ne_top le₂ le₁ hclcond ,
end

lemma portmanteau_closed_and_open_cond_equivalent
  (μseq : ℕ → (borel_measure(α)))
  (μseq_fin : ∀ (n : ℕ) , @probability_measure α (borel(α)) (μseq(n)))
  (μ : borel_measure(α)) (μ_fin : @probability_measure α (borel(α)) μ) :
  portmanteau_closed μseq μ ↔ portmanteau_open μseq μ :=
begin
  split ,
  { exact portmanteau_closed_imp_open_cond μseq μseq_fin μ μ_fin , } ,
  { exact portmanteau_open_imp_closed_cond μseq μseq_fin μ μ_fin , } ,
end

end portmanteau_open_equiv_closed

end portmanteau


import tactic
import data.nat.basic
import tactic.slim_check

/-
Example:

lemma ex (a b c : ℕ) (hab : a^2 + b^2 < c) : a + b < c :=
begin
  may_assume h : a ≤ b,
  {
  -- state here is
  -- (a b c : ℕ) (hab : a^2 + b^2 < c)
  -- (this : ∀ (a b c : ℕ) (hab : a^2 + b^2 < c) (h : a ≤ b), a + b < c)
  -- ⊢ a + b < c

  },
  -- state here is
  -- (a b c : ℕ) (hab : a^2 + b^2 < c) (h : a ≤ b)
  -- ⊢ a + b < c

end

-/

/- lemma ex (a b c : ℕ) (hab : a^2 + b^2 < c) : a + b < c :=
begin
  have : ∀ (a b c : ℕ) (hab : a^2 + b^2 < c) (this : ∀ (a' b' c' : ℕ) (hab : a'^2 + b'^2 < c') (h : a' ≤ b'), a' + b' < c'),
   a + b < c,
  { clear_except this,
    intros,
    -- state here is
    -- (a b c : ℕ) (hab : a^2 + b^2 < c)
    -- (this : ∀ (a b c : ℕ) (hab : a^2 + b^2 < c) (h : a ≤ b), a + b < c)
    -- ⊢ a + b < c
    cases le_total a b; specialize this _ _ c _ h,
    assumption,
    assumption,
    rw add_comm,
    assumption,
    rw add_comm,
    assumption, },
  apply this a b c hab,
  clear_except,
  intros a b c hab h,
  -- state here is
  -- (a b c : ℕ) (hab : a^2 + b^2 < c) (h : a ≤ b)
  -- ⊢ a + b < c
  admit,

end -/

namespace tactic.interactive
open tactic expr

setup_tactic_parser

/-- auxiliary function for `apply_under_n_pis` -/
private meta def insert_under_n_pis_aux (na : name) (ty : expr) : ℕ → ℕ → expr → expr
| n 0 bd := expr.pi na binder_info.default ty (bd.lift_vars 0 1)
| n (k+1) (expr.pi nm bi tp bd) :=
  expr.pi nm binder_info.default tp (insert_under_n_pis_aux (n+1) k bd)
| n (k+1) t := insert_under_n_pis_aux n 0 t
/--
Assumes `pi_expr` is of the form `Π x1 ... xn xn+1..., _`.
Creates a pexpr of the form `Π x1 ... xn, func (arg x1 ... xn)`.
All arguments (implicit and explicit) to `arg` should be supplied. -/
meta def insert_under_n_pis (na : name) (ty : expr) (pi_expr : expr) (n : ℕ) : expr :=
insert_under_n_pis_aux na ty 0 n (pi_expr)

/--
Assumes `pi_expr` is of the form `Π x1 ... xn, _`.
Creates a pexpr of the form `Π x1 ... xn, func (arg x1 ... xn)`.
All arguments (implicit and explicit) to `arg` should be supplied. -/
meta def insert_under_pis (na : name) (ty : expr) (pi_expr : expr) : expr :=
insert_under_n_pis na ty pi_expr pi_expr.pi_arity

meta def may_assume (h : parse ident?) (q₁ : parse (tk ":" *> texpr))
  (wi : parse (tk "with" *> ident)?) (ot : parse (tk "else")?)
  : tactic unit :=
let h := h.get_or_else `this,
wi := wi.get_or_else `h_red in
focus1 $ do
  ls ← local_context,
  q₂ ← to_expr q₁,
  g ← get_goal,
  ⟨n,g⟩ ← goal_of_mvar g,
  assert `h_red (insert_under_pis h (q₂.abstract_locals (ls.map local_uniq_name)) g),
  -- s ← get_local wi,
  -- let t : ident := wi,
  focus1 `[clear_except h_red, introsI],
  swap,
  if ot.is_some then focus1 `[contrapose! h_red] else skip

end tactic.interactive

/- lemma ex' (a b c : ℕ) (hab : a^2 + b^2 < c) : a + b < c :=
begin
  may_assume h : a ≤ b,
  { cases le_total a b; specialize h_red _ _ c _ h,
    assumption,
    assumption,
    rw add_comm,
    assumption,
    rw add_comm,
    assumption, },
admit
end -/

namespace tactic

namespace interactive
setup_tactic_parser

meta def doneif (h : parse ident?) (t : parse (tk ":" *> texpr))
  (revert : parse (
    (tk "generalizing" *> ((none <$ tk "*") <|> some <$> ident*)) <|> pure (some []))) :
  tactic unit := do
  let h := h.get_or_else `this,
  t ← i_to_expr ``(%%t : Sort*),
  (num_generalized, goal) ← retrieve (do
    assert_core h t, swap,
    num_generalized ← match revert with
    | none := revert_all
    | some revert := revert.mmap tactic.get_local >>= revert_lst
    end,
    goal ← target,
    return (num_generalized, goal)),
  tactic.assert h goal,
  goal ← target,
  (take_pi_args num_generalized goal).reverse.mmap' $ λ h,
    try (tactic.get_local h >>= tactic.clear),
  intron (num_generalized + 1)

meta def wlog' (h : parse ident?) (t : parse (tk ":" *> texpr)) : tactic unit :=
doneif h t none >> swap

end interactive
end tactic

lemma div_pow''' {a b : ℕ} (n : ℕ) (h : b ∣ a) : (a / b) ^ n = a ^ n / b ^ n :=
begin
  by_cases hb : b = 0,
  { simp only [hb, zero_dvd_iff, eq_self_iff_true, nat.div_zero] at *,
    rw h,
    by_cases hn : n = 0,
    simp only [hn, nat.lt_one_iff, nat.div_self, pow_zero],
    rw zero_pow (pos_iff_ne_zero.mpr hn),
    simp },
  have hb : 0 < b := pos_iff_ne_zero.mpr hb,
  -- have : 0 < b := by library_search,
  rcases h with ⟨h_w, rfl⟩,
  rw [mul_comm, mul_pow, nat.mul_div_cancel h_w hb, nat.mul_div_cancel (h_w ^ n) (pow_pos hb n)],
end
/-
lemma fermat (a b c n : ℕ) (hab : a^n + b^n = c^n) : a * b * c = 0 :=
begin
  may_assume h : a.coprime b with h_red else,
  { use [a / a.gcd b, b / a.gcd b, c / a.gcd b, n],
    simp,
    push_neg,
    split,
    rw div_pow''',
    rw div_pow''',
    rw div_pow''',
    admit,
    admit,
    exact nat.gcd_dvd_right a b,
    exact nat.gcd_dvd_left a b,
    split,
    refine nat.coprime_div_gcd_div_gcd _,
    contrapose h_red,
    simp at h_red,
    simp [h_red],
    split,
    split,
    simp,
    rw [nat.div_eq_zero_iff],
    simp,
    refine nat.le_of_dvd _ _,
    admit,
    exact nat.gcd_dvd_left a b,
    admit,
    admit,
    admit, },
  { admit },
end -/

/- lemma test (a b : ℕ) : (a - b) * (b - a) = 0 :=
begin
  may_assume h : a ≤ b with h_red else,
  { simp,
    admit, },
  { admit },
end

lemma fermat' (a b c d n : ℕ) (hab : a^n + b^n = c^n) (hd : d^2 = 4) : a * b * c = 0 :=
begin
  wlog' h : a.coprime b,
  { admit, },
  { admit },
end -/


/-
Copyright (c) 2021 Yury Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury Kudryashov
-/
import data.finset.option
import data.pfun

/-!
# Image of a `finset α` under a partially defined function

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

In this file we define `part.to_finset` and `finset.pimage`. We also prove some trivial lemmas about
these definitions.

## Tags

finite set, image, partial function
-/

variables {α β : Type*}

namespace part

/-- Convert a `o : part α` with decidable `part.dom o` to `finset α`. -/
def to_finset (o : part α) [decidable o.dom] : finset α := o.to_option.to_finset

@[simp] lemma mem_to_finset {o : part α} [decidable o.dom] {x : α} :
  x ∈ o.to_finset ↔ x ∈ o :=
by simp [to_finset]

@[simp] theorem to_finset_none [decidable (none : part α).dom] :
  none.to_finset = (∅ : finset α) :=
by simp [to_finset]

@[simp] theorem to_finset_some {a : α} [decidable (some a).dom] :
  (some a).to_finset = {a} :=
by simp [to_finset]

@[simp] lemma coe_to_finset (o : part α) [decidable o.dom] :
  (o.to_finset : set α) = {x | x ∈ o} :=
set.ext $ λ x, mem_to_finset

end part

namespace finset

variables [decidable_eq β] {f g : α →. β} [∀ x, decidable (f x).dom]
  [∀ x, decidable (g x).dom] {s t : finset α} {b : β}

/-- Image of `s : finset α` under a partially defined function `f : α →. β`. -/
def pimage (f : α →. β) [∀ x, decidable (f x).dom] (s : finset α) : finset β :=
s.bUnion (λ x, (f x).to_finset)

@[simp] lemma mem_pimage : b ∈ s.pimage f ↔ ∃ (a ∈ s), b ∈ f a := by simp [pimage]

@[simp, norm_cast] lemma coe_pimage : (s.pimage f : set β) = f.image s :=
set.ext $ λ x, mem_pimage

@[simp] lemma pimage_some (s : finset α) (f : α → β) [∀ x, decidable (part.some $ f x).dom] :
  s.pimage (λ x, part.some (f x)) = s.image f :=
by { ext, simp [eq_comm] }

lemma pimage_congr (h₁ : s = t) (h₂ : ∀ x ∈ t, f x = g x) : s.pimage f = t.pimage g :=
by { subst s, ext y, simp [h₂] { contextual := tt } }

/-- Rewrite `s.pimage f` in terms of `finset.filter`, `finset.attach`, and `finset.image`. -/
lemma pimage_eq_image_filter : s.pimage f =
  (filter (λ x, (f x).dom) s).attach.image (λ x, (f x).get (mem_filter.1 x.coe_prop).2) :=
by { ext x, simp [part.mem_eq, and.exists, -exists_prop] }

lemma pimage_union [decidable_eq α] : (s ∪ t).pimage f = s.pimage f ∪ t.pimage f :=
coe_inj.1 $ by simp only [coe_pimage, pfun.image_union, coe_union]

@[simp] lemma pimage_empty : pimage f ∅ = ∅ := by { ext, simp }

lemma pimage_subset {t : finset β} : s.pimage f ⊆ t ↔ ∀ (x ∈ s) (y ∈ f x), y ∈ t :=
by simp [subset_iff, @forall_swap _ β]

@[mono] lemma pimage_mono (h : s ⊆ t) : s.pimage f ⊆ t.pimage f :=
pimage_subset.2 $ λ x hx y hy, mem_pimage.2 ⟨x, h hx, hy⟩

lemma pimage_inter [decidable_eq α] : (s ∩ t).pimage f ⊆ s.pimage f ∩ t.pimage f :=
by simp only [← coe_subset, coe_pimage, coe_inter, pfun.image_inter]

end finset


-- import Mathlib
-- import SciLean.Mathlib.Algebra.Module.Basic
import SciLean.Categories
import SciLean.Quot.QuotQ

namespace SciLean

structure Compression (Val : Type) (Compr : Type) where
  canCompress : Val → Bool
  uncompress : Compr → Val
  compress : Val → Compr

  eq (a : Val) (b : Compr) : Prop := (a = uncompress b)
  compressible (a : Val)   : Prop := (a = uncompress (compress a))

  unique : ∀ b, (compress (uncompress b)) = b
  valid  : ∀ a, (canCompress a = true) ↔ compressible a

namespace Compressed

  inductive Repr (Val : Type) (Compr : Type) where
  | val   (a : Val) : Repr Val Compr
  | compr (b : Compr) : Repr Val Compr

  namespace Repr

    variable {α β : Type}

    instance [ToString α] [ToString β] : ToString (Repr α β) :=
    ⟨λ x =>
      match x with
      | val   a => toString a
      | compr b => toString b⟩

    def Eq (c : Compression α β) : Repr α β → Repr α β → Prop
      | val   x, val   y => x = y
      | compr x, compr y => x = y
      | val   x, compr y => c.eq x y
      | compr x, val   y => c.eq y x

    open Quot'

    instance (c : Compression α β) : QForm (Eq c) where
      RedForm := λ lvl x =>
        match lvl with
        | redLvl _ => True
        | normLvl =>
          match x with
          | compr _ => True
          | val   a => ¬(c.compressible a)
      redform_norm := sorry
      redform_zero := sorry
      redform_succ := sorry
      redform_inf  := sorry

    instance (c : Compression α β) (n : Nat) : QReduce (Eq c) (redLvl n) where
      reduce := id
      is_reduce := sorry
      eq_reduce := sorry
      preserve_stronger := sorry

    instance (c : Compression α β) : QReduce (Eq c) (normLvl) where
      reduce := λ x =>
        match x with
        | compr x => compr x
        | val   x => if h : c.canCompress x then compr (c.compress x) else val x
      is_reduce := sorry
      eq_reduce := sorry
      preserve_stronger := sorry

    def project (x : Repr α β) (c : Compression α β) : β :=
      match x with
      | compr x => x
      | val   x => c.compress x

  end Repr

end Compressed

def Compressed (α) {β} (c : Compression α β) (autoUncompress := true) := Quot' (Compressed.Repr.Eq c)

namespace Compressed

  variable {α β} {c c' : Compression α β}

  open Quot'

  instance : Coe α (Compressed α c) := ⟨λ a => ⟦⟨.val a, rawLvl, sorry⟩⟧⟩
  instance : Coe β (Compressed α c) := ⟨λ b => ⟦⟨.compr b, normLvl, sorry⟩⟧⟩

  def uncompress (x : Compressed α c) : α :=
    (Quot.lift · sorry x) <|
      (λ x =>
        match x.repr with
        | .val a => a
        | .compr x => c.uncompress x)

  -- compress if possible
  def maybe_compress (x : Compressed α c) : Compressed α c :=
    (Quot.lift · sorry x) <|
      (λ x => ⟦x.normalize⟧)

  @[simp]
  theorem maybe_compress_is_id (x : Compressed α c)
    : x.maybe_compress = x := sorry

  -- compress no matter what
  def compress (x : Compressed α c) : Compressed α c :=
    (Quot.lift · sorry x) <|
      (λ x => ⟦⟨.compr (x.repr.project c), normLvl, sorry⟩⟧)

  def map (x : Compressed α c)
    (f : α → γ) (g : β → γ)
    (h : ∀ a b, c.eq a b → f a = g b)
    : γ :=
    (Quot.lift · sorry x) <|
    (λ x =>
      match x.repr with
      | .val x => f x
      | .compr x => g x)

  def map₂ (x y : Compressed α c)
    (faa : α → α → γ) (fbb : β → β → γ)
    (fab : α → β → γ) (fba : β → α → γ)
    (h : (∀ xa xb ya yb,  c.eq xa xb → c.eq ya yb → (faa xa ya = fbb xb yb)) ∧
         (∀ xa xb ya, c.eq xa xb → (faa xa ya = fba xb ya)) ∧
         (∀ ya yb xa, c.eq ya yb → (faa xa ya = fab xa yb)))
    := x.map
        (λ xa => y.map
         (λ ya => faa xa ya)
         (λ yb => fab xa yb)
         sorry)
        (λ xb => y.map
         (λ ya => fba xb ya)
         (λ yb => fbb xb yb)
         sorry)
        sorry

  -- What is goint on with this coercion? It is doing odd stuff with `Coe`.
  instance : CoeHead (Compressed α c (autoUncompress := true)) α := ⟨(λ x => x.uncompress)⟩

  section FewTests

    variable (x : Compressed α c) (x' : Compressed α c' (autoUncompress := false))

    #check (x : α)
    #check_failure (x' : α)

    variable {α β} [HMul α β β] (a : α) (b : β)
    #check a * b

  end FewTests

end Compressed

def ZeroCompression (α : Type) [Zero α] [DecidableEq α] : Compression α Unit where
  canCompress a := (a = 0)
  uncompress p := 0
  compress a := ()

  valid := sorry
  unique := sorry

namespace ZeroCompression

  abbrev ZCompr (α : Type) [Zero α] [DecidableEq α] := Compressed α (ZeroCompression α)

  variable {α : Type} [DecidableEq α]

  instance [Zero α] : Zero (ZCompr α) := ⟨()⟩
  instance [One α] [Zero α] : One (ZCompr α) := ⟨(1:α)⟩

  instance {R : Type} [Monoid R] [AddMonoid α] [DistribMulAction R α]  : HMul R (ZCompr α) (ZCompr α) :=
    ⟨λ r x => x.map (λ a : α => (HMul.hMul r a : α)) (λ p => ())
     (by
      simp[Compressed.Repr.Eq, ZeroCompression]
      apply Quot.sound; simp
      apply (DistribMulAction.smul_zero)
     )⟩

  instance {α : Type} [DecidableEq α] [AddMonoid α] : Add (ZCompr α) :=
    ⟨λ x y : ZCompr α =>
      (x.map₂ y
        (λ x y => (x + y : α))
        (λ _ _ => ())
        (λ x _ => x)
        (λ _ x => x)
        (by
      simp[Compressed.Repr.Eq, ZeroCompression]
      constructor
      . intros _ _ h h'; apply Quot.sound; simp[h,h']
      constructor
      . intros _ _ h; apply Quot.sound; simp[h]
      . intros _ _ h; apply Quot.sound; simp[h]
     ))⟩

  instance [SubNegMonoid α] : Sub (ZCompr α) :=
    ⟨λ x y : ZCompr α =>
      (x.map₂ y
        (λ x y => (x - y : α))
        (λ _ _ => ())
        (λ x _ => x)
        (λ _ x => (-x : α))
        (by
      simp[Compressed.Repr.Eq, ZeroCompression]
      constructor
      . intros _ _ h h'; apply Quot.sound; simp[h,h']; admit
      constructor
      . intros _ _ h; apply Quot.sound; simp[h]; admit
      . intros _ _ h; apply Quot.sound; simp[h]; admit
     ))⟩

  instance [MulZeroClass α] : Mul (ZCompr α) :=
    ⟨λ x y : ZCompr α =>
      (x.map₂ y
        (λ x y => (x * y : α))
        (λ _ _ => ())
        (λ x _ => ())
        (λ _ x => ())
        (by
      simp[Compressed.Repr.Eq, ZeroCompression]
      constructor
      . intros _ _ h h'; apply Quot.sound; simp[h,h']; admit
      constructor
      . intros _ _ h; apply Quot.sound; simp[h]; admit
      . intros _ _ h; apply Quot.sound; simp[h]; admit
     ))⟩

  instance [SubNegMonoid α] : Neg (ZCompr α) := ⟨λ x => x.map (λ a => (-a : α)) (λ p => ())
    (by
      simp[Compressed.Repr.Eq, ZeroCompression]
      apply Quot.sound; simp
      admit -- -0=0 this should be provable from `SubNegMonoid`
     )⟩

  instance [AddCommGroup α] : AddCommGroup (ZCompr α) where
    add_comm := sorry
    add_assoc := sorry
    add_zero := sorry
    zero_add := sorry
    add_left_neg := sorry
    nsmul_zero' := sorry
    nsmul_succ' n x := sorry
    sub_eq_add_neg a b := sorry
    gsmul_zero' := sorry
    gsmul_succ' n x := sorry
    gsmul_neg' n x := sorry

  instance [Ring α] : Ring (ZCompr α) where
    zero_mul := sorry
    mul_zero := sorry
    -- mul_comm := sorry
    left_distrib := sorry
    right_distrib := sorry
    mul_one := sorry
    one_mul := sorry
    -- npow n x := x^(n.toReal) ----------- !!!
    npow_zero' n := sorry
    npow_succ' n x := sorry
    mul_assoc := sorry
    add_comm := sorry
    add_assoc := sorry
    add_zero := sorry
    zero_add := sorry
    add_left_neg := sorry
    -- nsmul n x := (n.toReal) * x ----------------  !!!
    nsmul_zero' := sorry
    nsmul_succ' n x := sorry
    sub_eq_add_neg a b := sorry
    -- gsmul n x := (n.toReal) * x --------- !!!
    gsmul_zero' := sorry
    gsmul_succ' n x := sorry
    gsmul_neg' n x := sorry
    natCast n := (n : α)
    natCast_zero := sorry
    natCast_succ := sorry
    intCast n := (AddGroupWithOne.intCast n : α)
    intCast_ofNat := sorry
    intCast_negSucc := sorry

  instance [CommRing α] : CommRing (ZCompr α) where
    mul_comm := sorry

  instance [Semiring R] [AddCommGroup α] [Module R α] : Module R (ZCompr α) where
    one_smul := sorry
    mul_smul := sorry
    smul_add := sorry
    smul_zero := sorry
    add_smul := sorry
    zero_smul := sorry

  instance [Vec α] : Vec (ZCompr α) := Vec.mk

end ZeroCompression

namespace HOHO

  open ZeroCompression

  def a : ZCompr Int := (42 : Int)
  def b : ZCompr Int := ()
  def c := a * b
  def d := a + b + a
  #eval a.toDebugString
  #eval b.toDebugString
  #eval c.toDebugString
  #eval d.toDebugString

end HOHO


/-
Copyright (c) 2019 Seul Baek. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Seul Baek

! This file was ported from Lean 3 source module tactic.omega.nat.form
! leanprover-community/mathlib commit 3d7987cda72abc473c7cdbbb075170e9ac620042
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Tactic.Omega.Nat.Preterm

/-
Linear natural number arithmetic preformulas in pre-normalized preform.
-/
namespace Omega

namespace Nat

/-- Intermediate shadow syntax for LNA formulas that includes unreified exprs -/
unsafe inductive exprform
  | Eq : exprterm → exprterm → exprform
  | le : exprterm → exprterm → exprform
  | Not : exprform → exprform
  | Or : exprform → exprform → exprform
  | And : exprform → exprform → exprform
#align omega.nat.exprform omega.nat.exprform

/-- Intermediate shadow syntax for LNA formulas that includes non-canonical terms -/
inductive Preform
  | Eq : Preterm → Preterm → preform
  | le : Preterm → Preterm → preform
  | Not : preform → preform
  | Or : preform → preform → preform
  | And : preform → preform → preform
  deriving has_reflect, Inhabited
#align omega.nat.preform Omega.Nat.Preform

-- mathport name: preform.eq
scoped notation x " =* " y => Omega.Nat.Preform.eq x y

-- mathport name: preform.le
scoped notation x " ≤* " y => Omega.Nat.Preform.le x y

-- mathport name: preform.not
scoped notation "¬* " p => Omega.Nat.Preform.not p

-- mathport name: preform.or
scoped notation p " ∨* " q => Omega.Nat.Preform.or p q

-- mathport name: preform.and
scoped notation p " ∧* " q => Omega.Nat.Preform.and p q

namespace Preform

/-- Evaluate a preform into prop using the valuation `v`. -/
@[simp]
def Holds (v : Nat → Nat) : Preform → Prop
  | t =* s => t.val v = s.val v
  | t ≤* s => t.val v ≤ s.val v
  | ¬* p => ¬p.Holds
  | p ∨* q => p.Holds ∨ q.Holds
  | p ∧* q => p.Holds ∧ q.Holds
#align omega.nat.preform.holds Omega.Nat.Preform.Holds

end Preform

/-- `univ_close p n` := `p` closed by prepending `n` universal quantifiers -/
@[simp]
def UnivClose (p : Preform) : (Nat → Nat) → Nat → Prop
  | v, 0 => p.Holds v
  | v, k + 1 => ∀ i : Nat, univ_close (updateZero i v) k
#align omega.nat.univ_close Omega.Nat.UnivClose

namespace Preform

/-- Argument is free of negations -/
def NegFree : Preform → Prop
  | t =* s => True
  | t ≤* s => True
  | p ∨* q => neg_free p ∧ neg_free q
  | p ∧* q => neg_free p ∧ neg_free q
  | _ => False
#align omega.nat.preform.neg_free Omega.Nat.Preform.NegFree

/-- Return expr of proof that argument is free of subtractions -/
def SubFree : Preform → Prop
  | t =* s => t.SubFree ∧ s.SubFree
  | t ≤* s => t.SubFree ∧ s.SubFree
  | ¬* p => p.SubFree
  | p ∨* q => p.SubFree ∧ q.SubFree
  | p ∧* q => p.SubFree ∧ q.SubFree
#align omega.nat.preform.sub_free Omega.Nat.Preform.SubFree

/-- Fresh de Brujin index not used by any variable in argument -/
def freshIndex : Preform → Nat
  | t =* s => max t.freshIndex s.freshIndex
  | t ≤* s => max t.freshIndex s.freshIndex
  | ¬* p => p.freshIndex
  | p ∨* q => max p.freshIndex q.freshIndex
  | p ∧* q => max p.freshIndex q.freshIndex
#align omega.nat.preform.fresh_index Omega.Nat.Preform.freshIndex

theorem holds_constant {v w : Nat → Nat} :
    ∀ p : Preform, (∀ x < p.freshIndex, v x = w x) → (p.Holds v ↔ p.Holds w)
  | t =* s, h1 => by
    simp only [holds]
    apply pred_mono_2 <;> apply preterm.val_constant <;> intro x h2 <;>
      apply h1 _ (lt_of_lt_of_le h2 _)
    apply le_max_left; apply le_max_right
  | t ≤* s, h1 => by
    simp only [holds]
    apply pred_mono_2 <;> apply preterm.val_constant <;> intro x h2 <;>
      apply h1 _ (lt_of_lt_of_le h2 _)
    apply le_max_left; apply le_max_right
  | ¬* p, h1 => by
    apply not_congr
    apply holds_constant p h1
  | p ∨* q, h1 => by
    simp only [holds]
    apply pred_mono_2' <;> apply holds_constant <;> intro x h2 <;> apply h1 _ (lt_of_lt_of_le h2 _)
    apply le_max_left; apply le_max_right
  | p ∧* q, h1 => by
    simp only [holds]
    apply pred_mono_2' <;> apply holds_constant <;> intro x h2 <;> apply h1 _ (lt_of_lt_of_le h2 _)
    apply le_max_left; apply le_max_right
#align omega.nat.preform.holds_constant Omega.Nat.Preform.holds_constant

/-- All valuations satisfy argument -/
def Valid (p : Preform) : Prop :=
  ∀ v, Holds v p
#align omega.nat.preform.valid Omega.Nat.Preform.Valid

/-- There exists some valuation that satisfies argument -/
def Sat (p : Preform) : Prop :=
  ∃ v, Holds v p
#align omega.nat.preform.sat Omega.Nat.Preform.Sat

/-- `implies p q` := under any valuation, `q` holds if `p` holds -/
def Implies (p q : Preform) : Prop :=
  ∀ v, Holds v p → Holds v q
#align omega.nat.preform.implies Omega.Nat.Preform.Implies

/-- `equiv p q` := under any valuation, `p` holds iff `q` holds -/
def Equiv (p q : Preform) : Prop :=
  ∀ v, Holds v p ↔ Holds v q
#align omega.nat.preform.equiv Omega.Nat.Preform.Equiv

theorem sat_of_implies_of_sat {p q : Preform} : Implies p q → Sat p → Sat q := by intro h1 h2;
  apply Exists.imp h1 h2
#align omega.nat.preform.sat_of_implies_of_sat Omega.Nat.Preform.sat_of_implies_of_sat

theorem sat_or {p q : Preform} : Sat (p ∨* q) ↔ Sat p ∨ Sat q :=
  by
  constructor <;> intro h1
  · cases' h1 with v h1
    cases' h1 with h1 h1 <;> [left, right] <;> refine' ⟨v, _⟩ <;> assumption
  · cases' h1 with h1 h1 <;> cases' h1 with v h1 <;> refine' ⟨v, _⟩ <;> [left, right] <;> assumption
#align omega.nat.preform.sat_or Omega.Nat.Preform.sat_or

/-- There does not exist any valuation that satisfies argument -/
def Unsat (p : Preform) : Prop :=
  ¬Sat p
#align omega.nat.preform.unsat Omega.Nat.Preform.Unsat

def repr : Preform → String
  | t =* s => "(" ++ t.repr ++ " = " ++ s.repr ++ ")"
  | t ≤* s => "(" ++ t.repr ++ " ≤ " ++ s.repr ++ ")"
  | ¬* p => "¬" ++ p.repr
  | p ∨* q => "(" ++ p.repr ++ " ∨ " ++ q.repr ++ ")"
  | p ∧* q => "(" ++ p.repr ++ " ∧ " ++ q.repr ++ ")"
#align omega.nat.preform.repr Omega.Nat.Preform.repr

instance hasRepr : Repr Preform :=
  ⟨repr⟩
#align omega.nat.preform.has_repr Omega.Nat.Preform.hasRepr

unsafe instance has_to_format : has_to_format Preform :=
  ⟨fun x => x.repr⟩
#align omega.nat.preform.has_to_format omega.nat.preform.has_to_format

end Preform

theorem univClose_of_valid {p : Preform} : ∀ {m : Nat} {v : Nat → Nat}, p.valid → UnivClose p v m
  | 0, v, h1 => h1 _
  | m + 1, v, h1 => fun i => univ_close_of_valid h1
#align omega.nat.univ_close_of_valid Omega.Nat.univClose_of_valid

theorem valid_of_unsat_not {p : Preform} : (¬* p).Unsat → p.valid :=
  by
  simp only [preform.sat, preform.unsat, preform.valid, preform.holds]
  rw [not_exists_not]; intro h; assumption
#align omega.nat.valid_of_unsat_not Omega.Nat.valid_of_unsat_not

/- ./././Mathport/Syntax/Translate/Expr.lean:330:4: warning: unsupported (TODO): `[tacs] -/
/-- Tactic for setting up proof by induction over preforms. -/
unsafe def preform.induce (t : tactic Unit := tactic.skip) : tactic Unit :=
  sorry
#align omega.nat.preform.induce omega.nat.preform.induce

end Nat

end Omega


/-
Copyright (c) 2019 The Flypitch Project. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.

Authors: Jesse Han, Floris van Doorn
-/
import .to_mathlib

/- The proper generality to do this is with directed categories as the indexing objects -/

/- We'll settle for directed types instead -/

--local attribute [instance, priority 0] classical.prop_decidable

universes u v w

namespace colimit

-- def directed {ι : Sort v} (f : ι → α) := ∀x y, ∃z, f x ≼ f z ∧ f y ≼ f z

structure directed_type : Type (u+1) :=
  (carrier : Type u) (rel : carrier → carrier → Prop)
  (h_reflexive : reflexive rel)
  (h_transitive : transitive rel)
  (h_directed : ∀ x y, ∃ z : carrier, rel x z ∧ rel y z)

lemma trans {D : directed_type} {i j k : D.carrier} (h1 : D.rel i j) (h2 : D.rel j k) : D.rel i k
:= begin fapply directed_type.h_transitive, exact j, repeat{assumption} end

structure directed_diagram (D : (directed_type : Type (u+1))) : Type (max (u+1) (v+1)) :=
  (obj : D.carrier → Type v)
  (mor : ∀{x}, ∀{y}, D.rel x y → (obj x  → obj y))
  (h_mor : ∀{x} {y} {z} {f1 : D.rel x y} {f2 : D.rel y z} {f3 : D.rel x z},
           (mor f3) = (mor f2) ∘ (mor f1)) -- functoriality

@[reducible]def directed_type_of_nat : directed_type :=
  begin refine ⟨ℕ, (≤), _, _, _⟩, intro, refl,
  fapply le_trans, intros, fapply exists.intro, exact x + y,
  simp only [*, zero_le, le_add_iff_nonneg_right, and_self, le_add_iff_nonneg_left]
  end

notation `ℕ'` :=  directed_type_of_nat

@[simp]lemma ℕ_of_ℕ'.carrier : (ℕ').carrier = ℕ := by refl
@[simp]lemma le_of_ℕ'.rel : (ℕ').rel = nat.le := by refl

-- @[reducible]def has_le_ℕ' : has_le (ℕ').carrier := begin split, rw[ℕ_of_ℕ'.carrier], exact λ x y, x ≤ y end
-- attribute [instance] has_le_ℕ'

def constant_functor (D : directed_type) (A : Type v) : directed_diagram D :=
  ⟨(λ x, A), λ x y h, id, by simp⟩

def coproduct_of_directed_diagram {D : (directed_type : Type (u+1)) }
    (F : (directed_diagram D :  Type (max (u+1) (v+1)))) :  Type (max u v) :=
    Σ a : D.carrier, F.obj a

def canonical_inclusion_coproduct {D : directed_type} {F : directed_diagram D} (i : D.carrier) :
                                  F.obj i → coproduct_of_directed_diagram F := λ x, ⟨i,x⟩

def germ_relation {D : (directed_type : Type (u+1)) }
(F : (directed_diagram D :  Type (max (u+1) (v+1)))) : coproduct_of_directed_diagram F → coproduct_of_directed_diagram F  → Prop :=
λ ⟨i,x⟩ ⟨j, y⟩, ∃ k : D.carrier, ∃ z : F.obj k, ∃ f_x : D.rel i k, ∃ f_y : D.rel j k,
                 (F.mor f_x) x = z ∧ (F.mor f_y) y = z

lemma germ_equivalence {D : (directed_type : Type (u+1)) }
(F : (directed_diagram D :  Type (max (u+1) (v+1)))) : equivalence (germ_relation F) :=
begin
  split,
    {rintro ⟨i, x⟩, repeat{split}, swap, exact i, exact D.h_reflexive i},
  split,
    {intros x y, rcases x with ⟨i, x⟩, rcases y with ⟨j, y⟩, intro h,
    rcases h with ⟨ℓ,z,f_x,f_y,H⟩, repeat{fapply exists.intro},
    exacts [ℓ,z,f_y,f_x, and.intro H.right H.left]},
    {unfold transitive, intros, cases x with i x, cases y with j y, cases z with k z,
    rcases a with ⟨ℓ₁, z, fi, fj_1, Hℓ₁⟩, rcases a_1 with ⟨ℓ₂, z', fj_2, fk, Hℓ₂⟩,
    have a_2 := D.h_directed ℓ₁ ℓ₂, rcases a_2 with ⟨ℓ₃, g1, g2⟩,
    have f1 : D.rel i (ℓ₃),
      {fapply D.h_transitive, exacts [ℓ₁, fi, g1]},
    have f2 : D.rel j ℓ₃,
      {fapply D.h_transitive, exacts [ℓ₁, fj_1, g1]},
    have f3 : D.rel k (ℓ₃),
      {fapply D.h_transitive, exacts [ℓ₂, fk, g2]},
    have H1 : F.mor f1 = F.mor g1 ∘ F.mor fi; have H2_l : F.mor f2 = F.mor g1 ∘ F.mor fj_1;
    have H2_r : F.mor f2 = F.mor g2 ∘ F.mor fj_2; have H3 : F.mor f3 = F.mor g2 ∘ F.mor fk;
    all_goals{try{fapply F.h_mor}},
    have H4 : (F.mor fi x) = (F.mor fj_1 y), by cc, dedup,
    have H5 : (F.mor fk z) = (F.mor fj_2 y), by cc,
    unfold germ_relation at *, fapply exists.intro,
    exact ℓ₃, fapply exists.intro, exact (F.mor f2) y, fapply exists.intro, exact f1,
    fapply exists.intro, exact f3, fapply and.intro,
    {simp[H1, H2_l], rw[H4]}, {simp[H2_r, H3], rw[H5]},
    }
end

@[reducible]def coproduct_setoid {D : directed_type} (F : directed_diagram D) : setoid $ coproduct_of_directed_diagram F := ⟨germ_relation F, germ_equivalence F⟩
attribute [instance] coproduct_setoid

def colimit {D : (directed_type : Type (u+1)) } (F : (directed_diagram D :  Type (max (u+1) (v+1)))) : Type (max u v) :=
  @quotient (coproduct_of_directed_diagram F) (by fapply coproduct_setoid)

def canonical_map {D : directed_type} {F : directed_diagram D} (i : D.carrier) :
                  F.obj i → colimit F := (by apply quotient.mk) ∘ canonical_inclusion_coproduct i

lemma canonical_map_inj_of_transition_maps_inj {D : directed_type} {F : directed_diagram D} (i : D.carrier) (H : ∀ {i} {j}, ∀ h : D.rel i j, function.injective (F.mor h)) : function.injective (@canonical_map D F i) :=
begin
    unfold function.injective canonical_map canonical_inclusion_coproduct, intros x y,
    simp only [function.comp_app, quotient.eq], simp only [(≈)],
    unfold germ_relation, intro H_eqv, rcases H_eqv with ⟨j,z,edge,_, ⟨H1, H2⟩⟩,
    exact H edge (by cc)
end

structure cocone {D} (F : directed_diagram D) :=
  (vertex : Type*)
  (map : Π i : D.carrier, F.obj i → vertex)
  (h_compat : ∀{i}, ∀{j}, Π h : D.rel i j, (map i) = (map j) ∘ (F.mor h))

def cocone_of_colimit {D} (F : directed_diagram D) : cocone F :=
  begin
  refine ⟨colimit F, canonical_map, _⟩, intros i j H, fapply funext, intro x,
  simp only [quotient.eq,(≈),canonical_map,function.comp], have h_refl : D.rel j j,
  by apply D.h_reflexive, refine ⟨j,F.mor H x, H, h_refl, rfl, _⟩,
  change ((F.mor h_refl) ∘ (F.mor H)) x = F.mor H x, rw[<-F.h_mor]
end

/- Given a cocone V over a diagram D, return the canonical map colim D → V-/
def universal_map {D} {F : directed_diagram D} {V : cocone F} : colimit F → (V.vertex) :=
begin
  fapply quotient.lift, {exact λp, V.map p.fst p.snd},
  {intros p q H, rcases p with ⟨i,x⟩, rcases q with ⟨j,y⟩, simp only *,
   simp[(≈), germ_relation] at H, rcases H with ⟨k,z,⟨f1, H1⟩,f2,H2⟩,
   change V.map i x = V.map j y, have : V.map i x = V.map k (F.mor f1 x),
   simp only [V.h_compat f1, eq_self_iff_true, function.comp_app],
   have : V.map j y = V.map k (F.mor f2 y),
   simp only [V.h_compat f2, eq_self_iff_true, function.comp_app],
   simp only [*, eq_self_iff_true],
  }
end

@[simp]lemma universal_map_property {D} {F : directed_diagram D} {V : cocone F} (i : D.carrier) (x) : universal_map ((canonical_map i) x) = (V.map i) x := by refl

/- this generalizes canonical_map_inj_of_transition_maps_inj, because every colimit
   is a cocone over its own diagram

   If the maps to the vertex are injective, then the comparison map from the colimit
   is injective.
-/

lemma universal_map_inj_of_components_inj {D} {F : directed_diagram D} {V : cocone F} (h_inj : ∀ i : D.carrier, function.injective (V.map i)) : function.injective (universal_map : colimit F → (V.vertex)) :=
begin
unfold universal_map, rintros ⟨i,x⟩ ⟨j,y⟩ H, unfold quotient.lift at H, dsimp[colimit] at *, change (⟦⟨i,x⟩⟧ : colimit F) = (⟦⟨j,y⟩⟧ : colimit F),
simp[quotient.eq, (≈)], have := (D.h_directed i j), rcases this with ⟨k, Hik, Hjk⟩,
refine ⟨k, F.mor Hik x, Hik, Hjk, rfl, _⟩, fapply h_inj k,
simp only [*, V.h_compat Hik, V.h_compat Hjk, function.injective.eq_iff, eq_self_iff_true, function.comp_app] at *
end

/- Given a germ-equivalence class from the colimit, return a representative from the coproduct and a proof that this is a lift  -/
noncomputable def germ_rep {D} {F : directed_diagram D} (a : colimit F) : Σ' x : (coproduct_of_directed_diagram F), ⟦x⟧ = a := classical.psigma_of_exists (quotient.exists_rep a)

@[simp]lemma canonical_map_quotient {D} {F : directed_diagram D} (a : coproduct_of_directed_diagram F) : canonical_map a.fst a.snd = ⟦a⟧ :=
by {auto_cases, refl}

/- Assuming canonical maps into the colimit are injective, ⟨i,x⟩ and ⟨j,y⟩ in the same fiber
over a ⟦z⟧ : colimit F are related by any transition map i → j. -/
@[simp]lemma eq_mor_of_same_fiber {D} {F : directed_diagram D} (a b : coproduct_of_directed_diagram F) {z : colimit F} (Ha : ⟦a⟧ = z) (Hb : ⟦b⟧ = z)
                           (H_inj : ∀ i : D.carrier, function.injective (@canonical_map D F i)) (H_rel : D.rel a.fst b.fst) : F.mor H_rel a.snd = b.snd :=
begin
have H_eq : z = canonical_map (b.fst) (F.mor H_rel (a.snd)), by
  {have := (cocone_of_colimit F).h_compat, have H := congr_fun (@this a.fst b.fst H_rel) a.snd,
  dsimp[cocone_of_colimit] at H, rw[canonical_map_quotient, Ha] at H, exact H},
have : canonical_map (b.fst) (b.snd) = canonical_map (b.fst) (F.mor H_rel (a.snd)),
simp only [*, canonical_map_quotient b, colimit.canonical_map_quotient, function.injective.eq_iff, eq_self_iff_true],
fapply H_inj b.fst, symmetry, exact this
end

@[simp]lemma eq_mor_of_same_fiber' {D} {F : directed_diagram D} (a_fst b_fst : D.carrier) (a_snd : F.obj a_fst) (b_snd : F.obj b_fst) {z : colimit F} (Ha : ⟦(⟨a_fst, a_snd⟩ : coproduct_of_directed_diagram F)⟧ = z) (Hb : ⟦(⟨b_fst, b_snd⟩ : coproduct_of_directed_diagram F)⟧ = z) (H_inj : ∀ i : D.carrier, function.injective (@canonical_map D F i)) (H_rel : D.rel a_fst b_fst) : F.mor H_rel a_snd = b_snd :=
begin
  let a : coproduct_of_directed_diagram F := ⟨a_fst, a_snd⟩,
  let b : coproduct_of_directed_diagram F := ⟨b_fst, b_snd⟩,
  have : ⟦a⟧ = z, by assumption, have : ⟦b⟧ = z, by assumption,
  change F.mor H_rel a.snd = b.snd, have := @eq_mor_of_same_fiber D F a b z _ _ _ _,
  repeat{assumption},
end

/- Given an x : F_i and a j : ℕ, apply the map to obtain x' : F_{i+j} -/
@[reducible]def push_to_sum_r {F : directed_diagram ℕ'} {i} (x : F.obj i) (j) : F.obj (i+j) :=
F.mor (by simp only [zero_le, le_add_iff_nonneg_right]) x

@[reducible]def push_to_sum_l {F : directed_diagram ℕ'} {j} (x : F.obj j) (i) : F.obj (i+j) :=
F.mor (by simp only [zero_le, le_add_iff_nonneg_right, add_comm]) x

/- The push_to of x is in the same germ-equivalence class of x -/
lemma same_fiber_as_push_to_r {F : directed_diagram ℕ'} {i} (x : F.obj i) (j) :
     canonical_map i x = canonical_map (i+j) (push_to_sum_r x j)  :=
by {have := (cocone_of_colimit F).h_compat, have := @this i (i+j) (by simp), tidy}

lemma same_fiber_as_push_to_l {F : directed_diagram ℕ'} {j} (x : F.obj j) (i) :
     canonical_map j x = canonical_map (i+j) (push_to_sum_l x i)  :=
by {have := (cocone_of_colimit F).h_compat, have := @this i (i+j) (by simp), tidy}

end colimit
namespace omega_colimit
open colimit
/- Facts about directed colimits indexed by ℕ'. -/
def diagram.mk.map {F : ℕ → Type*} {h_succ : ∀{i : ℕ}, F i → F (i+1)} : Π (x y : ℕ), x ≤ y → F x → F y
| x 0 h := by {rw[nat.eq_zero_of_le_zero h], exact id}
| x (y+1) h := by {by_cases x = y + 1, rw[h], exact id, refine h_succ ∘ _,
                  apply diagram.mk.map, apply nat.le_of_le_and_ne_succ, repeat{assumption}}

@[simp]lemma diagram.mk.map_self_id {F : ℕ → Type*} {h_succ : ∀(i : ℕ), F i → F (i+1)} (x : ℕ) :
                  @diagram.mk.map F @h_succ x x (by constructor) = id :=
by {induction x, tidy, simp[diagram.mk.map,*], refl}

/- If the successive maps of h_succ are injective, then all their compositions are injective -/
lemma diagram.mk.map_inj {F : ℕ → Type*} {h_succ : ∀(i : ℕ), F i → F (i+1)} {h_inj : ∀ {i : ℕ}, function.injective (@h_succ i )} (x y : ℕ) (h : x ≤ y) : function.injective (@diagram.mk.map F h_succ x y h) :=
begin
  induction y,
    {have : x = 0, by exact nat.eq_zero_of_le_zero h, dsimp[*,diagram.mk.map], finish},
    by_cases x = y_n + 1,
      {dsimp[*, diagram.mk.map], finish},
    have : x ≤ y_n, by {apply nat.le_of_le_and_ne_succ, repeat{assumption}},
    simp[*, diagram.mk.map], apply function.injective_comp, apply h_inj, apply y_ih
end

-- /- Given a ℕ-indexed family of types and a way of assigning maps between successive objects
--    in this family, return the induced directed_diagram over ℕ'. -/
def diagram.mk(F : ℕ → Type*) (h_succ :∀{i : ℕ}, F i → F (i+1)) : directed_diagram ℕ' :=
begin
refine ⟨F, by {apply diagram.mk.map, assumption}, _⟩,
  intros x y z H1 H2 H3,
    induction z, induction y, induction x,
    dsimp[diagram.mk.map], refl,
     by {exfalso, fapply nat.succ_ne_zero, exact x_n, apply (nat.le_zero_iff).mp, assumption},
     by {exfalso, fapply nat.succ_ne_zero, exact y_n, apply (nat.le_zero_iff).mp, assumption},
     by_cases h : y = z_n+1, subst h;
       by_cases x = z_n+1;
       {repeat{dsimp[diagram.mk.map], simp*, refl}},
     by_cases h' : x = z_n+1,
       {exfalso, have : y < z_n+1 := lt_of_le_of_ne H2 h, dsimp at *, linarith},
       {have h_x : x ≤ z_n; have h_y : y ≤ z_n,
         all_goals{try{apply nat.le_of_le_and_ne_succ, repeat{assumption}}},
        have := @z_ih h_y h_x,
        dsimp[diagram.mk.map],
        simp only [h, h', dif_neg, not_false_iff, nat.le_of_le_and_ne_succ, this]}
end

-- TODO refactor henkin_language_chain et al in terms of diagram.mk

end omega_colimit


import tactic.suggest

open tactic

set_option back_chaining.max_depth 10
set_option trace.tactic.back_chaining true

namespace ex1

constant f : ℕ → ℕ
constant g : ℕ → ℕ

axiom A : f 0 + f 1 = 5
axiom B : f 1 + f 2 = 3
axiom C : f 2 = 0

axiom add_zero (n : ℕ) : n + 0 = n
axiom add_comm (n m : ℕ) : n + m = m + n

example : f 0 = 2 :=
begin
  have h₁ := B,
  have h₂ := C,
  rw h₂ at h₁,
  rw add_zero at h₁,
  have h₃ := A,
  rw h₁ at h₃,
  exact add_right_cancel h₃,
end

end ex1

namespace ex2

constant α : Type
constant reverse_core : list α → list α → list α
constant reverse : list α → list α
constant concat : list α → list α → list α

axiom reverse_core.base (l : list α) : reverse_core [] l = l
axiom reverse_core.step (x : α) (xs l : list α) :
  reverse_core (x :: xs) l = reverse_core xs (x :: l)

axiom reverse.def (xs : list α) : reverse xs = reverse_core xs []

axiom concat.base (l : list α) : concat [] l = l
axiom concat.step (x : α) (xs l : list α) :
  concat (x :: xs) l = x :: concat xs l

lemma reverse.single (x : α) : reverse [x] = [x] :=
begin
  rw reverse.def,
  rw reverse_core.step,
  rw reverse_core.base,
end

#print reverse.single

attribute [intro] reverse_core.step reverse_core.base reverse.def

lemma reverse.single₂ (x : α) : reverse [x] = [x] :=
begin
  -- back_chaining, -- use apply but i expect that one use rewrite :(
    sorry,
end

end ex2

namespace ex3
constants a b c d : Prop

constant ab : a → b
constant bc : b → c
constant cd : c → d

attribute [intro] ab bc cd

lemma example₁ (h : a) : d :=
begin
  apply cd,
  apply bc,
  apply ab,
  exact h,
end

lemma example₂ (h : a) : d :=
begin
  back_chaining,
end

constants x y z : Prop

lemma example₃ (h : a) (ax : a → x) : x :=
begin
  success_if_fail { back_chaining,},
  suggest, -- exact ax h
  exact ax h,
end

#print example₁
#print example₂

end ex3