/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro, Sean Leather

Functions on lists of sigma types.
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.list.perm
import Mathlib.data.list.range
import Mathlib.data.sigma.default
import Mathlib.PostPort

universes u v u_1 u_2

namespace Mathlib

namespace list

/- keys -/

/-- List of keys from a list of key-value pairs -/
def keys {α : Type u} {β : α → Type v} : List (sigma β) → List α :=
  map sigma.fst

@[simp] theorem keys_nil {α : Type u} {β : α → Type v} : keys [] = [] :=
  rfl

@[simp] theorem keys_cons {α : Type u} {β : α → Type v} {s : sigma β} {l : List (sigma β)} : keys (s :: l) = sigma.fst s :: keys l :=
  rfl

theorem mem_keys_of_mem {α : Type u} {β : α → Type v} {s : sigma β} {l : List (sigma β)} : s ∈ l → sigma.fst s ∈ keys l :=
  mem_map_of_mem sigma.fst

theorem exists_of_mem_keys {α : Type u} {β : α → Type v} {a : α} {l : List (sigma β)} (h : a ∈ keys l) : ∃ (b : β a), sigma.mk a b ∈ l := sorry

theorem mem_keys {α : Type u} {β : α → Type v} {a : α} {l : List (sigma β)} : a ∈ keys l ↔ ∃ (b : β a), sigma.mk a b ∈ l := sorry

theorem not_mem_keys {α : Type u} {β : α → Type v} {a : α} {l : List (sigma β)} : ¬a ∈ keys l ↔ ∀ (b : β a), ¬sigma.mk a b ∈ l :=
  iff.trans (not_iff_not_of_iff mem_keys) not_exists

theorem not_eq_key {α : Type u} {β : α → Type v} {a : α} {l : List (sigma β)} : ¬a ∈ keys l ↔ ∀ (s : sigma β), s ∈ l → a ≠ sigma.fst s := sorry

/- nodupkeys -/

def nodupkeys {α : Type u} {β : α → Type v} (l : List (sigma β)) :=
  nodup (keys l)

