/-
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.nat.units
import data.int.basic
import algebra.ring.units

/-!
# Lemmas about units in `ℤ`.

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

namespace int

/-! ### units -/

@[simp] theorem units_nat_abs (u : ℤˣ) : nat_abs u = 1 :=
units.ext_iff.1 $ nat.units_eq_one ⟨nat_abs u, nat_abs ↑u⁻¹,
  by rw [← nat_abs_mul, units.mul_inv]; refl,
  by rw [← nat_abs_mul, units.inv_mul]; refl⟩

theorem units_eq_one_or (u : ℤˣ) : u = 1 ∨ u = -1 :=
by simpa only [units.ext_iff, units_nat_abs] using nat_abs_eq u

lemma is_unit_eq_one_or {a : ℤ} : is_unit a → a = 1 ∨ a = -1
| ⟨x, hx⟩ := hx ▸ (units_eq_one_or _).imp (congr_arg coe) (congr_arg coe)

lemma is_unit_iff {a : ℤ} : is_unit a ↔ a = 1 ∨ a = -1 :=
begin
  refine ⟨λ h, is_unit_eq_one_or h, λ h, _⟩,
  rcases h with rfl | rfl,
  { exact is_unit_one },
  { exact is_unit_one.neg }
end

lemma is_unit_eq_or_eq_neg {a b : ℤ} (ha : is_unit a) (hb : is_unit b) : a = b ∨ a = -b :=
begin
  rcases is_unit_eq_one_or hb with rfl | rfl,
  { exact is_unit_eq_one_or ha },
  { rwa [or_comm, neg_neg, ←is_unit_iff] },
end

lemma eq_one_or_neg_one_of_mul_eq_one {z w : ℤ} (h : z * w = 1) : z = 1 ∨ z = -1 :=
is_unit_iff.mp (is_unit_of_mul_eq_one z w h)

lemma eq_one_or_neg_one_of_mul_eq_one' {z w : ℤ} (h : z * w = 1) :
  (z = 1 ∧ w = 1) ∨ (z = -1 ∧ w = -1) :=
begin
  have h' : w * z = 1 := (mul_comm z w) ▸ h,
  rcases eq_one_or_neg_one_of_mul_eq_one h with rfl | rfl;
  rcases eq_one_or_neg_one_of_mul_eq_one h' with rfl | rfl;
  tauto,
end

theorem eq_of_mul_eq_one {z w : ℤ} (h : z * w = 1) : z = w :=
(eq_one_or_neg_one_of_mul_eq_one' h).elim (λ h, h.1.trans h.2.symm) (λ h, h.1.trans h.2.symm)

lemma mul_eq_one_iff_eq_one_or_neg_one {z w : ℤ} :
  z * w = 1 ↔ z = 1 ∧ w = 1 ∨ z = -1 ∧ w = -1 :=
begin
  refine ⟨eq_one_or_neg_one_of_mul_eq_one', λ h, or.elim h (λ H, _) (λ H, _)⟩;
  rcases H with ⟨rfl, rfl⟩;
  refl,
end

lemma eq_one_or_neg_one_of_mul_eq_neg_one' {z w : ℤ} (h : z * w = -1) :
  z = 1 ∧ w = -1 ∨ z = -1 ∧ w = 1 :=
begin
  rcases is_unit_eq_one_or (is_unit.mul_iff.mp (int.is_unit_iff.mpr (or.inr h))).1 with rfl | rfl,
  { exact or.inl ⟨rfl, one_mul w ▸ h⟩, },
  { exact or.inr ⟨rfl, neg_inj.mp (neg_one_mul w ▸ h)⟩, }
end

lemma mul_eq_neg_one_iff_eq_one_or_neg_one {z w : ℤ} :
  z * w = -1 ↔ z = 1 ∧ w = -1 ∨ z = -1 ∧ w = 1 :=
begin
  refine ⟨eq_one_or_neg_one_of_mul_eq_neg_one', λ h, or.elim h (λ H, _) (λ H, _)⟩;
  rcases H with ⟨rfl, rfl⟩;
  refl,
end

theorem is_unit_iff_nat_abs_eq {n : ℤ} : is_unit n ↔ n.nat_abs = 1 :=
by simp [nat_abs_eq_iff, is_unit_iff, nat.cast_zero]

alias is_unit_iff_nat_abs_eq ↔ is_unit.nat_abs_eq _

@[norm_cast]
lemma of_nat_is_unit {n : ℕ} : is_unit (n : ℤ) ↔ is_unit n :=
by rw [nat.is_unit_iff, is_unit_iff_nat_abs_eq, nat_abs_of_nat]

lemma is_unit_mul_self {a : ℤ} (ha : is_unit a) : a * a = 1 :=
(is_unit_eq_one_or ha).elim (λ h, h.symm ▸ rfl) (λ h, h.symm ▸ rfl)

lemma is_unit_add_is_unit_eq_is_unit_add_is_unit {a b c d : ℤ}
  (ha : is_unit a) (hb : is_unit b) (hc : is_unit c) (hd : is_unit d) :
  a + b = c + d ↔ a = c ∧ b = d ∨ a = d ∧ b = c :=
begin
  rw is_unit_iff at ha hb hc hd,
  cases ha; cases hb; cases hc; cases hd;
  subst ha; subst hb; subst hc; subst hd;
  tidy,
end

end int


universe u

def f1 (n m : Nat) (x : Fin n) (h : n = m) : Fin m :=
h ▸ x

def f2 (n m : Nat) (x : Fin n) (h : m = n) : Fin m :=
h ▸ x

theorem ex1 {α : Sort u} {a b c : α} (h₁ : a = b) (h₂ : b = c) : a = c :=
h₂ ▸ h₁

theorem ex2 {α : Sort u} {a b : α} (h : a = b) : b = a :=
h ▸ rfl

theorem ex3 {α : Sort u} {a b c : α} (r : α → α → Prop) (h₁ : r a b) (h₂ : b = c) : r a c :=
h₂ ▸ h₁

theorem ex3b {α : Sort u} {a b c : α} (r : α → α → Prop) (h₁ : r a b) (h₂ : b = c) : r a c :=
h₂.symm ▸ h₁

theorem ex3c {α : Sort u} {a b c : α} (r : α → α → Prop) (h₁ : r a b) (h₂ : b = c) : r a c :=
h₂.symm.symm ▸ h₁

theorem ex4 {α : Sort u} {a b c : α} (r : α → α → Prop) (h₁ : a = b) (h₂ : r b c) : r a c :=
h₁ ▸ h₂

theorem ex5 {p : Prop} (h : p = True) : p :=
h ▸ trivial

theorem ex6 {p : Prop} (h : p = False) : ¬p :=
fun hp => h ▸ hp

theorem ex7 {α} {a b c d : α} (h₁ : a = c) (h₂ : b = d) (h₃ : c ≠ d) : a ≠ b :=
h₁ ▸ h₂ ▸ h₃

theorem ex8 (n m k : Nat) (h : Nat.succ n + m = Nat.succ n + k) : Nat.succ (n + m) = Nat.succ (n + k) :=
Nat.succ_add .. ▸ Nat.succ_add .. ▸ h

theorem ex9 (a b : Nat) (h₁ : a = a + b) (h₂ : a = b) : a = b + a  :=
h₂ ▸ h₁

theorem ex10 (a b : Nat) (h : a = b) : b = a :=
h ▸ rfl

def ex11  {α : Type u} {n : Nat} (a : Array α) (i : Nat) (h₁ : a.size = n) (h₂ : i < n) : α :=
  a.get ⟨i, h₁ ▸ h₂⟩

theorem ex12 {α : Type u} {n : Nat}
  (a b : Array α)
  (hsz₁ : a.size = n) (hsz₂ : b.size = n)
  (h : ∀ (i : Nat) (hi : i < n), a.getLit i hsz₁ hi = b.getLit i hsz₂ hi) : a = b :=
Array.ext a b (hsz₁.trans hsz₂.symm) fun i hi₁ hi₂ => h i (hsz₁ ▸ hi₁)

def toArrayLit {α : Type u} (a : Array α) (n : Nat) (hsz : a.size = n) : Array α :=
List.toArray $ Array.toListLitAux a n hsz n (hsz ▸ Nat.le_refl _) []

partial def isEqvAux {α} (a b : Array α) (hsz : a.size = b.size) (p : α → α → Bool) (i : Nat) : Bool :=
  if h : i < a.size then
     let aidx : Fin a.size := ⟨i, h⟩
     let bidx : Fin b.size := ⟨i, hsz ▸ h⟩
     match p (a.get aidx) (b.get bidx) with
     | true  => isEqvAux a b hsz p (i+1)
     | false => false
  else
    true


import tactic

-- Comments follow [Set Theory: An Open Introduction][1] and, only where
-- specified, [An Introduction To Set Theory][2].
--
-- [1]: https://st.openlogicproject.org/settheory-screen.pdf
-- [2]: https://www.math.toronto.edu/weiss/set_theory.pdf

/-

An Introduction To Set Theory introduces abbreviations for working with
classes. A class is a string of symbols of the form `{x : φ}` where `x`
is a variable and `φ` is a formula. We write:

    x ∈ {y : φ} instead of φ[y / x]
    x = {y : φ} instead of ∀ z, z ∈ x ↔ φ[y / z]
    {x : φ} = y instead of ∀ z, φ[x / z] ↔ z ∈ y
    {x : φ} = {y : ψ} instead of ∀ z, φ[x / z] ↔ ψ[y / z]
    {x : φ} ∈ y instead of ∃ z, z ∈ y ∧ ∀ x, x ∈ z ↔ φ
    {x : φ} ∈ {y : ψ} instead of ∃ z, ψ[y / z] ∧ ∀ x, x ∈ z ↔ φ

where `z` is always fresh, i.e., `z` is neither `x` nor `y` and occurs in
neither `φ` or `ψ`.

Whenever we have a finite number of classes or variables `a₁`, `a₂`, ..., `aₙ`
the notation `{a₁, a₂, ..., aₙ}` is used as an abbreviation for the class:

    {x : x = a₁ ∨ x = a₂ ∨ ... ∨ x = aₙ}

We also abbreviate the following:

    a ∪ b for {x : x ∈ a ∨ x ∈ b}
    a ∩ b for {x : x ∈ a ∧ x ∈ b}
    a \ b for {x : x ∈ a ∧ x ∉ b}
    ⟨a, b⟩ for {{a}, {a, b}}
    a × b for {p : ∃ x y, x ∈ a ∧ y ∈ b ∧ p = ⟨a, b⟩}
    dom(f) for {x : ∃ y, ⟨x, y⟩ ∈ f}
    rng(f) for {y : ∃ x, ⟨x, y⟩ ∈ f}

Examples:

    ¬ ∃ z, z = {x : x ∉ x}
    ¬ ∃ z, ∀ y, y ∈ z ↔ y ∉ y
    ¬ ∃ z, ∀ x, x ∈ z ↔ x ∉ x

    ∀ a, a ∈ {a, b}
    ∀ a, a ∈ {x : x = a ∨ x = b}
    ∀ a, a = a ∨ a = b

    ∃ z, z = ∅
    ∃ z, z = {x : x ≠ x}
    ∃ z, ∀ x, x ∈ z ↔ x ≠ x
    ...
    ∃ z, ∀ x, x ∉ z

    ∀ x y, ∃ z, z = {x, y}
    ∀ x y, ∃ z, z = {w : w = x ∨ w = y}
    ∀ x y, ∃ z, ∀ w, w ∈ z ↔ w = x ∨ w = y

-/

-- Stages-are-key. Every set is formed at some stage.
--
-- Stages-are-ordered. Stages are ordered: some come before others.
--
-- Stages-accumulate. For any stage S, and for any sets which were formed
-- before stage S: a set is formed at stage S whose members are exactly those
-- sets. Nothing else is formed at stage S.
--
-- Stages-keep-going. There is no last stage.
--
-- Stages-hit-infinity. There is an infinite stage. That is, there is a stage
-- which (a) is not the first stage, and which (b) has some stages before it,
-- but which (c) has no immediate predecessor.

noncomputable theory

axiom Set : Type
axiom mem : Set → Set → Prop
instance : has_mem Set Set := ⟨mem⟩

def subset (A B : Set) := ∀ ⦃x⦄, x ∈ A → x ∈ B
instance : has_subset Set := ⟨subset⟩

theorem russell's_paradox : ¬ ∃ z : Set, ∀ x, x ∈ z ↔ x ∉ x :=
begin
  rintros ⟨z, hz⟩,
  specialize hz z,
  simpa using hz
end

-- Axiom (Extensionality). For any sets A and B: ∀ x (x ∈ A ↔ x ∈ B) → A = B
@[ext] axiom extensionality {A B : Set} (h : ∀ x, x ∈ A ↔ x ∈ B) : A = B

-- The axiom of equality, as presented in An Introduction To Set Theory.
example (a b : Set) (h : a = b) : ∀ x : Set, a ∈ x ↔ b ∈ x :=
by simp [h]

-- The axiom of extensionality, as presented in An Introduction To Set Theory.
lemma ext_iff {A B : Set} : A = B ↔ ∀ x, x ∈ A ↔ x ∈ B :=
⟨λ h, by simp [h], extensionality⟩

-- Axiom (Pairs). For any sets a, b, the set {a, b} exists.
-- ∀ a ∀ b ∃ P ∀ x (x ∈ P ↔ (x = a ∨ x = b))
axiom pairing (a b : Set) : ∃ P : Set, ∀ x, x ∈ P ↔ x = a ∨ x = b

-- https://en.wikipedia.org/wiki/Extension_by_definitions
example (a b : Set) : ∃! P : Set, ∀ x, x ∈ P ↔ x = a ∨ x = b :=
begin
  obtain ⟨P, hP⟩ := pairing a b,
  refine ⟨P, hP, _⟩,
  intros P' hP',
  ext x,
  specialize hP x,
  specialize hP' x,
  rw [hP, hP']
end

-- Given the above we could add the following, making a conservative extension
-- of ZFC.
--axiom pair (a b : Set) : Set
--axiom pair_spec (a b : Set) : ∀ x, x ∈ pair a b ↔ x = a ∨ x = b

example {φ : Set → Prop} {H : ∃ z, φ z} {χ : Prop} (h : ∀ z, φ z → χ) : ∃ z, φ z ∧ χ :=
begin
  obtain ⟨z, hz⟩ := H,
  exact ⟨z, hz, h z hz⟩
end

example {φ : Set → Prop} {χ : Prop} (h : ∃ z, φ z ∧ χ) : ∀ z, φ z → χ :=
begin
  obtain ⟨z, hz, h⟩ := h,
  exact λ _ _, h
end

-- Using the abbreviations defined in An Introduction To Set Theory:
--
--      ∀ a b, ∃ P, P = {a, b}
--      ∀ a b, ∃ P, P = {x : x = a ∨ x = b}
--      ∀ a b, ∃ P, ∀ x, x ∈ P ↔ x = a ∨ x = b
--
example (a b : Set) : ∃ P : Set, ∀ x, x ∈ P ↔ x = a ∨ x = b :=
pairing a b

-- Using the abbreviations defined in An Introduction To Set Theory:
--
--      ∀ a b, ∃ P, P = ⟨a, b⟩
--      ∀ a b, ∃ P, P = {{a}, {a, b}}
--      ∀ a b, ∃ P, P = {x : x = {a} ∨ x = {a, b}}
--      ∀ a b, ∃ P, ∀ x, x ∈ P ↔ x = {a} ∨ x = {a, b}
--      ∀ a b, ∃ P, ∀ x, x ∈ P ↔ x = {y : y = a} ∨ x = {y : y = a ∨ y = b}
--      ∀ a b, ∃ P, ∀ x, x ∈ P ↔ (∀ z, z ∈ x ↔ z = a) ∨ (∀ z, z ∈ x ↔ z = a ∨ z = b)
--
lemma pair (a b : Set) :
  ∃ P : Set, ∀ x, x ∈ P ↔ (∀ z, z ∈ x ↔ z = a) ∨ (∀ z, z ∈ x ↔ z = a ∨ z = b) :=
begin
  obtain ⟨P₁, hP₁⟩ := pairing a a,
  simp only [or_self] at hP₁,
  obtain ⟨P₂, hP₂⟩ := pairing a b,
  obtain ⟨P, hP⟩ := pairing P₁ P₂,
  use P,
  intro x,
  rw hP x,
  clear hP,
  split,
  { rintro (rfl | rfl),
    { left, assumption },
    { right, assumption } },
  { rintro (h | h),
    { left, ext y, rw hP₁ y, exact h y },
    { right, ext y, rw hP₂ y, exact h y } }
end

-- Using the abbreviations defined in An Introduction To Set Theory:
--
--      ∀ a₁ a₂ b₁ b₂, ⟨a₁, b₁⟩ = ⟨a₂, b₂⟩ ↔ a₁ = a₂ ∧ b₁ = b₂
--      ∀ a₁ a₂ b₁ b₂, {{a₁}, {a₁, b₁}} = {{a₂}, {a₂, b₂}} ↔ a₁ = a₂ ∧ b₁ = b₂
--      ∀ a₁ a₂ b₁ b₂, {x : x = {a₁} ∨ x = {a₁, b₁}} = {y : y = {a₂} ∨ y = {a₂, b₂}} ↔ a₁ = a₂ ∧ b₁ = b₂
--      ∀ a₁ a₂ b₁ b₂, (∀ z, z = {a₁} ∨ z = {a₁, b₁}} ↔ z = {a₂} ∨ z = {a₂, b₂}) ↔ a₁ = a₂ ∧ b₁ = b₂
--      ∀ a₁ a₂ b₁ b₂, (∀ z, z = {w : w = a₁} ∨ z = {w : w = a₁ ∨ w = b₁}} ↔ z = {w : w = a₂} ∨ z = {w : w = a₂ ∨ w = b₂}) ↔ a₁ = a₂ ∧ b₁ = b₂
--      ∀ a₁ a₂ b₁ b₂, (∀ z, (∀ w, w ∈ z ↔ w = a₁) ∨ (∀ w, w ∈ z ↔ w = a₁ ∨ w = b₁) ↔ (∀ w, w ∈ z ↔ w = a₂) ∨ (∀ w, w ∈ z ↔ w = a₂ ∨ w = b₂)) ↔ a₁ = a₂ ∧ b₁ = b₂
--
lemma fst_eq_fst_of_pair_eq_pair {a₁ a₂ b₁ b₂ : Set}
  (h : ∀ z : Set, (∀ w, w ∈ z ↔ w = a₁) ∨ (∀ w, w ∈ z ↔ w = a₁ ∨ w = b₁) ↔
                  (∀ w, w ∈ z ↔ w = a₂) ∨ (∀ w, w ∈ z ↔ w = a₂ ∨ w = b₂)) : a₁ = a₂ :=
