/-
Copyright (c) 2017 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura, Mario Carneiro
-/
import control.traversable.equiv
import data.vector.basic

universes u v w

namespace d_array
variables {n : ℕ} {α : fin n → Type u}

instance [∀ i, inhabited (α i)] : inhabited (d_array n α) :=
⟨⟨λ _, default⟩⟩

end d_array

namespace array

instance {n α} [inhabited α] : inhabited (array n α) :=
d_array.inhabited

theorem to_list_of_heq {n₁ n₂ α} {a₁ : array n₁ α} {a₂ : array n₂ α}
  (hn : n₁ = n₂) (ha : a₁ == a₂) : a₁.to_list = a₂.to_list :=
by congr; assumption

/- rev_list -/

section rev_list
variables {n : ℕ} {α : Type u} {a : array n α}

theorem rev_list_reverse_aux : ∀ i (h : i ≤ n) (t : list α),
  (a.iterate_aux (λ _, (::)) i h []).reverse_core t = a.rev_iterate_aux (λ _, (::)) i h t
| 0     h t := rfl
| (i+1) h t := rev_list_reverse_aux i _ _

@[simp] theorem rev_list_reverse : a.rev_list.reverse = a.to_list :=
rev_list_reverse_aux _ _ _

@[simp] theorem to_list_reverse : a.to_list.reverse = a.rev_list :=
by rw [←rev_list_reverse, list.reverse_reverse]

end rev_list

/- mem -/

section mem
variables {n : ℕ} {α : Type u} {v : α} {a : array n α}

theorem mem.def : v ∈ a ↔ ∃ i, a.read i = v :=
iff.rfl

theorem mem_rev_list_aux : ∀ {i} (h : i ≤ n),
  (∃ (j : fin n), (j : ℕ) < i ∧ read a j = v) ↔ v ∈ a.iterate_aux (λ _, (::)) i h []
| 0     _ := ⟨λ ⟨i, n, _⟩, absurd n i.val.not_lt_zero, false.elim⟩
| (i+1) h := let IH := mem_rev_list_aux (le_of_lt h) in
  ⟨λ ⟨j, ji1, e⟩, or.elim (lt_or_eq_of_le $ nat.le_of_succ_le_succ ji1)
    (λ ji, list.mem_cons_of_mem _ $ IH.1 ⟨j, ji, e⟩)
    (λ je, by simp [d_array.iterate_aux]; apply or.inl; unfold read at e;
          have H : j = ⟨i, h⟩ := fin.eq_of_veq je; rwa [←H, e]),
  λ m, begin
    simp [d_array.iterate_aux, list.mem] at m,
    cases m with e m',
    exact ⟨⟨i, h⟩, nat.lt_succ_self _, eq.symm e⟩,
    exact let ⟨j, ji, e⟩ := IH.2 m' in
    ⟨j, nat.le_succ_of_le ji, e⟩
  end⟩

@[simp] theorem mem_rev_list : v ∈ a.rev_list ↔ v ∈ a :=
iff.symm $ iff.trans
  (exists_congr $ λ j, iff.symm $
    show j.1 < n ∧ read a j = v ↔ read a j = v,
    from and_iff_right j.2)
  (mem_rev_list_aux _)

@[simp] theorem mem_to_list : v ∈ a.to_list ↔ v ∈ a :=
by rw ←rev_list_reverse; exact list.mem_reverse.trans mem_rev_list

end mem

/- foldr -/

section foldr
variables {n : ℕ} {α : Type u} {β : Type w} {b : β} {f : α → β → β} {a : array n α}

theorem rev_list_foldr_aux : ∀ {i} (h : i ≤ n),
  (d_array.iterate_aux a (λ _, (::)) i h []).foldr f b = d_array.iterate_aux a (λ _, f) i h b
| 0     h := rfl
| (j+1) h := congr_arg (f (read a ⟨j, h⟩)) (rev_list_foldr_aux _)

theorem rev_list_foldr : a.rev_list.foldr f b = a.foldl b f :=
rev_list_foldr_aux _

end foldr

/- foldl -/

section foldl
variables {n : ℕ} {α : Type u} {β : Type w} {b : β} {f : β → α → β} {a : array n α}

theorem to_list_foldl : a.to_list.foldl f b = a.foldl b (function.swap f) :=
by rw [←rev_list_reverse, list.foldl_reverse, rev_list_foldr]

end foldl

/- length -/

section length
variables {n : ℕ} {α : Type u}

theorem rev_list_length_aux (a : array n α) (i h) :
  (a.iterate_aux (λ _, (::)) i h []).length = i :=
by induction i; simp [*, d_array.iterate_aux]

@[simp] theorem rev_list_length (a : array n α) : a.rev_list.length = n :=
rev_list_length_aux a _ _

@[simp] theorem to_list_length (a : array n α) : a.to_list.length = n :=
by rw[←rev_list_reverse, list.length_reverse, rev_list_length]

end length

/- nth -/

section nth
variables {n : ℕ} {α : Type u} {a : array n α}

