/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Yury G. Kudryashov, Scott Morrison
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.algebra.algebra.basic
import Mathlib.linear_algebra.finsupp
import Mathlib.PostPort

universes u₁ u₂ u_1 u_2 u_3 u₃ ui

namespace Mathlib

/-!
# Monoid algebras

When the domain of a `finsupp` has a multiplicative or additive structure, we can define
a convolution product. To mathematicians this structure is known as the "monoid algebra",
i.e. the finite formal linear combinations over a given semiring of elements of the monoid.
The "group ring" ℤ[G] or the "group algebra" k[G] are typical uses.

In this file we define `monoid_algebra k G := G →₀ k`, and `add_monoid_algebra k G`
in the same way, and then define the convolution product on these.

When the domain is additive, this is used to define polynomials:
```
polynomial α := add_monoid_algebra ℕ α
mv_polynomial σ α := add_monoid_algebra (σ →₀ ℕ) α
```

When the domain is multiplicative, e.g. a group, this will be used to define the group ring.

## Implementation note
Unfortunately because additive and multiplicative structures both appear in both cases,
it doesn't appear to be possible to make much use of `to_additive`, and we just settle for
saying everything twice.

Similarly, I attempted to just define
`add_monoid_algebra k G := monoid_algebra k (multiplicative G)`, but the definitional equality
`multiplicative G = G` leaks through everywhere, and seems impossible to use.
-/

/-! ### Multiplicative monoids -/

/--
The monoid algebra over a semiring `k` generated by the monoid `G`.
It is the type of finite formal `k`-linear combinations of terms of `G`,
endowed with the convolution product.
-/
def monoid_algebra (k : Type u₁) (G : Type u₂) [semiring k] := G →₀ k

namespace monoid_algebra

/-! #### Semiring structure -/

/-- The product of `f g : monoid_algebra k G` is the finitely supported function
  whose value at `a` is the sum of `f x * g y` over all pairs `x, y`
  such that `x * y = a`. (Think of the group ring of a group.) -/
protected instance has_mul {k : Type u₁} {G : Type u₂} [semiring k] [monoid G] :
    Mul (monoid_algebra k G) :=
  { mul :=
      fun (f g : monoid_algebra k G) =>
        finsupp.sum f
          fun (a₁ : G) (b₁ : k) =>
            finsupp.sum g fun (a₂ : G) (b₂ : k) => finsupp.single (a₁ * a₂) (b₁ * b₂) }

theorem mul_def {k : Type u₁} {G : Type u₂} [semiring k] [monoid G] {f : monoid_algebra k G}
    {g : monoid_algebra k G} :
    f * g =
        finsupp.sum f
          fun (a₁ : G) (b₁ : k) =>
            finsupp.sum g fun (a₂ : G) (b₂ : k) => finsupp.single (a₁ * a₂) (b₁ * b₂) :=
  rfl

/-- The unit of the multiplication is `single 1 1`, i.e. the function
  that is `1` at `1` and zero elsewhere. -/
protected instance has_one {k : Type u₁} {G : Type u₂} [semiring k] [monoid G] :
    HasOne (monoid_algebra k G) :=
  { one := finsupp.single 1 1 }

theorem one_def {k : Type u₁} {G : Type u₂} [semiring k] [monoid G] : 1 = finsupp.single 1 1 := rfl

protected instance semiring {k : Type u₁} {G : Type u₂} [semiring k] [monoid G] :
    semiring (monoid_algebra k G) :=
  semiring.mk Add.add sorry 0 sorry sorry sorry Mul.mul sorry 1 sorry sorry sorry sorry sorry sorry

/-- A non-commutative version of `monoid_algebra.lift`: given a additive homomorphism `f : k →+ R`
and a multiplicative monoid homomorphism `g : G →* R`, returns the additive homomorphism from
`monoid_algebra k G` such that `lift_nc f g (single a b) = f b * g a`. If `f` is a ring homomorphism
and the range of either `f` or `g` is in center of `R`, then the result is a ring homomorphism.  If
`R` is a `k`-algebra and `f = algebra_map k R`, then the result is an algebra homomorphism called
`monoid_algebra.lift`. -/
def lift_nc {k : Type u₁} {G : Type u₂} [semiring k] [monoid G] {R : Type u_1} [semiring R]
    (f : k →+ R) (g : G →* R) : monoid_algebra k G →+ R :=
  coe_fn finsupp.lift_add_hom
    fun (x : G) => add_monoid_hom.comp (add_monoid_hom.mul_right (coe_fn g x)) f

@[simp] theorem lift_nc_single {k : Type u₁} {G : Type u₂} [semiring k] [monoid G] {R : Type u_1}
    [semiring R] (f : k →+ R) (g : G →* R) (a : G) (b : k) :
    coe_fn (lift_nc f g) (finsupp.single a b) = coe_fn f b * coe_fn g a :=
  finsupp.lift_add_hom_apply_single
    (fun (x : G) => add_monoid_hom.comp (add_monoid_hom.mul_right (coe_fn g x)) f) a b

@[simp] theorem lift_nc_one {k : Type u₁} {G : Type u₂} [semiring k] [monoid G] {R : Type u_1}
    [semiring R] (f : k →+* R) (g : G →* R) : coe_fn (lift_nc (↑f) g) 1 = 1 :=
  sorry

theorem lift_nc_mul {k : Type u₁} {G : Type u₂} [semiring k] [monoid G] {R : Type u_1} [semiring R]
    (f : k →+* R) (g : G →* R) (a : monoid_algebra k G) (b : monoid_algebra k G)
    (h_comm : ∀ {x y : G}, y ∈ finsupp.support a → commute (coe_fn f (coe_fn b x)) (coe_fn g y)) :
    coe_fn (lift_nc (↑f) g) (a * b) = coe_fn (lift_nc (↑f) g) a * coe_fn (lift_nc (↑f) g) b :=
  sorry

/-- `lift_nc` as a `ring_hom`, for when `f x` and `g y` commute -/
def lift_nc_ring_hom {k : Type u₁} {G : Type u₂} [semiring k] [monoid G] {R : Type u_1} [semiring R]
    (f : k →+* R) (g : G →* R) (h_comm : ∀ (x : k) (y : G), commute (coe_fn f x) (coe_fn g y)) :
    monoid_algebra k G →+* R :=
  ring_hom.mk (⇑(lift_nc (↑f) g)) (lift_nc_one f g) sorry sorry sorry

protected instance comm_semiring {k : Type u₁} {G : Type u₂} [comm_semiring k] [comm_monoid G] :
    comm_semiring (monoid_algebra k G) :=
  comm_semiring.mk semiring.add sorry semiring.zero sorry sorry sorry semiring.mul sorry
    semiring.one sorry sorry sorry sorry sorry sorry sorry

protected instance nontrivial {k : Type u₁} {G : Type u₂} [semiring k] [nontrivial k] [monoid G] :
    nontrivial (monoid_algebra k G) :=
  finsupp.nontrivial

/-! #### Derived instances -/

protected instance unique {k : Type u₁} {G : Type u₂} [semiring k] [subsingleton k] :
    unique (monoid_algebra k G) :=
  finsupp.unique_of_right

protected instance add_group {k : Type u₁} {G : Type u₂} [ring k] :
    add_group (monoid_algebra k G) :=
  finsupp.add_group

protected instance ring {k : Type u₁} {G : Type u₂} [ring k] [monoid G] :
    ring (monoid_algebra k G) :=
  ring.mk semiring.add sorry semiring.zero sorry sorry Neg.neg
    (add_comm_group.sub._default semiring.add sorry semiring.zero sorry sorry Neg.neg) sorry sorry
    semiring.mul sorry semiring.one sorry sorry sorry sorry

protected instance comm_ring {k : Type u₁} {G : Type u₂} [comm_ring k] [comm_monoid G] :
    comm_ring (monoid_algebra k G) :=
  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

protected instance has_scalar {k : Type u₁} {G : Type u₂} {R : Type u_1} [semiring R] [semiring k]
    [semimodule R k] : has_scalar R (monoid_algebra k G) :=
  finsupp.has_scalar

protected instance semimodule {k : Type u₁} {G : Type u₂} {R : Type u_1} [semiring R] [semiring k]
    [semimodule R k] : semimodule R (monoid_algebra k G) :=
  finsupp.semimodule G k

protected instance distrib_mul_action {k : Type u₁} {G : Type u₂} [group G] [semiring k] :
    distrib_mul_action G (monoid_algebra k G) :=
  finsupp.comap_distrib_mul_action_self

theorem mul_apply {k : Type u₁} {G : Type u₂} [semiring k] [monoid G] (f : monoid_algebra k G)
    (g : monoid_algebra k G) (x : G) :
    coe_fn (f * g) x =
        finsupp.sum f
          fun (a₁ : G) (b₁ : k) =>
            finsupp.sum g fun (a₂ : G) (b₂ : k) => ite (a₁ * a₂ = x) (b₁ * b₂) 0 :=
  sorry

theorem mul_apply_antidiagonal {k : Type u₁} {G : Type u₂} [semiring k] [monoid G]
    (f : monoid_algebra k G) (g : monoid_algebra k G) (x : G) (s : finset (G × G))
    (hs : ∀ {p : G × G}, p ∈ s ↔ prod.fst p * prod.snd p = x) :
    coe_fn (f * g) x =
        finset.sum s fun (p : G × G) => coe_fn f (prod.fst p) * coe_fn g (prod.snd p) :=
  sorry

theorem support_mul {k : Type u₁} {G : Type u₂} [semiring k] [monoid G] (a : monoid_algebra k G)
    (b : monoid_algebra k G) :
    finsupp.support (a * b) ⊆
        finset.bUnion (finsupp.support a)
          fun (a₁ : G) => finset.bUnion (finsupp.support b) fun (a₂ : G) => singleton (a₁ * a₂) :=
  sorry

@[simp] theorem single_mul_single {k : Type u₁} {G : Type u₂} [semiring k] [monoid G] {a₁ : G}
    {a₂ : G} {b₁ : k} {b₂ : k} :
    finsupp.single a₁ b₁ * finsupp.single a₂ b₂ = finsupp.single (a₁ * a₂) (b₁ * b₂) :=
  sorry

@[simp] theorem single_pow {k : Type u₁} {G : Type u₂} [semiring k] [monoid G] {a : G} {b : k}
    (n : ℕ) : finsupp.single a b ^ n = finsupp.single (a ^ n) (b ^ n) :=
  sorry

/-- Like `finsupp.map_domain_add`, but for the convolutive multiplication we define in this file -/
theorem map_domain_mul {α : Type u_1} {β : Type u_2} {α₂ : Type u_3} [semiring β] [monoid α]
    [monoid α₂] {x : monoid_algebra β α} {y : monoid_algebra β α} (f : mul_hom α α₂) :
    finsupp.map_domain (⇑f) (x * y) = finsupp.map_domain (⇑f) x * finsupp.map_domain (⇑f) y :=
  sorry

/-- Embedding of a monoid into its monoid algebra. -/
def of (k : Type u₁) (G : Type u₂) [semiring k] [monoid G] : G →* monoid_algebra k G :=
  monoid_hom.mk (fun (a : G) => finsupp.single a 1) sorry sorry

@[simp] theorem of_apply {k : Type u₁} {G : Type u₂} [semiring k] [monoid G] (a : G) :
    coe_fn (of k G) a = finsupp.single a 1 :=
  rfl

theorem of_injective {k : Type u₁} {G : Type u₂} [semiring k] [monoid G] [nontrivial k] :
    function.injective ⇑(of k G) :=
  sorry

theorem mul_single_apply_aux {k : Type u₁} {G : Type u₂} [semiring k] [monoid G]
    (f : monoid_algebra k G) {r : k} {x : G} {y : G} {z : G} (H : ∀ (a : G), a * x = z ↔ a = y) :
    coe_fn (f * finsupp.single x r) z = coe_fn f y * r :=
  sorry

theorem mul_single_one_apply {k : Type u₁} {G : Type u₂} [semiring k] [monoid G]
    (f : monoid_algebra k G) (r : k) (x : G) : coe_fn (f * finsupp.single 1 r) x = coe_fn f x * r :=
  mul_single_apply_aux f
    fun (a : G) =>
      eq.mpr (id (Eq._oldrec (Eq.refl (a * 1 = x ↔ a = x)) (mul_one a))) (iff.refl (a = x))

theorem single_mul_apply_aux {k : Type u₁} {G : Type u₂} [semiring k] [monoid G]
    (f : monoid_algebra k G) {r : k} {x : G} {y : G} {z : G} (H : ∀ (a : G), x * a = y ↔ a = z) :
    coe_fn (finsupp.single x r * f) y = r * coe_fn f z :=
  sorry

theorem single_one_mul_apply {k : Type u₁} {G : Type u₂} [semiring k] [monoid G]
    (f : monoid_algebra k G) (r : k) (x : G) : coe_fn (finsupp.single 1 r * f) x = r * coe_fn f x :=
  single_mul_apply_aux f
    fun (a : G) =>
      eq.mpr (id (Eq._oldrec (Eq.refl (1 * a = x ↔ a = x)) (one_mul a))) (iff.refl (a = x))

theorem lift_nc_smul {k : Type u₁} {G : Type u₂} [semiring k] [monoid G] {R : Type u_1} [semiring R]
    (f : k →+* R) (g : G →* R) (c : k) (φ : monoid_algebra k G) :
    coe_fn (lift_nc (↑f) g) (c • φ) = coe_fn f c * coe_fn (lift_nc (↑f) g) φ :=
  sorry

/-! #### Algebra structure -/

theorem single_one_comm {k : Type u₁} {G : Type u₂} [comm_semiring k] [monoid G] (r : k)
    (f : monoid_algebra k G) : finsupp.single 1 r * f = f * finsupp.single 1 r :=
  sorry

/-- `finsupp.single 1` as a `ring_hom` -/
def single_one_ring_hom {k : Type u₁} {G : Type u₂} [semiring k] [monoid G] :
    k →+* monoid_algebra k G :=
  ring_hom.mk (add_monoid_hom.to_fun (finsupp.single_add_hom 1)) sorry sorry sorry sorry

/-- If two ring homomorphisms from `monoid_algebra k G` are equal on all `single a 1`
and `single 1 b`, then they are equal. -/
theorem ring_hom_ext {k : Type u₁} {G : Type u₂} {R : Type u_1} [semiring k] [monoid G] [semiring R]
    {f : monoid_algebra k G →+* R} {g : monoid_algebra k G →+* R}
    (h₁ : ∀ (b : k), coe_fn f (finsupp.single 1 b) = coe_fn g (finsupp.single 1 b))
    (h_of : ∀ (a : G), coe_fn f (finsupp.single a 1) = coe_fn g (finsupp.single a 1)) : f = g :=
  sorry

/-- If two ring homomorphisms from `monoid_algebra k G` are equal on all `single a 1`
and `single 1 b`, then they are equal.

See note [partially-applied ext lemmas]. -/
theorem ring_hom_ext' {k : Type u₁} {G : Type u₂} {R : Type u_1} [semiring k] [monoid G]
    [semiring R] {f : monoid_algebra k G →+* R} {g : monoid_algebra k G →+* R}
    (h₁ : ring_hom.comp f single_one_ring_hom = ring_hom.comp g single_one_ring_hom)
    (h_of : monoid_hom.comp (↑f) (of k G) = monoid_hom.comp (↑g) (of k G)) : f = g :=
  ring_hom_ext (ring_hom.congr_fun h₁) (monoid_hom.congr_fun h_of)

