/-  Copyright (c) 2022 Sina Hazratpour. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
----------------

# Unbundled Structures
Sina Hazratpour
Introduction to Proof
MATH 301, Johns Hopkins University, Fall 2022
-/

import ..prooflab
import .lec8_structure_bundled

namespace PROOFS

namespace STR  --nested inside the namespace PROOFS

variables {X Y Z : Type}
variable {f : X → Y}

/- The unbundled definition of preorder: this is the type of preorder structure on  a type `X`. Note that this structure depends on the parameter `X` in contrast with the bundles version which does not have any parameters. -/

structure preorder_unbundled (X : Type) :=
(rel : X → X → Prop)
(rflx : reflexive rel)
(trns : transitive rel)

#check preorder_unbundled
#check preorder_bundled

#check preorder -- a function which assigns to every type `X` the type of preorder structures on `X`

def preorder_unbundled_nat_eq : preorder_unbundled ℕ :=
{
  rel := λ m, λ n, m = n,
  rflx := by {unfold reflexive,intro x, refl, },
  trns := by {unfold transitive, apply eq.trans,},
}

#check preorder_unbundled_nat_eq
#print preorder_unbundled_nat_eq

#reduce preorder_unbundled_nat_eq.rel
#reduce preorder_bundled_nat_eq.rel

def preorder_unbundled_nat_le : preorder_unbundled ℕ :=
{
  rel := λ m, λ n, m ≤ n,
  rflx := by {unfold reflexive,intro x, refl, },
  trns := by {unfold transitive, apply le_trans,},
}

#check preorder

def preorder_unbundled_bool_le : preorder_unbundled bool :=
{
  rel := λ b, λ b', b && b' = b,
  rflx := by { unfold reflexive, --
               intro x, --
               cases x,
               repeat {refl},
               },
  trns := by { unfold transitive,
               intros x y z,
               intros h₁ h₂, rw ← h₁, rw bool_and_assoc, rw h₂}, -- prove some associativity of && and use it here.
}

structure preorder_unbundled.morphism {X : Type} {Y : Type} (P : preorder_unbundled X) (Q : preorder_unbundled Y) :=
( to_fun :  X → Y ) -- a function between the carrier types
( respect_rel : ∀ {x₁ x₂ : X}, P.rel x₁ x₂ → Q.rel (to_fun x₁) (to_fun x₂) ) -- property which says that the relations between elements of X are respected by the function `f`

#check @preorder_unbundled.morphism

def preorder_unbundled.morphism.nat_eq_to_nat_le : preorder_unbundled.morphism  preorder_unbundled_nat_eq preorder_unbundled_nat_le :=
{
  to_fun := id,
  respect_rel := by {
                      intros a b,
                      intro h,
                      dsimp,
                      apply le_of_eq h,
                    },
}

namespace ptwise
lemma left_inv {g : Y → X} {f : X → Y} (h : g ∘ f = id) :
  ∀ x : X, g (f x) = x :=
begin
  intro x,
  apply congr_fun h,
end
end ptwise

#check ptwise.left_inv

/-! ## Equivalence of types -/

-- the type of endomorphisms of `A`
def endo (A : Type)  := A → A

#check endo

def id_A {A : Type} : endo A := id

universe u
/- `fun_equiv` (function equivalence) is the type of functions from `X → Y` with a two-sided inverse -/
structure fun_equiv (X : Type u) (Y : Type u) :=
(to_fun    : X → Y)
(inv_fun   : Y → X)
(left_inv  : inv_fun ∘ to_fun = id) -- i.e. inv_fun ∘ to_fun = id_X
(right_inv : to_fun ∘ inv_fun = id) -- i.e. to_fun ∘ inv_fun = id_Y

-- infix ` ≃ `:15 := fun_equiv

/--
`X ≃ Y` is the type of functions from `X → Y` with a two-sided inverse.
or just the type of all equivalences between X and Y
-/

-- the type of automorphisms of `A`
def auto (A : Type)  := fun_equiv A A

/-
Every automorphism is an endomorphism.
-/

def endo_of_auto {A : Type} (α : auto A) :
  endo A :=
α.to_fun

#check @endo_of_auto

def auto.action {A : Type} : auto(A) × A → A :=
uncurry endo_of_auto

def auto.id {A : Type} : auto(A) :=
{
  to_fun := id,
  inv_fun := id,
  left_inv := by {refl,}, -- id ∘ id = id
  right_inv := by {refl,}, -- id ∘ id = id
}

def auto.inv {A : Type} : auto(A) → auto(A) :=
λ α,
{
  to_fun := α.inv_fun,
  inv_fun := α.to_fun,
  left_inv := α.right_inv,
  right_inv := α.left_inv,
}

def auto.mul {A : Type} : auto(A) → auto (A) → auto(A) :=
λ α, λ β,
{
  to_fun := β.to_fun ∘ α.to_fun,
  inv_fun := α.inv_fun ∘ β.inv_fun,
  left_inv := by {rw ← comp_assoc, nth_rewrite 1 comp_assoc, rw β.left_inv, simp, rw α.left_inv,},
  right_inv := by {funext, simp [ptwise.left_inv (α.right_inv), ptwise.left_inv (β.right_inv)], }
  -- or, -- by {funext, dsimp, rw ptwise.left_inv (α.right_inv), rw ptwise.left_inv (β.right_inv),  },
}

end STR

end PROOFS


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

! This file was ported from Lean 3 source module group_theory.group_action.option
! leanprover-community/mathlib commit f1a2caaf51ef593799107fe9a8d5e411599f3996
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.GroupTheory.GroupAction.Defs

/-!
# Option instances for additive and multiplicative actions

This file defines instances for additive and multiplicative actions on `Option` type. Scalar
multiplication is defined by `a • some b = some (a • b)` and `a • none = none`.

## See also

* `GroupTheory.GroupAction.Pi`
* `GroupTheory.GroupAction.Prod`
* `GroupTheory.GroupAction.Sigma`
* `GroupTheory.GroupAction.Sum`
-/

variable {M N α : Type _}

namespace Option

section SMul

variable [SMul M α] [SMul N α] (a : M) (b : α) (x : Option α)

@[to_additive Option.VAdd]
instance : SMul M (Option α) :=
  ⟨fun a => Option.map <| (a • ·)⟩

@[to_additive]
theorem smul_def : a • x = x.map ((· • ·) a) :=
  rfl
#align option.smul_def Option.smul_def
#align option.vadd_def Option.vadd_def

@[to_additive (attr := simp)]
theorem smul_none : a • (none : Option α) = none :=
  rfl
#align option.smul_none Option.smul_none
#align option.vadd_none Option.vadd_none

@[to_additive (attr := simp)]
theorem smul_some : a • some b = some (a • b) :=
  rfl
#align option.smul_some Option.smul_some
#align option.vadd_some Option.vadd_some

@[to_additive]
instance [SMul M N] [IsScalarTower M N α] : IsScalarTower M N (Option α) :=
  ⟨fun a b x => by
    cases x
    exacts[rfl, congr_arg some (smul_assoc _ _ _)]⟩

@[to_additive]
instance [SMulCommClass M N α] : SMulCommClass M N (Option α) :=
  ⟨fun _ _ => Function.Commute.option_map <| smul_comm _ _⟩

@[to_additive]
instance [SMul Mᵐᵒᵖ α] [IsCentralScalar M α] : IsCentralScalar M (Option α) :=
  ⟨fun a x => by
    cases x
    exacts[rfl, congr_arg some (op_smul_eq_smul _ _)]⟩

@[to_additive]
instance [FaithfulSMul M α] : FaithfulSMul M (Option α) :=
  ⟨fun h => eq_of_smul_eq_smul fun b : α => by injection h (some b)⟩

end SMul

instance [Monoid M] [MulAction M α] :
    MulAction M (Option α) where
  smul := (· • ·)
  one_smul b := by
    cases b
    exacts[rfl, congr_arg some (one_smul _ _)]
  mul_smul a₁ a₂ b := by
    cases b
    exacts[rfl, congr_arg some (mul_smul _ _ _)]

end Option


/-
Copyright (c) 2023 Maxwell Thum. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Maxwell Thum
-/
import combinatorial_surface.abstract_simplicial_complex.basic

/-!
# Oriented abstract simplicial complexes

~~Based on this definition from (a StackExchange question quoting) Rotman's
Algebraic Topology:
"An oriented simplicial complex K
 is a simplicial complex and a partial order on Vert(K)
 whose restriction to the vertices of any simplex in K
 is a linear order."~~

Now based on my definition which is easier: an orientation on an ASC is a set of
functions from its simplices/faces to ℕ with compatible orders.

## Main declarations

*

## Notation

-/

open finset set abstract_simplicial_complex
variables (E : Type*) [decidable_eq E] {s t : finset E} {x : E}

/-- An *oriented* abstract simplicial complex is an abstract simplicial complex with orders assigned to
each of its faces such that the order of a subset of a face has the same order as that subset has within
the larger face's order. -/
@[ext] structure oriented_asc extends abstract_simplicial_complex E :=
(orientation : faces → list E)
(orientation_nodup : Π s : faces, (orientation s).nodup)
(olists_eq_faces : Π s : faces, (⟨orientation s, orientation_nodup s⟩ : finset E) = s.1) -- name is wip
(orientation_consistent : Π s : faces, Π t : faces, t.1 ⊆ s.1 → (orientation t).sublist (orientation s))
-- (orientation_is_vertices : Π s : faces, (orientation s).to_finset = s.1) -- name is wip

namespace oriented_asc
variables {E} {K : oriented_asc E}

/-- The set of oriented faces in `K`. -/
def oriented_faces (K : oriented_asc E) : set (list E) := range K.orientation

/-- The set of oriented `k`-faces in `K`, the 'image' of `K.faces` under `K.orientation`. -/
def oriented_k_faces (K : oriented_asc E) (k : ℕ) : set K.oriented_faces :=
  { s | ∃ t ∈ K.k_faces k, K.orientation t = s.1 }
  --{ s : K.oriented_faces | s.1.length = k + 1 }

/-- The images of `k`-faces under `K.orientation` are indeed `k+1` long. -/
lemma oriented_k_face_length_eq_k {k : ℕ} :
  ∀ s : K.oriented_faces, s ∈ oriented_k_faces K k → s.1.length = k + 1 := by
{ intros s hs,
  cases hs with t ht,
  cases ht with htk hts,
  rw ← hts,
  have card_eq_length : (K.orientation t).length = (⟨K.orientation t, K.orientation_nodup t⟩ : finset E).card,
    simp only [card_mk, multiset.coe_card],
  rw card_eq_length,
  rw K.olists_eq_faces t,
  unfold k_faces at htk,
  rw mem_set_of_eq at htk,
  exact htk,
}

end oriented_asc


import linear_algebra.dimension
import missing_mathlib.set_theory.cardinal

