/-
Copyright (c) 2020 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin
-/
import algebra.group.basic
import algebra.group_with_zero.defs
import algebra.group.order_synonym

/-!
# Groups with an adjoined zero element

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

This file describes structures that are not usually studied on their own right in mathematics,
namely a special sort of monoid: apart from a distinguished “zero element” they form a group,
or in other words, they are groups with an adjoined zero element.

Examples are:

* division rings;
* the value monoid of a multiplicative valuation;
* in particular, the non-negative real numbers.

## Main definitions

Various lemmas about `group_with_zero` and `comm_group_with_zero`.
To reduce import dependencies, the type-classes themselves are in
`algebra.group_with_zero.defs`.

## Implementation details

As is usual in mathlib, we extend the inverse function to the zero element,
and require `0⁻¹ = 0`.

-/

open_locale classical
open function

variables {α M₀ G₀ M₀' G₀' F F' : Type*}

section

section mul_zero_class

variables [mul_zero_class M₀] {a b : M₀}

lemma left_ne_zero_of_mul : a * b ≠ 0 → a ≠ 0 := mt (λ h, mul_eq_zero_of_left h b)

lemma right_ne_zero_of_mul : a * b ≠ 0 → b ≠ 0 := mt (mul_eq_zero_of_right a)

lemma ne_zero_and_ne_zero_of_mul (h : a * b ≠ 0) : a ≠ 0 ∧ b ≠ 0 :=
⟨left_ne_zero_of_mul h, right_ne_zero_of_mul h⟩

lemma mul_eq_zero_of_ne_zero_imp_eq_zero {a b : M₀} (h : a ≠ 0 → b = 0) :
  a * b = 0 :=
if ha : a = 0 then by rw [ha, zero_mul] else by rw [h ha, mul_zero]

/-- To match `one_mul_eq_id`. -/
lemma zero_mul_eq_const : ((*) (0 : M₀)) = function.const _ 0 := funext zero_mul

/-- To match `mul_one_eq_id`. -/
lemma mul_zero_eq_const : (* (0 : M₀)) = function.const _ 0 := funext mul_zero

end mul_zero_class

section has_mul

variables [has_mul M₀] [has_zero M₀] [no_zero_divisors M₀] {a b : M₀}

lemma eq_zero_of_mul_self_eq_zero (h : a * a = 0) : a = 0 :=
(eq_zero_or_eq_zero_of_mul_eq_zero h).elim id id

@[field_simps] theorem mul_ne_zero (ha : a ≠ 0) (hb : b ≠ 0) : a * b ≠ 0 :=
mt eq_zero_or_eq_zero_of_mul_eq_zero $ not_or_distrib.mpr ⟨ha, hb⟩

end has_mul

namespace ne_zero

instance mul [has_zero M₀] [has_mul M₀] [no_zero_divisors M₀] {x y : M₀}
  [ne_zero x] [ne_zero y] : ne_zero (x * y) :=
⟨mul_ne_zero out out⟩

end ne_zero

end

section

variables [mul_zero_one_class M₀]

/-- In a monoid with zero, if zero equals one, then zero is the only element. -/
lemma eq_zero_of_zero_eq_one (h : (0 : M₀) = 1) (a : M₀) : a = 0 :=
by rw [← mul_one a, ← h, mul_zero]

/-- In a monoid with zero, if zero equals one, then zero is the unique element.

Somewhat arbitrarily, we define the default element to be `0`.
All other elements will be provably equal to it, but not necessarily definitionally equal. -/
def unique_of_zero_eq_one (h : (0 : M₀) = 1) : unique M₀ :=
{ default := 0, uniq := eq_zero_of_zero_eq_one h }

/-- In a monoid with zero, zero equals one if and only if all elements of that semiring
are equal. -/
theorem subsingleton_iff_zero_eq_one : (0 : M₀) = 1 ↔ subsingleton M₀ :=
⟨λ h, @unique.subsingleton _ (unique_of_zero_eq_one h), λ h, @subsingleton.elim _ h _ _⟩

alias subsingleton_iff_zero_eq_one ↔ subsingleton_of_zero_eq_one _

lemma eq_of_zero_eq_one (h : (0 : M₀) = 1) (a b : M₀) : a = b :=
@subsingleton.elim _ (subsingleton_of_zero_eq_one h) a b

/-- In a monoid with zero, either zero and one are nonequal, or zero is the only element. -/
lemma zero_ne_one_or_forall_eq_0 : (0 : M₀) ≠ 1 ∨ (∀a:M₀, a = 0) :=
not_or_of_imp eq_zero_of_zero_eq_one
end

section

variables [mul_zero_one_class M₀] [nontrivial M₀] {a b : M₀}

lemma left_ne_zero_of_mul_eq_one (h : a * b = 1) : a ≠ 0 :=
left_ne_zero_of_mul $ ne_zero_of_eq_one h

lemma right_ne_zero_of_mul_eq_one (h : a * b = 1) : b ≠ 0 :=
right_ne_zero_of_mul $ ne_zero_of_eq_one h

end

section cancel_monoid_with_zero

variables [cancel_monoid_with_zero M₀] {a b c : M₀}

@[priority 10] -- see Note [lower instance priority]
instance cancel_monoid_with_zero.to_no_zero_divisors : no_zero_divisors M₀ :=
⟨λ a b ab0, by { by_cases a = 0, { left, exact h }, right,
  apply cancel_monoid_with_zero.mul_left_cancel_of_ne_zero h, rw [ab0, mul_zero], }⟩

lemma mul_left_inj' (hc : c ≠ 0) : a * c = b * c ↔ a = b := (mul_left_injective₀ hc).eq_iff
lemma mul_right_inj' (ha : a ≠ 0) : a * b = a * c ↔ b = c := (mul_right_injective₀ ha).eq_iff

@[simp] lemma mul_eq_mul_right_iff : a * c = b * c ↔ a = b ∨ c = 0 :=
by by_cases hc : c = 0; [simp [hc], simp [mul_left_inj', hc]]

@[simp] lemma mul_eq_mul_left_iff : a * b = a * c ↔ b = c ∨ a = 0 :=
by by_cases ha : a = 0; [simp [ha], simp [mul_right_inj', ha]]

lemma mul_right_eq_self₀ : a * b = a ↔ b = 1 ∨ a = 0 :=
calc a * b = a ↔ a * b = a * 1 : by rw mul_one
     ...       ↔ b = 1 ∨ a = 0 : mul_eq_mul_left_iff

lemma mul_left_eq_self₀ : a * b = b ↔ a = 1 ∨ b = 0 :=
calc a * b = b ↔ a * b = 1 * b : by rw one_mul
     ...       ↔ a = 1 ∨ b = 0 : mul_eq_mul_right_iff

/-- An element of a `cancel_monoid_with_zero` fixed by right multiplication by an element other
than one must be zero. -/
theorem eq_zero_of_mul_eq_self_right (h₁ : b ≠ 1) (h₂ : a * b = a) : a = 0 :=
classical.by_contradiction $ λ ha, h₁ $ mul_left_cancel₀ ha $ h₂.symm ▸ (mul_one a).symm

/-- An element of a `cancel_monoid_with_zero` fixed by left multiplication by an element other
than one must be zero. -/
theorem eq_zero_of_mul_eq_self_left (h₁ : b ≠ 1) (h₂ : b * a = a) : a = 0 :=
classical.by_contradiction $ λ ha, h₁ $ mul_right_cancel₀ ha $ h₂.symm ▸ (one_mul a).symm

end cancel_monoid_with_zero

section group_with_zero
variables [group_with_zero G₀] {a b c g h x : G₀}

@[simp] lemma mul_inv_cancel_right₀ (h : b ≠ 0) (a : G₀) :
  (a * b) * b⁻¹ = a :=
calc (a * b) * b⁻¹ = a * (b * b⁻¹) : mul_assoc _ _ _
               ... = a             : by simp [h]

@[simp] lemma mul_inv_cancel_left₀ (h : a ≠ 0) (b : G₀) :
  a * (a⁻¹ * b) = b :=
calc a * (a⁻¹ * b) = (a * a⁻¹) * b : (mul_assoc _ _ _).symm
               ... = b             : by simp [h]

lemma inv_ne_zero (h : a ≠ 0) : a⁻¹ ≠ 0 :=
assume a_eq_0, by simpa [a_eq_0] using mul_inv_cancel h

@[simp] lemma inv_mul_cancel (h : a ≠ 0) : a⁻¹ * a = 1 :=
calc a⁻¹ * a = (a⁻¹ * a) * a⁻¹ * a⁻¹⁻¹ : by simp [inv_ne_zero h]
         ... = a⁻¹ * a⁻¹⁻¹             : by simp [h]
         ... = 1                       : by simp [inv_ne_zero h]

lemma group_with_zero.mul_left_injective (h : x ≠ 0) :
  function.injective (λ y, x * y) :=
λ y y' w, by simpa only [←mul_assoc, inv_mul_cancel h, one_mul] using congr_arg (λ y, x⁻¹ * y) w

lemma group_with_zero.mul_right_injective (h : x ≠ 0) :
  function.injective (λ y, y * x) :=
λ y y' w, by simpa only [mul_assoc, mul_inv_cancel h, mul_one] using congr_arg (λ y, y * x⁻¹) w

@[simp] lemma inv_mul_cancel_right₀ (h : b ≠ 0) (a : G₀) :
  (a * b⁻¹) * b = a :=
calc (a * b⁻¹) * b = a * (b⁻¹ * b) : mul_assoc _ _ _
               ... = a             : by simp [h]

@[simp] lemma inv_mul_cancel_left₀ (h : a ≠ 0) (b : G₀) :
  a⁻¹ * (a * b) = b :=
calc a⁻¹ * (a * b) = (a⁻¹ * a) * b : (mul_assoc _ _ _).symm
               ... = b             : by simp [h]

private lemma inv_eq_of_mul (h : a * b = 1) : a⁻¹ = b :=
by rw [← inv_mul_cancel_left₀ (left_ne_zero_of_mul_eq_one h) b, h, mul_one]

@[priority 100] -- See note [lower instance priority]
instance group_with_zero.to_division_monoid : division_monoid G₀ :=
{ inv := has_inv.inv,
  inv_inv := λ a, begin
    by_cases h : a = 0,
    { simp [h] },
    { exact left_inv_eq_right_inv (inv_mul_cancel $ inv_ne_zero h) (inv_mul_cancel h) }
  end,
  mul_inv_rev := λ a b, begin
    by_cases ha : a = 0, { simp [ha] },
    by_cases hb : b = 0, { simp [hb] },
    refine inv_eq_of_mul _,
    simp [mul_assoc, ha, hb]
  end,
  inv_eq_of_mul := λ a b, inv_eq_of_mul,
  ..‹group_with_zero G₀› }

end group_with_zero

section group_with_zero
variables [group_with_zero G₀] {a b c : G₀}

@[simp] lemma zero_div (a : G₀) : 0 / a = 0 :=
by rw [div_eq_mul_inv, zero_mul]

@[simp] lemma div_zero (a : G₀) : a / 0 = 0 :=
by rw [div_eq_mul_inv, inv_zero, mul_zero]

/-- Multiplying `a` by itself and then by its inverse results in `a`
(whether or not `a` is zero). -/
@[simp] lemma mul_self_mul_inv (a : G₀) : a * a * a⁻¹ = a :=
begin
  by_cases h : a = 0,
  { rw [h, inv_zero, mul_zero] },
  { rw [mul_assoc, mul_inv_cancel h, mul_one] }
end

/-- Multiplying `a` by its inverse and then by itself results in `a`
(whether or not `a` is zero). -/
@[simp] lemma mul_inv_mul_self (a : G₀) : a * a⁻¹ * a = a :=
begin
  by_cases h : a = 0,
  { rw [h, inv_zero, mul_zero] },
  { rw [mul_inv_cancel h, one_mul] }
end

/-- Multiplying `a⁻¹` by `a` twice results in `a` (whether or not `a`
is zero). -/
@[simp] lemma inv_mul_mul_self (a : G₀) : a⁻¹ * a * a = a :=
begin
  by_cases h : a = 0,
  { rw [h, inv_zero, mul_zero] },
  { rw [inv_mul_cancel h, one_mul] }
end

/-- Multiplying `a` by itself and then dividing by itself results in `a`, whether or not `a` is
zero. -/
@[simp] lemma mul_self_div_self (a : G₀) : a * a / a = a :=
by rw [div_eq_mul_inv, mul_self_mul_inv a]

/-- Dividing `a` by itself and then multiplying by itself results in `a`, whether or not `a` is
zero. -/
@[simp] lemma div_self_mul_self (a : G₀) : a / a * a = a :=
by rw [div_eq_mul_inv, mul_inv_mul_self a]

local attribute [simp] div_eq_mul_inv mul_comm mul_assoc mul_left_comm

@[simp] lemma div_self_mul_self' (a : G₀) : a / (a * a) = a⁻¹ :=
calc a / (a * a) = a⁻¹⁻¹ * a⁻¹ * a⁻¹ : by simp [mul_inv_rev]
... = a⁻¹ : inv_mul_mul_self _

lemma one_div_ne_zero {a : G₀} (h : a ≠ 0) : 1 / a ≠ 0 :=
by simpa only [one_div] using inv_ne_zero h

@[simp] lemma inv_eq_zero {a : G₀} : a⁻¹ = 0 ↔ a = 0 :=
by rw [inv_eq_iff_eq_inv, inv_zero]

@[simp] lemma zero_eq_inv {a : G₀} : 0 = a⁻¹ ↔ 0 = a :=
eq_comm.trans $ inv_eq_zero.trans eq_comm

/-- Dividing `a` by the result of dividing `a` by itself results in
`a` (whether or not `a` is zero). -/
@[simp] lemma div_div_self (a : G₀) : a / (a / a) = a :=
begin
  rw div_div_eq_mul_div,
  exact mul_self_div_self a
end

lemma ne_zero_of_one_div_ne_zero {a : G₀} (h : 1 / a ≠ 0) : a ≠ 0 :=
assume ha : a = 0, begin rw [ha, div_zero] at h, contradiction end

lemma eq_zero_of_one_div_eq_zero {a : G₀} (h : 1 / a = 0) : a = 0 :=
classical.by_cases
  (assume ha, ha)
  (assume ha, ((one_div_ne_zero ha) h).elim)

lemma mul_left_surjective₀ {a : G₀} (h : a ≠ 0) : surjective (λ g, a * g) :=
λ g, ⟨a⁻¹ * g, by simp [← mul_assoc, mul_inv_cancel h]⟩

lemma mul_right_surjective₀ {a : G₀} (h : a ≠ 0) : surjective (λ g, g * a) :=
λ g, ⟨g * a⁻¹, by simp [mul_assoc, inv_mul_cancel h]⟩

end group_with_zero

section comm_group_with_zero
variables [comm_group_with_zero G₀] {a b c d : G₀}

lemma div_mul_eq_mul_div₀ (a b c : G₀) : (a / c) * b = a * b / c :=
by simp_rw [div_eq_mul_inv, mul_assoc, mul_comm c⁻¹]

end comm_group_with_zero

/-! ### Order dual -/

open order_dual

instance [h : mul_zero_class α] : mul_zero_class αᵒᵈ := h
instance [h : mul_zero_one_class α] : mul_zero_one_class αᵒᵈ := h
instance [has_mul α] [has_zero α] [h : no_zero_divisors α] : no_zero_divisors αᵒᵈ := h
instance [h : semigroup_with_zero α] : semigroup_with_zero αᵒᵈ := h
instance [h : monoid_with_zero α] : monoid_with_zero αᵒᵈ := h
instance [h : cancel_monoid_with_zero α] : cancel_monoid_with_zero αᵒᵈ := h
instance [h : comm_monoid_with_zero α] : comm_monoid_with_zero αᵒᵈ := h
instance [h : cancel_comm_monoid_with_zero α] : cancel_comm_monoid_with_zero αᵒᵈ := h
instance [h : group_with_zero α] : group_with_zero αᵒᵈ := h
instance [h : comm_group_with_zero α] : comm_group_with_zero αᵒᵈ := h

/-! ### Lexicographic order -/

instance [h : mul_zero_class α] : mul_zero_class (lex α) := h
instance [h : mul_zero_one_class α] : mul_zero_one_class (lex α) := h
instance [has_mul α] [has_zero α] [h : no_zero_divisors α] : no_zero_divisors (lex α) := h
instance [h : semigroup_with_zero α] : semigroup_with_zero (lex α) := h
instance [h : monoid_with_zero α] : monoid_with_zero (lex α) := h
instance [h : cancel_monoid_with_zero α] : cancel_monoid_with_zero (lex α) := h
instance [h : comm_monoid_with_zero α] : comm_monoid_with_zero (lex α) := h
instance [h : cancel_comm_monoid_with_zero α] : cancel_comm_monoid_with_zero (lex α) := h
instance [h : group_with_zero α] : group_with_zero (lex α) := h
instance [h : comm_group_with_zero α] : comm_group_with_zero (lex α) := h


/-
Copyright (c) 2014 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura, Jeremy Avigad

! This file was ported from Lean 3 source module init.data.subtype.basic
! leanprover-community/lean commit 855e5b74e3a52a40552e8f067169d747d48743fd
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Init.Logic

/-! # Subtypes

These are ported from the Lean 3 standard library file `init/data/subtype/basic.lean`.
-/

open Decidable

universe u

namespace Subtype

theorem exists_of_subtype {α : Type u} {p : α → Prop} : { x // p x } → ∃ x, p x
  | ⟨a, h⟩ => ⟨a, h⟩
#align subtype.exists_of_subtype Subtype.exists_of_subtype

variable {α : Type u} {p : α → Prop}

theorem tag_irrelevant {a : α} (h1 h2 : p a) : mk a h1 = mk a h2 :=
  rfl
#align subtype.tag_irrelevant Subtype.tag_irrelevant

#align subtype.eq Subtype.eq

theorem ne_of_val_ne {a1 a2 : { x // p x }} : val a1 ≠ val a2 → a1 ≠ a2 :=
  mt <| congr_arg _
#align subtype.ne_of_val_ne Subtype.ne_of_val_ne

#align subtype.eta Subtype.eta

end Subtype

open Subtype

/-- If there is some element satisfying the predicate, then the subtype is inhabited. -/
def Subtype.inhabited {α : Type u} {p : α → Prop} {a : α} (h : p a) : Inhabited { x // p x } :=
  ⟨⟨a, h⟩⟩
#align subtype.inhabited Subtype.inhabited


inductive FiniteType where
| zero : FiniteType
| application : FiniteType → FiniteType → FiniteType
deriving Repr, DecidableEq, Inhabited

notation "𝕆" => FiniteType.zero
infixr:60 " ↣ " => FiniteType.application

def FiniteType.deg : FiniteType → Nat
  | FiniteType.zero => 0
  | FiniteType.application ρ τ => Nat.max (deg τ) ((deg ρ) + 1)

#eval FiniteType.deg (FiniteType.zero ↣ FiniteType.zero ↣ FiniteType.zero ↣ FiniteType.zero)

inductive PureFiniteType where
| zero : PureFiniteType
| application : PureFiniteType → PureFiniteType
deriving Repr

def transform : PureFiniteType → FiniteType
 | PureFiniteType.zero => FiniteType.zero
 | PureFiniteType.application ρ => (transform ρ) ↣ FiniteType.zero

#eval transform (PureFiniteType.application (PureFiniteType.application PureFiniteType.zero))

def getPFT (n : Nat) : PureFiniteType :=
  match n with
    | Nat.zero => PureFiniteType.zero
    | Nat.succ n => PureFiniteType.application (getPFT n)

#eval getPFT 2

instance : Coe PureFiniteType FiniteType := ⟨transform⟩

instance : OfNat FiniteType n := ⟨getPFT n⟩

example (n : Nat) : FiniteType.deg (transform (getPFT n)) = n :=
  Nat.recOn (motive := fun x => FiniteType.deg (transform (getPFT x)) = x) n
    rfl
    (fun n ih => show FiniteType.deg (transform (getPFT (Nat.succ n))) = (Nat.succ n) from
    calc FiniteType.deg (transform (getPFT (Nat.succ n))) = Nat.succ (FiniteType.deg (transform (getPFT (n)))) := rfl
          _ = Nat.succ n := by rw [ih]
    )

namespace FiniteType

@[simp] def isArrow : FiniteType → Bool
| _ ↣ _ => true
| _ => false

@[simp] def getArrowSource? : FiniteType → Option FiniteType
| ρ ↣ τ => ρ
| _ => none

@[simp] def getArrowTarget? : FiniteType → Option FiniteType
| ρ ↣ τ => τ
| _ => none

@[simp] def contains : FiniteType → FiniteType → Bool
| ρ ↣ τ, σ => if ρ = σ || τ = σ then true else contains ρ σ || contains τ σ
| 𝕆, 𝕆 => true
| _, _ => false

end FiniteType


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

import algebra.algebra.equiv
import linear_algebra.span

/-!
# Towers of algebras

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

In this file we prove basic facts about towers of algebra.

An algebra tower A/S/R is expressed by having instances of `algebra A S`,
`algebra R S`, `algebra R A` and `is_scalar_tower R S A`, the later asserting the
compatibility condition `(r • s) • a = r • (s • a)`.

An important definition is `to_alg_hom R S A`, the canonical `R`-algebra homomorphism `S →ₐ[R] A`.

-/

open_locale pointwise
universes u v w u₁ v₁

variables (R : Type u) (S : Type v) (A : Type w) (B : Type u₁) (M : Type v₁)

namespace algebra

variables [comm_semiring R] [semiring A] [algebra R A]
variables [add_comm_monoid M] [module R M] [module A M] [is_scalar_tower R A M]

variables {A}

/-- The `R`-algebra morphism `A → End (M)` corresponding to the representation of the algebra `A`
on the `R`-module `M`.

This is a stronger version of `distrib_mul_action.to_linear_map`, and could also have been
called `algebra.to_module_End`. -/
def lsmul : A →ₐ[R] module.End R M :=
{ to_fun := distrib_mul_action.to_linear_map R M,
  map_one' := linear_map.ext $ λ _, one_smul A _,
  map_mul' := λ a b, linear_map.ext $ smul_assoc a b,
  map_zero' := linear_map.ext $ λ _, zero_smul A _,
  map_add' := λ a b, linear_map.ext $ λ _, add_smul _ _ _,
  commutes' := λ r, linear_map.ext $ algebra_map_smul A r, }

@[simp] lemma lsmul_coe (a : A) : (lsmul R M a : M → M) = (•) a := rfl

end algebra

namespace is_scalar_tower

section module

variables [comm_semiring R] [semiring A] [algebra R A]
variables [has_smul R M] [mul_action A M] [is_scalar_tower R A M]

variables {R} (A) {M}
theorem algebra_map_smul (r : R) (x : M) : algebra_map R A r • x = r • x :=
by rw [algebra.algebra_map_eq_smul_one, smul_assoc, one_smul]

end module

section semiring
variables [comm_semiring R] [comm_semiring S] [semiring A] [semiring B]
variables [algebra R S] [algebra S A] [algebra S B]

variables {R S A}
theorem of_algebra_map_eq [algebra R A]
  (h : ∀ x, algebra_map R A x = algebra_map S A (algebra_map R S x)) :
  is_scalar_tower R S A :=
⟨λ x y z, by simp_rw [algebra.smul_def, ring_hom.map_mul, mul_assoc, h]⟩

/-- See note [partially-applied ext lemmas]. -/
theorem of_algebra_map_eq' [algebra R A]
  (h : algebra_map R A = (algebra_map S A).comp (algebra_map R S)) :
  is_scalar_tower R S A :=
of_algebra_map_eq $ ring_hom.ext_iff.1 h

variables (R S A)

variables [algebra R A] [algebra R B]
variables [is_scalar_tower R S A] [is_scalar_tower R S B]

theorem algebra_map_eq :
  algebra_map R A = (algebra_map S A).comp (algebra_map R S) :=
ring_hom.ext $ λ x, by simp_rw [ring_hom.comp_apply, algebra.algebra_map_eq_smul_one,
    smul_assoc, one_smul]

theorem algebra_map_apply (x : R) : algebra_map R A x = algebra_map S A (algebra_map R S x) :=
by rw [algebra_map_eq R S A, ring_hom.comp_apply]

@[ext] lemma algebra.ext {S : Type u} {A : Type v} [comm_semiring S] [semiring A]
  (h1 h2 : algebra S A) (h : ∀ (r : S) (x : A), (by haveI := h1; exact r • x) = r • x) : h1 = h2 :=
algebra.algebra_ext _ _ $ λ r, by
  simpa only [@algebra.smul_def _ _ _ _ h1, @algebra.smul_def _ _ _ _ h2, mul_one] using h r 1

/-- In a tower, the canonical map from the middle element to the top element is an
algebra homomorphism over the bottom element. -/
def to_alg_hom : S →ₐ[R] A :=
{ commutes' := λ _, (algebra_map_apply _ _ _ _).symm,
  .. algebra_map S A }

lemma to_alg_hom_apply (y : S) : to_alg_hom R S A y = algebra_map S A y := rfl

@[simp] lemma coe_to_alg_hom : ↑(to_alg_hom R S A) = algebra_map S A :=
ring_hom.ext $ λ _, rfl

@[simp] lemma coe_to_alg_hom' : (to_alg_hom R S A : S → A) = algebra_map S A :=
rfl

variables {R S A B}

@[simp, priority 900] lemma _root_.alg_hom.map_algebra_map (f : A →ₐ[S] B) (r : R) :
  f (algebra_map R A r) = algebra_map R B r :=
by rw [algebra_map_apply R S A r, f.commutes, ← algebra_map_apply R S B]

variables (R)

@[simp, priority 900] lemma _root_.alg_hom.comp_algebra_map_of_tower (f : A →ₐ[S] B) :
  (f : A →+* B).comp (algebra_map R A) = algebra_map R B :=
ring_hom.ext f.map_algebra_map

variables (R) {S A B}

-- conflicts with is_scalar_tower.subalgebra
@[priority 999] instance subsemiring (U : subsemiring S) : is_scalar_tower U S A :=
of_algebra_map_eq $ λ x, rfl

@[nolint instance_priority]
instance of_ring_hom {R A B : Type*} [comm_semiring R] [comm_semiring A] [comm_semiring B]
  [algebra R A] [algebra R B] (f : A →ₐ[R] B) :
  @is_scalar_tower R A B _ (f.to_ring_hom.to_algebra.to_has_smul) _ :=
by { letI := (f : A →+* B).to_algebra, exact of_algebra_map_eq (λ x, (f.commutes x).symm) }

end semiring

end is_scalar_tower

section homs

variables [comm_semiring R] [comm_semiring S] [semiring A] [semiring B]
variables [algebra R S] [algebra S A] [algebra S B]
variables [algebra R A] [algebra R B]
variables [is_scalar_tower R S A] [is_scalar_tower R S B]

variables (R) {A S B}

open is_scalar_tower

namespace alg_hom

/-- R ⟶ S induces S-Alg ⥤ R-Alg -/
def restrict_scalars (f : A →ₐ[S] B) : A →ₐ[R] B :=
{ commutes' := λ r, by { rw [algebra_map_apply R S A, algebra_map_apply R S B],
    exact f.commutes (algebra_map R S r) },
  .. (f : A →+* B) }

lemma restrict_scalars_apply (f : A →ₐ[S] B) (x : A) : f.restrict_scalars R x = f x := rfl

@[simp] lemma coe_restrict_scalars (f : A →ₐ[S] B) : (f.restrict_scalars R : A →+* B) = f := rfl

@[simp] lemma coe_restrict_scalars' (f : A →ₐ[S] B) : (restrict_scalars R f : A → B) = f := rfl

lemma restrict_scalars_injective :
  function.injective (restrict_scalars R : (A →ₐ[S] B) → (A →ₐ[R] B)) :=
λ f g h, alg_hom.ext (alg_hom.congr_fun h : _)

end alg_hom

namespace alg_equiv

/-- R ⟶ S induces S-Alg ⥤ R-Alg -/
def restrict_scalars (f : A ≃ₐ[S] B) : A ≃ₐ[R] B :=
{ commutes' := λ r, by { rw [algebra_map_apply R S A, algebra_map_apply R S B],
    exact f.commutes (algebra_map R S r) },
  .. (f : A ≃+* B) }

lemma restrict_scalars_apply (f : A ≃ₐ[S] B) (x : A) : f.restrict_scalars R x = f x := rfl

@[simp] lemma coe_restrict_scalars (f : A ≃ₐ[S] B) : (f.restrict_scalars R : A ≃+* B) = f := rfl

@[simp] lemma coe_restrict_scalars' (f : A ≃ₐ[S] B) : (restrict_scalars R f : A → B) = f := rfl

lemma restrict_scalars_injective :
  function.injective (restrict_scalars R : (A ≃ₐ[S] B) → (A ≃ₐ[R] B)) :=
λ f g h, alg_equiv.ext (alg_equiv.congr_fun h : _)

end alg_equiv

end homs

namespace submodule

variables (R A) {M}
variables [comm_semiring R] [semiring A] [algebra R A] [add_comm_monoid M]
variables [module R M] [module A M] [is_scalar_tower R A M]

/-- If `A` is an `R`-algebra such that the induced morphism `R →+* A` is surjective, then the
`R`-module generated by a set `X` equals the `A`-module generated by `X`. -/
lemma restrict_scalars_span (hsur : function.surjective (algebra_map R A)) (X : set M) :
  restrict_scalars R (span A X) = span R X :=
begin
  refine ((span_le_restrict_scalars R A X).antisymm (λ m hm, _)).symm,
  refine span_induction hm subset_span (zero_mem _) (λ _ _, add_mem) (λ a m hm, _),
  obtain ⟨r, rfl⟩ := hsur a,
  simpa [algebra_map_smul] using smul_mem _ r hm
end

lemma coe_span_eq_span_of_surjective
  (h : function.surjective (algebra_map R A)) (s : set M) :
  (submodule.span A s : set M) = submodule.span R s :=
congr_arg coe (submodule.restrict_scalars_span R A h s)

end submodule

section semiring

variables {R S A}

namespace submodule

section module

variables [semiring R] [semiring S] [add_comm_monoid A]
variables [module R S] [module S A] [module R A] [is_scalar_tower R S A]

open is_scalar_tower

theorem smul_mem_span_smul_of_mem {s : set S} {t : set A} {k : S} (hks : k ∈ span R s)
  {x : A} (hx : x ∈ t) : k • x ∈ span R (s • t) :=
span_induction hks (λ c hc, subset_span $ set.mem_smul.2 ⟨c, x, hc, hx, rfl⟩)
  (by { rw zero_smul, exact zero_mem _ })
  (λ c₁ c₂ ih₁ ih₂, by { rw add_smul, exact add_mem ih₁ ih₂ })
  (λ b c hc, by { rw is_scalar_tower.smul_assoc, exact smul_mem _ _ hc })

variables [smul_comm_class R S A]

theorem smul_mem_span_smul {s : set S} (hs : span R s = ⊤) {t : set A} {k : S}
  {x : A} (hx : x ∈ span R t) :
  k • x ∈ span R (s • t) :=
span_induction hx (λ x hx, smul_mem_span_smul_of_mem (hs.symm ▸ mem_top) hx)
  (by { rw smul_zero, exact zero_mem _ })
  (λ x y ihx ihy, by { rw smul_add, exact add_mem ihx ihy })
  (λ c x hx, smul_comm c k x ▸ smul_mem _ _ hx)

theorem span_smul_of_span_eq_top {s : set S} (hs : span R s = ⊤) (t : set A) :
  span R (s • t) = (span S t).restrict_scalars R :=
le_antisymm (span_le.2 $ λ x hx, let ⟨p, q, hps, hqt, hpqx⟩ := set.mem_smul.1 hx in
  hpqx ▸ (span S t).smul_mem p (subset_span hqt)) $
λ p hp, span_induction hp (λ x hx, one_smul S x ▸ smul_mem_span_smul hs (subset_span hx))
  (zero_mem _)
  (λ _ _, add_mem)
  (λ k x hx, smul_mem_span_smul' hs hx)

end module

section algebra

variables [comm_semiring R] [semiring S] [add_comm_monoid A]
variables [algebra R S] [module S A] [module R A] [is_scalar_tower R S A]

/-- A variant of `submodule.span_image` for `algebra_map`. -/
lemma span_algebra_map_image (a : set R) :
  submodule.span R (algebra_map R S '' a) =
    (submodule.span R a).map (algebra.linear_map R S) :=
(submodule.span_image $ algebra.linear_map R S).trans rfl

lemma span_algebra_map_image_of_tower {S T : Type*} [comm_semiring S] [semiring T]
  [module R S] [is_scalar_tower R S S] [algebra R T] [algebra S T] [is_scalar_tower R S T]
  (a : set S) :
  submodule.span R (algebra_map S T '' a) =
    (submodule.span R a).map ((algebra.linear_map S T).restrict_scalars R) :=
(submodule.span_image $ (algebra.linear_map S T).restrict_scalars R).trans rfl

lemma map_mem_span_algebra_map_image {S T : Type*} [comm_semiring S] [semiring T]
  [algebra R S] [algebra R T] [algebra S T] [is_scalar_tower R S T]
  (x : S) (a : set S) (hx : x ∈ submodule.span R a) :
  algebra_map S T x ∈ submodule.span R (algebra_map S T '' a) :=
by { rw [span_algebra_map_image_of_tower, mem_map], exact ⟨x, hx, rfl⟩ }

end algebra

end submodule

end semiring

section ring

namespace algebra

variables [comm_semiring R] [semiring A] [algebra R A]
variables [add_comm_group M] [module A M] [module R M] [is_scalar_tower R A M]

lemma lsmul_injective [no_zero_smul_divisors A M] {x : A} (hx : x ≠ 0) :
  function.injective (lsmul R M x) :=
smul_right_injective _ hx

end algebra

end ring


import ring_theory.localization
import to_mathlib.localization.localization_alt
import to_mathlib.localization.localization_of
import spectrum_of_a_ring.properties
import sheaves.presheaf_of_rings_on_basis
import sheaves.sheaf_of_rings_on_standard_basis
import sheaves.locally_ringed_space
import spectrum_of_a_ring.spec
import spectrum_of_a_ring.zariski_topology
import spectrum_of_a_ring.standard_basis

universe u

local attribute [instance] classical.prop_decidable

variables {R : Type u} [comm_ring R]

open topological_space
open classical
open localization
open localization_alt

-- Define S(U) so that R[1/f] ≃ R[1/S(D(f))].

open Spec

def S (U : opens (Spec R)) : set R := { r : R | U.1 ⊆ D'(r) }

instance S.is_submonoid (U : opens (Spec R)) : is_submonoid (S U) :=
{ one_mem := λ ⟨P, PI⟩ HP, ((ideal.ne_top_iff_one P).1 PI.1),
  mul_mem := λ f g Hf Hg,
    begin
      show U.1 ⊆ Spec.D'(f*g),
      exact (Spec.D'.product_eq_inter f g).symm ▸ set.subset_inter Hf Hg,
    end, }

lemma S.rev_mono {U V : opens (Spec R)} (HVU : V ⊆ U) : S U ⊆ S V :=
λ x Hx, set.subset.trans HVU Hx

lemma S.f_mem (f : R) : f ∈ S (Spec.DO R (f)) := set.subset.refl _

lemma S.inter_subset_Sinter (U V : opens (Spec R)) : (S U) ∩ (S V) ⊆ S (U ∩ V) :=
begin
  rintros x ⟨HxU, HxV⟩,
  change U ⊆ Spec.DO R (x) at HxU,
  change V ⊆ Spec.DO R (x) at HxV,
  have H := set.inter_subset_inter HxU HxV,
  rw set.inter_self at H,
  exact H,
end

-- Structure presheaf on Spec(R) defined on the basis by the rule ℱ(U) = R[1/S(U)].

variable (R)

def structure_presheaf_on_basis : presheaf_of_rings_on_basis (Spec R) (D_fs_basis R) :=
{ F := λ U BU, localization R (S U),
  res := λ U V BU BV HVU,
    begin
      have H := S.rev_mono HVU,
      apply quotient.lift (λ (x : R × (S U)), ⟦(x.1, (⟨x.2.1, H x.2.2⟩ : S V))⟧),
      { rintros ⟨a1, b1, Hb1⟩ ⟨a2, b2, Hb2⟩ ⟨t, Ht, Habt⟩; simp,
        use [t, H Ht, Habt], },
    end,
  Hid := λ U BU, funext $ λ x, quotient.induction_on x $ λ a, by simp,
  Hcomp := λ U V W BU BV BW HWV HVU, funext $ λ x, quotient.induction_on x $ λ a, by simp,
  Fring := λ U BU, by apply_instance,
  res_is_ring_hom := λ U V BU BV HVU,
      { map_one := rfl,
        map_add := λ x y, quotient.induction_on₂ x y $ λ ⟨r₁, s₁, hs₁⟩ ⟨r₂, s₂, hs₂⟩, rfl,
        map_mul := λ x y, quotient.induction_on₂ x y $ λ ⟨r₁, s₁, hs₁⟩ ⟨r₂, s₂, hs₂⟩, rfl, }, }


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

import group_theory.complement
import group_theory.sylow

/-!
# The Transfer Homomorphism

In this file we construct the transfer homomorphism.

## Main definitions

- `diff ϕ S T` : The difference of two left transversals `S` and `T` under the homomorphism `ϕ`.
- `transfer ϕ` : The transfer homomorphism induced by `ϕ`.
- `transfer_center_pow`: The transfer homomorphism `G →* center G`.

## Main results
- `transfer_center_pow_apply`:
  The transfer homomorphism `G →* center G` is given by `g ↦ g ^ (center G).index`.
- `ker_transfer_sylow_is_complement'`: Burnside's transfer (or normal `p`-complement) theorem:
  If `hP : N(P) ≤ C(P)`, then `(transfer P hP).ker` is a normal `p`-complement.
-/

open_locale big_operators

variables {G : Type*} [group G] {H : subgroup G} {A : Type*} [comm_group A] (ϕ : H →* A)

namespace subgroup

namespace left_transversals

open finset mul_action

open_locale pointwise

variables (R S T : left_transversals (H : set G)) [finite_index H]

/-- The difference of two left transversals -/
@[to_additive "The difference of two left transversals"]
noncomputable def diff : A :=
let α := mem_left_transversals.to_equiv S.2, β := mem_left_transversals.to_equiv T.2 in
(@finset.univ (G ⧸ H) H.fintype_quotient_of_finite_index).prod $
  λ q, ϕ ⟨(α q)⁻¹ * β q, quotient_group.left_rel_apply.mp $
  quotient.exact' ((α.symm_apply_apply q).trans (β.symm_apply_apply q).symm)⟩

@[to_additive] lemma diff_mul_diff : diff ϕ R S * diff ϕ S T = diff ϕ R T :=
prod_mul_distrib.symm.trans (prod_congr rfl (λ q hq, (ϕ.map_mul _ _).symm.trans (congr_arg ϕ
  (by simp_rw [subtype.ext_iff, coe_mul, coe_mk, mul_assoc, mul_inv_cancel_left]))))

@[to_additive] lemma diff_self : diff ϕ T T = 1 :=
mul_right_eq_self.mp (diff_mul_diff ϕ T T T)

@[to_additive] lemma diff_inv : (diff ϕ S T)⁻¹ = diff ϕ T S :=
inv_eq_of_mul_eq_one_right $ (diff_mul_diff ϕ S T S).trans $ diff_self ϕ S

@[to_additive] lemma smul_diff_smul (g : G) : diff ϕ (g • S) (g • T) = diff ϕ S T :=
let h := H.fintype_quotient_of_finite_index in by exactI
prod_bij' (λ q _, g⁻¹ • q) (λ _ _, mem_univ _) (λ _ _, congr_arg ϕ (by simp_rw [coe_mk,
  smul_apply_eq_smul_apply_inv_smul, smul_eq_mul, mul_inv_rev, mul_assoc, inv_mul_cancel_left]))
  (λ q _, g • q) (λ _ _, mem_univ _) (λ q _, smul_inv_smul g q) (λ q _, inv_smul_smul g q)

end left_transversals

end subgroup

namespace monoid_hom

open mul_action subgroup subgroup.left_transversals

/-- Given `ϕ : H →* A` from `H : subgroup G` to a commutative group `A`,
the transfer homomorphism is `transfer ϕ : G →* A`. -/
@[to_additive "Given `ϕ : H →+ A` from `H : add_subgroup G` to an additive commutative group `A`,
the transfer homomorphism is `transfer ϕ : G →+ A`."]
noncomputable def transfer [finite_index H] : G →* A :=
let T : left_transversals (H : set G) := inhabited.default in
{ to_fun := λ g, diff ϕ T (g • T),
  map_one' := by rw [one_smul, diff_self],
  map_mul' := λ g h, by rw [mul_smul, ←diff_mul_diff, smul_diff_smul] }

variables (T : left_transversals (H : set G))

@[to_additive] lemma transfer_def [finite_index H] (g : G) : transfer ϕ g = diff ϕ T (g • T) :=
by rw [transfer, ←diff_mul_diff, ←smul_diff_smul, mul_comm, diff_mul_diff]; refl

/-- Explicit computation of the transfer homomorphism. -/
lemma transfer_eq_prod_quotient_orbit_rel_zpowers_quot [finite_index H]
  (g : G) [fintype (quotient (orbit_rel (zpowers g) (G ⧸ H)))] :
  transfer ϕ g = ∏ (q : quotient (orbit_rel (zpowers g) (G ⧸ H))),
    ϕ ⟨q.out'.out'⁻¹ * g ^ function.minimal_period ((•) g) q.out' * q.out'.out',
      quotient_group.out'_conj_pow_minimal_period_mem H g q.out'⟩ :=
begin
  classical,
  letI := H.fintype_quotient_of_finite_index,
  calc transfer ϕ g = ∏ (q : G ⧸ H), _ : transfer_def ϕ (transfer_transversal H g) g
  ... = _ : ((quotient_equiv_sigma_zmod H g).symm.prod_comp _).symm
  ... = _ : finset.prod_sigma _ _ _
  ... = _ : fintype.prod_congr _ _ (λ q, _),
  simp only [quotient_equiv_sigma_zmod_symm_apply,
    transfer_transversal_apply', transfer_transversal_apply''],
  rw fintype.prod_eq_single (0 : zmod (function.minimal_period ((•) g) q.out')) (λ k hk, _),
  { simp only [if_pos, zmod.cast_zero, zpow_zero, one_mul, mul_assoc] },
  { simp only [if_neg hk, inv_mul_self],
    exact map_one ϕ },
end

/-- Auxillary lemma in order to state `transfer_eq_pow`. -/
lemma transfer_eq_pow_aux (g : G)
  (key : ∀ (k : ℕ) (g₀ : G), g₀⁻¹ * g ^ k * g₀ ∈ H → g₀⁻¹ * g ^ k * g₀ = g ^ k) :
  g ^ H.index ∈ H :=
begin
  by_cases hH : H.index = 0,
  { rw [hH, pow_zero],
    exact H.one_mem },
  letI := fintype_of_index_ne_zero hH,
  classical,
  replace key : ∀ (k : ℕ) (g₀ : G), g₀⁻¹ * g ^ k * g₀ ∈ H → g ^ k ∈ H :=
  λ k g₀ hk, (_root_.congr_arg (∈ H) (key k g₀ hk)).mp hk,
  replace key : ∀ q : G ⧸ H, g ^ function.minimal_period ((•) g) q ∈ H :=
  λ q, key (function.minimal_period ((•) g) q) q.out'
    (quotient_group.out'_conj_pow_minimal_period_mem H g q),
  let f : quotient (orbit_rel (zpowers g) (G ⧸ H)) → zpowers g :=
  λ q, (⟨g, mem_zpowers g⟩ : zpowers g) ^ function.minimal_period ((•) g) q.out',
  have hf : ∀ q, f q ∈ H.subgroup_of (zpowers g) := λ q, key q.out',
  replace key := subgroup.prod_mem (H.subgroup_of (zpowers g)) (λ q (hq : q ∈ finset.univ), hf q),
  simpa only [minimal_period_eq_card, finset.prod_pow_eq_pow_sum, fintype.card_sigma,
    fintype.card_congr (self_equiv_sigma_orbits (zpowers g) (G ⧸ H)), index_eq_card] using key,
end

lemma transfer_eq_pow [finite_index H] (g : G)
  (key : ∀ (k : ℕ) (g₀ : G), g₀⁻¹ * g ^ k * g₀ ∈ H → g₀⁻¹ * g ^ k * g₀ = g ^ k) :
  transfer ϕ g = ϕ ⟨g ^ H.index, transfer_eq_pow_aux g key⟩ :=
begin
  classical,
  letI := H.fintype_quotient_of_finite_index,
  change ∀ k g₀ (hk : g₀⁻¹ * g ^ k * g₀ ∈ H), ↑(⟨g₀⁻¹ * g ^ k * g₀, hk⟩ : H) = g ^ k at key,
  rw [transfer_eq_prod_quotient_orbit_rel_zpowers_quot, ←finset.prod_to_list, list.prod_map_hom],
  refine congr_arg ϕ (subtype.coe_injective _),
  rw [H.coe_mk, ←(zpowers g).coe_mk g (mem_zpowers g), ←(zpowers g).coe_pow, (zpowers g).coe_mk,
      index_eq_card, fintype.card_congr (self_equiv_sigma_orbits (zpowers g) (G ⧸ H)),
      fintype.card_sigma, ←finset.prod_pow_eq_pow_sum, ←finset.prod_to_list],
  simp only [coe_list_prod, list.map_map, ←minimal_period_eq_card],
  congr' 2,
  funext,
  apply key,
end

lemma transfer_center_eq_pow [finite_index (center G)] (g : G) :
  transfer (monoid_hom.id (center G)) g = ⟨g ^ (center G).index, (center G).pow_index_mem g⟩ :=
transfer_eq_pow (id (center G)) g (λ k _ hk, by rw [←mul_right_inj, hk, mul_inv_cancel_right])

variables (G)

/-- The transfer homomorphism `G →* center G`. -/
noncomputable def transfer_center_pow [finite_index (center G)] : G →* center G :=
{ to_fun := λ g, ⟨g ^ (center G).index, (center G).pow_index_mem g⟩,
  map_one' := subtype.ext (one_pow (center G).index),
  map_mul' := λ a b, by simp_rw [←show ∀ g, (_ : center G) = _,
    from transfer_center_eq_pow, map_mul] }

variables {G}

@[simp]

section burnside_transfer

variables {p : ℕ} (P : sylow p G) (hP : (P : subgroup G).normalizer ≤ (P : subgroup G).centralizer)

include hP

/-- The homomorphism `G →* P` in Burnside's transfer theorem. -/
noncomputable def transfer_sylow [finite_index (P : subgroup G)] : G →* (P : subgroup G) :=
@transfer G _ P P (@subgroup.is_commutative.comm_group G _ P
  ⟨⟨λ a b, subtype.ext (hP (le_normalizer b.2) a a.2)⟩⟩) (monoid_hom.id P) _

variables [fact p.prime] [finite (sylow p G)]

/-- Auxillary lemma in order to state `transfer_sylow_eq_pow`. -/
lemma transfer_sylow_eq_pow_aux (g : G) (hg : g ∈ P) (k : ℕ) (g₀ : G) (h : g₀⁻¹ * g ^ k * g₀ ∈ P) :
  g₀⁻¹ * g ^ k * g₀ = g ^ k :=
begin
  haveI : (P : subgroup G).is_commutative := ⟨⟨λ a b, subtype.ext (hP (le_normalizer b.2) a a.2)⟩⟩,
  replace hg := (P : subgroup G).pow_mem hg k,
  obtain ⟨n, hn, h⟩ := P.conj_eq_normalizer_conj_of_mem (g ^ k) g₀ hg h,
  exact h.trans (commute.inv_mul_cancel (hP hn (g ^ k) hg).symm),
end

variables [finite_index (P : subgroup G)]

lemma transfer_sylow_eq_pow (g : G) (hg : g ∈ P) : transfer_sylow P hP g =
  ⟨g ^ (P : subgroup G).index, transfer_eq_pow_aux g (transfer_sylow_eq_pow_aux P hP g hg)⟩ :=
by apply transfer_eq_pow

lemma transfer_sylow_restrict_eq_pow :
  ⇑((transfer_sylow P hP).restrict (P : subgroup G)) = (^ (P : subgroup G).index) :=
funext (λ g, transfer_sylow_eq_pow P hP g g.2)

/-- Burnside's normal p-complement theorem: If `N(P) ≤ C(P)`, then `P` has a normal complement. -/
lemma ker_transfer_sylow_is_complement' : is_complement' (transfer_sylow P hP).ker P :=
begin
  have hf : function.bijective ((transfer_sylow P hP).restrict (P : subgroup G)) :=
  (transfer_sylow_restrict_eq_pow P hP).symm ▸ (P.2.pow_equiv' (not_dvd_index_sylow P
    (mt index_eq_zero_of_relindex_eq_zero index_ne_zero_of_finite))).bijective,
  rw [function.bijective, ←range_top_iff_surjective, restrict_range] at hf,
  have := range_top_iff_surjective.mp (top_le_iff.mp (hf.2.ge.trans (map_le_range _ P))),
  rw [←(comap_injective this).eq_iff, comap_top, comap_map_eq, sup_comm, set_like.ext'_iff,
      normal_mul, ←ker_eq_bot_iff, ←(map_injective (P : subgroup G).subtype_injective).eq_iff,
      ker_restrict, subgroup_of_map_subtype, subgroup.map_bot, coe_top] at hf,
  exact is_complement'_of_disjoint_and_mul_eq_univ (disjoint_iff.2 hf.1) hf.2,
end

lemma not_dvd_card_ker_transfer_sylow : ¬ p ∣ nat.card (transfer_sylow P hP).ker :=
(ker_transfer_sylow_is_complement' P hP).index_eq_card ▸ not_dvd_index_sylow P $
  mt index_eq_zero_of_relindex_eq_zero index_ne_zero_of_finite

lemma ker_transfer_sylow_disjoint (Q : subgroup G) (hQ : is_p_group p Q) :
  disjoint (transfer_sylow P hP).ker Q :=
disjoint_iff.mpr $ card_eq_one.mp $ (hQ.to_le inf_le_right).card_eq_or_dvd.resolve_right $
  λ h, not_dvd_card_ker_transfer_sylow P hP $ h.trans $ nat_card_dvd_of_le _ _ inf_le_left

end burnside_transfer

end monoid_hom


/-
Copyright (c) 2021 Oliver Nash. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Oliver Nash
-/
import algebra.lie.basic
import algebra.lie.subalgebra
import algebra.algebra.subalgebra

/-!
# Lie algebras of associative algebras

This file defines the Lie algebra structure that arises on an associative algebra via the ring
commutator.

Since the linear endomorphisms of a Lie algebra form an associative algebra, one can define the
adjoint action as a morphism of Lie algebras from a Lie algebra to its linear endomorphisms. We
make such a definition in this file.

## Main definitions

 * `lie_algebra.of_associative_algebra`
 * `lie_algebra.of_associative_algebra_hom`
 * `lie_module.to_endomorphism`
 * `lie_algebra.ad`
 * `linear_equiv.lie_conj`
 * `alg_equiv.to_lie_equiv`

## Tags

lie algebra, ring commutator, adjoint action
-/

universes u v w w₁ w₂

section of_associative

variables {A : Type v} [ring A]

namespace ring

/-- The bracket operation for rings is the ring commutator, which captures the extent to which a
ring is commutative. It is identically zero exactly when the ring is commutative. -/
@[priority 100]
instance : has_bracket A A := ⟨λ x y, x*y - y*x⟩

lemma lie_def (x y : A) : ⁅x, y⁆ = x*y - y*x := rfl

end ring

namespace lie_ring

/-- An associative ring gives rise to a Lie ring by taking the bracket to be the ring commutator. -/
@[priority 100]
instance of_associative_ring : lie_ring A :=
{ add_lie      := by simp only [ring.lie_def, right_distrib, left_distrib,
    sub_eq_add_neg, add_comm, add_left_comm, forall_const, eq_self_iff_true, neg_add_rev],
  lie_add      := by simp only [ring.lie_def, right_distrib, left_distrib,
    sub_eq_add_neg, add_comm, add_left_comm, forall_const, eq_self_iff_true, neg_add_rev],
  lie_self     := by simp only [ring.lie_def, forall_const, sub_self],
  leibniz_lie  := λ x y z, by { repeat { rw ring.lie_def, }, noncomm_ring, } }

lemma of_associative_ring_bracket (x y : A) : ⁅x, y⁆ = x*y - y*x := rfl

@[simp] lemma lie_apply {α : Type*} (f g : α → A) (a : α) : ⁅f, g⁆ a = ⁅f a, g a⁆ := rfl

end lie_ring

section lie_algebra

variables {R : Type u} [comm_ring R] [algebra R A]

/-- An associative algebra gives rise to a Lie algebra by taking the bracket to be the ring
commutator. -/
@[priority 100]
instance lie_algebra.of_associative_algebra : lie_algebra R A :=
{ lie_smul := λ t x y,
    by rw [lie_ring.of_associative_ring_bracket, lie_ring.of_associative_ring_bracket,
           algebra.mul_smul_comm, algebra.smul_mul_assoc, smul_sub], }

namespace alg_hom

variables {B : Type w} {C : Type w₁} [ring B] [ring C] [algebra R B] [algebra R C]
variables (f : A →ₐ[R] B) (g : B →ₐ[R] C)

/-- The map `of_associative_algebra` associating a Lie algebra to an associative algebra is
functorial. -/
def to_lie_hom : A →ₗ⁅R⁆ B :=
 { map_lie' := λ x y, show f ⁅x,y⁆ = ⁅f x,f y⁆,
     by simp only [lie_ring.of_associative_ring_bracket, alg_hom.map_sub, alg_hom.map_mul],
  ..f.to_linear_map, }

instance : has_coe (A →ₐ[R] B) (A →ₗ⁅R⁆ B) := ⟨to_lie_hom⟩

@[simp] lemma to_lie_hom_coe : f.to_lie_hom = ↑f := rfl

@[simp]

lemma to_lie_hom_apply (x : A) : f.to_lie_hom x = f x := rfl

@[simp] lemma to_lie_hom_id : (alg_hom.id R A : A →ₗ⁅R⁆ A) = lie_hom.id := rfl

@[simp] lemma to_lie_hom_comp : (g.comp f : A →ₗ⁅R⁆ C) = (g : B →ₗ⁅R⁆ C).comp (f : A →ₗ⁅R⁆ B) := rfl

lemma to_lie_hom_injective {f g : A →ₐ[R] B}
  (h : (f : A →ₗ⁅R⁆ B) = (g : A →ₗ⁅R⁆ B)) : f = g :=
by { ext a, exact lie_hom.congr_fun h a, }

end alg_hom

end lie_algebra

end of_associative

section adjoint_action

variables (R : Type u) (L : Type v) (M : Type w)
variables [comm_ring R] [lie_ring L] [lie_algebra R L] [add_comm_group M] [module R M]
variables [lie_ring_module L M] [lie_module R L M]

/-- A Lie module yields a Lie algebra morphism into the linear endomorphisms of the module.

See also `lie_module.to_module_hom`. -/
@[simps] def lie_module.to_endomorphism : L →ₗ⁅R⁆ module.End R M :=
{ to_fun    := λ x,
  { to_fun    := λ m, ⁅x, m⁆,
    map_add'  := lie_add x,
    map_smul' := λ t, lie_smul t x, },
  map_add'  := λ x y, by { ext m, apply add_lie, },
  map_smul' := λ t x, by { ext m, apply smul_lie, },
  map_lie'  := λ x y, by { ext m, apply lie_lie, }, }

/-- The adjoint action of a Lie algebra on itself. -/
def lie_algebra.ad : L →ₗ⁅R⁆ module.End R L := lie_module.to_endomorphism R L L

@[simp] lemma lie_algebra.ad_apply (x y : L) : lie_algebra.ad R L x y = ⁅x, y⁆ := rfl

open lie_algebra

lemma lie_algebra.ad_eq_lmul_left_sub_lmul_right (A : Type v) [ring A] [algebra R A] :
  (ad R A : A → module.End R A) = algebra.lmul_left R - algebra.lmul_right R :=
by { ext a b, simp [lie_ring.of_associative_ring_bracket], }

variables {R L}

lemma lie_subalgebra.ad_comp_incl_eq (K : lie_subalgebra R L) (x : K) :
  (ad R L ↑x).comp (K.incl : K →ₗ[R] L) = (K.incl : K →ₗ[R] L).comp (ad R K x) :=
begin
  ext y,
  simp only [ad_apply, lie_hom.coe_to_linear_map, lie_subalgebra.coe_incl, linear_map.coe_comp,
    lie_subalgebra.coe_bracket, function.comp_app],
end

end adjoint_action

/-- A subalgebra of an associative algebra is a Lie subalgebra of the associated Lie algebra. -/
def lie_subalgebra_of_subalgebra (R : Type u) [comm_ring R] (A : Type v) [ring A] [algebra R A]
  (A' : subalgebra R A) : lie_subalgebra R A :=
{ lie_mem' := λ x y hx hy, by
  { change ⁅x, y⁆ ∈ A', change x ∈ A' at hx, change y ∈ A' at hy,
    rw lie_ring.of_associative_ring_bracket,
    have hxy := A'.mul_mem hx hy,
    have hyx := A'.mul_mem hy hx,
    exact submodule.sub_mem A'.to_submodule hxy hyx, },
  ..A'.to_submodule }

namespace linear_equiv

variables {R : Type u} {M₁ : Type v} {M₂ : Type w}
variables [comm_ring R] [add_comm_group M₁] [module R M₁] [add_comm_group M₂] [module R M₂]
variables (e : M₁ ≃ₗ[R] M₂)

/-- A linear equivalence of two modules induces a Lie algebra equivalence of their endomorphisms. -/
def lie_conj : module.End R M₁ ≃ₗ⁅R⁆ module.End R M₂ :=
{ map_lie' := λ f g, show e.conj ⁅f, g⁆ = ⁅e.conj f, e.conj g⁆,
    by simp only [lie_ring.of_associative_ring_bracket, linear_map.mul_eq_comp, e.conj_comp,
                  linear_equiv.map_sub],
  ..e.conj }

@[simp] lemma lie_conj_apply (f : module.End R M₁) : e.lie_conj f = e.conj f := rfl

@[simp] lemma lie_conj_symm : e.lie_conj.symm = e.symm.lie_conj := rfl

end linear_equiv

namespace alg_equiv

variables {R : Type u} {A₁ : Type v} {A₂ : Type w}
variables [comm_ring R] [ring A₁] [ring A₂] [algebra R A₁] [algebra R A₂]
variables (e : A₁ ≃ₐ[R] A₂)

/-- An equivalence of associative algebras is an equivalence of associated Lie algebras. -/
def to_lie_equiv : A₁ ≃ₗ⁅R⁆ A₂ :=
{ to_fun   := e.to_fun,
  map_lie' := λ x y, by simp [lie_ring.of_associative_ring_bracket],
  ..e.to_linear_equiv }

@[simp] lemma to_lie_equiv_apply (x : A₁) : e.to_lie_equiv x = e x := rfl

@[simp] lemma to_lie_equiv_symm_apply (x : A₂) : e.to_lie_equiv.symm x = e.symm x := rfl

end alg_equiv


/-
Copyright (c) 2019 Tim Baanen. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Tim Baanen.
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.algebra.associated
import Mathlib.linear_algebra.determinant
import Mathlib.tactic.linarith.default
import Mathlib.tactic.ring_exp
import Mathlib.PostPort

universes u v u_1

namespace Mathlib

/-!
# Nonsingular inverses

In this file, we define an inverse for square matrices of invertible
determinant. For matrices that are not square or not of full rank, there is a
more general notion of pseudoinverses which we do not consider here.

The definition of inverse used in this file is the adjugate divided by the determinant.
The adjugate is calculated with Cramer's rule, which we introduce first.
The vectors returned by Cramer's rule are given by the linear map `cramer`,
which sends a matrix `A` and vector `b` to the vector consisting of the
determinant of replacing the `i`th column of `A` with `b` at index `i`
(written as `(A.update_column i b).det`).
Using Cramer's rule, we can compute for each matrix `A` the matrix `adjugate A`.
The entries of the adjugate are the determinants of each minor of `A`.
Instead of defining a minor to be `A` with row `i` and column `j` deleted, we
replace the `i`th row of `A` with the `j`th basis vector; this has the same
determinant as the minor but more importantly equals Cramer's rule applied
to `A` and the `j`th basis vector, simplifying the subsequent proofs.
We prove the adjugate behaves like `det A • A⁻¹`. Finally, we show that dividing
the adjugate by `det A` (if possible), giving a matrix `nonsing_inv A`, will
result in a multiplicative inverse to `A`.

## References

  * https://en.wikipedia.org/wiki/Cramer's_rule#Finding_inverse_matrix

## Tags

matrix inverse, cramer, cramer's rule, adjugate
-/

namespace matrix

/-!
  ### `cramer` section

  Introduce the linear map `cramer` with values defined by `cramer_map`.
  After defining `cramer_map` and showing it is linear,
  we will restrict our proofs to using `cramer`.
-/

/--
  `cramer_map A b i` is the determinant of the matrix `A` with column `i` replaced with `b`,
  and thus `cramer_map A b` is the vector output by Cramer's rule on `A` and `b`.

  If `A ⬝ x = b` has a unique solution in `x`, `cramer_map A` sends the vector `b` to `A.det • x`.
  Otherwise, the outcome of `cramer_map` is well-defined but not necessarily useful.
-/
def cramer_map {n : Type u} [DecidableEq n] [fintype n] {α : Type v} [comm_ring α]
    (A : matrix n n α) (b : n → α) (i : n) : α :=
  det (update_column A i b)

theorem cramer_map_is_linear {n : Type u} [DecidableEq n] [fintype n] {α : Type v} [comm_ring α]
    (A : matrix n n α) (i : n) : is_linear_map α fun (b : n → α) => cramer_map A b i :=
  sorry

theorem cramer_is_linear {n : Type u} [DecidableEq n] [fintype n] {α : Type v} [comm_ring α]
    (A : matrix n n α) : is_linear_map α (cramer_map A) :=
  is_linear_map.mk
    (fun (x y : n → α) =>
      funext fun (i : n) => is_linear_map.map_add (cramer_map_is_linear A i) x y)
    fun (c : α) (x : n → α) =>
      funext fun (i : n) => is_linear_map.map_smul (cramer_map_is_linear A i) c x

/--
  `cramer A b i` is the determinant of the matrix `A` with column `i` replaced with `b`,
  and thus `cramer A b` is the vector output by Cramer's rule on `A` and `b`.

  If `A ⬝ x = b` has a unique solution in `x`, `cramer A` sends the vector `b` to `A.det • x`.
  Otherwise, the outcome of `cramer` is well-defined but not necessarily useful.
 -/
def cramer {n : Type u} [DecidableEq n] [fintype n] {α : Type v} [comm_ring α] (A : matrix n n α) :
    linear_map α (n → α) (n → α) :=
  is_linear_map.mk' (cramer_map A) sorry

theorem cramer_apply {n : Type u} [DecidableEq n] [fintype n] {α : Type v} [comm_ring α]
    (A : matrix n n α) (b : n → α) (i : n) : coe_fn (cramer A) b i = det (update_column A i b) :=
  rfl

theorem cramer_transpose_row_self {n : Type u} [DecidableEq n] [fintype n] {α : Type v}
    [comm_ring α] (A : matrix n n α) (i : n) :
    coe_fn (cramer (transpose A)) (A i) = fun (j : n) => ite (i = j) (det A) 0 :=
  sorry

/-- Use linearity of `cramer` to take it out of a summation. -/
theorem sum_cramer {n : Type u} [DecidableEq n] [fintype n] {α : Type v} [comm_ring α]
    (A : matrix n n α) {β : Type u_1} (s : finset β) (f : β → n → α) :
    (finset.sum s fun (x : β) => coe_fn (cramer A) (f x)) =
        coe_fn (cramer A) (finset.sum s fun (x : β) => f x) :=
  Eq.symm (linear_map.map_sum (cramer A))

/-- Use linearity of `cramer` and vector evaluation to take `cramer A _ i` out of a summation. -/
theorem sum_cramer_apply {n : Type u} [DecidableEq n] [fintype n] {α : Type v} [comm_ring α]
    (A : matrix n n α) {β : Type u_1} (s : finset β) (f : n → β → α) (i : n) :
    (finset.sum s fun (x : β) => coe_fn (cramer A) (fun (j : n) => f j x) i) =
        coe_fn (cramer A) (fun (j : n) => finset.sum s fun (x : β) => f j x) i :=
  sorry

/-!
### `adjugate` section

Define the `adjugate` matrix and a few equations.
These will hold for any matrix over a commutative ring,
while the `inv` section is specifically for invertible matrices.
-/

/-- The adjugate matrix is the transpose of the cofactor matrix.

  Typically, the cofactor matrix is defined by taking the determinant of minors,
  i.e. the matrix with a row and column removed.
  However, the proof of `mul_adjugate` becomes a lot easier if we define the
  minor as replacing a column with a basis vector, since it allows us to use
  facts about the `cramer` map.
-/
def adjugate {n : Type u} [DecidableEq n] [fintype n] {α : Type v} [comm_ring α]
    (A : matrix n n α) : matrix n n α :=
  fun (i : n) => coe_fn (cramer (transpose A)) fun (j : n) => ite (i = j) 1 0

theorem adjugate_def {n : Type u} [DecidableEq n] [fintype n] {α : Type v} [comm_ring α]
    (A : matrix n n α) :
    adjugate A = fun (i : n) => coe_fn (cramer (transpose A)) fun (j : n) => ite (i = j) 1 0 :=
  rfl

theorem adjugate_apply {n : Type u} [DecidableEq n] [fintype n] {α : Type v} [comm_ring α]
    (A : matrix n n α) (i : n) (j : n) :
    adjugate A i j = det (update_row A j fun (j : n) => ite (i = j) 1 0) :=
  sorry

theorem adjugate_transpose {n : Type u} [DecidableEq n] [fintype n] {α : Type v} [comm_ring α]
    (A : matrix n n α) : transpose (adjugate A) = adjugate (transpose A) :=
  sorry

/-- Since the map `b ↦ cramer A b` is linear in `b`, it must be multiplication by some matrix. This
matrix is `A.adjugate`. -/
theorem cramer_eq_adjugate_mul_vec {n : Type u} [DecidableEq n] [fintype n] {α : Type v}
    [comm_ring α] (A : matrix n n α) (b : n → α) : coe_fn (cramer A) b = mul_vec (adjugate A) b :=
  sorry

theorem mul_adjugate_apply {n : Type u} [DecidableEq n] [fintype n] {α : Type v} [comm_ring α]
    (A : matrix n n α) (i : n) (j : n) (k : n) :
    A i k * adjugate A k j =
        coe_fn (cramer (transpose A)) (fun (j : n) => ite (k = j) (A i k) 0) j :=
  sorry

theorem mul_adjugate {n : Type u} [DecidableEq n] [fintype n] {α : Type v} [comm_ring α]
    (A : matrix n n α) : matrix.mul A (adjugate A) = det A • 1 :=
  sorry

theorem adjugate_mul {n : Type u} [DecidableEq n] [fintype n] {α : Type v} [comm_ring α]
    (A : matrix n n α) : matrix.mul (adjugate A) A = det A • 1 :=
  sorry

/-- `det_adjugate_of_cancel` is an auxiliary lemma for computing `(adjugate A).det`,
  used in `det_adjugate_eq_one` and `det_adjugate_of_is_unit`.

  The formula for the determinant of the adjugate of an `n` by `n` matrix `A`
  is in general `(adjugate A).det = A.det ^ (n - 1)`, but the proof differs in several cases.
  This lemma `det_adjugate_of_cancel` covers the case that `det A` cancels
  on the left of the equation `A.det * b = A.det ^ n`.
-/
theorem det_adjugate_of_cancel {n : Type u} [DecidableEq n] [fintype n] {α : Type v} [comm_ring α]
    {A : matrix n n α}
    (h : ∀ (b : α), det A * b = det A ^ fintype.card n → b = det A ^ (fintype.card n - 1)) :
    det (adjugate A) = det A ^ (fintype.card n - 1) :=
  sorry

theorem adjugate_eq_one_of_card_eq_one {n : Type u} [DecidableEq n] [fintype n] {α : Type v}
    [comm_ring α] {A : matrix n n α} (h : fintype.card n = 1) : adjugate A = 1 :=
  sorry

@[simp] theorem adjugate_zero {n : Type u} [DecidableEq n] [fintype n] {α : Type v} [comm_ring α]
    (h : 1 < fintype.card n) : adjugate 0 = 0 :=
  sorry

theorem det_adjugate_eq_one {n : Type u} [DecidableEq n] [fintype n] {α : Type v} [comm_ring α]
    {A : matrix n n α} (h : det A = 1) : det (adjugate A) = 1 :=
  sorry

/-- `det_adjugate_of_is_unit` gives the formula for `(adjugate A).det` if `A.det` has an inverse.

  The formula for the determinant of the adjugate of an `n` by `n` matrix `A`
  is in general `(adjugate A).det = A.det ^ (n - 1)`, but the proof differs in several cases.
  This lemma `det_adjugate_of_is_unit` covers the case that `det A` has an inverse.
-/
theorem det_adjugate_of_is_unit {n : Type u} [DecidableEq n] [fintype n] {α : Type v} [comm_ring α]
    {A : matrix n n α} (h : is_unit (det A)) : det (adjugate A) = det A ^ (fintype.card n - 1) :=
  sorry

/-!
### `inv` section

Defines the matrix `nonsing_inv A` and proves it is the inverse matrix
of a square matrix `A` as long as `det A` has a multiplicative inverse.
-/

theorem is_unit_det_transpose {n : Type u} [DecidableEq n] [fintype n] {α : Type v} [comm_ring α]
    (A : matrix n n α) (h : is_unit (det A)) : is_unit (det (transpose A)) :=
  eq.mpr (id (Eq._oldrec (Eq.refl (is_unit (det (transpose A)))) (det_transpose A))) h

/-- The inverse of a square matrix, when it is invertible (and zero otherwise).-/
def nonsing_inv {n : Type u} [DecidableEq n] [fintype n] {α : Type v} [comm_ring α]
    (A : matrix n n α) : matrix n n α :=
  dite (is_unit (det A)) (fun (h : is_unit (det A)) => ↑(is_unit.unit h⁻¹) • adjugate A)
    fun (h : ¬is_unit (det A)) => 0

protected instance has_inv {n : Type u} [DecidableEq n] [fintype n] {α : Type v} [comm_ring α] :
    has_inv (matrix n n α) :=
  has_inv.mk nonsing_inv

theorem nonsing_inv_apply {n : Type u} [DecidableEq n] [fintype n] {α : Type v} [comm_ring α]
    (A : matrix n n α) (h : is_unit (det A)) : A⁻¹ = ↑(is_unit.unit h⁻¹) • adjugate A :=
  sorry

theorem transpose_nonsing_inv {n : Type u} [DecidableEq n] [fintype n] {α : Type v} [comm_ring α]
    (A : matrix n n α) (h : is_unit (det A)) : transpose (A⁻¹) = (transpose A⁻¹) :=
  sorry

/-- The `nonsing_inv` of `A` is a right inverse. -/
@[simp] theorem mul_nonsing_inv {n : Type u} [DecidableEq n] [fintype n] {α : Type v} [comm_ring α]
    (A : matrix n n α) (h : is_unit (det A)) : matrix.mul A (A⁻¹) = 1 :=
  sorry

/-- The `nonsing_inv` of `A` is a left inverse. -/
@[simp] theorem nonsing_inv_mul {n : Type u} [DecidableEq n] [fintype n] {α : Type v} [comm_ring α]
    (A : matrix n n α) (h : is_unit (det A)) : matrix.mul (A⁻¹) A = 1 :=
  sorry

@[simp] theorem nonsing_inv_det {n : Type u} [DecidableEq n] [fintype n] {α : Type v} [comm_ring α]
    (A : matrix n n α) (h : is_unit (det A)) : det (A⁻¹) * det A = 1 :=
  eq.mpr (id (Eq._oldrec (Eq.refl (det (A⁻¹) * det A = 1)) (Eq.symm (det_mul (A⁻¹) A))))
    (eq.mpr (id (Eq._oldrec (Eq.refl (det (matrix.mul (A⁻¹) A) = 1)) (nonsing_inv_mul A h)))
      (eq.mpr (id (Eq._oldrec (Eq.refl (det 1 = 1)) det_one)) (Eq.refl 1)))

theorem is_unit_nonsing_inv_det {n : Type u} [DecidableEq n] [fintype n] {α : Type v} [comm_ring α]
    (A : matrix n n α) (h : is_unit (det A)) : is_unit (det (A⁻¹)) :=
  is_unit_of_mul_eq_one (det (A⁻¹)) (det A) (nonsing_inv_det A h)

@[simp] theorem nonsing_inv_nonsing_inv {n : Type u} [DecidableEq n] [fintype n] {α : Type v}
    [comm_ring α] (A : matrix n n α) (h : is_unit (det A)) : A⁻¹⁻¹ = A :=
  sorry

/-- A matrix whose determinant is a unit is itself a unit. -/
def nonsing_inv_unit {n : Type u} [DecidableEq n] [fintype n] {α : Type v} [comm_ring α]
    (A : matrix n n α) (h : is_unit (det A)) : units (matrix n n α) :=
  units.mk A (A⁻¹) sorry sorry

theorem is_unit_iff_is_unit_det {n : Type u} [DecidableEq n] [fintype n] {α : Type v} [comm_ring α]
    (A : matrix n n α) : is_unit A ↔ is_unit (det A) :=
  sorry

theorem is_unit_det_of_left_inverse {n : Type u} [DecidableEq n] [fintype n] {α : Type v}
    [comm_ring α] (A : matrix n n α) (B : matrix n n α) (h : matrix.mul B A = 1) :
    is_unit (det A) :=
  sorry

theorem is_unit_det_of_right_inverse {n : Type u} [DecidableEq n] [fintype n] {α : Type v}
    [comm_ring α] (A : matrix n n α) (B : matrix n n α) (h : matrix.mul A B = 1) :
    is_unit (det A) :=
  sorry

theorem nonsing_inv_left_right {n : Type u} [DecidableEq n] [fintype n] {α : Type v} [comm_ring α]
    (A : matrix n n α) (B : matrix n n α) (h : matrix.mul A B = 1) : matrix.mul B A = 1 :=
  sorry

theorem nonsing_inv_right_left {n : Type u} [DecidableEq n] [fintype n] {α : Type v} [comm_ring α]
    (A : matrix n n α) (B : matrix n n α) (h : matrix.mul B A = 1) : matrix.mul A B = 1 :=
  nonsing_inv_left_right B A h

/- One form of Cramer's rule. -/

@[simp] theorem det_smul_inv_mul_vec_eq_cramer {n : Type u} [DecidableEq n] [fintype n] {α : Type v}
    [comm_ring α] (A : matrix n n α) (b : n → α) (h : is_unit (det A)) :
    det A • mul_vec (A⁻¹) b = coe_fn (cramer A) b :=
  sorry

/- A stronger form of Cramer's rule that allows us to solve some instances of `A ⬝ x = b` even if
the determinant is not a unit. A sufficient (but still not necessary) condition is that `A.det`
divides `b`. -/

@[simp] theorem mul_vec_cramer {n : Type u} [DecidableEq n] [fintype n] {α : Type v} [comm_ring α]
    (A : matrix n n α) (b : n → α) : mul_vec A (coe_fn (cramer A) b) = det A • b :=
  sorry

end Mathlib


/-
Copyright (c) 2019 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Patrick Massot, Casper Putz, Anne Baanen, Antoine Labelle

! This file was ported from Lean 3 source module linear_algebra.trace
! leanprover-community/mathlib commit 70fd9563a21e7b963887c9360bd29b2393e6225a
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.LinearAlgebra.Matrix.ToLin
import Mathbin.LinearAlgebra.Matrix.Trace
import Mathbin.LinearAlgebra.Contraction
import Mathbin.LinearAlgebra.TensorProductBasis
import Mathbin.LinearAlgebra.FreeModule.StrongRankCondition
import Mathbin.LinearAlgebra.FreeModule.Finite.Rank
import Mathbin.LinearAlgebra.Projection

/-!
# Trace of a linear map

This file defines the trace of a linear map.

See also `linear_algebra/matrix/trace.lean` for the trace of a matrix.

## Tags

linear_map, trace, diagonal

-/

noncomputable section

universe u v w

namespace LinearMap

open BigOperators

open Matrix

open FiniteDimensional

open TensorProduct

section

variable (R : Type u) [CommSemiring R] {M : Type v} [AddCommMonoid M] [Module R M]

variable {ι : Type w} [DecidableEq ι] [Fintype ι]

variable {κ : Type _} [DecidableEq κ] [Fintype κ]

variable (b : Basis ι R M) (c : Basis κ R M)

/-- The trace of an endomorphism given a basis. -/
def traceAux : (M →ₗ[R] M) →ₗ[R] R :=
  Matrix.traceLinearMap ι R R ∘ₗ ↑(LinearMap.toMatrix b b)
#align linear_map.trace_aux LinearMap.traceAux

-- Can't be `simp` because it would cause a loop.
theorem traceAux_def (b : Basis ι R M) (f : M →ₗ[R] M) :
    traceAux R b f = Matrix.trace (LinearMap.toMatrix b b f) :=
  rfl
#align linear_map.trace_aux_def LinearMap.traceAux_def

theorem traceAux_eq : traceAux R b = traceAux R c :=
  LinearMap.ext fun f =>
    calc
      Matrix.trace (LinearMap.toMatrix b b f) =
          Matrix.trace (LinearMap.toMatrix b b ((LinearMap.id.comp f).comp LinearMap.id)) :=
        by rw [LinearMap.id_comp, LinearMap.comp_id]
      _ =
          Matrix.trace
            (LinearMap.toMatrix c b LinearMap.id ⬝ LinearMap.toMatrix c c f ⬝
              LinearMap.toMatrix b c LinearMap.id) :=
        by rw [LinearMap.toMatrix_comp _ c, LinearMap.toMatrix_comp _ c]
      _ =
          Matrix.trace
            (LinearMap.toMatrix c c f ⬝ LinearMap.toMatrix b c LinearMap.id ⬝
              LinearMap.toMatrix c b LinearMap.id) :=
        by rw [Matrix.mul_assoc, Matrix.trace_mul_comm]
      _ = Matrix.trace (LinearMap.toMatrix c c ((f.comp LinearMap.id).comp LinearMap.id)) := by
        rw [LinearMap.toMatrix_comp _ b, LinearMap.toMatrix_comp _ c]
      _ = Matrix.trace (LinearMap.toMatrix c c f) := by rw [LinearMap.comp_id, LinearMap.comp_id]

#align linear_map.trace_aux_eq LinearMap.traceAux_eq

open Classical

variable (R) (M)

/-- Trace of an endomorphism independent of basis. -/
def trace : (M →ₗ[R] M) →ₗ[R] R :=
  if H : ∃ s : Finset M, Nonempty (Basis s R M) then traceAux R H.choose_spec.some else 0
#align linear_map.trace LinearMap.trace

variable (R) {M}

/-- Auxiliary lemma for `trace_eq_matrix_trace`. -/
theorem trace_eq_matrix_trace_of_finset {s : Finset M} (b : Basis s R M) (f : M →ₗ[R] M) :
    trace R M f = Matrix.trace (LinearMap.toMatrix b b f) :=
  by
  have : ∃ s : Finset M, Nonempty (Basis s R M) := ⟨s, ⟨b⟩⟩
  rw [trace, dif_pos this, ← trace_aux_def]
  congr 1
  apply trace_aux_eq
#align linear_map.trace_eq_matrix_trace_of_finset LinearMap.trace_eq_matrix_trace_of_finset

theorem trace_eq_matrix_trace (f : M →ₗ[R] M) :
    trace R M f = Matrix.trace (LinearMap.toMatrix b b f) := by
  rw [trace_eq_matrix_trace_of_finset R b.reindex_finset_range, ← trace_aux_def, ← trace_aux_def,
    trace_aux_eq R b]
#align linear_map.trace_eq_matrix_trace LinearMap.trace_eq_matrix_trace

theorem trace_mul_comm (f g : M →ₗ[R] M) : trace R M (f * g) = trace R M (g * f) :=
  if H : ∃ s : Finset M, Nonempty (Basis s R M) then
    by
    let ⟨s, ⟨b⟩⟩ := H
    simp_rw [trace_eq_matrix_trace R b, LinearMap.toMatrix_mul]
    apply Matrix.trace_mul_comm
  else by rw [trace, dif_neg H, LinearMap.zero_apply, LinearMap.zero_apply]
#align linear_map.trace_mul_comm LinearMap.trace_mul_comm

/-- The trace of an endomorphism is invariant under conjugation -/
@[simp]
theorem trace_conj (g : M →ₗ[R] M) (f : (M →ₗ[R] M)ˣ) : trace R M (↑f * g * ↑f⁻¹) = trace R M g :=
  by
  rw [trace_mul_comm]
  simp
#align linear_map.trace_conj LinearMap.trace_conj

end

section

variable {R : Type _} [CommRing R] {M : Type _} [AddCommGroup M] [Module R M]

variable (N : Type _) [AddCommGroup N] [Module R N]

variable {ι : Type _}

/-- The trace of a linear map correspond to the contraction pairing under the isomorphism
 `End(M) ≃ M* ⊗ M`-/
theorem trace_eq_contract_of_basis [Finite ι] (b : Basis ι R M) :
    LinearMap.trace R M ∘ₗ dualTensorHom R M M = contractLeft R M := by
  classical
    cases nonempty_fintype ι
    apply Basis.ext (Basis.tensorProduct (Basis.dualBasis b) b)
    rintro ⟨i, j⟩
    simp only [Function.comp_apply, Basis.tensorProduct_apply, Basis.coe_dualBasis, coe_comp]
    rw [trace_eq_matrix_trace R b, toMatrix_dualTensorHom]
    by_cases hij : i = j
    · rw [hij]
      simp
    rw [Matrix.stdBasisMatrix.trace_zero j i (1 : R) hij]
    simp [Finsupp.single_eq_pi_single, hij]
#align linear_map.trace_eq_contract_of_basis LinearMap.trace_eq_contract_of_basis

/-- The trace of a linear map correspond to the contraction pairing under the isomorphism
 `End(M) ≃ M* ⊗ M`-/
theorem trace_eq_contract_of_basis' [Fintype ι] [DecidableEq ι] (b : Basis ι R M) :
    LinearMap.trace R M = contractLeft R M ∘ₗ (dualTensorHomEquivOfBasis b).symm.toLinearMap := by
  simp [LinearEquiv.eq_comp_toLinearMap_symm, trace_eq_contract_of_basis b]
#align linear_map.trace_eq_contract_of_basis' LinearMap.trace_eq_contract_of_basis'

variable (R M N)

variable [Module.Free R M] [Module.Finite R M] [Module.Free R N] [Module.Finite R N] [Nontrivial R]

/-- When `M` is finite free, the trace of a linear map correspond to the contraction pairing under
the isomorphism `End(M) ≃ M* ⊗ M`-/
@[simp]
theorem trace_eq_contract : LinearMap.trace R M ∘ₗ dualTensorHom R M M = contractLeft R M :=
  trace_eq_contract_of_basis (Module.Free.chooseBasis R M)
#align linear_map.trace_eq_contract LinearMap.trace_eq_contract

@[simp]
theorem trace_eq_contract_apply (x : Module.Dual R M ⊗[R] M) :
    (LinearMap.trace R M) ((dualTensorHom R M M) x) = contractLeft R M x := by
  rw [← comp_apply, trace_eq_contract]
#align linear_map.trace_eq_contract_apply LinearMap.trace_eq_contract_apply

open Classical

/-- When `M` is finite free, the trace of a linear map correspond to the contraction pairing under
the isomorphism `End(M) ≃ M* ⊗ M`-/
theorem trace_eq_contract' :
    LinearMap.trace R M = contractLeft R M ∘ₗ (dualTensorHomEquiv R M M).symm.toLinearMap :=
  trace_eq_contract_of_basis' (Module.Free.chooseBasis R M)
#align linear_map.trace_eq_contract' LinearMap.trace_eq_contract'

/-- The trace of the identity endomorphism is the dimension of the free module -/
@[simp]
theorem trace_one : trace R M 1 = (finrank R M : R) :=
  by
  have b := Module.Free.chooseBasis R M
  rw [trace_eq_matrix_trace R b, to_matrix_one, Module.Free.finrank_eq_card_chooseBasisIndex]
  simp
#align linear_map.trace_one LinearMap.trace_one

/-- The trace of the identity endomorphism is the dimension of the free module -/
@[simp]
theorem trace_id : trace R M id = (finrank R M : R) := by rw [← one_eq_id, trace_one]
#align linear_map.trace_id LinearMap.trace_id

@[simp]
theorem trace_transpose : trace R (Module.Dual R M) ∘ₗ Module.Dual.transpose = trace R M :=
  by
  let e := dualTensorHomEquiv R M M
  have h : Function.Surjective e.to_linear_map := e.surjective
  refine' (cancel_right h).1 _
  ext (f m); simp [e]
#align linear_map.trace_transpose LinearMap.trace_transpose

theorem trace_prodMap :
    trace R (M × N) ∘ₗ prodMapLinear R M N M N R =
      (coprod id id : R × R →ₗ[R] R) ∘ₗ prodMap (trace R M) (trace R N) :=
  by
  let e := (dualTensorHomEquiv R M M).Prod (dualTensorHomEquiv R N N)
  have h : Function.Surjective e.to_linear_map := e.surjective
  refine' (cancel_right h).1 _
  ext
  ·
    simp only [dualTensorHomEquiv, TensorProduct.AlgebraTensorModule.curry_apply, to_fun_eq_coe,
      TensorProduct.curry_apply, coe_restrict_scalars_eq_coe, coe_comp, LinearEquiv.coe_toLinearMap,
      coe_inl, Function.comp_apply, LinearEquiv.prod_apply, dualTensorHomEquivOfBasis_apply,
      map_zero, prod_map_apply, coprod_apply, id_coe, id.def, add_zero, prod_map_linear_apply,
      dualTensorHom_prodMap_zero, trace_eq_contract_apply, contractLeft_apply, fst_apply]
  ·
    simp only [dualTensorHomEquiv, TensorProduct.AlgebraTensorModule.curry_apply, to_fun_eq_coe,
      TensorProduct.curry_apply, coe_restrict_scalars_eq_coe, coe_comp, LinearEquiv.coe_toLinearMap,
      coe_inr, Function.comp_apply, LinearEquiv.prod_apply, dualTensorHomEquivOfBasis_apply,
      map_zero, prod_map_apply, coprod_apply, id_coe, id.def, zero_add, prod_map_linear_apply,
      zero_prodMap_dualTensorHom, trace_eq_contract_apply, contractLeft_apply, snd_apply]
#align linear_map.trace_prod_map LinearMap.trace_prodMap

variable {R M N}

theorem trace_prod_map' (f : M →ₗ[R] M) (g : N →ₗ[R] N) :
    trace R (M × N) (prodMap f g) = trace R M f + trace R N g :=
  by
  have h := ext_iff.1 (trace_prod_map R M N) (f, g)
  simp only [coe_comp, Function.comp_apply, prod_map_apply, coprod_apply, id_coe, id.def,
    prod_map_linear_apply] at h
  exact h
#align linear_map.trace_prod_map' LinearMap.trace_prod_map'

variable (R M N)

open TensorProduct Function

theorem trace_tensorProduct :
    compr₂ (mapBilinear R M N M N) (trace R (M ⊗ N)) =
      compl₁₂ (lsmul R R : R →ₗ[R] R →ₗ[R] R) (trace R M) (trace R N) :=
  by
  apply
    (compl₁₂_inj (show surjective (dualTensorHom R M M) from (dualTensorHomEquiv R M M).Surjective)
        (show surjective (dualTensorHom R N N) from (dualTensorHomEquiv R N N).Surjective)).1
  ext (f m g n)
  simp only [algebra_tensor_module.curry_apply, to_fun_eq_coe, TensorProduct.curry_apply,
    coe_restrict_scalars_eq_coe, compl₁₂_apply, compr₂_apply, map_bilinear_apply,
    trace_eq_contract_apply, contractLeft_apply, lsmul_apply, Algebra.id.smul_eq_mul,
    map_dualTensorHom, dual_distrib_apply]
#align linear_map.trace_tensor_product LinearMap.trace_tensorProduct

theorem trace_comp_comm :
    compr₂ (llcomp R M N M) (trace R M) = compr₂ (llcomp R N M N).flip (trace R N) :=
  by
  apply
    (compl₁₂_inj (show surjective (dualTensorHom R N M) from (dualTensorHomEquiv R N M).Surjective)
        (show surjective (dualTensorHom R M N) from (dualTensorHomEquiv R M N).Surjective)).1
  ext (g m f n)
  simp only [TensorProduct.AlgebraTensorModule.curry_apply, to_fun_eq_coe,
    LinearEquiv.coe_toLinearMap, TensorProduct.curry_apply, coe_restrict_scalars_eq_coe,
    compl₁₂_apply, compr₂_apply, flip_apply, llcomp_apply', comp_dualTensorHom, map_smul,
    trace_eq_contract_apply, contractLeft_apply, smul_eq_mul, mul_comm]
#align linear_map.trace_comp_comm LinearMap.trace_comp_comm

variable {R M N}

@[simp]
theorem trace_transpose' (f : M →ₗ[R] M) : trace R _ (Module.Dual.transpose f) = trace R M f := by
  rw [← comp_apply, trace_transpose]
#align linear_map.trace_transpose' LinearMap.trace_transpose'

theorem trace_tensor_product' (f : M →ₗ[R] M) (g : N →ₗ[R] N) :
    trace R (M ⊗ N) (map f g) = trace R M f * trace R N g :=
  by
  have h := ext_iff.1 (ext_iff.1 (trace_tensor_product R M N) f) g
  simp only [compr₂_apply, map_bilinear_apply, compl₁₂_apply, lsmul_apply,
    Algebra.id.smul_eq_mul] at h
  exact h
#align linear_map.trace_tensor_product' LinearMap.trace_tensor_product'

theorem trace_comp_comm' (f : M →ₗ[R] N) (g : N →ₗ[R] M) :
    trace R M (g ∘ₗ f) = trace R N (f ∘ₗ g) :=
  by
  have h := ext_iff.1 (ext_iff.1 (trace_comp_comm R M N) g) f
  simp only [llcomp_apply', compr₂_apply, flip_apply] at h
  exact h
#align linear_map.trace_comp_comm' LinearMap.trace_comp_comm'

@[simp]
theorem trace_conj' (f : M →ₗ[R] M) (e : M ≃ₗ[R] N) : trace R N (e.conj f) = trace R M f := by
  rw [e.conj_apply, trace_comp_comm', ← comp_assoc, LinearEquiv.comp_coe,
    LinearEquiv.self_trans_symm, LinearEquiv.refl_toLinearMap, id_comp]
#align linear_map.trace_conj' LinearMap.trace_conj'

theorem IsProj.trace {p : Submodule R M} {f : M →ₗ[R] M} (h : IsProj p f) [Module.Free R p]
    [Module.Finite R p] [Module.Free R f.ker] [Module.Finite R f.ker] :
    trace R M f = (finrank R p : R) := by
  rw [h.eq_conj_prod_map, trace_conj', trace_prod_map', trace_id, map_zero, add_zero]
#align linear_map.is_proj.trace LinearMap.IsProj.trace

end

end LinearMap


import tactic

/-
# Level 4 : Proving conjunctions
-/

namespace math3345 -- hide

/-
P and Q are propositions.
-/

variable P : Prop
variable Q : Prop

/- Lemma : no-side-bar

`h` is evidence that `(P ∧ Q)` so we can extract evidence for `P` by
using `h.left` and extract evidence for `Q` with `h.right`.

Start with `split` to separate the thing we're trying to prove into
two goals.  Then finish the proof with `exact` followed by something.

-/
lemma using_and (h : (P ∧ Q)) : (Q ∧ P) :=
begin
  split,
  sorry,

end

end math3345 -- hide


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

! This file was ported from Lean 3 source module combinatorics.catalan
! leanprover-community/mathlib commit 10bf4f825ad729c5653adc039dafa3622e7f93c9
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Algebra.BigOperators.Fin
import Mathbin.Algebra.BigOperators.NatAntidiagonal
import Mathbin.Algebra.CharZero.Lemmas
import Mathbin.Data.Finset.NatAntidiagonal
import Mathbin.Data.Nat.Choose.Central
import Mathbin.Data.Tree
import Mathbin.Tactic.FieldSimp
import Mathbin.Tactic.LinearCombination

/-!
# Catalan numbers

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

The Catalan numbers (http://oeis.org/A000108) are probably the most ubiquitous sequence of integers
in mathematics. They enumerate several important objects like binary trees, Dyck paths, and
triangulations of convex polygons.

## Main definitions

* `catalan n`: the `n`th Catalan number, defined recursively as
  `catalan (n + 1) = ∑ i : fin n.succ, catalan i * catalan (n - i)`.

## Main results

* `catalan_eq_central_binom_div `: The explicit formula for the Catalan number using the central
  binomial coefficient, `catalan n = nat.central_binom n / (n + 1)`.

* `trees_of_nodes_eq_card_eq_catalan`: The number of binary trees with `n` internal nodes
  is `catalan n`

## Implementation details

The proof of `catalan_eq_central_binom_div` follows
https://math.stackexchange.com/questions/3304415/catalan-numbers-algebraic-proof-of-the-recurrence-relation

## TODO

* Prove that the Catalan numbers enumerate many interesting objects.
* Provide the many variants of Catalan numbers, e.g. associated to complex reflection groups,
  Fuss-Catalan, etc.

-/

open BigOperators

open Finset

open Finset.Nat.antidiagonal (fst_le snd_le)

#print catalan /-
/-- The recursive definition of the sequence of Catalan numbers:
`catalan (n + 1) = ∑ i : fin n.succ, catalan i * catalan (n - i)` -/
def catalan : ℕ → ℕ
  | 0 => 1
  | n + 1 =>
    ∑ i : Fin n.succ,
      have := i.2
      have := Nat.lt_succ_iff.mpr (n.sub_le i)
      catalan i * catalan (n - i)
#align catalan catalan
-/

#print catalan_zero /-
@[simp]
theorem catalan_zero : catalan 0 = 1 := by rw [catalan]
#align catalan_zero catalan_zero
-/

#print catalan_succ /-
theorem catalan_succ (n : ℕ) : catalan (n + 1) = ∑ i : Fin n.succ, catalan i * catalan (n - i) := by
  rw [catalan]
#align catalan_succ catalan_succ
-/

#print catalan_succ' /-
theorem catalan_succ' (n : ℕ) :
    catalan (n + 1) = ∑ ij in Nat.antidiagonal n, catalan ij.1 * catalan ij.2 := by
  rw [catalan_succ, nat.sum_antidiagonal_eq_sum_range_succ (fun x y => catalan x * catalan y) n,
    sum_range]
#align catalan_succ' catalan_succ'
-/

#print catalan_one /-
@[simp]
theorem catalan_one : catalan 1 = 1 := by simp [catalan_succ]
#align catalan_one catalan_one
-/

/-- A helper sequence that can be used to prove the equality of the recursive and the explicit
definition using a telescoping sum argument. -/
private def gosper_catalan (n j : ℕ) : ℚ :=
  Nat.centralBinom j * Nat.centralBinom (n - j) * (2 * j - n) / (2 * n * (n + 1))
#align gosper_catalan gosper_catalan

private theorem gosper_trick {n i : ℕ} (h : i ≤ n) :
    gosperCatalan (n + 1) (i + 1) - gosperCatalan (n + 1) i =
      Nat.centralBinom i / (i + 1) * Nat.centralBinom (n - i) / (n - i + 1) :=
  by
  have : (n : ℚ) + 1 ≠ 0 := by exact_mod_cast n.succ_ne_zero
  have : (n : ℚ) + 1 + 1 ≠ 0 := by exact_mod_cast (n + 1).succ_ne_zero
  have : (i : ℚ) + 1 ≠ 0 := by exact_mod_cast i.succ_ne_zero
  have : (n : ℚ) - i + 1 ≠ 0 := by exact_mod_cast (n - i).succ_ne_zero
  have h₁ : ((i : ℚ) + 1) * (i + 1).centralBinom = 2 * (2 * i + 1) * i.central_binom := by
    exact_mod_cast Nat.succ_mul_centralBinom_succ i
  have h₂ :
    ((n : ℚ) - i + 1) * (n - i + 1).centralBinom = 2 * (2 * (n - i) + 1) * (n - i).centralBinom :=
    by exact_mod_cast Nat.succ_mul_centralBinom_succ (n - i)
  simp only [gosper_catalan]
  push_cast
  field_simp
  rw [Nat.succ_sub h]
  linear_combination
    (2 : ℚ) * (n - i).centralBinom * (i + 1 - (n - i)) * (n + 1) * (n + 2) * (n - i + 1) * h₁ -
      2 * i.central_binom * (n + 1) * (n + 2) * (i - (n - i) - 1) * (i + 1) * h₂
#align gosper_trick gosper_trick

private theorem gosper_catalan_sub_eq_central_binom_div (n : ℕ) :
    gosperCatalan (n + 1) (n + 1) - gosperCatalan (n + 1) 0 = Nat.centralBinom (n + 1) / (n + 2) :=
  by
  have : (n : ℚ) + 1 ≠ 0 := by exact_mod_cast n.succ_ne_zero
  have : (n : ℚ) + 1 + 1 ≠ 0 := by exact_mod_cast (n + 1).succ_ne_zero
  have h : (n : ℚ) + 2 ≠ 0 := by exact_mod_cast (n + 1).succ_ne_zero
  simp only [gosper_catalan, Nat.sub_zero, Nat.centralBinom_zero, Nat.sub_self]
  field_simp
  ring
#align gosper_catalan_sub_eq_central_binom_div gosper_catalan_sub_eq_central_binom_div

#print catalan_eq_centralBinom_div /-
theorem catalan_eq_centralBinom_div (n : ℕ) : catalan n = n.centralBinom / (n + 1) :=
  by
  suffices (catalan n : ℚ) = Nat.centralBinom n / (n + 1)
    by
    have h := Nat.succ_dvd_centralBinom n
    exact_mod_cast this
  induction' n using Nat.case_strong_induction_on with d hd
  · simp
  · simp_rw [catalan_succ, Nat.cast_sum, Nat.cast_mul]
    trans
      (∑ i : Fin d.succ, Nat.centralBinom i / (i + 1) * (Nat.centralBinom (d - i) / (d - i + 1)) :
        ℚ)
    · refine' sum_congr rfl fun i _ => _
      congr
      · exact_mod_cast hd i i.is_le
      · rw_mod_cast [hd (d - i)]
        push_cast
        rw [Nat.cast_sub i.is_le]
        exact tsub_le_self
    · trans ∑ i : Fin d.succ, gosper_catalan (d + 1) (i + 1) - gosper_catalan (d + 1) i
      · refine' sum_congr rfl fun i _ => _
        rw_mod_cast [gosper_trick i.is_le, mul_div]
      · rw [← sum_range fun i => gosper_catalan (d + 1) (i + 1) - gosper_catalan (d + 1) i,
          sum_range_sub, Nat.succ_eq_add_one]
        exact_mod_cast gosper_catalan_sub_eq_central_binom_div d
#align catalan_eq_central_binom_div catalan_eq_centralBinom_div
-/

#print succ_mul_catalan_eq_centralBinom /-
theorem succ_mul_catalan_eq_centralBinom (n : ℕ) : (n + 1) * catalan n = n.centralBinom :=
  (Nat.eq_mul_of_div_eq_right n.succ_dvd_centralBinom (catalan_eq_centralBinom_div n).symm).symm
#align succ_mul_catalan_eq_central_binom succ_mul_catalan_eq_centralBinom
-/

#print catalan_two /-
theorem catalan_two : catalan 2 = 2 := by
  norm_num [catalan_eq_centralBinom_div, Nat.centralBinom, Nat.choose]
#align catalan_two catalan_two
-/

#print catalan_three /-
theorem catalan_three : catalan 3 = 5 := by
  norm_num [catalan_eq_centralBinom_div, Nat.centralBinom, Nat.choose]
#align catalan_three catalan_three
-/

namespace Tree

open Tree

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
#print Tree.pairwiseNode /-
/-- Given two finsets, find all trees that can be formed with
  left child in `a` and right child in `b` -/
@[reducible]
def pairwiseNode (a b : Finset (Tree Unit)) : Finset (Tree Unit) :=
  (a ×ˢ b).map ⟨fun x => x.1 △ x.2, fun ⟨x₁, x₂⟩ ⟨y₁, y₂⟩ => fun h => by simpa using h⟩
#align tree.pairwise_node Tree.pairwiseNode
-/

#print Tree.treesOfNumNodesEq /-
/-- A finset of all trees with `n` nodes. See `mem_trees_of_nodes_eq` -/
def treesOfNumNodesEq : ℕ → Finset (Tree Unit)
  | 0 => {nil}
  | n + 1 =>
    (Finset.Nat.antidiagonal n).attach.bunionᵢ fun ijh =>
      have := Nat.lt_succ_of_le (fst_le ijh.2)
      have := Nat.lt_succ_of_le (snd_le ijh.2)
      pairwiseNode (trees_of_num_nodes_eq ijh.1.1) (trees_of_num_nodes_eq ijh.1.2)
#align tree.trees_of_num_nodes_eq Tree.treesOfNumNodesEq
-/

#print Tree.treesOfNumNodesEq_zero /-
@[simp]
theorem treesOfNumNodesEq_zero : treesOfNumNodesEq 0 = {nil} := by rw [trees_of_num_nodes_eq]
#align tree.trees_of_nodes_eq_zero Tree.treesOfNumNodesEq_zero
-/

/- warning: tree.trees_of_nodes_eq_succ -> Tree.treesOfNumNodesEq_succ is a dubious translation:
lean 3 declaration is
  forall (n : Nat), Eq.{1} (Finset.{0} (Tree.{0} Unit)) (Tree.treesOfNumNodesEq (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (OfNat.ofNat.{0} Nat 1 (OfNat.mk.{0} Nat 1 (One.one.{0} Nat Nat.hasOne))))) (Finset.bunionᵢ.{0, 0} (Prod.{0, 0} Nat Nat) (Tree.{0} Unit) (fun (a : Tree.{0} Unit) (b : Tree.{0} Unit) => Tree.decidableEq.{0} Unit (fun (a : Unit) (b : Unit) => PUnit.decidableEq.{1} a b) a b) (Finset.Nat.antidiagonal n) (fun (ij : Prod.{0, 0} Nat Nat) => Tree.pairwiseNode (Tree.treesOfNumNodesEq (Prod.fst.{0, 0} Nat Nat ij)) (Tree.treesOfNumNodesEq (Prod.snd.{0, 0} Nat Nat ij))))
but is expected to have type
  forall (n : Nat), Eq.{1} (Finset.{0} (Tree.{0} Unit)) (Tree.treesOfNumNodesEq (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) n (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1)))) (Finset.bunionᵢ.{0, 0} (Prod.{0, 0} Nat Nat) (Tree.{0} Unit) (fun (a : Tree.{0} Unit) (b : Tree.{0} Unit) => instDecidableEqTree.{0} Unit (fun (a : Unit) (b : Unit) => instDecidableEqPUnit.{1} a b) a b) (Finset.Nat.antidiagonal n) (fun (ij : Prod.{0, 0} Nat Nat) => Tree.pairwiseNode (Tree.treesOfNumNodesEq (Prod.fst.{0, 0} Nat Nat ij)) (Tree.treesOfNumNodesEq (Prod.snd.{0, 0} Nat Nat ij))))
Case conversion may be inaccurate. Consider using '#align tree.trees_of_nodes_eq_succ Tree.treesOfNumNodesEq_succₓ'. -/
theorem treesOfNumNodesEq_succ (n : ℕ) :
    treesOfNumNodesEq (n + 1) =
      (Nat.antidiagonal n).bunionᵢ fun ij =>
        pairwiseNode (treesOfNumNodesEq ij.1) (treesOfNumNodesEq ij.2) :=
  by
  rw [trees_of_num_nodes_eq]
  ext
  simp
#align tree.trees_of_nodes_eq_succ Tree.treesOfNumNodesEq_succ

#print Tree.mem_treesOfNumNodesEq /-
@[simp]
theorem mem_treesOfNumNodesEq {x : Tree Unit} {n : ℕ} : x ∈ treesOfNumNodesEq n ↔ x.numNodes = n :=
  by
  induction x using Tree.unitRecOn generalizing n <;> cases n <;>
    simp [trees_of_nodes_eq_succ, Nat.succ_eq_add_one, *]
  trivial
#align tree.mem_trees_of_nodes_eq Tree.mem_treesOfNumNodesEq
-/

#print Tree.mem_treesOfNumNodesEq_numNodes /-
theorem mem_treesOfNumNodesEq_numNodes (x : Tree Unit) : x ∈ treesOfNumNodesEq x.numNodes :=
  mem_treesOfNumNodesEq.mpr rfl
#align tree.mem_trees_of_nodes_eq_num_nodes Tree.mem_treesOfNumNodesEq_numNodes
-/

#print Tree.coe_treesOfNumNodesEq /-
@[simp, norm_cast]
theorem coe_treesOfNumNodesEq (n : ℕ) :
    ↑(treesOfNumNodesEq n) = { x : Tree Unit | x.numNodes = n } :=
  Set.ext (by simp)
#align tree.coe_trees_of_nodes_eq Tree.coe_treesOfNumNodesEq
-/

#print Tree.treesOfNumNodesEq_card_eq_catalan /-
theorem treesOfNumNodesEq_card_eq_catalan (n : ℕ) : (treesOfNumNodesEq n).card = catalan n :=
  by
  induction' n using Nat.case_strong_induction_on with n ih
  · simp
  rw [trees_of_nodes_eq_succ, card_bUnion, catalan_succ']
  · apply sum_congr rfl
    rintro ⟨i, j⟩ H
    simp [ih _ (fst_le H), ih _ (snd_le H)]
  · simp_rw [disjoint_left]
    rintro ⟨i, j⟩ _ ⟨i', j'⟩ _
    clear * -
    tidy
#align tree.trees_of_nodes_eq_card_eq_catalan Tree.treesOfNumNodesEq_card_eq_catalan
-/

end Tree


variables A B C D: Prop

example : A ∧ (A → B) → B :=
  assume h,
  have A, from and.left h,
  have A → B, from and.right h,
  ‹A → B› ‹A›

example : A → ¬ (¬ A ∧ B) :=
  assume :A,
  show ¬ (¬ A ∧ B), from
    assume h,
    have nA: ¬A, from and.left h,
    nA ‹A›

example : ¬ (A ∧ B) → (A → ¬ B) :=
 assume h₁,
 assume h₂,
 show ¬B, from
  assume :B,
  have A ∧ B, from and.intro h₂ this,
  h₁ this

example (h₁ : A ∨ B) (h₂ : A → C) (h₃ : B → D) : C ∨ D :=
  have A → C ∨ D, from
    assume :A,
    have C, from h₂ ‹A›,
    or.inl this,
  have B → C ∨ D, from
    assume :B,
    have D, from h₃ ‹B›,
    or.inr this,
  or.elim h₁ ‹A → C ∨ D› ‹B → C ∨ D›

example (h : ¬ A ∧ ¬ B) : ¬ (A ∨ B) :=
  assume nh,
  have nA: ¬A, from and.left h,
  have nB: ¬B, from and.right h,
  have h₁: A → false, from assume :A, nA this,
  have h₂: B → false, from assume :B, nB this,
  or.elim nh h₁ h₂

example : ¬ (A ↔ ¬ A) :=
  assume h: A ↔ ¬A,
  show false, from
    have hₐ: ¬A, from
      assume h₁: A,
      have h₂: A → ¬A, from iff.elim_left h,
      show false, from h₂ h₁ h₁,
    have h₁: ¬A → A, from iff.elim_right h,
    hₐ (h₁ hₐ)


import GMLAlgebra.Basic
import GMLAlgebra.Monoid

namespace Algebra.CommMonoid
open Algebra

inductive Expr {α : Type _} : List α → Type _
| nil : Expr []
| cons (n : Nat) {x : α} {xs : List α} : Expr xs → Expr (x :: xs)

namespace Expr

instance instDecidableEq {α} : {xs : List α} → DecidableEq (Expr xs)
| [], nil, nil => Decidable.isTrue rfl
| _::_, cons m a, cons n b =>
  match instDecidableEq a b, inferDecidable (m = n) with
  | isTrue rfl, isTrue rfl => isTrue rfl
  | isFalse h, _ => isFalse fun | rfl => h rfl
  | _, isFalse h => isFalse fun | rfl => h rfl

abbrev lift {α} (x : α) {xs : List α} : Expr xs → Expr (x :: xs) := cons 0

protected def id {α} : {xs : List α} → Expr xs
| [] => nil
| _::_ => cons 0 Expr.id

protected def op {α} : {xs : List α} → Expr xs → Expr xs → Expr xs
| [], _, _ => nil
| _::_, cons m a, cons n b => cons (m + n) (Expr.op a b)

section Eval
variable (s : MonoidSig α)

def eval : {xs : List α} → Expr xs → α
| [], _ => s.id
| _::_, cons 0 a => eval a
| x::xs, cons (n+1) a => s.op x (eval (xs:=x::xs) (cons n a))

variable [CommMonoid s]

@[simp] theorem eval_lift {x : α} {xs : List α} (a : Expr xs) : eval s (Expr.lift x a) = eval s a := by
  simp only [eval]

@[simp] theorem eval_cons_zero {x : α} {xs : List α} (a : Expr xs) : eval s (Expr.cons (x:=x) 0 a) = eval s a := by
  simp only [eval]

@[simp] theorem eval_cons_succ {x : α} {xs : List α} (a : Expr xs) : eval s (Expr.cons (x:=x) (n+1) a) = s.op x (eval s (cons (x:=x) n a)) := by
  simp only [eval]

@[simp] theorem eval_id : ∀ {xs : List α}, eval s (Expr.id (xs:=xs)) = s.id
| [] => rfl
| _::_ => by unfold eval Expr.id; exact eval_id

@[simp] theorem eval_op {xs : List α} (a b : Expr xs) : eval s (Expr.op a b) = s.op (eval s a) (eval s b) := by
  induction xs with
  | nil =>
    match a, b with
    | nil, nil =>
      unfold eval
      rw [Algebra.op_left_id s.op]
  | cons x xs ihxs =>
    match a, b with
    | cons m a, cons n b =>
      induction m, n using Nat.recDiagOn with
      | zero_zero =>
        calc
        _ = eval s (Expr.op (Expr.cons 0 a) (Expr.cons 0 b)) := by rfl
        _ = eval s (Expr.cons (x:=x) (0 + 0) (Expr.op a b)) := by rw [Expr.op]
        _ = eval s (Expr.op a b) := by rw [eval_cons_zero]
        _ = s.op (eval s a) (eval s b) := by rw [ihxs a b]
        _ = s.op (eval s (cons 0 a)) (eval s b) := by rw [eval_cons_zero s a (x:=x)]
        _ = s.op (eval s (cons 0 a)) (eval s (cons 0 b)) := by rw [eval_cons_zero s b (x:=x)]
      | zero_succ n ih =>
        calc
        _ = eval s (Expr.op (cons 0 a) (cons (n + 1) b)) := rfl
        _ = eval s (cons (x:=x) (n + 1) (Expr.op a b)) := by rw [Expr.op, Nat.zero_add]
        _ = s.op x (eval s (cons n (Expr.op a b))) := by rw [eval_cons_succ]
        _ = s.op x (eval s ((Expr.op (cons 0 a) (cons n b)))) := by rw [Expr.op, Nat.zero_add]
        _ = s.op x (s.op (eval s (cons 0 a)) (eval s (cons n b))) := by rw [ih]
        _ = s.op (eval s (cons 0 a)) (s.op x (eval s (cons n b))) := by rw [Algebra.op_left_comm s.op]
        _ = s.op (eval s (cons 0 a)) (eval s (cons (n + 1) b)) := by rw [eval_cons_succ]
      | succ_zero m ih =>
        calc
        _ = eval s (Expr.op (cons (m + 1) a) (cons 0 b)) := rfl
        _ = eval s (cons (x:=x) (m + 1) (Expr.op a b)) := by rw [Expr.op]
        _ = s.op x (eval s (cons (m + 0) (Expr.op a b))) := by rw [eval_cons_succ, Nat.add_zero]
        _ = s.op x (eval s (Expr.op (cons m a) (cons 0 b))) := by rw [Expr.op]
        _ = s.op x (s.op (eval s (cons m a)) (eval s (cons 0 b))) := by rw [ih]
        _ = s.op (s.op x (eval s (cons m a))) (eval s (cons 0 b)) := by rw [Algebra.op_assoc s.op]
        _ = s.op (eval s (cons (m + 1) a)) (eval s (cons 0 b)) := by rw [eval_cons_succ]
      | succ_succ m n ih =>
        calc
        _ = eval s (Expr.op (cons (m + 1) a) (cons (n + 1) b)) := rfl
        _ = eval s (cons (x:=x) ((m + 1) + (n + 1)) (Expr.op a b)) := by rw [Expr.op]
        _ = eval s (cons (m + n + 1 + 1) (Expr.op a b)) := by rw [Nat.add_succ, Nat.succ_add]; rfl
        _ = s.op x (s.op x (eval s (cons (m + n) (Expr.op a b)))) := by rw [eval_cons_succ, eval_cons_succ]
        _ = s.op x (s.op x (eval s (Expr.op (cons m a) (cons n b)))) := by rw [Expr.op]
        _ = s.op x (s.op x (s.op (eval s (cons m a)) (eval s (cons n b)))) := by rw [ih]
        _ = s.op (s.op x x) (s.op (eval s (cons m a)) (eval s (cons n b))) := by rw [Algebra.op_assoc s.op]
        _ = s.op (s.op x (eval s (cons m a))) (s.op x (eval s (cons n b))) := by rw [Algebra.op_cross_comm s.op]
        _ = s.op (eval s (cons (m + 1) a)) (eval s (cons (n + 1) b)) := by rw [eval_cons_succ, eval_cons_succ]

end Eval

section Completeness

theorem op_assoc {α} : ∀ {xs : List α} (a b c : Expr xs), Expr.op (Expr.op a b) c = Expr.op a (Expr.op b c)
| [], _, _, _ => by unfold Expr.op; rfl
| _::_, cons l a, cons m b, cons n c => by simp only [Expr.op, Nat.add_assoc l m n, op_assoc a b c]

theorem op_comm {α} : ∀ {xs : List α} (a b : Expr xs), Expr.op a b = Expr.op b a
| [], _, _ => by unfold Expr.op; rfl
| _::_, cons m a, cons n b => by simp only [Expr.op, Nat.add_comm m n, op_comm a b]

theorem op_right_id {α} : ∀ {xs : List α} (a : Expr xs), Expr.op a Expr.id = a
| [], nil => by unfold Expr.op; rfl
| _::_, cons n a => by simp only [Expr.op, Nat.add_zero n, op_right_id a]

def sig {α} (xs : List α) : MonoidSig (Expr xs) where
  op := Expr.op
  id := Expr.id

instance {α} (xs : List α) : CommMonoid (sig xs) where
  op_assoc := op_assoc
  op_comm := op_comm
  op_right_id := op_right_id

end Completeness

end Expr

class Reflect {α} (s : MonoidSig α) (x : α) (xs : List α) where
  expr : Expr xs
  eval_eq : expr.eval s = x

protected def Reflect.eq {α} (s : MonoidSig α) (x xs) [inst : Reflect s x xs] : inst.expr.eval s = x := inst.eval_eq

namespace Reflect
variable {α} (s : MonoidSig α) [CommMonoid s]

class Var (x : α) (xs : List α) extends Reflect s x xs

instance (priority:=low) instVarLift (x y : α) (xs : List α) [Var s y xs] : Var s y (x :: xs) where
  expr := Expr.lift x (expr s y)
  eval_eq := by simp [eval_eq]

instance instVarSelf (x : α) (xs : List α) : Var s x (x :: xs) where
  expr := Expr.cons 1 Expr.id
  eval_eq := by simp; rw [Algebra.op_right_id s.op]

instance instId {xs : List α} : Reflect s (no_index (s.id)) xs where
  expr := Expr.id
  eval_eq := by simp

instance instOp (x y : α) {xs : List α} [Reflect s x xs] [Reflect s y xs] : Reflect s (no_index (s.op x y)) xs where
  expr := Expr.op (expr s x) (expr s y)
  eval_eq := by simp [eval_eq]

end Reflect

theorem reflect {α} (s : MonoidSig α) [CommMonoid s] (xs : List α) {a b : α} [Reflect s a xs] [Reflect s b xs] : Reflect.expr s a (xs:=xs) = Reflect.expr s b → a = b := by
  intro h
  rw [←Reflect.eq s a xs, ←Reflect.eq s b xs, h]

end Algebra.CommMonoid