/-
Copyright (c) 2021 Kexing Ying. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kexing Ying, Rémy Degenne

! This file was ported from Lean 3 source module probability.process.filtration
! leanprover-community/mathlib commit f2ce6086713c78a7f880485f7917ea547a215982
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.MeasureTheory.Function.ConditionalExpectation.Real

/-!
# Filtrations

This file defines filtrations of a measurable space and σ-finite filtrations.

## Main definitions

* `measure_theory.filtration`: a filtration on a measurable space. That is, a monotone sequence of
  sub-σ-algebras.
* `measure_theory.sigma_finite_filtration`: a filtration `f` is σ-finite with respect to a measure
  `μ` if for all `i`, `μ.trim (f.le i)` is σ-finite.
* `measure_theory.filtration.natural`: the smallest filtration that makes a process adapted. That
  notion `adapted` is not defined yet in this file. See `measure_theory.adapted`.

## Main results

* `measure_theory.filtration.complete_lattice`: filtrations are a complete lattice.

## Tags

filtration, stochastic process

-/

open Filter Order TopologicalSpace

open Classical MeasureTheory NNReal ENNReal Topology BigOperators

namespace MeasureTheory

/-- A `filtration` on a measurable space `Ω` with σ-algebra `m` is a monotone
sequence of sub-σ-algebras of `m`. -/
structure Filtration {Ω : Type _} (ι : Type _) [Preorder ι] (m : MeasurableSpace Ω) where
  seq : ι → MeasurableSpace Ω
  mono' : Monotone seq
  le' : ∀ i : ι, seq i ≤ m
#align measure_theory.filtration MeasureTheory.Filtration

variable {Ω β ι : Type _} {m : MeasurableSpace Ω}

instance [Preorder ι] : CoeFun (Filtration ι m) fun _ => ι → MeasurableSpace Ω :=
  ⟨fun f => f.seq⟩

namespace Filtration

variable [Preorder ι]

protected theorem mono {i j : ι} (f : Filtration ι m) (hij : i ≤ j) : f i ≤ f j :=
  f.mono' hij
#align measure_theory.filtration.mono MeasureTheory.Filtration.mono

protected theorem le (f : Filtration ι m) (i : ι) : f i ≤ m :=
  f.le' i
#align measure_theory.filtration.le MeasureTheory.Filtration.le

@[ext]
protected theorem ext {f g : Filtration ι m} (h : (f : ι → MeasurableSpace Ω) = g) : f = g :=
  by
  cases f
  cases g
  simp only
  exact h
#align measure_theory.filtration.ext MeasureTheory.Filtration.ext

variable (ι)