theorem nodupkeys_iff_pairwise {α : Type u} {β : α → Type v} {l : List (sigma β)} : nodupkeys l ↔ pairwise (fun (s s' : sigma β) => sigma.fst s ≠ sigma.fst s') l :=
  pairwise_map sigma.fst

theorem nodupkeys.pairwise_ne {α : Type u} {β : α → Type v} {l : List (sigma β)} (h : nodupkeys l) : pairwise (fun (s s' : sigma β) => sigma.fst s ≠ sigma.fst s') l :=
  iff.mp nodupkeys_iff_pairwise h

@[simp] theorem nodupkeys_nil {α : Type u} {β : α → Type v} : nodupkeys [] :=
  pairwise.nil

@[simp] theorem nodupkeys_cons {α : Type u} {β : α → Type v} {s : sigma β} {l : List (sigma β)} : nodupkeys (s :: l) ↔ ¬sigma.fst s ∈ keys l ∧ nodupkeys l := sorry

theorem nodupkeys.eq_of_fst_eq {α : Type u} {β : α → Type v} {l : List (sigma β)} (nd : nodupkeys l) {s : sigma β} {s' : sigma β} (h : s ∈ l) (h' : s' ∈ l) : sigma.fst s = sigma.fst s' → s = s' := sorry

theorem nodupkeys.eq_of_mk_mem {α : Type u} {β : α → Type v} {a : α} {b : β a} {b' : β a} {l : List (sigma β)} (nd : nodupkeys l) (h : sigma.mk a b ∈ l) (h' : sigma.mk a b' ∈ l) : b = b' := sorry

theorem nodupkeys_singleton {α : Type u} {β : α → Type v} (s : sigma β) : nodupkeys [s] :=
  nodup_singleton (sigma.fst s)

theorem nodupkeys_of_sublist {α : Type u} {β : α → Type v} {l₁ : List (sigma β)} {l₂ : List (sigma β)} (h : l₁ <+ l₂) : nodupkeys l₂ → nodupkeys l₁ :=
  nodup_of_sublist (sublist.map sigma.fst h)

theorem nodup_of_nodupkeys {α : Type u} {β : α → Type v} {l : List (sigma β)} : nodupkeys l → nodup l :=
  nodup_of_nodup_map sigma.fst

theorem perm_nodupkeys {α : Type u} {β : α → Type v} {l₁ : List (sigma β)} {l₂ : List (sigma β)} (h : l₁ ~ l₂) : nodupkeys l₁ ↔ nodupkeys l₂ :=
  perm.nodup_iff (perm.map sigma.fst h)

theorem nodupkeys_join {α : Type u} {β : α → Type v} {L : List (List (sigma β))} : nodupkeys (join L) ↔ (∀ (l : List (sigma β)), l ∈ L → nodupkeys l) ∧ pairwise disjoint (map keys L) := sorry

theorem nodup_enum_map_fst {α : Type u} (l : List α) : nodup (map prod.fst (enum l)) := sorry

theorem mem_ext {α : Type u} {β : α → Type v} {l₀ : List (sigma β)} {l₁ : List (sigma β)} (nd₀ : nodup l₀) (nd₁ : nodup l₁) (h : ∀ (x : sigma β), x ∈ l₀ ↔ x ∈ l₁) : l₀ ~ l₁ := sorry

/- lookup -/

/-- `lookup a l` is the first value in `l` corresponding to the key `a`,
  or `none` if no such element exists. -/
def lookup {α : Type u} {β : α → Type v} [DecidableEq α] (a : α) : List (sigma β) → Option (β a) :=
  sorry

@[simp] theorem lookup_nil {α : Type u} {β : α → Type v} [DecidableEq α] (a : α) : lookup a [] = none :=
  rfl

@[simp] theorem lookup_cons_eq {α : Type u} {β : α → Type v} [DecidableEq α] (l : List (sigma fun (a : α) => β a)) (a : α) (b : β a) : lookup a (sigma.mk a b :: l) = some b :=
  dif_pos rfl

@[simp] theorem lookup_cons_ne {α : Type u} {β : α → Type v} [DecidableEq α] (l : List (sigma β)) {a : α} (s : sigma β) : a ≠ sigma.fst s → lookup a (s :: l) = lookup a l := sorry

theorem lookup_is_some {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} {l : List (sigma β)} : ↥(option.is_some (lookup a l)) ↔ a ∈ keys l := sorry

theorem lookup_eq_none {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} {l : List (sigma β)} : lookup a l = none ↔ ¬a ∈ keys l := sorry

theorem of_mem_lookup {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} {b : β a} {l : List (sigma β)} : b ∈ lookup a l → sigma.mk a b ∈ l := sorry

theorem mem_lookup {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} {b : β a} {l : List (sigma β)} (nd : nodupkeys l) (h : sigma.mk a b ∈ l) : b ∈ lookup a l := sorry

theorem map_lookup_eq_find {α : Type u} {β : α → Type v} [DecidableEq α] (a : α) (l : List (sigma β)) : option.map (sigma.mk a) (lookup a l) = find (fun (s : sigma β) => a = sigma.fst s) l := sorry

theorem mem_lookup_iff {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} {b : β a} {l : List (sigma β)} (nd : nodupkeys l) : b ∈ lookup a l ↔ sigma.mk a b ∈ l :=
  { mp := of_mem_lookup, mpr := mem_lookup nd }

theorem perm_lookup {α : Type u} {β : α → Type v} [DecidableEq α] (a : α) {l₁ : List (sigma β)} {l₂ : List (sigma β)} (nd₁ : nodupkeys l₁) (nd₂ : nodupkeys l₂) (p : l₁ ~ l₂) : lookup a l₁ = lookup a l₂ := sorry

theorem lookup_ext {α : Type u} {β : α → Type v} [DecidableEq α] {l₀ : List (sigma β)} {l₁ : List (sigma β)} (nd₀ : nodupkeys l₀) (nd₁ : nodupkeys l₁) (h : ∀ (x : α) (y : β x), y ∈ lookup x l₀ ↔ y ∈ lookup x l₁) : l₀ ~ l₁ := sorry

/- lookup_all -/

/-- `lookup_all a l` is the list of all values in `l` corresponding to the key `a`. -/
def lookup_all {α : Type u} {β : α → Type v} [DecidableEq α] (a : α) : List (sigma β) → List (β a) :=
  sorry

@[simp] theorem lookup_all_nil {α : Type u} {β : α → Type v} [DecidableEq α] (a : α) : lookup_all a [] = [] :=
  rfl

@[simp] theorem lookup_all_cons_eq {α : Type u} {β : α → Type v} [DecidableEq α] (l : List (sigma fun (a : α) => β a)) (a : α) (b : β a) : lookup_all a (sigma.mk a b :: l) = b :: lookup_all a l :=
  dif_pos rfl

@[simp] theorem lookup_all_cons_ne {α : Type u} {β : α → Type v} [DecidableEq α] (l : List (sigma β)) {a : α} (s : sigma β) : a ≠ sigma.fst s → lookup_all a (s :: l) = lookup_all a l := sorry

theorem lookup_all_eq_nil {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} {l : List (sigma β)} : lookup_all a l = [] ↔ ∀ (b : β a), ¬sigma.mk a b ∈ l := sorry

theorem head_lookup_all {α : Type u} {β : α → Type v} [DecidableEq α] (a : α) (l : List (sigma β)) : head' (lookup_all a l) = lookup a l := sorry

theorem mem_lookup_all {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} {b : β a} {l : List (sigma β)} : b ∈ lookup_all a l ↔ sigma.mk a b ∈ l := sorry

theorem lookup_all_sublist {α : Type u} {β : α → Type v} [DecidableEq α] (a : α) (l : List (sigma β)) : map (sigma.mk a) (lookup_all a l) <+ l := sorry

theorem lookup_all_length_le_one {α : Type u} {β : α → Type v} [DecidableEq α] (a : α) {l : List (sigma β)} (h : nodupkeys l) : length (lookup_all a l) ≤ 1 := sorry

theorem lookup_all_eq_lookup {α : Type u} {β : α → Type v} [DecidableEq α] (a : α) {l : List (sigma β)} (h : nodupkeys l) : lookup_all a l = option.to_list (lookup a l) := sorry

theorem lookup_all_nodup {α : Type u} {β : α → Type v} [DecidableEq α] (a : α) {l : List (sigma β)} (h : nodupkeys l) : nodup (lookup_all a l) :=
  eq.mpr (id (Eq._oldrec (Eq.refl (nodup (lookup_all a l))) (lookup_all_eq_lookup a h)))
    (option.to_list_nodup (lookup a l))

theorem perm_lookup_all {α : Type u} {β : α → Type v} [DecidableEq α] (a : α) {l₁ : List (sigma β)} {l₂ : List (sigma β)} (nd₁ : nodupkeys l₁) (nd₂ : nodupkeys l₂) (p : l₁ ~ l₂) : lookup_all a l₁ = lookup_all a l₂ := sorry

/- kreplace -/

def kreplace {α : Type u} {β : α → Type v} [DecidableEq α] (a : α) (b : β a) : List (sigma β) → List (sigma β) :=
  lookmap
    fun (s : sigma β) =>
      dite (a = sigma.fst s) (fun (h : a = sigma.fst s) => some (sigma.mk a b)) fun (h : ¬a = sigma.fst s) => none

theorem kreplace_of_forall_not {α : Type u} {β : α → Type v} [DecidableEq α] (a : α) (b : β a) {l : List (sigma β)} (H : ∀ (b : β a), ¬sigma.mk a b ∈ l) : kreplace a b l = l := sorry

theorem kreplace_self {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} {b : β a} {l : List (sigma β)} (nd : nodupkeys l) (h : sigma.mk a b ∈ l) : kreplace a b l = l := sorry

theorem keys_kreplace {α : Type u} {β : α → Type v} [DecidableEq α] (a : α) (b : β a) (l : List (sigma β)) : keys (kreplace a b l) = keys l := sorry

theorem kreplace_nodupkeys {α : Type u} {β : α → Type v} [DecidableEq α] (a : α) (b : β a) {l : List (sigma β)} : nodupkeys (kreplace a b l) ↔ nodupkeys l := sorry

theorem perm.kreplace {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} {b : β a} {l₁ : List (sigma β)} {l₂ : List (sigma β)} (nd : nodupkeys l₁) : l₁ ~ l₂ → kreplace a b l₁ ~ kreplace a b l₂ := sorry

/- kerase -/

/-- Remove the first pair with the key `a`. -/
def kerase {α : Type u} {β : α → Type v} [DecidableEq α] (a : α) : List (sigma β) → List (sigma β) :=
  erasep fun (s : sigma β) => a = sigma.fst s

@[simp] theorem kerase_nil {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} : kerase a [] = [] :=
  rfl

@[simp] theorem kerase_cons_eq {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} {s : sigma β} {l : List (sigma β)} (h : a = sigma.fst s) : kerase a (s :: l) = l := sorry

@[simp] theorem kerase_cons_ne {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} {s : sigma β} {l : List (sigma β)} (h : a ≠ sigma.fst s) : kerase a (s :: l) = s :: kerase a l := sorry

@[simp] theorem kerase_of_not_mem_keys {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} {l : List (sigma β)} (h : ¬a ∈ keys l) : kerase a l = l := sorry

theorem kerase_sublist {α : Type u} {β : α → Type v} [DecidableEq α] (a : α) (l : List (sigma β)) : kerase a l <+ l :=
  erasep_sublist l

theorem kerase_keys_subset {α : Type u} {β : α → Type v} [DecidableEq α] (a : α) (l : List (sigma β)) : keys (kerase a l) ⊆ keys l :=
  sublist.subset (sublist.map sigma.fst (kerase_sublist a l))

theorem mem_keys_of_mem_keys_kerase {α : Type u} {β : α → Type v} [DecidableEq α] {a₁ : α} {a₂ : α} {l : List (sigma β)} : a₁ ∈ keys (kerase a₂ l) → a₁ ∈ keys l :=
  kerase_keys_subset a₂ l

theorem exists_of_kerase {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} {l : List (sigma β)} (h : a ∈ keys l) : ∃ (b : β a),
  ∃ (l₁ : List (sigma β)), ∃ (l₂ : List (sigma β)), ¬a ∈ keys l₁ ∧ l = l₁ ++ sigma.mk a b :: l₂ ∧ kerase a l = l₁ ++ l₂ := sorry

@[simp] theorem mem_keys_kerase_of_ne {α : Type u} {β : α → Type v} [DecidableEq α] {a₁ : α} {a₂ : α} {l : List (sigma β)} (h : a₁ ≠ a₂) : a₁ ∈ keys (kerase a₂ l) ↔ a₁ ∈ keys l := sorry

theorem keys_kerase {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} {l : List (sigma β)} : keys (kerase a l) = list.erase (keys l) a := sorry

theorem kerase_kerase {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} {a' : α} {l : List (sigma β)} : kerase a (kerase a' l) = kerase a' (kerase a l) := sorry

theorem kerase_nodupkeys {α : Type u} {β : α → Type v} [DecidableEq α] (a : α) {l : List (sigma β)} : nodupkeys l → nodupkeys (kerase a l) :=
  nodupkeys_of_sublist (kerase_sublist a l)

theorem perm.kerase {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} {l₁ : List (sigma β)} {l₂ : List (sigma β)} (nd : nodupkeys l₁) : l₁ ~ l₂ → kerase a l₁ ~ kerase a l₂ :=
  perm.erasep (fun (s : sigma β) => a = sigma.fst s)
    (pairwise.imp (fun (x y : sigma β) (h : sigma.fst x ≠ sigma.fst y) (ᾰ : a = sigma.fst x) => Eq._oldrec h (Eq.symm ᾰ))
      (iff.mp nodupkeys_iff_pairwise nd))

@[simp] theorem not_mem_keys_kerase {α : Type u} {β : α → Type v} [DecidableEq α] (a : α) {l : List (sigma β)} (nd : nodupkeys l) : ¬a ∈ keys (kerase a l) := sorry

@[simp] theorem lookup_kerase {α : Type u} {β : α → Type v} [DecidableEq α] (a : α) {l : List (sigma β)} (nd : nodupkeys l) : lookup a (kerase a l) = none :=
  iff.mpr lookup_eq_none (not_mem_keys_kerase a nd)

@[simp] theorem lookup_kerase_ne {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} {a' : α} {l : List (sigma β)} (h : a ≠ a') : lookup a (kerase a' l) = lookup a l := sorry

theorem kerase_append_left {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} {l₁ : List (sigma β)} {l₂ : List (sigma β)} : a ∈ keys l₁ → kerase a (l₁ ++ l₂) = kerase a l₁ ++ l₂ := sorry

theorem kerase_append_right {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} {l₁ : List (sigma β)} {l₂ : List (sigma β)} : ¬a ∈ keys l₁ → kerase a (l₁ ++ l₂) = l₁ ++ kerase a l₂ := sorry

theorem kerase_comm {α : Type u} {β : α → Type v} [DecidableEq α] (a₁ : α) (a₂ : α) (l : List (sigma β)) : kerase a₂ (kerase a₁ l) = kerase a₁ (kerase a₂ l) := sorry

theorem sizeof_kerase {α : Type u_1} {β : α → Type u_2} [DecidableEq α] [SizeOf (sigma β)] (x : α) (xs : List (sigma β)) : sizeof (kerase x xs) ≤ sizeof xs := sorry

/- kinsert -/

/-- Insert the pair `⟨a, b⟩` and erase the first pair with the key `a`. -/
def kinsert {α : Type u} {β : α → Type v} [DecidableEq α] (a : α) (b : β a) (l : List (sigma β)) : List (sigma β) :=
  sigma.mk a b :: kerase a l

@[simp] theorem kinsert_def {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} {b : β a} {l : List (sigma β)} : kinsert a b l = sigma.mk a b :: kerase a l :=
  rfl

theorem mem_keys_kinsert {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} {a' : α} {b' : β a'} {l : List (sigma β)} : a ∈ keys (kinsert a' b' l) ↔ a = a' ∨ a ∈ keys l := sorry

theorem kinsert_nodupkeys {α : Type u} {β : α → Type v} [DecidableEq α] (a : α) (b : β a) {l : List (sigma β)} (nd : nodupkeys l) : nodupkeys (kinsert a b l) :=
  iff.mpr nodupkeys_cons { left := not_mem_keys_kerase a nd, right := kerase_nodupkeys a nd }

theorem perm.kinsert {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} {b : β a} {l₁ : List (sigma β)} {l₂ : List (sigma β)} (nd₁ : nodupkeys l₁) (p : l₁ ~ l₂) : kinsert a b l₁ ~ kinsert a b l₂ :=
  perm.cons (sigma.mk a b) (perm.kerase nd₁ p)

theorem lookup_kinsert {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} {b : β a} (l : List (sigma β)) : lookup a (kinsert a b l) = some b := sorry

theorem lookup_kinsert_ne {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} {a' : α} {b' : β a'} {l : List (sigma β)} (h : a ≠ a') : lookup a (kinsert a' b' l) = lookup a l := sorry

/- kextract -/

def kextract {α : Type u} {β : α → Type v} [DecidableEq α] (a : α) : List (sigma β) → Option (β a) × List (sigma β) :=
  sorry

@[simp] theorem kextract_eq_lookup_kerase {α : Type u} {β : α → Type v} [DecidableEq α] (a : α) (l : List (sigma β)) : kextract a l = (lookup a l, kerase a l) := sorry

/- erase_dupkeys -/

/-- Remove entries with duplicate keys from `l : list (sigma β)`. -/
def erase_dupkeys {α : Type u} {β : α → Type v} [DecidableEq α] : List (sigma β) → List (sigma β) :=
  foldr (fun (x : sigma β) => kinsert (sigma.fst x) (sigma.snd x)) []

theorem erase_dupkeys_cons {α : Type u} {β : α → Type v} [DecidableEq α] {x : sigma β} (l : List (sigma β)) : erase_dupkeys (x :: l) = kinsert (sigma.fst x) (sigma.snd x) (erase_dupkeys l) :=
  rfl

theorem nodupkeys_erase_dupkeys {α : Type u} {β : α → Type v} [DecidableEq α] (l : List (sigma β)) : nodupkeys (erase_dupkeys l) := sorry

theorem lookup_erase_dupkeys {α : Type u} {β : α → Type v} [DecidableEq α] (a : α) (l : List (sigma β)) : lookup a (erase_dupkeys l) = lookup a l := sorry

theorem sizeof_erase_dupkeys {α : Type u_1} {β : α → Type u_2} [DecidableEq α] [SizeOf (sigma β)] (xs : List (sigma β)) : sizeof (erase_dupkeys xs) ≤ sizeof xs := sorry

/- kunion -/

/-- `kunion l₁ l₂` is the append to l₁ of l₂ after, for each key in l₁, the
first matching pair in l₂ is erased. -/
def kunion {α : Type u} {β : α → Type v} [DecidableEq α] : List (sigma β) → List (sigma β) → List (sigma β) :=
  sorry

@[simp] theorem nil_kunion {α : Type u} {β : α → Type v} [DecidableEq α] {l : List (sigma β)} : kunion [] l = l :=
  rfl

@[simp] theorem kunion_nil {α : Type u} {β : α → Type v} [DecidableEq α] {l : List (sigma β)} : kunion l [] = l := sorry

@[simp] theorem kunion_cons {α : Type u} {β : α → Type v} [DecidableEq α] {s : sigma β} {l₁ : List (sigma β)} {l₂ : List (sigma β)} : kunion (s :: l₁) l₂ = s :: kunion l₁ (kerase (sigma.fst s) l₂) :=
  rfl

@[simp] theorem mem_keys_kunion {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} {l₁ : List (sigma β)} {l₂ : List (sigma β)} : a ∈ keys (kunion l₁ l₂) ↔ a ∈ keys l₁ ∨ a ∈ keys l₂ := sorry

@[simp] theorem kunion_kerase {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} {l₁ : List (sigma β)} {l₂ : List (sigma β)} : kunion (kerase a l₁) (kerase a l₂) = kerase a (kunion l₁ l₂) := sorry

theorem kunion_nodupkeys {α : Type u} {β : α → Type v} [DecidableEq α] {l₁ : List (sigma β)} {l₂ : List (sigma β)} (nd₁ : nodupkeys l₁) (nd₂ : nodupkeys l₂) : nodupkeys (kunion l₁ l₂) := sorry

theorem perm.kunion_right {α : Type u} {β : α → Type v} [DecidableEq α] {l₁ : List (sigma β)} {l₂ : List (sigma β)} (p : l₁ ~ l₂) (l : List (sigma β)) : kunion l₁ l ~ kunion l₂ l := sorry

theorem perm.kunion_left {α : Type u} {β : α → Type v} [DecidableEq α] (l : List (sigma β)) {l₁ : List (sigma β)} {l₂ : List (sigma β)} : nodupkeys l₁ → l₁ ~ l₂ → kunion l l₁ ~ kunion l l₂ := sorry

theorem perm.kunion {α : Type u} {β : α → Type v} [DecidableEq α] {l₁ : List (sigma β)} {l₂ : List (sigma β)} {l₃ : List (sigma β)} {l₄ : List (sigma β)} (nd₃ : nodupkeys l₃) (p₁₂ : l₁ ~ l₂) (p₃₄ : l₃ ~ l₄) : kunion l₁ l₃ ~ kunion l₂ l₄ :=
  perm.trans (perm.kunion_right p₁₂ l₃) (perm.kunion_left l₂ nd₃ p₃₄)

@[simp] theorem lookup_kunion_left {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} {l₁ : List (sigma β)} {l₂ : List (sigma β)} (h : a ∈ keys l₁) : lookup a (kunion l₁ l₂) = lookup a l₁ := sorry

@[simp] theorem lookup_kunion_right {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} {l₁ : List (sigma β)} {l₂ : List (sigma β)} (h : ¬a ∈ keys l₁) : lookup a (kunion l₁ l₂) = lookup a l₂ := sorry

@[simp] theorem mem_lookup_kunion {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} {b : β a} {l₁ : List (sigma β)} {l₂ : List (sigma β)} : b ∈ lookup a (kunion l₁ l₂) ↔ b ∈ lookup a l₁ ∨ ¬a ∈ keys l₁ ∧ b ∈ lookup a l₂ := sorry

theorem mem_lookup_kunion_middle {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} {b : β a} {l₁ : List (sigma β)} {l₂ : List (sigma β)} {l₃ : List (sigma β)} (h₁ : b ∈ lookup a (kunion l₁ l₃)) (h₂ : ¬a ∈ keys l₂) : b ∈ lookup a (kunion (kunion l₁ l₂) l₃) := sorry


import parlang
import parlang_nonmono

namespace parlang
namespace ac_loop

open parlang
open parlang.kernel
open parlang_nonmono

variables {n : ℕ} {σ : Type} {ι : Type} {τ : ι → Type} {s t u : state n σ τ} {ac : vector bool n} {f f' : σ → bool}  [decidable_eq ι] {semantics : kernel σ τ → vector bool n → state n σ τ → state n σ τ → Prop}

class has_unique (semantics : kernel σ τ → vector bool n → state n σ τ → state n σ τ → Prop) :=
(unique : ∀ {k : kernel σ τ} {ac : vector bool n} {s t t' : state n σ τ}, semantics k ac s t → semantics k ac s t' → t = t')

variables [has_unique semantics]

instance unique2 : has_unique $ @parlang.exec_state σ ι τ _ n := ⟨begin
    intros _ _ _ _ _ a b,
    apply parlang.exec_state_unique b a,
end⟩

instance unique1 : has_unique $ @exec_state σ ι τ _ n := sorry

notation `v[` v:(foldr `, ` (h t, vector.cons h t) vector.nil `]`) := v

-- this is similar to the semantic itself except we are not interested in states but the resulting active maps
inductive ac_after_n_iteration (semantics : kernel σ τ → vector bool n → state n σ τ → state n σ τ → Prop) (k : kernel σ τ) (f : σ → bool) : state n σ τ → vector bool n → vector bool n → ℕ → Prop
| base (ac : vector bool n) (s : state n σ τ) : ac_after_n_iteration s ac ac 0
| step {ac : vector bool n} (s t : state n σ τ) {i : ℕ} {ac' : vector bool n} : ac_after_n_iteration t (deactivate_threads (bnot ∘ f) ac s) ac' i → semantics k (deactivate_threads (bnot ∘ f) ac s) s t → ac_after_n_iteration s ac ac' (i + 1)

example : ac_after_n_iteration exec_state (compute (λ (m : bool), ff)) id (@parlang.init_state bool string (λs, ℕ) _ (λ_, tt) (λ_,1) (λs:string, 0)) v[tt] v[tt] 1 := begin
    apply ac_after_n_iteration.step _ (@parlang.init_state bool string (λs, ℕ) _ (λ_, ff) (λ_,1) (λs:string, 0)),
    swap,
    sorry,
    sorry,
end

lemma ac_after_n_iteration_unique {k : kernel σ τ} {f : σ → bool} {ac' ac'' : vector bool n} {i} :
ac_after_n_iteration semantics k f s ac ac' i → ac_after_n_iteration semantics k f s ac ac'' i → ac' = ac'' := begin
    admit,
end

lemma ac_ge_single {k : kernel σ τ} {f : σ → bool} {ac' : vector bool n} {i : ℕ} : ac_after_n_iteration semantics k f s ac ac' i → ac ≥ ac' := begin
    intros h,
    induction i generalizing s ac ac',
    case nat.zero {
        cases h,
        intros t hna,
        assumption,
    },
    case nat.succ {
        cases h,
        specialize i_ih h_a,
        have : ac ≥ (deactivate_threads (bnot ∘ f) ac s) := by apply ac_sub_deac,
        sorry, -- proof by transitivity
    }
end

lemma ac_ge_two {k : kernel σ τ} {f : σ → bool} {i i' : ℕ} {ac' ac'' : vector bool n} :
ac_after_n_iteration semantics k f s ac ac' i → ac_after_n_iteration semantics k f s ac ac'' (i + i') → ac' ≥ ac'' := begin
    intros h₁ h₂,
    induction i generalizing s ac,
    case nat.zero {
        cases h₁,
        apply ac_ge_single h₂,
    },
    case nat.succ {
        cases h₁,
        have : nat.succ i_n + i' = nat.succ (i_n + i') := by rw nat.succ_add,
        rw this at h₂,
        cases h₂,
        have : h₁_t = h₂_t := has_unique.unique _ _ _ h₁_a_1 h₂_a_1,
        subst this,
        apply i_ih h₁_a h₂_a,
    }
end

def monotone_loop (semantics : kernel σ τ → vector bool n → state n σ τ → state n σ τ → Prop) (f k) (s : state n σ τ) (ac : vector bool n) : Prop :=
∀ (i i' : ℕ) (ac' ac'' : vector bool n), ac_after_n_iteration semantics k f s ac ac' i → ac_after_n_iteration semantics k f s ac ac'' (i + i') → ac' ≥ ac''

lemma par_loop_ac' {k : kernel σ τ} : parlang.exec_state (loop f k) ac s t → ∃ i ac', ac_after_n_iteration parlang.exec_state k f s ac ac' i ∧ no_thread_active (deactivate_threads (bnot ∘ f) ac' t) := begin
    generalize eq_l : (loop f k) = l,
    intro h,
    induction h;
        cases eq_l,
    {
        use 0,
        use h_ac,
        split,
        apply ac_after_n_iteration.base,
        assumption,
    }, {
        clear h_ih_a,
        specialize h_ih_a_1 rfl,
        cases h_ih_a_1 with i ih,
        cases ih with ac' ih,
        cases ih with ha hb,
        use i + 1,
        use ac',
        split,
        swap,
        assumption,
        apply ac_after_n_iteration.step,
        repeat { assumption },
    }
end

lemma loop_ac' {k : kernel σ τ} : exec_state (loop f k) ac s t → ∃ i ac', ac_after_n_iteration exec_state k f s ac ac' i ∧ no_thread_active (deactivate_threads (bnot ∘ f) ac' t) := begin
    generalize eq_l : (loop f k) = l,
    intro h,
    induction h generalizing;
        cases eq_l,
    {
        use 0,
        use h_ac,
        split,
        apply ac_after_n_iteration.base,
        assumption,
    }, {
        clear h_ih_a,
        specialize h_ih_a_1 rfl,
        cases h_ih_a_1 with i ih,
        cases ih with ac' ih,
        cases ih with ha hb,
        use i + 1,
        use ac',
        split,
        swap,
        assumption,
        {
            apply ac_after_n_iteration.step,
            swap,
            exact h_a_1,
            induction ha,
            case ac_after_n_iteration.base {
                have : monotone_loop exec_state f k h_s ha_ac := by apply ac_ge_two,
                have : monotone_loop exec_state f k h_s ha_ac := by apply ac_ge_two,
            }
        }
    }
end

end ac_loop
end parlang


import pq_induction_principles
import minimal_sub_pq_gen_group

universe u

section pq_like_eq_equalizer

variables {G : Type u} [group G] --[inhabited Q]

lemma prod_in_free_gen_list (gen : set G) (x : list (free_gen_group_sub_pq gen)) (hx : of ((x.map of).prod) = (x.map (of ∘ of)).prod) : (x.map coe).prod ∈ (free_gen_group_sub_pq gen : set G) :=
begin
  induction x with g x hx,
  {
    simp only [list.prod_nil, list.map],
    sorry,
  },
  {
    simp only [list.prod_cons, list.map],
    simp only [function.comp_app, list.prod_cons, list.map] at hx,
    have hx1 := congr_arg (L_of_morph (gen_set_counit gen) (functoriality_group_to_pq (gen_set_counit gen))) hx,
    simp only [monoid_hom.map_mul, L_of_morph_of, gen_set_counit_of] at hx1,
    sorry,
  },
end

theorem eta_eq_L_eta (gen : set G) (x : pq_group (free_gen_group_sub_pq gen)) : (of x = L_of_morph of of_is_pq_morphism x) ↔ (∃ y, x = of y) :=
begin
  split,
  swap,
  {
    intro hx,
    cases hx with y hy,
    rw hy,
    simp only [L_of_morph_of],
  },
  {
    revert x,
    refine pq_group_list _,
    intros x hx,
    fconstructor,
    fconstructor,
    use (x.map (λ x, ↑x)).prod,
    {
      simp only,
      induction x,
      {
        simp only [list.prod_nil, list.map],
        sorry,
      },
      have hx1 := congr_arg (L_of_morph (gen_set_counit gen) (functoriality_group_to_pq (gen_set_counit gen))) hx,
      simp only [monoid_hom.map_mul, list.prod_cons, list.map, L_of_morph_of, gen_set_counit_of] at hx1,
      simp only [list.prod_cons, list.map],
      sorry,
    },
    {
      sorry,
    },
    /-
    refine pq_group_word_induction _ _,
    {
      intro h1,
      clear h1,
      use (arbitrary Q)^(0 : ℤ),
      simp only [of_pow_eq_pow_of, gpow_zero],
    },
    {
      intros x z hx hxz,
      sorry,
    },
    -/
  },
end

end pq_like_eq_equalizer


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Gabriel Ebner, Scott Morrison
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.tactic.core
import Mathlib.PostPort

namespace Mathlib

/-!
# simp_result

`dsimp_result` and `simp_result` are a pair of tactics for
applying `dsimp` or `simp` to the result produced by other tactics.

As examples, tactics which use `revert` and `intro`
may insert additional `id` terms in the result they produce.
If there is some reason these are undesirable
(e.g. the result term needs to be human-readable, or
satisfying syntactic rather than just definitional properties),
wrapping those tactics in `dsimp_result`
can remove the `id` terms "after the fact".

Similarly, tactics using `subst` and `rw` will nearly always introduce `eq.rec` terms,
but sometimes these will be easy to remove,
for example by simplifying using `eq_rec_constant`.
This is a non-definitional simplification lemma,
and so wrapping these tactics in `simp_result` will result
in a definitionally different result.

There are several examples in the associated test file,
demonstrating these interactions with `revert` and `subst`.

These tactics should be used with some caution.
You should consider whether there is any real need for the simplification of the result,
and whether there is a more direct way of producing the result you wanted,
before relying on these tactics.

Both are implemented in terms of a generic `intercept_result` tactic,
which allows you to run an arbitrary tactic and modify the returned results.
-/

namespace tactic

/--
`intercept_result m t`
attempts to run a tactic `t`,
intercepts any results `t` assigns to the goals,
and runs `m : expr → tactic expr` on each of the expressions
before assigning the returned values to the original goals.

Because `intercept_result` uses `unsafe.type_context.assign` rather than `unify`,
if the tactic `m` does something unreasonable
you may produce terms that don't typecheck,
possibly with mysterious error messages.
Be careful!
-/
-- Replace the goals with copies.

-- Run the tactic on the copied goals.

-- Run `m` on the produced terms,

/--
`dsimp_result t`
attempts to run a tactic `t`,
intercepts any results it assigns to the goals,
and runs `dsimp` on those results
before assigning the simplified values to the original goals.
-/
/--
`simp_result t`
attempts to run a tactic `t`,
intercepts any results `t` assigns to the goals,
and runs `simp` on those results
before assigning the simplified values to the original goals.
-/
namespace interactive

/--
`dsimp_result { tac }`
attempts to run a tactic block `tac`,
intercepts any results the tactic block would have assigned to the goals,
and runs `dsimp` on those results
before assigning the simplified values to the original goals.

You can use the usual interactive syntax for `dsimp`, e.g.
`dsimp_result only [a, b, c] with attr { tac }`.
-/
/--
`simp_result { tac }`
attempts to run a tactic block `tac`,
intercepts any results the tactic block would have assigned to the goals,
and runs `simp` on those results
before assigning the simplified values to the original goals.

You can use the usual interactive syntax for `simp`, e.g.
`simp_result only [a, b, c] with attr { tac }`.
-/
/--
`simp_result { tac }`


import tactic.interactive
import algebra.group.basic

/-!
`refine_struct` caused a variety of interesting problems,
which were identified in
https://github.com/leanprover-community/mathlib/pull/2251
and
https://leanprover.zulipchat.com/#narrow/stream/113488-general/topic/Need.20help.20with.20class.20instance.20resolution

These tests are quite specific to testing the patch made in
https://github.com/leanprover-community/mathlib/pull/2319
and are not a complete test suite for `refine_struct`.
-/

instance pi_has_one {α : Type*} {β : α → Type*} [Π x, has_one (β x)] : has_one (Π x, β x) :=
by refine_struct { .. }; exact λ _, 1

open tactic

run_cmd (do
  (declaration.defn _ _ _ b _ _) ← get_decl ``pi_has_one,
  -- Make sure that `eq.mpr` really doesn't occur in the body:
  when (b.list_constant.contains ``eq.mpr) $
    fail "result generated by `refine_struct` contained an unnecessary `eq.mpr`",
  -- Make sure that `id` really doesn't occur in the body:
  when (b.list_constant.contains ``id) $
    fail "result generated by `refine_struct` contained an unnecessary `id`")

-- Next we check that fields defined for embedded structures are unfolded
-- when seen by fields in the outer structure.
structure foo (α : Type):=
(a : α)

structure bar (α : Type) extends foo α :=
(b : a = a)

example : bar ℕ :=
begin
  refine_struct { a := 1, .. },
  -- We're making sure that the goal is
  -- ⊢ 1 = 1
  -- rather than
  -- ⊢ {a := 1}.a = {a := 1}.a
  guard_target 1 = 1,
  trivial
end

section
variables {α : Type} [_inst : monoid α]
include _inst

example : true :=
begin
  have : group α,
  { refine_struct { .._inst },
    guard_tags _field inv group, admit,
    guard_tags _field div group, admit,
    guard_tags _field div_eq_mul_inv group, admit,
    guard_tags _field gpow group, admit,
    guard_tags _field gpow_zero' group, admit,
    guard_tags _field gpow_succ' group, admit,
    guard_tags _field gpow_neg' group, admit,
    guard_tags _field mul_left_inv group, admit, },
  trivial
end
end

def my_foo {α} (x : semigroup α) (y : group α) : true := trivial

example {α : Type} : true :=
begin
  have : true,
  { refine_struct (@my_foo α { .. } { .. } ),
      -- 18 goals
    guard_tags _field mul semigroup, admit,
      -- case semigroup, mul
      -- α : Type
      -- ⊢ α → α → α

    guard_tags _field mul_assoc semigroup, admit,
      -- case semigroup, mul_assoc
      -- α : Type
      -- ⊢ ∀ (a b c : α), a * b * c = a * (b * c)

    guard_tags _field mul group, admit,
      -- case group, mul
      -- α : Type
      -- ⊢ α → α → α

    guard_tags _field mul_assoc group, admit,
      -- case group, mul_assoc
      -- α : Type
      -- ⊢ ∀ (a b c : α), a * b * c = a * (b * c)

    guard_tags _field one group, admit,
      -- case group, one
      -- α : Type
      -- ⊢ α

    guard_tags _field one_mul group, admit,
      -- case group, one_mul
      -- α : Type
      -- ⊢ ∀ (a : α), 1 * a = a

    guard_tags _field mul_one group, admit,
      -- case group, mul_one
      -- α : Type
      -- ⊢ ∀ (a : α), a * 1 = a

    guard_tags _field npow group, admit,
      -- case group, npow
      -- α : Type
      -- ⊢ ℕ → α → α

    guard_tags _field npow_zero' group, admit,
      -- case group, inv
      -- α : Type
      -- ⊢ ∀ (x : α), sorry 0 x = 1

    guard_tags _field npow_succ' group, admit,
      -- case group, npow_succ'
      -- α : Type
      -- ⊢ ∀ (n : ℕ) (x : α), sorry n.succ x = x * sorry n x

    guard_tags _field inv group, admit,
      -- case group, inv
      -- α : Type
      -- ⊢ α → α

    guard_tags _field div group, admit,
      -- case group, div
      -- α : Type
      -- ⊢ α → α

    guard_tags _field div_eq_mul_inv group, admit,
      -- case group, div_eq_mul_inv
      -- α : Type
      -- ⊢ α → α

    guard_tags _field gpow group, admit,
      -- case group, gpow
      -- α : Type
      -- ⊢ ℤ → α → α

    guard_tags _field gpow_zero' group, admit,
      -- case group, gpow_zero'
      -- α : Type
      -- ⊢ ∀ (a : α), sorry 0 a = 1

    guard_tags _field gpow_succ' group, admit,
      -- case group, inv
      -- α : Type
      -- ⊢ ∀ (n : ℕ) (a : α), sorry (int.of_nat n.succ) a = a * sorry (int.of_nat n) a

    guard_tags _field gpow_neg' group, admit,
      -- case group, inv
      -- α : Type
      -- ⊢ ∀ (n : ℕ) (a : α), sorry -[1+ n] a = sorry (sorry ↑(n.succ) a)

    guard_tags _field mul_left_inv group, admit,
      -- case group, mul_left_inv
      -- α : Type
      -- ⊢ ∀ (a : α), a⁻¹ * a = 1
  },
  trivial
end

def my_bar {α} (x : semigroup α) (y : group α) (i j : α) : α := i

example {α : Type} : true :=
begin
  have : monoid α,
  { refine_struct { mul := my_bar { .. } { .. } },
    guard_tags _field mul semigroup, admit,
    guard_tags _field mul_assoc semigroup, admit,
    guard_tags _field mul group, admit,
    guard_tags _field mul_assoc group, admit,
    guard_tags _field one group, admit,
    guard_tags _field one_mul group, admit,
    guard_tags _field mul_one group, admit,
    guard_tags _field npow group, admit,
    guard_tags _field npow_zero' group, admit,
    guard_tags _field npow_succ' group, admit,
    guard_tags _field inv group, admit,
    guard_tags _field div group, admit,
    guard_tags _field div_eq_mul_inv group, admit,
    guard_tags _field gpow group, admit,
    guard_tags _field gpow_zero' group, admit,
    guard_tags _field gpow_succ' group, admit,
    guard_tags _field gpow_neg' group, admit,
    guard_tags _field mul_left_inv group, admit,
    guard_tags _field mul_assoc monoid, admit,
    guard_tags _field one monoid, admit,
    guard_tags _field one_mul monoid, admit,
    guard_tags _field mul_one monoid, admit,
    guard_tags _field npow monoid, admit,
    guard_tags _field npow_zero' monoid, admit,
    guard_tags _field npow_succ' monoid, admit, },
  trivial
end

def my_semigroup := semigroup

example {α} (mul : α → α → α) (h : false) : my_semigroup α :=
begin
  refine_struct { mul := mul, .. },
  field mul_assoc {
    guard_target ∀ a b c : α, mul (mul a b) c = mul a (mul b c),
    exact h.elim }
end


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.tactic.abel
import Mathlib.category_theory.limits.shapes.biproducts
import Mathlib.category_theory.preadditive.default
import Mathlib.PostPort

universes u v

namespace Mathlib

/-!
# Basic facts about morphisms between biproducts in preadditive categories.

* In any category (with zero morphisms), if `biprod.map f g` is an isomorphism,
  then both `f` and `g` are isomorphisms.

The remaining lemmas hold in any preadditive category.

* If `f` is a morphism `X₁ ⊞ X₂ ⟶ Y₁ ⊞ Y₂` whose `X₁ ⟶ Y₁` entry is an isomorphism,
  then we can construct isomorphisms `L : X₁ ⊞ X₂ ≅ X₁ ⊞ X₂` and `R : Y₁ ⊞ Y₂ ≅ Y₁ ⊞ Y₂`
  so that `L.hom ≫ g ≫ R.hom` is diagonal (with `X₁ ⟶ Y₁` component still `f`),
  via Gaussian elimination.

* As a corollary of the previous two facts,
  if we have an isomorphism `X₁ ⊞ X₂ ≅ Y₁ ⊞ Y₂` whose `X₁ ⟶ Y₁` entry is an isomorphism,
  we can construct an isomorphism `X₂ ≅ Y₂`.

* If `f : W ⊞ X ⟶ Y ⊞ Z` is an isomorphism, either `𝟙 W = 0`,
  or at least one of the component maps `W ⟶ Y` and `W ⟶ Z` is nonzero.

* If `f : ⨁ S ⟶ ⨁ T` is an isomorphism,
  then every column (corresponding to a nonzero summand in the domain)
  has some nonzero matrix entry.
-/

namespace category_theory

/--
If
```
(f 0)
(0 g)
```
is invertible, then `f` is invertible.
-/
def is_iso_left_of_is_iso_biprod_map {C : Type u} [category C] [limits.has_zero_morphisms C]
    [limits.has_binary_biproducts C] {W : C} {X : C} {Y : C} {Z : C} (f : W ⟶ Y) (g : X ⟶ Z)
    [is_iso (limits.biprod.map f g)] : is_iso f :=
  is_iso.mk (limits.biprod.inl ≫ inv (limits.biprod.map f g) ≫ limits.biprod.fst)

/--
If
```
(f 0)
(0 g)
```
is invertible, then `g` is invertible.
-/
def is_iso_right_of_is_iso_biprod_map {C : Type u} [category C] [limits.has_zero_morphisms C]
    [limits.has_binary_biproducts C] {W : C} {X : C} {Y : C} {Z : C} (f : W ⟶ Y) (g : X ⟶ Z)
    [is_iso (limits.biprod.map f g)] : is_iso g :=
  let _inst : is_iso (limits.biprod.map g f) := eq.mpr sorry is_iso.comp_is_iso;
  is_iso_left_of_is_iso_biprod_map g f

/--
The "matrix" morphism `X₁ ⊞ X₂ ⟶ Y₁ ⊞ Y₂` with specified components.
-/
def biprod.of_components {C : Type u} [category C] [preadditive C] [limits.has_binary_biproducts C]
    {X₁ : C} {X₂ : C} {Y₁ : C} {Y₂ : C} (f₁₁ : X₁ ⟶ Y₁) (f₁₂ : X₁ ⟶ Y₂) (f₂₁ : X₂ ⟶ Y₁)
    (f₂₂ : X₂ ⟶ Y₂) : X₁ ⊞ X₂ ⟶ Y₁ ⊞ Y₂ :=
  limits.biprod.fst ≫ f₁₁ ≫ limits.biprod.inl + limits.biprod.fst ≫ f₁₂ ≫ limits.biprod.inr +
      limits.biprod.snd ≫ f₂₁ ≫ limits.biprod.inl +
    limits.biprod.snd ≫ f₂₂ ≫ limits.biprod.inr

@[simp] theorem biprod.inl_of_components {C : Type u} [category C] [preadditive C]
    [limits.has_binary_biproducts C] {X₁ : C} {X₂ : C} {Y₁ : C} {Y₂ : C} (f₁₁ : X₁ ⟶ Y₁)
    (f₁₂ : X₁ ⟶ Y₂) (f₂₁ : X₂ ⟶ Y₁) (f₂₂ : X₂ ⟶ Y₂) :
    limits.biprod.inl ≫ biprod.of_components f₁₁ f₁₂ f₂₁ f₂₂ =
        f₁₁ ≫ limits.biprod.inl + f₁₂ ≫ limits.biprod.inr :=
  sorry

@[simp] theorem biprod.inr_of_components {C : Type u} [category C] [preadditive C]
    [limits.has_binary_biproducts C] {X₁ : C} {X₂ : C} {Y₁ : C} {Y₂ : C} (f₁₁ : X₁ ⟶ Y₁)
    (f₁₂ : X₁ ⟶ Y₂) (f₂₁ : X₂ ⟶ Y₁) (f₂₂ : X₂ ⟶ Y₂) :
    limits.biprod.inr ≫ biprod.of_components f₁₁ f₁₂ f₂₁ f₂₂ =
        f₂₁ ≫ limits.biprod.inl + f₂₂ ≫ limits.biprod.inr :=
  sorry

@[simp] theorem biprod.of_components_fst {C : Type u} [category C] [preadditive C]
    [limits.has_binary_biproducts C] {X₁ : C} {X₂ : C} {Y₁ : C} {Y₂ : C} (f₁₁ : X₁ ⟶ Y₁)
    (f₁₂ : X₁ ⟶ Y₂) (f₂₁ : X₂ ⟶ Y₁) (f₂₂ : X₂ ⟶ Y₂) :
    biprod.of_components f₁₁ f₁₂ f₂₁ f₂₂ ≫ limits.biprod.fst =
        limits.biprod.fst ≫ f₁₁ + limits.biprod.snd ≫ f₂₁ :=
  sorry

@[simp] theorem biprod.of_components_snd {C : Type u} [category C] [preadditive C]
    [limits.has_binary_biproducts C] {X₁ : C} {X₂ : C} {Y₁ : C} {Y₂ : C} (f₁₁ : X₁ ⟶ Y₁)
    (f₁₂ : X₁ ⟶ Y₂) (f₂₁ : X₂ ⟶ Y₁) (f₂₂ : X₂ ⟶ Y₂) :
    biprod.of_components f₁₁ f₁₂ f₂₁ f₂₂ ≫ limits.biprod.snd =
        limits.biprod.fst ≫ f₁₂ + limits.biprod.snd ≫ f₂₂ :=
  sorry

@[simp] theorem biprod.of_components_eq {C : Type u} [category C] [preadditive C]
    [limits.has_binary_biproducts C] {X₁ : C} {X₂ : C} {Y₁ : C} {Y₂ : C} (f : X₁ ⊞ X₂ ⟶ Y₁ ⊞ Y₂) :
    biprod.of_components (limits.biprod.inl ≫ f ≫ limits.biprod.fst)
          (limits.biprod.inl ≫ f ≫ limits.biprod.snd) (limits.biprod.inr ≫ f ≫ limits.biprod.fst)
          (limits.biprod.inr ≫ f ≫ limits.biprod.snd) =
        f :=
  sorry

@[simp] theorem biprod.of_components_comp {C : Type u} [category C] [preadditive C]
    [limits.has_binary_biproducts C] {X₁ : C} {X₂ : C} {Y₁ : C} {Y₂ : C} {Z₁ : C} {Z₂ : C}
    (f₁₁ : X₁ ⟶ Y₁) (f₁₂ : X₁ ⟶ Y₂) (f₂₁ : X₂ ⟶ Y₁) (f₂₂ : X₂ ⟶ Y₂) (g₁₁ : Y₁ ⟶ Z₁) (g₁₂ : Y₁ ⟶ Z₂)
    (g₂₁ : Y₂ ⟶ Z₁) (g₂₂ : Y₂ ⟶ Z₂) :
    biprod.of_components f₁₁ f₁₂ f₂₁ f₂₂ ≫ biprod.of_components g₁₁ g₁₂ g₂₁ g₂₂ =
        biprod.of_components (f₁₁ ≫ g₁₁ + f₁₂ ≫ g₂₁) (f₁₁ ≫ g₁₂ + f₁₂ ≫ g₂₂) (f₂₁ ≫ g₁₁ + f₂₂ ≫ g₂₁)
          (f₂₁ ≫ g₁₂ + f₂₂ ≫ g₂₂) :=
  sorry

/--
The unipotent upper triangular matrix
```
(1 r)
(0 1)
```
as an isomorphism.
-/
@[simp] theorem biprod.unipotent_upper_hom {C : Type u} [category C] [preadditive C]
    [limits.has_binary_biproducts C] {X₁ : C} {X₂ : C} (r : X₁ ⟶ X₂) :
    iso.hom (biprod.unipotent_upper r) = biprod.of_components 𝟙 r 0 𝟙 :=
  Eq.refl (iso.hom (biprod.unipotent_upper r))

/--
The unipotent lower triangular matrix
```
(1 0)
(r 1)
```
as an isomorphism.
-/
@[simp] theorem biprod.unipotent_lower_hom {C : Type u} [category C] [preadditive C]
    [limits.has_binary_biproducts C] {X₁ : C} {X₂ : C} (r : X₂ ⟶ X₁) :
    iso.hom (biprod.unipotent_lower r) = biprod.of_components 𝟙 0 r 𝟙 :=
  Eq.refl (iso.hom (biprod.unipotent_lower r))

/--
If `f` is a morphism `X₁ ⊞ X₂ ⟶ Y₁ ⊞ Y₂` whose `X₁ ⟶ Y₁` entry is an isomorphism,
then we can construct isomorphisms `L : X₁ ⊞ X₂ ≅ X₁ ⊞ X₂` and `R : Y₁ ⊞ Y₂ ≅ Y₁ ⊞ Y₂`
so that `L.hom ≫ g ≫ R.hom` is diagonal (with `X₁ ⟶ Y₁` component still `f`),
via Gaussian elimination.

(This is the version of `biprod.gaussian` written in terms of components.)
-/
def biprod.gaussian' {C : Type u} [category C] [preadditive C] [limits.has_binary_biproducts C]
    {X₁ : C} {X₂ : C} {Y₁ : C} {Y₂ : C} (f₁₁ : X₁ ⟶ Y₁) (f₁₂ : X₁ ⟶ Y₂) (f₂₁ : X₂ ⟶ Y₁)
    (f₂₂ : X₂ ⟶ Y₂) [is_iso f₁₁] :
    psigma
        fun (L : X₁ ⊞ X₂ ≅ X₁ ⊞ X₂) =>
          psigma
            fun (R : Y₁ ⊞ Y₂ ≅ Y₁ ⊞ Y₂) =>
              psigma
                fun (g₂₂ : X₂ ⟶ Y₂) =>
                  iso.hom L ≫ biprod.of_components f₁₁ f₁₂ f₂₁ f₂₂ ≫ iso.hom R =
                    limits.biprod.map f₁₁ g₂₂ :=
  psigma.mk (biprod.unipotent_lower (-f₂₁ ≫ inv f₁₁))
    (psigma.mk (biprod.unipotent_upper (-inv f₁₁ ≫ f₁₂))
      (psigma.mk (f₂₂ - f₂₁ ≫ inv f₁₁ ≫ f₁₂) sorry))

/--
If `f` is a morphism `X₁ ⊞ X₂ ⟶ Y₁ ⊞ Y₂` whose `X₁ ⟶ Y₁` entry is an isomorphism,
then we can construct isomorphisms `L : X₁ ⊞ X₂ ≅ X₁ ⊞ X₂` and `R : Y₁ ⊞ Y₂ ≅ Y₁ ⊞ Y₂`
so that `L.hom ≫ g ≫ R.hom` is diagonal (with `X₁ ⟶ Y₁` component still `f`),
via Gaussian elimination.
-/
def biprod.gaussian {C : Type u} [category C] [preadditive C] [limits.has_binary_biproducts C]
    {X₁ : C} {X₂ : C} {Y₁ : C} {Y₂ : C} (f : X₁ ⊞ X₂ ⟶ Y₁ ⊞ Y₂)
    [is_iso (limits.biprod.inl ≫ f ≫ limits.biprod.fst)] :
    psigma
        fun (L : X₁ ⊞ X₂ ≅ X₁ ⊞ X₂) =>
          psigma
            fun (R : Y₁ ⊞ Y₂ ≅ Y₁ ⊞ Y₂) =>
              psigma
                fun (g₂₂ : X₂ ⟶ Y₂) =>
                  iso.hom L ≫ f ≫ iso.hom R =
                    limits.biprod.map (limits.biprod.inl ≫ f ≫ limits.biprod.fst) g₂₂ :=
  let this :
    psigma
      fun (L : X₁ ⊞ X₂ ≅ X₁ ⊞ X₂) =>
        psigma
          fun (R : Y₁ ⊞ Y₂ ≅ Y₁ ⊞ Y₂) =>
            psigma
              fun (g₂₂ : X₂ ⟶ Y₂) =>
                iso.hom L ≫
                    biprod.of_components (limits.biprod.inl ≫ f ≫ limits.biprod.fst)
                        (limits.biprod.inl ≫ f ≫ limits.biprod.snd)
                        (limits.biprod.inr ≫ f ≫ limits.biprod.fst)
                        (limits.biprod.inr ≫ f ≫ limits.biprod.snd) ≫
                      iso.hom R =
                  limits.biprod.map (limits.biprod.inl ≫ f ≫ limits.biprod.fst) g₂₂ :=
    biprod.gaussian' (limits.biprod.inl ≫ f ≫ limits.biprod.fst)
      (limits.biprod.inl ≫ f ≫ limits.biprod.snd) (limits.biprod.inr ≫ f ≫ limits.biprod.fst)
      (limits.biprod.inr ≫ f ≫ limits.biprod.snd);
  eq.mpr sorry (eq.mp sorry this)

/--
If `X₁ ⊞ X₂ ≅ Y₁ ⊞ Y₂` via a two-by-two matrix whose `X₁ ⟶ Y₁` entry is an isomorphism,
then we can construct an isomorphism `X₂ ≅ Y₂`, via Gaussian elimination.
-/
def biprod.iso_elim' {C : Type u} [category C] [preadditive C] [limits.has_binary_biproducts C]
    {X₁ : C} {X₂ : C} {Y₁ : C} {Y₂ : C} (f₁₁ : X₁ ⟶ Y₁) (f₁₂ : X₁ ⟶ Y₂) (f₂₁ : X₂ ⟶ Y₁)
    (f₂₂ : X₂ ⟶ Y₂) [is_iso f₁₁] [is_iso (biprod.of_components f₁₁ f₁₂ f₂₁ f₂₂)] : X₂ ≅ Y₂ :=
  psigma.cases_on (biprod.gaussian' f₁₁ f₁₂ f₂₁ f₂₂)
    fun (L : X₁ ⊞ X₂ ≅ X₁ ⊞ X₂)
      (snd :
      psigma
        fun (R : Y₁ ⊞ Y₂ ≅ Y₁ ⊞ Y₂) =>
          psigma
            fun (g₂₂ : X₂ ⟶ Y₂) =>
              iso.hom L ≫ biprod.of_components f₁₁ f₁₂ f₂₁ f₂₂ ≫ iso.hom R =
                limits.biprod.map f₁₁ g₂₂) =>
      psigma.cases_on snd
        fun (R : Y₁ ⊞ Y₂ ≅ Y₁ ⊞ Y₂)
          (snd_snd :
          psigma
            fun (g₂₂ : X₂ ⟶ Y₂) =>
              iso.hom L ≫ biprod.of_components f₁₁ f₁₂ f₂₁ f₂₂ ≫ iso.hom R =
                limits.biprod.map f₁₁ g₂₂) =>
          psigma.cases_on snd_snd
            fun (g : X₂ ⟶ Y₂)
              (w :
              iso.hom L ≫ biprod.of_components f₁₁ f₁₂ f₂₁ f₂₂ ≫ iso.hom R =
                limits.biprod.map f₁₁ g) =>
              let _inst : is_iso (limits.biprod.map f₁₁ g) := eq.mpr sorry is_iso.comp_is_iso;
              let _inst_6 : is_iso g := is_iso_right_of_is_iso_biprod_map f₁₁ g;
              as_iso g

/--
If `f` is an isomorphism `X₁ ⊞ X₂ ≅ Y₁ ⊞ Y₂` whose `X₁ ⟶ Y₁` entry is an isomorphism,
then we can construct an isomorphism `X₂ ≅ Y₂`, via Gaussian elimination.
-/
def biprod.iso_elim {C : Type u} [category C] [preadditive C] [limits.has_binary_biproducts C]
    {X₁ : C} {X₂ : C} {Y₁ : C} {Y₂ : C} (f : X₁ ⊞ X₂ ≅ Y₁ ⊞ Y₂)
    [is_iso (limits.biprod.inl ≫ iso.hom f ≫ limits.biprod.fst)] : X₂ ≅ Y₂ :=
  let _inst :
    is_iso
      (biprod.of_components (limits.biprod.inl ≫ iso.hom f ≫ limits.biprod.fst)
        (limits.biprod.inl ≫ iso.hom f ≫ limits.biprod.snd)
        (limits.biprod.inr ≫ iso.hom f ≫ limits.biprod.fst)
        (limits.biprod.inr ≫ iso.hom f ≫ limits.biprod.snd)) :=
    eq.mpr sorry (is_iso.of_iso f);
  biprod.iso_elim' (limits.biprod.inl ≫ iso.hom f ≫ limits.biprod.fst)
    (limits.biprod.inl ≫ iso.hom f ≫ limits.biprod.snd)
    (limits.biprod.inr ≫ iso.hom f ≫ limits.biprod.fst)
    (limits.biprod.inr ≫ iso.hom f ≫ limits.biprod.snd)

theorem biprod.column_nonzero_of_iso {C : Type u} [category C] [preadditive C]
    [limits.has_binary_biproducts C] {W : C} {X : C} {Y : C} {Z : C} (f : W ⊞ X ⟶ Y ⊞ Z)
    [is_iso f] :
    𝟙 = 0 ∨
        limits.biprod.inl ≫ f ≫ limits.biprod.fst ≠ 0 ∨
          limits.biprod.inl ≫ f ≫ limits.biprod.snd ≠ 0 :=
  sorry

theorem biproduct.column_nonzero_of_iso' {C : Type u} [category C] [preadditive C] {σ : Type v}
    {τ : Type v} [DecidableEq σ] [DecidableEq τ] [fintype τ] {S : σ → C} [limits.has_biproduct S]
    {T : τ → C} [limits.has_biproduct T] (s : σ) (f : ⨁ S ⟶ ⨁ T) [is_iso f] :
    (∀ (t : τ), limits.biproduct.ι S s ≫ f ≫ limits.biproduct.π T t = 0) → 𝟙 = 0 :=
  sorry

/--
If `f : ⨁ S ⟶ ⨁ T` is an isomorphism, and `s` is a non-trivial summand of the source,
then there is some `t` in the target so that the `s, t` matrix entry of `f` is nonzero.
-/
def biproduct.column_nonzero_of_iso {C : Type u} [category C] [preadditive C] {σ : Type v}
    {τ : Type v} [DecidableEq σ] [DecidableEq τ] [fintype τ] {S : σ → C} [limits.has_biproduct S]
    {T : τ → C} [limits.has_biproduct T] (s : σ) (nz : 𝟙 ≠ 0) [(t : τ) → DecidableEq (S s ⟶ T t)]
    (f : ⨁ S ⟶ ⨁ T) [is_iso f] :
    trunc (psigma fun (t : τ) => limits.biproduct.ι S s ≫ f ≫ limits.biproduct.π T t ≠ 0) :=
  trunc_sigma_of_exists sorry

end Mathlib


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import algebra.category.Group.basic
import category_theory.single_obj
import category_theory.limits.functor_category
import category_theory.limits.preserves.basic
import category_theory.adjunction.limits
import category_theory.monoidal.functor_category
import category_theory.monoidal.transport
import category_theory.monoidal.rigid.of_equivalence
import category_theory.monoidal.rigid.functor_category
import category_theory.monoidal.linear
import category_theory.monoidal.braided
import category_theory.abelian.functor_category
import category_theory.abelian.transfer
import category_theory.conj
import category_theory.linear.functor_category

/-!
# `Action V G`, the category of actions of a monoid `G` inside some category `V`.

The prototypical example is `V = Module R`,
where `Action (Module R) G` is the category of `R`-linear representations of `G`.

We check `Action V G ≌ (single_obj G ⥤ V)`,
and construct the restriction functors `res {G H : Mon} (f : G ⟶ H) : Action V H ⥤ Action V G`.

* When `V` has (co)limits so does `Action V G`.
* When `V` is monoidal, braided, or symmetric, so is `Action V G`.
* When `V` is preadditive, linear, or abelian so is `Action V G`.
-/

universes u

open category_theory
open category_theory.limits

variables (V : Type (u+1)) [large_category V]

/--
An `Action V G` represents a bundled action of
the monoid `G` on an object of some category `V`.

As an example, when `V = Module R`, this is an `R`-linear representation of `G`,
while when `V = Type` this is a `G`-action.
-/
-- Note: this is _not_ a categorical action of `G` on `V`.
structure Action (G : Mon.{u}) :=
(V : V)
(ρ : G ⟶ Mon.of (End V))

namespace Action
variable {V}

@[simp]
lemma ρ_one {G : Mon.{u}} (A : Action V G) : A.ρ 1 = 𝟙 A.V :=
by { rw [monoid_hom.map_one], refl, }

/-- When a group acts, we can lift the action to the group of automorphisms. -/
@[simps]
def ρ_Aut {G : Group.{u}} (A : Action V (Mon.of G)) : G ⟶ Group.of (Aut A.V) :=
{ to_fun := λ g,
  { hom := A.ρ g,
    inv := A.ρ (g⁻¹ : G),
    hom_inv_id' := ((A.ρ).map_mul (g⁻¹ : G) g).symm.trans (by rw [inv_mul_self, ρ_one]),
    inv_hom_id' := ((A.ρ).map_mul g (g⁻¹ : G)).symm.trans (by rw [mul_inv_self, ρ_one]), },
  map_one' := by { ext, exact A.ρ.map_one },
  map_mul' := λ x y, by { ext, exact A.ρ.map_mul x y }, }

variable (G : Mon.{u})

section

/-- The trivial representation of a group. -/
def trivial : Action AddCommGroup G :=
{ V := AddCommGroup.of punit,
  ρ := 1, }

instance : inhabited (Action AddCommGroup G) := ⟨trivial G⟩
end

variables {G V}

/--
A homomorphism of `Action V G`s is a morphism between the underlying objects,
commuting with the action of `G`.
-/
@[ext]
structure hom (M N : Action V G) :=
(hom : M.V ⟶ N.V)
(comm' : ∀ g : G, M.ρ g ≫ hom = hom ≫ N.ρ g . obviously)

restate_axiom hom.comm'

namespace hom

/-- The identity morphism on a `Action V G`. -/
@[simps]
def id (M : Action V G) : Action.hom M M :=
{ hom := 𝟙 M.V }

instance (M : Action V G) : inhabited (Action.hom M M) := ⟨id M⟩

/--
The composition of two `Action V G` homomorphisms is the composition of the underlying maps.
-/
@[simps]
def comp {M N K : Action V G} (p : Action.hom M N) (q : Action.hom N K) :
  Action.hom M K :=
{ hom := p.hom ≫ q.hom,
  comm' := λ g, by rw [←category.assoc, p.comm, category.assoc, q.comm, ←category.assoc] }

end hom

instance : category (Action V G) :=
{ hom := λ M N, hom M N,
  id := λ M, hom.id M,
  comp := λ M N K f g, hom.comp f g, }

@[simp]
lemma id_hom (M : Action V G) : (𝟙 M : hom M M).hom = 𝟙 M.V := rfl
@[simp]
lemma comp_hom {M N K : Action V G} (f : M ⟶ N) (g : N ⟶ K) :
  (f ≫ g : hom M K).hom = f.hom ≫ g.hom :=
rfl

/-- Construct an isomorphism of `G` actions/representations
from an isomorphism of the the underlying objects,
where the forward direction commutes with the group action. -/
@[simps]
def mk_iso {M N : Action V G} (f : M.V ≅ N.V) (comm : ∀ g : G, M.ρ g ≫ f.hom = f.hom ≫ N.ρ g) :
  M ≅ N :=
{ hom :=
  { hom := f.hom,
    comm' := comm, },
  inv :=
  { hom := f.inv,
    comm' := λ g, by { have w := comm g =≫ f.inv, simp at w, simp [w], }, }}

namespace functor_category_equivalence

/-- Auxilliary definition for `functor_category_equivalence`. -/
@[simps]
def functor : Action V G ⥤ (single_obj G ⥤ V) :=
{ obj := λ M,
  { obj := λ _, M.V,
    map := λ _ _ g, M.ρ g,
    map_id' := λ _, M.ρ.map_one,
    map_comp' := λ _ _ _ g h, M.ρ.map_mul h g, },
  map := λ M N f,
  { app := λ _, f.hom,
    naturality' := λ _ _ g, f.comm g, } }

/-- Auxilliary definition for `functor_category_equivalence`. -/
@[simps]
def inverse : (single_obj G ⥤ V) ⥤ Action V G :=
{ obj := λ F,
  { V := F.obj punit.star,
    ρ :=
    { to_fun := λ g, F.map g,
      map_one' := F.map_id punit.star,
      map_mul' := λ g h, F.map_comp h g, } },
  map := λ M N f,
  { hom := f.app punit.star,
    comm' := λ g, f.naturality g, } }.

/-- Auxilliary definition for `functor_category_equivalence`. -/
@[simps]
def unit_iso : 𝟭 (Action V G) ≅ functor ⋙ inverse :=
nat_iso.of_components (λ M, mk_iso ((iso.refl _)) (by tidy)) (by tidy).

/-- Auxilliary definition for `functor_category_equivalence`. -/
@[simps]
def counit_iso : inverse ⋙ functor ≅ 𝟭 (single_obj G ⥤ V) :=
nat_iso.of_components (λ M, nat_iso.of_components (by tidy) (by tidy)) (by tidy).

end functor_category_equivalence

section
open functor_category_equivalence

variables (V G)

/--
The category of actions of `G` in the category `V`
is equivalent to the functor category `single_obj G ⥤ V`.
-/
def functor_category_equivalence : Action V G ≌ (single_obj G ⥤ V) :=
{ functor := functor,
  inverse := inverse,
  unit_iso := unit_iso,
  counit_iso := counit_iso, }

attribute [simps] functor_category_equivalence

instance [has_finite_products V] : has_finite_products (Action V G) :=
{ out := λ J _, by exactI
  adjunction.has_limits_of_shape_of_equivalence (Action.functor_category_equivalence _ _).functor }

instance [has_limits V] : has_limits (Action V G) :=
adjunction.has_limits_of_equivalence (Action.functor_category_equivalence _ _).functor

instance [has_colimits V] : has_colimits (Action V G) :=
adjunction.has_colimits_of_equivalence (Action.functor_category_equivalence _ _).functor

end

section forget

variables (V G)

/-- (implementation) The forgetful functor from bundled actions to the underlying objects.

Use the `category_theory.forget` API provided by the `concrete_category` instance below,
rather than using this directly.
-/
@[simps]
def forget : Action V G ⥤ V :=
{ obj := λ M, M.V,
  map := λ M N f, f.hom, }

instance : faithful (forget V G) :=
{ map_injective' := λ X Y f g w, hom.ext _ _ w, }

instance [concrete_category V] : concrete_category (Action V G) :=
{ forget := forget V G ⋙ (concrete_category.forget V), }

instance has_forget_to_V [concrete_category V] : has_forget₂ (Action V G) V :=
{ forget₂ := forget V G }

/-- The forgetful functor is intertwined by `functor_category_equivalence` with
evaluation at `punit.star`. -/
def functor_category_equivalence_comp_evaluation :
  (functor_category_equivalence V G).functor ⋙ (evaluation _ _).obj punit.star ≅ forget V G :=
iso.refl _

noncomputable instance [has_limits V] : limits.preserves_limits (forget V G) :=
limits.preserves_limits_of_nat_iso
  (Action.functor_category_equivalence_comp_evaluation V G)

noncomputable instance [has_colimits V] : preserves_colimits (forget V G) :=
preserves_colimits_of_nat_iso
  (Action.functor_category_equivalence_comp_evaluation V G)

-- TODO construct categorical images?

end forget

lemma iso.conj_ρ {M N : Action V G} (f : M ≅ N) (g : G) :
   N.ρ g = (((forget V G).map_iso f).conj (M.ρ g)) :=
by { rw [iso.conj_apply, iso.eq_inv_comp], simp [f.hom.comm'] }

section has_zero_morphisms
variables [has_zero_morphisms V]

instance : has_zero_morphisms (Action V G) :=
{ has_zero := λ X Y, ⟨⟨0, by tidy⟩⟩, }

instance : functor.preserves_zero_morphisms (functor_category_equivalence V G).functor := {}

end has_zero_morphisms

section preadditive
variables [preadditive V]

instance : preadditive (Action V G) :=
{ hom_group := λ X Y,
  { zero := ⟨0, by simp⟩,
    add := λ f g, ⟨f.hom + g.hom, by simp [f.comm, g.comm]⟩,
    neg := λ f, ⟨-f.hom, by simp [f.comm]⟩,
    zero_add := by { intros, ext, exact zero_add _, },
    add_zero := by { intros, ext, exact add_zero _, },
    add_assoc := by { intros, ext, exact add_assoc _ _ _, },
    add_left_neg := by { intros, ext, exact add_left_neg _, },
    add_comm := by { intros, ext, exact add_comm _ _, }, },
  add_comp' := by { intros, ext, exact preadditive.add_comp _ _ _ _ _ _, },
  comp_add' := by { intros, ext, exact preadditive.comp_add _ _ _ _ _ _, }, }

instance : functor.additive (functor_category_equivalence V G).functor := {}

@[simp] lemma zero_hom {X Y : Action V G} : (0 : X ⟶ Y).hom = 0 := rfl
@[simp] lemma neg_hom {X Y : Action V G} (f : X ⟶ Y) : (-f).hom = -f.hom := rfl
@[simp] lemma add_hom {X Y : Action V G} (f g : X ⟶ Y) : (f + g).hom = f.hom + g.hom := rfl

end preadditive

section linear
variables [preadditive V] {R : Type*} [semiring R] [linear R V]

instance : linear R (Action V G) :=
{ hom_module := λ X Y,
  { smul := λ r f, ⟨r • f.hom, by simp [f.comm]⟩,
    one_smul := by { intros, ext, exact one_smul _ _, },
    smul_zero := by { intros, ext, exact smul_zero _, },
    zero_smul := by { intros, ext, exact zero_smul _ _, },
    add_smul := by { intros, ext, exact add_smul _ _ _, },
    smul_add := by { intros, ext, exact smul_add _ _ _, },
    mul_smul := by { intros, ext, exact mul_smul _ _ _, }, },
  smul_comp' := by { intros, ext, exact linear.smul_comp _ _ _ _ _ _, },
  comp_smul' := by { intros, ext, exact linear.comp_smul _ _ _ _ _ _, }, }

instance : functor.linear R (functor_category_equivalence V G).functor := {}

@[simp] lemma smul_hom {X Y : Action V G} (r : R) (f : X ⟶ Y) : (r • f).hom = r • f.hom := rfl

end linear

section abelian
/-- Auxilliary construction for the `abelian (Action V G)` instance. -/
def abelian_aux : Action V G ≌ (ulift.{u} (single_obj G) ⥤ V) :=
(functor_category_equivalence V G).trans (equivalence.congr_left ulift.equivalence)

noncomputable instance [abelian V] : abelian (Action V G) :=
abelian_of_equivalence abelian_aux.functor

end abelian

section monoidal
variables [monoidal_category V]

instance : monoidal_category (Action V G) :=
monoidal.transport (Action.functor_category_equivalence _ _).symm

@[simp] lemma tensor_V {X Y : Action V G} : (X ⊗ Y).V = X.V ⊗ Y.V := rfl
@[simp] lemma tensor_rho {X Y : Action V G} {g : G} : (X ⊗ Y).ρ g = X.ρ g ⊗ Y.ρ g := rfl
@[simp] lemma tensor_hom {W X Y Z : Action V G} (f : W ⟶ X) (g : Y ⟶ Z) :
  (f ⊗ g).hom = f.hom ⊗ g.hom := rfl
@[simp] lemma associator_hom_hom {X Y Z : Action V G} :
  hom.hom (α_ X Y Z).hom = (α_ X.V Y.V Z.V).hom :=
begin
  dsimp [monoidal.transport_associator],
  simp,
end
@[simp] lemma associator_inv_hom {X Y Z : Action V G} :
  hom.hom (α_ X Y Z).inv = (α_ X.V Y.V Z.V).inv :=
begin
  dsimp [monoidal.transport_associator],
  simp,
end
@[simp] lemma left_unitor_hom_hom {X : Action V G} :
  hom.hom (λ_ X).hom = (λ_ X.V).hom :=
begin
  dsimp [monoidal.transport_left_unitor],
  simp,
end
@[simp] lemma left_unitor_inv_hom {X : Action V G} :
  hom.hom (λ_ X).inv = (λ_ X.V).inv :=
begin
  dsimp [monoidal.transport_left_unitor],
  simp,
end
@[simp] lemma right_unitor_hom_hom {X : Action V G} :
  hom.hom (ρ_ X).hom = (ρ_ X.V).hom :=
begin
  dsimp [monoidal.transport_right_unitor],
  simp,
end
@[simp] lemma right_unitor_inv_hom {X : Action V G} :
  hom.hom (ρ_ X).inv = (ρ_ X.V).inv :=
begin
  dsimp [monoidal.transport_right_unitor],
  simp,
end

variables (V G)

/-- When `V` is monoidal the forgetful functor `Action V G` to `V` is monoidal. -/
@[simps]
def forget_monoidal : monoidal_functor (Action V G) V :=
{ ε := 𝟙 _,
  μ := λ X Y, 𝟙 _,
  ..Action.forget _ _, }

instance forget_monoidal_faithful : faithful (forget_monoidal V G).to_functor :=
by { change faithful (forget V G), apply_instance, }

section
variables [braided_category V]

instance : braided_category (Action V G) :=
braided_category_of_faithful (forget_monoidal V G) (λ X Y, mk_iso (β_ _ _) (by tidy)) (by tidy)

/-- When `V` is braided the forgetful functor `Action V G` to `V` is braided. -/
@[simps]
def forget_braided : braided_functor (Action V G) V :=
{ ..forget_monoidal _ _, }

instance forget_braided_faithful : faithful (forget_braided V G).to_functor :=
by { change faithful (forget V G), apply_instance, }

end

instance [symmetric_category V] : symmetric_category (Action V G) :=
symmetric_category_of_faithful (forget_braided V G)

section
local attribute [simp] monoidal_preadditive.tensor_add monoidal_preadditive.add_tensor

variables [preadditive V] [monoidal_preadditive V]

instance : monoidal_preadditive (Action V G) := {}

variables {R : Type*} [semiring R] [linear R V] [monoidal_linear R V]

instance : monoidal_linear R (Action V G) := {}

end

variables (V G)
noncomputable theory

/-- Upgrading the functor `Action V G ⥤ (single_obj G ⥤ V)` to a monoidal functor. -/
def functor_category_monoidal_equivalence : monoidal_functor (Action V G) (single_obj G ⥤ V) :=
monoidal.from_transported (Action.functor_category_equivalence _ _).symm

instance : is_equivalence ((functor_category_monoidal_equivalence V G).to_functor) :=
by { change is_equivalence (Action.functor_category_equivalence _ _).functor, apply_instance, }

variables (H : Group.{u})

instance [right_rigid_category V] : right_rigid_category (single_obj (H : Mon.{u}) ⥤ V) :=
by { change right_rigid_category (single_obj H ⥤ V), apply_instance }

/-- If `V` is right rigid, so is `Action V G`. -/
instance [right_rigid_category V] : right_rigid_category (Action V H) :=
right_rigid_category_of_equivalence (functor_category_monoidal_equivalence V _)

instance [left_rigid_category V] : left_rigid_category (single_obj (H : Mon.{u}) ⥤ V) :=
by { change left_rigid_category (single_obj H ⥤ V), apply_instance }

/-- If `V` is left rigid, so is `Action V G`. -/
instance [left_rigid_category V] : left_rigid_category (Action V H) :=
left_rigid_category_of_equivalence (functor_category_monoidal_equivalence V _)

instance [rigid_category V] : rigid_category (single_obj (H : Mon.{u}) ⥤ V) :=
by { change rigid_category (single_obj H ⥤ V), apply_instance }

/-- If `V` is rigid, so is `Action V G`. -/
instance [rigid_category V] : rigid_category (Action V H) :=
rigid_category_of_equivalence (functor_category_monoidal_equivalence V _)

variables {V H} (X : Action V H)

@[simp] lemma right_dual_V [right_rigid_category V] : (Xᘁ).V = (X.V)ᘁ := rfl

@[simp] lemma left_dual_V [left_rigid_category V] : (ᘁX).V = ᘁ(X.V) := rfl

@[simp] lemma right_dual_ρ [right_rigid_category V] (h : H) : (Xᘁ).ρ h = (X.ρ (h⁻¹ : H))ᘁ :=
by { rw ←single_obj.inv_as_inv, refl }

@[simp] lemma left_dual_ρ [left_rigid_category V] (h : H) : (ᘁX).ρ h = ᘁ(X.ρ (h⁻¹ : H)) :=
by { rw ←single_obj.inv_as_inv, refl }

end monoidal

/-- Actions/representations of the trivial group are just objects in the ambient category. -/
def Action_punit_equivalence : Action V (Mon.of punit) ≌ V :=
{ functor := forget V _,
  inverse :=
  { obj := λ X, ⟨X, 1⟩,
    map := λ X Y f, ⟨f, λ ⟨⟩, by simp⟩, },
  unit_iso := nat_iso.of_components (λ X, mk_iso (iso.refl _) (λ ⟨⟩, by simpa using ρ_one X))
    (by tidy),
  counit_iso := nat_iso.of_components (λ X, iso.refl _) (by tidy), }

variables (V)
/--
The "restriction" functor along a monoid homomorphism `f : G ⟶ H`,
taking actions of `H` to actions of `G`.

(This makes sense for any homomorphism, but the name is natural when `f` is a monomorphism.)
-/
@[simps]
def res {G H : Mon} (f : G ⟶ H) : Action V H ⥤ Action V G :=
{ obj := λ M,
  { V := M.V,
    ρ := f ≫ M.ρ },
  map := λ M N p,
  { hom := p.hom,
    comm' := λ g, p.comm (f g) } }

/--
The natural isomorphism from restriction along the identity homomorphism to
the identity functor on `Action V G`.
-/
def res_id {G : Mon} : res V (𝟙 G) ≅ 𝟭 (Action V G) :=
nat_iso.of_components (λ M, mk_iso (iso.refl _) (by tidy)) (by tidy)

attribute [simps] res_id

/--
The natural isomorphism from the composition of restrictions along homomorphisms
to the restriction along the composition of homomorphism.
-/
def res_comp {G H K : Mon} (f : G ⟶ H) (g : H ⟶ K) : res V g ⋙ res V f ≅ res V (f ≫ g) :=
nat_iso.of_components (λ M, mk_iso (iso.refl _) (by tidy)) (by tidy)

attribute [simps] res_comp

-- TODO promote `res` to a pseudofunctor from
-- the locally discrete bicategory constructed from `Monᵒᵖ` to `Cat`, sending `G` to `Action V G`.

variables {G} {H : Mon.{u}} (f : G ⟶ H)

instance res_additive [preadditive V] : (res V f).additive := {}

variables {R : Type*} [semiring R]

instance res_linear [preadditive V] [linear R V] : (res V f).linear R := {}

end Action

namespace category_theory.functor

variables {V} {W : Type (u+1)} [large_category W]

/-- A functor between categories induces a functor between
the categories of `G`-actions within those categories. -/
@[simps]
def map_Action (F : V ⥤ W) (G : Mon.{u}) : Action V G ⥤ Action W G :=
{ obj := λ M,
  { V := F.obj M.V,
    ρ :=
    { to_fun := λ g, F.map (M.ρ g),
      map_one' := by simp only [End.one_def, Action.ρ_one, F.map_id],
      map_mul' := λ g h, by simp only [End.mul_def, F.map_comp, map_mul], }, },
  map := λ M N f,
  { hom := F.map f.hom,
    comm' := λ g, by { dsimp, rw [←F.map_comp, f.comm, F.map_comp], }, },
  map_id' := λ M, by { ext, simp only [Action.id_hom, F.map_id], },
  map_comp' := λ M N P f g, by { ext, simp only [Action.comp_hom, F.map_comp], }, }

variables (F : V ⥤ W) (G : Mon.{u}) [preadditive V] [preadditive W]

instance map_Action_preadditive [F.additive] : (F.map_Action G).additive := {}

variables {R : Type*} [semiring R] [category_theory.linear R V] [category_theory.linear R W]

instance map_Action_linear [F.additive] [F.linear R] : (F.map_Action G).linear R := {}

end category_theory.functor


/-
Copyright (c) 2017 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import data.list.basic

/-!
# Prefixes, subfixes, infixes

This file proves properties about
* `list.prefix`: `l₁` is a prefix of `l₂` if `l₂` starts with `l₁`.
* `list.subfix`: `l₁` is a subfix of `l₂` if `l₂` ends with `l₁`.
* `list.infix`: `l₁` is an infix of `l₂` if `l₁` is a prefix of some subfix of `l₂`.
* `list.inits`: The list of prefixes of a list.
* `list.tails`: The list of prefixes of a list.
* `insert` on lists

All those (except `insert`) are defined in `data.list.defs`.

## Notation

`l₁ <+: l₂`: `l₁` is a prefix of `l₂`.
`l₁ <:+ l₂`: `l₁` is a subfix of `l₂`.
`l₁ <:+: l₂`: `l₁` is an infix of `l₂`.
-/

open nat

variables {α β : Type*}

namespace list
variables {l l₁ l₂ l₃ : list α} {a b : α} {m n : ℕ}

/-! ### prefix, suffix, infix -/

section fix

@[simp] lemma prefix_append (l₁ l₂ : list α) : l₁ <+: l₁ ++ l₂ := ⟨l₂, rfl⟩
@[simp] lemma suffix_append (l₁ l₂ : list α) : l₂ <:+ l₁ ++ l₂ := ⟨l₁, rfl⟩

lemma infix_append (l₁ l₂ l₃ : list α) : l₂ <:+: l₁ ++ l₂ ++ l₃ := ⟨l₁, l₃, rfl⟩

@[simp] lemma infix_append' (l₁ l₂ l₃ : list α) : l₂ <:+: l₁ ++ (l₂ ++ l₃) :=
by rw ← list.append_assoc; apply infix_append

lemma is_prefix.is_infix : l₁ <+: l₂ → l₁ <:+: l₂ := λ ⟨t, h⟩, ⟨[], t, h⟩
lemma is_suffix.is_infix : l₁ <:+ l₂ → l₁ <:+: l₂ := λ ⟨t, h⟩, ⟨t, [], by rw [h, append_nil]⟩

lemma nil_prefix (l : list α) : [] <+: l := ⟨l, rfl⟩
lemma nil_suffix (l : list α) : [] <:+ l := ⟨l, append_nil _⟩
lemma nil_infix (l : list α) : [] <:+: l := (nil_prefix _).is_infix

@[refl] lemma prefix_refl (l : list α) : l <+: l := ⟨[], append_nil _⟩
@[refl] lemma suffix_refl (l : list α) : l <:+ l := ⟨[], rfl⟩
@[refl] lemma infix_refl (l : list α) : l <:+: l := (prefix_refl l).is_infix

lemma prefix_rfl : l <+: l := prefix_refl _
lemma suffix_rfl : l <:+ l := suffix_refl _
lemma infix_rfl : l <:+: l := infix_refl _

@[simp] lemma suffix_cons (a : α) : ∀ l, l <:+ a :: l := suffix_append [a]

lemma prefix_concat (a : α) (l) : l <+: concat l a := by simp

lemma infix_cons : l₁ <:+: l₂ → l₁ <:+: a :: l₂ := λ ⟨L₁, L₂, h⟩, ⟨a :: L₁, L₂, h ▸ rfl⟩
lemma infix_concat : l₁ <:+: l₂ → l₁ <:+: concat l₂ a :=
λ ⟨L₁, L₂, h⟩, ⟨L₁, concat L₂ a, by simp_rw [←h, concat_eq_append, append_assoc]⟩

@[trans] lemma is_prefix.trans : ∀ {l₁ l₂ l₃ : list α}, l₁ <+: l₂ → l₂ <+: l₃ → l₁ <+: l₃
| l ._ ._ ⟨r₁, rfl⟩ ⟨r₂, rfl⟩ := ⟨r₁ ++ r₂, (append_assoc _ _ _).symm⟩

@[trans] lemma is_suffix.trans : ∀ {l₁ l₂ l₃ : list α}, l₁ <:+ l₂ → l₂ <:+ l₃ → l₁ <:+ l₃
| l ._ ._ ⟨l₁, rfl⟩ ⟨l₂, rfl⟩ := ⟨l₂ ++ l₁, append_assoc _ _ _⟩

@[trans] lemma is_infix.trans : ∀ {l₁ l₂ l₃ : list α}, l₁ <:+: l₂ → l₂ <:+: l₃ → l₁ <:+: l₃
| l ._ ._ ⟨l₁, r₁, rfl⟩ ⟨l₂, r₂, rfl⟩ := ⟨l₂ ++ l₁, r₁ ++ r₂, by simp only [append_assoc]⟩

protected lemma is_infix.sublist : l₁ <:+: l₂ → l₁ <+ l₂ :=
λ ⟨s, t, h⟩, by { rw [← h], exact (sublist_append_right _ _).trans (sublist_append_left _ _) }

protected lemma is_prefix.sublist (h : l₁ <+: l₂) : l₁ <+ l₂ := h.is_infix.sublist
protected lemma is_suffix.sublist (h : l₁ <:+ l₂) : l₁ <+ l₂ := h.is_infix.sublist

@[simp] lemma reverse_suffix : reverse l₁ <:+ reverse l₂ ↔ l₁ <+: l₂ :=
⟨λ ⟨r, e⟩, ⟨reverse r,
  by rw [← reverse_reverse l₁, ← reverse_append, e, reverse_reverse]⟩,
 λ ⟨r, e⟩, ⟨reverse r, by rw [← reverse_append, e]⟩⟩

@[simp] lemma reverse_prefix : reverse l₁ <+: reverse l₂ ↔ l₁ <:+ l₂ :=
by rw ← reverse_suffix; simp only [reverse_reverse]

alias reverse_prefix ↔ _ list.is_suffix.reverse
alias reverse_suffix ↔ _ list.is_prefix.reverse

lemma infix.length_le (h : l₁ <:+: l₂) : length l₁ ≤ length l₂ := length_le_of_sublist h.sublist

lemma eq_nil_of_infix_nil (h : l <:+: []) : l = [] := eq_nil_of_sublist_nil h.sublist

@[simp] lemma infix_nil_iff : l <:+: [] ↔ l = [] :=
⟨λ h, eq_nil_of_sublist_nil h.sublist, λ h, h ▸ infix_rfl⟩

alias infix_nil_iff ↔ list.eq_nil_of_infix_nil _

@[simp] lemma prefix_nil_iff : l <+: [] ↔ l = [] :=
⟨λ h, eq_nil_of_infix_nil h.is_infix, λ h, h ▸ prefix_rfl⟩

@[simp] lemma suffix_nil_iff : l <:+ [] ↔ l = [] :=
⟨λ h, eq_nil_of_infix_nil h.is_infix, λ h, h ▸ suffix_rfl⟩

alias prefix_nil_iff ↔ list.eq_nil_of_prefix_nil _
alias suffix_nil_iff ↔ list.eq_nil_of_suffix_nil _

lemma infix_iff_prefix_suffix (l₁ l₂ : list α) : l₁ <:+: l₂ ↔ ∃ t, l₁ <+: t ∧ t <:+ l₂ :=
⟨λ ⟨s, t, e⟩, ⟨l₁ ++ t, ⟨_, rfl⟩, by rw [← e, append_assoc]; exact ⟨_, rfl⟩⟩,
  λ ⟨._, ⟨t, rfl⟩, s, e⟩, ⟨s, t, by rw append_assoc; exact e⟩⟩

lemma eq_of_infix_of_length_eq (h : l₁ <:+: l₂) : l₁.length = l₂.length → l₁ = l₂ :=
eq_of_sublist_of_length_eq h.sublist

lemma eq_of_prefix_of_length_eq (h : l₁ <+: l₂) : l₁.length = l₂.length → l₁ = l₂ :=
eq_of_sublist_of_length_eq h.sublist

lemma eq_of_suffix_of_length_eq (h : l₁ <:+ l₂) : l₁.length = l₂.length → l₁ = l₂ :=
eq_of_sublist_of_length_eq h.sublist

lemma prefix_of_prefix_length_le : ∀ {l₁ l₂ l₃ : list α},
  l₁ <+: l₃ → l₂ <+: l₃ → length l₁ ≤ length l₂ → l₁ <+: l₂
| []      l₂ l₃ h₁ h₂ _ := nil_prefix _
| (a :: l₁) (b :: l₂) _ ⟨r₁, rfl⟩ ⟨r₂, e⟩ ll := begin
  injection e with _ e', subst b,
  rcases prefix_of_prefix_length_le ⟨_, rfl⟩ ⟨_, e'⟩
    (le_of_succ_le_succ ll) with ⟨r₃, rfl⟩,
  exact ⟨r₃, rfl⟩
end

lemma prefix_or_prefix_of_prefix (h₁ : l₁ <+: l₃) (h₂ : l₂ <+: l₃) : l₁ <+: l₂ ∨ l₂ <+: l₁ :=
(le_total (length l₁) (length l₂)).imp
  (prefix_of_prefix_length_le h₁ h₂)
  (prefix_of_prefix_length_le h₂ h₁)

lemma suffix_of_suffix_length_le (h₁ : l₁ <:+ l₃) (h₂ : l₂ <:+ l₃) (ll : length l₁ ≤ length l₂) :
  l₁ <:+ l₂ :=
reverse_prefix.1 $ prefix_of_prefix_length_le
  (reverse_prefix.2 h₁) (reverse_prefix.2 h₂) (by simp [ll])

lemma suffix_or_suffix_of_suffix (h₁ : l₁ <:+ l₃) (h₂ : l₂ <:+ l₃) : l₁ <:+ l₂ ∨ l₂ <:+ l₁ :=
(prefix_or_prefix_of_prefix (reverse_prefix.2 h₁) (reverse_prefix.2 h₂)).imp
  reverse_prefix.1 reverse_prefix.1

lemma suffix_cons_iff : l₁ <:+ a :: l₂ ↔ l₁ = a :: l₂ ∨ l₁ <:+ l₂ :=
begin
  split,
  { rintro ⟨⟨hd, tl⟩, hl₃⟩,
    { exact or.inl hl₃ },
    { simp only [cons_append] at hl₃,
      exact or.inr ⟨_, hl₃.2⟩ } },
  { rintro (rfl | hl₁),
    { exact (a :: l₂).suffix_refl },
    { exact hl₁.trans (l₂.suffix_cons _) } }
end

lemma infix_of_mem_join : ∀ {L : list (list α)}, l ∈ L → l <:+: join L
| (_  :: L) (or.inl rfl) := infix_append [] _ _
| (l' :: L) (or.inr h)   := is_infix.trans (infix_of_mem_join h) $ (suffix_append _ _).is_infix

lemma prefix_append_right_inj (l) : l ++ l₁ <+: l ++ l₂ ↔ l₁ <+: l₂ :=
exists_congr $ λ r, by rw [append_assoc, append_right_inj]

lemma prefix_cons_inj (a) : a :: l₁ <+: a :: l₂ ↔ l₁ <+: l₂ := prefix_append_right_inj [a]

lemma take_prefix (n) (l : list α) : take n l <+: l := ⟨_, take_append_drop _ _⟩
lemma drop_suffix (n) (l : list α) : drop n l <:+ l := ⟨_, take_append_drop _ _⟩
lemma take_sublist (n) (l : list α) : take n l <+ l := (take_prefix n l).sublist
lemma drop_sublist (n) (l : list α) : drop n l <+ l := (drop_suffix n l).sublist
lemma take_subset (n) (l : list α) : take n l ⊆ l := (take_sublist n l).subset
lemma drop_subset (n) (l : list α) : drop n l ⊆ l := (drop_sublist n l).subset
lemma mem_of_mem_take (h : a ∈ l.take n) : a ∈ l := take_subset n l h
lemma mem_of_mem_drop (h : a ∈ l.drop n) : a ∈ l := drop_subset n l h

lemma init_prefix : ∀ (l : list α), l.init <+: l
| [] := ⟨nil, by rw [init, list.append_nil]⟩
| (a :: l) := ⟨_, init_append_last (cons_ne_nil a l)⟩

lemma tail_suffix (l : list α) : tail l <:+ l := by rw ← drop_one; apply drop_suffix

lemma init_sublist (l : list α) : l.init <+ l := (init_prefix l).sublist

lemma prefix_iff_eq_append : l₁ <+: l₂ ↔ l₁ ++ drop (length l₁) l₂ = l₂ :=
⟨by rintros ⟨r, rfl⟩; rw drop_left, λ e, ⟨_, e⟩⟩

lemma suffix_iff_eq_append : l₁ <:+ l₂ ↔ take (length l₂ - length l₁) l₂ ++ l₁ = l₂ :=
⟨by rintros ⟨r, rfl⟩; simp only [length_append, add_tsub_cancel_right, take_left], λ e, ⟨_, e⟩⟩

lemma prefix_iff_eq_take : l₁ <+: l₂ ↔ l₁ = take (length l₁) l₂ :=
⟨λ h, append_right_cancel $
  (prefix_iff_eq_append.1 h).trans (take_append_drop _ _).symm,
 λ e, e.symm ▸ take_prefix _ _⟩

lemma suffix_iff_eq_drop : l₁ <:+ l₂ ↔ l₁ = drop (length l₂ - length l₁) l₂ :=
⟨λ h, append_left_cancel $
  (suffix_iff_eq_append.1 h).trans (take_append_drop _ _).symm,
 λ e, e.symm ▸ drop_suffix _ _⟩

instance decidable_prefix [decidable_eq α] : ∀ (l₁ l₂ : list α), decidable (l₁ <+: l₂)
| []      l₂ := is_true ⟨l₂, rfl⟩
| (a :: l₁) [] := is_false $ λ ⟨t, te⟩, list.no_confusion te
| (a :: l₁) (b :: l₂) :=
  if h : a = b then
    @decidable_of_iff _ _ (by rw [← h, prefix_cons_inj])
      (decidable_prefix l₁ l₂)
  else
    is_false $ λ ⟨t, te⟩, h $ by injection te

-- Alternatively, use mem_tails
instance decidable_suffix [decidable_eq α] : ∀ (l₁ l₂ : list α), decidable (l₁ <:+ l₂)
| []      l₂ := is_true ⟨l₂, append_nil _⟩
| (a :: l₁) [] := is_false $ mt (length_le_of_sublist ∘ is_suffix.sublist) dec_trivial
| l₁      l₂ := let len1 := length l₁, len2 := length l₂ in
  if hl : len1 ≤ len2 then
    decidable_of_iff' (l₁ = drop (len2-len1) l₂) suffix_iff_eq_drop
  else is_false $ λ h, hl $ length_le_of_sublist $ h.sublist

lemma prefix_take_le_iff {L : list (list (option α))} (hm : m < L.length) :
  L.take m <+: L.take n ↔ m ≤ n :=
begin
  simp only [prefix_iff_eq_take, length_take],
  induction m with m IH generalizing L n,
  { simp only [min_eq_left, eq_self_iff_true, nat.zero_le, take] },
  cases L with l ls,
  { exact (not_lt_bot hm).elim },
  cases n,
  { refine iff_of_false _ (zero_lt_succ _).not_le,
    rw [take_zero, take_nil],
    simp only [take],
      exact not_false },
  { simp only [length] at hm,
    specialize @IH ls n (nat.lt_of_succ_lt_succ hm),
    simp only [le_of_lt (nat.lt_of_succ_lt_succ hm), min_eq_left] at IH,
    simp only [le_of_lt hm, IH, true_and, min_eq_left, eq_self_iff_true, length, take],
    exact ⟨nat.succ_le_succ, nat.le_of_succ_le_succ⟩ }
end

lemma cons_prefix_iff : a :: l₁ <+: b :: l₂ ↔ a = b ∧ l₁ <+: l₂ :=
begin
  split,
  { rintro ⟨L, hL⟩,
    simp only [cons_append] at hL,
    exact ⟨hL.left, ⟨L, hL.right⟩⟩ },
  { rintro ⟨rfl, h⟩,
    rwa [prefix_cons_inj] }
end

lemma is_prefix.map (h : l₁ <+: l₂) (f : α → β) : l₁.map f <+: l₂.map f :=
begin
  induction l₁ with hd tl hl generalizing l₂,
  { simp only [nil_prefix, map_nil] },
  { cases l₂ with hd₂ tl₂,
    { simpa only using eq_nil_of_prefix_nil h },
    { rw cons_prefix_iff at h,
      simp only [h, prefix_cons_inj, hl, map] } }
end

lemma is_prefix.filter_map (h : l₁ <+: l₂) (f : α → option β) :
  l₁.filter_map f <+: l₂.filter_map f :=
begin
  induction l₁ with hd₁ tl₁ hl generalizing l₂,
  { simp only [nil_prefix, filter_map_nil] },
  { cases l₂ with hd₂ tl₂,
    { simpa only using eq_nil_of_prefix_nil h },
    { rw cons_prefix_iff at h,
      rw [←@singleton_append _ hd₁ _, ←@singleton_append _ hd₂ _, filter_map_append,
         filter_map_append, h.left, prefix_append_right_inj],
      exact hl h.right } }
end

lemma is_prefix.reduce_option {l₁ l₂ : list (option α)} (h : l₁ <+: l₂) :
  l₁.reduce_option <+: l₂.reduce_option :=
h.filter_map id

lemma is_prefix.filter (p : α → Prop) [decidable_pred p] ⦃l₁ l₂ : list α⦄ (h : l₁ <+: l₂) :
  l₁.filter p <+: l₂.filter p :=
begin
  obtain ⟨xs, rfl⟩ := h,
  rw filter_append,
  exact prefix_append _ _
end

lemma is_suffix.filter (p : α → Prop) [decidable_pred p] ⦃l₁ l₂ : list α⦄ (h : l₁ <:+ l₂) :
  l₁.filter p <:+ l₂.filter p :=
begin
  obtain ⟨xs, rfl⟩ := h,
  rw filter_append,
  exact suffix_append _ _
end

lemma is_infix.filter (p : α → Prop) [decidable_pred p] ⦃l₁ l₂ : list α⦄ (h : l₁ <:+: l₂) :
  l₁.filter p <:+: l₂.filter p :=
begin
  obtain ⟨xs, ys, rfl⟩ := h,
  rw [filter_append, filter_append],
  exact infix_append _ _ _
end

end fix

section inits_tails

@[simp] lemma mem_inits : ∀ (s t : list α), s ∈ inits t ↔ s <+: t
| s []     := suffices s = nil ↔ s <+: nil, by simpa only [inits, mem_singleton],
  ⟨λ h, h.symm ▸ prefix_refl [], eq_nil_of_prefix_nil⟩
| s (a :: t) :=
  suffices (s = nil ∨ ∃ l ∈ inits t, a :: l = s) ↔ s <+: a :: t, by simpa,
  ⟨λ o, match s, o with
  | ._, or.inl rfl := ⟨_, rfl⟩
  | s, or.inr ⟨r, hr, hs⟩ := let ⟨s, ht⟩ := (mem_inits _ _).1 hr in
    by rw [← hs, ← ht]; exact ⟨s, rfl⟩
  end, λ mi, match s, mi with
  | [], ⟨._, rfl⟩ := or.inl rfl
  | (b :: s), ⟨r, hr⟩ := list.no_confusion hr $ λ ba (st : s++r = t), or.inr $
    by rw ba; exact ⟨_, (mem_inits _ _).2 ⟨_, st⟩, rfl⟩
  end⟩

@[simp] lemma mem_tails : ∀ (s t : list α), s ∈ tails t ↔ s <:+ t
| s []     := by simp only [tails, mem_singleton];
  exact ⟨λ h, by rw h; exact suffix_refl [], eq_nil_of_suffix_nil⟩
| s (a :: t) := by simp only [tails, mem_cons_iff, mem_tails s t];
  exact show s = a :: t ∨ s <:+ t ↔ s <:+ a :: t, from
  ⟨λ o, match s, t, o with
  | ._, t, or.inl rfl := suffix_rfl
  | s, ._, or.inr ⟨l, rfl⟩ := ⟨a :: l, rfl⟩
  end, λ e, match s, t, e with
  | ._, t, ⟨[], rfl⟩ := or.inl rfl
  | s, t, ⟨b :: l, he⟩ := list.no_confusion he (λ ab lt, or.inr ⟨l, lt⟩)
  end⟩

lemma inits_cons (a : α) (l : list α) : inits (a :: l) = [] :: l.inits.map (λ t, a :: t) := by simp
lemma tails_cons (a : α) (l : list α) : tails (a :: l) = (a :: l) :: l.tails := by simp

@[simp]
lemma inits_append : ∀ (s t : list α), inits (s ++ t) = s.inits ++ t.inits.tail.map (λ l, s ++ l)
| [] [] := by simp
| [] (a :: t) := by simp
| (a :: s) t := by simp [inits_append s t]

@[simp]
lemma tails_append : ∀ (s t : list α), tails (s ++ t) = s.tails.map (λ l, l ++ t) ++ t.tails.tail
| [] [] := by simp
| [] (a :: t) := by simp
| (a :: s) t := by simp [tails_append s t]

-- the lemma names `inits_eq_tails` and `tails_eq_inits` are like `sublists_eq_sublists'`
lemma inits_eq_tails : ∀ (l : list α), l.inits = (reverse $ map reverse $ tails $ reverse l)
| [] := by simp
| (a :: l) := by simp [inits_eq_tails l, map_eq_map_iff]

lemma tails_eq_inits : ∀ (l : list α), l.tails = (reverse $ map reverse $ inits $ reverse l)
| [] := by simp
| (a :: l) := by simp [tails_eq_inits l, append_left_inj]

lemma inits_reverse (l : list α) : inits (reverse l) = reverse (map reverse l.tails) :=
by { rw tails_eq_inits l, simp [reverse_involutive.comp_self] }

lemma tails_reverse (l : list α) : tails (reverse l) = reverse (map reverse l.inits) :=
by { rw inits_eq_tails l, simp [reverse_involutive.comp_self] }

lemma map_reverse_inits (l : list α) : map reverse l.inits = (reverse $ tails $ reverse l) :=
by { rw inits_eq_tails l, simp [reverse_involutive.comp_self] }

lemma map_reverse_tails (l : list α) : map reverse l.tails = (reverse $ inits $ reverse l) :=
by { rw tails_eq_inits l, simp [reverse_involutive.comp_self] }

@[simp] lemma length_tails (l : list α) : length (tails l) = length l + 1 :=
begin
  induction l with x l IH,
  { simp },
  { simpa using IH }
end

@[simp] lemma length_inits (l : list α) : length (inits l) = length l + 1 :=
by simp [inits_eq_tails]

@[simp] lemma nth_le_tails (l : list α) (n : ℕ) (hn : n < length (tails l)) :
  nth_le (tails l) n hn = l.drop n :=
begin
  induction l with x l IH generalizing n,
  { simp },
  { cases n,
    { simp },
    { simpa using IH n _ } }
end

@[simp] lemma nth_le_inits (l : list α) (n : ℕ) (hn : n < length (inits l)) :
  nth_le (inits l) n hn = l.take n :=
begin
  induction l with x l IH generalizing n,
  { simp },
  { cases n,
    { simp },
    { simpa using IH n _ } }
end

instance decidable_infix [decidable_eq α] : ∀ (l₁ l₂ : list α), decidable (l₁ <:+: l₂)
| []        l₂ := is_true ⟨[], l₂, rfl⟩
| (a :: l₁) [] := is_false $ λ ⟨s, t, te⟩, absurd te $ append_ne_nil_of_ne_nil_left _ _ $
                append_ne_nil_of_ne_nil_right _ _ $ λ h, list.no_confusion h
| l₁        l₂ := decidable_of_decidable_of_iff (list.decidable_bex (λ t, l₁ <+: t) (tails l₂)) $
  by refine (exists_congr (λ t, _)).trans (infix_iff_prefix_suffix _ _).symm;
     exact ⟨λ ⟨h1, h2⟩, ⟨h2, (mem_tails _ _).1 h1⟩, λ ⟨h2, h1⟩, ⟨(mem_tails _ _).2 h1, h2⟩⟩

end inits_tails

/-! ### insert -/

section insert
variable [decidable_eq α]

@[simp] lemma insert_nil (a : α) : insert a nil = [a] := rfl

lemma insert.def (a : α) (l : list α) : insert a l = if a ∈ l then l else a :: l := rfl

@[simp, priority 980]
lemma insert_of_mem (h : a ∈ l) : insert a l = l := by simp only [insert.def, if_pos h]

@[simp, priority 970]
lemma insert_of_not_mem (h : a ∉ l) : insert a l = a :: l :=
by simp only [insert.def, if_neg h]; split; refl

@[simp] lemma mem_insert_iff : a ∈ insert b l ↔ a = b ∨ a ∈ l :=
begin
  by_cases h' : b ∈ l,
  { simp only [insert_of_mem h'],
    apply (or_iff_right_of_imp _).symm,
    exact λ e, e.symm ▸ h' },
  { simp only [insert_of_not_mem h', mem_cons_iff] }
end

@[simp] lemma suffix_insert (a : α) (l : list α) : l <:+ insert a l :=
by by_cases a ∈ l; [simp only [insert_of_mem h], simp only [insert_of_not_mem h, suffix_cons]]

lemma infix_insert (a : α) (l : list α) : l <:+: insert a l := (suffix_insert a l).is_infix
lemma sublist_insert (a : α) (l : list α) : l <+  l.insert a := (suffix_insert a l).sublist
lemma subset_insert (a : α) (l : list α) : l ⊆ l.insert a := (sublist_insert a l).subset

@[simp] lemma mem_insert_self (a : α) (l : list α) : a ∈  l.insert a :=
mem_insert_iff.2 $ or.inl rfl

lemma mem_insert_of_mem (h : a ∈ l) : a ∈ insert b l := mem_insert_iff.2 (or.inr h)

lemma eq_or_mem_of_mem_insert (h : a ∈ insert b l) : a = b ∨ a ∈ l := mem_insert_iff.1 h

@[simp] lemma length_insert_of_mem (h : a ∈ l) : (insert a l).length = l.length :=
congr_arg _ $ insert_of_mem h

@[simp] lemma length_insert_of_not_mem (h : a ∉ l) : (insert a l).length = l.length + 1 :=
congr_arg _ $ insert_of_not_mem h

end insert
end list


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

! This file was ported from Lean 3 source module algebra.lie.base_change
! 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.Algebra.Algebra.RestrictScalars
import Mathbin.Algebra.Lie.TensorProduct

/-!
# Extension and restriction of scalars for Lie algebras

Lie algebras have a well-behaved theory of extension and restriction of scalars.

## Main definitions

 * `lie_algebra.extend_scalars.lie_algebra`
 * `lie_algebra.restrict_scalars.lie_algebra`

## Tags

lie ring, lie algebra, extension of scalars, restriction of scalars, base change
-/

universe u v w w₁ w₂ w₃

open TensorProduct

variable (R : Type u) (A : Type w) (L : Type v)

namespace LieAlgebra

namespace ExtendScalars

variable [CommRing R] [CommRing A] [Algebra R A] [LieRing L] [LieAlgebra R L]

/-- The Lie bracket on the extension of a Lie algebra `L` over `R` by an algebra `A` over `R`.

In fact this bracket is fully `A`-bilinear but without a significant upgrade to our mixed-scalar
support in the tensor product library, it is far easier to bootstrap like this, starting with the
definition below. -/
private def bracket' : A ⊗[R] L →ₗ[R] A ⊗[R] L →ₗ[R] A ⊗[R] L :=
  TensorProduct.curry <|
    TensorProduct.map (LinearMap.mul' R _) (LieModule.toModuleHom R L L : L ⊗[R] L →ₗ[R] L) ∘ₗ
      ↑(TensorProduct.tensorTensorTensorComm R A L A L)
#align lie_algebra.extend_scalars.bracket' lie_algebra.extend_scalars.bracket'

@[simp]
private theorem bracket'_tmul (s t : A) (x y : L) :
    bracket' R A L (s ⊗ₜ[R] x) (t ⊗ₜ[R] y) = (s * t) ⊗ₜ ⁅x, y⁆ := by simp [bracket']
#align lie_algebra.extend_scalars.bracket'_tmul lie_algebra.extend_scalars.bracket'_tmul

instance : Bracket (A ⊗[R] L) (A ⊗[R] L) where bracket x y := bracket' R A L x y

private theorem bracket_def (x y : A ⊗[R] L) : ⁅x, y⁆ = bracket' R A L x y :=
  rfl
#align lie_algebra.extend_scalars.bracket_def lie_algebra.extend_scalars.bracket_def

@[simp]
theorem bracket_tmul (s t : A) (x y : L) : ⁅s ⊗ₜ[R] x, t ⊗ₜ[R] y⁆ = (s * t) ⊗ₜ ⁅x, y⁆ := by
  rw [bracket_def, bracket'_tmul]
#align lie_algebra.extend_scalars.bracket_tmul LieAlgebra.ExtendScalars.bracket_tmul

private theorem bracket_lie_self (x : A ⊗[R] L) : ⁅x, x⁆ = 0 :=
  by
  simp only [bracket_def]
  apply x.induction_on
  · simp only [LinearMap.map_zero, eq_self_iff_true, LinearMap.zero_apply]
  · intro a l
    simp only [bracket'_tmul, TensorProduct.tmul_zero, eq_self_iff_true, lie_self]
  · intro z₁ z₂ h₁ h₂
    suffices bracket' R A L z₁ z₂ + bracket' R A L z₂ z₁ = 0 by
      rw [LinearMap.map_add, LinearMap.map_add, LinearMap.add_apply, LinearMap.add_apply, h₁, h₂,
        zero_add, add_zero, add_comm, this]
    apply z₁.induction_on
    · simp only [LinearMap.map_zero, add_zero, LinearMap.zero_apply]
    · intro a₁ l₁
      apply z₂.induction_on
      · simp only [LinearMap.map_zero, add_zero, LinearMap.zero_apply]
      · intro a₂ l₂
        simp only [← lie_skew l₂ l₁, mul_comm a₁ a₂, TensorProduct.tmul_neg, bracket'_tmul,
          add_right_neg]
      · intro y₁ y₂ hy₁ hy₂
        simp only [hy₁, hy₂, add_add_add_comm, add_zero, LinearMap.add_apply, LinearMap.map_add]
    · intro y₁ y₂ hy₁ hy₂
      simp only [add_add_add_comm, hy₁, hy₂, add_zero, LinearMap.add_apply, LinearMap.map_add]
#align lie_algebra.extend_scalars.bracket_lie_self lie_algebra.extend_scalars.bracket_lie_self

private theorem bracket_leibniz_lie (x y z : A ⊗[R] L) : ⁅x, ⁅y, z⁆⁆ = ⁅⁅x, y⁆, z⁆ + ⁅y, ⁅x, z⁆⁆ :=
  by
  simp only [bracket_def]
  apply x.induction_on
  · simp only [LinearMap.map_zero, add_zero, eq_self_iff_true, LinearMap.zero_apply]
  · intro a₁ l₁
    apply y.induction_on
    · simp only [LinearMap.map_zero, add_zero, eq_self_iff_true, LinearMap.zero_apply]
    · intro a₂ l₂
      apply z.induction_on
      · simp only [LinearMap.map_zero, add_zero]
      · intro a₃ l₃
        simp only [bracket'_tmul]
        rw [mul_left_comm a₂ a₁ a₃, mul_assoc, leibniz_lie, TensorProduct.tmul_add]
      · intro u₁ u₂ h₁ h₂
        simp only [add_add_add_comm, h₁, h₂, LinearMap.map_add]
    · intro u₁ u₂ h₁ h₂
      simp only [add_add_add_comm, h₁, h₂, LinearMap.add_apply, LinearMap.map_add]
  · intro u₁ u₂ h₁ h₂
    simp only [add_add_add_comm, h₁, h₂, LinearMap.add_apply, LinearMap.map_add]
#align lie_algebra.extend_scalars.bracket_leibniz_lie lie_algebra.extend_scalars.bracket_leibniz_lie

instance : LieRing (A ⊗[R] L)
    where
  add_lie x y z := by simp only [bracket_def, LinearMap.add_apply, LinearMap.map_add]
  lie_add x y z := by simp only [bracket_def, LinearMap.map_add]
  lie_self := bracket_lie_self R A L
  leibniz_lie := bracket_leibniz_lie R A L

private theorem bracket_lie_smul (a : A) (x y : A ⊗[R] L) : ⁅x, a • y⁆ = a • ⁅x, y⁆ :=
  by
  apply x.induction_on
  · simp only [zero_lie, smul_zero]
  · intro a₁ l₁
    apply y.induction_on
    · simp only [lie_zero, smul_zero]
    · intro a₂ l₂
      simp only [bracket_def, bracket', TensorProduct.smul_tmul', mul_left_comm a₁ a a₂,
        TensorProduct.curry_apply, LinearMap.mul'_apply, Algebra.id.smul_eq_mul,
        Function.comp_apply, LinearEquiv.coe_coe, LinearMap.coe_comp, TensorProduct.map_tmul,
        TensorProduct.tensorTensorTensorComm_tmul]
    · intro z₁ z₂ h₁ h₂
      simp only [h₁, h₂, smul_add, lie_add]
  · intro z₁ z₂ h₁ h₂
    simp only [h₁, h₂, smul_add, add_lie]
#align lie_algebra.extend_scalars.bracket_lie_smul lie_algebra.extend_scalars.bracket_lie_smul

instance lieAlgebra : LieAlgebra A (A ⊗[R] L) where lie_smul := bracket_lie_smul R A L
#align lie_algebra.extend_scalars.lie_algebra LieAlgebra.ExtendScalars.lieAlgebra

end ExtendScalars

namespace RestrictScalars

open RestrictScalars

variable [h : LieRing L]

include h

instance : LieRing (RestrictScalars R A L) :=
  h

variable [CommRing A] [LieAlgebra A L]

instance lieAlgebra [CommRing R] [Algebra R A] : LieAlgebra R (RestrictScalars R A L)
    where lie_smul t x y :=
    (lie_smul (algebraMap R A t) (RestrictScalars.addEquiv R A L x)
        (RestrictScalars.addEquiv R A L y) :
      _)
#align lie_algebra.restrict_scalars.lie_algebra LieAlgebra.RestrictScalars.lieAlgebra

end RestrictScalars

end LieAlgebra


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

! This file was ported from Lean 3 source module algebra.hierarchy_design
! leanprover-community/mathlib commit 448144f7ae193a8990cb7473c9e9a01990f64ac7
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Tactic.DocCommands

/-!
# Documentation of the algebraic hierarchy

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

A library note giving advice on modifying the algebraic hierarchy.
(It is not intended as a "tour".)

TODO: Add sections about interactions with topological typeclasses, and order typeclasses.

-/

library_note "the algebraic hierarchy"/-- # The algebraic hierarchy

In any theorem proving environment,
there are difficult decisions surrounding the design of the "algebraic hierarchy".

There is a danger of exponential explosion in the number of gadgets,
especially once interactions between algebraic and order/topological/etc structures are considered.

In mathlib, we try to avoid this by only introducing new algebraic typeclasses either
1. when there is "real mathematics" to be done with them, or
2. when there is a meaninful gain in simplicity by factoring out a common substructure.

(As examples, at this point we don't have `loop`, or `unital_magma`,
but we do have `lie_submodule` and `topological_field`!
We also have `group_with_zero`, as an exemplar of point 2.)

Generally in mathlib we use the extension mechanism (so `comm_ring` extends `ring`)
rather than mixins (e.g. with separate `ring` and `comm_mul` classes),
in part because of the potential blow-up in term sizes described at
https://www.ralfj.de/blog/2019/05/15/typeclasses-exponential-blowup.html
However there is tension here, as it results in considerable duplication in the API,
particularly in the interaction with order structures.

This library note is not intended as a design document
justifying and explaining the history of mathlib's algebraic hierarchy!
Instead it is intended as a developer's guide, for contributors wanting to extend
(either new leaves, or new intermediate classes) the algebraic hierarchy as it exists.

(Ideally we would have both a tour guide to the existing hierarchy,
and an account of the design choices.
See https://arxiv.org/abs/1910.09336 for an overview of mathlib as a whole,
with some attention to the algebraic hierarchy and
https://leanprover-community.github.io/mathlib-overview.html
for a summary of what is in mathlib today.)

## Instances

When adding a new typeclass `Z` to the algebraic hierarchy
one should attempt to add the following constructions and results,
when applicable:

* Instances transferred elementwise to products, like `prod.monoid`.
  See `algebra.group.prod` for more examples.
  ```
  instance prod.Z [Z M] [Z N] : Z (M × N) := ...
  ```
* Instances transferred elementwise to pi types, like `pi.monoid`.
  See `algebra.group.pi` for more examples.
  ```
  instance pi.Z [∀ i, Z $ f i] : Z (Π i : I, f i) := ...
  ```
* Instances transferred to `mul_opposite M`, like `mul_opposite.monoid`.
  See `algebra.opposites` for more examples.
  ```
  instance mul_opposite.Z [Z M] : Z (mul_opposite M) := ...
  ```
* Instances transferred to `ulift M`, like `ulift.monoid`.
  See `algebra.group.ulift` for more examples.
  ```
  instance ulift.Z [Z M] : Z (ulift M) := ...
  ```
* Definitions for transferring the proof fields of instances along
  injective or surjective functions that agree on the data fields,
  like `function.injective.monoid` and `function.surjective.monoid`.
  We make these definitions `@[reducible]`, see note [reducible non-instances].
  See `algebra.group.inj_surj` for more examples.
  ```
  @[reducible]
  def function.injective.Z [Z M₂] (f : M₁ → M₂) (hf : injective f)
    (one : f 1 = 1) (mul : ∀ x y, f (x * y) = f x * f y) : Z M₁ := ...

  @[reducible]
  def function.surjective.Z [Z M₁] (f : M₁ → M₂) (hf : surjective f)
    (one : f 1 = 1) (mul : ∀ x y, f (x * y) = f x * f y) : Z M₂ := ...
  ```
* Instances transferred elementwise to `finsupp`s, like `finsupp.semigroup`.
  See `data.finsupp.pointwise` for more examples.
  ```
  instance finsupp.Z [Z β] : Z (α →₀ β) := ...
  ```
* Instances transferred elementwise to `set`s, like `set.monoid`.
  See `algebra.pointwise` for more examples.
  ```
  instance set.Z [Z α] : Z (set α) := ...
  ```
* Definitions for transferring the entire structure across an equivalence, like `equiv.monoid`.
  See `data.equiv.transfer_instance` for more examples. See also the `transport` tactic.
  ```
  def equiv.Z (e : α ≃ β) [Z β] : Z α := ...
  /- When there is a new notion of `Z`-equiv: -/
  def equiv.Z_equiv (e : α ≃ β) [Z β] : by { letI := equiv.Z e, exact α ≃Z β } := ...
  ```

## Subobjects

When a new typeclass `Z` adds new data fields,
you should also create a new `sub_Z` `structure` with a `carrier` field.

This can be a lot of work; for now try to closely follow the existing examples
(e.g. `submonoid`, `subring`, `subalgebra`).
We would very much like to provide some automation here, but a prerequisite will be making
all the existing APIs more uniform.

If `Z` extends `Y`, then `sub_Z` should usually extend `sub_Y`.

When `Z` adds only new proof fields to an existing structure `Y`,
you should provide instances transferring
`Z α` to `Z (sub_Y α)`, like `submonoid.to_comm_monoid`.
Typically this is done using the `function.injective.Z` definition mentioned above.
```
instance sub_Y.to_Z [Z α] : Z (sub_Y α) :=
coe_injective.Z coe ...
```

## Morphisms and equivalences

## Category theory

For many algebraic structures, particularly ones used in representation theory, algebraic geometry,
etc., we also define "bundled" versions, which carry `category` instances.

These bundled versions are usually named in camel case,
so for example we have `AddCommGroup` as a bundled `add_comm_group`,
and `TopCommRing` (which bundles together `comm_ring`, `topological_space`, and `topological_ring`).

These bundled versions have many appealing features:
* a uniform notation for morphisms `X ⟶ Y`
* a uniform notation (and definition) for isomorphisms `X ≅ Y`
* a uniform API for subobjects, via the partial order `subobject X`
* interoperability with unbundled structures, via coercions to `Type`
  (so if `G : AddCommGroup`, you can treat `G` as a type,
  and it automatically has an `add_comm_group` instance)
  and lifting maps `AddCommGroup.of G`, when `G` is a type with an `add_comm_group` instance.

If, for example you do the work of proving that a typeclass `Z` has a good notion of tensor product,
you are strongly encouraged to provide the corresponding `monoidal_category` instance
on a bundled version.
This ensures that the API for tensor products is complete, and enables use of general machinery.
Similarly if you prove universal properties, or adjunctions, you are encouraged to state these
using categorical language!

One disadvantage of the bundled approach is that we can only speak of morphisms between
objects living in the same type-theoretic universe.
In practice this is rarely a problem.

# Making a pull request

With so many moving parts, how do you actually go about changing the algebraic hierarchy?

We're still evolving how to handle this, but the current suggestion is:

* If you're adding a new "leaf" class, the requirements are lower,
  and an initial PR can just add whatever is immediately needed.
* A new "intermediate" class, especially low down in the hierarchy,
  needs to be careful about leaving gaps.

In a perfect world, there would be a group of simultaneous PRs that basically cover everything!
(Or at least an expectation that PRs may not be merged immediately while waiting on other
PRs that fill out the API.)

However "perfect is the enemy of good", and it would also be completely reasonable
to add a TODO list in the main module doc-string for the new class,
briefly listing the parts of the API which still need to be provided.
Hopefully this document makes it easy to assemble this list.

Another alternative to a TODO list in the doc-strings is adding github issues.

-/

library_note "reducible non-instances"/--
Some definitions that define objects of a class cannot be instances, because they have an
explicit argument that does not occur in the conclusion. An example is `preorder.lift` that has a
function `f : α → β` as an explicit argument to lift a preorder on `β` to a preorder on `α`.

If these definitions are used to define instances of this class *and* this class is an argument to
some other type-class so that type-class inference will have to unfold these instances to check
for definitional equality, then these definitions should be marked `@[reducible]`.

For example, `preorder.lift` is used to define `units.preorder` and `partial_order.lift` is used
to define `units.partial_order`. In some cases it is important that type-class inference can
recognize that `units.preorder` and `units.partial_order` give rise to the same `has_le` instance.
For example, you might have another class that takes `[has_le α]` as an argument, and this argument
sometimes comes from `units.preorder` and sometimes from `units.partial_order`.
Therefore, `preorder.lift` and `partial_order.lift` are marked `@[reducible]`.
-/