/-  Math40001 : Introduction to university mathematics.

Problem Sheet 2, October 2019.

This is a Lean file. It can be read with the Lean theorem prover.

You can work on this file online at
https://tinyurl.com/Lean-M40001-Example-Sheet-2

or you can install Lean and its maths library following the
instructions at
https://github.com/leanprover-community/mathlib#installation

There are advantages to installing Lean on your own computer
(for example it's faster), but it's more hassle than
just using it online.

In the below, delete "sorry" and replace it with some
tactics which prove the result.

-/

import data.real.basic -- need real numbers for Q5

-- Q1 prove that ∩ is symmetric
lemma question1 (Ω : Type) (X Y : set Ω) : X ∩ Y = Y ∩ X :=
begin
  sorry
end

-- Q2 we define the set U
def U : set ℕ := {1, 2, 3, 4, 5}

/- and then five of the questions still make sense
   in type theory, and the other three don't.
   What I'm saying is that b,f,g would continue to be
   wrong even if you changed the numbers around, because
   the questions do not even typecheck: U only contains
   numbers, and b, f, g are asking if a non-number is
   in U.

   For the remaining five questions, if you think they're
   false then change `_true` to `_false` and add a ¬ in front.
-/

lemma question2a_true : 1 ∈ U :=
begin
  sorry
end

lemma question2c_true : {1} ⊆ U :=
begin
  sorry
end

lemma question2d_true : {1, 2} ⊆ U :=
begin
  sorry
end

lemma question2e_true : {1, 2, 1} ⊆ U :=
begin
  sorry
end

lemma question2h_true : U ⊇ U :=
begin
  sorry
end

-- question 3 defs
def A := {x : ℝ | x ^ 2 < 3}
def B := {x : ℝ | ∃ n : ℤ, x = n ∧ x ^ 2 < 3}
def C := {x : ℝ | x ^ 3 < 3}

-- like Q2, change _true to _false and put a ¬ in front
-- of the goal if you think it's false.

lemma question3a_true : (1 : ℝ)/2 ∈ A ∩ B :=
begin
  sorry
end

lemma question3b_true : (1 : ℝ)/2 ∈ A ∪ B :=
begin
  sorry
end

lemma question3c_true : A ⊆ C :=
begin
  sorry
end

lemma question3d_true : B ⊆ C :=
begin
  sorry
end

lemma question3e_true : C ⊆ A ∪ B :=
begin
  sorry
end

lemma question3f_true : (A ∩ B) ∪ C = (A ∪ B) ∩ C :=
begin
  sorry
end

-- Q4 set-up
variables (X Y : Type)
variable (P : X → Prop)
variable (Q : X → Prop)
variable (R : X → Y → Prop)

-- for Q4 you're going to have to change the right hand
-- side of the ↔ in the statement
-- of the lemma to the answer you think is correct.

lemma question4a : ¬ (∀ x : X, P x ∧ ¬ Q x) ↔ true := -- change `true`!
begin
  sorry
end

lemma question4b : ¬ (∃ x : X, (¬ P x) ∧ Q x) ↔ true := -- change `true`!
begin
  sorry
end

lemma question4c : ¬ (∀ x : X, ∃ y : Y, R x y) ↔ true := -- change `true`!
begin
  sorry
end

example (f : ℝ → ℝ) (x : ℝ) :
  ¬ (∀ ε : ℝ, ε > 0 → ∃ δ : ℝ, δ > 0 → ∀ y : ℝ, abs (y - x) < δ → abs (f y -f x) < ε )
↔ -- change next line
true :=
begin
  sorry
end

-- change _true to _false in 5a, 5b if you think the opposite is true.
lemma question5a_true : ∀ x : ℝ, ∃ y : ℝ, x + y = 2 :=
begin
  sorry
end

lemma question5b_true : ∃ y : ℝ, ∀ x : ℝ, x + y = 2 :=
begin
  sorry
end

-- similarly for Q6 -- change _true to _false and add in a negation if you
-- want to prove that the proposition in the question is false.
lemma question6a_true : ∃ x ∈ (∅ : set ℕ), 2 + 2 = 5 :=
begin
  sorry
end

lemma question6b_true : ∀ x ∈ (∅ : set ℕ), 2 + 2 = 5 :=
begin
  sorry
end


-- Formulación equivalente de lemas con dos hipótesis
-- ==================================================

-- Demostrar que
--    (P ∧ Q → R) ↔ (P → (Q → R))

import tactic

variables (P Q R : Prop)

-- 1ª demostración
-- ===============

example : (P ∧ Q → R) ↔ (P → (Q → R)) :=
begin
  split,
  { intros h hP hQ,
    exact h ⟨hP, hQ⟩, },
  { rintro h ⟨hP, hQ⟩,
    exact h hP hQ, },
end

-- 2ª demostración
-- ===============

example : (P ∧ Q → R) ↔ (P → (Q → R)) :=
iff.intro (λ h hP hQ, h ⟨hP, hQ⟩)
          (λ h ⟨hP, hQ⟩, h hP hQ)

-- 3ª demostración
-- ===============

example : (P ∧ Q → R) ↔ (P → (Q → R)) :=
and_imp

-- 4ª demostración
-- ===============

example : (P ∧ Q → R) ↔ (P → (Q → R)) :=
by simp

-- 5ª demostración
-- ===============

example : (P ∧ Q → R) ↔ (P → (Q → R)) :=
by finish


/-
Copyright (c) 2021 Chris Birkbeck. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Chris Birkbeck
-/
import linear_algebra.matrix.nonsingular_inverse
import linear_algebra.special_linear_group

/-!
# The General Linear group $GL(n, R)$

This file defines the elements of the General Linear group `general_linear_group n R`,
consisting of all invertible `n` by `n` `R`-matrices.

## Main definitions

* `matrix.general_linear_group` is the type of matrices over R which are units in the matrix ring.
* `matrix.GL_pos` gives the subgroup of matrices with
  positive determinant (over a linear ordered ring).

## Tags

matrix group, group, matrix inverse
-/

namespace matrix
universes u v
open_locale matrix
open linear_map

-- disable this instance so we do not accidentally use it in lemmas.
local attribute [-instance] special_linear_group.has_coe_to_fun

/-- `GL n R` is the group of `n` by `n` `R`-matrices with unit determinant.
Defined as a subtype of matrices-/
abbreviation general_linear_group (n : Type u) (R : Type v)
  [decidable_eq n] [fintype n] [comm_ring R] : Type* := (matrix n n R)ˣ

notation `GL` := general_linear_group

namespace general_linear_group

variables {n : Type u} [decidable_eq n] [fintype n] {R : Type v} [comm_ring R]

/-- The determinant of a unit matrix is itself a unit. -/
@[simps]
def det : GL n R →* Rˣ :=
{ to_fun := λ A,
  { val := (↑A : matrix n n R).det,
    inv := (↑(A⁻¹) : matrix n n R).det,
    val_inv := by rw [←det_mul, ←mul_eq_mul, A.mul_inv, det_one],
    inv_val := by rw [←det_mul, ←mul_eq_mul, A.inv_mul, det_one]},
  map_one' := units.ext det_one,
  map_mul' := λ A B, units.ext $ det_mul _ _ }

/--The `GL n R` and `general_linear_group R n` groups are multiplicatively equivalent-/
def to_lin : (GL n R) ≃* (linear_map.general_linear_group R (n → R)) :=
units.map_equiv to_lin_alg_equiv'.to_mul_equiv

/--Given a matrix with invertible determinant we get an element of `GL n R`-/
def mk' (A : matrix n n R) (h : invertible (matrix.det A)) : GL n R :=
unit_of_det_invertible A

/--Given a matrix with unit determinant we get an element of `GL n R`-/
noncomputable def mk'' (A : matrix n n R) (h : is_unit (matrix.det A)) : GL n R :=
nonsing_inv_unit A h

/--Given a matrix with non-zero determinant over a field, we get an element of `GL n K`-/
def mk_of_det_ne_zero {K : Type*} [field K] (A : matrix n n K) (h : matrix.det A ≠ 0) :
  GL n K :=
mk' A (invertible_of_nonzero h)

lemma ext_iff (A B : GL n R) : A = B ↔ (∀ i j, (A : matrix n n R) i j = (B : matrix n n R) i j) :=
units.ext_iff.trans matrix.ext_iff.symm

/-- Not marked `@[ext]` as the `ext` tactic already solves this. -/
lemma ext ⦃A B : GL n R⦄ (h : ∀ i j, (A : matrix n n R) i j = (B : matrix n n R) i j) :
  A = B :=
units.ext $ matrix.ext h

section coe_lemmas

variables (A B : GL n R)

@[simp] lemma coe_mul : ↑(A * B) = (↑A : matrix n n R) ⬝ (↑B : matrix n n R) := rfl

@[simp] lemma coe_one : ↑(1 : GL n R) = (1 : matrix n n R) := rfl

lemma coe_inv : ↑(A⁻¹) = (↑A : matrix n n R)⁻¹ :=
begin
  letI := A.invertible,
  exact inv_of_eq_nonsing_inv (↑A : matrix n n R),
end

/-- An element of the matrix general linear group on `(n) [fintype n]` can be considered as an
element of the endomorphism general linear group on `n → R`. -/
def to_linear : general_linear_group n R ≃* linear_map.general_linear_group R (n → R) :=
units.map_equiv matrix.to_lin_alg_equiv'.to_ring_equiv.to_mul_equiv

-- Note that without the `@` and `‹_›`, lean infers `λ a b, _inst_1 a b` instead of `_inst_1` as the
-- decidability argument, which prevents `simp` from obtaining the instance by unification.
-- These `λ a b, _inst a b` terms also appear in the type of `A`, but simp doesn't get confused by
-- them so for now we do not care.
@[simp] lemma coe_to_linear :
  (@to_linear n ‹_› ‹_› _ _ A : (n → R) →ₗ[R] (n → R)) = matrix.mul_vec_lin A :=
rfl

@[simp] lemma to_linear_apply (v : n → R) :
  (@to_linear n ‹_› ‹_› _ _ A) v = matrix.mul_vec_lin ↑A v :=
rfl

end coe_lemmas

end general_linear_group

namespace special_linear_group

variables {n : Type u} [decidable_eq n] [fintype n] {R : Type v} [comm_ring R]

instance has_coe_to_general_linear_group : has_coe (special_linear_group n R) (GL n R) :=
⟨λ A, ⟨↑A, ↑(A⁻¹), congr_arg coe (mul_right_inv A), congr_arg coe (mul_left_inv A)⟩⟩

end special_linear_group

section

variables {n : Type u} {R : Type v} [decidable_eq n] [fintype n] [linear_ordered_comm_ring R ]

section
variables (n R)

/-- This is the subgroup of `nxn` matrices with entries over a
linear ordered ring and positive determinant. -/
def GL_pos : subgroup (GL n R) :=
(units.pos_subgroup R).comap general_linear_group.det
end

@[simp] lemma mem_GL_pos (A : GL n R) : A ∈ GL_pos n R ↔ 0 < (A.det : R) := iff.rfl
end

section has_neg

variables {n : Type u} {R : Type v} [decidable_eq n] [fintype n] [linear_ordered_comm_ring R ]
[fact (even (fintype.card n))]

/-- Formal operation of negation on general linear group on even cardinality `n` given by negating
each element. -/
instance : has_neg (GL_pos n R) :=
⟨λ g, ⟨-g, begin
    rw [mem_GL_pos, general_linear_group.coe_det_apply, units.coe_neg, det_neg,
      nat.neg_one_pow_of_even (fact.out (even (fintype.card n))), one_mul],
    exact g.prop,
  end⟩⟩

instance : has_distrib_neg (GL_pos n R) :=
{ neg := has_neg.neg,
  neg_neg := λ x, subtype.ext $ neg_neg _,
  neg_mul := λ x y, subtype.ext $ neg_mul _ _,
  mul_neg := λ x y, subtype.ext $ mul_neg _ _ }

@[simp] lemma GL_pos.coe_neg (g : GL_pos n R) : ↑(- g) = - (↑g : matrix n n R) :=
rfl

@[simp] lemma GL_pos.coe_neg_apply (g : GL_pos n R) (i j : n) :
  (↑(-g) : matrix n n R) i j = -((↑g : matrix n n R) i j) :=
rfl

end has_neg

namespace special_linear_group

variables {n : Type u} [decidable_eq n] [fintype n] {R : Type v} [linear_ordered_comm_ring R]

/-- `special_linear_group n R` embeds into `GL_pos n R` -/
def to_GL_pos : special_linear_group n R →* GL_pos n R :=
{ to_fun := λ A, ⟨(A : GL n R), show 0 < (↑A : matrix n n R).det, from A.prop.symm ▸ zero_lt_one⟩,
  map_one' := subtype.ext $ units.ext $ rfl,
  map_mul' := λ A₁ A₂, subtype.ext $ units.ext $ rfl }

instance : has_coe (special_linear_group n R) (GL_pos n R) := ⟨to_GL_pos⟩

lemma coe_eq_to_GL_pos : (coe : special_linear_group n R → GL_pos n R) = to_GL_pos := rfl

lemma to_GL_pos_injective :
  function.injective (to_GL_pos : special_linear_group n R → GL_pos n R) :=
(show function.injective ((coe : GL_pos n R → matrix n n R) ∘ to_GL_pos),
 from subtype.coe_injective).of_comp

end special_linear_group

section examples

/-- The matrix [a, b; -b, a] (inspired by multiplication by a complex number); it is an element of
$GL_2(R)$ if `a ^ 2 + b ^ 2` is nonzero. -/
@[simps coe {fully_applied := ff}]
def plane_conformal_matrix {R} [field R] (a b : R) (hab : a ^ 2 + b ^ 2 ≠ 0) :
  matrix.general_linear_group (fin 2) R :=
general_linear_group.mk_of_det_ne_zero ![![a, -b], ![b, a]]
  (by simpa [det_fin_two, sq] using hab)

/- TODO: Add Iwasawa matrices `n_x=![![1,x],![0,1]]`, `a_t=![![exp(t/2),0],![0,exp(-t/2)]]` and
  `k_θ==![![cos θ, sin θ],![-sin θ, cos θ]]`
-/

end examples

namespace general_linear_group
variables {n : Type u} [decidable_eq n] [fintype n] {R : Type v} [comm_ring R]

-- this section should be last to ensure we do not use it in lemmas
section coe_fn_instance

/-- This instance is here for convenience, but is not the simp-normal form. -/
instance : has_coe_to_fun (GL n R) (λ _, n → n → R) :=
{ coe := λ A, A.val }

@[simp] lemma coe_fn_eq_coe (A : GL n R) : ⇑A = (↑A : matrix n n R) := rfl

end coe_fn_instance

end general_linear_group

end matrix


variable data : Type

variables
L15_E R15_E L16_E R16_E
L0_D  R0_D  L1_D  R1_D
K_16                    : data

variable xor (d1 d2 : data) : data
variable f (d k : data) : data

premise xor_assoc (x1 x2 x3 : data) :
(xor (xor x1 x2) x3) = (xor x1 (xor x2 x3))

premise xor_cancel : ∀ x1 x2 : data, xor x1 (xor x2 x2) = x1

premise H1        : L16_E = R15_E
premise H2        : R16_E = xor L15_E (f R15_E K_16)
premise H3        : L0_D  = R16_E
premise H4        : R0_D  = L16_E
premise H5        : L1_D  = R0_D
premise H6        : R1_D  = xor L0_D (f R0_D K_16)

theorem ProofRight_Long : R15_E = L1_D :=
have H7  : R15_E = L16_E, from eq.symm  H1,
have H8  : L16_E = R0_D,  from eq.symm  H4,
have H9  : R0_D  = L1_D,  from eq.symm  H5,
have H10 : R15_E = R0_D,  from eq.trans H7  H8,
show       R15_E = L1_D,  from eq.trans H10 H9

theorem ProofLeft : L15_E = R1_D :=
have H11 : R1_D = xor L0_D  (f R0_D  K_16), from H6,
have H12 : R1_D = xor R16_E (f R0_D  K_16), from eq.subst H3 H11,
have H13 : R1_D = xor R16_E (f L16_E K_16), from eq.subst H4 H12,
have H14 : R1_D = xor R16_E (f R15_E K_16), from eq.subst H1 H13,
have H15 : R1_D = xor (xor L15_E (f R15_E K_16)) (f R15_E K_16),
    from eq.subst H2 H14,
have H16 : xor (xor L15_E (f R15_E K_16)) (f R15_E K_16) =
           xor L15_E (xor (f R15_E K_16) (f R15_E K_16)),
    from xor_assoc L15_E (f R15_E K_16) (f R15_E K_16),
have H17 : R1_D = xor L15_E (xor (f R15_E K_16) (f R15_E K_16)),
    from eq.trans H15 H16,
have H18 : xor L15_E (xor (f R15_E K_16) (f R15_E K_16)) = L15_E,
    from xor_cancel L15_E (f R15_E K_16),
show L15_E = R1_D, from eq.symm (eq.trans H17 H18)


-- do I use a section? What even is a section?
-- so I use a namespace? What would a sensible convention be?
-- I don't care about junk like imports at the beginning of files

-- This file is for undergraduate mathematicians who want to see the
-- proof that one of the axioms that Lean uses to define a group
-- actually follows from the others!

-- G comes with notation * (group law) 1 (identiy) and a⁻¹ (inverse)
-- mul : G → G → G := λ g h, g * h
-- one : G := 1
-- inv : G → G := λ a, a⁻¹

class has_group_notation (G : Type)
  extends has_mul G, has_one G, has_inv G

class group' (G : Type) extends has_group_notation G :=
(mul_assoc : ∀ (a b c : G), a * b * c = a * (b * c))
(one_mul : ∀ (a : G), 1 * a = a)
(mul_left_inv : ∀ (a : G), a⁻¹ * a = 1)

variables {G : Type} [group' G]
-- variables (H : Type) [has_mul H] [has_one H] [has_inv H]

-- We prove left_mul_cancel for group'

namespace group'
lemma mul_left_cancel : ∀ (a b c : G), a * b = a * c → b = c :=
λ a b c Habac,
 calc b = 1 * b         : by rw one_mul
    ... = (a⁻¹ * a) * b : by rw mul_left_inv
    ... = a⁻¹ * (a * b) : by rw mul_assoc
    ... = a⁻¹ * (a * c) : by rw Habac
    ... = (a⁻¹ * a) * c : by rw mul_assoc
    ... = 1 * c         : by rw mul_left_inv
                ... = c : by rw one_mul

-- why do I seem to have to fill in far more blanks with _ in term mode?

theorem group'.mul_one : ∀ (a : G), a * 1 = a :=
begin
intro a,
 apply group'.mul_left_cancel a⁻¹,
 rw [←group'.mul_assoc,group'.mul_left_inv,group'.one_mul],
end

-- other than the group' everywhere, I really like how this came out.
-- You can really clearly see the unique point in the proof where type
-- unification can't guess the variable.

#exit

-- thoughts about canonical isomorphism
import data.equiv
theorem group'_canonically_isomorphic_to_group (G : Type) : equiv [group' G] [group G] :=
⟨_,_,_,_⟩


import data.nat.prime data.finset
open nat

def island_rules : ℕ → ℕ → (ℕ → Prop)
| 0       b B := (B = b ∨ B = b - 1) ∧ B > 0
| (d + 1) b B := island_rules d b B ∧
 ((∀ C, island_rules d b C → C = b) ↔ ∀ C, island_rules d B C → C = B)

def island_rules2 : ℕ → ℕ → finset ℕ
| 0     b := ({b - 1, b} : finset ℕ).filter (> 0)
| (d+1) b := (island_rules2 d b).filter
  (λ B, (∀ C ∈ island_rules2 d b, C = b) ↔ (∀ C ∈ island_rules2 d B, C = B))

#eval island_rules2 5 7 -- {6, 7}
#eval island_rules2 6 7 -- {7}

lemma island_rules_iff (d : ℕ) : ∀ b B, island_rules d b B ↔ B ∈ island_rules2 d b :=
by induction d; simp [island_rules, island_rules2, *]; finish

instance (d b B) : decidable (island_rules d b B) :=
decidable_of_iff _ (island_rules_iff _ _ _).symm

lemma island_rules_iff' (d : ℕ) : ∀ b, (∀ B, island_rules d b B → B = b) ↔ (∀ B ∈ island_rules2 d b, B = b) :=
by simp [island_rules_iff]

instance dec2 : decidable_rel (λ d b, ∀ B, island_rules d b B → B = b) :=
λ d b, decidable_of_iff _ (island_rules_iff' d b).symm

lemma blue_eyed_islander : ∀ d < 100, (∀ B, island_rules d 100 B → B = 100) ↔ d = 99 :=
dec_trivial


/-
Copyright (c) 2016 Jeremy Avigad. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jeremy Avigad, Leonardo de Moura, Mario Carneiro, Johannes Hölzl

! This file was ported from Lean 3 source module algebra.order.group.with_top
! leanprover-community/mathlib commit 448144f7ae193a8990cb7473c9e9a01990f64ac7
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Algebra.Order.Group.Instances
import Mathbin.Algebra.Order.Monoid.WithTop

/-!
# Adjoining a top element to a `linear_ordered_add_comm_group_with_top`.

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

variable {α : Type _}

section LinearOrderedAddCommGroup

variable [LinearOrderedAddCommGroup α] {a b c d : α}

#print WithTop.linearOrderedAddCommGroupWithTop /-
instance WithTop.linearOrderedAddCommGroupWithTop : LinearOrderedAddCommGroupWithTop (WithTop α) :=
  { WithTop.linearOrderedAddCommMonoidWithTop,
    Option.nontrivial with
    neg := Option.map fun a : α => -a
    neg_top := @Option.map_none _ _ fun a : α => -a
    add_neg_cancel := by
      rintro (a | a) ha
      · exact (ha rfl).elim
      · exact with_top.coe_add.symm.trans (WithTop.coe_eq_coe.2 (add_neg_self a)) }
#align with_top.linear_ordered_add_comm_group_with_top WithTop.linearOrderedAddCommGroupWithTop
-/

/- warning: with_top.coe_neg -> WithTop.coe_neg is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} [_inst_1 : LinearOrderedAddCommGroup.{u1} α] (a : α), Eq.{succ u1} (WithTop.{u1} α) ((fun (a : Type.{u1}) (b : Type.{u1}) [self : HasLiftT.{succ u1, succ u1} a b] => self.0) α (WithTop.{u1} α) (HasLiftT.mk.{succ u1, succ u1} α (WithTop.{u1} α) (CoeTCₓ.coe.{succ u1, succ u1} α (WithTop.{u1} α) (WithTop.hasCoeT.{u1} α))) (Neg.neg.{u1} α (SubNegMonoid.toHasNeg.{u1} α (AddGroup.toSubNegMonoid.{u1} α (AddCommGroup.toAddGroup.{u1} α (OrderedAddCommGroup.toAddCommGroup.{u1} α (LinearOrderedAddCommGroup.toOrderedAddCommGroup.{u1} α _inst_1))))) a)) (Neg.neg.{u1} (WithTop.{u1} α) (SubNegMonoid.toHasNeg.{u1} (WithTop.{u1} α) (LinearOrderedAddCommGroupWithTop.toSubNegMonoid.{u1} (WithTop.{u1} α) (WithTop.linearOrderedAddCommGroupWithTop.{u1} α _inst_1))) ((fun (a : Type.{u1}) (b : Type.{u1}) [self : HasLiftT.{succ u1, succ u1} a b] => self.0) α (WithTop.{u1} α) (HasLiftT.mk.{succ u1, succ u1} α (WithTop.{u1} α) (CoeTCₓ.coe.{succ u1, succ u1} α (WithTop.{u1} α) (WithTop.hasCoeT.{u1} α))) a))
but is expected to have type
  forall {α : Type.{u1}} [_inst_1 : LinearOrderedAddCommGroup.{u1} α] (a : α), Eq.{succ u1} (WithTop.{u1} α) (WithTop.some.{u1} α (Neg.neg.{u1} α (NegZeroClass.toNeg.{u1} α (SubNegZeroMonoid.toNegZeroClass.{u1} α (SubtractionMonoid.toSubNegZeroMonoid.{u1} α (SubtractionCommMonoid.toSubtractionMonoid.{u1} α (AddCommGroup.toDivisionAddCommMonoid.{u1} α (OrderedAddCommGroup.toAddCommGroup.{u1} α (LinearOrderedAddCommGroup.toOrderedAddCommGroup.{u1} α _inst_1))))))) a)) (Neg.neg.{u1} (WithTop.{u1} α) (LinearOrderedAddCommGroupWithTop.toNeg.{u1} (WithTop.{u1} α) (WithTop.linearOrderedAddCommGroupWithTop.{u1} α _inst_1)) (WithTop.some.{u1} α a))
Case conversion may be inaccurate. Consider using '#align with_top.coe_neg WithTop.coe_negₓ'. -/
@[simp, norm_cast]
theorem WithTop.coe_neg (a : α) : ((-a : α) : WithTop α) = -a :=
  rfl
#align with_top.coe_neg WithTop.coe_neg

end LinearOrderedAddCommGroup


/-
Copyright (c) 2020 Aaron Anderson. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Aaron Anderson
-/

import linear_algebra.span
import order.atoms

/-!
# Simple Modules

## Main Definitions
  * `is_simple_module` indicates that a module has no proper submodules
  (the only submodules are `⊥` and `⊤`).
  * `is_semisimple_module` indicates that every submodule has a complement, or equivalently,
    the module is a direct sum of simple modules.
  * A `division_ring` structure on the endomorphism ring of a simple module.

## Main Results
  * Schur's Lemma: `bijective_or_eq_zero` shows that a linear map between simple modules
  is either bijective or 0, leading to a `division_ring` structure on the endomorphism ring.

## TODO
  * Artin-Wedderburn Theory
  * Unify with the work on Schur's Lemma in a category theory context

-/

variables (R : Type*) [ring R] (M : Type*) [add_comm_group M] [module R M]

/-- A module is simple when it has only two submodules, `⊥` and `⊤`. -/
abbreviation is_simple_module := (is_simple_order (submodule R M))

/-- A module is semisimple when every submodule has a complement, or equivalently, the module
  is a direct sum of simple modules. -/
abbreviation is_semisimple_module := (is_complemented (submodule R M))

-- Making this an instance causes the linter to complain of "dangerous instances"
theorem is_simple_module.nontrivial [is_simple_module R M] : nontrivial M :=
⟨⟨0, begin
  have h : (⊥ : submodule R M) ≠ ⊤ := bot_ne_top,
  contrapose! h,
  ext,
  simp [submodule.mem_bot,submodule.mem_top, h x],
end⟩⟩

variables {R} {M} {m : submodule R M} {N : Type*} [add_comm_group N] [module R N]

theorem is_simple_module_iff_is_atom :
  is_simple_module R m ↔ is_atom m :=
begin
  rw ← set.is_simple_order_Iic_iff_is_atom,
  apply order_iso.is_simple_order_iff,
  exact submodule.map_subtype.rel_iso m,
end

namespace is_simple_module

variable [hm : is_simple_module R m]

@[simp]
lemma is_atom : is_atom m := is_simple_module_iff_is_atom.1 hm

end is_simple_module

theorem is_semisimple_of_Sup_simples_eq_top
  (h : Sup {m : submodule R M | is_simple_module R m} = ⊤) :
  is_semisimple_module R M :=
is_complemented_of_Sup_atoms_eq_top (by simp_rw [← h, is_simple_module_iff_is_atom])

namespace is_semisimple_module

variable [is_semisimple_module R M]

theorem Sup_simples_eq_top : Sup {m : submodule R M | is_simple_module R m} = ⊤ :=
begin
  simp_rw is_simple_module_iff_is_atom,
  exact Sup_atoms_eq_top,
end

instance is_semisimple_submodule {m : submodule R M} : is_semisimple_module R m :=
begin
  have f : submodule R m ≃o set.Iic m := submodule.map_subtype.rel_iso m,
  exact f.is_complemented_iff.2 is_modular_lattice.is_complemented_Iic,
end

end is_semisimple_module

theorem is_semisimple_iff_top_eq_Sup_simples :
  Sup {m : submodule R M | is_simple_module R m} = ⊤ ↔ is_semisimple_module R M :=
⟨is_semisimple_of_Sup_simples_eq_top, by { introI, exact is_semisimple_module.Sup_simples_eq_top }⟩

namespace linear_map

theorem injective_or_eq_zero [is_simple_module R M] (f : M →ₗ[R] N) :
  function.injective f ∨ f = 0 :=
begin
  rw [← ker_eq_bot, ← ker_eq_top],
  apply eq_bot_or_eq_top,
end

theorem injective_of_ne_zero [is_simple_module R M] {f : M →ₗ[R] N} (h : f ≠ 0) :
  function.injective f :=
f.injective_or_eq_zero.resolve_right h

theorem surjective_or_eq_zero [is_simple_module R N] (f : M →ₗ[R] N) :
  function.surjective f ∨ f = 0 :=
begin
  rw [← range_eq_top, ← range_eq_bot, or_comm],
  apply eq_bot_or_eq_top,
end

theorem surjective_of_ne_zero [is_simple_module R N] {f : M →ₗ[R] N} (h : f ≠ 0) :
  function.surjective f :=
f.surjective_or_eq_zero.resolve_right h

/-- **Schur's Lemma** for linear maps between (possibly distinct) simple modules -/
theorem bijective_or_eq_zero [is_simple_module R M] [is_simple_module R N]
  (f : M →ₗ[R] N) :
  function.bijective f ∨ f = 0 :=
begin
  by_cases h : f = 0,
  { right,
    exact h },
  exact or.intro_left _ ⟨injective_of_ne_zero h, surjective_of_ne_zero h⟩,
end

theorem bijective_of_ne_zero [is_simple_module R M] [is_simple_module R N]
  {f : M →ₗ[R] N} (h : f ≠ 0):
  function.bijective f :=
f.bijective_or_eq_zero.resolve_right h

/-- Schur's Lemma makes the endomorphism ring of a simple module a division ring. -/
noncomputable instance _root_.module.End.division_ring
  [decidable_eq (module.End R M)] [is_simple_module R M] :
  division_ring (module.End R M) :=
{ inv := λ f, if h : f = 0 then 0 else (linear_map.inverse f
    (equiv.of_bijective _ (bijective_of_ne_zero h)).inv_fun
    (equiv.of_bijective _ (bijective_of_ne_zero h)).left_inv
    (equiv.of_bijective _ (bijective_of_ne_zero h)).right_inv),
  exists_pair_ne := ⟨0, 1, begin
    haveI := is_simple_module.nontrivial R M,
    have h := exists_pair_ne M,
    contrapose! h,
    intros x y,
    simp_rw [ext_iff, one_apply, zero_apply] at h,
    rw [← h x, h y],
  end⟩,
  mul_inv_cancel := begin
    intros a a0,
    change (a * (dite _ _ _)) = 1,
    ext,
    rw [dif_neg a0, mul_eq_comp, one_apply, comp_apply],
    exact (equiv.of_bijective _ (bijective_of_ne_zero a0)).right_inv x,
  end,
  inv_zero := dif_pos rfl,
.. (module.End.ring : ring (module.End R M))}

end linear_map


/-
Copyright (c) 2016 Jeremy Avigad. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jeremy Avigad
-/

import data.int.order.basic
import data.int.units
import algebra.group_power.order

/-!
# Lemmas about units in `ℤ`, which interact with the order structure.

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

namespace int

lemma is_unit_iff_abs_eq {x : ℤ} : is_unit x ↔ abs x = 1 :=
by rw [is_unit_iff_nat_abs_eq, abs_eq_nat_abs, ←int.coe_nat_one, coe_nat_inj']

lemma is_unit_sq {a : ℤ} (ha : is_unit a) : a ^ 2 = 1 :=
by rw [sq, is_unit_mul_self ha]

@[simp] lemma units_sq (u : ℤˣ) : u ^ 2 = 1 :=
by rw [units.ext_iff, units.coe_pow, units.coe_one, is_unit_sq u.is_unit]

alias units_sq ← units_pow_two

@[simp] lemma units_mul_self (u : ℤˣ) : u * u = 1 :=
by rw [←sq, units_sq]

@[simp] lemma units_inv_eq_self (u : ℤˣ) : u⁻¹ = u :=
by rw [inv_eq_iff_mul_eq_one, units_mul_self]

-- `units.coe_mul` is a "wrong turn" for the simplifier, this undoes it and simplifies further
@[simp]

@[simp] lemma neg_one_pow_ne_zero {n : ℕ} : (-1 : ℤ)^n ≠ 0 :=
pow_ne_zero _ (abs_pos.mp (by simp))

lemma sq_eq_one_of_sq_lt_four {x : ℤ} (h1 : x ^ 2 < 4) (h2 : x ≠ 0) : x ^ 2 = 1 :=
sq_eq_one_iff.mpr ((abs_eq (zero_le_one' ℤ)).mp (le_antisymm (lt_add_one_iff.mp
  (abs_lt_of_sq_lt_sq h1 zero_le_two)) (sub_one_lt_iff.mp (abs_pos.mpr h2))))

lemma sq_eq_one_of_sq_le_three {x : ℤ} (h1 : x ^ 2 ≤ 3) (h2 : x ≠ 0) : x ^ 2 = 1 :=
sq_eq_one_of_sq_lt_four (lt_of_le_of_lt h1 (lt_add_one 3)) h2

lemma units_pow_eq_pow_mod_two (u : ℤˣ) (n : ℕ) : u ^ n = u ^ (n % 2) :=
by conv {to_lhs, rw ← nat.mod_add_div n 2}; rw [pow_add, pow_mul, units_sq, one_pow, mul_one]

end int


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import algebra.algebra.basic
import ring_theory.ideal.quotient

/-!
# Quotients of non-commutative rings

Unfortunately, ideals have only been developed in the commutative case as `ideal`,
and it's not immediately clear how one should formalise ideals in the non-commutative case.

In this file, we directly define the quotient of a semiring by any relation,
by building a bigger relation that represents the ideal generated by that relation.

We prove the universal properties of the quotient, and recommend avoiding relying on the actual
definition, which is made irreducible for this purpose.

Since everything runs in parallel for quotients of `R`-algebras, we do that case at the same time.
-/

universes u₁ u₂ u₃ u₄

variables {R : Type u₁} [semiring R]
variables {S : Type u₂} [comm_semiring S]
variables {A : Type u₃} [semiring A] [algebra S A]

namespace ring_quot

/--
Given an arbitrary relation `r` on a ring, we strengthen it to a relation `rel r`,
such that the equivalence relation generated by `rel r` has `x ~ y` if and only if
`x - y` is in the ideal generated by elements `a - b` such that `r a b`.
-/
inductive rel (r : R → R → Prop) : R → R → Prop
| of ⦃x y : R⦄ (h : r x y) : rel x y
| add_left ⦃a b c⦄ : rel a b → rel (a + c) (b + c)
| mul_left ⦃a b c⦄ : rel a b → rel (a * c) (b * c)
| mul_right ⦃a b c⦄ : rel b c → rel (a * b) (a * c)

theorem rel.add_right {r : R → R → Prop} ⦃a b c : R⦄ (h : rel r b c) : rel r (a + b) (a + c) :=
by { rw [add_comm a b, add_comm a c], exact rel.add_left h }

theorem rel.neg {R : Type u₁} [ring R] {r : R → R → Prop} ⦃a b : R⦄ (h : rel r a b) :
  rel r (-a) (-b) :=
by simp only [neg_eq_neg_one_mul a, neg_eq_neg_one_mul b, rel.mul_right h]

theorem rel.sub_left {R : Type u₁} [ring R] {r : R → R → Prop} ⦃a b c : R⦄ (h : rel r a b) :
  rel r (a - c) (b - c) :=
by simp only [sub_eq_add_neg, h.add_left]

theorem rel.sub_right {R : Type u₁} [ring R] {r : R → R → Prop} ⦃a b c : R⦄ (h : rel r b c) :
  rel r (a - b) (a - c) :=
by simp only [sub_eq_add_neg, h.neg.add_right]

theorem rel.smul {r : A → A → Prop} (k : S) ⦃a b : A⦄ (h : rel r a b) : rel r (k • a) (k • b) :=
by simp only [algebra.smul_def, rel.mul_right h]

end ring_quot

/-- The quotient of a ring by an arbitrary relation. -/
structure ring_quot (r : R → R → Prop) :=
(to_quot : quot (ring_quot.rel r))

namespace ring_quot

variable (r : R → R → Prop)

@[irreducible] private def zero : ring_quot r := ⟨quot.mk _ 0⟩
@[irreducible] private def one : ring_quot r := ⟨quot.mk _ 1⟩
@[irreducible] private def add : ring_quot r → ring_quot r → ring_quot r
| ⟨a⟩ ⟨b⟩ := ⟨quot.map₂ (+) rel.add_right rel.add_left a b⟩
@[irreducible] private def mul : ring_quot r → ring_quot r → ring_quot r
| ⟨a⟩ ⟨b⟩ := ⟨quot.map₂ (*) rel.mul_right rel.mul_left a b⟩
@[irreducible] private def neg {R : Type u₁} [ring R] (r : R → R → Prop) : ring_quot r → ring_quot r
| ⟨a⟩:= ⟨quot.map (λ a, -a) rel.neg a⟩
@[irreducible] private def sub {R : Type u₁} [ring R] (r : R → R → Prop) :
  ring_quot r → ring_quot r → ring_quot r
| ⟨a⟩ ⟨b⟩ := ⟨quot.map₂ has_sub.sub rel.sub_right rel.sub_left a b⟩
@[irreducible] private def smul [algebra S R] (n : S) : ring_quot r → ring_quot r
| ⟨a⟩ := ⟨quot.map (λ a, n • a) (rel.smul n) a⟩

instance : has_zero (ring_quot r) := ⟨zero r⟩
instance : has_one (ring_quot r) := ⟨one r⟩
instance : has_add (ring_quot r) := ⟨add r⟩
instance : has_mul (ring_quot r) := ⟨mul r⟩
instance {R : Type u₁} [ring R] (r : R → R → Prop) : has_neg (ring_quot r) := ⟨neg r⟩
instance {R : Type u₁} [ring R] (r : R → R → Prop) : has_sub (ring_quot r) := ⟨sub r⟩
instance [algebra S R] : has_scalar S (ring_quot r) := ⟨smul r⟩

lemma zero_quot : (⟨quot.mk _ 0⟩ : ring_quot r) = 0 := show _ = zero r, by rw zero
lemma one_quot : (⟨quot.mk _ 1⟩ : ring_quot r) = 1 := show _ = one r, by rw one
lemma add_quot {a b} : (⟨quot.mk _ a⟩ + ⟨quot.mk _ b⟩ : ring_quot r) = ⟨quot.mk _ (a + b)⟩ :=
by { show add r _ _ = _, rw add, refl }
lemma mul_quot {a b} : (⟨quot.mk _ a⟩ * ⟨quot.mk _ b⟩ : ring_quot r) = ⟨quot.mk _ (a * b)⟩ :=
by { show mul r _ _ = _, rw mul, refl }
lemma neg_quot {R : Type u₁} [ring R] (r : R → R → Prop) {a} :
  (-⟨quot.mk _ a⟩ : ring_quot r) = ⟨quot.mk _ (-a)⟩ :=
by { show neg r _ = _, rw neg, refl }
lemma sub_quot {R : Type u₁} [ring R] (r : R → R → Prop) {a b} :
  (⟨quot.mk _ a⟩ - ⟨ quot.mk _ b⟩ : ring_quot r) = ⟨quot.mk _ (a - b)⟩ :=
by { show sub r _ _ = _, rw sub, refl }
lemma smul_quot [algebra S R] {n : S} {a : R} :
  (n • ⟨quot.mk _ a⟩ : ring_quot r) = ⟨quot.mk _ (n • a)⟩ :=
by { show smul r _ _ = _, rw smul, refl }

instance (r : R → R → Prop) : semiring (ring_quot r) :=
{ add           := (+),
  mul           := (*),
  zero          := 0,
  one           := 1,
  add_assoc     := by { rintros ⟨⟨⟩⟩ ⟨⟨⟩⟩ ⟨⟨⟩⟩, simp [add_quot, add_assoc] },
  zero_add      := by { rintros ⟨⟨⟩⟩, simp [add_quot, ← zero_quot] },
  add_zero      := by { rintros ⟨⟨⟩⟩, simp [add_quot, ← zero_quot], },
  zero_mul      := by { rintros ⟨⟨⟩⟩, simp [mul_quot, ← zero_quot], },
  mul_zero      := by { rintros ⟨⟨⟩⟩, simp [mul_quot, ← zero_quot], },
  add_comm      := by { rintros ⟨⟨⟩⟩ ⟨⟨⟩⟩, simp [add_quot, add_comm], },
  mul_assoc     := by { rintros ⟨⟨⟩⟩ ⟨⟨⟩⟩ ⟨⟨⟩⟩, simp [mul_quot, mul_assoc] },
  one_mul       := by { rintros ⟨⟨⟩⟩, simp [mul_quot, ← one_quot] },
  mul_one       := by { rintros ⟨⟨⟩⟩, simp [mul_quot, ← one_quot] },
  left_distrib  := by { rintros ⟨⟨⟩⟩ ⟨⟨⟩⟩ ⟨⟨⟩⟩, simp [mul_quot, add_quot, left_distrib] },
  right_distrib := by { rintros ⟨⟨⟩⟩ ⟨⟨⟩⟩ ⟨⟨⟩⟩, simp [mul_quot, add_quot, right_distrib] },
  nsmul         := (•),
  nsmul_zero'   := by { rintros ⟨⟨⟩⟩, simp [smul_quot, ← zero_quot] },
  nsmul_succ'   := by { rintros n ⟨⟨⟩⟩, simp [smul_quot, add_quot, add_mul, add_comm] } }

instance {R : Type u₁} [ring R] (r : R → R → Prop) : ring (ring_quot r) :=
{ neg           := has_neg.neg,
  add_left_neg  := by { rintros ⟨⟨⟩⟩, simp [neg_quot, add_quot, ← zero_quot], },
  sub            := has_sub.sub,
  sub_eq_add_neg := by { rintros ⟨⟨⟩⟩ ⟨⟨⟩⟩, simp [neg_quot, sub_quot, add_quot, sub_eq_add_neg] },
  .. (ring_quot.semiring r) }

instance {R : Type u₁} [comm_semiring R] (r : R → R → Prop) : comm_semiring (ring_quot r) :=
{ mul_comm := by { rintros ⟨⟨⟩⟩ ⟨⟨⟩⟩, simp [mul_quot, mul_comm], }
  .. (ring_quot.semiring r) }

instance {R : Type u₁} [comm_ring R] (r : R → R → Prop) : comm_ring (ring_quot r) :=
{ .. (ring_quot.comm_semiring r),
  .. (ring_quot.ring r) }

instance (r : R → R → Prop) : inhabited (ring_quot r) := ⟨0⟩

instance [algebra S R] (r : R → R → Prop) : algebra S (ring_quot r) :=
{ smul      := (•),
  to_fun    := λ r, ⟨quot.mk _ (algebra_map S R r)⟩,
  map_one'  := by simp [← one_quot],
  map_mul'  := by simp [mul_quot],
  map_zero' := by simp [← zero_quot],
  map_add'  := by simp [add_quot],
  commutes' := λ r, by { rintro ⟨⟨a⟩⟩, simp [algebra.commutes, mul_quot] },
  smul_def' := λ r, by { rintro ⟨⟨a⟩⟩, simp [smul_quot, algebra.smul_def, mul_quot], }, }

/--
The quotient map from a ring to its quotient, as a homomorphism of rings.
-/
def mk_ring_hom (r : R → R → Prop) : R →+* ring_quot r :=
{ to_fun := λ x, ⟨quot.mk _ x⟩,
  map_one'  := by simp [← one_quot],
  map_mul'  := by simp [mul_quot],
  map_zero' := by simp [← zero_quot],
  map_add'  := by simp [add_quot], }

lemma mk_ring_hom_rel {r : R → R → Prop} {x y : R} (w : r x y) :
  mk_ring_hom r x = mk_ring_hom r y :=
by simp [mk_ring_hom, quot.sound (rel.of w)]

lemma mk_ring_hom_surjective (r : R → R → Prop) : function.surjective (mk_ring_hom r) :=
by { dsimp [mk_ring_hom], rintro ⟨⟨⟩⟩, simp, }

@[ext]
lemma ring_quot_ext {T : Type u₄} [semiring T] {r : R → R → Prop} (f g : ring_quot r →+* T)
  (w : f.comp (mk_ring_hom r) = g.comp (mk_ring_hom r)) : f = g :=
begin
  ext,
  rcases mk_ring_hom_surjective r x with ⟨x, rfl⟩,
  exact (ring_hom.congr_fun w x : _),
end

variables  {T : Type u₄} [semiring T]

/--
Any ring homomorphism `f : R →+* T` which respects a relation `r : R → R → Prop`
factors uniquely through a morphism `ring_quot r →+* T`.
-/
def lift {r : R → R → Prop} :
  {f : R →+* T // ∀ ⦃x y⦄, r x y → f x = f y} ≃ (ring_quot r →+* T) :=
{ to_fun := λ f', let f := (f' : R →+* T) in
  { to_fun := λ x, quot.lift f
    begin
      rintros _ _ r,
      induction r,
      case of : _ _ r { exact f'.prop r, },
      case add_left : _ _ _ _ r' { simp [r'], },
      case mul_left : _ _ _ _ r' { simp [r'], },
      case mul_right : _ _ _ _ r' { simp [r'], },
    end x.to_quot,
    map_zero' := by simp [← zero_quot, f.map_zero],
    map_add' := by { rintros ⟨⟨x⟩⟩ ⟨⟨y⟩⟩, simp [add_quot, f.map_add x y], },
    map_one' := by simp [← one_quot, f.map_one],
    map_mul' := by { rintros ⟨⟨x⟩⟩ ⟨⟨y⟩⟩, simp [mul_quot, f.map_mul x y] }, },
  inv_fun := λ F, ⟨F.comp (mk_ring_hom r), λ x y h, by { dsimp, rw mk_ring_hom_rel h, }⟩,
  left_inv := λ f, by { ext, simp, refl },
  right_inv := λ F, by { ext, simp, refl } }

@[simp]
lemma lift_mk_ring_hom_apply (f : R →+* T) {r : R → R → Prop} (w : ∀ ⦃x y⦄, r x y → f x = f y) (x) :
  lift ⟨f, w⟩ (mk_ring_hom r x) = f x :=
rfl

-- note this is essentially `lift.symm_apply_eq.mp h`
lemma lift_unique (f : R →+* T) {r : R → R → Prop} (w : ∀ ⦃x y⦄, r x y → f x = f y)
  (g : ring_quot r →+* T) (h : g.comp (mk_ring_hom r) = f) : g = lift ⟨f, w⟩ :=
by { ext, simp [h], }

lemma eq_lift_comp_mk_ring_hom {r : R → R → Prop} (f : ring_quot r →+* T) :
  f = lift ⟨f.comp (mk_ring_hom r), λ x y h, by { dsimp, rw mk_ring_hom_rel h, }⟩ :=
(lift.apply_symm_apply f).symm

section comm_ring
/-!
We now verify that in the case of a commutative ring, the `ring_quot` construction
agrees with the quotient by the appropriate ideal.
-/

variables {B : Type u₁} [comm_ring B]

/-- The universal ring homomorphism from `ring_quot r` to `B ⧸ ideal.of_rel r`. -/
def ring_quot_to_ideal_quotient (r : B → B → Prop) :
  ring_quot r →+* B ⧸ ideal.of_rel r :=
lift
  ⟨ideal.quotient.mk (ideal.of_rel r),
   λ x y h, quot.sound (submodule.mem_Inf.mpr (λ p w, w ⟨x, y, h, sub_add_cancel x y⟩))⟩

@[simp] lemma ring_quot_to_ideal_quotient_apply (r : B → B → Prop) (x : B) :
  ring_quot_to_ideal_quotient r (mk_ring_hom r x) = ideal.quotient.mk _ x := rfl

/-- The universal ring homomorphism from `B ⧸ ideal.of_rel r` to `ring_quot r`. -/
def ideal_quotient_to_ring_quot (r : B → B → Prop) :
  B ⧸ ideal.of_rel r →+* ring_quot r :=
ideal.quotient.lift (ideal.of_rel r) (mk_ring_hom r)
begin
  refine λ x h, submodule.span_induction h _ _ _ _,
  { rintro y ⟨a, b, h, su⟩,
    symmetry' at su,
    rw ←sub_eq_iff_eq_add at su,
    rw [ ← su, ring_hom.map_sub, mk_ring_hom_rel h, sub_self], },
  { simp, },
  { intros a b ha hb, simp [ha, hb], },
  { intros a x hx, simp [hx], },
end

@[simp] lemma ideal_quotient_to_ring_quot_apply (r : B → B → Prop) (x : B) :
  ideal_quotient_to_ring_quot r (ideal.quotient.mk _ x) = mk_ring_hom r x := rfl

/--
The ring equivalence between `ring_quot r` and `(ideal.of_rel r).quotient`
-/
def ring_quot_equiv_ideal_quotient (r : B → B → Prop) :
  ring_quot r ≃+* B ⧸ ideal.of_rel r :=
ring_equiv.of_hom_inv (ring_quot_to_ideal_quotient r) (ideal_quotient_to_ring_quot r)
  (by { ext, refl, }) (by { ext, refl, })

end comm_ring

section star_ring

variables [star_ring R] (r) (hr : ∀ a b, r a b → r (star a) (star b))
include hr

theorem rel.star ⦃a b : R⦄ (h : rel r a b) :
  rel r (star a) (star b) :=
begin
  induction h,
  { exact rel.of (hr _ _ h_h) },
  { rw [star_add, star_add], exact rel.add_left h_ih, },
  { rw [star_mul, star_mul], exact rel.mul_right h_ih, },
  { rw [star_mul, star_mul], exact rel.mul_left h_ih, },
end

@[irreducible] private def star' : ring_quot r → ring_quot r
| ⟨a⟩ := ⟨quot.map (star : R → R) (rel.star r hr) a⟩

lemma star'_quot (hr : ∀ a b, r a b → r (star a) (star b)) {a} :
  (star' r hr ⟨quot.mk _ a⟩ : ring_quot r) = ⟨quot.mk _ (star a)⟩ :=
by { show star' r _ _ = _, rw star', refl }

/-- Transfer a star_ring instance through a quotient, if the quotient is invariant to `star` -/
def star_ring {R : Type u₁} [semiring R] [star_ring R] (r : R → R → Prop)
  (hr : ∀ a b, r a b → r (star a) (star b)) :
  star_ring (ring_quot r) :=
{ star := star' r hr,
  star_involutive := by { rintros ⟨⟨⟩⟩, simp [star'_quot], },
  star_mul := by { rintros ⟨⟨⟩⟩ ⟨⟨⟩⟩, simp [star'_quot, mul_quot, star_mul], },
  star_add := by { rintros ⟨⟨⟩⟩ ⟨⟨⟩⟩, simp [star'_quot, add_quot, star_add], } }

end star_ring

section algebra

variables (S)

/--
The quotient map from an `S`-algebra to its quotient, as a homomorphism of `S`-algebras.
-/
def mk_alg_hom (s : A → A → Prop) : A →ₐ[S] ring_quot s :=
{ commutes' := λ r, rfl,
  ..mk_ring_hom s }

@[simp]
lemma mk_alg_hom_coe (s : A → A → Prop) : (mk_alg_hom S s : A →+* ring_quot s) = mk_ring_hom s :=
rfl

lemma mk_alg_hom_rel {s : A → A → Prop} {x y : A} (w : s x y) :
  mk_alg_hom S s x = mk_alg_hom S s y :=
by simp [mk_alg_hom, mk_ring_hom, quot.sound (rel.of w)]

lemma mk_alg_hom_surjective (s : A → A → Prop) : function.surjective (mk_alg_hom S s) :=
by { dsimp [mk_alg_hom], rintro ⟨⟨a⟩⟩, use a, refl, }

variables {B : Type u₄} [semiring B] [algebra S B]

@[ext]
lemma ring_quot_ext' {s : A → A → Prop}
  (f g : ring_quot s →ₐ[S] B) (w : f.comp (mk_alg_hom S s) = g.comp (mk_alg_hom S s)) : f = g :=
begin
  ext,
  rcases mk_alg_hom_surjective S s x with ⟨x, rfl⟩,
  exact (alg_hom.congr_fun w x : _),
end

/--
Any `S`-algebra homomorphism `f : A →ₐ[S] B` which respects a relation `s : A → A → Prop`
factors uniquely through a morphism `ring_quot s →ₐ[S]  B`.
-/
def lift_alg_hom {s : A → A → Prop} :
  { f : A →ₐ[S] B // ∀ ⦃x y⦄, s x y → f x = f y} ≃ (ring_quot s →ₐ[S] B) :=
{ to_fun := λ f', let f := (f' : A →ₐ[S] B) in
  { to_fun := λ x, quot.lift f
    begin
      rintros _ _ r,
      induction r,
      case of : _ _ r { exact f'.prop r, },
      case add_left : _ _ _ _ r' { simp [r'], },
      case mul_left : _ _ _ _ r' { simp [r'], },
      case mul_right : _ _ _ _ r' { simp [r'], },
    end x.to_quot,
    map_zero' := by simp [← zero_quot, f.map_zero],
    map_add' := by { rintros ⟨⟨x⟩⟩ ⟨⟨y⟩⟩, simp [add_quot, f.map_add x y] },
    map_one' := by simp [← one_quot, f.map_one],
    map_mul' := by { rintros ⟨⟨x⟩⟩ ⟨⟨y⟩⟩, simp [mul_quot, f.map_mul x y], },
    commutes' := by { rintros x, simp [← one_quot, smul_quot, algebra.algebra_map_eq_smul_one] } },
  inv_fun := λ F, ⟨F.comp (mk_alg_hom S s), λ _ _ h, by { dsimp, erw mk_alg_hom_rel S h }⟩,
  left_inv := λ f, by { ext, simp, refl },
  right_inv := λ F, by { ext, simp, refl } }

@[simp]
lemma lift_alg_hom_mk_alg_hom_apply (f : A →ₐ[S] B) {s : A → A → Prop}
  (w : ∀ ⦃x y⦄, s x y → f x = f y) (x) :
  (lift_alg_hom S ⟨f, w⟩) ((mk_alg_hom S s) x) = f x :=
rfl

-- note this is essentially `(lift_alg_hom S).symm_apply_eq.mp h`
lemma lift_alg_hom_unique (f : A →ₐ[S] B) {s : A → A → Prop} (w : ∀ ⦃x y⦄, s x y → f x = f y)
  (g : ring_quot s →ₐ[S] B) (h : g.comp (mk_alg_hom S s) = f) : g = lift_alg_hom S ⟨f, w⟩ :=
by { ext, simp [h], }

lemma eq_lift_alg_hom_comp_mk_alg_hom {s : A → A → Prop} (f : ring_quot s →ₐ[S] B) :
  f = lift_alg_hom S ⟨f.comp (mk_alg_hom S s), λ x y h, by { dsimp, erw mk_alg_hom_rel S h, }⟩ :=
((lift_alg_hom S).apply_symm_apply f).symm

end algebra

attribute [irreducible] mk_ring_hom mk_alg_hom lift lift_alg_hom

end ring_quot


/-
Copyright (c) 2019 Zhouhang Zhou. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Zhouhang Zhou
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.algebra.invertible
import Mathlib.tactic.linarith.default
import Mathlib.order.filter.at_top_bot
import Mathlib.PostPort

universes u_1

namespace Mathlib

/-!
# Quadratic discriminants and roots of a quadratic

This file defines the discriminant of a quadratic and gives the solution to a quadratic equation.

## Main definition

- `discrim a b c`: the discriminant of a quadratic `a * x * x + b * x + c` is `b * b - 4 * a * c`.

## Main statements

- `quadratic_eq_zero_iff`: roots of a quadratic can be written as
  `(-b + s) / (2 * a)` or `(-b - s) / (2 * a)`, where `s` is a square root of the discriminant.
- `quadratic_ne_zero_of_discrim_ne_square`: if the discriminant has no square root,
  then the corresponding quadratic has no root.
- `discrim_le_zero`: if a quadratic is always non-negative, then its discriminant is non-positive.

## Tags

polynomial, quadratic, discriminant, root
-/

/-- Discriminant of a quadratic -/
def discrim {R : Type u_1} [ring R] (a : R) (b : R) (c : R) : R :=
  b ^ bit0 1 - bit0 (bit0 1) * a * c

/--
A quadratic has roots if and only if its discriminant equals some square.
-/
theorem quadratic_eq_zero_iff_discrim_eq_square {R : Type u_1} [integral_domain R] {a : R} {b : R} {c : R} (h2 : bit0 1 ≠ 0) (ha : a ≠ 0) (x : R) : a * x * x + b * x + c = 0 ↔ discrim a b c = (bit0 1 * a * x + b) ^ bit0 1 := sorry

/-- A quadratic has no root if its discriminant has no square root. -/
theorem quadratic_ne_zero_of_discrim_ne_square {R : Type u_1} [integral_domain R] {a : R} {b : R} {c : R} (h2 : bit0 1 ≠ 0) (ha : a ≠ 0) (h : ∀ (s : R), discrim a b c ≠ s * s) (x : R) : a * x * x + b * x + c ≠ 0 := sorry

/-- Roots of a quadratic -/
theorem quadratic_eq_zero_iff {K : Type u_1} [field K] [invertible (bit0 1)] {a : K} {b : K} {c : K} (ha : a ≠ 0) {s : K} (h : discrim a b c = s * s) (x : K) : a * x * x + b * x + c = 0 ↔ x = (-b + s) / (bit0 1 * a) ∨ x = (-b - s) / (bit0 1 * a) := sorry

/-- A quadratic has roots if its discriminant has square roots -/
theorem exists_quadratic_eq_zero {K : Type u_1} [field K] [invertible (bit0 1)] {a : K} {b : K} {c : K} (ha : a ≠ 0) (h : ∃ (s : K), discrim a b c = s * s) : ∃ (x : K), a * x * x + b * x + c = 0 := sorry

/-- Root of a quadratic when its discriminant equals zero -/
theorem quadratic_eq_zero_iff_of_discrim_eq_zero {K : Type u_1} [field K] [invertible (bit0 1)] {a : K} {b : K} {c : K} (ha : a ≠ 0) (h : discrim a b c = 0) (x : K) : a * x * x + b * x + c = 0 ↔ x = -b / (bit0 1 * a) := sorry

/-- If a polynomial of degree 2 is always nonnegative, then its discriminant is nonpositive -/
theorem discrim_le_zero {K : Type u_1} [linear_ordered_field K] {a : K} {b : K} {c : K} (h : ∀ (x : K), 0 ≤ a * x * x + b * x + c) : discrim a b c ≤ 0 := sorry

/--
If a polynomial of degree 2 is always positive, then its discriminant is negative,
at least when the coefficient of the quadratic term is nonzero.
-/
theorem discrim_lt_zero {K : Type u_1} [linear_ordered_field K] {a : K} {b : K} {c : K} (ha : a ≠ 0) (h : ∀ (x : K), 0 < a * x * x + b * x + c) : discrim a b c < 0 := sorry


-- Some basic category-theoretic constructions
namespace CategoryTheory

structure HomStruct where
  obj : Type u
  hom : obj → obj → Type v

class Category (C : HomStruct) where
  id' : (c : C.obj) → C.hom c c
  comp : {c d e : C.obj} → C.hom c d → C.hom d e → C.hom c e
  id_comp : {c d : C.obj} → (f : C.hom c d) → comp (id' c) f = f
  comp_id : {c d : C.obj} → (f : C.hom c d) → comp f (id' d) = f
  assoc : {a b c d : C.obj} → (f : C.hom a b) → (g : C.hom b c)
      → (h : C.hom c d) → comp (comp f g) h = comp f (comp g h)

open HomStruct
open Category

notation:80 lhs " ∘ " rhs:81  => comp rhs lhs

attribute [simp] id_comp comp_id assoc

section Set

universe u

abbrev SmallCategory (C : HomStruct) := Category.{u,u} C
abbrev LargeCategory (C : HomStruct) := Category.{u+1,u} C

def Set : HomStruct := {
  obj := Type u,
  hom := fun a b => a → b
}

instance Set.Category : LargeCategory Set :=
{ id'     := fun a x => x
  comp    := fun f g x => g (f x)
  id_comp := by
    intros
    simp
  comp_id := by
    intros
    simp
  assoc := by
    intros
    simp
}

end Set

def HomStruct.opposite (C: HomStruct) : HomStruct := {
  obj := C.obj
  hom := fun f g => C.hom g f
}

notation:1030 arg "ᵒᵖ"  => HomStruct.opposite arg

instance Category.opposite (C: HomStruct) [Category C]: Category Cᵒᵖ := {
  id' := fun c => id' (C := C) c
  comp := fun f g => comp (C := C) g f
  id_comp := by
    intros
    simp
  comp_id := by
    intros
    simp
  assoc := by
    intros
    simp
}

-- Note that this doesn't allow for the usual trick where we
-- replace `C` by `Cᵒᵖ` in a lemma and then reduce `Cᵒᵖᵒᵖ` to `C`
-- since this is *an equality of `HomStruct`s* and that means that
-- we can't construct a motive where the `HomStruct` `C` has the
-- `[Category C]` instance.
-- We would need bundled structures to actually use this trick.
theorem opop (C: HomStruct) : Cᵒᵖᵒᵖ = C  := by
  revert C
  intro { obj := obj, hom := hom}
  simp [HomStruct.opposite]

attribute [simp] opop

def inverses (C: HomStruct) [Category C] {c d: C.obj} (f: C.hom c d) (g: C.hom d c) := g ∘ f = id' c ∧ f ∘ g = id' d

theorem inverse_unique (C: HomStruct) [Category C] {c d: C.obj} (f: C.hom c d) (g h: C.hom d c) : inverses C f g ∧ inverses C f h → g = h := by
  intro ⟨⟨_,p⟩,⟨q,_⟩⟩
  have r : (h ∘ f) ∘ g = h := by
    rw [<- assoc, p, id_comp]

  rw [<- r, q, comp_id]

def isomorphism (C: HomStruct) [Category C] {c d: C.obj} (f: C.hom c d) :=
  exists (g: C.hom d c), inverses C f g

namespace Function

variable {A: Type _} {B: Type _}

def inverses (f: A → B) (g: B → A) :=
  (Function.comp g f = id) ∧ (Function.comp f g  = id)

theorem inverses_sym (f: A → B) (g: B → A) : inverses f g <-> inverses g f := by
  simp [inverses]
  exact ⟨
    by
      intro ⟨p,q⟩
      exact ⟨q,p⟩,
    by
      intro ⟨p,q⟩
      exact ⟨q,p⟩
  ⟩

def isomorphism (f: A → B) :=
  exists (g: B → A), inverses f g

end Function

structure Functor (C D: HomStruct) [Category C] [Category D] where
  obj : C.obj → D.obj
  map : {c d : C.obj} → C.hom c d → D.hom (obj c) (obj d)
  map_id : {c : C.obj} → map (id' c) = id' (obj c)
  map_comp : {c d e : C.obj} → (f : C.hom c d) → (g : C.hom d e) → map (g ∘ f) = map g ∘ map f

attribute [simp] Functor.map_id Functor.map_comp

theorem Functor.ext {C D : HomStruct} [Category C] [Category D]: (F G : Functor C D) → (p: F.obj = G.obj) →
  (q: (fun c d (f: C.hom c d) => F.map f)
    ≅ (fun c d (f: C.hom c d) => G.map f))
  → F = G
  := by
  intro { obj := F, map := FMap, ..}
  intro { obj := G, map := GMap, ..}
  intro p q
  simp at p q
  simp -- applies propext
  exact ⟨p,q⟩

def fId (C: HomStruct) [Category C] : Functor C C := {
  obj := id
  map := id
  map_id := by
    intros
    rfl
  map_comp := by
    intros
    rfl
}

def fComp {C D E: HomStruct} [Category C] [Category D] [Category E] (F: Functor C D) (G: Functor D E) : Functor C E := {
  obj := Function.comp G.obj F.obj
  map := fun f => G.map (F.map f)
  map_id := by
    intros
    simp
  map_comp := by
    intros
    simp
}

structure BundledCategory where
  base : HomStruct
  inst : Category base

instance (C: BundledCategory) : Category C.base := C.inst

def Cat : HomStruct.{max (u + 1) (v + 1), max u v} := {
  obj := BundledCategory.{u,v},
  hom := fun C D => Functor C.base D.base
}

instance : Category Cat where
  id' := fun {C} => fId C.base
  comp := fComp
  id_comp := by
    intros
    simp [fComp, fId]

    apply Functor.ext
    simp [Function.comp]
    simp
    exact HEq.rfl

  comp_id := by
    intros
    simp [fComp, fId]

    apply Functor.ext
    simp [Function.comp]
    simp
    exact HEq.rfl

  assoc := by
    intros
    simp [fComp]

    apply Functor.ext
    simp [Function.comp]
    simp
    exact HEq.rfl

def fully_faithful {C: HomStruct} [Category C] {D: HomStruct} [Category D] (F: Functor C D) :=
  forall c d : C.obj, Function.isomorphism (F.map (c := c) (d := d))

section NatTrans

variable {C : HomStruct} [Category C]
variable {D : HomStruct} [Category D]

structure NatTrans (F G : Functor C D) :=
  app : (c : C.obj) → D.hom (F.obj c) (G.obj c)
  naturality : {c d : C.obj} → (f : C.hom c d) → app d ∘ (F.map f) = (G.map f) ∘ app c

open NatTrans

theorem NatTrans.ext {F G : Functor C D} : (η μ : NatTrans F G) → (p: η.app = μ.app) → (η = μ) := by
  intro { app := η, .. }
  intro { app := μ, .. }
  intro p
  simp at p
  simp -- applies propext
  exact p

def FunctorCat (C: HomStruct) [Category C] (D: HomStruct) [Category D]: HomStruct := {
  obj := Functor C D
  hom := NatTrans
}

def idTrans (F : Functor C D) : NatTrans F F := {
  app := fun c => id' (Functor.obj F c),
  naturality := by
    intro c d f
    simp
}

def vComp {F G H : Functor C D} (η : NatTrans F G) (μ : NatTrans G H) : NatTrans F H := {
  app := fun c => (app μ c) ∘ (app η c),
  naturality := by
    intro c d f
    simp
    rw [<- naturality μ f]
    rw [<- Category.assoc]
    rw [naturality η f]
    rw [Category.assoc]
}

instance : Category (FunctorCat C D) := {
  id'     := idTrans,
  comp    := vComp,
  id_comp := by
    intros
    apply NatTrans.ext
    simp [id', idTrans, comp, vComp]
  comp_id := by
    intros
    apply NatTrans.ext
    simp [id', idTrans, comp, vComp]
  assoc := by
    intros
    apply NatTrans.ext
    simp [comp, vComp]
}

end NatTrans

section Yoneda

universes u v

variable {C : HomStruct.{u,v}} [Category C]

def yObj (c: C.obj) : (Functor Cᵒᵖ Set.{v}) := {
    obj := fun d => C.hom d c
    -- f gets sent to precomposition with f
    map := fun f g => g ∘ f
    map_id := by
      intros
      simp [id']
    map_comp := by
      intros
      simp [comp]
  }

def yMap {c d: C.obj} (f: C.hom c d) : NatTrans (yObj c) (yObj d) := {
  app := fun c g => f ∘ g
  naturality := by
    intros
    simp [yObj, comp]
}

def y : Functor C (FunctorCat Cᵒᵖ Set.{v}) := {
  obj := yObj
  map := yMap
  map_id := by
    intros
    apply NatTrans.ext
    simp [yMap, id', idTrans]
  map_comp := by
    intros
    apply NatTrans.ext
    simp [yMap, comp, vComp]
}

def yonedaMap (c : C.obj) (F: Functor Cᵒᵖ Set.{v}) (η: NatTrans (y.obj c) F) : F.obj c := η.app c (id' c)

def yonedaMapInv (c : C.obj) (F: Functor Cᵒᵖ Set.{v}) (x: F.obj c) : NatTrans (y.obj c) F := {
  app := fun d f => F.map f x
  naturality := by
    intros d e f
    simp [y, yObj, comp]
    funext g
    -- It honestly is a bit confusing not knowing in which category
    -- the composition takes place
    have p: comp (C := C) f g = comp (C := Cᵒᵖ) g f  := by rfl
    rw [p, Functor.map_comp]
    simp [comp]
}

theorem yoneda (c : C.obj) (F: Functor Cᵒᵖ Set.{v}) : Function.inverses (yonedaMap c F) (yonedaMapInv c F) := ⟨
  by
    simp [yonedaMap, yonedaMapInv]
    apply funext
    intro { app := η, naturality := nat }
    simp [comp,id',y,yObj]
    funext d f
    -- Rewrite the application in the goal as a composition in order
    -- to apply naturality
    have p: F.map f (η c (id' c)) = (comp (η c) (F.map f)) (id' c) := by rfl
    rw [p, <- nat f]
    simp [y, yObj, comp],
  by
    simp [yonedaMap, yonedaMapInv, Function.comp]
    funext x
    have p: id' (C := C) c = id' (C := Cᵒᵖ) c  := by rfl
    rw [p, Functor.map_id]
    simp [id']
⟩

theorem y_fully_faithful: fully_faithful (y (C := C)) := by
  simp [fully_faithful, Function.isomorphism]
  intros c d

  -- The crucial insight is that `y.map` is in fact equal to `yonedaMapInverse` and thus by the yoneda lemma has an inverse
  have yoneda := yoneda c (y.obj d)

  refine ⟨ yonedaMap c (y.obj d), ?_ ⟩

  have p: yonedaMapInv c (Functor.obj y d) = y.map := by
    funext f
    apply NatTrans.ext
    simp [yonedaMapInv, y, yMap, yObj]

  rw [<- p, Function.inverses_sym]
  exact yoneda

end Yoneda

end CategoryTheory


-- Copyright © 2019 François G. Dorais. All rights reserved.
-- Released under Apache 2.0 license as described in the file LICENSE.

import .basic
import .group
import .monoid
import .semiring

set_option default_priority 0

namespace algebra

signature ring (α : Type*) :=
(mul : α → α → α)
(one : α)
(add : α → α → α)
(neg : α → α)
(zero : α)

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

@[signature_instance]
def to_add_group : group_sig α :=
{ op := s.add
, inv := s.neg
, id := s.zero
}

@[signature_instance]
def to_mul_monoid : monoid_sig α :=
{ op := s.mul
, id := s.one
}

@[unify]
definition to_mul_monoid_to_semigroup_op_hint (t : semigroup_sig α) : unification_hint :=
{ pattern := t.op =?= s.mul
, constraints := [t =?= s.to_mul_monoid.to_semigroup]
}

@[signature_instance]
definition to_semiring : semiring_sig α :=
{ add := s.add
, zero := s.zero
, mul := s.mul
, one := s.one
}

end ring_sig

variables {α : Type*} (s : ring_sig α)
local notation `𝟘` := s.zero
local notation `𝟙` := s.one
local prefix - := s.neg
local infix + := s.add
local infix ∙ := s.mul

@[theory]
class ring : Prop := intro ::
(add_associative : identity.op_associative s.add)
(add_right_identity : identity.op_right_identity s.add s.zero)
(add_right_inverse : identity.op_right_inverse s.add s.neg s.zero)
(mul_associative : identity.op_associative s.mul)
(mul_left_identity : identity.op_left_identity s.mul s.one)
(mul_right_identity : identity.op_right_identity s.mul s.one)
(mul_left_distributive : identity.op_left_distributive s.mul s.add)
(mul_right_distributive : identity.op_right_distributive s.mul s.add)

namespace ring
variable [i : ring s]
include i

instance to_add_group : group s.to_add_group := group.infer _

@[identity_instance]
theorem add_commutative : identity.op_commutative s.add :=
λ x y,
have (x + x) + (y + y) = (x + y) + (x + y),
from calc (x + x) + (y + y)
= (𝟙 ∙ x + 𝟙 ∙ x) + (y + y) : by rw op_left_identity s.mul s.one x ...
= (𝟙 ∙ x + 𝟙 ∙ x) + (𝟙 ∙ y + 𝟙 ∙ y) : by rw op_left_identity s.mul s.one y ...
= (𝟙 + 𝟙) ∙ x + (𝟙 ∙ y + 𝟙 ∙ y) : by rw op_left_distributive s.mul s.add _ _ x ...
= (𝟙 + 𝟙) ∙ x + (𝟙 + 𝟙) ∙ y : by rw op_left_distributive s.mul s.add _ _ y ...
= (𝟙 + 𝟙) ∙ (x + y) : by rw op_right_distributive s.mul ...
= 𝟙 ∙ (x + y) + 𝟙 ∙ (x + y) : by rw op_left_distributive s.mul ...
= (x + y) + (x + y) : by rw op_left_identity s.mul s.one,
have x + ((x + y) + y) = x + ((y + x) + y),
from calc x + ((x + y) + y)
= x + (x + (y + y)) : by rw op_associative s.add ...
= (x + x) + (y + y) : by rw op_associative s.add ...
= (x + y) + (x + y) : by rw this ...
= x + (y + (x + y)) : by rw op_associative s.add ...
= x + ((y + x) + y) : by rw op_associative s.add,
have (x + y) + y = (y + x) + y,
from op_left_cancellative s.add this,
show x + y = y + x,
from op_right_cancellative s.add this

instance to_add_comm_group : comm_group s.to_add_group := comm_group.infer _

@[identity_instance]
theorem mul_left_null : identity.op_left_fixpoint s.mul s.zero :=
λ x,
have x + 𝟘 ∙ x = x + 𝟘,
from calc x + 𝟘 ∙ x
= 𝟙 ∙ x + 𝟘 ∙ x : by rw op_left_identity s.mul s.one ...
= (𝟙 + 𝟘) ∙ x : by rw op_left_distributive s.mul ...
= 𝟙 ∙ x : by rw op_right_identity s.add s.zero ...
= x : by rw op_left_identity s.mul s.one ...
= x + 𝟘 : by rw op_right_identity s.add s.zero,
show 𝟘 ∙ x = 𝟘,
from op_left_cancellative s.add this

@[identity_instance]
theorem mul_right_null : identity.op_right_fixpoint s.mul s.zero :=
λ x,
have x + x ∙ 𝟘 = x + 𝟘,
from calc x + x ∙ 𝟘
= x ∙ 𝟙 + x ∙ 𝟘 : by rw op_right_identity s.mul s.one ...
= x ∙ (𝟙 + 𝟘) : by rw op_right_distributive s.mul ...
= x ∙ 𝟙 : by rw op_right_identity s.add s.zero ...
= x : by rw op_right_identity s.mul s.one ...
= x + 𝟘 : by rw op_right_identity s.add s.zero,
show x ∙ 𝟘 = 𝟘,
from op_left_cancellative s.add this

instance to_semiring : semiring s.to_semiring := semiring.infer _

@[identity_instance]
theorem mul_neg_left_homomorphism : identity.op_left_fn_homomorphism s.mul s.neg s.neg :=
λ x y,
have -x ∙ y + x ∙ y = -(x ∙ y) + x ∙ y,
from calc -x ∙ y + x ∙ y
= (-x + x) ∙ y : by rw op_left_distributive s.mul ...
= 𝟘 ∙ y : by rw op_left_inverse s.add s.neg s.zero ...
= 𝟘 : by rw op_left_fixpoint s.mul ...
= -(x ∙ y) + x ∙ y : by rw op_left_inverse s.add s.neg s.zero,
show -x ∙ y = -(x ∙ y),
from op_right_cancellative s.add this

@[identity_instance]
theorem mul_neg_right_homomorphism : identity.op_right_fn_homomorphism s.mul s.neg s.neg :=
λ x y,
have x ∙ -y + x ∙ y = -(x ∙ y) + x ∙ y,
from calc x ∙ -y + x ∙ y
= x ∙ (-y + y) : by rw op_right_distributive s.mul ...
= x ∙ 𝟘 : by rw op_left_inverse s.add s.neg s.zero ...
= 𝟘 : by rw op_right_fixpoint s.mul ...
= -(x ∙ y) + x ∙ y : by rw op_left_inverse s.add s.neg s.zero,
show x ∙ -y = -(x ∙ y),
from op_right_cancellative s.add this

end ring

@[theory]
class comm_ring : Prop := intro ::
(add_associative : identity.op_associative s.add)
(add_right_identity : identity.op_right_identity s.add s.zero)
(add_right_inverse : identity.op_right_inverse s.add s.neg s.zero)
(mul_associative : identity.op_associative s.mul)
(mul_commutative : identity.op_commutative s.mul)
(mul_right_identity : identity.op_right_identity s.mul s.one)
(mul_right_distributive : identity.op_right_distributive s.mul s.add)

namespace comm_ring
variables [i : comm_ring s]
include i

@[identity_instance]
theorem mul_left_distributive : identity.op_left_distributive s.mul s.add :=
λ x y z,
show (x + y) ∙ z = x ∙ z + y ∙ z,
from calc (x + y) ∙ z
= z ∙ (x + y) : by rw op_commutative s.mul ...
= z ∙ x + z ∙ y : by rw op_right_distributive s.mul ...
= x ∙ z + z ∙ y : by rw op_commutative s.mul x ...
= x ∙ z + y ∙ z : by rw op_commutative s.mul y

instance to_mul_comm_monoid : comm_monoid s.to_mul_monoid := comm_monoid.infer _

instance to_ring : ring s := ring.infer _

instance to_comm_semiring : comm_semiring s.to_semiring := comm_semiring.infer _

end comm_ring

end algebra


inductive InfTree.{u} (α : Type u)
| leaf : α → InfTree α
| node : (Nat → InfTree α) → InfTree α

open InfTree

def szn.{u} {α : Type u} (n : Nat) : InfTree α → InfTree α → Nat
| leaf a, t2     => 1
| node c, leaf b => 0
| node c, node d => szn n (c n) (d n)

universes u

theorem ex1 {α : Type u} (n : Nat) (c : Nat → InfTree α) (d : Nat → InfTree α) : szn n (node c) (node d) = szn n (c n) (d n) :=
rfl

inductive BTree (α : Type u)
| leaf : α → BTree α
| node : (Bool → Bool → BTree α) → BTree α

def BTree.sz {α : Type u} : BTree α → Nat
| leaf a => 1
| node c => sz (c true true) + sz (c true false) + sz (c false true) + sz (c false false) + 1

theorem ex2 {α : Type u} (c : Bool → Bool → BTree α) : (BTree.node c).sz = (c true true).sz + (c true false).sz + (c false true).sz + (c false false).sz + 1 :=
rfl

inductive L (α : Type u)
| nil  : L α
| cons : (Unit → α) → (Unit → L α) → L α

def L.append {α} : L α → L α → L α
| nil, bs       => bs
| cons a as, bs => cons a (fun _ => append (as ()) bs)

theorem L.appendNil {α} : (as : L α) → append as nil = as
| nil       => rfl
| cons a as =>
  show cons a (fun _ => append (as ()) nil) = cons a as from
  have ih : append (as ()) nil = as () := appendNil $ as ()
  have thunkAux : (fun _ => as ()) = as := funext fun x => by
    cases x
    exact rfl
  by rw [ih, thunkAux]


import tactic -- hide
open function nat -- hide

/-
## Some more on `rw`

We can do replacements in hypotheses, not just on the goal, by using `at`. For instance, in the example below
we can substitute the value of $a=3$ in `h1` (via `rw h2 at h1`), or substituting the value of $a=b+c$
in `h2` (via `rw h1 at h2`). This will allow you to close the goal without using `assumption`, by
doing one more `rw`.
-/

/- Lemma : no-side-bar
If $a = b+c$ and $a = 3$, then $b + c = 3$.
-/
lemma l3 (a b c : ℕ) (h1 : a = b + c) (h2 : a = 3) : b + c = 3:=
begin
  rw h2 at h1,
  rw ←h1,

end