universe variables u u' u'' v v' w w'

variables {α : Type u} {β γ δ ε : Type v}
variables {ι : Type w} {ι' : Type w'} {η : Type u''} {φ : η → Type u'}
-- TODO: relax these universe constraints

section vector_space
variables [decidable_eq ι] [decidable_eq ι'] [field α] [decidable_eq α] [add_comm_group β] [vector_space α β]
include α
open submodule lattice function set
open vector_space

lemma submodule.bot_of_dim_zero (p : submodule α β) (h_dim : dim α p = 0) : p = ⊥ :=
begin
  haveI : decidable_eq β := classical.dec_eq β,
  obtain ⟨b, hb⟩ : ∃b : set p, is_basis α (λ i : b, i.val) := @exists_is_basis α p _ _ _,
  rw ←le_bot_iff,
  intros x hx,
  have : (⟨x, (submodule.mem_coe p).1 hx⟩ : p) = (0 : p),
  { rw ←@mem_bot α p _ _ _,
    rw [← @span_empty α p _ _ _, ←(@set.range_eq_empty p b (λ (i : b), i.val)).2, hb.2],
    apply mem_top,
    unfold_coes,
    rw [nonempty_subtype],
    push_neg,
    rw [←set.eq_empty_iff_forall_not_mem, ←cardinal.mk_zero_iff_empty_set],
    rwa cardinal.lift_inj.1 hb.mk_eq_dim },
  rw [mem_bot],
  rw <-coe_eq_zero at this,
  apply this,
end

lemma linear_independent.le_lift_dim [decidable_eq β] {v : ι → β} (hv : linear_independent α v) :
  cardinal.lift.{w v} (cardinal.mk ι) ≤ cardinal.lift.{v w} (dim α β) :=
calc
  cardinal.lift.{w v} (cardinal.mk ι)
      = cardinal.lift.{v w} (cardinal.mk (range v)) :
          by rw ←cardinal.mk_range_eq_of_injective (linear_independent.injective hv)
  ... = cardinal.lift.{v w} (dim α (span α (range v))) :
          by rw ←dim_span hv
  ... ≤ cardinal.lift.{v w} (dim α (⊤ : submodule α β)) :
          cardinal.lift_le.2 (dim_le_of_submodule (submodule.span α (set.range v)) ⊤ le_top)
  ... ≤ cardinal.lift.{v w} (dim α β) :
          by rw dim_top

lemma linear_independent_le_dim {α : Type u} {β : Type v} {ι : Type w}
  [field α] [decidable_eq β] [add_comm_group β] [vector_space α β] [decidable_eq ι]
  {v : ι → β} (hv : @linear_independent _ α _ v (@comm_ring.to_ring _ (field.to_comm_ring _)) _ _) :
  cardinal.lift.{w v} (cardinal.mk ι) ≤ cardinal.lift.{v w} (dim α β) :=
calc
  cardinal.lift.{w v} (cardinal.mk ι) = cardinal.lift.{v w} (cardinal.mk (set.range v)) :
     (cardinal.mk_range_eq_of_injective (linear_independent.injective hv)).symm
  ... = cardinal.lift.{v w} (dim α (submodule.span α (set.range v))) : by rw (dim_span hv).symm
  ... ≤ cardinal.lift.{v w} (dim α β) : cardinal.lift_le.2 (dim_submodule_le (submodule.span α _))

lemma powers_linear_dependent_of_dim_finite (α : Type v) (β : Type w)
  [field α] [decidable_eq β] [add_comm_group β] [vector_space α β]
  (f : β →ₗ[α] β) (h_dim : dim α β < cardinal.omega) (v : β) :
  ¬ linear_independent α (λ n : ℕ, (f ^ n) v) :=
begin
  intro hw,
  apply not_lt_of_le _ h_dim,
  rw [← cardinal.lift_id (dim α β), cardinal.lift_umax.{w 0}],
  apply linear_independent_le_dim hw
end

lemma exists_mem_ne_zero_of_dim_pos' {α : Type v} {β : Type w}
  [field α] [add_comm_group β] [vector_space α β]
  (h_dim : 0 < dim α β) : ∃ x : β, x ≠ 0 :=
begin
  obtain ⟨b, _, _⟩ : (∃ b : β, b ∈ (⊤ : submodule α β) ∧ b ≠ 0),
  { apply exists_mem_ne_zero_of_dim_pos,
    rw dim_top,
    apply h_dim },
  use b
end

lemma dim_pos_of_mem_ne_zero {α : Type v} {β : Type w}
  [field α] [add_comm_group β] [vector_space α β]
  (x : β) (h : x ≠ 0) : 0 < dim α β :=
begin
  classical,
  by_contra hc,
  rw [not_lt, cardinal.le_zero, ←dim_top] at hc,
  have x_mem_bot : x ∈ ⊥,
  { rw ← submodule.bot_of_dim_zero ⊤ hc,
    apply mem_top },
  exact h ((mem_bot α).1 x_mem_bot)
end

end vector_space


-- Definition of a graded algebra, with no other operations defined
import algebra.group.basic
import linear_algebra.tensor_product
import linear_algebra.dfinsupp
import tactic.ring

universes u

-- TODO: open_locale only under namespace, never globally
open_locale big_operators
open_locale classical
open finset

-- TODO: should this have a shorter name like graded and places it under a namespace?
class graded_module_components
  -- a type for each grade.
  -- TODO do we need ℤ or we can simply use ℕ
  -- the inductive definition of ℤ is based on ℕ
  -- and may add unwanted complexity to proof
  (A : ℤ → Type u)
:=
  -- (A 0) is the scalar type
  -- TODO what does zc stand for?
  [zc: comm_ring (A 0)]

  -- all the types form commutative vector spaces
  -- TODO change to meaningful names
  [b: ∀ r, add_comm_monoid (A r)]
  [c: ∀ r, module (A 0) (A r)]

attribute [instance] graded_module_components.zc
attribute [instance] graded_module_components.b
attribute [instance] graded_module_components.c

-- namespace graded_module_components
--   -- TODO should always open a section before using variables
--   variables {A : ℤ → Type u}
--   /-- objects are coercible only if they have the same grade-/
--   -- TODO did it work? should we remove it?
--   instance has_coe (r s : ℕ) (h: r = s) : has_coe (A r) (A s) := { coe := by {subst h, exact id}}
-- end graded_module_components

/-- Grade selection maps from objects in G to a finite set of components of substituent grades -/
-- TODO how about place it under namespace graded and name it has_select
class has_grade_select
  (A : ℤ → Type u) (G: Type u)
  [graded_module_components A]
  [add_comm_group G]
  [module (A 0) G] :=
-- TODO better find a way to avoid A 0 everywhere
(select : G →ₗ[A 0] (Π₀ r, A r))

/- TODO: check precedence -/
local notation `⟨`:0 g`⟩_`:0 r:100 := has_grade_select.select g r

-- introducing these needs types which restrict the domain of A to `{z // z : ℤ, z %2 == 0}`
-- notation `⟨`:0 g`⟩₊`:0 := has_grade_select.select_even
-- notation `⟨`:0 g`⟩₋`:0 := has_grade_select.select_odd

/-- A module divisible into disjoint graded modules, where the grade selectio
    operator is a complete and independent set of projections -/
class graded_module
  (A : ℤ → Type u) (G: Type u)
  -- TODO: we should avoid the plague of [] parameters, by bundling them?
  [graded_module_components A]
  [add_comm_group G]
  [module (A 0) G]
  extends has_grade_select A G :=
(to_fun : ∀{r}, A r →ₗ[A 0] G)
(is_complete : ∀ g : G, ∀ f, f = select g ↔ g = f.sum (λ r, to_fun))

namespace graded_module
  variables {A : ℤ → Type u} {G: Type u}
  variables [graded_module_components A] [add_comm_group G] [module (A 0) G]
  variables [graded_module A G]

  /- locally bind the notation above to our A and G -/
  -- TODO I have a feeling that this notation would not survive very long
  local notation (name := grade_select) `⟨`:0 g`⟩_`:0 r:100 := @has_grade_select.select A G _ _ _ _ g r

  /-- convert from r-vectors to multi-vectors -/
  instance has_coe (r : ℤ) : has_coe (A r) G := { coe := to_fun }

  @[simp]
  lemma coe_def {r : ℤ} (v : A r) : (v : G) = to_fun v := rfl

  /-- An r-vector has only a single grade
      Discussed at https://leanprover.zulipchat.com/#narrow/stream/113489-new-members/topic/Expressing.20a.20sum.20with.20finitely.20many.20nonzero.20terms/near/202657281-/
  lemma select_coe_is_single {r : ℤ} (v : A r) :
  has_grade_select.select (v : G) = dfinsupp.single r v := begin
    symmetry,
    rw is_complete (v : G) (dfinsupp.single r v),
    symmetry,
    apply dfinsupp.sum_single_index,
    exact linear_map.map_zero _,
  end

  def is_r_vector (r : ℤ) (a : G) := (⟨a⟩_r : G) = a

  /-- Chisholm 6a, ish.
      This says A = ⟨A}_r for r-vectors.
      Chisholm aditionally wants proof that A != ⟨A}_r for non-rvectors -/
  lemma r_grade_of_coe {r : ℤ} (v : A r) : ⟨v⟩_r = v := begin
    rw select_coe_is_single,
    rw dfinsupp.single_apply,
    rw [dif_pos],
    refl,
  end

  /-- to_fun is injective -/
  lemma to_fun_inj (r : ℤ) : function.injective (to_fun : A r → G) := begin
    intros a b h,
    rw ← r_grade_of_coe a,
    rw ← r_grade_of_coe b,
    simp only [coe_def],
    rw h,
    apply_instance,
  end

  /-- Chisholm 6b -/
  lemma grade_of_sum (r : ℤ) (a b : G) :
  ⟨a + b⟩_r = ⟨a⟩_r + ⟨b⟩_r :=
  by simp only [dfinsupp.add_apply, linear_map.map_add]

  /-- Chisholm 6c -/
  lemma grade_smul (r : ℤ) (k : A 0) (a : G) :
  ⟨k • a⟩_r = k • ⟨a⟩_r :=
  by simp only [dfinsupp.smul_apply, linear_map.map_smul]

  /-- chisholm 6d. Modifid to use `_s` instead of `_r` on the right, to keep the statement cast-free -/
  lemma grade_grade (r s : ℤ) (a : G) : ⟨⟨a⟩_r⟩_s = if r = s then ⟨a⟩_s else 0
  := begin
    rw select_coe_is_single,
    rw dfinsupp.single_apply,
    split_ifs,
    {
      cases h with s,
      simp only [],
    },
    simp only [eq_self_iff_true],
  end

  /-- chisholm 6e. The phrasing is made a little awkward by the construction of the finite decomposition of select --/
  lemma grade_sum (g : G) : g = (has_grade_select.select g).sum (λ r, (to_fun : A r → G)) := begin
    apply (is_complete g (has_grade_select.select g)).1,
    refl,
  end