begin
  obtain ⟨P₁, hP₁⟩ := pairing a₁ a₁,
  obtain ⟨P₂, hP₂⟩ := pairing a₂ a₂,
  have h₁ := h P₁,
  have h₂ := h P₂,
  finish
end

lemma snd_eq_snd_of_pair_eq_pair {a₁ a₂ b₁ b₂ : Set}
  (h : ∀ z : Set, (∀ w, w ∈ z ↔ w = a₁) ∨ (∀ w, w ∈ z ↔ w = a₁ ∨ w = b₁) ↔
                  (∀ w, w ∈ z ↔ w = a₂) ∨ (∀ w, w ∈ z ↔ w = a₂ ∨ w = b₂)) : b₁ = b₂ :=
begin
  obtain rfl := fst_eq_fst_of_pair_eq_pair h,
  rename a₁ a,
  obtain ⟨P₁, hP₁⟩ := pairing a b₁,
  obtain ⟨P₂, hP₂⟩ := pairing a b₂,
  have h₁ := h P₁, simp [hP₁] at h₁, clear hP₁ P₁,
  have h₂ := h P₂, simp [hP₂] at h₂, clear hP₂ P₂,
  clear h,
  cases h₁; cases h₂,
  { rw [h₁, h₂] },
  { tidy },
  { tidy },
  { specialize h₁ b₁, simp at h₁,
    specialize h₂ b₂, simp at h₂,
    cases h₁; cases h₂; tidy }
end

example {a₁ a₂ b₁ b₂ : Set} :
  (∀ z : Set, (∀ w, w ∈ z ↔ w = a₁) ∨ (∀ w, w ∈ z ↔ w = a₁ ∨ w = b₁) ↔
              (∀ w, w ∈ z ↔ w = a₂) ∨ (∀ w, w ∈ z ↔ w = a₂ ∨ w = b₂)) ↔ a₁ = a₂ ∧ b₁ = b₂ :=
begin
  split; intro h,
  { simp [fst_eq_fst_of_pair_eq_pair h, snd_eq_snd_of_pair_eq_pair h] },
  { simp [h] }
end


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

import data.fin.basic
import data.finset.sort
import data.prod.lex

/-!

# Sorting tuples by their values

Given an `n`-tuple `f : fin n → α` where `α` is ordered,
we may want to turn it into a sorted `n`-tuple.
This file provides an API for doing so, with the sorted `n`-tuple given by
`f ∘ tuple.sort f`.

## Main declarations

* `tuple.sort`: given `f : fin n → α`, produces a permutation on `fin n`
* `tuple.monotone_sort`: `f ∘ tuple.sort f` is `monotone`

-/

namespace tuple

variables {n : ℕ}
variables {α : Type*} [linear_order α]

/--
`graph f` produces the finset of pairs `(f i, i)`
equipped with the lexicographic order.
-/
def graph (f : fin n → α) : finset (α ×ₗ (fin n)) :=
finset.univ.image (λ i, (f i, i))

/--
Given `p : α ×ₗ (fin n) := (f i, i)` with `p ∈ graph f`,
`graph.proj p` is defined to be `f i`.
-/
def graph.proj {f : fin n → α} : graph f → α := λ p, p.1.1

@[simp] lemma graph.card (f : fin n → α) : (graph f).card = n :=
begin
  rw [graph, finset.card_image_of_injective],
  { exact finset.card_fin _ },
  { intros _ _,
    simp }
end

/--
`graph_equiv₁ f` is the natural equivalence between `fin n` and `graph f`,
mapping `i` to `(f i, i)`. -/
def graph_equiv₁ (f : fin n → α) : fin n ≃ graph f :=
{ to_fun := λ i, ⟨(f i, i), by simp [graph]⟩,
  inv_fun := λ p, p.1.2,
  left_inv := λ i, by simp,
  right_inv := λ ⟨⟨x, i⟩, h⟩, by simpa [graph] using h }

@[simp] lemma proj_equiv₁' (f : fin n → α) : graph.proj ∘ graph_equiv₁ f = f :=
rfl

/--
`graph_equiv₂ f` is an equivalence between `fin n` and `graph f` that respects the order.
-/
def graph_equiv₂ (f : fin n → α) : fin n ≃o graph f :=
finset.order_iso_of_fin _ (by simp)

/-- `sort f` is the permutation that orders `fin n` according to the order of the outputs of `f`. -/
def sort (f : fin n → α) : equiv.perm (fin n) :=
(graph_equiv₂ f).to_equiv.trans (graph_equiv₁ f).symm

lemma self_comp_sort (f : fin n → α) : f ∘ sort f = graph.proj ∘ graph_equiv₂ f :=
show graph.proj ∘ ((graph_equiv₁ f) ∘ (graph_equiv₁ f).symm) ∘ (graph_equiv₂ f).to_equiv = _,
  by simp

lemma monotone_proj (f : fin n → α) : monotone (graph.proj : graph f → α) :=
begin
  rintro ⟨⟨x, i⟩, hx⟩ ⟨⟨y, j⟩, hy⟩ (h|h),
  { exact le_of_lt ‹_› },
  { simp [graph.proj] },
end

lemma monotone_sort (f : fin n → α) : monotone (f ∘ sort f) :=
begin
  rw [self_comp_sort],
  exact (monotone_proj f).comp (graph_equiv₂ f).monotone,
end

end tuple


-- Math 52: Week 5

import .utils
open classical

-- The following lemmas may be useful for the next proof.
-- mul_lt_mul_of_pos_left (a b c : ℝ) : a < b → 0 < c → c * a < c * b
-- mul_lt_mul_of_pos_right (a b c : ℝ) : a < b → 0 < c → a * c < b * c

-- Lakins 2.1.2: For all real numbers a and b, if 0 < a < b, then a² < b².
theorem L212 : ∀ (a b : ℝ), 0 < a ∧ a < b → a * a < b * b :=
begin
sorry
end

-- The following lemmas may be useful for the next proof.
-- mul_le_mul_of_nonneg_left (a b c : ℝ) : a ≤ b → 0 ≤ c → c * a ≤ c * b
-- mul_le_mul_of_nonneg_right (a b c : ℝ) : a ≤ b → 0 ≤ c → a * c ≤ b * c
-- mul_le_mul_of_nonpos_left (a b c : ℝ) : b ≤ a → c ≤ 0 → c * a ≤ c * b
-- mul_le_mul_of_nonpos_right (a b c : ℝ) : b ≤ a → c ≤ 0 → a * c ≤ b * c

-- Lakins 2.1.6: For all real numbers x, 0 ≤ x².
theorem L216 : ∀ (x : ℝ), 0 ≤ x * x :=
begin
sorry
end

-- The following lemmas may be useful in the following proof.
-- div_le_of_le_mul_of_pos (a b c : ℝ) : a ≤ b * c → c > 0 → a / c ≤ b
-- le_div_of_mul_le_of_pos (a b c : ℝ) : a * c ≤ b → c > 0 → a ≤ b / c

-- Lakins 2.1.11: For all real numbers x and y, if x ≤ y then x ≤ (x + y)/2 ≤ y.
theorem L2111 : ∀ (x y : ℝ), x ≤ y → x ≤ (x + y)/2 ∧ (x + y)/2 ≤ y :=
begin
sorry
end

-- The following lemmas may be useful in the next proof.
-- ne_of_lt (a b : ℝ) : a < b → a ≠ b
-- mul_pos (a b : ℝ) : a > 0 → b > 0 → a * b > 0
-- mul_neg_of_pos_of_neg (a b : ℝ) : a > 0 → b < 0 → a * b < 0
-- mul_neg_of_neg_of_pos (a b : ℝ) : a < 0 → b > 0 → a * b < 0
-- mul_pos_of_neg_of_neg (a b : ℝ) : a < 0 → b < 0 → a * b > 0

-- Lakins 2.1.7: For all real numbers x and y, if xy = 0, then x = 0 or y = 0.
theorem L217 : ∀ (x y : ℝ), x * y = 0 → x = 0 ∨ y = 0 :=
begin
sorry
end

-- This is a really tricky proof!
-- Lakins 2.1.9: For all real numbers x and y, if x² = y², then x = y or x = −y; i.e., x = ±y.
theorem L219 : ∀ (x y : ℝ), x * x = y * y → x = y ∨ x = -y :=
begin
intros x y H,
have L : x - y = 0 ∨ x + y = 0,
begin
apply L217,
calc (x - y) * (x + y)
= x * (x + y) - y * (x + y) : by rw sub_mul ...
= (x * x + x * y) - y * (x + y) : by rw mul_add ...
= (x * x + x * y) - (y * x + y * y) : by rw mul_add ...
= ((x * x + x * y) - y * x) - y * y : by rw sub_sub ...
= ((x * x + x * y) - x * y) - y * y : by ac_refl ...
= x * x - y * y : by rw add_sub_cancel ...
= x * x - x * x : by rw H ...
= 0 : by rw sub_self,
end,
cases L,
{ left,
  apply eq_of_sub_eq_zero,
  assumption
},
{ right,
  apply eq_of_sub_eq_zero,
  rw sub_neg_eq_add,
  assumption,
},
end


-- Interseccion_con_la_imagen_inversa.lean
-- Intersección con la imagen inversa
-- José A. Alonso Jiménez
-- Sevilla, 21 de junio de 2021
-- ---------------------------------------------------------------------

-- ---------------------------------------------------------------------
-- Demostrar que
--    s ∩ f ⁻¹' v ⊆ f ⁻¹' (f '' s ∩ v)
-- ----------------------------------------------------------------------

import data.set.basic

open set

variables {α : Type*} {β : Type*}
variable  f : α → β
variable  s : set α
variable  v : set β

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

example : s ∩ f ⁻¹' v ⊆ f ⁻¹' (f '' s ∩ v) :=
begin
  intros x hx,
  rw mem_preimage,
  split,
  { apply mem_image_of_mem,
    exact hx.1, },
  { rw ← mem_preimage,
    exact hx.2, },
end

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

example : s ∩ f ⁻¹' v ⊆ f ⁻¹' (f '' s ∩ v) :=
begin
  rintros x ⟨xs, xv⟩,
  split,
  { exact mem_image_of_mem f xs, },
  { exact xv, },
end

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

example : s ∩ f ⁻¹' v ⊆ f ⁻¹' (f '' s ∩ v) :=
begin
  rintros x ⟨xs, xv⟩,
  exact ⟨mem_image_of_mem f xs, xv⟩,
end

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

example : s ∩ f ⁻¹' v ⊆ f ⁻¹' (f '' s ∩ v) :=
begin
  rintros x ⟨xs, xv⟩,
  show f x ∈ f '' s ∩ v,
  split,
  { use [x, xs, rfl] },
  { exact xv },
end

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

example : s ∩ f ⁻¹' v ⊆ f ⁻¹' (f '' s ∩ v) :=
inter_preimage_subset s v f


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

import Algdata.Init.Nat

/-!
# A variety of recursions on `Nat`
-/

universe u

namespace Nat

/-!
## Complete induction

Given a predicate `p : Nat → Prop`, one can conclude `∀ n, p n` provided `∀ n, (∀ k, k < n → p k) → p n`.
-/

/-- Complete induction using well-founded recursion -/
@[inline]
def recCompleteWF {motive : Nat → Sort u} (ind : (n : Nat) → (∀ (k : Nat), k < n → motive k) → motive n) (n : Nat) : motive n :=
  ind n (λ k _ => recCompleteWF ind k)

/-- Complete induction without well-founded recursion -/
@[implemented_by recCompleteWF]
def recComplete {motive : Nat → Sort u} (ind : (n : Nat) → (∀ (k : Nat), k < n → motive k) → motive n) (n : Nat) : motive n :=
  let rec aux : (n k : Nat) → k ≤ n → motive k
  | 0, k, hk =>
    have : k = 0 := Nat.eq_zero_of_le_zero hk
    ind k (λ l hl => absurd (this ▸ hl) l.not_lt_zero)
  | _+1, 0, _ => ind 0 (λ k hk => absurd hk k.not_lt_zero)
  | n+1, k+1, hk =>
    ind (k+1) (λ l hl => aux n l (Nat.le_of_lt_succ $ Trans.trans hl hk))
  aux n n n.le_refl

/-- Proof that the two implememtations of the complete induction are equivalent. -/
theorem recComplete_eq {motive : Nat → Sort u} {ind : (n : Nat) → (∀ (k : Nat), k < n → motive k) → motive n} {n : Nat} : recComplete (motive:=motive) ind n = recCompleteWF (motive:=motive) ind n := by
  suffices ∀ k (hk : k ≤ n), recComplete.aux (motive:=motive) ind n k hk = recCompleteWF (motive:=motive) ind k
    from this n n.le_refl
  intro k hk
  induction n generalizing k
  case zero =>
    dsimp [recComplete.aux]; unfold recCompleteWF
    have : k = 0 := k.eq_zero_of_le_zero hk
    cases this
    apply congrArg; funext k hk; cases hk
  case succ n h_ind =>
    cases k
    case zero =>
      dsimp [recComplete.aux]; unfold recCompleteWF
      apply congrArg; funext k hk; cases hk
    case succ k =>
      dsimp [recComplete.aux]; unfold recCompleteWF
      apply congrArg; funext k hk; rw [h_ind]

/-!
## Ascending recursion with upper bound. -/

def recAscend {motive : Nat → Sort u} {n : Nat} (ceil : motive n) (ascend : ∀ (k : Nat), k < n → motive k.succ → motive k) (k : Nat) (h : k ≤ n) : motive k :=
  if hlt : k < n
    then ascend k hlt (recAscend ceil ascend k.succ (Nat.succ_le_of_lt hlt))
    else
      have : k = n := Nat.le_antisymm h (Nat.le_of_not_lt hlt)
      this ▸ ceil
termination_by _ => n-k

/-!
### Recursion on base2 digits
-/

@[inline]
def recBase2 {motive : Nat → Sort u} (zero : motive 0) (one : motive 1) (div2 : (n : Nat) → motive (n/2 + 1) → motive (n + 2)) (n : Nat) : motive n :=
  n.recComplete $ λ n ind =>
    match n with
    | 0 => zero
    | 1 => one
    | n+2 =>
      have : n/2 + 1 < n+2 := calc
        n/2 + 1 = (n+2)/2 := Eq.symm $ Nat.add_div_right _ (Nat.zero_lt_succ 1)
        _       < n+2     := Nat.div_lt_self (Nat.zero_lt_succ _) (Nat.lt.base 1)
      div2 n (ind _ this)

section recBase2_rec

variable {motive : Nat → Sort u} {zero : motive 0} {one : motive 1} {div2 : (n : Nat) → motive (n/2 + 1) → motive (n+2)}