theorem to_list_nth_le_aux (i : ℕ) (ih : i < n) : ∀ j {jh t h'},
  (∀ k tl, j + k = i → list.nth_le t k tl = a.read ⟨i, ih⟩) →
  (a.rev_iterate_aux (λ _, (::)) j jh t).nth_le i h' = a.read ⟨i, ih⟩
| 0     _  _ _  al := al i _ $ zero_add _
| (j+1) jh t h' al := to_list_nth_le_aux j $ λ k tl hjk,
  show list.nth_le (a.read ⟨j, jh⟩ :: t) k tl = a.read ⟨i, ih⟩, from
  match k, hjk, tl with
  | 0,    e, tl := match i, e, ih with ._, rfl, _ := rfl end
  | k'+1, _, tl := by simp[list.nth_le]; exact al _ _ (by simp [add_comm, add_assoc, *]; cc)
  end

theorem to_list_nth_le (i : ℕ) (h h') : list.nth_le a.to_list i h' = a.read ⟨i, h⟩ :=
to_list_nth_le_aux _ _ _ (λ k tl, absurd tl k.not_lt_zero)

@[simp] theorem to_list_nth_le' (a : array n α) (i : fin n) (h') :
  list.nth_le a.to_list i h' = a.read i :=
by cases i; apply to_list_nth_le

theorem to_list_nth {i v} : list.nth a.to_list i = some v ↔ ∃ h, a.read ⟨i, h⟩ = v :=
begin
  rw list.nth_eq_some,
  have ll := to_list_length a,
  split; intro h; cases h with h e; subst v,
  { exact ⟨ll ▸ h, (to_list_nth_le _ _ _).symm⟩ },
  { exact ⟨ll.symm ▸ h, to_list_nth_le _ _ _⟩ }
end

theorem write_to_list {i v} : (a.write i v).to_list = a.to_list.update_nth i v :=
list.ext_le (by simp) $ λ j h₁ h₂, begin
  have h₃ : j < n, {simpa using h₁},
  rw [to_list_nth_le _ h₃],
  refine let ⟨_, e⟩ := list.nth_eq_some.1 _ in e.symm,
  by_cases ij : (i : ℕ) = j,
  { subst j, rw [show (⟨(i : ℕ), h₃⟩ : fin _) = i, from fin.eq_of_veq rfl,
      array.read_write, list.nth_update_nth_of_lt],
    simp [h₃] },
  { rw [list.nth_update_nth_ne _ _ ij, a.read_write_of_ne,
        to_list_nth.2 ⟨h₃, rfl⟩],
    exact fin.ne_of_vne ij }
end

end nth

/- enum -/

section enum
variables {n : ℕ} {α : Type u} {a : array n α}

theorem mem_to_list_enum {i v} : (i, v) ∈ a.to_list.enum ↔ ∃ h, a.read ⟨i, h⟩ = v :=
by simp [list.mem_iff_nth, to_list_nth, and.comm, and.assoc, and.left_comm]

end enum

/- to_array -/

section to_array
variables {n : ℕ} {α : Type u}

@[simp] theorem to_list_to_array (a : array n α) : a.to_list.to_array == a :=
heq_of_heq_of_eq
  (@@eq.drec_on (λ m (e : a.to_list.length = m), (d_array.mk (λ v, a.to_list.nth_le v.1 v.2)) ==
    (@d_array.mk m (λ _, α) $ λ v, a.to_list.nth_le v.1 $ e.symm ▸ v.2)) a.to_list_length heq.rfl) $
  d_array.ext $ λ ⟨i, h⟩, to_list_nth_le i h _

@[simp] theorem to_array_to_list (l : list α) : l.to_array.to_list = l :=
list.ext_le (to_list_length _) $ λ n h1 h2, to_list_nth_le _ h2 _

end to_array

/- push_back -/

section push_back
variables {n : ℕ} {α : Type u} {v : α} {a : array n α}

lemma push_back_rev_list_aux : ∀ i h h',
  d_array.iterate_aux (a.push_back v) (λ _, (::)) i h [] = d_array.iterate_aux a (λ _, (::)) i h' []
| 0 h h' := rfl
| (i+1) h h' := begin
  simp [d_array.iterate_aux],
  refine ⟨_, push_back_rev_list_aux _ _ _⟩,
  dsimp [read, d_array.read, push_back],
  rw [dif_neg], refl,
  exact ne_of_lt h',
end

@[simp] theorem push_back_rev_list : (a.push_back v).rev_list = v :: a.rev_list :=
begin
  unfold push_back rev_list foldl iterate d_array.iterate,
  dsimp [d_array.iterate_aux, read, d_array.read, push_back],
  rw [dif_pos (eq.refl n)],
  apply congr_arg,
  apply push_back_rev_list_aux
end

@[simp] theorem push_back_to_list : (a.push_back v).to_list = a.to_list ++ [v] :=
by rw [←rev_list_reverse, ←rev_list_reverse, push_back_rev_list, list.reverse_cons]

@[simp] lemma read_push_back_left (i : fin n) : (a.push_back v).read i.cast_succ = a.read i :=
begin
  cases i with i hi,
  have : ¬ i = n := ne_of_lt hi,
  simp [push_back, this, fin.cast_succ, fin.cast_add, fin.cast_le, fin.cast_lt, read, d_array.read]
end

@[simp] lemma read_push_back_right : (a.push_back v).read (fin.last _) = v :=
begin
  cases hn : fin.last n with k hk,
  have : k = n := by simpa [fin.eq_iff_veq ] using hn.symm,
  simp [push_back, this, fin.cast_succ, fin.cast_add, fin.cast_le, fin.cast_lt, read, d_array.read]
end

end push_back

/- foreach -/

section foreach
variables {n : ℕ} {α : Type u} {β : Type v} {i : fin n} {f : fin n → α → β} {a : array n α}

@[simp] theorem read_foreach : (foreach a f).read i = f i (a.read i) :=
rfl

end foreach

/- map -/

section map
variables {n : ℕ} {α : Type u} {β : Type v} {i : fin n} {f : α → β} {a : array n α}

theorem read_map : (a.map f).read i = f (a.read i) :=
read_foreach

end map

/- map₂ -/

section map₂
variables {n : ℕ} {α : Type u} {i : fin n} {f : α → α → α} {a₁ a₂ : array n α}

@[simp] theorem read_map₂ : (map₂ f a₁ a₂).read i = f (a₁.read i) (a₂.read i) :=
read_foreach

end map₂

end array

namespace equiv

/-- The natural equivalence between length-`n` heterogeneous arrays
and dependent functions from `fin n`. -/
def d_array_equiv_fin {n : ℕ} (α : fin n → Type*) : d_array n α ≃ (Π i, α i) :=
⟨d_array.read, d_array.mk, λ ⟨f⟩, rfl, λ f, rfl⟩

/-- The natural equivalence between length-`n` arrays and functions from `fin n`. -/
def array_equiv_fin (n : ℕ) (α : Type*) : array n α ≃ (fin n → α) :=
d_array_equiv_fin _

/-- The natural equivalence between length-`n` vectors and length-`n` arrays. -/
def vector_equiv_array (α : Type*) (n : ℕ) : vector α n ≃ array n α :=
(vector_equiv_fin _ _).trans (array_equiv_fin _ _).symm

end equiv

namespace array
open function
variable {n : ℕ}

instance : traversable (array n) :=
@equiv.traversable (flip vector n) _ (λ α, equiv.vector_equiv_array α n) _

instance : is_lawful_traversable (array n) :=
@equiv.is_lawful_traversable (flip vector n) _ (λ α, equiv.vector_equiv_array α n) _ _

end array


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

! This file was ported from Lean 3 source module order.category.BddDistLat
! leanprover-community/mathlib commit e8ac6315bcfcbaf2d19a046719c3b553206dac75
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Order.Category.BddLat
import Mathbin.Order.Category.DistLat

/-!
# The category of bounded distributive lattices

This defines `BddDistLat`, the category of bounded distributive lattices.

Note that this category is sometimes called [`DistLat`](https://ncatlab.org/nlab/show/DistLat) when
being a lattice is understood to entail having a bottom and a top element.
-/

universe u

open CategoryTheory

/-- The category of bounded distributive lattices with bounded lattice morphisms. -/
structure BddDistLat where
  toDistLat : DistLat
  [isBoundedOrder : BoundedOrder to_DistLat]
#align BddDistLat BddDistLat

namespace BddDistLat

instance : CoeSort BddDistLat (Type _) :=
  ⟨fun X => X.toDistLat⟩

instance (X : BddDistLat) : DistribLattice X :=
  X.toDistLat.str

attribute [instance] BddDistLat.isBoundedOrder

/-- Construct a bundled `BddDistLat` from a `bounded_order` `distrib_lattice`. -/
def of (α : Type _) [DistribLattice α] [BoundedOrder α] : BddDistLat :=
  ⟨⟨α⟩⟩
#align BddDistLat.of BddDistLat.of

@[simp]
theorem coe_of (α : Type _) [DistribLattice α] [BoundedOrder α] : ↥(of α) = α :=
  rfl
#align BddDistLat.coe_of BddDistLat.coe_of

instance : Inhabited BddDistLat :=
  ⟨of PUnit⟩

/-- Turn a `BddDistLat` into a `BddLat` by forgetting it is distributive. -/
def toBddLat (X : BddDistLat) : BddLat :=
  BddLat.of X
#align BddDistLat.to_BddLat BddDistLat.toBddLat

@[simp]
theorem coe_toBddLat (X : BddDistLat) : ↥X.toBddLat = ↥X :=
  rfl
#align BddDistLat.coe_to_BddLat BddDistLat.coe_toBddLat

instance : LargeCategory.{u} BddDistLat :=
  InducedCategory.category toBddLat

instance : ConcreteCategory BddDistLat :=
  InducedCategory.concreteCategory toBddLat

instance hasForgetToDistLat : HasForget₂ BddDistLat DistLat
    where forget₂ :=
    { obj := fun X => ⟨X⟩
      map := fun X Y => BoundedLatticeHom.toLatticeHom }
#align BddDistLat.has_forget_to_DistLat BddDistLat.hasForgetToDistLat

instance hasForgetToBddLat : HasForget₂ BddDistLat BddLat :=
  InducedCategory.hasForget₂ toBddLat
#align BddDistLat.has_forget_to_BddLat BddDistLat.hasForgetToBddLat

theorem forget_bddLat_lat_eq_forget_distLat_lat :
    forget₂ BddDistLat BddLat ⋙ forget₂ BddLat Lat =
      forget₂ BddDistLat DistLat ⋙ forget₂ DistLat Lat :=
  rfl
#align BddDistLat.forget_BddLat_Lat_eq_forget_DistLat_Lat BddDistLat.forget_bddLat_lat_eq_forget_distLat_lat

/-- Constructs an equivalence between bounded distributive lattices from an order isomorphism
between them. -/
@[simps]
def Iso.mk {α β : BddDistLat.{u}} (e : α ≃o β) : α ≅ β
    where
  Hom := (e : BoundedLatticeHom α β)
  inv := (e.symm : BoundedLatticeHom β α)
  hom_inv_id' := by
    ext
    exact e.symm_apply_apply _
  inv_hom_id' := by
    ext
    exact e.apply_symm_apply _
#align BddDistLat.iso.mk BddDistLat.Iso.mk

/-- `order_dual` as a functor. -/
@[simps]
def dual : BddDistLat ⥤ BddDistLat where
  obj X := of Xᵒᵈ
  map X Y := BoundedLatticeHom.dual
#align BddDistLat.dual BddDistLat.dual

/-- The equivalence between `BddDistLat` and itself induced by `order_dual` both ways. -/
@[simps Functor inverse]
def dualEquiv : BddDistLat ≌ BddDistLat :=
  Equivalence.mk dual dual
    (NatIso.ofComponents (fun X => Iso.mk <| OrderIso.dualDual X) fun X Y f => rfl)
    (NatIso.ofComponents (fun X => Iso.mk <| OrderIso.dualDual X) fun X Y f => rfl)
#align BddDistLat.dual_equiv BddDistLat.dualEquiv

end BddDistLat

theorem bddDistLat_dual_comp_forget_to_distLat :
    BddDistLat.dual ⋙ forget₂ BddDistLat DistLat = forget₂ BddDistLat DistLat ⋙ DistLat.dual :=
  rfl
#align BddDistLat_dual_comp_forget_to_DistLat bddDistLat_dual_comp_forget_to_distLat


/-
Copyright (c) 2019 Oliver Nash. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Oliver Nash
-/
import tactic.noncomm_ring
import data.equiv.module
import data.bracket
import linear_algebra.basic

/-!
# Lie algebras

This file defines Lie rings and Lie algebras over a commutative ring together with their
modules, morphisms and equivalences, as well as various lemmas to make these definitions usable.

## Main definitions

  * `lie_ring`
  * `lie_algebra`
  * `lie_ring_module`
  * `lie_module`
  * `lie_hom`
  * `lie_equiv`
  * `lie_module_hom`
  * `lie_module_equiv`

## Notation

Working over a fixed commutative ring `R`, we introduce the notations:
 * `L →ₗ⁅R⁆ L'` for a morphism of Lie algebras,
 * `L ≃ₗ⁅R⁆ L'` for an equivalence of Lie algebras,
 * `M →ₗ⁅R,L⁆ N` for a morphism of Lie algebra modules `M`, `N` over a Lie algebra `L`,
 * `M ≃ₗ⁅R,L⁆ N` for an equivalence of Lie algebra modules `M`, `N` over a Lie algebra `L`.

## Implementation notes

Lie algebras are defined as modules with a compatible Lie ring structure and thus, like modules,
are partially unbundled.

## References
* [N. Bourbaki, *Lie Groups and Lie Algebras, Chapters 1--3*](bourbaki1975)

## Tags

lie bracket, jacobi identity, lie ring, lie algebra, lie module
-/

universes u v w w₁ w₂
open function

/-- A Lie ring is an additive group with compatible product, known as the bracket, satisfying the
Jacobi identity. -/
@[protect_proj] class lie_ring (L : Type v) extends add_comm_group L, has_bracket L L :=
(add_lie  : ∀ (x y z : L), ⁅x + y, z⁆ = ⁅x, z⁆ + ⁅y, z⁆)
(lie_add  : ∀ (x y z : L), ⁅x, y + z⁆ = ⁅x, y⁆ + ⁅x, z⁆)
(lie_self : ∀ (x : L), ⁅x, x⁆ = 0)
(leibniz_lie : ∀ (x y z : L), ⁅x, ⁅y, z⁆⁆ = ⁅⁅x, y⁆, z⁆ + ⁅y, ⁅x, z⁆⁆)

/-- A Lie algebra is a module with compatible product, known as the bracket, satisfying the Jacobi
identity. Forgetting the scalar multiplication, every Lie algebra is a Lie ring. -/
@[protect_proj] class lie_algebra (R : Type u) (L : Type v) [comm_ring R] [lie_ring L]
  extends module R L :=
(lie_smul : ∀ (t : R) (x y : L), ⁅x, t • y⁆ = t • ⁅x, y⁆)

/-- A Lie ring module is an additive group, together with an additive action of a
Lie ring on this group, such that the Lie bracket acts as the commutator of endomorphisms.
(For representations of Lie *algebras* see `lie_module`.) -/
@[protect_proj] class lie_ring_module (L : Type v) (M : Type w)
  [lie_ring L] [add_comm_group M] extends has_bracket L M :=
(add_lie     : ∀ (x y : L) (m : M), ⁅x + y, m⁆ = ⁅x, m⁆ + ⁅y, m⁆)
(lie_add     : ∀ (x : L) (m n : M), ⁅x, m + n⁆ = ⁅x, m⁆ + ⁅x, n⁆)
(leibniz_lie : ∀ (x y : L) (m : M), ⁅x, ⁅y, m⁆⁆ = ⁅⁅x, y⁆, m⁆ + ⁅y, ⁅x, m⁆⁆)

/-- A Lie module is a module over a commutative ring, together with a linear action of a Lie
algebra on this module, such that the Lie bracket acts as the commutator of endomorphisms. -/
@[protect_proj] class lie_module (R : Type u) (L : Type v) (M : Type w)
  [comm_ring R] [lie_ring L] [lie_algebra R L] [add_comm_group M] [module R M]
  [lie_ring_module L M] :=
(smul_lie : ∀ (t : R) (x : L) (m : M), ⁅t • x, m⁆ = t • ⁅x, m⁆)
(lie_smul : ∀ (t : R) (x : L) (m : M), ⁅x, t • m⁆ = t • ⁅x, m⁆)

section basic_properties

variables {R : Type u} {L : Type v} {M : Type w} {N : Type w₁}
variables [comm_ring R] [lie_ring L] [lie_algebra R L]
variables [add_comm_group M] [module R M] [lie_ring_module L M] [lie_module R L M]
variables [add_comm_group N] [module R N] [lie_ring_module L N] [lie_module R L N]
variables (t : R) (x y z : L) (m n : M)

@[simp] lemma add_lie : ⁅x + y, m⁆ = ⁅x, m⁆ + ⁅y, m⁆ := lie_ring_module.add_lie x y m

@[simp] lemma lie_add : ⁅x, m + n⁆ = ⁅x, m⁆ + ⁅x, n⁆ := lie_ring_module.lie_add x m n

@[simp] lemma smul_lie : ⁅t • x, m⁆ = t • ⁅x, m⁆ := lie_module.smul_lie t x m

@[simp] lemma lie_smul : ⁅x, t • m⁆ = t • ⁅x, m⁆ := lie_module.lie_smul t x m

lemma leibniz_lie : ⁅x, ⁅y, m⁆⁆ = ⁅⁅x, y⁆, m⁆ + ⁅y, ⁅x, m⁆⁆ := lie_ring_module.leibniz_lie x y m

@[simp] lemma lie_zero : ⁅x, 0⁆ = (0 : M) := (add_monoid_hom.mk' _ (lie_add x)).map_zero

@[simp] lemma zero_lie : ⁅(0 : L), m⁆ = 0 :=
(add_monoid_hom.mk' (λ (x : L), ⁅x, m⁆) (λ x y, add_lie x y m)).map_zero

@[simp] lemma lie_self : ⁅x, x⁆ = 0 := lie_ring.lie_self x

instance lie_ring_self_module : lie_ring_module L L := { ..(infer_instance : lie_ring L) }

@[simp] lemma lie_skew : -⁅y, x⁆ = ⁅x, y⁆ :=
have h : ⁅x + y, x⁆ + ⁅x + y, y⁆ = 0, { rw ← lie_add, apply lie_self, },
by simpa [neg_eq_iff_add_eq_zero] using h

/-- Every Lie algebra is a module over itself. -/
instance lie_algebra_self_module : lie_module R L L :=
{ smul_lie := λ t x m, by rw [←lie_skew, ←lie_skew x m, lie_algebra.lie_smul, smul_neg],
  lie_smul := by apply lie_algebra.lie_smul, }

@[simp] lemma neg_lie : ⁅-x, m⁆ = -⁅x, m⁆ :=
by { rw [←sub_eq_zero, sub_neg_eq_add, ←add_lie], simp, }

@[simp] lemma lie_neg : ⁅x, -m⁆ = -⁅x, m⁆ :=
by { rw [←sub_eq_zero, sub_neg_eq_add, ←lie_add], simp, }

@[simp] lemma sub_lie : ⁅x - y, m⁆ = ⁅x, m⁆ - ⁅y, m⁆ :=
by simp [sub_eq_add_neg]

@[simp] lemma lie_sub : ⁅x, m - n⁆ = ⁅x, m⁆ - ⁅x, n⁆ :=
by simp [sub_eq_add_neg]

@[simp] lemma nsmul_lie (n : ℕ) : ⁅n • x, m⁆ = n • ⁅x, m⁆ :=
add_monoid_hom.map_nsmul ⟨λ (x : L), ⁅x, m⁆, zero_lie m, λ _ _, add_lie _ _ _⟩ _ _

@[simp] lemma lie_nsmul (n : ℕ) : ⁅x, n • m⁆ = n • ⁅x, m⁆ :=
add_monoid_hom.map_nsmul ⟨λ (m : M), ⁅x, m⁆, lie_zero x, λ _ _, lie_add _ _ _⟩ _ _

@[simp] lemma zsmul_lie (a : ℤ) : ⁅a • x, m⁆ = a • ⁅x, m⁆ :=
add_monoid_hom.map_zsmul ⟨λ (x : L), ⁅x, m⁆, zero_lie m, λ _ _, add_lie _ _ _⟩ _ _

@[simp] lemma lie_zsmul (a : ℤ) : ⁅x, a • m⁆ = a • ⁅x, m⁆ :=
add_monoid_hom.map_zsmul ⟨λ (m : M), ⁅x, m⁆, lie_zero x, λ _ _, lie_add _ _ _⟩ _ _

@[simp] lemma lie_lie : ⁅⁅x, y⁆, m⁆ = ⁅x, ⁅y, m⁆⁆ - ⁅y, ⁅x, m⁆⁆ :=
by rw [leibniz_lie, add_sub_cancel]

lemma lie_jacobi : ⁅x, ⁅y, z⁆⁆ + ⁅y, ⁅z, x⁆⁆ + ⁅z, ⁅x, y⁆⁆ = 0 :=
by { rw [← neg_neg ⁅x, y⁆, lie_neg z, lie_skew y x, ← lie_skew, lie_lie], abel, }

instance lie_ring.int_lie_algebra : lie_algebra ℤ L :=
{ lie_smul := λ n x y, lie_zsmul x y n, }

instance : lie_ring_module L (M →ₗ[R] N) :=
{ bracket     := λ x f,
  { to_fun    := λ m, ⁅x, f m⁆ - f ⁅x, m⁆,
    map_add'  := λ m n, by { simp only [lie_add, linear_map.map_add], abel, },
    map_smul' := λ t m, by simp only [smul_sub, linear_map.map_smul, lie_smul, ring_hom.id_apply] },
  add_lie     := λ x y f, by
    { ext n, simp only [add_lie, linear_map.coe_mk, linear_map.add_apply, linear_map.map_add],
      abel, },
  lie_add     := λ x f g, by
    { ext n, simp only [linear_map.coe_mk, lie_add, linear_map.add_apply], abel, },
  leibniz_lie := λ x y f, by
    { ext n,
      simp only [lie_lie, linear_map.coe_mk, linear_map.map_sub, linear_map.add_apply, lie_sub],
      abel, }, }

@[simp] lemma lie_hom.lie_apply (f : M →ₗ[R] N) (x : L) (m : M) :
  ⁅x, f⁆ m = ⁅x, f m⁆ - f ⁅x, m⁆ :=
rfl

instance : lie_module R L (M →ₗ[R] N) :=
{ smul_lie := λ t x f, by
    { ext n,
      simp only [smul_sub, smul_lie, linear_map.smul_apply, lie_hom.lie_apply,
        linear_map.map_smul], },
  lie_smul := λ t x f, by
    { ext n, simp only [smul_sub, linear_map.smul_apply, lie_hom.lie_apply, lie_smul], }, }

end basic_properties

/-- A morphism of Lie algebras is a linear map respecting the bracket operations. -/
structure lie_hom (R : Type u) (L : Type v) (L' : Type w)
  [comm_ring R] [lie_ring L] [lie_algebra R L] [lie_ring L'] [lie_algebra R L']
  extends L →ₗ[R] L' :=
(map_lie' : ∀ {x y : L}, to_fun ⁅x, y⁆ = ⁅to_fun x, to_fun y⁆)

attribute [nolint doc_blame] lie_hom.to_linear_map

notation L ` →ₗ⁅`:25 R:25 `⁆ `:0 L':0 := lie_hom R L L'

namespace lie_hom

variables {R : Type u} {L₁ : Type v} {L₂ : Type w} {L₃ : Type w₁}
variables [comm_ring R]
variables [lie_ring L₁] [lie_algebra R L₁]
variables [lie_ring L₂] [lie_algebra R L₂]
variables [lie_ring L₃] [lie_algebra R L₃]

instance : has_coe (L₁ →ₗ⁅R⁆ L₂) (L₁ →ₗ[R] L₂) := ⟨lie_hom.to_linear_map⟩

/-- see Note [function coercion] -/
instance : has_coe_to_fun (L₁ →ₗ⁅R⁆ L₂) (λ _, L₁ → L₂) := ⟨λ f, f.to_linear_map.to_fun⟩

/-- See Note [custom simps projection]. We need to specify this projection explicitly in this case,
  because it is a composition of multiple projections. -/
def simps.apply (h : L₁ →ₗ⁅R⁆ L₂) : L₁ → L₂ := h

initialize_simps_projections lie_hom (to_linear_map_to_fun → apply)

@[simp, norm_cast] lemma coe_to_linear_map (f : L₁ →ₗ⁅R⁆ L₂) : ((f : L₁ →ₗ[R] L₂) : L₁ → L₂) = f :=
rfl

@[simp] lemma to_fun_eq_coe (f : L₁ →ₗ⁅R⁆ L₂) : f.to_fun = ⇑f := rfl

@[simp] lemma map_smul (f : L₁ →ₗ⁅R⁆ L₂) (c : R) (x : L₁) : f (c • x) = c • f x :=
linear_map.map_smul (f : L₁ →ₗ[R] L₂) c x

@[simp] lemma map_add (f : L₁ →ₗ⁅R⁆ L₂) (x y : L₁) : f (x + y) = (f x) + (f y) :=
linear_map.map_add (f : L₁ →ₗ[R] L₂) x y

@[simp] lemma map_sub (f : L₁ →ₗ⁅R⁆ L₂) (x y : L₁) : f (x - y) = (f x) - (f y) :=
linear_map.map_sub (f : L₁ →ₗ[R] L₂) x y

@[simp] lemma map_neg (f : L₁ →ₗ⁅R⁆ L₂) (x : L₁) : f (-x) = -(f x) :=
linear_map.map_neg (f : L₁ →ₗ[R] L₂) x

@[simp] lemma map_lie (f : L₁ →ₗ⁅R⁆ L₂) (x y : L₁) : f ⁅x, y⁆ = ⁅f x, f y⁆ := lie_hom.map_lie' f

@[simp] lemma map_zero (f : L₁ →ₗ⁅R⁆ L₂) : f 0 = 0 := (f : L₁ →ₗ[R] L₂).map_zero

/-- The identity map is a morphism of Lie algebras. -/
def id : L₁ →ₗ⁅R⁆ L₁ :=
{ map_lie' := λ x y, rfl,
  .. (linear_map.id : L₁ →ₗ[R] L₁) }

@[simp] lemma coe_id : ((id : L₁ →ₗ⁅R⁆ L₁) : L₁ → L₁) = _root_.id := rfl

lemma id_apply (x : L₁) : (id : L₁ →ₗ⁅R⁆ L₁) x = x := rfl

/-- The constant 0 map is a Lie algebra morphism. -/
instance : has_zero (L₁ →ₗ⁅R⁆ L₂) := ⟨{ map_lie' := by simp, ..(0 : L₁ →ₗ[R] L₂)}⟩

@[norm_cast, simp] lemma coe_zero : ((0 : L₁ →ₗ⁅R⁆ L₂) : L₁ → L₂) = 0 := rfl

lemma zero_apply (x : L₁) : (0 : L₁ →ₗ⁅R⁆ L₂) x = 0 := rfl

/-- The identity map is a Lie algebra morphism. -/
instance : has_one (L₁ →ₗ⁅R⁆ L₁) := ⟨id⟩

@[simp] lemma coe_one : ((1 : (L₁ →ₗ⁅R⁆ L₁)) : L₁ → L₁) = _root_.id := rfl

lemma one_apply (x : L₁) : (1 : (L₁ →ₗ⁅R⁆ L₁)) x = x := rfl

instance : inhabited (L₁ →ₗ⁅R⁆ L₂) := ⟨0⟩

lemma coe_injective : @function.injective (L₁ →ₗ⁅R⁆ L₂) (L₁ → L₂) coe_fn :=
by rintro ⟨⟨f, _⟩⟩ ⟨⟨g, _⟩⟩ ⟨h⟩; congr

@[ext] lemma ext {f g : L₁ →ₗ⁅R⁆ L₂} (h : ∀ x, f x = g x) : f = g :=
coe_injective $ funext h

lemma ext_iff {f g : L₁ →ₗ⁅R⁆ L₂} : f = g ↔ ∀ x, f x = g x :=
⟨by { rintro rfl x, refl }, ext⟩

lemma congr_fun {f g : L₁ →ₗ⁅R⁆ L₂} (h : f = g) (x : L₁) : f x = g x := h ▸ rfl

@[simp] lemma mk_coe (f : L₁ →ₗ⁅R⁆ L₂) (h₁ h₂ h₃) :
  (⟨⟨f, h₁, h₂⟩, h₃⟩ : L₁ →ₗ⁅R⁆ L₂) = f :=
by { ext, refl, }

@[simp] lemma coe_mk (f : L₁ → L₂) (h₁ h₂ h₃) :
  ((⟨⟨f, h₁, h₂⟩, h₃⟩ : L₁ →ₗ⁅R⁆ L₂) : L₁ → L₂) = f := rfl

/-- The composition of morphisms is a morphism. -/
def comp (f : L₂ →ₗ⁅R⁆ L₃) (g : L₁ →ₗ⁅R⁆ L₂) : L₁ →ₗ⁅R⁆ L₃ :=
{ map_lie' := λ x y, by { change f (g ⁅x, y⁆) = ⁅f (g x), f (g y)⁆, rw [map_lie, map_lie], },
  ..linear_map.comp f.to_linear_map g.to_linear_map }

lemma comp_apply (f : L₂ →ₗ⁅R⁆ L₃) (g : L₁ →ₗ⁅R⁆ L₂) (x : L₁) :
  f.comp g x = f (g x) := rfl

@[norm_cast, simp]
lemma coe_comp (f : L₂ →ₗ⁅R⁆ L₃) (g : L₁ →ₗ⁅R⁆ L₂) :
  (f.comp g : L₁ → L₃) = f ∘ g :=
rfl

@[norm_cast, simp]
lemma coe_linear_map_comp (f : L₂ →ₗ⁅R⁆ L₃) (g : L₁ →ₗ⁅R⁆ L₂) :
  (f.comp g : L₁ →ₗ[R] L₃) = (f : L₂ →ₗ[R] L₃).comp (g : L₁ →ₗ[R] L₂) :=
rfl

@[simp] lemma comp_id (f : L₁ →ₗ⁅R⁆ L₂) : f.comp (id : L₁ →ₗ⁅R⁆ L₁) = f :=
by { ext, refl, }

@[simp] lemma id_comp (f : L₁ →ₗ⁅R⁆ L₂) : (id : L₂ →ₗ⁅R⁆ L₂).comp f = f :=
by { ext, refl, }

/-- The inverse of a bijective morphism is a morphism. -/
def inverse (f : L₁ →ₗ⁅R⁆ L₂) (g : L₂ → L₁)
  (h₁ : function.left_inverse g f) (h₂ : function.right_inverse g f) : L₂ →ₗ⁅R⁆ L₁ :=
{ map_lie' := λ x y,
  calc g ⁅x, y⁆ = g ⁅f (g x), f (g y)⁆ : by { conv_lhs { rw [←h₂ x, ←h₂ y], }, }
            ... = g (f ⁅g x, g y⁆) : by rw map_lie
            ... = ⁅g x, g y⁆ : (h₁ _),
  ..linear_map.inverse f.to_linear_map g h₁ h₂ }

end lie_hom

section module_pull_back

variables {R : Type u} {L₁ : Type v} {L₂ : Type w} (M : Type w₁)
variables [comm_ring R]  [lie_ring L₁] [lie_algebra R L₁] [lie_ring L₂] [lie_algebra R L₂]
variables [add_comm_group M] [lie_ring_module L₂ M]
variables (f : L₁ →ₗ⁅R⁆ L₂)
include f

/-- A Lie ring module may be pulled back along a morphism of Lie algebras.

See note [reducible non-instances]. -/
@[reducible]
def lie_ring_module.comp_lie_hom : lie_ring_module L₁ M :=
{ bracket     := λ x m, ⁅f x, m⁆,
  lie_add     := λ x, lie_add (f x),
  add_lie     := λ x y m, by simp only [lie_hom.map_add, add_lie],
  leibniz_lie := λ x y m, by simp only [lie_lie, sub_add_cancel, lie_hom.map_lie], }

lemma lie_ring_module.comp_lie_hom_apply (x : L₁) (m : M) :
  by haveI := lie_ring_module.comp_lie_hom M f; exact
  ⁅x, m⁆ = ⁅f x, m⁆ :=
rfl

/-- A Lie module may be pulled back along a morphism of Lie algebras.

See note [reducible non-instances]. -/
@[reducible]
def lie_module.comp_lie_hom [module R M] [lie_module R L₂ M] :
  @lie_module R L₁ M _ _ _ _ _ (lie_ring_module.comp_lie_hom M f) :=
{ smul_lie := λ t x m, by simp only [smul_lie, lie_hom.map_smul],
  lie_smul := λ t x m, by simp only [lie_smul], }

end module_pull_back

/-- An equivalence of Lie algebras is a morphism which is also a linear equivalence. We could
instead define an equivalence to be a morphism which is also a (plain) equivalence. However it is
more convenient to define via linear equivalence to get `.to_linear_equiv` for free. -/
structure lie_equiv (R : Type u) (L : Type v) (L' : Type w)
  [comm_ring R] [lie_ring L] [lie_algebra R L] [lie_ring L'] [lie_algebra R L']
  extends L →ₗ⁅R⁆ L' :=
(inv_fun   : L' → L)
(left_inv  : function.left_inverse inv_fun to_lie_hom.to_fun)
(right_inv : function.right_inverse inv_fun to_lie_hom.to_fun)

attribute [nolint doc_blame] lie_equiv.to_lie_hom

notation L ` ≃ₗ⁅`:50 R `⁆ ` L' := lie_equiv R L L'

namespace lie_equiv

variables {R : Type u} {L₁ : Type v} {L₂ : Type w} {L₃ : Type w₁}
variables [comm_ring R] [lie_ring L₁] [lie_ring L₂] [lie_ring L₃]
variables [lie_algebra R L₁] [lie_algebra R L₂] [lie_algebra R L₃]

/-- Consider an equivalence of Lie algebras as a linear equivalence. -/
def to_linear_equiv (f : L₁ ≃ₗ⁅R⁆ L₂) : L₁ ≃ₗ[R] L₂ := { ..f.to_lie_hom, ..f }

instance has_coe_to_lie_hom : has_coe (L₁ ≃ₗ⁅R⁆ L₂) (L₁ →ₗ⁅R⁆ L₂) := ⟨to_lie_hom⟩
instance has_coe_to_linear_equiv : has_coe (L₁ ≃ₗ⁅R⁆ L₂) (L₁ ≃ₗ[R] L₂) := ⟨to_linear_equiv⟩

/-- see Note [function coercion] -/
instance : has_coe_to_fun (L₁ ≃ₗ⁅R⁆ L₂) (λ _, L₁ → L₂) := ⟨λ e, e.to_lie_hom.to_fun⟩

@[simp, norm_cast] lemma coe_to_lie_hom (e : L₁ ≃ₗ⁅R⁆ L₂) : ((e : L₁ →ₗ⁅R⁆ L₂) : L₁ → L₂) = e :=
rfl

@[simp, norm_cast] lemma coe_to_linear_equiv (e : L₁ ≃ₗ⁅R⁆ L₂) :
  ((e : L₁ ≃ₗ[R] L₂) : L₁ → L₂) = e := rfl

@[simp] lemma to_linear_equiv_mk (f : L₁ →ₗ⁅R⁆ L₂) (g h₁ h₂) :
  (mk f g h₁ h₂ : L₁ ≃ₗ[R] L₂) = { inv_fun := g, left_inv := h₁, right_inv := h₂, .. f } := rfl

lemma coe_linear_equiv_injective : injective (coe : (L₁ ≃ₗ⁅R⁆ L₂) → (L₁ ≃ₗ[R] L₂)) :=
begin
  intros f₁ f₂ h, cases f₁, cases f₂, dsimp at h, simp only at h,
  congr, exacts [lie_hom.coe_injective h.1, h.2]
end

lemma coe_injective : @injective (L₁ ≃ₗ⁅R⁆ L₂) (L₁ → L₂) coe_fn :=
linear_equiv.coe_injective.comp coe_linear_equiv_injective

@[ext] lemma ext {f g : L₁ ≃ₗ⁅R⁆ L₂} (h : ∀ x, f x = g x) : f = g := coe_injective $ funext h

instance : has_one (L₁ ≃ₗ⁅R⁆ L₁) :=
⟨{ map_lie' := λ x y, rfl,
  ..(1 : L₁ ≃ₗ[R] L₁)}⟩

@[simp] lemma one_apply (x : L₁) : (1 : (L₁ ≃ₗ⁅R⁆ L₁)) x = x := rfl

instance : inhabited (L₁ ≃ₗ⁅R⁆ L₁) := ⟨1⟩

/-- Lie algebra equivalences are reflexive. -/
@[refl]
def refl : L₁ ≃ₗ⁅R⁆ L₁ := 1

@[simp] lemma refl_apply (x : L₁) : (refl : L₁ ≃ₗ⁅R⁆ L₁) x = x := rfl

/-- Lie algebra equivalences are symmetric. -/
@[symm]
def symm (e : L₁ ≃ₗ⁅R⁆ L₂) : L₂ ≃ₗ⁅R⁆ L₁ :=
{ ..lie_hom.inverse e.to_lie_hom e.inv_fun e.left_inv e.right_inv,
  ..e.to_linear_equiv.symm }

@[simp] lemma symm_symm (e : L₁ ≃ₗ⁅R⁆ L₂) : e.symm.symm = e :=
by { ext, refl }

@[simp] lemma apply_symm_apply (e : L₁ ≃ₗ⁅R⁆ L₂) : ∀ x, e (e.symm x) = x :=
  e.to_linear_equiv.apply_symm_apply

@[simp] lemma symm_apply_apply (e : L₁ ≃ₗ⁅R⁆ L₂) : ∀ x, e.symm (e x) = x :=
  e.to_linear_equiv.symm_apply_apply

/-- Lie algebra equivalences are transitive. -/
@[trans]
def trans (e₁ : L₁ ≃ₗ⁅R⁆ L₂) (e₂ : L₂ ≃ₗ⁅R⁆ L₃) : L₁ ≃ₗ⁅R⁆ L₃ :=
{ ..lie_hom.comp e₂.to_lie_hom e₁.to_lie_hom,
  ..linear_equiv.trans e₁.to_linear_equiv e₂.to_linear_equiv }

@[simp] lemma self_trans_symm (e : L₁ ≃ₗ⁅R⁆ L₂) : e.trans e.symm = refl :=
ext e.symm_apply_apply

@[simp] lemma symm_trans_self (e : L₁ ≃ₗ⁅R⁆ L₂) : e.symm.trans e = refl :=
e.symm.self_trans_symm

@[simp] lemma trans_apply (e₁ : L₁ ≃ₗ⁅R⁆ L₂) (e₂ : L₂ ≃ₗ⁅R⁆ L₃) (x : L₁) :
  (e₁.trans e₂) x = e₂ (e₁ x) := rfl

@[simp] lemma symm_trans (e₁ : L₁ ≃ₗ⁅R⁆ L₂) (e₂ : L₂ ≃ₗ⁅R⁆ L₃) :
  (e₁.trans e₂).symm = e₂.symm.trans e₁.symm := rfl

protected lemma bijective (e : L₁ ≃ₗ⁅R⁆ L₂) : function.bijective ((e : L₁ →ₗ⁅R⁆ L₂) : L₁ → L₂) :=
e.to_linear_equiv.bijective

protected lemma injective (e : L₁ ≃ₗ⁅R⁆ L₂) : function.injective ((e : L₁ →ₗ⁅R⁆ L₂) : L₁ → L₂) :=
e.to_linear_equiv.injective

protected lemma surjective (e : L₁ ≃ₗ⁅R⁆ L₂) : function.surjective ((e : L₁ →ₗ⁅R⁆ L₂) : L₁ → L₂) :=
e.to_linear_equiv.surjective

/-- A bijective morphism of Lie algebras yields an equivalence of Lie algebras. -/
@[simps] noncomputable def of_bijective (f : L₁ →ₗ⁅R⁆ L₂)
  (h₁ : function.injective f) (h₂ : function.surjective f) : L₁ ≃ₗ⁅R⁆ L₂ :=
{ to_fun   := f,
  map_lie' := f.map_lie,
  .. (linear_equiv.of_bijective (f : L₁ →ₗ[R] L₂) h₁ h₂), }

end lie_equiv

section lie_module_morphisms

variables (R : Type u) (L : Type v) (M : Type w) (N : Type w₁) (P : Type w₂)
variables [comm_ring R] [lie_ring L] [lie_algebra R L]
variables [add_comm_group M] [add_comm_group N] [add_comm_group P]
variables [module R M] [module R N] [module R P]
variables [lie_ring_module L M] [lie_ring_module L N] [lie_ring_module L P]
variables [lie_module R L M] [lie_module R L N] [lie_module R L P]

/-- A morphism of Lie algebra modules is a linear map which commutes with the action of the Lie
algebra. -/
structure lie_module_hom extends M →ₗ[R] N :=
(map_lie' : ∀ {x : L} {m : M}, to_fun ⁅x, m⁆ = ⁅x, to_fun m⁆)

attribute [nolint doc_blame] lie_module_hom.to_linear_map

notation M ` →ₗ⁅`:25 R,L:25 `⁆ `:0 N:0 := lie_module_hom R L M N

namespace lie_module_hom

variables {R L M N P}

instance : has_coe (M →ₗ⁅R,L⁆ N) (M →ₗ[R] N) := ⟨lie_module_hom.to_linear_map⟩

/-- see Note [function coercion] -/
instance : has_coe_to_fun (M →ₗ⁅R,L⁆ N) (λ _, M → N) := ⟨λ f, f.to_linear_map.to_fun⟩

@[simp, norm_cast] lemma coe_to_linear_map (f : M →ₗ⁅R,L⁆ N) : ((f : M →ₗ[R] N) : M → N) = f :=
rfl

@[simp] lemma map_smul (f : M →ₗ⁅R,L⁆ N) (c : R) (x : M) : f (c • x) = c • f x :=
linear_map.map_smul (f : M →ₗ[R] N) c x

@[simp] lemma map_add (f : M →ₗ⁅R,L⁆ N) (x y : M) : f (x + y) = (f x) + (f y) :=
linear_map.map_add (f : M →ₗ[R] N) x y

@[simp] lemma map_sub (f : M →ₗ⁅R,L⁆ N) (x y : M) : f (x - y) = (f x) - (f y) :=
linear_map.map_sub (f : M →ₗ[R] N) x y

@[simp] lemma map_neg (f : M →ₗ⁅R,L⁆ N) (x : M) : f (-x) = -(f x) :=
linear_map.map_neg (f : M →ₗ[R] N) x

@[simp] lemma map_lie (f : M →ₗ⁅R,L⁆ N) (x : L) (m : M) : f ⁅x, m⁆ = ⁅x, f m⁆ :=
lie_module_hom.map_lie' f

lemma map_lie₂ (f : M →ₗ⁅R,L⁆ N →ₗ[R] P) (x : L) (m : M) (n : N) :
  ⁅x, f m n⁆ = f ⁅x, m⁆ n + f m ⁅x, n⁆ :=
by simp only [sub_add_cancel, map_lie, lie_hom.lie_apply]

@[simp] lemma map_zero (f : M →ₗ⁅R,L⁆ N) : f 0 = 0 :=
linear_map.map_zero (f : M →ₗ[R] N)

/-- The identity map is a morphism of Lie modules. -/
def id : M →ₗ⁅R,L⁆ M :=
{ map_lie' := λ x m, rfl,
  .. (linear_map.id : M →ₗ[R] M) }

@[simp] lemma coe_id : ((id : M →ₗ⁅R,L⁆ M) : M → M) = _root_.id := rfl

lemma id_apply (x : M) : (id : M →ₗ⁅R,L⁆ M) x = x := rfl

/-- The constant 0 map is a Lie module morphism. -/
instance : has_zero (M →ₗ⁅R,L⁆ N) := ⟨{ map_lie' := by simp, ..(0 : M →ₗ[R] N) }⟩

@[norm_cast, simp] lemma coe_zero : ((0 : M →ₗ⁅R,L⁆ N) : M → N) = 0 := rfl

lemma zero_apply (m : M) : (0 : M →ₗ⁅R,L⁆ N) m = 0 := rfl

/-- The identity map is a Lie module morphism. -/
instance : has_one (M →ₗ⁅R,L⁆ M) := ⟨id⟩

instance : inhabited (M →ₗ⁅R,L⁆ N) := ⟨0⟩

lemma coe_injective : @function.injective (M →ₗ⁅R,L⁆ N) (M → N) coe_fn :=
by { rintros ⟨⟨f, _⟩⟩ ⟨⟨g, _⟩⟩ ⟨h⟩, congr, }

@[ext] lemma ext {f g : M →ₗ⁅R,L⁆ N} (h : ∀ m, f m = g m) : f = g :=
coe_injective $ funext h

lemma ext_iff {f g : M →ₗ⁅R,L⁆ N} : f = g ↔ ∀ m, f m = g m :=
⟨by { rintro rfl m, refl, }, ext⟩

lemma congr_fun {f g : M →ₗ⁅R,L⁆ N} (h : f = g) (x : M) : f x = g x := h ▸ rfl

@[simp] lemma mk_coe (f : M →ₗ⁅R,L⁆ N) (h) :
  (⟨f, h⟩ : M →ₗ⁅R,L⁆ N) = f :=
by { ext, refl, }

@[simp] lemma coe_mk (f : M →ₗ[R] N) (h) :
  ((⟨f, h⟩ : M →ₗ⁅R,L⁆ N) : M → N) = f :=
by { ext, refl, }

@[norm_cast, simp] lemma coe_linear_mk (f : M →ₗ[R] N) (h) :
  ((⟨f, h⟩ : M →ₗ⁅R,L⁆ N) : M →ₗ[R] N) = f :=
by { ext, refl, }

/-- The composition of Lie module morphisms is a morphism. -/
def comp (f : N →ₗ⁅R,L⁆ P) (g : M →ₗ⁅R,L⁆ N) : M →ₗ⁅R,L⁆ P :=
{ map_lie' := λ x m, by { change f (g ⁅x, m⁆) = ⁅x, f (g m)⁆, rw [map_lie, map_lie], },
  ..linear_map.comp f.to_linear_map g.to_linear_map }

lemma comp_apply (f : N →ₗ⁅R,L⁆ P) (g : M →ₗ⁅R,L⁆ N) (m : M) :
  f.comp g m = f (g m) := rfl

@[norm_cast, simp] lemma coe_comp (f : N →ₗ⁅R,L⁆ P) (g : M →ₗ⁅R,L⁆ N) :
  (f.comp g : M → P) = f ∘ g :=
rfl

@[norm_cast, simp] lemma coe_linear_map_comp (f : N →ₗ⁅R,L⁆ P) (g : M →ₗ⁅R,L⁆ N) :
  (f.comp g : M →ₗ[R] P) = (f : N →ₗ[R] P).comp (g : M →ₗ[R] N) :=
rfl

/-- The inverse of a bijective morphism of Lie modules is a morphism of Lie modules. -/
def inverse (f : M →ₗ⁅R,L⁆ N) (g : N → M)
  (h₁ : function.left_inverse g f) (h₂ : function.right_inverse g f) : N →ₗ⁅R,L⁆ M :=
{ map_lie' := λ x n,
    calc g ⁅x, n⁆ = g ⁅x, f (g n)⁆ : by rw h₂
              ... = g (f ⁅x, g n⁆) : by rw map_lie
              ... = ⁅x, g n⁆ : (h₁ _),
  ..linear_map.inverse f.to_linear_map g h₁ h₂ }

instance : has_add (M →ₗ⁅R,L⁆ N) :=
{ add := λ f g, { map_lie' := by simp, ..((f : M →ₗ[R] N) + (g : M →ₗ[R] N)) }, }

instance : has_sub (M →ₗ⁅R,L⁆ N) :=
{ sub := λ f g, { map_lie' := by simp, ..((f : M →ₗ[R] N) - (g : M →ₗ[R] N)) }, }

instance : has_neg (M →ₗ⁅R,L⁆ N) :=
{ neg := λ f, { map_lie' := by simp, ..(-(f : (M →ₗ[R] N))) }, }

@[norm_cast, simp] lemma coe_add (f g : M →ₗ⁅R,L⁆ N) : ⇑(f + g) = f + g := rfl

lemma add_apply (f g : M →ₗ⁅R,L⁆ N) (m : M) : (f + g) m = f m + g m := rfl

@[norm_cast, simp] lemma coe_sub (f g : M →ₗ⁅R,L⁆ N) : ⇑(f - g) = f - g := rfl

lemma sub_apply (f g : M →ₗ⁅R,L⁆ N) (m : M) : (f - g) m = f m - g m := rfl

@[norm_cast, simp] lemma coe_neg (f : M →ₗ⁅R,L⁆ N) : ⇑(-f) = -f := rfl

lemma neg_apply (f : M →ₗ⁅R,L⁆ N) (m : M) : (-f) m = -(f m) := rfl

instance : add_comm_group (M →ₗ⁅R,L⁆ N) :=
{ zero           := 0,
  add            := (+),
  neg            := has_neg.neg,
  sub            := has_sub.sub,
  nsmul          := λ n f, { map_lie' := λ x m, by simp, ..(n • (f : M →ₗ[R] N)) },
  nsmul_zero'    := λ f, by { ext, simp, },
  nsmul_succ'    := λ n f, by { ext, simp [nat.succ_eq_one_add, add_nsmul], },
  ..(coe_injective.add_comm_group _ coe_zero coe_add coe_neg coe_sub :
    add_comm_group (M →ₗ⁅R,L⁆ N)) }

instance : has_scalar R (M →ₗ⁅R,L⁆ N) :=
{ smul := λ t f, { map_lie' := by simp, ..(t • (f : M →ₗ[R] N)) }, }

@[norm_cast, simp] lemma coe_smul (t : R) (f : M →ₗ⁅R,L⁆ N) : ⇑(t • f) = t • f := rfl

lemma smul_apply (t : R) (f : M →ₗ⁅R,L⁆ N) (m : M) : (t • f) m = t • (f m) := rfl

instance : module R (M →ₗ⁅R,L⁆ N) :=
function.injective.module R ⟨λ f, f.to_linear_map.to_fun, rfl, coe_add⟩ coe_injective coe_smul

end lie_module_hom

/-- An equivalence of Lie algebra modules is a linear equivalence which is also a morphism of
Lie algebra modules. -/
structure lie_module_equiv extends M →ₗ⁅R,L⁆ N :=
(inv_fun   : N → M)
(left_inv  : function.left_inverse inv_fun to_fun)
(right_inv : function.right_inverse inv_fun to_fun)

attribute [nolint doc_blame] lie_module_equiv.to_lie_module_hom

notation M ` ≃ₗ⁅`:25 R,L:25 `⁆ `:0 N:0 := lie_module_equiv R L M N

namespace lie_module_equiv

variables {R L M N P}

/-- View an equivalence of Lie modules as a linear equivalence. -/
@[ancestor]
def to_linear_equiv (e : M ≃ₗ⁅R,L⁆ N) : M ≃ₗ[R] N := { ..e }

/-- View an equivalence of Lie modules as a type level equivalence. -/
@[ancestor]
def to_equiv (e : M ≃ₗ⁅R,L⁆ N) : M ≃ N := { ..e }

instance has_coe_to_equiv : has_coe (M ≃ₗ⁅R,L⁆ N) (M ≃ N) := ⟨to_equiv⟩
instance has_coe_to_lie_module_hom : has_coe (M ≃ₗ⁅R,L⁆ N) (M →ₗ⁅R,L⁆ N) := ⟨to_lie_module_hom⟩
instance has_coe_to_linear_equiv : has_coe (M ≃ₗ⁅R,L⁆ N) (M ≃ₗ[R] N) := ⟨to_linear_equiv⟩

/-- see Note [function coercion] -/
instance : has_coe_to_fun (M ≃ₗ⁅R,L⁆ N) (λ _, M → N) := ⟨λ e, e.to_lie_module_hom.to_fun⟩

lemma injective (e : M ≃ₗ⁅R,L⁆ N) : function.injective e := e.to_equiv.injective

@[simp] lemma coe_mk (f : M →ₗ⁅R,L⁆ N) (inv_fun h₁ h₂) :
  ((⟨f, inv_fun, h₁, h₂⟩ : M ≃ₗ⁅R,L⁆ N) : M → N) = f := rfl

@[simp, norm_cast] lemma coe_to_lie_module_hom (e : M ≃ₗ⁅R,L⁆ N) :
  ((e : M →ₗ⁅R,L⁆ N) : M → N) = e := rfl

@[simp, norm_cast] lemma coe_to_linear_equiv (e : M ≃ₗ⁅R,L⁆ N) : ((e : M ≃ₗ[R] N) : M → N) = e :=
rfl

lemma to_equiv_injective : function.injective (to_equiv : (M ≃ₗ⁅R,L⁆ N) → M ≃ N) :=
λ e₁ e₂ h, begin
  rcases e₁ with ⟨⟨⟩⟩, rcases e₂ with ⟨⟨⟩⟩,
  have inj := equiv.mk.inj h,
  dsimp at inj,
  apply lie_module_equiv.mk.inj_eq.mpr,
  split,
  { congr,
    ext,
    rw inj.1 },
  { exact inj.2 },
end

@[ext] lemma ext (e₁ e₂ : M ≃ₗ⁅R,L⁆ N) (h : ∀ m, e₁ m = e₂ m) : e₁ = e₂ :=
to_equiv_injective (equiv.ext h)

instance : has_one (M ≃ₗ⁅R,L⁆ M) := ⟨{ map_lie' := λ x m, rfl, ..(1 : M ≃ₗ[R] M) }⟩

@[simp] lemma one_apply (m : M) : (1 : (M ≃ₗ⁅R,L⁆ M)) m = m := rfl

instance : inhabited (M ≃ₗ⁅R,L⁆ M) := ⟨1⟩

/-- Lie module equivalences are reflexive. -/
@[refl] def refl : M ≃ₗ⁅R,L⁆ M := 1

@[simp] lemma refl_apply (m : M) : (refl : M ≃ₗ⁅R,L⁆ M) m = m := rfl

/-- Lie module equivalences are syemmtric. -/
@[symm] def symm (e : M ≃ₗ⁅R,L⁆ N) : N ≃ₗ⁅R,L⁆ M :=
{ ..lie_module_hom.inverse e.to_lie_module_hom e.inv_fun e.left_inv e.right_inv,
  ..(e : M ≃ₗ[R] N).symm }

@[simp] lemma apply_symm_apply (e : M ≃ₗ⁅R,L⁆ N) : ∀ x, e (e.symm x) = x :=
  e.to_linear_equiv.apply_symm_apply

@[simp] lemma symm_apply_apply (e : M ≃ₗ⁅R,L⁆ N) : ∀ x, e.symm (e x) = x :=
  e.to_linear_equiv.symm_apply_apply

@[simp] lemma symm_symm (e : M ≃ₗ⁅R,L⁆ N) : e.symm.symm = e :=
by { ext, apply_fun e.symm using e.symm.injective, simp, }

/-- Lie module equivalences are transitive. -/
@[trans] def trans (e₁ : M ≃ₗ⁅R,L⁆ N) (e₂ : N ≃ₗ⁅R,L⁆ P) : M ≃ₗ⁅R,L⁆ P :=
{ ..lie_module_hom.comp e₂.to_lie_module_hom e₁.to_lie_module_hom,
  ..linear_equiv.trans e₁.to_linear_equiv e₂.to_linear_equiv }

@[simp] lemma trans_apply (e₁ : M ≃ₗ⁅R,L⁆ N) (e₂ : N ≃ₗ⁅R,L⁆ P) (m : M) :
  (e₁.trans e₂) m = e₂ (e₁ m) := rfl

@[simp] lemma symm_trans (e₁ : M ≃ₗ⁅R,L⁆ N) (e₂ : N ≃ₗ⁅R,L⁆ P) :
  (e₁.trans e₂).symm = e₂.symm.trans e₁.symm := rfl

@[simp] lemma self_trans_symm (e : M ≃ₗ⁅R,L⁆ N) : e.trans e.symm = refl :=
ext _ _ e.symm_apply_apply

@[simp] lemma symm_trans_self (e : M ≃ₗ⁅R,L⁆ N) : e.symm.trans e = refl :=
ext _ _ e.apply_symm_apply

end lie_module_equiv

end lie_module_morphisms


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

! This file was ported from Lean 3 source module linear_algebra.clifford_algebra.even
! leanprover-community/mathlib commit 9264b15ee696b7ca83f13c8ad67c83d6eb70b730
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.LinearAlgebra.CliffordAlgebra.Fold
import Mathbin.LinearAlgebra.CliffordAlgebra.Grading

/-!
# The universal property of the even subalgebra

## Main definitions

* `clifford_algebra.even Q`: The even subalgebra of `clifford_algebra Q`.
* `clifford_algebra.even_hom`: The type of bilinear maps that satisfy the universal property of the
  even subalgebra
* `clifford_algebra.even.lift`: The universal property of the even subalgebra, which states
  that every bilinear map `f` with `f v v = Q v` and `f u v * f v w = Q v • f u w` is in unique
  correspondence with an algebra morphism from `clifford_algebra.even Q`.

## Implementation notes

The approach here is outlined in "Computing with the universal properties of the Clifford algebra
and the even subalgebra" (to appear).

The broad summary is that we have two tricks available to us for implementing complex recursors on
top of `clifford_algebra.lift`: the first is to use morphisms as the output type, such as
`A = module.End R N` which is how we obtained `clifford_algebra.foldr`; and the second is to use
`N = (N', S)` where `N'` is the value we wish to compute, and `S` is some auxiliary state passed
between one recursor invocation and the next.
For the universal property of the even subalgebra, we apply a variant of the first trick again by
choosing `S` to itself be a submodule of morphisms.
-/

namespace CliffordAlgebra

variable {R M : Type _} [CommRing R] [AddCommGroup M] [Module R M]

variable {Q : QuadraticForm R M}

-- put this after `Q` since we want to talk about morphisms from `clifford_algebra Q` to `A` and
-- that order is more natural
variable {A B : Type _} [Ring A] [Ring B] [Algebra R A] [Algebra R B]

open DirectSum

variable (Q)

/-- The even submodule `clifford_algebra.even_odd Q 0` is also a subalgebra. -/
def even : Subalgebra R (CliffordAlgebra Q) :=
  (evenOdd Q 0).toSubalgebra SetLike.GradedMonoid.one_mem fun x y hx hy =>
    add_zero (0 : ZMod 2) ▸ SetLike.GradedMonoid.mul_mem hx hy
#align clifford_algebra.even CliffordAlgebra.even

@[simp]
theorem even_toSubmodule : (even Q).toSubmodule = evenOdd Q 0 :=
  rfl
#align clifford_algebra.even_to_submodule CliffordAlgebra.even_toSubmodule

variable (A)

/-- The type of bilinear maps which are accepted by `clifford_algebra.even.lift`. -/
@[ext]
structure EvenHom : Type max u_2 u_3 where
  bilin : M →ₗ[R] M →ₗ[R] A
  contract (m : M) : bilin m m = algebraMap R A (Q m)
  contract_mid (m₁ m₂ m₃ : M) : bilin m₁ m₂ * bilin m₂ m₃ = Q m₂ • bilin m₁ m₃
#align clifford_algebra.even_hom CliffordAlgebra.EvenHom

variable {A Q}

/-- Compose an `even_hom` with an `alg_hom` on the output. -/
@[simps]
def EvenHom.compr₂ (g : EvenHom Q A) (f : A →ₐ[R] B) : EvenHom Q B
    where
  bilin := g.bilin.compr₂ f.toLinearMap
  contract m := (f.congr_arg <| g.contract _).trans <| f.commutes _
  contract_mid m₁ m₂ m₃ :=
    (f.map_mul _ _).symm.trans <| (f.congr_arg <| g.contract_mid _ _ _).trans <| f.map_smul _ _
#align clifford_algebra.even_hom.compr₂ CliffordAlgebra.EvenHom.compr₂

variable (Q)

/-- The embedding of pairs of vectors into the even subalgebra, as a bilinear map. -/
@[simps bilin_apply_apply_coe]
def even.ι : EvenHom Q (even Q)
    where
  bilin :=
    LinearMap.mk₂ R (fun m₁ m₂ => ⟨ι Q m₁ * ι Q m₂, ι_mul_ι_mem_evenOdd_zero _ _ _⟩)
      (fun _ _ _ => by
        simp only [LinearMap.map_add, add_mul]
        rfl)
      (fun _ _ _ => by
        simp only [LinearMap.map_smul, smul_mul_assoc]
        rfl)
      (fun _ _ _ => by
        simp only [LinearMap.map_add, mul_add]
        rfl)
      fun _ _ _ => by
      simp only [LinearMap.map_smul, mul_smul_comm]
      rfl
  contract m := Subtype.ext <| ι_sq_scalar Q m
  contract_mid m₁ m₂ m₃ :=
    Subtype.ext <|
      calc
        ι Q m₁ * ι Q m₂ * (ι Q m₂ * ι Q m₃) = ι Q m₁ * (ι Q m₂ * ι Q m₂ * ι Q m₃) := by
          simp only [mul_assoc]
        _ = Q m₂ • (ι Q m₁ * ι Q m₃) := by rw [Algebra.smul_def, ι_sq_scalar, Algebra.left_comm]

#align clifford_algebra.even.ι CliffordAlgebra.even.ι

instance : Inhabited (EvenHom Q (even Q)) :=
  ⟨even.ι Q⟩

variable (f : EvenHom Q A)

/-- Two algebra morphisms from the even subalgebra are equal if they agree on pairs of generators.

See note [partially-applied ext lemmas]. -/
@[ext]
theorem even.algHom_ext ⦃f g : even Q →ₐ[R] A⦄ (h : (even.ι Q).compr₂ f = (even.ι Q).compr₂ g) :
    f = g := by
  rw [even_hom.ext_iff] at h
  ext ⟨x, hx⟩
  refine' even_induction _ _ _ _ _ hx
  · intro r
    exact (f.commutes r).trans (g.commutes r).symm
  · intro x y hx hy ihx ihy
    have := congr_arg₂ (· + ·) ihx ihy
    exact (f.map_add _ _).trans (this.trans <| (g.map_add _ _).symm)
  · intro m₁ m₂ x hx ih
    have := congr_arg₂ (· * ·) (LinearMap.congr_fun (LinearMap.congr_fun h m₁) m₂) ih
    exact (f.map_mul _ _).trans (this.trans <| (g.map_mul _ _).symm)
#align clifford_algebra.even.alg_hom_ext CliffordAlgebra.even.algHom_ext

variable {Q}

namespace Even.Lift

/-- An auxiliary submodule used to store the half-applied values of `f`.
This is the span of elements `f'` such that `∃ x m₂, ∀ m₁, f' m₁ = f m₁ m₂ * x`.  -/
private def S : Submodule R (M →ₗ[R] A) :=
  Submodule.span R
    { f' | ∃ x m₂, f' = LinearMap.lcomp R _ (f.bilin.flip m₂) (LinearMap.mulRight R x) }
#align clifford_algebra.even.lift.S clifford_algebra.even.lift.S

/-- An auxiliary bilinear map that is later passed into `clifford_algebra.fold`. Our desired result
is stored in the `A` part of the accumulator, while auxiliary recursion state is stored in the `S f`
part. -/
private def f_fold : M →ₗ[R] A × s f →ₗ[R] A × s f :=
  LinearMap.mk₂ R
    (fun m acc =>
      /- We could write this `snd` term in a point-free style as follows, but it wouldn't help as we
        don't have any prod or subtype combinators to deal with n-linear maps of this degree.
        ```lean
        (linear_map.lcomp R _ (algebra.lmul R A).to_linear_map.flip).comp $
          (linear_map.llcomp R M A A).flip.comp f.flip : M →ₗ[R] A →ₗ[R] M →ₗ[R] A)
        ```
        -/
      (Acc.2 m,
        ⟨(LinearMap.mulRight R Acc.1).comp (f.bilin.flip m), Submodule.subset_span <| ⟨_, _, rfl⟩⟩))
    (fun m₁ m₂ a =>
      Prod.ext (LinearMap.map_add _ m₁ m₂)
        (Subtype.ext <|
          LinearMap.ext fun m₃ =>
            show f.bilin m₃ (m₁ + m₂) * a.1 = f.bilin m₃ m₁ * a.1 + f.bilin m₃ m₂ * a.1 by
              rw [map_add, add_mul]))
    (fun c m a =>
      Prod.ext (LinearMap.map_smul _ c m)
        (Subtype.ext <|
          LinearMap.ext fun m₃ =>
            show f.bilin m₃ (c • m) * a.1 = c • (f.bilin m₃ m * a.1) by
              rw [LinearMap.map_smul, smul_mul_assoc]))
    (fun m a₁ a₂ => Prod.ext rfl (Subtype.ext <| LinearMap.ext fun m₃ => mul_add _ _ _))
    fun c m a => Prod.ext rfl (Subtype.ext <| LinearMap.ext fun m₃ => mul_smul_comm _ _ _)
#align clifford_algebra.even.lift.f_fold clifford_algebra.even.lift.f_fold

@[simp]
private theorem fst_f_fold_f_fold (m₁ m₂ : M) (x : A × s f) :
    (fFold f m₁ (fFold f m₂ x)).fst = f.bilin m₁ m₂ * x.fst :=
  rfl
#align clifford_algebra.even.lift.fst_f_fold_f_fold clifford_algebra.even.lift.fst_f_fold_f_fold

@[simp]
private theorem snd_f_fold_f_fold (m₁ m₂ m₃ : M) (x : A × s f) :
    ((fFold f m₁ (fFold f m₂ x)).snd : M →ₗ[R] A) m₃ = f.bilin m₃ m₁ * (x.snd : M →ₗ[R] A) m₂ :=
  rfl
#align clifford_algebra.even.lift.snd_f_fold_f_fold clifford_algebra.even.lift.snd_f_fold_f_fold

private theorem f_fold_f_fold (m : M) (x : A × s f) : fFold f m (fFold f m x) = Q m • x :=
  by
  obtain ⟨a, ⟨g, hg⟩⟩ := x
  ext : 2
  · change f.bilin m m * a = Q m • a
    rw [Algebra.smul_def, f.contract]
  · ext m₁
    change f.bilin _ _ * g m = Q m • g m₁
    apply Submodule.span_induction' _ _ _ _ hg
    · rintro _ ⟨b, m₃, rfl⟩
      change f.bilin _ _ * (f.bilin _ _ * b) = Q m • (f.bilin _ _ * b)
      rw [← smul_mul_assoc, ← mul_assoc, f.contract_mid]
    · change f.bilin m₁ m * 0 = Q m • 0
      rw [MulZeroClass.mul_zero, smul_zero]
    · rintro x hx y hy ihx ihy
      rw [LinearMap.add_apply, LinearMap.add_apply, mul_add, smul_add, ihx, ihy]
    · rintro x hx c ihx
      rw [LinearMap.smul_apply, LinearMap.smul_apply, mul_smul_comm, ihx, smul_comm]
#align clifford_algebra.even.lift.f_fold_f_fold clifford_algebra.even.lift.f_fold_f_fold

/-- The final auxiliary construction for `clifford_algebra.even.lift`. This map is the forwards
direction of that equivalence, but not in the fully-bundled form. -/
@[simps (config := { attrs := [] }) apply]
def aux (f : EvenHom Q A) : CliffordAlgebra.even Q →ₗ[R] A :=
  by
  refine' _ ∘ₗ (Even Q).val.toLinearMap
  exact LinearMap.fst _ _ _ ∘ₗ foldr Q (f_fold f) (f_fold_f_fold f) (1, 0)
#align clifford_algebra.even.lift.aux CliffordAlgebra.even.Lift.aux

@[simp]
theorem aux_one : aux f 1 = 1 :=
  congr_arg Prod.fst (foldr_one _ _ _ _)
#align clifford_algebra.even.lift.aux_one CliffordAlgebra.even.Lift.aux_one

@[simp]
theorem aux_ι (m₁ m₂ : M) : aux f ((even.ι Q).bilin m₁ m₂) = f.bilin m₁ m₂ :=
  (congr_arg Prod.fst (foldr_mul _ _ _ _ _ _)).trans
    (by
      rw [foldr_ι, foldr_ι]
      exact mul_one _)
#align clifford_algebra.even.lift.aux_ι CliffordAlgebra.even.Lift.aux_ι

@[simp]
theorem aux_algebraMap (r) (hr) : aux f ⟨algebraMap R _ r, hr⟩ = algebraMap R _ r :=
  (congr_arg Prod.fst (foldr_algebraMap _ _ _ _ _)).trans (Algebra.algebraMap_eq_smul_one r).symm
#align clifford_algebra.even.lift.aux_algebra_map CliffordAlgebra.even.Lift.aux_algebraMap

@[simp]
theorem aux_mul (x y : even Q) : aux f (x * y) = aux f x * aux f y :=
  by
  cases x
  cases y
  refine' (congr_arg Prod.fst (foldr_mul _ _ _ _ _ _)).trans _
  dsimp only
  refine' even_induction Q _ _ _ _ x_property
  · intro r
    rw [foldr_algebra_map, aux_algebra_map]
    exact Algebra.smul_def r _
  · intro x y hx hy ihx ihy
    rw [LinearMap.map_add, Prod.fst_add, ihx, ihy, ← add_mul, ← LinearMap.map_add]
    rfl
  · rintro m₁ m₂ x (hx : x ∈ Even Q) ih
    rw [aux_apply, foldr_mul, foldr_mul, foldr_ι, foldr_ι, fst_f_fold_f_fold, ih, ← mul_assoc,
      Subtype.coe_mk, foldr_mul, foldr_mul, foldr_ι, foldr_ι, fst_f_fold_f_fold]
    rfl
#align clifford_algebra.even.lift.aux_mul CliffordAlgebra.even.Lift.aux_mul

end Even.Lift

open Even.Lift

variable (Q) {A}

/-- Every algebra morphism from the even subalgebra is in one-to-one correspondence with a
bilinear map that sends duplicate arguments to the quadratic form, and contracts across
multiplication. -/
@[simps symm_apply_bilin]
def even.lift : EvenHom Q A ≃ (CliffordAlgebra.even Q →ₐ[R] A)
    where
  toFun f := AlgHom.ofLinearMap (aux f) (aux_one f) (aux_mul f)
  invFun F := (even.ι Q).compr₂ F
  left_inv f := EvenHom.ext _ _ <| LinearMap.ext₂ <| even.Lift.aux_ι f
  right_inv F := even.algHom_ext Q <| EvenHom.ext _ _ <| LinearMap.ext₂ <| even.Lift.aux_ι _
#align clifford_algebra.even.lift CliffordAlgebra.even.lift

@[simp]
theorem even.lift_ι (f : EvenHom Q A) (m₁ m₂ : M) :
    even.lift Q f ((even.ι Q).bilin m₁ m₂) = f.bilin m₁ m₂ :=
  even.Lift.aux_ι _ _ _
#align clifford_algebra.even.lift_ι CliffordAlgebra.even.lift_ι

end CliffordAlgebra


import counit_ker_abelian
import pq_group_homo_locus
import pq_induction_principles

universe u

section pq_group_homo_locus_pres

inductive pre_homo_locus_pres (G : Type u) [group G] : Type u
| unit : pre_homo_locus_pres
| incl (x y : G) : pre_homo_locus_pres
| mul (x y : pre_homo_locus_pres) : pre_homo_locus_pres
| inv (x : pre_homo_locus_pres) : pre_homo_locus_pres

open pre_homo_locus_pres

inductive pre_homo_locus_pres_rel' (G : Type u) [group G] : pre_homo_locus_pres G → pre_homo_locus_pres G → Type u
| refl {a : pre_homo_locus_pres G} : pre_homo_locus_pres_rel' a a
| symm {a b : pre_homo_locus_pres G} (hab : pre_homo_locus_pres_rel' a b) : pre_homo_locus_pres_rel' b a
| trans {a b c : pre_homo_locus_pres G}
  (hab : pre_homo_locus_pres_rel' a b) (hbc : pre_homo_locus_pres_rel' b c) : pre_homo_locus_pres_rel' a c
| congr_mul {a b a' b' : pre_homo_locus_pres G}
  (ha : pre_homo_locus_pres_rel' a a') (hb : pre_homo_locus_pres_rel' b b') :
  pre_homo_locus_pres_rel' (mul a b) (mul a' b')
| congr_inv {a a' : pre_homo_locus_pres G} (ha : pre_homo_locus_pres_rel' a a') :
  pre_homo_locus_pres_rel' (inv a) (inv a')
| assoc (a b c : pre_homo_locus_pres G) : pre_homo_locus_pres_rel' (mul (mul a b) c) (mul a (mul b c))
| one_mul (a : pre_homo_locus_pres G) : pre_homo_locus_pres_rel' (mul unit a) a
| mul_one (a : pre_homo_locus_pres G) : pre_homo_locus_pres_rel' (mul a unit) a
| mul_left_inv (a : pre_homo_locus_pres G) : pre_homo_locus_pres_rel' (mul (inv a) a) unit
| comm (a1 a2 b1 b2 : G) : pre_homo_locus_pres_rel' (mul (incl a1 a2) (incl b1 b2)) (mul (incl b1 b2) (incl a1 a2))
| homo_locus_eq_zero (a b : G) (hab : homo_locus (a, b)) : pre_homo_locus_pres_rel' (incl a b) unit
| third_cancel (a b x : G) : pre_homo_locus_pres_rel' (incl a b) (mul (mul (incl x a)  (incl (x * a) (b))) (inv (incl x (a * b))))
| rhd_inv (a b : G) : pre_homo_locus_pres_rel' (incl a b) (inv (incl (a * b) (a⁻¹)))

inductive pre_homo_locus_pres_rel (G : Type u) [group G] : pre_homo_locus_pres G → pre_homo_locus_pres G → Prop
| rel {a b : pre_homo_locus_pres G} (r : pre_homo_locus_pres_rel' G a b) : pre_homo_locus_pres_rel a b

variables {G : Type*} [group G]

lemma pre_homo_locus_pres_rel'.rel {a b : pre_homo_locus_pres G} : pre_homo_locus_pres_rel' G a b → pre_homo_locus_pres_rel G a b := pre_homo_locus_pres_rel.rel

@[refl]
lemma pre_homo_locus_pres_rel.refl {a : pre_homo_locus_pres G} : pre_homo_locus_pres_rel G a a :=
pre_homo_locus_pres_rel'.rel pre_homo_locus_pres_rel'.refl

@[symm]
lemma pre_homo_locus_pres_rel.symm {a b : pre_homo_locus_pres G} : pre_homo_locus_pres_rel G a b → pre_homo_locus_pres_rel G b a
| ⟨r⟩ := r.symm.rel

@[trans]
lemma pre_homo_locus_pres_rel.trans {a b c : pre_homo_locus_pres G} :
pre_homo_locus_pres_rel G a b → pre_homo_locus_pres_rel G b c → pre_homo_locus_pres_rel G a c
| ⟨rab⟩ ⟨rbc⟩ := (rab.trans rbc).rel

instance pre_homo_locus_pres.setoid (G : Type*) [group G] : setoid (pre_homo_locus_pres G) :=
{
    r := pre_homo_locus_pres_rel G,
    iseqv := begin
        split, apply pre_homo_locus_pres_rel.refl,
        split, apply pre_homo_locus_pres_rel.symm,
        apply pre_homo_locus_pres_rel.trans,
    end
}

def homo_locus_pres (G : Type*) [group G] := quotient (pre_homo_locus_pres.setoid G)

instance homo_locus_pres_is_group : group (homo_locus_pres G) :=
{ mul := λ a b, quotient.lift_on₂ a b
                  (λ a b, ⟦pre_homo_locus_pres.mul a b⟧)
                  (λ a b a' b' ⟨ha⟩ ⟨hb⟩,
                    quotient.sound (pre_homo_locus_pres_rel'.congr_mul ha hb).rel),
  one := ⟦unit⟧,
  inv := λ a, quotient.lift_on a
                (λ a, ⟦pre_homo_locus_pres.inv a⟧)
                (λ a a' ⟨ha⟩,
                  quotient.sound (pre_homo_locus_pres_rel'.congr_inv ha).rel),
  mul_assoc := λ a b c,
    quotient.induction_on₃ a b c (λ a b c, quotient.sound (pre_homo_locus_pres_rel'.assoc a b c).rel),
  one_mul := λ a,
    quotient.induction_on a (λ a, quotient.sound (pre_homo_locus_pres_rel'.one_mul a).rel),
  mul_one := λ a,
    quotient.induction_on a (λ a, quotient.sound (pre_homo_locus_pres_rel'.mul_one a).rel),
  mul_left_inv := λ a,
    quotient.induction_on a (λ a, quotient.sound (pre_homo_locus_pres_rel'.mul_left_inv a).rel) }

def homo_locus_of (x : G × G) : homo_locus_pres G := ⟦incl x.1 x.2⟧

lemma homo_locus_of_def (x : G × G) : homo_locus_of x = ⟦incl x.1 x.2⟧ := rfl

lemma homo_locus_pres_one_def : (1 : homo_locus_pres G) = ⟦unit⟧ := rfl

lemma homo_locus_pres_mul_def (x y : pre_homo_locus_pres G) : (⟦x⟧ * ⟦y⟧ : homo_locus_pres G) = ⟦x.mul y⟧ := rfl

lemma homo_locus_pres_inv_def (x : pre_homo_locus_pres G) : (⟦x⟧⁻¹ : homo_locus_pres G) = ⟦x.inv⟧ := rfl

lemma homo_locus_pres_quot_mk_helper (x : pre_homo_locus_pres G) : quot.mk setoid.r x = ⟦x⟧ := rfl

variables {H : Type*} [group H]

def is_homo_locus_liftable (f : G × G → H) : Prop := (∀ a b : G × G, f a * f b = f b * f a) ∧ (∀ a b : G, homo_locus (a, b) → f (a, b) = 1) ∧ (∀ a b x : G, f (a, b) = f (x, a) * f (x * a, b) * ((f (x, (a * b)))⁻¹)) ∧ (∀ a b : G, f (a, b) = (f (a * b, a⁻¹))⁻¹)

def lift_homo_locus_pres_morph_pre (f : G × G → H) (hf : is_homo_locus_liftable f) : pre_homo_locus_pres G → H
| unit := 1
| (incl a b) := f (a, b)
| (mul a b) := lift_homo_locus_pres_morph_pre a * lift_homo_locus_pres_morph_pre b
| (inv a) := (lift_homo_locus_pres_morph_pre a)⁻¹

def lift_homo_locus_pres_morph (f : G × G → H) (hf : is_homo_locus_liftable f) : homo_locus_pres G →* H := {
  to_fun := quotient.lift (lift_homo_locus_pres_morph_pre f hf) begin
    intros a b hab,
    induction hab,
    induction hab_r,
    {
      refl,
    },
    {
      symmetry,
      assumption,
    },
    {
      transitivity,
      assumption,
      assumption,
    },
    {
      unfold lift_homo_locus_pres_morph_pre,
      congr,
      assumption,
      assumption,
    },
    {
      unfold lift_homo_locus_pres_morph_pre,
      congr,
      assumption,
    },
    {
      unfold lift_homo_locus_pres_morph_pre,
      rw mul_assoc,
    },
    {
      unfold lift_homo_locus_pres_morph_pre,
      rw one_mul,
    },
    {
      unfold lift_homo_locus_pres_morph_pre,
      rw mul_one,
    },
    {
      unfold lift_homo_locus_pres_morph_pre,
      rw mul_left_inv,
    },
    {
      unfold lift_homo_locus_pres_morph_pre,
      rw hf.1,
    },
    {
      unfold lift_homo_locus_pres_morph_pre,
      rw hf.2.1,
      assumption,
    },
    {
      unfold lift_homo_locus_pres_morph_pre,
      rw hf.2.2.1,
    },
    {
      unfold lift_homo_locus_pres_morph_pre,
      rw hf.2.2.2,
    },
  end,
  map_one' := begin
    refl,
  end,
  map_mul' := begin
    intros x y,
    induction x,
    induction y,
    refl,
    refl,
    refl,
  end }

lemma homo_locus_of_inv_alt (x y : G) : (homo_locus_of (x * y, x⁻¹))⁻¹ = homo_locus_of (x, y) :=
begin
  symmetry,
  apply quotient.sound,
  simp only,
  fconstructor,
  exact pre_homo_locus_pres_rel'.rhd_inv x y,
end

lemma homo_locus_of_inv (x y : G) : (homo_locus_of (x, y))⁻¹ = homo_locus_of (x * y, x⁻¹) :=
begin
  rw ←homo_locus_of_inv_alt,
  simp only [inv_inv],
end

lemma homo_locus_of_one (x y : G) (hxy : homo_locus (x, y)) : homo_locus_of (x, y) = 1 :=
begin
  apply quotient.sound,
  simp only,
  fconstructor,
  exact pre_homo_locus_pres_rel'.homo_locus_eq_zero x y hxy,
end

lemma homo_locus_third_cancel (a b x : G) : homo_locus_of (a, b) = (homo_locus_of (x, a) * homo_locus_of (x * a, b) * (homo_locus_of (x, a * b))⁻¹) :=
begin
  apply quotient.sound,
  simp only,
  fconstructor,
  exact pre_homo_locus_pres_rel'.third_cancel a b x,
end

lemma homo_locus_pres_comm (x y : homo_locus_pres G) : x * y = y * x :=
begin
  induction x,
  induction y,
  {
    rw homo_locus_pres_quot_mk_helper,
    rw homo_locus_pres_quot_mk_helper,
    induction x,
    {
      rw ←homo_locus_pres_one_def,
      simp only [mul_one, one_mul],
    },
    {
      induction y,
      {
        rw ←homo_locus_pres_one_def,
        simp only [mul_one, one_mul],
      },
      {
        apply quotient.sound,
        fconstructor,
        exact pre_homo_locus_pres_rel'.comm x_x x_y y_x y_y,
      },
      {
        rw ←homo_locus_pres_mul_def,
        rw ←mul_assoc,
        rw y_ih_x,
        rw mul_assoc,
        rw y_ih_y,
        rw ←mul_assoc,
      },
      {
        rw ←homo_locus_pres_inv_def,
        have : (⟦y_x⟧ * ⟦y_x⟧⁻¹ * ⟦incl x_x x_y⟧ * ⟦y_x⟧ : homo_locus_pres G) = ⟦y_x⟧ * ⟦incl x_x x_y⟧ * ⟦y_x⟧⁻¹ * ⟦y_x⟧,
        {
          simp only [one_mul, mul_right_inv, inv_mul_cancel_right],
          rw y_ih,
        },
        rw mul_left_inj at this,
        rw mul_assoc at this,
        rw mul_assoc at this,
        rw mul_right_inj at this,
        rw this,
      },
    },
    {
      rw ←homo_locus_pres_mul_def,
      rw mul_assoc,
      rw x_ih_y,
      rw ←mul_assoc,
      rw x_ih_x,
      rw ←mul_assoc,
    },
    {
      rw ←homo_locus_pres_inv_def,
      have : (⟦x_x⟧ * ⟦x_x⟧⁻¹ * ⟦y⟧ * ⟦x_x⟧ : homo_locus_pres G) = ⟦x_x⟧ * ⟦y⟧ * ⟦x_x⟧⁻¹ * ⟦x_x⟧,
      {
        simp only [one_mul, mul_right_inv, inv_mul_cancel_right],
        rw x_ih,
      },
      rw mul_left_inj at this,
      rw mul_assoc at this,
      rw mul_assoc at this,
      rw mul_right_inj at this,
      rw this,
    },
  },
  refl,
  refl,
end

lemma homo_locus_assoc (a b c : G) : homo_locus_of (a * b, c) * homo_locus_of (a, b) = homo_locus_of (a, b * c) * homo_locus_of (b, c) :=
begin
  rw homo_locus_third_cancel b c a,
  rw homo_locus_pres_comm,
  conv {
    to_rhs,
    rw homo_locus_pres_comm,
  },
  simp only [inv_mul_cancel_right],
end

lemma homo_locus_assoc_alt (a b c : G) : homo_locus_of (a * b, c) = homo_locus_of (a, b * c) * homo_locus_of (b, c) * (homo_locus_of (a, b))⁻¹ :=
begin
  rw ←homo_locus_assoc,
  simp only [mul_inv_cancel_right],
end

lemma homo_locus_of_inv_assoc (a b : G) : (homo_locus_of (a, b))⁻¹ = homo_locus_of (b⁻¹, a * b) :=
begin
  have : (homo_locus_of (b⁻¹, a))⁻¹ * homo_locus_of (b⁻¹, a) = 1,
  {
    simp only [mul_left_inv],
  },
  rw homo_locus_of_inv at this,
  rw homo_locus_assoc_alt at this,
  simp only [inv_inv, inv_mul_cancel_right] at this,
  group,
  simp only [gpow_one, gpow_neg],
  refine inv_inj.mp _,
  simp only [mul_inv_rev, one_inv, inv_inv],
  exact this,
end

lemma homo_locus_of_inv_cancel (a b : G) : (homo_locus_of (a, b))⁻¹ = homo_locus_of (a * b, b⁻¹) :=
begin
  rw homo_locus_assoc_alt,
  have : homo_locus_of (a, b * b⁻¹) = 1,
  {
    simp only [mul_right_inv],
    rw homo_locus_of_one,
    exact homo_locus_closed_right_one a,
  },
  rw this,
  clear this,
  have : homo_locus_of (b, b⁻¹) = 1,
  {
    rw homo_locus_of_one,
    exact homo_locus_closed_right_inv b,
  },
  rw this,
  clear this,
  simp only [one_mul],
end

lemma homo_locus_of_symm (a b c : G) : homo_locus_of (a, b) = homo_locus_of (b, a) :=
begin
  have : ∀ a b : G, homo_locus_of (b⁻¹, a * b) = homo_locus_of (a * b, b⁻¹),
  {
    intros a b,
    rw ←homo_locus_of_inv_cancel,
    rw ←homo_locus_of_inv_assoc,
  },
  specialize this (a * b) (b⁻¹),
  simp only [inv_inv, mul_inv_cancel_right] at this,
  symmetry,
  exact this,
end

lemma homo_locus_of_shift (a b : G) : homo_locus_of (a, b) = homo_locus_of (a, (a*b)⁻¹) :=
begin
  have : ∀ a b : G, homo_locus_of (a * b, b⁻¹) = homo_locus_of (a * b, a⁻¹),
  {
    intros a b,
    rw ←homo_locus_of_inv a b,
    rw ←homo_locus_of_inv_cancel,
  },
  specialize this (a * b) (b⁻¹),
  simp only [mul_inv_rev, inv_inv, mul_inv_cancel_right] at this,
  convert this,
  simp only [mul_inv_rev],
end

-- Try to prove another way, and remove from quotient rel
-- An idea: use isomorphism to obtain this
lemma homo_locus_of_inv_rev (a b : G) : (homo_locus_of (a, b))⁻¹ = homo_locus_of (b⁻¹, a⁻¹) :=
begin
  refine inv_inj.mp _,
  simp only [inv_inv],
  rw homo_locus_of_inv_assoc,
  simp only [inv_inv],
  rw homo_locus_of_shift,
  simp only [mul_inv_rev],
end

end pq_group_homo_locus_pres

section pq_group_homo_locus_pres_double_list

variables {G : Type u} [group G]

open pre_homo_locus_pres

def pre_homo_locus_pres_to_list : pre_homo_locus_pres G → list G
| unit := []
| (incl a b) := [a, b]
| (mul a b) := let x := (pre_homo_locus_pres_to_list a) in let y := (pre_homo_locus_pres_to_list b) in x ++ y ++ [x.prod⁻¹]
| (inv a) := let x := (pre_homo_locus_pres_to_list a) in (x.map (λ x : G, x⁻¹)).reverse

lemma pre_homo_locus_pres_to_list_eq_id (x : pre_homo_locus_pres G) : ((counit_ker_decomp (pre_homo_locus_pres_to_list x)).map (homo_locus_of)).prod = ⟦x⟧ :=
begin
  induction x,
  {
    unfold pre_homo_locus_pres_to_list,
    unfold counit_ker_decomp,
    unfold counit_ker_decomp_pre,
    simp only [list.prod_nil, list.map],
    refl,
  },
  {
    unfold pre_homo_locus_pres_to_list,
    unfold counit_ker_decomp,
    unfold counit_ker_decomp_pre,
    simp only [mul_one, one_mul, list.prod_cons, list.prod_nil, list.map],
    suffices : homo_locus_of (1, x_x) = 1,
    simp only [this, one_mul], refl,
    apply quotient.sound,
    simp only,
    fconstructor,
    refine pre_homo_locus_pres_rel'.homo_locus_eq_zero 1 x_x _,
    exact homo_locus_closed_left_one x_x,
  },
  {
    unfold pre_homo_locus_pres_to_list,
    simp only,
    rw ←homo_locus_pres_mul_def,
    rw ←x_ih_x,
    rw ←x_ih_y,
    clear x_ih_x x_ih_y,
    rw counit_ker_decomp_append,
    rw counit_ker_decomp_append,
    simp only [mul_right_inj, list.map_append, list.prod_append, list.append_assoc],
    unfold counit_ker_decomp_pre,
    simp only [mul_one, list.prod_cons, list.prod_nil, list.map],
    generalize : pre_homo_locus_pres_to_list x_x = x,
    generalize : pre_homo_locus_pres_to_list x_y = y,
    clear x_x x_y,
    unfold counit_ker_decomp,
    suffices : (list.map homo_locus_of (counit_ker_decomp_pre x.prod y)).prod = (list.map homo_locus_of (counit_ker_decomp_pre 1 y)).prod * (homo_locus_of (x.prod * y.prod, (x.prod)⁻¹))⁻¹,
    {
      rw this,
      simp only [inv_mul_cancel_right],
    },
    rw homo_locus_of_inv_alt,
    generalize : x.prod = b,
    clear x,
    induction y generalizing b,
    {
      simp only [mul_one, list.prod_nil],
      unfold counit_ker_decomp_pre,
      simp only [one_mul, list.prod_nil, list.map],
      symmetry,
      apply homo_locus_of_one,
      exact homo_locus_closed_right_one b,
    },
    {
      unfold counit_ker_decomp_pre,
      simp only [one_mul, list.prod_cons, list.map],
      have hy1 := y_ih (b * y_hd),
      rw hy1,
      clear hy1,
      have hy2 := y_ih (y_hd),
      rw hy2,
      clear hy2,
      rw ←mul_assoc,
      have one_rw : homo_locus_of (1, y_hd) = 1,
      {
        apply homo_locus_of_one,
        exact homo_locus_closed_left_one y_hd,
      },
      rw one_rw,
      rw one_mul,
      clear one_rw,
      rw homo_locus_pres_comm,
      rw ←mul_assoc,
      conv {
        to_rhs,
        rw homo_locus_pres_comm,
        congr,
        skip,
        rw homo_locus_pres_comm,
      },
      rw ←mul_assoc,
      simp only [mul_left_inj],
      generalize : y_tl.prod = c,
      rename y_hd a,
      clear y_ih y_tl,
      apply homo_locus_assoc,
    },
  },
  {
    unfold pre_homo_locus_pres_to_list,
    simp only,
    rw ←homo_locus_pres_inv_def,
    rw ←x_ih,
    clear x_ih,
    generalize : pre_homo_locus_pres_to_list x_x = x,
    clear x_x,
    induction x,
    {
      simp only [list.map, list.reverse_nil],
      exact one_inv.symm,
    },
    {
      simp only [list.reverse_cons, list.map],
      rw counit_ker_decomp_append_one,
      simp only [mul_one, list.map_append, list.prod_append, list.prod_cons, list.prod_nil, list.map],
      rw x_ih,
      clear x_ih,
      unfold counit_ker_decomp,
      unfold counit_ker_decomp_pre,
      simp only [mul_inv_rev, one_mul, list.prod_cons, list.map],
      have : (homo_locus_of (1, x_hd))⁻¹ = 1,
      {
        refine inv_eq_one.mpr _,
        apply homo_locus_of_one,
        exact homo_locus_closed_left_one x_hd,
      },
      rw this,
      clear this,
      rw mul_one,
      have : (list.map has_inv.inv x_tl).reverse.prod = (x_tl.prod)⁻¹,
      {
        clear x_hd,
        induction x_tl,
        {
          simp only [one_inv, list.prod_nil, list.map, list.reverse_nil],
        },
        {
          simp only [list.reverse_cons, mul_inv_rev, mul_one, list.prod_append, list.prod_cons, list.prod_nil, mul_left_inj, list.map, x_tl_ih],
        },
      },
      rw this,
      clear this,
      rw ←inv_inj,
      simp only [mul_inv_rev, inv_inv],
      induction x_tl generalizing x_hd,
      {
        simp only [one_inv, list.prod_nil],
        unfold counit_ker_decomp_pre,
        simp only [mul_one, inv_eq_one, list.prod_nil, list.map],
        apply homo_locus_of_one,
        exact homo_locus_closed_left_one x_hd⁻¹,
      },
      {
        simp only [mul_inv_rev, list.prod_cons],
        unfold counit_ker_decomp_pre,
        simp only [one_mul, list.prod_cons, list.map],
        rw ←x_tl_ih (x_tl_hd),
        rw ←x_tl_ih (x_hd * x_tl_hd),
        simp only [←mul_assoc],
        simp only [mul_inv_rev, mul_left_inj],
        generalize : (x_tl_tl.prod)⁻¹ = c,
        generalize hb : (x_tl_hd)⁻¹ = b,
        generalize ha : (x_hd)⁻¹ = a,
        clear x_tl_ih x_tl_tl,
        have ha1 : x_hd = a⁻¹,
        {
          rw ←ha,
          rw inv_inv,
        },
        have hb1 : x_tl_hd = b⁻¹,
        {
          rw ←hb,
          rw inv_inv,
        },
        rw ha1,
        rw hb1,
        clear ha1 hb1 ha hb x_tl_hd x_hd,
        have : homo_locus_of (1, b⁻¹) = 1,
        {
          apply homo_locus_of_one,
          exact homo_locus_closed_left_one b⁻¹,
        },
        rw this,
        clear this,
        rw mul_one,
        rw ←inv_inj,
        simp only [mul_inv_rev, inv_inv],
        rw homo_locus_pres_comm,
        rw homo_locus_assoc c b a,
        rw homo_locus_of_inv_rev,
        simp only [inv_inv],
      },
    },
  },
end

end pq_group_homo_locus_pres_double_list

section pq_group_homo_locus_pres_iso_ker_counit

variables {G : Type u} [group G]

def homo_locus_pres_iso_ker_counit_forward : homo_locus_pres G →* (counit : pq_group G →* G).ker :=
begin
  fapply lift_homo_locus_pres_morph,
  {
    intro g,
    fconstructor,
    exact of g.1 * of g.2 * (of (g.1 * g.2))⁻¹,
    refine counit.mem_ker.mpr _,
    simp only [counit_of, mul_inv_rev, monoid_hom.map_mul, monoid_hom.map_mul_inv],
    group,
  },
  {
    split,
    {
      intros a b,
      cases a with a1 a2,
      cases b with b1 b2,
      simp only,
      rw counit_ker_abelian,
    },
    split,
    {
      intros a b hab,
      simp only,
      ext1,
      simp only [subgroup.coe_one, subgroup.coe_mk],
      simp only [homo_locus_def] at hab,
      rw hab,
      simp only [mul_right_inv],
    },
    split,
    {
      intros a b x,
      simp only,
      ext1,
      simp only [mul_inv_rev, subgroup.coe_inv, subgroup.coe_mul, inv_inv, subgroup.coe_mk],
      suffices : of a * (of (x * a))⁻¹ * (of (x * a) * of b * (of (x * a * b))⁻¹) * of (x * (a * b)) * (of (a * b))⁻¹ = of a * of b * (of (a * b))⁻¹,
      {
        assoc_rw this,
        clear this _inst,
        assoc_rw counit_ker_abelian_counit (of a * of b * (of (a * b))⁻¹) _ _,
        simp only [one_mul, mul_right_inv],
        simp only [counit_of, mul_inv_rev, monoid_hom.map_mul, monoid_hom.map_mul_inv],
        group,
      },
      group,
    },
    {
      intros a b,
      simp only,
      ext1,
      simp only [mul_inv_rev, subgroup.coe_inv, inv_inv, subgroup.coe_mk],
      rw ←rhd_def_group,
      rw ←rhd_of_eq_of_rhd,
      rw rhd_def_group,
      rw inv_of,
      simp only [inv_inv],
      group,
    },
  },
end

lemma homo_locus_pres_iso_ker_counit_forward_homo_locus_of (a b : G) : homo_locus_pres_iso_ker_counit_forward (homo_locus_of (a, b)) = ⟨of a * of b * (of (a * b))⁻¹, begin
  refine counit.mem_ker.mpr _,
  simp only [counit_of, mul_inv_rev, monoid_hom.map_mul, monoid_hom.map_mul_inv],
  group,
end⟩  :=
begin
  refl,
end

theorem homo_locus_pres_iso_ker_counit_forward_from_list (x : pre_homo_locus_pres G) : homo_locus_pres_iso_ker_counit_forward ⟦x⟧ = ⟨((counit_ker_decomp (pre_homo_locus_pres_to_list x)).map (λ (a : G × G), of a.1 * of a.2 * (of (a.1 * a.2))⁻¹)).prod, begin
  apply counit_ker_decomp_comp_in_ker,
end⟩ :=
begin
  rw ←pre_homo_locus_pres_to_list_eq_id,
  generalize : counit_ker_decomp (pre_homo_locus_pres_to_list x) = y,
  clear x,
  rw hom_list_prod,
  ext1,
  simp only [list.map_map, subgroup.coe_mk],
  have coe_prod : ∀ x : list ((counit : pq_group G →* G).ker), (↑(x.prod) : pq_group G) = (x.map (λ x, ↑x)).prod,
  {
    intros x,
    clear y,
    induction x,
    {
      simp only [subgroup.coe_one, list.prod_nil, list.map],
    },
    {
      simp only [mul_right_inj, subgroup.coe_mul, list.prod_cons, list.map],
      exact x_ih,
    },
  },
  rw coe_prod,
  simp only [list.map_map],
  refl,
end

/-

variables {H : Type u} [group H]

def counit_ker_data_induction (f : G × G → H) (hf : is_homo_locus_liftable f) : (counit : pq_group G →* G).ker →* H :=
begin
  rcases hf with ⟨hf1, hf2, hf3, hf4, hf5⟩,
  fconstructor,
  {
    intro x,
    cases x with x hx,
    clear hx,
    induction x,
    {
      --rw quot_mk_helper at hx,
      exact ((counit_ker_decomp (create_list_from_pq x)).map f).prod,
    },
    {
      sorry,
    },
  },
  {
    sorry,
  },
  {
    sorry,
  },
end

-/

/-

def homo_locus_pres_iso_ker_counit_backward_fun_aux_pre : G → list G → homo_locus_pres G
| y (a :: x) := homo_locus_of (y, a) * homo_locus_pres_iso_ker_counit_backward_fun_aux_pre (y * a) x
| y [] := 1

def homo_locus_pres_iso_ker_counit_backward_fun_aux : list G → homo_locus_pres G := λ x, homo_locus_pres_iso_ker_counit_backward_fun_aux_pre 1 (x)

def homo_locus_pres_iso_ker_counit_backward_fun : (counit : pq_group G →* G).ker → homo_locus_pres G :=
begin
  fapply pq_group_list_data_property,
  exact (λ ⟨x, hx⟩, homo_locus_pres_iso_ker_counit_backward_fun_aux x),
  {
    intros x y hx hy hxy,

    induction hxy,
    induction hxy_r,
    {
      refl,
    },
    {
      symmetry,
      solve_by_elim
    },
    {
      have hb : ⟦hxy_r_b⟧ ∈ has_coe_t_aux.coe counit.ker,
      {
        suffices : ⟦hxy_r_a⟧ = ⟦hxy_r_b⟧,
        rw ←this,
        exact hx,
        apply quotient.sound,
        fconstructor,
        assumption,
      },
      transitivity,
      apply hxy_r_ih_hab,
      assumption,
      solve_by_elim,
    },
    {
      unfold create_list_from_pq,

    },
    {
      sorry,
    },
    {
      sorry,
    },
    {
      sorry,
    },
    {
      sorry,
    },
    {
      sorry,
    },
    {
      sorry,
    },
    {
      sorry,
    },
    {
      sorry,
    },
    {
      sorry,
    },
  },
end

-/

/-

def homo_locus_pres_iso_ker_counit_backward : (counit : pq_group G →* G).ker →* homo_locus_pres G := {
  to_fun := homo_locus_pres_iso_ker_counit_backward_fun,
  map_one' := sorry,
  map_mul' := sorry }

theorem homo_locus_pres_iso_ker_counit_forward_bijective : function.bijective (homo_locus_pres_iso_ker_counit_forward : homo_locus_pres G → (counit : pq_group G →* G).ker) :=
begin
  split,
  {
    refine homo_locus_pres_iso_ker_counit_forward.injective_iff.mpr _,
    intros a ha,
    induction a,
    {
      rw homo_locus_pres_quot_mk_helper at *,
      rw homo_locus_pres_iso_ker_counit_forward_from_list at ha,
      injections_and_clear,
      rename h_1 ha,
      rw ←pre_homo_locus_pres_to_list_eq_id,
      generalize hax : (pre_homo_locus_pres_to_list a) = x,
      rw hax at ha,
      clear hax a,
      rename ha hx,
      rw ←counit_ker_decomp_comp_alt at hx,

    },
    {refl,},
  },
  {
    refine counit_ker_induction _ _,
    {
      intros a b,
      use homo_locus_of (a, b),
      refl,
    },
    {
      intros a b ha hb,
      cases ha with x hx,
      cases hb with y hy,
      use x * y,
      simp only [monoid_hom.map_mul, hx, hy],
    },
  },
end

def homo_locus_pres_iso_ker_counit : homo_locus_pres G ≃* (counit : pq_group G →* G).ker := {
  to_fun := homo_locus_pres_iso_ker_counit_forward,
  inv_fun := sorry,
  left_inv := sorry,
  right_inv := sorry,
  map_mul' := begin
    intros x y,
    simp only [monoid_hom.map_mul],
  end }

-/

end pq_group_homo_locus_pres_iso_ker_counit


import to_mathlib.analysis.normed_group
import to_mathlib.linear_algebra.basis
import to_mathlib.topology.algebra.order.basic

import loops.exists

import local.corrugation
import local.ample_relation

import interactive_expr
set_option trace.filter_inst_type true

/-!
# Local h-principle for open and ample relations

This file proves lem:h_principle_open_ample_loc from the blueprint. This is the local
version of the h-principle for open and ample relations. The proof brings together the
main result `exist_loops` from the loop folder (Chapter 1 in the blueprint) and
the corrugation technique.

One formalization issue is that the whole construction carries around a lot of data.
On paper it is easy to state one lemma listing once all this data and proving many properties.
Here it is more convenient to give each property its own lemma so carrying around data,
assumptions and constructions requires some planning. Our way to mitigate this issue
is to use two ad-hoc structures `landscape` and `step_landscape` which partly bundle
all this.

The `landscape` structure record three sets in a vector space, a closed
set `C` and two nested compact sets `K₀` and `K₁`. This is the ambiant data for
the local h-principle result. We call this partly bundled because it doesn't include
the data of the formal solution we want to improve. Instead we have a Prop-valued
structure `landscape.accepts` that takes a landscape and a formal solution and assert
some compatibility conditions. There are four conditions, which is already enough
motivation to introduce a structure instead of one definition using the logical
conjunction operator that would lead to awkward and error prone access to the
individual conditions.

The proof of this proposition involves an induction on a flag of subspaces (nested
subspaces of increasing dimensions). For the purpose of this induction we use
a second structure `step_landscape` that extends `landscape` with two more pieces
of data, a subspace and a dual pair, and a compatibility condition, namely the subspace
has to be in the hyperplane defined by the dual pair.

In this setup, given `(L : step_landscape E) {𝓕 : formal_sol R} (h : L.accepts R 𝓕)`,
the loop family constructed by Chapter 2 is `L.loop h`. Together with corrugation,
it is used to build `L.improve_step h` which is the homotopy of 1-jet sections improving
the formal solution `𝓕` in that step of the main inductive proof. A rather long series of
lemmas prove all the required properties of that homotopy, corresponding to
lemma lem:integration_step from the blueprint.

The inductive proof itself is the proof of `rel_loc.formal_sol.improve`.
Here all conclusions are stated at once this the induction requires to know about each
of them to proceed to the next step. We could have introduced one more ad-hoc structure
to record those conclusion but this isn't needed (at least in that Chapter) since we
need to access its components only once.

-/

noncomputable theory

open_locale unit_interval classical filter topology
open filter set rel_loc linear_map (ker)

variables (E : Type*) [normed_add_comm_group E] [normed_space ℝ E]
          {F : Type*} [normed_add_comm_group F] [normed_space ℝ F]
          {G : Type*} [normed_add_comm_group G] [normed_space ℝ G]

/--
The setup for local h-principle is two compact subsets `K₀ ⊆ K₁` in `E` with
`K₀ ⊆ interior K₁` and a closed subset `C`.
-/
structure landscape :=
(C K₀ K₁ : set E)
(hC : is_closed C)
(hK₀ : is_compact K₀)
(hK₁ : is_compact K₁)
(h₀₁ : K₀ ⊆ interior K₁)

section improve_step
/-!
## Improvement step

This section proves lem:integration_step.
-/

/--
The setup for a one-step improvement towards a local h-principle is two compact subsets
`K₀ ⊆ K₁` in `E` with `K₀ ⊆ interior K₁` and a closed subset `C`
together with a dual pair `p` and a subspace `E'` of the corresponding hyperplane `ker p.π`.
-/
structure step_landscape extends landscape E :=
(E' : submodule ℝ E)
(p : dual_pair E)
(hEp : E' ≤ ker p.π)

variables {E}

open_locale classical

variables (R : rel_loc E F)

namespace step_landscape

/-- A one-step improvement landscape accepts a formal solution if it can improve it. -/
structure accepts (L : step_landscape E) (𝓕 : jet_sec E F) : Prop :=
(h_op : is_open R)
(hK₀ : ∀ᶠ x near L.K₀, 𝓕.is_part_holonomic_at L.E' x)
(h_short : ∀ x, 𝓕.is_short_at R L.p x)
(hC : ∀ᶠ x near L.C, 𝓕.is_holonomic_at x)

/-- The union of all slices of `R` corresponding to `𝓕`. -/
def Ω (L : step_landscape E) (𝓕 : jet_sec E F) : set (E × F) :=
{p | p.2 ∈ 𝓕.slice_at R L.p p.1}
--⋃ x, ({x} : set E) ×ˢ (connected_component_in (𝓕.slice_at R L.p x) $ 𝓕.φ x L.p.v)

/-- The linear form in a `step_landscape`, coming from the underlying dual pair. -/
def π (L : step_landscape E) : E →L[ℝ] ℝ := L.p.π

/-- The vector in a `step_landscape`, coming from the underlying dual pair. -/
def v (L : step_landscape E) : E := L.p.v

/-- One more compact set in the landscape: K₁ ∩ C, needed as an input to the
loop construction. -/
def K (L : step_landscape E) : set E := L.K₁ ∩ L.C

/-- The base function for the loop family associated in any jet section in a
step landscape. -/
def b (L : step_landscape E) (𝓕 : jet_sec E F) : E → F := λ x, 𝓕.φ x L.v

/-- The desired average for the loop family associated in any jet section in a
step landscape. -/
def g (L : step_landscape E) (𝓕 : jet_sec E F) : E → F := λ x, D 𝓕.f x L.v

lemma is_compact_K (L : step_landscape E) : is_compact L.K :=
L.hK₁.inter_right L.hC

variables {R}

lemma accepts.open [finite_dimensional ℝ E]  {L : step_landscape E} {𝓕 : jet_sec E F} (h : L.accepts R 𝓕) :
  is_open (L.Ω R 𝓕) :=
begin
  set ψ : E × F → one_jet E F := λ p, (p.1, 𝓕.f p.1, L.p.update (𝓕.φ p.1) p.2),
  change is_open {p : E × F | ψ p ∈ R},
  apply is_open.preimage _ h.h_op,
  apply continuous_fst.prod_mk (𝓕.f_diff.continuous.fst'.prod_mk _),
  exact L.p.continuous_update 𝓕.φ_diff.continuous.fst' continuous_snd
end

lemma smooth_b (L : step_landscape E) (𝓕 : jet_sec E F) :
  𝒞 ∞ (L.b 𝓕) :=
(continuous_linear_map.apply ℝ F L.v).cont_diff.comp 𝓕.φ_diff

lemma smooth_g (L : step_landscape E) (𝓕 : jet_sec E F) :
  𝒞 ∞ (L.g 𝓕) :=
(continuous_linear_map.apply ℝ F L.v).cont_diff.comp (cont_diff_top_iff_fderiv.mp 𝓕.f_diff).2

lemma accepts.rel {L : step_landscape E} {𝓕 : jet_sec E F} (h : L.accepts R 𝓕) :
  ∀ᶠ (x : E) near L.K, (L.g 𝓕) x = (L.b 𝓕) x :=
begin
  apply (h.hC.filter_mono $ monotone_nhds_set (inter_subset_right L.K₁ L.C)).mono,
  intros x hx,
  dsimp [jet_sec.is_holonomic_at] at hx,
  dsimp [step_landscape.g, step_landscape.b],
  rw hx
end

variables [finite_dimensional ℝ E]  [finite_dimensional ℝ F]

open_locale borelize

/-- The loop family to use in some landscape to improve a formal solution. -/
def loop (L : step_landscape E) {𝓕 : formal_sol R} (h : L.accepts R 𝓕) :
ℝ → E → loop F :=
classical.some (exist_loops L.is_compact_K h.open (L.smooth_g 𝓕) (L.smooth_b 𝓕) h.rel h.h_short)

lemma nice (L : step_landscape E) {𝓕 : formal_sol R} (h : L.accepts R 𝓕) :
  nice_loop (L.g ↑𝓕) (L.b ↑𝓕) (Ω R L 𝓕) L.K (L.loop h) :=
classical.some_spec $ exist_loops L.is_compact_K h.open (L.smooth_g 𝓕) (L.smooth_b 𝓕) h.rel h.h_short

lemma update_zero (L : step_landscape E) {𝓕 : formal_sol R} (h : L.accepts R 𝓕) (x : E) (s : ℝ) :
L.p.update (𝓕.φ x) ((L.loop h 0 x) s) = 𝓕.φ x :=
begin
  rw (L.nice h).t_zero x s,
  exact L.p.update_self _,
end

lemma loop_smooth (L : step_landscape E) {𝓕 : formal_sol R} (h : L.accepts R 𝓕) :
  𝒞 ∞ ↿(L.loop h) :=
(L.nice h).smooth

lemma loop_smooth' (L : step_landscape E) {𝓕 : formal_sol R} (h : L.accepts R 𝓕)
  {t : G → ℝ} (ht : 𝒞 ∞ t) {s : G → ℝ} (hs : 𝒞 ∞ s) {x : G → E} (hx : 𝒞 ∞ x) :
  𝒞 ∞ (λ g, L.loop h (t g) (x g) (s g)) :=
(L.loop_smooth h).comp (ht.prod $ hx.prod hs)

lemma loop_C1 (L : step_landscape E) {𝓕 : formal_sol R} (h : L.accepts R 𝓕) :
∀ t, 𝒞 1 ↿(L.loop h t) :=
λ t, (L.loop_smooth' h cont_diff_const cont_diff_snd cont_diff_fst).of_le le_top

variables (L : step_landscape E)

/-- The cut-off function associated to a step landscape, equal to one near K₀ and
zero outside K₁. -/
def ρ (L : step_landscape E) : E → ℝ :=
(exists_cont_diff_one_nhds_of_interior L.hK₀.is_closed L.h₀₁).some

lemma ρ_smooth (L : step_landscape E) : 𝒞 ∞ L.ρ :=
(exists_cont_diff_one_nhds_of_interior L.hK₀.is_closed L.h₀₁).some_spec.1

lemma ρ_mem (L : step_landscape E) (x : E) : L.ρ x ∈ I :=
(exists_cont_diff_one_nhds_of_interior L.hK₀.is_closed L.h₀₁).some_spec.2.2.2 x

lemma ρ_le (L : step_landscape E) (x : E) : |L.ρ x| ≤ 1 :=
begin
  cases L.ρ_mem x with h h',
  rw abs_le,
  refine ⟨_, h'⟩,
  linarith
end

lemma hρ₀ (L : step_landscape E) : ∀ᶠ x near L.K₀, L.ρ x = 1 :=
(exists_cont_diff_one_nhds_of_interior L.hK₀.is_closed L.h₀₁).some_spec.2.1

lemma hρ_compl_K₁ (L : step_landscape E) {x : E} : x ∉ L.K₁ → L.ρ x = 0 :=
(exists_cont_diff_one_nhds_of_interior L.hK₀.is_closed L.h₀₁).some_spec.2.2.1 x

/--
Homotopy of formal solutions obtained by corrugation in the direction of `p : dual_pair E`
in some landscape to improve a formal solution `𝓕` from being `L.E'`-holonomic to
`L.E' ⊔ span {p.v}`-holonomic near `L.K₀`.
-/
def improve_step {𝓕 : formal_sol R} (h : L.accepts R 𝓕) (N : ℝ) : htpy_jet_sec E F :=
{ f := λ t x, 𝓕.f x + (smooth_step t*L.ρ x) • corrugation L.π N (L.loop h t) x,
  f_diff :=  𝓕.f_diff.snd'.add $
    (smooth_step.smooth.fst'.mul L.ρ_smooth.snd').smul $
    corrugation.cont_diff' N (L.loop_smooth h) cont_diff_snd cont_diff_fst,
  φ := λ t x, L.p.update (𝓕.φ x) (L.loop h (smooth_step t*L.ρ x) x $ N * L.π x) +
                (smooth_step t*L.ρ x) • (corrugation.remainder L.p.π N (L.loop h 1) x),
  φ_diff := begin
    apply cont_diff.add,
    apply L.p.smooth_update,
    apply 𝓕.φ_diff.snd',
    apply L.loop_smooth',
    exact smooth_step.smooth.fst'.mul L.ρ_smooth.snd',
    apply cont_diff_const.mul L.π.cont_diff.snd',
    exact cont_diff_snd,
    apply cont_diff.smul,
    exact smooth_step.smooth.fst'.mul L.ρ_smooth.snd',
    exact remainder.smooth _ _ (L.loop_smooth h) cont_diff_snd cont_diff_const
  end }

variables {L} {𝓕 : formal_sol R} (h : L.accepts R 𝓕) (N : ℝ)

@[simp]
lemma improve_step_apply (t : ℝ) (x : E) :
  L.improve_step h N t x = (𝓕.f x + (smooth_step t*L.ρ x) • corrugation L.π N (L.loop h t) x,
  L.p.update (𝓕.φ x) (L.loop h (smooth_step t*L.ρ x) x $ N * L.π x) +
                 (smooth_step t*L.ρ x) • (corrugation.remainder L.p.π N (L.loop h 1) x)) :=
by { simp [improve_step, h], refl }

@[simp]
lemma improve_step_apply_f (t : ℝ) (x : E) :
  (L.improve_step h N t).f x = 𝓕.f x + (smooth_step t*L.ρ x) • corrugation L.π N (L.loop h t) x :=
rfl

@[simp]
lemma improve_step_apply_φ (t : ℝ) (x : E) :
  (L.improve_step h N t).φ x = L.p.update (𝓕.φ x) (L.loop h (smooth_step t*L.ρ x) x $ N * L.π x) +
                 (smooth_step t*L.ρ x) • (corrugation.remainder L.p.π N (L.loop h 1) x) :=
rfl

lemma improve_step_of_support (t : ℝ) {x : E}
  (H : ∀ t, x ∉ loop.support (L.loop h t)) :
  L.improve_step h N t x = 𝓕 x :=
begin
  have : ∀ t s, L.loop h t x s = 𝓕.φ x L.v,
      { intros t s,
        rw loop.is_const_of_not_mem_support (H t) s 0,
        apply (L.nice h).s_zero x t },
  rw [improve_step_apply h, corrugation_eq_zero _ _ _ _ (H t),
      remainder_eq_zero _ _ (L.loop_C1 h 1) (H 1)],
  simp only [formal_sol.to_jet_sec_eq_coe, smul_zero, add_zero, this],
  erw L.p.update_self,
  refl
end

lemma improve_step_rel_t_eq_0 : L.improve_step h N 0 = 𝓕 :=
begin
  ext x,
  { rw improve_step_apply_f h,
    simp [(L.nice h).t_zero x] },
  { ext x,
    rw improve_step_apply_φ h,
    simp only [formal_sol.to_jet_sec_eq_coe, zero_mul, smooth_step.zero, zero_smul, add_zero],
    erw L.update_zero h, refl }
end

lemma improve_step_rel_compl_K₁ {x} (hx : x ∉ L.K₁) (t) : L.improve_step h N t x = 𝓕 x :=
begin
  rw [improve_step_apply h, L.hρ_compl_K₁ hx],
  simp only [formal_sol.to_jet_sec_eq_coe, mul_zero, zero_smul, add_zero],
  erw L.update_zero h,
  refl
end

lemma improve_step_rel_K : ∀ᶠ x near L.K, ∀ t, L.improve_step h N t x = 𝓕 x :=
begin
  have : ∀ᶠ x near L.K, ∀ t, x ∉ loop.support (L.loop h t),
  { apply (L.nice h).rel_K.eventually_nhds_set.mono,
    intros x hx t,
    apply loop.not_mem_support,
    apply hx.mono,
    intros y hy,
    exact loop.is_const_of_eq (hy t) },
  apply this.mono,
  intros x hx t,
  exact improve_step_of_support _ _ _ hx
end

lemma improve_step_rel_C : ∀ᶠ x near L.C, ∀ t, L.improve_step h N t x = 𝓕 x :=
begin
  apply eventually.filter_mono (L.hK₁.is_closed.nhds_set_le_sup' L.C),
  rw eventually_sup,
  split,
  { apply improve_step_rel_K },
  { rw eventually_principal,
    exact λ x, improve_step_rel_compl_K₁ h N }
end

-- In the next lemma we reintroduce F to appaise the unused argument linter since
-- `finite_dimensional ℝ F` isn't needed here.

lemma bu_lt {F : Type*} [normed_add_comm_group F] [normed_space ℝ F]
  (t : ℝ) (x : E) {v : F} {ε : ℝ} (hv : ‖v‖ < ε) :
  ‖(smooth_step t * L.ρ x) • v‖ < ε :=
calc ‖(smooth_step t * L.ρ x) • v‖ = |smooth_step t| * |L.ρ x| * ‖v‖ : by
             rw [norm_smul, real.norm_eq_abs, abs_mul]
... ≤ ‖v‖ : mul_le_of_le_one_left (norm_nonneg _) (mul_le_one (smooth_step.abs_le t)
                                                          (abs_nonneg _) (L.ρ_le x))
... < ε : hv

lemma improve_step_c0_close {ε : ℝ} (ε_pos : 0 < ε) :
  ∀ᶠ N in at_top, ∀ x t, ‖(L.improve_step h N t).f x - 𝓕.f x‖ ≤ ε :=
begin
  set γ := L.loop h,
  have γ_cont : continuous ↿(λ t x, γ t x) := (L.nice h).smooth.continuous,
  have γ_C1 : 𝒞 1 ↿(γ 1) := ((L.nice h).smooth.comp (cont_diff_prod_mk_right 1)).of_le le_top,
  apply ((corrugation.c0_small_on L.hK₁ (L.nice h).t_le_zero (L.nice h).t_ge_one γ_cont ε_pos).and $
        remainder_c0_small_on L.π L.hK₁ γ_C1 ε_pos).mono,
  rintros N ⟨H, H'⟩ x t,
  by_cases hx : x ∈ L.K₁,
  { rw [improve_step_apply_f h],
    suffices : ‖(smooth_step t * L.ρ x) • corrugation L.π N (L.loop h t) x‖ ≤ ε, by simpa,
    exact (bu_lt _ _ $ H _ hx t).le },
  { rw show (L.improve_step h N t).f x = 𝓕.f x, from congr_arg prod.fst (improve_step_rel_compl_K₁ h N hx t),
    simp [ε_pos.le] }
end

lemma improve_step_part_hol {N : ℝ} (hN : N ≠ 0) :
  ∀ᶠ x near L.K₀, (L.improve_step h N 1).is_part_holonomic_at (L.E' ⊔ L.p.span_v) x :=
begin
  have γ_C1 : 𝒞 1 ↿(L.loop h 1) := ((L.nice h).smooth.comp (cont_diff_prod_mk_right 1)).of_le le_top,
  let 𝓕' : jet_sec E F :=
  { f := λ x, 𝓕.f x + corrugation L.π N (L.loop h 1) x,
    f_diff := 𝓕.f_diff.add
     (corrugation.cont_diff' _ (L.loop_smooth h) cont_diff_id cont_diff_const),
    φ := λ x , L.p.update (𝓕.φ x) (L.loop h 1 x $ N * L.π x) +
               corrugation.remainder L.p.π N (L.loop h 1) x,
    φ_diff := begin
      apply cont_diff.add,
      apply L.p.smooth_update,
      apply 𝓕.φ_diff,
      apply L.loop_smooth',
      apply cont_diff_const,
      apply cont_diff_const.mul L.π.cont_diff,
      exact cont_diff_id,
      exact remainder.smooth _ _ (L.loop_smooth h) cont_diff_id cont_diff_const
    end },
  have H : ∀ᶠ x near L.K₀, L.improve_step h N 1 x = 𝓕' x,
  { apply L.hρ₀.mono,
    intros x hx,
    simp [improve_step_apply h, hx],
    refl },
  have fderiv_𝓕' := λ x, fderiv_corrugated_map N hN γ_C1 (𝓕.f_diff.of_le le_top) L.p ((L.nice h).avg x),
  rw eventually_congr (H.is_part_holonomic_at_congr (L.E' ⊔ L.p.span_v)),
  apply h.hK₀.mono,
  intros x hx,
  apply jet_sec.is_part_holonomic_at.sup,
  { intros u hu,
    have hu_ker := L.hEp hu,
    dsimp [𝓕'],
    erw [fderiv_𝓕', continuous_linear_map.add_apply, L.p.update_ker_pi _ _ hu_ker,
         L.p.update_ker_pi _ _ hu_ker, hx u hu] },
  { intros u hu,
    rcases submodule.mem_span_singleton.mp hu with ⟨l, rfl⟩,
    rw [(D 𝓕'.f x).map_smul, (𝓕'.φ x).map_smul],
    apply congr_arg,
    dsimp [𝓕'],
    erw [fderiv_𝓕', L.p.update_v, continuous_linear_map.add_apply, L.p.update_v],
    refl }
end

lemma improve_step_formal_sol :
  ∀ᶠ N in at_top, ∀ t, (L.improve_step h N t).is_formal_sol R :=
begin
  set γ := L.loop h,
  have γ_cont : continuous ↿(λ t x, γ t x) := (L.nice h).smooth.continuous,
    have γ_C1 : 𝒞 1 ↿(γ 1) := ((L.nice h).smooth.comp (cont_diff_prod_mk_right 1)).of_le le_top,
  set K := (λ p : E × ℝ × ℝ, (p.1, 𝓕.f p.1, L.p.update (𝓕.φ p.1) (L.loop h p.2.1 p.1 p.2.2))) '' (L.K₁ ×ˢ (I ×ˢ I)),
  have K_cpt : is_compact K,
  { refine (L.hK₁.prod (is_compact_Icc.prod is_compact_Icc)).image _,
    refine continuous_fst.prod_mk (𝓕.f_diff.continuous.fst'.prod_mk _ ),
    apply L.p.continuous_update 𝓕.φ_diff.continuous.fst',
    change continuous (↿(L.loop h) ∘ (λ (g : E × ℝ × ℝ), (g.snd.fst, g.fst, g.snd.snd))),
    exact (L.loop_smooth h).continuous.comp₃ continuous_snd.fst continuous_fst continuous_snd.snd },
  have K_sub : K ⊆ R,
  { rintros _ ⟨⟨x, t, s⟩, ⟨x_in, t_in, s_in⟩, rfl⟩,
    exact (L.nice h).mem_Ω x t s },
  obtain ⟨ε, ε_pos, hε⟩ : ∃ ε, 0 < ε ∧ metric.thickening ε K ⊆ R,
    from  K_cpt.exists_thickening_subset_open h.h_op K_sub,

  apply ((corrugation.c0_small_on L.hK₁ (L.nice h).t_le_zero (L.nice h).t_ge_one γ_cont ε_pos).and $
         remainder_c0_small_on L.π L.hK₁ γ_C1 ε_pos).mono,
  rintros N ⟨H, H'⟩ t x,
  by_cases hxK₁ : x ∈ L.K₁,
  { apply hε,
    rw metric.mem_thickening_iff,
    refine ⟨(x, 𝓕.f x, L.p.update (𝓕.φ x) $ L.loop h (smooth_step t*L.ρ x) x $ N * L.π x), _, _⟩,
    { simp only [hxK₁, formal_sol.to_jet_sec_eq_coe, exists_prop, mem_set_of_eq, eq_self_iff_true, true_and, K],
      exact ⟨⟨x, smooth_step t * L.ρ x, int.fract (N * L.π x)⟩,
            ⟨hxK₁, unit_interval.mul_mem (smooth_step.mem t) (L.ρ_mem x),
              unit_interval.fract_mem _⟩, by simp only [loop.fract_eq]⟩ },
    { simp only [h, improve_step_apply_f, formal_sol.to_jet_sec_eq_coe, improve_step_apply_φ],
      rw [prod.dist_eq, max_lt_iff, prod.dist_eq, max_lt_iff],
      refine ⟨by simpa using ε_pos, _, _⟩ ; dsimp only ; rw dist_self_add_left,
      { exact (bu_lt _ _ $ H _ hxK₁ _) },
      { exact (bu_lt _ _ $ H' _ hxK₁) } } },
  { rw [show ((L.improve_step h N) t).f x = 𝓕.f x,
          from congr_arg prod.fst $ improve_step_rel_compl_K₁ h N hxK₁ t,
        show ((L.improve_step h N) t).φ x = 𝓕.φ x,
          from congr_arg prod.snd $ improve_step_rel_compl_K₁ h N hxK₁ t],
    exact 𝓕.is_sol _ }
end

end step_landscape

end improve_step

section improve
/-!
## Full improvement

This section proves lem:h_principle_open_ample_loc.
-/

open finite_dimensional submodule step_landscape

variables {E} [finite_dimensional ℝ E] [finite_dimensional ℝ F]
  {R : rel_loc E F} (h_op : is_open R) (h_ample : R.is_ample)
variables (L : landscape E)
variables {ε : ℝ} (ε_pos : 0 < ε)

include h_op h_ample ε_pos

/--
Homotopy of formal solutions obtained by successive corrugations in some landscape `L` to improve a
formal solution `𝓕` until it becomes holonomic near `L.K₀`.
-/
lemma rel_loc.formal_sol.improve (𝓕 : formal_sol R)
  (h_hol : ∀ᶠ x near L.C, 𝓕.is_holonomic_at x) :
  ∃ H : htpy_jet_sec E F,
    (∀ᶠ t near Iic 0, H t = 𝓕) ∧
    (∀ᶠ t near Ici 1, H t = H 1) ∧
    (∀ᶠ x near L.C, ∀ t, H t x = 𝓕 x ) ∧
    (∀ x, x ∉ L.K₁ → ∀ t, H t x = 𝓕 x) ∧
    (∀ x t, ‖(H t).f x - 𝓕.f x‖ ≤ ε) ∧
    (∀ t, (H t).is_formal_sol R) ∧
    (∀ᶠ x near L.K₀, (H 1).is_holonomic_at x) :=
begin
  let n := finrank ℝ E,
  let e := fin_basis ℝ E,
  let E' := e.flag,
  suffices : ∀ k : fin (n + 1), ∀ δ > (0 : ℝ), ∃ H : htpy_jet_sec E F,
    (∀ᶠ t near Iic 0, H t = 𝓕) ∧
    (∀ᶠ t near Ici 1, H t = H 1) ∧
    (∀ᶠ x near L.C, ∀ t, H t x = 𝓕 x ) ∧
    (∀ x, x ∉ L.K₁ → ∀ t, H t x = 𝓕 x) ∧
    (∀ x t, ‖(H t).f x - 𝓕.f x‖ ≤ δ) ∧
    (∀ t, (H t).is_formal_sol R) ∧
    (∀ᶠ x near L.K₀, (H 1).is_part_holonomic_at (E' k) x),
  { simpa only [show E' (fin.last n) = ⊤, from e.flag_last, jet_sec.is_part_holonomic_top] using
      this (fin.last n) ε ε_pos },
  clear ε_pos ε,
  intro k,
  apply fin.induction_on k ; clear k,
  { intros δ δ_pos,
    use 𝓕.to_jet_sec.const_htpy,
    simp [show E' 0 = ⊥, from e.flag_zero, le_of_lt δ_pos] },
  { rintros k HH δ δ_pos,
    rcases HH (δ/2) (half_pos δ_pos) with ⟨H, hH₀, hH₁, hHC, hHK₁, hHc0, hH_sol, hH_hol⟩, clear HH,
    let S : step_landscape E :=
    { E' := E' k,
      p := e.dual_pair k,
      hEp := by simpa only [E', basis.dual_pair] using e.flag_le_ker_dual k,
      ..L},
    set H₁ : formal_sol R := (hH_sol 1).formal_sol,
    have h_span : S.E' ⊔ S.p.span_v = E' k.succ := e.flag_span_succ k,
    have acc : S.accepts R H₁ :=
    { h_op := h_op,
      hK₀ := begin
        apply hH_hol.mono,
        intros x hx,
        dsimp [S],
        convert hx,
        rw [← fin.coe_eq_cast_succ, coe_coe]
      end,
      h_short := λ x, h_ample.is_short_at H₁ S.p x,
      hC := begin
        apply h_hol.congr (formal_sol.is_holonomic_at_congr _ _ _),
        apply hHC.mono,
        tauto,
      end  },
    have hH₁_rel_C : ∀ᶠ (x : E) near S.C, H₁ x = 𝓕 x,
    { apply hHC.mono,
      intros x hx,
      apply hx },
    have hH₁_C : ∀ᶠ (x : E) near S.to_landscape.C, H₁.is_holonomic_at x,
    { apply h_hol.congr (formal_sol.is_holonomic_at_congr _ _ _),
      exact (h_hol.and hH₁_rel_C).mono (λ x hx, hx.2.symm) },
    have hH₁_K₁ : ∀ x ∉ L.K₁, H₁ x = 𝓕 x,
    { intros x hx,
      apply hHK₁ x hx },
    obtain ⟨N, ⟨hN_close, hN_sol⟩, hNneq⟩ :=
      (((improve_step_c0_close acc $ half_pos δ_pos).and
      (improve_step_formal_sol acc)).and $ eventually_ne_at_top (0 :ℝ)).exists,
    have glue : H 1 = S.improve_step acc N 0,
    { rw improve_step_rel_t_eq_0,
      refl  },
    refine ⟨H.comp (S.improve_step acc N) glue, _, _, _, _, _, _, _⟩,
    { apply (H.comp_le_0 _ _).mono,
      intros t ht,
      rw ht,
      exact hH₀.on_set 0 right_mem_Iic }, -- t = 0
    { apply (H.comp_ge_1 _ _).mono,
      intros t ht,
      rw [ht, H.comp_1] },
    { -- rel C
      apply (hHC.and $ hH₁_rel_C.and $ improve_step_rel_C acc N).mono,
      rintros x ⟨hx, hx', hx''⟩ t,
      by_cases ht : t ≤ 1/2,
      { simp only [ht, hx, htpy_jet_sec.comp_of_le]},
      { simp only [ht, hx', hx'', htpy_jet_sec.comp_of_not_le, not_false_iff]} },
    { -- rel K₁
      intros x hx t,
      by_cases ht : t ≤ 1/2,
      { simp only [ht, hx, hHK₁, htpy_jet_sec.comp_of_le, not_false_iff]},
      { simp only [ht, hx, hH₁_K₁, improve_step_rel_compl_K₁, htpy_jet_sec.comp_of_not_le,
                   not_false_iff] } },
    { -- C⁰-close
      intros x t,
      by_cases ht : t ≤ 1/2,
      { apply le_trans _ (half_le_self $ le_of_lt δ_pos),
        simp only [ht, hHc0, htpy_jet_sec.comp_of_le]},
      { simp only [ht, htpy_jet_sec.comp_of_not_le, not_false_iff],
        rw ← add_halves δ,
        exact norm_sub_le_add_of_le (hN_close _ _) (hHc0 _ _) } },
    { -- formal solution
      intros t,
      by_cases ht : t ≤ 1/2,
      { simp only [ht, hH_sol, htpy_jet_sec.comp_of_le]},
      { simp only [ht, hN_sol, htpy_jet_sec.comp_of_not_le, not_false_iff] } },
    {  -- part-hol E' (k + 1)
      rw [← h_span, htpy_jet_sec.comp_1],
      apply improve_step_part_hol acc hNneq } }
end

/-- A repackaging of `rel_loc.formal_sol.improve` for convenience. -/
lemma rel_loc.formal_sol.improve_htpy' (𝓕 : formal_sol R)
  (h_hol : ∀ᶠ x near L.C, 𝓕.is_holonomic_at x) :
  ∃ H : htpy_formal_sol R,
    (∀ᶠ t near Iic 0, H t = 𝓕) ∧
    (∀ᶠ t near Ici 1, H t = H 1) ∧
    (∀ᶠ x near L.C, ∀ t, H t x = 𝓕 x ) ∧
    (∀ x, x ∉ L.K₁ → ∀ t, H t x = 𝓕 x) ∧
    (∀ x t, ‖(H t).f x - 𝓕.f x‖ < ε)  ∧
    (∀ᶠ x near L.K₀, (H 1).is_holonomic_at x) :=
begin
  rcases 𝓕.improve h_op h_ample L (half_pos ε_pos) h_hol with ⟨H, h₁, h₂, h₃, h₄, h₅, h₆, h₇⟩,
  exact ⟨{is_sol := h₆, ..H}, h₁, h₂, h₃, h₄, λ x t, (h₅ x t).trans_lt (half_lt_self ε_pos), h₇⟩
end

end improve