/-- The constant filtration which is equal to `m` for all `i : ι`. -/
def const (m' : MeasurableSpace Ω) (hm' : m' ≤ m) : Filtration ι m :=
  ⟨fun _ => m', monotone_const, fun _ => hm'⟩
#align measure_theory.filtration.const MeasureTheory.Filtration.const

variable {ι}

@[simp]
theorem const_apply {m' : MeasurableSpace Ω} {hm' : m' ≤ m} (i : ι) : const ι m' hm' i = m' :=
  rfl
#align measure_theory.filtration.const_apply MeasureTheory.Filtration.const_apply

instance : Inhabited (Filtration ι m) :=
  ⟨const ι m le_rfl⟩

instance : LE (Filtration ι m) :=
  ⟨fun f g => ∀ i, f i ≤ g i⟩

instance : Bot (Filtration ι m) :=
  ⟨const ι ⊥ bot_le⟩

instance : Top (Filtration ι m) :=
  ⟨const ι m le_rfl⟩

instance : Sup (Filtration ι m) :=
  ⟨fun f g =>
    { seq := fun i => f i ⊔ g i
      mono' := fun i j hij =>
        sup_le ((f.mono hij).trans le_sup_left) ((g.mono hij).trans le_sup_right)
      le' := fun i => sup_le (f.le i) (g.le i) }⟩

@[norm_cast]
theorem coeFn_sup {f g : Filtration ι m} : ⇑(f ⊔ g) = f ⊔ g :=
  rfl
#align measure_theory.filtration.coe_fn_sup MeasureTheory.Filtration.coeFn_sup

instance : Inf (Filtration ι m) :=
  ⟨fun f g =>
    { seq := fun i => f i ⊓ g i
      mono' := fun i j hij =>
        le_inf (inf_le_left.trans (f.mono hij)) (inf_le_right.trans (g.mono hij))
      le' := fun i => inf_le_left.trans (f.le i) }⟩

@[norm_cast]
theorem coeFn_inf {f g : Filtration ι m} : ⇑(f ⊓ g) = f ⊓ g :=
  rfl
#align measure_theory.filtration.coe_fn_inf MeasureTheory.Filtration.coeFn_inf

instance : SupSet (Filtration ι m) :=
  ⟨fun s =>
    { seq := fun i => supₛ ((fun f : Filtration ι m => f i) '' s)
      mono' := fun i j hij => by
        refine' supₛ_le fun m' hm' => _
        rw [Set.mem_image] at hm'
        obtain ⟨f, hf_mem, hfm'⟩ := hm'
        rw [← hfm']
        refine' (f.mono hij).trans _
        have hfj_mem : f j ∈ (fun g : filtration ι m => g j) '' s := ⟨f, hf_mem, rfl⟩
        exact le_supₛ hfj_mem
      le' := fun i => by
        refine' supₛ_le fun m' hm' => _
        rw [Set.mem_image] at hm'
        obtain ⟨f, hf_mem, hfm'⟩ := hm'
        rw [← hfm']
        exact f.le i }⟩

theorem supₛ_def (s : Set (Filtration ι m)) (i : ι) :
    supₛ s i = supₛ ((fun f : Filtration ι m => f i) '' s) :=
  rfl
#align measure_theory.filtration.Sup_def MeasureTheory.Filtration.supₛ_def

noncomputable instance : InfSet (Filtration ι m) :=
  ⟨fun s =>
    { seq := fun i => if Set.Nonempty s then infₛ ((fun f : Filtration ι m => f i) '' s) else m
      mono' := fun i j hij => by
        by_cases h_nonempty : Set.Nonempty s
        swap
        · simp only [h_nonempty, Set.nonempty_image_iff, if_false, le_refl]
        simp only [h_nonempty, if_true, le_infₛ_iff, Set.mem_image, forall_exists_index, and_imp,
          forall_apply_eq_imp_iff₂]
        refine' fun f hf_mem => le_trans _ (f.mono hij)
        have hfi_mem : f i ∈ (fun g : filtration ι m => g i) '' s := ⟨f, hf_mem, rfl⟩
        exact infₛ_le hfi_mem
      le' := fun i => by
        by_cases h_nonempty : Set.Nonempty s
        swap; · simp only [h_nonempty, if_false, le_refl]
        simp only [h_nonempty, if_true]
        obtain ⟨f, hf_mem⟩ := h_nonempty
        exact le_trans (infₛ_le ⟨f, hf_mem, rfl⟩) (f.le i) }⟩

theorem infₛ_def (s : Set (Filtration ι m)) (i : ι) :
    infₛ s i = if Set.Nonempty s then infₛ ((fun f : Filtration ι m => f i) '' s) else m :=
  rfl
#align measure_theory.filtration.Inf_def MeasureTheory.Filtration.infₛ_def

noncomputable instance : CompleteLattice (Filtration ι m)
    where
  le := (· ≤ ·)
  le_refl f i := le_rfl
  le_trans f g h h_fg h_gh i := (h_fg i).trans (h_gh i)
  le_antisymm f g h_fg h_gf := Filtration.ext <| funext fun i => (h_fg i).antisymm (h_gf i)
  sup := (· ⊔ ·)
  le_sup_left f g i := le_sup_left
  le_sup_right f g i := le_sup_right
  sup_le f g h h_fh h_gh i := sup_le (h_fh i) (h_gh _)
  inf := (· ⊓ ·)
  inf_le_left f g i := inf_le_left
  inf_le_right f g i := inf_le_right
  le_inf f g h h_fg h_fh i := le_inf (h_fg i) (h_fh i)
  supₛ := supₛ
  le_sup s f hf_mem i := le_supₛ ⟨f, hf_mem, rfl⟩
  sup_le s f h_forall i :=
    supₛ_le fun m' hm' => by
      obtain ⟨g, hg_mem, hfm'⟩ := hm'
      rw [← hfm']
      exact h_forall g hg_mem i
  infₛ := infₛ
  inf_le s f hf_mem i := by
    have hs : s.nonempty := ⟨f, hf_mem⟩
    simp only [Inf_def, hs, if_true]
    exact infₛ_le ⟨f, hf_mem, rfl⟩
  le_inf s f h_forall i := by
    by_cases hs : s.nonempty
    swap;
    · simp only [Inf_def, hs, if_false]
      exact f.le i
    simp only [Inf_def, hs, if_true, le_infₛ_iff, Set.mem_image, forall_exists_index, and_imp,
      forall_apply_eq_imp_iff₂]
    exact fun g hg_mem => h_forall g hg_mem i
  top := ⊤
  bot := ⊥
  le_top f i := f.le' i
  bot_le f i := bot_le

end Filtration

theorem measurableSet_of_filtration [Preorder ι] {f : Filtration ι m} {s : Set Ω} {i : ι}
    (hs : measurable_set[f i] s) : measurable_set[m] s :=
  f.le i s hs
#align measure_theory.measurable_set_of_filtration MeasureTheory.measurableSet_of_filtration

/-- A measure is σ-finite with respect to filtration if it is σ-finite with respect
to all the sub-σ-algebra of the filtration. -/
class SigmaFiniteFiltration [Preorder ι] (μ : Measure Ω) (f : Filtration ι m) : Prop where
  SigmaFinite : ∀ i : ι, SigmaFinite (μ.trim (f.le i))
#align measure_theory.sigma_finite_filtration MeasureTheory.SigmaFiniteFiltration

instance sigmaFiniteOfSigmaFiniteFiltration [Preorder ι] (μ : Measure Ω) (f : Filtration ι m)
    [hf : SigmaFiniteFiltration μ f] (i : ι) : SigmaFinite (μ.trim (f.le i)) := by
  apply hf.sigma_finite
#align measure_theory.sigma_finite_of_sigma_finite_filtration MeasureTheory.sigmaFiniteOfSigmaFiniteFiltration

-- can't exact here
instance (priority := 100) IsFiniteMeasure.sigmaFiniteFiltration [Preorder ι] (μ : Measure Ω)
    (f : Filtration ι m) [IsFiniteMeasure μ] : SigmaFiniteFiltration μ f :=
  ⟨fun n => by infer_instance⟩
#align measure_theory.is_finite_measure.sigma_finite_filtration MeasureTheory.IsFiniteMeasure.sigmaFiniteFiltration

/-- Given a integrable function `g`, the conditional expectations of `g` with respect to a
filtration is uniformly integrable. -/
theorem Integrable.uniformIntegrableCondexpFiltration [Preorder ι] {μ : Measure Ω}
    [IsFiniteMeasure μ] {f : Filtration ι m} {g : Ω → ℝ} (hg : Integrable g μ) :
    UniformIntegrable (fun i => μ[g|f i]) 1 μ :=
  hg.uniformIntegrableCondexp f.le
#align measure_theory.integrable.uniform_integrable_condexp_filtration MeasureTheory.Integrable.uniformIntegrableCondexpFiltration

section OfSet

variable [Preorder ι]

/-- Given a sequence of measurable sets `(sₙ)`, `filtration_of_set` is the smallest filtration
such that `sₙ` is measurable with respect to the `n`-the sub-σ-algebra in `filtration_of_set`. -/
def filtrationOfSet {s : ι → Set Ω} (hsm : ∀ i, MeasurableSet (s i)) : Filtration ι m
    where
  seq i := MeasurableSpace.generateFrom { t | ∃ j ≤ i, s j = t }
  mono' n m hnm := MeasurableSpace.generateFrom_mono fun t ⟨k, hk₁, hk₂⟩ => ⟨k, hk₁.trans hnm, hk₂⟩
  le' n := MeasurableSpace.generateFrom_le fun t ⟨k, hk₁, hk₂⟩ => hk₂ ▸ hsm k
#align measure_theory.filtration_of_set MeasureTheory.filtrationOfSet

theorem measurableSet_filtrationOfSet {s : ι → Set Ω} (hsm : ∀ i, measurable_set[m] (s i)) (i : ι)
    {j : ι} (hj : j ≤ i) : measurable_set[filtrationOfSet hsm i] (s j) :=
  MeasurableSpace.measurableSet_generateFrom ⟨j, hj, rfl⟩
#align measure_theory.measurable_set_filtration_of_set MeasureTheory.measurableSet_filtrationOfSet

theorem measurableSet_filtration_of_set' {s : ι → Set Ω} (hsm : ∀ n, measurable_set[m] (s n))
    (i : ι) : measurable_set[filtrationOfSet hsm i] (s i) :=
  measurableSet_filtrationOfSet hsm i le_rfl
#align measure_theory.measurable_set_filtration_of_set' MeasureTheory.measurableSet_filtration_of_set'

end OfSet

namespace Filtration

variable [TopologicalSpace β] [MetrizableSpace β] [mβ : MeasurableSpace β] [BorelSpace β]
  [Preorder ι]

include mβ

/-- Given a sequence of functions, the natural filtration is the smallest sequence
of σ-algebras such that that sequence of functions is measurable with respect to
the filtration. -/
def natural (u : ι → Ω → β) (hum : ∀ i, StronglyMeasurable (u i)) : Filtration ι m
    where
  seq i := ⨆ j ≤ i, MeasurableSpace.comap (u j) mβ
  mono' i j hij := bsupᵢ_mono fun k => ge_trans hij
  le' i := by
    refine' supᵢ₂_le _
    rintro j hj s ⟨t, ht, rfl⟩
    exact (hum j).Measurable ht
#align measure_theory.filtration.natural MeasureTheory.Filtration.natural

section

open MeasurableSpace

theorem filtrationOfSet_eq_natural [MulZeroOneClass β] [Nontrivial β] {s : ι → Set Ω}
    (hsm : ∀ i, measurable_set[m] (s i)) :
    filtrationOfSet hsm =
      natural (fun i => (s i).indicator (fun ω => 1 : Ω → β)) fun i =>
        stronglyMeasurable_one.indicator (hsm i) :=
  by
  simp only [natural, filtration_of_set, measurable_space_supr_eq]
  ext1 i
  refine' le_antisymm (generate_from_le _) (generate_from_le _)
  · rintro _ ⟨j, hij, rfl⟩
    refine' measurable_set_generate_from ⟨j, measurable_set_generate_from ⟨hij, _⟩⟩
    rw [comap_eq_generate_from]
    refine' measurable_set_generate_from ⟨{1}, measurable_set_singleton 1, _⟩
    ext x
    simp [Set.indicator_const_preimage_eq_union]
  · rintro t ⟨n, ht⟩
    suffices
      MeasurableSpace.generateFrom
          { t |
            ∃ H : n ≤ i,
              measurable_set[MeasurableSpace.comap ((s n).indicator (fun ω => 1 : Ω → β)) mβ] t } ≤
        generate_from { t | ∃ (j : ι)(H : j ≤ i), s j = t }
      by exact this _ ht
    refine' generate_from_le _
    rintro t ⟨hn, u, hu, hu'⟩
    obtain heq | heq | heq | heq := Set.indicator_const_preimage (s n) u (1 : β)
    pick_goal 4
    rw [Set.mem_singleton_iff] at heq
    all_goals rw [HEq] at hu'; rw [← hu']
    exacts[measurable_set_empty _, MeasurableSet.univ, measurable_set_generate_from ⟨n, hn, rfl⟩,
      MeasurableSet.compl (measurable_set_generate_from ⟨n, hn, rfl⟩)]
#align measure_theory.filtration.filtration_of_set_eq_natural MeasureTheory.Filtration.filtrationOfSet_eq_natural

end

section Limit

omit mβ

variable {E : Type _} [Zero E] [TopologicalSpace E] {ℱ : Filtration ι m} {f : ι → Ω → E}
  {μ : Measure Ω}

/-- Given a process `f` and a filtration `ℱ`, if `f` converges to some `g` almost everywhere and
`g` is `⨆ n, ℱ n`-measurable, then `limit_process f ℱ μ` chooses said `g`, else it returns 0.

This definition is used to phrase the a.e. martingale convergence theorem
`submartingale.ae_tendsto_limit_process` where an L¹-bounded submartingale `f` adapted to `ℱ`
converges to `limit_process f ℱ μ` `μ`-almost everywhere. -/
noncomputable def limitProcess (f : ι → Ω → E) (ℱ : Filtration ι m)
    (μ : Measure Ω := by exact MeasureTheory.MeasureSpace.volume) :=
  if h :
      ∃ g : Ω → E,
        strongly_measurable[⨆ n, ℱ n] g ∧ ∀ᵐ ω ∂μ, Tendsto (fun n => f n ω) atTop (𝓝 (g ω)) then
    Classical.choose h
  else 0
#align measure_theory.filtration.limit_process MeasureTheory.Filtration.limitProcess

theorem stronglyMeasurable_limitProcess : strongly_measurable[⨆ n, ℱ n] (limitProcess f ℱ μ) :=
  by
  rw [limit_process]
  split_ifs with h h
  exacts[(Classical.choose_spec h).1, strongly_measurable_zero]
#align measure_theory.filtration.strongly_measurable_limit_process MeasureTheory.Filtration.stronglyMeasurable_limitProcess

theorem stronglyMeasurable_limit_process' : strongly_measurable[m] (limitProcess f ℱ μ) :=
  stronglyMeasurable_limitProcess.mono (supₛ_le fun m ⟨n, hn⟩ => hn ▸ ℱ.le _)
#align measure_theory.filtration.strongly_measurable_limit_process' MeasureTheory.Filtration.stronglyMeasurable_limit_process'

theorem memℒpLimitProcessOfSnormBdd {R : ℝ≥0} {p : ℝ≥0∞} {F : Type _} [NormedAddCommGroup F]
    {ℱ : Filtration ℕ m} {f : ℕ → Ω → F} (hfm : ∀ n, AeStronglyMeasurable (f n) μ)
    (hbdd : ∀ n, snorm (f n) p μ ≤ R) : Memℒp (limitProcess f ℱ μ) p μ :=
  by
  rw [limit_process]
  split_ifs with h
  · refine'
      ⟨strongly_measurable.ae_strongly_measurable
          ((Classical.choose_spec h).1.mono (supₛ_le fun m ⟨n, hn⟩ => hn ▸ ℱ.le _)),
        lt_of_le_of_lt (Lp.snorm_lim_le_liminf_snorm hfm _ (Classical.choose_spec h).2)
          (lt_of_le_of_lt _ (ENNReal.coe_lt_top : ↑R < ∞))⟩
    simp_rw [liminf_eq, eventually_at_top]
    exact supₛ_le fun b ⟨a, ha⟩ => (ha a le_rfl).trans (hbdd _)
  · exact zero_mem_ℒp
#align measure_theory.filtration.mem_ℒp_limit_process_of_snorm_bdd MeasureTheory.Filtration.memℒpLimitProcessOfSnormBdd

end Limit

end Filtration

end MeasureTheory


section propositional

variables P Q R : Prop

------------------------------------------------
-- Proposições de dupla negaço:
------------------------------------------------

theorem doubleneg_intro :
  P → ¬¬P  :=
begin
  intro hp,

end

theorem doubleneg_elim :
  ¬¬P → P  :=
begin
  sorry,
end

theorem doubleneg_law :
  ¬¬P ↔ P  :=
begin
  sorry,
end

------------------------------------------------
-- Comutatividade dos ∨,∧:
------------------------------------------------

theorem disj_comm :
  (P ∨ Q) → (Q ∨ P)  :=
begin
  sorry,
end

theorem conj_comm :
  (P ∧ Q) → (Q ∧ P)  :=
begin
  sorry,
end

------------------------------------------------
-- Proposições de interdefinabilidade dos →,∨:
------------------------------------------------

theorem impl_as_disj_converse :
  (¬P ∨ Q) → (P → Q)  :=
begin
  sorry,
end

theorem disj_as_impl :
  (P ∨ Q) → (¬P → Q)  :=
begin
  sorry,
end

------------------------------------------------
-- Proposições de contraposição:
------------------------------------------------

theorem impl_as_contrapositive :
  (P → Q) → (¬Q → ¬P)  :=
begin
  sorry,
end

theorem impl_as_contrapositive_converse :
  (¬Q → ¬P) → (P → Q)  :=
begin
  sorry,
end

theorem contrapositive_law :
  (P → Q) ↔ (¬Q → ¬P)  :=
begin
  sorry,
end

------------------------------------------------
-- A irrefutabilidade do LEM:
------------------------------------------------

theorem lem_irrefutable :
  ¬¬(P∨¬P)  :=
begin
  sorry,
end

------------------------------------------------
-- A lei de Peirce
------------------------------------------------

theorem peirce_law_weak :
  ((P → Q) → P) → ¬¬P  :=
begin
  sorry,
end

------------------------------------------------
-- Proposições de interdefinabilidade dos ∨,∧:
------------------------------------------------

theorem disj_as_negconj :
  P∨Q → ¬(¬P∧¬Q)  :=
begin
  sorry,
end

theorem conj_as_negdisj :
  P∧Q → ¬(¬P∨¬Q)  :=
begin
  sorry,
end

------------------------------------------------
-- As leis de De Morgan para ∨,∧:
------------------------------------------------

theorem demorgan_disj :
  ¬(P∨Q) → (¬P ∧ ¬Q)  :=
begin
  sorry,
end

theorem demorgan_disj_converse :
  (¬P ∧ ¬Q) → ¬(P∨Q)  :=
begin
  sorry,
end

theorem demorgan_conj :
  ¬(P∧Q) → (¬Q ∨ ¬P)  :=
begin
  sorry,
end

theorem demorgan_conj_converse :
  (¬Q ∨ ¬P) → ¬(P∧Q)  :=
begin
  sorry,
end

theorem demorgan_conj_law :
  ¬(P∧Q) ↔ (¬Q ∨ ¬P)  :=
begin
  sorry,
end

theorem demorgan_disj_law :
  ¬(P∨Q) ↔ (¬P ∧ ¬Q)  :=
begin
  sorry,
end

------------------------------------------------
-- Proposições de distributividade dos ∨,∧:
------------------------------------------------

theorem distr_conj_disj :
  P∧(Q∨R) → (P∧Q)∨(P∧R)  :=
begin
  sorry,
end

theorem distr_conj_disj_converse :
  (P∧Q)∨(P∧R) → P∧(Q∨R)  :=
begin
  sorry,
end

theorem distr_disj_conj :
  P∨(Q∧R) → (P∨Q)∧(P∨R)  :=
begin
  sorry,
end

theorem distr_disj_conj_converse :
  (P∨Q)∧(P∨R) → P∨(Q∧R)  :=
begin
  sorry,
end

------------------------------------------------
-- Currificação
------------------------------------------------

theorem curry_prop :
  ((P∧Q)→R) → (P→(Q→R))  :=
begin
  sorry,
end

theorem uncurry_prop :
  (P→(Q→R)) → ((P∧Q)→R)  :=
begin
  sorry,
end

------------------------------------------------
-- Reflexividade da →:
------------------------------------------------

theorem impl_refl :
  P → P  :=
begin
  sorry,
end

------------------------------------------------
-- Weakening and contraction:
------------------------------------------------

theorem weaken_disj_right :
  P → (P∨Q)  :=
begin
  sorry,
end

theorem weaken_disj_left :
  Q → (P∨Q)  :=
begin
  sorry,
end

theorem weaken_conj_right :
  (P∧Q) → P  :=
begin
  sorry,
end

theorem weaken_conj_left :
  (P∧Q) → Q  :=
begin
  sorry,
end

theorem conj_idempot :
  (P∧P) ↔ P :=
begin
  sorry,
end

theorem disj_idempot :
  (P∨P) ↔ P  :=
begin
  sorry,
end

end propositional

----------------------------------------------------------------

section predicate

variable U : Type
variables P Q : U -> Prop

------------------------------------------------
-- As leis de De Morgan para ∃,∀:
------------------------------------------------

theorem demorgan_exists :
  ¬(∃x, P x) → (∀x, ¬P x)  :=
begin
  sorry,
end

theorem demorgan_exists_converse :
  (∀x, ¬P x) → ¬(∃x, P x)  :=
begin
  sorry,
end

theorem demorgan_forall :
  ¬(∀x, P x) → (∃x, ¬P x)  :=
begin
  sorry,
end

theorem demorgan_forall_converse :
  (∃x, ¬P x) → ¬(∀x, P x)  :=
begin
  sorry,
end

theorem demorgan_forall_law :
  ¬(∀x, P x) ↔ (∃x, ¬P x)  :=
begin
  sorry,
end

theorem demorgan_exists_law :
  ¬(∃x, P x) ↔ (∀x, ¬P x)  :=
begin
  sorry,
end

------------------------------------------------
-- Proposições de interdefinabilidade dos ∃,∀:
------------------------------------------------

theorem exists_as_neg_forall :
  (∃x, P x) → ¬(∀x, ¬P x)  :=
begin
  sorry,
end

theorem forall_as_neg_exists :
  (∀x, P x) → ¬(∃x, ¬P x)  :=
begin
  sorry,
end

theorem forall_as_neg_exists_converse :
  ¬(∃x, ¬P x) → (∀x, P x)  :=
begin
  sorry,
end

theorem exists_as_neg_forall_converse :
  ¬(∀x, ¬P x) → (∃x, P x)  :=
begin
  sorry,
end

theorem forall_as_neg_exists_law :
  (∀x, P x) ↔ ¬(∃x, ¬P x)  :=
begin
  sorry,
end

theorem exists_as_neg_forall_law :
  (∃x, P x) ↔ ¬(∀x, ¬P x)  :=
begin
  sorry,
end

------------------------------------------------
--  Proposições de distributividade de quantificadores:
------------------------------------------------

theorem exists_conj_as_conj_exists :
  (∃x, P x ∧ Q x) → (∃x, P x) ∧ (∃x, Q x)  :=
begin
  sorry,
end

theorem exists_disj_as_disj_exists :
  (∃x, P x ∨ Q x) → (∃x, P x) ∨ (∃x, Q x)  :=
begin
  sorry,
end

theorem exists_disj_as_disj_exists_converse :
  (∃x, P x) ∨ (∃x, Q x) → (∃x, P x ∨ Q x)  :=
begin
  sorry,
end

theorem forall_conj_as_conj_forall :
  (∀x, P x ∧ Q x) → (∀x, P x) ∧ (∀x, Q x)  :=
begin
  sorry,
end

theorem forall_conj_as_conj_forall_converse :
  (∀x, P x) ∧ (∀x, Q x) → (∀x, P x ∧ Q x)  :=
begin
  sorry,
end

theorem forall_disj_as_disj_forall_converse :
  (∀x, P x) ∨ (∀x, Q x) → (∀x, P x ∨ Q x)  :=
begin
  sorry,
end

/- NOT THEOREMS --------------------------------

theorem forall_disj_as_disj_forall :
  (∀x, P x ∨ Q x) → (∀x, P x) ∨ (∀x, Q x)  :=
begin
end

theorem exists_conj_as_conj_exists_converse :
  (∃x, P x) ∧ (∃x, Q x) → (∃x, P x ∧ Q x)  :=
begin
end

---------------------------------------------- -/

end predicate


/-
Copyright (c) 2022 Mac Malone. All rights reserved.
Released under the MIT license described in the file LICENSE.
Authors: Mac Malone
-/

import Folktale.Classical

/-!
Folktale's formalization of the concept of knights and knaves.
-/

namespace Folktale

-- # Basics

/-- The type of knights and knaves. -/
constant Folk : Type

/-- The proposition of being a knight. -/
constant knight : Folk → Prop

/-- The proposition of being a knave. -/
constant knave : Folk → Prop

/-- The axiom that all folks are either knights or knaves. -/
axiom knight_or_knave (K : Folk) :
  knight K ∨ knave K

/-- The axiom that no folks are both a knight and a knave. -/
axiom knight_not_knave {K : Folk} :
  knight K → knave K → False

/-- A folk that is not a knight is a knave. -/
theorem not_knight_knave {K : Folk} : ¬ knight K → knave K := by
  intro not_knight_K
  cases knight_or_knave K with
  | inl knight_K => exact absurd knight_K not_knight_K
  | inr knave_K => exact knave_K

/-- A folk that is not a knave is a knight. -/
theorem not_knave_knight {K : Folk} : ¬ knave K → knight K := by
  intro not_knave_K
  cases knight_or_knave K with
  | inl knight_K => exact knight_K
  | inr knave_K => exact absurd knave_K not_knave_K

/-- Binary connective representing a statement by a knight or knave. -/
constant Folk.say : Folk → Prop → Prop

/-- The axiom that knights always tell the truth. -/
axiom knight_truth  {K : Folk} {P : Prop} :
  knight K → K.say P → P

/-- The axiom that knaves always lie. -/
axiom knave_lie {K : Folk} {P : Prop} :
  knave K → K.say P → ¬ P

-- # Helpers

/--
The proposition that 2 folks are of the same type
(i.e., either both knights or both knaves).
-/
abbrev same2 (k1 k2 : Folk) :=
  (knight k1 ∧ knight k2) ∨ (knave k1 ∧ knave k2)

/--
The proposition that 3 folks are of the same type
(i.e., either all knights or all knaves).
-/
abbrev same3 (k1 k2 k3 : Folk)  :=
  (knight k1 ∧ knight k2 ∧ knight k3) ∨ (knave k1 ∧ knave k2 ∧ knave k3)

/-- If 3 folks are not the same, one is a knight and one is a knave. -/
theorem not_same3_one_knight_knave : ¬ same3 A B C →
(knight A ∨ knight B ∨ knight C) ∧ (knave A ∨ knave B ∨ knave C) := by
  intro h
  let hor := Classical.dm_or h
  refine And.intro ?one_knight ?one_knave
  case one_knight =>
    let not_all_knaves := hor.2
    cases Classical.dm_and not_all_knaves with
    | inl not_A =>
      exact Or.inl <| not_knave_knight not_A
    | inr not_B_C =>
      cases Classical.dm_and not_B_C with
      | inl not_B =>
        exact Or.inr <| Or.inl <| not_knave_knight not_B
      | inr not_C =>
        exact Or.inr <| Or.inr <| not_knave_knight not_C
  case one_knave =>
    let not_all_knights := hor.1
    cases Classical.dm_and not_all_knights with
    | inl not_A =>
      exact Or.inl <| not_knight_knave not_A
    | inr not_B_C =>
      cases Classical.dm_and not_B_C with
      | inl not_B =>
        exact Or.inr <| Or.inl <| not_knight_knave not_B
      | inr not_C =>
        exact Or.inr <| Or.inr <| not_knight_knave not_C


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

import field_theory.primitive_element
import linear_algebra.determinant
import linear_algebra.matrix.charpoly.coeff
import linear_algebra.matrix.to_linear_equiv
import field_theory.is_alg_closed.algebraic_closure

/-!
# Norm for (finite) ring extensions

Suppose we have an `R`-algebra `S` with a finite basis. For each `s : S`,
the determinant of the linear map given by multiplying by `s` gives information
about the roots of the minimal polynomial of `s` over `R`.

## Implementation notes

Typically, the norm is defined specifically for finite field extensions.
The current definition is as general as possible and the assumption that we have
fields or that the extension is finite is added to the lemmas as needed.

We only define the norm for left multiplication (`algebra.left_mul_matrix`,
i.e. `algebra.lmul_left`).
For now, the definitions assume `S` is commutative, so the choice doesn't
matter anyway.

See also `algebra.trace`, which is defined similarly as the trace of
`algebra.left_mul_matrix`.

## References

 * https://en.wikipedia.org/wiki/Field_norm

-/

universes u v w

variables {R S T : Type*} [comm_ring R] [is_domain R] [comm_ring S]
variables [algebra R S]
variables {K L F : Type*} [field K] [field L] [field F]
variables [algebra K L] [algebra K F]
variables {ι : Type w} [fintype ι]

open finite_dimensional
open linear_map
open matrix polynomial

open_locale big_operators
open_locale matrix

namespace algebra

variables (R)

/-- The norm of an element `s` of an `R`-algebra is the determinant of `(*) s`. -/
noncomputable def norm : S →* R :=
linear_map.det.comp (lmul R S).to_ring_hom.to_monoid_hom

lemma norm_apply (x : S) : norm R x = linear_map.det (lmul R S x) := rfl

lemma norm_eq_one_of_not_exists_basis
  (h : ¬ ∃ (s : finset S), nonempty (basis s R S)) (x : S) : norm R x = 1 :=
by { rw [norm_apply, linear_map.det], split_ifs with h, refl }

variables {R}

-- Can't be a `simp` lemma because it depends on a choice of basis
lemma norm_eq_matrix_det [decidable_eq ι] (b : basis ι R S) (s : S) :
  norm R s = matrix.det (algebra.left_mul_matrix b s) :=
by rw [norm_apply, ← linear_map.det_to_matrix b, to_matrix_lmul_eq]

/-- If `x` is in the base field `K`, then the norm is `x ^ [L : K]`. -/
lemma norm_algebra_map_of_basis (b : basis ι R S) (x : R) :
  norm R (algebra_map R S x) = x ^ fintype.card ι :=
begin
  haveI := classical.dec_eq ι,
  rw [norm_apply, ← det_to_matrix b, lmul_algebra_map],
  convert @det_diagonal _ _ _ _ _ (λ (i : ι), x),
  { ext i j, rw [to_matrix_lsmul, matrix.diagonal] },
  { rw [finset.prod_const, finset.card_univ] }
end

/-- If `x` is in the base field `K`, then the norm is `x ^ [L : K]`.

(If `L` is not finite-dimensional over `K`, then `norm = 1 = x ^ 0 = x ^ (finrank L K)`.)
-/
@[simp]
lemma norm_algebra_map (x : K) : norm K (algebra_map K L x) = x ^ finrank K L :=
begin
  by_cases H : ∃ (s : finset L), nonempty (basis s K L),
  { rw [norm_algebra_map_of_basis H.some_spec.some, finrank_eq_card_basis H.some_spec.some] },
  { rw [norm_eq_one_of_not_exists_basis K H, finrank_eq_zero_of_not_exists_basis, pow_zero],
    rintros ⟨s, ⟨b⟩⟩,
    exact H ⟨s, ⟨b⟩⟩ },
end

section eq_prod_roots

/-- Given `pb : power_basis K S`, then the norm of `pb.gen` is
`(-1) ^ pb.dim * coeff (minpoly K pb.gen) 0`. -/
lemma power_basis.norm_gen_eq_coeff_zero_minpoly [algebra K S] (pb : power_basis K S) :
  norm K pb.gen = (-1) ^ pb.dim * coeff (minpoly K pb.gen) 0 :=
begin
  rw [norm_eq_matrix_det pb.basis, det_eq_sign_charpoly_coeff, charpoly_left_mul_matrix,
    fintype.card_fin]
end

/-- Given `pb : power_basis K S`, then the norm of `pb.gen` is
`((minpoly K pb.gen).map (algebra_map K F)).roots.prod`. -/
lemma power_basis.norm_gen_eq_prod_roots [algebra K S] (pb : power_basis K S)
  (hf : (minpoly K pb.gen).splits (algebra_map K F)) :
  algebra_map K F (norm K pb.gen) =
    ((minpoly K pb.gen).map (algebra_map K F)).roots.prod :=
begin
  rw [power_basis.norm_gen_eq_coeff_zero_minpoly, ← pb.nat_degree_minpoly, ring_hom.map_mul,
    ← coeff_map, prod_roots_eq_coeff_zero_of_monic_of_split
      (monic_map _ (minpoly.monic (power_basis.is_integral_gen _)))
      ((splits_id_iff_splits _).2 hf), nat_degree_map, map_pow, ← mul_assoc, ← mul_pow],
  simp
end

end eq_prod_roots

section eq_zero_iff

lemma norm_eq_zero_iff_of_basis [is_domain S] (b : basis ι R S) {x : S} :
  algebra.norm R x = 0 ↔ x = 0 :=
begin
  have hι : nonempty ι := b.index_nonempty,
  letI := classical.dec_eq ι,
  rw algebra.norm_eq_matrix_det b,
  split,
  { rw ← matrix.exists_mul_vec_eq_zero_iff,
    rintros ⟨v, v_ne, hv⟩,
    rw [← b.equiv_fun.apply_symm_apply v, b.equiv_fun_symm_apply, b.equiv_fun_apply,
        algebra.left_mul_matrix_mul_vec_repr] at hv,
    refine (mul_eq_zero.mp (b.ext_elem $ λ i, _)).resolve_right (show ∑ i, v i • b i ≠ 0, from _),
    { simpa only [linear_equiv.map_zero, pi.zero_apply] using congr_fun hv i },
    { contrapose! v_ne with sum_eq,
      apply b.equiv_fun.symm.injective,
      rw [b.equiv_fun_symm_apply, sum_eq, linear_equiv.map_zero] } },
  { rintro rfl,
    rw [alg_hom.map_zero, matrix.det_zero hι] },
end

lemma norm_ne_zero_iff_of_basis [is_domain S] (b : basis ι R S) {x : S} :
  algebra.norm R x ≠ 0 ↔ x ≠ 0 :=
not_iff_not.mpr (algebra.norm_eq_zero_iff_of_basis b)

/-- See also `algebra.norm_eq_zero_iff'` if you already have rewritten with `algebra.norm_apply`. -/
@[simp]
lemma norm_eq_zero_iff [finite_dimensional K L] {x : L} :
  algebra.norm K x = 0 ↔ x = 0 :=
algebra.norm_eq_zero_iff_of_basis (basis.of_vector_space K L)

/-- This is `algebra.norm_eq_zero_iff` composed with `algebra.norm_apply`. -/
@[simp]
lemma norm_eq_zero_iff' [finite_dimensional K L] {x : L} :
  linear_map.det (algebra.lmul K L x) = 0 ↔ x = 0 :=
algebra.norm_eq_zero_iff_of_basis (basis.of_vector_space K L)

end eq_zero_iff

open intermediate_field

variable (K)

lemma norm_eq_norm_adjoin [finite_dimensional K L] [is_separable K L] (x : L) :
  norm K x = norm K (adjoin_simple.gen K x) ^ finrank K⟮x⟯ L :=
begin
  letI := is_separable_tower_top_of_is_separable K K⟮x⟯ L,
  let pbL := field.power_basis_of_finite_of_separable K⟮x⟯ L,
  let pbx := intermediate_field.adjoin.power_basis (is_separable.is_integral K x),
  rw [← adjoin_simple.algebra_map_gen K x, norm_eq_matrix_det (pbx.basis.smul pbL.basis) _,
    smul_left_mul_matrix_algebra_map, det_block_diagonal, norm_eq_matrix_det pbx.basis],
  simp only [finset.card_fin, finset.prod_const],
  congr,
  rw [← power_basis.finrank, adjoin_simple.algebra_map_gen K x]
end

variable {K}

section intermediate_field

lemma _root_.intermediate_field.adjoin_simple.norm_gen_eq_one {x : L}
  (hx : ¬_root_.is_integral K x) : norm K (adjoin_simple.gen K x) = 1 :=
begin
  rw [norm_eq_one_of_not_exists_basis],
  contrapose! hx,
  obtain ⟨s, ⟨b⟩⟩ := hx,
  refine is_integral_of_mem_of_fg (K⟮x⟯).to_subalgebra _ x _,
  { exact (submodule.fg_iff_finite_dimensional _).mpr (of_finset_basis b) },
  { exact intermediate_field.subset_adjoin K _ (set.mem_singleton x) }
end

lemma _root_.intermediate_field.adjoin_simple.norm_gen_eq_prod_roots (x : L)
  (hf : (minpoly K x).splits (algebra_map K F)) :
  (algebra_map K F) (norm K (adjoin_simple.gen K x)) =
    ((minpoly K x).map (algebra_map K F)).roots.prod :=
begin
  have injKxL : function.injective (algebra_map K⟮x⟯ L) := ring_hom.injective _,
  by_cases hx : _root_.is_integral K x, swap,
  { simp [minpoly.eq_zero hx, intermediate_field.adjoin_simple.norm_gen_eq_one hx] },
  have hx' : _root_.is_integral K (adjoin_simple.gen K x),
  { rwa [← is_integral_algebra_map_iff injKxL, adjoin_simple.algebra_map_gen],
    apply_instance },
  rw [← adjoin.power_basis_gen hx, power_basis.norm_gen_eq_prod_roots];
    rw [adjoin.power_basis_gen hx, minpoly.eq_of_algebra_map_eq injKxL hx'];
    try { simp only [adjoin_simple.algebra_map_gen _ _] },
  exact hf
end

end intermediate_field

section eq_prod_embeddings

open intermediate_field intermediate_field.adjoin_simple polynomial

variables (E : Type*) [field E] [algebra K E]

lemma norm_eq_prod_embeddings_gen
  (pb : power_basis K L)
  (hE : (minpoly K pb.gen).splits (algebra_map K E)) (hfx : (minpoly K pb.gen).separable) :
  algebra_map K E (norm K pb.gen) =
    (@@finset.univ (power_basis.alg_hom.fintype pb)).prod (λ σ, σ pb.gen) :=
begin
  letI := classical.dec_eq E,
  rw [power_basis.norm_gen_eq_prod_roots pb hE, fintype.prod_equiv pb.lift_equiv',
    finset.prod_mem_multiset, finset.prod_eq_multiset_prod, multiset.to_finset_val,
    multiset.erase_dup_eq_self.mpr, multiset.map_id],
  { exact nodup_roots ((separable_map _).mpr hfx) },
  { intro x, refl },
  { intro σ, rw [power_basis.lift_equiv'_apply_coe, id.def] }
end

lemma norm_eq_prod_roots [is_separable K L] [finite_dimensional K L]
  {x : L} (hF : (minpoly K x).splits (algebra_map K F)) :
  algebra_map K F (norm K x) = ((minpoly K x).map (algebra_map K F)).roots.prod ^ finrank K⟮x⟯ L :=
by rw [norm_eq_norm_adjoin K x, map_pow,
  intermediate_field.adjoin_simple.norm_gen_eq_prod_roots _ hF]

variable (F)

lemma prod_embeddings_eq_finrank_pow [algebra L F] [is_scalar_tower K L F][is_alg_closed E]
  [is_separable K F] [finite_dimensional K F] (pb : power_basis K L) :
  ∏ σ : F →ₐ[K] E, σ (algebra_map L F pb.gen) =
  ((@@finset.univ (power_basis.alg_hom.fintype pb)).prod
    (λ σ : L →ₐ[K] E, σ pb.gen)) ^ finrank L F :=
begin
  haveI : finite_dimensional L F := finite_dimensional.right K L F,
  haveI : is_separable L F := is_separable_tower_top_of_is_separable K L F,
  letI : fintype (L →ₐ[K] E) := power_basis.alg_hom.fintype pb,
  letI : ∀ (f : L →ₐ[K] E), fintype (@@alg_hom L F E _ _ _ _ f.to_ring_hom.to_algebra) := _,
  rw [fintype.prod_equiv alg_hom_equiv_sigma (λ (σ : F →ₐ[K] E), _) (λ σ, σ.1 pb.gen),
     ← finset.univ_sigma_univ, finset.prod_sigma, ← finset.prod_pow],
  refine finset.prod_congr rfl (λ σ _, _),
  { letI : algebra L E := σ.to_ring_hom.to_algebra,
    simp only [finset.prod_const, finset.card_univ],
    congr,
    rw alg_hom.card L F E },
  { intros σ,
    simp only [alg_hom_equiv_sigma, equiv.coe_fn_mk, alg_hom.restrict_domain, alg_hom.comp_apply,
         is_scalar_tower.coe_to_alg_hom'] }
end

variable (K)

/-- For `L/K` a finite separable extension of fields and `E` an algebraically closed extension
of `K`, the norm (down to `K`) of an element `x` of `L` is equal to the product of the images
of `x` over all the `K`-embeddings `σ`  of `L` into `E`. -/
lemma norm_eq_prod_embeddings [finite_dimensional K L] [is_separable K L] [is_alg_closed E]
  {x : L} : algebra_map K E (norm K x) = ∏ σ : L →ₐ[K] E, σ x :=
begin
  have hx := is_separable.is_integral K x,
  rw [norm_eq_norm_adjoin K x, ring_hom.map_pow, ← adjoin.power_basis_gen hx,
    norm_eq_prod_embeddings_gen E (adjoin.power_basis hx) (is_alg_closed.splits_codomain _)],
  { exact (prod_embeddings_eq_finrank_pow L E (adjoin.power_basis hx)).symm },
  { haveI := is_separable_tower_bot_of_is_separable K K⟮x⟯ L,
    exact is_separable.separable K _ }
end

lemma is_integral_norm [algebra S L] [algebra S K] [is_scalar_tower S K L]
  [is_separable K L] [finite_dimensional K L] {x : L} (hx : _root_.is_integral S x) :
  _root_.is_integral S (norm K x) :=
begin
  have hx' : _root_.is_integral K x := is_integral_of_is_scalar_tower _ hx,
  rw [← is_integral_algebra_map_iff (algebra_map K (algebraic_closure L)).injective,
      norm_eq_prod_roots],
  { refine (is_integral.multiset_prod (λ y hy, _)).pow _,
    rw mem_roots_map (minpoly.ne_zero hx') at hy,
    use [minpoly S x, minpoly.monic hx],
    rw ← aeval_def at ⊢ hy,
    exact minpoly.aeval_of_is_scalar_tower S x y hy },
  { apply is_alg_closed.splits_codomain },
  { apply_instance }
end

end eq_prod_embeddings

end algebra


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

! This file was ported from Lean 3 source module algebra.category.Group.adjunctions
! leanprover-community/mathlib commit ecef68622cf98f6d42c459e5b5a079aeecdd9842
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Algebra.Category.Group.Basic
import Mathbin.GroupTheory.FreeAbelianGroup

/-!
# Adjunctions regarding the category of (abelian) groups

This file contains construction of basic adjunctions concerning the category of groups and the
category of abelian groups.

## Main definitions

* `AddCommGroup.free`: constructs the functor associating to a type `X` the free abelian group with
  generators `x : X`.
* `Group.free`: constructs the functor associating to a type `X` the free group with
  generators `x : X`.
* `abelianize`: constructs the functor which associates to a group `G` its abelianization `Gᵃᵇ`.

## Main statements

* `AddCommGroup.adj`: proves that `AddCommGroup.free` is the left adjoint of the forgetful functor
  from abelian groups to types.
* `Group.adj`: proves that `Group.free` is the left adjoint of the forgetful functor from groups to
  types.
* `abelianize_adj`: proves that `abelianize` is left adjoint to the forgetful functor from
  abelian groups to groups.
-/

noncomputable section

universe u

open CategoryTheory

namespace AddCommGroupCat

open Classical

/-- The free functor `Type u ⥤ AddCommGroup` sending a type `X` to the
free abelian group with generators `x : X`.
-/
def free : Type u ⥤ AddCommGroupCat
    where
  obj α := of (FreeAbelianGroup α)
  map X Y := FreeAbelianGroup.map
  map_id' X := AddMonoidHom.ext FreeAbelianGroup.map_id_apply
  map_comp' X Y Z f g := AddMonoidHom.ext FreeAbelianGroup.map_comp_apply
#align AddCommGroup.free AddCommGroupCat.free

@[simp]
theorem free_obj_coe {α : Type u} : (free.obj α : Type u) = FreeAbelianGroup α :=
  rfl
#align AddCommGroup.free_obj_coe AddCommGroupCat.free_obj_coe

@[simp]
theorem free_map_coe {α β : Type u} {f : α → β} (x : FreeAbelianGroup α) :
    (free.map f) x = f <$> x :=
  rfl
#align AddCommGroup.free_map_coe AddCommGroupCat.free_map_coe

/-- The free-forgetful adjunction for abelian groups.
-/
def adj : free ⊣ forget AddCommGroupCat.{u} :=
  Adjunction.mkOfHomEquiv
    { homEquiv := fun X G => FreeAbelianGroup.lift.symm
      homEquiv_naturality_left_symm := by
        intros
        ext
        rfl }
#align AddCommGroup.adj AddCommGroupCat.adj

instance : IsRightAdjoint (forget AddCommGroupCat.{u}) :=
  ⟨_, adj⟩

/-- As an example, we now give a high-powered proof that
the monomorphisms in `AddCommGroup` are just the injective functions.

(This proof works in all universes.)
-/
example {G H : AddCommGroupCat.{u}} (f : G ⟶ H) [Mono f] : Function.Injective f :=
  (mono_iff_injective f).1 (show Mono ((forget AddCommGroupCat.{u}).map f) by infer_instance)

end AddCommGroupCat

namespace GroupCat

/-- The free functor `Type u ⥤ Group` sending a type `X` to the free group with generators `x : X`.
-/
def free : Type u ⥤ GroupCat where
  obj α := of (FreeGroup α)
  map X Y := FreeGroup.map
  map_id' := by
    intros
    ext1
    rfl
  map_comp' := by
    intros
    ext1
    rfl
#align Group.free GroupCat.free

/-- The free-forgetful adjunction for groups.
-/
def adj : free ⊣ forget GroupCat.{u} :=
  Adjunction.mkOfHomEquiv
    { homEquiv := fun X G => FreeGroup.lift.symm
      homEquiv_naturality_left_symm := fun X Y G f g =>
        by
        ext1
        rfl }
#align Group.adj GroupCat.adj

instance : IsRightAdjoint (forget GroupCat.{u}) :=
  ⟨_, adj⟩

end GroupCat

section Abelianization

/-- The abelianization functor `Group ⥤ CommGroup` sending a group `G` to its abelianization `Gᵃᵇ`.
 -/
def abelianize : GroupCat.{u} ⥤ CommGroupCat.{u}
    where
  obj G :=
    { α := Abelianization G
      str := by infer_instance }
  map G H f :=
    Abelianization.lift
      { toFun := fun x => Abelianization.of (f x)
        map_one' := by simp
        map_mul' := by simp }
  map_id' := by
    intros
    simp only [MonoidHom.mk_coe, coe_id]
    ext1
    rfl
  map_comp' := by
    intros
    simp only [coe_comp]
    ext1
    rfl
#align abelianize abelianize

/-- The abelianization-forgetful adjuction from `Group` to `CommGroup`.-/
def abelianizeAdj : abelianize ⊣ forget₂ CommGroupCat.{u} GroupCat.{u} :=
  Adjunction.mkOfHomEquiv
    { homEquiv := fun G A => Abelianization.lift.symm
      homEquiv_naturality_left_symm := fun G H A f g =>
        by
        ext1
        rfl }
#align abelianize_adj abelianizeAdj

end Abelianization

/-- The functor taking a monoid to its subgroup of units. -/
@[simps]
def MonCat.units : MonCat.{u} ⥤ GroupCat.{u}
    where
  obj R := GroupCat.of Rˣ
  map R S f := GroupCat.ofHom <| Units.map f
  map_id' X := MonoidHom.ext fun x => Units.ext rfl
  map_comp' X Y Z f g := MonoidHom.ext fun x => Units.ext rfl
#align Mon.units MonCat.units

/-- The forgetful-units adjunction between `Group` and `Mon`. -/
def GroupCat.forget₂MonAdj : forget₂ GroupCat MonCat ⊣ MonCat.units.{u}
    where
  homEquiv X Y :=
    { toFun := fun f => MonoidHom.toHomUnits f
      invFun := fun f => (Units.coeHom Y).comp f
      left_inv := fun f => MonoidHom.ext fun _ => rfl
      right_inv := fun f => MonoidHom.ext fun _ => Units.ext rfl }
  Unit :=
    { app := fun X => { (@toUnits X _).toMonoidHom with }
      naturality' := fun X Y f => MonoidHom.ext fun x => Units.ext rfl }
  counit :=
    { app := fun X => Units.coeHom X
      naturality' := fun X Y f => MonoidHom.ext fun x => rfl }
  homEquiv_unit X Y f := MonoidHom.ext fun _ => Units.ext rfl
  homEquiv_counit X Y f := MonoidHom.ext fun _ => rfl
#align Group.forget₂_Mon_adj GroupCat.forget₂MonAdj

instance : IsRightAdjoint MonCat.units.{u} :=
  ⟨_, GroupCat.forget₂MonAdj⟩

/-- The functor taking a monoid to its subgroup of units. -/
@[simps]
def CommMonCat.units : CommMonCat.{u} ⥤ CommGroupCat.{u}
    where
  obj R := CommGroupCat.of Rˣ
  map R S f := CommGroupCat.ofHom <| Units.map f
  map_id' X := MonoidHom.ext fun x => Units.ext rfl
  map_comp' X Y Z f g := MonoidHom.ext fun x => Units.ext rfl
#align CommMon.units CommMonCat.units

/-- The forgetful-units adjunction between `CommGroup` and `CommMon`. -/
def CommGroupCat.forget₂CommMonAdj : forget₂ CommGroupCat CommMonCat ⊣ CommMonCat.units.{u}
    where
  homEquiv X Y :=
    { toFun := fun f => MonoidHom.toHomUnits f
      invFun := fun f => (Units.coeHom Y).comp f
      left_inv := fun f => MonoidHom.ext fun _ => rfl
      right_inv := fun f => MonoidHom.ext fun _ => Units.ext rfl }
  Unit :=
    { app := fun X => { (@toUnits X _).toMonoidHom with }
      naturality' := fun X Y f => MonoidHom.ext fun x => Units.ext rfl }
  counit :=
    { app := fun X => Units.coeHom X
      naturality' := fun X Y f => MonoidHom.ext fun x => rfl }
  homEquiv_unit X Y f := MonoidHom.ext fun _ => Units.ext rfl
  homEquiv_counit X Y f := MonoidHom.ext fun _ => rfl
#align CommGroup.forget₂_CommMon_adj CommGroupCat.forget₂CommMonAdj

instance : IsRightAdjoint CommMonCat.units.{u} :=
  ⟨_, CommGroupCat.forget₂CommMonAdj⟩


/-
Author: Adrián Doña Mateo.
-/

import algebra.archimedean
import data.nat.modeq
import data.nat.sqrt
import data.zmod.basic
import tactic

import .modeq

open nat

/-!
# IMO 2017 Q1

For each integer `a₀ > 1`, define a sequence `a₀, a₁, a₂, ...` by:

  `aₙ₊₁ = √aₙ` if `√aₙ` is an integer, `aₙ + 3` otherwise, for each `n ≥ 0`.

Determine all values of `a₀` for which there is a number `A` such that `aₙ = A` for infinitely
many values of `n`.
-/

/-- The first order recurrence relation -/
def a (a₀ : ℕ) : ℕ → ℕ
| 0     := a₀
| (n+1) :=
  let k := sqrt (a n) in
  if k * k = a n then k else a n + 3

/- Convenience lemmas for determining the next term of the sequence -/
lemma a_succ_of_sq {a₀ n : ℕ} (k : ℕ) (hk : k * k = a a₀ n) :
  a a₀ (n + 1) = k :=
begin
  have hsq : sqrt (a a₀ n) = k := by rw [← hk, sqrt_eq k],
  dsimp [a],
  split_ifs,
  { assumption },
  rw hsq at h,
  contradiction
end

lemma a_succ_of_not_sq {a₀ n : ℕ} (h : ¬ ∃ k, k * k = a a₀ n) :
  a a₀ (n + 1) = a a₀ n + 3 :=
begin
  simp [a], intro h1,
  exfalso, exact h ⟨sqrt (a a₀ n), h1⟩,
end

/- Convenience lemma to determine terms of the sequence in a run of not squares -/
lemma a_no_squares {a₀ n k : ℕ} (h : ∀ i, i < k → ¬ ∃ t, t * t = a a₀ n + 3 * i) :
  ∀ i, i ≤ k → a a₀ (n + i) = a a₀ n + 3 * i :=
begin
  induction k with k ih,
  { intros i hik, rw le_zero_iff.mp hik, refl },
  intros i hik,
  have hk : ∀ i, i ≤ k → a a₀ (n + i) = a a₀ n + 3 * i :=
    ih (λ i hik, h i (lt_trans hik $ lt_succ_self k)),
  by_cases hi : i = k.succ, swap,
  {	exact hk i (le_of_lt_succ (lt_of_le_of_ne hik hi)) },
  rw [hi, add_succ, a_succ_of_not_sq _], swap,
  {	rw hk k (le_refl k), exact h k (lt_succ_self k) },
  rw [hk k (le_refl k), add_assoc, mul_succ],
end

/-- The definition of periodicity -/
def periodic (a₀ : ℕ) : Prop :=
  ∃ A, ∀ N, ∃ M, N ≤ M ∧ a a₀ M = A

/-- If two terms of the sequence are equal, so are all following terms -/
lemma rest_equal (a₀ : ℕ) (m n : ℕ) (h : a a₀ m = a a₀ n) :
  ∀ k, a a₀ (m + k) = a a₀ (n + k) :=
begin
  intro k,
  induction k with k ih,
  {	simpa },
  simp [add_succ, a, ih],
end

/--	If two terms of the sequence are equal, then successive terms that are the same
distance appart will be equal -/
lemma periodic_term_of_term_equal (a₀ : ℕ) (m n : ℕ) (hmn : m ≤ n) (h : a a₀ m = a a₀ n) :
  ∀ k, a a₀ (m + k * (n - m)) = a a₀ m :=
begin
  intro k,
  induction k with k ih,
  {	simp },
  calc a a₀ (m + k.succ * (n - m))
      = a a₀ (m + k * (n - m) + (n - m)) : by rw [succ_mul, add_assoc]
  ... = a a₀ (m + (n - m))               : rest_equal a₀ (m + k * (n - m)) m ih (n - m)
  ... = a a₀ n                           : by rw nat.add_sub_cancel' hmn
  ... = a a₀ m                           : eq.symm h
end

/-- If two different terms of the sequence are equal, then it visits the same term
infinitely many times -/
lemma periodic_of_term_equal {a₀ m n : ℕ} (hmn : m < n) (h : a a₀ m = a a₀ n) :
  periodic a₀ :=
begin
  use a a₀ m,
  intro N,
  by_cases hNm : N ≤ m,
  {	use [m, hNm] },
  have : 0 < n - m, from nat.sub_pos_of_lt hmn,
  cases archimedean.arch (N - m) this with k hk,
  simp at hk,
  let M := m + k * (n - m),
  have hM : N ≤ M, from
    calc N
        = N - m + m       : by rw nat.sub_add_cancel (le_of_not_ge hNm)
    ... ≤ k * (n - m) + m : by simp [hk]
    ... = m + k * (n - m) : by rw add_comm,
  use [M, hM],
  apply periodic_term_of_term_equal _ _ _ (le_of_lt hmn) h,
end

/-- A square is not congruent to 2 modulo 3 -/
lemma not_square_of_two_mod_three {n : ℕ} (h : n ≡ 2 [MOD 3]) :
  ¬∃ m, m * m = n :=
begin
  rintro ⟨m, rfl⟩,
  have : ¬∃ (m : zmod 3), m * m = 2 := by dec_trivial,
  apply this ⟨m, _⟩,
  norm_cast,
  rwa ←zmod.eq_iff_modeq_nat at h,
end

/--	If a term of the sequence is congruent to 2 modulo 3 then it is increasing
from that point on -/
lemma increasing_of_term_cong_two {a₀ n : ℕ} (h : a a₀ n ≡ 2 [MOD 3]) :
  ∀ m, a a₀ (n + m) = a a₀ n + 3 * m :=
begin
  intro m,
  induction m with m ih,
  {	refl },
  have h2 : a a₀ (n + m) ≡ 2 [MOD 3] := modeq.trans (modeq.symm _) h, swap,
  { rw ih, exact modeq.modeq_add_mul_mod m },
  rw [add_succ, a_succ_of_not_sq (not_square_of_two_mod_three h2), ih, add_assoc, mul_succ],
end

/-- If a term of the sequence is congruent to 2 modulo 3 then it is not periodic -/
lemma not_periodic_of_term_cong_two {a₀ n : ℕ} (h : a a₀ n ≡ 2 [MOD 3]) :
  ¬ periodic a₀ :=
begin
  rintro ⟨A, hA⟩,
  rcases hA n with ⟨m₁, hnm₁, hm₁⟩,
  have : a a₀ m₁ ≡ 2 [MOD 3],
  {	apply modeq.trans _ h,
    have : (↑(a a₀ m₁) : zmod 3) = ↑(a a₀ n + 3 * (m₁ - n)),
    {	congr,
      convert increasing_of_term_cong_two h (m₁ - n),
      rw nat.add_sub_cancel' hnm₁ },
    simp at this,
    rwa ←zmod.eq_iff_modeq_nat 3 },
  rcases hA (m₁ + 1) with ⟨m₂, hmm₂, hm₂⟩,
  have : a a₀ m₂ = A + 3 * (m₂ - m₁),
  {	rw ←hm₁,
    convert increasing_of_term_cong_two this (m₂ - m₁),
    rw nat.add_sub_cancel' (le_of_succ_le hmm₂) },
  rw hm₂ at this,
  have hmm₂ : 0 < m₂ - m₁, from nat.sub_pos_of_lt (lt_of_succ_le hmm₂),
  linarith,
end

/-- All perfect squares between a² and (a + b)² are of the form (a + k)² for some k ≤ b -/
lemma middle_squares {n a b : ℕ} (hl : a * a ≤ n) (hr : n ≤ (a + b) * (a + b)) :
  (∃ t, t * t = n) → ∃ k, k ≤ b ∧ (a + k) * (a + k) = n :=
begin
  intro hsq,
  induction b with b ih,
  {	use [0, le_refl 0], linarith },
  by_cases h1 : n ≤ (a + b) * (a + b),
  {	rcases ih h1 with ⟨k, hkb, hk⟩,
    use [k, le_succ_of_le hkb, hk] },
  by_cases h2 : n < (a + b.succ) * (a + b.succ),
  {	exfalso, exact not_exists_sq (lt_of_not_ge h1) h2 hsq },
  use [b.succ, le_refl _],
  linarith,
end

/- This long lemma takes care of each possibility for b and t mod 3. -/
lemma first_square_aux {b : ℕ} (hpos : b ≠ 0) (hb : b ≡ 0 [MOD 3] ∨ b ≡ 1 [MOD 3]) :
  let t := sqrt (b - 1) in
  ∃ (j : fin 3) n, b + 3 * n = (t + 1 + j) * (t + 1 + j) ∧
  ∀ k, k < n → ¬ ∃ r, r * r = b + 3 * k :=
begin
  intro t,
  have htb : t * t < b := lt_of_le_of_lt (sqrt_le _) (pred_lt hpos),
  have hbt : ∀ j : fin 3, b ≤ (t + 1 + j) * (t + 1 + j) :=
    λ j, le_trans (le_of_pred_lt $ lt_succ_sqrt (b - 1)) _, swap,
  {	simp [pred_eq_sub_one, ← t], apply nat.mul_self_le_mul_self, simp },
  cases hb with h0 h1,
  {	let tm : zmod 3 := t,
    fin_cases tm,
    {	-- Case : b ≡ 0 and t ≡ 0 [MOD 3]
      have ht1 : (↑1 : zmod 3) = ↑((t + 1) * (t + 1)) := by simp [← tm, h],
      have ht2 : (↑1 : zmod 3) = ↑((t + 2) * (t + 2)) := by { simp [← tm, h], ring },
      have ht3 : (↑0 : zmod 3) = ↑((t + 3) * (t + 3)) := by simp [← tm, h],
      rcases modeq.add_mul_mod_of_modeq (hbt 2) (modeq.trans h0 _) with ⟨n, hn⟩, swap,
      {	rwa ← zmod.eq_iff_modeq_nat 3 },
      use [2, n, hn],
      change b + 3 * n = (t + 3) * (t + 3) at hn,
      intros k hkn hsq,
      -- Show that (t + 3)² is the first square by eliminating the intermediate ones
      rcases @middle_squares _ t 3 _ _ hsq with ⟨r, hlr, hr⟩, swap,
      { linarith }, swap,
      { rw ← hn, linarith },
      interval_cases r,
      {	linarith },
      { apply @modeq.not_modeq_of_lt 0 1 3 (by norm_num) (by norm_num),
        apply modeq.trans (modeq.trans h0.symm $ modeq.modeq_add_mul_mod k),
        apply modeq.trans _ ((zmod.eq_iff_modeq_nat 3).mp ht1).symm,
        rwa hr },
      {	apply @modeq.not_modeq_of_lt 0 1 3 (by norm_num) (by norm_num),
        apply modeq.trans (modeq.trans h0.symm $ modeq.modeq_add_mul_mod k),
        apply modeq.trans _ ((zmod.eq_iff_modeq_nat 3).mp ht2).symm,
        rwa hr },
      { rw ← hn at hr, linarith } },
    {	-- Case : b ≡ 0 and t ≡ 1 [MOD 3]
      have ht1 : (↑1 : zmod 3) = ↑((t + 1) * (t + 1)) := by { simp [← tm, h], ring },
      have ht2 : (↑0 : zmod 3) = ↑((t + 2) * (t + 2)) := by { simp [← tm, h], ring },
      rcases modeq.add_mul_mod_of_modeq (hbt 1) (modeq.trans h0 _) with ⟨n, hn⟩, swap,
      {	rwa ← zmod.eq_iff_modeq_nat 3 },
      use [1, n, hn],
      change b + 3 * n = (t + 2) * (t + 2) at hn,
      intros k hkn hsq,
      -- Show that (t + 2)² by eliminating the previous one
      rcases @middle_squares _ t 2 _ _ hsq with ⟨r, hlr, hr⟩, swap,
      {	linarith }, swap,
      { rw ← hn, linarith },
      interval_cases r,
      { linarith },
      { apply @modeq.not_modeq_of_lt 0 1 3 (by norm_num) (by norm_num),
        apply modeq.trans (modeq.trans h0.symm $ modeq.modeq_add_mul_mod k),
        apply modeq.trans _ ((zmod.eq_iff_modeq_nat 3).mp ht1).symm,
        rwa hr },
      { rw ← hn at hr, linarith } },
    {	-- Case : b ≡ 0 and t ≡ 2 [MOD 3]
      have ht1 : (↑0 : zmod 3) = ↑((t + 1) * (t + 1)) := by { simp [← tm, h], ring },
      rcases modeq.add_mul_mod_of_modeq (hbt 0) (modeq.trans h0 _) with ⟨n, hn⟩, swap,
      { rwa ← zmod.eq_iff_modeq_nat 3 },
      use [0, n, hn],
      change b + 3 * n = (t + 1) * (t + 1) at hn,
      intros k hkn,
      -- There is no possible square before it, so (t + 1)² must be the first
      apply not_exists_sq (lt_of_lt_of_le htb _),
      {	rw ← hn, linarith },
      linarith } },
  {	let tm : zmod 3 := t,
    fin_cases tm,
    {	-- Case : b ≡ 1 and t ≡ 0 [MOD 3]
      have ht1 : (↑1 : zmod 3) = ↑((t + 1) * (t + 1)) := by { simp [← tm, h] },
      rcases modeq.add_mul_mod_of_modeq (hbt 0) (modeq.trans h1 _) with ⟨n, hn⟩, swap,
      {	rwa ← zmod.eq_iff_modeq_nat 3 },
      use [0, n, hn],
      change b + 3 * n = (t + 1) * (t + 1) at hn,
      intros k hkn,
      -- There is no possible square before it, so (t + 1)² must be the first
      apply not_exists_sq (lt_of_lt_of_le htb _),
      {	rw ← hn, linarith },
      linarith },
    { -- Case : b ≡ 1 and t ≡ 1 [MOD 3]
      have ht1 : (↑1 : zmod 3) = ↑((t + 1) * (t + 1)) := by { simp [← tm, h], ring },
      rcases modeq.add_mul_mod_of_modeq (hbt 0) (modeq.trans h1 _) with ⟨n, hn⟩, swap,
      {	rwa ← zmod.eq_iff_modeq_nat 3 },
      use [0, n, hn],
      change b + 3 * n = (t + 1) * (t + 1) at hn,
      intros k hkn,
      -- There is no possible square before it, so (t + 1)² must be the first
      apply not_exists_sq (lt_of_lt_of_le htb _),
      {	rw ← hn, linarith },
      linarith },
    { -- Case : b ≡ 1 and t ≡ 2 [MOD 3]
      have ht1 : (↑0 : zmod 3) = ↑((t + 1) * (t + 1)) := by { simp [← tm, h], ring },
      have ht2 : (↑1 : zmod 3) = ↑((t + 2) * (t + 2)) := by { simp [← tm, h], ring },
      rcases modeq.add_mul_mod_of_modeq (hbt 1) (modeq.trans h1 _) with ⟨n, hn⟩, swap,
      {	rwa ← zmod.eq_iff_modeq_nat 3 },
      use [1, n, hn],
      change b + 3 * n = (t + 2) * (t + 2) at hn,
      intros k hkn hsq,
      -- Show that (t + 2)² by eliminating the previous one
      rcases @middle_squares _ t 2 _ _ hsq with ⟨r, hlr, hr⟩, swap,
      {	linarith }, swap,
      { rw ← hn, linarith },
      interval_cases r,
      { linarith },
      { apply @modeq.not_modeq_of_lt 0 1 3 (by norm_num) (by norm_num),
        apply modeq.trans ((zmod.eq_iff_modeq_nat 3).mp ht1),
        apply modeq.trans _ (modeq.trans (modeq.modeq_add_mul_mod k).symm h1),
        rwa hr },
      { rw ← hn at hr, linarith }	} },
end

/-- If ¬ aₙ ≡ 2 [MOD 3] and aₙ > 9 then the next perfect square in the sequence is one of
t², (t+1)² or (t+2)², where t is the largest natural number such that t² ≤ aₙ -/
lemma first_square {a₀ n : ℕ} (h1 : a a₀ n ≡ 0 [MOD 3] ∨ a a₀ n ≡ 1 [MOD 3]) (h2 : a a₀ n ≠ 0) :
  let t := sqrt (a a₀ n - 1) in
  ∃ (j : fin 3) m, n ≤ m ∧ a a₀ m = (t + 1 + j) * (t + 1 + j) ∧
  ∀ k, n ≤ k → k < m → ¬ ∃ r, r * r = a a₀ k :=
begin
  rcases first_square_aux h2 h1 with ⟨j, k, hsq, hfirst⟩,
  have hk : ∀ i, i ≤ k → a a₀ (n + i) = a a₀ n + 3 * i := a_no_squares hfirst,
  use [j, n + k, by linarith], split,
  { rw ← hsq, exact hk k (le_refl k) },
  intros m hnm hmnk,
  have hm : m - n < k := (nat.sub_lt_left_iff_lt_add hnm).mpr hmnk,
  rw [← nat.add_sub_cancel' hnm, hk (m - n) (le_of_lt hm)],
  exact hfirst (m - n) hm,
end

/-- If ¬ aₙ ≡ 2 [MOD 3] and aₙ > 9 then there is an index m > n such that aₘ < aₙ -/
lemma term_lt_of_term_congr_0_or_1 {a₀ n : ℕ} (h : a a₀ n ≡ 0 [MOD 3] ∨ a a₀ n ≡ 1 [MOD 3]) (h9 : 9 < a a₀ n) :
  ∃ m, n < m ∧ a a₀ m < a a₀ n :=
begin
  rcases first_square h (by linarith) with ⟨j, m, hnm, ham, hfirst⟩,
  use [m + 1, by linarith],
  rw a_succ_of_sq _ ham.symm,
  have h9 : 9 ≤ a a₀ n - 1 := le_pred_of_lt h9,
  have h3 : 3 ≤ sqrt (a a₀ n - 1) := le_sqrt.mpr h9,
  have h2 : 2 ≤ sqrt (a a₀ n - 1) := le_of_succ_le h3,
  calc sqrt (a a₀ n - 1) + 1 + ↑j
      ≤ sqrt (a a₀ n - 1) + 3
    :	by { have : ↑j ≤ 2, from le_of_lt_succ (fin.is_lt j),	linarith }
  ... ≤ sqrt (a a₀ n - 1) + sqrt (a a₀ n - 1)
    : by linarith
  ... = 2 * sqrt (a a₀ n - 1)
    : by rw two_mul
  ... ≤ sqrt (a a₀ n - 1) * sqrt (a a₀ n - 1)
    : by { apply mul_le_mul h2, refl, repeat {linarith} }
  ... ≤ a a₀ n - 1
    : by apply sqrt_le
  ... < a a₀ n
    :	by { rw ←pred_eq_sub_one, apply pred_lt, linarith }
end

/-- A multiple of 3 is always followed by a multiple of 3 -/
lemma mul_three_of_mul_three {a₀ n : ℕ} (h : a a₀ n ≡ 0 [MOD 3]) :
  ∀ m, n ≤ m → a a₀ m ≡ 0 [MOD 3] :=
begin
  have : ∀ k, a a₀ (n + k) ≡ 0 [MOD 3],
  { intro k,
    induction k with k ih,
    {	exact h },
    rw add_succ, simp [a],
    split_ifs with hsq,
    {	rw [← hsq, modeq.modeq_zero_iff, prime.dvd_mul] at ih,
      {	cases ih;	{ exact modeq.modeq_zero_iff.mpr ih } },
      norm_num },
    rw ←add_zero 0,
    apply modeq.modeq_add,
    { assumption },
    simp [modeq] },
  intros m hnm,
  convert this (m - n),
  rw nat.add_sub_cancel' hnm,
end

/-- If aₙ ∈ {3,6,9}, then the sequence visits three infinitely many times -/
lemma periodic_of_three_six_nine {a₀ n : ℕ} (h : a a₀ n = 3 ∨ a a₀ n = 6 ∨ a a₀ n = 9) :
  periodic a₀ :=
begin
  have h9 : ∀ n, a a₀ n = 9 → a a₀ (n+1) = 3 :=
    λ n h, a_succ_of_sq 3 (by { rw h, refl }),
  have h6 : ∀ n, a a₀ n = 6 → a a₀ (n+1) = 9,
  {	intros n h, convert a_succ_of_not_sq _,	{	rw h },
    rw h,	apply @not_exists_sq 6 2; norm_num },
  have h3 : ∀ n, a a₀ n = 3 → a a₀ (n+1) = 6,
  {	intros n h,	convert a_succ_of_not_sq _,	{ rw h},
    rw h,	apply @not_exists_sq 3 1; norm_num },
  have hper : (∃ n, a a₀ n = 3) → periodic a₀,
  {	rintro ⟨n, hn⟩,
    apply @periodic_of_term_equal _ n (n + 3) (by linarith),
    rw [hn, h9 _ (h6 _ (h3 _ hn))] },
  rcases h with c3 | c6 | c9,
  {	exact hper ⟨n, c3⟩ },
  { have : a a₀ (n+1) = 9, from h6 _ c6,
    have : a a₀ (n+2) = 3, from h9 _ this,
    exact hper ⟨n+2, this⟩ },
  { have : a a₀ (n+1) = 3, from h9 _ c9,
    exact hper ⟨n+1, this⟩ },
end

/-- Multiples of 3 that are ≤ 9 -/
lemma mul_three_le_nine {x : ℕ} (h9 : x ≤ 9) (h3 : 3 ∣ x) : x = 0 ∨ x = 3 ∨ x = 6 ∨ x = 9 :=
begin
    cases h3 with k h3k,
    have : k ≤ 3 := by linarith,
    interval_cases k; dec_trivial!,
end

/- The following two theorems use the fact that < on ℕ is well founded to find certain elements
in a set and then in the tail of the sequence a a₀ n -/
theorem has_le_b {b : ℕ} (S : set ℕ) (hS : S.nonempty)
  (h : ∀ x ∈ S, b < x → ∃ y ∈ S, y < x) :	∃ x ∈ S, x ≤ b :=
begin
  rcases well_founded.has_min lt_wf S hS with ⟨x, xS, hx⟩,
  use [x, xS],
  by_contradiction hbx,
  rcases h x xS (lt_of_not_ge hbx) with ⟨y, yS, hy⟩,
  exact hx y yS hy,
end

theorem term_le_b {a₀ n b : ℕ}
  (h : ∀ m, n ≤ m → b < a a₀ m → ∃ k, m < k ∧ a a₀ k < a a₀ m) :
  ∃ m, n ≤ m ∧ a a₀ m ≤ b :=
begin
  let S := { x | ∃ m, n ≤ m ∧ a a₀ m = x },
  have hS : ∀ x ∈ S, b < x → ∃ y ∈ S, y < x,
  {	rintros x ⟨m, hnm, rfl⟩ hbx,
    rcases h m hnm hbx with ⟨k, hmk, hk⟩,
    use [a a₀ k, ⟨k, le_trans hnm (le_of_lt hmk), rfl⟩, hk] },
  rcases has_le_b S ⟨a a₀ n, n, le_refl n, rfl⟩  hS with ⟨x, ⟨m, hnm, rfl⟩, hxb⟩,
  use [m, hnm, hxb],
end

/-- If aₙ ≡ 0 [MOD 3], then there is an index m > n such that aₘ = 3 -/
lemma periodic_of_term_cong_zero {a₀ n : ℕ} (h : a a₀ n ≡ 0 [MOD 3]) (h1 : ∀ m, 1 < a a₀ m):
  periodic a₀ :=
begin
  have hm9 : ∃ m, n ≤ m ∧ a a₀ m ≤ 9 :=
    term_le_b (λ m hnm h9, term_lt_of_term_congr_0_or_1 (or.inl $ mul_three_of_mul_three h m hnm) h9),
  rcases hm9 with ⟨m, hnm, hm⟩,
  have hm3 : 3 ∣ a a₀ m := modeq.modeq_zero_iff.mp (mul_three_of_mul_three h m hnm),
  cases mul_three_le_nine hm hm3 with _ h369,
  { have : 1 < a a₀ m := h1 m, linarith },
  exact periodic_of_three_six_nine h369,
end

/-- There is a term congruent to 2 mod 3 whenever some term is 4 or 7 -/
lemma term_cong_two_of_four_seven {a₀ n : ℕ} (h : a a₀ n = 4 ∨ a a₀ n = 7) :
  ∃ m, n < m ∧ a a₀ m ≡ 2 [MOD 3] :=
begin
  have h4 : ∀ n, a a₀ n = 4 → a a₀ (n+1) = 2 :=
    λ n hn, a_succ_of_sq 2 (by { rw hn, refl }),
  have h7 : ∀ n, a a₀ n = 7 → a a₀ (n+1) = 10,
  { intros n han, convert a_succ_of_not_sq _, { rw han },
    rw han,	apply @not_exists_sq 7 2; norm_num },
  have h10 : ∀ n, a a₀ n = 10 → a a₀ (n+1) = 13,
  { intros n han, convert a_succ_of_not_sq _, { rw han },
    rw han, apply @not_exists_sq 10 3; norm_num },
  have h13 : ∀ n, a a₀ n = 13 → a a₀ (n+1) = 16,
  { intros n han, convert a_succ_of_not_sq _, { rw han },
    rw han, apply @not_exists_sq 13 3; norm_num },
  have h16 : ∀ n, a a₀ n = 16 → a a₀ (n+1) = 4 :=
    λ n hn, a_succ_of_sq 4 (by { rw hn, refl }),
  cases h with c4 c7,
  {	use [n + 1, lt_succ_self n],
    have : a a₀ (n+1) = 2, from h4 _ c4,
    rw this },
  { use [n + 5, by linarith],
    have : a a₀ (n+1) = 10, from h7 _ c7,
    have : a a₀ (n+2) = 13, from h10 _ this,
    have : a a₀ (n+3) = 16, from h13 _ this,
    have : a a₀ (n+4) = 4, from h16 _ this,
    have : a a₀ (n+5) = 2, from h4 _ this,
    rw this },
end

/-- All numbers ≤ 9 that are congruent to 1 mod 3 -/
lemma eq_1_4_7_of_cong_1_le_9 {x : ℕ} (h9 : x ≤ 9) (h1 : x ≡ 1 [MOD 3]) :
  x = 1 ∨ x = 4 ∨ x = 7 :=
begin
  by_cases h : x < 1,
  {	interval_cases x, contradiction },
  have hx1 : 1 ≤ x, from le_of_not_lt h,
  have : 3 ∣ x - 1, from (modeq.modeq_iff_dvd' hx1).mp (modeq.symm h1),
  cases this with k h3k,
  have : x = 3 * k + 1, { rw [←nat.sub_add_cancel hx1, h3k] },
  have : k ≤ 8, linarith,
  interval_cases k; dec_trivial!,
end

lemma congr_one_or_two_of_congr_one {a₀ n : ℕ} (h : a a₀ n ≡ 1 [MOD 3]) :
  ∀ m, n ≤ m → a a₀ m ≡ 1 [MOD 3] ∨ a a₀ m ≡ 2 [MOD 3] :=
begin
  have : ∀ k, a a₀ (n + k) ≡ 1 [MOD 3] ∨ a a₀ (n + k) ≡ 2 [MOD 3],
  {	intro k, induction k with k ih,
    {	left, assumption },
    rw add_succ,
    cases ih with h1 h2,
    {	by_cases hsq : ∃ t, t * t = a a₀ (n + k),
      {	cases hsq with t ht,
        rw a_succ_of_sq t ht,
        rw ← ht at h1,
        have h12 : ↑t = ↑1 ∨ ↑t = ↑2 := @zmod.one_or_two_of_sq_eq_one ↑t _, swap,
        {	convert (zmod.eq_iff_modeq_nat 3).mpr h1, norm_cast },
        cases h12 with h1 h2,
        {	left, exact (zmod.eq_iff_modeq_nat 3).mp h1 },
        { right, exact (zmod.eq_iff_modeq_nat 3).mp h2 } },
      rw a_succ_of_not_sq hsq,
      left, exact modeq.trans (modeq.modeq_add_mul_mod 1) h1 },
    right, rw increasing_of_term_cong_two h2 1,
    exact modeq.trans (modeq.modeq_add_mul_mod 1) h2 },
  intros m hnm,
  convert this (m - n);	{ rw nat.add_sub_cancel' hnm }
end

/-- If aₙ ≡ 1 [MOD 3], then there is an index m > n such that aₘ ≡ 2 [MOD 3] -/
lemma term_cong_two_of_term_cong_one {a₀ n : ℕ} (hn1 : a a₀ n ≡ 1 [MOD 3]) (h1 : ∀ m, 1 < a a₀ m) :
  ∃ m, n ≤ m ∧ a a₀ m ≡ 2 [MOD 3] :=
begin
  by_contradiction,
  have hm1 : ∀ m, n ≤ m → a a₀ m ≡ 1 [MOD 3],
  {	intros m hnm,
    cases congr_one_or_two_of_congr_one hn1 m hnm with hm1 hm2,
    { assumption },
    { exfalso, exact h ⟨m, hnm, hm2⟩ } },
  have hm9 : ∃ m, n ≤ m ∧ a a₀ m ≤ 9 :=
    term_le_b (λ m hnm h9, term_lt_of_term_congr_0_or_1 (or.inr $ hm1 m hnm) h9),
  rcases hm9 with ⟨m, hnm, hm⟩,
  cases eq_1_4_7_of_cong_1_le_9 hm (hm1 m hnm) with _ h47,
  { have : 1 < a a₀ m := h1 m, linarith },
  apply h,
  rcases term_cong_two_of_four_seven h47 with ⟨k, hmk, hk⟩,
  use [k, le_of_lt (lt_of_le_of_lt hnm hmk), hk],
end

lemma all_gt_one_of_gt_one {a₀ : ℕ} (h : 1 < a₀) :
  ∀ n, 1 < a a₀ n :=
begin
  intro n, induction n with n ih,
  { assumption },
  by_cases hsq : ∃ t, t * t = a a₀ n,
  { cases hsq with t ht, rw a_succ_of_sq t ht, rw ← ht at ih,
    by_contradiction,
    have : t * t ≤ 1 := mul_le_one (le_of_not_lt h) t.zero_le (le_of_not_lt h),
    linarith },
  rw a_succ_of_not_sq hsq, linarith,
end

theorem imo2017q1 (a₀ : ℕ) (h : 1 < a₀) : periodic a₀ ↔ 3 ∣ a₀ :=
begin
  have h1 : ∀ n, 1 < a a₀ n := all_gt_one_of_gt_one h,
  split, swap,
  { intro h3, apply @periodic_of_term_cong_zero _ 0 _ h1,
    apply modeq.symm,
    simp [a], rw modeq.modeq_iff_dvd' (a₀.zero_le),
    assumption },
  intro hper,
  have ub : a₀ % 3 < 3 := mod_lt _ (by norm_num),
  interval_cases a₀ % 3,
  {	exact dvd_of_mod_eq_zero h_1 },
  { have ha1 : a a₀ 0 ≡ 1 [MOD 3] :=
      modeq.trans (modeq.symm $ modeq.mod_modeq _ _) (by { simp [a], rw h_1 }),
    exfalso,
    rcases term_cong_two_of_term_cong_one ha1 h1 with ⟨m, _, hm⟩,
    exact not_periodic_of_term_cong_two hm hper },
  { have h2 : a a₀ 0 ≡ 2 [MOD 3] :=
      modeq.trans (modeq.symm $ modeq.mod_modeq _ _) (by { simp [a], rw h_1 }),
    exfalso,
    exact not_periodic_of_term_cong_two h2 hper },
end


import analysis.complex.polynomial
import data.polynomial.taylor
import data.nat.digits
import data.fin.vec_notation

open polynomial
open_locale big_operators

-- ℤ is a ring where there is unique factorization
example : unique_factorization_monoid ℤ := by apply_instance

-- any integer can be expressed uniquely by ±1 times a product of primes
-- N.B. this is not true for 0, since the empty product is 1,
-- and 0 is not a prime. the only product that can equal 0 must have 0 in it
example (x : ℤ) (hx : x ≠ 0) : ∃ (f : multiset ℤ) (hf : ∀ p ∈ f, prime p),
  f.prod = x ∨ f.prod = -x :=
begin
  obtain ⟨f, hf, u, rfl⟩ := unique_factorization_monoid.exists_prime_factors x hx,
  refine ⟨f, hf, _⟩,
  rcases int.units_eq_one_or u with rfl|rfl;
  simp [units.coe_neg]
end

-- ℂ[X] is a ring where there is unique factorization
example : unique_factorization_monoid (polynomial ℂ) := by apply_instance

-- any polynomial (over the complexes) can be uniquely expressed as
-- P(X) = α(X − α₁)(X − α₂)...(X − αₙ)
-- where α, α₁, α₂, ..., αₙ are complex numbers
example (p : polynomial ℂ) : ∃ (α : ℂ) (f : multiset ℂ),
  p = α • (f.map (λ a, (X : polynomial ℂ) - C a)).prod :=
begin
  refine ⟨p.leading_coeff, p.roots, _⟩,
  rw [smul_eq_C_mul, C_leading_coeff_mul_prod_multiset_X_sub_C],
  rw ←splits_iff_card_roots,
  exact is_alg_closed.splits p
end

-- √2 is a root of Y ^ 2 − 2, so is an algebraic number
example : is_algebraic ℤ (real.sqrt 2) :=
begin
  refine ⟨X ^ 2 - 2, _, by simp⟩,
  intro H,
  simpa using congr_arg (eval 0) H
end

-- Need this to express that a polynomial is an algebraic function
local attribute [instance] polynomial.has_smul_pi polynomial.has_smul_pi'
  polynomial.algebra_pi

-- f(X) = √(X ^ 3 − 3 X + 1),
-- which is a root of Y ^ 2 − (X ^ 3 − 3 X + 1), is an algebraic function
example : is_algebraic (polynomial ℤ) (λ x, complex.cpow (x ^ 3 - 3 • x + 1) (1 / 2)) :=
begin
  refine ⟨X ^ 2 - C (X ^ 3 - 3 • X + 1), _, _⟩,
  { intro H,
    replace H := congr_arg (eval 0) (congr_arg (eval 0) H),
    simpa only [nsmul_eq_mul, eval_sub, eval_pow, eval_X, eval_add, eval_C,
                eval_mul, eval_one, mul_zero, eval_zero] using H },
  { ext1 x,
    suffices : ((x ^ 3 - 3 * x + 1) ^ (2 : ℂ)⁻¹) ^ 2 - (x ^ 3 - 3 * x + 1) = 0,
    { simpa only [nsmul_eq_mul, one_div, complex.cpow_eq_pow, _root_.map_add,
      _root_.map_sub, nat.cast_bit1, map_pow, _root_.map_mul, _root_.map_one, aeval_one,
      pi.sub_apply, nat.cast_one, aeval_X, pi.pow_apply, aeval_C, C_bit1, aeval_bit1,
      pi.add_apply, algebra_map_pi_eq_aeval, pi.one_apply] },
    have h2 : (2 : ℂ) = (2 : ℝ),
    { simp only [complex.of_real_bit0, complex.of_real_one] },
    rw [←complex.cpow_nat_cast, ←complex.cpow_mul],
    { simp only [nat.cast_bit0, nat.cast_one, inv_mul_cancel_of_invertible,
                 complex.cpow_one, sub_self] },
    { rw [h2, ←complex.of_real_inv, mul_comm, ←complex.real_smul,
          complex.smul_im, smul_eq_mul, ←inv_mul_lt_iff, inv_inv],
      { refine lt_trans _ (complex.neg_pi_lt_log_im _),
        simpa only [two_mul, add_neg_lt_iff_le_add', add_right_neg,
                    right.neg_neg_iff] using real.pi_pos},
      { simp only [inv_pos, zero_lt_bit0, zero_lt_one] } },
    { rw [h2, ←complex.of_real_inv, mul_comm, ←complex.real_smul,
          complex.smul_im, smul_eq_mul, inv_mul_le_iff],
      { refine (complex.log_im_le_pi (x ^ 3 - 3 * x + 1)).trans _,
        simpa only [two_mul, le_add_iff_nonneg_left] using real.pi_pos.le },
      { exact zero_lt_two } } }
end

-- P(X) : ℂ[X] Taylor expansion at α
example (p : polynomial ℂ) (α : ℂ) : ∃ (q : polynomial ℂ) (hq : q.nat_degree = p.nat_degree),
  p = q.sum (λ i a, a • (X - C α) ^ i) :=
begin
  refine ⟨taylor α p, nat_degree_taylor _ _, _⟩,
  simp_rw [smul_eq_C_mul, sum_taylor_eq]
end

example : 321 = nat.of_digits 10 [1, 2, 3] :=
begin
  simp only [nat.of_digits_eq_foldr, add_zero, nat.cast_id, mul_zero, list.foldr],
  norm_num
end

example (m b : ℕ) (hp : 2 ≤ b) :
  ((nat.digits b m).map_with_index (λ i a, a * b ^ i)).sum = m :=
by rw [←nat.of_digits_eq_sum_map_with_index, nat.of_digits_digits]

-- every number `m` can be written as a sum over "digits" in base p
-- note, no hypothesis of `prime p` needed, just that `2 ≤ p`, which all primes are
example (m p : ℕ) (hp : 2 ≤ p) : ∃ (n : ℕ) (f : fin n → ℕ) (hf : ∀ i, f i < p),
  ∑ i, f i * p ^ (i : ℕ) = m :=
begin
  let l := nat.digits p m,
  refine ⟨l.length, λ i, l.nth_le i i.is_lt, λ _, nat.digits_lt_base hp (list.nth_le_mem _ _ _), _⟩,
  rw [←nat.of_digits_digits p m, nat.of_digits_eq_sum_map_with_index, ←list.sum_of_fn,
      list.map_with_index_eq_of_fn]
end

example (f : fin 3 → ℕ) (hf : f = ![5, 3, 6]) :
  320 = ∑ i, f i * 7 ^ (i : ℕ) :=
by norm_num [hf, fin.sum_univ_succ]

example : nat.digits 7 320 = [5, 3, 6] :=
by norm_num


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

universes v u₁ u₂

namespace Mathlib

/-!
# Isomorphisms about functors which preserve (co)limits

If `G` preserves limits, and `C` and `D` have limits, then for any diagram `F : J ⥤ C` we have a
canonical isomorphism `preserves_limit_iso : G.obj (limit F) ≅ limit (F ⋙ G)`.
We also show that we can commute `is_limit.lift` of a preserved limit with `functor.map_cone`:
`(preserves_limit.preserves t).lift (G.map_cone c₂) = G.map (t.lift c₂)`.

The duals of these are also given. For functors which preserve (co)limits of specific shapes, see
`preserves/shapes.lean`.
-/

namespace category_theory

@[simp] theorem preserves_lift_map_cone {C : Type u₁} [category C] {D : Type u₂} [category D]
    (G : C ⥤ D) {J : Type v} [small_category J] (F : J ⥤ C) [limits.preserves_limit F G]
    (c₁ : limits.cone F) (c₂ : limits.cone F) (t : limits.is_limit c₁) :
    limits.is_limit.lift (limits.preserves_limit.preserves t) (functor.map_cone G c₂) =
        functor.map G (limits.is_limit.lift t c₂) :=
  sorry

/--
If `G` preserves limits, we have an isomorphism from the image of the limit of a functor `F`
to the limit of the functor `F ⋙ G`.
-/
def preserves_limit_iso {C : Type u₁} [category C] {D : Type u₂} [category D] (G : C ⥤ D)
    {J : Type v} [small_category J] (F : J ⥤ C) [limits.preserves_limit F G] [limits.has_limit F]
    [limits.has_limit (F ⋙ G)] : functor.obj G (limits.limit F) ≅ limits.limit (F ⋙ G) :=
  limits.is_limit.cone_point_unique_up_to_iso
    (limits.preserves_limit.preserves (limits.limit.is_limit F)) (limits.limit.is_limit (F ⋙ G))

@[simp] theorem preserves_limits_iso_hom_π_assoc {C : Type u₁} [category C] {D : Type u₂}
    [category D] (G : C ⥤ D) {J : Type v} [small_category J] (F : J ⥤ C)
    [limits.preserves_limit F G] [limits.has_limit F] [limits.has_limit (F ⋙ G)] (j : J) {X' : D}
    (f' : functor.obj (F ⋙ G) j ⟶ X') :
    iso.hom (preserves_limit_iso G F) ≫ limits.limit.π (F ⋙ G) j ≫ f' =
        functor.map G (limits.limit.π F j) ≫ f' :=
  sorry

@[simp] theorem preserves_limits_iso_inv_π_assoc {C : Type u₁} [category C] {D : Type u₂}
    [category D] (G : C ⥤ D) {J : Type v} [small_category J] (F : J ⥤ C)
    [limits.preserves_limit F G] [limits.has_limit F] [limits.has_limit (F ⋙ G)] (j : J) {X' : D}
    (f' : functor.obj G (functor.obj F j) ⟶ X') :
    iso.inv (preserves_limit_iso G F) ≫ functor.map G (limits.limit.π F j) ≫ f' =
        limits.limit.π (F ⋙ G) j ≫ f' :=
  sorry

@[simp] theorem lift_comp_preserves_limits_iso_hom_assoc {C : Type u₁} [category C] {D : Type u₂}
    [category D] (G : C ⥤ D) {J : Type v} [small_category J] (F : J ⥤ C)
    [limits.preserves_limit F G] [limits.has_limit F] [limits.has_limit (F ⋙ G)] (t : limits.cone F)
    {X' : D} (f' : limits.limit (F ⋙ G) ⟶ X') :
    functor.map G (limits.limit.lift F t) ≫ iso.hom (preserves_limit_iso G F) ≫ f' =
        limits.limit.lift (F ⋙ G) (functor.map_cone G t) ≫ f' :=
  sorry

@[simp] theorem preserves_desc_map_cocone {C : Type u₁} [category C] {D : Type u₂} [category D]
    (G : C ⥤ D) {J : Type v} [small_category J] (F : J ⥤ C) [limits.preserves_colimit F G]
    (c₁ : limits.cocone F) (c₂ : limits.cocone F) (t : limits.is_colimit c₁) :
    limits.is_colimit.desc (limits.preserves_colimit.preserves t) (functor.map_cocone G c₂) =
        functor.map G (limits.is_colimit.desc t c₂) :=
  sorry

/--
If `G` preserves colimits, we have an isomorphism from the image of the colimit of a functor `F`
to the colimit of the functor `F ⋙ G`.
-/
-- TODO: think about swapping the order here

def preserves_colimit_iso {C : Type u₁} [category C] {D : Type u₂} [category D] (G : C ⥤ D)
    {J : Type v} [small_category J] (F : J ⥤ C) [limits.preserves_colimit F G]
    [limits.has_colimit F] [limits.has_colimit (F ⋙ G)] :
    functor.obj G (limits.colimit F) ≅ limits.colimit (F ⋙ G) :=
  limits.is_colimit.cocone_point_unique_up_to_iso
    (limits.preserves_colimit.preserves (limits.colimit.is_colimit F))
    (limits.colimit.is_colimit (F ⋙ G))

@[simp] theorem ι_preserves_colimits_iso_inv_assoc {C : Type u₁} [category C] {D : Type u₂}
    [category D] (G : C ⥤ D) {J : Type v} [small_category J] (F : J ⥤ C)
    [limits.preserves_colimit F G] [limits.has_colimit F] [limits.has_colimit (F ⋙ G)] (j : J)
    {X' : D} (f' : functor.obj G (limits.colimit F) ⟶ X') :
    limits.colimit.ι (F ⋙ G) j ≫ iso.inv (preserves_colimit_iso G F) ≫ f' =
        functor.map G (limits.colimit.ι F j) ≫ f' :=
  sorry

@[simp] theorem ι_preserves_colimits_iso_hom_assoc {C : Type u₁} [category C] {D : Type u₂}
    [category D] (G : C ⥤ D) {J : Type v} [small_category J] (F : J ⥤ C)
    [limits.preserves_colimit F G] [limits.has_colimit F] [limits.has_colimit (F ⋙ G)] (j : J)
    {X' : D} (f' : limits.colimit (F ⋙ G) ⟶ X') :
    functor.map G (limits.colimit.ι F j) ≫ iso.hom (preserves_colimit_iso G F) ≫ f' =
        limits.colimit.ι (F ⋙ G) j ≫ f' :=
  sorry

@[simp] theorem preserves_colimits_iso_inv_comp_desc {C : Type u₁} [category C] {D : Type u₂}
    [category D] (G : C ⥤ D) {J : Type v} [small_category J] (F : J ⥤ C)
    [limits.preserves_colimit F G] [limits.has_colimit F] [limits.has_colimit (F ⋙ G)]
    (t : limits.cocone F) :
    iso.inv (preserves_colimit_iso G F) ≫ functor.map G (limits.colimit.desc F t) =
        limits.colimit.desc (F ⋙ G) (functor.map_cocone G t) :=
  sorry

end Mathlib


/-
Copyright (c) 2021 Yury Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury Kudryashov
-/
import analysis.box_integral.partition.basic

/-!
# Tagged partitions

A tagged (pre)partition is a (pre)partition `π` enriched with a tagged point for each box of
‵π`. For simplicity we require that the function `box_integral.tagged_prepartition.tag` is defined
on all boxes `J : box ι` but use its values only on boxes of the partition. Given `π :
box_integral.tagged_partition I`, we require that each `box_integral.tagged_partition π J` belongs
to `box_integral.box.Icc I`. If for every `J ∈ π`, `π.tag J` belongs to `J.Icc`, then `π` is called
a *Henstock* partition. We do not include this assumption into the definition of a tagged
(pre)partition because McShane integral is defined as a limit along tagged partitions without this
requirement.

### Tags

rectangular box, box partition
-/

noncomputable theory
open_locale classical ennreal nnreal
open set function

namespace box_integral

variables {ι : Type*}

/-- A tagged prepartition is a prepartition enriched with a tagged point for each box of the
prepartition. For simiplicity we require that `tag` is defined for all boxes in `ι → ℝ` but
we will use onle the values of `tag` on the boxes of the partition. -/
structure tagged_prepartition (I : box ι) extends prepartition I :=
(tag : box ι → ι → ℝ)
(tag_mem_Icc : ∀ J, tag J ∈ I.Icc)

namespace tagged_prepartition

variables {I J J₁ J₂ : box ι} (π : tagged_prepartition I) {x : ι → ℝ}

instance : has_mem (box ι) (tagged_prepartition I) := ⟨λ J π, J ∈ π.boxes⟩

@[simp] lemma mem_to_prepartition {π : tagged_prepartition I} :
  J ∈ π.to_prepartition ↔ J ∈ π := iff.rfl

@[simp] lemma mem_mk (π : prepartition I) (f h) :
  J ∈ mk π f h ↔ J ∈ π := iff.rfl

/-- Union of all boxes of a tagged prepartition. -/
def Union : set (ι → ℝ) := π.to_prepartition.Union

lemma Union_def : π.Union = ⋃ J ∈ π, ↑J := rfl

@[simp] lemma Union_mk (π : prepartition I) (f h) : (mk π f h).Union = π.Union := rfl

@[simp] lemma Union_to_prepartition : π.to_prepartition.Union = π.Union := rfl

@[simp] lemma mem_Union : x ∈ π.Union ↔ ∃ J ∈ π, x ∈ J := set.mem_Union₂

lemma subset_Union (h : J ∈ π) : ↑J ⊆ π.Union := subset_bUnion_of_mem h

lemma Union_subset : π.Union ⊆ I := Union₂_subset π.le_of_mem'

/-- A tagged prepartition is a partition if it covers the whole box. -/
def is_partition := π.to_prepartition.is_partition

lemma is_partition_iff_Union_eq : is_partition π ↔ π.Union = I :=
prepartition.is_partition_iff_Union_eq

/-- The tagged partition made of boxes of `π` that satisfy predicate `p`. -/
@[simps { fully_applied := ff }] def filter (p : box ι → Prop) : tagged_prepartition I :=
⟨π.1.filter p, π.2, π.3⟩

@[simp] lemma mem_filter {p : box ι → Prop} : J ∈ π.filter p ↔ J ∈ π ∧ p J :=
finset.mem_filter

@[simp] lemma Union_filter_not (π : tagged_prepartition I) (p : box ι → Prop) :
  (π.filter (λ J, ¬p J)).Union = π.Union \ (π.filter p).Union :=
π.to_prepartition.Union_filter_not p

end tagged_prepartition

namespace prepartition

variables {I J : box ι}

/-- Given a partition `π` of `I : box_integral.box ι` and a collection of tagged partitions
`πi J` of all boxes `J ∈ π`, returns the tagged partition of `I` into all the boxes of `πi J`
with tags coming from `(πi J).tag`. -/
def bUnion_tagged (π : prepartition I) (πi : Π J, tagged_prepartition J) :
  tagged_prepartition I :=
{ to_prepartition := π.bUnion (λ J, (πi J).to_prepartition),
  tag := λ J, (πi (π.bUnion_index (λ J, (πi J).to_prepartition) J)).tag J,
  tag_mem_Icc := λ J, box.le_iff_Icc.1 (π.bUnion_index_le _ _) ((πi _).tag_mem_Icc _) }

@[simp] lemma mem_bUnion_tagged (π : prepartition I) {πi : Π J, tagged_prepartition J} :
  J ∈ π.bUnion_tagged πi ↔ ∃ J' ∈ π, J ∈ πi J' :=
π.mem_bUnion

lemma tag_bUnion_tagged (π : prepartition I) {πi : Π J, tagged_prepartition J} (hJ : J ∈ π) {J'}
  (hJ' : J' ∈ πi J) :
  (π.bUnion_tagged πi).tag J' = (πi J).tag J' :=
begin
  have : J' ∈ π.bUnion_tagged πi, from π.mem_bUnion.2 ⟨J, hJ, hJ'⟩,
  obtain rfl := π.bUnion_index_of_mem hJ hJ',
  refl
end

@[simp] lemma Union_bUnion_tagged (π : prepartition I) (πi : Π J, tagged_prepartition J) :
  (π.bUnion_tagged πi).Union = ⋃ J ∈ π, (πi J).Union :=
Union_bUnion _ _

lemma forall_bUnion_tagged (p : (ι → ℝ) → box ι → Prop) (π : prepartition I)
  (πi : Π J, tagged_prepartition J) :
  (∀ J ∈ π.bUnion_tagged πi, p ((π.bUnion_tagged πi).tag J) J) ↔
    ∀ (J ∈ π) (J' ∈ πi J), p ((πi J).tag J') J' :=
begin
  simp only [bex_imp_distrib, mem_bUnion_tagged],
  refine ⟨λ H J hJ J' hJ', _, λ H J' J hJ hJ', _⟩,
  { rw ← π.tag_bUnion_tagged hJ hJ', exact H J' J hJ hJ' },
  { rw π.tag_bUnion_tagged hJ hJ', exact H J hJ J' hJ' }
end

lemma is_partition.bUnion_tagged {π : prepartition I} (h : is_partition π)
  {πi : Π J, tagged_prepartition J} (hi : ∀ J ∈ π, (πi J).is_partition) :
  (π.bUnion_tagged πi).is_partition :=
h.bUnion hi

end prepartition

namespace tagged_prepartition

variables {I J : box ι} {π π₁ π₂ : tagged_prepartition I} {x : ι → ℝ}

/-- Given a tagged partition `π` of `I` and a (not tagged) partition `πi J hJ` of each `J ∈ π`,
returns the tagged partition of `I` into all the boxes of all `πi J hJ`. The tag of a box `J`
is defined to be the `π.tag` of the box of the partition `π` that includes `J`.

Note that usually the result is not a Henstock partition. -/
@[simps tag { fully_applied := ff }]
def bUnion_prepartition (π : tagged_prepartition I) (πi : Π J, prepartition J) :
  tagged_prepartition I :=
{ to_prepartition := π.to_prepartition.bUnion πi,
  tag := λ J, π.tag (π.to_prepartition.bUnion_index πi J),
  tag_mem_Icc := λ J, π.tag_mem_Icc _ }

lemma is_partition.bUnion_prepartition {π : tagged_prepartition I} (h : is_partition π)
  {πi : Π J, prepartition J} (hi : ∀ J ∈ π, (πi J).is_partition) :
  (π.bUnion_prepartition πi).is_partition :=
h.bUnion hi

/-- Given two partitions `π₁` and `π₁`, one of them tagged and the other is not, returns the tagged
partition with `to_partition = π₁.to_partition ⊓ π₂` and tags coming from `π₁`.

Note that usually the result is not a Henstock partition. -/
def inf_prepartition (π : tagged_prepartition I) (π' : prepartition I) :
  tagged_prepartition I :=
π.bUnion_prepartition $ λ J, π'.restrict J

@[simp] lemma inf_prepartition_to_prepartition (π : tagged_prepartition I) (π' : prepartition I) :
  (π.inf_prepartition π').to_prepartition = π.to_prepartition ⊓ π' := rfl

lemma mem_inf_prepartition_comm :
  J ∈ π₁.inf_prepartition π₂.to_prepartition ↔ J ∈ π₂.inf_prepartition π₁.to_prepartition :=
by simp only [← mem_to_prepartition, inf_prepartition_to_prepartition, inf_comm]

lemma is_partition.inf_prepartition (h₁ : π₁.is_partition) {π₂ : prepartition I}
  (h₂ : π₂.is_partition) :
  (π₁.inf_prepartition π₂).is_partition :=
h₁.inf h₂

open metric

/-- A tagged partition is said to be a Henstock partition if for each `J ∈ π`, the tag of `J`
belongs to `J.Icc`. -/
def is_Henstock (π : tagged_prepartition I) : Prop := ∀ J ∈ π, π.tag J ∈ J.Icc

@[simp] lemma is_Henstock_bUnion_tagged
  {π : prepartition I} {πi : Π J, tagged_prepartition J} :
  is_Henstock (π.bUnion_tagged πi) ↔ ∀ J ∈ π, (πi J).is_Henstock :=
π.forall_bUnion_tagged (λ x J, x ∈ J.Icc) πi

/-- In a Henstock prepartition, there are at most `2 ^ fintype.card ι` boxes with a given tag. -/
lemma is_Henstock.card_filter_tag_eq_le [fintype ι] (h : π.is_Henstock) (x : ι → ℝ) :
  (π.boxes.filter (λ J, π.tag J = x)).card ≤ 2 ^ fintype.card ι :=
calc (π.boxes.filter (λ J, π.tag J = x)).card ≤ (π.boxes.filter (λ J : box ι, x ∈ J.Icc)).card :
  begin
    refine finset.card_le_of_subset (λ J hJ, _),
    rw finset.mem_filter at hJ ⊢, rcases hJ with ⟨hJ, rfl⟩,
    exact ⟨hJ, h J hJ⟩
  end
... ≤ 2 ^ fintype.card ι : π.to_prepartition.card_filter_mem_Icc_le x

/-- A tagged partition `π` is subordinate to `r : (ι → ℝ) → ℝ` if each box `J ∈ π` is included in
the closed ball with center `π.tag J` and radius `r (π.tag J)`. -/
def is_subordinate [fintype ι] (π : tagged_prepartition I) (r : (ι → ℝ) → Ioi (0 : ℝ)) : Prop :=
∀ J ∈ π, (J : _).Icc ⊆ closed_ball (π.tag J) (r $ π.tag J)

variables {r r₁ r₂ : (ι → ℝ) → Ioi (0 : ℝ)}

@[simp] lemma is_subordinate_bUnion_tagged [fintype ι]
  {π : prepartition I} {πi : Π J, tagged_prepartition J} :
  is_subordinate (π.bUnion_tagged πi) r ↔ ∀ J ∈ π, (πi J).is_subordinate r :=
π.forall_bUnion_tagged (λ x J, J.Icc ⊆ closed_ball x (r x)) πi

lemma is_subordinate.bUnion_prepartition [fintype ι] (h : is_subordinate π r)
  (πi : Π J, prepartition J) :
  is_subordinate (π.bUnion_prepartition πi) r :=
λ J hJ, subset.trans (box.le_iff_Icc.1 $ π.to_prepartition.le_bUnion_index hJ) $
  h _ $ π.to_prepartition.bUnion_index_mem hJ

lemma is_subordinate.inf_prepartition [fintype ι] (h : is_subordinate π r) (π' : prepartition I) :
  is_subordinate (π.inf_prepartition π') r :=
h.bUnion_prepartition _

lemma is_subordinate.mono' [fintype ι] {π : tagged_prepartition I}
  (hr₁ : π.is_subordinate r₁) (h : ∀ J ∈ π, r₁ (π.tag J) ≤ r₂ (π.tag J)) :
  π.is_subordinate r₂ :=
λ J hJ x hx, closed_ball_subset_closed_ball (h _ hJ) (hr₁ _ hJ hx)

lemma is_subordinate.mono [fintype ι] {π : tagged_prepartition I}
  (hr₁ : π.is_subordinate r₁) (h : ∀ x ∈ I.Icc, r₁ x ≤ r₂ x) :
  π.is_subordinate r₂ :=
hr₁.mono' $ λ J _, h _ $ π.tag_mem_Icc J

lemma is_subordinate.diam_le [fintype ι] {π : tagged_prepartition I}
  (h : π.is_subordinate r) (hJ : J ∈ π.boxes) :
  diam J.Icc ≤ 2 * r (π.tag J) :=
calc diam J.Icc ≤ diam (closed_ball (π.tag J) (r $ π.tag J)) :
  diam_mono (h J hJ) bounded_closed_ball
            ... ≤ 2 * r (π.tag J) : diam_closed_ball (le_of_lt (r _).2)

/-- Tagged prepartition with single box and prescribed tag. -/
@[simps { fully_applied := ff }]
def single (I J : box ι) (hJ : J ≤ I) (x : ι → ℝ) (h : x ∈ I.Icc) : tagged_prepartition I :=
⟨prepartition.single I J hJ, λ J, x, λ J, h⟩

@[simp] lemma mem_single {J'} (hJ : J ≤ I) (h : x ∈ I.Icc) : J' ∈ single I J hJ x h ↔ J' = J :=
finset.mem_singleton

instance (I : box ι) : inhabited (tagged_prepartition I) :=
⟨single I I le_rfl I.upper I.upper_mem_Icc⟩

lemma is_partition_single_iff (hJ : J ≤ I) (h : x ∈ I.Icc) :
  (single I J hJ x h).is_partition ↔ J = I :=
prepartition.is_partition_single_iff hJ

lemma is_partition_single (h : x ∈ I.Icc) : (single I I le_rfl x h).is_partition :=
prepartition.is_partition_top I

lemma forall_mem_single (p : (ι → ℝ) → (box ι) → Prop) (hJ : J ≤ I) (h : x ∈ I.Icc) :
  (∀ J' ∈ single I J hJ x h, p ((single I J hJ x h).tag J') J') ↔ p x J :=
by simp

@[simp] lemma is_Henstock_single_iff (hJ : J ≤ I) (h : x ∈ I.Icc) :
  is_Henstock (single I J hJ x h) ↔ x ∈ J.Icc :=
forall_mem_single (λ x J, x ∈ J.Icc) hJ h

@[simp]

@[simp] lemma is_subordinate_single [fintype ι] (hJ : J ≤ I) (h : x ∈ I.Icc) :
  is_subordinate (single I J hJ x h) r ↔ J.Icc ⊆ closed_ball x (r x) :=
forall_mem_single (λ x J, J.Icc ⊆ closed_ball x (r x)) hJ h

@[simp] lemma Union_single (hJ : J ≤ I) (h : x ∈ I.Icc) :
  (single I J hJ x h).Union = J :=
prepartition.Union_single hJ

/-- Union of two tagged prepartitions with disjoint unions of boxes. -/
def disj_union (π₁ π₂ : tagged_prepartition I) (h : disjoint π₁.Union π₂.Union) :
  tagged_prepartition I :=
{ to_prepartition := π₁.to_prepartition.disj_union π₂.to_prepartition h,
  tag := π₁.boxes.piecewise π₁.tag π₂.tag,
  tag_mem_Icc := λ J, by { dunfold finset.piecewise, split_ifs,
    exacts [π₁.tag_mem_Icc J, π₂.tag_mem_Icc J]  } }

@[simp] lemma disj_union_boxes (h : disjoint π₁.Union π₂.Union) :
  (π₁.disj_union π₂ h).boxes = π₁.boxes ∪ π₂.boxes := rfl

@[simp] lemma mem_disj_union (h : disjoint π₁.Union π₂.Union) :
  J ∈ π₁.disj_union π₂ h ↔ J ∈ π₁ ∨ J ∈ π₂ :=
finset.mem_union

@[simp] lemma Union_disj_union (h : disjoint π₁.Union π₂.Union) :
  (π₁.disj_union π₂ h).Union = π₁.Union ∪ π₂.Union :=
prepartition.Union_disj_union _

lemma disj_union_tag_of_mem_left (h : disjoint π₁.Union π₂.Union) (hJ : J ∈ π₁) :
  (π₁.disj_union π₂ h).tag J = π₁.tag J :=
dif_pos hJ

lemma disj_union_tag_of_mem_right (h : disjoint π₁.Union π₂.Union) (hJ : J ∈ π₂) :
  (π₁.disj_union π₂ h).tag J = π₂.tag J :=
dif_neg $ λ h₁, h.le_bot ⟨π₁.subset_Union h₁ J.upper_mem, π₂.subset_Union hJ J.upper_mem⟩

lemma is_subordinate.disj_union [fintype ι] (h₁ : is_subordinate π₁ r)
  (h₂ : is_subordinate π₂ r) (h : disjoint π₁.Union π₂.Union) :
  is_subordinate (π₁.disj_union π₂ h) r :=
begin
  refine λ J hJ, (finset.mem_union.1 hJ).elim (λ hJ, _) (λ hJ, _),
  { rw disj_union_tag_of_mem_left _ hJ, exact h₁ _ hJ },
  { rw disj_union_tag_of_mem_right _ hJ, exact h₂ _ hJ }
end

lemma is_Henstock.disj_union (h₁ : is_Henstock π₁) (h₂ : is_Henstock π₂)
  (h : disjoint π₁.Union π₂.Union) :
  is_Henstock (π₁.disj_union π₂ h) :=
begin
  refine λ J hJ, (finset.mem_union.1 hJ).elim (λ hJ, _) (λ hJ, _),
  { rw disj_union_tag_of_mem_left _ hJ, exact h₁ _ hJ },
  { rw disj_union_tag_of_mem_right _ hJ, exact h₂ _ hJ }
end

/-- If `I ≤ J`, then every tagged prepartition of `I` is a tagged prepartition of `J`. -/
def embed_box (I J : box ι) (h : I ≤ J) :
  tagged_prepartition I ↪ tagged_prepartition J :=
{ to_fun := λ π,
  { le_of_mem' := λ J' hJ', (π.le_of_mem' J' hJ').trans h,
    tag_mem_Icc := λ J, box.le_iff_Icc.1 h (π.tag_mem_Icc J),
    .. π },
  inj' := by { rintro ⟨⟨b₁, h₁le, h₁d⟩, t₁, ht₁⟩ ⟨⟨b₂, h₂le, h₂d⟩, t₂, ht₂⟩ H, simpa using H } }

section distortion

variables [fintype ι] (π)
open finset

/-- The distortion of a tagged prepartition is the maximum of distortions of its boxes. -/
def distortion : ℝ≥0 := π.to_prepartition.distortion

lemma distortion_le_of_mem (h : J ∈ π) : J.distortion ≤ π.distortion :=
le_sup h

lemma distortion_le_iff {c : ℝ≥0} : π.distortion ≤ c ↔ ∀ J ∈ π, box.distortion J ≤ c :=
finset.sup_le_iff

@[simp] lemma _root_.box_integral.prepartition.distortion_bUnion_tagged (π : prepartition I)
  (πi : Π J, tagged_prepartition J) :
  (π.bUnion_tagged πi).distortion = π.boxes.sup (λ J, (πi J).distortion) :=
sup_bUnion _ _

@[simp] lemma distortion_bUnion_prepartition (π : tagged_prepartition I)
  (πi : Π J, prepartition J) :
  (π.bUnion_prepartition πi).distortion = π.boxes.sup (λ J, (πi J).distortion) :=
sup_bUnion _ _

@[simp] lemma distortion_disj_union (h : disjoint π₁.Union π₂.Union) :
  (π₁.disj_union π₂ h).distortion = max π₁.distortion π₂.distortion :=
sup_union

lemma distortion_of_const {c} (h₁ : π.boxes.nonempty) (h₂ : ∀ J ∈ π, box.distortion J = c) :
  π.distortion = c :=
(sup_congr rfl h₂).trans (sup_const h₁ _)

@[simp] lemma distortion_single (hJ : J ≤ I) (h : x ∈ I.Icc) :
  distortion (single I J hJ x h) = J.distortion :=
sup_singleton

lemma distortion_filter_le (p : box ι → Prop) : (π.filter p).distortion ≤ π.distortion :=
sup_mono (filter_subset _ _)

end distortion

end tagged_prepartition

end box_integral


import data.matrix data.rat.basic linear_algebra.basis data.fintype tactic.omega
import algebra.associated
import linear_algebra.determinant

open matrix fintype finset

variables {m n : ℕ}
variables (A : matrix (fin m) (fin n) ℚ)

local notation `rvec` n := matrix (fin 1) (fin n) ℚ
local notation `cvec` m := matrix (fin m) (fin 1) ℚ

-- def column (j : fin n) : cvec m := λ i _, A i j

-- def row (i : fin m) : rvec n := λ _ j, A i j

variables (b : cvec m) (c : cvec n)

--instance : partial_order (matrix (fin m) (fin n) ℚ) := pi.partial_order

constant matrix.has_inv : has_inv (matrix (fin n) (fin n) ℚ)

local notation M `⬝` N := M.mul N
local postfix `ᵀ` : 1500 := transpose

instance : partial_order (matrix (fin m ) (fin n) ℚ) := pi.partial_order

def is_feasible (x : cvec n) : Prop :=
0 ≤ x ∧ A ⬝ x = b

instance decidable_le : decidable_rel ((≤) : matrix (fin m) (fin n) ℚ → matrix (fin m) (fin n) ℚ → Prop) :=
λ M N, show decidable (∀ i j, M i j ≤ N i j), by apply_instance

instance (x : cvec n) : decidable (is_feasible A b x) :=
by dunfold is_feasible; apply_instance

def is_optimal (x : cvec n) : Prop :=
is_feasible A b x ∧ ∀ y, is_feasible A b y → cᵀ ⬝ y ≤ cᵀ ⬝ x

def is_invertible (M : matrix (fin m) (fin n) ℚ) : Prop :=
∃ h : m = n, by rw h at M; exact det M ≠ 0

instance is_invertible.decidable : decidable_pred (@is_invertible m n) :=
λ _, by unfold is_invertible; apply_instance

def comatrix (M : matrix (fin n) (fin n) ℚ) : matrix (fin n) (fin n) ℚ :=
begin
  cases n,
  { exact fin.elim0 },
  { exact λ i j, det (minor M
    (λ i' : fin n, if i'.1 < i.1 then i'.cast_le sorry
      else i'.succ)
    (λ j' : fin n, if j'.1 < j.1 then j'.cast_le sorry
      else j'.succ)) }
end

def inverse (M : matrix (fin m) (fin n) ℚ) : matrix (fin n) (fin m) ℚ :=
if h : m = n then by subst h; exact (det M)⁻¹ • (comatrix M)ᵀ else 0

def check_reduced_cost (x : cvec n) (B : finset (fin n)) : Prop :=
let permB : matrix (fin n) (fin B.card) ℚ :=
  minor 1 id (λ i, (finset.sort (≤) B).nth_le i.1 (by simpa using i.2)) in
let N : finset (fin n) := univ.filter (∉ B) in
let permN : matrix (fin n) (fin N.card) ℚ :=
  minor 1 id (λ i, (finset.sort (≤) N).nth_le i.1 (by simpa using i.2)) in
let basis := A ⬝ permB in
let non_basis := A ⬝ permN in
let ctN := cᵀ ⬝ permN in
let ctB := cᵀ ⬝ permB in
xᵀ ⬝ permN = 0 ∧ is_invertible basis ∧ ctN - ctB ⬝ inverse basis ⬝ non_basis ≤ 0

instance (x : cvec n) (B : finset (fin n)) : decidable (check_reduced_cost A c x B) :=
by dunfold check_reduced_cost; apply_instance

lemma is_optimal_of_check_reduced_cost (x : cvec n) (B : finset (fin n)) :
  check_reduced_cost A c x B ∧ is_feasible A b x → is_optimal A b c x := sorry

set_option profiler true

def ex.A : matrix (fin 2) (fin 4) ℚ :=
λ i j, (list.nth_le [[1,0,1,0], [1,2,0,1]] i sorry).nth_le j sorry

def ex.B : finset (fin 4) := {2,3}

def ex.c : cvec 4 := λ i _, (list.nth_le [1,1,0,0] i sorry)

def ex.b : cvec 2 := λ i _, (list.nth_le [2,4] i sorry)

def ex.x : cvec 4 := λ i _, (list.nth_le [0,0,2,4] i sorry)

--#reduce (is_feasible ex.A ex.b ex.x : bool)

--set_option trace.class_instances true
--#reduce (check_reduced_cost ex.A ex.c ex.x ex.B : bool)

def ex2.A : matrix (fin 2) (fin 4) ℚ :=
  λ i j, (list.nth_le [[1,0,1,0], [1,2,0,1]] i sorry).nth_le j sorry

def ex2.B : finset (fin 4) := {0,1}

def ex2.c : cvec 4 := λ i _, (list.nth_le [1,1,0,0] i sorry)

def ex2.b : cvec 2 := λ i _, (list.nth_le [2,4] i sorry)

def ex2.x : cvec 4 := λ i _, (list.nth_le [2,1,0,0] i sorry)

#eval (is_feasible ex2.A ex2.b ex2.x : bool)

#eval (check_reduced_cost ex2.A ex2.c ex2.x ex2.B : bool)


import ..simp_omega ..term ..logic ..option ..nat

open tactic

namespace nat

@[derive has_reflect, derive decidable_eq]
inductive preterm : Type
| cst : nat → preterm
| var : nat → nat → preterm
| add : preterm → preterm → preterm
| sub : preterm → preterm → preterm

notation `&` k := preterm.cst k
infix `**` : 300 := preterm.var
notation t `+*` s := preterm.add t s
notation t `-*` s := preterm.sub t s

-- | (& m) := sorry
-- | (m ** n) := sorry
-- | (t +* s) := sorry
-- | (t -* s) := sorry

namespace preterm

meta def induce (tac : tactic unit := tactic.skip) : tactic unit :=
`[ intro t, induction t with m m n t s iht ihs t s iht ihs; tac]

def val (v : nat → nat) : preterm → nat
| (& i) := i
| (i ** n) :=
  if i = 1
  then v n
  else (v n) * i
| (t1 +* t2) := t1.val + t2.val
| (t1 -* t2) := t1.val - t2.val

@[omega] lemma val_const {v m} : (& m).val v = m := rfl

@[omega] lemma val_var {v m n} :
  (m ** n).val v = m * (v n) :=
begin
  simp only [val], by_cases h1 : m = 1,
  rw [if_pos h1, h1, one_mul],
  rw [if_neg h1, mul_comm],
end

@[omega] lemma val_add {v t s} : (t +* s).val v = t.val v + s.val v := rfl

@[omega] lemma val_sub {v t s} : (t -* s).val v = t.val v - s.val v := rfl

def fresh_idx : preterm → nat
| (& _)      := 0
| (i ** n)   := n + 1
| (t1 +* t2) := max t1.fresh_idx t2.fresh_idx
| (t1 -* t2) := max t1.fresh_idx t2.fresh_idx

def val_constant (v w : nat → nat) :
  ∀ t : preterm, (∀ x < t.fresh_idx, v x = w x) →
  t.val v = t.val w
| (& n)      h1 := rfl
| (m ** n)   h1 :=
  begin
    simp_omega, apply congr_arg (λ y, m * y),
    apply h1 _ (lt_add_one _)
  end
| (t +* s) h1 :=
  begin
    simp_omega,
    have ht := val_constant t
      (λ x hx, h1 _ (lt_of_lt_of_le hx (le_max_left _ _))),
    have hs := val_constant s
      (λ x hx, h1 _ (lt_of_lt_of_le hx (le_max_right _ _))),
    rw [ht, hs]
  end
| (t -* s) h1 :=
  begin
    simp_omega,
    have ht := val_constant t
      (λ x hx, h1 _ (lt_of_lt_of_le hx (le_max_left _ _))),
    have hs := val_constant s
      (λ x hx, h1 _ (lt_of_lt_of_le hx (le_max_right _ _))),
    rw [ht, hs]
  end

def repr : preterm → string
| (& i)      := i.repr
| (i ** n)   := i.repr ++ "*x" ++ n.repr
| (t1 +* t2) := "(" ++ t1.repr ++ " + " ++ t2.repr ++ ")"
| (t1 -* t2) := "(" ++ t1.repr ++ " - " ++ t2.repr ++ ")"

@[omega] def succ (t : preterm) : preterm := t +* (&1)

def sub_free : preterm → Prop
| (& m)    := true
| (m ** n) := true
| (t +* s) := t.sub_free ∧ s.sub_free
| (_ -* _) := false

end preterm

@[omega] def canonize : preterm → term
| (& m)    := ⟨↑m,[]⟩
| (m ** n) := ⟨0,[]{n ↦ ↑m}⟩
| (t +* s) := term.add (canonize t) (canonize s)
| (_ -* _) := ⟨0,[]⟩ -- Irr.

@[omega] lemma val_canonize {v : nat → nat} :
  ∀ {t : preterm}, t.sub_free →
  (canonize t).val (λ x, ↑(v x)) = t.val v
| (& i) h1 := by simp_omega
| (i ** n) h1 :=
  begin simp_omega, rw ← int.coe_nat_mul end
| (t +* s) h1 :=
  by simp_omega [val_canonize h1.left,
    val_canonize h1.right, int.coe_nat_add]

end nat