end graded_module


import fibonacci_world.divides  -- hide
open function set -- hide

/-
## A stronger induction principle

We will will use the following basic induction principle, which is
already provided to us by *Lean*, to prove a stronger induction principle,
where the induction hypothesis is about the two previous values.

-/

variables {P : ℕ → Prop} -- hide
lemma induction  (n : ℕ) (h0 : P 0) (h : ∀ n, P n → P (n+1)) : P n
:= nat.rec h0 h n -- hide

/- Axiom : induction
(n : ℕ) (h0 : P 0) (h : ∀ n, P n → P (n+1)) : P n
-/

/-  Lemma :
If $P$ is a predicate on natural numbers, to prove $P(n)$ for all $n$
it suffices to show:

* $P(0)$,
* $P(1)$, and
* $\forall n, P(n) ∧ P (n+1)$ implies $P(n+2)$.
-/
lemma induction' {P : ℕ → Prop} (n : ℕ)
(h : ∀ n, (P n → P (n+1) → P (n+2))) (h0 : P 0) (h1 : P 1) : P n :=
begin
  have h : ∀ n, P n ∧ P (n+1),
  {
    intro n,
    apply induction n,
    split,
    {
      assumption,
    },
    {
      assumption,
    },
    intros n hd,
    cases hd,
    split,
    {
      assumption,
    },
    {
      apply h,
      assumption,
      assumption,
    },
  },
  {
    cases h n,
    assumption,
  },

end


/-
Copyright (c) 2019 Floris van Doorn. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Floris van Doorn
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.set_theory.cardinal_ordinal
import Mathlib.analysis.specific_limits
import Mathlib.data.rat.denumerable
import Mathlib.data.set.intervals.image_preimage
import Mathlib.PostPort

namespace Mathlib

/-!
# The cardinality of the reals

This file shows that the real numbers have cardinality continuum, i.e. `#ℝ = 2^ω`.

We shows that `#ℝ ≤ 2^ω` by noting that every real number is determined by a Cauchy-sequence of the
form `ℕ → ℚ`, which has cardinality `2^ω`. To show that `#ℝ ≥ 2^ω` we define an injection from
`{0, 1} ^ ℕ` to `ℝ` with `f ↦ Σ n, f n * (1 / 3) ^ n`.

We conclude that all intervals with distinct endpoints have cardinality continuum.

## Main definitions

* `cardinal.cantor_function` is the function that sends `f` in `{0, 1} ^ ℕ` to `ℝ` by
  `f ↦ Σ' n, f n * (1 / 3) ^ n`

## Main statements

* `cardinal.mk_real : #ℝ = 2 ^ omega`: the reals have cardinality continuum.
* `cardinal.not_countable_real`: the universal set of real numbers is not countable. We can use this same
  proof to show that all the other sets in this file are not countable.
* 8 lemmas of the form `mk_Ixy_real` for `x,y ∈ {i,o,c}` state that intervals on the reals
  have cardinality continuum.

## Tags
continuum, cardinality, reals, cardinality of the reals
-/

namespace cardinal

/-- The body of the sum in `cantor_function`.
`cantor_function_aux c f n = c ^ n` if `f n = tt`;
`cantor_function_aux c f n = 0` if `f n = ff`. -/
def cantor_function_aux (c : ℝ) (f : ℕ → Bool) (n : ℕ) : ℝ :=
  cond (f n) (c ^ n) 0

@[simp] theorem cantor_function_aux_tt {c : ℝ} {f : ℕ → Bool} {n : ℕ} (h : f n = tt) : cantor_function_aux c f n = c ^ n := sorry

@[simp] theorem cantor_function_aux_ff {c : ℝ} {f : ℕ → Bool} {n : ℕ} (h : f n = false) : cantor_function_aux c f n = 0 := sorry

theorem cantor_function_aux_nonneg {c : ℝ} {f : ℕ → Bool} {n : ℕ} (h : 0 ≤ c) : 0 ≤ cantor_function_aux c f n := sorry

theorem cantor_function_aux_eq {c : ℝ} {f : ℕ → Bool} {g : ℕ → Bool} {n : ℕ} (h : f n = g n) : cantor_function_aux c f n = cantor_function_aux c g n := sorry

theorem cantor_function_aux_succ {c : ℝ} (f : ℕ → Bool) : (fun (n : ℕ) => cantor_function_aux c f (n + 1)) = fun (n : ℕ) => c * cantor_function_aux c (fun (n : ℕ) => f (n + 1)) n := sorry

theorem summable_cantor_function {c : ℝ} (f : ℕ → Bool) (h1 : 0 ≤ c) (h2 : c < 1) : summable (cantor_function_aux c f) := sorry

/-- `cantor_function c (f : ℕ → bool)` is `Σ n, f n * c ^ n`, where `tt` is interpreted as `1` and
`ff` is interpreted as `0`. It is implemented using `cantor_function_aux`. -/
def cantor_function (c : ℝ) (f : ℕ → Bool) : ℝ :=
  tsum fun (n : ℕ) => cantor_function_aux c f n

theorem cantor_function_le {c : ℝ} {f : ℕ → Bool} {g : ℕ → Bool} (h1 : 0 ≤ c) (h2 : c < 1) (h3 : ∀ (n : ℕ), ↥(f n) → ↥(g n)) : cantor_function c f ≤ cantor_function c g := sorry

theorem cantor_function_succ {c : ℝ} (f : ℕ → Bool) (h1 : 0 ≤ c) (h2 : c < 1) : cantor_function c f = cond (f 0) 1 0 + c * cantor_function c fun (n : ℕ) => f (n + 1) := sorry

/-- `cantor_function c` is strictly increasing with if `0 < c < 1/2`, if we endow `ℕ → bool` with a
lexicographic order. The lexicographic order doesn't exist for these infinitary products, so we
explicitly write out what it means. -/
theorem increasing_cantor_function {c : ℝ} (h1 : 0 < c) (h2 : c < 1 / bit0 1) {n : ℕ} {f : ℕ → Bool} {g : ℕ → Bool} (hn : ∀ (k : ℕ), k < n → f k = g k) (fn : f n = false) (gn : g n = tt) : cantor_function c f < cantor_function c g := sorry

/-- `cantor_function c` is injective if `0 < c < 1/2`. -/
theorem cantor_function_injective {c : ℝ} (h1 : 0 < c) (h2 : c < 1 / bit0 1) : function.injective (cantor_function c) := sorry

/-- The cardinality of the reals, as a type. -/
theorem mk_real : mk ℝ = bit0 1 ^ omega := sorry

/-- The cardinality of the reals, as a set. -/
theorem mk_univ_real : mk ↥set.univ = bit0 1 ^ omega :=
  eq.mpr (id (Eq._oldrec (Eq.refl (mk ↥set.univ = bit0 1 ^ omega)) mk_univ))
    (eq.mpr (id (Eq._oldrec (Eq.refl (mk ℝ = bit0 1 ^ omega)) mk_real)) (Eq.refl (bit0 1 ^ omega)))

/-- The reals are not countable. -/
theorem not_countable_real : ¬set.countable set.univ :=
  eq.mpr (id (Eq._oldrec (Eq.refl (¬set.countable set.univ)) (propext (countable_iff set.univ))))
    (eq.mpr (id (Eq._oldrec (Eq.refl (¬mk ↥set.univ ≤ omega)) (propext not_le)))
      (eq.mpr (id (Eq._oldrec (Eq.refl (omega < mk ↥set.univ)) mk_univ_real)) (cantor omega)))

/-- The cardinality of the interval (a, ∞). -/
theorem mk_Ioi_real (a : ℝ) : mk ↥(set.Ioi a) = bit0 1 ^ omega := sorry

/-- The cardinality of the interval [a, ∞). -/
theorem mk_Ici_real (a : ℝ) : mk ↥(set.Ici a) = bit0 1 ^ omega :=
  le_antisymm (mk_real ▸ mk_set_le (set.Ici a)) (mk_Ioi_real a ▸ mk_le_mk_of_subset set.Ioi_subset_Ici_self)

/-- The cardinality of the interval (-∞, a). -/
theorem mk_Iio_real (a : ℝ) : mk ↥(set.Iio a) = bit0 1 ^ omega := sorry

/-- The cardinality of the interval (-∞, a]. -/
theorem mk_Iic_real (a : ℝ) : mk ↥(set.Iic a) = bit0 1 ^ omega :=
  le_antisymm (mk_real ▸ mk_set_le (set.Iic a)) (mk_Iio_real a ▸ mk_le_mk_of_subset set.Iio_subset_Iic_self)

/-- The cardinality of the interval (a, b). -/
theorem mk_Ioo_real {a : ℝ} {b : ℝ} (h : a < b) : mk ↥(set.Ioo a b) = bit0 1 ^ omega := sorry

/-- The cardinality of the interval [a, b). -/
theorem mk_Ico_real {a : ℝ} {b : ℝ} (h : a < b) : mk ↥(set.Ico a b) = bit0 1 ^ omega :=
  le_antisymm (mk_real ▸ mk_set_le (set.Ico a b)) (mk_Ioo_real h ▸ mk_le_mk_of_subset set.Ioo_subset_Ico_self)

/-- The cardinality of the interval [a, b]. -/
theorem mk_Icc_real {a : ℝ} {b : ℝ} (h : a < b) : mk ↥(set.Icc a b) = bit0 1 ^ omega :=
  le_antisymm (mk_real ▸ mk_set_le (set.Icc a b)) (mk_Ioo_real h ▸ mk_le_mk_of_subset set.Ioo_subset_Icc_self)

/-- The cardinality of the interval (a, b]. -/
theorem mk_Ioc_real {a : ℝ} {b : ℝ} (h : a < b) : mk ↥(set.Ioc a b) = bit0 1 ^ omega :=
  le_antisymm (mk_real ▸ mk_set_le (set.Ioc a b)) (mk_Ioo_real h ▸ mk_le_mk_of_subset set.Ioo_subset_Ioc_self)


/-
Copyright (c) 2023 María Inés de Frutos-Fernández. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: María Inés de Frutos-Fernández
-/
import from_mathlib.rank_one_valuation
import from_mathlib.ring_seminorm
import topology.algebra.valuation

/-!
# Correspondence between nontrivial nonarchimedean norms and rank one valuations

Nontrivial nonarchimedean norms correspond to rank one valuations.

## Main Definitions
* `normed_field.to_valued` : the valued field structure on a nonarchimedean normed field `K`,
  determined by the norm.
* `valued_field.to_normed_field` : the normed field structure determined by a rank one valuation.

## Main Results
* `real.exists_strict_mono_lt` : if `Γ₀ˣ` is nontrivial and `f : Γ₀ →*₀ ℝ≥0` is a strict
  monomorphism, then for any positive real `r`, there exists `d : Γ₀ˣ` with `f d < r`.