theorem recBase2_zero : recBase2 zero one div2 0 = zero := rfl
theorem recBase2_one : recBase2 zero one div2 1 = one := rfl
theorem recBase2_div2 {n : Nat} : recBase2 zero one div2 (n+2) = div2 n (recBase2 zero one div2 (n/2+1)) := by
  unfold recBase2; rw [recComplete_eq, recComplete_eq]
  conv =>
    lhs; unfold recCompleteWF

end recBase2_rec

end Nat


import .lovelib

/- # LoVe Homework 8: Operational Semantics

Homework must be done individually. -/

set_option pp.beta true
set_option pp.generalized_field_notation false

namespace LoVe

/- ## Question 1 (6 points + 1 bonus point): Semantics of the REPEAT Language

We introduce REPEAT, a programming language that resembles the WHILE language
but whose defining feature is a `repeat` loop.

The Lean definition of its abstract syntax tree follows: -/

inductive stmt : Type
| skip   : stmt
| assign : string → (state → ℕ) → stmt
| seq    : stmt → stmt → stmt
| unless : (state → Prop) → stmt → stmt
| repeat : ℕ → stmt → stmt

infixr ` ;; ` : 90 := stmt.seq

/- The `skip`, `assign`, and `S ;; T` statements have the same syntax and
semantics as in the WHILE language.

The `unless b S` statement executes `S` unless `b` is true—i.e., it executes `S`
if `b` is false. Otherwise, `unless b S` does nothing. This construct is
inspired by the Perl language.

The `repeat n S` statement executes `S` exactly `n` times. Thus, `repeat 5 S` is
equivalent to `S ;; S ;; S ;; S ;; S` (in terms of a big-step semantics at
least) and `repeat 0 S` is equivalent to `skip`.

1.1 (1.5 points). Complete the following definition of a big-step
semantics: -/

inductive big_step : stmt × state → state → Prop
| skip {s} :
  big_step (stmt.skip, s) s
-- enter the missing cases here

infix ` ⟹ ` : 110 := big_step

/- 1.2 (1.5 points). Complete the following definition of a small-step
semantics: -/

inductive small_step : stmt × state → stmt × state → Prop
| assign {x a s} :
  small_step (stmt.assign x a, s) (stmt.skip, s{x ↦ a s})
-- enter the missing cases here

infixr ` ⇒ ` := small_step
infixr ` ⇒* ` : 100 := star small_step

/- 1.3 (1 point). We will now attempt to prove termination of the REPEAT
language. More precisely, we will show that there cannot be infinite chains of
the form

    `(S₀, s₀) ⇒ (S₁, s₁) ⇒ (S₂, s₂) ⇒ ⋯`

Towards this goal, you are asked to define a __measure__ function: a function
`mess` that takes a statement `S` and that returns a natural number indicating
how "big" the statement is. The measure should be defined so that it strictly
decreases with each small-step transition. -/

def mess : stmt → ℕ
| stmt.skip         := 0
-- enter the missing cases here

/- 1.4 (1 point). Consider the following program `S₀`: -/

def incr (x : string) : stmt :=
stmt.assign x (λs, s x + 1)

def S₀ : stmt :=
stmt.repeat 1 (incr "m" ;; incr "n")

/- Check that `mess` strictly decreases with each step of its small-step
evaluation, by giving `S₀`, `S₁`, `S₂`, …, as well as the corresponding values
of `mess` (which you can obtain using `#eval`). -/

-- enter your answer here

/- 1.5 (1 point). Prove that the measure decreases with each small-step
transition. If necessary, revise your answer to question 1.3. -/

lemma small_step_mess_decreases {Ss Tt : stmt × state} (h : Ss ⇒ Tt) :
  mess (prod.fst Ss) > mess (prod.fst Tt) :=
sorry

/- 1.6 (1 bonus point). Prove that the inverse of the `⇒` relation is well
founded. The inverse is simply `λTt Ss, Ss ⇒ Tt`. A relation `≺` is well founded
if there exist no infinite left-descending chains of the form

    `⋯ ≺ x₂ ≺ x₁ ≺ x₀`

Proof strategy: The `measure` function from `mathlib` converts a function to `ℕ`
to a relation, using `<` to compare two numbers. Hence, start by proving that
`measure mess`, or rather `measure (mess ∘ prod.fst)`, is well founded. Here,
`library_search` can help, or just search manually in `wf.lean`, close to the
definition of `measure`. Then prove that `λTt Ss, Ss ⇒ Tt` is a subrelation of
`measure (mess ∘ prod.fst)` (using lemma `small_step_mess_decreases` from
question 1.4) and therefore (using another lemma from `wf.lean`) that it must be
well founded. -/

lemma small_step_wf :
  well_founded (λTt Ss, Ss ⇒ Tt) :=
sorry

/- ## Question 2 (3 points): Inversion Rules

2.1 (1 point). Prove the following inversion rule for the big-step semantics
of `unless`. -/

lemma big_step_ite_iff {b S s t} :
  (stmt.unless b S, s) ⟹ t ↔ (b s ∧ s = t) ∨ (¬ b s ∧ (S, s) ⟹ t) :=
sorry

/- 2.2 (2 points). Prove the following inversion rule for the big-step
semantics of `repeat`. -/

lemma big_step_repeat_iff {n S s u} :
  (stmt.repeat n S, s) ⟹ u ↔
  (n = 0 ∧ u = s)
  ∨ (∃m t, n = m + 1 ∧ (S, s) ⟹ t ∧ (stmt.repeat m S, t) ⟹ u) :=
sorry

end LoVe


/-
Copyright (c) 2018 Chris Hughes. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Chris Hughes, Johannes Hölzl, Scott Morrison, Jens Wagemaker
-/
import data.polynomial.derivative
import tactic.ring_exp

/-!
# Theory of univariate polynomials

The main def is `binom_expansion`.
-/

noncomputable theory

namespace polynomial
universes u v w x y z
variables {R : Type u} {S : Type v} {T : Type w} {ι : Type x} {k : Type y} {A : Type z}
  {a b : R} {m n : ℕ}

section identities

/- @TODO: pow_add_expansion and pow_sub_pow_factor are not specific to polynomials.
  These belong somewhere else. But not in group_power because they depend on tactic.ring_exp

Maybe use data.nat.choose to prove it.
 -/
