import Lean4Axiomatic.Natural.Core

/-!
# Natural number addition
-/

namespace Lean4Axiomatic.Natural

/-!
## Axioms
-/

/--
Definition of addition, and properties that it must satisfy.

All other properties of addition can be derived from these.
-/
class Addition (ℕ : Type) [Core ℕ] :=
  /-- Definition of and syntax for addition. -/
  addOp : Add ℕ

  /-- Adding zero to any natural number (on the left) leaves it unchanged. -/
  zero_add {m : ℕ} : 0 + m ≃ m

  /-- Incrementing the left term in a sum increments the result. -/
  step_add {n m : ℕ} : step n + m ≃ step (n + m)

attribute [instance] Addition.addOp

export Addition (addOp step_add zero_add)

/-!
## Derived properties
-/

variable {ℕ : Type}
variable [Core ℕ]
variable [Axioms ℕ]
variable [Addition ℕ]

/-- Adding zero to any natural number (on the right) leaves it unchanged. -/
theorem add_zero {n : ℕ} : n + 0 ≃ n := by
  apply ind_on (motive := λ n => n + 0 ≃ n) n
  case zero =>
    show 0 + 0 ≃ 0
    calc
      0 + (0 : ℕ) ≃ _ := Addition.zero_add
      0           ≃ _ := Rel.refl
  case step =>
    intro n (ih : n + 0 ≃ n)
    show step n + 0 ≃ step n
    calc
      step n + 0   ≃ _ := Addition.step_add
      step (n + 0) ≃ _ := AA.subst₁ ih
      step n       ≃ _ := Rel.refl

instance add_identity : AA.Identity (α := ℕ) 0 (· + ·) := {
  identityL := AA.IdentityOn.mk Addition.zero_add
  identityR := AA.IdentityOn.mk add_zero
}

/-- Convenience lemma for several integer proofs. -/
theorem add_swapped_zeros_eqv {n m : ℕ} : n + 0 ≃ 0 + m ↔ n ≃ m := by
  apply Iff.intro
  case mp =>
    intro (_ : n + 0 ≃ 0 + m)
    show n ≃ m
    calc
      n     ≃ _ := Rel.symm AA.identR
      n + 0 ≃ _ := ‹n + 0 ≃ 0 + m›
      0 + m ≃ _ := AA.identL
      m     ≃ _ := Rel.refl
  case mpr =>
    intro (_ : n ≃ m)
    show n + 0 ≃ 0 + m
    calc
      n + 0 ≃ _ := AA.identR
      n     ≃ _ := ‹n ≃ m›
      m     ≃ _ := Rel.symm AA.identL
      0 + m ≃ _ := Rel.refl

/-- Incrementing the right term in a sum increments the result. -/
theorem add_step {n m : ℕ} : n + step m ≃ step (n + m) := by
  apply ind_on (motive := λ n => n + step m ≃ step (n + m)) n
  case zero =>
    show 0 + step m ≃ step (0 + m)
    calc
      0 + step m   ≃ _ := Addition.zero_add
      step m       ≃ _ := AA.subst₁ (Rel.symm Addition.zero_add)
      step (0 + m) ≃ _ := Rel.refl
  case step =>
    intro n (ih : n + step m ≃ step (n + m))
    show step n + step m ≃ step (step n + m)
    calc
      step n + step m     ≃ _ := Addition.step_add
      step (n + step m)   ≃ _ := AA.subst₁ ih
      step (step (n + m)) ≃ _ := AA.subst₁ (Rel.symm Addition.step_add)
      step (step n + m)   ≃ _ := Rel.refl

instance add_semicompatible_step : AA.Semicompatible (α := ℕ) step (· + ·) := {
  semicompatibleL := AA.SemicompatibleOn.mk (Rel.symm Addition.step_add)
  semicompatibleR := AA.SemicompatibleOn.mk (Rel.symm add_step)
}

/--
The `step` operation can be exchanged between the operands of an addition.

**Property intuition**: It doesn't matter which operand is incremented; the
result will be the same.

**Proof intuition**: Use `step_add` and `add_step` to bring the increment to
the outside of the sum and then back to the other operand.
-/
theorem step_add_swap {n m : ℕ} : step n + m ≃ n + step m := calc
  step n + m   ≃ _ := step_add
  step (n + m) ≃ _ := Rel.symm add_step
  n + step m   ≃ _ := Rel.refl

/-- Exchanging the operands of an addition does not change the result. -/
theorem add_comm {n m : ℕ} : n + m ≃ m + n := by
  apply ind_on (motive := λ n => n + m ≃ m + n) n
  case zero =>
    show 0 + m ≃ m + 0
    calc
      0 + m ≃ _ := Addition.zero_add
      m     ≃ _ := Rel.symm add_zero
      m + 0 ≃ _ := Rel.refl
  case step =>
    intro n (ih : n + m ≃ m + n)
    show step n + m ≃ m + step n
    calc
      step n + m   ≃ _ := Addition.step_add
      step (n + m) ≃ _ := AA.subst₁ ih
      step (m + n) ≃ _ := Rel.symm add_step
      m + step n   ≃ _ := Rel.refl

instance add_commutative : AA.Commutative (α := ℕ) (· + ·) := {
  comm := add_comm
}

/--
Addition preserves equivalence of natural numbers; two equivalent natural
numbers are still equivalent after the same quantity is added to both (on the
right).
-/
theorem subst_add {n₁ n₂ m : ℕ} : n₁ ≃ n₂ → n₁ + m ≃ n₂ + m := by
  apply ind_on (motive := λ x => ∀ y, x ≃ y → x + m ≃ y + m) n₁
  case zero =>
    intro n₂
    show 0 ≃ n₂ → 0 + m ≃ n₂ + m
    apply cases_on (motive := λ y => 0 ≃ y → 0 + m ≃ y + m)
    case zero =>
      intro (_ : 0 ≃ (0 : ℕ))
      show 0 + m ≃ 0 + m
      exact Rel.refl
    case step =>
      intro n₂ (_ : 0 ≃ step n₂)
      exact absurd (Rel.symm ‹0 ≃ step n₂›) step_neqv_zero
  case step =>
    intro n₁ (ih : ∀ y, n₁ ≃ y → n₁ + m ≃ y + m) n₂
    show step n₁ ≃ n₂ → step n₁ + m ≃ n₂ + m
    apply cases_on (motive := λ y => step n₁ ≃ y → step n₁ + m ≃ y + m)
    case zero =>
      intro (_ : step n₁ ≃ 0)
      show step n₁ + m ≃ 0 + m
      exact absurd ‹step n₁ ≃ 0› step_neqv_zero
    case step =>
      intro n₂ (_ : step n₁ ≃ step n₂)
      show step n₁ + m ≃ step n₂ + m
      have : n₁ ≃ n₂ := AA.inject ‹step n₁ ≃ step n₂›
      calc
        step n₁ + m   ≃ _ := Addition.step_add
        step (n₁ + m) ≃ _ := AA.subst₁ (ih _ ‹n₁ ≃ n₂›)
        step (n₂ + m) ≃ _ := Rel.symm Addition.step_add
        step n₂ + m   ≃ _ := Rel.refl

def add_substL
    : AA.SubstitutiveOn Hand.L (α := ℕ) (· + ·) AA.tc (· ≃ ·) (· ≃ ·)
    := {
  subst₂ := λ (_ : True) => subst_add
}

instance add_substitutive
    : AA.Substitutive₂ (α := ℕ) (· + ·) AA.tc (· ≃ ·) (· ≃ ·)
    := {
  substitutiveL := add_substL
  substitutiveR := AA.substR_from_substL_swap (rS := (· ≃ ·)) add_substL
}

/-- Adding one is the same as incrementing. -/
theorem add_one_step {n : ℕ} : n + 1 ≃ step n := by
  calc
    n + 1        ≃ _ := AA.substR Literals.literal_step
    n + step 0   ≃ _ := add_step
    step (n + 0) ≃ _ := AA.subst₁ add_zero
    step n       ≃ _ := Rel.refl

/--
The grouping of the terms in a sum doesn't matter.

**Intuition**: the `step_add` and `add_step` properties allow `step`s to be
moved arbitrarily between terms. Given any particular grouping of a sum, all of
the `step`s can be moved over to the first term, always producing the same
result.
-/
instance add_associative : AA.Associative (α := ℕ) (· + ·) := by
  constructor
  intro n m k
  show (n + m) + k ≃ n + (m + k)
  apply ind_on (motive := λ n => (n + m) + k ≃ n + (m + k)) n
  case zero =>
    show (0 + m) + k ≃ 0 + (m + k)
    calc
      (0 + m) + k ≃ _ := AA.substL Addition.zero_add
      m + k       ≃ _ := Rel.symm Addition.zero_add
      0 + (m + k) ≃ _ := Rel.refl
  case step =>
    intro n (ih : (n + m) + k ≃ n + (m + k))
    show (step n + m) + k ≃ step n + (m + k)
    calc
      (step n + m) + k   ≃ _ := AA.substL Addition.step_add
      step (n + m) + k   ≃ _ := Addition.step_add
      step ((n + m) + k) ≃ _ := AA.subst₁ ih
      step (n + (m + k)) ≃ _ := Rel.symm Addition.step_add
      step n + (m + k)   ≃ _ := Rel.refl

/--
The right-hand sides of two equal sums are equal if their left-hand sides are.

**Proof intuition**: the left-hand sides can be removed one `step` at a time by
applying `step_injective` and finally `zero_add`, leaving the desired result.
-/
theorem cancel_add {n m k : ℕ} : n + m ≃ n + k → m ≃ k := by
  apply ind_on (motive := λ n => n + m ≃ n + k → m ≃ k) n
  case zero =>
    intro (_ : 0 + m ≃ 0 + k)
    show m ≃ k
    calc
      m     ≃ _ := Rel.symm Addition.zero_add
      0 + m ≃ _ := ‹0 + m ≃ 0 + k›
      0 + k ≃ _ := Addition.zero_add
      k     ≃ _ := Rel.refl
  case step =>
    intro n (ih : n + m ≃ n + k → m ≃ k) (_ : step n + m ≃ step n + k)
    show m ≃ k
    apply ih
    show n + m ≃ n + k
    apply AA.inject (β := ℕ) (f := step) (rβ := (· ≃ ·))
    show step (n + m) ≃ step (n + k)
    calc
      step (n + m) ≃ _ := Rel.symm Addition.step_add
      step n + m   ≃ _ := ‹step n + m ≃ step n + k›
      step n + k   ≃ _ := Addition.step_add
      step (n + k) ≃ _ := Rel.refl

def add_cancelL
    : AA.CancellativeOn Hand.L (α := ℕ) (· + ·) AA.tc (· ≃ ·) (· ≃ ·) := {
  cancel := λ (_ : True) => cancel_add
}

instance add_cancellative
    : AA.Cancellative (α := ℕ) (· + ·) AA.tc (· ≃ ·) (· ≃ ·) := {
  cancellativeL := add_cancelL
  cancellativeR := AA.cancelR_from_cancelL add_cancelL
}

/--
Both operands in a sum of natural numbers must be zero if the result is zero.
-/
theorem zero_sum_split {n m : ℕ} : n + m ≃ 0 → n ≃ 0 ∧ m ≃ 0 := by
  apply cases_on (motive := λ n => n + m ≃ 0 → n ≃ 0 ∧ m ≃ 0) n
  case zero =>
    intro (_ : 0 + m ≃ 0)
    show 0 ≃ 0 ∧ m ≃ 0
    have : m ≃ 0 := Rel.trans (Rel.symm Addition.zero_add) ‹0 + m ≃ 0›
    exact And.intro Rel.refl ‹m ≃ 0›
  case step =>
    intro n (_ : step n + m ≃ 0)
    show step n ≃ 0 ∧ m ≃ 0
    apply False.elim
    show False
    have : step (n + m) ≃ step n + m := Rel.symm Addition.step_add
    have : step (n + m) ≃ 0 :=
      Rel.trans ‹step (n + m) ≃ step n + m› ‹step n + m ≃ 0›
    exact absurd ‹step (n + m) ≃ 0› step_neqv_zero

end Lean4Axiomatic.Natural


/-
Copyright (c) 2019 Amelia Livingston. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Amelia Livingston, Jireh Loreaux
-/
import algebra.group_with_zero.inj_surj
import algebra.ring.basic
import algebra.divisibility.basic
import data.pi.algebra
import algebra.hom.units
import data.set.image

/-!
# Homomorphisms of semirings and rings

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

This file defines bundled homomorphisms of (non-unital) semirings and rings. As with monoid and
groups, we use the same structure `ring_hom a β`, a.k.a. `α →+* β`, for both types of homomorphisms.

The unbundled homomorphisms are defined in `deprecated.ring`. They are deprecated and the plan is to
slowly remove them from mathlib.

## Main definitions

* `non_unital_ring_hom`: Non-unital (semi)ring homomorphisms. Additive monoid homomorphism which
  preserve multiplication.
* `ring_hom`: (Semi)ring homomorphisms. Monoid homomorphisms which are also additive monoid
  homomorphism.

## Notations

* `→ₙ+*`: Non-unital (semi)ring homs
* `→+*`: (Semi)ring homs

## Implementation notes

* There's a coercion from bundled homs to fun, and the canonical notation is to
  use the bundled hom as a function via this coercion.

* There is no `semiring_hom` -- the idea is that `ring_hom` is used.
  The constructor for a `ring_hom` between semirings needs a proof of `map_zero`,
  `map_one` and `map_add` as well as `map_mul`; a separate constructor
  `ring_hom.mk'` will construct ring homs between rings from monoid homs given
  only a proof that addition is preserved.

## Tags

