/-
Copyright (c) 2018 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau, Yury Kudryashov
-/
import algebra.algebra.basic

/-!
# Homomorphisms of `R`-algebras

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

This file defines bundled homomorphisms of `R`-algebras.

## Main definitions

* `alg_hom R A B`: the type of `R`-algebra morphisms from `A` to `B`.
* `algebra.of_id R A : R →ₐ[R] A`: the canonical map from `R` to `A`, as an `alg_hom`.

## Notations

* `A →ₐ[R] B` : `R`-algebra homomorphism from `A` to `B`.
-/

open_locale big_operators

universes u v w u₁ v₁

set_option old_structure_cmd true
/-- Defining the homomorphism in the category R-Alg. -/
@[nolint has_nonempty_instance]
structure alg_hom (R : Type u) (A : Type v) (B : Type w)
  [comm_semiring R] [semiring A] [semiring B] [algebra R A] [algebra R B] extends ring_hom A B :=
(commutes' : ∀ r : R, to_fun (algebra_map R A r) = algebra_map R B r)

run_cmd tactic.add_doc_string `alg_hom.to_ring_hom "Reinterpret an `alg_hom` as a `ring_hom`"

infixr ` →ₐ `:25 := alg_hom _
notation A ` →ₐ[`:25 R `] ` B := alg_hom R A B

/-- `alg_hom_class F R A B` asserts `F` is a type of bundled algebra homomorphisms
from `A` to `B`.  -/
class alg_hom_class (F : Type*) (R : out_param Type*) (A : out_param Type*) (B : out_param Type*)
  [comm_semiring R] [semiring A] [semiring B] [algebra R A] [algebra R B]
  extends ring_hom_class F A B :=
(commutes : ∀ (f : F) (r : R), f (algebra_map R A r) = algebra_map R B r)

-- `R` becomes a metavariable but that's fine because it's an `out_param`
attribute [nolint dangerous_instance] alg_hom_class.to_ring_hom_class

attribute [simp] alg_hom_class.commutes

namespace alg_hom_class

variables {R : Type*} {A : Type*} {B : Type*} [comm_semiring R] [semiring A] [semiring B]
  [algebra R A] [algebra R B]

@[priority 100] -- see Note [lower instance priority]
instance {F : Type*} [alg_hom_class F R A B] : linear_map_class F R A B :=
{ map_smulₛₗ := λ f r x, by simp only [algebra.smul_def, map_mul, commutes, ring_hom.id_apply],
  ..‹alg_hom_class F R A B› }

instance {F : Type*} [alg_hom_class F R A B] : has_coe_t F (A →ₐ[R] B) :=
{ coe := λ f,
  { to_fun := f,
    commutes' := alg_hom_class.commutes f,
    .. (f : A →+* B) } }

end alg_hom_class

namespace alg_hom

variables {R : Type u} {A : Type v} {B : Type w} {C : Type u₁} {D : Type v₁}

section semiring

variables [comm_semiring R] [semiring A] [semiring B] [semiring C] [semiring D]
variables [algebra R A] [algebra R B] [algebra R C] [algebra R D]

instance : has_coe_to_fun (A →ₐ[R] B) (λ _, A → B) := ⟨alg_hom.to_fun⟩

initialize_simps_projections alg_hom (to_fun → apply)

@[simp, protected] lemma coe_coe {F : Type*} [alg_hom_class F R A B] (f : F) :
  ⇑(f : A →ₐ[R] B) = f := rfl

@[simp] lemma to_fun_eq_coe (f : A →ₐ[R] B) : f.to_fun = f := rfl

instance : alg_hom_class (A →ₐ[R] B) R A B :=
{ coe := to_fun,
  coe_injective' := λ f g h, by { cases f, cases g, congr' },
  map_add := map_add',
  map_zero := map_zero',
  map_mul := map_mul',
  map_one := map_one',
  commutes := λ f, f.commutes' }

instance coe_ring_hom : has_coe (A →ₐ[R] B) (A →+* B) := ⟨alg_hom.to_ring_hom⟩

instance coe_monoid_hom : has_coe (A →ₐ[R] B) (A →* B) := ⟨λ f, ↑(f : A →+* B)⟩

instance coe_add_monoid_hom : has_coe (A →ₐ[R] B) (A →+ B) := ⟨λ f, ↑(f : A →+* B)⟩

@[simp, norm_cast] lemma coe_mk {f : A → B} (h₁ h₂ h₃ h₄ h₅) :
  ⇑(⟨f, h₁, h₂, h₃, h₄, h₅⟩ : A →ₐ[R] B) = f := rfl

-- make the coercion the simp-normal form
@[simp] lemma to_ring_hom_eq_coe (f : A →ₐ[R] B) : f.to_ring_hom = f := rfl

@[simp, norm_cast] lemma coe_to_ring_hom (f : A →ₐ[R] B) : ⇑(f : A →+* B) = f := rfl

@[simp, norm_cast] lemma coe_to_monoid_hom (f : A →ₐ[R] B) : ⇑(f : A →* B) = f := rfl

@[simp, norm_cast] lemma coe_to_add_monoid_hom (f : A →ₐ[R] B) : ⇑(f : A →+ B) = f := rfl

variables (φ : A →ₐ[R] B)

theorem coe_fn_injective : @function.injective (A →ₐ[R] B) (A → B) coe_fn := fun_like.coe_injective

theorem coe_fn_inj {φ₁ φ₂ : A →ₐ[R] B} : (φ₁ : A → B) = φ₂ ↔ φ₁ = φ₂ := fun_like.coe_fn_eq

theorem coe_ring_hom_injective : function.injective (coe : (A →ₐ[R] B) → (A →+* B)) :=
λ φ₁ φ₂ H, coe_fn_injective $ show ((φ₁ : (A →+* B)) : A → B) = ((φ₂ : (A →+* B)) : A → B),
  from congr_arg _ H

theorem coe_monoid_hom_injective : function.injective (coe : (A →ₐ[R] B)  → (A →* B)) :=
ring_hom.coe_monoid_hom_injective.comp coe_ring_hom_injective

theorem coe_add_monoid_hom_injective : function.injective (coe : (A →ₐ[R] B)  → (A →+ B)) :=
ring_hom.coe_add_monoid_hom_injective.comp coe_ring_hom_injective

protected lemma congr_fun {φ₁ φ₂ : A →ₐ[R] B} (H : φ₁ = φ₂) (x : A) : φ₁ x = φ₂ x :=
fun_like.congr_fun H x
protected lemma congr_arg (φ : A →ₐ[R] B) {x y : A} (h : x = y) : φ x = φ y :=
fun_like.congr_arg φ h

@[ext]
theorem ext {φ₁ φ₂ : A →ₐ[R] B} (H : ∀ x, φ₁ x = φ₂ x) : φ₁ = φ₂ := fun_like.ext _ _ H

theorem ext_iff {φ₁ φ₂ : A →ₐ[R] B} : φ₁ = φ₂ ↔ ∀ x, φ₁ x = φ₂ x := fun_like.ext_iff

@[simp] theorem mk_coe {f : A →ₐ[R] B} (h₁ h₂ h₃ h₄ h₅) :
  (⟨f, h₁, h₂, h₃, h₄, h₅⟩ : A →ₐ[R] B) = f := ext $ λ _, rfl

@[simp]
theorem commutes (r : R) : φ (algebra_map R A r) = algebra_map R B r := φ.commutes' r

theorem comp_algebra_map : (φ : A →+* B).comp (algebra_map R A) = algebra_map R B :=
ring_hom.ext $ φ.commutes

protected lemma map_add (r s : A) : φ (r + s) = φ r + φ s := map_add _ _ _
protected lemma map_zero : φ 0 = 0 := map_zero _
protected lemma map_mul (x y) : φ (x * y) = φ x * φ y := map_mul _ _ _
protected lemma map_one : φ 1 = 1 := map_one _
protected lemma map_pow (x : A) (n : ℕ) : φ (x ^ n) = (φ x) ^ n := map_pow _ _ _

@[simp] protected lemma map_smul (r : R) (x : A) : φ (r • x) = r • φ x := map_smul _ _ _

protected lemma map_sum {ι : Type*} (f : ι → A) (s : finset ι) :
  φ (∑ x in s, f x) = ∑ x in s, φ (f x) := map_sum _ _ _

protected lemma map_finsupp_sum {α : Type*} [has_zero α] {ι : Type*} (f : ι →₀ α) (g : ι → α → A) :
  φ (f.sum g) = f.sum (λ i a, φ (g i a)) := map_finsupp_sum _ _ _

protected lemma map_bit0 (x) : φ (bit0 x) = bit0 (φ x) := map_bit0 _ _
protected lemma map_bit1 (x) : φ (bit1 x) = bit1 (φ x) := map_bit1 _ _

/-- If a `ring_hom` is `R`-linear, then it is an `alg_hom`. -/
def mk' (f : A →+* B) (h : ∀ (c : R) x, f (c • x) = c • f x) : A →ₐ[R] B :=
{ to_fun := f,
  commutes' := λ c, by simp only [algebra.algebra_map_eq_smul_one, h, f.map_one],
  .. f }

@[simp]

section

variables (R A)
/-- Identity map as an `alg_hom`. -/
protected def id : A →ₐ[R] A :=
{ commutes' := λ _, rfl,
  ..ring_hom.id A }

@[simp] lemma coe_id : ⇑(alg_hom.id R A) = id := rfl

@[simp] lemma id_to_ring_hom : (alg_hom.id R A : A →+* A) = ring_hom.id _ := rfl

end

lemma id_apply (p : A) : alg_hom.id R A p = p := rfl

/-- Composition of algebra homeomorphisms. -/
def comp (φ₁ : B →ₐ[R] C) (φ₂ : A →ₐ[R] B) : A →ₐ[R] C :=
{ commutes' := λ r : R, by rw [← φ₁.commutes, ← φ₂.commutes]; refl,
  .. φ₁.to_ring_hom.comp ↑φ₂ }

@[simp] lemma coe_comp (φ₁ : B →ₐ[R] C) (φ₂ : A →ₐ[R] B) : ⇑(φ₁.comp φ₂) = φ₁ ∘ φ₂ := rfl

lemma comp_apply (φ₁ : B →ₐ[R] C) (φ₂ : A →ₐ[R] B) (p : A) : φ₁.comp φ₂ p = φ₁ (φ₂ p) := rfl

lemma comp_to_ring_hom (φ₁ : B →ₐ[R] C) (φ₂ : A →ₐ[R] B) :
  (φ₁.comp φ₂ : A →+* C) = (φ₁ : B →+* C).comp ↑φ₂ := rfl

@[simp] theorem comp_id : φ.comp (alg_hom.id R A) = φ :=
ext $ λ x, rfl

@[simp] theorem id_comp : (alg_hom.id R B).comp φ = φ :=
ext $ λ x, rfl

theorem comp_assoc (φ₁ : C →ₐ[R] D) (φ₂ : B →ₐ[R] C) (φ₃ : A →ₐ[R] B) :
  (φ₁.comp φ₂).comp φ₃ = φ₁.comp (φ₂.comp φ₃) :=
ext $ λ x, rfl

/-- R-Alg ⥤ R-Mod -/
def to_linear_map : A →ₗ[R] B :=
{ to_fun := φ,
  map_add' := map_add _,
  map_smul' := map_smul _ }

@[simp] lemma to_linear_map_apply (p : A) : φ.to_linear_map p = φ p := rfl

theorem to_linear_map_injective : function.injective (to_linear_map : _ → (A →ₗ[R] B)) :=
λ φ₁ φ₂ h, ext $ linear_map.congr_fun h

@[simp] lemma comp_to_linear_map (f : A →ₐ[R] B) (g : B →ₐ[R] C) :
  (g.comp f).to_linear_map = g.to_linear_map.comp f.to_linear_map := rfl

@[simp] lemma to_linear_map_id : to_linear_map (alg_hom.id R A) = linear_map.id :=
linear_map.ext $ λ _, rfl

/-- Promote a `linear_map` to an `alg_hom` by supplying proofs about the behavior on `1` and `*`. -/
@[simps]
def of_linear_map (f : A →ₗ[R] B) (map_one : f 1 = 1) (map_mul : ∀ x y, f (x * y) = f x * f y) :
  A →ₐ[R] B :=
{ to_fun := f,
  map_one' := map_one,
  map_mul' := map_mul,
  commutes' := λ c, by simp only [algebra.algebra_map_eq_smul_one, f.map_smul, map_one],
  .. f.to_add_monoid_hom }

@[simp] lemma of_linear_map_to_linear_map (map_one) (map_mul) :
  of_linear_map φ.to_linear_map map_one map_mul = φ :=
by { ext, refl }

@[simp] lemma to_linear_map_of_linear_map (f : A →ₗ[R] B) (map_one) (map_mul) :
  to_linear_map (of_linear_map f map_one map_mul) = f :=
by { ext, refl }

@[simp] lemma of_linear_map_id (map_one) (map_mul) :
  of_linear_map linear_map.id map_one map_mul = alg_hom.id R A :=
ext $ λ _, rfl

lemma map_smul_of_tower {R'} [has_smul R' A] [has_smul R' B]
  [linear_map.compatible_smul A B R' R] (r : R') (x : A) : φ (r • x) = r • φ x :=
φ.to_linear_map.map_smul_of_tower r x

lemma map_list_prod (s : list A) :
  φ s.prod = (s.map φ).prod :=
φ.to_ring_hom.map_list_prod s

@[simps mul one {attrs := []}] instance End : monoid (A →ₐ[R] A) :=
{ mul := comp,
  mul_assoc := λ ϕ ψ χ, rfl,
  one := alg_hom.id R A,
  one_mul := λ ϕ, ext $ λ x, rfl,
  mul_one := λ ϕ, ext $ λ x, rfl }

@[simp] lemma one_apply (x : A) : (1 : A →ₐ[R] A) x = x := rfl

@[simp] lemma mul_apply (φ ψ : A →ₐ[R] A) (x : A) : (φ * ψ) x = φ (ψ x) := rfl

lemma algebra_map_eq_apply (f : A →ₐ[R] B) {y : R} {x : A} (h : algebra_map R A y = x) :
  algebra_map R B y = f x :=
h ▸ (f.commutes _).symm

end semiring

section comm_semiring

variables [comm_semiring R] [comm_semiring A] [comm_semiring B]
variables [algebra R A] [algebra R B] (φ : A →ₐ[R] B)

protected lemma map_multiset_prod (s : multiset A) :
  φ s.prod = (s.map φ).prod := map_multiset_prod _ _

protected lemma map_prod {ι : Type*} (f : ι → A) (s : finset ι) :
  φ (∏ x in s, f x) = ∏ x in s, φ (f x) := map_prod _ _ _

protected lemma map_finsupp_prod {α : Type*} [has_zero α] {ι : Type*} (f : ι →₀ α) (g : ι → α → A) :
  φ (f.prod g) = f.prod (λ i a, φ (g i a)) := map_finsupp_prod _ _ _

end comm_semiring

section ring

variables [comm_semiring R] [ring A] [ring B]
variables [algebra R A] [algebra R B] (φ : A →ₐ[R] B)

protected lemma map_neg (x) : φ (-x) = -φ x := map_neg _ _
protected lemma map_sub (x y) : φ (x - y) = φ x - φ y := map_sub _ _ _

end ring

end alg_hom

namespace ring_hom
variables {R S : Type*}

/-- Reinterpret a `ring_hom` as an `ℕ`-algebra homomorphism. -/
def to_nat_alg_hom [semiring R] [semiring S] (f : R →+* S) :
  R →ₐ[ℕ] S :=
{ to_fun := f, commutes' := λ n, by simp, .. f }

/-- Reinterpret a `ring_hom` as a `ℤ`-algebra homomorphism. -/
def to_int_alg_hom [ring R] [ring S] [algebra ℤ R] [algebra ℤ S] (f : R →+* S) :
  R →ₐ[ℤ] S :=
{ commutes' := λ n, by simp, .. f }

/-- Reinterpret a `ring_hom` as a `ℚ`-algebra homomorphism. This actually yields an equivalence,
see `ring_hom.equiv_rat_alg_hom`. -/
def to_rat_alg_hom [ring R] [ring S] [algebra ℚ R] [algebra ℚ S] (f : R →+* S) :
  R →ₐ[ℚ] S :=
{ commutes' := f.map_rat_algebra_map, .. f }

@[simp]
lemma to_rat_alg_hom_to_ring_hom [ring R] [ring S] [algebra ℚ R] [algebra ℚ S]
  (f : R →+* S) : ↑f.to_rat_alg_hom = f :=
ring_hom.ext $ λ x, rfl

end ring_hom

section
variables {R S : Type*}

@[simp]
lemma alg_hom.to_ring_hom_to_rat_alg_hom [ring R] [ring S] [algebra ℚ R] [algebra ℚ S]
  (f : R →ₐ[ℚ] S) : (f : R →+* S).to_rat_alg_hom = f :=
alg_hom.ext $ λ x, rfl

/-- The equivalence between `ring_hom` and `ℚ`-algebra homomorphisms. -/
@[simps]
def ring_hom.equiv_rat_alg_hom [ring R] [ring S] [algebra ℚ R] [algebra ℚ S] :
  (R →+* S) ≃ (R →ₐ[ℚ] S) :=
{ to_fun := ring_hom.to_rat_alg_hom,
  inv_fun := alg_hom.to_ring_hom,
  left_inv := ring_hom.to_rat_alg_hom_to_ring_hom,
  right_inv := alg_hom.to_ring_hom_to_rat_alg_hom, }

end

namespace algebra
variables (R : Type u) (A : Type v)
variables [comm_semiring R] [semiring A] [algebra R A]

/-- `algebra_map` as an `alg_hom`. -/
def of_id : R →ₐ[R] A :=
{ commutes' := λ _, rfl, .. algebra_map R A }
variables {R}

theorem of_id_apply (r) : of_id R A r = algebra_map R A r := rfl

end algebra

namespace mul_semiring_action
variables {M G : Type*} (R A : Type*) [comm_semiring R] [semiring A] [algebra R A]
variables [monoid M] [mul_semiring_action M A] [smul_comm_class M R A]

/-- Each element of the monoid defines a algebra homomorphism.

This is a stronger version of `mul_semiring_action.to_ring_hom` and
`distrib_mul_action.to_linear_map`. -/
@[simps]
def to_alg_hom (m : M) : A →ₐ[R] A :=
{ to_fun := λ a, m • a,
  commutes' := smul_algebra_map _,
  ..mul_semiring_action.to_ring_hom _ _ m }

theorem to_alg_hom_injective [has_faithful_smul M A] :
  function.injective (mul_semiring_action.to_alg_hom R A : M → A →ₐ[R] A) :=
λ m₁ m₂ h, eq_of_smul_eq_smul $ λ r, alg_hom.ext_iff.1 h r

end mul_semiring_action


/-
Copyright (c) 2020 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta
-/
import category_theory.limits.shapes.equalizers
import category_theory.limits.shapes.reflexive
import category_theory.adjunction
import category_theory.monad.adjunction
import category_theory.monad.coequalizer

/-!
# Adjoint lifting

This file gives two constructions for building left adjoints: the adjoint triangle theorem and the
adjoint lifting theorem.
The adjoint triangle theorem says that given a functor `U : B ⥤ C` with a left adjoint `F` such
that `ε_X : FUX ⟶ X` is a regular epi. Then for any category `A` with coequalizers of reflexive
pairs, a functor `R : A ⥤ B` has a left adjoint if (and only if) the composite `R ⋙ U` does.
Note that the condition on `U` regarding `ε_X` is automatically satisfied in the case when `U` is
a monadic functor, giving the corollary: `monadic_adjoint_triangle_lift`, i.e. if `U` is monadic,
`A` has reflexive coequalizers then `R : A ⥤ B` has a left adjoint provided `R ⋙ U` does.

The adjoint lifting theorem says that given a commutative square of functors (up to isomorphism):

      Q
    A → B
  U ↓   ↓ V
    C → D
      R

where `U` and `V` are monadic and `A` has reflexive coequalizers, then if `R` has a left adjoint
then `Q` has a left adjoint.

## Implementation

It is more convenient to prove this theorem by assuming we are given the explicit adjunction rather
than just a functor known to be a right adjoint. In docstrings, we write `(η, ε)` for the unit
and counit of the adjunction `adj₁ : F ⊣ U` and `(ι, δ)` for the unit and counit of the adjunction
`adj₂ : F' ⊣ R ⋙ U`.

## TODO

Dualise to lift right adjoints through comonads (by reversing 1-cells) and dualise to lift right
adjoints through monads (by reversing 2-cells), and the combination.

## References
* https://ncatlab.org/nlab/show/adjoint+triangle+theorem
* https://ncatlab.org/nlab/show/adjoint+lifting+theorem
* Adjoint Lifting Theorems for Categories of Algebras (PT Johnstone, 1975)
* A unified approach to the lifting of adjoints (AJ Power, 1988)
-/

namespace category_theory

open category limits

universes v₁ v₂ v₃ v₄ u₁ u₂ u₃ u₄

variables {A : Type u₁} {B : Type u₂} {C : Type u₃}
variables [category.{v₁} A] [category.{v₂} B] [category.{v₃} C]

-- Hide implementation details in this namespace
namespace lift_adjoint

variables {U : B ⥤ C} {F : C ⥤ B} (R : A ⥤ B) (F' : C ⥤ A)
variables (adj₁ : F ⊣ U) (adj₂ : F' ⊣ R ⋙ U)

/--
To show that `ε_X` is a coequalizer for `(FUε_X, ε_FUX)`, it suffices to assume it's always a
coequalizer of something (i.e. a regular epi).
-/
def counit_coequalises [∀ (X : B), regular_epi (adj₁.counit.app X)] (X : B) :
  is_colimit (cofork.of_π (adj₁.counit.app X) (adj₁.counit_naturality _)) :=
cofork.is_colimit.mk' _ $ λ s,
begin
  refine ⟨(regular_epi.desc' (adj₁.counit.app X) s.π _).1, _, _⟩,
  { rw ← cancel_epi (adj₁.counit.app (regular_epi.W (adj₁.counit.app X))),
    rw ← adj₁.counit_naturality_assoc,
    dsimp only [functor.comp_obj],
    rw [← s.condition, ← F.map_comp_assoc, ← U.map_comp, regular_epi.w, U.map_comp,
        F.map_comp_assoc, s.condition, ← adj₁.counit_naturality_assoc] },
  { apply (regular_epi.desc' (adj₁.counit.app X) s.π _).2 },
  { intros m hm,
    rw ← cancel_epi (adj₁.counit.app X),
    apply hm.trans (regular_epi.desc' (adj₁.counit.app X) s.π _).2.symm }
end

include adj₁ adj₂

/--
(Implementation)
To construct the left adjoint, we use the coequalizer of `F' U ε_Y` with the composite

`F' U F U X ⟶ F' U F U R F U' X ⟶ F' U R F' U X ⟶ F' U X`

where the first morphism is `F' U F ι_UX`, the second is `F' U ε_RF'UX`, and the third is `δ_F'UX`.
We will show that this coequalizer exists and that it forms the object map for a left adjoint to
`R`.
-/
def other_map (X) : F'.obj (U.obj (F.obj (U.obj X))) ⟶ F'.obj (U.obj X) :=
F'.map (U.map (F.map (adj₂.unit.app _) ≫ adj₁.counit.app _)) ≫ adj₂.counit.app _

/--
`(F'Uε_X, other_map X)` is a reflexive pair: in particular if `A` has reflexive coequalizers then
it has a coequalizer.
-/
instance (X : B) :
  is_reflexive_pair (F'.map (U.map (adj₁.counit.app X))) (other_map _ _ adj₁ adj₂ X) :=
is_reflexive_pair.mk'
  (F'.map (adj₁.unit.app (U.obj X)))
  (by {rw [← F'.map_comp, adj₁.right_triangle_components], apply F'.map_id })
  begin
    dsimp [other_map],
    rw [← F'.map_comp_assoc, U.map_comp, adj₁.unit_naturality_assoc, adj₁.right_triangle_components,
        comp_id, adj₂.left_triangle_components]
  end

variables [has_reflexive_coequalizers A]

/--
Construct the object part of the desired left adjoint as the coequalizer of `F'Uε_Y` with
`other_map`.
-/
noncomputable def construct_left_adjoint_obj (Y : B) : A :=
coequalizer (F'.map (U.map (adj₁.counit.app Y))) (other_map _ _ adj₁ adj₂ Y)

/-- The homset equivalence which helps show that `R` is a right adjoint. -/
@[simps {rhs_md := semireducible}]
noncomputable
def construct_left_adjoint_equiv [∀ (X : B), regular_epi (adj₁.counit.app X)] (Y : A) (X : B) :
  (construct_left_adjoint_obj _ _ adj₁ adj₂ X ⟶ Y) ≃ (X ⟶ R.obj Y) :=
calc (construct_left_adjoint_obj _ _ adj₁ adj₂ X ⟶ Y)
        ≃ {f : F'.obj (U.obj X) ⟶ Y //
              F'.map (U.map (adj₁.counit.app X)) ≫ f = other_map _ _ adj₁ adj₂ _ ≫ f} :
                cofork.is_colimit.hom_iso (colimit.is_colimit _) _
  ... ≃ {g : U.obj X ⟶ U.obj (R.obj Y) //
          U.map (F.map g ≫ adj₁.counit.app _) = U.map (adj₁.counit.app _) ≫ g} :
            begin
              apply (adj₂.hom_equiv _ _).subtype_equiv _,
              intro f,
              rw [← (adj₂.hom_equiv _ _).injective.eq_iff, eq_comm, adj₂.hom_equiv_naturality_left,
                  other_map, assoc, adj₂.hom_equiv_naturality_left, ← adj₂.counit_naturality,
                  adj₂.hom_equiv_naturality_left, adj₂.hom_equiv_unit,
                  adj₂.right_triangle_components, comp_id, functor.comp_map, ← U.map_comp, assoc,
                  ← adj₁.counit_naturality, adj₂.hom_equiv_unit, adj₂.hom_equiv_unit, F.map_comp,
                  assoc],
              refl,
            end
  ... ≃ {z : F.obj (U.obj X) ⟶ R.obj Y // _} :
            begin
              apply (adj₁.hom_equiv _ _).symm.subtype_equiv,
              intro g,
              rw [← (adj₁.hom_equiv _ _).symm.injective.eq_iff, adj₁.hom_equiv_counit,
                  adj₁.hom_equiv_counit, adj₁.hom_equiv_counit, F.map_comp, assoc, U.map_comp,
                  F.map_comp, assoc, adj₁.counit_naturality, adj₁.counit_naturality_assoc],
              apply eq_comm,
            end
  ... ≃ (X ⟶ R.obj Y) : (cofork.is_colimit.hom_iso (counit_coequalises adj₁ X) _).symm

/-- Construct the left adjoint to `R`, with object map `construct_left_adjoint_obj`. -/
noncomputable def construct_left_adjoint [∀ (X : B), regular_epi (adj₁.counit.app X)] : B ⥤ A :=
begin
  refine adjunction.left_adjoint_of_equiv (λ X Y, construct_left_adjoint_equiv R _ adj₁ adj₂ Y X) _,
  intros X Y Y' g h,
  rw [construct_left_adjoint_equiv_apply, construct_left_adjoint_equiv_apply, function.comp_app,
      function.comp_app, equiv.trans_apply, equiv.trans_apply, equiv.trans_apply, equiv.trans_apply,
      equiv.symm_apply_eq, subtype.ext_iff, cofork.is_colimit.hom_iso_natural,
      equiv.apply_symm_apply, equiv.subtype_equiv_apply, equiv.subtype_equiv_apply,
      equiv.subtype_equiv_apply, equiv.subtype_equiv_apply, subtype.coe_mk, subtype.coe_mk,
      subtype.coe_mk, subtype.coe_mk, ← adj₁.hom_equiv_naturality_right_symm,
      cofork.is_colimit.hom_iso_natural, adj₂.hom_equiv_naturality_right, functor.comp_map],
end

end lift_adjoint

/--
The adjoint triangle theorem: Suppose `U : B ⥤ C` has a left adjoint `F` such that each counit
`ε_X : FUX ⟶ X` is a regular epimorphism. Then if a category `A` has coequalizers of reflexive
pairs, then a functor `R : A ⥤ B` has a left adjoint if the composite `R ⋙ U` does.

Note the converse is true (with weaker assumptions), by `adjunction.comp`.
See https://ncatlab.org/nlab/show/adjoint+triangle+theorem
-/
noncomputable def adjoint_triangle_lift {U : B ⥤ C} {F : C ⥤ B} (R : A ⥤ B) (adj₁ : F ⊣ U)
  [Π (X : B), regular_epi (adj₁.counit.app X)]
  [has_reflexive_coequalizers A]
  [is_right_adjoint (R ⋙ U)] : is_right_adjoint R :=
{ left := lift_adjoint.construct_left_adjoint R _ adj₁ (adjunction.of_right_adjoint _),
  adj := adjunction.adjunction_of_equiv_left _ _ }

/--
If `R ⋙ U` has a left adjoint, the domain of `R` has reflexive coequalizers and `U` is a monadic
functor, then `R` has a left adjoint.
This is a special case of `adjoint_triangle_lift` which is often more useful in practice.
-/
noncomputable def monadic_adjoint_triangle_lift (U : B ⥤ C) [monadic_right_adjoint U] {R : A ⥤ B}
  [has_reflexive_coequalizers A]
  [is_right_adjoint (R ⋙ U)] :
  is_right_adjoint R :=
begin
  let R' : A ⥤ _ := R ⋙ monad.comparison (adjunction.of_right_adjoint U),
  suffices : is_right_adjoint R',
  { let : is_right_adjoint (R' ⋙ (monad.comparison (adjunction.of_right_adjoint U)).inv),
    { resetI,
      apply_instance },
    { let : R' ⋙ (monad.comparison (adjunction.of_right_adjoint U)).inv ≅ R :=
        (iso_whisker_left R (monad.comparison _).as_equivalence.unit_iso.symm : _) ≪≫
          R.right_unitor,
      exactI adjunction.right_adjoint_of_nat_iso this } },
  let : is_right_adjoint (R' ⋙ monad.forget (adjunction.of_right_adjoint U).to_monad) :=
    adjunction.right_adjoint_of_nat_iso
      (iso_whisker_left R (monad.comparison_forget (adjunction.of_right_adjoint U)).symm : _),
  letI : Π X, regular_epi ((monad.adj (adjunction.of_right_adjoint U).to_monad).counit.app X),
  { intro X,
    dsimp only [monad.adj_counit, functor.comp_map, monad.forget_obj, functor.id_obj,
                functor.comp_obj, monad.free_obj_A],
    simp only [functor.map_id, id_comp],
    exact ⟨_, _, _, _, monad.beck_algebra_coequalizer X⟩ },
  exact adjoint_triangle_lift R' (monad.adj _),
end

variables {D : Type u₄}
variables [category.{v₄} D]

/--
Suppose we have a commutative square of functors

      Q
    A → B
  U ↓   ↓ V
    C → D
      R

where `U` has a left adjoint, `A` has reflexive coequalizers and `V` has a left adjoint such that
each component of the counit is a regular epi.
Then `Q` has a left adjoint if `R` has a left adjoint.

See https://ncatlab.org/nlab/show/adjoint+lifting+theorem
-/
noncomputable def adjoint_square_lift (Q : A ⥤ B) (V : B ⥤ D) (U : A ⥤ C) (R : C ⥤ D)
  (comm : U ⋙ R ≅ Q ⋙ V)
  [is_right_adjoint U] [is_right_adjoint V] [is_right_adjoint R]
  [∀ X, regular_epi ((adjunction.of_right_adjoint V).counit.app X)]
  [has_reflexive_coequalizers A] :
  is_right_adjoint Q :=
begin
  let := adjunction.right_adjoint_of_nat_iso comm,
  exactI adjoint_triangle_lift Q (adjunction.of_right_adjoint V),
end

/--
Suppose we have a commutative square of functors

      Q
    A → B
  U ↓   ↓ V
    C → D
      R

where `U` has a left adjoint, `A` has reflexive coequalizers and `V` is monadic.
Then `Q` has a left adjoint if `R` has a left adjoint.

See https://ncatlab.org/nlab/show/adjoint+lifting+theorem
-/
noncomputable def monadic_adjoint_square_lift (Q : A ⥤ B) (V : B ⥤ D) (U : A ⥤ C) (R : C ⥤ D)
  (comm : U ⋙ R ≅ Q ⋙ V)
  [is_right_adjoint U] [monadic_right_adjoint V] [is_right_adjoint R]
  [has_reflexive_coequalizers A] :
  is_right_adjoint Q :=
begin
  let := adjunction.right_adjoint_of_nat_iso comm,
  exactI monadic_adjoint_triangle_lift V,
end

end category_theory


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

import Std.Data.List.Lemmas

import Algdata.Init.Fin
import Algdata.Init.LawfulLT

namespace List

universe u
variable {α : Type u}

theorem get_congr {x y : List α} {i : Fin x.length} {j : Fin y.length} : x = y → i.val = j.val → get x i = get y j
| rfl, h => by rw [Fin.eq_of_val_eq h]

theorem get_congrList {x y : List α} {i : Fin x.length} : (h : x = y) → get x i = get y ⟨i.val, h▸i.isLt⟩
| rfl => rfl

theorem get_proof_irrev (x : List α) (i : Fin x.length) (h : i.val < x.length) : x.get i = x.get ⟨i.val, h⟩ :=
  get_congr rfl rfl

theorem get_head (a : α) (as : List α) : ∀ {i : Fin (a::as).length}, i.val = 0 → (a::as).get i = a
| Fin.mk i hi, h => by cases h; rfl

theorem get_tail (a : α) (as : List α) : ∀ {i : Fin (a::as).length} (hpos : i.val > 0), (a::as).get i = as.get (i.pred hpos)
| Fin.mk 0 _, hpos => (Nat.not_lt_zero _ hpos).elim
| Fin.mk (k+1) hk, hpos => by
  rw [get, Fin.pred]
  apply get_congr rfl _
  simp

theorem get_set_on : ∀ (x : List α) (i : Nat) (v : α) (j : Fin (x.set i v).length), i = j.val → get (x.set i v) j = v
| [], _, _, Fin.mk _ hk, _ => (Nat.not_lt_zero _ hk).elim
| (a::as), 0, v, Fin.mk 0 _, _ => rfl
| (a::as), 0, v, Fin.mk (k+1) hk, h => (Nat.succ_ne_zero _ h.symm).elim
| (a::as), (i+1), v, Fin.mk 0 _, h => (Nat.succ_ne_zero _ h).elim
| (a::as), (i+1), v, Fin.mk (k+1) hk, h => by
  have hset : set (a::as) i.succ v = a::(as.set i v) := rfl
  rw [get_congr hset rfl, get]
  rw [get_set_on as]
  exact Nat.succ.inj h

theorem get_set_off : ∀ (x : List α) (i : Nat) (v : α) (j : Fin (x.set i v).length), i ≠ j.val → get (x.set i v) j = get x ⟨j.val, x.length_set i v ▸ j.isLt⟩
| [], _, _, Fin.mk _ hk, _ => (Nat.not_lt_zero _ hk).elim
| (a::as), 0, v, Fin.mk 0 _, h => (h rfl).elim
| (a::as), 0, v, Fin.mk (k+1) hk, _ => by
  have : set (a::as) 0 v = v::as := rfl
  rw [get_congr this rfl, get, get]
| (a::as), (i+1), v, Fin.mk 0 _, _ => by
  have : set (a::as) (i+1) v = a :: set as i v := rfl
  rw [get_congr this rfl, get, get]
| (a::as), (i+1), v, Fin.mk (k+1) hk, h => by
  have : set (a::as) (i+1) v = a :: set as i v := rfl
  rw [get_congr this rfl, get, get]
  rw [get_set_off as i v ⟨k,_⟩ (h ∘ congrArg Nat.succ)]

theorem foldl_comm {α β : Type _} {f : α → β → α} {g : α → α} : (∀ a b, f (g a) b = g (f a b)) → ∀ {init : α} {bs : List β}, bs.foldl f (g init) = g (bs.foldl f init) := by
  intro hfg init bs
  revert init; induction bs
  case nil => exact λ {_} => rfl
  case cons b bs h_ind =>
    intro init
    dsimp [foldl]
    rw [hfg init b, h_ind (init:=f init b)]

theorem comp_map {α β γ : Type _} (f : α → β) (g : β → γ) : ∀ (as : List α), as.map (g ∘ f) = (as.map f).map g
| [] => rfl
| (a::as) => by unfold map; rw [comp_map f g as]; rfl

theorem comp_filterMap {α β γ : Type _} (f : α → β) (g : β → Option γ) : ∀ (as : List α), as.filterMap (g ∘ f) = (as.map f).filterMap g
| [] => rfl
| (a::as) => by
  unfold map; unfold filterMap
  rw [comp_filterMap f g as]
  rfl

theorem zipWith_nil_first {β γ : Type _} (f : α → β → γ) : ∀ (x : List β), List.zipWith f [] x = []
| [] => rfl
| (_::_) => rfl

theorem zipWith_nil_second {β γ : Type _} (f : α → β → γ) : ∀ (x : List α), List.zipWith f x [] = []
| [] => rfl
| (_::_) => rfl

theorem reverseAux_append_left {α : Type _} {as₁ as₂ bs : List α} : reverseAux (as₁ ++ as₂) bs = as₂.reverse ++ reverseAux as₁ bs := by
  revert bs; induction as₁ <;> intro bs
  case nil => rw [reverseAux_eq_append]; rfl
  case cons a₁ as₁ h_ind =>
    rw [cons_append]
    unfold reverseAux
    rw [h_ind]

theorem bind_congr {α β : Type _} : ∀ {as₁ as₂ : List α} {f₁ f₂ : α → List β}, as₁ = as₂ → (∀ a, f₁ a = f₂ a) → as₁.bind f₁ = as₂.bind f₂
| as, _, _, _, rfl, h =>
  congrArg (as.bind) (funext h)

theorem bind_map_binary_eq_map_bind_map {α β γ : Type _} (f : α → β → γ) (as : List α) (bs : List β) : as.bind (fun a => bs.map (f a)) = (as.map f).bind bs.map := by
  induction as with
  | nil => rfl
  | cons a as hi =>
    rw [cons_bind, map, cons_bind]
    rw [hi]

--- Lexicographical lift of relations
protected
inductive lex {α : Type _} (r : α → α → Prop) : List α → List α → Prop
| nil : (a : α) → (as : List α) → List.lex r [] (a::as)
| head {a b : α} {as bs : List α} : r a b → List.lex r (a::as) (b::bs)
| tail {a : α} {as bs : List α} : List.lex r as bs → List.lex r (a::as) (a::bs)

namespace lex

variable {α : Type _} {r : α → α → Prop}

protected
theorem trans [Trans r r r] : {as bs cs : List α} → List.lex r as bs → List.lex r bs cs → List.lex r as cs
| [], (_::_), (_::_), List.lex.nil _ _, List.lex.head _ => List.lex.nil _ _
| [], (_::_), (_::_), List.lex.nil _ _, List.lex.tail _ => List.lex.nil _ _
| (_::_), (_::_), (_::_), List.lex.head hab, List.lex.head hbc => List.lex.head (trans hab hbc)
| (_::_), (_::_), (_::_), List.lex.head hab, List.lex.tail _ => List.lex.head hab
| (_::_), (_::_), (_::_), List.lex.tail _, List.lex.head hbc => List.lex.head hbc
| (_::_), (_::_), (_::_), List.lex.tail hab, List.lex.tail hbc => List.lex.tail (List.lex.trans hab hbc)

protected
theorem irrefl [Irreflective r] : ∀ (as : List α), ¬ List.lex r as as
| (_::_), List.lex.head h => absurd h (Irreflective.irrefl _)
| (_::_), List.lex.tail h => List.lex.irrefl _ h

protected
theorem asymm [Asymmetry r] : ∀ (as bs : List α), List.lex r as bs → ¬ List.lex r bs as
| (_::_), (_::_), List.lex.head hab, List.lex.head hba =>
  Asymmetry.asymm _ _ hab hba
| (_::_), (_::_), List.lex.head hab, List.lex.tail _ =>
  Asymmetry.asymm _ _ hab hab
| (_::_), (_::_), List.lex.tail _, List.lex.head hba =>
  Asymmetry.asymm _ _ hba hba
| (_::_), (_::_), List.lex.tail hab, List.lex.tail hba =>
  List.lex.asymm _ _ hab hba

protected
theorem trichot [Trichotomous r] : ∀ (as bs : List α), as = bs ∨ List.lex r as bs ∨ List.lex r bs as
| [], [] => Or.inl rfl
| [], (_::_) => Or.inr $ Or.inl $ List.lex.nil _ _
| (_::_), [] => Or.inr $ Or.inr $ List.lex.nil _ _
| (a::as), (b::bs) =>
  trichotCasesOn r a b
    (λ a h_ind =>
      Or.map (congrArg (List.cons a)) (Or.map List.lex.tail List.lex.tail) h_ind
    )
    (λ _ _ h _ => Or.inr $ Or.inl $ List.lex.head h)
    (λ _ _ h _ => Or.inr $ Or.inr $ List.lex.head h)
    (List.lex.trichot as bs)

instance instTransListLex [Trans r r r] : Trans (List.lex r) (List.lex r) (List.lex r) where
  trans := List.lex.trans

instance instIrreflectiveListLex [Irreflective r] : Irreflective (List.lex r) where
  irrefl := List.lex.irrefl

instance instAsymmetryListLex [Asymmetry r] : Asymmetry (List.lex r) where
  asymm := List.lex.asymm

instance instTrichotomousListLex [Trichotomous r] : Trichotomous (List.lex r) where
  trichot := List.lex.trichot

instance instDecidableRelListLex [DecidableEq α] [DecidableRel r] : DecidableRel (List.lex r)
| [], [] => isFalse $ λ hcontra => by cases hcontra
| (a::as), [] => isFalse $ λ hcontra => by cases hcontra
| [], (b::bs) => isTrue $ List.lex.nil _ _
| (a::as), (b::bs) =>
  if hab : r a b then
    isTrue $ List.lex.head hab
  else if heq : a = b then
    match instDecidableRelListLex as bs with
    | isTrue htail => isTrue $ heq ▸ List.lex.tail htail
    | isFalse htail => isFalse $ by
      cases heq; intro hcontra; cases hcontra <;> contradiction
  else
    isFalse $ λ hcontra => by
      cases hcontra <;> contradiction

end lex

end List


import .logging

universe u

/- Checks if applying a tactic will succeed without actually applying it -/
meta def tactic.will_succeed {α : Type u} (t : tactic α) : tactic bool :=
  λ ts,
    let b :=
      match t ts with
      | (result.success _ _) := tt
      | (result.exception _ _ _) := ff
      end
    in result.success b ts

/-
Add arguments to `add_args_type` so it unifies with `fixed_type`
Returns `some n` if unifiable after putting in `n` arguments
Returns `none` if fails to unify
-/
meta def unify_with_args : expr → expr → tactic (option ℕ) := λ fixed_type add_args_type, do
  can_unify ← tactic.will_succeed $ tactic.unify fixed_type add_args_type,
  if can_unify then
    return (some 0)
  else
    match add_args_type with
    | (expr.pi arg_name _ arg_type body) := do
        arg_mvar ← tactic.mk_meta_var arg_type,
        let substituted_expr := body.instantiate_var arg_mvar,
        recur_result ← unify_with_args fixed_type substituted_expr,
        return $ match recur_result with
        | some n := some (n + 1)
        | none := none
        end
    | _ := return none
    end

@[hole_command]
meta def any_value_that_fits : hole_command :=
{ name   := "Anything",
  descr  := "Insert any value that, when inserted, typechecks",
  action := λ _, do
    tar ← tactic.target,
    env ← tactic.get_env,
    ans ← env.fold (return []) $ λ decl accum, (do
      accum_result ← accum,
      unify_with_args_result ← unify_with_args tar decl.type,
      return $
        match unify_with_args_result with
        | some n := ("(" ++ decl.to_name.to_string ++ string.join (list.repeat " {! !}" n) ++ ")", "") :: accum_result
        | none := accum_result
        end
    ),
    log $ string.intercalate "\n" $ ans.map to_string,
    return ans
}

-- Applying hole command inserts `(unsigned_sz)`, which is a ℕ
example := 1 + {! !}

inductive MyType : ℕ → ℕ → Type
| constr : ∀ x y : ℕ, MyType x y

-- Applying hole command should insert `(MyType.constr {! !} {! !})`
-- Doesn't work yet
example : MyType 1 2 := {! !}

-- Doesn't work yet
example (x y z : ℕ) : ((x + y) + z = x + (y + z)) := {! !}

-- Doesn't work yet
example (α : Type u) (x : α) : α := {! !}


/-
Copyright (c) 2021 Yaël Dillies. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies, Scott Morrison

! This file was ported from Lean 3 source module data.finset.functor
! leanprover-community/mathlib commit f16e7a22e11fc09c71f25446ac1db23a24e8a0bd
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Data.Finset.Lattice
import Mathbin.Data.Finset.NAry
import Mathbin.Data.Multiset.Functor

/-!
# Functoriality of `finset`

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

This file defines the functor structure of `finset`.

## TODO

Currently, all instances are classical because the functor classes want to run over all types. If
instead we could state that a functor is lawful/applicative/traversable... between two given types,
then we could provide the instances for types with decidable equality.
-/

universe u

open Function

namespace Finset

/-! ### Functor -/

section Functor

variable {α β : Type u} [∀ P, Decidable P]

/-- Because `finset.image` requires a `decidable_eq` instance for the target type, we can only
construct `functor finset` when working classically. -/
instance : Functor Finset where map α β f s := s.image f

instance : LawfulFunctor Finset where
  id_map α s := image_id
  comp_map α β γ f g s := image_image.symm

#print Finset.fmap_def /-
@[simp]
theorem fmap_def {s : Finset α} (f : α → β) : f <$> s = s.image f :=
  rfl
#align finset.fmap_def Finset.fmap_def
-/

end Functor

/-! ### Pure -/

instance : Pure Finset :=
  ⟨fun α x => {x}⟩

#print Finset.pure_def /-
@[simp]
theorem pure_def {α} : (pure : α → Finset α) = singleton :=
  rfl
#align finset.pure_def Finset.pure_def
-/

/-! ### Applicative functor -/

section Applicative

variable {α β : Type u} [∀ P, Decidable P]

instance : Applicative Finset :=
  { Finset.functor,
    Finset.hasPure with
    seq := fun α β t s => t.sup fun f => s.image f
    seqLeft := fun α β s t => if t = ∅ then ∅ else s
    seqRight := fun α β s t => if s = ∅ then ∅ else t }

#print Finset.seq_def /-
@[simp]
theorem seq_def (s : Finset α) (t : Finset (α → β)) : t <*> s = t.sup fun f => s.image f :=
  rfl
#align finset.seq_def Finset.seq_def
-/

#print Finset.seqLeft_def /-
@[simp]
theorem seqLeft_def (s : Finset α) (t : Finset β) : s <* t = if t = ∅ then ∅ else s :=
  rfl
#align finset.seq_left_def Finset.seqLeft_def
-/

#print Finset.seqRight_def /-
@[simp]
theorem seqRight_def (s : Finset α) (t : Finset β) : s *> t = if s = ∅ then ∅ else t :=
  rfl
#align finset.seq_right_def Finset.seqRight_def
-/

#print Finset.image₂_def /-
/-- `finset.image₂` in terms of monadic operations. Note that this can't be taken as the definition
because of the lack of universe polymorphism. -/
theorem image₂_def {α β γ : Type _} (f : α → β → γ) (s : Finset α) (t : Finset β) :
    image₂ f s t = f <$> s <*> t := by
  ext
  simp [mem_sup]
#align finset.image₂_def Finset.image₂_def
-/

instance : LawfulApplicative Finset :=
  {
    Finset.lawfulFunctor with
    seqLeft_eq := fun α β s t => by
      rw [seq_def, fmap_def, seq_left_def]
      obtain rfl | ht := t.eq_empty_or_nonempty
      · simp_rw [if_pos rfl, image_empty]
        exact (sup_bot _).symm
      · ext a
        rw [if_neg ht.ne_empty, mem_sup]
        refine' ⟨fun ha => ⟨const β a, mem_image_of_mem _ ha, mem_image_const_self.2 ht⟩, _⟩
        rintro ⟨f, hf, ha⟩
        rw [mem_image] at hf ha
        obtain ⟨b, hb, rfl⟩ := hf
        obtain ⟨_, _, rfl⟩ := ha
        exact hb
    seqRight_eq := fun α β s t =>
      by
      rw [seq_def, fmap_def, seq_right_def]
      obtain rfl | hs := s.eq_empty_or_nonempty
      · rw [if_pos rfl, image_empty, sup_empty, bot_eq_empty]
      · ext a
        rw [if_neg hs.ne_empty, mem_sup]
        refine' ⟨fun ha => ⟨id, mem_image_const_self.2 hs, by rwa [image_id]⟩, _⟩
        rintro ⟨f, hf, ha⟩
        rw [mem_image] at hf ha
        obtain ⟨b, hb, rfl⟩ := ha
        obtain ⟨_, _, rfl⟩ := hf
        exact hb
    pure_seq := fun α β f s => sup_singleton
    map_pure := fun α β f a => image_singleton _ _
    seq_pure := fun α β s a => sup_singleton'' _ _
    seq_assoc := fun α β γ s t u => by
      ext a
      simp_rw [seq_def, fmap_def]
      simp only [exists_prop, mem_sup, mem_image]
      constructor
      · rintro ⟨g, hg, b, ⟨f, hf, a, ha, rfl⟩, rfl⟩
        exact ⟨g ∘ f, ⟨comp g, ⟨g, hg, rfl⟩, f, hf, rfl⟩, a, ha, rfl⟩
      · rintro ⟨c, ⟨_, ⟨g, hg, rfl⟩, f, hf, rfl⟩, a, ha, rfl⟩
        exact ⟨g, hg, f a, ⟨f, hf, a, ha, rfl⟩, rfl⟩ }

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
instance : CommApplicative Finset :=
  { Finset.lawfulApplicative with
    commutative_prod := fun α β s t =>
      by
      simp_rw [seq_def, fmap_def, sup_image, sup_eq_bUnion]
      change (s.bUnion fun a => t.image fun b => (a, b)) = t.bUnion fun b => s.image fun a => (a, b)
      trans s ×ˢ t <;> [rw [product_eq_bUnion], rw [product_eq_bUnion_right]] <;> congr <;> ext <;>
        simp_rw [mem_image] }

end Applicative

/-! ### Monad -/

section Monad

variable [∀ P, Decidable P]

instance : Monad Finset :=
  { Finset.applicative with bind := fun α β => @sup _ _ _ _ }

/- warning: finset.bind_def -> Finset.bind_def is a dubious translation:
lean 3 declaration is
  forall [_inst_1 : forall (P : Prop), Decidable P] {α : Type.{u1}} {β : Type.{u1}}, Eq.{succ u1} ((Finset.{u1} β) -> (β -> (Finset.{u1} α)) -> (Finset.{u1} α)) (Bind.bind.{u1, u1} Finset.{u1} (Monad.toHasBind.{u1, u1} Finset.{u1} (Finset.monad.{u1} (fun (P : Prop) => _inst_1 P))) β α) (Finset.sup.{u1, u1} (Finset.{u1} α) β (Lattice.toSemilatticeSup.{u1} (Finset.{u1} α) (Finset.lattice.{u1} α (fun (a : α) (b : α) => _inst_1 (Eq.{succ u1} α a b)))) (Finset.orderBot.{u1} α))
but is expected to have type
  forall [_inst_1 : forall (P : Prop), Decidable P] {α : Type.{u1}} {β : Type.{u1}}, Eq.{succ u1} ((Finset.{u1} β) -> (β -> (Finset.{u1} α)) -> (Finset.{u1} α)) (fun (x._@.Mathlib.Data.Finset.Functor._hyg.1288 : Finset.{u1} β) (x._@.Mathlib.Data.Finset.Functor._hyg.1290 : β -> (Finset.{u1} α)) => Bind.bind.{u1, u1} Finset.{u1} (Monad.toBind.{u1, u1} Finset.{u1} (Finset.instMonadFinset.{u1} (fun (P : Prop) => _inst_1 P))) β α x._@.Mathlib.Data.Finset.Functor._hyg.1288 x._@.Mathlib.Data.Finset.Functor._hyg.1290) (Finset.sup.{u1, u1} (Finset.{u1} α) β (Lattice.toSemilatticeSup.{u1} (Finset.{u1} α) (Finset.instLatticeFinset.{u1} α (fun (a : α) (b : α) => _inst_1 (Eq.{succ u1} α a b)))) (Finset.instOrderBotFinsetToLEToPreorderPartialOrder.{u1} α))
Case conversion may be inaccurate. Consider using '#align finset.bind_def Finset.bind_defₓ'. -/
@[simp]
theorem bind_def {α β} : (· >>= ·) = @sup (Finset α) β _ _ :=
  rfl
#align finset.bind_def Finset.bind_def

instance : LawfulMonad Finset :=
  {
    Finset.lawfulApplicative with
    bind_pure_comp_eq_map := fun α β f s => sup_singleton'' _ _
    bind_map_eq_seq := fun α β t s => rfl
    pure_bind := fun α β t s => sup_singleton
    bind_assoc := fun α β γ s f g => by
      convert sup_bUnion _ _
      exact sup_eq_bUnion _ _ }

end Monad

/-! ### Alternative functor -/

section Alternative

variable [∀ P, Decidable P]

instance : Alternative Finset :=
  { Finset.applicative with
    orelse := fun α => (· ∪ ·)
    failure := fun α => ∅ }

end Alternative

/-! ### Traversable functor -/

section Traversable

variable {α β γ : Type u} {F G : Type u → Type u} [Applicative F] [Applicative G]
  [CommApplicative F] [CommApplicative G]

#print Finset.traverse /-
/-- Traverse function for `finset`. -/
def traverse [DecidableEq β] (f : α → F β) (s : Finset α) : F (Finset β) :=
  Multiset.toFinset <$> Multiset.traverse f s.1
#align finset.traverse Finset.traverse
-/

/- warning: finset.id_traverse -> Finset.id_traverse is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} [_inst_5 : DecidableEq.{succ u1} α] (s : Finset.{u1} α), Eq.{succ u1} (id.{succ (succ u1)} Type.{u1} (Finset.{u1} α)) (Finset.traverse.{u1} α α (id.{succ (succ u1)} Type.{u1}) (Monad.toApplicative.{u1, u1} (id.{succ (succ u1)} Type.{u1}) id.monad.{u1}) id.commApplicative.{u1} (fun (a : α) (b : α) => _inst_5 a b) (id.mk.{succ u1} α) s) s
but is expected to have type
  forall {α : Type.{u1}} [_inst_5 : DecidableEq.{succ u1} α] (s : Finset.{u1} α), Eq.{succ u1} (Id.{u1} (Finset.{u1} α)) (Finset.traverse.{u1} α α Id.{u1} (Monad.toApplicative.{u1, u1} Id.{u1} Id.instMonadId.{u1}) instCommApplicativeIdToApplicativeInstMonadId.{u1} (fun (a : α) (b : α) => _inst_5 a b) (Pure.pure.{u1, u1} Id.{u1} (Applicative.toPure.{u1, u1} Id.{u1} (Monad.toApplicative.{u1, u1} Id.{u1} Id.instMonadId.{u1})) α) s) s
Case conversion may be inaccurate. Consider using '#align finset.id_traverse Finset.id_traverseₓ'. -/
@[simp]
theorem id_traverse [DecidableEq α] (s : Finset α) : traverse id.mk s = s :=
  by
  rw [traverse, Multiset.id_traverse]
  exact s.val_to_finset
#align finset.id_traverse Finset.id_traverse

open Classical

#print Finset.map_comp_coe /-
@[simp]
theorem map_comp_coe (h : α → β) :
    Functor.map h ∘ Multiset.toFinset = Multiset.toFinset ∘ Functor.map h :=
  funext fun s => image_toFinset
#align finset.map_comp_coe Finset.map_comp_coe
-/

#print Finset.map_traverse /-
theorem map_traverse (g : α → G β) (h : β → γ) (s : Finset α) :
    Functor.map h <$> traverse g s = traverse (Functor.map h ∘ g) s :=
  by
  unfold traverse
  simp only [map_comp_coe, functor_norm]
  rw [LawfulFunctor.comp_map, Multiset.map_traverse]
#align finset.map_traverse Finset.map_traverse
-/

end Traversable

end Finset


/-
Copyright (c) 2019 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau, Johan Commelin
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.equiv.functor
import Mathlib.data.mv_polynomial.equiv
import Mathlib.data.mv_polynomial.comm_ring
import Mathlib.ring_theory.free_ring
import Mathlib.PostPort

universes u v u_1 u_2

namespace Mathlib

/-!
# Free commutative rings

The theory of the free commutative ring generated by a type `α`.
It is isomorphic to the polynomial ring over ℤ with variables
in `α`

## Main definitions

* `free_comm_ring α`     : the free commutative ring on a type α
* `lift_hom (f : α → R)` : the ring hom `free_comm_ring α →+* R` induced by functoriality from `f`.
* `map (f : α → β)`      : the ring hom `free_comm_ring α →*+ free_comm_ring β` induced by
                           functoriality from f.

## Main results

`free_comm_ring` has functorial properties (it is an adjoint to the forgetful functor).
In this file we have:

* `of : α → free_comm_ring α`
* `lift_hom (f : α → R) : free_comm_ring α →+* R`
* `map (f : α → β) : free_comm_ring α →+* free_comm_ring β`

* `free_comm_ring_equiv_mv_polynomial_int : free_comm_ring α ≃+* mv_polynomial α ℤ` :
    `free_comm_ring α` is isomorphic to a polynomial ring.

## Implementation notes

`free_comm_ring α` is implemented not using `mv_polynomial` but
directly as the free abelian group on `multiset α`, the type
of monomials in this free commutative ring.

## Tags

free commutative ring, free ring
-/

/-- `free_comm_ring α` is the free commutative ring on the type `α`. -/
def free_comm_ring (α : Type u) :=
  free_abelian_group (multiplicative (multiset α))

namespace free_comm_ring

/-- The structure of a commutative ring on `free_comm_ring α`. -/
protected instance comm_ring (α : Type u) : comm_ring (free_comm_ring α) :=
  free_abelian_group.comm_ring (multiplicative (multiset α))

protected instance inhabited (α : Type u) : Inhabited (free_comm_ring α) :=
  { default := 0 }

/-- The canonical map from `α` to the free commutative ring on `α`. -/
def of {α : Type u} (x : α) : free_comm_ring α :=
  free_abelian_group.of ↑[x]

theorem of_injective {α : Type u} : function.injective of :=
  function.injective.comp free_abelian_group.of_injective
    fun (x y : α) => iff.mp (iff.trans multiset.coe_eq_coe list.singleton_perm_singleton)

protected theorem induction_on {α : Type u} {C : free_comm_ring α → Prop} (z : free_comm_ring α) (hn1 : C (-1)) (hb : ∀ (b : α), C (of b)) (ha : ∀ (x y : free_comm_ring α), C x → C y → C (x + y)) (hm : ∀ (x y : free_comm_ring α), C x → C y → C (x * y)) : C z := sorry

/-- Lift a map `α → R` to a additive group homomorphism `free_comm_ring α → R`.
For a version producing a bundled homomorphism, see `lift_hom`. -/
def lift {α : Type u} {R : Type v} [comm_ring R] (f : α → R) : free_comm_ring α →+* R :=
  ring_hom.mk
    (add_monoid_hom.to_fun
      (free_abelian_group.lift
        fun (s : multiplicative (multiset α)) => multiset.prod (multiset.map f (coe_fn multiplicative.to_add s))))
    sorry sorry sorry sorry

@[simp] theorem lift_of {α : Type u} {R : Type v} [comm_ring R] (f : α → R) (x : α) : coe_fn (lift f) (of x) = f x := sorry

@[simp] theorem lift_comp_of {α : Type u} {R : Type v} [comm_ring R] (f : free_comm_ring α →+* R) : lift (⇑f ∘ of) = f := sorry

/-- A map `f : α → β` produces a ring homomorphism `free_comm_ring α →+* free_comm_ring β`. -/
def map {α : Type u} {β : Type v} (f : α → β) : free_comm_ring α →+* free_comm_ring β :=
  lift (of ∘ f)

@[simp] theorem map_of {α : Type u} {β : Type v} (f : α → β) (x : α) : coe_fn (map f) (of x) = of (f x) :=
  lift_of (of ∘ f) x

/-- `is_supported x s` means that all monomials showing up in `x` have variables in `s`. -/
def is_supported {α : Type u} (x : free_comm_ring α) (s : set α) :=
  x ∈ ring.closure (of '' s)

theorem is_supported_upwards {α : Type u} {x : free_comm_ring α} {s : set α} {t : set α} (hs : is_supported x s) (hst : s ⊆ t) : is_supported x t :=
  ring.closure_mono (set.monotone_image hst) hs

theorem is_supported_add {α : Type u} {x : free_comm_ring α} {y : free_comm_ring α} {s : set α} (hxs : is_supported x s) (hys : is_supported y s) : is_supported (x + y) s :=
  is_add_submonoid.add_mem hxs hys

theorem is_supported_neg {α : Type u} {x : free_comm_ring α} {s : set α} (hxs : is_supported x s) : is_supported (-x) s :=
  is_add_subgroup.neg_mem hxs

theorem is_supported_sub {α : Type u} {x : free_comm_ring α} {y : free_comm_ring α} {s : set α} (hxs : is_supported x s) (hys : is_supported y s) : is_supported (x - y) s :=
  is_add_subgroup.sub_mem hxs hys

theorem is_supported_mul {α : Type u} {x : free_comm_ring α} {y : free_comm_ring α} {s : set α} (hxs : is_supported x s) (hys : is_supported y s) : is_supported (x * y) s :=
  is_submonoid.mul_mem hxs hys

theorem is_supported_zero {α : Type u} {s : set α} : is_supported 0 s :=
  is_add_submonoid.zero_mem

theorem is_supported_one {α : Type u} {s : set α} : is_supported 1 s :=
  is_submonoid.one_mem

theorem is_supported_int {α : Type u} {i : ℤ} {s : set α} : is_supported (↑i) s := sorry

/-- The restriction map from `free_comm_ring α` to `free_comm_ring s` where `s : set α`, defined
  by sending all variables not in `s` to zero. -/
def restriction {α : Type u} (s : set α) [decidable_pred s] : free_comm_ring α →+* free_comm_ring ↥s :=
  lift fun (p : α) => dite (p ∈ s) (fun (H : p ∈ s) => of { val := p, property := H }) fun (H : ¬p ∈ s) => 0

@[simp] theorem restriction_of {α : Type u} (s : set α) [decidable_pred s] (p : α) : coe_fn (restriction s) (of p) = dite (p ∈ s) (fun (H : p ∈ s) => of { val := p, property := H }) fun (H : ¬p ∈ s) => 0 :=
  lift_of (fun (p : α) => dite (p ∈ s) (fun (H : p ∈ s) => of { val := p, property := H }) fun (H : ¬p ∈ s) => 0) p

theorem is_supported_of {α : Type u} {p : α} {s : set α} : is_supported (of p) s ↔ p ∈ s := sorry

theorem map_subtype_val_restriction {α : Type u} {x : free_comm_ring α} (s : set α) [decidable_pred s] (hxs : is_supported x s) : coe_fn (map subtype.val) (coe_fn (restriction s) x) = x := sorry

theorem exists_finite_support {α : Type u} (x : free_comm_ring α) : ∃ (s : set α), set.finite s ∧ is_supported x s := sorry

theorem exists_finset_support {α : Type u} (x : free_comm_ring α) : ∃ (s : finset α), is_supported x ↑s := sorry

end free_comm_ring

namespace free_ring

/-- The canonical ring homomorphism from the free ring generated by `α` to the free commutative ring
    generated by `α`. -/
def to_free_comm_ring {α : Type u_1} : free_ring α →+* free_comm_ring α :=
  lift free_comm_ring.of

protected instance free_comm_ring.has_coe (α : Type u) : has_coe (free_ring α) (free_comm_ring α) :=
  has_coe.mk ⇑to_free_comm_ring

protected instance coe.is_ring_hom (α : Type u) : is_ring_hom coe :=
  ring_hom.is_ring_hom to_free_comm_ring

@[simp] protected theorem coe_zero (α : Type u) : ↑0 = 0 :=
  rfl

@[simp] protected theorem coe_one (α : Type u) : ↑1 = 1 :=
  rfl

@[simp] protected theorem coe_of {α : Type u} (a : α) : ↑(of a) = free_comm_ring.of a :=
  lift_of free_comm_ring.of a

@[simp] protected theorem coe_neg {α : Type u} (x : free_ring α) : ↑(-x) = -↑x :=
  ring_hom.map_neg (lift free_comm_ring.of) x

@[simp] protected theorem coe_add {α : Type u} (x : free_ring α) (y : free_ring α) : ↑(x + y) = ↑x + ↑y :=
  ring_hom.map_add (lift free_comm_ring.of) x y

@[simp] protected theorem coe_sub {α : Type u} (x : free_ring α) (y : free_ring α) : ↑(x - y) = ↑x - ↑y :=
  ring_hom.map_sub (lift free_comm_ring.of) x y

@[simp] protected theorem coe_mul {α : Type u} (x : free_ring α) (y : free_ring α) : ↑(x * y) = ↑x * ↑y :=
  ring_hom.map_mul (lift free_comm_ring.of) x y

protected theorem coe_surjective (α : Type u) : function.surjective coe := sorry

theorem coe_eq (α : Type u) : coe = Functor.map fun (l : List α) => ↑l := sorry

-- FIXME This was in `deprecated.ring`, but only used here.

-- It would be good to inline it into the next construction.

/-- Interpret an equivalence `f : R ≃ S` as a ring equivalence `R ≃+* S`. -/
def of' {R : Type u_1} {S : Type u_2} [ring R] [ring S] (e : R ≃ S) [is_ring_hom ⇑e] : R ≃+* S :=
  ring_equiv.mk (equiv.to_fun e) (equiv.inv_fun e) (equiv.left_inv e) (equiv.right_inv e) sorry sorry

/-- If α has size at most 1 then the natural map from the free ring on `α` to the
    free commutative ring on `α` is an isomorphism of rings. -/
def subsingleton_equiv_free_comm_ring (α : Type u) [subsingleton α] : free_ring α ≃+* free_comm_ring α :=
  of' (functor.map_equiv free_abelian_group (multiset.subsingleton_equiv α))

protected instance comm_ring (α : Type u) [subsingleton α] : comm_ring (free_ring α) :=
  comm_ring.mk ring.add sorry ring.zero sorry sorry ring.neg ring.sub sorry sorry ring.mul sorry ring.one sorry sorry
    sorry sorry sorry

end free_ring

/-- The free commutative ring on `α` is isomorphic to the polynomial ring over ℤ with
    variables in `α` -/
def free_comm_ring_equiv_mv_polynomial_int (α : Type u) : free_comm_ring α ≃+* mv_polynomial α ℤ :=
  ring_equiv.mk (⇑(free_comm_ring.lift fun (a : α) => mv_polynomial.X a))
    (mv_polynomial.eval₂ (int.cast_ring_hom (free_comm_ring α)) free_comm_ring.of) sorry sorry sorry sorry

/-- The free commutative ring on the empty type is isomorphic to `ℤ`. -/
def free_comm_ring_pempty_equiv_int : free_comm_ring pempty ≃+* ℤ :=
  ring_equiv.trans (free_comm_ring_equiv_mv_polynomial_int pempty) (mv_polynomial.pempty_ring_equiv ℤ)

/-- The free commutative ring on a type with one term is isomorphic to `ℤ[X]`. -/
def free_comm_ring_punit_equiv_polynomial_int : free_comm_ring PUnit ≃+* polynomial ℤ :=
  ring_equiv.trans (free_comm_ring_equiv_mv_polynomial_int PUnit) (mv_polynomial.punit_ring_equiv ℤ)

/-- The free ring on the empty type is isomorphic to `ℤ`. -/
def free_ring_pempty_equiv_int : free_ring pempty ≃+* ℤ :=
  ring_equiv.trans (free_ring.subsingleton_equiv_free_comm_ring pempty) free_comm_ring_pempty_equiv_int

/-- The free ring on a type with one term is isomorphic to `ℤ[X]`. -/
def free_ring_punit_equiv_polynomial_int : free_ring PUnit ≃+* polynomial ℤ :=
  ring_equiv.trans (free_ring.subsingleton_equiv_free_comm_ring PUnit) free_comm_ring_punit_equiv_polynomial_int


-- import category_theory.limits.terminal
-- import category_theory.tactics.obviously

-- open category_theory

-- universes u v

-- namespace category_theory.limits

-- variables {C : Type u} [𝒞 : category.{u v} C]
-- include 𝒞

-- structure is_zero (t : C) :=
-- (lift : ∀ (s : C), s ⟶ t)
-- (uniq_lift' : ∀ (s : C) (m : s ⟶ t), m = lift s . obviously)
-- (desc : ∀ (s : C), t ⟶ s)
-- (uniq_desc' : ∀ (s : C) (m : t ⟶ s), m = desc s . obviously)

-- namespace is_zero
-- def to_is_initial  {t : C} (Z : is_zero.{u v} t) : is_initial.{u v} t  := { desc := Z.desc, uniq' := Z.uniq_desc' }
-- def to_is_terminal {t : C} (Z : is_zero.{u v} t) : is_terminal.{u v} t := { lift := Z.lift, uniq' := Z.uniq_lift' }
-- end is_zero

-- restate_axiom is_zero.uniq_lift'
-- restate_axiom is_zero.uniq_desc'
-- attribute [search,elim] is_zero.uniq_lift is_zero.uniq_desc

-- @[extensionality] lemma is_zero.ext {X : C} (P Q : is_zero.{u v} X) : P = Q :=
-- begin tactic.unfreeze_local_instances, cases P, cases Q, congr, obviously, end

-- instance hom_to_zero_subsingleton (X Z : C) (B : is_zero.{u v} Z) : subsingleton (X ⟶ Z) :=
-- limits.hom_to_terminal_subsingleton X Z B.to_is_terminal
-- instance hom_from_zero_subsingleton (Z X : C) (B : is_zero.{u v} Z) : subsingleton (Z ⟶ X) :=
-- limits.hom_from_initial_subsingleton Z X B.to_is_initial

-- variable (C)

-- class has_zero_object :=
-- (zero : C)
-- (is_zero : is_zero.{u v} zero)

-- end category_theory.limits

-- namespace category_theory.limits

-- def zero_object := has_zero_object.zero.{u v}

-- variables {C : Type u} [𝒞 : category.{u v} C]
-- include 𝒞

-- variables [has_zero_object.{u v} C]

-- def zero_is_zero : is_zero.{u v} (zero_object.{u v} C) := has_zero_object.is_zero C

-- instance has_initial_object_of_has_zero : has_initial_object.{u v} C :=
-- { initial := zero_object.{u v} C,
--   is_initial := zero_is_zero.to_is_initial }

-- instance has_terminal_object_of_has_zero: has_terminal_object.{u v} C :=
-- { terminal := zero_object.{u v} C,
--   is_terminal := zero_is_zero.to_is_terminal }

-- def zero_morphism (X Y : C) : X ⟶ Y := (zero_is_zero.lift.{u v} X) ≫ (zero_is_zero.desc.{u v} Y)

-- instance hom_has_zero (X Y : C) : _root_.has_zero (X ⟶ Y) := { zero := zero_morphism X Y }

-- @[extensionality] lemma ext.out (Y : C) (f g : zero_object.{u v} C ⟶ Y) : f = g :=
-- begin
--   rw (initial.universal_property).uniq _ f,
--   rw (initial.universal_property).uniq _ g,
-- end
-- @[extensionality] lemma ext.in  (Y : C) (f g : Y ⟶ zero_object.{u v} C) : f = g :=
-- begin
--   rw (terminal.universal_property).uniq _ f,
--   rw (terminal.universal_property).uniq _ g,
-- end

-- @[simp] lemma zero_morphism_left  {X Y Z : C} (f : Y ⟶ Z) : (zero_morphism X Y) ≫ f = zero_morphism X Z :=
-- begin
--   unfold zero_morphism,
--   rw category.assoc,
--   congr,
--   tidy,
-- end
-- @[simp] lemma zero_morphism_right {X Y Z : C} (f : X ⟶ Y) : f ≫ (zero_morphism Y Z) = zero_morphism X Z :=
-- begin
--   unfold zero_morphism,
--   rw ← category.assoc,
--   congr,
--   tidy,
-- end

-- end category_theory.limits


import tactic

variable {α : Type*}
variables (s t u : set α)

-- BEGIN
example : s \ t \ u ⊆ s \ (t ∪ u) :=
begin
  intros x xstu,
  have xs : x ∈ s := xstu.1.1,
  have xnt : x ∉ t := xstu.1.2,
  have xnu : x ∉ u := xstu.2,
  split,
  { exact xs }, dsimp,
  intro xtu, -- x ∈ t ∨ x ∈ u
  cases xtu with xt xu,
  { show false, from xnt xt },
  show false, from xnu xu
end

/- Alternatively -/
example : s \ t \ u ⊆ s \ (t ∪ u) :=
begin
  rintros x ⟨⟨xs, xnt⟩, xnu⟩,
  use xs,
  rintros (xt | xu); contradiction,
end
-- END


/-
Copyright (c) 2019 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin, Fabian Glöckle
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.linear_algebra.finite_dimensional
import Mathlib.tactic.apply_fun
import Mathlib.PostPort

universes u_1 u_2 u_3 u_4 u v w l

namespace Mathlib

/-!
# Dual vector spaces

The dual space of an R-module M is the R-module of linear maps `M → R`.

## Main definitions

* `dual R M` defines the dual space of M over R.
* Given a basis for a K-vector space `V`, `is_basis.to_dual` produces a map from `V` to `dual K V`.
* Given families of vectors `e` and `ε`, `dual_pair e ε` states that these families have the
  characteristic properties of a basis and a dual.

## Main results

* `to_dual_equiv` : the dual space is linearly equivalent to the primal space.
* `dual_pair.is_basis` and `dual_pair.eq_dual`: if `e` and `ε` form a dual pair, `e` is a basis and
  `ε` is its dual basis.

## Notation

We sometimes use `V'` as local notation for `dual K V`.

-/

namespace module

/-- The dual space of an R-module M is the R-module of linear maps `M → R`. -/
def dual (R : Type u_1) (M : Type u_2) [comm_ring R] [add_comm_group M] [module R M] :=
  linear_map R M R

namespace dual

protected instance inhabited (R : Type u_1) (M : Type u_2) [comm_ring R] [add_comm_group M]
    [module R M] : Inhabited (dual R M) :=
  id linear_map.inhabited

protected instance has_coe_to_fun (R : Type u_1) (M : Type u_2) [comm_ring R] [add_comm_group M]
    [module R M] : has_coe_to_fun (dual R M) :=
  has_coe_to_fun.mk (fun (x : dual R M) => M → R) linear_map.to_fun

/-- Maps a module M to the dual of the dual of M. See `vector_space.erange_coe` and
`vector_space.eval_equiv`. -/
def eval (R : Type u_1) (M : Type u_2) [comm_ring R] [add_comm_group M] [module R M] :
    linear_map R M (dual R (dual R M)) :=
  linear_map.flip linear_map.id

@[simp] theorem eval_apply (R : Type u_1) (M : Type u_2) [comm_ring R] [add_comm_group M]
    [module R M] (v : M) (a : dual R M) : coe_fn (coe_fn (eval R M) v) a = coe_fn a v :=
  sorry

/-- The transposition of linear maps, as a linear map from `M →ₗ[R] M'` to
`dual R M' →ₗ[R] dual R M`. -/
def transpose {R : Type u_1} {M : Type u_2} [comm_ring R] [add_comm_group M] [module R M]
    {M' : Type u_3} [add_comm_group M'] [module R M'] :
    linear_map R (linear_map R M M') (linear_map R (dual R M') (dual R M)) :=
  linear_map.flip (linear_map.llcomp R M M' R)

theorem transpose_apply {R : Type u_1} {M : Type u_2} [comm_ring R] [add_comm_group M] [module R M]
    {M' : Type u_3} [add_comm_group M'] [module R M'] (u : linear_map R M M') (l : dual R M') :
    coe_fn (coe_fn transpose u) l = linear_map.comp l u :=
  rfl

theorem transpose_comp {R : Type u_1} {M : Type u_2} [comm_ring R] [add_comm_group M] [module R M]
    {M' : Type u_3} [add_comm_group M'] [module R M'] {M'' : Type u_4} [add_comm_group M'']
    [module R M''] (u : linear_map R M' M'') (v : linear_map R M M') :
    coe_fn transpose (linear_map.comp u v) =
        linear_map.comp (coe_fn transpose v) (coe_fn transpose u) :=
  rfl

end dual

end module

namespace is_basis

/-- The linear map from a vector space equipped with basis to its dual vector space,
taking basis elements to corresponding dual basis elements. -/
def to_dual {K : Type u} {V : Type v} {ι : Type w} [field K] [add_comm_group V] [vector_space K V]
    [de : DecidableEq ι] (B : ι → V) (h : is_basis K B) : linear_map K V (module.dual K V) :=
  constr h fun (v : ι) => constr h fun (w : ι) => ite (w = v) 1 0

theorem to_dual_apply {K : Type u} {V : Type v} {ι : Type w} [field K] [add_comm_group V]
    [vector_space K V] [de : DecidableEq ι] {B : ι → V} (h : is_basis K B) (i : ι) (j : ι) :
    coe_fn (coe_fn (to_dual B h) (B i)) (B j) = ite (i = j) 1 0 :=
  sorry

@[simp] theorem to_dual_total_left {K : Type u} {V : Type v} {ι : Type w} [field K]
    [add_comm_group V] [vector_space K V] [de : DecidableEq ι] {B : ι → V} (h : is_basis K B)
    (f : ι →₀ K) (i : ι) :
    coe_fn (coe_fn (to_dual B h) (coe_fn (finsupp.total ι V K B) f)) (B i) = coe_fn f i :=
  sorry

@[simp] theorem to_dual_total_right {K : Type u} {V : Type v} {ι : Type w} [field K]
    [add_comm_group V] [vector_space K V] [de : DecidableEq ι] {B : ι → V} (h : is_basis K B)
    (f : ι →₀ K) (i : ι) :
    coe_fn (coe_fn (to_dual B h) (B i)) (coe_fn (finsupp.total ι V K B) f) = coe_fn f i :=
  sorry

theorem to_dual_apply_left {K : Type u} {V : Type v} {ι : Type w} [field K] [add_comm_group V]
    [vector_space K V] [de : DecidableEq ι] {B : ι → V} (h : is_basis K B) (v : V) (i : ι) :
    coe_fn (coe_fn (to_dual B h) v) (B i) = coe_fn (coe_fn (repr h) v) i :=
  sorry

theorem to_dual_apply_right {K : Type u} {V : Type v} {ι : Type w} [field K] [add_comm_group V]
    [vector_space K V] [de : DecidableEq ι] {B : ι → V} (h : is_basis K B) (i : ι) (v : V) :
    coe_fn (coe_fn (to_dual B h) (B i)) v = coe_fn (coe_fn (repr h) v) i :=
  sorry

/-- `h.to_dual_flip v` is the linear map sending `w` to `h.to_dual w v`. -/
def to_dual_flip {K : Type u} {V : Type v} {ι : Type w} [field K] [add_comm_group V]
    [vector_space K V] [de : DecidableEq ι] (B : ι → V) (h : is_basis K B) (v : V) :
    linear_map K V K :=
  coe_fn (linear_map.flip (to_dual B h)) v

-- TODO: unify this with `finsupp.lapply`.

/-- Evaluation of finitely supported functions at a fixed point `i`, as a `K`-linear map. -/
def eval_finsupp_at {K : Type u} {ι : Type w} [field K] (i : ι) : linear_map K (ι →₀ K) K :=
  linear_map.mk (fun (f : ι →₀ K) => coe_fn f i) sorry sorry

/-- `h.coord_fun i` sends vectors to their `i`'th coordinate with respect to the basis `h`. -/
def coord_fun {K : Type u} {V : Type v} {ι : Type w} [field K] [add_comm_group V] [vector_space K V]
    {B : ι → V} (h : is_basis K B) (i : ι) : linear_map K V K :=
  linear_map.comp (eval_finsupp_at i) (repr h)

theorem coord_fun_eq_repr {K : Type u} {V : Type v} {ι : Type w} [field K] [add_comm_group V]
    [vector_space K V] {B : ι → V} (h : is_basis K B) (v : V) (i : ι) :
    coe_fn (coord_fun h i) v = coe_fn (coe_fn (repr h) v) i :=
  rfl

-- TODO: this lemma should be called something like `to_dual_flip_apply`

theorem to_dual_swap_eq_to_dual {K : Type u} {V : Type v} {ι : Type w} [field K] [add_comm_group V]
    [vector_space K V] [de : DecidableEq ι] {B : ι → V} (h : is_basis K B) (v : V) (w : V) :
    coe_fn (to_dual_flip B h v) w = coe_fn (coe_fn (to_dual B h) w) v :=
  rfl

theorem to_dual_eq_repr {K : Type u} {V : Type v} {ι : Type w} [field K] [add_comm_group V]
    [vector_space K V] [de : DecidableEq ι] {B : ι → V} (h : is_basis K B) (v : V) (i : ι) :
    coe_fn (coe_fn (to_dual B h) v) (B i) = coe_fn (coe_fn (repr h) v) i :=
  to_dual_apply_left h v i

theorem to_dual_eq_equiv_fun {K : Type u} {V : Type v} {ι : Type w} [field K] [add_comm_group V]
    [vector_space K V] [de : DecidableEq ι] {B : ι → V} (h : is_basis K B) [fintype ι] (v : V)
    (i : ι) : coe_fn (coe_fn (to_dual B h) v) (B i) = coe_fn (equiv_fun h) v i :=
  sorry

theorem to_dual_inj {K : Type u} {V : Type v} {ι : Type w} [field K] [add_comm_group V]
    [vector_space K V] [de : DecidableEq ι] {B : ι → V} (h : is_basis K B) (v : V)
    (a : coe_fn (to_dual B h) v = 0) : v = 0 :=
  sorry

theorem to_dual_ker {K : Type u} {V : Type v} {ι : Type w} [field K] [add_comm_group V]
    [vector_space K V] [de : DecidableEq ι] {B : ι → V} (h : is_basis K B) :
    linear_map.ker (to_dual B h) = ⊥ :=
  iff.mpr linear_map.ker_eq_bot' (to_dual_inj h)

theorem to_dual_range {K : Type u} {V : Type v} {ι : Type w} [field K] [add_comm_group V]
    [vector_space K V] [de : DecidableEq ι] {B : ι → V} (h : is_basis K B) [fin : fintype ι] :
    linear_map.range (to_dual B h) = ⊤ :=
  sorry

/-- Maps a basis for `V` to a basis for the dual space. -/
def dual_basis {K : Type u} {V : Type v} {ι : Type w} [field K] [add_comm_group V]
    [vector_space K V] [de : DecidableEq ι] {B : ι → V} (h : is_basis K B) : ι → module.dual K V :=
  fun (i : ι) => coe_fn (to_dual B h) (B i)

theorem dual_lin_independent {K : Type u} {V : Type v} {ι : Type w} [field K] [add_comm_group V]
    [vector_space K V] [de : DecidableEq ι] {B : ι → V} (h : is_basis K B) :
    linear_independent K (dual_basis h) :=
  linear_independent.map' (and.left h) (to_dual B h) (to_dual_ker h)

@[simp] theorem dual_basis_apply_self {K : Type u} {V : Type v} {ι : Type w} [field K]
    [add_comm_group V] [vector_space K V] [de : DecidableEq ι] {B : ι → V} (h : is_basis K B)
    (i : ι) (j : ι) : coe_fn (dual_basis h i) (B j) = ite (i = j) 1 0 :=
  to_dual_apply h i j

/-- A vector space is linearly equivalent to its dual space. -/
def to_dual_equiv {K : Type u} {V : Type v} {ι : Type w} [field K] [add_comm_group V]
    [vector_space K V] [de : DecidableEq ι] (B : ι → V) (h : is_basis K B) [fintype ι] :
    linear_equiv K V (module.dual K V) :=
  linear_equiv.of_bijective (to_dual B h) sorry sorry

theorem dual_basis_is_basis {K : Type u} {V : Type v} {ι : Type w} [field K] [add_comm_group V]
    [vector_space K V] [de : DecidableEq ι] {B : ι → V} (h : is_basis K B) [fintype ι] :
    is_basis K (dual_basis h) :=
  linear_equiv.is_basis h (to_dual_equiv B h)

@[simp] theorem total_dual_basis {K : Type u} {V : Type v} {ι : Type w} [field K] [add_comm_group V]
    [vector_space K V] [de : DecidableEq ι] {B : ι → V} (h : is_basis K B) [fintype ι] (f : ι →₀ K)
    (i : ι) :
    coe_fn (coe_fn (finsupp.total ι (module.dual K V) K (dual_basis h)) f) (B i) = coe_fn f i :=
  sorry

theorem dual_basis_repr {K : Type u} {V : Type v} {ι : Type w} [field K] [add_comm_group V]
    [vector_space K V] [de : DecidableEq ι] {B : ι → V} (h : is_basis K B) [fintype ι]
    (l : module.dual K V) (i : ι) :
    coe_fn (coe_fn (repr (dual_basis_is_basis h)) l) i = coe_fn l (B i) :=
  sorry

theorem dual_basis_equiv_fun {K : Type u} {V : Type v} {ι : Type w} [field K] [add_comm_group V]
    [vector_space K V] [de : DecidableEq ι] {B : ι → V} (h : is_basis K B) [fintype ι]
    (l : module.dual K V) (i : ι) :
    coe_fn (equiv_fun (dual_basis_is_basis h)) l i = coe_fn l (B i) :=
  sorry

theorem dual_basis_apply {K : Type u} {V : Type v} {ι : Type w} [field K] [add_comm_group V]
    [vector_space K V] [de : DecidableEq ι] {B : ι → V} (h : is_basis K B) [fintype ι] (i : ι)
    (v : V) : coe_fn (dual_basis h i) v = coe_fn (equiv_fun h) v i :=
  to_dual_apply_right h i v

@[simp] theorem to_dual_to_dual {K : Type u} {V : Type v} {ι : Type w} [field K] [add_comm_group V]
    [vector_space K V] [de : DecidableEq ι] {B : ι → V} (h : is_basis K B) [fintype ι] :
    linear_map.comp (to_dual (dual_basis h) (dual_basis_is_basis h)) (to_dual B h) =
        module.dual.eval K V :=
  sorry

theorem dual_dim_eq {K : Type u} {V : Type v} {ι : Type w} [field K] [add_comm_group V]
    [vector_space K V] {B : ι → V} (h : is_basis K B) [fintype ι] :
    cardinal.lift (vector_space.dim K V) = vector_space.dim K (module.dual K V) :=
  sorry

end is_basis

namespace vector_space

theorem eval_ker {K : Type u} {V : Type v} [field K] [add_comm_group V] [vector_space K V] :
    linear_map.ker (module.dual.eval K V) = ⊥ :=
  sorry

theorem dual_dim_eq {K : Type u} {V : Type v} [field K] [add_comm_group V] [vector_space K V]
    [finite_dimensional K V] : cardinal.lift (dim K V) = dim K (module.dual K V) :=
  sorry

theorem erange_coe {K : Type u} {V : Type v} [field K] [add_comm_group V] [vector_space K V]
    [finite_dimensional K V] : linear_map.range (module.dual.eval K V) = ⊤ :=
  sorry

/-- A vector space is linearly equivalent to the dual of its dual space. -/
def eval_equiv {K : Type u} {V : Type v} [field K] [add_comm_group V] [vector_space K V]
    [finite_dimensional K V] : linear_equiv K V (module.dual K (module.dual K V)) :=
  linear_equiv.of_bijective (module.dual.eval K V) eval_ker erange_coe

end vector_space

/-- `e` and `ε` have characteristic properties of a basis and its dual -/
structure dual_pair {K : Type u} {V : Type v} {ι : Type w} [DecidableEq ι] [field K]
    [add_comm_group V] [vector_space K V] (e : ι → V) (ε : ι → module.dual K V)
    where
  eval : ∀ (i j : ι), coe_fn (ε i) (e j) = ite (i = j) 1 0
  total : ∀ {v : V}, (∀ (i : ι), coe_fn (ε i) v = 0) → v = 0
  finite : (v : V) → fintype ↥(set_of fun (i : ι) => coe_fn (ε i) v ≠ 0)

namespace dual_pair

/-- The coefficients of `v` on the basis `e` -/
def coeffs {K : Type u} {V : Type v} {ι : Type w} [dι : DecidableEq ι] [field K] [add_comm_group V]
    [vector_space K V] {e : ι → V} {ε : ι → module.dual K V} (h : dual_pair e ε) (v : V) : ι →₀ K :=
  finsupp.mk (set.to_finset (set_of fun (i : ι) => coe_fn (ε i) v ≠ 0))
    (fun (i : ι) => coe_fn (ε i) v) sorry

@[simp] theorem coeffs_apply {K : Type u} {V : Type v} {ι : Type w} [dι : DecidableEq ι] [field K]
    [add_comm_group V] [vector_space K V] {e : ι → V} {ε : ι → module.dual K V} (h : dual_pair e ε)
    (v : V) (i : ι) : coe_fn (coeffs h v) i = coe_fn (ε i) v :=
  rfl

/-- linear combinations of elements of `e`.
This is a convenient abbreviation for `finsupp.total _ V K e l` -/
def lc {K : Type u} {V : Type v} {ι : Type w} [field K] [add_comm_group V] [vector_space K V]
    (e : ι → V) (l : ι →₀ K) : V :=
  finsupp.sum l fun (i : ι) (a : K) => a • e i

theorem dual_lc {K : Type u} {V : Type v} {ι : Type w} [dι : DecidableEq ι] [field K]
    [add_comm_group V] [vector_space K V] {e : ι → V} {ε : ι → module.dual K V} (h : dual_pair e ε)
    (l : ι →₀ K) (i : ι) : coe_fn (ε i) (lc e l) = coe_fn l i :=
  sorry

@[simp] theorem coeffs_lc {K : Type u} {V : Type v} {ι : Type w} [dι : DecidableEq ι] [field K]
    [add_comm_group V] [vector_space K V] {e : ι → V} {ε : ι → module.dual K V} (h : dual_pair e ε)
    (l : ι →₀ K) : coeffs h (lc e l) = l :=
  sorry

/-- For any v : V n, \sum_{p ∈ Q n} (ε p v) • e p = v -/
theorem decomposition {K : Type u} {V : Type v} {ι : Type w} [dι : DecidableEq ι] [field K]
    [add_comm_group V] [vector_space K V] {e : ι → V} {ε : ι → module.dual K V} (h : dual_pair e ε)
    (v : V) : lc e (coeffs h v) = v :=
  sorry

theorem mem_of_mem_span {K : Type u} {V : Type v} {ι : Type w} [dι : DecidableEq ι] [field K]
    [add_comm_group V] [vector_space K V] {e : ι → V} {ε : ι → module.dual K V} (h : dual_pair e ε)
    {H : set ι} {x : V} (hmem : x ∈ submodule.span K (e '' H)) (i : ι) :
    coe_fn (ε i) x ≠ 0 → i ∈ H :=
  sorry

theorem is_basis {K : Type u} {V : Type v} {ι : Type w} [dι : DecidableEq ι] [field K]
    [add_comm_group V] [vector_space K V] {e : ι → V} {ε : ι → module.dual K V}
    (h : dual_pair e ε) : is_basis K e :=
  sorry

theorem eq_dual {K : Type u} {V : Type v} {ι : Type w} [dι : DecidableEq ι] [field K]
    [add_comm_group V] [vector_space K V] {e : ι → V} {ε : ι → module.dual K V}
    (h : dual_pair e ε) : ε = is_basis.dual_basis (is_basis h) :=
  sorry

end Mathlib


import tactic
import for_mathlib -- gives us new theorem `alg_hom.eq_of_id`

/-!

# Formally unramified morphisms

A ring morphism `A →+* B` between commutative rings `A` and `B` is *formally unramified*
if for every surjective square-zero extension of A-algebras `R' →+* R`
(meaning that the kernel I satisties I² = 0)
the natural map Hom_A(B,R') → Hom_A(B,R) is injective.

-/

-- Let A and B be commutative rings
variables {A B : Type} [comm_ring A] [comm_ring B]

--set_option pp.notation false

/-- A ring homomorphism `f : A → B` is *formally unramified* if for every surjective square zero
morphism `φ : R → R'` of A-algebras, the natural map Hom_A(B,R') → Hom_A(B, R) is
an injection. -/
def is_formally_unramified {A B : Type} [comm_ring A] [comm_ring B] (f : A →+* B) : Prop :=
-- First let's make B into an A-algebra in the obvious way via f
let h : algebra A B := f.to_algebra in
-- The condition is: For all A-algebras R and R'
∀ {{R R' : Type}} [comm_ring R] [comm_ring R'], by exactI
∀ [algebra A R] [algebra A R'], by exactI
-- and for all A-algebra morphisms φ : R' → R with square zero
∀ {φ : R' →ₐ[A] R} (hφ1 : ∀ r : R, ∃ r' : R', φ r' = r)
  (hφ2 : ∀ x y : R', φ x = 0 → φ y = 0 → x * y = 0),
-- composing with φ is an injection Hom_A(B,R') → Hom_A(B, R)
function.injective (φ.comp : (B →ₐ[A] R') → (B →ₐ[A] R))

lemma is_formally_unramified_id : is_formally_unramified (ring_hom.id A: A →+* A) :=
begin
  intros R R',
  intro _,
  intro _,
  intros _ _,
  intro φ,
  intro hφ,
  intro hφ',
  unfold function.injective,
  intros a₁ a₂,
  resetI,
  intro h,
  rw a₁.eq_of_id,
  rw a₂.eq_of_id,
  -- the last two lines can be replaced by
  -- apply subsingleton.elim,
  -- then lean does more work (see zulip chat)
end

variables {C : Type} [comm_ring C]

lemma is_formally_unramified.comp {φ : A →+* B} (hφ : is_formally_unramified φ)
  {ψ : B →+* C} (hψ : is_formally_unramified ψ) : is_formally_unramified (ψ.comp φ) :=
begin
 intros R R' _ _ _ _ f,
 intros hf1 hf2,
  unfold function.injective,
  intros a₁ a₂ hyp,
  letI : algebra A B := φ.to_algebra,
  letI : algebra A C := (ψ.comp φ).to_algebra,
  let ψ' : B →ₐ[A] C :=
  { commutes' := λ r, rfl, -- definitional abuse!
    ..ψ },
have h_5: f.comp (a₁.comp ψ') =  f.comp (a₂.comp ψ'),
  begin
  rw ← alg_hom.comp_assoc,
  rw ← alg_hom.comp_assoc,
  rw hyp,
  end,
 have h_6: a₁.comp ψ' =  a₂.comp ψ', -- as phi is formally unramified
  begin
  apply hφ hf1 hf2,
  apply h_5
  end,
 let σ := a₁.comp ψ',
 let ρ := f.comp (a₁.comp ψ'),
 letI : algebra B R' := σ.to_ring_hom.to_algebra,
 letI : algebra B R := ρ.to_ring_hom.to_algebra,
 let f' : R' →ₐ[B] R :=
  { commutes' := λ r, rfl,
    ..f },
-- now I want to tell lean that a₁ and a₂ are in fact B algbera maps using h_6.
letI : algebra B C := ψ.to_algebra,
let a₁' : C →ₐ[B] R' :=
{ commutes' :=  λ r, rfl,
   ..a₁ },
let a₂' : C →ₐ[B] R' :=
{ commutes' := begin intro r, change (a₂.comp ψ') r = _, rw ← h_6, refl,
end, ..a₂ },
have h_7 : f'.comp a₁' = f'.comp a₂',
  begin
  ext r,
  rw alg_hom.ext_iff at hyp,
  specialize hyp r,
  exact hyp,
  end,
have hf1' : ∀ (r : R), ∃ (r' : R'), f' r' = r,
  exact hf1,
have hf2' : ∀ (x y : R'), f' x = 0 → f' y = 0 → x * y = 0,
  exact hf2,
have h_8 : a₁' = a₂',
  begin
  specialize hψ hf1' hf2',
  apply hψ h_7,
  end,
ext r,
rw alg_hom.ext_iff at h_8,
specialize h_8 r,
exact h_8,
end