/--
`(x + y)^n` can be expressed as `x^n + n*x^(n-1)*y + k * y^2` for some `k` in the ring.
-/
def pow_add_expansion {R : Type*} [comm_semiring R] (x y : R) : ∀ (n : ℕ),
  {k // (x + y)^n = x^n + n*x^(n-1)*y + k * y^2}
| 0 := ⟨0, by simp⟩
| 1 := ⟨0, by simp⟩
| (n+2) :=
  begin
    cases pow_add_expansion (n+1) with z hz,
    existsi x*z + (n+1)*x^n+z*y,
    calc (x + y) ^ (n + 2) = (x + y) * (x + y) ^ (n + 1) : by ring_exp
    ... = (x + y) * (x ^ (n + 1) + ↑(n + 1) * x ^ (n + 1 - 1) * y + z * y ^ 2) : by rw hz
    ... = x ^ (n + 2) + ↑(n + 2) * x ^ (n + 1) * y + (x*z + (n+1)*x^n+z*y) * y ^ 2 :
      by { push_cast, ring_exp! }
  end

variables [comm_ring R]

private def poly_binom_aux1 (x y : R) (e : ℕ) (a : R) :
  {k : R // a * (x + y)^e = a * (x^e + e*x^(e-1)*y + k*y^2)} :=
begin
  existsi (pow_add_expansion x y e).val,
  congr,
  apply (pow_add_expansion _ _ _).property
end

private lemma poly_binom_aux2 (f : polynomial R) (x y : R) :
  f.eval (x + y) = f.sum (λ e a, a * (x^e + e*x^(e-1)*y + (poly_binom_aux1 x y e a).val*y^2)) :=
begin
  unfold eval eval₂, congr' with n z,
  apply (poly_binom_aux1 x y _ _).property
end

private lemma poly_binom_aux3 (f : polynomial R) (x y : R) : f.eval (x + y) =
  f.sum (λ e a, a * x^e) +
  f.sum (λ e a, (a * e * x^(e-1)) * y) +
  f.sum (λ e a, (a *(poly_binom_aux1 x y e a).val)*y^2) :=
by { rw poly_binom_aux2, simp [left_distrib, sum_add, mul_assoc] }

/--
A polynomial `f` evaluated at `x + y` can be expressed as
the evaluation of `f` at `x`, plus `y` times the (polynomial) derivative of `f` at `x`,
plus some element `k : R` times `y^2`.
-/
def binom_expansion (f : polynomial R) (x y : R) :
  {k : R // f.eval (x + y) = f.eval x + (f.derivative.eval x) * y + k * y^2} :=
begin
  existsi f.sum (λ e a, a *((poly_binom_aux1 x y e a).val)),
  rw poly_binom_aux3,
  congr,
  { rw [←eval_eq_sum], },
  { rw derivative_eval, exact finset.sum_mul.symm },
  { exact finset.sum_mul.symm }
end

/--
`x^n - y^n` can be expressed as `z * (x - y)` for some `z` in the ring.
-/
def pow_sub_pow_factor (x y : R) : Π (i : ℕ), {z : R // x^i - y^i = z * (x - y)}
| 0 := ⟨0, by simp⟩
| 1 := ⟨1, by simp⟩
| (k+2) :=
  begin
    cases @pow_sub_pow_factor (k+1) with z hz,
    existsi z*x + y^(k+1),
    calc x ^ (k + 2) - y ^ (k + 2)
        = x * (x ^ (k + 1) - y ^ (k + 1)) + (x * y ^ (k + 1) - y ^ (k + 2)) : by ring_exp
    ... = x * (z * (x - y)) + (x * y ^ (k + 1) - y ^ (k + 2)) : by rw hz
    ... = (z * x + y ^ (k + 1)) * (x - y) : by ring_exp
  end

/--
For any polynomial `f`, `f.eval x - f.eval y` can be expressed as `z * (x - y)`
for some `z` in the ring.
-/
def eval_sub_factor (f : polynomial R) (x y : R) :
  {z : R // f.eval x - f.eval y = z * (x - y)} :=
begin
  refine ⟨f.sum (λ i r, r * (pow_sub_pow_factor x y i).val), _⟩,
  delta eval eval₂,
  simp only [sum, ← finset.sum_sub_distrib, finset.sum_mul],
  dsimp,
  congr' with i r,
  rw [mul_assoc, ←(pow_sub_pow_factor x y _).prop, mul_sub],
end

end identities

end polynomial


/-
Copyright (c) 2020 David Wärn. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: David Wärn
-/
import category_theory.elements
import category_theory.is_connected
import category_theory.single_obj
import group_theory.group_action.basic
import group_theory.semidirect_product

/-!
# Actions as functors and as categories

From a multiplicative action M ↻ X, we can construct a functor from M to the category of
types, mapping the single object of M to X and an element `m : M` to map `X → X` given by
multiplication by `m`.
  This functor induces a category structure on X -- a special case of the category of elements.
A morphism `x ⟶ y` in this category is simply a scalar `m : M` such that `m • x = y`. In the case
where M is a group, this category is a groupoid -- the `action groupoid'.
-/

open mul_action semidirect_product
namespace category_theory

universes u

variables (M : Type*) [monoid M] (X : Type u) [mul_action M X]

/-- A multiplicative action M ↻ X viewed as a functor mapping the single object of M to X
  and an element `m : M` to the map `X → X` given by multiplication by `m`. -/
@[simps]
def action_as_functor : single_obj M ⥤ Type u :=
{ obj := λ _, X,
  map := λ _ _, (•),
  map_id' := λ _, funext $ mul_action.one_smul,
  map_comp' := λ _ _ _ f g, funext $ λ x, (smul_smul g f x).symm }

/-- A multiplicative action M ↻ X induces a category strucure on X, where a morphism
 from x to y is a scalar taking x to y. Due to implementation details, the object type
 of this category is not equal to X, but is in bijection with X. -/
@[derive category]
def action_category := (action_as_functor M X).elements

namespace action_category

/-- The projection from the action category to the monoid, mapping a morphism to its
  label. -/
def π : action_category M X ⥤ single_obj M :=
category_of_elements.π _

@[simp]
lemma π_map (p q : action_category M X) (f : p ⟶ q) : (π M X).map f = f.val := rfl

@[simp]
lemma π_obj (p : action_category M X) : (π M X).obj p = single_obj.star M :=
unit.ext

variables {M X}
/-- The canonical map `action_category M X → X`. It is given by `λ x, x.snd`, but
  has a more explicit type. -/
protected def back : action_category M X → X :=
λ x, x.snd

instance : has_coe_t X (action_category M X) :=
⟨λ x, ⟨(), x⟩⟩

@[simp] lemma coe_back (x : X) : (↑x : action_category M X).back = x := rfl
@[simp] lemma back_coe (x : action_category M X) : ↑(x.back) = x := by ext; refl

variables (M X)

/-- An object of the action category given by M ↻ X corresponds to an element of X. -/
def obj_equiv : X ≃ action_category M X :=
{ to_fun := coe,
  inv_fun := λ x, x.back,
  left_inv := coe_back,
  right_inv := back_coe }

lemma hom_as_subtype (p q : action_category M X) :
  (p ⟶ q) = { m : M // m • p.back = q.back } := rfl

instance [inhabited X] : inhabited (action_category M X) :=
{ default := ↑(default X) }

instance [nonempty X] : nonempty (action_category M X) :=
nonempty.map (obj_equiv M X) infer_instance

variables {X} (x : X)
/-- The stabilizer of a point is isomorphic to the endomorphism monoid at the
  corresponding point. In fact they are definitionally equivalent. -/
def stabilizer_iso_End : stabilizer.submonoid M x ≃* End (↑x : action_category M X) :=
mul_equiv.refl _

@[simp]
lemma stabilizer_iso_End_apply (f : stabilizer.submonoid M x) :
  (stabilizer_iso_End M x).to_fun f = f := rfl

@[simp]
lemma stabilizer_iso_End_symm_apply (f : End _) :
  (stabilizer_iso_End M x).inv_fun f = f := rfl

variables {M X}

@[simp] protected

@[simp] protected lemma comp_val {x y z : action_category M X}
  (f : x ⟶ y) (g : y ⟶ z) : (f ≫ g).val = g.val * f.val := rfl

instance [is_pretransitive M X] [nonempty X] : is_connected (action_category M X) :=
zigzag_is_connected $ λ x y, relation.refl_trans_gen.single $ or.inl $
  nonempty_subtype.mpr (show _, from exists_smul_eq M x.back y.back)

section group

variables {G : Type*} [group G] [mul_action G X]

noncomputable instance : groupoid (action_category G X) :=
category_theory.groupoid_of_elements _

/-- Any subgroup of `G` is a vertex group in its action groupoid. -/
def End_mul_equiv_subgroup (H : subgroup G) :
  End (obj_equiv G (quotient_group.quotient H) ↑(1 : G)) ≃* H :=
mul_equiv.trans
  (stabilizer_iso_End G ((1 : G) : quotient_group.quotient H)).symm
  (mul_equiv.subgroup_congr $ stabilizer_quotient H)

/-- A target vertex `t` and a scalar `g` determine a morphism in the action groupoid. -/
def hom_of_pair (t : X) (g : G) : ↑(g⁻¹ • t) ⟶ (t : action_category G X) :=
subtype.mk g (smul_inv_smul g t)

@[simp] lemma hom_of_pair.val (t : X) (g : G) : (hom_of_pair t g).val = g := rfl

/-- Any morphism in the action groupoid is given by some pair. -/
protected def cases {P : Π ⦃a b : action_category G X⦄, (a ⟶ b) → Sort*}
  (hyp : ∀ t g, P (hom_of_pair t g)) ⦃a b⦄ (f : a ⟶ b) : P f :=
begin
  refine cast _ (hyp b.back f.val),
  rcases a with ⟨⟨⟩, a : X⟩,
  rcases b with ⟨⟨⟩, b : X⟩,
  rcases f with ⟨g : G, h : g • a = b⟩,
  cases (inv_smul_eq_iff.mpr h.symm),
  refl
end

variables {H : Type*} [group H]

/-- Given `G` acting on `X`, a functor from the corresponding action groupoid to a group `H`
    can be curried to a group homomorphism `G →* (X → H) ⋊ G`. -/
@[simps] def curry (F : action_category G X ⥤ single_obj H) :
  G →* (X → H) ⋊[mul_aut_arrow] G :=
have F_map_eq : ∀ {a b} {f : a ⟶ b}, F.map f = (F.map (hom_of_pair b.back f.val) : H) :=
  action_category.cases (λ _ _, rfl),
{ to_fun := λ g, ⟨λ b, F.map (hom_of_pair b g), g⟩,
  map_one' := by { congr, funext, exact F_map_eq.symm.trans (F.map_id b) },
  map_mul' := begin
    intros g h,
    congr, funext,
    exact F_map_eq.symm.trans (F.map_comp (hom_of_pair (g⁻¹ • b) h) (hom_of_pair b g)),
  end }

/-- Given `G` acting on `X`, a group homomorphism `φ : G →* (X → H) ⋊ G` can be uncurried to
    a functor from the action groupoid to `H`, provided that `φ g = (_, g)` for all `g`. -/
@[simps] def uncurry (F : G →* (X → H) ⋊[mul_aut_arrow] G) (sane : ∀ g, (F g).right = g) :
  action_category G X ⥤ single_obj H :=
{ obj := λ _, (),
  map := λ a b f, ((F f.val).left b.back),
  map_id' := by { intro x, rw [action_category.id_val, F.map_one], refl },
  map_comp' := begin
    intros x y z f g, revert y z g,
    refine action_category.cases _,
    simp [single_obj.comp_as_mul, sane],
  end }

end group

end action_category
end category_theory


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

import deprecated.subring
import group_theory.subgroup
import ring_theory.subsemiring

/-!
# Subrings

Let `R` be a ring. This file defines the "bundled" subring type `subring R`, a type
whose terms correspond to subrings of `R`. This is the preferred way to talk
about subrings in mathlib. Unbundled subrings (`s : set R` and `is_subring s`)
are not in this file, and they will ultimately be deprecated.

We prove that subrings are a complete lattice, and that you can `map` (pushforward) and
`comap` (pull back) them along ring homomorphisms.

We define the `closure` construction from `set R` to `subring R`, sending a subset of `R`
to the subring it generates, and prove that it is a Galois insertion.

## Main definitions

Notation used here:

`(R : Type u) [ring R] (S : Type u) [ring S] (f g : R →+* S)`
`(A : subring R) (B : subring S) (s : set R)`

* `subring R` : the type of subrings of a ring `R`.

* `instance : complete_lattice (subring R)` : the complete lattice structure on the subrings.

* `subring.closure` : subring closure of a set, i.e., the smallest subring that includes the set.

* `subring.gi` : `closure : set M → subring M` and coercion `coe : subring M → set M`
  form a `galois_insertion`.

* `comap f B : subring A` : the preimage of a subring `B` along the ring homomorphism `f`

* `map f A : subring B` : the image of a subring `A` along the ring homomorphism `f`.

* `prod A B : subring (R × S)` : the product of subrings

* `f.range : subring B` : the range of the ring homomorphism `f`.

* `eq_locus f g : subring R` : given ring homomorphisms `f g : R →+* S`,
     the subring of `R` where `f x = g x`

## Implementation notes

A subring is implemented as a subsemiring which is also an additive subgroup.
The initial PR was as a submonoid which is also an additive subgroup.

Lattice inclusion (e.g. `≤` and `⊓`) is used rather than set notation (`⊆` and `∩`), although
`∈` is defined as membership of a subring's underlying set.

## Tags
subring, subrings
-/

open_locale big_operators
universes u v w

variables {R : Type u} {S : Type v} {T : Type w} [ring R] [ring S] [ring T]

set_option old_structure_cmd true

/-- `subring R` is the type of subrings of `R`. A subring of `R` is a subset `s` that is a
  multiplicative submonoid and an additive subgroup. Note in particular that it shares the
  same 0 and 1 as R. -/
structure subring (R : Type u) [ring R] extends subsemiring R, add_subgroup R

/-- Reinterpret a `subring` as a `subsemiring`. -/
add_decl_doc subring.to_subsemiring

/-- Reinterpret a `subring` as an `add_subgroup`. -/
add_decl_doc subring.to_add_subgroup

namespace subring

/-- The underlying submonoid of a subring. -/
def to_submonoid (s : subring R) : submonoid R :=
{ carrier := s.carrier,
  ..s.to_subsemiring.to_submonoid }

instance : set_like (subring R) R :=
⟨subring.carrier, λ p q h, by cases p; cases q; congr'⟩

@[simp]
lemma mem_carrier {s : subring R} {x : R} : x ∈ s.carrier ↔ x ∈ s := iff.rfl

/-- Two subrings are equal if they have the same elements. -/
@[ext] theorem ext {S T : subring R} (h : ∀ x, x ∈ S ↔ x ∈ T) : S = T := set_like.ext h

/-- Copy of a subring with a new `carrier` equal to the old one. Useful to fix definitional
equalities. -/
protected def copy (S : subring R) (s : set R) (hs : s = ↑S) : subring R :=
{ carrier := s,
  neg_mem' := hs.symm ▸ S.neg_mem',
  ..S.to_subsemiring.copy s hs }

lemma to_subsemiring_injective : function.injective (to_subsemiring : subring R → subsemiring R)
| r s h := ext (set_like.ext_iff.mp h : _)

@[mono]
lemma to_subsemiring_strict_mono : strict_mono (to_subsemiring : subring R → subsemiring R) :=
λ _ _, id

@[mono]
lemma to_subsemiring_mono : monotone (to_subsemiring : subring R → subsemiring R) :=
to_subsemiring_strict_mono.monotone

lemma to_add_subgroup_injective : function.injective (to_add_subgroup : subring R → add_subgroup R)
| r s h := ext (set_like.ext_iff.mp h : _)

@[mono]
lemma to_add_subgroup_strict_mono : strict_mono (to_add_subgroup : subring R → add_subgroup R) :=
λ _ _, id

@[mono]
lemma to_add_subgroup_mono : monotone (to_add_subgroup : subring R → add_subgroup R) :=
to_add_subgroup_strict_mono.monotone

lemma to_submonoid_injective : function.injective (to_submonoid : subring R → submonoid R)
| r s h := ext (set_like.ext_iff.mp h : _)

@[mono]
lemma to_submonoid_strict_mono : strict_mono (to_submonoid : subring R → submonoid R) :=
λ _ _, id

@[mono]
lemma to_submonoid_mono : monotone (to_submonoid : subring R → submonoid R) :=
to_submonoid_strict_mono.monotone

/-- Construct a `subring R` from a set `s`, a submonoid `sm`, and an additive
subgroup `sa` such that `x ∈ s ↔ x ∈ sm ↔ x ∈ sa`. -/
protected def mk' (s : set R) (sm : submonoid R) (sa : add_subgroup R)
  (hm : ↑sm = s) (ha : ↑sa = s) :
  subring R :=
{ carrier := s,
  zero_mem' := ha ▸ sa.zero_mem,
  one_mem' := hm ▸ sm.one_mem,
  add_mem' := λ x y, by simpa only [← ha] using sa.add_mem,
  mul_mem' := λ x y, by simpa only [← hm] using sm.mul_mem,
  neg_mem' := λ x, by simpa only [← ha] using sa.neg_mem, }

@[simp] lemma coe_mk' {s : set R} {sm : submonoid R} (hm : ↑sm = s)
  {sa : add_subgroup R} (ha : ↑sa = s) :
  (subring.mk' s sm sa hm ha : set R) = s := rfl

@[simp] lemma mem_mk' {s : set R} {sm : submonoid R} (hm : ↑sm = s)
  {sa : add_subgroup R} (ha : ↑sa = s) {x : R} :
  x ∈ subring.mk' s sm sa hm ha ↔ x ∈ s :=
iff.rfl

@[simp] lemma mk'_to_submonoid {s : set R} {sm : submonoid R} (hm : ↑sm = s)
  {sa : add_subgroup R} (ha : ↑sa = s) :
  (subring.mk' s sm sa hm ha).to_submonoid = sm :=
set_like.coe_injective hm.symm

@[simp] lemma mk'_to_add_subgroup {s : set R} {sm : submonoid R} (hm : ↑sm = s)
  {sa : add_subgroup R} (ha : ↑sa  =s) :
  (subring.mk' s sm sa hm ha).to_add_subgroup = sa :=
set_like.coe_injective ha.symm

end subring

/-- Construct a `subring` from a set satisfying `is_subring`. -/
def set.to_subring (S : set R) [is_subring S] : subring R :=
{ carrier := S,
  one_mem' := is_submonoid.one_mem,
  mul_mem' := λ a b, is_submonoid.mul_mem,
  zero_mem' := is_add_submonoid.zero_mem,
  add_mem' := λ a b, is_add_submonoid.add_mem,
  neg_mem' := λ a, is_add_subgroup.neg_mem }

/-- A `subsemiring` containing -1 is a `subring`. -/
def subsemiring.to_subring (s : subsemiring R) (hneg : (-1 : R) ∈ s) : subring R :=
{ neg_mem' := by { rintros x, rw <-neg_one_mul, apply subsemiring.mul_mem, exact hneg, }
..s.to_submonoid, ..s.to_add_submonoid }

namespace subring

variables (s : subring R)

/-- A subring contains the ring's 1. -/
theorem one_mem : (1 : R) ∈ s := s.one_mem'

/-- A subring contains the ring's 0. -/
theorem zero_mem : (0 : R) ∈ s := s.zero_mem'

/-- A subring is closed under multiplication. -/
theorem mul_mem : ∀ {x y : R}, x ∈ s → y ∈ s → x * y ∈ s := s.mul_mem'

/-- A subring is closed under addition. -/
theorem add_mem : ∀ {x y : R}, x ∈ s → y ∈ s → x + y ∈ s := s.add_mem'

/-- A subring is closed under negation. -/
theorem neg_mem : ∀ {x : R}, x ∈ s → -x ∈ s := s.neg_mem'

/-- A subring is closed under subtraction -/
theorem sub_mem {x y : R} (hx : x ∈ s) (hy : y ∈ s) : x - y ∈ s :=
by { rw sub_eq_add_neg, exact s.add_mem hx (s.neg_mem hy) }

/-- Product of a list of elements in a subring is in the subring. -/
lemma list_prod_mem {l : list R} : (∀x ∈ l, x ∈ s) → l.prod ∈ s :=
s.to_submonoid.list_prod_mem

/-- Sum of a list of elements in a subring is in the subring. -/
lemma list_sum_mem {l : list R} : (∀x ∈ l, x ∈ s) → l.sum ∈ s :=
s.to_add_subgroup.list_sum_mem

/-- Product of a multiset of elements in a subring of a `comm_ring` is in the subring. -/
lemma multiset_prod_mem {R} [comm_ring R] (s : subring R) (m : multiset R) :
  (∀a ∈ m, a ∈ s) → m.prod ∈ s :=
s.to_submonoid.multiset_prod_mem m

/-- Sum of a multiset of elements in an `subring` of a `ring` is
in the `subring`. -/
lemma multiset_sum_mem {R} [ring R] (s : subring R) (m : multiset R) :
  (∀a ∈ m, a ∈ s) → m.sum ∈ s :=
s.to_add_subgroup.multiset_sum_mem m

/-- Product of elements of a subring of a `comm_ring` indexed by a `finset` is in the
    subring. -/
lemma prod_mem {R : Type*} [comm_ring R] (s : subring R)
  {ι : Type*} {t : finset ι} {f : ι → R} (h : ∀c ∈ t, f c ∈ s) :
  ∏ i in t, f i ∈ s :=
s.to_submonoid.prod_mem h

/-- Sum of elements in a `subring` of a `ring` indexed by a `finset`
is in the `subring`. -/
lemma sum_mem {R : Type*} [ring R] (s : subring R)
  {ι : Type*} {t : finset ι} {f : ι → R} (h : ∀c ∈ t, f c ∈ s) :
  ∑ i in t, f i ∈ s :=
s.to_add_subgroup.sum_mem h

lemma pow_mem {x : R} (hx : x ∈ s) (n : ℕ) : x^n ∈ s := s.to_submonoid.pow_mem hx n

lemma gsmul_mem {x : R} (hx : x ∈ s) (n : ℤ) :
  n • x ∈ s := s.to_add_subgroup.gsmul_mem hx n

lemma coe_int_mem (n : ℤ) : (n : R) ∈ s :=
by simp only [← gsmul_one, gsmul_mem, one_mem]

/-- A subring of a ring inherits a ring structure -/
instance to_ring : ring s :=
{ right_distrib := λ x y z, subtype.eq $ right_distrib x y z,
  left_distrib := λ x y z, subtype.eq $ left_distrib x y z,
  .. s.to_submonoid.to_monoid, .. s.to_add_subgroup.to_add_comm_group }

@[simp, norm_cast] lemma coe_add (x y : s) : (↑(x + y) : R) = ↑x + ↑y := rfl
@[simp, norm_cast] lemma coe_neg (x : s) : (↑(-x) : R) = -↑x := rfl
@[simp, norm_cast] lemma coe_mul (x y : s) : (↑(x * y) : R) = ↑x * ↑y := rfl
@[simp, norm_cast] lemma coe_zero : ((0 : s) : R) = 0 := rfl
@[simp, norm_cast] lemma coe_one : ((1 : s) : R) = 1 := rfl
@[simp, norm_cast] lemma coe_pow (x : s) (n : ℕ) : (↑(x ^ n) : R) = x ^ n :=
s.to_submonoid.coe_pow x n

@[simp] lemma coe_eq_zero_iff {x : s} : (x : R) = 0 ↔ x = 0 :=
⟨λ h, subtype.ext (trans h s.coe_zero.symm),
 λ h, h.symm ▸ s.coe_zero⟩

/-- A subring of a `comm_ring` is a `comm_ring`. -/
instance to_comm_ring {R} [comm_ring R] (s : subring R) : comm_ring s :=
{ mul_comm := λ _ _, subtype.eq $ mul_comm _ _, ..subring.to_ring s}

/-- A subring of a non-trivial ring is non-trivial. -/
instance {R} [ring R] [nontrivial R] (s : subring R) : nontrivial s :=
s.to_subsemiring.nontrivial

/-- A subring of a ring with no zero divisors has no zero divisors. -/
instance {R} [ring R] [no_zero_divisors R] (s : subring R) : no_zero_divisors s :=
s.to_subsemiring.no_zero_divisors

/-- A subring of an integral domain is an integral domain. -/
instance {R} [integral_domain R] (s : subring R) : integral_domain s :=
{ .. s.nontrivial, .. s.no_zero_divisors, .. s.to_comm_ring }

/-- A subring of an `ordered_ring` is an `ordered_ring`. -/
instance to_ordered_ring {R} [ordered_ring R] (s : subring R) : ordered_ring s :=
subtype.coe_injective.ordered_ring coe rfl rfl (λ _ _, rfl) (λ _ _, rfl) (λ _, rfl) (λ _ _, rfl)

/-- A subring of an `ordered_comm_ring` is an `ordered_comm_ring`. -/
instance to_ordered_comm_ring {R} [ordered_comm_ring R] (s : subring R) : ordered_comm_ring s :=
subtype.coe_injective.ordered_comm_ring coe rfl rfl
  (λ _ _, rfl) (λ _ _, rfl) (λ _, rfl) (λ _ _, rfl)

/-- A subring of a `linear_ordered_ring` is a `linear_ordered_ring`. -/
instance to_linear_ordered_ring {R} [linear_ordered_ring R] (s : subring R) :
  linear_ordered_ring s :=
subtype.coe_injective.linear_ordered_ring coe rfl rfl
  (λ _ _, rfl) (λ _ _, rfl) (λ _, rfl) (λ _ _, rfl)

/-- A subring of a `linear_ordered_comm_ring` is a `linear_ordered_comm_ring`. -/
instance to_linear_ordered_comm_ring {R} [linear_ordered_comm_ring R] (s : subring R) :
  linear_ordered_comm_ring s :=
subtype.coe_injective.linear_ordered_comm_ring coe rfl rfl
  (λ _ _, rfl) (λ _ _, rfl) (λ _, rfl) (λ _ _, rfl)

/-- The natural ring hom from a subring of ring `R` to `R`. -/
def subtype (s : subring R) : s →+* R :=
{ to_fun := coe,
 .. s.to_submonoid.subtype, .. s.to_add_subgroup.subtype }

@[simp] theorem coe_subtype : ⇑s.subtype = coe := rfl
@[simp, norm_cast] lemma coe_nat_cast (n : ℕ) : ((n : s) : R) = n :=
s.subtype.map_nat_cast n
@[simp, norm_cast] lemma coe_int_cast (n : ℤ) : ((n : s) : R) = n :=
s.subtype.map_int_cast n

/-! # Partial order -/

@[simp] lemma mem_to_submonoid {s : subring R} {x : R} : x ∈ s.to_submonoid ↔ x ∈ s := iff.rfl
@[simp] lemma coe_to_submonoid (s : subring R) : (s.to_submonoid : set R) = s := rfl
@[simp] lemma mem_to_add_subgroup {s : subring R} {x : R} :
  x ∈ s.to_add_subgroup ↔ x ∈ s := iff.rfl
@[simp] lemma coe_to_add_subgroup (s : subring R) : (s.to_add_subgroup : set R) = s := rfl

/-! # top -/

/-- The subring `R` of the ring `R`. -/
instance : has_top (subring R) :=
⟨{ .. (⊤ : submonoid R), .. (⊤ : add_subgroup R) }⟩

@[simp] lemma mem_top (x : R) : x ∈ (⊤ : subring R) := set.mem_univ x

@[simp] lemma coe_top : ((⊤ : subring R) : set R) = set.univ := rfl

/-! # comap -/

/-- The preimage of a subring along a ring homomorphism is a subring. -/
def comap {R : Type u} {S : Type v} [ring R] [ring S]
  (f : R →+* S) (s : subring S) : subring R :=
{ carrier := f ⁻¹' s.carrier,
 .. s.to_submonoid.comap (f : R →* S),
  .. s.to_add_subgroup.comap (f : R →+ S) }

@[simp] lemma coe_comap (s : subring S) (f : R →+* S) : (s.comap f : set R) = f ⁻¹' s := rfl

@[simp]
lemma mem_comap {s : subring S} {f : R →+* S} {x : R} : x ∈ s.comap f ↔ f x ∈ s := iff.rfl

lemma comap_comap (s : subring T) (g : S →+* T) (f : R →+* S) :
  (s.comap g).comap f = s.comap (g.comp f) :=
rfl

/-! # map -/

/-- The image of a subring along a ring homomorphism is a subring. -/
def map {R : Type u} {S : Type v} [ring R] [ring S]
  (f : R →+* S) (s : subring R) : subring S :=
  { carrier := f '' s.carrier,
.. s.to_submonoid.map (f : R →* S),
.. s.to_add_subgroup.map (f : R →+ S) }

@[simp] lemma coe_map (f : R →+* S) (s : subring R) : (s.map f : set S) = f '' s := rfl

@[simp] lemma mem_map {f : R →+* S} {s : subring R} {y : S} :
  y ∈ s.map f ↔ ∃ x ∈ s, f x = y :=
set.mem_image_iff_bex

lemma map_map (g : S →+* T) (f : R →+* S) : (s.map f).map g = s.map (g.comp f) :=
set_like.coe_injective $ set.image_image _ _ _

lemma map_le_iff_le_comap {f : R →+* S} {s : subring R} {t : subring S} :
  s.map f ≤ t ↔ s ≤ t.comap f :=
set.image_subset_iff

lemma gc_map_comap (f : R →+* S) : galois_connection (map f) (comap f) :=
λ S T, map_le_iff_le_comap

end subring

namespace ring_hom

variables (g : S →+* T) (f : R →+* S)

/-! # range -/

/-- The range of a ring homomorphism, as a subring of the target. See Note [range copy pattern]. -/
def range {R : Type u} {S : Type v} [ring R] [ring S] (f : R →+* S) : subring S :=
((⊤ : subring R).map f).copy (set.range f) set.image_univ.symm

@[simp] lemma coe_range : (f.range : set S) = set.range f := rfl

@[simp] lemma mem_range {f : R →+* S} {y : S} : y ∈ f.range ↔ ∃ x, f x = y := iff.rfl

lemma range_eq_map (f : R →+* S) : f.range = subring.map f ⊤ :=
by { ext, simp }

lemma mem_range_self (f : R →+* S) (x : R) : f x ∈ f.range :=
mem_range.mpr ⟨x, rfl⟩

lemma map_range : f.range.map g = (g.comp f).range :=
by simpa only [range_eq_map] using (⊤ : subring R).map_map g f

-- TODO -- rename to `cod_restrict` when is_ring_hom is deprecated
/-- Restrict the codomain of a ring homomorphism to a subring that includes the range. -/
def cod_restrict' {R : Type u} {S : Type v} [ring R] [ring S] (f : R →+* S)
  (s : subring S) (h : ∀ x, f x ∈ s) : R →+* s :=
{ to_fun := λ x, ⟨f x, h x⟩,
  map_add' := λ x y, subtype.eq $ f.map_add x y,
  map_zero' := subtype.eq f.map_zero,
  map_mul' := λ x y, subtype.eq $ f.map_mul x y,
  map_one' := subtype.eq f.map_one }

end ring_hom

namespace subring

/-! # bot -/

instance : has_bot (subring R) := ⟨(int.cast_ring_hom R).range⟩

instance : inhabited (subring R) := ⟨⊥⟩

lemma coe_bot : ((⊥ : subring R) : set R) = set.range (coe : ℤ → R) :=
ring_hom.coe_range (int.cast_ring_hom R)

lemma mem_bot {x : R} : x ∈ (⊥ : subring R) ↔ ∃ (n : ℤ), ↑n = x :=
ring_hom.mem_range

/-! # inf -/

/-- The inf of two subrings is their intersection. -/
instance : has_inf (subring R) :=
⟨λ s t,
  { carrier := s ∩ t,
    .. s.to_submonoid ⊓ t.to_submonoid,
    .. s.to_add_subgroup ⊓ t.to_add_subgroup }⟩

@[simp] lemma coe_inf (p p' : subring R) : ((p ⊓ p' : subring R) : set R) = p ∩ p' := rfl

@[simp] lemma mem_inf {p p' : subring R} {x : R} : x ∈ p ⊓ p' ↔ x ∈ p ∧ x ∈ p' := iff.rfl

instance : has_Inf (subring R) :=
⟨λ s, subring.mk' (⋂ t ∈ s, ↑t) (⨅ t ∈ s, subring.to_submonoid t )
  (⨅ t ∈ s, subring.to_add_subgroup t) (by simp) (by simp)⟩

@[simp, norm_cast] lemma coe_Inf (S : set (subring R)) :
  ((Inf S : subring R) : set R) = ⋂ s ∈ S, ↑s := rfl

lemma mem_Inf {S : set (subring R)} {x : R} : x ∈ Inf S ↔ ∀ p ∈ S, x ∈ p := set.mem_bInter_iff

@[simp] lemma Inf_to_submonoid (s : set (subring R)) :
  (Inf s).to_submonoid = ⨅ t ∈ s, subring.to_submonoid t := mk'_to_submonoid _ _

@[simp] lemma Inf_to_add_subgroup (s : set (subring R)) :
  (Inf s).to_add_subgroup = ⨅ t ∈ s, subring.to_add_subgroup t := mk'_to_add_subgroup _ _

/-- Subrings of a ring form a complete lattice. -/
instance : complete_lattice (subring R) :=
{ bot := (⊥),
  bot_le := λ s x hx, let ⟨n, hn⟩ := mem_bot.1 hx in hn ▸ s.coe_int_mem n,
  top := (⊤),
  le_top := λ s x hx, trivial,
  inf := (⊓),
  inf_le_left := λ s t x, and.left,
  inf_le_right := λ s t x, and.right,
  le_inf := λ s t₁ t₂ h₁ h₂ x hx, ⟨h₁ hx, h₂ hx⟩,
  .. complete_lattice_of_Inf (subring R)
    (λ s, is_glb.of_image (λ s t,
      show (s : set R) ≤ t ↔ s ≤ t, from set_like.coe_subset_coe) is_glb_binfi)}

lemma eq_top_iff' (A : subring R) : A = ⊤ ↔ ∀ x : R, x ∈ A :=
eq_top_iff.trans ⟨λ h m, h $ mem_top m, λ h m _, h m⟩

/-! # subring closure of a subset -/

/-- The `subring` generated by a set. -/
def closure (s : set R) : subring R := Inf {S | s ⊆ S}

lemma mem_closure {x : R} {s : set R} : x ∈ closure s ↔ ∀ S : subring R, s ⊆ S → x ∈ S :=
mem_Inf

/-- The subring generated by a set includes the set. -/
@[simp] lemma subset_closure {s : set R} : s ⊆ closure s := λ x hx, mem_closure.2 $ λ S hS, hS hx

/-- A subring `t` includes `closure s` if and only if it includes `s`. -/
@[simp]
lemma closure_le {s : set R} {t : subring R} : closure s ≤ t ↔ s ⊆ t :=
⟨set.subset.trans subset_closure, λ h, Inf_le h⟩

/-- Subring closure of a set is monotone in its argument: if `s ⊆ t`,
then `closure s ≤ closure t`. -/
lemma closure_mono ⦃s t : set R⦄ (h : s ⊆ t) : closure s ≤ closure t :=
closure_le.2 $ set.subset.trans h subset_closure

lemma closure_eq_of_le {s : set R} {t : subring R} (h₁ : s ⊆ t) (h₂ : t ≤ closure s) :
  closure s = t :=
le_antisymm (closure_le.2 h₁) h₂

/-- An induction principle for closure membership. If `p` holds for `0`, `1`, and all elements
of `s`, and is preserved under addition, negation, and multiplication, then `p` holds for all
elements of the closure of `s`. -/
@[elab_as_eliminator]
lemma closure_induction {s : set R} {p : R → Prop} {x} (h : x ∈ closure s)
  (Hs : ∀ x ∈ s, p x) (H0 : p 0) (H1 : p 1)
  (Hadd : ∀ x y, p x → p y → p (x + y))
  (Hneg : ∀ (x : R), p x → p (-x))
  (Hmul : ∀ x y, p x → p y → p (x * y)) : p x :=
(@closure_le _ _ _ ⟨p, H1, Hmul, H0, Hadd, Hneg⟩).2 Hs h

lemma mem_closure_iff {s : set R} {x} :
  x ∈ closure s ↔ x ∈ add_subgroup.closure (submonoid.closure s : set R) :=
⟨ λ h, closure_induction h (λ x hx, add_subgroup.subset_closure $ submonoid.subset_closure hx )
 (add_subgroup.zero_mem _)
 (add_subgroup.subset_closure ( submonoid.one_mem (submonoid.closure s)) )
 (λ x y hx hy, add_subgroup.add_mem _ hx hy )
 (λ x hx, add_subgroup.neg_mem _ hx )
 ( λ x y hx hy, add_subgroup.closure_induction hy
  (λ q hq, add_subgroup.closure_induction hx
    ( λ p hp, add_subgroup.subset_closure ((submonoid.closure s).mul_mem hp hq) )
    ( begin rw zero_mul q, apply add_subgroup.zero_mem _, end )
    ( λ p₁ p₂ ihp₁ ihp₂, begin rw add_mul p₁ p₂ q, apply add_subgroup.add_mem _ ihp₁ ihp₂, end )
    ( λ x hx, begin have f : -x * q = -(x*q) :=
      by simp, rw f, apply add_subgroup.neg_mem _ hx, end ) )
  ( begin rw mul_zero x, apply add_subgroup.zero_mem _, end )
  ( λ q₁ q₂ ihq₁ ihq₂, begin rw mul_add x q₁ q₂, apply add_subgroup.add_mem _ ihq₁ ihq₂ end )
  ( λ z hz, begin have f : x * -z = -(x*z) := by simp,
            rw f, apply add_subgroup.neg_mem _ hz, end ) ),
 λ h, add_subgroup.closure_induction h
 ( λ x hx, submonoid.closure_induction hx
  ( λ x hx, subset_closure hx )
  ( one_mem _ )
  ( λ x y hx hy, mul_mem _ hx hy ) )
 ( zero_mem _ )
 (λ x y hx hy, add_mem _ hx hy)
 ( λ x hx, neg_mem _ hx ) ⟩

theorem exists_list_of_mem_closure {s : set R} {x : R} (h : x ∈ closure s) :
  (∃ L : list (list R), (∀ t ∈ L, ∀ y ∈ t, y ∈ s ∨ y = (-1:R)) ∧ (L.map list.prod).sum = x) :=
add_subgroup.closure_induction (mem_closure_iff.1 h)
  (λ x hx, let ⟨l, hl, h⟩ :=submonoid.exists_list_of_mem_closure hx in ⟨[l], by simp [h];
    clear_aux_decl; tauto!⟩)
  ⟨[], by simp⟩
  (λ x y ⟨l, hl1, hl2⟩ ⟨m, hm1, hm2⟩, ⟨l ++ m, λ t ht, (list.mem_append.1 ht).elim (hl1 t) (hm1 t),
    by simp [hl2, hm2]⟩)
  (λ x ⟨L, hL⟩, ⟨L.map (list.cons (-1)), list.forall_mem_map_iff.2 $ λ j hj, list.forall_mem_cons.2
    ⟨or.inr rfl, hL.1 j hj⟩, hL.2 ▸ list.rec_on L (by simp)
      (by simp [list.map_cons, add_comm] {contextual := tt})⟩)

variable (R)
/-- `closure` forms a Galois insertion with the coercion to set. -/
protected def gi : galois_insertion (@closure R _) coe :=
{ choice := λ s _, closure s,
  gc := λ s t, closure_le,
  le_l_u := λ s, subset_closure,
  choice_eq := λ s h, rfl }

variable {R}

/-- Closure of a subring `S` equals `S`. -/
lemma closure_eq (s : subring R) : closure (s : set R) = s := (subring.gi R).l_u_eq s

@[simp] lemma closure_empty : closure (∅ : set R) = ⊥ := (subring.gi R).gc.l_bot

@[simp] lemma closure_univ : closure (set.univ : set R) = ⊤ := @coe_top R _ ▸ closure_eq ⊤

lemma closure_union (s t : set R) : closure (s ∪ t) = closure s ⊔ closure t :=
(subring.gi R).gc.l_sup

lemma closure_Union {ι} (s : ι → set R) : closure (⋃ i, s i) = ⨆ i, closure (s i) :=
(subring.gi R).gc.l_supr

lemma closure_sUnion (s : set (set R)) : closure (⋃₀ s) = ⨆ t ∈ s, closure t :=
(subring.gi R).gc.l_Sup

lemma map_sup (s t : subring R) (f : R →+* S) : (s ⊔ t).map f = s.map f ⊔ t.map f :=
(gc_map_comap f).l_sup

lemma map_supr {ι : Sort*} (f : R →+* S) (s : ι → subring R) :
  (supr s).map f = ⨆ i, (s i).map f :=
(gc_map_comap f).l_supr

lemma comap_inf (s t : subring S) (f : R →+* S) : (s ⊓ t).comap f = s.comap f ⊓ t.comap f :=
(gc_map_comap f).u_inf

lemma comap_infi {ι : Sort*} (f : R →+* S) (s : ι → subring S) :
  (infi s).comap f = ⨅ i, (s i).comap f :=
(gc_map_comap f).u_infi

@[simp] lemma map_bot (f : R →+* S) : (⊥ : subring R).map f = ⊥ :=
(gc_map_comap f).l_bot

@[simp] lemma comap_top (f : R →+* S) : (⊤ : subring S).comap f = ⊤ :=
(gc_map_comap f).u_top

/-- Given `subring`s `s`, `t` of rings `R`, `S` respectively, `s.prod t` is `s × t`
as a subring of `R × S`. -/
def prod (s : subring R) (t : subring S) : subring (R × S) :=
{ carrier := (s : set R).prod t,
  .. s.to_submonoid.prod t.to_submonoid, .. s.to_add_subgroup.prod t.to_add_subgroup}

@[norm_cast]
lemma coe_prod (s : subring R) (t : subring S) :
  (s.prod t : set (R × S)) = (s : set R).prod (t : set S) :=
rfl

lemma mem_prod {s : subring R} {t : subring S} {p : R × S} :
  p ∈ s.prod t ↔ p.1 ∈ s ∧ p.2 ∈ t := iff.rfl

@[mono] lemma prod_mono ⦃s₁ s₂ : subring R⦄ (hs : s₁ ≤ s₂) ⦃t₁ t₂ : subring S⦄
  (ht : t₁ ≤ t₂) : s₁.prod t₁ ≤ s₂.prod t₂ :=
set.prod_mono hs ht

lemma prod_mono_right (s : subring R) : monotone (λ t : subring S, s.prod t) :=
prod_mono (le_refl s)

lemma prod_mono_left (t : subring S) : monotone (λ s : subring R, s.prod t) :=
λ s₁ s₂ hs, prod_mono hs (le_refl t)

lemma prod_top (s : subring R) :
  s.prod (⊤ : subring S) = s.comap (ring_hom.fst R S) :=
ext $ λ x, by simp [mem_prod, monoid_hom.coe_fst]

lemma top_prod (s : subring S) :
  (⊤ : subring R).prod s = s.comap (ring_hom.snd R S) :=
ext $ λ x, by simp [mem_prod, monoid_hom.coe_snd]

@[simp]
lemma top_prod_top : (⊤ : subring R).prod (⊤ : subring S) = ⊤ :=
(top_prod _).trans $ comap_top _

/-- Product of subrings is isomorphic to their product as rings. -/
def prod_equiv (s : subring R) (t : subring S) : s.prod t ≃+* s × t :=
{ map_mul' := λ x y, rfl, map_add' := λ x y, rfl, .. equiv.set.prod ↑s ↑t }

/-- The underlying set of a non-empty directed Sup of subrings is just a union of the subrings.
  Note that this fails without the directedness assumption (the union of two subrings is
  typically not a subring) -/
lemma mem_supr_of_directed {ι} [hι : nonempty ι] {S : ι → subring R} (hS : directed (≤) S)
  {x : R} :
  x ∈ (⨆ i, S i) ↔ ∃ i, x ∈ S i :=
begin
  refine ⟨_, λ ⟨i, hi⟩, (set_like.le_def.1 $ le_supr S i) hi⟩,
  let U : subring R := subring.mk' (⋃ i, (S i : set R))
    (⨆ i, (S i).to_submonoid) (⨆ i, (S i).to_add_subgroup)
    (submonoid.coe_supr_of_directed $ hS.mono_comp _ (λ _ _, id))
    (add_subgroup.coe_supr_of_directed $ hS.mono_comp _ (λ _ _, id)),
  suffices : (⨆ i, S i) ≤ U, by simpa using @this x,
  exact supr_le (λ i x hx, set.mem_Union.2 ⟨i, hx⟩),
end

lemma coe_supr_of_directed {ι} [hι : nonempty ι] {S : ι → subring R} (hS : directed (≤) S) :
  ((⨆ i, S i : subring R) : set R) = ⋃ i, ↑(S i) :=
set.ext $ λ x, by simp [mem_supr_of_directed hS]

lemma mem_Sup_of_directed_on {S : set (subring R)} (Sne : S.nonempty)
  (hS : directed_on (≤) S) {x : R} :
  x ∈ Sup S ↔ ∃ s ∈ S, x ∈ s :=
begin
  haveI : nonempty S := Sne.to_subtype,
  simp only [Sup_eq_supr', mem_supr_of_directed hS.directed_coe, set_coe.exists, subtype.coe_mk]
end

lemma coe_Sup_of_directed_on {S : set (subring R)} (Sne : S.nonempty) (hS : directed_on (≤) S) :
  (↑(Sup S) : set R) = ⋃ s ∈ S, ↑s :=
set.ext $ λ x, by simp [mem_Sup_of_directed_on Sne hS]

end subring

namespace ring_hom

variables [ring T] {s : subring R}

open subring

/-- Restriction of a ring homomorphism to a subring of the domain. -/
def restrict (f : R →+* S) (s : subring R) : s →+* S := f.comp s.subtype

@[simp] lemma restrict_apply (f : R →+* S) (x : s) : f.restrict s x = f x := rfl

/-- Restriction of a ring homomorphism to its range interpreted as a subsemiring.

This is the bundled version of `set.range_factorization`. -/
def range_restrict (f : R →+* S) : R →+* f.range :=
f.cod_restrict' f.range $ λ x, ⟨x, rfl⟩

@[simp] lemma coe_range_restrict (f : R →+* S) (x : R) : (f.range_restrict x : S) = f x := rfl

lemma range_restrict_surjective (f : R →+* S) : function.surjective f.range_restrict :=
λ ⟨y, hy⟩, let ⟨x, hx⟩ := mem_range.mp hy in ⟨x, subtype.ext hx⟩

lemma range_top_iff_surjective {f : R →+* S} :
  f.range = (⊤ : subring S) ↔ function.surjective f :=
set_like.ext'_iff.trans $ iff.trans (by rw [coe_range, coe_top]) set.range_iff_surjective

/-- The range of a surjective ring homomorphism is the whole of the codomain. -/
lemma range_top_of_surjective (f : R →+* S) (hf : function.surjective f) :
  f.range = (⊤ : subring S) :=
range_top_iff_surjective.2 hf

/-- The subring of elements `x : R` such that `f x = g x`, i.e.,
  the equalizer of f and g as a subring of R -/
def eq_locus (f g : R →+* S) : subring R :=
{ carrier := {x | f x = g x}, .. (f : R →* S).eq_mlocus g, .. (f : R →+ S).eq_locus g }

/-- If two ring homomorphisms are equal on a set, then they are equal on its subring closure. -/
lemma eq_on_set_closure {f g : R →+* S} {s : set R} (h : set.eq_on f g s) :
  set.eq_on f g (closure s) :=
show closure s ≤ f.eq_locus g, from closure_le.2 h

lemma eq_of_eq_on_set_top {f g : R →+* S} (h : set.eq_on f g (⊤ : subring R)) :
  f = g :=
ext $ λ x, h trivial

lemma eq_of_eq_on_set_dense {s : set R} (hs : closure s = ⊤) {f g : R →+* S} (h : s.eq_on f g) :
  f = g :=
eq_of_eq_on_set_top $ hs ▸ eq_on_set_closure h

lemma closure_preimage_le (f : R →+* S) (s : set S) :
  closure (f ⁻¹' s) ≤ (closure s).comap f :=
closure_le.2 $ λ x hx, set_like.mem_coe.2 $ mem_comap.2 $ subset_closure hx

/-- The image under a ring homomorphism of the subring generated by a set equals
the subring generated by the image of the set. -/
lemma map_closure (f : R →+* S) (s : set R) :
  (closure s).map f = closure (f '' s) :=
le_antisymm
  (map_le_iff_le_comap.2 $ le_trans (closure_mono $ set.subset_preimage_image _ _)
    (closure_preimage_le _ _))
  (closure_le.2 $ set.image_subset _ subset_closure)

end ring_hom

namespace subring

open ring_hom

/-- The ring homomorphism associated to an inclusion of subrings. -/
def inclusion {S T : subring R} (h : S ≤ T) : S →* T :=
S.subtype.cod_restrict' _ (λ x, h x.2)

@[simp] lemma range_subtype (s : subring R) : s.subtype.range = s :=
set_like.coe_injective $ (coe_srange _).trans subtype.range_coe

@[simp]
lemma range_fst : (fst R S).srange = ⊤ :=
(fst R S).srange_top_of_surjective $ prod.fst_surjective

@[simp]
lemma range_snd : (snd R S).srange = ⊤ :=
(snd R S).srange_top_of_surjective $ prod.snd_surjective

@[simp]
lemma prod_bot_sup_bot_prod (s : subring R) (t : subring S) :
  (s.prod ⊥) ⊔ (prod ⊥ t) = s.prod t :=
le_antisymm (sup_le (prod_mono_right s bot_le) (prod_mono_left t bot_le)) $
assume p hp, prod.fst_mul_snd p ▸ mul_mem _
  ((le_sup_left : s.prod ⊥ ≤ s.prod ⊥ ⊔ prod ⊥ t) ⟨hp.1, set_like.mem_coe.2 $ one_mem ⊥⟩)
  ((le_sup_right : prod ⊥ t ≤ s.prod ⊥ ⊔ prod ⊥ t) ⟨set_like.mem_coe.2 $ one_mem ⊥, hp.2⟩)

end subring

namespace ring_equiv

variables {s t : subring R}

/-- Makes the identity isomorphism from a proof two subrings of a multiplicative
    monoid are equal. -/
def subring_congr (h : s = t) : s ≃+* t :=
{ map_mul' :=  λ _ _, rfl, map_add' := λ _ _, rfl, ..equiv.set_congr $ congr_arg _ h }

/-- Restrict a ring homomorphism with a left inverse to a ring isomorphism to its
`ring_hom.range`. -/
def of_left_inverse {g : S → R} {f : R →+* S} (h : function.left_inverse g f) :
  R ≃+* f.range :=
{ to_fun := λ x, f.range_restrict x,
  inv_fun := λ x, (g ∘ f.range.subtype) x,
  left_inv := h,
  right_inv := λ x, subtype.ext $
    let ⟨x', hx'⟩ := ring_hom.mem_range.mp x.prop in
    show f (g x) = x, by rw [←hx', h x'],
  ..f.range_restrict }

@[simp] lemma of_left_inverse_apply
  {g : S → R} {f : R →+* S} (h : function.left_inverse g f) (x : R) :
  ↑(of_left_inverse h x) = f x := rfl

@[simp] lemma of_left_inverse_symm_apply
  {g : S → R} {f : R →+* S} (h : function.left_inverse g f) (x : f.range) :
  (of_left_inverse h).symm x = g x := rfl

end ring_equiv

namespace subring

variables {s : set R}
local attribute [reducible] closure

@[elab_as_eliminator]
protected theorem in_closure.rec_on {C : R → Prop} {x : R} (hx : x ∈ closure s)
  (h1 : C 1) (hneg1 : C (-1)) (hs : ∀ z ∈ s, ∀ n, C n → C (z * n))
  (ha : ∀ {x y}, C x → C y → C (x + y)) : C x :=
begin
  have h0 : C 0 := add_neg_self (1:R) ▸ ha h1 hneg1,
  rcases exists_list_of_mem_closure hx with ⟨L, HL, rfl⟩, clear hx,
  induction L with hd tl ih, { exact h0 },
  rw list.forall_mem_cons at HL,
  suffices : C (list.prod hd),
  { rw [list.map_cons, list.sum_cons],
    exact ha this (ih HL.2) },
  replace HL := HL.1, clear ih tl,
  suffices : ∃ L : list R, (∀ x ∈ L, x ∈ s) ∧
    (list.prod hd = list.prod L ∨ list.prod hd = -list.prod L),
  { rcases this with ⟨L, HL', HP | HP⟩,
    { rw HP, clear HP HL hd, induction L with hd tl ih, { exact h1 },
      rw list.forall_mem_cons at HL',
      rw list.prod_cons,
      exact hs _ HL'.1 _ (ih HL'.2) },
    rw HP, clear HP HL hd, induction L with hd tl ih, { exact hneg1 },
    rw [list.prod_cons, neg_mul_eq_mul_neg],
    rw list.forall_mem_cons at HL',
    exact hs _ HL'.1 _ (ih HL'.2) },
  induction hd with hd tl ih,
  { exact ⟨[], list.forall_mem_nil _, or.inl rfl⟩ },
  rw list.forall_mem_cons at HL,
  rcases ih HL.2 with ⟨L, HL', HP | HP⟩; cases HL.1 with hhd hhd,
  { exact ⟨hd :: L, list.forall_mem_cons.2 ⟨hhd, HL'⟩, or.inl $
      by rw [list.prod_cons, list.prod_cons, HP]⟩ },
  { exact ⟨L, HL', or.inr $ by rw [list.prod_cons, hhd, neg_one_mul, HP]⟩ },
  { exact ⟨hd :: L, list.forall_mem_cons.2 ⟨hhd, HL'⟩, or.inr $
      by rw [list.prod_cons, list.prod_cons, HP, neg_mul_eq_mul_neg]⟩ },
  { exact ⟨L, HL', or.inl $ by rw [list.prod_cons, hhd, HP, neg_one_mul, neg_neg]⟩ }
end

lemma closure_preimage_le (f : R →+* S) (s : set S) :
  closure (f ⁻¹' s) ≤ (closure s).comap f :=
closure_le.2 $ λ x hx, set_like.mem_coe.2 $ mem_comap.2 $ subset_closure hx

end subring

lemma add_subgroup.int_mul_mem {G : add_subgroup R} (k : ℤ) {g : R} (h : g ∈ G) :
  (k : R) * g ∈ G :=
by { convert add_subgroup.gsmul_mem G h k, simp }


/-
  Copyright 2020 Grayson Burton
  License available in the LICENSE file.
-/
import data.set tactic .between

section
universe u
parameters {α : Type u} [has_betweenness α]

/-- The convex hull of a set. -/
/- thanks chris hughes -/
inductive convex_hull (s : set α) : set α
| of_set : ∀ {v}, v ∈ s → convex_hull v
| intrv : ∀ {v₁ v₂ v₃}, convex_hull v₁ → convex_hull v₂ →
  v₃ ∈ interval v₁ v₂ → convex_hull v₃

inductive affine_hull (s : set α) : set α
| of_set : ∀ {v}, v ∈ s → affine_hull v
| of_line : ∀ {v₁ v₂ v₃}, affine_hull v₁ → affine_hull v₂ → v₃ ∈ line v₁ v₂ → affine_hull v₃

def lin_indep_sets (s₁ s₂ : set α) : Prop :=
disjoint (affine_hull s₁) (affine_hull s₂)

def lin_indep (s : set α) : Prop :=
∀ p ∈ s, p ∉ affine_hull (s \ {p})

/-- A set is convex if it is equal to its own convex hull. -/
@[reducible]
def is_convex (s : set α) : Prop :=
convex_hull s = s

@[reducible]
def is_affine (s : set α) : Prop :=
affine_hull s = s

end

section
universe u
parameters {α : Type u} [has_betweenness α]

@[simp]
theorem is_convex.convex_def (s : set α) : is_convex s = (convex_hull s = s) :=
rfl

@[simp]
theorem is_affine.affine_def (s : set α) : is_affine s = (affine_hull s = s) :=
rfl

namespace convex_hull
/-- `x` is in a convex hull of a set iff it's in the original set or it is on a
    line segment between two points that are also in the convex hull. -/
@[simp]
theorem mem_iff {s : set α} (x : α) :
  x ∈ convex_hull s ↔ x ∈ s ∨ ∃ (v₁ v₂ ∈ convex_hull s), x ∈ interval v₁ v₂ :=
begin
  refine ⟨λ h, _, λ h, _⟩,
    { rcases h with ⟨_, h⟩ | ⟨_, _, _, hv₁, hv₂, h⟩,
        { exact or.inl h },
        { exact or.inr ⟨_, _, hv₁, hv₂, h⟩ }},
    { rcases h with ⟨h⟩ | ⟨_, _, hv₁, hv₂, h⟩,
        { exact of_set h },
        { exact intrv hv₁ hv₂ h }}
end

theorem mem_iff' {s : set α} (x : α) :
  convex_hull s x ↔ x ∈ s ∨ ∃ (v₁ v₂ ∈ convex_hull s), x ∈ interval v₁ v₂ :=
mem_iff x

/-- Taking the convex hull of a convex hull is idempotent. -/
@[simp]
theorem idempotent (s : set α) : convex_hull (convex_hull s) = convex_hull s :=
begin
  apply set.eq_of_subset_of_subset (λ _ h, _) (λ _ h, _),
    { induction h with _ _ _ _ _ _ _ h hv₁ hv₂,
        { assumption },
        { exact intrv hv₁ hv₂ h }},
    { rcases h with ⟨_, h⟩ | ⟨_, _, _, hv₁, hv₂, h⟩,
        { exact of_set (of_set h) },
        { exact intrv (of_set hv₁) (of_set hv₂) h }}
end

/-- Every set is a subset of its convex hull. -/
theorem self_subs_hull (s : set α) : s ⊆ convex_hull s :=
λ _, of_set

theorem eq_of_hull_subs {s : set α} (h : convex_hull s ⊆ s) : is_convex s :=
set.eq_of_subset_of_subset h (self_subs_hull s)

/-- Every convex hull is convex. -/
theorem convex (s : set α) : is_convex (convex_hull s) :=
idempotent s

/-- If `S₁ ⊆ S₂`, then the convex hull of `S₁` is also a subset of the convex
    hull of `S₂`. -/
theorem is_mono {s t : set α} (hs : s ⊆ t) : convex_hull s ⊆ convex_hull t :=
begin
  intros x h,
  induction h with _ h _ _ _ _ _ h hv₁ hv₂,
    { exact self_subs_hull _ (hs h) },
    { exact intrv hv₁ hv₂ h }
end

/-- If `S₁ ⊂ S₂` and both are convex, then the convex hull of `S₁` is also a
    strict subset of the convex hull of `S₂`. -/
theorem is_mono_convex {s t : set α} (hs : is_convex s) (ht : is_convex t) :
  s ⊂ t → convex_hull s ⊂ convex_hull t :=
λ h, by rw is_convex.convex_def at hs ht; rwa [hs, ht]

/-- If `S₁` and `S₂` are both convex, then `S₁ ⊂ S₂` iff the same is true of
    their convex hulls. -/
theorem iff_ssubs_of_convex {s t : set α} (hs : is_convex s) (ht : is_convex t) :
  s ⊂ t ↔ convex_hull s ⊂ convex_hull t :=
by rw is_convex.convex_def at hs ht; rwa [hs, ht]

@[simp]
theorem of_empty : @convex_hull α _ ∅ = ∅ :=
begin
  apply eq_of_hull_subs (λ _ h, _),
  induction h with _ _ _ _ _ _ _ _ h, { assumption },
  exact (set.not_mem_empty _) h
end

@[simp]
theorem is_empty_iff (s : set α) : (@convex_hull α _ s = ∅) ↔ s = ∅ :=
begin
  refine ⟨λ h, _, λ h, by rw h; exact of_empty⟩,
  rw [←set.subset_empty_iff, ←h],
  apply self_subs_hull
end

@[simp]
theorem of_singleton (p : α) : @convex_hull α _ {p} = {p} :=
begin
  apply eq_of_hull_subs (λ _ h, _),
  induction h with _ h₂ _ _ _ _ _ h hv₁ hv₂, { assumption },
  rw [set.mem_singleton_iff] at hv₁ hv₂, rw [hv₁, hv₂] at h,
  exact interval.eq_of_mem_same h
end

@[simp]
theorem of_univ : @convex_hull α _ set.univ = set.univ :=
set.eq_univ_of_subset (self_subs_hull set.univ) rfl

end convex_hull

namespace affine_hull

/-- `x` is in a affine_hull of a set iff it's in the original set or it is on a line
    between two points that are also in the affine_hull. -/
@[simp]
theorem mem_iff {s : set α} (x : α) : x ∈ affine_hull s ↔ x ∈ s ∨ ∃ (v₁ v₂ ∈ affine_hull s), x ∈ line v₁ v₂ :=
begin
  refine ⟨λ h, _, λ h, _⟩,
    { rcases h with ⟨_, h⟩ | ⟨_, _, _, hv₁, hv₂, h⟩,
        { exact or.inl h },
        { exact or.inr ⟨_, _, hv₁, hv₂, h⟩ }},
    { rcases h with ⟨h⟩ | ⟨_, _, hv₁, hv₂, h⟩,
        { exact of_set h },
        { exact of_line hv₁ hv₂ h }}
end

theorem mem_iff' {s : set α} (x : α) : affine_hull s x ↔ x ∈ s ∨ ∃ (v₁ v₂ ∈ affine_hull s), x ∈ line v₁ v₂ :=
mem_iff x

@[simp]
theorem idempotent (s : set α) : affine_hull (affine_hull s) = affine_hull s :=
begin
  apply set.eq_of_subset_of_subset (λ _ h, _) (λ _ h, _),
    { induction h with _ _ _ _ _ _ _ h hv₁ hv₂,
        { assumption },
        { exact of_line hv₁ hv₂ h }},
    { rcases h with ⟨_, h⟩ | ⟨_, _, _, hv₁, hv₂, h⟩,
        { exact of_set (of_set h) },
        { exact of_line (of_set hv₁) (of_set hv₂) h }}
end

/-- Every set is a subset of its affine_hull. -/
theorem self_subs_span (s : set α) : s ⊆ affine_hull s :=
λ _, of_set

/-- If `S₁ ⊆ S₂`, then the affine_hull of `S₁` is also a subset of the affine_hull of `S₂`. -/
theorem is_mono {s t : set α} (hs : s ⊆ t) : affine_hull s ⊆ affine_hull t :=
begin
  intros x h,
  induction h with _ h _ _ _ _ _ h hv₁ hv₂,
    { exact self_subs_span _ (hs h) },
    { exact of_line hv₁ hv₂ h }

end

@[simp]
theorem of_empty : @affine_hull α _ ∅ = ∅ :=
begin
  rw set.eq_empty_iff_forall_not_mem,
  intros _ h,
  induction h with _ _ _ _ _ _ _ _ h, repeat { assumption }
end

@[simp]
theorem is_empty_iff (s : set α) : (@affine_hull α _ s = ∅) ↔ s = ∅ :=
begin
  refine ⟨λ h, _, λ h, by rw h; exact of_empty⟩,
  rw [←set.subset_empty_iff, ←h],
  apply self_subs_span
end

@[simp]
theorem eq_iff_span_subs (s : set α) : affine_hull s = s ↔ affine_hull s ⊆ s :=
begin
  refine ⟨λ h, by rw h; refl, λ h, set.eq_of_subset_of_subset h _⟩,
  exact self_subs_span _
end

@[simp]
theorem of_singleton (p : α) : @affine_hull α _ {p} = {p} :=
begin
  rw eq_iff_span_subs,
  intros _ h,
  induction h with _ h₂ _ _ _ _ _ h hv₁ hv₂, { assumption },
  rw [set.mem_singleton_iff] at hv₁ hv₂, rw [hv₁, hv₂] at h,
  exact line.eq_of_mem_same h
end

@[simp]
theorem of_univ : @affine_hull α _ set.univ = set.univ :=
set.eq_univ_of_subset (self_subs_span set.univ) rfl

theorem convex_subs_span (s : set α) : convex_hull s ⊆ affine_hull s :=
begin
  intros _ h,
  induction h with _ h _ _ _ _ _ h hv₁ hv₂, { exact of_set h },
  exact of_line hv₁ hv₂ (line.intrv_subs _ _ h)
end

theorem affine (s : set α) : is_affine (affine_hull s) :=
by rw [is_affine, idempotent]

end affine_hull

namespace lin_indep_sets

theorem indep_def (s₁ s₂ : set α) : lin_indep_sets s₁ s₂ = disjoint (affine_hull s₁) (affine_hull s₂) :=
rfl

theorem symm_iff (s₁ s₂ : set α) : lin_indep_sets s₁ s₂ ↔ lin_indep_sets s₂ s₁ :=
by rw [indep_def, indep_def]; exact disjoint.comm

theorem symm {s₁ s₂ : set α} : lin_indep_sets s₁ s₂ → lin_indep_sets s₂ s₁ :=
(symm_iff s₁ s₂).mp

theorem of_empty (s : set α) : lin_indep_sets ∅ s :=
by rw [indep_def, affine_hull.of_empty]; apply set.empty_disjoint

theorem of_empty' (s : set α) : lin_indep_sets s ∅ :=
by rw symm_iff; apply of_empty

@[simp]
theorem of_singletons (p q : α) : @lin_indep_sets α _ {p} {q} ↔ p ≠ q :=
by rw [indep_def, affine_hull.of_singleton, affine_hull.of_singleton, set.disjoint_singleton_left]; refl

@[simp]
theorem of_singleton_left (p : α) (s : set α) : lin_indep_sets {p} s ↔ p ∉ affine_hull s :=
by rw [indep_def, affine_hull.of_singleton, set.disjoint_singleton_left]

@[simp]
theorem of_singleton_right (p : α) (s : set α) : lin_indep_sets s {p} ↔ p ∉ affine_hull s :=
by rw [indep_def, affine_hull.of_singleton, set.disjoint_singleton_right]

end lin_indep_sets

namespace lin_indep

theorem indep_def (s : set α) : lin_indep s = ∀ p ∈ s, p ∉ affine_hull (s \ {p}) :=
rfl

theorem indep_iff_indep_sets (s : set α) : lin_indep s ↔ ∀ p ∈ s, lin_indep_sets {p} (s \ {p}) :=
begin
  rw indep_def,
  refine ⟨λ h _ hp, _, λ h _ hp, _⟩,
    { rw lin_indep_sets.of_singleton_left, exact h _ hp },
    { exact (lin_indep_sets.of_singleton_left _ _).mp (h _ hp) }
end

lemma of_singleton (p : α) : lin_indep ({p} : set α) :=
by intros _ h; induction h; simp

theorem not_iff_ex_in_span (s : set α) : ¬ lin_indep s ↔ ∃ p ∈ s, p ∈ affine_hull (s \ {p}) :=
by rw indep_def; push_neg; tauto

theorem not_iff_ex_in_line (s : set α) :
  ¬ lin_indep s ↔ ∃ (p ∈ s) (q r ∈ affine_hull (s \ {p})), p ∈ line q r :=
begin
  rw not_iff_ex_in_span,
  refine ⟨λ h, _, λ h, _⟩,
    { rcases h with ⟨_, h, h'⟩,
      refine ⟨_, h, _⟩,
      rcases h' with ⟨_, h'⟩ | ⟨_, _, _, h₁, h₂, h'⟩, { exact (h'.right rfl).elim },
      exact ⟨_, _, h₁, h₂, h'⟩ },
    { rcases h with ⟨_, h, _, _, h₀, h₁, h₂⟩, exact ⟨_, h, affine_hull.of_line h₀ h₁ h₂⟩ }
end

theorem of_sup {s₁ s₂ : set α} (h : s₁ ⊆ s₂) (hs₂ : lin_indep s₂) : lin_indep s₁ :=
begin
  rw indep_def at hs₂ ⊢,
  intros _ hp hps,
  specialize hs₂ _ (h hp),
  exact hs₂ ((affine_hull.is_mono $ set.diff_subset_diff_left h) hps)
end

lemma empty : lin_indep (∅ : set α) :=
λ _ h, (set.not_mem_empty _ h).elim

end lin_indep

namespace is_convex

/-- Every convex hull is convex. -/
theorem hulls_are_convex (s : set α) : is_convex (convex_hull s) :=
convex_hull.convex s

theorem ex_set_convex_eq_of_convex {s : set α} (h : is_convex s) : ∃ s', convex_hull s' = s :=
⟨s, h⟩

theorem convex_iff_ex_set_convex_eq (s : set α) : is_convex s ↔ ∃ s', convex_hull s' = s :=
begin
  refine ⟨ex_set_convex_eq_of_convex, _⟩,
  rintro ⟨_, h⟩,
  rw [is_convex, ←h, convex_hull.idempotent]
end

/-- If `S` is convex, then every point in `s` lies on some line segment in
    `S`. -/
theorem mem_intrv_of_convex {s : set α} :
  is_convex s → ∀ {x}, x ∈ s → ∃ v₁ v₂ ∈ s, x ∈ interval v₁ v₂ :=
begin
  intros hs x h,
  rw convex_def at hs,
  rw ←hs at h,
  rcases h with ⟨_, h⟩ | ⟨_, _, _, hv₁, hv₂, h⟩,
    { exact ⟨x, x, h, h, interval.end_mem_intrv_left _ _⟩ },
  rw ←hs,
  exact ⟨_, _, hv₁, hv₂, h⟩
end

/-- If `S` is convex, then every point in `s` lies on some line segment in
    `S`. -/
theorem iff_mem_intrv_of_convex {s : set α} :
  is_convex s → ∀ {x}, x ∈ s ↔ ∃ v₁ v₂ ∈ s, x ∈ interval v₁ v₂ :=
begin
  intros hs x,
  apply iff.intro (mem_intrv_of_convex hs),
  rw convex_def at hs,
  rintro ⟨_, _, hv₁, hv₂, h⟩,
  rw ←hs at *,
  exact convex_hull.intrv hv₁ hv₂ h
end

theorem of_convex_subs (s : set α) : is_convex s ↔ convex_hull s ⊆ s :=
begin
  refine ⟨λ h _ h', _, λ h, set.eq_of_subset_of_subset h $ convex_hull.self_subs_hull _⟩,
  change _ = _ at h,
  rwa h at h'
end

/-- A set `S` is convex iff, for any point `x`, `x ∈ S` is equivalent to there
    being two more points in `S` such that `x` is on the line segment between
    them. -/
theorem iff_mem_intrv_iff_convex (s : set α) :
  is_convex s ↔ ∀ {x}, x ∈ s ↔ ∃ v₁ v₂ ∈ s, x ∈ interval v₁ v₂ :=
begin
  apply iff.intro iff_mem_intrv_of_convex (λ hs, _),
  apply set.eq_of_subset_of_subset (λ _ h, _) (λ _, convex_hull.of_set),
  induction h with _ h₂ _ _ _ _ _ h hv₁ hv₂,
    { assumption },
    { exact hs.mpr ⟨_, _, hv₁, hv₂, h⟩ }
end

theorem intersect_closed {s₁ s₂ : set α} (hs₁ : is_convex s₁) (hs₂ : is_convex s₂) :
  is_convex (s₁ ∩ s₂) :=
begin
  apply (iff_mem_intrv_iff_convex _).mpr (λ _, ⟨λ hp, _, λ hp, _⟩),
    { exact ⟨_, _, hp, hp, interval.end_mem_intrv_left _ _⟩ },
  rcases hp with ⟨_, _, hq, hr, hpqr⟩,
  rw iff_mem_intrv_iff_convex at hs₁ hs₂,
  split,
    { rw hs₁, exact ⟨_, _, hq.left, hr.left, hpqr⟩ },
    { rw hs₂, exact ⟨_, _, hq.right, hr.right, hpqr⟩ }
end

theorem convex_of_ex_hull_eq (s : set α) : is_convex s ↔ ∃ s₁, s = convex_hull s₁ :=
begin
  refine ⟨λ h, ⟨s, eq.symm h⟩, λ h, _⟩,
  cases h with _ h, rw h,
  apply hulls_are_convex
end

protected theorem univ : @is_convex α _ set.univ :=
convex_hull.of_univ

end is_convex

theorem convex_hull.eq_bInter_convex (s : set α) :
  convex_hull s = ⋂ (s₁ ⊇ s) (h : is_convex s₁), s₁ :=
begin
  apply set.eq_of_subset_of_subset (λ _ h, _) (λ _ h, _),
    { simp only [is_convex.convex_def, set.mem_Inter],
      intros _ hs₁ hs₂, rw ←hs₂,
      exact convex_hull.is_mono hs₁ h },
    { simp only [set.mem_Inter] at h,
      specialize h _ (convex_hull.self_subs_hull _),
      exact h (is_convex.hulls_are_convex _) }
end

namespace is_affine

/-- Every linear affine_hull is a linear subspace. -/
theorem spans_are_affines (s : set α) : is_affine (affine_hull s) :=
affine_hull.affine s

theorem ex_set_span_eq_of_affine {s : set α} (h : is_affine s) : ∃ s', affine_hull s' = s :=
⟨s, h⟩

theorem affine_iff_ex_set_span_eq (s : set α) : is_affine s ↔ ∃ s', affine_hull s' = s :=
begin
  refine ⟨ex_set_span_eq_of_affine
, _⟩,
  rintro ⟨_, h⟩,
  rw [is_affine
, ←h, affine_hull.idempotent]
end

/-- If `S` is a linear subspace, then every point in `S` lies on some line
    intersecting `S`. -/
theorem mem_line_of_mem {s : set α} (hs : is_affine s) {x : α} (h : x ∈ s) :
  ∃ v₁ v₂ ∈ s, x ∈ line v₁ v₂ :=
⟨_, _, h, h, line.end_mem_line_left _ _⟩

/-- If `S` is a linear subspace, then a point is in `S` iff it is on a line
    intersecting two points in `S`. -/
theorem mem_iff_mem_line {s : set α} (hs : is_affine s) (x : α) :
  x ∈ s ↔ ∃ v₁ v₂ ∈ s, x ∈ line v₁ v₂ :=
begin
  apply iff.intro (mem_line_of_mem hs),
  rw affine_def at hs,
  rintro ⟨_, _, hv₁, hv₂, h⟩,
  rw ←hs at *,
  exact affine_hull.of_line hv₁ hv₂ h
end

/-- A set `S` is a linear subspace iff, for any point `x`, `x ∈ S` is equivalent
    to there being two more points in `S` such that `x` is on the line between
    them. -/
theorem affine_iff_mem_iff_mem_line (s : set α) :
  is_affine
 s ↔ ∀ x, x ∈ s ↔ ∃ v₁ v₂ ∈ s, x ∈ line v₁ v₂ :=
begin
  apply iff.intro mem_iff_mem_line (λ hs, _),
  apply set.eq_of_subset_of_subset (λ _ h, _) (λ _, affine_hull.of_set),
  induction h with _ h₂ _ _ _ _ _ h hv₁ hv₂,
    { assumption },
    { exact (hs _).mpr ⟨_, _, hv₁, hv₂, h⟩ }
end

protected theorem is_convex (s : set α) : is_convex $ affine_hull s :=
begin
  apply set.eq_of_subset_of_subset (λ _ h, _) (convex_hull.self_subs_hull _),
  induction h with _ h _ _ _ _ _ h hv₁ hv₂, { assumption },
  exact affine_hull.of_line hv₁ hv₂ (line.intrv_subs _ _ h)
end

protected theorem univ : @is_affine α _ set.univ :=
affine_hull.of_univ

end is_affine

theorem affine_hull.eq_bInter_affine (s : set α) :
  affine_hull s = ⋂ (s₁ ⊇ s) (h : is_affine s₁), s₁ :=
begin
  apply set.eq_of_subset_of_subset (λ _ h, _) (λ _ h, _),
    { simp only [is_affine.affine_def, set.mem_Inter],
      intros _ hs₁ hs₂, rw ←hs₂,
      exact affine_hull.is_mono hs₁ h },
    { simp only [set.mem_Inter] at h,
      specialize h _ (affine_hull.self_subs_span _),
      exact h (affine_hull.affine
     _) }
end
end


#print nat.less_than_or_equal

example : 7 <= 19 :=
begin
apply nat.less_than_or_equal.step,
apply nat.less_than_or_equal.step,
apply nat.less_than_or_equal.step,
apply nat.less_than_or_equal.step,
apply nat.less_than_or_equal.step,
apply nat.less_than_or_equal.step,
apply nat.less_than_or_equal.step,
apply nat.less_than_or_equal.step,
apply nat.less_than_or_equal.step,
apply nat.less_than_or_equal.step,
apply nat.less_than_or_equal.step,
apply nat.less_than_or_equal.step,
apply nat.less_than_or_equal.refl,
end

example : 7 <= 19 :=
begin
repeat {
  apply nat.less_than_or_equal.step;
  try  { apply nat.less_than_or_equal.refl }
},
end

#print gt
#print nat.lt

example : ∀ n : ℕ, nat.succ n > n :=
begin
intro n,
unfold gt,
apply nat.less_than_or_equal.refl,
end

#print nat.add_succ

lemma foo :
  ∀ n m, nat.succ (n + m) = n + nat.succ m :=
begin
  intros n m,
  apply eq.symm,
  rw nat.add_comm,
  simp,
end

theorem sum_inequality (a b : nat) :
  a > b → a + a > b + b :=
begin
intro h,
change b < a at h,
change nat.succ b <= a at h,
change b + b < a + a,
change nat.succ (b + b) <= a + a,
induction h,

rewrite nat.add_succ,
simp [nat.add],
rewrite foo,
apply nat.less_than_or_equal.step,
apply nat.less_than_or_equal.refl,

end


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

From https://github.com/leanprover-community/mathlib/blob/71b1be63560d43c689b2c1338ed1366619ce2940/src/linear_algebra/clifford_algebra/grading.lean
-/
import linear_algebra.clifford_algebra.basic
import data.zmod.basic

import cicm2022.internal.graded_ring

/-!
# Results about the grading structure of the clifford algebra

The main result is `clifford_algebra.graded_algebra`, which says that the clifford algebra is a
ℤ₂-graded algebra (or "superalgebra").
-/

namespace clifford_algebra
variables {R M : Type*} [comm_ring R] [add_comm_group M] [module R M]
variables {Q : quadratic_form R M}

open_locale direct_sum

variables (Q)

/-- The even or odd submodule, defined as the supremum of the even or odd powers of
`(ι Q).range`. `even_odd 0` is the even submodule, and `even_odd 1` is the odd submodule. -/
def even_odd (i : zmod 2) : submodule R (clifford_algebra Q) :=
⨆ (j : {n : ℕ // ↑n = i}), (ι Q).range ^ (j : ℕ)

lemma one_le_even_odd_zero : 1 ≤ even_odd Q 0 :=
begin
  refine le_trans _ (le_supr _ ⟨0, nat.cast_zero⟩),
  exact (pow_zero _).ge,
end

lemma range_ι_le_even_odd_one : (ι Q).range ≤ even_odd Q 1 :=
begin
  refine le_trans _ (le_supr _ ⟨1, nat.cast_one⟩),
  exact (pow_one _).ge,
end

lemma ι_mem_even_odd_one (m : M) : ι Q m ∈ even_odd Q 1 :=
range_ι_le_even_odd_one Q $ linear_map.mem_range_self _ m

lemma ι_mul_ι_mem_even_odd_zero (m₁ m₂ : M) :
  ι Q m₁ * ι Q m₂ ∈ even_odd Q 0 :=
submodule.mem_supr_of_mem ⟨2, rfl⟩ begin
  rw [subtype.coe_mk, pow_two],
  exact submodule.mul_mem_mul ((ι Q).mem_range_self m₁) ((ι Q).mem_range_self m₂),
end

lemma even_odd_mul_le (i j : zmod 2) : even_odd Q i * even_odd Q j ≤ even_odd Q (i + j) :=
begin
  simp_rw [even_odd, submodule.supr_eq_span, submodule.span_mul_span],
  apply submodule.span_mono,
  intros z hz,
  obtain ⟨x, y, hx, hy, rfl⟩ := hz,
  obtain ⟨xi, hx'⟩ := set.mem_Union.mp hx,
  obtain ⟨yi, hy'⟩ := set.mem_Union.mp hy,
  refine set.mem_Union.mpr ⟨⟨xi + yi, by simp only [nat.cast_add, xi.prop, yi.prop]⟩, _⟩,
  simp only [subtype.coe_mk, nat.cast_add, pow_add],
  exact submodule.mul_mem_mul hx' hy',
end

instance even_odd.graded_monoid : set_like.graded_monoid (even_odd Q) :=
{ one_mem := submodule.one_le.mp (one_le_even_odd_zero Q),
  mul_mem := λ i j p q hp hq, submodule.mul_le.mp (even_odd_mul_le Q _ _) _ hp _ hq }

/-- A version of `clifford_algebra.ι` that maps directly into the graded structure. This is
primarily an auxiliary construction used to provide `clifford_algebra.graded_algebra`. -/
def graded_algebra.ι : M →ₗ[R] ⨁ i : zmod 2, even_odd Q i :=
direct_sum.lof R (zmod 2) (λ i, ↥(even_odd Q i)) 1 ∘ₗ (ι Q).cod_restrict _ (ι_mem_even_odd_one Q)

lemma graded_algebra.ι_apply (m : M) :
  graded_algebra.ι Q m = direct_sum.of (λ i, ↥(even_odd Q i)) 1 (⟨ι Q m, ι_mem_even_odd_one Q m⟩) :=
rfl

lemma graded_algebra.ι_sq_scalar (m : M) :
  graded_algebra.ι Q m * graded_algebra.ι Q m = algebra_map R _ (Q m) :=
begin
  rw [graded_algebra.ι_apply, direct_sum.of_mul_of, direct_sum.algebra_map_apply],
  refine direct_sum.of_eq_of_graded_monoid_eq (sigma.subtype_ext rfl $ ι_sq_scalar _ _),
end

lemma graded_algebra.lift_ι_eq (i' : zmod 2) (x' : even_odd Q i') :
  lift Q ⟨graded_algebra.ι Q, graded_algebra.ι_sq_scalar Q⟩ x' =
    direct_sum.of (λ i, even_odd Q i) i' x' :=
begin
  cases x' with x' hx',
  dsimp only [subtype.coe_mk, direct_sum.lof_eq_of],
  refine submodule.supr_induction' _ (λ i x hx, _) _ (λ x y hx hy ihx ihy, _) hx',
  { obtain ⟨i, rfl⟩ := i,
    dsimp only [subtype.coe_mk] at hx,
    refine submodule.pow_induction_on_left' _
      (λ r, _) (λ x y i hx hy ihx ihy, _) (λ m hm i x hx ih, _) hx,
    { rw [alg_hom.commutes, direct_sum.algebra_map_apply], refl },
    { rw [alg_hom.map_add, ihx, ihy, ←map_add], refl },
    { obtain ⟨_, rfl⟩ := hm,
      rw [alg_hom.map_mul, ih, lift_ι_apply, graded_algebra.ι_apply, direct_sum.of_mul_of],
      refine direct_sum.of_eq_of_graded_monoid_eq (sigma.subtype_ext _ _);
        dsimp only [graded_monoid.mk, subtype.coe_mk],
      { rw [nat.succ_eq_add_one, add_comm, nat.cast_add, nat.cast_one] },
      refl } },
  { rw alg_hom.map_zero,
    apply eq.symm,
    apply dfinsupp.single_eq_zero.mpr, refl, },
  { rw [alg_hom.map_add, ihx, ihy, ←map_add], refl },
end

/-- The clifford algebra is graded by the even and odd parts. -/
instance graded_algebra : graded_algebra (even_odd Q) :=
graded_algebra.of_alg_hom (even_odd Q)
  (lift _ ⟨graded_algebra.ι Q, graded_algebra.ι_sq_scalar Q⟩)
  -- the proof from here onward is mostly similar to the `tensor_algebra` case, with some extra
  -- handling for the `supr` in `even_odd`.
  (begin
    ext m,
    dsimp only [linear_map.comp_apply, alg_hom.to_linear_map_apply, alg_hom.comp_apply,
      alg_hom.id_apply],
    rw [lift_ι_apply, graded_algebra.ι_apply, direct_sum.coe_alg_hom_of, subtype.coe_mk],
  end)
  (by exact graded_algebra.lift_ι_eq Q)

lemma supr_ι_range_eq_top : (⨆ i : ℕ, (ι Q).range ^ i) = ⊤ :=
begin
  rw [← (direct_sum.decomposition.is_internal (even_odd Q)).submodule_supr_eq_top, eq_comm],
  calc    (⨆ (i : zmod 2) (j : {n // ↑n = i}), (ι Q).range ^ ↑j)
        = (⨆ (i : Σ i : zmod 2, {n : ℕ // ↑n = i}), (ι Q).range ^ (i.2 : ℕ)) : by rw supr_sigma
    ... = (⨆ (i : ℕ), (ι Q).range ^ i)
        : function.surjective.supr_congr (λ i, i.2) (λ i, ⟨⟨_, i, rfl⟩, rfl⟩) (λ _, rfl),
end

lemma even_odd_is_compl : is_compl (even_odd Q 0) (even_odd Q 1) :=
(direct_sum.decomposition.is_internal (even_odd Q)).is_compl zero_ne_one $ begin
  have : (finset.univ : finset (zmod 2)) = {0, 1} := rfl,
  simpa using congr_arg (coe : finset (zmod 2) → set (zmod 2)) this,
end

/-- To show a property is true on the even or odd part, it suffices to show it is true on the
scalars or vectors (respectively), closed under addition, and under left-multiplication by a pair
of vectors. -/
@[elab_as_eliminator]
lemma even_odd_induction (n : zmod 2) {P : Π x, x ∈ even_odd Q n → Prop}
  (hr : ∀ v (h : v ∈ (ι Q).range ^ n.val),
    P v (submodule.mem_supr_of_mem ⟨n.val, n.nat_cast_zmod_val⟩ h))
  (hadd : ∀ {x y hx hy}, P x hx → P y hy → P (x + y) (submodule.add_mem _ hx hy))
  (hιι_mul : ∀ m₁ m₂ {x hx}, P x hx → P (ι Q m₁ * ι Q m₂ * x)
    (zero_add n ▸ set_like.graded_monoid.mul_mem (ι_mul_ι_mem_even_odd_zero Q m₁ m₂) hx))
  (x : clifford_algebra Q) (hx : x ∈ even_odd Q n) : P x hx :=
begin
  apply submodule.supr_induction' _ _ (hr 0 (submodule.zero_mem _)) @hadd,
  refine subtype.rec _,
  simp_rw [subtype.coe_mk, zmod.nat_coe_zmod_eq_iff, add_comm n.val],
  rintros n' ⟨k, rfl⟩ xv,
  simp_rw [pow_add, pow_mul],
  refine submodule.mul_induction_on' _ _,
  { intros a ha b hb,
    refine submodule.pow_induction_on_left' ((ι Q).range ^ 2) _ _ _ ha,
    { intro r,
      simp_rw ←algebra.smul_def,
      exact hr _ (submodule.smul_mem _ _ hb), },
    { intros x y n hx hy,
      simp_rw add_mul,
      apply hadd, },
    { intros x hx n y hy ihy,
      revert hx,
      simp_rw pow_two,
      refine submodule.mul_induction_on' _ _,
      { simp_rw linear_map.mem_range,
        rintros _ ⟨m₁, rfl⟩ _ ⟨m₂, rfl⟩,
        simp_rw mul_assoc _ y b,
        refine hιι_mul _ _ ihy, },
      { intros x hx y hy ihx ihy,
        simp_rw add_mul,
        apply hadd ihx ihy } } },
  { intros x y hx hy,
    apply hadd }
end

/-- To show a property is true on the even parts, it suffices to show it is true on the
scalars, closed under addition, and under left-multiplication by a pair of vectors. -/
@[elab_as_eliminator]
lemma even_induction  {P : Π x, x ∈ even_odd Q 0 → Prop}
  (hr : ∀ r : R, P (algebra_map _ _ r) (set_like.has_graded_one.algebra_map_mem _ _))
  (hadd : ∀ {x y hx hy}, P x hx → P y hy → P (x + y) (submodule.add_mem _ hx hy))
  (hιι_mul : ∀ m₁ m₂ {x hx}, P x hx → P (ι Q m₁ * ι Q m₂ * x)
    (zero_add 0 ▸ set_like.graded_monoid.mul_mem (ι_mul_ι_mem_even_odd_zero Q m₁ m₂) hx))
  (x : clifford_algebra Q) (hx : x ∈ even_odd Q 0) : P x hx :=
begin
  refine even_odd_induction Q 0 (λ rx, _) @hadd hιι_mul x hx,
  simp_rw [zmod.val_zero, pow_zero],
  rintro ⟨r, rfl⟩,
  exact hr r,
end

/-- To show a property is true on the odd parts, it suffices to show it is true on the
vectors, closed under addition, and under left-multiplication by a pair of vectors. -/
@[elab_as_eliminator]
lemma odd_induction {P : Π x, x ∈ even_odd Q 1 → Prop}
  (hι : ∀ v, P (ι Q v) (ι_mem_even_odd_one _ _))
  (hadd : ∀ {x y hx hy}, P x hx → P y hy → P (x + y) (submodule.add_mem _ hx hy))
  (hιι_mul : ∀ m₁ m₂ {x hx}, P x hx → P (ι Q m₁ * ι Q m₂ * x)
    (zero_add (1 : zmod 2) ▸ set_like.graded_monoid.mul_mem (ι_mul_ι_mem_even_odd_zero Q m₁ m₂) hx))
  (x : clifford_algebra Q) (hx : x ∈ even_odd Q 1) : P x hx :=
begin
  refine even_odd_induction Q 1 (λ ιv, _) @hadd hιι_mul x hx,
  simp_rw [zmod.val_one, pow_one],
  rintro ⟨v, rfl⟩,
  exact hι v,
end

end clifford_algebra


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

/-!
# Triangles in graphs

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

A *triangle* in a simple graph is a `3`-clique, namely a set of three vertices that are
pairwise adjacent.

This module defines and proves properties about triangles in simple graphs.

## Main declarations

* `simple_graph.far_from_triangle_free`: Predicate for a graph to have enough triangles that, to
  remove all of them, one must one must remove a lot of edges. This is the crux of the Triangle
  Removal lemma.

## TODO

* Generalise `far_from_triangle_free` to other graphs, to state and prove the Graph Removal Lemma.
* Find a better name for `far_from_triangle_free`. Added 4/26/2022. Remove this TODO if it gets old.
-/

open finset fintype nat
open_locale classical

namespace simple_graph
variables {α 𝕜 : Type*} [fintype α] [linear_ordered_field 𝕜] {G H : simple_graph α} {ε δ : 𝕜}
  {n : ℕ} {s : finset α}

/-- A simple graph is *`ε`-triangle-free far* if one must remove at least `ε * (card α)^2` edges to
make it triangle-free. -/
def far_from_triangle_free (G : simple_graph α) (ε : 𝕜) : Prop :=
G.delete_far (λ H, H.clique_free 3) $ ε * (card α^2 : ℕ)

lemma far_from_triangle_free_iff :
  G.far_from_triangle_free ε ↔
    ∀ ⦃H⦄, H ≤ G → H.clique_free 3 → ε * (card α^2 : ℕ) ≤ G.edge_finset.card - H.edge_finset.card :=
delete_far_iff

alias far_from_triangle_free_iff ↔ far_from_triangle_free.le_card_sub_card _

lemma far_from_triangle_free.mono (hε : G.far_from_triangle_free ε) (h : δ ≤ ε) :
  G.far_from_triangle_free δ :=
hε.mono $ mul_le_mul_of_nonneg_right h $ cast_nonneg _

lemma far_from_triangle_free.clique_finset_nonempty' (hH : H ≤ G) (hG : G.far_from_triangle_free ε)
  (hcard : (G.edge_finset.card - H.edge_finset.card : 𝕜) < ε * (card α ^ 2 : ℕ)) :
  (H.clique_finset 3).nonempty :=
nonempty_of_ne_empty $ H.clique_finset_eq_empty_iff.not.2 $ λ hH',
  (hG.le_card_sub_card hH hH').not_lt hcard

variables [nonempty α]

lemma far_from_triangle_free.nonpos (h₀ : G.far_from_triangle_free ε) (h₁ : G.clique_free 3) :
  ε ≤ 0 :=
begin
  have := h₀ (empty_subset _),
  rw [coe_empty, finset.card_empty, cast_zero, delete_edges_empty_eq] at this,
  exact nonpos_of_mul_nonpos_left (this h₁) (cast_pos.2 $ sq_pos_of_pos fintype.card_pos),
end

lemma clique_free.not_far_from_triangle_free (hG : G.clique_free 3) (hε : 0 < ε) :
  ¬ G.far_from_triangle_free ε :=
λ h, (h.nonpos hG).not_lt hε

lemma far_from_triangle_free.not_clique_free (hG : G.far_from_triangle_free ε) (hε : 0 < ε) :
  ¬ G.clique_free 3 :=
λ h, (hG.nonpos h).not_lt hε

lemma far_from_triangle_free.clique_finset_nonempty (hG : G.far_from_triangle_free ε) (hε : 0 < ε) :
  (G.clique_finset 3).nonempty :=
nonempty_of_ne_empty $ G.clique_finset_eq_empty_iff.not.2 $ hG.not_clique_free hε

end simple_graph