/-
Copyright (c) 2019 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin, Floris van Doorn
-/
import algebra.big_operators.basic
import algebra.module.basic
import data.finset.preimage
import data.set.finite
import group_theory.submonoid.basic

/-!
# Pointwise addition, multiplication, scalar multiplication and vector subtraction of sets.

This file defines pointwise algebraic operations on sets.
* For a type `α` with multiplication, multiplication is defined on `set α` by taking
  `s * t` to be the set of all `x * y` where `x ∈ s` and `y ∈ t`. Similarly for addition.
* For `α` a semigroup, `set α` is a semigroup.
* If `α` is a (commutative) monoid, we define an alias `set_semiring α` for `set α`, which then
  becomes a (commutative) semiring with union as addition and pointwise multiplication as
  multiplication.
* For a type `β` with scalar multiplication by another type `α`, this
  file defines a scalar multiplication of `set β` by `set α` and a separate scalar
  multiplication of `set β` by `α`.
* We also define pointwise multiplication on `finset`.

Appropriate definitions and results are also transported to the additive theory via `to_additive`.

## Implementation notes
* The following expressions are considered in simp-normal form in a group:
  `(λ h, h * g) ⁻¹' s`, `(λ h, g * h) ⁻¹' s`, `(λ h, h * g⁻¹) ⁻¹' s`, `(λ h, g⁻¹ * h) ⁻¹' s`,
  `s * t`, `s⁻¹`, `(1 : set _)` (and similarly for additive variants).
  Expressions equal to one of these will be simplified.
* We put all instances in the locale `pointwise`, so that these instances are not available by
  default. Note that we do not mark them as reducible (as argued by note [reducible non-instances])
  since we expect the locale to be open whenever the instances are actually used (and making the
  instances reducible changes the behavior of `simp`).

## Tags

set multiplication, set addition, pointwise addition, pointwise multiplication,
pointwise subtraction
-/

open function

variables {α β γ : Type*}

namespace set

/-! ### Properties about 1 -/

section one
variables [has_one α] {s : set α} {a : α}

/-- The set `(1 : set α)` is defined as `{1}` in locale `pointwise`. -/
@[to_additive
/-"The set `(0 : set α)` is defined as `{0}` in locale `pointwise`. "-/]
protected def has_one : has_one (set α) := ⟨{1}⟩

localized "attribute [instance] set.has_one set.has_zero" in pointwise

@[to_additive]
lemma singleton_one : ({1} : set α) = 1 := rfl

@[simp, to_additive]
lemma mem_one : a ∈ (1 : set α) ↔ a = 1 := iff.rfl

@[to_additive]
lemma one_mem_one : (1 : α) ∈ (1 : set α) := eq.refl _

@[simp, to_additive]
lemma one_subset : 1 ⊆ s ↔ (1 : α) ∈ s := singleton_subset_iff

@[to_additive]
lemma one_nonempty : (1 : set α).nonempty := ⟨1, rfl⟩

@[simp, to_additive]
lemma image_one {f : α → β} : f '' 1 = {f 1} := image_singleton

end one

open_locale pointwise

/-! ### Properties about multiplication -/

section mul
variables {s s₁ s₂ t t₁ t₂ u : set α} {a b : α}

/-- The set `(s * t : set α)` is defined as `{x * y | x ∈ s, y ∈ t}` in locale `pointwise`. -/
@[to_additive
/-" The set `(s + t : set α)` is defined as `{x + y | x ∈ s, y ∈ t}` in locale `pointwise`."-/]
protected def has_mul [has_mul α] : has_mul (set α) := ⟨image2 has_mul.mul⟩

localized "attribute [instance] set.has_mul set.has_add" in pointwise

section has_mul
variables {ι : Sort*} {κ : ι → Sort*} [has_mul α]

@[simp, to_additive]
lemma image2_mul : image2 has_mul.mul s t = s * t := rfl

@[to_additive]
lemma mem_mul : a ∈ s * t ↔ ∃ x y, x ∈ s ∧ y ∈ t ∧ x * y = a := iff.rfl

@[to_additive]
lemma mul_mem_mul (ha : a ∈ s) (hb : b ∈ t) : a * b ∈ s * t := mem_image2_of_mem ha hb

@[to_additive]
lemma mul_subset_mul (h₁ : s₁ ⊆ t₁) (h₂ : s₂ ⊆ t₂) : s₁ * s₂ ⊆ t₁ * t₂ := image2_subset h₁ h₂

@[to_additive add_image_prod]
lemma image_mul_prod : (λ x : α × α, x.fst * x.snd) '' (s ×ˢ t) = s * t := image_prod _

@[simp, to_additive] lemma empty_mul : ∅ * s = ∅ := image2_empty_left
@[simp, to_additive] lemma mul_empty : s * ∅ = ∅ := image2_empty_right

@[simp, to_additive] lemma mul_singleton : s * {b} = (* b) '' s := image2_singleton_right
@[simp, to_additive] lemma singleton_mul : {a} * t = ((*) a) '' t := image2_singleton_left

@[simp, to_additive]
lemma singleton_mul_singleton : ({a} : set α) * {b} = {a * b} := image2_singleton

@[to_additive] lemma mul_subset_mul_left (h : t₁ ⊆ t₂) : s * t₁ ⊆ s * t₂ := image2_subset_left h
@[to_additive] lemma mul_subset_mul_right (h : s₁ ⊆ s₂) : s₁ * t ⊆ s₂ * t := image2_subset_right h

@[to_additive] lemma union_mul : (s₁ ∪ s₂) * t = s₁ * t ∪ s₂ * t := image2_union_left
@[to_additive] lemma mul_union : s * (t₁ ∪ t₂) = s * t₁ ∪ s * t₂ := image2_union_right

@[to_additive]
lemma inter_mul_subset : (s₁ ∩ s₂) * t ⊆ s₁ * t ∩ (s₂ * t) := image2_inter_subset_left

@[to_additive]
lemma mul_inter_subset : s * (t₁ ∩ t₂) ⊆ s * t₁ ∩ (s * t₂) := image2_inter_subset_right

@[to_additive]
lemma Union_mul_left_image : (⋃ a ∈ s, (λ x, a * x) '' t) = s * t := Union_image_left _

@[to_additive]
lemma Union_mul_right_image : (⋃ a ∈ t, (λ x, x * a) '' s) = s * t := Union_image_right _

@[to_additive]
lemma Union_mul (s : ι → set α) (t : set α) : (⋃ i, s i) * t = ⋃ i, s i * t :=
image2_Union_left _ _ _

@[to_additive]
lemma mul_Union (s : set α) (t : ι → set α) : s * (⋃ i, t i) = ⋃ i, s * t i :=
image2_Union_right _ _ _

@[to_additive]
lemma Union₂_mul (s : Π i, κ i → set α) (t : set α) : (⋃ i j, s i j) * t = ⋃ i j, s i j * t :=
image2_Union₂_left _ _ _

@[to_additive]
lemma mul_Union₂ (s : set α) (t : Π i, κ i → set α) : s * (⋃ i j, t i j) = ⋃ i j, s * t i j :=
image2_Union₂_right _ _ _

@[to_additive]
lemma Inter_mul_subset (s : ι → set α) (t : set α) : (⋂ i, s i) * t ⊆ ⋂ i, s i * t :=
image2_Inter_subset_left _ _ _

@[to_additive]
lemma mul_Inter_subset (s : set α) (t : ι → set α) : s * (⋂ i, t i) ⊆ ⋂ i, s * t i :=
image2_Inter_subset_right _ _ _

@[to_additive]
lemma Inter₂_mul_subset (s : Π i, κ i → set α) (t : set α) :
  (⋂ i j, s i j) * t ⊆ ⋂ i j, s i j * t :=
image2_Inter₂_subset_left _ _ _

@[to_additive]
lemma mul_Inter₂_subset (s : set α) (t : Π i, κ i → set α) :
  s * (⋂ i j, t i j) ⊆ ⋂ i j, s * t i j :=
image2_Inter₂_subset_right _ _ _