## Tags

norm, nonarchimedean, nontrivial, valuation, rank one
-/

noncomputable theory

open_locale nnreal

variables {K : Type*} [hK : normed_field K]
include hK

/-- The valuation on a nonarchimedean normed field `K` defined as `nnnorm`. -/
def valuation_from_norm (h : is_nonarchimedean (norm : K → ℝ)) : valuation K ℝ≥0 :=
{ to_fun    := nnnorm,
  map_zero' := nnnorm_zero,
  map_one'  := nnnorm_one,
  map_mul'  := nnnorm_mul,
  map_add_le_max' := h }

lemma valuation_from_norm_apply (h : is_nonarchimedean (norm : K → ℝ)) (x : K):
  valuation_from_norm h x = ‖ x ‖₊ := rfl

/-- The valued field structure on a nonarchimedean normed field `K`, determined by the norm. -/
def normed_field.to_valued (h : is_nonarchimedean (norm : K → ℝ)) : valued K ℝ≥0 :=
{ v := valuation_from_norm h,
  is_topological_valuation := λ U,
  begin
    rw metric.mem_nhds_iff,
    refine ⟨λ h, _, λ h, _⟩,
    { obtain ⟨ε, hε, h⟩ := h,
      use units.mk0 ⟨ε, le_of_lt hε⟩ (ne_of_gt hε),
      intros x hx,
      exact h (mem_ball_zero_iff.mpr hx) },
    { obtain ⟨ε, hε⟩ := h,
      use [(ε : ℝ), nnreal.coe_pos.mpr (units.zero_lt _)],
      intros x hx,
      exact hε  (mem_ball_zero_iff.mp hx) },
  end,
  ..hK.to_uniform_space,
  ..non_unital_normed_ring.to_normed_add_comm_group }

omit hK

variables {L : Type*} [hL : field L] {Γ₀ : Type*} [linear_ordered_comm_group_with_zero Γ₀]
  [val : valued L Γ₀] [hv : is_rank_one val.v]

/-- If `Γ₀ˣ` is nontrivial and `f : Γ₀ →*₀ ℝ≥0` is a strict monomorphism, then for any positive
  `r : ℝ≥0`, there exists `d : Γ₀ˣ` with `f d < r`. -/
lemma nnreal.exists_strict_mono_lt {g : Γ₀ˣ} (hg1 : g ≠ 1) {f : Γ₀ →*₀ ℝ≥0} (hf : strict_mono f)
  {r : ℝ≥0} (hr : 0 < r) :  ∃ d : Γ₀ˣ, f d < r :=
begin
  set u : Γ₀ˣ := if g < 1 then g else g⁻¹ with hu,
  have hfu : f u < 1,
  { rw hu,
    split_ifs with hu1,
    { rw ← map_one f, exact hf hu1, },
    { have hfg0 : f g ≠ 0,
      { intro h0,
        exact (units.ne_zero g)  ((map_eq_zero f).mp h0), },
      have hg1' : 1 < g,
      { exact lt_of_le_of_ne (not_lt.mp hu1) hg1.symm },
      simp only [units.coe_inv, map_inv₀],
      rw [nnreal.inv_lt_one_iff hfg0, ← map_one f],
      exact hf hg1', }},
  obtain ⟨n, hn⟩ := nnreal.exists_pow_lt_of_lt_one hr hfu,
  use u^n,
  rw [units.coe_pow, map_pow],
  exact hn,
end

/-- If `Γ₀ˣ` is nontrivial and `f : Γ₀ →*₀ ℝ≥0` is a strict monomorphism, then for any positive
  real `r`, there exists `d : Γ₀ˣ` with `f d < r`. -/
lemma real.exists_strict_mono_lt {g : Γ₀ˣ} (hg1 : g ≠ 1) {f : Γ₀ →*₀ ℝ≥0} (hf : strict_mono f)
  {r : ℝ} (hr : 0 < r) :  ∃ d : Γ₀ˣ, (f d : ℝ) < r :=
begin
  set s : nnreal := ⟨r, le_of_lt hr⟩,
  have hs : 0 < s := hr,
  exact nnreal.exists_strict_mono_lt hg1 hf hs,
end

include hL val hv

namespace rank_one_valuation

/-- The norm function determined by a rank one valuation on a field `L`. -/
def norm_def : L → ℝ := λ x : L, hv.hom (valued.v x)

lemma norm_def_nonneg (x : L) : 0 ≤ norm_def x := by simp only [norm_def, nnreal.zero_le_coe]

lemma norm_def_add_le  (x y : L) :
  norm_def (x + y) ≤ max (norm_def x) (norm_def y) :=
begin
  simp only [norm_def, nnreal.coe_le_coe, le_max_iff, strict_mono.le_iff_le hv.strict_mono],
  exact le_max_iff.mp (valuation.map_add_le_max' val.v _ _),
end

lemma norm_def_eq_zero {x : L} (hx : norm_def x = 0) : x = 0 :=
by simpa [norm_def, nnreal.coe_eq_zero, is_rank_one_hom_eq_zero_iff, valuation.zero_iff] using hx

/-- The normed field structure determined by a rank one valuation. -/
def valued_field.to_normed_field : normed_field L :=
{ norm               := norm_def,
  dist               := λ x y, norm_def (x - y),
  dist_self          := λ x, by simp only [sub_self, norm_def, valuation.map_zero,
    (hv.hom).map_zero, nnreal.coe_zero],
  dist_comm          := λ x y, by { simp only [norm_def], rw [← neg_sub, valuation.map_neg] },
  dist_triangle      := λ x y z,
  begin
    simp only [← sub_add_sub_cancel x y z],
    exact le_trans (norm_def_add_le _ _)
      (max_le_add_of_nonneg (norm_def_nonneg _) (norm_def_nonneg _)),
  end,
  eq_of_dist_eq_zero := λ x y hxy, eq_of_sub_eq_zero (norm_def_eq_zero hxy),
  dist_eq            := λ x y, rfl,
  norm_mul'          := λ x y, by { simp only [norm_def, ← nnreal.coe_mul, map_mul], },
  to_uniform_space   := valued.to_uniform_space,
  uniformity_dist    :=
  begin
    ext U,
    rw [filter.has_basis_iff.mp (valued.has_basis_uniformity L Γ₀), infi_subtype',
      filter.mem_infi_of_directed],
    { simp only [exists_true_left, filter.mem_principal, subtype.exists, gt_iff_lt, subtype.coe_mk,
        exists_prop, true_and],
      refine ⟨λ h, _, λ h, _⟩,
      { obtain ⟨ε,  hε⟩ := h,
        set δ : ℝ≥0 := hv.hom ε with hδ,
        have hδ_pos : 0 < δ,
        { rw [hδ, ← map_zero hv.hom],
        exact hv.strict_mono (units.zero_lt ε), },
        use [δ, hδ_pos],
        apply subset_trans _ hε,
        intros x hx,
        simp only [set.mem_set_of_eq, norm_def, hδ, nnreal.val_eq_coe, nnreal.coe_lt_coe] at hx,
        rw [set.mem_set_of, ← neg_sub, valuation.map_neg],
        exact hv.strict_mono.lt_iff_lt.mp hx },
      { obtain ⟨r, hr_pos, hr⟩ := h,
        obtain ⟨u, hu⟩ :=
        real.exists_strict_mono_lt (is_rank_one_unit_ne_one val.v) hv.strict_mono hr_pos,
        use u,
        apply subset_trans _ hr,
        intros x hx,
        simp only [norm_def, set.mem_set_of_eq],
        apply lt_trans _ hu,
        rw [nnreal.coe_lt_coe, ← neg_sub, valuation.map_neg],
        exact hv.strict_mono.lt_iff_lt.mpr hx, }},
    { simp only [gt_iff_lt, ge_iff_le, directed],
      intros x y,
      use min x y,
      simp only [filter.le_principal_iff, filter.mem_principal, set.set_of_subset_set_of,
          prod.forall],
      exact ⟨λ a b hab, lt_of_lt_of_le hab (min_le_left _ _),
        λ a b hab, lt_of_lt_of_le hab (min_le_right _ _)⟩ }
  end,
  ..hL, }

  end rank_one_valuation


/-
Copyright (c) 2019 Chris Hughes. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Chris Hughes, Johan Commelin
-/
import data.polynomial.field_division
import ring_theory.integral_closure
import ring_theory.polynomial.gauss_lemma

/-!
# Minimal polynomials

This file defines the minimal polynomial of an element `x` of an `A`-algebra `B`,
under the assumption that x is integral over `A`.

After stating the defining property we specialize to the setting of field extensions
and derive some well-known properties, amongst which the fact that minimal polynomials
are irreducible, and uniquely determined by their defining property.

-/

open_locale classical polynomial
open polynomial set function

variables {A B : Type*}

section min_poly_def
variables (A) [comm_ring A] [ring B] [algebra A B]

/--
Suppose `x : B`, where `B` is an `A`-algebra.

The minimal polynomial `minpoly A x` of `x`
is a monic polynomial with coefficients in `A` of smallest degree that has `x` as its root,
if such exists (`is_integral A x`) or zero otherwise.

For example, if `V` is a `𝕜`-vector space for some field `𝕜` and `f : V →ₗ[𝕜] V` then
the minimal polynomial of `f` is `minpoly 𝕜 f`.
-/
noncomputable def minpoly (x : B) : A[X] :=
if hx : is_integral A x then well_founded.min degree_lt_wf _ hx else 0

end min_poly_def

namespace minpoly

section ring
variables [comm_ring A] [ring B] [algebra A B]
variables {x : B}

/-- A minimal polynomial is monic. -/
lemma monic (hx : is_integral A x) : monic (minpoly A x) :=
by { delta minpoly, rw dif_pos hx, exact (well_founded.min_mem degree_lt_wf _ hx).1 }

/-- A minimal polynomial is nonzero. -/
lemma ne_zero [nontrivial A] (hx : is_integral A x) : minpoly A x ≠ 0 :=
(monic hx).ne_zero

lemma eq_zero (hx : ¬ is_integral A x) : minpoly A x = 0 :=
dif_neg hx

variables (A x)

/-- An element is a root of its minimal polynomial. -/
@[simp] lemma aeval : aeval x (minpoly A x) = 0 :=
begin
  delta minpoly, split_ifs with hx,
  { exact (well_founded.min_mem degree_lt_wf _ hx).2 },
  { exact aeval_zero _ }
end

/-- A minimal polynomial is not `1`. -/
lemma ne_one [nontrivial B] : minpoly A x ≠ 1 :=
begin
  intro h,
  refine (one_ne_zero : (1 : B) ≠ 0) _,
  simpa using congr_arg (polynomial.aeval x) h
end

lemma map_ne_one [nontrivial B] {R : Type*} [semiring R] [nontrivial R] (f : A →+* R) :
  (minpoly A x).map f ≠ 1 :=
begin
  by_cases hx : is_integral A x,
  { exact mt ((monic hx).eq_one_of_map_eq_one f) (ne_one A x) },
  { rw [eq_zero hx, polynomial.map_zero], exact zero_ne_one },
end

/-- A minimal polynomial is not a unit. -/
lemma not_is_unit [nontrivial B] : ¬ is_unit (minpoly A x) :=
begin
  haveI : nontrivial A := (algebra_map A B).domain_nontrivial,
  by_cases hx : is_integral A x,
  { exact mt (eq_one_of_is_unit_of_monic (monic hx)) (ne_one A x) },
  { rw [eq_zero hx], exact not_is_unit_zero }
end

lemma mem_range_of_degree_eq_one (hx : (minpoly A x).degree = 1) : x ∈ (algebra_map A B).range :=
begin
  have h : is_integral A x,
  { by_contra h,
    rw [eq_zero h, degree_zero, ←with_bot.coe_one] at hx,
    exact (ne_of_lt (show ⊥ < ↑1, from with_bot.bot_lt_coe 1) hx) },
  have key := minpoly.aeval A x,
  rw [eq_X_add_C_of_degree_eq_one hx, (minpoly.monic h).leading_coeff, C_1, one_mul, aeval_add,
      aeval_C, aeval_X, ←eq_neg_iff_add_eq_zero, ←ring_hom.map_neg] at key,
  exact ⟨-(minpoly A x).coeff 0, key.symm⟩,
end

/-- The defining property of the minimal polynomial of an element `x`:
it is the monic polynomial with smallest degree that has `x` as its root. -/
lemma min {p : A[X]} (pmonic : p.monic) (hp : polynomial.aeval x p = 0) :
  degree (minpoly A x) ≤ degree p :=
begin
  delta minpoly, split_ifs with hx,
  { exact le_of_not_lt (well_founded.not_lt_min degree_lt_wf _ hx ⟨pmonic, hp⟩) },
  { simp only [degree_zero, bot_le] }
end

@[nontriviality] lemma subsingleton [subsingleton B] : minpoly A x = 1 :=
begin
  nontriviality A,
  have := minpoly.min A x monic_one (subsingleton.elim _ _),
  rw degree_one at this,
  cases le_or_lt (minpoly A x).degree 0 with h h,
  { rwa (monic ⟨1, monic_one, by simp⟩ : (minpoly A x).monic).degree_le_zero_iff_eq_one at h },
  { exact (this.not_lt h).elim },
end

end ring

section comm_ring

variables [comm_ring A]

section ring

variables [ring B] [algebra A B] [nontrivial B]
variables {x : B}

/-- The degree of a minimal polynomial, as a natural number, is positive. -/
lemma nat_degree_pos (hx : is_integral A x) : 0 < nat_degree (minpoly A x) :=
begin
  rw pos_iff_ne_zero,
  intro ndeg_eq_zero,
  have eq_one : minpoly A x = 1,
  { rw eq_C_of_nat_degree_eq_zero ndeg_eq_zero, convert C_1,
    simpa only [ndeg_eq_zero.symm] using (monic hx).leading_coeff },
  simpa only [eq_one, alg_hom.map_one, one_ne_zero] using aeval A x
end

/-- The degree of a minimal polynomial is positive. -/
lemma degree_pos (hx : is_integral A x) : 0 < degree (minpoly A x) :=
nat_degree_pos_iff_degree_pos.mp (nat_degree_pos hx)

/-- If `B/A` is an injective ring extension, and `a` is an element of `A`,
then the minimal polynomial of `algebra_map A B a` is `X - C a`. -/
lemma eq_X_sub_C_of_algebra_map_inj
  (a : A) (hf : function.injective (algebra_map A B)) :
  minpoly A (algebra_map A B a) = X - C a :=
begin
  nontriviality A,
  have hdegle : (minpoly A (algebra_map A B a)).nat_degree ≤ 1,
  { apply with_bot.coe_le_coe.1,
    rw [←degree_eq_nat_degree (ne_zero (@is_integral_algebra_map A B _ _ _ a)),
      with_top.coe_one, ←degree_X_sub_C a],
    refine min A (algebra_map A B a) (monic_X_sub_C a) _,
    simp only [aeval_C, aeval_X, alg_hom.map_sub, sub_self] },
  have hdeg : (minpoly A (algebra_map A B a)).degree = 1,
  { apply (degree_eq_iff_nat_degree_eq (ne_zero (@is_integral_algebra_map A B _ _ _ a))).2,
    apply le_antisymm hdegle (nat_degree_pos (@is_integral_algebra_map A B _ _ _ a)) },
  have hrw := eq_X_add_C_of_degree_eq_one hdeg,
  simp only [monic (@is_integral_algebra_map A B _ _ _ a), one_mul,
    monic.leading_coeff, ring_hom.map_one] at hrw,
  have h0 : (minpoly A (algebra_map A B a)).coeff 0 = -a,
  { have hroot := aeval A (algebra_map A B a),
    rw [hrw, add_comm] at hroot,
    simp only [aeval_C, aeval_X, aeval_add] at hroot,
    replace hroot := eq_neg_of_add_eq_zero_left hroot,
    rw [←ring_hom.map_neg _ a] at hroot,
    exact (hf hroot) },
  rw hrw,
  simp only [h0, ring_hom.map_neg, sub_eq_add_neg],
end

end ring

section is_domain

variables [is_domain A] [ring B] [algebra A B]
variables {x : B}

/-- If `a` strictly divides the minimal polynomial of `x`, then `x` cannot be a root for `a`. -/
lemma aeval_ne_zero_of_dvd_not_unit_minpoly {a : A[X]} (hx : is_integral A x)
  (hamonic : a.monic) (hdvd : dvd_not_unit a (minpoly A x)) :
  polynomial.aeval x a ≠ 0 :=
begin
  intro ha,
  refine not_lt_of_ge (minpoly.min A x hamonic ha) _,
  obtain ⟨hzeroa, b, hb_nunit, prod⟩ := hdvd,
  have hbmonic : b.monic,
  { rw monic.def,
    have := monic hx,
    rwa [monic.def, prod, leading_coeff_mul, monic.def.mp hamonic, one_mul] at this },
  have hzerob : b ≠ 0 := hbmonic.ne_zero,
  have degbzero : 0 < b.nat_degree,
  { apply nat.pos_of_ne_zero,
    intro h,
    have h₁ := eq_C_of_nat_degree_eq_zero h,
    rw [←h, ←leading_coeff, monic.def.1 hbmonic, C_1] at h₁,
    rw h₁ at hb_nunit,
    have := is_unit_one,
    contradiction },
  rw [prod, degree_mul, degree_eq_nat_degree hzeroa, degree_eq_nat_degree hzerob],
  exact_mod_cast lt_add_of_pos_right _ degbzero,
end

variables [is_domain B]

/-- A minimal polynomial is irreducible. -/
lemma irreducible (hx : is_integral A x) : irreducible (minpoly A x) :=
begin
  cases irreducible_or_factor (minpoly A x) (not_is_unit A x) with hirr hred,
  { exact hirr },
  exfalso,
  obtain ⟨a, b, ha_nunit, hb_nunit, hab_eq⟩ := hred,
  have coeff_prod : a.leading_coeff * b.leading_coeff = 1,
  { rw [←monic.def.1 (monic hx), ←hab_eq],
    simp only [leading_coeff_mul] },
  have hamonic : (a * C b.leading_coeff).monic,
  { rw monic.def,
    simp only [coeff_prod, leading_coeff_mul, leading_coeff_C] },
  have hbmonic : (b * C a.leading_coeff).monic,
  { rw [monic.def, mul_comm],
    simp only [coeff_prod, leading_coeff_mul, leading_coeff_C] },
  have prod : minpoly A x = (a * C b.leading_coeff) * (b * C a.leading_coeff),
  { symmetry,
    calc a * C b.leading_coeff * (b * C a.leading_coeff)
        = a * b * (C a.leading_coeff * C b.leading_coeff) : by ring
    ... = a * b * (C (a.leading_coeff * b.leading_coeff)) : by simp only [ring_hom.map_mul]
    ... = a * b : by rw [coeff_prod, C_1, mul_one]
    ... = minpoly A x : hab_eq },
  have hzero := aeval A x,
  rw [prod, aeval_mul, mul_eq_zero] at hzero,
  cases hzero,
  { refine aeval_ne_zero_of_dvd_not_unit_minpoly hx hamonic _ hzero,
    exact ⟨hamonic.ne_zero, _, mt is_unit_of_mul_is_unit_left hb_nunit, prod⟩ },
  { refine aeval_ne_zero_of_dvd_not_unit_minpoly hx hbmonic _ hzero,
    rw mul_comm at prod,
    exact ⟨hbmonic.ne_zero, _, mt is_unit_of_mul_is_unit_left ha_nunit, prod⟩ },
end

end is_domain

end comm_ring

section field
variables [field A]

section ring
variables [ring B] [algebra A B]
variables {x : B}

variables (A x)

/-- If an element `x` is a root of a nonzero polynomial `p`,
then the degree of `p` is at least the degree of the minimal polynomial of `x`. -/
lemma degree_le_of_ne_zero
  {p : A[X]} (pnz : p ≠ 0) (hp : polynomial.aeval x p = 0) :
  degree (minpoly A x) ≤ degree p :=
calc degree (minpoly A x) ≤ degree (p * C (leading_coeff p)⁻¹) :
    min A x (monic_mul_leading_coeff_inv pnz) (by simp [hp])
  ... = degree p : degree_mul_leading_coeff_inv p pnz

lemma ne_zero_of_finite_field_extension (e : B) [finite_dimensional A B] : minpoly A e ≠ 0 :=
minpoly.ne_zero $ is_integral_of_noetherian (is_noetherian.iff_fg.2 infer_instance) _

/-- The minimal polynomial of an element `x` is uniquely characterized by its defining property:
if there is another monic polynomial of minimal degree that has `x` as a root,
then this polynomial is equal to the minimal polynomial of `x`. -/
lemma unique {p : A[X]}
  (pmonic : p.monic) (hp : polynomial.aeval x p = 0)
  (pmin : ∀ q : A[X], q.monic → polynomial.aeval x q = 0 → degree p ≤ degree q) :
  p = minpoly A x :=
begin
  have hx : is_integral A x := ⟨p, pmonic, hp⟩,
  symmetry, apply eq_of_sub_eq_zero,
  by_contra hnz,
  have := degree_le_of_ne_zero A x hnz (by simp [hp]),
  contrapose! this,
  apply degree_sub_lt _ (ne_zero hx),
  { rw [(monic hx).leading_coeff, pmonic.leading_coeff] },
  { exact le_antisymm (min A x pmonic hp)
      (pmin (minpoly A x) (monic hx) (aeval A x)) }
end

/-- If an element `x` is a root of a polynomial `p`,
then the minimal polynomial of `x` divides `p`. -/
lemma dvd {p : A[X]} (hp : polynomial.aeval x p = 0) : minpoly A x ∣ p :=
begin
  by_cases hp0 : p = 0,
  { simp only [hp0, dvd_zero] },
  have hx : is_integral A x,
  { rw ← is_algebraic_iff_is_integral, exact ⟨p, hp0, hp⟩ },
  rw ← dvd_iff_mod_by_monic_eq_zero (monic hx),
  by_contra hnz,
  have := degree_le_of_ne_zero A x hnz _,
  { contrapose! this,
    exact degree_mod_by_monic_lt _ (monic hx) },
  { rw ← mod_by_monic_add_div p (monic hx) at hp,
    simpa using hp }
end

lemma dvd_map_of_is_scalar_tower (A K : Type*) {R : Type*} [comm_ring A] [field K] [comm_ring R]
  [algebra A K] [algebra A R] [algebra K R] [is_scalar_tower A K R] (x : R) :
  minpoly K x ∣ (minpoly A x).map (algebra_map A K) :=
by { refine minpoly.dvd K x _, rw [← is_scalar_tower.aeval_apply, minpoly.aeval] }

/-- If `y` is a conjugate of `x` over a field `K`, then it is a conjugate over a subring `R`. -/
lemma aeval_of_is_scalar_tower (R : Type*) {K T U : Type*} [comm_ring R] [field K] [comm_ring T]
  [algebra R K] [algebra K T] [algebra R T] [is_scalar_tower R K T]
  [comm_semiring U] [algebra K U] [algebra R U] [is_scalar_tower R K U]
  (x : T) (y : U)
  (hy : polynomial.aeval y (minpoly K x) = 0) : polynomial.aeval y (minpoly R x) = 0 :=
by { rw is_scalar_tower.aeval_apply R K,
     exact eval₂_eq_zero_of_dvd_of_eval₂_eq_zero (algebra_map K U) y
        (minpoly.dvd_map_of_is_scalar_tower R K x) hy }

variables {A x}

theorem eq_of_irreducible_of_monic
  [nontrivial B] {p : A[X]} (hp1 : _root_.irreducible p)
  (hp2 : polynomial.aeval x p = 0) (hp3 : p.monic) : p = minpoly A x :=
let ⟨q, hq⟩ := dvd A x hp2 in
eq_of_monic_of_associated hp3 (monic ⟨p, ⟨hp3, hp2⟩⟩) $
mul_one (minpoly A x) ▸ hq.symm ▸ associated.mul_left _ $
associated_one_iff_is_unit.2 $ (hp1.is_unit_or_is_unit hq).resolve_left $ not_is_unit A x

lemma eq_of_irreducible [nontrivial B] {p : A[X]}
  (hp1 : _root_.irreducible p) (hp2 : polynomial.aeval x p = 0) :
  p * C p.leading_coeff⁻¹ = minpoly A x :=
begin
  have : p.leading_coeff ≠ 0 := leading_coeff_ne_zero.mpr hp1.ne_zero,
  apply eq_of_irreducible_of_monic,
  { exact associated.irreducible ⟨⟨C p.leading_coeff⁻¹, C p.leading_coeff,
      by rwa [←C_mul, inv_mul_cancel, C_1], by rwa [←C_mul, mul_inv_cancel, C_1]⟩, rfl⟩ hp1 },
  { rw [aeval_mul, hp2, zero_mul] },
  { rwa [polynomial.monic, leading_coeff_mul, leading_coeff_C, mul_inv_cancel] },
end

/-- If `y` is the image of `x` in an extension, their minimal polynomials coincide.

We take `h : y = algebra_map L T x` as an argument because `rw h` typically fails
since `is_integral R y` depends on y.
-/
lemma eq_of_algebra_map_eq {K S T : Type*} [field K] [comm_ring S] [comm_ring T]
  [algebra K S] [algebra K T] [algebra S T]
  [is_scalar_tower K S T] (hST : function.injective (algebra_map S T))
  {x : S} {y : T} (hx : is_integral K x) (h : y = algebra_map S T x) :
  minpoly K x = minpoly K y :=
minpoly.unique _ _ (minpoly.monic hx)
  (by rw [h, ← is_scalar_tower.algebra_map_aeval, minpoly.aeval, ring_hom.map_zero])
  (λ q q_monic root_q, minpoly.min _ _ q_monic
    (is_scalar_tower.aeval_eq_zero_of_aeval_algebra_map_eq_zero K S T hST
      (h ▸ root_q : polynomial.aeval (algebra_map S T x) q = 0)))

lemma add_algebra_map {B : Type*} [comm_ring B] [algebra A B] {x : B}
  (hx : is_integral A x) (a : A) :
  minpoly A (x + (algebra_map A B a)) = (minpoly A x).comp (X - C a) :=
begin
  refine (minpoly.unique _ _ ((minpoly.monic hx).comp_X_sub_C _) _ (λ q qmo hq, _)).symm,
  { simp [aeval_comp] },
  { have : (polynomial.aeval x) (q.comp (X + C a)) = 0 := by simpa [aeval_comp] using hq,
    have H := minpoly.min A x (qmo.comp_X_add_C _) this,
    rw [degree_eq_nat_degree qmo.ne_zero, degree_eq_nat_degree
      ((minpoly.monic hx).comp_X_sub_C _).ne_zero, with_bot.coe_le_coe, nat_degree_comp,
      nat_degree_X_sub_C, mul_one],
    rwa [degree_eq_nat_degree (minpoly.ne_zero hx), degree_eq_nat_degree
      (qmo.comp_X_add_C _).ne_zero, with_bot.coe_le_coe, nat_degree_comp,
      nat_degree_X_add_C, mul_one] at H }
end

lemma sub_algebra_map {B : Type*} [comm_ring B] [algebra A B] {x : B}
  (hx : is_integral A x) (a : A) :
  minpoly A (x - (algebra_map A B a)) = (minpoly A x).comp (X + C a) :=
by simpa [sub_eq_add_neg] using add_algebra_map hx (-a)

section gcd_domain

/-- For GCD domains, the minimal polynomial over the ring is the same as the minimal polynomial
over the fraction field. -/
lemma gcd_domain_eq_field_fractions {A R : Type*} (K : Type*) [comm_ring A] [is_domain A]
  [normalized_gcd_monoid A] [field K]
  [comm_ring R] [is_domain R] [algebra A K] [is_fraction_ring A K]
  [algebra K R] [algebra A R] [is_scalar_tower A K R] {x : R} (hx : is_integral A x) :
  minpoly K x = (minpoly A x).map (algebra_map A K) :=
begin
  symmetry,
  refine eq_of_irreducible_of_monic _ _ _,
  { exact (polynomial.is_primitive.irreducible_iff_irreducible_map_fraction_map
      (polynomial.monic.is_primitive (monic hx))).1 (irreducible hx) },
  { have htower := is_scalar_tower.aeval_apply A K R x (minpoly A x),
    rwa [aeval, eq_comm] at htower },
  { exact (monic hx).map _ }
end

/-- For GCD domains, the minimal polynomial divides any primitive polynomial that has the integral
element as root. -/
lemma gcd_domain_dvd {A R : Type*} (K : Type*)
  [comm_ring A] [is_domain A] [normalized_gcd_monoid A] [field K]
  [comm_ring R] [is_domain R] [algebra A K]
  [is_fraction_ring A K] [algebra K R] [algebra A R] [is_scalar_tower A K R]
  {x : R} (hx : is_integral A x)
  {P : A[X]} (hprim : is_primitive P) (hroot : polynomial.aeval x P = 0) :
  minpoly A x ∣ P :=
begin
  apply (is_primitive.dvd_iff_fraction_map_dvd_fraction_map K
    (monic.is_primitive (monic hx)) hprim).2,
  rw ← gcd_domain_eq_field_fractions K hx,
  refine dvd _ _ _,
  rwa ← is_scalar_tower.aeval_apply
end

end gcd_domain

variables (B) [nontrivial B]

/-- If `B/K` is a nontrivial algebra over a field, and `x` is an element of `K`,
then the minimal polynomial of `algebra_map K B x` is `X - C x`. -/
lemma eq_X_sub_C (a : A) : minpoly A (algebra_map A B a) = X - C a :=
eq_X_sub_C_of_algebra_map_inj a (algebra_map A B).injective

lemma eq_X_sub_C' (a : A) : minpoly A a = X - C a := eq_X_sub_C A a

variables (A)

/-- The minimal polynomial of `0` is `X`. -/
@[simp] lemma zero : minpoly A (0:B) = X :=
by simpa only [add_zero, C_0, sub_eq_add_neg, neg_zero, ring_hom.map_zero]
  using eq_X_sub_C B (0:A)

/-- The minimal polynomial of `1` is `X - 1`. -/
@[simp] lemma one : minpoly A (1:B) = X - 1 :=
by simpa only [ring_hom.map_one, C_1, sub_eq_add_neg] using eq_X_sub_C B (1:A)

end ring

section is_domain
variables [ring B] [is_domain B] [algebra A B]
variables {x : B}

/-- A minimal polynomial is prime. -/
lemma prime (hx : is_integral A x) : prime (minpoly A x) :=
begin
  refine ⟨ne_zero hx, not_is_unit A x, _⟩,
  rintros p q ⟨d, h⟩,
  have :    polynomial.aeval x (p*q) = 0 := by simp [h, aeval A x],
  replace : polynomial.aeval x p = 0 ∨ polynomial.aeval x q = 0 := by simpa,
  exact or.imp (dvd A x) (dvd A x) this
end

/-- If `L/K` is a field extension and an element `y` of `K` is a root of the minimal polynomial
of an element `x ∈ L`, then `y` maps to `x` under the field embedding. -/
lemma root {x : B} (hx : is_integral A x) {y : A} (h : is_root (minpoly A x) y) :
  algebra_map A B y = x :=
have key : minpoly A x = X - C y :=
eq_of_monic_of_associated (monic hx) (monic_X_sub_C y) (associated_of_dvd_dvd
  ((irreducible_X_sub_C y).dvd_symm (irreducible hx) (dvd_iff_is_root.2 h))
  (dvd_iff_is_root.2 h)),
by { have := aeval A x, rwa [key, alg_hom.map_sub, aeval_X, aeval_C, sub_eq_zero, eq_comm] at this }

/-- The constant coefficient of the minimal polynomial of `x` is `0` if and only if `x = 0`. -/
@[simp] lemma coeff_zero_eq_zero (hx : is_integral A x) : coeff (minpoly A x) 0 = 0 ↔ x = 0 :=
begin
  split,
  { intro h,
    have zero_root := zero_is_root_of_coeff_zero_eq_zero h,
    rw ← root hx zero_root,
    exact ring_hom.map_zero _ },
  { rintro rfl, simp }
end

/-- The minimal polynomial of a nonzero element has nonzero constant coefficient. -/
lemma coeff_zero_ne_zero (hx : is_integral A x) (h : x ≠ 0) : coeff (minpoly A x) 0 ≠ 0 :=
by { contrapose! h, simpa only [hx, coeff_zero_eq_zero] using h }

end is_domain

end field

end minpoly


/-
Copyright (c) 2020 Anatole Dedecker. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Anatole Dedecker, Alexey Soloyev, Junyan Xu

! This file was ported from Lean 3 source module data.real.golden_ratio
! leanprover-community/mathlib commit 2196ab363eb097c008d4497125e0dde23fb36db2
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Data.Real.Irrational
import Mathbin.Data.Nat.Fib
import Mathbin.Data.Nat.PrimeNormNum
import Mathbin.Data.Fin.VecNotation
import Mathbin.Tactic.RingExp
import Mathbin.Algebra.LinearRecurrence

/-!
# The golden ratio and its conjugate

This file defines the golden ratio `φ := (1 + √5)/2` and its conjugate
`ψ := (1 - √5)/2`, which are the two real roots of `X² - X - 1`.

Along with various computational facts about them, we prove their
irrationality, and we link them to the Fibonacci sequence by proving
Binet's formula.
-/

noncomputable section

open Polynomial

/-- The golden ratio `φ := (1 + √5)/2`. -/
@[reducible]
def goldenRatio :=
  (1 + Real.sqrt 5) / 2
#align golden_ratio goldenRatio

/-- The conjugate of the golden ratio `ψ := (1 - √5)/2`. -/
@[reducible]
def goldenConj :=
  (1 - Real.sqrt 5) / 2
#align golden_conj goldenConj

-- mathport name: golden_ratio
scoped[Real] notation "φ" => goldenRatio

-- mathport name: golden_conj
scoped[Real] notation "ψ" => goldenConj

/-- The inverse of the golden ratio is the opposite of its conjugate. -/
theorem inv_gold : φ⁻¹ = -ψ :=
  by
  have : 1 + Real.sqrt 5 ≠ 0 := ne_of_gt (add_pos (by norm_num) <| real.sqrt_pos.mpr (by norm_num))
  field_simp [sub_mul, mul_add]
  norm_num
#align inv_gold inv_gold

/-- The opposite of the golden ratio is the inverse of its conjugate. -/
theorem inv_gold_conj : ψ⁻¹ = -φ :=
  by
  rw [inv_eq_iff_eq_inv, ← neg_inv, ← neg_eq_iff_eq_neg]
  exact inv_gold.symm
#align inv_gold_conj inv_gold_conj

@[simp]
theorem gold_mul_gold_conj : φ * ψ = -1 := by
  field_simp
  rw [← sq_sub_sq]
  norm_num
#align gold_mul_gold_conj gold_mul_gold_conj

@[simp]
theorem gold_conj_mul_gold : ψ * φ = -1 := by
  rw [mul_comm]
  exact gold_mul_gold_conj
#align gold_conj_mul_gold gold_conj_mul_gold

@[simp]
theorem gold_add_gold_conj : φ + ψ = 1 :=
  by
  rw [goldenRatio, goldenConj]
  ring
#align gold_add_gold_conj gold_add_gold_conj

theorem one_sub_gold_conj : 1 - φ = ψ := by linarith [gold_add_gold_conj]
#align one_sub_gold_conj one_sub_gold_conj

theorem one_sub_gold : 1 - ψ = φ := by linarith [gold_add_gold_conj]
#align one_sub_gold one_sub_gold

@[simp]
theorem gold_sub_gold_conj : φ - ψ = Real.sqrt 5 :=
  by
  rw [goldenRatio, goldenConj]
  ring
#align gold_sub_gold_conj gold_sub_gold_conj

@[simp]
theorem gold_sq : φ ^ 2 = φ + 1 :=
  by
  rw [goldenRatio, ← sub_eq_zero]
  ring
  rw [Real.sq_sqrt] <;> norm_num
#align gold_sq gold_sq

@[simp]
theorem gold_conj_sq : ψ ^ 2 = ψ + 1 :=
  by
  rw [goldenConj, ← sub_eq_zero]
  ring
  rw [Real.sq_sqrt] <;> norm_num
#align gold_conj_sq gold_conj_sq

theorem gold_pos : 0 < φ :=
  mul_pos (by apply add_pos <;> norm_num) <| inv_pos.2 zero_lt_two
#align gold_pos gold_pos

theorem gold_ne_zero : φ ≠ 0 :=
  ne_of_gt gold_pos
#align gold_ne_zero gold_ne_zero

theorem one_lt_gold : 1 < φ :=
  by
  refine' lt_of_mul_lt_mul_left _ (le_of_lt gold_pos)
  simp [← sq, gold_pos, zero_lt_one]
#align one_lt_gold one_lt_gold

theorem gold_conj_neg : ψ < 0 := by linarith [one_sub_gold_conj, one_lt_gold]
#align gold_conj_neg gold_conj_neg

theorem gold_conj_ne_zero : ψ ≠ 0 :=
  ne_of_lt gold_conj_neg
#align gold_conj_ne_zero gold_conj_ne_zero

theorem neg_one_lt_gold_conj : -1 < ψ :=
  by
  rw [neg_lt, ← inv_gold]
  exact inv_lt_one one_lt_gold
#align neg_one_lt_gold_conj neg_one_lt_gold_conj

/-!
## Irrationality
-/

/-- The golden ratio is irrational. -/
theorem gold_irrational : Irrational φ :=
  by
  have := Nat.Prime.irrational_sqrt (show Nat.Prime 5 by norm_num)
  have := this.rat_add 1
  have := this.rat_mul (show (0.5 : ℚ) ≠ 0 by norm_num)
  convert this
  field_simp
#align gold_irrational gold_irrational

/-- The conjugate of the golden ratio is irrational. -/
theorem gold_conj_irrational : Irrational ψ :=
  by
  have := Nat.Prime.irrational_sqrt (show Nat.Prime 5 by norm_num)
  have := this.rat_sub 1
  have := this.rat_mul (show (0.5 : ℚ) ≠ 0 by norm_num)
  convert this
  field_simp
#align gold_conj_irrational gold_conj_irrational

/-!
## Links with Fibonacci sequence
-/

section Fibrec

variable {α : Type _} [CommSemiring α]

/-- The recurrence relation satisfied by the Fibonacci sequence. -/
def fibRec : LinearRecurrence α where
  order := 2
  coeffs := ![1, 1]
#align fib_rec fibRec

section Poly

open Polynomial

/-- The characteristic polynomial of `fib_rec` is `X² - (X + 1)`. -/
theorem fibRec_charPoly_eq {β : Type _} [CommRing β] : fibRec.charPoly = X ^ 2 - (X + (1 : β[X])) :=
  by
  rw [fibRec, LinearRecurrence.charPoly]
  simp [Finset.sum_fin_eq_sum_range, Finset.sum_range_succ', ← smul_X_eq_monomial]
#align fib_rec_char_poly_eq fibRec_charPoly_eq

end Poly

/-- As expected, the Fibonacci sequence is a solution of `fib_rec`. -/
theorem fib_is_sol_fibRec : fibRec.IsSolution (fun x => x.fib : ℕ → α) :=
  by
  rw [fibRec]
  intro n
  simp only
  rw [Nat.fib_add_two, add_comm]
  simp [Finset.sum_fin_eq_sum_range, Finset.sum_range_succ']
#align fib_is_sol_fib_rec fib_is_sol_fibRec

/-- The geometric sequence `λ n, φ^n` is a solution of `fib_rec`. -/
theorem geom_gold_is_sol_fibRec : fibRec.IsSolution (pow φ) :=
  by
  rw [fib_rec.geom_sol_iff_root_char_poly, fibRec_charPoly_eq]
  simp [sub_eq_zero]
#align geom_gold_is_sol_fib_rec geom_gold_is_sol_fibRec

/-- The geometric sequence `λ n, ψ^n` is a solution of `fib_rec`. -/
theorem geom_gold_conj_is_sol_fibRec : fibRec.IsSolution (pow ψ) :=
  by
  rw [fib_rec.geom_sol_iff_root_char_poly, fibRec_charPoly_eq]
  simp [sub_eq_zero]
#align geom_gold_conj_is_sol_fib_rec geom_gold_conj_is_sol_fibRec

end Fibrec

/-- Binet's formula as a function equality. -/
theorem Real.coe_fib_eq' : (fun n => Nat.fib n : ℕ → ℝ) = fun n => (φ ^ n - ψ ^ n) / Real.sqrt 5 :=
  by
  rw [fib_rec.sol_eq_of_eq_init]
  · intro i hi
    fin_cases hi
    · simp
    · simp only [goldenRatio, goldenConj]
      ring
      rw [mul_inv_cancel] <;> norm_num
  · exact fib_is_sol_fibRec
  · ring_nf
    exact
      (@fibRec ℝ _).solSpace.sub_mem
        (Submodule.smul_mem fib_rec.sol_space (Real.sqrt 5)⁻¹ geom_gold_is_sol_fibRec)
        (Submodule.smul_mem fib_rec.sol_space (Real.sqrt 5)⁻¹ geom_gold_conj_is_sol_fibRec)
#align real.coe_fib_eq' Real.coe_fib_eq'

/-- Binet's formula as a dependent equality. -/
theorem Real.coe_fib_eq : ∀ n, (Nat.fib n : ℝ) = (φ ^ n - ψ ^ n) / Real.sqrt 5 := by
  rw [← Function.funext_iff, Real.coe_fib_eq']
#align real.coe_fib_eq Real.coe_fib_eq


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

import algebra.big_operators.basic

/-!
# Products (respectively, sums) over a finset or a multiset.

The regular `finset.prod` and `multiset.prod` require `[comm_monoid α]`.
Often, there are collections `s : finset α` where `[monoid α]` and we know,
in a dependent fashion, that for all the terms `∀ (x ∈ s) (y ∈ s), commute x y`.
This allows to still have a well-defined product over `s`.

## Main definitions

- `finset.noncomm_prod`, requiring a proof of commutativity of held terms
- `multiset.noncomm_prod`, requiring a proof of commutativity of held terms

## Implementation details

While `list.prod` is defined via `list.foldl`, `noncomm_prod` is defined via
`multiset.foldr` for neater proofs and definitions. By the commutativity assumption,
the two must be equal.

-/

variables {α β : Type*} (f : α → β → β) (op : α → α → α)

namespace multiset

/-- Fold of a `s : multiset α` with `f : α → β → β`, given a proof that `left_commutative f`
on all elements `x ∈ s`. -/
def noncomm_foldr (s : multiset α) (comm : ∀ (x ∈ s) (y ∈ s) b, f x (f y b) = f y (f x b)) (b : β) :
  β :=
s.attach.foldr (f ∘ subtype.val) (λ ⟨x, hx⟩ ⟨y, hy⟩, comm x hx y hy) b

@[simp] lemma noncomm_foldr_coe (l : list α)
  (comm : ∀ (x ∈ (l : multiset α)) (y ∈ (l : multiset α)) b, f x (f y b) = f y (f x b)) (b : β) :
  noncomm_foldr f (l : multiset α) comm b = l.foldr f b :=
begin
  simp only [noncomm_foldr, coe_foldr, coe_attach, list.attach],
  rw ←list.foldr_map,
  simp [list.map_pmap, list.pmap_eq_map]
end

@[simp] lemma noncomm_foldr_empty
  (h : ∀ (x ∈ (0 : multiset α)) (y ∈ (0 : multiset α)) b, f x (f y b) = f y (f x b)) (b : β) :
  noncomm_foldr f (0 : multiset α) h b = b := rfl

lemma noncomm_foldr_cons (s : multiset α) (a : α)
  (h : ∀ (x ∈ (a ::ₘ s)) (y ∈ (a ::ₘ s)) b, f x (f y b) = f y (f x b))
  (h' : ∀ (x ∈ s) (y ∈ s) b, f x (f y b) = f y (f x b))
  (b : β) :
  noncomm_foldr f (a ::ₘ s) h b = f a (noncomm_foldr f s h' b) :=
begin
  induction s using quotient.induction_on,
  simp
end

lemma noncomm_foldr_eq_foldr (s : multiset α) (h : left_commutative f) (b : β) :
  noncomm_foldr f s (λ x _ y _, h x y) b = foldr f h b s :=
begin
  induction s using quotient.induction_on,
  simp
end

variables [assoc : is_associative α op]
include assoc

/-- Fold of a `s : multiset α` with an associative `op : α → α → α`, given a proofs that `op`
is commutative on all elements `x ∈ s`. -/
def noncomm_fold (s : multiset α)
  (comm : ∀ (x ∈ s) (y ∈ s), op x y = op y x)
  (a : α) : α :=
noncomm_foldr op s (λ x hx y hy b, by rw [←assoc.assoc, comm _ hx _ hy, assoc.assoc]) a

@[simp] lemma noncomm_fold_coe (l : list α)
  (comm : ∀ (x ∈ (l : multiset α)) (y ∈ (l : multiset α)), op x y = op y x)
  (a : α) :
  noncomm_fold op (l : multiset α) comm a = l.foldr op a :=
by simp [noncomm_fold]

@[simp] lemma noncomm_fold_empty
  (h : ∀ (x ∈ (0 : multiset α)) (y ∈ (0 : multiset α)), op x y = op y x) (a : α) :
  noncomm_fold op (0 : multiset α) h a = a := rfl

lemma noncomm_fold_cons (s : multiset α) (a : α)
  (h : ∀ (x ∈ a ::ₘ s) (y ∈ a ::ₘ s), op x y = op y x)
  (h' : ∀ (x ∈ s) (y ∈ s), op x y = op y x)
  (x : α) :
  noncomm_fold op (a ::ₘ s) h x = op a (noncomm_fold op s h' x) :=
begin
  induction s using quotient.induction_on,
  simp
end

lemma noncomm_fold_eq_fold (s : multiset α) [is_commutative α op]
  (a : α) :
  noncomm_fold op s (λ x _ y _, is_commutative.comm x y) a = fold op a s :=
begin
  induction s using quotient.induction_on,
  simp
end

omit assoc
variables [monoid α]

/-- Product of a `s : multiset α` with `[monoid α]`, given a proof that `*` commutes
on all elements `x ∈ s`. -/
@[to_additive "Sum of a `s : multiset α` with `[add_monoid α]`, given a proof that `+` commutes
on all elements `x ∈ s`." ]
def noncomm_prod (s : multiset α) (comm : ∀ (x ∈ s) (y ∈ s), commute x y) : α :=
s.noncomm_fold (*) comm 1

@[simp, to_additive] lemma noncomm_prod_coe (l : list α)
  (comm : ∀ (x ∈ (l : multiset α)) (y ∈ (l : multiset α)), commute x y) :
  noncomm_prod (l : multiset α) comm = l.prod :=
begin
  rw [noncomm_prod],
  simp only [noncomm_fold_coe],
  induction l with hd tl hl,
  { simp },
  { rw [list.prod_cons, list.foldr, hl],
    intros x hx y hy,
    exact comm x (list.mem_cons_of_mem _ hx) y (list.mem_cons_of_mem _ hy) }
end

@[simp, to_additive] lemma noncomm_prod_empty
  (h : ∀ (x ∈ (0 : multiset α)) (y ∈ (0 : multiset α)), commute x y) :
  noncomm_prod (0 : multiset α) h = 1 := rfl

@[simp, to_additive] lemma noncomm_prod_cons (s : multiset α) (a : α)
  (comm : ∀ (x ∈ a ::ₘ s) (y ∈ a ::ₘ s), commute x y) :
  noncomm_prod (a ::ₘ s) comm = a * noncomm_prod s
    (λ x hx y hy, comm _ (mem_cons_of_mem hx) _ (mem_cons_of_mem hy)) :=
begin
  induction s using quotient.induction_on,
  simp
end

@[to_additive] lemma noncomm_prod_cons' (s : multiset α) (a : α)
  (comm : ∀ (x ∈ a ::ₘ s) (y ∈ a ::ₘ s), commute x y) :
  noncomm_prod (a ::ₘ s) comm = noncomm_prod s
    (λ x hx y hy, comm _ (mem_cons_of_mem hx) _ (mem_cons_of_mem hy)) * a :=
begin
  induction s using quotient.induction_on with s,
  simp only [quot_mk_to_coe, cons_coe, noncomm_prod_coe, list.prod_cons],
  induction s with hd tl IH,
  { simp },
  { rw [list.prod_cons, mul_assoc, ←IH, ←mul_assoc, ←mul_assoc],
    { congr' 1,
      apply comm;
      simp },
    { intros x hx y hy,
      simp only [quot_mk_to_coe, list.mem_cons_iff, mem_coe, cons_coe] at hx hy,
      apply comm,
      { cases hx;
        simp [hx] },
      { cases hy;
        simp [hy] } } }
end

@[to_additive]

end multiset

namespace finset

variables [monoid β]

/-- Product of a `s : finset α` mapped with `f : α → β` with `[monoid β]`,
given a proof that `*` commutes on all elements `f x` for `x ∈ s`. -/
@[to_additive "Sum of a `s : finset α` mapped with `f : α → β` with `[add_monoid β]`,
given a proof that `+` commutes on all elements `f x` for `x ∈ s`."]
def noncomm_prod (s : finset α) (f : α → β) (comm : ∀ (x ∈ s) (y ∈ s), commute (f x) (f y)) : β :=
(s.1.map f).noncomm_prod (by simpa [multiset.mem_map, ←finset.mem_def] using comm)

@[simp, to_additive] lemma noncomm_prod_to_finset [decidable_eq α] (l : list α) (f : α → β)
  (comm : ∀ (x ∈ l.to_finset) (y ∈ l.to_finset), commute (f x) (f y))
  (hl : l.nodup) :
  noncomm_prod l.to_finset f comm = (l.map f).prod :=
begin
  rw ←list.erase_dup_eq_self at hl,
  simp [noncomm_prod, hl]
end

@[simp, to_additive] lemma noncomm_prod_empty (f : α → β)
  (h : ∀ (x ∈ (∅ : finset α)) (y ∈ (∅ : finset α)), commute (f x) (f y)) :
  noncomm_prod (∅ : finset α) f h = 1 := rfl

@[simp, to_additive] lemma noncomm_prod_insert_of_not_mem [decidable_eq α] (s : finset α) (a : α)
  (f : α → β)
  (comm : ∀ (x ∈ insert a s) (y ∈ insert a s), commute (f x) (f y))
  (ha : a ∉ s) :
  noncomm_prod (insert a s) f comm = f a * noncomm_prod s f
    (λ x hx y hy, comm _ (mem_insert_of_mem hx) _ (mem_insert_of_mem hy)) :=
by simp [insert_val_of_not_mem ha, noncomm_prod]

@[to_additive] lemma noncomm_prod_insert_of_not_mem' [decidable_eq α] (s : finset α) (a : α)
  (f : α → β)
  (comm : ∀ (x ∈ insert a s) (y ∈ insert a s), commute (f x) (f y))
  (ha : a ∉ s) :
  noncomm_prod (insert a s) f comm = noncomm_prod s f
    (λ x hx y hy, comm _ (mem_insert_of_mem hx) _ (mem_insert_of_mem hy)) * f a :=
by simp [noncomm_prod, insert_val_of_not_mem ha, multiset.noncomm_prod_cons']

@[simp, to_additive] lemma noncomm_prod_singleton (a : α) (f : α → β) :
  noncomm_prod ({a} : finset α) f
    (λ x hx y hy, by rw [mem_singleton.mp hx, mem_singleton.mp hy]) = f a :=
by simp [noncomm_prod, multiset.singleton_eq_cons]

@[to_additive] lemma noncomm_prod_eq_prod {β : Type*} [comm_monoid β] (s : finset α) (f : α → β) :
  noncomm_prod s f (λ _ _ _ _, commute.all _ _) = s.prod f :=
begin
  classical,
  induction s using finset.induction_on with a s ha IH,
  { simp },
  { simp [ha, IH] }
end

/- The non-commutative version of `finset.prod_union` -/
@[to_additive /-" The non-commutative version of `finset.sum_union` "-/]
lemma noncomm_prod_union_of_disjoint [decidable_eq α] {s t : finset α}
  (h : disjoint s t) (f : α → β)
  (comm : ∀ (x ∈ s ∪ t) (y ∈ s ∪ t), commute (f x) (f y))
  (scomm : ∀ (x ∈ s) (y ∈ s), commute (f x) (f y) :=
    λ _ hx _ hy, comm _ (mem_union_left _ hx) _ (mem_union_left _ hy))
  (tcomm : ∀ (x ∈ t) (y ∈ t), commute (f x) (f y) :=
    λ _ hx _ hy, comm _ (mem_union_right _ hx) _ (mem_union_right _ hy)) :
  noncomm_prod (s ∪ t) f comm = noncomm_prod s f scomm * noncomm_prod t f tcomm :=
begin
  obtain ⟨sl, sl', rfl⟩ := exists_list_nodup_eq s,
  obtain ⟨tl, tl', rfl⟩ := exists_list_nodup_eq t,
  rw list.disjoint_to_finset_iff_disjoint at h,
  simp [sl', tl', noncomm_prod_to_finset, ←list.prod_append, ←list.to_finset_append,
        list.nodup_append_of_nodup sl' tl' h]
end

end finset