/-
Copyright (c) 2021 Eric Wieser. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Eric Wieser
-/
import linear_algebra.finsupp
import algebra.monoid_algebra.basic
import algebra.direct_sum.internal

/-!
# Internal grading of an `add_monoid_algebra`

In this file, we show that an `add_monoid_algebra` has an internal direct sum structure.

## Main results

* `add_monoid_algebra.grade_by R f i`: the `i`th grade of an `add_monoid_algebra R M` given by the
  degree function `f`.
* `add_monoid_algebra.grade R i`: the `i`th grade of an `add_monoid_algebra R M` when the degree
  function is the identity.
* `add_monoid_algebra.equiv_grade_by`: the equivalence between an `add_monoid_algebra` and the
  direct sum of its grades.
* `add_monoid_algebra.equiv_grade`: the equivalence between an `add_monoid_algebra` and the direct
  sum of its grades when the degree function is the identity.
* `add_monoid_algebra.grade_by.is_internal`: propositionally, the statement that
  `add_monoid_algebra.grade_by` defines an internal graded structure.
* `add_monoid_algebra.grade.is_internal`: propositionally, the statement that
  `add_monoid_algebra.grade` defines an internal graded structure when the degree function
  is the identity.
-/

noncomputable theory

namespace add_monoid_algebra
variables {M : Type*} {ι : Type*} {R : Type*} [decidable_eq M]

section
variables (R) [comm_semiring R]