/-- Under `[has_mul M]`, the `singleton` map from `M` to `set M` as a `mul_hom`, that is, a map
which preserves multiplication. -/
@[to_additive "Under `[has_add A]`, the `singleton` map from `A` to `set A` as an `add_hom`,
that is, a map which preserves addition.", simps]
def singleton_mul_hom : mul_hom α (set α) :=
{ to_fun := singleton,
  map_mul' := λ a b, singleton_mul_singleton.symm }

end has_mul

@[simp, to_additive]
lemma image_mul_left [group α] : ((*) a) '' t = ((*) a⁻¹) ⁻¹' t :=
by { rw image_eq_preimage_of_inverse; intro c; simp }

@[simp, to_additive]
lemma image_mul_right [group α] : (* b) '' t = (* b⁻¹) ⁻¹' t :=
by { rw image_eq_preimage_of_inverse; intro c; simp }

@[to_additive]
lemma image_mul_left' [group α] : (λ b, a⁻¹ * b) '' t = (λ b, a * b) ⁻¹' t := by simp

@[to_additive]
lemma image_mul_right' [group α] : (* b⁻¹) '' t = (* b) ⁻¹' t := by simp

@[simp, to_additive]
lemma preimage_mul_left_singleton [group α] : ((*) a) ⁻¹' {b} = {a⁻¹ * b} :=
by rw [← image_mul_left', image_singleton]

@[simp, to_additive]
lemma preimage_mul_right_singleton [group α] : (* a) ⁻¹' {b} = {b * a⁻¹} :=
by rw [← image_mul_right', image_singleton]

@[simp, to_additive]
lemma preimage_mul_left_one [group α] : ((*) a) ⁻¹' 1 = {a⁻¹} :=
by rw [← image_mul_left', image_one, mul_one]

@[simp, to_additive]
lemma preimage_mul_right_one [group α] : (* b) ⁻¹' 1 = {b⁻¹} :=
by rw [← image_mul_right', image_one, one_mul]

@[to_additive]
lemma preimage_mul_left_one' [group α] : (λ b, a⁻¹ * b) ⁻¹' 1 = {a} := by simp

@[to_additive]
lemma preimage_mul_right_one' [group α] : (* b⁻¹) ⁻¹' 1 = {b} := by simp

@[to_additive]
protected lemma mul_comm [comm_semigroup α] : s * t = t * s :=
by simp only [← image2_mul, image2_swap _ s, mul_comm]

/-- `set α` is a `mul_one_class` under pointwise operations if `α` is. -/
@[to_additive /-"`set α` is an `add_zero_class` under pointwise operations if `α` is."-/]
protected def mul_one_class [mul_one_class α] : mul_one_class (set α) :=
{ mul_one := λ s, by { simp only [← singleton_one, mul_singleton, mul_one, image_id'] },
  one_mul := λ s, by { simp only [← singleton_one, singleton_mul, one_mul, image_id'] },
  ..set.has_one, ..set.has_mul }

/-- `set α` is a `semigroup` under pointwise operations if `α` is. -/
@[to_additive /-"`set α` is an `add_semigroup` under pointwise operations if `α` is. "-/]
protected def semigroup [semigroup α] : semigroup (set α) :=
{ mul_assoc := λ _ _ _, image2_assoc mul_assoc,
  ..set.has_mul }

/-- `set α` is a `monoid` under pointwise operations if `α` is. -/
@[to_additive /-"`set α` is an `add_monoid` under pointwise operations if `α` is. "-/]
protected def monoid [monoid α] : monoid (set α) :=
{ ..set.semigroup,
  ..set.mul_one_class }

/-- `set α` is a `comm_monoid` under pointwise operations if `α` is. -/
@[to_additive /-"`set α` is an `add_comm_monoid` under pointwise operations if `α` is. "-/]
protected def comm_monoid [comm_monoid α] : comm_monoid (set α) :=
{ mul_comm := λ _ _, set.mul_comm, ..set.monoid }

localized "attribute [instance] set.mul_one_class set.add_zero_class set.semigroup set.add_semigroup
  set.monoid set.add_monoid set.comm_monoid set.add_comm_monoid" in pointwise

@[to_additive nsmul_mem_nsmul]
lemma pow_mem_pow [monoid α] (ha : a ∈ s) (n : ℕ) :
  a ^ n ∈ s ^ n :=
begin
  induction n with n ih,
  { rw pow_zero,
    exact set.mem_singleton 1 },
  { rw pow_succ,
    exact set.mul_mem_mul ha ih },
end

@[to_additive empty_nsmul]
lemma empty_pow [monoid α] (n : ℕ) (hn : n ≠ 0) : (∅ : set α) ^ n = ∅ :=
by rw [← tsub_add_cancel_of_le (nat.succ_le_of_lt $ nat.pos_of_ne_zero hn), pow_succ, empty_mul]

instance decidable_mem_mul [monoid α] [fintype α] [decidable_eq α]
  [decidable_pred (∈ s)] [decidable_pred (∈ t)] :
  decidable_pred (∈ s * t) :=
λ _, decidable_of_iff _ mem_mul.symm

instance decidable_mem_pow [monoid α] [fintype α] [decidable_eq α]
  [decidable_pred (∈ s)] (n : ℕ) :
  decidable_pred (∈ (s ^ n)) :=
begin
  induction n with n ih,
  { simp_rw [pow_zero, mem_one], apply_instance },
  { letI := ih, rw pow_succ, apply_instance }
end

@[to_additive]
lemma subset_mul_left [mul_one_class α] (s : set α) {t : set α} (ht : (1 : α) ∈ t) : s ⊆ s * t :=
λ x hx, ⟨x, 1, hx, ht, mul_one _⟩

@[to_additive]
lemma subset_mul_right [mul_one_class α] {s : set α} (t : set α) (hs : (1 : α) ∈ s) : t ⊆ s * t :=
λ x hx, ⟨1, x, hs, hx, one_mul _⟩

lemma pow_subset_pow [monoid α] (hst : s ⊆ t) (n : ℕ) :
  s ^ n ⊆ t ^ n :=
begin
  induction n with n ih,
  { rw pow_zero,
    exact subset.rfl },
  { rw [pow_succ, pow_succ],
    exact mul_subset_mul hst ih },
end

@[simp, to_additive]
lemma univ_mul_univ [monoid α] : (univ : set α) * univ = univ :=
begin
  have : ∀x, ∃a b : α, a * b = x := λx, ⟨x, ⟨1, mul_one x⟩⟩,
  simpa only [mem_mul, eq_univ_iff_forall, mem_univ, true_and]
end

@[simp, to_additive]
lemma mul_univ [group α] (hs : s.nonempty) : s * (univ : set α) = univ :=
let ⟨a, ha⟩ := hs in eq_univ_of_forall $ λ b, ⟨a, a⁻¹ * b, ha, trivial, mul_inv_cancel_left _ _⟩

@[simp, to_additive]
lemma univ_mul [group α] (ht : t.nonempty) : (univ : set α) * t = univ :=
let ⟨a, ha⟩ := ht in eq_univ_of_forall $ λ b, ⟨b * a⁻¹, a, trivial, ha, inv_mul_cancel_right _ _⟩

/-- `singleton` is a monoid hom. -/
@[to_additive singleton_add_hom "singleton is an add monoid hom"]
def singleton_hom [monoid α] : α →* set α :=
{ to_fun := singleton, map_one' := rfl, map_mul' := λ a b, singleton_mul_singleton.symm }

@[to_additive]
lemma nonempty.mul [has_mul α] : s.nonempty → t.nonempty → (s * t).nonempty := nonempty.image2

@[to_additive]
lemma finite.mul [has_mul α] (hs : finite s) (ht : finite t) : finite (s * t) :=
hs.image2 _ ht

/-- multiplication preserves finiteness -/
@[to_additive "addition preserves finiteness"]
def fintype_mul [has_mul α] [decidable_eq α] (s t : set α) [hs : fintype s] [ht : fintype t] :
  fintype (s * t : set α) :=
set.fintype_image2 _ s t

@[to_additive]
lemma bdd_above_mul [ordered_comm_monoid α] {A B : set α} :
  bdd_above A → bdd_above B → bdd_above (A * B) :=
begin
  rintros ⟨bA, hbA⟩ ⟨bB, hbB⟩,
  use bA * bB,
  rintros x ⟨xa, xb, hxa, hxb, rfl⟩,
  exact mul_le_mul' (hbA hxa) (hbB hxb),
end

end mul

open_locale pointwise

section big_operators
open_locale big_operators

variables {ι : Type*} [comm_monoid α]

/-- The n-ary version of `set.mem_mul`. -/
@[to_additive /-" The n-ary version of `set.mem_add`. "-/]
lemma mem_finset_prod (t : finset ι) (f : ι → set α) (a : α) :
  a ∈ ∏ i in t, f i ↔ ∃ (g : ι → α) (hg : ∀ {i}, i ∈ t → g i ∈ f i), ∏ i in t, g i = a :=
begin
  classical,
  induction t using finset.induction_on with i is hi ih generalizing a,
  { simp_rw [finset.prod_empty, set.mem_one],
    exact ⟨λ h, ⟨λ i, a, λ i, false.elim, h.symm⟩, λ ⟨f, _, hf⟩, hf.symm⟩ },
  rw [finset.prod_insert hi, set.mem_mul],
  simp_rw [finset.prod_insert hi],
  simp_rw ih,
  split,
  { rintros ⟨x, y, hx, ⟨g, hg, rfl⟩, rfl⟩,
    refine ⟨function.update g i x, λ j hj, _, _⟩,
    obtain rfl | hj := finset.mem_insert.mp hj,
    { rw function.update_same, exact hx },
    { rw update_noteq (ne_of_mem_of_not_mem hj hi), exact hg hj, },
    rw [finset.prod_update_of_not_mem hi, function.update_same], },
  { rintros ⟨g, hg, rfl⟩,
    exact ⟨g i, is.prod g, hg (is.mem_insert_self _),
      ⟨g, λ i hi, hg (finset.mem_insert_of_mem hi), rfl⟩, rfl⟩ },
end

/-- A version of `set.mem_finset_prod` with a simpler RHS for products over a fintype. -/
@[to_additive /-" A version of `set.mem_finset_sum` with a simpler RHS for sums over a fintype. "-/]
lemma mem_fintype_prod [fintype ι] (f : ι → set α) (a : α) :
  a ∈ ∏ i, f i ↔ ∃ (g : ι → α) (hg : ∀ i, g i ∈ f i), ∏ i, g i = a :=
by { rw mem_finset_prod, simp }

/-- The n-ary version of `set.mul_mem_mul`. -/
@[to_additive /-" The n-ary version of `set.add_mem_add`. "-/]
lemma finset_prod_mem_finset_prod (t : finset ι) (f : ι → set α)
  (g : ι → α) (hg : ∀ i ∈ t, g i ∈ f i) :
  ∏ i in t, g i ∈ ∏ i in t, f i :=
by { rw mem_finset_prod, exact ⟨g, hg, rfl⟩ }

/-- The n-ary version of `set.mul_subset_mul`. -/
@[to_additive /-" The n-ary version of `set.add_subset_add`. "-/]
lemma finset_prod_subset_finset_prod (t : finset ι) (f₁ f₂ : ι → set α)
  (hf : ∀ {i}, i ∈ t → f₁ i ⊆ f₂ i) :
  ∏ i in t, f₁ i ⊆ ∏ i in t, f₂ i :=
begin
  intro a,
  rw [mem_finset_prod, mem_finset_prod],
  rintro ⟨g, hg, rfl⟩,
  exact ⟨g, λ i hi, hf hi $ hg hi, rfl⟩
end

@[to_additive]
lemma finset_prod_singleton {M ι : Type*} [comm_monoid M] (s : finset ι) (I : ι → M) :
  ∏ (i : ι) in s, ({I i} : set M) = {∏ (i : ι) in s, I i} :=
begin
  letI := classical.dec_eq ι,
  refine finset.induction_on s _ _,
  { simpa },
  { intros _ _ H ih,
    rw [finset.prod_insert H, finset.prod_insert H, ih],
    simp }
end

/-! TODO: define `decidable_mem_finset_prod` and `decidable_mem_finset_sum`. -/

end big_operators

/-! ### Properties about inversion -/

section inv
variables {s t : set α} {a : α}

/-- The set `(s⁻¹ : set α)` is defined as `{x | x⁻¹ ∈ s}` in locale `pointwise`.
It is equal to `{x⁻¹ | x ∈ s}`, see `set.image_inv`. -/
@[to_additive
/-" The set `(-s : set α)` is defined as `{x | -x ∈ s}` in locale `pointwise`.
It is equal to `{-x | x ∈ s}`, see `set.image_neg`. "-/]
protected def has_inv [has_inv α] : has_inv (set α) :=
⟨preimage has_inv.inv⟩

localized "attribute [instance] set.has_inv set.has_neg" in pointwise

@[simp, to_additive]
lemma inv_empty [has_inv α] : (∅ : set α)⁻¹ = ∅ := rfl

@[simp, to_additive]
lemma inv_univ [has_inv α] : (univ : set α)⁻¹ = univ := rfl

@[simp, to_additive]
lemma nonempty_inv [group α] {s : set α} : s⁻¹.nonempty ↔ s.nonempty :=
inv_involutive.surjective.nonempty_preimage

@[to_additive] lemma nonempty.inv [group α] {s : set α} (h : s.nonempty) : s⁻¹.nonempty :=
nonempty_inv.2 h

@[simp, to_additive]
lemma mem_inv [has_inv α] : a ∈ s⁻¹ ↔ a⁻¹ ∈ s := iff.rfl

@[to_additive]
lemma inv_mem_inv [group α] : a⁻¹ ∈ s⁻¹ ↔ a ∈ s :=
by simp only [mem_inv, inv_inv]

@[simp, to_additive]
lemma inv_preimage [has_inv α] : has_inv.inv ⁻¹' s = s⁻¹ := rfl

@[simp, to_additive]
lemma image_inv [group α] : has_inv.inv '' s = s⁻¹ :=
by { simp only [← inv_preimage], rw [image_eq_preimage_of_inverse]; intro; simp only [inv_inv] }

@[simp, to_additive]
lemma inter_inv [has_inv α] : (s ∩ t)⁻¹ = s⁻¹ ∩ t⁻¹ := preimage_inter

@[simp, to_additive]
lemma union_inv [has_inv α] : (s ∪ t)⁻¹ = s⁻¹ ∪ t⁻¹ := preimage_union

@[simp, to_additive]
lemma Inter_inv {ι : Sort*} [has_inv α] (s : ι → set α) : (⋂ i, s i)⁻¹ = ⋂ i, (s i)⁻¹ :=
preimage_Inter

@[simp, to_additive]
lemma Union_inv {ι : Sort*} [has_inv α] (s : ι → set α) : (⋃ i, s i)⁻¹ = ⋃ i, (s i)⁻¹ :=
preimage_Union

@[simp, to_additive]
lemma compl_inv [has_inv α] : (sᶜ)⁻¹ = (s⁻¹)ᶜ := preimage_compl

@[simp, to_additive]
protected lemma inv_inv [group α] : s⁻¹⁻¹ = s :=
by { simp only [← inv_preimage, preimage_preimage, inv_inv, preimage_id'] }

@[simp, to_additive]
protected lemma univ_inv [group α] : (univ : set α)⁻¹ = univ := preimage_univ

@[simp, to_additive]
lemma inv_subset_inv [group α] {s t : set α} : s⁻¹ ⊆ t⁻¹ ↔ s ⊆ t :=
(equiv.inv α).surjective.preimage_subset_preimage_iff

@[to_additive] lemma inv_subset [group α] {s t : set α} : s⁻¹ ⊆ t ↔ s ⊆ t⁻¹ :=
by { rw [← inv_subset_inv, set.inv_inv] }

@[to_additive] lemma finite.inv [group α] {s : set α} (hs : finite s) : finite s⁻¹ :=
hs.preimage $ inv_injective.inj_on _

@[to_additive] lemma inv_singleton {β : Type*} [group β] (x : β) : ({x} : set β)⁻¹ = {x⁻¹} :=
by { ext1 y, rw [mem_inv, mem_singleton_iff, mem_singleton_iff, inv_eq_iff_inv_eq, eq_comm], }

@[to_additive] protected lemma mul_inv_rev [group α] (s t : set α) : (s * t)⁻¹ = t⁻¹ * s⁻¹ :=
by simp_rw [←image_inv, ←image2_mul, image_image2, image2_image_left, image2_image_right,
              mul_inv_rev, image2_swap _ s t]

end inv

/-! ### Properties about scalar multiplication -/

section smul

/-- The scaling of a set `(x • s : set β)` by a scalar `x ∶ α` is defined as `{x • y | y ∈ s}`
in locale `pointwise`. -/
@[to_additive has_vadd_set "The translation of a set `(x +ᵥ s : set β)` by a scalar `x ∶ α` is
defined as `{x +ᵥ y | y ∈ s}` in locale `pointwise`."]
protected def has_scalar_set [has_scalar α β] : has_scalar α (set β) :=
⟨λ a, image (has_scalar.smul a)⟩

/-- The pointwise scalar multiplication `(s • t : set β)` by a set of scalars `s ∶ set α`
is defined as `{x • y | x ∈ s, y ∈ t}` in locale `pointwise`. -/
@[to_additive has_vadd "The pointwise translation `(s +ᵥ t : set β)` by a set of constants
`s ∶ set α` is defined as `{x +ᵥ y | x ∈ s, y ∈ t}` in locale `pointwise`."]
protected def has_scalar [has_scalar α β] : has_scalar (set α) (set β) :=
⟨image2 has_scalar.smul⟩

localized "attribute [instance] set.has_scalar_set set.has_scalar" in pointwise
localized "attribute [instance] set.has_vadd_set set.has_vadd" in pointwise

section has_scalar
variables {ι : Sort*} {κ : ι → Sort*} [has_scalar α β] {s s₁ s₂ : set α} {t t₁ t₂ u : set β} {a : α}
  {b : β}

@[simp, to_additive]
lemma image2_smul : image2 has_scalar.smul s t = s • t := rfl

@[to_additive add_image_prod]
lemma image_smul_prod : (λ x : α × β, x.fst • x.snd) '' (s ×ˢ t) = s • t := image_prod _

@[to_additive]
lemma mem_smul : b ∈ s • t ↔ ∃ x y, x ∈ s ∧ y ∈ t ∧ x • y = b := iff.rfl

@[to_additive]
lemma smul_mem_smul (ha : a ∈ s) (hb : b ∈ t) : a • b ∈ s • t := mem_image2_of_mem ha hb

@[to_additive]
lemma smul_subset_smul (hs : s₁ ⊆ s₂) (ht : t₁ ⊆ t₂) : s₁ • t₁ ⊆ s₂ • t₂ := image2_subset hs ht

@[to_additive] lemma smul_subset_iff : s • t ⊆ u ↔ ∀ (a ∈ s) (b ∈ t), a • b ∈ u := image2_subset_iff

@[simp, to_additive] lemma empty_smul : (∅ : set α) • t = ∅ := image2_empty_left
@[simp, to_additive] lemma smul_empty : s • (∅ : set β) = ∅ := image2_empty_right

@[simp, to_additive] lemma smul_singleton : s • {b} = (• b) '' s := image2_singleton_right
@[simp, to_additive] lemma singleton_smul : ({a} : set α) • t = a • t := image2_singleton_left

@[simp, to_additive]
lemma singleton_smul_singleton : ({a} : set α) • ({b} : set β) = {a • b} := image2_singleton

@[to_additive] lemma smul_subset_smul_left (h : t₁ ⊆ t₂) : s • t₁ ⊆ s • t₂ := image2_subset_left h
@[to_additive] lemma smul_subset_smul_right (h : s₁ ⊆ s₂) : s₁ • t ⊆ s₂ • t := image2_subset_right h

@[to_additive] lemma union_smul : (s₁ ∪ s₂) • t = s₁ • t ∪ s₂ • t := image2_union_left
@[to_additive] lemma smul_union : s • (t₁ ∪ t₂) = s • t₁ ∪ s • t₂ := image2_union_right

@[to_additive]
lemma inter_smul_subset : (s₁ ∩ s₂) • t ⊆ s₁ • t ∩ s₂ • t := image2_inter_subset_left

@[to_additive]
lemma smul_inter_subset : s • (t₁ ∩ t₂) ⊆ s • t₁ ∩ s • t₂ := image2_inter_subset_right

@[to_additive]
lemma Union_smul_left_image : (⋃ a ∈ s, a • t) = s • t := Union_image_left _

@[to_additive]
lemma Union_smul_right_image : (⋃ a ∈ t, (λ x, x • a) '' s) = s • t := Union_image_right _

@[to_additive]
lemma Union_smul (s : ι → set α) (t : set β) : (⋃ i, s i) • t = ⋃ i, s i • t :=
image2_Union_left _ _ _

@[to_additive]
lemma smul_Union (s : set α) (t : ι → set β) : s • (⋃ i, t i) = ⋃ i, s • t i :=
image2_Union_right _ _ _

@[to_additive]
lemma Union₂_smul (s : Π i, κ i → set α) (t : set β) : (⋃ i j, s i j) • t = ⋃ i j, s i j • t :=
image2_Union₂_left _ _ _

@[to_additive]
lemma smul_Union₂ (s : set α) (t : Π i, κ i → set β) : s • (⋃ i j, t i j) = ⋃ i j, s • t i j :=
image2_Union₂_right _ _ _

@[to_additive]
lemma Inter_smul_subset (s : ι → set α) (t : set β) : (⋂ i, s i) • t ⊆ ⋂ i, s i • t :=
image2_Inter_subset_left _ _ _

@[to_additive]
lemma smul_Inter_subset (s : set α) (t : ι → set β) : s • (⋂ i, t i) ⊆ ⋂ i, s • t i :=
image2_Inter_subset_right _ _ _

@[to_additive]
lemma Inter₂_smul_subset (s : Π i, κ i → set α) (t : set β) :
  (⋂ i j, s i j) • t ⊆ ⋂ i j, s i j • t :=
image2_Inter₂_subset_left _ _ _

@[to_additive]
lemma smul_Inter₂_subset (s : set α) (t : Π i, κ i → set β) :
  s • (⋂ i j, t i j) ⊆ ⋂ i j, s • t i j :=
image2_Inter₂_subset_right _ _ _

end has_scalar

section has_scalar_set
variables {ι : Sort*} {κ : ι → Sort*} [has_scalar α β] {s t t₁ t₂ : set β} {a : α} {b : β} {x y : β}

@[simp, to_additive] lemma image_smul : (λ x, a • x) '' t = a • t := rfl

@[to_additive] lemma mem_smul_set : x ∈ a • t ↔ ∃ y, y ∈ t ∧ a • y = x := iff.rfl

@[to_additive] lemma smul_mem_smul_set (hy : y ∈ t) : a • y ∈ a • t := ⟨y, hy, rfl⟩

@[to_additive]
lemma mem_smul_of_mem {s : set α} (ha : a ∈ s) (hb : b ∈ t) : a • b ∈ s • t :=
mem_image2_of_mem ha hb

@[simp, to_additive] lemma smul_set_empty : a • (∅ : set β) = ∅ := image_empty _

@[simp, to_additive] lemma smul_set_singleton : a • ({b} : set β) = {a • b} := image_singleton

@[to_additive] lemma smul_set_mono (h : s ⊆ t) : a • s ⊆ a • t := image_subset _ h

@[to_additive] lemma smul_set_union : a • (t₁ ∪ t₂) = a • t₁ ∪ a • t₂ := image_union _ _ _

@[to_additive]
lemma smul_set_inter_subset : a • (t₁ ∩ t₂) ⊆ a • t₁ ∩ (a • t₂) := image_inter_subset _ _ _

@[to_additive]
lemma smul_set_Union (a : α) (s : ι → set β) : a • (⋃ i, s i) = ⋃ i, a • s i := image_Union

@[to_additive]
lemma smul_set_Union₂ (a : α) (s : Π i, κ i → set β) : a • (⋃ i j, s i j) = ⋃ i j, a • s i j :=
image_Union₂ _ _

@[to_additive]
lemma smul_set_Inter_subset (a : α) (t : ι → set β) : a • (⋂ i, t i) ⊆ ⋂ i, a • t i :=
image_Inter_subset _ _

@[to_additive]
lemma smul_set_Inter₂_subset (a : α) (t : Π i, κ i → set β) :
  a • (⋂ i j, t i j) ⊆ ⋂ i j, a • t i j :=
image_Inter₂_subset _ _

@[to_additive] lemma finite.smul_set (hs : finite s) : finite (a • s) := hs.image _

end has_scalar_set

variables {s s₁ s₂ : set α} {t t₁ t₂ : set β} {a : α} {b : β}

@[to_additive]
lemma smul_set_inter [group α] [mul_action α β] {s t : set β} :
  a • (s ∩ t) = a • s ∩ a • t :=
(image_inter $ mul_action.injective a).symm

lemma smul_set_inter₀ [group_with_zero α] [mul_action α β] {s t : set β} (ha : a ≠ 0) :
  a • (s ∩ t) = a • s ∩ a • t :=
show units.mk0 a ha • _ = _, from smul_set_inter

@[simp, to_additive]
lemma smul_set_univ [group α] [mul_action α β] {a : α} : a • (univ : set β) = univ :=
eq_univ_of_forall $ λ b, ⟨a⁻¹ • b, trivial, smul_inv_smul _ _⟩

@[simp, to_additive]
lemma smul_univ [group α] [mul_action α β] {s : set α} (hs : s.nonempty) :
  s • (univ : set β) = univ :=
let ⟨a, ha⟩ := hs in eq_univ_of_forall $ λ b, ⟨a, a⁻¹ • b, ha, trivial, smul_inv_smul _ _⟩

@[to_additive]
theorem range_smul_range {ι κ : Type*} [has_scalar α β] (b : ι → α) (c : κ → β) :
  range b • range c = range (λ p : ι × κ, b p.1 • c p.2) :=
ext $ λ x, ⟨λ hx, let ⟨p, q, ⟨i, hi⟩, ⟨j, hj⟩, hpq⟩ := set.mem_smul.1 hx in
  ⟨(i, j), hpq ▸ hi ▸ hj ▸ rfl⟩,
λ ⟨⟨i, j⟩, h⟩, set.mem_smul.2 ⟨b i, c j, ⟨i, rfl⟩, ⟨j, rfl⟩, h⟩⟩

@[to_additive]
instance smul_comm_class_set [has_scalar α γ] [has_scalar β γ] [smul_comm_class α β γ] :
  smul_comm_class α (set β) (set γ) :=
{ smul_comm := λ a T T',
    by simp only [←image2_smul, ←image_smul, image2_image_right, image_image2, smul_comm] }

@[to_additive]
instance smul_comm_class_set' [has_scalar α γ] [has_scalar β γ] [smul_comm_class α β γ] :
  smul_comm_class (set α) β (set γ) :=
by haveI := smul_comm_class.symm α β γ; exact smul_comm_class.symm _ _ _

@[to_additive]
instance smul_comm_class [has_scalar α γ] [has_scalar β γ] [smul_comm_class α β γ] :
  smul_comm_class (set α) (set β) (set γ) :=
{ smul_comm := λ T T' T'', begin
    simp only [←image2_smul, image2_swap _ T],
    exact image2_assoc (λ b c a, smul_comm a b c),
  end }

instance is_scalar_tower [has_scalar α β] [has_scalar α γ] [has_scalar β γ]
  [is_scalar_tower α β γ] :
  is_scalar_tower α β (set γ) :=
{ smul_assoc := λ a b T, by simp only [←image_smul, image_image, smul_assoc] }

instance is_scalar_tower' [has_scalar α β] [has_scalar α γ] [has_scalar β γ]
  [is_scalar_tower α β γ] :
  is_scalar_tower α (set β) (set γ) :=
{ smul_assoc := λ a T T',
    by simp only [←image_smul, ←image2_smul, image_image2, image2_image_left, smul_assoc] }

instance is_scalar_tower'' [has_scalar α β] [has_scalar α γ] [has_scalar β γ]
  [is_scalar_tower α β γ] :
  is_scalar_tower (set α) (set β) (set γ) :=
{ smul_assoc := λ T T' T'', image2_assoc smul_assoc }

instance is_central_scalar [has_scalar α β] [has_scalar αᵐᵒᵖ β] [is_central_scalar α β] :
  is_central_scalar α (set β) :=
⟨λ a S, congr_arg (λ f, f '' S) $ by exact funext (λ _, op_smul_eq_smul _ _)⟩

end smul

section vsub
variables {ι : Sort*} {κ : ι → Sort*} [has_vsub α β] {s s₁ s₂ t t₁ t₂ : set β} {a : α}
  {b c : β}
include α

instance has_vsub : has_vsub (set α) (set β) := ⟨image2 (-ᵥ)⟩

@[simp] lemma image2_vsub : (image2 has_vsub.vsub s t : set α) = s -ᵥ t := rfl

lemma image_vsub_prod : (λ x : β × β, x.fst -ᵥ x.snd) '' (s ×ˢ t) = s -ᵥ t := image_prod _

lemma mem_vsub : a ∈ s -ᵥ t ↔ ∃ x y, x ∈ s ∧ y ∈ t ∧ x -ᵥ y = a := iff.rfl

lemma vsub_mem_vsub (hb : b ∈ s) (hc : c ∈ t) : b -ᵥ c ∈ s -ᵥ t := mem_image2_of_mem hb hc

lemma vsub_subset_vsub (hs : s₁ ⊆ s₂) (ht : t₁ ⊆ t₂) : s₁ -ᵥ t₁ ⊆ s₂ -ᵥ t₂ := image2_subset hs ht

lemma vsub_subset_iff {u : set α} : s -ᵥ t ⊆ u ↔ ∀ (x ∈ s) (y ∈ t), x -ᵥ y ∈ u := image2_subset_iff

@[simp] lemma empty_vsub (t : set β) : ∅ -ᵥ t = ∅ := image2_empty_left
@[simp] lemma vsub_empty (s : set β) : s -ᵥ ∅ = ∅ := image2_empty_right

@[simp] lemma vsub_singleton (s : set β) (b : β) : s -ᵥ {b} = (-ᵥ b) '' s := image2_singleton_right
@[simp] lemma singleton_vsub (t : set β) (b : β) : {b} -ᵥ t = ((-ᵥ) b) '' t := image2_singleton_left

@[simp] lemma singleton_vsub_singleton : ({b} : set β) -ᵥ {c} = {b -ᵥ c} := image2_singleton

lemma vsub_subset_vsub_left (h : t₁ ⊆ t₂) : s -ᵥ t₁ ⊆ s -ᵥ t₂ := image2_subset_left h
lemma vsub_subset_vsub_right (h : s₁ ⊆ s₂) : s₁ -ᵥ t ⊆ s₂ -ᵥ t := image2_subset_right h

lemma union_vsub : (s₁ ∪ s₂) -ᵥ t = s₁ -ᵥ t ∪ (s₂ -ᵥ t) := image2_union_left
lemma vsub_union : s -ᵥ (t₁ ∪ t₂) = s -ᵥ t₁ ∪ (s -ᵥ t₂) := image2_union_right

lemma inter_vsub_subset : s₁ ∩ s₂ -ᵥ t ⊆ (s₁ -ᵥ t) ∩ (s₂ -ᵥ t) := image2_inter_subset_left
lemma vsub_inter_subset : s -ᵥ t₁ ∩ t₂ ⊆ (s -ᵥ t₁) ∩ (s -ᵥ t₂) := image2_inter_subset_right

lemma Union_vsub_left_image : (⋃ a ∈ s, ((-ᵥ) a) '' t) = s -ᵥ t := Union_image_left _
lemma Union_vsub_right_image : (⋃ a ∈ t, (-ᵥ a) '' s) = s -ᵥ t := Union_image_right _

lemma Union_vsub (s : ι → set β) (t : set β) : (⋃ i, s i) -ᵥ t = ⋃ i, s i -ᵥ t :=
image2_Union_left _ _ _

lemma vsub_Union (s : set β) (t : ι → set β) : s -ᵥ (⋃ i, t i) = ⋃ i, s -ᵥ t i :=
image2_Union_right _ _ _

lemma Union₂_vsub (s : Π i, κ i → set β) (t : set β) : (⋃ i j, s i j) -ᵥ t = ⋃ i j, s i j -ᵥ t :=
image2_Union₂_left _ _ _

lemma vsub_Union₂ (s : set β) (t : Π i, κ i → set β) : s -ᵥ (⋃ i j, t i j) = ⋃ i j, s -ᵥ t i j :=
image2_Union₂_right _ _ _

lemma Inter_vsub_subset (s : ι → set β) (t : set β) : (⋂ i, s i) -ᵥ t ⊆ ⋂ i, s i -ᵥ t :=
image2_Inter_subset_left _ _ _

lemma vsub_Inter_subset (s : set β) (t : ι → set β) : s -ᵥ (⋂ i, t i) ⊆ ⋂ i, s -ᵥ t i :=
image2_Inter_subset_right _ _ _

lemma Inter₂_vsub_subset (s : Π i, κ i → set β) (t : set β) :
  (⋂ i j, s i j) -ᵥ t ⊆ ⋂ i j, s i j -ᵥ t :=
image2_Inter₂_subset_left _ _ _

lemma vsub_Inter₂_subset (s : set β) (t : Π i, κ i → set β) :
  s -ᵥ (⋂ i j, t i j) ⊆ ⋂ i j, s -ᵥ t i j :=
image2_Inter₂_subset_right _ _ _

lemma finite.vsub (hs : finite s) (ht : finite t) : finite (s -ᵥ t) := hs.image2 _ ht

lemma vsub_self_mono (h : s ⊆ t) : s -ᵥ s ⊆ t -ᵥ t := vsub_subset_vsub h h

end vsub

open_locale pointwise

section ring
variables [ring α] [add_comm_group β] [module α β] {s : set α} {t : set β} {a : α}

@[simp] lemma neg_smul_set : -a • t = -(a • t) :=
by simp_rw [←image_smul, ←image_neg, image_image, neg_smul]

@[simp] lemma smul_set_neg : a • -t = -(a • t) :=
by simp_rw [←image_smul, ←image_neg, image_image, smul_neg]

@[simp] protected lemma neg_smul : -s • t = -(s • t) :=
by simp_rw [←image2_smul, ←image_neg, image2_image_left, image_image2, neg_smul]

@[simp] protected lemma smul_neg : s • -t = -(s • t) :=
by simp_rw [←image2_smul, ←image_neg, image2_image_right, image_image2, smul_neg]

end ring

section monoid

/-! ### `set α` as a `(∪,*)`-semiring -/

/-- An alias for `set α`, which has a semiring structure given by `∪` as "addition" and pointwise
  multiplication `*` as "multiplication". -/
@[derive [inhabited, partial_order, order_bot]] def set_semiring (α : Type*) : Type* := set α

/-- The identitiy function `set α → set_semiring α`. -/
protected def up (s : set α) : set_semiring α := s
/-- The identitiy function `set_semiring α → set α`. -/
protected def set_semiring.down (s : set_semiring α) : set α := s
@[simp] protected lemma down_up {s : set α} : s.up.down = s := rfl
@[simp] protected lemma up_down {s : set_semiring α} : s.down.up = s := rfl

/- This lemma is not tagged `simp`, since otherwise the linter complains. -/
lemma up_le_up {s t : set α} : s.up ≤ t.up ↔ s ⊆ t := iff.rfl
/- This lemma is not tagged `simp`, since otherwise the linter complains. -/
lemma up_lt_up {s t : set α} : s.up < t.up ↔ s ⊂ t := iff.rfl

@[simp] lemma down_subset_down {s t : set_semiring α} : s.down ⊆ t.down ↔ s ≤ t := iff.rfl
@[simp] lemma down_ssubset_down {s t : set_semiring α} : s.down ⊂ t.down ↔ s < t := iff.rfl

instance set_semiring.add_comm_monoid : add_comm_monoid (set_semiring α) :=
{ add := λ s t, (s ∪ t : set α),
  zero := (∅ : set α),
  add_assoc := union_assoc,
  zero_add := empty_union,
  add_zero := union_empty,
  add_comm := union_comm, }

instance set_semiring.non_unital_non_assoc_semiring [has_mul α] :
  non_unital_non_assoc_semiring (set_semiring α) :=
{ zero_mul := λ s, empty_mul,
  mul_zero := λ s, mul_empty,
  left_distrib := λ _ _ _, mul_union,
  right_distrib := λ _ _ _, union_mul,
  ..set.has_mul, ..set_semiring.add_comm_monoid }

instance set_semiring.non_assoc_semiring [mul_one_class α] : non_assoc_semiring (set_semiring α) :=
{ ..set_semiring.non_unital_non_assoc_semiring, ..set.mul_one_class }

instance set_semiring.non_unital_semiring [semigroup α] : non_unital_semiring (set_semiring α) :=
{ ..set_semiring.non_unital_non_assoc_semiring, ..set.semigroup }

instance set_semiring.semiring [monoid α] : semiring (set_semiring α) :=
{ ..set_semiring.non_assoc_semiring, ..set_semiring.non_unital_semiring }

instance set_semiring.comm_semiring [comm_monoid α] : comm_semiring (set_semiring α) :=
{ ..set.comm_monoid, ..set_semiring.semiring }

/-- A multiplicative action of a monoid on a type β gives also a
 multiplicative action on the subsets of β. -/
@[to_additive "An additive action of an additive monoid on a type β gives also an additive action
on the subsets of β."]
protected def mul_action_set [monoid α] [mul_action α β] : mul_action α (set β) :=
{ mul_smul := by { intros, simp only [← image_smul, image_image, ← mul_smul] },
  one_smul := by { intros, simp only [← image_smul, image_eta, one_smul, image_id'] },
  ..set.has_scalar_set }

localized "attribute [instance] set.mul_action_set set.add_action_set" in pointwise

section mul_hom

variables [has_mul α] [has_mul β] (m : mul_hom α β) {s t : set α}

@[to_additive]
lemma image_mul : m '' (s * t) = m '' s * m '' t :=
by { simp only [← image2_mul, image_image2, image2_image_left, image2_image_right, m.map_mul] }

@[to_additive]
lemma preimage_mul_preimage_subset {s t : set β} : m ⁻¹' s * m ⁻¹' t ⊆ m ⁻¹' (s * t) :=
by { rintros _ ⟨_, _, _, _, rfl⟩, exact ⟨_, _, ‹_›, ‹_›, (m.map_mul _ _).symm ⟩ }

instance set_semiring.no_zero_divisors : no_zero_divisors (set_semiring α) :=
⟨λ a b ab, a.eq_empty_or_nonempty.imp_right $ λ ha, b.eq_empty_or_nonempty.resolve_right $
  λ hb, nonempty.ne_empty ⟨_, mul_mem_mul ha.some_mem hb.some_mem⟩ ab⟩

/- Since addition on `set_semiring` is commutative (it is set union), there is no need
to also have the instance `covariant_class (set_semiring α) (set_semiring α) (swap (+)) (≤)`. -/
instance set_semiring.covariant_class_add :
  covariant_class (set_semiring α) (set_semiring α) (+) (≤) :=
{ elim := λ a b c, union_subset_union_right _ }

instance set_semiring.covariant_class_mul_left :
  covariant_class (set_semiring α) (set_semiring α) (*) (≤) :=
{ elim := λ a b c, mul_subset_mul_left }

instance set_semiring.covariant_class_mul_right :
  covariant_class (set_semiring α) (set_semiring α) (swap (*)) (≤) :=
{ elim := λ a b c, mul_subset_mul_right }

end mul_hom

/-- The image of a set under a multiplicative homomorphism is a ring homomorphism
with respect to the pointwise operations on sets. -/
def image_hom [monoid α] [monoid β] (f : α →* β) : set_semiring α →+* set_semiring β :=
{ to_fun := image f,
  map_zero' := image_empty _,
  map_one' := by simp only [← singleton_one, image_singleton, f.map_one],
  map_add' := image_union _,
  map_mul' := λ _ _, image_mul f.to_mul_hom }

end monoid

section comm_monoid

variable [comm_monoid α]

instance : canonically_ordered_comm_semiring (set_semiring α) :=
{ add_le_add_left := λ a b, add_le_add_left,
  le_iff_exists_add := λ a b, ⟨λ ab, ⟨b, (union_eq_right_iff_subset.2 ab).symm⟩,
    by { rintro ⟨c, rfl⟩, exact subset_union_left _ _ }⟩,
  ..(infer_instance : comm_semiring (set_semiring α)),
  ..(infer_instance : partial_order (set_semiring α)),
  ..(infer_instance : order_bot (set_semiring α)),
  ..(infer_instance : no_zero_divisors (set_semiring α)) }

end comm_monoid

end set

open set
open_locale pointwise

section

section smul_with_zero
variables [has_zero α] [has_zero β] [smul_with_zero α β]

/-- A nonempty set is scaled by zero to the singleton set containing 0. -/
lemma zero_smul_set {s : set β} (h : s.nonempty) : (0 : α) • s = (0 : set β) :=
by simp only [← image_smul, image_eta, zero_smul, h.image_const, singleton_zero]

lemma zero_smul_subset (s : set β) : (0 : α) • s ⊆ 0 := image_subset_iff.2 $ λ x _, zero_smul α x

lemma subsingleton_zero_smul_set (s : set β) : ((0 : α) • s).subsingleton :=
subsingleton_singleton.mono (zero_smul_subset s)

lemma zero_mem_smul_set {t : set β} {a : α} (h : (0 : β) ∈ t) : (0 : β) ∈ a • t :=
⟨0, h, smul_zero' _ _⟩

variables [no_zero_smul_divisors α β] {s : set α} {t : set β} {a : α}

lemma zero_mem_smul_iff : (0 : β) ∈ s • t ↔ (0 : α) ∈ s ∧ t.nonempty ∨ (0 : β) ∈ t ∧ s.nonempty :=
begin
  split,
  { rintro ⟨a, b, ha, hb, h⟩,
    obtain rfl | rfl := eq_zero_or_eq_zero_of_smul_eq_zero h,
    { exact or.inl ⟨ha, b, hb⟩ },
    { exact or.inr ⟨hb, a, ha⟩ } },
  { rintro (⟨hs, b, hb⟩ | ⟨ht, a, ha⟩),
    { exact ⟨0, b, hs, hb, zero_smul _ _⟩ },
    { exact ⟨a, 0, ha, ht, smul_zero' _ _⟩ } }
end

lemma zero_mem_smul_set_iff (ha : a ≠ 0) : (0 : β) ∈ a • t ↔ (0 : β) ∈ t :=
begin
  refine ⟨_, zero_mem_smul_set⟩,
  rintro ⟨b, hb, h⟩,
  rwa (eq_zero_or_eq_zero_of_smul_eq_zero h).resolve_left ha at hb,
end

end smul_with_zero

lemma smul_add_set [monoid α] [add_monoid β] [distrib_mul_action α β] (c : α) (s t : set β) :
  c • (s + t) = c • s + c • t :=
image_add (distrib_mul_action.to_add_monoid_hom β c).to_add_hom

section group
variables [group α] [mul_action α β] {A B : set β} {a : α} {x : β}

@[simp, to_additive]
lemma smul_mem_smul_set_iff : a • x ∈ a • A ↔ x ∈ A :=
⟨λ h, begin
  rw [←inv_smul_smul a x, ←inv_smul_smul a A],
  exact smul_mem_smul_set h,
end, smul_mem_smul_set⟩

@[to_additive]
lemma mem_smul_set_iff_inv_smul_mem : x ∈ a • A ↔ a⁻¹ • x ∈ A :=
show x ∈ mul_action.to_perm a '' A ↔ _, from mem_image_equiv

@[to_additive]
lemma mem_inv_smul_set_iff : x ∈ a⁻¹ • A ↔ a • x ∈ A :=
by simp only [← image_smul, mem_image, inv_smul_eq_iff, exists_eq_right]

@[to_additive]
lemma preimage_smul (a : α) (t : set β) : (λ x, a • x) ⁻¹' t = a⁻¹ • t :=
((mul_action.to_perm a).symm.image_eq_preimage _).symm

@[to_additive]
lemma preimage_smul_inv (a : α) (t : set β) : (λ x, a⁻¹ • x) ⁻¹' t = a • t :=
preimage_smul (to_units a)⁻¹ t

@[simp, to_additive]
lemma set_smul_subset_set_smul_iff : a • A ⊆ a • B ↔ A ⊆ B :=
image_subset_image_iff $ mul_action.injective _

@[to_additive]
lemma set_smul_subset_iff : a • A ⊆ B ↔ A ⊆ a⁻¹ • B :=
(image_subset_iff).trans $ iff_of_eq $ congr_arg _ $
  preimage_equiv_eq_image_symm _ $ mul_action.to_perm _

@[to_additive]
lemma subset_set_smul_iff : A ⊆ a • B ↔ a⁻¹ • A ⊆ B :=
iff.symm $ (image_subset_iff).trans $ iff.symm $ iff_of_eq $ congr_arg _ $
  image_equiv_eq_preimage_symm _ $ mul_action.to_perm _

end group

section group_with_zero
variables [group_with_zero α] [mul_action α β] {s : set α} {a : α}

@[simp] lemma smul_mem_smul_set_iff₀ (ha : a ≠ 0) (A : set β)
  (x : β) : a • x ∈ a • A ↔ x ∈ A :=
show units.mk0 a ha • _ ∈ _ ↔ _, from smul_mem_smul_set_iff

lemma mem_smul_set_iff_inv_smul_mem₀ (ha : a ≠ 0) (A : set β) (x : β) :
  x ∈ a • A ↔ a⁻¹ • x ∈ A :=
show _ ∈ units.mk0 a ha • _ ↔ _, from mem_smul_set_iff_inv_smul_mem

lemma mem_inv_smul_set_iff₀ (ha : a ≠ 0) (A : set β) (x : β) : x ∈ a⁻¹ • A ↔ a • x ∈ A :=
show _ ∈ (units.mk0 a ha)⁻¹ • _ ↔ _, from mem_inv_smul_set_iff

lemma preimage_smul₀ (ha : a ≠ 0) (t : set β) : (λ x, a • x) ⁻¹' t = a⁻¹ • t :=
preimage_smul (units.mk0 a ha) t

lemma preimage_smul_inv₀ (ha : a ≠ 0) (t : set β) :
  (λ x, a⁻¹ • x) ⁻¹' t = a • t :=
preimage_smul ((units.mk0 a ha)⁻¹) t

@[simp] lemma set_smul_subset_set_smul_iff₀ (ha : a ≠ 0) {A B : set β} :
  a • A ⊆ a • B ↔ A ⊆ B :=
show units.mk0 a ha • _ ⊆ _ ↔ _, from set_smul_subset_set_smul_iff

lemma set_smul_subset_iff₀ (ha : a ≠ 0) {A B : set β} : a • A ⊆ B ↔ A ⊆ a⁻¹ • B :=
show units.mk0 a ha • _ ⊆ _ ↔ _, from set_smul_subset_iff

lemma subset_set_smul_iff₀ (ha : a ≠ 0) {A B : set β} : A ⊆ a • B ↔ a⁻¹ • A ⊆ B :=
show _ ⊆ units.mk0 a ha • _ ↔ _, from subset_set_smul_iff

lemma smul_univ₀ (hs : ¬ s ⊆ 0) : s • (univ : set β) = univ :=
let ⟨a, ha, ha₀⟩ := not_subset.1 hs in eq_univ_of_forall $ λ b,
  ⟨a, a⁻¹ • b, ha, trivial, smul_inv_smul₀ ha₀ _⟩

lemma smul_set_univ₀ (ha : a ≠ 0) : a • (univ : set β) = univ :=
eq_univ_of_forall $ λ b, ⟨a⁻¹ • b, trivial, smul_inv_smul₀ ha _⟩

end group_with_zero

end

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

/-- The finset `(1 : finset α)` is defined as `{1}` in locale `pointwise`. -/
@[to_additive /-"The finset `(0 : finset α)` is defined as `{0}` in locale `pointwise`. "-/]
protected def has_one [has_one α] : has_one (finset α) := ⟨{1}⟩

localized "attribute [instance] finset.has_one finset.has_zero" in pointwise

@[simp, to_additive]
lemma mem_one [has_one α] : a ∈ (1 : finset α) ↔ a = 1 :=
by simp [has_one.one]

@[simp, to_additive]
theorem one_subset [has_one α] : (1 : finset α) ⊆ s ↔ (1 : α) ∈ s := singleton_subset_iff

section decidable_eq
variables [decidable_eq α]

/-- The pointwise product of two finite sets `s` and `t`:
`st = s ⬝ t = s * t = { x * y | x ∈ s, y ∈ t }`. -/
@[to_additive /-"The pointwise sum of two finite sets `s` and `t`:
`s + t = { x + y | x ∈ s, y ∈ t }`. "-/]
protected def has_mul [has_mul α] : has_mul (finset α) :=
⟨λ s t, (s.product t).image (λ p : α × α, p.1 * p.2)⟩

localized "attribute [instance] finset.has_mul finset.has_add" in pointwise

section has_mul
variables [has_mul α]

@[to_additive]
lemma mul_def : s * t = (s.product t).image (λ p : α × α, p.1 * p.2) := rfl

@[to_additive]
lemma mem_mul {x : α} : x ∈ s * t ↔ ∃ y z, y ∈ s ∧ z ∈ t ∧ y * z = x :=
by { simp only [finset.mul_def, and.assoc, mem_image, exists_prop, prod.exists, mem_product] }

@[simp, norm_cast, to_additive]
lemma coe_mul : (↑(s * t) : set α) = ↑s * ↑t :=
by { ext, simp only [mem_mul, set.mem_mul, mem_coe] }

@[to_additive]
lemma mul_mem_mul {x y : α} (hx : x ∈ s) (hy : y ∈ t) : x * y ∈ s * t :=
by { simp only [finset.mem_mul], exact ⟨x, y, hx, hy, rfl⟩ }

@[to_additive]
lemma mul_card_le : (s * t).card ≤ s.card * t.card :=
by { convert finset.card_image_le, rw [finset.card_product, mul_comm] }

@[simp, to_additive] lemma empty_mul (s : finset α) : ∅ * s = ∅ :=
eq_empty_of_forall_not_mem (by simp [mem_mul])

@[simp, to_additive] lemma mul_empty (s : finset α) : s * ∅ = ∅ :=
eq_empty_of_forall_not_mem (by simp [mem_mul])

@[simp, to_additive]
lemma mul_nonempty_iff (s t : finset α) : (s * t).nonempty ↔ s.nonempty ∧ t.nonempty :=
by simp [finset.mul_def]

@[to_additive, mono] lemma mul_subset_mul  (hs : s₁ ⊆ s₂) (ht : t₁ ⊆ t₂) : s₁ * t₁ ⊆ s₂ * t₂ :=
image_subset_image (product_subset_product hs ht)

attribute [mono] add_subset_add

@[simp, to_additive]
lemma mul_singleton (a : α) : s * {a} = s.image (* a) :=
by { rw [mul_def, product_singleton, map_eq_image, image_image], refl }

@[simp, to_additive]
lemma singleton_mul (a : α) : {a} * s = s.image ((*) a) :=
by { rw [mul_def, singleton_product, map_eq_image, image_image], refl }

@[simp, to_additive]
lemma singleton_mul_singleton (a b : α) : ({a} : finset α) * {b} = {a * b} :=
by rw [mul_def, singleton_product_singleton, image_singleton]

end has_mul

section mul_zero_class
variables [mul_zero_class α]

lemma mul_zero_subset (s : finset α) : s * 0 ⊆ 0 := by simp [subset_iff, mem_mul]

lemma zero_mul_subset (s : finset α) : 0 * s ⊆ 0 := by simp [subset_iff, mem_mul]

lemma nonempty.mul_zero (hs : s.nonempty) : s * 0 = 0 :=
s.mul_zero_subset.antisymm $ by simpa [finset.mem_mul] using hs

lemma nonempty.zero_mul (hs : s.nonempty) : 0 * s = 0 :=
s.zero_mul_subset.antisymm $ by simpa [finset.mem_mul] using hs

lemma singleton_zero_mul (s : finset α) :
  {(0 : α)} * s ⊆ {0} :=
by simp [subset_iff, mem_mul]

end mul_zero_class
end decidable_eq

open_locale pointwise
variables {u : finset α} {b : α} {x y : β}

@[to_additive]
lemma singleton_one [has_one α] : ({1} : finset α) = 1 := rfl

@[to_additive]
lemma one_mem_one [has_one α] : (1 : α) ∈ (1 : finset α) := by simp [has_one.one]

@[to_additive]
theorem one_nonempty [has_one α] : (1 : finset α).nonempty := ⟨1, one_mem_one⟩

@[simp, to_additive]
theorem image_one [decidable_eq β] [has_one α] {f : α → β} : image f 1 = {f 1} :=
image_singleton f 1

@[to_additive add_image_prod]
lemma image_mul_prod [decidable_eq α] [has_mul α] :
  image (λ x : α × α, x.fst * x.snd) (s.product t) = s * t := rfl

@[simp, to_additive]
lemma image_mul_left [decidable_eq α] [group α] :
  image (λ b, a * b) t = preimage t (λ b, a⁻¹ * b) (assume x hx y hy, (mul_right_inj a⁻¹).mp) :=
coe_injective $ by simp

@[simp, to_additive]
lemma image_mul_right [decidable_eq α] [group α] :
  image (* b) t = preimage t (* b⁻¹) (assume x hx y hy, (mul_left_inj b⁻¹).mp) :=
coe_injective $ by simp

@[to_additive]
lemma image_mul_left' [decidable_eq α] [group α] :
  image (λ b, a⁻¹ * b) t = preimage t (λ b, a * b) (assume x hx y hy, (mul_right_inj a).mp) :=
by simp

@[to_additive]
lemma image_mul_right' [decidable_eq α] [group α] :
  image (* b⁻¹) t = preimage t (* b) (assume x hx y hy, (mul_left_inj b).mp) :=
by simp

@[simp, to_additive]
lemma preimage_mul_left_singleton [group α] :
  preimage {b} ((*) a) (assume x hx y hy, (mul_right_inj a).mp) = {a⁻¹ * b} :=
by { classical, rw [← image_mul_left', image_singleton] }

@[simp, to_additive]
lemma preimage_mul_right_singleton [group α] :
  preimage {b} (* a) (assume x hx y hy, (mul_left_inj a).mp) = {b * a⁻¹} :=
by { classical, rw [← image_mul_right', image_singleton] }

@[simp, to_additive]
lemma preimage_mul_left_one [group α] :
  preimage 1 (λ b, a * b) (assume x hx y hy, (mul_right_inj a).mp) = {a⁻¹} :=
by {classical, rw [← image_mul_left', image_one, mul_one] }

@[simp, to_additive]
lemma preimage_mul_right_one [group α] :
  preimage 1 (* b) (assume x hx y hy, (mul_left_inj b).mp) = {b⁻¹} :=
by {classical, rw [← image_mul_right', image_one, one_mul] }

@[to_additive]
lemma preimage_mul_left_one' [group α] :
  preimage 1 (λ b, a⁻¹ * b) (assume x hx y hy, (mul_right_inj _).mp) = {a} := by simp

@[to_additive]
lemma preimage_mul_right_one' [group α] :
  preimage 1 (* b⁻¹) (assume x hx y hy, (mul_left_inj _).mp) = {b} := by simp

@[to_additive]
protected lemma mul_comm [decidable_eq α] [comm_semigroup α] : s * t = t * s :=
by exact_mod_cast @set.mul_comm _ (s : set α) t _

/-- `finset α` is a `mul_one_class` under pointwise operations if `α` is. -/
@[to_additive /-"`finset α` is an `add_zero_class` under pointwise operations if `α` is."-/]
protected def mul_one_class [decidable_eq α] [mul_one_class α] : mul_one_class (finset α) :=
function.injective.mul_one_class _ coe_injective (coe_singleton 1) (by simp)

/-- `finset α` is a `semigroup` under pointwise operations if `α` is. -/
@[to_additive /-"`finset α` is an `add_semigroup` under pointwise operations if `α` is. "-/]
protected def semigroup [decidable_eq α] [semigroup α] : semigroup (finset α) :=
function.injective.semigroup _ coe_injective (by simp)

/-- `finset α` is a `monoid` under pointwise operations if `α` is. -/
@[to_additive /-"`finset α` is an `add_monoid` under pointwise operations if `α` is. "-/]
protected def monoid [decidable_eq α] [monoid α] : monoid (finset α) :=
function.injective.monoid _ coe_injective (coe_singleton 1) (by simp)

/-- `finset α` is a `comm_monoid` under pointwise operations if `α` is. -/
@[to_additive /-"`finset α` is an `add_comm_monoid` under pointwise operations if `α` is. "-/]
protected def comm_monoid [decidable_eq α] [comm_monoid α] : comm_monoid (finset α) :=
function.injective.comm_monoid _ coe_injective (coe_singleton 1) (by simp)

localized "attribute [instance] finset.mul_one_class finset.add_zero_class finset.semigroup
  finset.add_semigroup finset.monoid finset.add_monoid finset.comm_monoid finset.add_comm_monoid"
  in pointwise

open_locale classical

/-- A finite set `U` contained in the product of two sets `S * S'` is also contained in the product
of two finite sets `T * T' ⊆ S * S'`. -/
@[to_additive]
lemma subset_mul {M : Type*} [monoid M] {S : set M} {S' : set M} {U : finset M} (f : ↑U ⊆ S * S') :
  ∃ (T T' : finset M), ↑T ⊆ S ∧ ↑T' ⊆ S' ∧ U ⊆ T * T' :=
begin
  apply finset.induction_on' U,
  { use [∅, ∅], simp only [finset.empty_subset, finset.coe_empty, set.empty_subset, and_self], },
  rintros a s haU hs has ⟨T, T', hS, hS', h⟩,
  obtain ⟨x, y, hx, hy, ha⟩ := set.mem_mul.1 (f haU),
  use [insert x T, insert y T'],
  simp only [finset.coe_insert],
  repeat { rw [set.insert_subset], },
  use [hx, hS, hy, hS'],
  refine finset.insert_subset.mpr ⟨_, _⟩,
  { rw finset.mem_mul,
    use [x,y],
    simpa only [true_and, true_or, eq_self_iff_true, finset.mem_insert], },
  { suffices g : (s : set M) ⊆ insert x T * insert y T', { norm_cast at g, assumption, },
    transitivity ↑(T * T'),
    apply h,
    rw finset.coe_mul,
    apply set.mul_subset_mul (set.subset_insert x T) (set.subset_insert y T'), },
end

end finset

/-! Some lemmas about pointwise multiplication and submonoids. Ideally we put these in
  `group_theory.submonoid.basic`, but currently we cannot because that file is imported by this. -/
namespace submonoid

variables {M : Type*} [monoid M] {s t u : set M}

@[to_additive]
lemma mul_subset {S : submonoid M} (hs : s ⊆ S) (ht : t ⊆ S) : s * t ⊆ S :=
by { rintro _ ⟨p, q, hp, hq, rfl⟩, exact submonoid.mul_mem _ (hs hp) (ht hq) }

@[to_additive]
lemma mul_subset_closure (hs : s ⊆ u) (ht : t ⊆ u) : s * t ⊆ submonoid.closure u :=
mul_subset (subset.trans hs submonoid.subset_closure) (subset.trans ht submonoid.subset_closure)

@[to_additive]
lemma coe_mul_self_eq (s : submonoid M) : (s : set M) * s = s :=
begin
  ext x,
  refine ⟨_, λ h, ⟨x, 1, h, s.one_mem, mul_one x⟩⟩,
  rintros ⟨a, b, ha, hb, rfl⟩,
  exact s.mul_mem ha hb
end

@[to_additive]
lemma closure_mul_le (S T : set M) : closure (S * T) ≤ closure S ⊔ closure T :=
Inf_le $ λ x ⟨s, t, hs, ht, hx⟩, hx ▸ (closure S ⊔ closure T).mul_mem
    (set_like.le_def.mp le_sup_left $ subset_closure hs)
    (set_like.le_def.mp le_sup_right $ subset_closure ht)

@[to_additive]
lemma sup_eq_closure (H K : submonoid M) : H ⊔ K = closure (H * K) :=
le_antisymm
  (sup_le
    (λ h hh, subset_closure ⟨h, 1, hh, K.one_mem, mul_one h⟩)
    (λ k hk, subset_closure ⟨1, k, H.one_mem, hk, one_mul k⟩))
  (by conv_rhs { rw [← closure_eq H, ← closure_eq K] }; apply closure_mul_le)

lemma pow_smul_mem_closure_smul {N : Type*} [comm_monoid N] [mul_action M N]
  [is_scalar_tower M N N] (r : M) (s : set N) {x : N} (hx : x ∈ closure s) :
  ∃ n : ℕ, r ^ n • x ∈ closure (r • s) :=
begin
  apply @closure_induction N _ s
    (λ (x : N), ∃ n : ℕ, r ^ n • x ∈ closure (r • s)) _ hx,
  { intros x hx,
    exact ⟨1, subset_closure ⟨_, hx, by rw pow_one⟩⟩ },
  { exact ⟨0, by simpa using one_mem _⟩ },
  { rintros x y ⟨nx, hx⟩ ⟨ny, hy⟩,
    use nx + ny,
    convert mul_mem _ hx hy,
    rw [pow_add, smul_mul_assoc, mul_smul, mul_comm, ← smul_mul_assoc, mul_comm] }
end

end submonoid

namespace group

lemma card_pow_eq_card_pow_card_univ_aux {f : ℕ → ℕ} (h1 : monotone f)
  {B : ℕ} (h2 : ∀ n, f n ≤ B) (h3 : ∀ n, f n = f (n + 1) → f (n + 1) = f (n + 2)) :
  ∀ k, B ≤ k → f k = f B :=
begin
  have key : ∃ n : ℕ, n ≤ B ∧ f n = f (n + 1),
  { contrapose! h2,
    suffices : ∀ n : ℕ, n ≤ B + 1 → n ≤ f n,
    { exact ⟨B + 1, this (B + 1) (le_refl (B + 1))⟩ },
    exact λ n, nat.rec (λ h, nat.zero_le (f 0)) (λ n ih h, lt_of_le_of_lt (ih (n.le_succ.trans h))
      (lt_of_le_of_ne (h1 n.le_succ) (h2 n (nat.succ_le_succ_iff.mp h)))) n },
  { obtain ⟨n, hn1, hn2⟩ := key,
    replace key : ∀ k : ℕ, f (n + k) = f (n + k + 1) ∧ f (n + k) = f n :=
    λ k, nat.rec ⟨hn2, rfl⟩ (λ k ih, ⟨h3 _ ih.1, ih.1.symm.trans ih.2⟩) k,
    replace key : ∀ k : ℕ, n ≤ k → f k = f n :=
    λ k hk, (congr_arg f (add_tsub_cancel_of_le hk)).symm.trans (key (k - n)).2,
    exact λ k hk, (key k (hn1.trans hk)).trans (key B hn1).symm },
end

variables {G : Type*} [group G] [fintype G] (S : set G)

@[to_additive]
lemma card_pow_eq_card_pow_card_univ [∀ (k : ℕ), decidable_pred (∈ (S ^ k))] :
  ∀ k, fintype.card G ≤ k → fintype.card ↥(S ^ k) = fintype.card ↥(S ^ (fintype.card G)) :=
begin
  have hG : 0 < fintype.card G := fintype.card_pos_iff.mpr ⟨1⟩,
  by_cases hS : S = ∅,
  { refine λ k hk, fintype.card_congr _,
    rw [hS, empty_pow _ (ne_of_gt (lt_of_lt_of_le hG hk)), empty_pow _ (ne_of_gt hG)] },
  obtain ⟨a, ha⟩ := set.ne_empty_iff_nonempty.mp hS,
  classical,
  have key : ∀ a (s t : set G), (∀ b : G, b ∈ s → a * b ∈ t) → fintype.card s ≤ fintype.card t,
  { refine λ a s t h, fintype.card_le_of_injective (λ ⟨b, hb⟩, ⟨a * b, h b hb⟩) _,
    rintros ⟨b, hb⟩ ⟨c, hc⟩ hbc,
    exact subtype.ext (mul_left_cancel (subtype.ext_iff.mp hbc)) },
  have mono : monotone (λ n, fintype.card ↥(S ^ n) : ℕ → ℕ) :=
  monotone_nat_of_le_succ (λ n, key a _ _ (λ b hb, set.mul_mem_mul ha hb)),
  convert card_pow_eq_card_pow_card_univ_aux mono (λ n, set_fintype_card_le_univ (S ^ n))
    (λ n h, le_antisymm (mono (n + 1).le_succ) (key a⁻¹ _ _ _)),
  { simp only [finset.filter_congr_decidable, fintype.card_of_finset] },
  replace h : {a} * S ^ n = S ^ (n + 1),
  { refine set.eq_of_subset_of_card_le _ (le_trans (ge_of_eq h) _),
    { exact mul_subset_mul (set.singleton_subset_iff.mpr ha) set.subset.rfl },
    { convert key a (S ^ n) ({a} * S ^ n) (λ b hb, set.mul_mem_mul (set.mem_singleton a) hb) } },
  rw [pow_succ', ←h, mul_assoc, ←pow_succ', h],
  rintros _ ⟨b, c, hb, hc, rfl⟩,
  rwa [set.mem_singleton_iff.mp hb, inv_mul_cancel_left],
end

end group


import tactic

variables {α : Type} {a a₁ a₂ b₁ b₂ : α}

def pair (a b : α) : set (set α) := {{a}, {a, b}}

lemma eq_of_eq_singleton (h : {b₁, b₂} = ({a} : set α)) : b₁ = b₂ :=
begin
  have h₁ := set.ext_iff.mp h b₁,
  have h₂ := set.ext_iff.mp h b₂,
  tidy
end

lemma fst_eq_fst_of_pair_eq_pair (h : pair a₁ b₁ = pair a₂ b₂) : a₁ = a₂ :=
begin
  have : {a₂} ∈ pair a₁ b₁, by simp [pair, h],
  cases this,
  { tidy },
  { suffices : a₁ = b₁, by tidy,
    simp [eq_of_eq_singleton (set.mem_singleton_iff.mp this).symm] }
end

lemma snd_eq_snd_of_pair_eq_pair (h : pair a₁ b₁ = pair a₂ b₂) : b₁ = b₂ :=
begin
  obtain rfl := fst_eq_fst_of_pair_eq_pair h,
  rename a₁ a,
  unfold pair at h,
  have : {a, b₂} ∈ pair a b₁, by simp [pair, h],
  cases this,
  { obtain rfl := eq_of_eq_singleton this,
    rw [set.pair_eq_singleton, set.pair_eq_singleton] at h,
    have h := (@eq_of_eq_singleton (set α) _ _ _ h),
    have h := eq_of_eq_singleton h.symm,
    rw h },
  { simp at this,
    change (λ x, x = a ∨ x = b₂) = (λ x, x = a ∨ x = b₁) at this,
    have h₁ := congr_fun this b₁, simp at h₁,
    have h₂ := congr_fun this b₂, simp at h₂,
    cases h₁; cases h₂; tidy }
end

example : pair a₁ b₁ = pair a₂ 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


namespace exc

theorem and_comm {P Q : Prop} : P ∧ Q → Q ∧ P :=
begin
  assume h : P ∧ Q,
  have hp : P, from h.left,
  have hq : Q, from h.right,
  show Q ∧ P, from and.intro hq hp
end

theorem and_comm_1 {P Q : Prop} : P ∧ Q → Q ∧ P :=
  fun x : P ∧ Q , and.intro x.right x.left

theorem or_comm (P Q : Prop) : P ∨ Q → Q ∨ P :=
begin
  assume h : P ∨ Q,
  cases h with hp hq,
    right, exact hp,
    left, exact hq
end

theorem or_elim_0 (p q r : Prop) : (p ∨ q) → (p → r) → (q → r) → r :=
begin
  assume poq : p ∨ q,
  assume par : p → r,
  assume qar : q → r,
  cases poq with hp hq,
    show r, from par(hp),
    show r, from qar(hq)
end

variable S : Type
variable P : S -> S -> Prop

example : (∃ x : S, ∀ y : S, P x y) -> (∀ x : S, ∃ y : S, P y x) :=
begin
  intro h,
  intro x,
  cases h with x0,
  existsi x0,
  exact (h_h x),
end

theorem contrapostition (R Q : Prop) : (R → Q) → ¬ Q → ¬ R :=
begin
  assume h0,
  assume h1,
  assume h2,
  exact h1(h0(h2))
end

theorem id_S : S → S := fun (x : S), x

theorem transitivity (P Q R : Prop) : (P → Q) → (Q → R) → P → R :=
begin
  assume pq,
  assume qr,
  assume p,
  exact qr (pq p)
end

theorem transitivity_0 (P Q R : Prop) : (P → Q) → (Q → R) → P → R :=
  fun pq : P → Q,
    fun qr : Q → R,
      fun p : P,
        qr (pq p)

variable R : Prop
variable r : R
variable Q : Prop
variable q : Q
example : R ∨ Q := or.inl r
example : R ∨ Q := or.inr q

example (P Q : Prop) : (P ∧ Q) → (P ∨ Q) :=
  fun pq : P ∧ Q,
    or.inl pq.left

example (P Q : Prop) : (P ∧ Q) → (P ∨ Q) :=
  fun pq : P ∧ Q,
    or.inr pq.right

end exc


/-
Copyright (c) 2021 Jakob Scholbach. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jakob Scholbach
-/
import algebra.algebra.basic
import algebra.char_p.exp_char
import field_theory.separable

/-!

# Separable degree

This file contains basics about the separable degree of a polynomial.

## Main results

- `is_separable_contraction`: is the condition that, for `g` a separable polynomial, we have that
   `g(x^(q^m)) = f(x)` for some `m : ℕ`.
- `has_separable_contraction`: the condition of having a separable contraction
- `has_separable_contraction.degree`: the separable degree, defined as the degree of some
  separable contraction
- `irreducible.has_separable_contraction`: any irreducible polynomial can be contracted
  to a separable polynomial
- `has_separable_contraction.dvd_degree'`: the degree of a separable contraction divides the degree,
  in function of the exponential characteristic of the field
- `has_separable_contraction.dvd_degree` and `has_separable_contraction.eq_degree` specialize the
  statement of `separable_degree_dvd_degree`
- `is_separable_contraction.degree_eq`: the separable degree is well-defined, implemented as the
  statement that the degree of any separable contraction equals `has_separable_contraction.degree`

## Tags

separable degree, degree, polynomial
-/

namespace polynomial

noncomputable theory
open_locale classical polynomial

section comm_semiring

variables {F : Type*} [comm_semiring F] (q : ℕ)

/-- A separable contraction of a polynomial `f` is a separable polynomial `g` such that
`g(x^(q^m)) = f(x)` for some `m : ℕ`.-/
def is_separable_contraction (f : F[X]) (g : F[X]) : Prop :=
g.separable ∧ ∃ m : ℕ, expand F (q^m) g = f

/-- The condition of having a separable contration. -/
def has_separable_contraction (f : F[X]) : Prop :=
∃ g : F[X], is_separable_contraction q f g

variables {q} {f : F[X]} (hf : has_separable_contraction q f)

/-- A choice of a separable contraction. -/
def has_separable_contraction.contraction : F[X] := classical.some hf

/-- The separable degree of a polynomial is the degree of a given separable contraction. -/
def has_separable_contraction.degree : ℕ := hf.contraction.nat_degree

/-- The separable degree divides the degree, in function of the exponential characteristic of F. -/
lemma is_separable_contraction.dvd_degree' {g} (hf : is_separable_contraction q f g) :
  ∃ m : ℕ, g.nat_degree * (q ^ m) = f.nat_degree :=
begin
  obtain ⟨m, rfl⟩ := hf.2,
  use m,
  rw nat_degree_expand,
end

lemma has_separable_contraction.dvd_degree' : ∃ m : ℕ, hf.degree * (q ^ m) = f.nat_degree :=
(classical.some_spec hf).dvd_degree'

/-- The separable degree divides the degree. -/
lemma has_separable_contraction.dvd_degree :
  hf.degree ∣ f.nat_degree :=
let ⟨a, ha⟩ := hf.dvd_degree' in dvd.intro (q ^ a) ha

/-- In exponential characteristic one, the separable degree equals the degree. -/
lemma has_separable_contraction.eq_degree {f : F[X]}
  (hf : has_separable_contraction 1 f) : hf.degree = f.nat_degree :=
let ⟨a, ha⟩ := hf.dvd_degree' in by rw [←ha, one_pow a, mul_one]

end comm_semiring

section field

variables {F : Type*} [field F]
variables (q : ℕ) {f : F[X]} (hf : has_separable_contraction q f)

/-- Every irreducible polynomial can be contracted to a separable polynomial.
https://stacks.math.columbia.edu/tag/09H0 -/
lemma _root_.irreducible.has_separable_contraction (q : ℕ) [hF : exp_char F q]
  (f : F[X]) (irred : irreducible f) : has_separable_contraction q f :=
begin
  casesI hF,
  { exact ⟨f, irred.separable, ⟨0, by rw [pow_zero, expand_one]⟩⟩ },
  { rcases exists_separable_of_irreducible q irred ‹q.prime›.ne_zero with ⟨n, g, hgs, hge⟩,
    exact ⟨g, hgs, n, hge⟩, }
end

/-- If two expansions (along the positive characteristic) of two separable polynomials `g` and `g'`
agree, then they have the same degree. -/
theorem contraction_degree_eq_or_insep
  [hq : ne_zero q] [char_p F q]
  (g g' : F[X]) (m m' : ℕ)
  (h_expand : expand F (q^m) g = expand F (q^m') g')
  (hg : g.separable) (hg' : g'.separable) :
  g.nat_degree = g'.nat_degree :=
begin
  wlog hm : m ≤ m',
  { exact (this g' g m' m h_expand.symm hg' hg (le_of_not_le hm)).symm },
  obtain ⟨s, rfl⟩ := exists_add_of_le hm,
  rw [pow_add, expand_mul, expand_inj (pow_pos (ne_zero.pos q) m)] at h_expand,
  subst h_expand,
  rcases is_unit_or_eq_zero_of_separable_expand q s (ne_zero.pos q) hg with h | rfl,
  { rw [nat_degree_expand, nat_degree_eq_zero_of_is_unit h, zero_mul] },
  { rw [nat_degree_expand, pow_zero, mul_one] },
end

/-- The separable degree equals the degree of any separable contraction, i.e., it is unique. -/
theorem is_separable_contraction.degree_eq [hF : exp_char F q]
  (g : F[X]) (hg : is_separable_contraction q f g) :
  g.nat_degree = hf.degree :=
begin
  casesI hF,
  { rcases hg with ⟨g, m, hm⟩,
    rw [one_pow, expand_one] at hm,
    rw hf.eq_degree,
    rw hm, },
  { rcases hg with ⟨hg, m, hm⟩,
    let g' := classical.some hf,
    cases (classical.some_spec hf).2 with m' hm',
    haveI : fact q.prime := fact_iff.2 hF_hprime,
    apply contraction_degree_eq_or_insep q g g' m m',
    rw [hm, hm'],
    exact hg, exact (classical.some_spec hf).1 }
end

end field

end polynomial


import standard
--import data.nat

structure Category :=
  (Obj : Type)
  (Hom : Obj → Obj → Type)

  (identity : Π A : Obj, Hom A A)
  (compose : Π ⦃A B C : Obj⦄, Hom A B → Hom B C → Hom A C)

  (left_identity  : Π ⦃A B : Obj⦄ (f : Hom A B), compose (identity _) f = f)
  (right_identity : Π ⦃A B : Obj⦄ (f : Hom A B), compose f (identity _) = f)
  (associativity  : Π ⦃A B C D : Obj⦄ (f : Hom A B) (g : Hom B C) (h : Hom C D),
    compose (compose f g) h = compose f (compose g h))

namespace Category
  -- Can we put this before the definition?
  notation f ∘ g := compose _ _ _ _ f g
  -- infixr `∘` := compose _ _ _ _
  infixl `⟶` :25 := Hom _

  --def Mor := Hom
end Category

/-
instance ℕCategory : Category :=
  { Category .
    Obj      := unit,
    Hom      := λ a b, ℕ,
    identity := λ a, 0,
    compose  := λ a b c, add,

    left_identity  := λ a b, zero_add,
    right_identity := λ a b, add_zero,
    associativity  := λ a b c d, add_assoc }

-- This is how Coq's program directive does it under the
-- hood. Everything after the refine line should be able to be
-- replaced by a single tactic (like crush).
instance ℕCategory' : Category :=
begin
  refine (Category.mk unit (λ a b, ℕ) (λ a, 0) (λ a b c, add) _ _ _),
  intros A B,
  exact zero_add,
  intros A B,
  exact add_zero,
  intros A B C D,
  exact add_assoc
end
-/

open Category

print Category

-- This needs to use typeclasses; still trying to figure that out

class Functor (source target : Category) :=
  (onObjects     : Obj source → Obj target)
  (onMorphisms   : Π ⦃a b : Obj source⦄, Hom _ a b → Hom _ (onObjects a) (onObjects b))
--
--  (identities    : Π (a : Obj source), onMorphisms (Id _ a) = Id _ (onObjects a))
--  (functoriality : Π ⦃a b c : Obj source⦄ (f : Hom _ a b) (g : Hom _ b c),
--                    onMorphisms (f ∘ g) = onMorphisms f ∘ onMorphisms g)

--namespace Functor
--  infix `<$>`:50 := λ {C D : Category} (F : Functor C D) (a : Obj C), onObjects F a
--  infix `<$>m`:50 := λ {C D : Category} (F : Functor C D) {a b : Obj C}
--                        (f : Hom _ a b), onMorphisms F f
--end Functor
--
--open function

-- This clearly shouldn't be here. In Lean 2, this could be done by blast
theorem double_order (n m p q : ℕ) : n + m + (p + q) = n + p + (m + q) :=
calc
  n + m + (p + q) = n + (m + (p + q)) : add_assoc n m (p + q)
              ... = n + (m + p + q)   : eq.symm (congr_arg (add n) (add_assoc m p q))
              ... = n + (p + m + q)   : congr_arg (add n) (congr_arg (λ n, n + q) (add_comm m p))
              ... = n + (p + (m + q)) : congr_arg (add n) (add_assoc p m q)
              ... = n + p + (m + q)   : eq.symm (add_assoc n p (m + q))

--@[reducible]
--def DoublingAsFunctor : Functor ℕCategory ℕCategory :=
--  { Functor .
--    onObj := id,
--    onMor := λ a b (n : ℕ), n + n,
--
--    respect_Id   := λ a, rfl,
--    respect_comp := begin
--                    intros,
--                    exact double_order f g f g
--                    end }

-- This was a part of the standard library in Lean 2. Let's put it in
-- until they add it again.
theorem pair_eq {A B : Type} {a₁ a₂ : A} {b₁ b₂ : B} :
    a₁ = a₂ → b₁ = b₂ → (a₁, b₁) = (a₂, b₂) :=
assume H1 H2, H1 ▸ H2 ▸ rfl

open prod

-- Needs to use typeclasses again.

--instance ProductCategory (C D : Category) [Category] [Category] : Category :=
--  { Category .
--    Obj := Obj C × Obj D,
--    Hom := λ a b, Hom C (fst a) (fst b) × Hom D (snd a) (snd b),
--
--    identity := λ a, (identity C (fst a), identity D (snd a)),
--    compose  := λ a b c f g, (fst f ∘ fst g, snd f ∘ snd g),
--
--    left_identities  := λ a b c d, pair_eq (left_identity  C _) (left_identity  D _) ,
--    right_identities := λ a b c d, pair_eq (right_identity C _) (right_identity D _),
--    associativity := begin
--                     intros,
--                     exact pair_eq (assoc C _ _ _ _ _) (assoc D _ _ _ _ _)
--                     end }
--
--namespace ProductCategory
--  notation C `×c` D := ProductCategory C D
--end ProductCategory
--
--open Functor
--open ProductCategory
--
--structure LaxMonoidalCategory :=
--  (carrier : Category)
--  (tensor : Functor (carrier ×c carrier) carrier)
--  (unit : let obj := Obj carrier in obj)
--
--  (associator : Π (a b c : Obj carrier),
--                  Hom _ (tensor <$> (tensor <$> (a,b), c))
--                       (tensor <$> (a, tensor <$> (b,c))))
--  --(pentagon : Π (a b c d : Obj carrier),
--  --              associator (tensor <$> (a,b)) c d ∘c associator a b (tensor <$> (c,d)) =
--
----attribute [coercion] LaxMonoidalCategory.carrier
----
--namespace LaxMonoidalCategory
--  infix `⊗`:70 := λ {C : LaxMonoidalCategory} (a b : Obj C), tensor C <$> (a,b)
--  infix `⊗m`:70 := λ {C : LaxMonoidalCategory} {a b c d : Obj C}
--                      (f : Hom a b) (g : Hom c d), tensor C <$> (f,g)
--end LaxMonoidalCategory

--@[reducible]
--def ℕTensorProduct : Functor (ℕCategory ×c ℕCategory) ℕCategory :=
--  { Functor .
--    onObj := fst,
--    onMor := λ a b n, fst n + snd n,
--
--    respect_Id   := λ a, rfl,
--    respect_comp := begin
--                    intros,
--                    refine (double_order f g f g)
--                    end }

--def ℕTensorProduct' : Functor (ℕCategory ×c ℕCategory) ℕCategory :=
--  Functor.mk pr1 (λ a b (f : ℕ × ℕ), pr1 f + pr2 f) _ _ _
--begin
--  refine Functor.mk (pr1) (λ (a b : unit), λ (f : ℕ × ℕ), pr1 f + pr2 f) _ _,
--end
--
--def ℕLaxMonoidalCategory : LaxMonoidalCategory :=
--  ⦃ LaxMonoidalCategory,
--    carrier    := ℕCategory,
--    tensor     := ℕTensorProduct,
--    unit       := unit.star,
--
--    associator := λ a b c, Id _ _ ⦄
--
--open LaxMonoidalCategory

--check (2 : Hom ℕLaxMonoidalCategory unit.star unit.star)


/-
Copyright (c) 2021 Jakob Scholbach. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jakob Scholbach
-/
import algebra.algebra.basic
import algebra.char_p.exp_char
import field_theory.separable

/-!

# Separable degree

This file contains basics about the separable degree of a polynomial.

## Main results

- `is_separable_contraction`: is the condition that `g(x^(q^m)) = f(x)` for some `m : ℕ`
- `has_separable_contraction`: the condition of having a separable contraction
- `has_separable_contraction.degree`: the separable degree, defined as the degree of some
  separable contraction
- `irreducible_has_separable_contraction`: any irreducible polynomial can be contracted
  to a separable polynomial
- `has_separable_contraction.dvd_degree'`: the degree of a separable contraction divides the degree,
  in function of the exponential characteristic of the field
- `has_separable_contraction.dvd_degree` and `has_separable_contraction.eq_degree` specialize the
  statement of `separable_degree_dvd_degree`
- `is_separable_contraction.degree_eq`: the separable degree is well-defined, implemented as the
  statement that the degree of any separable contraction equals `has_separable_contraction.degree`

## Tags

separable degree, degree, polynomial
-/

namespace polynomial

noncomputable theory
open_locale classical polynomial

section comm_semiring

variables {F : Type} [comm_semiring F] (q : ℕ)

/-- A separable contraction of a polynomial `f` is a separable polynomial `g` such that
`g(x^(q^m)) = f(x)` for some `m : ℕ`.-/
def is_separable_contraction (f : F[X]) (g : F[X]) : Prop :=
g.separable ∧ ∃ m : ℕ, expand F (q^m) g = f

/-- The condition of having a separable contration. -/
def has_separable_contraction (f : F[X]) : Prop :=
∃ g : F[X], is_separable_contraction q f g

variables {q} {f : F[X]} (hf : has_separable_contraction q f)

/-- A choice of a separable contraction. -/
def has_separable_contraction.contraction : F[X] := classical.some hf

/-- The separable degree of a polynomial is the degree of a given separable contraction. -/
def has_separable_contraction.degree : ℕ := hf.contraction.nat_degree

/-- The separable degree divides the degree, in function of the exponential characteristic of F. -/
lemma is_separable_contraction.dvd_degree' {g} (hf : is_separable_contraction q f g) :
  ∃ m : ℕ, g.nat_degree * (q ^ m) = f.nat_degree :=
begin
  obtain ⟨m, rfl⟩ := hf.2,
  use m,
  rw nat_degree_expand,
end

lemma has_separable_contraction.dvd_degree' : ∃ m : ℕ, hf.degree * (q ^ m) = f.nat_degree :=
(classical.some_spec hf).dvd_degree'

/-- The separable degree divides the degree. -/
lemma has_separable_contraction.dvd_degree :
  hf.degree ∣ f.nat_degree :=
let ⟨a, ha⟩ := hf.dvd_degree' in dvd.intro (q ^ a) ha

/-- In exponential characteristic one, the separable degree equals the degree. -/
lemma has_separable_contraction.eq_degree {f : F[X]}
  (hf : has_separable_contraction 1 f) : hf.degree = f.nat_degree :=
let ⟨a, ha⟩ := hf.dvd_degree' in by rw [←ha, one_pow a, mul_one]

end comm_semiring

section field

variables {F : Type} [field F]
variables (q : ℕ) {f : F[X]} (hf : has_separable_contraction q f)

/-- Every irreducible polynomial can be contracted to a separable polynomial.
https://stacks.math.columbia.edu/tag/09H0 -/
lemma irreducible_has_separable_contraction (q : ℕ) [hF : exp_char F q]
  (f : F[X]) [irred : irreducible f] : has_separable_contraction q f :=
begin
  casesI hF,
  { exact ⟨f, irred.separable, ⟨0, by rw [pow_zero, expand_one]⟩⟩ },
  { rcases exists_separable_of_irreducible q irred ‹q.prime›.ne_zero with ⟨n, g, hgs, hge⟩,
    exact ⟨g, hgs, n, hge⟩, }
end

/-- A helper lemma: if two expansions (along the positive characteristic) of two polynomials `g` and
`g'` agree, and the one with the larger degree is separable, then their degrees are the same. -/
lemma contraction_degree_eq_aux [hq : fact q.prime] [hF : char_p F q]
  (g g' : F[X]) (m m' : ℕ)
  (h_expand : expand F (q^m) g = expand F (q^m') g')
  (h : m < m') (hg : g.separable):
  g.nat_degree =  g'.nat_degree :=
begin
  obtain ⟨s, rfl⟩ := nat.exists_eq_add_of_lt h,
  rw [add_assoc, pow_add, expand_mul] at h_expand,
  let aux := expand_injective (pow_pos hq.1.pos m) h_expand,
  rw aux at hg,
  have := (is_unit_or_eq_zero_of_separable_expand q (s + 1) hq.out.pos hg).resolve_right
    s.succ_ne_zero,
  rw [aux, nat_degree_expand,
    nat_degree_eq_of_degree_eq_some (degree_eq_zero_of_is_unit this),
    zero_mul]
end

/-- If two expansions (along the positive characteristic) of two separable polynomials
`g` and `g'` agree, then they have the same degree. -/
theorem contraction_degree_eq_or_insep
  [hq : fact q.prime] [char_p F q]
  (g g' : F[X]) (m m' : ℕ)
  (h_expand : expand F (q^m) g = expand F (q^m') g')
  (hg : g.separable) (hg' : g'.separable) :
  g.nat_degree = g'.nat_degree :=
begin
  by_cases h : m = m',
  { -- if `m = m'` then we show `g.nat_degree = g'.nat_degree` by unfolding the definitions
    rw h at h_expand,
    have expand_deg : ((expand F (q ^ m')) g).nat_degree =
      (expand F (q ^ m') g').nat_degree, by rw h_expand,
    rw [nat_degree_expand (q^m') g, nat_degree_expand (q^m') g'] at expand_deg,
    apply nat.eq_of_mul_eq_mul_left (pow_pos hq.1.pos m'),
    rw [mul_comm] at expand_deg, rw expand_deg, rw [mul_comm] },
  { cases ne.lt_or_lt h,
    { exact contraction_degree_eq_aux q g g' m m' h_expand h_1 hg },
    { exact (contraction_degree_eq_aux q g' g m' m h_expand.symm h_1 hg').symm, } }
end

/-- The separable degree equals the degree of any separable contraction, i.e., it is unique. -/
theorem is_separable_contraction.degree_eq [hF : exp_char F q]
  (g : F[X]) (hg : is_separable_contraction q f g) :
  g.nat_degree = hf.degree :=
begin
  casesI hF,
  { rcases hg with ⟨g, m, hm⟩,
    rw [one_pow, expand_one] at hm,
    rw hf.eq_degree,
    rw hm, },
  { rcases hg with ⟨hg, m, hm⟩,
    let g' := classical.some hf,
    cases (classical.some_spec hf).2 with m' hm',
    haveI : fact q.prime := fact_iff.2 hF_hprime,
    apply contraction_degree_eq_or_insep q g g' m m',
    rw [hm, hm'],
    exact hg, exact (classical.some_spec hf).1 }
end

end field

end polynomial


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import ring_theory.matrix_algebra
import data.polynomial.algebra_map
import data.matrix.basis
import data.matrix.dmatrix

/-!
# Algebra isomorphism between matrices of polynomials and polynomials of matrices

Given `[comm_ring R] [ring A] [algebra R A]`
we show `polynomial A ≃ₐ[R] (A ⊗[R] polynomial R)`.
Combining this with the isomorphism `matrix n n A ≃ₐ[R] (A ⊗[R] matrix n n R)` proved earlier
in `ring_theory.matrix_algebra`, we obtain the algebra isomorphism
```
def mat_poly_equiv :
  matrix n n (polynomial R) ≃ₐ[R] polynomial (matrix n n R)
```
which is characterized by
```
coeff (mat_poly_equiv m) k i j = coeff (m i j) k
```

We will use this algebra isomorphism to prove the Cayley-Hamilton theorem.
-/

universes u v w

open_locale tensor_product

open polynomial
open tensor_product
open algebra.tensor_product (alg_hom_of_linear_map_tensor_product include_left)

noncomputable theory

variables (R A : Type*)
variables [comm_semiring R]
variables [semiring A] [algebra R A]

namespace poly_equiv_tensor

/--
(Implementation detail).
The function underlying `A ⊗[R] polynomial R →ₐ[R] polynomial A`,
as a bilinear function of two arguments.
-/
@[simps apply_apply]
def to_fun_bilinear : A →ₗ[A] polynomial R →ₗ[R] polynomial A :=
linear_map.to_span_singleton A _ (aeval (polynomial.X : polynomial A)).to_linear_map

lemma to_fun_bilinear_apply_eq_sum (a : A) (p : polynomial R) :
  to_fun_bilinear R A a p = p.sum (λ n r, monomial n (a * algebra_map R A r)) :=
begin
  dsimp [to_fun_bilinear_apply_apply, aeval_def, eval₂_eq_sum, polynomial.sum],
  rw finset.smul_sum,
  congr' with i : 1,
  rw [←algebra.smul_def, ←C_mul', mul_smul_comm, C_mul_X_pow_eq_monomial, ←algebra.commutes,
    ←algebra.smul_def, smul_monomial],
end

/--
(Implementation detail).
The function underlying `A ⊗[R] polynomial R →ₐ[R] polynomial A`,
as a linear map.
-/
def to_fun_linear : A ⊗[R] polynomial R →ₗ[R] polynomial A :=
tensor_product.lift (to_fun_bilinear R A)

@[simp]
lemma to_fun_linear_tmul_apply (a : A) (p : polynomial R) :
  to_fun_linear R A (a ⊗ₜ[R] p) = to_fun_bilinear R A a p := lift.tmul _ _

-- We apparently need to provide the decidable instance here
-- in order to successfully rewrite by this lemma.
lemma to_fun_linear_mul_tmul_mul_aux_1
  (p : polynomial R) (k : ℕ) (h : decidable (¬p.coeff k = 0)) (a : A) :
  ite (¬coeff p k = 0) (a * (algebra_map R A) (coeff p k)) 0 = a * (algebra_map R A) (coeff p k) :=
by { classical, split_ifs; simp *, }

lemma to_fun_linear_mul_tmul_mul_aux_2 (k : ℕ) (a₁ a₂ : A) (p₁ p₂ : polynomial R) :
  a₁ * a₂ * (algebra_map R A) ((p₁ * p₂).coeff k) =
    (finset.nat.antidiagonal k).sum
      (λ x, a₁ * (algebra_map R A) (coeff p₁ x.1) * (a₂ * (algebra_map R A) (coeff p₂ x.2))) :=
begin
  simp_rw [mul_assoc, algebra.commutes, ←finset.mul_sum, mul_assoc, ←finset.mul_sum],
  congr,
  simp_rw [algebra.commutes (coeff p₂ _), coeff_mul, ring_hom.map_sum, ring_hom.map_mul],
end

lemma to_fun_linear_mul_tmul_mul (a₁ a₂ : A) (p₁ p₂ : polynomial R) :
  (to_fun_linear R A) ((a₁ * a₂) ⊗ₜ[R] (p₁ * p₂)) =
    (to_fun_linear R A) (a₁ ⊗ₜ[R] p₁) * (to_fun_linear R A) (a₂ ⊗ₜ[R] p₂) :=
begin
  simp only [to_fun_linear_tmul_apply, to_fun_bilinear_apply_eq_sum],
  ext k,
  simp_rw [coeff_sum, coeff_monomial, sum_def, finset.sum_ite_eq', mem_support_iff, ne.def],
  conv_rhs { rw [coeff_mul] },
  simp_rw [finset_sum_coeff, coeff_monomial,
    finset.sum_ite_eq', mem_support_iff, ne.def,
    mul_ite, mul_zero, ite_mul, zero_mul],
  simp_rw [ite_mul_zero_left (¬coeff p₁ _ = 0) (a₁ * (algebra_map R A) (coeff p₁ _))],
  simp_rw [ite_mul_zero_right (¬coeff p₂ _ = 0) _ (_ * _)],
  simp_rw [to_fun_linear_mul_tmul_mul_aux_1, to_fun_linear_mul_tmul_mul_aux_2],
end

lemma to_fun_linear_algebra_map_tmul_one (r : R) :
  (to_fun_linear R A) ((algebra_map R A) r ⊗ₜ[R] 1) = (algebra_map R (polynomial A)) r :=
by rw [to_fun_linear_tmul_apply, to_fun_bilinear_apply_apply, polynomial.aeval_one,
  algebra_map_smul, algebra.algebra_map_eq_smul_one]

/--
(Implementation detail).
The algebra homomorphism `A ⊗[R] polynomial R →ₐ[R] polynomial A`.
-/
def to_fun_alg_hom : A ⊗[R] polynomial R →ₐ[R] polynomial A :=
alg_hom_of_linear_map_tensor_product
  (to_fun_linear R A)
  (to_fun_linear_mul_tmul_mul R A)
  (to_fun_linear_algebra_map_tmul_one R A)

@[simp] lemma to_fun_alg_hom_apply_tmul (a : A) (p : polynomial R) :
  to_fun_alg_hom R A (a ⊗ₜ[R] p) = p.sum (λ n r, monomial n (a * (algebra_map R A) r)) :=
begin
  dsimp [to_fun_alg_hom],
  rw [to_fun_linear_tmul_apply, to_fun_bilinear_apply_eq_sum],
end

/--
(Implementation detail.)

The bare function `polynomial A → A ⊗[R] polynomial R`.
(We don't need to show that it's an algebra map, thankfully --- just that it's an inverse.)
-/
def inv_fun (p : polynomial A) : A ⊗[R] polynomial R :=
p.eval₂
  (include_left : A →ₐ[R] A ⊗[R] polynomial R)
  ((1 : A) ⊗ₜ[R] (X : polynomial R))

@[simp]
lemma inv_fun_add {p q} : inv_fun R A (p + q) = inv_fun R A p + inv_fun R A q :=
by simp only [inv_fun, eval₂_add]

lemma inv_fun_monomial (n : ℕ) (a : A) :
  inv_fun R A (monomial n a) = include_left a * ((1 : A) ⊗ₜ[R] (X : polynomial R)) ^ n :=
eval₂_monomial _ _

lemma left_inv (x : A ⊗ polynomial R) :
  inv_fun R A ((to_fun_alg_hom R A) x) = x :=
begin
  apply tensor_product.induction_on x,
  { simp [inv_fun], },
  { intros a p, dsimp only [inv_fun],
    rw [to_fun_alg_hom_apply_tmul, eval₂_sum],
    simp_rw [eval₂_monomial, alg_hom.coe_to_ring_hom, algebra.tensor_product.tmul_pow, one_pow,
      algebra.tensor_product.include_left_apply, algebra.tensor_product.tmul_mul_tmul,
      mul_one, one_mul, ←algebra.commutes, ←algebra.smul_def, smul_tmul, sum_def, ←tmul_sum],
    conv_rhs { rw [←sum_C_mul_X_eq p], },
    simp only [algebra.smul_def],
    refl, },
  { intros p q hp hq,
    simp only [alg_hom.map_add, inv_fun_add, hp, hq], },
end

lemma right_inv (x : polynomial A) :
  (to_fun_alg_hom R A) (inv_fun R A x) = x :=
begin
  apply polynomial.induction_on' x,
  { intros p q hp hq, simp only [inv_fun_add, alg_hom.map_add, hp, hq], },
  { intros n a,
    rw [inv_fun_monomial, algebra.tensor_product.include_left_apply,
      algebra.tensor_product.tmul_pow, one_pow, algebra.tensor_product.tmul_mul_tmul,
      mul_one, one_mul, to_fun_alg_hom_apply_tmul, X_pow_eq_monomial, sum_monomial_index];
    simp, }
end

/--
(Implementation detail)

The equivalence, ignoring the algebra structure, `(A ⊗[R] polynomial R) ≃ polynomial A`.
-/
def equiv : (A ⊗[R] polynomial R) ≃ polynomial A :=
{ to_fun := to_fun_alg_hom R A,
  inv_fun := inv_fun R A,
  left_inv := left_inv R A,
  right_inv := right_inv R A, }

end poly_equiv_tensor

open poly_equiv_tensor

/--
The `R`-algebra isomorphism `polynomial A ≃ₐ[R] (A ⊗[R] polynomial R)`.
-/
def poly_equiv_tensor : polynomial A ≃ₐ[R] (A ⊗[R] polynomial R) :=
alg_equiv.symm
{ ..(poly_equiv_tensor.to_fun_alg_hom R A), ..(poly_equiv_tensor.equiv R A) }

@[simp]
lemma poly_equiv_tensor_apply (p : polynomial A) :
  poly_equiv_tensor R A p =
    p.eval₂ (include_left : A →ₐ[R] A ⊗[R] polynomial R) ((1 : A) ⊗ₜ[R] (X : polynomial R)) :=
rfl

@[simp]
lemma poly_equiv_tensor_symm_apply_tmul (a : A) (p : polynomial R) :
  (poly_equiv_tensor R A).symm (a ⊗ₜ p) = p.sum (λ n r, monomial n (a * algebra_map R A r)) :=
to_fun_alg_hom_apply_tmul _ _ _ _

open dmatrix matrix
open_locale big_operators

variables {R}
variables {n : Type w} [decidable_eq n] [fintype n]

/--
The algebra isomorphism stating "matrices of polynomials are the same as polynomials of matrices".

(You probably shouldn't attempt to use this underlying definition ---
it's an algebra equivalence, and characterised extensionally by the lemma
`mat_poly_equiv_coeff_apply` below.)
-/
noncomputable def mat_poly_equiv :
  matrix n n (polynomial R) ≃ₐ[R] polynomial (matrix n n R) :=
(((matrix_equiv_tensor R (polynomial R) n)).trans
  (algebra.tensor_product.comm R _ _)).trans
  (poly_equiv_tensor R (matrix n n R)).symm

open finset

lemma mat_poly_equiv_coeff_apply_aux_1 (i j : n) (k : ℕ) (x : R) :
  mat_poly_equiv (std_basis_matrix i j $ monomial k x) =
    monomial k (std_basis_matrix i j x) :=
begin
  simp only [mat_poly_equiv, alg_equiv.trans_apply,
    matrix_equiv_tensor_apply_std_basis],
  apply (poly_equiv_tensor R (matrix n n R)).injective,
  simp only [alg_equiv.apply_symm_apply],
  convert algebra.tensor_product.comm_tmul _ _ _ _ _,
  simp only [poly_equiv_tensor_apply],
  convert eval₂_monomial _ _,
  simp only [algebra.tensor_product.tmul_mul_tmul, one_pow, one_mul, matrix.mul_one,
    algebra.tensor_product.tmul_pow, algebra.tensor_product.include_left_apply, mul_eq_mul],
  rw [monomial_eq_smul_X, ← tensor_product.smul_tmul],
  congr' with i' j'; simp
end

lemma mat_poly_equiv_coeff_apply_aux_2
  (i j : n) (p : polynomial R) (k : ℕ) :
  coeff (mat_poly_equiv (std_basis_matrix i j p)) k =
    std_basis_matrix i j (coeff p k) :=
begin
  apply polynomial.induction_on' p,
  { intros p q hp hq, ext,
    simp [hp, hq, coeff_add, add_apply, std_basis_matrix_add], },
  { intros k x,
    simp only [mat_poly_equiv_coeff_apply_aux_1, coeff_monomial],
    split_ifs; { funext, simp, }, }
end

@[simp] lemma mat_poly_equiv_coeff_apply
  (m : matrix n n (polynomial R)) (k : ℕ) (i j : n) :
  coeff (mat_poly_equiv m) k i j = coeff (m i j) k :=
begin
  apply matrix.induction_on' m,
  { simp, },
  { intros p q hp hq, simp [hp, hq], },
  { intros i' j' x,
    erw mat_poly_equiv_coeff_apply_aux_2,
    dsimp [std_basis_matrix],
    split_ifs,
    { rcases h with ⟨rfl, rfl⟩, simp [std_basis_matrix], },
    { simp [std_basis_matrix, h], }, },
end

@[simp] lemma mat_poly_equiv_symm_apply_coeff
  (p : polynomial (matrix n n R)) (i j : n) (k : ℕ) :
  coeff (mat_poly_equiv.symm p i j) k = coeff p k i j :=
begin
  have t : p = mat_poly_equiv
    (mat_poly_equiv.symm p) := by simp,
  conv_rhs { rw t, },
  simp only [mat_poly_equiv_coeff_apply],
end

lemma mat_poly_equiv_smul_one (p : polynomial R) :
  mat_poly_equiv (p • 1) = p.map (algebra_map R (matrix n n R)) :=
begin
  ext m i j,
  simp only [coeff_map, one_apply, algebra_map_matrix_apply, mul_boole,
    pi.smul_apply, mat_poly_equiv_coeff_apply],
  split_ifs; simp,
end

lemma support_subset_support_mat_poly_equiv
  (m : matrix n n (polynomial R)) (i j : n) :
  support (m i j) ⊆ support (mat_poly_equiv m) :=
begin
  assume k,
  contrapose,
  simp only [not_mem_support_iff],
  assume hk,
  rw [← mat_poly_equiv_coeff_apply, hk],
  refl
end


import data.set
import data.finset
import data.list.basic
import data.vector
import data.option.basic
import tactic

import myoption
import mylist
import myfinset
import myfintype
import konig

namespace graph

open set finset

attribute [instance] classical.prop_decidable

-- A graph is a collection of vertices with at most one edge between
-- any pair of vertices.  Self-loops are allowed.
structure graph (X : Type) :=
  mk :: (V : set X) (E : X → X → Prop) (sym : symmetric E)

-- A subgraph consists of a subset of vertices and a "subset" of edges.
protected def is_subgraph {X} (G' : graph X) (G : graph X)
:= G'.V ⊆ G.V ∧ ∀ v ∈ G'.V, ∀ w ∈ G'.V, G'.E v w → G.E v w

-- use G' ⊆ G to denote subgraphs
instance (X) : has_subset (graph X) := ⟨graph.is_subgraph⟩

-- A graph containing an edge between every pair of distinct vertices
def complete_graph {X} (V : set X) := graph.mk V (λ v w, v ≠ w) (by tauto)

-- Gives the induced subgraph with vertex set W
def induced {X} (G : graph X) (W : set X) (sub : W ⊆ G.V) :=
  graph.mk W G.E G.sym

lemma induced_is_subgraph {X} (G : graph X) (W : set X) (sub : W ⊆ G.V)
: induced G W sub ⊆ G
:=
begin
  split,
  exact sub,
  intros v w vin win indedge,
  exact indedge,
end

-- A graph coloring is an assignment of a "color" to each vertex such
-- that adjacent vertices have distinct colors.
def graph_coloring {X} {C} (G : graph X) (c : X → C) :=
  ∀ v ∈ G.V, ∀ w ∈ G.V, G.E v w → c v ≠ c w

-- A graph is n-colorable if it is colorable using only the colors 0 through (n-1).
def ncolorable {X} (G : graph X) (n : ℕ) :=
  ∃ (c : X → ℕ), c '' G.V ⊆ ↑(range n) ∧ graph_coloring G c

lemma std_ncoloring {X} {C} {G : graph X} (C' : finset C) (c : X → C)
(nc : graph_coloring G c) (cod : ∀ v ∈ G.V, c v ∈ C')
: ncolorable G (card C')
:= begin
  rcases finset.inj_range C' with ⟨f, hfdom, hfinj⟩,
  use (f ∘ c),
  simp,
  split, {
    intros n nelt, simp at nelt,
    rcases nelt with ⟨v, velt, fcv_n⟩,
    simp,
    rw ← fcv_n,
    exact hfdom (c v) (cod v velt),
  }, {
    intros v vin w win hedge f,
    specialize hfinj (c v) (cod v vin) (c w) (cod w win) f,
    exact nc v vin w win hedge hfinj,
  },
end

def chromatic_number {X} (G : graph X) (n : ℕ) :=
  ncolorable G n ∧ ∀ m < n, ¬ncolorable G m

-- A complete graph of n vertices can be colored with n or more colors but no fewer.
lemma complete_graph_chromatic_number (n : ℕ): chromatic_number (complete_graph (↑(range n) : set ℕ)) n
:=
begin
  split, {
    set f := λ (v : ℕ), v with feq,
    use f,
    split, {
      dsimp only [complete_graph],
      intros c cin,
      rcases cin with ⟨x,h⟩, rw feq at h, dsimp only at h, rw ←h.2, tauto,
    }, {
      intros v vin w win hedge,
      dsimp [complete_graph] at vin, simp at vin,
      dsimp [complete_graph] at win, simp at win,
      dsimp [complete_graph] at hedge,
      rw feq, dsimp only, tauto,
    },
  }, {
    intros m msmall notcolor,
    rcases notcolor with ⟨f,fim,coloring⟩,
    dsimp [complete_graph] at fim,
    dsimp [graph_coloring,complete_graph] at coloring, simp at coloring,
    have h : ∀ x < n, f x < m, {
      intros x xin,
      have xin' : x ∈ range n, rw ← finset.mem_range at xin, exact xin,
      have fxin' : f x ∈ f '' ↑(range n), exact mem_image_of_mem f xin',
      specialize fim fxin', simp at fim, exact fim,
    },
    have rangen := range n,
    have coloring' : ∀ v ∈ range n, ∀ w ∈ range n, f v = f w → v = w,
      intros v velt w welt, simp at velt, simp at welt, specialize coloring v velt w welt, contrapose, assumption,
    have hh := card_image_of_inj_on coloring',
    have hh' := range_sup f n m h,
    dsimp only at hh, rw hh at hh',
    simp at hh', linarith,
  },
end

-- An n-colored graph can be colored with more than n colors.
lemma can_color_with_more {X} (G : graph X) (n m : ℕ) (gt : m ≥ n) (able : ncolorable G n) : ncolorable G m
:=
begin
  rcases able with ⟨c, cod, col⟩,
  have dom' : ∀ v ∈ G.V, c v < m,
    intros v vin,
    have code' := cod (mem_image_of_mem c vin),
    simp at code',
    linarith,
  unfold ncolorable,
  use c,
  split, {
    intros c celt,
    rcases celt with ⟨v, velt, cv_eq⟩,
    specialize dom' v velt,
    rw cv_eq at dom', simpa,
  }, {
    assumption,
  },
end

lemma can_color_subgraph {X} {H G : graph X} (sub : H ⊆ G) (c : X → ℕ) (is_coloring : graph_coloring G c)
: graph_coloring H c
:=
begin
  intros v vin w win vwedgeH,
  have vwedgeG : G.E v w := sub.2 v vin w win vwedgeH,
  exact is_coloring v (sub.1 vin) w (sub.1 win) vwedgeG,
end

-- The following theorem is an application of König's lemma, pointed
-- out by C. St. J. A. Nash-Williams in "Infinite graphs --- a survey"
-- (1967).
theorem can_color_countable_infinite (n : ℕ) (pos : n > 0)
(G : graph ℕ) (fcol : ∀ (V : finset ℕ) (sub : ↑V ⊆ G.V), ncolorable (induced G ↑V sub) n)
: ncolorable G n
:= begin
  let Vfin := λ n, G.V ∩ ↑(finset.range n),
  have sub : ∀ n, Vfin n ⊆ G.V, {
    intro n, exact G.V.sep_subset _,
  },
  let Gfin := λ k, induced G (Vfin k) (sub k),

  let zero : {i : ℕ // i < n} := ⟨0, pos⟩,
  let X := list {i : ℕ // i < n},
  let S : ℕ → set X := λ (k : ℕ), {v : X | v.length = k ∧ graph_coloring (Gfin k) (v.as_fn zero)},
  let fns := λ (k : ℕ) (v : X), v.init,

  have sys : konig.inv_system S fns, {
    intros k x xel,
    simp [fns] at xel ⊢,
    rcases xel with ⟨xlen, coloring⟩,
    have nonnil : x ≠ [], {
      by_contradiction f, push_neg at f,
      rw f at xlen, simp at xlen, exact (nat.succ_ne_zero k).symm xlen,
    },
    have h := list.init_length_is_pred nonnil,
    rw xlen at h, simp at h, rw h, simp,

    intros v vel w wel hedge,
    dsimp only [Gfin, Vfin, induced] at hedge,
    dsimp only [Gfin, Vfin, induced] at vel wel, simp at vel wel,
    dsimp only [graph_coloring, Gfin, Vfin, induced] at coloring, simp at coloring,
    specialize coloring v vel.1 (by linarith) w wel.1 (by linarith) hedge,
    have x_nonnil : x ≠ [], intro is_nil, rw is_nil at xlen, simp at xlen, tauto,
    have xinit_len : x.init.length = k,
      have hlen := list.init_length_is_pred x_nonnil, rw xlen at hlen, exact hlen,
    have vtineq : v < x.init.length,
      rw ← xinit_len at vel, exact vel.right,
    have wtineq : w < x.init.length,
      rw ← xinit_len at wel, exact wel.right,
    rw list.as_fn_inrange vtineq,
    rw list.as_fn_inrange wtineq,
    exact coloring,
  },
  have nonempty : ∀ k, ∃ c, c ∈ S k, {
    intro k,
    specialize fcol ((finset.range k).filter(λ k, k ∈ G.V)),
    have sub : ↑(filter (λ (k : ℕ), k ∈ G.V) (range k)) ⊆ G.V, {
      simp, exact (↑(finset.range k) : set ℕ).inter_subset_right G.V,
    },
    specialize fcol sub, simp at fcol,
    rcases fcol with ⟨c, hcdom, hcol⟩,
    let c' := λ i, if i ∈ G.V then c i else 0,
    have rng : ∀ i < k, c' i < n, {
      intros i iineq,
      dsimp [c'],
      by_cases h : i ∈ G.V,
      have htrue : i ∈ G.V ↔ true, tauto,
      rw htrue, simp,
      dsimp [induced] at hcdom,
      have elt : i ∈ {x ∈ ↑(range k) | x ∈ G.V}, {
        have irange : i ∈ (↑(range k) : set ℕ), simpa,
        exact mem_sep irange h,
      },
      have celt : c i ∈ range n, {
        apply hcdom, exact mem_image_of_mem c elt,
      },
      simp at celt, exact celt,
      have hfalse : i ∈ G.V ↔ false, tauto,
      rw hfalse, simp, linarith,
    },
    let c'' := λ i, if i < k then c' i else 0,
    have rng' : ∀ i, c'' i < n, {
      intro i,
      dsimp [c''],
      by_cases h : i < k, {
        have htrue : i < k ↔ true, tauto,
        rw htrue, simp,
        exact rng i h,
      }, {
        have hfalse : i < k ↔ false, tauto,
        rw hfalse, simp,
        linarith,
      },
    },
    let c''' : ℕ → {x : ℕ // x < n} := λ i, ⟨c'' i, rng' i⟩,
    let clis := (list.range2 0 k).map c''',
    use clis,
    dsimp [S],
    split, {
      dsimp [clis], simp,
    }, {
      intros v vin w win hedge,
      dsimp [Gfin, Vfin, induced] at vin win hedge, simp at vin win,
      dsimp [clis, list.as_fn], simp,
      have rngv := list.range2_nth 0 k v vin.2,
      have rngw := list.range2_nth 0 k w win.2,
      rw [rngv, rngw], simp,
      dsimp [c'', c'],
      have vkt : v < k ↔ true, tauto,
      have wkt : w < k ↔ true, tauto,
      have vint : v ∈ G.V ↔ true, tauto,
      have wint : w ∈ G.V ↔ true, tauto,
      simp [vkt, wkt, vint, wint],
      dsimp [graph_coloring, induced] at hcol, simp at hcol,
      exact hcol v vin.2 vin.1 w win.2 win.1 hedge,
    },
  },

  rcases konig.weak_konig_lemma sys nonempty with ⟨u, invlim⟩,
  use (λ v, list.as_fn ↑(u (v+1)) zero v),
  have zup : (0:ℕ) = ↑zero, unfold_coes,
  split, {
    intros c cin,
    simp at cin, simp,
    rcases cin with ⟨v, vin, cdef⟩,
    dsimp [list.as_fn] at cdef,
    rw zup at cdef,
    norm_cast at cdef, unfold_coes at cdef,
    set lu := ((list.nth (u (v + 1)) v).get_or_else zero) with lueq,
    rw ← cdef, exact lu.property,
  }, {
    intros v vin w win hedge,
    dsimp [list.as_fn], rw zup, norm_cast, unfold_coes,
    have rsys : ∀ k, u k = list.init (u (k + 1)), {
      intro k,
      have f := invlim k,
      dsimp [fns] at f,
      exact f.right,
    },
    have lens : ∀ k, (u k).length = k, {
      intro k,
      have f := (invlim k).left,
      dsimp [S] at f, exact f.1,
    },
    let K := max (v + 1) (w + 1),
    have liftv := list.init_rep_nth u rsys lens v (v + 1) K (by linarith) (le_max_left (v + 1) (w + 1)),
    have liftw := list.init_rep_nth u rsys lens w (w + 1) K (by linarith) (le_max_right (v + 1) (w + 1)),
    rw [liftv, liftw],
    have uKelt := (invlim K).left,
    dsimp [S,graph_coloring,Gfin,Vfin,list.as_fn,induced] at uKelt, simp at uKelt,
    have vlt : v < v + 1 ∨ v < w + 1, left, linarith,
    have wlt : w < v + 1 ∨ w < w + 1, right, linarith,
    have uKelt' := uKelt.right v vin vlt w win wlt hedge,
    intro as_eq,
    have as_eq' := subtype.eq as_eq,
    exact uKelt' as_eq',
  },

end

end graph


import .A2
import category_theory.functor_category
import algebra.category.CommRing.basic
universes v u
open A2
def map_A2 {A B :Type v}[comm_ring A][comm_ring B](f : A →  B)[is_ring_hom  f] : A2 A → A2 B := λ ζ,  begin
    use { a := f ζ.a, b := f ζ.b},
end
variables (A B :Type v)[comm_ring A][comm_ring B]
def map_a_b (f : A →  B)[is_ring_hom  f] (ζ : A2 A)  : (map_A2 (f) ζ).a = f ζ.a  ∧ (map_A2 (f) ζ).b = f ζ.b :=
begin
        split,
        exact rfl,
        exact rfl,
end
def 𝔸2 : CommRing ⥤ Type v :=
{ obj := λ R, A2 R,
  map := λ R R' f, map_A2 f,
--   map_id' := λ R, begin
--      funext,
--      rw category_theory.types_id,
--      ext,
--      exact rfl,
--      exact rfl,
--      end,
}
#print 𝔸2
#print 𝔸2._proof_2
/--
theorem 𝔸2._proof_2 : ∀ (X : CommRing), map_A2 ⇑(𝟙 X) = 𝟙 (A2 ↥X) :=
λ (X : CommRing),
  id
    (λ (X : CommRing),
       funext
         (λ (x : A2 ↥X),
            id
              (λ (X : CommRing) (x : A2 ↥X),
                 ext (eq.refl (map_A2 ⇑(𝟙 X) x).a) (eq.refl (map_A2 ⇑(𝟙 X) x).b))
              X
              x))
    X
-/