`ring_hom`, `semiring_hom`
-/

set_option old_structure_cmd true

open function

variables {F α β γ : Type*}

/-- Bundled non-unital semiring homomorphisms `α →ₙ+* β`; use this for bundled non-unital ring
homomorphisms too.

When possible, instead of parametrizing results over `(f : α →ₙ+* β)`,
you should parametrize over `(F : Type*) [non_unital_ring_hom_class F α β] (f : F)`.

When you extend this structure, make sure to extend `non_unital_ring_hom_class`. -/
structure non_unital_ring_hom (α β : Type*) [non_unital_non_assoc_semiring α]
  [non_unital_non_assoc_semiring β] extends α →ₙ* β, α →+ β

infixr ` →ₙ+* `:25 := non_unital_ring_hom

/-- Reinterpret a non-unital ring homomorphism `f : α →ₙ+* β` as a semigroup
homomorphism `α →ₙ* β`. The `simp`-normal form is `(f : α →ₙ* β)`. -/
add_decl_doc non_unital_ring_hom.to_mul_hom

/-- Reinterpret a non-unital ring homomorphism `f : α →ₙ+* β` as an additive
monoid homomorphism `α →+ β`. The `simp`-normal form is `(f : α →+ β)`. -/
add_decl_doc non_unital_ring_hom.to_add_monoid_hom

section non_unital_ring_hom_class

/-- `non_unital_ring_hom_class F α β` states that `F` is a type of non-unital (semi)ring
homomorphisms. You should extend this class when you extend `non_unital_ring_hom`. -/
class non_unital_ring_hom_class (F : Type*) (α β : out_param Type*)
  [non_unital_non_assoc_semiring α] [non_unital_non_assoc_semiring β]
  extends mul_hom_class F α β, add_monoid_hom_class F α β

variables [non_unital_non_assoc_semiring α] [non_unital_non_assoc_semiring β]
  [non_unital_ring_hom_class F α β]