/-- The submodule corresponding to each grade given by the degree function `f`. -/
abbreviation grade_by (f : M → ι) (i : ι) : submodule R (add_monoid_algebra R M) :=
{ carrier := {a | ∀ m, m ∈ a.support → f m = i },
  zero_mem' := set.empty_subset _,
  add_mem' := λ a b ha hb m h,
    or.rec_on (finset.mem_union.mp (finsupp.support_add h)) (ha m) (hb m),
  smul_mem' := λ a m h, set.subset.trans finsupp.support_smul h }

/-- The submodule corresponding to each grade. -/
abbreviation grade (m : M) : submodule R (add_monoid_algebra R M) := grade_by R id m

lemma grade_by_id : grade_by R (id : M → M) = grade R := by refl

lemma mem_grade_iff (m : M) (a : add_monoid_algebra R M) : a ∈ grade R m ↔ a.support ⊆ {m} :=
begin
  rw [← finset.coe_subset, finset.coe_singleton],
  refl
end

lemma mem_grade_iff' (m : M) (a : add_monoid_algebra R M) :
  a ∈ grade R m ↔
    a ∈ ((finsupp.lsingle m).range : submodule R (add_monoid_algebra R M)) :=
begin
  rw [mem_grade_iff, finsupp.support_subset_singleton'],
  apply exists_congr,
  intros r,
  split; exact eq.symm
end

lemma grade_eq_lsingle_range (m : M) : grade R m = (finsupp.lsingle m).range :=
submodule.ext (mem_grade_iff' R m)

lemma single_mem_grade_by {R} [comm_semiring R] (f : M → ι) (i : ι) (m : M)
  (h : f m = i) (r : R) :
  finsupp.single m r ∈ grade_by R f i :=
begin
  intros x hx,
  rw finset.mem_singleton.mp (finsupp.support_single_subset hx),
  exact h
end

lemma single_mem_grade {R} [comm_semiring R] (i : M) (r : R) : finsupp.single i r ∈ grade R i :=
single_mem_grade_by _ _ _ rfl _

end

open_locale direct_sum

instance grade_by.graded_monoid [add_monoid M] [add_monoid ι] [comm_semiring R] (f : M →+ ι) :
  set_like.graded_monoid (grade_by R f : ι → submodule R (add_monoid_algebra R M)) :=
{ one_mem := λ m h, begin
    rw one_def at h,
    by_cases H : (1 : R) = (0 : R),
    { rw [H , finsupp.single_zero] at h,
      exfalso,
      exact h },
    { rw [finsupp.support_single_ne_zero H, finset.mem_singleton] at h,
      rw [h, add_monoid_hom.map_zero] }
  end,
  mul_mem := λ i j a b ha hb c hc, begin
    set h := support_mul a b hc,
    simp only [finset.mem_bUnion] at h,
    rcases h with ⟨ma, ⟨hma, ⟨mb, ⟨hmb, hmc⟩⟩⟩⟩,
    rw [← ha ma hma, ← hb mb hmb, finset.mem_singleton.mp hmc],
    apply add_monoid_hom.map_add
  end }

instance grade.graded_monoid [add_monoid M] [comm_semiring R] :
  set_like.graded_monoid (grade R : M → submodule R (add_monoid_algebra R M)) :=
by apply grade_by.graded_monoid (add_monoid_hom.id _)

variables {R} [add_monoid M] [decidable_eq ι] [add_monoid ι] [comm_semiring R] (f : M →+ ι)

/-- The canonical grade decomposition. -/
def to_grades_by : add_monoid_algebra R M →ₐ[R] ⨁ i : ι, grade_by R f i :=
add_monoid_algebra.lift R M _
{ to_fun := λ m, direct_sum.of (λ i : ι, grade_by R f i) (f m.to_add)
    ⟨finsupp.single m.to_add 1, single_mem_grade_by _ _ _ rfl _⟩,
  map_one' := direct_sum.of_eq_of_graded_monoid_eq (by congr' 2; try {ext};
    simp only [submodule.mem_to_add_submonoid, to_add_one, add_monoid_hom.map_zero]),
  map_mul' := λ i j, begin
    symmetry,
    convert direct_sum.of_mul_of _ _,
    apply direct_sum.of_eq_of_graded_monoid_eq,
    congr' 2,
    { rw [to_add_mul, add_monoid_hom.map_add] },
    { ext,
      simp only [submodule.mem_to_add_submonoid, add_monoid_hom.map_add, to_add_mul] },
    { exact eq.trans (by rw [one_mul, to_add_mul]) single_mul_single.symm }
  end }

/-- The canonical grade decomposition. -/
def to_grades : add_monoid_algebra R M →ₐ[R] ⨁ i : M, grade R i :=
to_grades_by (add_monoid_hom.id M)

lemma to_grades_by_single' (i : ι) (m : M) (h : f m = i) (r : R) :
  to_grades_by f (finsupp.single m r) =
    direct_sum.of (λ i : ι, grade_by R f i) i
      ⟨finsupp.single m r, single_mem_grade_by _ _ _ h _⟩ :=
begin
  refine (lift_single _ _ _).trans _,
  refine (direct_sum.of_smul _ _ _ _).symm.trans _,
  apply direct_sum.of_eq_of_graded_monoid_eq,
  ext,
  { exact h },
  { rw graded_monoid.mk,
    simp only [mul_one, to_add_of_add, submodule.coe_mk, finsupp.smul_single',
      submodule.coe_smul_of_tower] }
end

@[simp]
lemma to_grades_by_single (m : M) (r : R) :
  to_grades_by f (finsupp.single m r) = direct_sum.of (λ i : ι, grade_by R f i) (f m)
    ⟨finsupp.single m r, single_mem_grade_by _ _ _ rfl _⟩ :=
by apply to_grades_by_single'

@[simp]
lemma to_grades_single (i : ι) (r : R) :
  to_grades (finsupp.single i r) =
    direct_sum.of (λ i : ι, grade R i) i ⟨finsupp.single i r, single_mem_grade _ _⟩ :=
by apply to_grades_by_single

@[simp]
lemma to_grades_by_coe {i : ι} (x : grade_by R f i) :
  to_grades_by f ↑x = direct_sum.of (λ i, grade_by R f i) i x :=
begin
  obtain ⟨x, hx⟩ := x,
  revert hx,
  refine finsupp.induction x _ _,
  { intros hx,
    symmetry,
    exact add_monoid_hom.map_zero _ },
  { intros m b y hmy hb ih hmby,
    have : disjoint (finsupp.single m b).support y.support,
    { simpa only [finsupp.support_single_ne_zero hb, finset.disjoint_singleton_left] },
    rw [mem_grade_by_iff, finsupp.support_add_eq this, finset.coe_union,
      set.union_subset_iff] at hmby,
    cases hmby with h1 h2,
    have : f m = i,
    { rwa [finsupp.support_single_ne_zero hb, finset.coe_singleton,
        set.singleton_subset_iff] at h1 },
    simp only [alg_hom.map_add, submodule.coe_mk, to_grades_by_single' f i m this],
    let ih' := ih h2,
    dsimp at ih',
    rw [ih', ← add_monoid_hom.map_add],
    apply direct_sum.of_eq_of_graded_monoid_eq,
    congr' 2 }
end

@[simp]
lemma to_grades_coe {i : ι} (x : grade R i) :
  to_grades ↑x = direct_sum.of (λ i, grade R i) i x :=
by apply to_grades_by_coe

/-- The canonical recombination of grades. -/
def of_grades_by : (⨁ i : ι, grade_by R f i) →ₐ[R] add_monoid_algebra R M :=
direct_sum.submodule_coe_alg_hom (grade_by R f)

/-- The canonical recombination of grades. -/
def of_grades : (⨁ i : ι, grade R i) →ₐ[R] add_monoid_algebra R ι :=
of_grades_by (add_monoid_hom.id ι)

@[simp]
lemma of_grades_by_of (i : ι) (x : grade_by R f i) :
  of_grades_by f (direct_sum.of (λ i, grade_by R f i) i x) = x :=
direct_sum.submodule_coe_alg_hom_of (grade_by R f) i x

@[simp]
lemma of_grades_of (i : ι) (x : grade R i) :
  of_grades (direct_sum.of (λ i, grade R i) i x) = x :=
by apply of_grades_by_of

@[simp]
lemma of_grades_by_comp_to_grades_by :
  (of_grades_by f).comp (to_grades_by f) = alg_hom.id R (add_monoid_algebra R M) :=
begin
  ext : 2,
  dsimp,
  rw [to_grades_by_single, of_grades_by_of, subtype.coe_mk],
end

@[simp]
lemma of_grades_comp_to_grades :
  of_grades.comp to_grades = alg_hom.id R (add_monoid_algebra R ι) :=
by apply of_grades_by_comp_to_grades_by

@[simp]
lemma of_grades_by_to_grades_by (x : add_monoid_algebra R M) :
  of_grades_by f (to_grades_by f x) = x :=
alg_hom.congr_fun (of_grades_by_comp_to_grades_by f) x

@[simp]
lemma of_grades_to_grades (x : add_monoid_algebra R ι) : of_grades x.to_grades = x :=
by apply of_grades_by_to_grades_by

@[simp]
lemma to_grades_by_comp_of_grades_by :
  (to_grades_by f).comp (of_grades_by f) = alg_hom.id R (⨁ i : ι, grade_by R f i) :=
begin
  ext : 2,
  dsimp [direct_sum.lof_eq_of],
  rw [of_grades_by_of, to_grades_by_coe],
end

@[simp]
lemma to_grades_comp_of_grades :
  to_grades.comp of_grades = alg_hom.id R (⨁ i : ι, grade R i) :=
by apply to_grades_by_comp_of_grades_by

@[simp]
lemma to_grades_by_of_grades_by (g : ⨁ i : ι, grade_by R f i) :
  to_grades_by f (of_grades_by f g) = g :=
alg_hom.congr_fun (to_grades_by_comp_of_grades_by f) g

@[simp]
lemma to_grades_of_grades (g : ⨁ i : ι, grade R i) : (of_grades g).to_grades = g :=
by apply to_grades_by_of_grades_by

/-- An `add_monoid_algebra R M` is equivalent as an algebra to the direct sum of its grades.
-/
@[simps]
def equiv_grades_by : add_monoid_algebra R M ≃ₐ[R] ⨁ i : ι, grade_by R f i :=
alg_equiv.of_alg_hom _ _ (to_grades_by_comp_of_grades_by f) (of_grades_by_comp_to_grades_by f)

/-- An `add_monoid_algebra R ι` is equivalent as an algebra to the direct sum of its grades.
-/
@[simps]
def equiv_grades : add_monoid_algebra R ι ≃ₐ[R] ⨁ i : ι, grade R i :=
equiv_grades_by (add_monoid_hom.id ι)

/-- `add_monoid_algebra.gradesby` describe an internally graded algebra -/
lemma grade_by.is_internal : direct_sum.submodule_is_internal (grade_by R f) :=
(equiv_grades_by f).symm.bijective

/-- `add_monoid_algebra.grades` describe an internally graded algebra -/
lemma grade.is_internal : direct_sum.submodule_is_internal (grade R : ι → submodule R _) :=
grade_by.is_internal (add_monoid_hom.id ι)

end add_monoid_algebra


/-
Copyright (c) 2022 Yaël Dillies. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies

! This file was ported from Lean 3 source module data.finsupp.indicator
! leanprover-community/mathlib commit 842328d9df7e96fd90fc424e115679c15fb23a71
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Data.Finsupp.Defs

/-!
# Building finitely supported functions off finsets

This file defines `Finsupp.indicator` to help create finsupps from finsets.

## Main declarations

* `Finsupp.indicator`: Turns a map from a `Finset` into a `Finsupp` from the entire type.
-/

noncomputable section

open Finset Function

variable {ι α : Type _}

namespace Finsupp

variable [Zero α] {s : Finset ι} (f : ∀ i ∈ s, α) {i : ι}

/-- Create an element of `ι →₀ α` from a finset `s` and a function `f` defined on this finset. -/
def indicator (s : Finset ι) (f : ∀ i ∈ s, α) : ι →₀ α
    where
  toFun i :=
    haveI := Classical.decEq ι
    if H : i ∈ s then f i H else 0
  support :=
    haveI := Classical.decEq α
    (s.attach.filter fun i : s => f i.1 i.2 ≠ 0).map (Embedding.subtype _)
  mem_support_toFun i := by
    classical simp
#align finsupp.indicator Finsupp.indicator

theorem indicator_of_mem (hi : i ∈ s) (f : ∀ i ∈ s, α) : indicator s f i = f i hi :=
  @dif_pos _ (id _) hi _ _ _
#align finsupp.indicator_of_mem Finsupp.indicator_of_mem

theorem indicator_of_not_mem (hi : i ∉ s) (f : ∀ i ∈ s, α) : indicator s f i = 0 :=
  @dif_neg _ (id _) hi _ _ _
#align finsupp.indicator_of_not_mem Finsupp.indicator_of_not_mem

variable (s i)

@[simp]
theorem indicator_apply [DecidableEq ι] : indicator s f i = if hi : i ∈ s then f i hi else 0 := by
  simp only [indicator, ne_eq, coe_mk]
  congr
#align finsupp.indicator_apply Finsupp.indicator_apply

theorem indicator_injective : Injective fun f : ∀ i ∈ s, α => indicator s f := by
  intro a b h
  ext (i hi)
  rw [← indicator_of_mem hi a, ← indicator_of_mem hi b]
  exact FunLike.congr_fun h i
#align finsupp.indicator_injective Finsupp.indicator_injective

theorem support_indicator_subset : ((indicator s f).support : Set ι) ⊆ s := by
  intro i hi
  rw [mem_coe, mem_support_iff] at hi
  by_contra h
  exact hi (indicator_of_not_mem h _)
#align finsupp.support_indicator_subset Finsupp.support_indicator_subset

lemma single_eq_indicator (b : α) : single i b = indicator {i} (fun _ _ => b) := by
  classical
  ext j
  simp [single_apply, indicator_apply, @eq_comm _ j]
#align finsupp.single_eq_indicator Finsupp.single_eq_indicator

end Finsupp


import data.complex.basic
import data.complex.module
import data.fintype.basic
import data.real.basic
import data.matrix.basic
import linear_algebra.matrix

open_locale matrix big_operators
open_locale complex_conjugate
open fintype finset matrix complex

universes u
-- variables {α : Type u}
-- variables {m n : Type*} [fintype m] [fintype n] [decidable_eq m] [decidable_eq n] [has_one n]
variable (n : ℕ)
-- namespace matrix

variables (M : matrix (fin n) (fin n) ℂ)

-- end matrix

-- def make_mat (M : matrix n n ℂ) : matrix n n ℂ := λ i: n, (λ j : n, (M i j))

-- lemma trace_form (A : matrix n n ℂ) (B : matrix n n ℂ) : ∑ (i : n), ∑ (j : n), (A i j)*(B i j) = ( (A.transpose).mul B).trce :=
-- begin
--   simp only [matrix.trce, matrix.mul],
--   -- ∑ (i j : n), A i j * B i j = ∑ (x : n), Aᵀ x ⬝ᵥ λ (j : n), B j x
--   simp [matrix.transpose, dot_product],
--   exact sum_comm,
--   -- ∑ (i j : n), A i j * B i j = ∑ (x : n), Aᵀ x ⬝ᵥ λ (j : n), B j x
-- end

lemma trace_form (A : matrix (fin n) (fin n) ℂ) (B : matrix (fin n) (fin n) ℂ) : ∑ (i : (fin n)), ∑ (j : (fin n)), (A i j)*(B i j) = matrix.trace (fin n) ℂ ℂ ( (A.transpose).mul B) :=
begin
  simp only [matrix.trace, matrix.mul],
  -- ∑ (i j : n), A i j * B i j = ∑ (x : n), Aᵀ x ⬝ᵥ λ (j : n), B j x
  simp [matrix.transpose, dot_product],
  exact sum_comm,
  -- ∑ (i j : n), A i j * B i j = ∑ (x : n), Aᵀ x ⬝ᵥ λ (j : n), B j x
end

lemma Laplace (A : matrix (fin n.succ) (fin n.succ) ℂ) : ∀ i : (fin n.succ), det A = ∑ (j : (fin n.succ)), (A i j)*(-1)^(i+j : ℕ)*det (A.minor i.succ_above j.succ_above) :=
begin
  intro i,
  have hyp := det_succ_row A i,
  rw hyp,
  simp [add_comm, mul_comm],
end


/-
Copyright (c) 2022 Kexing Ying. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kexing Ying
-/
import probability.notation
import probability.independence
import measure_theory.function.conditional_expectation.basic

/-!

# Probabilistic properties of the conditional expectation

This file contains some properties about the conditional expectation which does not belong in
the main conditional expectation file.

## Main result

* `measure_theory.condexp_indep_eq`: If `m₁, m₂` are independent σ-algebras and `f` is a
  `m₁`-measurable function, then `𝔼[f | m₂] = 𝔼[f]` almost everywhere.

-/

open topological_space filter
open_locale nnreal ennreal measure_theory probability_theory big_operators

namespace measure_theory

open probability_theory

variables {Ω E : Type*} [normed_add_comm_group E] [normed_space ℝ E] [complete_space E]
  {m₁ m₂ m : measurable_space Ω} {μ : measure Ω} {f : Ω → E}

/-- If `m₁, m₂` are independent σ-algebras and `f` is `m₁`-measurable, then `𝔼[f | m₂] = 𝔼[f]`
almost everywhere. -/
lemma condexp_indep_eq
  (hle₁ : m₁ ≤ m) (hle₂ : m₂ ≤ m) [sigma_finite (μ.trim hle₂)]
  (hf : strongly_measurable[m₁] f) (hindp : indep m₁ m₂ μ) :
  μ[f | m₂] =ᵐ[μ] λ x, μ[f] :=
begin
  by_cases hfint : integrable f μ,
  swap, { rw [condexp_undef hfint, integral_undef hfint], refl, },
  have hfint₁ := hfint.trim hle₁ hf,
  refine (ae_eq_condexp_of_forall_set_integral_eq hle₂ hfint
    (λ s _ hs, integrable_on_const.2 (or.inr hs)) (λ s hms hs, _)
    strongly_measurable_const.ae_strongly_measurable').symm,
  rw set_integral_const,
  rw ← mem_ℒp_one_iff_integrable at hfint,
  refine hfint.induction_strongly_measurable hle₁ ennreal.one_ne_top _ _ _ _ _ _,
  { intros c t hmt ht,
    rw [integral_indicator (hle₁ _ hmt), set_integral_const, smul_smul,
      ← ennreal.to_real_mul, mul_comm, ← hindp _ _ hmt hms, set_integral_indicator (hle₁ _ hmt),
      set_integral_const, set.inter_comm] },
  { intros u v hdisj huint hvint hu hv hu_eq hv_eq,
    rw mem_ℒp_one_iff_integrable at huint hvint,
    rw [integral_add' huint hvint, smul_add, hu_eq, hv_eq,
      integral_add' huint.integrable_on hvint.integrable_on], },
  { have heq₁ : (λ f : Lp_meas E ℝ m₁ 1 μ, ∫ x, f x ∂μ) =
      (λ f : Lp E 1 μ, ∫ x, f x ∂μ) ∘ (submodule.subtypeL _),
    { refine funext (λ f, integral_congr_ae _),
      simp_rw [submodule.coe_subtypeL', submodule.coe_subtype, ← coe_fn_coe_base], },
    have heq₂ : (λ f : Lp_meas E ℝ m₁ 1 μ, ∫ x in s, f x ∂μ) =
      (λ f : Lp E 1 μ, ∫ x in s, f x ∂μ) ∘ (submodule.subtypeL _),
    { refine funext (λ f, integral_congr_ae (ae_restrict_of_ae _)),
      simp_rw [submodule.coe_subtypeL', submodule.coe_subtype, ← coe_fn_coe_base],
      exact eventually_of_forall (λ _, rfl), },
    refine is_closed_eq (continuous.const_smul _ _) _,
    { rw heq₁,
      exact continuous_integral.comp (continuous_linear_map.continuous _), },
    { rw heq₂,
      exact (continuous_set_integral _).comp (continuous_linear_map.continuous _), }, },
  { intros u v huv huint hueq,
    rwa [← integral_congr_ae huv,
      ← (set_integral_congr_ae (hle₂ _ hms) _ : ∫ x in s, u x ∂μ = ∫ x in s, v x ∂μ)],
    filter_upwards [huv] with x hx _ using hx, },
  { exact ⟨f, hf, eventually_eq.rfl⟩, },
end

end measure_theory


/-
Copyright (c) 2022 OpenAI. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Daniel Selsam
-/
import data.nat.basic
import data.list.basic
import data.list.pairwise
import tactic.interval_cases

open tactic

/--
Aaron, Darren, Karen, Maren, and Sharon rode on a small train that has five cars that seat one person each.
Maren sat in the last car. Aaron sat directly behind Sharon. Darren sat in one of the cars in front of Aaron.
At least one person sat between Karen and Darren. Who sat in the middle car?
-/
theorem amc8_2020_p6 (aaron darren karen maren sharon : ℕ) :
  list.pairwise (≠) [aaron, darren, karen, maren, sharon]
  → list.all [aaron, darren, karen, maren, sharon] (λ n, n < 5)
  → maren = 0
  → aaron + 1 = sharon
  → darren > aaron
  → max darren karen > min darren karen + 1
  → aaron = 2 :=
begin
  intros h_distinct h_bounds h_maren h_aaron_sharon h_darren_aaron h_darren_karen,
  subst h_maren,
  simp at h_distinct h_bounds,
  cases_matching* [_ ∧ _],
  interval_cases aaron ; try { contradiction } ; subst_vars ;
    interval_cases darren ; try { contradiction } ; subst_vars ;
    interval_cases karen  ; try { contradiction } ; subst_vars ;
    simp at h_darren_karen ; contradiction
end


import ideal

section generation

variables {R : Type} [comm_ring R]

/- Inductively define the (underlying set of) the ideal
  generated by a set
-/
inductive gen_by' (A : set R) : set R
| mem_self : ∀ a ∈ A, gen_by' a
| zero_mem : gen_by' 0
| add_mem : ∀ x y : R, gen_by' x → gen_by' y → gen_by' (x + y)
| smul_mem : ∀ r x : R, gen_by' x → gen_by' (r*x)

def gen_by (A : set R) : ideal R :=
{ carrier := gen_by' A,
  zero_mem' :=  gen_by'.zero_mem,
  add_mem' := gen_by'.add_mem,
  smul_mem' := gen_by'.smul_mem
}

/- TODO : a million helper lemmas
  gen_by A ⊆ I ↔ A ⊆ I.carrier
  gen_by A = intersection of ideals I st A ⊆ I.carrier,
  etc.
-/

end generation

/- An ideal is finitely generated if it is the ideal defined by a
  finite set.
  Lean defines a set X to be finite if there is a list L (built-in inductive type)
  of elements of the set, such that ∀ x ∈ X, x ∈ X → x ∈ L
-/

section fingen

variables {R : Type} [comm_ring R]

def fin_gen (I : ideal R) := ∃ A : set R, set.finite A ∧ gen_by A = I

end fingen

section noeth

variables (R : Type) [comm_ring R]

def noetherian := ∀ I : ideal R, fin_gen I

end noeth

section ascending_chain

variables (R : Type) [comm_ring R]

def asc_chain {R : Type} [comm_ring R] (I : ℕ → ideal R) := ∀ n : ℕ, I n ⊆ I (n + 1)

def asc_ch_cond (R : Type) [comm_ring R] :=
  ∀ (f : ℕ → ideal R), asc_chain f → ∃ N : ℕ, ∀ n : ℕ, n ≥ N → f n = f N

end ascending_chain

variables {R : Type} [comm_ring R]

lemma noetherian_of_acc (h : asc_ch_cond R) : noetherian R := sorry
lemma acc_of_noetherian (h : noetherian R) : asc_ch_cond R := sorry

-- need facts about polynomials, degrees?


/-
Copyright (c) 2022 Dagur Tómas Ásgeirsson. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Dagur Tómas Ásgeirsson, Leonardo de Moura
-/

import data.set.image

/-!
# Indicator function valued in bool

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

See also `set.indicator` and `set.piecewise`.
-/

open bool

namespace set
variables {α : Type*} (s : set α)

/-- `bool_indicator` maps `x` to `tt` if `x ∈ s`, else to `ff` -/
noncomputable def bool_indicator (x : α) :=
@ite _ (x ∈ s) (classical.prop_decidable _) tt ff

lemma mem_iff_bool_indicator (x : α) : x ∈ s ↔ s.bool_indicator x = tt :=
by { unfold bool_indicator, split_ifs ; tauto }

lemma not_mem_iff_bool_indicator (x : α) : x ∉ s ↔ s.bool_indicator x = ff :=
by { unfold bool_indicator, split_ifs ; tauto }

lemma preimage_bool_indicator_tt : s.bool_indicator ⁻¹' {tt} = s :=
ext (λ x, (s.mem_iff_bool_indicator x).symm)

lemma preimage_bool_indicator_ff : s.bool_indicator ⁻¹' {ff} = sᶜ :=
ext (λ x, (s.not_mem_iff_bool_indicator x).symm)

open_locale classical

lemma preimage_bool_indicator_eq_union (t : set bool) :
  s.bool_indicator ⁻¹' t = (if tt ∈ t then s else ∅) ∪ (if ff ∈ t then sᶜ else ∅) :=
begin
  ext x,
  dsimp [bool_indicator],
  split_ifs ; tauto
end

lemma preimage_bool_indicator (t : set bool) :
  s.bool_indicator ⁻¹' t = univ ∨ s.bool_indicator ⁻¹' t = s ∨
  s.bool_indicator ⁻¹' t = sᶜ ∨ s.bool_indicator ⁻¹' t = ∅ :=
begin
  simp only [preimage_bool_indicator_eq_union],
  split_ifs ; simp [s.union_compl_self]
end

end set


inductive day : Type
| monday : day
| tuesday : day
| wednesday : day
| thursday : day
| friday : day
| saturday : day
| sunday : day

def next_weekday : day → day
| day.monday    := day.tuesday
| day.tuesday   := day.wednesday
| day.wednesday := day.thursday
| day.thursday  := day.friday
| day.friday    := day.monday
| day.saturday  := day.monday
| day.sunday    := day.monday

#eval (next_weekday day.friday)

#eval (next_weekday (next_weekday day.saturday))

#check (next_weekday (next_weekday day.saturday))

/-
def test_next_weekday : Prop := (next_weekday (next_weekday day.saturday)) = day.tuesday

#check test_next_weekday
-/

/-
theorem test_next_weekday : (next_weekday (next_weekday day.saturday)) = day.tuesday :=
begin

end
-/


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

/-!
# The fold operation for a commutative associative operation over a finset.
-/

namespace finset
open multiset

variables {α β γ : Type*}

/-! ### fold -/
section fold
variables (op : β → β → β) [hc : is_commutative β op] [ha : is_associative β op]
local notation a * b := op a b
include hc ha

/-- `fold op b f s` folds the commutative associative operation `op` over the
  `f`-image of `s`, i.e. `fold (+) b f {1,2,3} = f 1 + f 2 + f 3 + b`. -/
def fold (b : β) (f : α → β) (s : finset α) : β := (s.1.map f).fold op b

variables {op} {f : α → β} {b : β} {s : finset α} {a : α}

@[simp] theorem fold_empty : (∅ : finset α).fold op b f = b := rfl

@[simp] theorem fold_cons (h : a ∉ s) : (cons a s h).fold op b f = f a * s.fold op b f :=
by { dunfold fold, rw [cons_val, multiset.map_cons, fold_cons_left], }

@[simp] theorem fold_insert [decidable_eq α] (h : a ∉ s) :
  (insert a s).fold op b f = f a * s.fold op b f :=
by unfold fold; rw [insert_val, ndinsert_of_not_mem h, multiset.map_cons, fold_cons_left]

@[simp] theorem fold_singleton : ({a} : finset α).fold op b f = f a * b := rfl

@[simp] theorem fold_map {g : γ ↪ α} {s : finset γ} :
  (s.map g).fold op b f = s.fold op b (f ∘ g) :=
by simp only [fold, map, multiset.map_map]

@[simp] theorem fold_image [decidable_eq α] {g : γ → α} {s : finset γ}
  (H : ∀ (x ∈ s) (y ∈ s), g x = g y → x = y) : (s.image g).fold op b f = s.fold op b (f ∘ g) :=
by simp only [fold, image_val_of_inj_on H, multiset.map_map]

@[congr] theorem fold_congr {g : α → β} (H : ∀ x ∈ s, f x = g x) : s.fold op b f = s.fold op b g :=
by rw [fold, fold, map_congr rfl H]

theorem fold_op_distrib {f g : α → β} {b₁ b₂ : β} :
  s.fold op (b₁ * b₂) (λx, f x * g x) = s.fold op b₁ f * s.fold op b₂ g :=
by simp only [fold, fold_distrib]

lemma fold_const [decidable (s = ∅)] (c : β) (h : op c (op b c) = op b c) :
  finset.fold op b (λ _, c) s = if s = ∅ then b else op b c :=
begin
  classical,
  unfreezingI { induction s using finset.induction_on with x s hx IH },
  { simp },
  { simp only [finset.fold_insert hx, IH, if_false, finset.insert_ne_empty],
    split_ifs,
    { rw hc.comm },
    { exact h } }
end

theorem fold_hom {op' : γ → γ → γ} [is_commutative γ op'] [is_associative γ op']
  {m : β → γ} (hm : ∀x y, m (op x y) = op' (m x) (m y)) :
  s.fold op' (m b) (λx, m (f x)) = m (s.fold op b f) :=
by rw [fold, fold, ← fold_hom op hm, multiset.map_map]

theorem fold_disj_union {s₁ s₂ : finset α} {b₁ b₂ : β} (h) :
  (s₁.disj_union s₂ h).fold op (b₁ * b₂) f = s₁.fold op b₁ f * s₂.fold op b₂ f :=
(congr_arg _ $ multiset.map_add _ _ _).trans (multiset.fold_add _ _ _ _ _)

theorem fold_union_inter [decidable_eq α] {s₁ s₂ : finset α} {b₁ b₂ : β} :
  (s₁ ∪ s₂).fold op b₁ f * (s₁ ∩ s₂).fold op b₂ f = s₁.fold op b₂ f * s₂.fold op b₁ f :=
by unfold fold; rw [← fold_add op, ← multiset.map_add, union_val,
     inter_val, union_add_inter, multiset.map_add, hc.comm, fold_add]

@[simp] theorem fold_insert_idem [decidable_eq α] [hi : is_idempotent β op] :
  (insert a s).fold op b f = f a * s.fold op b f :=
begin
  by_cases (a ∈ s),
  { rw [← insert_erase h], simp [← ha.assoc, hi.idempotent] },
  { apply fold_insert h },
end

theorem fold_image_idem [decidable_eq α] {g : γ → α} {s : finset γ}
  [hi : is_idempotent β op] :
  (image g s).fold op b f = s.fold op b (f ∘ g) :=
begin
  induction s using finset.cons_induction with x xs hx ih,
  { rw [fold_empty, image_empty, fold_empty] },
  { haveI := classical.dec_eq γ,
    rw [fold_cons, cons_eq_insert, image_insert, fold_insert_idem, ih], }
end

/-- A stronger version of `finset.fold_ite`, but relies on
an explicit proof of idempotency on the seed element, rather
than relying on typeclass idempotency over the whole type. -/
lemma fold_ite' {g : α → β} (hb : op b b = b)
  (p : α → Prop) [decidable_pred p] :
  finset.fold op b (λ i, ite (p i) (f i) (g i)) s =
  op (finset.fold op b f (s.filter p)) (finset.fold op b g (s.filter (λ i, ¬ p i))) :=
begin
  classical,
  induction s using finset.induction_on with x s hx IH,
  { simp [hb] },
  { simp only [finset.filter_congr_decidable, finset.fold_insert hx],
    split_ifs with h h,
    { have : x ∉ finset.filter p s,
      { simp [hx] },
      simp [finset.filter_insert, h, finset.fold_insert this, ha.assoc, IH] },
    { have : x ∉ finset.filter (λ i, ¬ p i) s,
      { simp [hx] },
      simp [finset.filter_insert, h, finset.fold_insert this, IH, ←ha.assoc, hc.comm] } }
end

/-- A weaker version of `finset.fold_ite'`,
relying on typeclass idempotency over the whole type,
instead of solely on the seed element.
However, this is easier to use because it does not generate side goals. -/
lemma fold_ite [is_idempotent β op] {g : α → β}
  (p : α → Prop) [decidable_pred p] :
  finset.fold op b (λ i, ite (p i) (f i) (g i)) s =
  op (finset.fold op b f (s.filter p)) (finset.fold op b g (s.filter (λ i, ¬ p i))) :=
fold_ite' (is_idempotent.idempotent _) _

lemma fold_op_rel_iff_and
  {r : β → β → Prop} (hr : ∀ {x y z}, r x (op y z) ↔ (r x y ∧ r x z)) {c : β} :
  r c (s.fold op b f) ↔ (r c b ∧ ∀ x∈s, r c (f x)) :=
begin
  classical,
  apply finset.induction_on s, { simp },
  clear s, intros a s ha IH,
  rw [finset.fold_insert ha, hr, IH, ← and_assoc, and_comm (r c (f a)), and_assoc],
  apply and_congr iff.rfl,
  split,
  { rintro ⟨h₁, h₂⟩, intros b hb, rw finset.mem_insert at hb,
    rcases hb with rfl|hb; solve_by_elim },
  { intro h, split,
    { exact h a (finset.mem_insert_self _ _), },
    { intros b hb, apply h b, rw finset.mem_insert, right, exact hb } }
end

lemma fold_op_rel_iff_or
  {r : β → β → Prop} (hr : ∀ {x y z}, r x (op y z) ↔ (r x y ∨ r x z)) {c : β} :
  r c (s.fold op b f) ↔ (r c b ∨ ∃ x∈s, r c (f x)) :=
begin
  classical,
  apply finset.induction_on s, { simp },
  clear s, intros a s ha IH,
  rw [finset.fold_insert ha, hr, IH, ← or_assoc, or_comm (r c (f a)), or_assoc],
  apply or_congr iff.rfl,
  split,
  { rintro (h₁|⟨x, hx, h₂⟩),
    { use a, simp [h₁] },
    { refine ⟨x, by simp [hx], h₂⟩ } },
  { rintro ⟨x, hx, h⟩,
    rw mem_insert at hx, cases hx,
    { left, rwa hx at h },
    { right, exact ⟨x, hx, h⟩ } }
end

omit hc ha

@[simp]
lemma fold_union_empty_singleton [decidable_eq α] (s : finset α) :
  finset.fold (∪) ∅ singleton s = s :=
begin
  apply finset.induction_on s,
  { simp only [fold_empty], },
  { intros a s has ih, rw [fold_insert has, ih, insert_eq], }
end

lemma fold_sup_bot_singleton [decidable_eq α] (s : finset α) :
  finset.fold (⊔) ⊥ singleton s = s :=
fold_union_empty_singleton s

section order
variables [linear_order β] (c : β)

lemma le_fold_min : c ≤ s.fold min b f ↔ (c ≤ b ∧ ∀ x∈s, c ≤ f x) :=
fold_op_rel_iff_and $ λ x y z, le_min_iff

lemma fold_min_le : s.fold min b f ≤ c ↔ (b ≤ c ∨ ∃ x∈s, f x ≤ c) :=
begin
  show _ ≥ _ ↔ _,
  apply fold_op_rel_iff_or,
  intros x y z,
  show _ ≤ _ ↔ _,
  exact min_le_iff
end

lemma lt_fold_min : c < s.fold min b f ↔ (c < b ∧ ∀ x∈s, c < f x) :=
fold_op_rel_iff_and $ λ x y z, lt_min_iff

lemma fold_min_lt : s.fold min b f < c ↔ (b < c ∨ ∃ x∈s, f x < c) :=
begin
  show _ > _ ↔ _,
  apply fold_op_rel_iff_or,
  intros x y z,
  show _ < _ ↔ _,
  exact min_lt_iff
end

lemma fold_max_le : s.fold max b f ≤ c ↔ (b ≤ c ∧ ∀ x∈s, f x ≤ c) :=
begin
  show _ ≥ _ ↔ _,
  apply fold_op_rel_iff_and,
  intros x y z,
  show _ ≤ _ ↔ _,
  exact max_le_iff
end

lemma le_fold_max : c ≤ s.fold max b f ↔ (c ≤ b ∨ ∃ x∈s, c ≤ f x) :=
fold_op_rel_iff_or $ λ x y z, le_max_iff

lemma fold_max_lt : s.fold max b f < c ↔ (b < c ∧ ∀ x∈s, f x < c) :=
begin
  show _ > _ ↔ _,
  apply fold_op_rel_iff_and,
  intros x y z,
  show _ < _ ↔ _,
  exact max_lt_iff
end

lemma lt_fold_max : c < s.fold max b f ↔ (c < b ∨ ∃ x∈s, c < f x) :=
fold_op_rel_iff_or $ λ x y z, lt_max_iff

end order

end fold

end finset


/-
Copyright (c) 2014 Parikshit Khanna. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Parikshit Khanna, Jeremy Avigad, Leonardo de Moura, Floris van Doorn, Mario Carneiro,
Scott Morrison
-/
import data.list.count
import data.list.infix
import algebra.order.monoid.min_max

/-!
# Lattice structure of lists

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

This files prove basic properties about `list.disjoint`, `list.union`, `list.inter` and
`list.bag_inter`, which are defined in core Lean and `data.list.defs`.

`l₁ ∪ l₂` is the list where all elements of `l₁` have been inserted in `l₂` in order. For example,
`[0, 0, 1, 2, 2, 3] ∪ [4, 3, 3, 0] = [1, 2, 4, 3, 3, 0]`

`l₁ ∩ l₂` is the list of elements of `l₁` in order which are in `l₂`. For example,
`[0, 0, 1, 2, 2, 3] ∪ [4, 3, 3, 0] = [0, 0, 3]`

`bag_inter l₁ l₂` is the list of elements that are in both `l₁` and `l₂`, counted with multiplicity
and in the order they appear in `l₁`. As opposed to `list.inter`, `list.bag_inter` copes well with
multiplicity. For example,
`bag_inter [0, 1, 2, 3, 2, 1, 0] [1, 0, 1, 4, 3] = [0, 1, 3, 1]`
-/

open nat

namespace list
variables {α : Type*} {l l₁ l₂ : list α} {p : α → Prop} {a : α}

/-! ### `disjoint` -/

section disjoint

lemma disjoint.symm (d : disjoint l₁ l₂) : disjoint l₂ l₁ := λ a i₂ i₁, d i₁ i₂

lemma disjoint_comm : disjoint l₁ l₂ ↔ disjoint l₂ l₁ := ⟨disjoint.symm, disjoint.symm⟩

lemma disjoint_left : disjoint l₁ l₂ ↔ ∀ ⦃a⦄, a ∈ l₁ → a ∉ l₂ := iff.rfl

lemma disjoint_right : disjoint l₁ l₂ ↔ ∀ ⦃a⦄, a ∈ l₂ → a ∉ l₁ := disjoint_comm

lemma disjoint_iff_ne : disjoint l₁ l₂ ↔ ∀ a ∈ l₁, ∀ b ∈ l₂, a ≠ b :=
by simp only [disjoint_left, imp_not_comm, forall_eq']

lemma disjoint_of_subset_left (ss : l₁ ⊆ l) (d : disjoint l l₂) : disjoint l₁ l₂ := λ x m, d (ss m)

lemma disjoint_of_subset_right (ss : l₂ ⊆ l) (d : disjoint l₁ l) : disjoint l₁ l₂ :=
λ x m m₁, d m (ss m₁)

lemma disjoint_of_disjoint_cons_left {l₁ l₂} : disjoint (a :: l₁) l₂ → disjoint l₁ l₂ :=
disjoint_of_subset_left (list.subset_cons _ _)

lemma disjoint_of_disjoint_cons_right {l₁ l₂} : disjoint l₁ (a :: l₂) → disjoint l₁ l₂ :=
disjoint_of_subset_right (list.subset_cons _ _)

@[simp] lemma disjoint_nil_left (l : list α) : disjoint [] l := λ a, (not_mem_nil a).elim

@[simp] lemma disjoint_nil_right (l : list α) : disjoint l [] :=
by { rw disjoint_comm, exact disjoint_nil_left _ }

@[simp, priority 1100] lemma singleton_disjoint : disjoint [a] l ↔ a ∉ l :=
by { simp only [disjoint, mem_singleton, forall_eq], refl }

@[simp, priority 1100] lemma disjoint_singleton : disjoint l [a] ↔ a ∉ l :=
by rw [disjoint_comm, singleton_disjoint]

@[simp] lemma disjoint_append_left : disjoint (l₁ ++ l₂) l ↔ disjoint l₁ l ∧ disjoint l₂ l :=
by simp only [disjoint, mem_append, or_imp_distrib, forall_and_distrib]

@[simp] lemma disjoint_append_right : disjoint l (l₁ ++ l₂) ↔ disjoint l l₁ ∧ disjoint l l₂ :=
disjoint_comm.trans $ by simp only [disjoint_comm, disjoint_append_left]

@[simp] lemma disjoint_cons_left : disjoint (a :: l₁) l₂ ↔ a ∉ l₂ ∧ disjoint l₁ l₂ :=
(@disjoint_append_left _ l₂ [a] l₁).trans $ by simp only [singleton_disjoint]

@[simp] lemma disjoint_cons_right : disjoint l₁ (a :: l₂) ↔ a ∉ l₁ ∧ disjoint l₁ l₂ :=
disjoint_comm.trans $ by simp only [disjoint_comm, disjoint_cons_left]

lemma disjoint_of_disjoint_append_left_left (d : disjoint (l₁ ++ l₂) l) : disjoint l₁ l :=
(disjoint_append_left.1 d).1

lemma disjoint_of_disjoint_append_left_right (d : disjoint (l₁ ++ l₂) l) : disjoint l₂ l :=
(disjoint_append_left.1 d).2

lemma disjoint_of_disjoint_append_right_left (d : disjoint l (l₁ ++ l₂)) : disjoint l l₁ :=
(disjoint_append_right.1 d).1

lemma disjoint_of_disjoint_append_right_right (d : disjoint l (l₁ ++ l₂)) : disjoint l l₂ :=
(disjoint_append_right.1 d).2

lemma disjoint_take_drop {m n : ℕ} (hl : l.nodup) (h : m ≤ n) : disjoint (l.take m) (l.drop n) :=
begin
  induction l generalizing m n,
  case list.nil : m n
  { simp },
  case list.cons : x xs xs_ih m n
  { cases m; cases n; simp only [disjoint_cons_left, mem_cons_iff, disjoint_cons_right, drop,
                                 true_or, eq_self_iff_true, not_true, false_and,
                                 disjoint_nil_left, take],
    { cases h },
    cases hl with _ _ h₀ h₁, split,
    { intro h, exact h₀ _ (mem_of_mem_drop h) rfl, },
    solve_by_elim [le_of_succ_le_succ] { max_depth := 4 } },
end

end disjoint

variable [decidable_eq α]

/-! ### `union` -/

section union

@[simp] lemma nil_union (l : list α) : [] ∪ l = l := rfl

@[simp] lemma cons_union (l₁ l₂ : list α) (a : α) : a :: l₁ ∪ l₂ = insert a (l₁ ∪ l₂) := rfl

@[simp] lemma mem_union : a ∈ l₁ ∪ l₂ ↔ a ∈ l₁ ∨ a ∈ l₂ :=
by induction l₁; simp only [nil_union, not_mem_nil, false_or, cons_union, mem_insert_iff,
  mem_cons_iff, or_assoc, *]

lemma mem_union_left (h : a ∈ l₁) (l₂ : list α) : a ∈ l₁ ∪ l₂ := mem_union.2 (or.inl h)

lemma mem_union_right (l₁ : list α) (h : a ∈ l₂) : a ∈ l₁ ∪ l₂ := mem_union.2 (or.inr h)

lemma sublist_suffix_of_union : ∀ l₁ l₂ : list α, ∃ t, t <+ l₁ ∧ t ++ l₂ = l₁ ∪ l₂
| [] l₂ := ⟨[], by refl, rfl⟩
| (a :: l₁) l₂ := let ⟨t, s, e⟩ := sublist_suffix_of_union l₁ l₂ in
  if h : a ∈ l₁ ∪ l₂
  then ⟨t, sublist_cons_of_sublist _ s, by simp only [e, cons_union, insert_of_mem h]⟩
  else ⟨a::t, s.cons_cons _, by simp only [cons_append, cons_union, e, insert_of_not_mem h];
    split; refl⟩

lemma suffix_union_right (l₁ l₂ : list α) : l₂ <:+ l₁ ∪ l₂ :=
(sublist_suffix_of_union l₁ l₂).imp (λ a, and.right)

lemma union_sublist_append (l₁ l₂ : list α) : l₁ ∪ l₂ <+ l₁ ++ l₂ :=
let ⟨t, s, e⟩ := sublist_suffix_of_union l₁ l₂ in
e ▸ (append_sublist_append_right _).2 s

lemma forall_mem_union : (∀ x ∈ l₁ ∪ l₂, p x) ↔ (∀ x ∈ l₁, p x) ∧ (∀ x ∈ l₂, p x) :=
by simp only [mem_union, or_imp_distrib, forall_and_distrib]

lemma forall_mem_of_forall_mem_union_left (h : ∀ x ∈ l₁ ∪ l₂, p x) : ∀ x ∈ l₁, p x :=
(forall_mem_union.1 h).1

lemma forall_mem_of_forall_mem_union_right
   (h : ∀ x ∈ l₁ ∪ l₂, p x) : ∀ x ∈ l₂, p x :=
(forall_mem_union.1 h).2

end union

/-! ### `inter` -/

section inter

@[simp] lemma inter_nil (l : list α) : [] ∩ l = [] := rfl

@[simp] lemma inter_cons_of_mem (l₁ : list α) (h : a ∈ l₂) :
  (a :: l₁) ∩ l₂ = a :: (l₁ ∩ l₂) :=
if_pos h

@[simp] lemma inter_cons_of_not_mem (l₁ : list α) (h : a ∉ l₂) :
  (a :: l₁) ∩ l₂ = l₁ ∩ l₂ :=
if_neg h

lemma mem_of_mem_inter_left : a ∈ l₁ ∩ l₂ → a ∈ l₁ := mem_of_mem_filter

lemma mem_of_mem_inter_right : a ∈ l₁ ∩ l₂ → a ∈ l₂ := of_mem_filter

lemma mem_inter_of_mem_of_mem : a ∈ l₁ → a ∈ l₂ → a ∈ l₁ ∩ l₂ :=
mem_filter_of_mem

@[simp] lemma mem_inter : a ∈ l₁ ∩ l₂ ↔ a ∈ l₁ ∧ a ∈ l₂ := mem_filter

lemma inter_subset_left (l₁ l₂ : list α) : l₁ ∩ l₂ ⊆ l₁ := filter_subset _

lemma inter_subset_right (l₁ l₂ : list α) : l₁ ∩ l₂ ⊆ l₂ := λ a, mem_of_mem_inter_right

lemma subset_inter {l l₁ l₂ : list α} (h₁ : l ⊆ l₁) (h₂ : l ⊆ l₂) : l ⊆ l₁ ∩ l₂ :=
λ a h, mem_inter.2 ⟨h₁ h, h₂ h⟩

lemma inter_eq_nil_iff_disjoint : l₁ ∩ l₂ = [] ↔ disjoint l₁ l₂ :=
by { simp only [eq_nil_iff_forall_not_mem, mem_inter, not_and], refl }

lemma forall_mem_inter_of_forall_left (h : ∀ x ∈ l₁, p x)
  (l₂ : list α) :
  ∀ x, x ∈ l₁ ∩ l₂ → p x :=
ball.imp_left (λ x, mem_of_mem_inter_left) h

lemma forall_mem_inter_of_forall_right (l₁ : list α)
  (h : ∀ x ∈ l₂, p x) :
  ∀ x, x ∈ l₁ ∩ l₂ → p x :=
ball.imp_left (λ x, mem_of_mem_inter_right) h

@[simp] lemma inter_reverse {xs ys : list α} : xs.inter ys.reverse = xs.inter ys :=
by simp only [list.inter, mem_reverse]

end inter

/-! ### `bag_inter` -/

section bag_inter

@[simp] lemma nil_bag_inter (l : list α) : [].bag_inter l = [] :=
by cases l; refl

@[simp] lemma bag_inter_nil (l : list α) : l.bag_inter [] = [] :=
by cases l; refl

@[simp] lemma cons_bag_inter_of_pos (l₁ : list α) (h : a ∈ l₂) :
  (a :: l₁).bag_inter l₂ = a :: l₁.bag_inter (l₂.erase a) :=
by cases l₂; exact if_pos h

@[simp] lemma cons_bag_inter_of_neg (l₁ : list α) (h : a ∉ l₂) :
  (a :: l₁).bag_inter l₂ = l₁.bag_inter l₂ :=
begin
  cases l₂, {simp only [bag_inter_nil]},
  simp only [erase_of_not_mem h, list.bag_inter, if_neg h]
end

@[simp] lemma mem_bag_inter {a : α} : ∀ {l₁ l₂ : list α}, a ∈ l₁.bag_inter l₂ ↔ a ∈ l₁ ∧ a ∈ l₂
| []        l₂ := by simp only [nil_bag_inter, not_mem_nil, false_and]
| (b :: l₁) l₂ := begin
    by_cases b ∈ l₂,
    { rw [cons_bag_inter_of_pos _ h, mem_cons_iff, mem_cons_iff, mem_bag_inter],
      by_cases ba : a = b,
      { simp only [ba, h, eq_self_iff_true, true_or, true_and] },
      { simp only [mem_erase_of_ne ba, ba, false_or] } },
    { rw [cons_bag_inter_of_neg _ h, mem_bag_inter, mem_cons_iff, or_and_distrib_right],
      symmetry, apply or_iff_right_of_imp,
      rintro ⟨rfl, h'⟩, exact h.elim h' }
  end

@[simp] lemma count_bag_inter {a : α} :
  ∀ {l₁ l₂ : list α}, count a (l₁.bag_inter l₂) = min (count a l₁) (count a l₂)
| []         l₂         := by simp
| l₁         []         := by simp
| (b :: l₁)  l₂         :=
begin
  by_cases hb : b ∈ l₂,
  { rw [cons_bag_inter_of_pos _ hb, count_cons', count_cons', count_bag_inter, count_erase,
      ← min_add_add_right],
    by_cases ab : a = b,
    { rw [if_pos ab, tsub_add_cancel_of_le],
      rwa [succ_le_iff, count_pos, ab] },
    { rw [if_neg ab, tsub_zero, add_zero, add_zero] } },
  { rw [cons_bag_inter_of_neg _ hb, count_bag_inter],
    by_cases ab : a = b,
    { rw [← ab] at hb, rw [count_eq_zero.2 hb, min_zero, min_zero] },
    { rw [count_cons_of_ne ab] } },
end

lemma bag_inter_nil_iff_inter_nil : ∀ l₁ l₂ : list α, l₁.bag_inter l₂ = [] ↔ l₁ ∩ l₂ = []
| []        l₂ := by simp
| (b :: l₁) l₂ :=
begin
  by_cases h : b ∈ l₂; simp [h],
  exact bag_inter_nil_iff_inter_nil l₁ l₂
end

end bag_inter
end list


/-
Copyright (c) 2014 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Leonardo de Moura, Jeremy Avigad
-/
import logic.eq
open inhabited decidable eq.ops

namespace prod
  variables {A B : Type} {a₁ a₂ : A} {b₁ b₂ : B} {u : A × B}

  theorem pair_eq : a₁ = a₂ → b₁ = b₂ → (a₁, b₁) = (a₂, b₂) :=
  assume H1 H2, H1 ▸ H2 ▸ rfl

  protected theorem eq {p₁ p₂ : prod A B} : pr₁ p₁ = pr₁ p₂ → pr₂ p₁ = pr₂ p₂ → p₁ = p₂ :=
  destruct p₁ (take a₁ b₁, destruct p₂ (take a₂ b₂ H₁ H₂, pair_eq H₁ H₂))

  protected definition is_inhabited [instance] [h₁ : inhabited A] [h₂ : inhabited B] : inhabited (prod A B) :=
  inhabited.mk (default A, default B)

  protected definition has_decidable_eq [instance] [h₁ : decidable_eq A] [h₂ : decidable_eq B] : ∀ p₁ p₂ : A × B, decidable (p₁ = p₂)
  | (a, b) (a', b') :=
    match h₁ a a' with
    | inl e₁ :=
      match h₂ b b' with
      | inl e₂ := by left; congruence; repeat assumption
      | inr n₂ := by right; intro h; injection h; contradiction
      end
    | inr n₁ := by right; intro h; injection h; contradiction
    end

  definition swap {A : Type} : A × A → A × A
  | (a, b) := (b, a)

  theorem swap_swap {A : Type} : ∀ p : A × A, swap (swap p) = p
  | (a, b) := rfl

  theorem eq_of_swap_eq {A : Type} : ∀ p₁ p₂ : A × A, swap p₁ = swap p₂ → p₁ = p₂ :=
  take p₁ p₂, assume seqs,
  have swap (swap p₁) = swap (swap p₂), from congr_arg swap seqs,
  by rewrite *swap_swap at this; exact this
end prod


/-
Copyright (c) 2021 Vladimir Goryachev. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies, Vladimir Goryachev, Kyle Miller, Scott Morrison, Eric Rodriguez

! This file was ported from Lean 3 source module data.nat.nth
! leanprover-community/mathlib commit 92ca63f0fb391a9ca5f22d2409a6080e786d99f7
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Data.Nat.Count
import Mathbin.Order.OrderIsoNat

/-!
# The `n`th Number Satisfying a Predicate

This file defines a function for "what is the `n`th number that satisifies a given predicate `p`",
and provides lemmas that deal with this function and its connection to `nat.count`.

## Main definitions

* `nth p n`: The `n`-th natural `k` (zero-indexed) such that `p k`. If there is no
  such natural (that is, `p` is true for at most `n` naturals), then `nth p n = 0`.

## Main results

* `nat.nth_set_card`: For a fintely-often true `p`, gives the cardinality of the set of numbers
  satisfying `p` above particular values of `nth p`
* `nat.count_nth_gc`: Establishes a Galois connection between `nth p` and `count p`.
* `nat.nth_eq_order_iso_of_nat`: For an infinitely-ofter true predicate, `nth` agrees with the
  order-isomorphism of the subtype to the natural numbers.

There has been some discussion on the subject of whether both of `nth` and
`nat.subtype.order_iso_of_nat` should exist. See discussion
[here](https://github.com/leanprover-community/mathlib/pull/9457#pullrequestreview-767221180).
Future work should address how lemmas that use these should be written.

-/

open Finset

namespace Nat

variable (p : ℕ → Prop)

/-- Find the `n`-th natural number satisfying `p` (indexed from `0`, so `nth p 0` is the first
natural number satisfying `p`), or `0` if there is no such number. See also
`subtype.order_iso_of_nat` for the order isomorphism with ℕ when `p` is infinitely often true. -/
noncomputable def nth : ℕ → ℕ
  | n => infₛ { i : ℕ | p i ∧ ∀ k < n, nth k < i }
#align nat.nth Nat.nth

theorem nth_zero : nth p 0 = infₛ { i : ℕ | p i } :=
  by
  rw [nth]
  simp
#align nat.nth_zero Nat.nth_zero

@[simp]
theorem nth_zero_of_zero (h : p 0) : nth p 0 = 0 := by simp [nth_zero, h]
#align nat.nth_zero_of_zero Nat.nth_zero_of_zero

theorem nth_zero_of_exists [DecidablePred p] (h : ∃ n, p n) : nth p 0 = Nat.find h :=
  by
  rw [nth_zero]
  convert Nat.infₛ_def h
#align nat.nth_zero_of_exists Nat.nth_zero_of_exists

theorem nth_set_card_aux {n : ℕ} (hp : (setOf p).Finite)
    (hp' : { i : ℕ | p i ∧ ∀ t < n, nth p t < i }.Finite) (hle : n ≤ hp.toFinset.card) :
    hp'.toFinset.card = hp.toFinset.card - n :=
  by
  induction' n with k hk
  · congr
    simp only [IsEmpty.forall_iff, Nat.not_lt_zero, forall_const, and_true_iff]
  have hp'' : { i : ℕ | p i ∧ ∀ t, t < k → nth p t < i }.Finite :=
    by
    refine' hp.subset fun x hx => _
    rw [Set.mem_setOf_eq] at hx
    exact hx.left
  have hle' := Nat.sub_pos_of_lt hle
  specialize hk hp'' (k.le_succ.trans hle)
  rw [Nat.sub_succ', ← hk]
  convert_to(Finset.erase hp''.to_finset (nth p k)).card = _
  · congr
    ext a
    simp only [Set.Finite.mem_toFinset, Ne.def, Set.mem_setOf_eq, Finset.mem_erase]
    refine'
      ⟨fun ⟨hp, hlt⟩ =>
        ⟨(hlt _ (lt_add_one k)).ne', ⟨hp, fun n hn => hlt n (hn.trans_le k.le_succ)⟩⟩, _⟩
    rintro ⟨hak : _ ≠ _, hp, hlt⟩
    refine' ⟨hp, fun n hn => _⟩
    rw [lt_succ_iff] at hn
    obtain hnk | rfl := hn.lt_or_eq
    · exact hlt _ hnk
    · refine' lt_of_le_of_ne _ (Ne.symm hak)
      rw [nth]
      apply Nat.infₛ_le
      simpa [hp] using hlt
  apply Finset.card_erase_of_mem
  rw [nth, Set.Finite.mem_toFinset]
  apply cinfₛ_mem
  rwa [← hp''.to_finset_nonempty, ← Finset.card_pos, hk]
#align nat.nth_set_card_aux Nat.nth_set_card_aux

theorem nth_set_card {n : ℕ} (hp : (setOf p).Finite)
    (hp' : { i : ℕ | p i ∧ ∀ k < n, nth p k < i }.Finite) :
    hp'.toFinset.card = hp.toFinset.card - n :=
  by
  obtain hn | hn := le_or_lt n hp.to_finset.card
  · exact nth_set_card_aux p hp _ hn
  rw [Nat.sub_eq_zero_of_le hn.le]
  simp only [Finset.card_eq_zero, Set.Finite.toFinset_eq_empty, ← Set.subset_empty_iff]
  convert_to _ ⊆ { i : ℕ | p i ∧ ∀ k : ℕ, k < hp.to_finset.card → nth p k < i }
  · symm
    rw [← Set.Finite.toFinset_eq_empty, ← Finset.card_eq_zero, ← Nat.sub_self hp.to_finset.card]
    · apply nth_set_card_aux p hp _ le_rfl
    · exact hp.subset fun x hx => hx.1
  exact fun x hx => ⟨hx.1, fun k hk => hx.2 _ (hk.trans hn)⟩
#align nat.nth_set_card Nat.nth_set_card

theorem nth_set_nonempty_of_lt_card {n : ℕ} (hp : (setOf p).Finite) (hlt : n < hp.toFinset.card) :
    { i : ℕ | p i ∧ ∀ k < n, nth p k < i }.Nonempty :=
  by
  have hp' : { i : ℕ | p i ∧ ∀ k : ℕ, k < n → nth p k < i }.Finite := hp.subset fun x hx => hx.1
  rw [← hp'.to_finset_nonempty, ← Finset.card_pos, nth_set_card p hp]
  exact Nat.sub_pos_of_lt hlt
#align nat.nth_set_nonempty_of_lt_card Nat.nth_set_nonempty_of_lt_card

theorem nth_mem_of_lt_card_finite_aux (n : ℕ) (hp : (setOf p).Finite) (hlt : n < hp.toFinset.card) :
    nth p n ∈ { i : ℕ | p i ∧ ∀ k < n, nth p k < i } :=
  by
  rw [nth]
  apply cinfₛ_mem
  exact nth_set_nonempty_of_lt_card _ _ hlt
#align nat.nth_mem_of_lt_card_finite_aux Nat.nth_mem_of_lt_card_finite_aux

theorem nth_mem_of_lt_card_finite {n : ℕ} (hp : (setOf p).Finite) (hlt : n < hp.toFinset.card) :
    p (nth p n) :=
  (nth_mem_of_lt_card_finite_aux p n hp hlt).1
#align nat.nth_mem_of_lt_card_finite Nat.nth_mem_of_lt_card_finite

theorem nth_strict_mono_of_finite {m n : ℕ} (hp : (setOf p).Finite) (hlt : n < hp.toFinset.card)
    (hmn : m < n) : nth p m < nth p n :=
  (nth_mem_of_lt_card_finite_aux p _ hp hlt).2 _ hmn
#align nat.nth_strict_mono_of_finite Nat.nth_strict_mono_of_finite

theorem nth_mem_of_infinite_aux (hp : (setOf p).Infinite) (n : ℕ) :
    nth p n ∈ { i : ℕ | p i ∧ ∀ k < n, nth p k < i } :=
  by
  rw [nth]
  apply cinfₛ_mem
  let s : Set ℕ := ⋃ k < n, { i : ℕ | nth p k ≥ i }
  convert_to(setOf p \ s).Nonempty
  · ext i
    simp
  refine' (hp.diff <| (Set.finite_lt_nat _).bunionᵢ _).Nonempty
  exact fun k h => Set.finite_le_nat _
#align nat.nth_mem_of_infinite_aux Nat.nth_mem_of_infinite_aux

theorem nth_mem_of_infinite (hp : (setOf p).Infinite) (n : ℕ) : p (nth p n) :=
  (nth_mem_of_infinite_aux p hp n).1
#align nat.nth_mem_of_infinite Nat.nth_mem_of_infinite

theorem nth_strictMono (hp : (setOf p).Infinite) : StrictMono (nth p) := fun a b =>
  (nth_mem_of_infinite_aux p hp b).2 _
#align nat.nth_strict_mono Nat.nth_strictMono

theorem nth_injective_of_infinite (hp : (setOf p).Infinite) : Function.Injective (nth p) :=
  by
  intro m n h
  wlog h' : m ≤ n
  · exact (this p hp h.symm (le_of_not_le h')).symm
  rw [le_iff_lt_or_eq] at h'
  obtain h' | rfl := h'
  · simpa [h] using nth_strict_mono p hp h'
  · rfl
#align nat.nth_injective_of_infinite Nat.nth_injective_of_infinite

theorem nth_monotone (hp : (setOf p).Infinite) : Monotone (nth p) :=
  (nth_strictMono p hp).Monotone
#align nat.nth_monotone Nat.nth_monotone

theorem nth_mono_of_finite {a b : ℕ} (hp : (setOf p).Finite) (hb : b < hp.toFinset.card)
    (hab : a ≤ b) : nth p a ≤ nth p b :=
  by
  obtain rfl | h := hab.eq_or_lt
  · exact le_rfl
  · exact (nth_strict_mono_of_finite p hp hb h).le
#align nat.nth_mono_of_finite Nat.nth_mono_of_finite

theorem le_nth_of_lt_nth_succ_finite {k a : ℕ} (hp : (setOf p).Finite)
    (hlt : k.succ < hp.toFinset.card) (h : a < nth p k.succ) (ha : p a) : a ≤ nth p k :=
  by
  by_contra' hak
  refine' h.not_le _
  rw [nth]
  apply Nat.infₛ_le
  refine' ⟨ha, fun n hn => lt_of_le_of_lt _ hak⟩
  exact nth_mono_of_finite p hp (k.le_succ.trans_lt hlt) (le_of_lt_succ hn)
#align nat.le_nth_of_lt_nth_succ_finite Nat.le_nth_of_lt_nth_succ_finite

theorem le_nth_of_lt_nth_succ_infinite {k a : ℕ} (hp : (setOf p).Infinite) (h : a < nth p k.succ)
    (ha : p a) : a ≤ nth p k := by
  by_contra' hak
  refine' h.not_le _
  rw [nth]
  apply Nat.infₛ_le
  exact ⟨ha, fun n hn => (nth_monotone p hp (le_of_lt_succ hn)).trans_lt hak⟩
#align nat.le_nth_of_lt_nth_succ_infinite Nat.le_nth_of_lt_nth_succ_infinite

section Count

variable [DecidablePred p]

@[simp]
theorem count_nth_zero : count p (nth p 0) = 0 :=
  by
  rw [count_eq_card_filter_range, Finset.card_eq_zero, nth_zero]
  ext a
  simp_rw [not_mem_empty, mem_filter, mem_range, iff_false_iff]
  rintro ⟨ha, hp⟩
  exact ha.not_le (Nat.infₛ_le hp)
#align nat.count_nth_zero Nat.count_nth_zero

theorem filter_range_nth_eq_insert_of_finite (hp : (setOf p).Finite) {k : ℕ}
    (hlt : k.succ < hp.toFinset.card) :
    Finset.filter p (Finset.range (nth p k.succ)) =
      insert (nth p k) (Finset.filter p (Finset.range (nth p k))) :=
  by
  ext a
  simp_rw [mem_insert, mem_filter, mem_range]
  constructor
  · rintro ⟨ha, hpa⟩
    refine' or_iff_not_imp_left.mpr fun h => ⟨lt_of_le_of_ne _ h, hpa⟩
    exact le_nth_of_lt_nth_succ_finite p hp hlt ha hpa
  · rintro (ha | ⟨ha, hpa⟩)
    · rw [ha]
      refine' ⟨nth_strict_mono_of_finite p hp hlt (lt_add_one _), _⟩
      apply nth_mem_of_lt_card_finite p hp
      exact k.le_succ.trans_lt hlt
    refine' ⟨ha.trans _, hpa⟩
    exact nth_strict_mono_of_finite p hp hlt (lt_add_one _)
#align nat.filter_range_nth_eq_insert_of_finite Nat.filter_range_nth_eq_insert_of_finite

theorem count_nth_of_lt_card_finite {n : ℕ} (hp : (setOf p).Finite) (hlt : n < hp.toFinset.card) :
    count p (nth p n) = n := by
  induction' n with k hk
  · exact count_nth_zero _
  · rw [count_eq_card_filter_range, filter_range_nth_eq_insert_of_finite p hp hlt,
      Finset.card_insert_of_not_mem, ← count_eq_card_filter_range, hk (lt_of_succ_lt hlt)]
    simp
#align nat.count_nth_of_lt_card_finite Nat.count_nth_of_lt_card_finite

theorem filter_range_nth_eq_insert_of_infinite (hp : (setOf p).Infinite) (k : ℕ) :
    (Finset.range (nth p k.succ)).filterₓ p =
      insert (nth p k) ((Finset.range (nth p k)).filterₓ p) :=
  by
  ext a
  simp_rw [mem_insert, mem_filter, mem_range]
  constructor
  · rintro ⟨ha, hpa⟩
    rw [nth] at ha
    refine' or_iff_not_imp_left.mpr fun hne => ⟨(le_of_not_lt fun h => _).lt_of_ne hne, hpa⟩
    exact
      ha.not_le (Nat.infₛ_le ⟨hpa, fun b hb => (nth_monotone p hp (le_of_lt_succ hb)).trans_lt h⟩)
  · rintro (rfl | ⟨ha, hpa⟩)
    · exact ⟨nth_strict_mono p hp (lt_succ_self k), nth_mem_of_infinite p hp _⟩
    · exact ⟨ha.trans (nth_strict_mono p hp (lt_succ_self k)), hpa⟩
#align nat.filter_range_nth_eq_insert_of_infinite Nat.filter_range_nth_eq_insert_of_infinite

theorem count_nth_of_infinite (hp : (setOf p).Infinite) (n : ℕ) : count p (nth p n) = n :=
  by
  induction' n with k hk
  · exact count_nth_zero _
  · rw [count_eq_card_filter_range, filter_range_nth_eq_insert_of_infinite p hp,
      Finset.card_insert_of_not_mem, ← count_eq_card_filter_range, hk]
    simp
#align nat.count_nth_of_infinite Nat.count_nth_of_infinite

@[simp]
theorem nth_count {n : ℕ} (hpn : p n) : nth p (count p n) = n :=
  by
  obtain hp | hp := em (setOf p).Finite
  · refine' count_injective _ hpn _
    · apply nth_mem_of_lt_card_finite p hp
      exact count_lt_card hp hpn
    · exact count_nth_of_lt_card_finite _ _ (count_lt_card hp hpn)
  · apply count_injective (nth_mem_of_infinite _ hp _) hpn
    apply count_nth_of_infinite p hp
#align nat.nth_count Nat.nth_count

theorem nth_count_eq_infₛ {n : ℕ} : nth p (count p n) = infₛ { i : ℕ | p i ∧ n ≤ i } :=
  by
  rw [nth]
  congr
  ext a
  simp only [Set.mem_setOf_eq, and_congr_right_iff]
  intro hpa
  refine' ⟨fun h => _, fun hn k hk => lt_of_lt_of_le _ hn⟩
  · by_contra ha
    simp only [not_le] at ha
    have hn : nth p (count p a) < a := h _ (count_strict_mono hpa ha)
    rwa [nth_count p hpa, lt_self_iff_false] at hn
  · apply (count_monotone p).reflect_lt
    convert hk
    obtain hp | hp : (setOf p).Finite ∨ (setOf p).Infinite := em (setOf p).Finite
    · rw [count_nth_of_lt_card_finite _ hp]
      exact hk.trans ((count_monotone _ hn).trans_lt (count_lt_card hp hpa))
    · apply count_nth_of_infinite p hp
#align nat.nth_count_eq_Inf Nat.nth_count_eq_infₛ

theorem nth_count_le (hp : (setOf p).Infinite) (n : ℕ) : n ≤ nth p (count p n) :=
  by
  rw [nth_count_eq_Inf]
  suffices h : Inf { i : ℕ | p i ∧ n ≤ i } ∈ { i : ℕ | p i ∧ n ≤ i }
  · exact h.2
  apply cinfₛ_mem
  obtain ⟨m, hp, hn⟩ := hp.exists_nat_lt n
  exact ⟨m, hp, hn.le⟩
#align nat.nth_count_le Nat.nth_count_le

theorem count_nth_gc (hp : (setOf p).Infinite) : GaloisConnection (count p) (nth p) :=
  by
  rintro x y
  rw [nth, le_cinfₛ_iff ⟨0, fun _ _ => Nat.zero_le _⟩ ⟨nth p y, nth_mem_of_infinite_aux p hp y⟩]
  dsimp
  refine' ⟨_, fun h => _⟩
  · rintro hy n ⟨hn, h⟩
    obtain hy' | rfl := hy.lt_or_eq
    · exact (nth_count_le p hp x).trans (h (count p x) hy').le
    · specialize h (count p n)
      replace hn : nth p (count p n) = n := nth_count _ hn
      replace h : count p x ≤ count p n := by rwa [hn, lt_self_iff_false, imp_false, not_lt] at h
      refine' (nth_count_le p hp x).trans _
      rw [← hn]
      exact nth_monotone p hp h
  · rw [← count_nth_of_infinite p hp y]
    exact
      count_monotone _
        (h (nth p y) ⟨nth_mem_of_infinite p hp y, fun k hk => nth_strict_mono p hp hk⟩)
#align nat.count_nth_gc Nat.count_nth_gc

theorem count_le_iff_le_nth (hp : (setOf p).Infinite) {a b : ℕ} : count p a ≤ b ↔ a ≤ nth p b :=
  count_nth_gc p hp _ _
#align nat.count_le_iff_le_nth Nat.count_le_iff_le_nth

theorem lt_nth_iff_count_lt (hp : (setOf p).Infinite) {a b : ℕ} : a < count p b ↔ nth p a < b :=
  lt_iff_lt_of_le_iff_le <| count_le_iff_le_nth p hp
#align nat.lt_nth_iff_count_lt Nat.lt_nth_iff_count_lt

theorem nth_lt_of_lt_count (n k : ℕ) (h : k < count p n) : nth p k < n :=
  by
  obtain hp | hp := em (setOf p).Finite
  · refine' (count_monotone p).reflect_lt _
    rwa [count_nth_of_lt_card_finite p hp]
    refine' h.trans_le _
    rw [count_eq_card_filter_range]
    exact Finset.card_le_of_subset fun x hx => hp.mem_to_finset.2 (mem_filter.1 hx).2
  · rwa [← lt_nth_iff_count_lt _ hp]
#align nat.nth_lt_of_lt_count Nat.nth_lt_of_lt_count

theorem le_nth_of_count_le (n k : ℕ) (h : n ≤ nth p k) : count p n ≤ k :=
  by
  by_contra hc
  apply not_lt.mpr h
  apply nth_lt_of_lt_count
  simpa using hc
#align nat.le_nth_of_count_le Nat.le_nth_of_count_le

end Count

theorem nth_zero_of_nth_zero (h₀ : ¬p 0) {a b : ℕ} (hab : a ≤ b) (ha : nth p a = 0) : nth p b = 0 :=
  by
  rw [nth, Inf_eq_zero] at ha⊢
  cases ha
  · exact (h₀ ha.1).elim
  · refine' Or.inr (Set.eq_empty_of_subset_empty fun x hx => _)
    rw [← ha]
    exact ⟨hx.1, fun k hk => hx.2 k <| hk.trans_le hab⟩
#align nat.nth_zero_of_nth_zero Nat.nth_zero_of_nth_zero

/-- When `p` is true infinitely often, `nth` agrees with `nat.subtype.order_iso_of_nat`. -/
theorem nth_eq_orderIsoOfNat (i : Infinite (setOf p)) (n : ℕ) :
    nth p n = Nat.Subtype.orderIsoOfNat (setOf p) n := by
  classical
    have hi := set.infinite_coe_iff.mp i
    induction' n with k hk <;>
      simp only [subtype.order_iso_of_nat_apply, subtype.of_nat, nat_zero_eq_zero]
    · rw [Nat.Subtype.coe_bot, nth_zero_of_exists]
    · simp only [Nat.Subtype.succ, Set.mem_setOf_eq, Subtype.coe_mk, Subtype.val_eq_coe]
      rw [subtype.order_iso_of_nat_apply] at hk
      set b := nth p k.succ - nth p k - 1 with hb
      replace hb : p (↑(subtype.of_nat (setOf p) k) + b + 1)
      · rw [hb, ← hk, tsub_right_comm]
        have hn11 : nth p k.succ - 1 + 1 = nth p k.succ :=
          by
          rw [tsub_add_cancel_iff_le]
          exact succ_le_of_lt (pos_of_gt (nth_strict_mono p hi (lt_add_one k)))
        rw [add_tsub_cancel_of_le]
        · rw [hn11]
          apply nth_mem_of_infinite p hi
        · rw [← lt_succ_iff, ← Nat.add_one, hn11]
          apply nth_strict_mono p hi
          exact lt_add_one k
      have H : ∃ n : ℕ, p (↑(subtype.of_nat (setOf p) k) + n + 1) := ⟨b, hb⟩
      set t := Nat.find H with ht
      obtain ⟨hp, hmin⟩ := (Nat.find_eq_iff _).mp ht
      rw [← ht, ← hk] at hp hmin⊢
      rw [nth, Inf_def ⟨_, nth_mem_of_infinite_aux p hi k.succ⟩, Nat.find_eq_iff]
      refine' ⟨⟨by convert hp, fun r hr => _⟩, fun n hn => _⟩
      · rw [lt_succ_iff] at hr⊢
        exact (nth_monotone p hi hr).trans (by simp)
      simp only [exists_prop, not_and, not_lt, Set.mem_setOf_eq, not_forall]
      refine' fun hpn => ⟨k, lt_add_one k, _⟩
      by_contra' hlt
      replace hn : n - nth p k - 1 < t
      · rw [tsub_lt_iff_left]
        · rw [tsub_lt_iff_left hlt.le]
          convert hn using 1
          ac_rfl
        exact le_tsub_of_add_le_left (succ_le_of_lt hlt)
      refine' hmin (n - nth p k - 1) hn _
      convert hpn
      have hn11 : n - 1 + 1 = n := Nat.sub_add_cancel (pos_of_gt hlt)
      rwa [tsub_right_comm, add_tsub_cancel_of_le]
      rwa [← hn11, lt_succ_iff] at hlt
#align nat.nth_eq_order_iso_of_nat Nat.nth_eq_orderIsoOfNat

end Nat


-- vim: ts=2 sw=0 sts=-1 et ai tw=70

import .le
import ..logic

namespace hidden

namespace mynat

def lt (m n: mynat) := ¬n ≤ m
instance: has_lt mynat := ⟨lt⟩

instance decidable_lt: ∀ m n: mynat, decidable (m < n) :=
(λ m n, not.decidable)

variables {m n p k : mynat}

theorem lt_nrefl: ¬m < m :=
(λ h, h le_refl)

theorem lt_succ_cancel: succ m < succ n → m < n :=
mp_to_contrapositive succ_le_succ

theorem lt_cancel (k: mynat): m + k < n + k → m < n :=
mp_to_contrapositive (le_add k)

theorem lt_cancel_strong: m + k < n → m < n :=
mp_to_contrapositive le_add_rhs

theorem lt_add_rhs: m < n → m < n + k :=
mp_to_contrapositive (le_cancel_strong k)

theorem nzero_iff_zero_lt: m ≠ 0 ↔ 0 < m :=
iff_to_contrapositive le_zero_iff.symm

theorem zero_lt_iff_succ: 0 < m ↔ ∃ n, m = succ n :=
by rw ←nzero_iff_zero_lt; from nzero_iff_succ

theorem lt_to_add_succ: m < m + succ n :=
begin
  assume hmmsn,
  cases hmmsn with d hd,
  rw [←add_zero m, add_assoc m _ _, add_assoc m _ _] at hd,
  have hd' := add_cancel hd,
  simp at hd',
  from succ_ne_zero hd'.symm,
end

theorem lt_nzero: ¬m < 0 := (λ h, h zero_le)

theorem zero_lt_succ: 0 < succ m := succ_nle_zero

theorem lt_add: m < n → m + k < n + k :=
mp_to_contrapositive le_cancel

theorem succ_lt_succ: m < n → succ m < succ n := @lt_add _ _ 1

theorem lt_impl_le: m < n → m ≤ n :=
begin
  assume hmn,
  cases (le_total_order m n) with hmltn hnm,
  from hmltn,
  exfalso, from hmn hnm,
end

theorem lt_impl_neq : m < n → m ≠ n :=
begin
  assume h heq,
  apply @lt_nrefl n,
  rwa heq at h,
end

-- pair of transformation theorems. Can be useful in a pinch
theorem le_iff_lt_succ: m ≤ n ↔ m < succ n :=
begin
  split, {
    assume hmn,
    cases hmn with d hd,
    rw hd,
    assume hmsd,
    cases hmsd with d' hd',
    rw [succ_add, add_assoc, ←add_succ,
        ←add_zero m, add_assoc] at hd',
    have hzsucc := add_cancel hd',
    rw zero_add at hzsucc,
    from succ_ne_zero hzsucc.symm,
  }, {
    assume hmsn,
    -- this total ordering theorem is crazy powerful. It feels like
    -- you need classical logic until you remember it exists
    cases (le_total_order m n) with hmn hnm,
    from hmn,
    cases hnm with d hd,
    cases d, {
      rw [hd, zz, add_zero],
    }, {
      have hsnm: succ n ≤ m,
      existsi d,
      rw [hd, add_succ, succ_add],
      exfalso, from hmsn hsnm,
    },
  },
end

theorem lt_iff_succ_le: m < n ↔ succ m ≤ n :=
begin
  split, {
    cases n, {
      assume h,
      exfalso, from lt_nzero h,
    }, {
      assume h,
      apply succ_le_succ, -- /o/
      rw le_iff_lt_succ, assumption,
    },
  }, {
    cases n, {
      assume h,
      cases h with d hd,
      exfalso, from succ_ne_zero (add_integral hd.symm),
    }, {
      assume h,
      rw ←le_iff_lt_succ,
      from le_succ_cancel h,
    },
  },
end

theorem zero_lt_one: (0 : mynat) < (1 : mynat) :=
by rw [←one_eq_succ_zero, ←le_iff_lt_succ]

-- somehow this feels like it's not using le_iff_lt_succ enough
theorem le_iff_lt_or_eq: m ≤ n ↔ m < n ∨ m = n :=
begin
  split, {
    assume hmn,
    cases hmn with d hd,
    cases d, {
      simp at hd,
      right, rw hd,
    }, {
      left,
      rw hd,
      from lt_to_add_succ,
    },
  }, {
    assume hmnmn,
    cases hmnmn, {
     from lt_impl_le hmnmn,
    }, {
      rw hmnmn,
    },
  },
end

theorem lt_iff_le_and_neq: m < n ↔ m ≤ n ∧ m ≠ n :=
begin
  split, {
    assume hmn,
    apply and.intro (lt_impl_le hmn),
    assume h,
    rw h at hmn,
    from lt_nrefl hmn,
  }, {
    assume h,
    cases h with hmn hneq,
    cases hmn with d hd,
    cases d, {
      exfalso,
      from hneq hd.symm,
    }, {
      rw lt_iff_succ_le,
      rw [hd, add_succ, ←succ_add],
      from le_to_add,
    },
  },
end

-- surely this is a library function somewhere
theorem lt_dne: ¬m < n → n ≤ m :=
begin
  by_cases (n ≤ m), {
    from (λ _, h),
  }, {
    assume h2,
    contradiction,
  },
end

theorem lt_strict: ¬(m < n ∧ n < m) :=
begin
  assume hmnnm,
  cases hmnnm with hmnnm_left hmnnm_right,
  from hmnnm_left (lt_impl_le hmnnm_right),
end

theorem lt_trichotomy: m = n ∨ m < n ∨ n < m :=
begin
  cases (le_total_order m n), {
    rw le_iff_lt_or_eq at h,
    cases h, {
      right, left, assumption,
    }, {
      left, assumption,
    },
  }, {
    rw le_iff_lt_or_eq at h,
    cases h, {
      right, right, assumption,
    }, {
      left, symmetry, assumption,
    },
  },
end

@[trans]
theorem lt_trans: m < n → n < k → m < k :=
begin
  assume hmn hnk hkm,
  cases hkm with d hd,
  cases d,
  simp at hd,
  rw hd at hmn,
  from lt_strict (and.intro hnk hmn),
  rw hd at hmn,
  have hkln: k ≤ n
  := le_cancel_strong (succ d) (lt_impl_le hmn),
  from hnk hkln,
end

theorem lt_comb {a b : mynat}: m < n → a < b → m + a < n + b :=
begin
  assume hmn hab,
  have h1: m + a < n + a, {
    apply lt_add,
    assumption,
  },
  have h2: n + a < n + b, {
    rw [add_comm n, add_comm n],
    apply lt_add,
    assumption,
  },
  from lt_trans h1 h2,
end

theorem lt_mul: k ≠ 0 → m < n → k * m < k * n :=
begin
  assume hknz hmln hknkm,
  cases hknkm with d hd,
  cases n, {
    from lt_nzero hmln,
  }, {
    rw ←le_iff_lt_succ at hmln,
    cases hmln with d' hd',
    rw [hd', mul_succ, mul_add] at hd,
    have : k + (k * m + k * d') + d = k * m + (k + k * d' + d),
      ac_refl,
    rw this at hd, clear this,
    have hcancel := add_cancel_to_zero hd,
    rw add_assoc at hcancel,
    from hknz (add_integral hcancel),
  },
end

theorem le_square: m ≤ n → m * m ≤ n * n :=
begin
  assume hle,
  have h₁ := le_mul n hle,
  have h₂ := le_mul m hle,
  rw mul_comm at h₁,
  from le_trans h₂ h₁,
end

theorem le_sqrt: m * m ≤ n * n → m ≤ n :=
begin
  assume hm2n2,
  cases (le_total_order m n), {
    assumption,
  }, {
    cases h with d hd,
    cases d, {
      simp [hd],
    }, {
      cases hm2n2 with d' hd',
      rw [hd] at hd',
      repeat { rw mul_succ at hd' <|>
               rw succ_mul  at hd' <|>
               rw mul_add  at hd' <|>
               rw add_mul  at hd' },
      have : n * n + (d * n + n) + (n + d.succ + (n * d + (d * d + d))) + d' =
             n * n + (d.succ + (d * n + n + n + n * d + d * d + d + d')),
        ac_refl,
      rw this at hd', clear this,
      have := add_cancel_to_zero hd',
      exfalso, from succ_ne_zero (add_integral this),
    },
  },
end

theorem lt_sqrt: m * m < n * n → m < n :=
begin
  assume hlt hnlem,
  have := le_square hnlem,
  contradiction,
end

theorem lt_le_chain (n : mynat): m < n → n ≤ k → m < k :=
begin
  assume hmn hnk,
  rw lt_iff_succ_le at hmn,
  rw lt_iff_succ_le,
  transitivity n,
    assumption,
  assumption,
end

theorem le_lt_chain (n : mynat): m ≤ n → n < k → m < k :=
begin
  assume hmn hnk,
  rw lt_iff_succ_le at hnk,
  rw le_iff_lt_succ at hmn,
  apply lt_le_chain (succ n),
    assumption,
  assumption,
end

theorem lt_comb_mul {a b : mynat}: m < n → a < b → m * a < n * b :=
begin
  assume hmn hab,
  rw lt_iff_succ_le at *,
  apply le_trans _ (le_mul_comb hmn hab),
  rw [mul_succ, succ_add, succ_mul, ←add_one_succ, ←add_one_succ],
  existsi m + a,
  ac_refl,
end

end mynat

end hidden


/-
Copyright (c) 2022 Violeta Hernández Palacios. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Violeta Hernández Palacios
-/

import set_theory.ordinal.arithmetic

/-!
# Natural operations on ordinals

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

The goal of this file is to define natural addition and multiplication on ordinals, also known as
the Hessenberg sum and product, and provide a basic API. The natural addition of two ordinals
`a ♯ b` is recursively defined as the least ordinal greater than `a' ♯ b` and `a ♯ b'` for `a' < a`
and `b' < b`. The natural multiplication `a ⨳ b` is likewise recursively defined as the least
ordinal such that `a ⨳ b ♯ a' ⨳ b'` is greater than `a' ⨳ b ♯ a ⨳ b'` for any `a' < a` and
`b' < b`.

These operations form a rich algebraic structure: they're commutative, associative, preserve order,
have the usual `0` and `1` from ordinals, and distribute over one another.

Moreover, these operations are the addition and multiplication of ordinals when viewed as
combinatorial `game`s. This makes them particularly useful for game theory.

Finally, both operations admit simple, intuitive descriptions in terms of the Cantor normal form.
The natural addition of two ordinals corresponds to adding their Cantor normal forms as if they were
polynomials in `ω`. Likewise, their natural multiplication corresponds to multiplying the Cantor
normal forms as polynomials.

# Implementation notes

Given the rich algebraic structure of these two operations, we choose to create a type synonym
`nat_ordinal`, where we provide the appropriate instances. However, to avoid casting back and forth
between both types, we attempt to prove and state most results on `ordinal`.

# Todo

- Define natural multiplication and provide a basic API.
- Prove the characterizations of natural addition and multiplication in terms of the Cantor normal
  form.
-/

universes u v

open function order

noncomputable theory

/-- A type synonym for ordinals with natural addition and multiplication. -/
@[derive [has_zero, inhabited, has_one, linear_order, succ_order, has_well_founded]]
def nat_ordinal : Type* := ordinal

/-- The identity function between `ordinal` and `nat_ordinal`. -/
@[pattern] def ordinal.to_nat_ordinal : ordinal ≃o nat_ordinal := order_iso.refl _

/-- The identity function between `nat_ordinal` and `ordinal`. -/
@[pattern] def nat_ordinal.to_ordinal : nat_ordinal ≃o ordinal := order_iso.refl _

open ordinal

namespace nat_ordinal

variables {a b c : nat_ordinal.{u}}

@[simp] theorem to_ordinal_symm_eq : nat_ordinal.to_ordinal.symm = ordinal.to_nat_ordinal := rfl
@[simp] theorem to_ordinal_to_nat_ordinal (a : nat_ordinal) : a.to_ordinal.to_nat_ordinal = a := rfl

theorem lt_wf : @well_founded nat_ordinal (<) := ordinal.lt_wf
instance : well_founded_lt nat_ordinal := ordinal.well_founded_lt
instance : is_well_order nat_ordinal (<) := ordinal.has_lt.lt.is_well_order

@[simp] theorem to_ordinal_zero : to_ordinal 0 = 0 := rfl
@[simp] theorem to_ordinal_one : to_ordinal 1 = 1 := rfl

@[simp] theorem to_ordinal_eq_zero (a) : to_ordinal a = 0 ↔ a = 0 := iff.rfl
@[simp] theorem to_ordinal_eq_one (a) : to_ordinal a = 1 ↔ a = 1 := iff.rfl

@[simp] theorem to_ordinal_max : (max a b).to_ordinal = max a.to_ordinal b.to_ordinal := rfl
@[simp] theorem to_ordinal_min : (min a b).to_ordinal = min a.to_ordinal b.to_ordinal := rfl

theorem succ_def (a : nat_ordinal) : succ a = (a.to_ordinal + 1).to_nat_ordinal := rfl

/-- A recursor for `nat_ordinal`. Use as `induction x using nat_ordinal.rec`. -/
protected def rec {β : nat_ordinal → Sort*} (h : Π a, β (to_nat_ordinal a)) : Π a, β a :=
λ a, h a.to_ordinal

/-- `ordinal.induction` but for `nat_ordinal`. -/
theorem induction {p : nat_ordinal → Prop} : ∀ i (h : ∀ j, (∀ k, k < j → p k) → p j), p i :=
ordinal.induction

end nat_ordinal

namespace ordinal

variables {a b c : ordinal.{u}}

@[simp] theorem to_nat_ordinal_symm_eq : to_nat_ordinal.symm = nat_ordinal.to_ordinal := rfl
@[simp] theorem to_nat_ordinal_to_ordinal (a : ordinal) : a.to_nat_ordinal.to_ordinal = a := rfl

@[simp] theorem to_nat_ordinal_zero : to_nat_ordinal 0 = 0 := rfl
@[simp] theorem to_nat_ordinal_one : to_nat_ordinal 1 = 1 := rfl

@[simp] theorem to_nat_ordinal_eq_zero (a) : to_nat_ordinal a = 0 ↔ a = 0 := iff.rfl
@[simp] theorem to_nat_ordinal_eq_one (a) : to_nat_ordinal a = 1 ↔ a = 1 := iff.rfl

@[simp] theorem to_nat_ordinal_max :
  to_nat_ordinal (max a b) = max a.to_nat_ordinal b.to_nat_ordinal := rfl
@[simp] theorem to_nat_ordinal_min :
  (linear_order.min a b).to_nat_ordinal = linear_order.min a.to_nat_ordinal b.to_nat_ordinal := rfl

/-- Natural addition on ordinals `a ♯ b`, also known as the Hessenberg sum, is recursively defined
as the least ordinal greater than `a' ♯ b` and `a ♯ b'` for all `a' < a` and `b' < b`. In contrast
to normal ordinal addition, it is commutative.

Natural addition can equivalently be characterized as the ordinal resulting from adding up
corresponding coefficients in the Cantor normal forms of `a` and `b`. -/
noncomputable def nadd : ordinal → ordinal → ordinal
| a b := max
  (blsub.{u u} a $ λ a' h, nadd a' b)
  (blsub.{u u} b $ λ b' h, nadd a b')
using_well_founded { dec_tac := `[solve_by_elim [psigma.lex.left, psigma.lex.right]] }

localized "infix (name := ordinal.nadd) ` ♯ `:65 := ordinal.nadd" in natural_ops

theorem nadd_def (a b : ordinal) : a ♯ b = max
  (blsub.{u u} a $ λ a' h, a' ♯ b)
  (blsub.{u u} b $ λ b' h, a ♯ b') :=
by rw nadd

theorem lt_nadd_iff : a < b ♯ c ↔ (∃ b' < b, a ≤ b' ♯ c) ∨ ∃ c' < c, a ≤ b ♯ c' :=
by { rw nadd_def, simp [lt_blsub_iff] }

theorem nadd_le_iff : b ♯ c ≤ a ↔ (∀ b' < b, b' ♯ c < a) ∧ ∀ c' < c, b ♯ c' < a :=
by { rw nadd_def, simp [blsub_le_iff] }

theorem nadd_lt_nadd_left (h : b < c) (a) : a ♯ b < a ♯ c :=
lt_nadd_iff.2 (or.inr ⟨b, h, le_rfl⟩)

theorem nadd_lt_nadd_right (h : b < c) (a) : b ♯ a < c ♯ a :=
lt_nadd_iff.2 (or.inl ⟨b, h, le_rfl⟩)

theorem nadd_le_nadd_left (h : b ≤ c) (a) : a ♯ b ≤ a ♯ c :=
begin
  rcases lt_or_eq_of_le h with h | rfl,
  { exact (nadd_lt_nadd_left h a).le },
  { exact le_rfl }
end

theorem nadd_le_nadd_right (h : b ≤ c) (a) : b ♯ a ≤ c ♯ a :=
begin
  rcases lt_or_eq_of_le h with h | rfl,
  { exact (nadd_lt_nadd_right h a).le },
  { exact le_rfl }
end

variables (a b)

theorem nadd_comm : ∀ a b, a ♯ b = b ♯ a
| a b := begin
  rw [nadd_def, nadd_def, max_comm],
  congr; ext c hc;
  apply nadd_comm
end
using_well_founded { dec_tac := `[solve_by_elim [psigma.lex.left, psigma.lex.right]] }

theorem nadd_assoc : ∀ a b c, a ♯ b ♯ c = a ♯ (b ♯ c)
| a b c := begin
  rw [nadd_def a (b ♯ c), nadd_def, blsub_nadd_of_mono, blsub_nadd_of_mono, max_assoc],
  { congr; ext d hd;
    apply nadd_assoc },
  { exact λ i j _ _ h, nadd_le_nadd_left h a },
  { exact λ i j _ _ h, nadd_le_nadd_right h c }
end
using_well_founded { dec_tac := `[solve_by_elim [psigma.lex.left, psigma.lex.right]] }

@[simp] theorem nadd_zero : a ♯ 0 = a :=
begin
  induction a using ordinal.induction with a IH,
  rw [nadd_def, blsub_zero, max_zero_right],
  convert blsub_id a,
  ext b hb,
  exact IH _ hb
end

@[simp] theorem zero_nadd : 0 ♯ a = a :=
by rw [nadd_comm, nadd_zero]

@[simp] theorem nadd_one : a ♯ 1 = succ a :=
begin
  induction a using ordinal.induction with a IH,
  rw [nadd_def, blsub_one, nadd_zero, max_eq_right_iff, blsub_le_iff],
  intros i hi,
  rwa [IH i hi, succ_lt_succ_iff]
end

@[simp] theorem one_nadd : 1 ♯ a = succ a :=
by rw [nadd_comm, nadd_one]

theorem nadd_succ : a ♯ succ b = succ (a ♯ b) :=
by rw [←nadd_one (a ♯ b), nadd_assoc, nadd_one]

theorem succ_nadd : succ a ♯ b = succ (a ♯ b) :=
by rw [←one_nadd (a ♯ b), ←nadd_assoc, one_nadd]

@[simp] theorem nadd_nat (n : ℕ) : a ♯ n = a + n :=
begin
  induction n with n hn,
  { simp },
  { rw [nat.cast_succ, add_one_eq_succ, nadd_succ, add_succ, hn] }
end

@[simp] theorem nat_nadd (n : ℕ) : ↑n ♯ a = a + n :=
by rw [nadd_comm, nadd_nat]

theorem add_le_nadd : a + b ≤ a ♯ b :=
begin
  apply b.limit_rec_on,
  { simp },
  { intros c h,
    rwa [add_succ, nadd_succ, succ_le_succ_iff] },
  { intros c hc H,
    rw [←is_normal.blsub_eq.{u u} (add_is_normal a) hc, blsub_le_iff],
    exact λ i hi, (H i hi).trans_lt (nadd_lt_nadd_left hi a) }
end

end ordinal

open ordinal

namespace nat_ordinal

instance : has_add nat_ordinal := ⟨nadd⟩

instance add_covariant_class_lt :
  covariant_class nat_ordinal.{u} nat_ordinal.{u} (+) (<) :=
⟨λ a b c h, nadd_lt_nadd_left h a⟩

instance add_covariant_class_le :
  covariant_class nat_ordinal.{u} nat_ordinal.{u} (+) (≤) :=
⟨λ a b c h, nadd_le_nadd_left h a⟩

instance add_contravariant_class_le :
  contravariant_class nat_ordinal.{u} nat_ordinal.{u} (+) (≤) :=
⟨λ a b c h, by { by_contra' h', exact h.not_lt (add_lt_add_left h' a) }⟩

instance : ordered_cancel_add_comm_monoid nat_ordinal :=
{ add := (+),
  add_assoc := nadd_assoc,
  add_le_add_left := λ a b, add_le_add_left,
  le_of_add_le_add_left := λ a b c, le_of_add_le_add_left,
  zero := 0,
  zero_add := zero_nadd,
  add_zero := nadd_zero,
  add_comm := nadd_comm,
  ..nat_ordinal.linear_order }

instance : add_monoid_with_one nat_ordinal := add_monoid_with_one.unary

@[simp] theorem add_one_eq_succ : ∀ a : nat_ordinal, a + 1 = succ a := nadd_one

@[simp] theorem to_ordinal_cast_nat (n : ℕ) : to_ordinal n = n :=
begin
  induction n with n hn,
  { refl },
  { change nadd (to_ordinal n) 1 = n + 1,
    rw hn,
    apply nadd_one }
end

end nat_ordinal

open nat_ordinal

open_locale natural_ops

namespace ordinal

@[simp] theorem to_nat_ordinal_cast_nat (n : ℕ) : to_nat_ordinal n = n :=
by { rw ←to_ordinal_cast_nat n, refl }

theorem lt_of_nadd_lt_nadd_left : ∀ {a b c}, a ♯ b < a ♯ c → b < c :=
@lt_of_add_lt_add_left nat_ordinal _ _ _
theorem lt_of_nadd_lt_nadd_right : ∀ {a b c}, b ♯ a < c ♯ a → b < c :=
@_root_.lt_of_add_lt_add_right nat_ordinal _ _ _
theorem le_of_nadd_le_nadd_left : ∀ {a b c}, a ♯ b ≤ a ♯ c → b ≤ c :=
@le_of_add_le_add_left nat_ordinal _ _ _
theorem le_of_nadd_le_nadd_right : ∀ {a b c}, b ♯ a ≤ c ♯ a → b ≤ c :=
@le_of_add_le_add_right nat_ordinal _ _ _

theorem nadd_lt_nadd_iff_left : ∀ a {b c}, a ♯ b < a ♯ c ↔ b < c :=
@add_lt_add_iff_left nat_ordinal _ _ _ _
theorem nadd_lt_nadd_iff_right : ∀ a {b c}, b ♯ a < c ♯ a ↔ b < c :=
@add_lt_add_iff_right nat_ordinal _ _ _ _
theorem nadd_le_nadd_iff_left : ∀ a {b c}, a ♯ b ≤ a ♯ c ↔ b ≤ c :=
@add_le_add_iff_left nat_ordinal _ _ _ _
theorem nadd_le_nadd_iff_right : ∀ a {b c}, b ♯ a ≤ c ♯ a ↔ b ≤ c :=
@_root_.add_le_add_iff_right nat_ordinal _ _ _ _

theorem nadd_left_cancel : ∀ {a b c}, a ♯ b = a ♯ c → b = c :=
@_root_.add_left_cancel nat_ordinal _ _
theorem nadd_right_cancel : ∀ {a b c}, a ♯ b = c ♯ b → a = c :=
@_root_.add_right_cancel nat_ordinal _ _
theorem nadd_left_cancel_iff : ∀ {a b c}, a ♯ b = a ♯ c ↔ b = c :=
@add_left_cancel_iff nat_ordinal _ _
theorem nadd_right_cancel_iff : ∀ {a b c}, b ♯ a = c ♯ a ↔ b = c :=
@add_right_cancel_iff nat_ordinal _ _

end ordinal


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

import algebra.big_operators.basic
import data.nat.interval
import tactic.linarith

/-!
# Results about big operators over intervals

We prove results about big operators over intervals (mostly the `ℕ`-valued `Ico m n`).
-/

universes u v w

open_locale big_operators nat

namespace finset

variables {α : Type u} {β : Type v} {γ : Type w} {s₂ s₁ s : finset α} {a : α}
  {g f : α → β}

lemma sum_Ico_add [ordered_cancel_add_comm_monoid α] [has_exists_add_of_le α]
  [locally_finite_order α] [add_comm_monoid β] (f : α → β) (a b c : α) :
  (∑ x in Ico a b, f (c + x)) = (∑ x in Ico (a + c) (b + c), f x) :=
begin
  classical,
  rw [←image_add_right_Ico, sum_image (λ x hx y hy h, add_right_cancel h)],
  simp_rw add_comm,
end

@[to_additive]
lemma prod_Ico_add [ordered_cancel_add_comm_monoid α] [has_exists_add_of_le α]
  [locally_finite_order α] [comm_monoid β] (f : α → β) (a b c : α) :
  (∏ x in Ico a b, f (c + x)) = (∏ x in Ico (a + c) (b + c), f x) :=
@sum_Ico_add _ (additive β) _ _ _ _ f a b c

variables [comm_monoid β]

lemma sum_Ico_succ_top {δ : Type*} [add_comm_monoid δ] {a b : ℕ}
  (hab : a ≤ b) (f : ℕ → δ) : (∑ k in Ico a (b + 1), f k) = (∑ k in Ico a b, f k) + f b :=
by rw [nat.Ico_succ_right_eq_insert_Ico hab, sum_insert right_not_mem_Ico, add_comm]

@[to_additive]
lemma prod_Ico_succ_top {a b : ℕ} (hab : a ≤ b) (f : ℕ → β) :
  (∏ k in Ico a (b + 1), f k) = (∏ k in Ico a b, f k) * f b :=
@sum_Ico_succ_top (additive β) _ _ _ hab _

lemma sum_eq_sum_Ico_succ_bot {δ : Type*} [add_comm_monoid δ] {a b : ℕ}
  (hab : a < b) (f : ℕ → δ) : (∑ k in Ico a b, f k) = f a + (∑ k in Ico (a + 1) b, f k) :=
have ha : a ∉ Ico (a + 1) b, by simp,
by rw [← sum_insert ha, nat.Ico_insert_succ_left hab]

@[to_additive]
lemma prod_eq_prod_Ico_succ_bot {a b : ℕ} (hab : a < b) (f : ℕ → β) :
  (∏ k in Ico a b, f k) = f a * (∏ k in Ico (a + 1) b, f k) :=
@sum_eq_sum_Ico_succ_bot (additive β) _ _ _ hab _

@[to_additive]
lemma prod_Ico_consecutive (f : ℕ → β) {m n k : ℕ} (hmn : m ≤ n) (hnk : n ≤ k) :
  (∏ i in Ico m n, f i) * (∏ i in Ico n k, f i) = (∏ i in Ico m k, f i) :=
Ico_union_Ico_eq_Ico hmn hnk ▸ eq.symm $ prod_union $ Ico_disjoint_Ico_consecutive m n k

@[to_additive]
lemma prod_range_mul_prod_Ico (f : ℕ → β) {m n : ℕ} (h : m ≤ n) :
  (∏ k in range m, f k) * (∏ k in Ico m n, f k) = (∏ k in range n, f k) :=
nat.Ico_zero_eq_range ▸ nat.Ico_zero_eq_range ▸ prod_Ico_consecutive f m.zero_le h

@[to_additive]
lemma prod_Ico_eq_mul_inv {δ : Type*} [comm_group δ] (f : ℕ → δ) {m n : ℕ} (h : m ≤ n) :
  (∏ k in Ico m n, f k) = (∏ k in range n, f k) * (∏ k in range m, f k)⁻¹ :=
eq_mul_inv_iff_mul_eq.2 $ by rw [mul_comm]; exact prod_range_mul_prod_Ico f h

lemma sum_Ico_eq_sub {δ : Type*} [add_comm_group δ] (f : ℕ → δ) {m n : ℕ} (h : m ≤ n) :
  (∑ k in Ico m n, f k) = (∑ k in range n, f k) - (∑ k in range m, f k) :=
by simpa only [sub_eq_add_neg] using sum_Ico_eq_add_neg f h

/-- The two ways of summing over `(i,j)` in the range `a<=i<=j<b` are equal. -/
lemma sum_Ico_Ico_comm {M : Type*} [add_comm_monoid M]
  (a b : ℕ) (f : ℕ → ℕ → M) :
  ∑ i in finset.Ico a b, ∑ j in finset.Ico i b, f i j =
  ∑ j in finset.Ico a b, ∑ i in finset.Ico a (j+1), f i j :=
begin
  rw [finset.sum_sigma', finset.sum_sigma'],
  refine finset.sum_bij'
    (λ (x : Σ (i : ℕ), ℕ) _, (⟨x.2, x.1⟩ : Σ (i : ℕ), ℕ)) _ (λ _ _, rfl)
    (λ (x : Σ (i : ℕ), ℕ) _, (⟨x.2, x.1⟩ : Σ (i : ℕ), ℕ)) _
    (by rintro ⟨⟩ _; refl) (by rintro ⟨⟩ _; refl);
  simp only [finset.mem_Ico, sigma.forall, finset.mem_sigma];
  rintros a b ⟨⟨h₁,h₂⟩, ⟨h₃, h₄⟩⟩; refine ⟨⟨_, _⟩, ⟨_, _⟩⟩; linarith
end

@[to_additive]
lemma prod_Ico_eq_prod_range (f : ℕ → β) (m n : ℕ) :
  (∏ k in Ico m n, f k) = (∏ k in range (n - m), f (m + k)) :=
begin
  by_cases h : m ≤ n,
  { rw [←nat.Ico_zero_eq_range, prod_Ico_add, zero_add, tsub_add_cancel_of_le h] },
  { replace h : n ≤ m :=  le_of_not_ge h,
     rw [Ico_eq_empty_of_le h, tsub_eq_zero_iff_le.mpr h, range_zero, prod_empty, prod_empty] }
end

lemma prod_Ico_reflect (f : ℕ → β) (k : ℕ) {m n : ℕ} (h : m ≤ n + 1) :
  ∏ j in Ico k m, f (n - j) = ∏ j in Ico (n + 1 - m) (n + 1 - k), f j :=
begin
  have : ∀ i < m, i ≤ n,
  { intros i hi,
    exact (add_le_add_iff_right 1).1 (le_trans (nat.lt_iff_add_one_le.1 hi) h) },
  cases lt_or_le k m with hkm hkm,
  { rw [← nat.Ico_image_const_sub_eq_Ico (this _ hkm)],
    refine (prod_image _).symm,
    simp only [mem_Ico],
    rintros i ⟨ki, im⟩ j ⟨kj, jm⟩ Hij,
    rw [← tsub_tsub_cancel_of_le (this _ im), Hij, tsub_tsub_cancel_of_le (this _ jm)] },
  { simp [Ico_eq_empty_of_le, tsub_le_tsub_left, hkm] }
end

lemma sum_Ico_reflect {δ : Type*} [add_comm_monoid δ] (f : ℕ → δ) (k : ℕ) {m n : ℕ}
  (h : m ≤ n + 1) :
  ∑ j in Ico k m, f (n - j) = ∑ j in Ico (n + 1 - m) (n + 1 - k), f j :=
@prod_Ico_reflect (multiplicative δ) _ f k m n h

lemma prod_range_reflect (f : ℕ → β) (n : ℕ) :
  ∏ j in range n, f (n - 1 - j) = ∏ j in range n, f j :=
begin
  cases n,
  { simp },
  { simp only [←nat.Ico_zero_eq_range, nat.succ_sub_succ_eq_sub, tsub_zero],
    rw prod_Ico_reflect _ _ le_rfl,
    simp }
end

lemma sum_range_reflect {δ : Type*} [add_comm_monoid δ] (f : ℕ → δ) (n : ℕ) :
  ∑ j in range n, f (n - 1 - j) = ∑ j in range n, f j :=
@prod_range_reflect (multiplicative δ) _ f n

@[simp] lemma prod_Ico_id_eq_factorial : ∀ n : ℕ, ∏ x in Ico 1 (n + 1), x = n!
| 0 := rfl
| (n+1) := by rw [prod_Ico_succ_top $ nat.succ_le_succ $ zero_le n,
  nat.factorial_succ, prod_Ico_id_eq_factorial n, nat.succ_eq_add_one, mul_comm]

@[simp] lemma prod_range_add_one_eq_factorial : ∀ n : ℕ, ∏ x in range n, (x+1) = n!
| 0 := rfl
| (n+1) := by simp [finset.range_succ, prod_range_add_one_eq_factorial n]

section gauss_sum

/-- Gauss' summation formula -/
lemma sum_range_id_mul_two (n : ℕ) :
  (∑ i in range n, i) * 2 = n * (n - 1) :=
calc (∑ i in range n, i) * 2 = (∑ i in range n, i) + (∑ i in range n, (n - 1 - i)) :
  by rw [sum_range_reflect (λ i, i) n, mul_two]
... = ∑ i in range n, (i + (n - 1 - i)) : sum_add_distrib.symm
... = ∑ i in range n, (n - 1) : sum_congr rfl $ λ i hi, add_tsub_cancel_of_le $
  nat.le_pred_of_lt $ mem_range.1 hi
... = n * (n - 1) : by rw [sum_const, card_range, nat.nsmul_eq_mul]

/-- Gauss' summation formula -/
lemma sum_range_id (n : ℕ) : (∑ i in range n, i) = (n * (n - 1)) / 2 :=
by rw [← sum_range_id_mul_two n, nat.mul_div_cancel]; exact dec_trivial

end gauss_sum

end finset


import .love09_hoare_logic_demo

/-! # LoVe Homework 9: Hoare Logic

Homework must be done individually. -/

set_option pp.beta true
set_option pp.generalized_field_notation false

namespace LoVe

/-! ## Question 1 (6 points): Hoare Logic for LOOP

We introduce the LOOP language: -/

namespace loop

inductive stmt : Type
| assign : string → (state → ℕ) → stmt
| seq    : stmt → stmt → stmt
| it     : (state → Prop) → stmt → stmt
| loop   : stmt → stmt

infixr ` ;; ` : 90 := stmt.seq

/-! The language is similar to WHILE. There are three differences:

* There is no `skip` statement.

* The `it` statement is an `if`–`then` construct with no `else` case.

* The `loop` construct corresponds to a randomized `while` loop. It executes
  the body an unspecified (possibly infinite) number of times.

The big-step semantics for LOOP is defined below. -/

inductive big_step : stmt × state → state → Prop
| assign {x a s} :
  big_step (stmt.assign x a, s) (s{x ↦ a s})
| seq {S T s t u} (hs : big_step (S, s) t)
    (ht : big_step (T, t) u) :
  big_step (S ;; T, s) u
| it_true {b : state → Prop} {S s t} (hcond : b s) (hbody : big_step (S, s) t) :
  big_step (stmt.it b S, s) t
| it_false {b : state → Prop} {S s} (hcond : ¬ b s) :
  big_step (stmt.it b S, s) s
| loop_continue {S s t u} (hbody : big_step (S, s) t)
    (hrest : big_step (stmt.loop S, t) u) :
  big_step (stmt.loop S, s) u
| loop_exit {S s} :
  big_step (stmt.loop S, s) s

infix ` ⟹ ` : 110 := big_step

/-! The definition of Hoare triples for partial correctness is unsurprising: -/

def partial_hoare (P : state → Prop) (S : stmt) (Q : state → Prop) : Prop :=
∀s t, P s → (S, s) ⟹ t → Q t

local notation `{* ` P : 1 ` *} ` S : 1 ` {* ` Q : 1 ` *}` :=
partial_hoare P S Q

namespace partial_hoare

/-! 1.1 (1 point). Prove the consequence rule. -/

lemma consequence {P P' Q Q' : state → Prop} {S} (h : {* P *} S {* Q *})
    (hp : ∀s, P' s → P s) (hq : ∀s, Q s → Q' s) :
  {* P' *} S {* Q' *} :=
sorry

/-! 1.2 (1 point). Prove the rule for `assign`. -/

lemma assign_intro {P : state → Prop} {x} {a : state → ℕ} :
  {* λs, P (s{x ↦ a s}) *} stmt.assign x a {* P *} :=
sorry

/-! 1.3 (1 point). Prove the rule for `seq`. -/

lemma seq_intro {P Q R S T} (hS : {* P *} S {* Q *}) (hT : {* Q *} T {* R *}) :
  {* P *} stmt.seq S T {* R *} :=
sorry

/-! 1.4 (1 point). Prove the rule for `it`. -/

lemma it_intro {b P Q : state → Prop} {S}
    (htrue : {* λs, P s ∧ b s *} S {* Q *}) (hfalse : ∀s, P s ∧ ¬ b s → Q s) :
  {* P *} stmt.it b S {* Q *} :=
sorry

/-! 1.5 (2 points). Prove the rule for `loop`. Notice the similarity with the
rule for `while` in the WHILE language. -/

lemma loop_intro {S} (P : state → Prop) (h : {* P *} S {* P *}) :
  {* P *} stmt.loop S {* P *} :=
sorry

end partial_hoare

end loop

/-! ## Question 2 (3 points): Program Verification

The following WHILE program is intended to compute 2 to the power of `n`,
leaving the result in `y`. -/

def POWER_OF_TWO : stmt :=
stmt.assign "y" (λs, 1) ;;
stmt.while (λs, s "n" ≠ 0)
  (stmt.assign "y" (λs, s "y" * 2) ;;
   stmt.assign "n" (λs, s "n" - 1))

/-! 2.1 (1 point). Define a recursive function that computes 2 to the power of
`n`. -/

def two_to_the_nth : ℕ → ℕ :=
sorry

/-! Remember to test your function. Otherwise, you will have big difficulties
answering question 2.2 below. -/

#eval two_to_the_nth 0   -- expected: 1
#eval two_to_the_nth 1   -- expected: 2
#eval two_to_the_nth 2   -- expected: 4
#eval two_to_the_nth 3   -- expected: 8
#eval two_to_the_nth 8   -- expected: 256

/-! 2.2 (2 points). Prove the correctness of `POWER_OF_TWO` using `vcg`. -/

lemma POWER_OF_TWO_correct (n₀ : ℕ) :
  {* λs, s "n" = n₀ *} POWER_OF_TWO {* λs, s "y" = two_to_the_nth n₀ *} :=
sorry

end LoVe