/--
The instance `algebra k (monoid_algebra A G)` whenever we have `algebra k A`.

In particular this provides the instance `algebra k (monoid_algebra k G)`.
-/
protected instance algebra {k : Type u₁} {G : Type u₂} {A : Type u_1} [comm_semiring k] [semiring A]
    [algebra k A] [monoid G] : algebra k (monoid_algebra A G) :=
  algebra.mk
    (ring_hom.mk (ring_hom.to_fun (ring_hom.comp single_one_ring_hom (algebra_map k A))) sorry sorry
      sorry sorry)
    sorry sorry

/-- `finsupp.single 1` as a `alg_hom` -/
def single_one_alg_hom {k : Type u₁} {G : Type u₂} {A : Type u_1} [comm_semiring k] [semiring A]
    [algebra k A] [monoid G] : alg_hom k A (monoid_algebra A G) :=
  alg_hom.mk (ring_hom.to_fun single_one_ring_hom) sorry sorry sorry sorry sorry

@[simp] theorem coe_algebra_map {k : Type u₁} {G : Type u₂} {A : Type u_1} [comm_semiring k]
    [semiring A] [algebra k A] [monoid G] :
    ⇑(algebra_map k (monoid_algebra A G)) = finsupp.single 1 ∘ ⇑(algebra_map k A) :=
  rfl

theorem single_eq_algebra_map_mul_of {k : Type u₁} {G : Type u₂} [comm_semiring k] [monoid G]
    (a : G) (b : k) :
    finsupp.single a b = coe_fn (algebra_map k (monoid_algebra k G)) b * coe_fn (of k G) a :=
  sorry

theorem single_algebra_map_eq_algebra_map_mul_of {k : Type u₁} {G : Type u₂} {A : Type u_1}
    [comm_semiring k] [semiring A] [algebra k A] [monoid G] (a : G) (b : k) :
    finsupp.single a (coe_fn (algebra_map k A) b) =
        coe_fn (algebra_map k (monoid_algebra A G)) b * coe_fn (of A G) a :=
  sorry

/-- `lift_nc_ring_hom` as a `alg_hom`, for when `f` is an `alg_hom` -/
def lift_nc_alg_hom {k : Type u₁} {G : Type u₂} [comm_semiring k] [monoid G] {A : Type u₃}
    [semiring A] [algebra k A] {B : Type u_1} [semiring B] [algebra k B] (f : alg_hom k A B)
    (g : G →* B) (h_comm : ∀ (x : A) (y : G), commute (coe_fn f x) (coe_fn g y)) :
    alg_hom k (monoid_algebra A G) B :=
  alg_hom.mk ⇑(lift_nc_ring_hom (↑f) g h_comm) sorry sorry sorry sorry sorry

