/-
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 Jannis Limperg. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jannis Limperg
-/

import Aesop
import Lean

open Aesop
open Lean
open Lean.Meta
open Lean.Elab.Tactic

set_option aesop.check.all true

/-! # Unit tests for the MetaM tactic that implements forward rules -/

syntax (name := forward) &"forward" ident ("[" ident* "]")? : tactic
syntax (name := elim)    &"elim"    ident ("[" ident* "]")? : tactic

def forwardTac (goal : MVarId) (id : Syntax) (immediate : Option (Array Syntax))
    (clear : Bool) : MetaM (List MVarId) := do
  let userName := id.getId
  let ldecl ← getLocalDeclFromUserName userName
  let immediate ← RuleBuilder.getImmediatePremises userName ldecl.type
    (immediate.map (·.map (·.getId)))
  let (goal, _) ←
    RuleTac.applyForwardRule goal (mkFVar ldecl.fvarId) immediate clear
      (generateScript := false)
  return [goal]

@[tactic forward]
def evalForward : Tactic
  | `(tactic| forward $t:ident $[[ $immediate:ident* ]]?) =>
    liftMetaTactic λ goal => forwardTac goal t immediate (clear := false)
  | _ => unreachable!

@[tactic elim]
def evalElim : Tactic
  | `(tactic| elim $t:ident $[[ $immediate:ident* ]]?) =>
    liftMetaTactic λ goal => forwardTac goal t immediate (clear := true)
  | _ => unreachable!

example (rule : (a : α) → (b : β) → γ) (h₁ : α) (h₂ : β) : γ := by
  forward rule [a b]
  assumption

set_option linter.unusedVariables false in
example {P Q R : α → Type} (rule : ∀ a (p : P a) (q : Q a), R a)
    (h₁ : P a) (h₁' : P a) (h₂ : Q a) (h₃ : P b) (h₄ : Q c) : R a := by
  forward rule [p q]
  assumption

set_option linter.unusedVariables false in
example {P Q R : α → Type} (rule : ∀ a (p : P a) (q : Q a), R a)
    (h₁ : P a) (h₁' : P a) (h₂ : Q a) (h₃ : P b) (h₄ : Q c) : R a := by
  forward rule
  assumption

example {P Q R : α → Type} (rule : ∀ a (p : P a) (q : Q a), R a)
    (h₁ : P a) (h₂ : P b) : (Q a → R a) × (Q b → R b) := by
  forward rule [p]
  exact (by assumption, by assumption)

example (rule : ∀ α β, α ∧ β → α) (h : P ∧ Q ∧ R) : P := by
  elim rule
  assumption

/-! # End-to-end tests -/

example (a : α) (b : β) (r₁ : (a : α) → (b : β) → γ₁ ∧ γ₂)
    (r₂ : (a : α) → δ₁ ∧ δ₂) : γ₁ ∧ γ₂ ∧ δ₁ ∧ δ₂ := by
  aesop (add safe [forward r₁, (forward (immediate := [a])) r₂])

example (a : α) (b : β) (r₁ : (a : α) → (b : β) → γ₁ ∧ γ₂)
    (r₂ : (a : α) → δ₁ ∧ δ₂) : γ₁ ∧ γ₂ ∧ δ₁ ∧ δ₂ := by
  fail_if_success
    aesop (add safe [destruct r₁, (destruct (immediate := [a])) r₂])
      (options := { terminal := true })
  aesop (add safe [forward r₁], 90% destruct r₂)