instance : has_coe_t F (α →ₙ+* β) :=
⟨λ f, { to_fun := f, map_zero' := map_zero f, map_mul' := map_mul f, map_add' := map_add f }⟩

end non_unital_ring_hom_class

namespace non_unital_ring_hom

section coe

/-!
Throughout this section, some `semiring` arguments are specified with `{}` instead of `[]`.
See note [implicit instance arguments].
-/
variables {rα : non_unital_non_assoc_semiring α} {rβ : non_unital_non_assoc_semiring β}

include rα rβ

instance : non_unital_ring_hom_class (α →ₙ+* β) α β :=
{ coe := non_unital_ring_hom.to_fun,
  coe_injective' := λ f g h, by cases f; cases g; congr',
  map_add := non_unital_ring_hom.map_add',
  map_zero := non_unital_ring_hom.map_zero',
  map_mul := non_unital_ring_hom.map_mul' }

/-- Helper instance for when there's too many metavariables to apply `fun_like.has_coe_to_fun`
directly. -/
instance : has_coe_to_fun (α →ₙ+* β) (λ _, α → β) := ⟨non_unital_ring_hom.to_fun⟩

@[simp] lemma to_fun_eq_coe (f : α →ₙ+* β) : f.to_fun = f := rfl

@[simp] lemma coe_mk (f : α → β) (h₁ h₂ h₃) : ⇑(⟨f, h₁, h₂, h₃⟩ : α →ₙ+* β) = f := rfl

@[simp] lemma coe_coe [non_unital_ring_hom_class F α β] (f : F) : ((f : α →ₙ+* β) : α → β) = f :=
rfl

@[simp] lemma coe_to_mul_hom (f : α →ₙ+* β) : ⇑f.to_mul_hom = f := rfl

@[simp] lemma coe_mul_hom_mk (f : α → β) (h₁ h₂ h₃) :
  ((⟨f, h₁, h₂, h₃⟩ : α →ₙ+* β) : α →ₙ* β) = ⟨f, h₁⟩ := rfl

@[simp] lemma coe_to_add_monoid_hom (f : α →ₙ+* β) : ⇑f.to_add_monoid_hom = f := rfl

@[simp] lemma coe_add_monoid_hom_mk (f : α → β) (h₁ h₂ h₃) :
  ((⟨f, h₁, h₂, h₃⟩ : α →ₙ+* β) : α →+ β) = ⟨f, h₂, h₃⟩ := rfl

/-- Copy of a `ring_hom` with a new `to_fun` equal to the old one. Useful to fix definitional
equalities. -/
protected def copy (f : α →ₙ+* β) (f' : α → β) (h : f' = f) : α →ₙ+* β :=
{ ..f.to_mul_hom.copy f' h, ..f.to_add_monoid_hom.copy f' h }

@[simp] lemma coe_copy (f : α →ₙ+* β) (f' : α → β) (h : f' = f) : ⇑(f.copy f' h) = f' := rfl

lemma copy_eq (f : α →ₙ+* β) (f' : α → β) (h : f' = f) : f.copy f' h = f := fun_like.ext' h

end coe

variables [rα : non_unital_non_assoc_semiring α] [rβ : non_unital_non_assoc_semiring β]

section
include rα rβ

variables (f : α →ₙ+* β) {x y : α} {rα rβ}

@[ext] lemma ext ⦃f g : α →ₙ+* β⦄ : (∀ x, f x = g x) → f = g := fun_like.ext _ _

lemma ext_iff {f g : α →ₙ+* β} : f = g ↔ ∀ x, f x = g x := fun_like.ext_iff

@[simp] lemma mk_coe (f : α →ₙ+* β) (h₁ h₂ h₃) : non_unital_ring_hom.mk f h₁ h₂ h₃ = f :=
ext $ λ _, rfl

lemma coe_add_monoid_hom_injective : injective (coe : (α →ₙ+* β) → (α →+ β)) :=
λ f g h, ext $ add_monoid_hom.congr_fun h

lemma coe_mul_hom_injective : injective (coe : (α →ₙ+* β) → (α →ₙ* β)) :=
λ f g h, ext $ mul_hom.congr_fun h

end

/-- The identity non-unital ring homomorphism from a non-unital semiring to itself. -/
protected def id (α : Type*) [non_unital_non_assoc_semiring α] : α →ₙ+* α :=
by refine {to_fun := id, ..}; intros; refl

include rα rβ

instance : has_zero (α →ₙ+* β) :=
⟨{ to_fun := 0,
   map_mul' := λ x y, (mul_zero (0 : β)).symm,
   map_zero' := rfl,
   map_add' := λ x y, (add_zero (0 : β)).symm }⟩

instance : inhabited (α →ₙ+* β) := ⟨0⟩

@[simp] lemma coe_zero : ⇑(0 : α →ₙ+* β) = 0 := rfl
@[simp] lemma zero_apply (x : α) : (0 : α →ₙ+* β) x = 0 := rfl

omit rβ

@[simp] lemma id_apply (x : α) : non_unital_ring_hom.id α x = x := rfl
@[simp] lemma coe_add_monoid_hom_id :
  (non_unital_ring_hom.id α : α →+ α) = add_monoid_hom.id α := rfl
@[simp] lemma coe_mul_hom_id : (non_unital_ring_hom.id α : α →ₙ* α) = mul_hom.id α := rfl

variable {rγ : non_unital_non_assoc_semiring γ}
include rβ rγ

/-- Composition of non-unital ring homomorphisms is a non-unital ring homomorphism. -/
def comp (g : β →ₙ+* γ) (f : α →ₙ+* β) : α →ₙ+* γ :=
{ ..g.to_mul_hom.comp f.to_mul_hom, ..g.to_add_monoid_hom.comp f.to_add_monoid_hom }

/-- Composition of non-unital ring homomorphisms is associative. -/
lemma comp_assoc {δ} {rδ : non_unital_non_assoc_semiring δ} (f : α →ₙ+* β) (g : β →ₙ+* γ)
  (h : γ →ₙ+* δ) : (h.comp g).comp f = h.comp (g.comp f) := rfl

@[simp] lemma coe_comp (g : β →ₙ+* γ) (f : α →ₙ+* β) : ⇑(g.comp f) = g ∘ f := rfl
@[simp] lemma comp_apply (g : β →ₙ+* γ) (f : α →ₙ+* β) (x : α) : g.comp f x = g (f x) := rfl

@[simp] lemma coe_comp_add_monoid_hom (g : β →ₙ+* γ) (f : α →ₙ+* β) :
  (g.comp f : α →+ γ) = (g : β →+ γ).comp f := rfl
@[simp] lemma coe_comp_mul_hom (g : β →ₙ+* γ) (f : α →ₙ+* β) :
  (g.comp f : α →ₙ* γ) = (g : β →ₙ* γ).comp f := rfl

@[simp] lemma comp_zero (g : β →ₙ+* γ) : g.comp (0 : α →ₙ+* β) = 0 := by { ext, simp }
@[simp] lemma zero_comp (f : α →ₙ+* β) : (0 : β →ₙ+* γ).comp f = 0 := by { ext, refl }

omit rγ

@[simp] lemma comp_id (f : α →ₙ+* β) : f.comp (non_unital_ring_hom.id α) = f := ext $ λ x, rfl
@[simp] lemma id_comp (f : α →ₙ+* β) : (non_unital_ring_hom.id β).comp f = f := ext $ λ x, rfl

omit rβ

instance : monoid_with_zero (α →ₙ+* α) :=
{ one := non_unital_ring_hom.id α,
  mul := comp,
  mul_one := comp_id,
  one_mul := id_comp,
  mul_assoc := λ f g h, comp_assoc _ _ _,
  zero := 0,
  mul_zero := comp_zero,
  zero_mul := zero_comp }

lemma one_def : (1 : α →ₙ+* α) = non_unital_ring_hom.id α := rfl

@[simp] lemma coe_one : ⇑(1 : α →ₙ+* α) = id := rfl

lemma mul_def (f g : α →ₙ+* α) : f * g = f.comp g := rfl

@[simp] lemma coe_mul (f g : α →ₙ+* α) : ⇑(f * g) = f ∘ g := rfl

include rβ rγ

lemma cancel_right {g₁ g₂ : β →ₙ+* γ} {f : α →ₙ+* β} (hf : surjective f) :
  g₁.comp f = g₂.comp f ↔ g₁ = g₂ :=
⟨λ h, ext $ hf.forall.2 (ext_iff.1 h), λ h, h ▸ rfl⟩

lemma cancel_left {g : β →ₙ+* γ} {f₁ f₂ : α →ₙ+* β} (hg : injective g) :
  g.comp f₁ = g.comp f₂ ↔ f₁ = f₂ :=
⟨λ h, ext $ λ x, hg $ by rw [← comp_apply, h, comp_apply], λ h, h ▸ rfl⟩

omit rα rβ rγ

end non_unital_ring_hom

/-- Bundled semiring homomorphisms; use this for bundled ring homomorphisms too.

This extends from both `monoid_hom` and `monoid_with_zero_hom` in order to put the fields in a
sensible order, even though `monoid_with_zero_hom` already extends `monoid_hom`. -/
structure ring_hom (α : Type*) (β : Type*) [non_assoc_semiring α] [non_assoc_semiring β]
  extends α →* β, α →+ β, α →ₙ+* β, α →*₀ β

infixr ` →+* `:25 := ring_hom

/-- Reinterpret a ring homomorphism `f : α →+* β` as a monoid with zero homomorphism `α →*₀ β`.
The `simp`-normal form is `(f : α →*₀ β)`. -/
add_decl_doc ring_hom.to_monoid_with_zero_hom

/-- Reinterpret a ring homomorphism `f : α →+* β` as a monoid homomorphism `α →* β`.
The `simp`-normal form is `(f : α →* β)`. -/
add_decl_doc ring_hom.to_monoid_hom

/-- Reinterpret a ring homomorphism `f : α →+* β` as an additive monoid homomorphism `α →+ β`.
The `simp`-normal form is `(f : α →+ β)`. -/
add_decl_doc ring_hom.to_add_monoid_hom

/-- Reinterpret a ring homomorphism `f : α →+* β` as a non-unital ring homomorphism `α →ₙ+* β`. The
`simp`-normal form is `(f : α →ₙ+* β)`. -/
add_decl_doc ring_hom.to_non_unital_ring_hom

section ring_hom_class

/-- `ring_hom_class F α β` states that `F` is a type of (semi)ring homomorphisms.
You should extend this class when you extend `ring_hom`.

This extends from both `monoid_hom_class` and `monoid_with_zero_hom_class` in
order to put the fields in a sensible order, even though
`monoid_with_zero_hom_class` already extends `monoid_hom_class`. -/
class ring_hom_class (F : Type*) (α β : out_param Type*)
  [non_assoc_semiring α] [non_assoc_semiring β]
  extends monoid_hom_class F α β, add_monoid_hom_class F α β, monoid_with_zero_hom_class F α β

variables [non_assoc_semiring α] [non_assoc_semiring β] [ring_hom_class F α β]

/-- Ring homomorphisms preserve `bit1`. -/
@[simp] lemma map_bit1 (f : F) (a : α) : (f (bit1 a) : β) = bit1 (f a) := by simp [bit1]

instance : has_coe_t F (α →+* β) :=
⟨λ f, { to_fun := f, map_zero' := map_zero f, map_one' := map_one f, map_mul' := map_mul f,
  map_add' := map_add f }⟩

@[priority 100]
instance ring_hom_class.to_non_unital_ring_hom_class : non_unital_ring_hom_class F α β :=
{ .. ‹ring_hom_class F α β› }

end ring_hom_class

namespace ring_hom

section coe

/-!
Throughout this section, some `semiring` arguments are specified with `{}` instead of `[]`.
See note [implicit instance arguments].
-/
variables {rα : non_assoc_semiring α} {rβ : non_assoc_semiring β}

include rα rβ

instance : ring_hom_class (α →+* β) α β :=
{ coe := ring_hom.to_fun,
  coe_injective' := λ f g h, by cases f; cases g; congr',
  map_add := ring_hom.map_add',
  map_zero := ring_hom.map_zero',
  map_mul := ring_hom.map_mul',
  map_one := ring_hom.map_one' }

/-- Helper instance for when there's too many metavariables to apply `fun_like.has_coe_to_fun`
directly.
-/
instance : has_coe_to_fun (α →+* β) (λ _, α → β) := ⟨ring_hom.to_fun⟩

initialize_simps_projections ring_hom (to_fun → apply)

@[simp] lemma to_fun_eq_coe (f : α →+* β) : f.to_fun = f := rfl

@[simp] lemma coe_mk (f : α → β) (h₁ h₂ h₃ h₄) : ⇑(⟨f, h₁, h₂, h₃, h₄⟩ : α →+* β) = f := rfl

@[simp] lemma coe_coe {F : Type*} [ring_hom_class F α β] (f : F) : ((f : α →+* β) : α → β) = f :=
rfl

instance has_coe_monoid_hom : has_coe (α →+* β) (α →* β) := ⟨ring_hom.to_monoid_hom⟩

@[simp, norm_cast] lemma coe_monoid_hom (f : α →+* β) : ⇑(f : α →* β) = f := rfl

@[simp] lemma to_monoid_hom_eq_coe (f : α →+* β) : f.to_monoid_hom = f := rfl
@[simp] lemma to_monoid_with_zero_hom_eq_coe (f : α →+* β) :
  (f.to_monoid_with_zero_hom : α → β) = f := rfl

@[simp] lemma coe_monoid_hom_mk (f : α → β) (h₁ h₂ h₃ h₄) :
  ((⟨f, h₁, h₂, h₃, h₄⟩ : α →+* β) : α →* β) = ⟨f, h₁, h₂⟩ := rfl

@[simp, norm_cast] lemma coe_add_monoid_hom (f : α →+* β) : ⇑(f : α →+ β) = f := rfl

@[simp] lemma to_add_monoid_hom_eq_coe (f : α →+* β) : f.to_add_monoid_hom = f := rfl

@[simp] lemma coe_add_monoid_hom_mk (f : α → β) (h₁ h₂ h₃ h₄) :
  ((⟨f, h₁, h₂, h₃, h₄⟩ : α →+* β) : α →+ β) = ⟨f, h₃, h₄⟩ := rfl

/-- Copy of a `ring_hom` with a new `to_fun` equal to the old one. Useful to fix definitional
equalities. -/
def copy (f : α →+* β) (f' : α → β) (h : f' = f) : α →+* β :=
{ ..f.to_monoid_with_zero_hom.copy f' h, ..f.to_add_monoid_hom.copy f' h }

@[simp] lemma coe_copy (f : α →+* β) (f' : α → β) (h : f' = f) : ⇑(f.copy f' h) = f' := rfl

lemma copy_eq (f : α →+* β) (f' : α → β) (h : f' = f) : f.copy f' h = f := fun_like.ext' h

end coe

variables [rα : non_assoc_semiring α] [rβ : non_assoc_semiring β]

section
include rα rβ

variables (f : α →+* β) {x y : α} {rα rβ}

lemma congr_fun {f g : α →+* β} (h : f = g) (x : α) : f x = g x := fun_like.congr_fun h x
lemma congr_arg (f : α →+* β) {x y : α} (h : x = y) : f x = f y := fun_like.congr_arg f h

lemma coe_inj ⦃f g : α →+* β⦄ (h : (f : α → β) = g) : f = g := fun_like.coe_injective h

@[ext] lemma ext ⦃f g : α →+* β⦄ : (∀ x, f x = g x) → f = g := fun_like.ext _ _

lemma ext_iff {f g : α →+* β} : f = g ↔ ∀ x, f x = g x := fun_like.ext_iff

@[simp] lemma mk_coe (f : α →+* β) (h₁ h₂ h₃ h₄) : ring_hom.mk f h₁ h₂ h₃ h₄ = f := ext $ λ _, rfl

lemma coe_add_monoid_hom_injective : injective (coe : (α →+* β) → (α →+ β)) :=
λ f g h, ext $ add_monoid_hom.congr_fun h

lemma coe_monoid_hom_injective : injective (coe : (α →+* β) → (α →* β)) :=
λ f g h, ext $ monoid_hom.congr_fun h

/-- Ring homomorphisms map zero to zero. -/
protected lemma map_zero (f : α →+* β) : f 0 = 0 := map_zero f

/-- Ring homomorphisms map one to one. -/
protected lemma map_one (f : α →+* β) : f 1 = 1 := map_one f

/-- Ring homomorphisms preserve addition. -/
protected lemma map_add (f : α →+* β) : ∀ a b, f (a + b) = f a + f b := map_add f

/-- Ring homomorphisms preserve multiplication. -/
protected lemma map_mul (f : α →+* β) : ∀ a b, f (a * b) = f a * f b := map_mul f

/-- Ring homomorphisms preserve `bit0`. -/
protected lemma map_bit0 (f : α →+* β) : ∀ a, f (bit0 a) = bit0 (f a) := map_bit0 f

/-- Ring homomorphisms preserve `bit1`. -/
protected lemma map_bit1 (f : α →+* β) : ∀ a, f (bit1 a) = bit1 (f a) := map_bit1 f

@[simp] lemma map_ite_zero_one {F : Type*} [ring_hom_class F α β] (f : F) (p : Prop) [decidable p] :
  f (ite p 0 1) = ite p 0 1 :=
by { split_ifs; simp [h] }

@[simp] lemma map_ite_one_zero {F : Type*} [ring_hom_class F α β] (f : F) (p : Prop) [decidable p] :
  f (ite p 1 0) = ite p 1 0 :=
by { split_ifs; simp [h] }

/-- `f : α →+* β` has a trivial codomain iff `f 1 = 0`. -/
lemma codomain_trivial_iff_map_one_eq_zero : (0 : β) = 1 ↔ f 1 = 0 := by rw [map_one, eq_comm]

/-- `f : α →+* β` has a trivial codomain iff it has a trivial range. -/
lemma codomain_trivial_iff_range_trivial : (0 : β) = 1 ↔ ∀ x, f x = 0 :=
f.codomain_trivial_iff_map_one_eq_zero.trans
  ⟨λ h x, by rw [←mul_one x, map_mul, h, mul_zero], λ h, h 1⟩

/-- `f : α →+* β` has a trivial codomain iff its range is `{0}`. -/
lemma codomain_trivial_iff_range_eq_singleton_zero : (0 : β) = 1 ↔ set.range f = {0} :=
f.codomain_trivial_iff_range_trivial.trans
  ⟨ λ h, set.ext (λ y, ⟨λ ⟨x, hx⟩, by simp [←hx, h x], λ hy, ⟨0, by simpa using hy.symm⟩⟩),
    λ h x, set.mem_singleton_iff.mp (h ▸ set.mem_range_self x)⟩

/-- `f : α →+* β` doesn't map `1` to `0` if `β` is nontrivial -/
lemma map_one_ne_zero [nontrivial β] : f 1 ≠ 0 :=
mt f.codomain_trivial_iff_map_one_eq_zero.mpr zero_ne_one

/-- If there is a homomorphism `f : α →+* β` and `β` is nontrivial, then `α` is nontrivial. -/
lemma domain_nontrivial [nontrivial β] : nontrivial α :=
⟨⟨1, 0, mt (λ h, show f 1 = 0, by rw [h, map_zero]) f.map_one_ne_zero⟩⟩

lemma codomain_trivial (f : α →+* β) [h : subsingleton α] : subsingleton β :=
(subsingleton_or_nontrivial β).resolve_right
  (λ _, by exactI not_nontrivial_iff_subsingleton.mpr h f.domain_nontrivial)

end

/-- Ring homomorphisms preserve additive inverse. -/
protected theorem map_neg [non_assoc_ring α] [non_assoc_ring β] (f : α →+* β) (x : α) :
  f (-x) = -(f x) :=
map_neg f x

/-- Ring homomorphisms preserve subtraction. -/
protected theorem map_sub [non_assoc_ring α] [non_assoc_ring β] (f : α →+* β) (x y : α) :
  f (x - y) = (f x) - (f y) := map_sub f x y

/-- Makes a ring homomorphism from a monoid homomorphism of rings which preserves addition. -/
def mk' [non_assoc_semiring α] [non_assoc_ring β] (f : α →* β)
  (map_add : ∀ a b, f (a + b) = f a + f b) :
  α →+* β :=
{ ..add_monoid_hom.mk' f map_add, ..f }

section semiring
variables [semiring α] [semiring β]

lemma is_unit_map (f : α →+* β) {a : α} : is_unit a → is_unit (f a) := is_unit.map f

protected lemma map_dvd (f : α →+* β) {a b : α} : a ∣ b → f a ∣ f b := map_dvd f

end semiring

/-- The identity ring homomorphism from a semiring to itself. -/
def id (α : Type*) [non_assoc_semiring α] : α →+* α := by refine {to_fun := id, ..}; intros; refl

include rα

instance : inhabited (α →+* α) := ⟨id α⟩

@[simp] lemma id_apply (x : α) : ring_hom.id α x = x := rfl
@[simp] lemma coe_add_monoid_hom_id : (id α : α →+ α) = add_monoid_hom.id α := rfl
@[simp] lemma coe_monoid_hom_id : (id α : α →* α) = monoid_hom.id α := rfl

variable {rγ : non_assoc_semiring γ}
include rβ rγ

/-- Composition of ring homomorphisms is a ring homomorphism. -/
def comp (g : β →+* γ) (f : α →+* β) : α →+* γ :=
{ to_fun := g ∘ f,
  map_one' := by simp,
  ..g.to_non_unital_ring_hom.comp f.to_non_unital_ring_hom }

/-- Composition of semiring homomorphisms is associative. -/
lemma comp_assoc {δ} {rδ: non_assoc_semiring δ} (f : α →+* β) (g : β →+* γ) (h : γ →+* δ) :
  (h.comp g).comp f = h.comp (g.comp f) := rfl

@[simp] lemma coe_comp (hnp : β →+* γ) (hmn : α →+* β) : (hnp.comp hmn : α → γ) = hnp ∘ hmn := rfl

lemma comp_apply (hnp : β →+* γ) (hmn : α →+* β) (x : α) : (hnp.comp hmn : α → γ) x =
  (hnp (hmn x)) := rfl

omit rγ

@[simp] lemma comp_id (f : α →+* β) : f.comp (id α) = f := ext $ λ x, rfl

@[simp] lemma id_comp (f : α →+* β) : (id β).comp f = f := ext $ λ x, rfl

omit rβ

instance : monoid (α →+* α) :=
{ one := id α,
  mul := comp,
  mul_one := comp_id,
  one_mul := id_comp,
  mul_assoc := λ f g h, comp_assoc _ _ _ }

lemma one_def : (1 : α →+* α) = id α := rfl
lemma mul_def (f g : α →+* α) : f * g = f.comp g := rfl

@[simp] lemma coe_one : ⇑(1 : α →+* α) = _root_.id := rfl
@[simp] lemma coe_mul (f g : α →+* α) : ⇑(f * g) = f ∘ g := rfl

include rβ rγ

lemma cancel_right {g₁ g₂ : β →+* γ} {f : α →+* β} (hf : surjective f) :
  g₁.comp f = g₂.comp f ↔ g₁ = g₂ :=
⟨λ h, ring_hom.ext $ hf.forall.2 (ext_iff.1 h), λ h, h ▸ rfl⟩

lemma cancel_left {g : β →+* γ} {f₁ f₂ : α →+* β} (hg : injective g) :
  g.comp f₁ = g.comp f₂ ↔ f₁ = f₂ :=
⟨λ h, ring_hom.ext $ λ x, hg $ by rw [← comp_apply, h, comp_apply], λ h, h ▸ rfl⟩

end ring_hom

/-- Pullback `is_domain` instance along an injective function. -/
protected theorem function.injective.is_domain [ring α] [is_domain α] [ring β] (f : β →+* α)
  (hf : injective f) : is_domain β :=
begin
  haveI := pullback_nonzero f f.map_zero f.map_one,
  haveI := is_right_cancel_mul_zero.to_no_zero_divisors α,
  haveI := hf.no_zero_divisors f f.map_zero f.map_mul,
  exact no_zero_divisors.to_is_domain β,
end

namespace add_monoid_hom
variables [comm_ring α] [is_domain α] [comm_ring β] (f : β →+ α)

/-- Make a ring homomorphism from an additive group homomorphism from a commutative ring to an
integral domain that commutes with self multiplication, assumes that two is nonzero and `1` is sent
to `1`. -/
def mk_ring_hom_of_mul_self_of_two_ne_zero (h : ∀ x, f (x * x) = f x * f x) (h_two : (2 : α) ≠ 0)
  (h_one : f 1 = 1) : β →+* α :=
{ map_one' := h_one,
  map_mul' := λ x y, begin
    have hxy := h (x + y),
    rw [mul_add, add_mul, add_mul, f.map_add, f.map_add, f.map_add, f.map_add, h x, h y, add_mul,
      mul_add, mul_add, ← sub_eq_zero, add_comm, ← sub_sub, ← sub_sub, ← sub_sub,
      mul_comm y x, mul_comm (f y) (f x)] at hxy,
    simp only [add_assoc, add_sub_assoc, add_sub_cancel'_right] at hxy,
    rw [sub_sub, ← two_mul, ← add_sub_assoc, ← two_mul, ← mul_sub, mul_eq_zero, sub_eq_zero,
      or_iff_not_imp_left] at hxy,
    exact hxy h_two,
  end,
  ..f }

@[simp] lemma coe_fn_mk_ring_hom_of_mul_self_of_two_ne_zero (h h_two h_one) :
  (f.mk_ring_hom_of_mul_self_of_two_ne_zero h h_two h_one : β → α) = f := rfl

@[simp] lemma coe_add_monoid_hom_mk_ring_hom_of_mul_self_of_two_ne_zero (h h_two h_one) :
  (f.mk_ring_hom_of_mul_self_of_two_ne_zero h h_two h_one : β →+ α) = f :=
by { ext, refl }

end add_monoid_hom


/-
Copyright (c) 2015 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura, Jeremy Avigad
-/
import data.finset.basic
import tactic.by_contra

/-!
# Cardinality of a finite set

This defines the cardinality of a `finset` and provides induction principles for finsets.

## Main declarations

* `finset.card`: `s.card : ℕ` returns the cardinality of `s : finset α`.

### Induction principles

* `finset.strong_induction`: Strong induction
* `finset.strong_induction_on`
* `finset.strong_downward_induction`
* `finset.strong_downward_induction_on`
* `finset.case_strong_induction_on`

## TODO

Should we add a noncomputable version?
-/

open function multiset nat

variables {α β : Type*}

namespace finset
variables {s t : finset α} {a : α}

/-- `s.card` is the number of elements of `s`, aka its cardinality. -/
def card (s : finset α) : ℕ := s.1.card

lemma card_def (s : finset α) : s.card = s.1.card := rfl

@[simp] lemma card_mk {m nodup} : (⟨m, nodup⟩ : finset α).card = m.card := rfl

@[simp] lemma card_empty : card (∅ : finset α) = 0 := rfl

lemma card_le_of_subset : s ⊆ t → s.card ≤ t.card := multiset.card_le_of_le ∘ val_le_iff.mpr

@[mono] lemma card_mono : monotone (@card α) := by apply card_le_of_subset

@[simp] lemma card_eq_zero : s.card = 0 ↔ s = ∅ := card_eq_zero.trans val_eq_zero

lemma card_pos : 0 < s.card ↔ s.nonempty :=
pos_iff_ne_zero.trans $ (not_congr card_eq_zero).trans nonempty_iff_ne_empty.symm

alias finset.card_pos ↔ _ finset.nonempty.card_pos

lemma card_ne_zero_of_mem (h : a ∈ s) : s.card ≠ 0 := (not_congr card_eq_zero).2 $ ne_empty_of_mem h

@[simp] lemma card_singleton (a : α) : card ({a} : finset α) = 1 := card_singleton _

lemma card_singleton_inter [decidable_eq α] : ({a} ∩ s).card ≤ 1 :=
begin
  cases (finset.decidable_mem a s),
  { simp [finset.singleton_inter_of_not_mem h] },
  { simp [finset.singleton_inter_of_mem h] }
end

@[simp] lemma card_cons (h : a ∉ s) : (s.cons a h).card = s.card + 1 := card_cons _ _

section insert_erase
variables [decidable_eq α]

@[simp] lemma card_insert_of_not_mem (h : a ∉ s) : (insert a s).card = s.card + 1 :=
by rw [←cons_eq_insert _ _ h, card_cons]

lemma card_insert_of_mem (h : a ∈ s) : card (insert a s) = s.card := by rw insert_eq_of_mem h

lemma card_insert_le (a : α) (s : finset α) : card (insert a s) ≤ s.card + 1 :=
by by_cases a ∈ s; [{rw insert_eq_of_mem h, exact nat.le_succ _ }, rw card_insert_of_not_mem h]

/-- If `a ∈ s` is known, see also `finset.card_insert_of_mem` and `finset.card_insert_of_not_mem`.
-/
lemma card_insert_eq_ite : card (insert a s) = if a ∈ s then s.card else s.card + 1 :=
begin
  by_cases h : a ∈ s,
  { rw [card_insert_of_mem h, if_pos h] },
  { rw [card_insert_of_not_mem h, if_neg h] }
end

@[simp]
lemma card_erase_of_mem : a ∈ s → (s.erase a).card = pred s.card := card_erase_of_mem

@[simp] lemma card_erase_add_one : a ∈ s → (s.erase a).card + 1 = s.card := card_erase_add_one

lemma card_erase_lt_of_mem : a ∈ s → (s.erase a).card < s.card := card_erase_lt_of_mem

lemma card_erase_le : (s.erase a).card ≤ s.card := card_erase_le

lemma pred_card_le_card_erase : s.card - 1 ≤ (s.erase a).card :=
begin
  by_cases h : a ∈ s,
  { exact (card_erase_of_mem h).ge },
  { rw erase_eq_of_not_mem h,
    exact nat.sub_le _ _ }
end

/-- If `a ∈ s` is known, see also `finset.card_erase_of_mem` and `finset.erase_eq_of_not_mem`. -/
lemma card_erase_eq_ite : (s.erase a).card = if a ∈ s then pred s.card else s.card :=
card_erase_eq_ite

end insert_erase

@[simp] lemma card_range (n : ℕ) : (range n).card = n := card_range n

@[simp] lemma card_attach : s.attach.card = s.card := multiset.card_attach

end finset

section to_list_multiset
variables [decidable_eq α] (m : multiset α) (l : list α)

lemma multiset.card_to_finset : m.to_finset.card = m.erase_dup.card := rfl

lemma multiset.to_finset_card_le : m.to_finset.card ≤ m.card := card_le_of_le $ erase_dup_le _

lemma multiset.to_finset_card_of_nodup {m : multiset α} (h : m.nodup) : m.to_finset.card = m.card :=
congr_arg card $ multiset.erase_dup_eq_self.mpr h

lemma list.card_to_finset : l.to_finset.card = l.erase_dup.length := rfl

lemma list.to_finset_card_le : l.to_finset.card ≤ l.length := multiset.to_finset_card_le ⟦l⟧

lemma list.to_finset_card_of_nodup {l : list α} (h : l.nodup) : l.to_finset.card = l.length :=
multiset.to_finset_card_of_nodup h

end to_list_multiset

namespace finset
variables {s t : finset α} {f : α → β} {n : ℕ}

@[simp] lemma length_to_list (s : finset α) : s.to_list.length = s.card :=
by { rw [to_list, ←multiset.coe_card, multiset.coe_to_list], refl }

lemma card_image_le [decidable_eq β] : (s.image f).card ≤ s.card :=
by simpa only [card_map] using (s.1.map f).to_finset_card_le

lemma card_image_of_inj_on [decidable_eq β] (H : set.inj_on f s) : (s.image f).card = s.card :=
by simp only [card, image_val_of_inj_on H, card_map]

lemma inj_on_of_card_image_eq [decidable_eq β] (H : (s.image f).card = s.card) : set.inj_on f s :=
begin
  change (s.1.map f).erase_dup.card = s.1.card at H,
  have : (s.1.map f).erase_dup = s.1.map f,
  { refine multiset.eq_of_le_of_card_le (multiset.erase_dup_le _) _,
    rw H,
    simp only [multiset.card_map] },
  rw multiset.erase_dup_eq_self at this,
  exact inj_on_of_nodup_map this,
end

lemma card_image_eq_iff_inj_on [decidable_eq β] : (s.image f).card = s.card ↔ set.inj_on f s :=
⟨inj_on_of_card_image_eq, card_image_of_inj_on⟩

lemma card_image_of_injective [decidable_eq β] (s : finset α) (H : injective f) :
  (s.image f).card = s.card :=
card_image_of_inj_on $ λ x _ y _ h, H h

@[simp] lemma card_map (f : α ↪ β) : (s.map f).card = s.card := multiset.card_map _ _

@[simp] lemma card_subtype (p : α → Prop) [decidable_pred p] (s : finset α) :
  (s.subtype p).card = (s.filter p).card :=
by simp [finset.subtype]

lemma card_filter_le (s : finset α) (p : α → Prop) [decidable_pred p] :
  (s.filter p).card ≤ s.card :=
card_le_of_subset $ filter_subset _ _

lemma eq_of_subset_of_card_le {s t : finset α} (h : s ⊆ t) (h₂ : t.card ≤ s.card) : s = t :=
eq_of_veq $ multiset.eq_of_le_of_card_le (val_le_iff.mpr h) h₂

lemma map_eq_of_subset {f : α ↪ α} (hs : s.map f ⊆ s) : s.map f = s :=
eq_of_subset_of_card_le hs (card_map _).ge

lemma filter_card_eq {p : α → Prop} [decidable_pred p] (h : (s.filter p).card = s.card) (x : α)
  (hx : x ∈ s) :
  p x :=
begin
  rw [←eq_of_subset_of_card_le (s.filter_subset p) h.ge, mem_filter] at hx,
  exact hx.2,
end

lemma card_lt_card (h : s ⊂ t) : s.card < t.card := card_lt_of_lt $ val_lt_iff.2 h

lemma card_eq_of_bijective (f : ∀ i, i < n → α) (hf : ∀ a ∈ s, ∃ i, ∃ h : i < n, f i h = a)
  (hf' : ∀ i (h : i < n), f i h ∈ s) (f_inj : ∀ i j (hi : i < n)
  (hj : j < n), f i hi = f j hj → i = j) :
  s.card = n :=
begin
  classical,
  have : ∀ (a : α), a ∈ s ↔ ∃ i (hi : i ∈ range n), f i (mem_range.1 hi) = a,
    from λ a, ⟨λ ha, let ⟨i, hi, eq⟩ := hf a ha in ⟨i, mem_range.2 hi, eq⟩,
      λ ⟨i, hi, eq⟩, eq ▸ hf' i (mem_range.1 hi)⟩,
  have : s = ((range n).attach.image $ λi, f i.1 (mem_range.1 i.2)),
    by simpa only [ext_iff, mem_image, exists_prop, subtype.exists, mem_attach, true_and],
  calc s.card = card ((range n).attach.image $ λ i, f i.1 (mem_range.1 i.2)) :
      by rw this
    ... = card ((range n).attach) :
      card_image_of_injective _ $ λ ⟨i, hi⟩ ⟨j, hj⟩ eq,
        subtype.eq $ f_inj i j (mem_range.1 hi) (mem_range.1 hj) eq
    ... = card (range n) : card_attach
    ... = n : card_range n
end

lemma card_congr {t : finset β} (f : Π a ∈ s, β) (h₁ : ∀ a ha, f a ha ∈ t)
  (h₂ : ∀ a b ha hb, f a ha = f b hb → a = b) (h₃ : ∀ b ∈ t, ∃ a ha, f a ha = b) :
  s.card = t.card :=
by classical;
calc s.card = s.attach.card : card_attach.symm
... = (s.attach.image (λ (a : {a // a ∈ s}), f a.1 a.2)).card
    : eq.symm (card_image_of_injective _ $ λ a b h, subtype.eq $ h₂ _ _ _ _ h)
... = t.card : congr_arg card (finset.ext $ λ b,
    ⟨λ h, let ⟨a, ha₁, ha₂⟩ := mem_image.1 h in ha₂ ▸ h₁ _ _,
      λ h, let ⟨a, ha₁, ha₂⟩ := h₃ b h in mem_image.2 ⟨⟨a, ha₁⟩, by simp [ha₂]⟩⟩)

lemma card_le_card_of_inj_on {t : finset β} (f : α → β) (hf : ∀ a ∈ s, f a ∈ t)
  (f_inj : ∀ a₁ ∈ s, ∀ a₂ ∈ s, f a₁ = f a₂ → a₁ = a₂) :
  s.card ≤ t.card :=
by classical;
  calc s.card = (s.image f).card : (card_image_of_inj_on f_inj).symm
    ... ≤ t.card : card_le_of_subset $ image_subset_iff.2 hf

/-- If there are more pigeons than pigeonholes, then there are two pigeons in the same pigeonhole.
-/
lemma exists_ne_map_eq_of_card_lt_of_maps_to {t : finset β} (hc : t.card < s.card)
  {f : α → β} (hf : ∀ a ∈ s, f a ∈ t) :
  ∃ (x ∈ s) (y ∈ s), x ≠ y ∧ f x = f y :=
begin
  classical,
  by_contra' hz,
  refine hc.not_le (card_le_card_of_inj_on f hf _),
  intros x hx y hy, contrapose, exact hz x hx y hy,
end

lemma le_card_of_inj_on_range (f : ℕ → α) (hf : ∀ i < n, f i ∈ s)
  (f_inj : ∀ (i < n) (j < n), f i = f j → i = j) :
  n ≤ s.card :=
calc n = card (range n) : (card_range n).symm
  ... ≤ s.card : card_le_card_of_inj_on f (by simpa only [mem_range]) (by simpa only [mem_range])

lemma surj_on_of_inj_on_of_card_le {t : finset β} (f : Π a ∈ s, β) (hf : ∀ a ha, f a ha ∈ t)
  (hinj : ∀ a₁ a₂ ha₁ ha₂, f a₁ ha₁ = f a₂ ha₂ → a₁ = a₂) (hst : t.card ≤ s.card) :
  ∀ b ∈ t, ∃ a ha, b = f a ha :=
begin
  classical,
  intros b hb,
  have h : (s.attach.image $ λ (a : {a // a ∈ s}), f a a.prop).card = s.card,
  { exact @card_attach _ s ▸ card_image_of_injective _
      (λ ⟨a₁, ha₁⟩ ⟨a₂, ha₂⟩ h, subtype.eq $ hinj _ _ _ _ h) },
  have h' : image (λ a : {a // a ∈ s}, f a a.prop) s.attach = t,
  { exact eq_of_subset_of_card_le (λ b h, let ⟨a, ha₁, ha₂⟩ := mem_image.1 h in
      ha₂ ▸ hf _ _) (by simp [hst, h]) },
  rw ←h' at hb,
  obtain ⟨a, ha₁, ha₂⟩ := mem_image.1 hb,
  exact ⟨a, a.2, ha₂.symm⟩,
end

lemma inj_on_of_surj_on_of_card_le {t : finset β} (f : Π a ∈ s, β) (hf : ∀ a ha, f a ha ∈ t)
  (hsurj : ∀ b ∈ t, ∃ a ha, b = f a ha) (hst : s.card ≤ t.card) ⦃a₁ a₂⦄ (ha₁ : a₁ ∈ s)
  (ha₂ : a₂ ∈ s) (ha₁a₂: f a₁ ha₁ = f a₂ ha₂) :
  a₁ = a₂ :=
by haveI : inhabited {x // x ∈ s} := ⟨⟨a₁, ha₁⟩⟩; exact
let f' : {x // x ∈ s} → {x // x ∈ t} := λ x, ⟨f x.1 x.2, hf x.1 x.2⟩ in
let g : {x // x ∈ t} → {x // x ∈ s} :=
  @surj_inv _ _ f'
    (λ x, let ⟨y, hy₁, hy₂⟩ := hsurj x.1 x.2 in ⟨⟨y, hy₁⟩, subtype.eq hy₂.symm⟩) in
have hg : injective g, from injective_surj_inv _,
have hsg : surjective g, from λ x,
  let ⟨y, hy⟩ := surj_on_of_inj_on_of_card_le (λ (x : {x // x ∈ t}) (hx : x ∈ t.attach), g x)
    (λ x _, show (g x) ∈ s.attach, from mem_attach _ _)
    (λ x y _ _ hxy, hg hxy) (by simpa) x (mem_attach _ _) in
  ⟨y, hy.snd.symm⟩,
have hif : injective f',
  from (left_inverse_of_surjective_of_right_inverse hsg
      (right_inverse_surj_inv _)).injective,
subtype.ext_iff_val.1 (@hif ⟨a₁, ha₁⟩ ⟨a₂, ha₂⟩ (subtype.eq ha₁a₂))

/-! ### Lattice structure -/

section lattice
variables [decidable_eq α]

lemma card_union_add_card_inter (s t : finset α) : (s ∪ t).card + (s ∩ t).card = s.card + t.card :=
finset.induction_on t (by simp) $ λ a r har, by by_cases a ∈ s; simp *; cc

lemma card_union_le (s t : finset α) : (s ∪ t).card ≤ s.card + t.card :=
card_union_add_card_inter s t ▸ nat.le_add_right _ _

lemma card_union_eq (h : disjoint s t) : (s ∪ t).card = s.card + t.card :=
by rw [←card_union_add_card_inter, disjoint_iff_inter_eq_empty.1 h, card_empty, add_zero]

@[simp] lemma card_disjoint_union (h : disjoint s t) : card (s ∪ t) = s.card + t.card :=
by rw [←card_union_add_card_inter, disjoint_iff_inter_eq_empty.1 h, card_empty, add_zero]

lemma card_sdiff (h : s ⊆ t) : card (t \ s) = t.card - s.card :=
suffices card (t \ s) = card ((t \ s) ∪ s) - s.card, by rwa sdiff_union_of_subset h at this,
by rw [card_disjoint_union sdiff_disjoint, add_tsub_cancel_right]

lemma card_sdiff_add_card : (s \ t).card + t.card = (s ∪ t).card :=
by rw [←card_disjoint_union sdiff_disjoint, sdiff_union_self_eq_union]

end lattice

lemma filter_card_add_filter_neg_card_eq_card (p : α → Prop) [decidable_pred p] :
  (s.filter p).card + (s.filter (not ∘ p)).card = s.card :=
by { classical, simp [←card_union_eq, filter_union_filter_neg_eq, disjoint_filter] }

/-- Given a set `A` and a set `B` inside it, we can shrink `A` to any appropriate size, and keep `B`
inside it. -/
lemma exists_intermediate_set {A B : finset α} (i : ℕ) (h₁ : i + card B ≤ card A) (h₂ : B ⊆ A) :
  ∃ (C : finset α), B ⊆ C ∧ C ⊆ A ∧ card C = i + card B :=
begin
  classical,
  rcases nat.le.dest h₁ with ⟨k, _⟩,
  clear h₁,
  induction k with k ih generalizing A,
  { exact ⟨A, h₂, subset.refl _, h.symm⟩ },
  have : (A \ B).nonempty,
  { rw [←card_pos, card_sdiff h₂, ←h, nat.add_right_comm,
        add_tsub_cancel_right, nat.add_succ],
    apply nat.succ_pos },
  rcases this with ⟨a, ha⟩,
  have z : i + card B + k = card (erase A a),
  { rw [card_erase_of_mem, ←h, nat.add_succ, nat.pred_succ],
    rw mem_sdiff at ha,
    exact ha.1 },
  rcases ih _ z with ⟨B', hB', B'subA', cards⟩,
  { exact ⟨B', hB', trans B'subA' (erase_subset _ _), cards⟩ },
  { rintro t th,
    apply mem_erase_of_ne_of_mem _ (h₂ th),
    rintro rfl,
    exact not_mem_sdiff_of_mem_right th ha }
end

/-- We can shrink `A` to any smaller size. -/
lemma exists_smaller_set (A : finset α) (i : ℕ) (h₁ : i ≤ card A) :
  ∃ (B : finset α), B ⊆ A ∧ card B = i :=
let ⟨B, _, x₁, x₂⟩ := exists_intermediate_set i (by simpa) (empty_subset A) in ⟨B, x₁, x₂⟩

lemma exists_subset_or_subset_of_two_mul_lt_card [decidable_eq α] {X Y : finset α} {n : ℕ}
  (hXY : 2 * n < (X ∪ Y).card) :
  ∃ C : finset α, n < C.card ∧ (C ⊆ X ∨ C ⊆ Y) :=
begin
  have h₁ : (X ∩ (Y \ X)).card = 0 := finset.card_eq_zero.mpr (finset.inter_sdiff_self X Y),
  have h₂ : (X ∪ Y).card = X.card + (Y \ X).card,
  { rw [←card_union_add_card_inter X (Y \ X), finset.union_sdiff_self_eq_union, h₁, add_zero] },
  rw [h₂, two_mul] at hXY,
  rcases lt_or_lt_of_add_lt_add hXY with h|h,
  { exact ⟨X, h, or.inl (finset.subset.refl X)⟩ },
  { exact ⟨Y \ X, h, or.inr (finset.sdiff_subset Y X)⟩ }
end

/-! ### Explicit description of a finset from its card -/

lemma card_eq_one : s.card = 1 ↔ ∃ a, s = {a} :=
by cases s; simp only [multiset.card_eq_one, finset.card, ←val_inj, singleton_val]

lemma card_le_one : s.card ≤ 1 ↔ ∀ (a ∈ s) (b ∈ s), a = b :=
begin
  obtain rfl | ⟨x, hx⟩ := s.eq_empty_or_nonempty,
  { simp },
  refine (nat.succ_le_of_lt (card_pos.2 ⟨x, hx⟩)).le_iff_eq.trans (card_eq_one.trans ⟨_, _⟩),
  { rintro ⟨y, rfl⟩,
    simp },
  { exact λ h, ⟨x, eq_singleton_iff_unique_mem.2 ⟨hx, λ y hy, h _ hy _ hx⟩⟩ }
end

lemma card_le_one_iff : s.card ≤ 1 ↔ ∀ {a b}, a ∈ s → b ∈ s → a = b := by { rw card_le_one, tauto }

lemma card_le_one_iff_subset_singleton [nonempty α] : s.card ≤ 1 ↔ ∃ (x : α), s ⊆ {x} :=
begin
  refine ⟨λ H, _, _⟩,
  { obtain rfl | ⟨x, hx⟩ := s.eq_empty_or_nonempty,
    { exact ⟨classical.arbitrary α, empty_subset _⟩ },
    { exact ⟨x, λ y hy, by rw [card_le_one.1 H y hy x hx, mem_singleton]⟩ } },
  { rintro ⟨x, hx⟩,
    rw ←card_singleton x,
    exact card_le_of_subset hx }
end

/-- A `finset` of a subsingleton type has cardinality at most one. -/
lemma card_le_one_of_subsingleton [subsingleton α] (s : finset α) : s.card ≤ 1 :=
finset.card_le_one_iff.2 $ λ _ _ _ _, subsingleton.elim _ _

lemma one_lt_card : 1 < s.card ↔ ∃ (a ∈ s) (b ∈ s), a ≠ b :=
by { rw ←not_iff_not, push_neg, exact card_le_one }

lemma one_lt_card_iff : 1 < s.card ↔ ∃ a b, a ∈ s ∧ b ∈ s ∧ a ≠ b :=
by { rw one_lt_card, simp only [exists_prop, exists_and_distrib_left] }

lemma two_lt_card_iff : 2 < s.card ↔ ∃ a b c, a ∈ s ∧ b ∈ s ∧ c ∈ s ∧ a ≠ b ∧ a ≠ c ∧ b ≠ c :=
begin
  classical,
  refine ⟨λ h, _, _⟩,
  { obtain ⟨c, hc⟩ := card_pos.mp (zero_lt_two.trans h),
    have : 1 < (s.erase c).card := by rwa [←add_lt_add_iff_right 1, card_erase_add_one hc],
    obtain ⟨a, b, ha, hb, hab⟩ := one_lt_card_iff.mp this,
    exact ⟨a, b, c, mem_of_mem_erase ha, mem_of_mem_erase hb, hc,
      hab, ne_of_mem_erase ha, ne_of_mem_erase hb⟩ },
  { rintros ⟨a, b, c, ha, hb, hc, hab, hac, hbc⟩,
    rw [←card_erase_add_one hc, ←card_erase_add_one (mem_erase_of_ne_of_mem hbc hb),
        ←card_erase_add_one (mem_erase_of_ne_of_mem hab (mem_erase_of_ne_of_mem hac ha))],
    apply nat.le_add_left },
end

lemma two_lt_card : 2 < s.card ↔ ∃ (a ∈ s) (b ∈ s) (c ∈ s), a ≠ b ∧ a ≠ c ∧ b ≠ c :=
by simp_rw [two_lt_card_iff, exists_prop, exists_and_distrib_left]

lemma exists_ne_of_one_lt_card (hs : 1 < s.card) (a : α) : ∃ b, b ∈ s ∧ b ≠ a :=
begin
  obtain ⟨x, hx, y, hy, hxy⟩ := finset.one_lt_card.mp hs,
  by_cases ha : y = a,
  { exact ⟨x, hx, ne_of_ne_of_eq hxy ha⟩ },
  { exact ⟨y, hy, ha⟩ }
end

lemma card_eq_succ [decidable_eq α] :
  s.card = n + 1 ↔ (∃ a t, a ∉ t ∧ insert a t = s ∧ t.card = n) :=
⟨λ eq,
  let ⟨a, has⟩ := card_pos.mp (eq.symm ▸ nat.zero_lt_succ _ : 0 < s.card) in
    ⟨a, s.erase a, s.not_mem_erase a, insert_erase has,
      by simp only [eq, card_erase_of_mem has, pred_succ]⟩,
  λ ⟨a, t, hat, s_eq, n_eq⟩, s_eq ▸ n_eq ▸ card_insert_of_not_mem hat⟩

lemma card_eq_two [decidable_eq α] : s.card = 2 ↔ ∃ x y, x ≠ y ∧ s = {x, y} :=
begin
  split,
  { rw card_eq_succ,
    simp_rw [card_eq_one],
    rintro ⟨a, _, hab, rfl, b, rfl⟩,
    exact ⟨a, b, not_mem_singleton.1 hab, rfl⟩ },
  { rintro ⟨x, y, hxy, rfl⟩,
    simp only [hxy, card_insert_of_not_mem, not_false_iff, mem_singleton, card_singleton] }
end

lemma card_eq_three [decidable_eq α] :
  s.card = 3 ↔ ∃ x y z, x ≠ y ∧ x ≠ z ∧ y ≠ z ∧ s = {x, y, z} :=
begin
  split,
  { rw card_eq_succ,
    simp_rw [card_eq_two],
    rintro ⟨a, _, abc, rfl, b, c, bc, rfl⟩,
    rw [mem_insert, mem_singleton, not_or_distrib] at abc,
    exact ⟨a, b, c, abc.1, abc.2, bc, rfl⟩ },
  { rintro ⟨x, y, z, xy, xz, yz, rfl⟩,
    simp only [xy, xz, yz, mem_insert, card_insert_of_not_mem, not_false_iff, mem_singleton,
      or_self, card_singleton] }
end

/-! ### Inductions -/

/-- Suppose that, given objects defined on all strict subsets of any finset `s`, one knows how to
define an object on `s`. Then one can inductively define an object on all finsets, starting from
the empty set and iterating. This can be used either to define data, or to prove properties. -/
def strong_induction {p : finset α → Sort*} (H : ∀ s, (∀ t ⊂ s, p t) → p s) :
  ∀ (s : finset α), p s
| s := H s (λ t h, have t.card < s.card, from card_lt_card h, strong_induction t)
using_well_founded {rel_tac := λ _ _, `[exact ⟨_, measure_wf card⟩]}

lemma strong_induction_eq {p : finset α → Sort*} (H : ∀ s, (∀ t ⊂ s, p t) → p s) (s : finset α) :
  strong_induction H s = H s (λ t h, strong_induction H t) :=
by rw strong_induction

/-- Analogue of `strong_induction` with order of arguments swapped. -/
@[elab_as_eliminator] def strong_induction_on {p : finset α → Sort*} (s : finset α) :
  (∀ s, (∀ t ⊂ s, p t) → p s) → p s :=
λ H, strong_induction H s

lemma strong_induction_on_eq {p : finset α → Sort*} (s : finset α) (H : ∀ s, (∀ t ⊂ s, p t) → p s) :
  s.strong_induction_on H = H s (λ t h, t.strong_induction_on H) :=
by { dunfold strong_induction_on, rw strong_induction }

@[elab_as_eliminator] lemma case_strong_induction_on [decidable_eq α] {p : finset α → Prop}
  (s : finset α) (h₀ : p ∅) (h₁ : ∀ a s, a ∉ s → (∀ t ⊆ s, p t) → p (insert a s)) :
  p s :=
finset.strong_induction_on s $ λ s,
finset.induction_on s (λ _, h₀) $ λ a s n _ ih, h₁ a s n $
λ t ss, ih _ (lt_of_le_of_lt ss (ssubset_insert n) : t < _)

/-- Suppose that, given that `p t` can be defined on all supersets of `s` of cardinality less than
`n`, one knows how to define `p s`. Then one can inductively define `p s` for all finsets `s` of
cardinality less than `n`, starting from finsets of card `n` and iterating. This
can be used either to define data, or to prove properties. -/
def strong_downward_induction {p : finset α → Sort*} {n : ℕ} (H : ∀ t₁, (∀ {t₂ : finset α},
  t₂.card ≤ n → t₁ ⊂ t₂ → p t₂) → t₁.card ≤ n → p t₁) :
  ∀ (s : finset α), s.card ≤ n → p s
| s := H s (λ t ht h, have n - t.card < n - s.card,
     from (tsub_lt_tsub_iff_left_of_le ht).2 (finset.card_lt_card h),
  strong_downward_induction t ht)
using_well_founded {rel_tac := λ _ _, `[exact ⟨_, measure_wf (λ (t : finset α), n - t.card)⟩]}

lemma strong_downward_induction_eq {p : finset α → Sort*}
  (H : ∀ t₁, (∀ {t₂ : finset α}, t₂.card ≤ n → t₁ ⊂ t₂ → p t₂) → t₁.card ≤ n → p t₁)
  (s : finset α) :
  strong_downward_induction H s = H s (λ t ht hst, strong_downward_induction H t ht) :=
by rw strong_downward_induction

/-- Analogue of `strong_downward_induction` with order of arguments swapped. -/
@[elab_as_eliminator] def strong_downward_induction_on {p : finset α → Sort*} (s : finset α)
  (H : ∀ t₁, (∀ {t₂ : finset α}, t₂.card ≤ n → t₁ ⊂ t₂ → p t₂) → t₁.card ≤ n → p t₁) :
  s.card ≤ n → p s :=
strong_downward_induction H s

lemma strong_downward_induction_on_eq {p : finset α → Sort*} (s : finset α) (H : ∀ t₁,
  (∀ {t₂ : finset α}, t₂.card ≤ n → t₁ ⊂ t₂ → p t₂) → t₁.card ≤ n → p t₁) :
  s.strong_downward_induction_on H = H s (λ t ht h, t.strong_downward_induction_on H ht) :=
by { dunfold strong_downward_induction_on, rw strong_downward_induction }

lemma lt_wf {α} : well_founded (@has_lt.lt (finset α) _) :=
have H : subrelation (@has_lt.lt (finset α) _)
    (inv_image ( < ) card),
  from λ x y hxy, card_lt_card hxy,
subrelation.wf H $ inv_image.wf _ $ nat.lt_wf

end finset


import mynat.definition
import mynat.mul
import world3.level1
import world3.level6

namespace mynat

lemma mul_comm (a b : mynat) : a * b = b * a :=
begin [nat_num_game]
    induction b with d hd,
    {
        rw mul_zero,
        rw zero_mul,
        refl,
    },
    {
        rw mul_succ,
        rw succ_mul,
        rw hd,
        refl,
    },
end

end mynat


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

import ring_theory.adjoin.basic
import ring_theory.power_basis
import linear_algebra.matrix.basis

/-!
# Power basis for `algebra.adjoin R {x}`

This file defines the canonical power basis on `algebra.adjoin R {x}`,
where `x` is an integral element over `R`.
-/

variables {K S : Type*} [field K] [comm_ring S] [algebra K S]

namespace algebra

open polynomial
open power_basis

open_locale big_operators

/-- The elements `1, x, ..., x ^ (d - 1)` for a basis for the `K`-module `K[x]`,
where `d` is the degree of the minimal polynomial of `x`. -/
noncomputable def adjoin.power_basis_aux {x : S} (hx : _root_.is_integral K x) :
  basis (fin (minpoly K x).nat_degree) K (adjoin K ({x} : set S)) :=
begin
  have hST : function.injective (algebra_map (adjoin K ({x} : set S)) S) := subtype.coe_injective,
  have hx' : _root_.is_integral K
    (show adjoin K ({x} : set S), from ⟨x, subset_adjoin (set.mem_singleton x)⟩),
  { apply (is_integral_algebra_map_iff hST).mp,
    convert hx,
    apply_instance },
  have minpoly_eq := minpoly.eq_of_algebra_map_eq hST hx' rfl,
  apply @basis.mk (fin (minpoly K x).nat_degree) _
    (adjoin K {x}) (λ i, ⟨x, subset_adjoin (set.mem_singleton x)⟩ ^ (i : ℕ)),
  { have := hx'.linear_independent_pow,
    rwa minpoly_eq at this },
  { rw _root_.eq_top_iff,
    rintros ⟨y, hy⟩ _,
    have := hx'.mem_span_pow,
    rw minpoly_eq at this,
    apply this,
    { rw [adjoin_singleton_eq_range_aeval] at hy,
      obtain ⟨f, rfl⟩ := (aeval x).mem_range.mp hy,
      use f,
      ext,
      exact (is_scalar_tower.algebra_map_aeval K (adjoin K {x}) S ⟨x, _⟩ _).symm } }
end

/-- The power basis `1, x, ..., x ^ (d - 1)` for `K[x]`,
where `d` is the degree of the minimal polynomial of `x`. -/
@[simps gen dim] noncomputable def adjoin.power_basis {x : S} (hx : _root_.is_integral K x) :
  power_basis K (adjoin K ({x} : set S)) :=
{ gen := ⟨x, subset_adjoin (set.mem_singleton x)⟩,
  dim := (minpoly K x).nat_degree,
  basis := adjoin.power_basis_aux hx,
  basis_eq_pow := basis.mk_apply _ _ }

end algebra

open algebra

/-- The power basis given by `x` if `B.gen ∈ adjoin K {x}`. -/
@[simps] noncomputable def power_basis.of_gen_mem_adjoin {x : S} (B : power_basis K S)
  (hint : _root_.is_integral K x) (hx : B.gen ∈ adjoin K ({x} : set S)) : power_basis K S :=
(algebra.adjoin.power_basis hint).map $
  (subalgebra.equiv_of_eq _ _ $ power_basis.adjoin_eq_top_of_gen_mem_adjoin hx).trans
  subalgebra.top_equiv

section is_integral

namespace power_basis

open polynomial

open_locale polynomial

variables {R : Type*} [comm_ring R] [algebra R S] [algebra R K] [is_scalar_tower R K S]
variables {A : Type*} [comm_ring A] [algebra R A] [algebra S A]
variables [is_scalar_tower R S A] {B : power_basis S A} (hB : is_integral R B.gen)

include hB

/-- If `B : power_basis S A` is such that `is_integral R B.gen`, then
`is_integral R (B.basis.repr (B.gen ^ n) i)` for all `i` if
`minpoly S B.gen = (minpoly R B.gen).map (algebra_map R S)`. This is the case if `R` is a GCD domain
and `S` is its fraction ring. -/
lemma repr_gen_pow_is_integral [is_domain S]
  (hmin : minpoly S B.gen = (minpoly R B.gen).map (algebra_map R S)) (n : ℕ) :
  ∀ i, is_integral R (B.basis.repr (B.gen ^ n) i) :=
begin
  intro i,
  let Q := (X ^ n) %ₘ (minpoly R B.gen),
  have : B.gen ^ n = aeval B.gen Q,
  { rw [← @aeval_X_pow R _ _ _ _ B.gen, ← mod_by_monic_add_div (X ^ n) (minpoly.monic hB)],
    simp },
  by_cases hQ : Q = 0,
  { simp [this, hQ, is_integral_zero] },
  have hlt : Q.nat_degree < B.dim,
  { rw [← B.nat_degree_minpoly, hmin, (minpoly.monic hB).nat_degree_map,
      nat_degree_lt_nat_degree_iff hQ],
    letI : nontrivial R := nontrivial.of_polynomial_ne hQ,
    exact degree_mod_by_monic_lt _ (minpoly.monic hB),
    apply_instance },
  rw [this, aeval_eq_sum_range' hlt],
  simp only [linear_equiv.map_sum, linear_equiv.map_smulₛₗ, ring_hom.id_apply, finset.sum_apply'],
  refine is_integral.sum _ (λ j hj, _),
  replace hj := finset.mem_range.1 hj,
  rw [← fin.coe_mk hj, ← B.basis_eq_pow, algebra.smul_def,
    is_scalar_tower.algebra_map_apply R S A, ← algebra.smul_def, linear_equiv.map_smul],
  simp only [algebra_map_smul, finsupp.coe_smul, pi.smul_apply, B.basis.repr_self_apply],
  by_cases hij : (⟨j, hj⟩ : fin _) = i,
  { simp only [hij, eq_self_iff_true, if_true],
    rw [algebra.smul_def, mul_one],
    exact is_integral_algebra_map },
  { simp [hij, is_integral_zero] }
end

variable {B}

/-- Let `B : power_basis S A` be such that `is_integral R B.gen`, and let `x y : A` be elements with
integral coordinates in the base `B.basis`. Then `is_integral R ((B.basis.repr (x * y) i)` for all
`i` if `minpoly S B.gen = (minpoly R B.gen).map (algebra_map R S)`. This is the case if `R` is a GCD
domain and `S` is its fraction ring. -/
lemma repr_mul_is_integral [is_domain S] {x y : A} (hx : ∀ i, is_integral R (B.basis.repr x i))
  (hy : ∀ i, is_integral R (B.basis.repr y i))
  (hmin : minpoly S B.gen = (minpoly R B.gen).map (algebra_map R S)) :
  ∀ i, is_integral R ((B.basis.repr (x * y) i)) :=
begin
  intro i,
  rw [← B.basis.sum_repr x, ← B.basis.sum_repr y, finset.sum_mul_sum, linear_equiv.map_sum,
    finset.sum_apply'],
  refine is_integral.sum _ (λ I hI, _),
  simp only [algebra.smul_mul_assoc, algebra.mul_smul_comm, linear_equiv.map_smulₛₗ,
    ring_hom.id_apply, finsupp.coe_smul, pi.smul_apply, id.smul_eq_mul],
  refine is_integral_mul (hy _) (is_integral_mul (hx _) _),
  simp only [coe_basis, ← pow_add],
  refine repr_gen_pow_is_integral hB hmin _ _,
end

/-- Let `B : power_basis S A` be such that `is_integral R B.gen`, and let `x : A` be and element
with integral coordinates in the base `B.basis`. Then `is_integral R ((B.basis.repr (x ^ n) i)` for
all `i` and all `n` if `minpoly S B.gen = (minpoly R B.gen).map (algebra_map R S)`. This is the case
if `R` is a GCD domain and `S` is its fraction ring. -/
lemma repr_pow_is_integral [is_domain S] {x : A} (hx : ∀ i, is_integral R (B.basis.repr x i))
  (hmin : minpoly S B.gen = (minpoly R B.gen).map (algebra_map R S)) (n : ℕ) :
  ∀ i, is_integral R ((B.basis.repr (x ^ n) i)) :=
begin
  nontriviality A using [subsingleton.elim (x ^ n) 0, is_integral_zero],
  revert hx,
  refine nat.case_strong_induction_on n _ (λ n hn, _),
  { intros hx i,
    rw [pow_zero, ← pow_zero B.gen, ← fin.coe_mk B.dim_pos, ← B.basis_eq_pow,
      B.basis.repr_self_apply],
    split_ifs,
    { exact is_integral_one },
    { exact is_integral_zero } },
  { intros hx,
    rw [pow_succ],
    exact repr_mul_is_integral hB hx (λ _, hn _ le_rfl (λ _, hx _) _) hmin }
end

/-- Let `B B' : power_basis K S` be such that `is_integral R B.gen`, and let `P : R[X]` be such that
`aeval B.gen P = B'.gen`. Then `is_integral R (B.basis.to_matrix B'.basis i j)` for all `i` and `j`
if `minpoly K B.gen = (minpoly R B.gen).map (algebra_map R L)`. This is the case
if `R` is a GCD domain and `K` is its fraction ring. -/
lemma to_matrix_is_integral {B B' : power_basis K S} {P : R[X]} (h : aeval B.gen P = B'.gen)
  (hB : is_integral R B.gen) (hmin : minpoly K B.gen = (minpoly R B.gen).map (algebra_map R K)) :
  ∀ i j, _root_.is_integral R (B.basis.to_matrix B'.basis i j) :=
begin
  intros i j,
  rw [B.basis.to_matrix_apply, B'.coe_basis],
  refine repr_pow_is_integral hB (λ i, _) hmin _ _,
  rw [← h, aeval_eq_sum_range, linear_equiv.map_sum, finset.sum_apply'],
  refine is_integral.sum _ (λ n hn, _),
  rw [algebra.smul_def, is_scalar_tower.algebra_map_apply R K S, ← algebra.smul_def,
    linear_equiv.map_smul, algebra_map_smul],
  exact is_integral_smul _ (repr_gen_pow_is_integral hB hmin _ _),
end

end power_basis

end is_integral


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

universes v₁ u_1 u₂ v₂

namespace Mathlib

/-!
# Connected limits

A connected limit is a limit whose shape is a connected category.

We give examples of connected categories, and prove that the functor given
by `(X × -)` preserves any connected limit. That is, any limit of shape `J`
where `J` is a connected category is preserved by the functor `(X × -)`.
-/

namespace category_theory

protected instance wide_pullback_shape_connected (J : Type v₁) : is_connected (limits.wide_pullback_shape J) :=
  is_connected.of_induct
    fun (p : set (limits.wide_pullback_shape J)) (hp : none ∈ p)
      (t : ∀ {j₁ j₂ : limits.wide_pullback_shape J}, (j₁ ⟶ j₂) → (j₁ ∈ p ↔ j₂ ∈ p)) (j : limits.wide_pullback_shape J) =>
      option.cases_on j hp
        fun (j : J) =>
          eq.mpr (id (Eq._oldrec (Eq.refl (some j ∈ p)) (propext (t (limits.wide_pullback_shape.hom.term j))))) hp

protected instance wide_pushout_shape_connected (J : Type v₁) : is_connected (limits.wide_pushout_shape J) :=
  is_connected.of_induct
    fun (p : set (limits.wide_pushout_shape J)) (hp : none ∈ p)
      (t : ∀ {j₁ j₂ : limits.wide_pushout_shape J}, (j₁ ⟶ j₂) → (j₁ ∈ p ↔ j₂ ∈ p)) (j : limits.wide_pushout_shape J) =>
      option.cases_on j hp
        fun (j : J) =>
          eq.mpr (id (Eq._oldrec (Eq.refl (some j ∈ p)) (Eq.symm (propext (t (limits.wide_pushout_shape.hom.init j))))))
            hp

protected instance parallel_pair_inhabited : Inhabited limits.walking_parallel_pair :=
  { default := limits.walking_parallel_pair.one }

protected instance parallel_pair_connected : is_connected limits.walking_parallel_pair :=
  is_connected.of_induct
    fun (p : set limits.walking_parallel_pair) (ᾰ : limits.walking_parallel_pair.one ∈ p)
      (t : ∀ {j₁ j₂ : limits.walking_parallel_pair}, (j₁ ⟶ j₂) → (j₁ ∈ p ↔ j₂ ∈ p)) (j : limits.walking_parallel_pair) =>
      limits.walking_parallel_pair.cases_on j
        (eq.mpr
          (id
            (Eq._oldrec (Eq.refl (limits.walking_parallel_pair.zero ∈ p))
              (propext (t limits.walking_parallel_pair_hom.left))))
          ᾰ)
        ᾰ

namespace prod_preserves_connected_limits

/-- (Impl). The obvious natural transformation from (X × K -) to K. -/
def γ₂ {C : Type u₂} [category C] [limits.has_binary_products C] {J : Type v₂} [small_category J] {K : J ⥤ C} (X : C) : K ⋙ functor.obj limits.prod.functor X ⟶ K :=
  nat_trans.mk fun (Y : J) => limits.prod.snd

/-- (Impl). The obvious natural transformation from (X × K -) to X -/
@[simp] theorem γ₁_app {C : Type u₂} [category C] [limits.has_binary_products C] {J : Type v₂} [small_category J] {K : J ⥤ C} (X : C) (Y : J) : nat_trans.app (γ₁ X) Y = limits.prod.fst :=
  Eq.refl (nat_trans.app (γ₁ X) Y)

/-- (Impl). Given a cone for (X × K -), produce a cone for K using the natural transformation `γ₂` -/
@[simp] theorem forget_cone_π {C : Type u₂} [category C] [limits.has_binary_products C] {J : Type v₂} [small_category J] {X : C} {K : J ⥤ C} (s : limits.cone (K ⋙ functor.obj limits.prod.functor X)) : limits.cone.π (forget_cone s) = limits.cone.π s ≫ γ₂ X :=
  Eq.refl (limits.cone.π (forget_cone s))

end prod_preserves_connected_limits

/--
The functor `(X × -)` preserves any connected limit.
Note that this functor does not preserve the two most obvious disconnected limits - that is,
`(X × -)` does not preserve products or terminal object, eg `(X ⨯ A) ⨯ (X ⨯ B)` is not isomorphic to
`X ⨯ (A ⨯ B)` and `X ⨯ 1` is not isomorphic to `1`.
-/
def prod_preserves_connected_limits {C : Type u₂} [category C] [limits.has_binary_products C] {J : Type v₂} [small_category J] [is_connected J] (X : C) : limits.preserves_limits_of_shape J (functor.obj limits.prod.functor X) :=
  limits.preserves_limits_of_shape.mk
    fun (K : J ⥤ C) =>
      limits.preserves_limit.mk
        fun (c : limits.cone K) (l : limits.is_limit c) =>
          limits.is_limit.mk
            fun (s : limits.cone (K ⋙ functor.obj limits.prod.functor X)) =>
              limits.prod.lift (nat_trans.app (limits.cone.π s) (classical.arbitrary J) ≫ limits.prod.fst)
                (limits.is_limit.lift l sorry)


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

import linear_algebra.direct_sum.finsupp
import logic.small
import linear_algebra.std_basis

/-!

# Free modules

We introduce a class `module.free R M`, for `R` a `semiring` and `M` an `R`-module and we provide
several basic instances for this class.

Use `finsupp.total_id_surjective` to prove that any module is the quotient of a free module.

## Main definition

* `module.free R M` : the class of free `R`-modules.

-/

universes u v w z

variables (R : Type u) (M : Type v) (N : Type z)

open_locale tensor_product direct_sum big_operators

section basic

variables [semiring R] [add_comm_monoid M] [module R M]

/-- `module.free R M` is the statement that the `R`-module `M` is free.-/
class module.free : Prop :=
(exists_basis [] : nonempty (Σ (I : Type v), basis I R M))

/- If `M` fits in universe `w`, then freeness is equivalent to existence of a basis in that
universe.

Note that if `M` does not fit in `w`, the reverse direction of this implication is still true as
`module.free.of_basis`. -/
lemma module.free_def [small.{w} M] : module.free R M ↔ ∃ (I : Type w), nonempty (basis I R M) :=
⟨ λ h, ⟨shrink (set.range h.exists_basis.some.2),
    ⟨(basis.reindex_range h.exists_basis.some.2).reindex (equiv_shrink _)⟩⟩,
  λ h, ⟨(nonempty_sigma.2 h).map $ λ ⟨i, b⟩, ⟨set.range b, b.reindex_range⟩⟩⟩

lemma module.free_iff_set : module.free R M ↔ ∃ (S : set M), nonempty (basis S R M) :=
⟨λ h, ⟨set.range h.exists_basis.some.2, ⟨basis.reindex_range h.exists_basis.some.2⟩⟩,
    λ ⟨S, hS⟩, ⟨nonempty_sigma.2 ⟨S, hS⟩⟩⟩

variables {R M}

lemma module.free.of_basis {ι : Type w} (b : basis ι R M) : module.free R M :=
(module.free_def R M).2 ⟨set.range b, ⟨b.reindex_range⟩⟩

end basic

namespace module.free

section semiring

variables (R M) [semiring R] [add_comm_monoid M] [module R M] [module.free R M]
variables [add_comm_monoid N] [module R N]

/-- If `module.free R M` then `choose_basis_index R M` is the `ι` which indexes the basis
  `ι → M`. -/
@[nolint has_inhabited_instance] def choose_basis_index := (exists_basis R M).some.1

/-- If `module.free R M` then `choose_basis : ι → M` is the basis.
Here `ι = choose_basis_index R M`. -/
noncomputable def choose_basis : basis (choose_basis_index R M) R M := (exists_basis R M).some.2

/-- The isomorphism `M ≃ₗ[R] (choose_basis_index R M →₀ R)`. -/
noncomputable def repr : M ≃ₗ[R] (choose_basis_index R M →₀ R) := (choose_basis R M).repr

/-- The universal property of free modules: giving a functon `(choose_basis_index R M) → N`, for `N`
an `R`-module, is the same as giving an `R`-linear map `M →ₗ[R] N`.

This definition is parameterized over an extra `semiring S`,
such that `smul_comm_class R S M'` holds.
If `R` is commutative, you can set `S := R`; if `R` is not commutative,
you can recover an `add_equiv` by setting `S := ℕ`.
See library note [bundled maps over different rings]. -/
noncomputable def constr {S : Type z} [semiring S] [module S N] [smul_comm_class R S N] :
  ((choose_basis_index R M) → N) ≃ₗ[S] M →ₗ[R] N := basis.constr (choose_basis R M) S

@[priority 100]
instance no_zero_smul_divisors [no_zero_divisors R] : no_zero_smul_divisors R M :=
let ⟨⟨_, b⟩⟩ := exists_basis R M in b.no_zero_smul_divisors

/-- The product of finitely many free modules is free. -/
instance pi {ι : Type*} [fintype ι] {M : ι → Type*} [Π (i : ι), add_comm_group (M i)]
  [Π (i : ι), module R (M i)] [Π (i : ι), module.free R (M i)] : module.free R (Π i, M i) :=
of_basis $ pi.basis $ λ i, choose_basis R (M i)

/-- The module of finite matrices is free. -/
instance matrix {m n : Type*} [fintype m] [fintype n] : module.free R (matrix m n R) :=
of_basis $ matrix.std_basis R m n

variables {R M N}

lemma of_equiv (e : M ≃ₗ[R] N) : module.free R N :=
of_basis $ (choose_basis R M).map e

/-- A variation of `of_equiv`: the assumption `module.free R P` here is explicit rather than an
instance. -/
lemma of_equiv' {P : Type v} [add_comm_monoid P] [module R P] (h : module.free R P)
  (e : P ≃ₗ[R] N) : module.free R N :=
of_equiv e

variables (R M N)

instance {ι : Type v} : module.free R (ι →₀ R) :=
of_basis (basis.of_repr (linear_equiv.refl _ _))

instance {ι : Type v} [fintype ι] : module.free R (ι → R) :=
of_equiv (basis.of_repr $ linear_equiv.refl _ _).equiv_fun

instance prod [module.free R N] : module.free R (M × N) :=
of_basis $ (choose_basis R M).prod (choose_basis R N)

instance self : module.free R R := of_basis $ basis.singleton unit R

@[priority 100]
instance of_subsingleton [subsingleton N] : module.free R N :=
of_basis (basis.empty N : basis pempty R N)

@[priority 100]
instance of_subsingleton' [subsingleton R] : module.free R N :=
by letI := module.subsingleton R N; exact module.free.of_subsingleton R N

instance dfinsupp {ι : Type*} (M : ι → Type*) [Π (i : ι), add_comm_monoid (M i)]
  [Π (i : ι), module R (M i)] [Π (i : ι), module.free R (M i)] : module.free R (Π₀ i, M i) :=
of_basis $ dfinsupp.basis $ λ i, choose_basis R (M i)

instance direct_sum {ι : Type*} (M : ι → Type*) [Π (i : ι), add_comm_monoid (M i)]
  [Π (i : ι), module R (M i)] [Π (i : ι), module.free R (M i)] : module.free R (⨁ i, M i) :=
module.free.dfinsupp R M

end semiring

section comm_ring

variables [comm_ring R] [add_comm_group M] [module R M] [module.free R M]
variables [add_comm_group N] [module R N] [module.free R N]

instance tensor : module.free R (M ⊗[R] N) :=
of_equiv' (of_equiv' (finsupp.free R) (finsupp_tensor_finsupp' R _ _).symm)
  (tensor_product.congr (choose_basis R M).repr (choose_basis R N).repr).symm

end comm_ring

section division_ring

variables [division_ring R] [add_comm_group M] [module R M]

@[priority 100]
instance of_division_ring : module.free R M :=
of_basis (basis.of_vector_space R M)

end division_ring

end module.free


import data.vector data.real.basic

def double (n : ℕ) : ℤ := 2 * n

example : ℕ → ℤ := double

example : Π (n : ℕ), ℤ := double

def zero_list (n : ℕ) : list ℝ := list.repeat 0 n

example : zero_list 5 = [0,0,0,0,0] := rfl

def myvec : vector ℝ 5 := ⟨[5,10,15,20,25], rfl⟩

example : list ℝ := zero_list 100000

-- The line below doesn't work as `n` is arbitrary.
--example (n : ℕ) : vector ℝ n := ⟨zero_list n, rfl⟩

def zero_vec (n : ℕ) : vector ℝ n := ⟨zero_list n, list.length_repeat 0 n⟩

example : Π (m : ℕ), vector ℝ m := zero_vec

namespace extras

def myvec' : vector ℕ 5 :=
{ val := [5,10,15,20,25],
  property := rfl }

def two : fin 5 := ⟨2, dec_trivial⟩

-- #reduce vector.nth myvec' 2

def zero_list' : ℕ → list ℝ
| 0       := []
| (n+1)   := 0 :: (zero_list' n)

def zero_list'' : ℕ → list ℝ := λ n, nat.rec_on n [] (λ n t, 0 :: t)

example (n : ℕ) : zero_list n = zero_list'' n :=
begin
  induction n,
  { refl },
  { simpa [zero_list, zero_list''] }
end

example (xs : list ℝ) : ∃ n : ℕ, list.length xs = n :=
begin
  induction xs with x xs h,
  { use 0, simp },
  { cases h with n h,
    use (n+1), simp [h], }
end

lemma length_zero_list' : ∀ n, list.length (zero_list' n) = n
| 0     := rfl
| (n+1) := by { simp only [list.length, zero_list', length_zero_list'] }

universe u

def const_vec (c : ℝ) (n : ℕ) : vector ℝ n := ⟨list.repeat c n, list.length_repeat c n⟩

def const_vec' {α} (c : α) (n : ℕ) : vector α n := ⟨list.repeat c n, list.length_repeat c n⟩

open list

def add_vec : Π {n : ℕ} (v₁ v₂ : vector ℕ n), vector ℕ n
| 0       _              _             := ⟨[],rfl⟩
| (n+1)   ⟨x :: v₁, p₁⟩  ⟨y :: v₂, p₂⟩  :=
(x + y) ::ᵥ (@add_vec n ⟨v₁, nat.succ.inj p₁⟩ ⟨v₂, nat.succ.inj p₂ ⟩)

example : add_vec  ⟨[0,1,2],rfl⟩ ⟨[5,6,7],rfl⟩ = ⟨[5,7,9], rfl⟩ := rfl

lemma nth_add_nth : Π {n : ℕ} (v₁ v₂ : vector ℕ n) (a : fin n), v₁.nth a + v₂.nth a = (add_vec v₁ v₂).nth a
| 0 _ _ ⟨a, p⟩ := absurd p (nat.not_lt_zero a)
| (n+1) ⟨x :: v₁, p₁⟩ ⟨y :: v₂, p₂⟩ ⟨0, h⟩ := by { simp only [vector.nth, add_vec, fin.mk_zero, fin.val_zero', vector.nth_cons_zero, nth_le], }
| (n+1) ⟨x :: v₁, p₁⟩ ⟨y :: v₂, p₂⟩ ⟨a+1,h⟩ :=
begin
  have ha : (⟨a+1,h⟩ : fin (n+1)) = fin.succ (⟨a, nat.succ_lt_succ_iff.mp h⟩), from rfl,
  rw [ha, add_vec, vector.nth_cons_succ, ←@nth_add_nth n],
  have h₁ : (⟨x :: v₁, p₁⟩ : vector ℕ (n+1)) = x ::ᵥ ⟨v₁, nat.succ.inj p₁⟩, { rw vector.cons, refl, },
  have h₂ : (⟨y :: v₂, p₂⟩ : vector ℕ (n+1)) = y ::ᵥ ⟨v₂, nat.succ.inj p₂⟩, { rw vector.cons, refl, },
  rw [h₁, h₂, vector.nth_cons_succ, vector.nth_cons_succ]
end

end extras

namespace generalisation

open list

variables {α : Type*} [has_add α]

def add_vec : Π {n : ℕ} (v₁ v₂ : vector α n), vector α n
| 0       _              _             := ⟨[],rfl⟩
| (n+1)   ⟨x :: v₁, p₁⟩  ⟨y :: v₂, p₂⟩  :=
(x + y) ::ᵥ (@add_vec n ⟨v₁, nat.succ.inj p₁⟩ ⟨v₂, nat.succ.inj p₂ ⟩)

lemma nth_add_nth : Π {n : ℕ} (v₁ v₂ : vector α n) (a : fin n), v₁.nth a + v₂.nth a = (add_vec v₁ v₂).nth a
| 0 _ _ ⟨a, p⟩ := absurd p (nat.not_lt_zero a)
| (n+1) ⟨x :: v₁, p₁⟩ ⟨y :: v₂, p₂⟩ ⟨0, h⟩ := by { simp [vector.nth, add_vec], }
| (n+1) ⟨x :: v₁, p₁⟩ ⟨y :: v₂, p₂⟩ ⟨a+1,h⟩ :=
begin
  have ha : (⟨a+1,h⟩ : fin (n+1)) = fin.succ (⟨a, nat.lt_of_succ_lt_succ h⟩), from rfl,
  rw [ha, add_vec, vector.nth_cons_succ, ←@nth_add_nth n],
  have h₁ : (⟨x :: v₁, p₁⟩ : vector α (n+1)) = x ::ᵥ ⟨v₁, nat.succ.inj p₁⟩, { rw vector.cons, refl, },
  have h₂ : (⟨y :: v₂, p₂⟩ : vector α (n+1)) = y ::ᵥ ⟨v₂, nat.succ.inj p₂⟩, { rw vector.cons, refl, },
  rw [h₁, h₂, vector.nth_cons_succ, vector.nth_cons_succ]
end

end generalisation


/-
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
-/
import algebra.category.Group.basic
import group_theory.free_abelian_group

/-!
# 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 theory

universe u

open category_theory

namespace AddCommGroup

open_locale classical

/--
The free functor `Type u ⥤ AddCommGroup` sending a type `X` to the
free abelian group with generators `x : X`.
-/
def free : Type u ⥤ AddCommGroup :=
{ obj := λ α, of (free_abelian_group α),
  map := λ X Y, free_abelian_group.map,
  map_id' := λ X, add_monoid_hom.ext free_abelian_group.map_id_apply,
  map_comp' := λ X Y Z f g, add_monoid_hom.ext free_abelian_group.map_comp_apply, }

@[simp] lemma free_obj_coe {α : Type u} :
  (free.obj α : Type u) = (free_abelian_group α) := rfl

@[simp] lemma free_map_coe {α β : Type u} {f : α → β} (x : free_abelian_group α) :
  (free.map f) x = f <$> x := rfl

/--
The free-forgetful adjunction for abelian groups.
-/
def adj : free ⊣ forget AddCommGroup.{u} :=
adjunction.mk_of_hom_equiv
{ hom_equiv := λ X G, free_abelian_group.lift.symm,
  hom_equiv_naturality_left_symm' :=
  by { intros, ext, refl} }

instance : is_right_adjoint (forget AddCommGroup.{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 : AddCommGroup.{u}} (f : G ⟶ H) [mono f] : function.injective f :=
(mono_iff_injective f).1 (show mono ((forget AddCommGroup.{u}).map f), by apply_instance)

end AddCommGroup

namespace Group

/-- The free functor `Type u ⥤ Group` sending a type `X` to the free group with generators `x : X`.
-/
def free : Type u ⥤ Group :=
{ obj := λ α, of (free_group α),
  map := λ X Y, free_group.map,
  map_id' := by { intros, ext1, refl },
  map_comp' := by { intros, ext1, refl } }

/-- The free-forgetful adjunction for groups.
-/
def adj : free ⊣ forget Group.{u} :=
adjunction.mk_of_hom_equiv
{ hom_equiv := λ X G, free_group.lift.symm,
  hom_equiv_naturality_left_symm' := λ X Y G f g, by { ext1, refl } }

instance : is_right_adjoint (forget Group.{u}) := ⟨_, adj⟩

end Group

section abelianization

/-- The abelianization functor `Group ⥤ CommGroup` sending a group `G` to its abelianization `Gᵃᵇ`.
 -/
def abelianize : Group.{u} ⥤ CommGroup.{u} :=
{ obj := λ G, { α := abelianization G, str := by apply_instance },
  map := λ G H f, abelianization.lift ( { to_fun := λ x, abelianization.of (f x),
  map_one' := by simp,
  map_mul' := by simp } ),
  map_id' := by { intros, simp only [monoid_hom.mk_coe, coe_id], ext1, refl },
  map_comp' := by { intros, simp only [coe_comp], ext1, refl } }

/-- The abelianization-forgetful adjuction from `Group` to `CommGroup`.-/
def abelianize_adj : abelianize ⊣ forget₂ CommGroup.{u} Group.{u} :=
adjunction.mk_of_hom_equiv
{ hom_equiv := λ G A, abelianization.lift.symm,
  hom_equiv_naturality_left_symm' := λ G H A f g, by { ext1, refl } }

end abelianization

/-- The functor taking a monoid to its subgroup of units. -/
@[simps]
def Mon.units : Mon.{u} ⥤ Group.{u} :=
{ obj := λ R, Group.of Rˣ,
  map := λ R S f, Group.of_hom $ units.map f,
  map_id' := λ X, monoid_hom.ext (λ x, units.ext rfl),
  map_comp' := λ X Y Z f g, monoid_hom.ext (λ x, units.ext rfl) }

/-- The forgetful-units adjunction between `Group` and `Mon`. -/
def Group.forget₂_Mon_adj : forget₂ Group Mon ⊣ Mon.units.{u} :=
{ hom_equiv := λ X Y,
  { to_fun := λ f, monoid_hom.to_hom_units f,
    inv_fun := λ f, (units.coe_hom Y).comp f,
    left_inv := λ f, monoid_hom.ext $ λ _, rfl,
    right_inv := λ f, monoid_hom.ext $ λ _, units.ext rfl },
  unit :=
  { app := λ X, { ..(@to_units X _).to_monoid_hom },
    naturality' := λ X Y f, monoid_hom.ext $ λ x, units.ext rfl },
  counit :=
  { app := λ X, units.coe_hom X,
    naturality' := λ X Y f, monoid_hom.ext $ λ x, rfl },
  hom_equiv_unit' := λ X Y f, monoid_hom.ext $ λ _, units.ext rfl,
  hom_equiv_counit' := λ X Y f, monoid_hom.ext $ λ _, rfl }

instance : is_right_adjoint Mon.units.{u} :=
⟨_, Group.forget₂_Mon_adj⟩

/-- The functor taking a monoid to its subgroup of units. -/
@[simps]
def CommMon.units : CommMon.{u} ⥤ CommGroup.{u} :=
{ obj := λ R, CommGroup.of Rˣ,
  map := λ R S f, CommGroup.of_hom $ units.map f,
  map_id' := λ X, monoid_hom.ext (λ x, units.ext rfl),
  map_comp' := λ X Y Z f g, monoid_hom.ext (λ x, units.ext rfl) }

/-- The forgetful-units adjunction between `CommGroup` and `CommMon`. -/
def CommGroup.forget₂_CommMon_adj : forget₂ CommGroup CommMon ⊣ CommMon.units.{u} :=
{ hom_equiv := λ X Y,
  { to_fun := λ f, monoid_hom.to_hom_units f,
    inv_fun := λ f, (units.coe_hom Y).comp f,
    left_inv := λ f, monoid_hom.ext $ λ _, rfl,
    right_inv := λ f, monoid_hom.ext $ λ _, units.ext rfl },
  unit :=
  { app := λ X, { ..(@to_units X _).to_monoid_hom },
    naturality' := λ X Y f, monoid_hom.ext $ λ x, units.ext rfl },
  counit :=
  { app := λ X, units.coe_hom X,
    naturality' := λ X Y f, monoid_hom.ext $ λ x, rfl },
  hom_equiv_unit' := λ X Y f, monoid_hom.ext $ λ _, units.ext rfl,
  hom_equiv_counit' := λ X Y f, monoid_hom.ext $ λ _, rfl }

instance : is_right_adjoint CommMon.units.{u} :=
⟨_, CommGroup.forget₂_CommMon_adj⟩


/-
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
-/
import order.category.Lattice
import order.hom.complete_lattice
import topology.category.CompHaus
import topology.sets.opens

/-!
# The category of frames

This file defines `Frame`, the category of frames.

## References

* [nLab, *Frm*](https://ncatlab.org/nlab/show/Frm)
-/

universes u

open category_theory opposite order topological_space

/-- The category of frames. -/
def Frame := bundled frame

namespace Frame

instance : has_coe_to_sort Frame Type* := bundled.has_coe_to_sort
instance (X : Frame) : frame X := X.str

/-- Construct a bundled `Frame` from a `frame`. -/
def of (α : Type*) [frame α] : Frame := bundled.of α

@[simp] lemma coe_of (α : Type*) [frame α] : ↥(of α) = α := rfl

instance : inhabited Frame := ⟨of punit⟩

/-- An abbreviation of `frame_hom` that assumes `frame` instead of the weaker `complete_lattice`.
Necessary for the category theory machinery. -/
abbreviation hom (α β : Type*) [frame α] [frame β] : Type* := frame_hom α β

instance bundled_hom : bundled_hom hom :=
⟨λ α β [frame α] [frame β], by exactI (coe_fn : frame_hom α β → α → β),
 λ α [frame α], by exactI frame_hom.id α,
 λ α β γ [frame α] [frame β] [frame γ], by exactI frame_hom.comp,
 λ α β [frame α] [frame β], by exactI fun_like.coe_injective⟩

attribute [derive [large_category, concrete_category]] Frame

instance has_forget_to_Lattice : has_forget₂ Frame Lattice :=
{ forget₂ := { obj := λ X, ⟨X⟩, map := λ X Y, frame_hom.to_lattice_hom } }

/-- Constructs an isomorphism of frames from an order isomorphism between them. -/
@[simps] def iso.mk {α β : Frame.{u}} (e : α ≃o β) : α ≅ β :=
{ hom := e,
  inv := e.symm,
  hom_inv_id' := by { ext, exact e.symm_apply_apply _ },
  inv_hom_id' := by { ext, exact e.apply_symm_apply _ } }

end Frame

/-- The forgetful functor from `Topᵒᵖ` to `Frame`. -/
@[simps] def Top_op_to_Frame : Topᵒᵖ ⥤ Frame :=
{ obj := λ X, Frame.of (opens (unop X : Top)),
  map := λ X Y f, opens.comap $ quiver.hom.unop f,
  map_id' := λ X, opens.comap_id }

-- Note, `CompHaus` is too strong. We only need `t0_space`.
instance CompHaus_op_to_Frame.faithful : faithful (CompHaus_to_Top.op ⋙ Top_op_to_Frame.{u}) :=
⟨λ X Y f g h, quiver.hom.unop_inj $ opens.comap_injective h⟩