/-- A `k`-algebra homomorphism from `monoid_algebra k G` is uniquely defined by its
values on the functions `single a 1`. -/
theorem alg_hom_ext {k : Type u₁} {G : Type u₂} [comm_semiring k] [monoid G] {A : Type u₃}
    [semiring A] [algebra k A] {φ₁ : alg_hom k (monoid_algebra k G) A}
    {φ₂ : alg_hom k (monoid_algebra k G) A}
    (h : ∀ (x : G), coe_fn φ₁ (finsupp.single x 1) = coe_fn φ₂ (finsupp.single x 1)) : φ₁ = φ₂ :=
  alg_hom.to_linear_map_inj (finsupp.lhom_ext' fun (a : G) => linear_map.ext_ring (h a))

/-- See note [partially-applied ext lemmas]. -/
theorem alg_hom_ext' {k : Type u₁} {G : Type u₂} [comm_semiring k] [monoid G] {A : Type u₃}
    [semiring A] [algebra k A] {φ₁ : alg_hom k (monoid_algebra k G) A}
    {φ₂ : alg_hom k (monoid_algebra k G) A}
    (h : monoid_hom.comp (↑φ₁) (of k G) = monoid_hom.comp (↑φ₂) (of k G)) : φ₁ = φ₂ :=
  alg_hom_ext (monoid_hom.congr_fun h)

/-- Any monoid homomorphism `G →* A` can be lifted to an algebra homomorphism
`monoid_algebra k G →ₐ[k] A`. -/
def lift (k : Type u₁) (G : Type u₂) [comm_semiring k] [monoid G] (A : Type u₃) [semiring A]
    [algebra k A] : (G →* A) ≃ alg_hom k (monoid_algebra k G) A :=
  equiv.mk (fun (F : G →* A) => lift_nc_alg_hom (algebra.of_id k A) F sorry)
    (fun (f : alg_hom k (monoid_algebra k G) A) => monoid_hom.comp (↑f) (of k G)) sorry sorry

theorem lift_apply' {k : Type u₁} {G : Type u₂} [comm_semiring k] [monoid G] {A : Type u₃}
    [semiring A] [algebra k A] (F : G →* A) (f : monoid_algebra k G) :
    coe_fn (coe_fn (lift k G A) F) f =
        finsupp.sum f fun (a : G) (b : k) => coe_fn (algebra_map k A) b * coe_fn F a :=
  rfl

theorem lift_apply {k : Type u₁} {G : Type u₂} [comm_semiring k] [monoid G] {A : Type u₃}
    [semiring A] [algebra k A] (F : G →* A) (f : monoid_algebra k G) :
    coe_fn (coe_fn (lift k G A) F) f = finsupp.sum f fun (a : G) (b : k) => b • coe_fn F a :=
  sorry

theorem lift_def {k : Type u₁} {G : Type u₂} [comm_semiring k] [monoid G] {A : Type u₃} [semiring A]
    [algebra k A] (F : G →* A) : ⇑(coe_fn (lift k G A) F) = ⇑(lift_nc (↑(algebra_map k A)) F) :=
  rfl

@[simp] theorem lift_symm_apply {k : Type u₁} {G : Type u₂} [comm_semiring k] [monoid G]
    {A : Type u₃} [semiring A] [algebra k A] (F : alg_hom k (monoid_algebra k G) A) (x : G) :
    coe_fn (coe_fn (equiv.symm (lift k G A)) F) x = coe_fn F (finsupp.single x 1) :=
  rfl

theorem lift_of {k : Type u₁} {G : Type u₂} [comm_semiring k] [monoid G] {A : Type u₃} [semiring A]
    [algebra k A] (F : G →* A) (x : G) :
    coe_fn (coe_fn (lift k G A) F) (coe_fn (of k G) x) = coe_fn F x :=
  sorry

@[simp] theorem lift_single {k : Type u₁} {G : Type u₂} [comm_semiring k] [monoid G] {A : Type u₃}
    [semiring A] [algebra k A] (F : G →* A) (a : G) (b : k) :
    coe_fn (coe_fn (lift k G A) F) (finsupp.single a b) = b • coe_fn F a :=
  sorry

theorem lift_unique' {k : Type u₁} {G : Type u₂} [comm_semiring k] [monoid G] {A : Type u₃}
    [semiring A] [algebra k A] (F : alg_hom k (monoid_algebra k G) A) :
    F = coe_fn (lift k G A) (monoid_hom.comp (↑F) (of k G)) :=
  Eq.symm (equiv.apply_symm_apply (lift k G A) F)

/-- Decomposition of a `k`-algebra homomorphism from `monoid_algebra k G` by
its values on `F (single a 1)`. -/
theorem lift_unique {k : Type u₁} {G : Type u₂} [comm_semiring k] [monoid G] {A : Type u₃}
    [semiring A] [algebra k A] (F : alg_hom k (monoid_algebra k G) A) (f : monoid_algebra k G) :
    coe_fn F f = finsupp.sum f fun (a : G) (b : k) => b • coe_fn F (finsupp.single a 1) :=
  sorry

/-- When `V` is a `k[G]`-module, multiplication by a group element `g` is a `k`-linear map. -/
def group_smul.linear_map (k : Type u₁) {G : Type u₂} [monoid G] [comm_semiring k] (V : Type u₃)
    [add_comm_monoid V] [semimodule k V] [semimodule (monoid_algebra k G) V]
    [is_scalar_tower k (monoid_algebra k G) V] (g : G) : linear_map k V V :=
  linear_map.mk (fun (v : V) => finsupp.single g 1 • v) sorry sorry

@[simp] theorem group_smul.linear_map_apply (k : Type u₁) {G : Type u₂} [monoid G] [comm_semiring k]
    (V : Type u₃) [add_comm_monoid V] [semimodule k V] [semimodule (monoid_algebra k G) V]
    [is_scalar_tower k (monoid_algebra k G) V] (g : G) (v : V) :
    coe_fn (group_smul.linear_map k V g) v = finsupp.single g 1 • v :=
  rfl

/-- Build a `k[G]`-linear map from a `k`-linear map and evidence that it is `G`-equivariant. -/
def equivariant_of_linear_of_comm {k : Type u₁} {G : Type u₂} [monoid G] [comm_semiring k]
    {V : Type u₃} {W : Type u₃} [add_comm_monoid V] [semimodule k V]
    [semimodule (monoid_algebra k G) V] [is_scalar_tower k (monoid_algebra k G) V]
    [add_comm_monoid W] [semimodule k W] [semimodule (monoid_algebra k G) W]
    [is_scalar_tower k (monoid_algebra k G) W] (f : linear_map k V W)
    (h : ∀ (g : G) (v : V), coe_fn f (finsupp.single g 1 • v) = finsupp.single g 1 • coe_fn f v) :
    linear_map (monoid_algebra k G) V W :=
  linear_map.mk ⇑f sorry sorry

@[simp] theorem equivariant_of_linear_of_comm_apply {k : Type u₁} {G : Type u₂} [monoid G]
    [comm_semiring k] {V : Type u₃} {W : Type u₃} [add_comm_monoid V] [semimodule k V]
    [semimodule (monoid_algebra k G) V] [is_scalar_tower k (monoid_algebra k G) V]
    [add_comm_monoid W] [semimodule k W] [semimodule (monoid_algebra k G) W]
    [is_scalar_tower k (monoid_algebra k G) W] (f : linear_map k V W)
    (h : ∀ (g : G) (v : V), coe_fn f (finsupp.single g 1 • v) = finsupp.single g 1 • coe_fn f v)
    (v : V) : coe_fn (equivariant_of_linear_of_comm f h) v = coe_fn f v :=
  rfl

theorem prod_single {k : Type u₁} {G : Type u₂} {ι : Type ui} [comm_semiring k] [comm_monoid G]
    {s : finset ι} {a : ι → G} {b : ι → k} :
    (finset.prod s fun (i : ι) => finsupp.single (a i) (b i)) =
        finsupp.single (finset.prod s fun (i : ι) => a i) (finset.prod s fun (i : ι) => b i) :=
  sorry

@[simp] theorem mul_single_apply {k : Type u₁} {G : Type u₂} [semiring k] [group G]
    (f : monoid_algebra k G) (r : k) (x : G) (y : G) :
    coe_fn (f * finsupp.single x r) y = coe_fn f (y * (x⁻¹)) * r :=
  mul_single_apply_aux f fun (a : G) => iff.symm eq_mul_inv_iff_mul_eq

@[simp] theorem single_mul_apply {k : Type u₁} {G : Type u₂} [semiring k] [group G] (r : k) (x : G)
    (f : monoid_algebra k G) (y : G) : coe_fn (finsupp.single x r * f) y = r * coe_fn f (x⁻¹ * y) :=
  single_mul_apply_aux f fun (z : G) => iff.symm eq_inv_mul_iff_mul_eq

theorem mul_apply_left {k : Type u₁} {G : Type u₂} [semiring k] [group G] (f : monoid_algebra k G)
    (g : monoid_algebra k G) (x : G) :
    coe_fn (f * g) x = finsupp.sum f fun (a : G) (b : k) => b * coe_fn g (a⁻¹ * x) :=
  sorry

-- If we'd assumed `comm_semiring`, we could deduce this from `mul_apply_left`.

theorem mul_apply_right {k : Type u₁} {G : Type u₂} [semiring k] [group G] (f : monoid_algebra k G)
    (g : monoid_algebra k G) (x : G) :
    coe_fn (f * g) x = finsupp.sum g fun (a : G) (b : k) => coe_fn f (x * (a⁻¹)) * b :=
  sorry

end monoid_algebra

/-! ### Additive monoids -/

/--
The monoid algebra over a semiring `k` generated by the additive monoid `G`.
It is the type of finite formal `k`-linear combinations of terms of `G`,
endowed with the convolution product.
-/
def add_monoid_algebra (k : Type u₁) (G : Type u₂) [semiring k] := G →₀ k

namespace add_monoid_algebra

/-! #### Semiring structure -/

/-- The product of `f g : add_monoid_algebra k G` is the finitely supported function
  whose value at `a` is the sum of `f x * g y` over all pairs `x, y`
  such that `x + y = a`. (Think of the product of multivariate
  polynomials where `α` is the additive monoid of monomial exponents.) -/
protected instance has_mul {k : Type u₁} {G : Type u₂} [semiring k] [add_monoid G] :
    Mul (add_monoid_algebra k G) :=
  { mul :=
      fun (f g : add_monoid_algebra k G) =>
        finsupp.sum f
          fun (a₁ : G) (b₁ : k) =>
            finsupp.sum g fun (a₂ : G) (b₂ : k) => finsupp.single (a₁ + a₂) (b₁ * b₂) }

theorem mul_def {k : Type u₁} {G : Type u₂} [semiring k] [add_monoid G] {f : add_monoid_algebra k G}
    {g : add_monoid_algebra k G} :
    f * g =
        finsupp.sum f
          fun (a₁ : G) (b₁ : k) =>
            finsupp.sum g fun (a₂ : G) (b₂ : k) => finsupp.single (a₁ + a₂) (b₁ * b₂) :=
  rfl

/-- The unit of the multiplication is `single 1 1`, i.e. the function
  that is `1` at `0` and zero elsewhere. -/
protected instance has_one {k : Type u₁} {G : Type u₂} [semiring k] [add_monoid G] :
    HasOne (add_monoid_algebra k G) :=
  { one := finsupp.single 0 1 }

theorem one_def {k : Type u₁} {G : Type u₂} [semiring k] [add_monoid G] : 1 = finsupp.single 0 1 :=
  rfl

protected instance semiring {k : Type u₁} {G : Type u₂} [semiring k] [add_monoid G] :
    semiring (add_monoid_algebra k G) :=
  semiring.mk Add.add sorry 0 sorry sorry sorry Mul.mul sorry 1 sorry sorry sorry sorry sorry sorry

/-- A non-commutative version of `add_monoid_algebra.lift`: given a additive homomorphism `f : k →+
R` and a multiplicative monoid homomorphism `g : multiplicative G →* R`, returns the additive
homomorphism from `add_monoid_algebra k G` such that `lift_nc f g (single a b) = f b * g a`. If `f`
is a ring homomorphism and the range of either `f` or `g` is in center of `R`, then the result is a
ring homomorphism.  If `R` is a `k`-algebra and `f = algebra_map k R`, then the result is an algebra
homomorphism called `add_monoid_algebra.lift`. -/
def lift_nc {k : Type u₁} {G : Type u₂} [semiring k] [add_monoid G] {R : Type u_1} [semiring R]
    (f : k →+ R) (g : multiplicative G →* R) : add_monoid_algebra k G →+ R :=
  coe_fn finsupp.lift_add_hom
    fun (x : G) =>
      add_monoid_hom.comp (add_monoid_hom.mul_right (coe_fn g (coe_fn multiplicative.of_add x))) f

@[simp] theorem lift_nc_single {k : Type u₁} {G : Type u₂} [semiring k] [add_monoid G]
    {R : Type u_1} [semiring R] (f : k →+ R) (g : multiplicative G →* R) (a : G) (b : k) :
    coe_fn (lift_nc f g) (finsupp.single a b) =
        coe_fn f b * coe_fn g (coe_fn multiplicative.of_add a) :=
  finsupp.lift_add_hom_apply_single
    (fun (x : G) =>
      add_monoid_hom.comp (add_monoid_hom.mul_right (coe_fn g (coe_fn multiplicative.of_add x))) f)
    a b

@[simp] theorem lift_nc_one {k : Type u₁} {G : Type u₂} [semiring k] [add_monoid G] {R : Type u_1}
    [semiring R] (f : k →+* R) (g : multiplicative G →* R) : coe_fn (lift_nc (↑f) g) 1 = 1 :=
  monoid_algebra.lift_nc_one f g

theorem lift_nc_mul {k : Type u₁} {G : Type u₂} [semiring k] [add_monoid G] {R : Type u_1}
    [semiring R] (f : k →+* R) (g : multiplicative G →* R) (a : add_monoid_algebra k G)
    (b : add_monoid_algebra k G)
    (h_comm :
      ∀ {x y : G},
        y ∈ finsupp.support a →
          commute (coe_fn f (coe_fn b x)) (coe_fn g (coe_fn multiplicative.of_add y))) :
    coe_fn (lift_nc (↑f) g) (a * b) = coe_fn (lift_nc (↑f) g) a * coe_fn (lift_nc (↑f) g) b :=
  monoid_algebra.lift_nc_mul f g a b h_comm

/-- `lift_nc` as a `ring_hom`, for when `f` and `g` commute -/
def lift_nc_ring_hom {k : Type u₁} {G : Type u₂} [semiring k] [add_monoid G] {R : Type u_1}
    [semiring R] (f : k →+* R) (g : multiplicative G →* R)
    (h_comm : ∀ (x : k) (y : multiplicative G), commute (coe_fn f x) (coe_fn g y)) :
    add_monoid_algebra k G →+* R :=
  ring_hom.mk (⇑(lift_nc (↑f) g)) (lift_nc_one f g) sorry sorry sorry

protected instance comm_semiring {k : Type u₁} {G : Type u₂} [comm_semiring k] [add_comm_monoid G] :
    comm_semiring (add_monoid_algebra k G) :=
  comm_semiring.mk semiring.add sorry semiring.zero sorry sorry sorry semiring.mul sorry
    semiring.one sorry sorry sorry sorry sorry sorry sorry

protected instance nontrivial {k : Type u₁} {G : Type u₂} [semiring k] [nontrivial k]
    [add_monoid G] : nontrivial (add_monoid_algebra k G) :=
  finsupp.nontrivial

/-! #### Derived instances -/

protected instance unique {k : Type u₁} {G : Type u₂} [semiring k] [subsingleton k] :
    unique (add_monoid_algebra k G) :=
  finsupp.unique_of_right

protected instance add_group {k : Type u₁} {G : Type u₂} [ring k] :
    add_group (add_monoid_algebra k G) :=
  finsupp.add_group

protected instance ring {k : Type u₁} {G : Type u₂} [ring k] [add_monoid G] :
    ring (add_monoid_algebra k G) :=
  ring.mk semiring.add sorry semiring.zero sorry sorry Neg.neg Sub.sub sorry sorry semiring.mul
    sorry semiring.one sorry sorry sorry sorry

protected instance comm_ring {k : Type u₁} {G : Type u₂} [comm_ring k] [add_comm_monoid G] :
    comm_ring (add_monoid_algebra k G) :=
  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

protected instance has_scalar {k : Type u₁} {G : Type u₂} {R : Type u_1} [semiring R] [semiring k]
    [semimodule R k] : has_scalar R (add_monoid_algebra k G) :=
  finsupp.has_scalar

protected instance semimodule {k : Type u₁} {G : Type u₂} {R : Type u_1} [semiring R] [semiring k]
    [semimodule R k] : semimodule R (add_monoid_algebra k G) :=
  finsupp.semimodule G k

/-! It is hard to state the equivalent of `distrib_mul_action G (add_monoid_algebra k G)`
because we've never discussed actions of additive groups. -/

theorem mul_apply {k : Type u₁} {G : Type u₂} [semiring k] [add_monoid G]
    (f : add_monoid_algebra k G) (g : add_monoid_algebra k G) (x : G) :
    coe_fn (f * g) x =
        finsupp.sum f
          fun (a₁ : G) (b₁ : k) =>
            finsupp.sum g fun (a₂ : G) (b₂ : k) => ite (a₁ + a₂ = x) (b₁ * b₂) 0 :=
  monoid_algebra.mul_apply f g x

theorem mul_apply_antidiagonal {k : Type u₁} {G : Type u₂} [semiring k] [add_monoid G]
    (f : add_monoid_algebra k G) (g : add_monoid_algebra k G) (x : G) (s : finset (G × G))
    (hs : ∀ {p : G × G}, p ∈ s ↔ prod.fst p + prod.snd p = x) :
    coe_fn (f * g) x =
        finset.sum s fun (p : G × G) => coe_fn f (prod.fst p) * coe_fn g (prod.snd p) :=
  monoid_algebra.mul_apply_antidiagonal f g x s hs

theorem support_mul {k : Type u₁} {G : Type u₂} [semiring k] [add_monoid G]
    (a : add_monoid_algebra k G) (b : add_monoid_algebra k G) :
    finsupp.support (a * b) ⊆
        finset.bUnion (finsupp.support a)
          fun (a₁ : G) => finset.bUnion (finsupp.support b) fun (a₂ : G) => singleton (a₁ + a₂) :=
  monoid_algebra.support_mul a b

theorem single_mul_single {k : Type u₁} {G : Type u₂} [semiring k] [add_monoid G] {a₁ : G} {a₂ : G}
    {b₁ : k} {b₂ : k} :
    finsupp.single a₁ b₁ * finsupp.single a₂ b₂ = finsupp.single (a₁ + a₂) (b₁ * b₂) :=
  monoid_algebra.single_mul_single

/-- Like `finsupp.map_domain_add`, but for the convolutive multiplication we define in this file -/
theorem map_domain_mul {α : Type u_1} {β : Type u_2} {α₂ : Type u_3} [semiring β] [add_monoid α]
    [add_monoid α₂] {x : add_monoid_algebra β α} {y : add_monoid_algebra β α} (f : add_hom α α₂) :
    finsupp.map_domain (⇑f) (x * y) = finsupp.map_domain (⇑f) x * finsupp.map_domain (⇑f) y :=
  sorry

/-- Embedding of a monoid into its monoid algebra. -/
def of (k : Type u₁) (G : Type u₂) [semiring k] [add_monoid G] :
    multiplicative G →* add_monoid_algebra k G :=
  monoid_hom.mk (fun (a : multiplicative G) => finsupp.single a 1) sorry sorry

@[simp] theorem of_apply {k : Type u₁} {G : Type u₂} [semiring k] [add_monoid G]
    (a : multiplicative G) :
    coe_fn (of k G) a = finsupp.single (coe_fn multiplicative.to_add a) 1 :=
  rfl

theorem of_injective {k : Type u₁} {G : Type u₂} [semiring k] [add_monoid G] [nontrivial k] :
    function.injective ⇑(of k G) :=
  sorry

theorem mul_single_apply_aux {k : Type u₁} {G : Type u₂} [semiring k] [add_monoid G]
    (f : add_monoid_algebra k G) (r : k) (x : G) (y : G) (z : G)
    (H : ∀ (a : G), a + x = z ↔ a = y) : coe_fn (f * finsupp.single x r) z = coe_fn f y * r :=
  monoid_algebra.mul_single_apply_aux f H

theorem mul_single_zero_apply {k : Type u₁} {G : Type u₂} [semiring k] [add_monoid G]
    (f : add_monoid_algebra k G) (r : k) (x : G) :
    coe_fn (f * finsupp.single 0 r) x = coe_fn f x * r :=
  mul_single_apply_aux f r 0 x x
    fun (a : G) =>
      eq.mpr (id (Eq._oldrec (Eq.refl (a + 0 = x ↔ a = x)) (add_zero a))) (iff.refl (a = x))

theorem single_mul_apply_aux {k : Type u₁} {G : Type u₂} [semiring k] [add_monoid G]
    (f : add_monoid_algebra k G) (r : k) (x : G) (y : G) (z : G)
    (H : ∀ (a : G), x + a = y ↔ a = z) : coe_fn (finsupp.single x r * f) y = r * coe_fn f z :=
  monoid_algebra.single_mul_apply_aux f H

theorem single_zero_mul_apply {k : Type u₁} {G : Type u₂} [semiring k] [add_monoid G]
    (f : add_monoid_algebra k G) (r : k) (x : G) :
    coe_fn (finsupp.single 0 r * f) x = r * coe_fn f x :=
  single_mul_apply_aux f r 0 x x
    fun (a : G) =>
      eq.mpr (id (Eq._oldrec (Eq.refl (0 + a = x ↔ a = x)) (zero_add a))) (iff.refl (a = x))

theorem lift_nc_smul {k : Type u₁} {G : Type u₂} [semiring k] [add_monoid G] {R : Type u_1}
    [semiring R] (f : k →+* R) (g : multiplicative G →* R) (c : k) (φ : monoid_algebra k G) :
    coe_fn (lift_nc (↑f) g) (c • φ) = coe_fn f c * coe_fn (lift_nc (↑f) g) φ :=
  monoid_algebra.lift_nc_smul f g c φ

end add_monoid_algebra

/-!
#### Conversions between `add_monoid_algebra` and `monoid_algebra`

While we were not able to define `add_monoid_algebra k G = monoid_algebra k (multiplicative G)` due
to definitional inconveniences, we can still show the types are isomorphic.
-/

/-- The equivalence between `add_monoid_algebra` and `monoid_algebra` in terms of
`multiplicative` -/
protected def add_monoid_algebra.to_multiplicative (k : Type u₁) (G : Type u₂) [semiring k]
    [add_monoid G] : add_monoid_algebra k G ≃+* monoid_algebra k (multiplicative G) :=
  ring_equiv.mk (add_equiv.to_fun (finsupp.dom_congr multiplicative.of_add))
    (add_equiv.inv_fun (finsupp.dom_congr multiplicative.of_add)) sorry sorry sorry sorry

/-- The equivalence between `monoid_algebra` and `add_monoid_algebra` in terms of `additive` -/
protected def monoid_algebra.to_additive (k : Type u₁) (G : Type u₂) [semiring k] [monoid G] :
    monoid_algebra k G ≃+* add_monoid_algebra k (additive G) :=
  ring_equiv.mk (add_equiv.to_fun (finsupp.dom_congr additive.of_mul))
    (add_equiv.inv_fun (finsupp.dom_congr additive.of_mul)) sorry sorry sorry sorry

namespace add_monoid_algebra

/-! #### Algebra structure -/

/-- `finsupp.single 0` as a `ring_hom` -/
@[simp] theorem single_zero_ring_hom_apply {k : Type u₁} {G : Type u₂} [semiring k] [add_monoid G] :
    ∀ (ᾰ : k), coe_fn single_zero_ring_hom ᾰ = add_monoid_hom.to_fun (finsupp.single_add_hom 0) ᾰ :=
  fun (ᾰ : k) => Eq.refl (coe_fn single_zero_ring_hom ᾰ)

/-- If two ring homomorphisms from `add_monoid_algebra k G` are equal on all `single a 1`
and `single 0 b`, then they are equal. -/
theorem ring_hom_ext {k : Type u₁} {G : Type u₂} {R : Type u_1} [semiring k] [add_monoid G]
    [semiring R] {f : add_monoid_algebra k G →+* R} {g : add_monoid_algebra k G →+* R}
    (h₀ : ∀ (b : k), coe_fn f (finsupp.single 0 b) = coe_fn g (finsupp.single 0 b))
    (h_of : ∀ (a : G), coe_fn f (finsupp.single a 1) = coe_fn g (finsupp.single a 1)) : f = g :=
  monoid_algebra.ring_hom_ext h₀ h_of

/-- If two ring homomorphisms from `add_monoid_algebra k G` are equal on all `single a 1`
and `single 0 b`, then they are equal.

See note [partially-applied ext lemmas]. -/
theorem ring_hom_ext' {k : Type u₁} {G : Type u₂} {R : Type u_1} [semiring k] [add_monoid G]
    [semiring R] {f : add_monoid_algebra k G →+* R} {g : add_monoid_algebra k G →+* R}
    (h₁ : ring_hom.comp f single_zero_ring_hom = ring_hom.comp g single_zero_ring_hom)
    (h_of : monoid_hom.comp (↑f) (of k G) = monoid_hom.comp (↑g) (of k G)) : f = g :=
  ring_hom_ext (ring_hom.congr_fun h₁) (monoid_hom.congr_fun h_of)

/--
The instance `algebra R (add_monoid_algebra k G)` whenever we have `algebra R k`.

In particular this provides the instance `algebra k (add_monoid_algebra k G)`.
-/
protected instance algebra {k : Type u₁} {G : Type u₂} {R : Type u_1} [comm_semiring R] [semiring k]
    [algebra R k] [add_monoid G] : algebra R (add_monoid_algebra k G) :=
  algebra.mk
    (ring_hom.mk (ring_hom.to_fun (ring_hom.comp single_zero_ring_hom (algebra_map R k))) sorry
      sorry sorry sorry)
    sorry sorry

/-- `finsupp.single 0` as a `alg_hom` -/
def single_zero_alg_hom {k : Type u₁} {G : Type u₂} {R : Type u_1} [comm_semiring R] [semiring k]
    [algebra R k] [add_monoid G] : alg_hom R k (add_monoid_algebra k G) :=
  alg_hom.mk (ring_hom.to_fun single_zero_ring_hom) sorry sorry sorry sorry sorry

@[simp] theorem coe_algebra_map {k : Type u₁} {G : Type u₂} {R : Type u_1} [comm_semiring R]
    [semiring k] [algebra R k] [add_monoid G] :
    ⇑(algebra_map R (add_monoid_algebra k G)) = finsupp.single 0 ∘ ⇑(algebra_map R k) :=
  rfl

/-- `lift_nc_ring_hom` as a `alg_hom`, for when `f` is an `alg_hom` -/
def lift_nc_alg_hom {k : Type u₁} {G : Type u₂} [comm_semiring k] [add_monoid G] {A : Type u₃}
    [semiring A] [algebra k A] {B : Type u_1} [semiring B] [algebra k B] (f : alg_hom k A B)
    (g : multiplicative G →* B)
    (h_comm : ∀ (x : A) (y : multiplicative G), commute (coe_fn f x) (coe_fn g y)) :
    alg_hom k (add_monoid_algebra A G) B :=
  alg_hom.mk ⇑(lift_nc_ring_hom (↑f) g h_comm) sorry sorry sorry sorry sorry

/-- A `k`-algebra homomorphism from `monoid_algebra k G` is uniquely defined by its
values on the functions `single a 1`. -/
theorem alg_hom_ext {k : Type u₁} {G : Type u₂} [comm_semiring k] [add_monoid G] {A : Type u₃}
    [semiring A] [algebra k A] {φ₁ : alg_hom k (add_monoid_algebra k G) A}
    {φ₂ : alg_hom k (add_monoid_algebra k G) A}
    (h : ∀ (x : G), coe_fn φ₁ (finsupp.single x 1) = coe_fn φ₂ (finsupp.single x 1)) : φ₁ = φ₂ :=
  monoid_algebra.alg_hom_ext h

/-- See note [partially-applied ext lemmas]. -/
theorem alg_hom_ext' {k : Type u₁} {G : Type u₂} [comm_semiring k] [add_monoid G] {A : Type u₃}
    [semiring A] [algebra k A] {φ₁ : alg_hom k (add_monoid_algebra k G) A}
    {φ₂ : alg_hom k (add_monoid_algebra k G) A}
    (h : monoid_hom.comp (↑φ₁) (of k G) = monoid_hom.comp (↑φ₂) (of k G)) : φ₁ = φ₂ :=
  alg_hom_ext (monoid_hom.congr_fun h)

/-- Any monoid homomorphism `G →* A` can be lifted to an algebra homomorphism
`monoid_algebra k G →ₐ[k] A`. -/
def lift (k : Type u₁) (G : Type u₂) [comm_semiring k] [add_monoid G] (A : Type u₃) [semiring A]
    [algebra k A] : (multiplicative G →* A) ≃ alg_hom k (add_monoid_algebra k G) A :=
  equiv.mk
    (fun (F : multiplicative G →* A) =>
      alg_hom.mk ⇑(lift_nc_alg_hom (algebra.of_id k A) F sorry) sorry sorry sorry sorry sorry)
    (fun (f : alg_hom k (add_monoid_algebra k G) A) => monoid_hom.comp (↑f) (of k G)) sorry sorry

theorem lift_apply' {k : Type u₁} {G : Type u₂} [comm_semiring k] [add_monoid G] {A : Type u₃}
    [semiring A] [algebra k A] (F : multiplicative G →* A) (f : monoid_algebra k G) :
    coe_fn (coe_fn (lift k G A) F) f =
        finsupp.sum f
          fun (a : G) (b : k) =>
            coe_fn (algebra_map k A) b * coe_fn F (coe_fn multiplicative.of_add a) :=
  rfl

theorem lift_apply {k : Type u₁} {G : Type u₂} [comm_semiring k] [add_monoid G] {A : Type u₃}
    [semiring A] [algebra k A] (F : multiplicative G →* A) (f : monoid_algebra k G) :
    coe_fn (coe_fn (lift k G A) F) f =
        finsupp.sum f fun (a : G) (b : k) => b • coe_fn F (coe_fn multiplicative.of_add a) :=
  sorry

theorem lift_def {k : Type u₁} {G : Type u₂} [comm_semiring k] [add_monoid G] {A : Type u₃}
    [semiring A] [algebra k A] (F : multiplicative G →* A) :
    ⇑(coe_fn (lift k G A) F) = ⇑(lift_nc (↑(algebra_map k A)) F) :=
  rfl

@[simp] theorem lift_symm_apply {k : Type u₁} {G : Type u₂} [comm_semiring k] [add_monoid G]
    {A : Type u₃} [semiring A] [algebra k A] (F : alg_hom k (add_monoid_algebra k G) A)
    (x : multiplicative G) :
    coe_fn (coe_fn (equiv.symm (lift k G A)) F) x =
        coe_fn F (finsupp.single (coe_fn multiplicative.to_add x) 1) :=
  rfl

theorem lift_of {k : Type u₁} {G : Type u₂} [comm_semiring k] [add_monoid G] {A : Type u₃}
    [semiring A] [algebra k A] (F : multiplicative G →* A) (x : multiplicative G) :
    coe_fn (coe_fn (lift k G A) F) (coe_fn (of k G) x) = coe_fn F x :=
  sorry

@[simp] theorem lift_single {k : Type u₁} {G : Type u₂} [comm_semiring k] [add_monoid G]
    {A : Type u₃} [semiring A] [algebra k A] (F : multiplicative G →* A) (a : G) (b : k) :
    coe_fn (coe_fn (lift k G A) F) (finsupp.single a b) =
        b • coe_fn F (coe_fn multiplicative.of_add a) :=
  sorry

theorem lift_unique' {k : Type u₁} {G : Type u₂} [comm_semiring k] [add_monoid G] {A : Type u₃}
    [semiring A] [algebra k A] (F : alg_hom k (add_monoid_algebra k G) A) :
    F = coe_fn (lift k G A) (monoid_hom.comp (↑F) (of k G)) :=
  Eq.symm (equiv.apply_symm_apply (lift k G A) F)

/-- Decomposition of a `k`-algebra homomorphism from `monoid_algebra k G` by
its values on `F (single a 1)`. -/
theorem lift_unique {k : Type u₁} {G : Type u₂} [comm_semiring k] [add_monoid G] {A : Type u₃}
    [semiring A] [algebra k A] (F : alg_hom k (add_monoid_algebra k G) A) (f : monoid_algebra k G) :
    coe_fn F f = finsupp.sum f fun (a : G) (b : k) => b • coe_fn F (finsupp.single a 1) :=
  sorry

theorem alg_hom_ext_iff {k : Type u₁} {G : Type u₂} [comm_semiring k] [add_monoid G] {A : Type u₃}
    [semiring A] [algebra k A] {φ₁ : alg_hom k (add_monoid_algebra k G) A}
    {φ₂ : alg_hom k (add_monoid_algebra k G) A} :
    (∀ (x : G), coe_fn φ₁ (finsupp.single x 1) = coe_fn φ₂ (finsupp.single x 1)) ↔ φ₁ = φ₂ :=
  { mp :=
      fun (h : ∀ (x : G), coe_fn φ₁ (finsupp.single x 1) = coe_fn φ₂ (finsupp.single x 1)) =>
        alg_hom_ext h,
    mpr := fun (ᾰ : φ₁ = φ₂) (x : G) => Eq._oldrec (Eq.refl (coe_fn φ₁ (finsupp.single x 1))) ᾰ }

theorem prod_single {k : Type u₁} {G : Type u₂} {ι : Type ui} [comm_semiring k] [add_comm_monoid G]
    {s : finset ι} {a : ι → G} {b : ι → k} :
    (finset.prod s fun (i : ι) => finsupp.single (a i) (b i)) =
        finsupp.single (finset.sum s fun (i : ι) => a i) (finset.prod s fun (i : ι) => b i) :=
  sorry

end Mathlib


/-
Copyright (c) 2021 OpenAI. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kunhao Zheng, Stanislas Polu, David Renshaw, OpenAI GPT-f
-/
import mathzoo.imports.miniF2F

open_locale nat rat real big_operators topological_space

theorem mathd_algebra_142
  (m b : ℝ)
  (h₀ : m * 7 + b = -1)
  (h₁ : m * (-1) + b = 7) :
  m + b = 5 :=
begin
  linarith,
end


/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro, Johan Commelin
-/
import algebra.ring.basic
import data.equiv.basic

/-!
# Adjoining a zero/one to semigroups and related algebraic structures

This file contains different results about adjoining an element to an algebraic structure which then
behaves like a zero or a one. An example is adjoining a one to a semigroup to obtain a monoid. That
this provides an example of an adjunction is proved in `algebra.category.Mon.adjunctions`.

Another result says that adjoining to a group an element `zero` gives a `group_with_zero`. For more
information about these structures (which are not that standard in informal mathematics, see
`algebra.group_with_zero.basic`)
-/

universes u v w
variable {α : Type u}

/-- Add an extra element `1` to a type -/
@[to_additive "Add an extra element `0` to a type"]
def with_one (α) := option α

namespace with_one

@[to_additive]
instance : monad with_one := option.monad

@[to_additive]
instance : has_one (with_one α) := ⟨none⟩

@[to_additive]
instance [has_mul α] : has_mul (with_one α) := ⟨option.lift_or_get (*)⟩

@[to_additive]
instance [has_inv α] : has_inv (with_one α) := ⟨λ a, option.map has_inv.inv a⟩

@[to_additive]
instance : inhabited (with_one α) := ⟨1⟩

@[to_additive]
instance [nonempty α] : nontrivial (with_one α) := option.nontrivial

@[to_additive]
instance : has_coe_t α (with_one α) := ⟨some⟩

@[to_additive]
lemma some_eq_coe {a : α} : (some a : with_one α) = ↑a := rfl

@[simp, to_additive]
lemma coe_ne_one {a : α} : (a : with_one α) ≠ (1 : with_one α) :=
option.some_ne_none a

@[simp, to_additive]
lemma one_ne_coe {a : α} : (1 : with_one α) ≠ a :=
coe_ne_one.symm

@[to_additive]
lemma ne_one_iff_exists {x : with_one α} : x ≠ 1 ↔ ∃ (a : α), ↑a = x :=
option.ne_none_iff_exists

@[to_additive]
instance : can_lift (with_one α) α :=
{ coe := coe,
  cond := λ a, a ≠ 1,
  prf := λ a, ne_one_iff_exists.1 }

@[simp, norm_cast, to_additive]
lemma coe_inj {a b : α} : (a : with_one α) = b ↔ a = b :=
option.some_inj

@[elab_as_eliminator, to_additive]
protected lemma cases_on {P : with_one α → Prop} :
  ∀ (x : with_one α), P 1 → (∀ a : α, P a) → P x :=
option.cases_on

-- the `show` statements in the proofs are important, because otherwise the generated lemmas
-- `with_one.mul_one_class._proof_{1,2}` have an ill-typed statement after `with_one` is made
-- irreducible.
@[to_additive]
instance [has_mul α] : mul_one_class (with_one α) :=
{ mul := (*),
  one := (1),
  one_mul   := show ∀ x : with_one α, 1 * x = x, from (option.lift_or_get_is_left_id _).1,
  mul_one   := show ∀ x : with_one α, x * 1 = x, from (option.lift_or_get_is_right_id _).1 }

@[to_additive]
instance [semigroup α] : monoid (with_one α) :=
{ mul_assoc := (option.lift_or_get_assoc _).1,
  ..with_one.mul_one_class }

example [semigroup α] :
  @monoid.to_mul_one_class _ (@with_one.monoid α _) = @with_one.mul_one_class α _ := rfl

@[to_additive]
instance [comm_semigroup α] : comm_monoid (with_one α) :=
{ mul_comm := (option.lift_or_get_comm _).1,
  ..with_one.monoid }

section
-- workaround: we make `with_one`/`with_zero` irreducible for this definition, otherwise `simps`
-- will unfold it in the statement of the lemma it generates.
local attribute [irreducible] with_one with_zero
/-- `coe` as a bundled morphism -/
@[to_additive "`coe` as a bundled morphism", simps apply]
def coe_mul_hom [has_mul α] : mul_hom α (with_one α) :=
{ to_fun := coe, map_mul' := λ x y, rfl }

end

section lift

variables [has_mul α] {β : Type v} [mul_one_class β]

/-- Lift a semigroup homomorphism `f` to a bundled monoid homorphism. -/
@[to_additive "Lift an add_semigroup homomorphism `f` to a bundled add_monoid homorphism."]
def lift : mul_hom α β ≃ (with_one α →* β) :=
{ to_fun := λ f,
  { to_fun := λ x, option.cases_on x 1 f,
    map_one' := rfl,
    map_mul' := λ x y,
      with_one.cases_on x (by { rw one_mul, exact (one_mul _).symm }) $ λ x,
      with_one.cases_on y (by { rw mul_one, exact (mul_one _).symm }) $ λ y,
      f.map_mul x y },
  inv_fun := λ F, F.to_mul_hom.comp coe_mul_hom,
  left_inv := λ f, mul_hom.ext $ λ x, rfl,
  right_inv := λ F, monoid_hom.ext $ λ x, with_one.cases_on x F.map_one.symm $ λ x, rfl }

variables (f : mul_hom α β)

@[simp, to_additive]
lemma lift_coe (x : α) : lift f x = f x := rfl

@[simp, to_additive]
lemma lift_one : lift f 1 = 1 := rfl

@[to_additive]
theorem lift_unique (f : with_one α →* β) : f = lift (f.to_mul_hom.comp coe_mul_hom) :=
(lift.apply_symm_apply f).symm

end lift

section map

variables {β : Type v} [has_mul α] [has_mul β]

/-- Given a multiplicative map from `α → β` returns a monoid homomorphism
  from `with_one α` to `with_one β` -/
@[to_additive "Given an additive map from `α → β` returns an add_monoid homomorphism
  from `with_zero α` to `with_zero β`"]
def map (f : mul_hom α β) : with_one α →* with_one β :=
lift (coe_mul_hom.comp f)

@[simp, to_additive]
lemma map_id : map (mul_hom.id α) = monoid_hom.id (with_one α) :=
by { ext, cases x; refl }

@[simp, to_additive]
lemma map_comp {γ : Type w} [has_mul γ] (f : mul_hom α β) (g : mul_hom β γ) :
map (g.comp f) = (map g).comp (map f) :=
by { ext, cases x; refl }

end map

attribute [irreducible] with_one

@[simp, norm_cast, to_additive]
lemma coe_mul [has_mul α] (a b : α) : ((a * b : α) : with_one α) = a * b := rfl

@[simp, norm_cast, to_additive]
lemma coe_inv [has_inv α] (a : α) : ((a⁻¹ : α) : with_one α) = a⁻¹ := rfl

end with_one

namespace with_zero

instance [one : has_one α] : has_one (with_zero α) :=
{ ..one }

@[simp, norm_cast] lemma coe_one [has_one α] : ((1 : α) : with_zero α) = 1 := rfl

instance [has_mul α] : mul_zero_class (with_zero α) :=
{ mul       := λ o₁ o₂, o₁.bind (λ a, option.map (λ b, a * b) o₂),
  zero_mul  := λ a, rfl,
  mul_zero  := λ a, by cases a; refl,
  ..with_zero.has_zero }

@[simp, norm_cast] lemma coe_mul {α : Type u} [has_mul α]
  {a b : α} : ((a * b : α) : with_zero α) = a * b := rfl

@[simp] lemma zero_mul {α : Type u} [has_mul α]
  (a : with_zero α) : 0 * a = 0 := rfl

@[simp] lemma mul_zero {α : Type u} [has_mul α]
  (a : with_zero α) : a * 0 = 0 := by cases a; refl

instance [semigroup α] : semigroup_with_zero (with_zero α) :=
{ mul_assoc := λ a b c, match a, b, c with
    | none,   _,      _      := rfl
    | some a, none,   _      := rfl
    | some a, some b, none   := rfl
    | some a, some b, some c := congr_arg some (mul_assoc _ _ _)
    end,
  ..with_zero.mul_zero_class }

instance [comm_semigroup α] : comm_semigroup (with_zero α) :=
{ mul_comm := λ a b, match a, b with
    | none,   _      := (mul_zero _).symm
    | some a, none   := rfl
    | some a, some b := congr_arg some (mul_comm _ _)
    end,
  ..with_zero.semigroup_with_zero }

instance [mul_one_class α] : mul_zero_one_class (with_zero α) :=
{ one_mul := λ a, match a with
    | none   := rfl
    | some a := congr_arg some $ one_mul _
    end,
  mul_one := λ a, match a with
    | none   := rfl
    | some a := congr_arg some $ mul_one _
    end,
  ..with_zero.mul_zero_class,
  ..with_zero.has_one }

instance [has_one α] [has_pow α ℕ] : has_pow (with_zero α) ℕ :=
⟨λ x n, match x, n with
  | none, 0 := 1
  | none, n + 1 := 0
  | some x, n := ↑(x ^ n)
  end⟩

@[simp, norm_cast] lemma coe_pow [has_one α] [has_pow α ℕ] {a : α} (n : ℕ) :
  ↑(a ^ n : α) = (↑a ^ n : with_zero α) := rfl

instance [monoid α] : monoid_with_zero (with_zero α) :=
{ npow := λ n x, x ^ n,
  npow_zero' := λ x, match x with
    | none   := rfl
    | some x := congr_arg some $ pow_zero _
    end,
  npow_succ' := λ n x, match x with
    | none   := rfl
    | some x := congr_arg some $ pow_succ _ _
    end,
  .. with_zero.mul_zero_one_class,
  .. with_zero.semigroup_with_zero }

instance [comm_monoid α] : comm_monoid_with_zero (with_zero α) :=
{ ..with_zero.monoid_with_zero, ..with_zero.comm_semigroup }

/-- Given an inverse operation on `α` there is an inverse operation
  on `with_zero α` sending `0` to `0`-/
instance [has_inv α] : has_inv (with_zero α) := ⟨λ a, option.map has_inv.inv a⟩

@[simp, norm_cast] lemma coe_inv [has_inv α] (a : α) :
  ((a⁻¹ : α) : with_zero α) = a⁻¹ := rfl

@[simp] lemma inv_zero [has_inv α] :
  (0 : with_zero α)⁻¹ = 0 := rfl

instance [has_div α] : has_div (with_zero α) :=
⟨λ o₁ o₂, o₁.bind (λ a, option.map (λ b, a / b) o₂)⟩

@[norm_cast] lemma coe_div [has_div α] (a b : α) : ↑(a / b : α) = (a / b : with_zero α) := rfl

instance [has_one α] [has_pow α ℤ] : has_pow (with_zero α) ℤ :=
⟨λ x n, match x, n with
  | none, int.of_nat 0            := 1
  | none, int.of_nat (nat.succ n) := 0
  | none, int.neg_succ_of_nat n   := 0
  | some x, n                     := ↑(x ^ n)
  end⟩

@[simp, norm_cast] lemma coe_zpow [div_inv_monoid α] {a : α} (n : ℤ) :
  ↑(a ^ n : α) = (↑a ^ n : with_zero α) := rfl

instance [div_inv_monoid α] : div_inv_monoid (with_zero α) :=
{ div_eq_mul_inv := λ a b, match a, b with
    | none,   _      := rfl
    | some a, none   := rfl
    | some a, some b := congr_arg some (div_eq_mul_inv _ _)
    end,
  zpow := λ n x, x ^ n,
  zpow_zero' := λ x, match x with
    | none   := rfl
    | some x := congr_arg some $ zpow_zero _
    end,
  zpow_succ' := λ n x, match x with
    | none   := rfl
    | some x := congr_arg some $ div_inv_monoid.zpow_succ' _ _
    end,
  zpow_neg' := λ n x, match x with
    | none   := rfl
    | some x := congr_arg some $ div_inv_monoid.zpow_neg' _ _
    end,
  .. with_zero.has_div,
  .. with_zero.has_inv,
  .. with_zero.monoid_with_zero, }

section group
variables [group α]

@[simp] lemma inv_one : (1 : with_zero α)⁻¹ = 1 :=
show ((1⁻¹ : α) : with_zero α) = 1, by simp

/-- if `G` is a group then `with_zero G` is a group with zero. -/
instance : group_with_zero (with_zero α) :=
{ inv_zero := inv_zero,
  mul_inv_cancel := λ a ha, by { lift a to α using ha, norm_cast, apply mul_right_inv },
  .. with_zero.monoid_with_zero,
  .. with_zero.div_inv_monoid,
  .. with_zero.nontrivial }

end group

instance [comm_group α] : comm_group_with_zero (with_zero α) :=
{ .. with_zero.group_with_zero, .. with_zero.comm_monoid_with_zero }

instance [semiring α] : semiring (with_zero α) :=
{ left_distrib := λ a b c, begin
    cases a with a, {refl},
    cases b with b; cases c with c; try {refl},
    exact congr_arg some (left_distrib _ _ _)
  end,
  right_distrib := λ a b c, begin
    cases c with c,
    { change (a + b) * 0 = a * 0 + b * 0, simp },
    cases a with a; cases b with b; try {refl},
    exact congr_arg some (right_distrib _ _ _)
  end,
  ..with_zero.add_comm_monoid,
  ..with_zero.mul_zero_class,
  ..with_zero.monoid_with_zero }

attribute [irreducible] with_zero

end with_zero


import data.finset
import data.finsupp
import algebra.big_operators.order

namespace finset

lemma filter_mem_set_of_subset_set {α} {s : set α} [decidable_pred (λ x, x ∈ s)]
  {fs : finset α} (h : ↑fs ⊆ s) :
  filter (λ x, x ∈ s) fs = fs :=
begin
  ext x,
  split,
  { apply filter_subset },
  { intro hmem, rw mem_filter, exact ⟨ hmem , h hmem ⟩ },
end

end finset

namespace finsupp

lemma le_sum {σ : Type*}
  (f : σ →₀ ℕ) (x : σ) :
  f x ≤ f.support.sum f :=
dite (f x = 0)
(λ h, by simp [h])
(λ h, finset.single_le_sum (λ s hs, nat.zero_le _) (finsupp.mem_support_iff.2 h))

end finsupp


--Thu Aug 22 08:26:12 -03 2019
-- Luiz Carlos R. Viana

import data.set.basic algebra.big_operators
data.nat.basic data.real.basic
tactic.tidy

-- We formalize the curriculum of a basic analysis course from scratch in Lean
-- (even though this is already part of the standard library).

-- The goal here however is the readability and simplicity of proofs, so that this material may
-- be used to teach undergraduate students about sets and proofs in the future.
-- For details about the language itself, the reader should refer to the guide "Theorem Proving in Lean", which can be
-- found at https://Leanprover.github.io/theorem_proving_in_Lean/index.html (access date = date of this document).

-- On a more technical note, since interactive theorem provers use type theory instead of set theory as a foundation
-- for mathematics, in order to develop the usual (material, pure) set theoretic foundation of analysis within
-- this type theory, we would need to consider an internal model of set theory within type theory.
-- This was already accomplished in the standard library in the module set_theory.zfc, but the approach used there
-- is unnecessarily technical for our purposes, as it would be hard to teach using the foundations there outlined.

-- Instead the approach used here is simply to declare a type of base things a set can be composed of and then prove
-- results in a similar fashion as is done in the standard library, such as in data.set.basic. This gives us a more
-- canonical way of writing this material without having to concern ourselves all that much with complex constructions involving
-- types. As an inevitable result of this, when we go up the hierarchy of sets we will notice that ∈ is unavoidably
-- type theoretical, since x ∈ y is not defined for arbitrary sets x and y.

-- We begin with the primitive notion of a Type. A Type is a kind of thing, and each thing has a single type.
-- For instance, there is a Type ℕ of numbers, and the things of Type ℕ are called natural numbers. We write n : ℕ
-- to indicate that n is an instance of Type ℕ, i.e. that n is a natural number.

-- One thing that is important to notice about the declaration "n : ℕ" is that it is not a proposition, as it
-- makes little sense to ask wether it is true or false. Rather the typing declaration of n is a presupposition of
-- any proposition we make involving n, without which it would not make sense. For instance, we can say
-- "the number 2 is walking in the street", and one interpretation of this expression would say that it is a proposition
-- that is false; but certainly there is something else going on here. If the expression is false, it doesn't appear to be
-- false in the exact same sense in which we say that "2 = 3" is false, but rather it would appear to us that the expression
-- itself is nonsensical. "Walking in the street" simply is not an operation that is defined for natural numbers, so the
-- expression itself, though it may pose as a proposition, is ill-formed. Rather, we must presuppose that we know the types
-- of things that we are talking about so as to understand the possible ways we can form propositions involving them.
-- In type theory we consider that both propositions and typing declarations are different forms of judgement.
open set
namespace hidden

-- Where do Types live in? We can define an universe of discourse which will include all Types relevant to the development
-- of our theory, and this universe will be the collection of all our Types.
universe u

-- All that is needed to develop set theory from type theory is a single Type of things we wish
-- to talk about, so let α be a Type in the universe u

variable α : Type u

-- A set X of α's can be identified with a function which takes x : α and constructs a proposition "x is an element of X".
-- This is already defined in Lean's standard library, so we simply reproduce that definition here.
-- def set (α : Type u) := α → Prop

-- We can give a few examples of sets of different Types, for instance instead of α we could use natural numbers:
example : set ℕ := {x : ℕ | x > 0} -- this is the set of all natural numbers greater than 0.
example : set ℕ := {1, 2, 3}

-- If X is a set, the symbol ∈ is used as notation for membership in X, so if x : α, the proposition x ∈ X is the
-- one we get by applying X over x as a function.

-- We now start to define important notions involving sets. The first of them is set inclusion:

-- This definition says that s₁ is a subset of s₂ if and only if every element of s₁ is an element of s₂
def subset (s₁ s₂ : set α) := ∀ ⦃a⦄, a ∈ s₁ → a ∈ s₂

-- in order to be able to use the notation ⊆ for sets we need to tell Lean's elaborator that the type set α is
-- one of those types for which this notation is defined. We do this with the following command.
instance : has_subset (set α) :=
⟨set.subset⟩

-- 2 sets X and Y are said to be equal if and only if they have exactly the same elements, i.e. X ⊆ Y and Y ⊆ X.
-- This is called the principle of extensionality for sets. Since Lean treats equality as a primitive concept,
-- we don't really have to define it, rather it is possible to prove from certain axioms within Lean that 2 sets
-- are equal if and only if they have the same elements. The important theorem of the standard library that does this
-- is declared as:
-- theorem ext {a b : set α} (h : ∀ x, x ∈ a ↔ x ∈ b) : a = b

-- We need to keep in mind only that to prove equality between 2 sets X and Y, all we need to do is take
-- an element of X and prove that it is in Y, and then take an element of Y and prove that it is in X.
-- This is equivalent to proving both X ⊆ Y and Y ⊆ X.
-- To aid such proofs there is also a theorem in the standard library:
-- theorem eq_of_subset_of_subset {a b : set α} (h₁ : a ⊆ b) (h₂ : b ⊆ a) : a = b

-- For instance, here is a proof that every set is equal to itself.

--#check or.elim

example : ∀ s : set α, s = s :=
    assume s : set α,
    have s ⊆ s, from
        (assume x : α,
         assume h : x ∈ s,
         show x ∈ s, from h
        ),
    show s = s, from eq_of_subset_of_subset this this -- notice "this" refers to the last theorem proved using "have".

-- This proof, although very simple, is much more complicated than it needs to be.
-- We already have a standard method of proving equality for any given Type without the need to go
-- into details about the Type in question.

example : ∀ s : set α, s = s := assume s : set α, rfl

-- We can then define the notions of union and intersection of sets and their respective notations,
-- and prove theorems about them.

def union (s₁ s₂ : set α) : set α := {a | a ∈ s₁ ∨ a ∈ s₂}

-- We use ∪ for union.
instance : has_union (set α) := ⟨set.union⟩

def inter (s₁ s₂ : set α) : set α := {a | a ∈ s₁ ∧ a ∈ s₂}

-- We use ∩ for intersection.
instance : has_inter (set α) := ⟨set.inter⟩

-- here is a result a little bit harder than the previous one.
lemma distributivity₁ : ∀ {A B C : set α}, (A ∩ B) ∪ C = (A ∪ C) ∩ (B ∪ C) :=
    assume A B C : set α, -- let A, B, C be sets.
    -- we prove the side (⊆) first.
    have c₀ : (A ∩ B) ∪ C ⊆ (A ∪ C) ∩ (B ∪ C), from
        (assume x : α, -- suppose x is an α.
         assume h : x ∈ (A ∩ B) ∪ C, -- suppose x is an element of the left hand side.
         have c₀ : x ∈ (A ∩ B) ∨ x ∈ C, from h, -- by the definition of ∪, obtain that x is in (A ∩ B) OR x is in C.
         -- lets prove that x ∈ A ∪ C.
         -- We give a proof by cases, assuming in one case that x ∈ (A ∩ B), and in the other that x ∈ C.
         -- The logical rule that allows us to do this is known as or-elimination.
         have c₁ : x ∈ (A ∪ C), from or.elim c₀
            (-- since we know c₀, assume in the fist case x ∈ (A ∩ B)
             assume h : x ∈ (A ∩ B),-- notice this replaces the 'h' defined above.
             -- We won't need that 'h' anymore so we can reuse the name.
             -- the logical rule that allows us to infer that x ∈ A from the fact that both x ∈ A and x ∈ B is called
             -- and-elimination.
             have x ∈ A, from and.elim_left h,
             -- since x ∈ A, x ∈ (A ∪ C). The rule that allows us to infer this is called or-introduction.
             show x ∈ (A ∪ C), from or.inl this
             -- this concludes the proof for the case x ∈ (A ∩ B)
            )
            (-- We then need to show the this works out in the other case as well.
             assume h : x ∈ C,
             -- likewise, we prove the desired result using or-introduction.
             -- Can you tell the difference between the rules or.inl and or.inr? Hint: (l)eft vs (r)ight.
             show x ∈ (A ∪ C), from or.inr h
            ),
        -- next we must prove x ∈ (B ∪ C). The proof is very similar to the previous one.
        have c₂ : x ∈ (B ∪ C), from or.elim c₀
            (assume h : x ∈ (A ∩ B),
             have x ∈ B, from and.elim_right h,
             show x ∈ (B ∪ C), from or.inl this
            )
            (assume h: x ∈ C,
             show x ∈ (B ∪ C), from or.inr h
            ),
        -- to conclude the proof we put both results together.
        show x ∈ (A ∪ C) ∩ (B ∪ C), from ⟨c₁, c₂⟩ -- the ⟨⟩ forms a notation for the rule of and-introduction.
        ),

    -- next we prove the other side.
    -- We we show here that we can write a proof of this sort more efficiently by using a few tricks.
    have c₁ : (A ∪ C) ∩ (B ∪ C) ⊆ (A ∩ B) ∪ C, from
        (assume x : α,
         assume h₀ : x ∈ (A ∪ C) ∩ (B ∪ C),
         match h₀.left with
        | (or.inl h₁) :=
            match h₀.right with
            | (or.inl h₂) := or.inl ⟨h₁, h₂⟩
            | (or.inr h₂) := or.inr h₂
            end
        | (or.inr h₁) := or.inr h₁
        end
        ),

    -- finally we put the 2 results together to prove the equality.
    show (A ∩ B) ∪ C = (A ∪ C) ∩ (B ∪ C), from eq_of_subset_of_subset c₀ c₁

-- When you learn to do these kinds of proof more or less in your head,
-- this is good evidence that you have a decent proficiency with proofs.

-- There is an even shorter way of writing proofs in Lean using tactics. We will show this style
-- of writing in the next theorem.

lemma distributivity₂ : ∀ {A B C : set α}, (A ∪ B) ∩ C = (A ∩ C) ∪ (B ∩ C) :=
begin
    intros A B C,
    apply eq_of_subset_of_subset,
        intros x h,
        cases h.left with c₁ c₂,
            exact or.inl ⟨c₁, h.right⟩,
            exact or.inr ⟨c₂, h.right⟩,
    intros x h,
    cases h with c₁ c₂,
        exact ⟨or.inl c₁.left, c₁.right⟩,
        exact ⟨or.inr c₂.left, c₂.right⟩,
end

-- By using tactics we tell Lean in a more abstract manner what to do to generate a proof of our theorem.
-- We can ask Lean to show the proof it generated using the print command

set_option pp.beta true
set_option pp.notation true
--#print distributivity₂

-- Here is the generated proof:

-- theorem hidden.distributivity₂ : ∀ (α : Type u) {A B C : set α}, (A ∪ B) ∩ C = A ∩ C ∪ B ∩ C :=
-- λ (α : Type u) (A B C : set α),
--   eq_of_subset_of_subset
--     (id
--        (λ (x : α) (h : x ∈ (A ∪ B) ∩ C),
--           or.dcases_on (h.left) (λ (c₁ : x ∈ A), or.inl ⟨c₁, h.right⟩)
--             (λ (c₂ : x ∈ B), or.inr ⟨c₂, h.right⟩)))
--     (id
--        (λ (x : α) (h : x ∈ A ∩ C ∪ B ∩ C),
--           or.dcases_on h (λ (c₁ : x ∈ A ∩ C), ⟨or.inl (c₁.left), c₁.right⟩)
--             (λ (c₂ : x ∈ B ∩ C), ⟨or.inr (c₂.left), c₂.right⟩)))

-- Moving on we prove other basic results:

lemma union_commutative : ∀ {A B : set α}, A ∪ B = B ∪ A :=
begin
    intros A B, -- let A, B be sets.
    apply eq_of_subset_of_subset, -- proceed to prove the equality by showing the inclusions on both sides.
        intros x h, -- to prove the first goal (⊆) assume x : α, h : x ∈ A ∪ B
        cases h, -- proceed to prove x ∈ B ∪ A by cases
            exact or.inr h, -- in case x ∈ A, we have x ∈ B ∪ A by applying or.inr
            exact or.inl h, -- in case x ∈ B, by or.inl
            -- Note: h was renamed to h : x ∈ A and h : x ∈ B, in each case respectively.
            -- this way it is unecessary to declare names c₁, c₂ with the "with" statement, as above.
    intros x h, -- now we prove the second goal, with h : x ∈ B ∪ A
    cases h, -- proceed to prove x ∈ A ∪ B by cases
            exact or.inr h, -- in case x ∈ B, we have x ∈ A ∪ B by applying or.inr
            exact or.inl h, -- in case x ∈ A, by or.inl
    -- Notice the proof of the second goal is symmetric to that of the first!!!
end

lemma union_associative : ∀ {A B C: set α}, (A ∪ B) ∪ C = A ∪ (B ∪ C) :=
begin
    intros A B C,
    apply eq_of_subset_of_subset,
        intros x h,
        cases h with c₁ c₂,
            cases c₁ with c₁₁ c₁₂, -- here we have to case c₁ : x ∈ A ∪ B
                exact or.inl c₁₁,
                exact or.inr (or.inl c₁₂),
            exact or.inr (or.inr c₂),
    intros x h,
    cases h with c₁ c₂,
        exact or.inl (or.inl c₁),
        cases c₂ with c₂₁ c₂₂,
            exact or.inl (or.inr c₂₁),
            exact or.inr c₂₂
end

lemma intersection_commutative : ∀ {A B : set α}, A ∩ B = B ∩ A :=
    by intros; apply eq_of_subset_of_subset; intros x h; exact ⟨h.2, h.1⟩
    -- This reads:
    -- 1. Introduce assumptions.
    -- 2. Prove the equality by eq_of_subset_of_subset.
    -- 3. Assume an x belonging to the respective left hand side of the inclusion.
    -- 4. If ⟨h₁, h₂⟩ is a proof of x ∈ X ∩ Y, with h₁ : x ∈ X and h₂ : x ∈ Y, then
    ---   the proof that x ∈ Y ∩ X is given exactly by ⟨h₂, h₁⟩

lemma intersection_associative : ∀ {A B C: set α}, (A ∩ B) ∩ C = A ∩ (B ∩ C) :=
begin
    intros,
    apply eq_of_subset_of_subset,
        intros x h,
        exact ⟨h.1.1, ⟨h.1.2, h.2⟩⟩,
    intros x h,
    exact ⟨⟨h.1, h.2.1⟩, h.2.2⟩
end

def relative_complement {B : set α} (A : set α) := {x ∈ B | x ∉ A}

instance set_complement : has_neg (set α) := ⟨@relative_complement α univ⟩

lemma set_pnc : ∀ {A : set α}, A ∩ - A = ∅ :=
    by intros; tidy

#print set_pnc
#check ext

lemma complement_distrib : ∀ {A B : set α}, (A ∪ B) ∩ - A = B ∩ - A :=
    by intros A B; rw [@distributivity₂ α A B (-A), set_pnc]; simp

section induction

-- The natural numbers are defined as:
-- inductive nat
-- | zero : nat
-- | succ (n : nat) : nat

-- Inductive types have recursors, which allow us to perform induction in these types.
-- The principle of mathematical induction for natural numbers is stated as follows:
#check nat.rec

open finset

-- example : ∀ n : ℕ, n > 1 → (finset.range n).prod (λi, 1 - 1 / i) =  1 / n :=
-- begin
--     intro n,
--     induction n with n₀ ih,
--         exfalso,
--         exact nat.not_succ_le_zero 1 h,
--     unfold finset.prod at *,
--     simp at *,
--     by_cases n₀ > 1,
--         rewrite ih h,
--         dsimp,

-- end

open nat
#check nat.add_div_left
example : ∀ n : ℕ, sum (range n) (λk, (k+1) / 2^(k+1)) =  (2^(n+1) - n - 2) / 2^n :=
begin
    intro n,
    induction n with n₀ ih,
        simp,
    simp [range_succ, ih, nat.pow_succ 2 n₀],
    admit

    --rewrite nat.pow_succ 2 n₀,

    -- induction n₀ with n₁ ih₂,
    --     simp,
    -- rewrite range_succ,
    -- simp,
    -- rewrite ih,
    -- have h : (n₀ + 1) / 2 ^ (n₀ + 1) + (2 ^ (n₀ + 1) - n₀ - 2) / 2 ^ n₀
    --     = ((n₀ + 1)  + 2*(2 ^ (n₀ + 1) - n₀ - 2) )/ 2 ^ (n₀ + 1), from rfl,

end

open real lattice

#check real.of_near --set.range of_rat
#check set.exists_mem_of_ne_empty

variables (A B : set real)
variables (bddA₁ : bdd_above A) (bddB₁ : bdd_above B)
variables (bddA₂ : bdd_below A) (bddB₂ : bdd_below B)
variables (ne₁ : A ≠ ∅) (ne₂ : B ≠ ∅)
variables (h₁ : A ⊆ set.range of_rat) (h₂ : B ⊆ set.range of_rat)

lemma aux : ∀ ε : ℝ, ε > 0 → ∃ a ∈ A, real.Sup A < a + ε :=
begin
 intros ε a,
 simp at *,
 fsplit;
 --work_on_goal 1 { simp at *, fsplit };
 admit
end

lemma aux₂ : ∀ ε : ℝ, ε > 0 → ∃ a ∈ B, real.Inf B > a - ε :=
sorry

include bddA₁ bddA₂ bddB₁ bddB₂ ne₁ ne₂ h₁ h₂
theorem ex3 : real.Sup A = real.Inf B ↔ (∀ (a ∈ A) (b ∈ B), a ≤ b) ∧ (∀ ε : ℝ, ε > 0 → ∃ (a ∈ A) (b ∈ B), a + ε > b) :=
begin
    constructor; intro h,
    -- ⟶ side
    constructor, -- prova o lado esquerdo do and.
        intros a a_in_A b b_in_B,
        have c₀ : a ≤ real.Sup A, from le_cSup bddA₁ a_in_A,
        have c₁ : real.Inf B ≤ b, from cInf_le bddB₂ b_in_B,
        rewrite h at c₀,
        exact le_trans c₀ c₁,
    intros ε ε_pos,
    obtain ⟨a, a_in_A, c₀⟩ := aux A (ε/2) (mul_pos ε_pos _),
        work_on_goal 1 {ring, exact one_half_pos},
    obtain ⟨b, b_in_B, c₁⟩ := aux₂ B (ε/2) (mul_pos ε_pos _),
        work_on_goal 1 {ring, exact one_half_pos},
    -- cases (aux A (ε/2) (mul_pos ε_pos sorry)) with a c₀,
    --     cases c₀ with a_in_A c₀,
    -- cases (aux₂ B (ε/2) (mul_pos ε_pos sorry)) with b c₁,
    --     cases c₁ with b_in_B c₁,
    suffices c : a + ε > b, from ⟨a, a_in_A, b, b_in_B, c⟩,
    rewrite ←h at *, simp * at *,
    have c, from lt_trans c₁ c₀,
    replace c, from add_lt_add_left c (ε/2),
    rw [add_comm, add_assoc, add_left_neg, add_zero] at c,
    simp at c, exact c,
    -- ⟵ side
    cases h with c₁ c₂,
    have c₀ : ∀ a ∈ A, a ≤ real.Sup A,
        intros a a_in_A,
        exact le_cSup bddA₁ a_in_A,
    have c₃ : ∀ b ∈ B, ∀ a ∈ A, a ≤ b,
        intros b b_in_B x x_in_A,
        exact c₁ x x_in_A b b_in_B,
    have c₄ : ∀ b ∈ B, real.Sup A ≤ b ,
        intros b b_in_B,
        exact cSup_le ne₁ (c₃ b b_in_B),
    have c₅ : real.Sup A ≤ real.Inf B, from le_cInf ne₂ c₄,
    have c₆ : ∀ a ∈ A, real.Inf A ≤ a,
        intros a a_in_A,
        exact cInf_le bddA₂ a_in_A,
    have c₇ : real.Inf A ≤ real.Sup A,
        cases (set.exists_mem_of_ne_empty ne₁) with a a_in_A,
        apply le_trans,
            exact c₆ a a_in_A,
            exact c₀ a a_in_A,
    replace c₇ : real.Inf A + -real.Inf A ≤ real.Sup A - real.Inf A,
        from add_le_add_right c₇ (-real.Inf A),
        simp at c₇,
    let ε := real.Sup A - real.Inf A,
    -- have c : 0 ≠ ε, from sorry,
    replace c₇, from lt_of_le_of_ne c₇ sorry,
    obtain ⟨a, a_in_A, b, b_in_B, c⟩ := (c₂ ε c₇),
    -- replace c, from (c₂ ε c₇),
    -- rcases c with ⟨a, a_in_A, b, b_in_B, c⟩,
    -- cases c with a c,
    -- cases c with a_in_A c,
    -- cases c with b c,
    -- cases c with b_in_B c,

    -- cases (set.exists_mem_of_ne_empty ne₁) with a a_in_A,
    -- cases (set.exists_mem_of_ne_empty ne₂) with b b_in_B,
    -- repeat{fsplit},
    --     exact a,
    --     exact a_in_A,
    --     exact b,
    --     exact b_in_B,
    -- clarify, simp at a_1,

    -- simp * at *,
    --cases (a (real.Sup A)),

end

-- example : ∀ n m : ℕ, m * n = n * m :=
-- begin
--     intros n m,
--     induction m with m ihm,
--         simp,
--     induction n with l ihn,
--         simp,
--     rewrite nat.mul_succ (n + 1) m,
--     rewrite nat.mul_succ (m+1) n,
--     rewrite ←ihm,
--     rewrite nat.mul_succ,
--     rewrite nat.add_assoc,

-- end

end induction

end hidden

-- Instead the approach used here is to construct the von Neumann hierarchy from the unit type,
-- the type with a single instance which is here to be considered as the empty set,
-- and we will define that a set  we begin by considering the


/-
Copyright © 2020 Nicolò Cavalleri. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Nicolò Cavalleri

! This file was ported from Lean 3 source module geometry.manifold.derivation_bundle
! leanprover-community/mathlib commit a0735864ba72769da4b378673d3dbe2453924fde
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Geometry.Manifold.Algebra.SmoothFunctions
import Mathbin.RingTheory.Derivation

/-!

# Derivation bundle

In this file we define the derivations at a point of a manifold on the algebra of smooth fuctions.
Moreover, we define the differential of a function in terms of derivations.

The content of this file is not meant to be regarded as an alternative definition to the current
tangent bundle but rather as a purely algebraic theory that provides a purely algebraic definition
of the Lie algebra for a Lie group.

-/

variable (𝕜 : Type _) [NontriviallyNormedField 𝕜] {E : Type _} [NormedAddCommGroup E]
  [NormedSpace 𝕜 E] {H : Type _} [TopologicalSpace H] (I : ModelWithCorners 𝕜 E H) (M : Type _)
  [TopologicalSpace M] [ChartedSpace H M] (n : ℕ∞)

open Manifold

-- the following two instances prevent poorly understood type class inference timeout problems
instance smoothFunctionsAlgebra : Algebra 𝕜 C^∞⟮I, M; 𝕜⟯ := by infer_instance
#align smooth_functions_algebra smoothFunctionsAlgebra

instance smooth_functions_tower : IsScalarTower 𝕜 C^∞⟮I, M; 𝕜⟯ C^∞⟮I, M; 𝕜⟯ := by infer_instance
#align smooth_functions_tower smooth_functions_tower

/-- Type synonym, introduced to put a different `has_smul` action on `C^n⟮I, M; 𝕜⟯`
which is defined as `f • r = f(x) * r`. -/
@[nolint unused_arguments]
def PointedSmoothMap (x : M) :=
  C^n⟮I, M; 𝕜⟯
#align pointed_smooth_map PointedSmoothMap

-- mathport name: pointed_smooth_map
scoped[Derivation] notation "C^" n "⟮" I ", " M "; " 𝕜 "⟯⟨" x "⟩" => PointedSmoothMap 𝕜 I M n x

variable {𝕜 M}

namespace PointedSmoothMap

instance {x : M} : CoeFun C^∞⟮I, M; 𝕜⟯⟨x⟩ fun _ => M → 𝕜 :=
  ContMdiffMap.hasCoeToFun

instance {x : M} : CommRing C^∞⟮I, M; 𝕜⟯⟨x⟩ :=
  SmoothMap.commRing

instance {x : M} : Algebra 𝕜 C^∞⟮I, M; 𝕜⟯⟨x⟩ :=
  SmoothMap.algebra

instance {x : M} : Inhabited C^∞⟮I, M; 𝕜⟯⟨x⟩ :=
  ⟨0⟩

instance {x : M} : Algebra C^∞⟮I, M; 𝕜⟯⟨x⟩ C^∞⟮I, M; 𝕜⟯ :=
  Algebra.id C^∞⟮I, M; 𝕜⟯

instance {x : M} : IsScalarTower 𝕜 C^∞⟮I, M; 𝕜⟯⟨x⟩ C^∞⟮I, M; 𝕜⟯ :=
  IsScalarTower.right

variable {I}

/-- `smooth_map.eval_ring_hom` gives rise to an algebra structure of `C^∞⟮I, M; 𝕜⟯` on `𝕜`. -/
instance evalAlgebra {x : M} : Algebra C^∞⟮I, M; 𝕜⟯⟨x⟩ 𝕜 :=
  (SmoothMap.evalRingHom x : C^∞⟮I, M; 𝕜⟯⟨x⟩ →+* 𝕜).toAlgebra
#align pointed_smooth_map.eval_algebra PointedSmoothMap.evalAlgebra

/-- With the `eval_algebra` algebra structure evaluation is actually an algebra morphism. -/
def eval (x : M) : C^∞⟮I, M; 𝕜⟯ →ₐ[C^∞⟮I, M; 𝕜⟯⟨x⟩] 𝕜 :=
  Algebra.ofId C^∞⟮I, M; 𝕜⟯⟨x⟩ 𝕜
#align pointed_smooth_map.eval PointedSmoothMap.eval

theorem smul_def (x : M) (f : C^∞⟮I, M; 𝕜⟯⟨x⟩) (k : 𝕜) : f • k = f x * k :=
  rfl
#align pointed_smooth_map.smul_def PointedSmoothMap.smul_def

instance (x : M) : IsScalarTower 𝕜 C^∞⟮I, M; 𝕜⟯⟨x⟩ 𝕜
    where smul_assoc k f h := by
    simp only [smul_def, Algebra.id.smul_eq_mul, SmoothMap.coe_smul, Pi.smul_apply, mul_assoc]

end PointedSmoothMap

open Derivation

/-- The derivations at a point of a manifold. Some regard this as a possible definition of the
tangent space -/
@[reducible]
def PointDerivation (x : M) :=
  Derivation 𝕜 C^∞⟮I, M; 𝕜⟯⟨x⟩ 𝕜
#align point_derivation PointDerivation

section

variable (I) {M} (X Y : Derivation 𝕜 C^∞⟮I, M; 𝕜⟯ C^∞⟮I, M; 𝕜⟯) (f g : C^∞⟮I, M; 𝕜⟯) (r : 𝕜)

/-- Evaluation at a point gives rise to a `C^∞⟮I, M; 𝕜⟯`-linear map between `C^∞⟮I, M; 𝕜⟯` and `𝕜`.
 -/
def SmoothFunction.evalAt (x : M) : C^∞⟮I, M; 𝕜⟯ →ₗ[C^∞⟮I, M; 𝕜⟯⟨x⟩] 𝕜 :=
  (PointedSmoothMap.eval x).toLinearMap
#align smooth_function.eval_at SmoothFunction.evalAt

namespace Derivation

variable {I}

/-- The evaluation at a point as a linear map. -/
def evalAt (x : M) : Derivation 𝕜 C^∞⟮I, M; 𝕜⟯ C^∞⟮I, M; 𝕜⟯ →ₗ[𝕜] PointDerivation I x :=
  (SmoothFunction.evalAt I x).compDer
#align derivation.eval_at Derivation.evalAt

theorem evalAt_apply (x : M) : evalAt x X f = (X f) x :=
  rfl
#align derivation.eval_at_apply Derivation.evalAt_apply

end Derivation

variable {I} {E' : Type _} [NormedAddCommGroup E'] [NormedSpace 𝕜 E'] {H' : Type _}
  [TopologicalSpace H'] {I' : ModelWithCorners 𝕜 E' H'} {M' : Type _} [TopologicalSpace M']
  [ChartedSpace H' M']

/-- The heterogeneous differential as a linear map. Instead of taking a function as an argument this
differential takes `h : f x = y`. It is particularly handy to deal with situations where the points
on where it has to be evaluated are equal but not definitionally equal. -/
def hfdifferential {f : C^∞⟮I, M; I', M'⟯} {x : M} {y : M'} (h : f x = y) :
    PointDerivation I x →ₗ[𝕜] PointDerivation I' y
    where
  toFun v :=
    Derivation.mk'
      { toFun := fun g => v (g.comp f)
        map_add' := fun g g' => by rw [SmoothMap.add_comp, Derivation.map_add]
        map_smul' := fun k g => by
          simp only [SmoothMap.smul_comp, Derivation.map_smul, RingHom.id_apply] }
      fun g g' => by
      simp only [Derivation.leibniz, SmoothMap.mul_comp, LinearMap.coe_mk,
        PointedSmoothMap.smul_def, ContMdiffMap.comp_apply, h]
  map_smul' k v := rfl
  map_add' v w := rfl
#align hfdifferential hfdifferential

/-- The homogeneous differential as a linear map. -/
def fdifferential (f : C^∞⟮I, M; I', M'⟯) (x : M) :
    PointDerivation I x →ₗ[𝕜] PointDerivation I' (f x) :=
  hfdifferential (rfl : f x = f x)
#align fdifferential fdifferential

-- mathport name: fdifferential
-- Standard notation for the differential. The abbreviation is `MId`.
scoped[Manifold] notation "𝒅" => fdifferential

-- mathport name: hfdifferential
-- Standard notation for the differential. The abbreviation is `MId`.
scoped[Manifold] notation "𝒅ₕ" => hfdifferential

@[simp]
theorem apply_fdifferential (f : C^∞⟮I, M; I', M'⟯) {x : M} (v : PointDerivation I x)
    (g : C^∞⟮I', M'; 𝕜⟯) : 𝒅 f x v g = v (g.comp f) :=
  rfl
#align apply_fdifferential apply_fdifferential

@[simp]
theorem apply_hfdifferential {f : C^∞⟮I, M; I', M'⟯} {x : M} {y : M'} (h : f x = y)
    (v : PointDerivation I x) (g : C^∞⟮I', M'; 𝕜⟯) : 𝒅ₕ h v g = 𝒅 f x v g :=
  rfl
#align apply_hfdifferential apply_hfdifferential

variable {E'' : Type _} [NormedAddCommGroup E''] [NormedSpace 𝕜 E''] {H'' : Type _}
  [TopologicalSpace H''] {I'' : ModelWithCorners 𝕜 E'' H''} {M'' : Type _} [TopologicalSpace M'']
  [ChartedSpace H'' M'']

@[simp]
theorem fdifferential_comp (g : C^∞⟮I', M'; I'', M''⟯) (f : C^∞⟮I, M; I', M'⟯) (x : M) :
    𝒅 (g.comp f) x = (𝒅 g (f x)).comp (𝒅 f x) :=
  rfl
#align fdifferential_comp fdifferential_comp

end


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

import control.functor.multivariate
import data.pfunctor.multivariate.basic
import data.pfunctor.multivariate.M
import data.qpf.multivariate.basic

/-!
# The final co-algebra of a multivariate qpf is again a qpf.

For a `(n+1)`-ary QPF `F (α₀,..,αₙ)`, we take the least fixed point of `F` with
regards to its last argument `αₙ`. The result is a `n`-ary functor: `fix F (α₀,..,αₙ₋₁)`.
Making `fix F` into a functor allows us to take the fixed point, compose with other functors
and take a fixed point again.

## Main definitions

 * `cofix.mk`     - constructor
 * `cofix.dest`   - destructor
 * `cofix.corec`  - corecursor: useful for formulating infinite, productive computations
 * `cofix.bisim`  - bisimulation: proof technique to show the equality of possibly infinite values
                    of `cofix F α`

## Implementation notes

For `F` a QPF, we define `cofix F α` in terms of the M-type of the polynomial functor `P` of `F`.
We define the relation `Mcongr` and take its quotient as the definition of `cofix F α`.

`Mcongr` is taken as the weakest bisimulation on M-type. See
[avigad-carneiro-hudon2019] for more details.

## Reference

 * Jeremy Avigad, Mario M. Carneiro and Simon Hudon.
   [*Data Types as Quotients of Polynomial Functors*][avigad-carneiro-hudon2019]
-/

universe u
open_locale mvfunctor

namespace mvqpf
open typevec mvpfunctor
open mvfunctor (liftp liftr)

variables {n : ℕ} {F : typevec.{u} (n+1) → Type u} [mvfunctor F] [q : mvqpf F]
include q

/-- `corecF` is used as a basis for defining the corecursor of `cofix F α`. `corecF`
uses corecursion to construct the M-type generated by `q.P` and uses function on `F`
as a corecursive step -/
def corecF {α : typevec n} {β : Type*} (g : β → F (α.append1 β)) : β → q.P.M α :=
M.corec _ (λ x, repr (g x))

theorem corecF_eq {α : typevec n} {β : Type*} (g : β → F (α.append1 β)) (x : β) :
  M.dest q.P (corecF g x) = append_fun id (corecF g) <$$> repr (g x) :=
by rw [corecF, M.dest_corec]

/-- Characterization of desirable equivalence relations on M-types -/
def is_precongr {α : typevec n} (r : q.P.M α → q.P.M α → Prop) : Prop :=
  ∀ ⦃x y⦄, r x y →
    abs (append_fun id (quot.mk r) <$$> M.dest q.P x) =
      abs (append_fun id (quot.mk r) <$$> M.dest q.P y)

/-- Equivalence relation on M-types representing a value of type `cofix F` -/
def Mcongr {α : typevec n} (x y : q.P.M α) : Prop :=
∃ r, is_precongr r ∧ r x y

/-- Greatest fixed point of functor F. The result is a functor with one fewer parameters
than the input. For `F a b c` a ternary functor, fix F is a binary functor such that

```lean
cofix F a b = F a b (cofix F a b)
```
-/
def cofix (F : typevec (n + 1) → Type u) [mvfunctor F] [q : mvqpf F] (α : typevec n) :=
quot (@Mcongr _ F _ q α)

instance {α : typevec n} [inhabited q.P.A] [Π (i : fin2 n), inhabited (α i)] :
  inhabited (cofix F α) := ⟨ quot.mk _ default ⟩

/-- maps every element of the W type to a canonical representative -/
def Mrepr {α : typevec n} : q.P.M α → q.P.M α := corecF (abs ∘ M.dest q.P)

/-- the map function for the functor `cofix F` -/
def cofix.map {α β : typevec n} (g : α ⟹ β) : cofix F α → cofix F β :=
quot.lift (λ x : q.P.M α, quot.mk Mcongr (g <$$> x))
  begin
    rintros aa₁ aa₂ ⟨r, pr, ra₁a₂⟩, apply quot.sound,
    let r' := λ b₁ b₂, ∃ a₁ a₂ : q.P.M α, r a₁ a₂ ∧ b₁ = g <$$> a₁ ∧ b₂ = g <$$> a₂,
    use r', split,
    { show is_precongr r',
      rintros b₁ b₂ ⟨a₁, a₂, ra₁a₂, b₁eq, b₂eq⟩,
      let u : quot r → quot r' := quot.lift (λ x : q.P.M α, quot.mk r' (g <$$> x))
        (by { intros a₁ a₂ ra₁a₂, apply quot.sound, exact ⟨a₁, a₂, ra₁a₂, rfl, rfl⟩ }),
      have hu : (quot.mk r' ∘ λ x : q.P.M α, g <$$> x) = u ∘ quot.mk r,
        { ext x, refl },
      rw [b₁eq, b₂eq, M.dest_map, M.dest_map, ←q.P.comp_map, ←q.P.comp_map],
      rw [←append_fun_comp, id_comp, hu, hu, ←comp_id g, append_fun_comp],
      rw [q.P.comp_map, q.P.comp_map, abs_map, pr ra₁a₂, ←abs_map] },
    show r' (g <$$> aa₁) (g <$$> aa₂), from ⟨aa₁, aa₂, ra₁a₂, rfl, rfl⟩
  end

instance cofix.mvfunctor : mvfunctor (cofix F) :=
{ map := @cofix.map _ _ _ _}

/-- Corecursor for `cofix F` -/
def cofix.corec {α : typevec n} {β : Type u} (g : β → F (α.append1 β)) : β → cofix F α :=
λ x, quot.mk  _ (corecF g x)

/-- Destructor for `cofix F` -/
def cofix.dest {α : typevec n} : cofix F α → F (α.append1 (cofix F α)) :=
quot.lift
  (λ x, append_fun id (quot.mk Mcongr) <$$> (abs (M.dest q.P x)))
  begin
    rintros x y ⟨r, pr, rxy⟩, dsimp,
    have : ∀ x y, r x y → Mcongr x y,
    { intros x y h, exact ⟨r, pr, h⟩ },
    rw [←quot.factor_mk_eq _ _ this], dsimp,
    conv { to_lhs,
      rw [append_fun_comp_id, comp_map, ←abs_map, pr rxy, abs_map, ←comp_map,
        ←append_fun_comp_id] }
  end

/-- Abstraction function for `cofix F α` -/
def cofix.abs {α} : q.P.M α → cofix F α :=
quot.mk _

/-- Representation function for `cofix F α` -/
def cofix.repr {α} : cofix F α → q.P.M α :=
M.corec _ $ repr ∘ cofix.dest

/-- Corecursor for `cofix F` -/
def cofix.corec'₁ {α : typevec n} {β : Type u}
  (g : Π {X}, (β → X) → F (α.append1 X)) (x : β) : cofix F α :=
cofix.corec (λ x, g id) x

/-- More flexible corecursor for `cofix F`. Allows the return of a fully formed
value instead of making a recursive call -/
def cofix.corec' {α : typevec n} {β : Type u} (g : β → F (α.append1 (cofix F α ⊕ β))) (x : β) :
  cofix F α :=
let f : α ::: cofix F α ⟹ α ::: (cofix F α ⊕ β) := id ::: sum.inl in
cofix.corec
(sum.elim (mvfunctor.map f ∘ cofix.dest) g)
(sum.inr x : cofix F α ⊕ β)

/-- Corecursor for `cofix F`. The shape allows recursive calls to
look like recursive calls. -/
def cofix.corec₁ {α : typevec n} {β : Type u}
  (g : Π {X}, (cofix F α → X) → (β → X) → β → F (α ::: X)) (x : β) : cofix F α :=
cofix.corec' (λ x, g sum.inl sum.inr x) x

theorem cofix.dest_corec {α : typevec n} {β : Type u} (g : β → F (α.append1 β)) (x : β) :
  cofix.dest (cofix.corec g x) = append_fun id (cofix.corec g) <$$> g x :=
begin
  conv { to_lhs, rw [cofix.dest, cofix.corec] }, dsimp,
  rw [corecF_eq, abs_map, abs_repr, ←comp_map, ←append_fun_comp], reflexivity
end

/-- constructor for `cofix F` -/
def cofix.mk {α : typevec n} : F (α.append1 $ cofix F α) → cofix F α :=
cofix.corec (λ x, append_fun id (λ i : cofix F α, cofix.dest.{u} i) <$$> x)

/-!
## Bisimulation principles for `cofix F`

The following theorems are bisimulation principles. The general idea
is to use a bisimulation relation to prove the equality between
specific values of type `cofix F α`.

A bisimulation relation `R` for values `x y : cofix F α`:

 * holds for `x y`: `R x y`
 * for any values `x y` that satisfy `R`, their root has the same shape
   and their children can be paired in such a way that they satisfy `R`.

-/

private theorem cofix.bisim_aux {α : typevec n}
    (r : cofix F α → cofix F α → Prop)
    (h' : ∀ x, r x x)
    (h : ∀ x y, r x y →
      append_fun id (quot.mk r) <$$> cofix.dest x = append_fun id (quot.mk r) <$$> cofix.dest y) :
  ∀ x y, r x y → x = y :=
begin
  intro x, apply quot.induction_on x, clear x,
  intros x y, apply quot.induction_on y, clear y,
  intros y rxy,
  apply quot.sound,
  let r' := λ x y, r (quot.mk _ x) (quot.mk _ y),
  have : is_precongr r',
  { intros a b r'ab,
      have  h₀ :
          append_fun id (quot.mk r ∘ quot.mk Mcongr) <$$> abs (M.dest q.P a) =
          append_fun id (quot.mk r ∘ quot.mk Mcongr) <$$> abs (M.dest q.P b) :=
        by rw [append_fun_comp_id, comp_map, comp_map]; exact h _ _ r'ab,
    have h₁ : ∀ u v : q.P.M α, Mcongr u v → quot.mk r' u = quot.mk r' v,
    { intros u v cuv, apply quot.sound, dsimp [r'], rw quot.sound cuv, apply h' },
    let f : quot r → quot r' := quot.lift (quot.lift (quot.mk r') h₁)
      begin
        intro c, apply quot.induction_on c, clear c,
        intros c d, apply quot.induction_on d, clear d,
        intros d rcd, apply quot.sound, apply rcd
      end,
    have : f ∘ quot.mk r ∘ quot.mk Mcongr = quot.mk r' := rfl,
    rw [←this, append_fun_comp_id, q.P.comp_map, q.P.comp_map, abs_map, abs_map, abs_map,
         abs_map, h₀] },
  refine ⟨r', this, rxy⟩
end

/-- Bisimulation principle using `map` and `quot.mk` to match and relate children of two trees. -/
theorem cofix.bisim_rel {α : typevec n}
    (r : cofix F α → cofix F α → Prop)
    (h : ∀ x y, r x y →
      append_fun id (quot.mk r) <$$> cofix.dest x = append_fun id (quot.mk r) <$$> cofix.dest y) :
  ∀ x y, r x y → x = y :=
let r' x y := x = y ∨ r x y in
begin
  intros x y rxy,
  apply cofix.bisim_aux r',
  { intro x, left, reflexivity },
  { intros x y r'xy,
    cases r'xy, { rw r'xy },
    have : ∀ x y, r x y → r' x y := λ x y h, or.inr h,
    rw ←quot.factor_mk_eq _ _ this, dsimp,
    rw [append_fun_comp_id, append_fun_comp_id],
    rw [@comp_map _ _ _ q _ _ _ (append_fun id (quot.mk r)),
        @comp_map _ _ _ q _ _ _ (append_fun id (quot.mk r))],
    rw h _ _ r'xy },
  right, exact rxy
end

/-- Bisimulation principle using `liftr` to match and relate children of two trees. -/
theorem cofix.bisim {α : typevec n}
    (r : cofix F α → cofix F α → Prop)
    (h : ∀ x y, r x y → liftr (rel_last α r) (cofix.dest x) (cofix.dest y)) :
  ∀ x y, r x y → x = y :=
begin
  apply cofix.bisim_rel,
  intros x y rxy,
  rcases (liftr_iff (rel_last α r) _ _).mp (h x y rxy) with ⟨a, f₀, f₁, dxeq, dyeq, h'⟩,
  rw [dxeq, dyeq, ←abs_map, ←abs_map, mvpfunctor.map_eq, mvpfunctor.map_eq],
  rw [←split_drop_fun_last_fun f₀, ←split_drop_fun_last_fun f₁],
  rw [append_fun_comp_split_fun, append_fun_comp_split_fun],
  rw [id_comp, id_comp],
  congr' 2 with i j, cases i with _ i; dsimp,
  { apply quot.sound, apply h' _ j },
  { change f₀ _ j = f₁ _ j, apply h' _ j },
end

open mvfunctor

/-- Bisimulation principle using `liftr'` to match and relate children of two trees. -/
theorem cofix.bisim₂ {α : typevec n}
    (r : cofix F α → cofix F α → Prop)
    (h : ∀ x y, r x y → liftr' (rel_last' α r) (cofix.dest x) (cofix.dest y)) :
  ∀ x y, r x y → x = y :=
cofix.bisim _ $ by intros; rw ← liftr_last_rel_iff; apply h; assumption

/-- Bisimulation principle the values `⟨a,f⟩` of the polynomial functor representing
`cofix F α` as well as an invariant `Q : β → Prop` and a state `β` generating the
left-hand side and right-hand side of the equality through functions `u v : β → cofix F α` -/
theorem cofix.bisim' {α : typevec n} {β : Type*} (Q : β → Prop)
  (u v : β → cofix F α)
    (h : ∀ x, Q x → ∃ a f' f₀ f₁,
      cofix.dest (u x) = abs ⟨a, q.P.append_contents f' f₀⟩ ∧
      cofix.dest (v x) = abs ⟨a, q.P.append_contents f' f₁⟩ ∧
      ∀ i, ∃ x', Q x' ∧ f₀ i = u x' ∧ f₁ i = v x') :
  ∀ x, Q x → u x = v x :=
λ x Qx,
let R := λ w z : cofix F α, ∃ x', Q x' ∧ w = u x' ∧ z = v x' in
cofix.bisim R
  (λ x y ⟨x', Qx', xeq, yeq⟩,
    begin
      rcases h x' Qx' with ⟨a, f', f₀, f₁, ux'eq, vx'eq, h'⟩,
      rw liftr_iff,
      refine ⟨a, q.P.append_contents f' f₀, q.P.append_contents f' f₁,
        xeq.symm ▸ ux'eq, yeq.symm ▸ vx'eq, _⟩,
      intro i, cases i,
      { apply h' },
      { intro j, apply eq.refl },
    end)
  _ _ ⟨x, Qx, rfl, rfl⟩

lemma cofix.dest_mk {α : typevec n} (x : F (α.append1 $ cofix F α)) : cofix.dest (cofix.mk x) = x :=
begin
  have : cofix.mk ∘ cofix.dest = @_root_.id (cofix F α) := funext cofix.mk_dest,
  rw [cofix.mk, cofix.dest_corec, ←comp_map, ←cofix.mk, ← append_fun_comp, this, id_comp,
    append_fun_id_id, mvfunctor.id_map]
end

lemma cofix.ext {α : typevec n} (x y : cofix F α) (h : x.dest = y.dest) : x = y :=
by rw [← cofix.mk_dest x,h,cofix.mk_dest]

lemma cofix.ext_mk {α : typevec n} (x y : F (α ::: cofix F α)) (h : cofix.mk x = cofix.mk  y) :
  x = y :=
by rw [← cofix.dest_mk x,h,cofix.dest_mk]

/-!
`liftr_map`, `liftr_map_last` and `liftr_map_last'` are useful for reasoning about
the induction step in bisimulation proofs.
-/

section liftr_map

omit q

theorem liftr_map {α β : typevec n} {F' : typevec n → Type u} [mvfunctor F']
  [is_lawful_mvfunctor F']
  (R : β ⊗ β ⟹ repeat n Prop) (x : F' α) (f g : α ⟹ β)
  (h : α ⟹ subtype_ R)
  (hh : subtype_val _ ⊚ h = (f ⊗' g) ⊚ prod.diag) :
  liftr' R (f <$$> x) (g <$$> x) :=
begin
  rw liftr_def,
  existsi h <$$> x,
  rw [mvfunctor.map_map,comp_assoc,hh,← comp_assoc,fst_prod_mk,comp_assoc,fst_diag],
  rw [mvfunctor.map_map,comp_assoc,hh,← comp_assoc,snd_prod_mk,comp_assoc,snd_diag],
  dsimp [liftr'], split; refl,
end

open function

theorem liftr_map_last [is_lawful_mvfunctor F] {α : typevec n} {ι ι'}
  (R : ι' → ι' → Prop) (x : F (α ::: ι)) (f g : ι → ι')
  (hh : ∀ x : ι, R (f x) (g x)) :
  liftr' (rel_last' _ R) ((id ::: f) <$$> x) ((id ::: g) <$$> x) :=
let h : ι → { x : ι' × ι' // uncurry R x } := λ x, ⟨ (f x,g x), hh x ⟩ in
let b : α ::: ι ⟹ _ := @diag_sub n α ::: h,
    c : subtype_ α.repeat_eq ::: {x // uncurry R x} ⟹
        (λ (i : fin2 (n)), {x // of_repeat (α.rel_last' R i.fs x)}) ::: subtype (uncurry R) :=
      of_subtype _ ::: id
in
have hh : subtype_val _ ⊚ to_subtype _ ⊚ from_append1_drop_last ⊚ c ⊚ b =
          (id ::: f ⊗' id ::: g) ⊚ prod.diag,
  by { dsimp [c,b],
       apply eq_of_drop_last_eq,
       { dsimp,
         simp only [prod_map_id, drop_fun_prod, drop_fun_append_fun, drop_fun_diag, id_comp,
                    drop_fun_to_subtype],
         erw [to_subtype_of_subtype_assoc,id_comp],
         clear_except,
         ext i x : 2, induction i,
         refl,  apply i_ih, },
       simp only [h, last_fun_from_append1_drop_last, last_fun_to_subtype, last_fun_append_fun,
                  last_fun_subtype_val, comp.left_id, last_fun_comp, last_fun_prod],
       dsimp, ext1, refl },
liftr_map _ _ _ _ (to_subtype _ ⊚ from_append1_drop_last ⊚ c ⊚ b) hh

theorem liftr_map_last' [is_lawful_mvfunctor F] {α : typevec n} {ι}
  (R : ι → ι → Prop) (x : F (α ::: ι)) (f : ι → ι)
  (hh : ∀ x : ι, R (f x) x) :
  liftr' (rel_last' _ R) ((id ::: f) <$$> x) x :=
begin
  have := liftr_map_last R x f id hh,
  rwa [append_fun_id_id,mvfunctor.id_map] at this,
end

end liftr_map

lemma cofix.abs_repr {α} (x : cofix F α) :
  quot.mk _ (cofix.repr x) = x :=
begin
  let R := λ x y : cofix F α,
    cofix.abs (cofix.repr y) = x,
  refine cofix.bisim₂ R _ _ _ rfl,
  clear x, rintros x y h, dsimp [R] at h, subst h,
  dsimp [cofix.dest,cofix.abs],
  induction y using quot.ind,
  simp only [cofix.repr, M.dest_corec, abs_map, abs_repr],
  conv { congr, skip, rw cofix.dest },
  dsimp, rw [mvfunctor.map_map,mvfunctor.map_map,← append_fun_comp_id,← append_fun_comp_id],
  let f : α ::: (P F).M α ⟹ subtype_ (α.rel_last' R) :=
    split_fun diag_sub (λ x, ⟨(cofix.abs (cofix.abs x).repr, cofix.abs x),_⟩),
  refine liftr_map _ _ _ _ f _,
  { simp only [←append_prod_append_fun, prod_map_id],
    apply eq_of_drop_last_eq,
    { dsimp, simp only [drop_fun_diag],
      erw subtype_val_diag_sub },
    ext1,
    simp only [cofix.abs, prod.mk.inj_iff, prod_map, function.comp_app, last_fun_append_fun,
               last_fun_subtype_val, last_fun_comp, last_fun_split_fun],
    dsimp [drop_fun_rel_last,last_fun,prod.diag],
    split; refl, },
  dsimp [rel_last',split_fun,function.uncurry,R],
  refl,
end

section tactic

setup_tactic_parser
open tactic
omit q

/-- tactic for proof by bisimulation -/
meta def mv_bisim (e : parse texpr) (ids : parse with_ident_list) : tactic unit :=
do e ← to_expr e,
   (expr.pi n bi d b) ← retrieve $ do
   { generalize e,
     target },
   `(@eq %%t %%l %%r) ← pure b,
   x ← mk_local_def `n d,
   v₀ ← mk_local_def `a t,
   v₁ ← mk_local_def `b t,
   x₀ ← mk_app ``eq [v₀,l.instantiate_var x],
   x₁ ← mk_app ``eq [v₁,r.instantiate_var x],
   xx ← mk_app ``and [x₀,x₁],
   ex ← lambdas [x] xx,
   ex ← mk_app ``Exists [ex] >>= lambdas [v₀,v₁],
   R ← pose `R none ex,
   refine ``(cofix.bisim₂ %%R _ _ _ ⟨_,rfl,rfl⟩),
   let f (a b : name) : name := if a = `_ then b else a,
   let ids := (ids ++ list.replicate 5 `_).zip_with f [`a,`b,`x,`Ha,`Hb],
   (ids₀,w::ids₁) ← pure $ list.split_at 2 ids,
   intro_lst ids₀,
   h ← intro1,
   [(_,[w,h],_)] ← cases_core h [w],
   cases h ids₁,
   pure ()

run_cmd add_interactive [``mv_bisim]

end tactic

theorem corec_roll {α : typevec n} {X Y} {x₀ : X}
  (f : X → Y) (g : Y → F (α ::: X)) :
  cofix.corec (g ∘ f) x₀ = cofix.corec (mvfunctor.map (id ::: f) ∘ g) (f x₀) :=
begin
  mv_bisim x₀,
  rw [Ha,Hb,cofix.dest_corec,cofix.dest_corec],
  rw [mvfunctor.map_map,← append_fun_comp_id],
  refine liftr_map_last _ _ _ _ _,
  intros a, refine ⟨a,rfl,rfl⟩
end

theorem cofix.dest_corec' {α : typevec n} {β : Type u}
  (g : β → F (α.append1 (cofix F α ⊕ β))) (x : β) :
  cofix.dest (cofix.corec' g x) = append_fun id (sum.elim id (cofix.corec' g)) <$$> g x :=
begin
  rw [cofix.corec',cofix.dest_corec], dsimp,
  congr' with (i|i); rw corec_roll; dsimp [cofix.corec'],
  { mv_bisim i,
    rw [Ha,Hb,cofix.dest_corec], dsimp [(∘)],
    repeat { rw [mvfunctor.map_map,← append_fun_comp_id] },
    apply liftr_map_last', dsimp [(∘),R], intros, exact ⟨_,rfl,rfl⟩ },
  { congr' with y, erw [append_fun_id_id], simp [mvfunctor.id_map] },
end

theorem cofix.dest_corec₁ {α : typevec n} {β : Type u}
  (g : Π {X}, (cofix F α → X) → (β → X) → β → F (α.append1 X)) (x : β)
  (h : ∀ X Y (f : cofix F α → X) (f' : β → X) (k : X → Y),
         g (k ∘ f) (k ∘ f') x = (id ::: k) <$$> g f f' x) :
  cofix.dest (cofix.corec₁ @g x) = g id (cofix.corec₁ @g) x :=
by rw [cofix.corec₁,cofix.dest_corec',← h]; refl

instance mvqpf_cofix : mvqpf (cofix F) :=
{ P         := q.P.Mp,
  abs       := λ α, quot.mk Mcongr,
  repr      := λ α, cofix.repr,
  abs_repr  := λ α, cofix.abs_repr,
  abs_map   := λ α β g x, rfl }

end mvqpf