/-
Copyright (c) 2020 Jannis Limperg. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jannis Limperg

! This file was ported from Lean 3 source module data.list.indexes
! leanprover-community/mathlib commit 8631e2d5ea77f6c13054d9151d82b83069680cb1
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Data.List.OfFn
import Mathlib.Data.List.Range

/-!
# Lemmas about List.*Idx functions.

Some specification lemmas for `List.mapIdx`, `List.mapIdxM`, `List.foldlIdx` and `List.foldrIdx`.
-/

universe u v

open Function

namespace List

variable {α : Type u} {β : Type v}

section MapIdx

-- Porting note: Add back old definition because it's easier for writing proofs.

/-- Lean3 `map_with_index` helper function -/
protected def oldMapIdxCore (f : ℕ → α → β) : ℕ → List α → List β
  | _, []      => []
  | k, a :: as => f k a :: List.oldMapIdxCore f (k + 1) as

/-- Given a function `f : ℕ → α → β` and `as : List α`, `as = [a₀, a₁, ...]`, returns the list
`[f 0 a₀, f 1 a₁, ...]`. -/
protected def oldMapIdx (f : ℕ → α → β) (as : List α) : List β :=
  List.oldMapIdxCore f 0 as

@[simp]
theorem mapIdx_nil {α β} (f : ℕ → α → β) : mapIdx f [] = [] :=
  rfl
#align list.map_with_index_nil List.mapIdx_nil

-- Porting note: new theorem.
protected theorem oldMapIdxCore_eq (l : List α) (f : ℕ → α → β) (n : ℕ) :
    l.oldMapIdxCore f n = l.oldMapIdx fun i a ↦ f (i + n) a := by
  induction' l with hd tl hl generalizing f n
  · rfl
  · rw [List.oldMapIdx]
    simp only [List.oldMapIdxCore, hl, add_left_comm, add_comm, add_zero, zero_add]
#noalign list.map_with_index_core_eq

-- Porting note: convert new definition to old definition.
--   A few new theorems are added to achieve this
--   1. Prove that `oldMapIdxCore f (l ++ [e]) = oldMapIdxCore f l ++ [f l.length e]`
--   2. Prove that `oldMapIdx f (l ++ [e]) = oldMapIdx f l ++ [f l.length e]`
--   3. Prove list induction using `∀ l e, p [] → (p l → p (l ++ [e])) → p l`
-- Porting note: new theorem.
theorem list_reverse_induction (p : List α → Prop) (base : p [])
    (ind : ∀ (l : List α) (e : α), p l → p (l ++ [e])) : (∀ (l : List α), p l) := by
  let q := fun l ↦ p (reverse l)
  have pq : ∀ l, p (reverse l) → q l := by simp only [reverse_reverse]; intro; exact id
  have qp : ∀ l, q (reverse l) → p l := by simp only [reverse_reverse]; intro; exact id
  intro l
  apply qp
  generalize (reverse l) = l
  induction' l with head tail ih
  · apply pq; simp only [reverse_nil, base]
  · apply pq; simp only [reverse_cons]; apply ind; apply qp; rw [reverse_reverse]; exact ih

-- Porting note: new theorem.
protected theorem oldMapIdxCore_append : ∀ (f : ℕ → α → β) (n : ℕ) (l₁ l₂ : List α),
    List.oldMapIdxCore f n (l₁ ++ l₂) =
    List.oldMapIdxCore f n l₁ ++ List.oldMapIdxCore f (n + l₁.length) l₂ := by
  intros f n l₁ l₂
  generalize e : (l₁ ++ l₂).length = len
  revert n l₁ l₂
  induction' len with len ih <;> intros n l₁ l₂ h
  · have l₁_nil : l₁ = [] := by cases l₁; rfl; contradiction
    have l₂_nil : l₂ = [] := by cases l₂; rfl; rw [List.length_append] at h; contradiction
    simp only [l₁_nil, l₂_nil]; rfl
  · cases' l₁ with head tail
    · rfl
    · simp only [List.oldMapIdxCore, List.append_eq, length_cons, cons_append,cons.injEq, true_and]
      suffices : n + Nat.succ (length tail) = n + 1 + tail.length
      { rw [this]
        apply ih (n + 1) _ _ _
        simp only [cons_append, length_cons, length_append, Nat.succ.injEq] at h
        simp only [length_append, h] }
      { rw [Nat.add_assoc]; simp only [Nat.add_comm] }

-- Porting note: new theorem.
protected theorem oldMapIdx_append : ∀ (f : ℕ → α → β) (l : List α) (e : α),
    List.oldMapIdx f (l ++ [e]) = List.oldMapIdx f l ++ [f l.length e] := by
  intros f l e
  unfold List.oldMapIdx
  rw [List.oldMapIdxCore_append f 0 l [e]]
  simp only [zero_add, append_cancel_left_eq]; rfl

-- Porting note: new theorem.
theorem mapIdxGo_append : ∀ (f : ℕ → α → β) (l₁ l₂ : List α) (arr : Array β),
    mapIdx.go f (l₁ ++ l₂) arr = mapIdx.go f l₂ (List.toArray (mapIdx.go f l₁ arr)) := by
  intros f l₁ l₂ arr
  generalize e : (l₁ ++ l₂).length = len
  revert l₁ l₂ arr
  induction' len with len ih <;> intros l₁ l₂ arr h
  · have l₁_nil : l₁ = [] := by cases l₁; rfl; contradiction
    have l₂_nil : l₂ = [] := by cases l₂; rfl; rw [List.length_append] at h; contradiction
    rw [l₁_nil, l₂_nil]; simp only [mapIdx.go, Array.toList_eq, Array.toArray_data]
  · cases' l₁ with head tail <;> simp only [mapIdx.go]
    · simp only [nil_append, Array.toList_eq, Array.toArray_data]
    · simp only [List.append_eq]
      rw [ih]
      · simp only [cons_append, length_cons, length_append, Nat.succ.injEq] at h
        simp only [length_append, h]

-- Porting note: new theorem.
theorem mapIdxGo_length : ∀ (f : ℕ → α → β) (l : List α) (arr : Array β),
    length (mapIdx.go f l arr) = length l + arr.size := by
  intro f l
  induction' l with head tail ih
  · intro; simp only [mapIdx.go, Array.toList_eq, length_nil, zero_add]
  · intro; simp only [mapIdx.go]; rw [ih]; simp only [Array.size_push, length_cons];
    simp only [Nat.add_succ, add_zero, Nat.add_comm]

-- Porting note: new theorem.
theorem mapIdx_append_one : ∀ (f : ℕ → α → β) (l : List α) (e : α),
    mapIdx f (l ++ [e]) = mapIdx f l ++ [f l.length e] := by
  intros f l e
  unfold mapIdx
  rw [mapIdxGo_append f l [e]]
  simp only [mapIdx.go, Array.size_toArray, mapIdxGo_length, length_nil, add_zero, Array.toList_eq,
    Array.push_data, Array.data_toArray]

-- Porting note: new theorem.
protected theorem new_def_eq_old_def :
    ∀ (f : ℕ → α → β) (l : List α), l.mapIdx f = List.oldMapIdx f l := by
  intro f
  apply list_reverse_induction
  · rfl
  · intro l e h
    rw [List.oldMapIdx_append, mapIdx_append_one, h]

@[local simp]
theorem map_enumFrom_eq_zipWith : ∀ (l : List α) (n : ℕ) (f : ℕ → α → β),
    map (uncurry f) (enumFrom n l) = zipWith (fun i ↦ f (i + n)) (range (length l)) l := by
  intro l
  generalize e : l.length = len
  revert l
  induction' len with len ih <;> intros l e n f
  · have : l = [] := by cases l; rfl; contradiction
    rw [this] ; rfl
  · cases' l with head tail
    · contradiction
    · simp only [map, uncurry_apply_pair, range_succ_eq_map, zipWith, zero_add, zipWith_map_left]
      rw [ih]
      suffices : (fun i ↦ f (i + (n + 1))) = ((fun i ↦ f (i + n)) ∘ Nat.succ)
      rw [this]
      funext n' a
      simp only [comp, Nat.add_assoc, Nat.add_comm, Nat.add_succ]
      simp only [length_cons, Nat.succ.injEq] at e; exact e

theorem mapIdx_eq_enum_map (l : List α) (f : ℕ → α → β) :
    l.mapIdx f = l.enum.map (Function.uncurry f) := by
  rw [List.new_def_eq_old_def]
  induction' l with hd tl hl generalizing f
  · rfl
  · rw [List.oldMapIdx, List.oldMapIdxCore, List.oldMapIdxCore_eq, hl]
    simp [enum_eq_zip_range, map_uncurry_zip_eq_zipWith]
#align list.map_with_index_eq_enum_map List.mapIdx_eq_enum_map

@[simp]
theorem mapIdx_cons {α β} (l : List α) (f : ℕ → α → β) (a : α) :
    mapIdx f (a :: l) = f 0 a :: mapIdx (fun i ↦ f (i + 1)) l := by
  simp [mapIdx_eq_enum_map, enum_eq_zip_range, map_uncurry_zip_eq_zipWith,
    range_succ_eq_map, zipWith_map_left]
#align list.map_with_index_cons List.mapIdx_cons

theorem mapIdx_append {α} (K L : List α) (f : ℕ → α → β) :
    (K ++ L).mapIdx f = K.mapIdx f ++ L.mapIdx fun i a ↦ f (i + K.length) a := by
  induction' K with a J IH generalizing f
  · rfl
  · simp [IH fun i ↦ f (i + 1), add_assoc]
#align list.map_with_index_append List.mapIdx_append

@[simp]
theorem length_mapIdx {α β} (l : List α) (f : ℕ → α → β) : (l.mapIdx f).length = l.length := by
  induction' l with hd tl IH generalizing f
  · rfl
  · simp [IH]
#align list.length_map_with_index List.length_mapIdx

@[simp, deprecated]
theorem nthLe_mapIdx {α β} (l : List α) (f : ℕ → α → β) (i : ℕ) (h : i < l.length)
    (h' : i < (l.mapIdx f).length := h.trans_le (l.length_mapIdx f).ge) :
    (l.mapIdx f).nthLe i h' = f i (l.nthLe i h) := by
  simp [mapIdx_eq_enum_map, enum_eq_zip_range]
#align list.nth_le_map_with_index List.nthLe_mapIdx

-- Porting note: Changed the type to use `List.get` instead of deprecated `List.nthLe`.
theorem mapIdx_eq_ofFn {α β} (l : List α) (f : ℕ → α → β) :
    l.mapIdx f = ofFn fun i : Fin l.length ↦ f (i : ℕ) (l.get i) := by
  induction' l with hd tl IH generalizing f
  · rfl
  · simp [IH]
#align list.map_with_index_eq_of_fn List.mapIdx_eq_ofFn

end MapIdx

section FoldrIdx

-- Porting note: Changed argument order of `foldrIdxSpec` to align better with `foldrIdx`.
/-- Specification of `foldrIdx`. -/
def foldrIdxSpec (f : ℕ → α → β → β) (b : β) (as : List α) (start : ℕ) : β :=
  foldr (uncurry f) b <| enumFrom start as
#align list.foldr_with_index_aux_spec List.foldrIdxSpecₓ

theorem foldrIdxSpec_cons (f : ℕ → α → β → β) (b a as start) :
    foldrIdxSpec f b (a :: as) start = f start a (foldrIdxSpec f b as (start + 1)) :=
  rfl
#align list.foldr_with_index_aux_spec_cons List.foldrIdxSpec_consₓ

theorem foldrIdx_eq_foldrIdxSpec (f : ℕ → α → β → β) (b as start) :
    foldrIdx f b as start = foldrIdxSpec f b as start := by
  induction as generalizing start
  · rfl
  · simp only [foldrIdx, foldrIdxSpec_cons, *]
#align list.foldr_with_index_aux_eq_foldr_with_index_aux_spec List.foldrIdx_eq_foldrIdxSpecₓ

theorem foldrIdx_eq_foldr_enum (f : ℕ → α → β → β) (b : β) (as : List α) :
    foldrIdx f b as = foldr (uncurry f) b (enum as) := by
  simp only [foldrIdx, foldrIdxSpec, foldrIdx_eq_foldrIdxSpec, enum]
#align list.foldr_with_index_eq_foldr_enum List.foldrIdx_eq_foldr_enum

end FoldrIdx

theorem indexesValues_eq_filter_enum (p : α → Prop) [DecidablePred p] (as : List α) :
    indexesValues p as = filter (p ∘ Prod.snd) (enum as) := by
  simp [indexesValues, foldrIdx_eq_foldr_enum, uncurry, filter_eq_foldr]
#align list.indexes_values_eq_filter_enum List.indexesValues_eq_filter_enum

theorem findIdxs_eq_map_indexesValues (p : α → Prop) [DecidablePred p] (as : List α) :
    findIdxs p as = map Prod.fst (indexesValues p as) := by
  simp only [indexesValues_eq_filter_enum, map_filter_eq_foldr, findIdxs, uncurry,
    foldrIdx_eq_foldr_enum, decide_eq_true_eq, comp_apply, Bool.cond_decide]
#align list.find_indexes_eq_map_indexes_values List.findIdxs_eq_map_indexesValues

section FoldlIdx

-- Porting note: Changed argument order of `foldlIdxSpec` to align better with `foldlIdx`.
/-- Specification of `foldlIdx`. -/
def foldlIdxSpec (f : ℕ → α → β → α) (a : α) (bs : List β) (start : ℕ) : α :=
  foldl (fun a p ↦ f p.fst a p.snd) a <| enumFrom start bs
#align list.foldl_with_index_aux_spec List.foldlIdxSpecₓ

theorem foldlIdxSpec_cons (f : ℕ → α → β → α) (a b bs start) :
    foldlIdxSpec f a (b :: bs) start = foldlIdxSpec f (f start a b) bs (start + 1) :=
  rfl
#align list.foldl_with_index_aux_spec_cons List.foldlIdxSpec_consₓ

theorem foldlIdx_eq_foldlIdxSpec (f : ℕ → α → β → α) (a bs start) :
    foldlIdx f a bs start = foldlIdxSpec f a bs start := by
  induction bs generalizing start a
  · rfl
  · simp [foldlIdxSpec, *]
#align list.foldl_with_index_aux_eq_foldl_with_index_aux_spec List.foldlIdx_eq_foldlIdxSpecₓ

theorem foldlIdx_eq_foldl_enum (f : ℕ → α → β → α) (a : α) (bs : List β) :
    foldlIdx f a bs = foldl (fun a p ↦ f p.fst a p.snd) a (enum bs) := by
  simp only [foldlIdx, foldlIdxSpec, foldlIdx_eq_foldlIdxSpec, enum]
#align list.foldl_with_index_eq_foldl_enum List.foldlIdx_eq_foldl_enum

end FoldlIdx

section FoldIdxM

-- Porting note: `foldrM_eq_foldr` now depends on `[LawfulMonad m]`
variable {m : Type u → Type v} [Monad m]

theorem foldrIdxM_eq_foldrM_enum {α β} (f : ℕ → α → β → m β) (b : β) (as : List α) [LawfulMonad m] :
    foldrIdxM f b as = foldrM (uncurry f) b (enum as) := by
  simp only [foldrIdxM, foldrM_eq_foldr, foldrIdx_eq_foldr_enum, uncurry]
#align list.mfoldr_with_index_eq_mfoldr_enum List.foldrIdxM_eq_foldrM_enum

theorem foldlIdxM_eq_foldlM_enum [LawfulMonad m] {α β} (f : ℕ → β → α → m β) (b : β) (as : List α) :
    foldlIdxM f b as = List.foldlM (fun b p ↦ f p.fst b p.snd) b (enum as) := by
  rw [foldlIdxM, foldlM_eq_foldl, foldlIdx_eq_foldl_enum]
#align list.mfoldl_with_index_eq_mfoldl_enum List.foldlIdxM_eq_foldlM_enum

end FoldIdxM

section MapIdxM

-- Porting note: `[Applicative m]` replaced by `[Monad m] [LawfulMonad m]`
variable {m : Type u → Type v} [Monad m] [LawfulMonad m]

/-- Specification of `mapIdxMAux`. -/
def mapIdxMAuxSpec {α β} (f : ℕ → α → m β) (start : ℕ) (as : List α) : m (List β) :=
  List.traverse (uncurry f) <| enumFrom start as
#align list.mmap_with_index_aux_spec List.mapIdxMAuxSpec

-- Note: `traverse` the class method would require a less universe-polymorphic
-- `m : Type u → Type u`.

theorem mapIdxMGo_eq_mapIdxMAuxSpec {α β} (f : ℕ → α → m β) (arr : Array β) (as : List α) :
    mapIdxM.go f as arr = (arr.toList ++ ·) <$> mapIdxMAuxSpec f arr.size as := by
  generalize e : as.length = len
  revert as arr
  induction' len with len ih <;> intro arr as h
  · have : as = [] := by cases as; rfl; contradiction
    simp only [this, mapIdxM.go, mapIdxMAuxSpec, List.traverse, map_pure, append_nil]
  · match as with
    | nil => contradiction
    | cons head tail =>
      simp only [length_cons, Nat.succ.injEq] at h
      simp only [mapIdxM.go, mapIdxMAuxSpec_cons, map_eq_pure_bind, seq_eq_bind_map,
        LawfulMonad.bind_assoc, pure_bind]
      congr
      conv => { lhs; intro x; rw [ih _ _ h]; }
      funext x
      simp only [Array.toList_eq, Array.push_data, append_assoc, singleton_append, Array.size_push,
        map_eq_pure_bind]
#align list.mmap_with_index_aux_eq_mmap_with_index_aux_spec List.mapIdxMGo_eq_mapIdxMAuxSpec

theorem mapIdxM_eq_mmap_enum {α β} (f : ℕ → α → m β) (as : List α) :
    as.mapIdxM f = List.traverse (uncurry f) (enum as) := by
  simp only [mapIdxM, mapIdxMGo_eq_mapIdxMAuxSpec, Array.toList_eq, Array.data_toArray,
    nil_append, mapIdxMAuxSpec, Array.size_toArray, length_nil, id_map', enum]
#align list.mmap_with_index_eq_mmap_enum List.mapIdxM_eq_mmap_enum

end MapIdxM

section MapIdxM'

-- Porting note: `[Applicative m] [LawfulApplicative m]` replaced by [Monad m] [LawfulMonad m]
variable {m : Type u → Type v} [Monad m] [LawfulMonad m]

theorem mapIdxMAux'_eq_mapIdxMGo {α} (f : ℕ → α → m PUnit) (as : List α) (arr : Array PUnit) :
    mapIdxMAux' f arr.size as = mapIdxM.go f as arr *> pure PUnit.unit := by
  revert arr
  induction' as with head tail ih <;> intro arr
  · simp only [mapIdxMAux', mapIdxM.go, seqRight_eq, map_pure, seq_pure]
  · simp only [mapIdxMAux', seqRight_eq, map_eq_pure_bind, seq_eq_bind, bind_pure_unit,
      LawfulMonad.bind_assoc, pure_bind, mapIdxM.go, seq_pure]
    generalize (f (Array.size arr) head) = head
    let arr_1 := arr.push ⟨⟩
    have : arr_1.size = arr.size + 1 := Array.size_push arr ⟨⟩
    rw [← this, ih arr_1]
    simp only [seqRight_eq, map_eq_pure_bind, seq_pure, LawfulMonad.bind_assoc, pure_bind]
#align list.mmap_with_index'_aux_eq_mmap_with_index_aux List.mapIdxMAux'_eq_mapIdxMGo

theorem mapIdxM'_eq_mapIdxM {α} (f : ℕ → α → m PUnit) (as : List α) :
    mapIdxM' f as = mapIdxM as f *> pure PUnit.unit :=
  mapIdxMAux'_eq_mapIdxMGo f as #[]
#align list.mmap_with_index'_eq_mmap_with_index List.mapIdxM'_eq_mapIdxM

end MapIdxM'

end List


import .lang

/-
The `has_app` typeclass provides an interpretation of a language.
-/
class has_app (L : lang) (A : Type*) :=
(app {n} : L n → ftuple A n → A)

notation `applyo` := has_app.app

/-
A morphism of raw algebras relative to a language L.
Use the notation `A →$[L] B`.
-/
structure ralg_hom (L : lang) (A : Type*) (B : Type*) [has_app L A] [has_app L B] :=
(to_fn : A → B)
(applyo_map' {n} {t : L n} {as : ftuple A n} : applyo t (as.map to_fn) = to_fn (applyo t as))

notation A ` →$[`:25 L:25 `] `:0 B:0 := ralg_hom L A B

namespace ralg_hom
instance {L : lang} {A : Type*} {B : Type*} [has_app L A] [has_app L B] : has_coe_to_fun (A →$[L] B ) := ⟨_,to_fn⟩

theorem applyo_map {n} {L : lang} {A : Type*} {B : Type*} [has_app L A] [has_app L B]
  (f : A →$[L] B) (t : L n) (as : ftuple A n) : applyo t (as.map f) = f (applyo t as) := by apply ralg_hom.applyo_map'

def comp {L : lang} {A : Type*} {B : Type*} {C : Type*} [has_app L A] [has_app L B] [has_app L C] :
  (A →$[L] B) → (B →$[L] C) → (A →$[L] C) := λ f g,
{ to_fn := g ∘ f,
  applyo_map' :=
  begin
    intros n t as,
    change _ = g _,
    simp_rw ←applyo_map,
    refl,
  end }

@[ext]
theorem ext {L : lang} {A : Type*} {B : Type*} [has_app L A] [has_app L B] (f g : A →$[L] B) : ⇑f = g → f = g :=
  by {cases f, cases g, finish}

theorem comp_assoc {L : lang} {A : Type*} {B : Type*} {C : Type*} {D : Type*}
  [has_app L A] [has_app L B] [has_app L C] [has_app L D]
  (f : A →$[L] B) (g : B →$[L] C) (h : C →$[L] D) : (f.comp g).comp h = f.comp (g.comp h) := by {apply ext, refl}
end ralg_hom

def applyt {n} {L : lang} {A : Type*} [has_app L A] (t : L.gen n) : ftuple A n → A :=
  lang.term.rec_on t
  (λ _, applyo)
  (λ as, as 0)
  (λ _ _ f _ h as, h (as.proj f))
  (λ _ _ _ _ h1 h2 as, as.compl h1 h2)
  (λ _ _ _ _ h1 h2 as, as.compr h1 h2)

namespace ralg_hom
lemma applyt_map {n} {L : lang} {A : Type*} {B : Type*} [has_app L A] [has_app L B]
  (f : A →$[L] B) (t : L.gen n) (as : ftuple A n) : applyt t (as.map f) = f (applyt t as) :=
begin
  induction t with _ _ _ _ _ _ h _ _ t1 t2 h1 h2 _ _ t1 t2 h1 h2,
  { apply ralg_hom.applyo_map,},
  { refl, },
  { apply h },
  repeat { change applyt t2 (ftuple.append (ftuple.of $ applyt t1 _) _) = _ <|>
    change applyt t2 (ftuple.append _ (ftuple.of $ applyt t1 _)) = _,
    simp only [←ftuple.map_init, h1, ←ftuple.map_of, ←ftuple.map_last, ←ftuple.map_append, h2],
    refl },
end
end ralg_hom

--instance {L : lang} {A : Type*} [has_app L A] : has_app L.gen A := ⟨λ n, applyt⟩

/-
namespace ralg_hom
def gen {L : lang} {A : Type*} {B : Type*} [has_app L A] [has_app L B] (f : A →$[L] B) : A →$[L.gen] B :=
  ⟨f,λ _, by apply gen.applyt_map⟩
end ralg_hom
-/

class ualg {L : lang} (R : rules L) (A : Type*) extends has_app L A :=
(cond_eq {n} (t1 t2 : L.gen n) (as : ftuple A n) : R t1 t2 → applyt t1 as = applyt t2 as)

/-
namespace vac
instance {L} {A : Type*} [has_app L A] : ualg L.vac A :=
{ cond_eq := by tauto,
  ..show has_app L A, by apply_instance }
end vac
-/


import analysis.topology.topological_space

import pequiv

structure phomeo α β [topological_space α] [topological_space β] extends pequiv α β :=
(to_cont : ∀ V : set β, is_open V → is_open (to_fun ⁻¹' (V ∩ range) ∩ domain))
(inv_cont : ∀ U : set α, is_open U → is_open (inv_fun ⁻¹' (U ∩ domain) ∩ range))

namespace phomeo
variables {α : Type*} {β : Type*} [topological_space α] [topological_space β]

instance : has_coe (phomeo α β) (pequiv α β) := ⟨λ f, f.to_pequiv⟩

def symm (f : phomeo α  β) : phomeo β α :=
⟨f.to_pequiv.symm, f.inv_cont, f.to_cont⟩

lemma is_open_map {f : phomeo α β} {U : set α} (H : is_open U) : is_open (f '' (U ∩ f.domain)) :=
begin
  change is_open ((f.to_pequiv) '' (U ∩ (f.to_pequiv).domain)),
  rw pequiv.image_eq_preimage,
  exact f.inv_cont U H
end
end phomeo


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

/-!
# Bind operation for multisets

This file defines a few basic operations on `multiset`, notably the monadic bind.

## Main declarations

* `multiset.join`: The join, aka union or sum, of multisets.
* `multiset.bind`: The bind of a multiset-indexed family of multisets.
* `multiset.product`: Cartesian product of two multisets.
* `multiset.sigma`: Disjoint sum of multisets in a sigma type.
-/

variables {α β γ δ : Type*}

namespace multiset

/-! ### Join -/

/-- `join S`, where `S` is a multiset of multisets, is the lift of the list join
  operation, that is, the union of all the sets.
     join {{1, 2}, {1, 2}, {0, 1}} = {0, 1, 1, 1, 2, 2} -/
def join : multiset (multiset α) → multiset α := sum

lemma coe_join : ∀ L : list (list α),
  join (L.map (@coe _ (multiset α) _) : multiset (multiset α)) = L.join
| []       := rfl
| (l :: L) := congr_arg (λ s : multiset α, ↑l + s) (coe_join L)

@[simp]

@[simp] lemma mem_join {a S} : a ∈ @join α S ↔ ∃ s ∈ S, a ∈ s :=
multiset.induction_on S (by simp) $
  by simp [or_and_distrib_right, exists_or_distrib] {contextual := tt}

@[simp] lemma card_join (S) : card (@join α S) = sum (map card S) :=
multiset.induction_on S (by simp) (by simp)

lemma rel_join {r : α → β → Prop} {s t} (h : rel (rel r) s t) : rel r s.join t.join :=
begin
  induction h,
  case rel.zero { simp },
  case rel.cons : a b s t hab hst ih { simpa using hab.add ih }
end

/-! ### Bind -/

section bind
variables (a : α) (s t : multiset α) (f g : α → multiset β)

/-- `s.bind f` is the monad bind operation, defined as `(s.map f).join`. It is the union of `f a` as
`a` ranges over `s`. -/
def bind (s : multiset α) (f : α → multiset β) : multiset β := (s.map f).join

@[simp] lemma coe_bind (l : list α) (f : α → list β) : @bind α β l (λ a, f a) = l.bind f :=
by rw [list.bind, ←coe_join, list.map_map]; refl

@[simp] lemma zero_bind : bind 0 f = 0 := rfl
@[simp] lemma cons_bind : (a ::ₘ s).bind f = f a + s.bind f := by simp [bind]
@[simp] lemma singleton_bind : bind {a} f = f a := by simp [bind]
@[simp] lemma add_bind : (s + t).bind f = s.bind f + t.bind f := by simp [bind]
@[simp] lemma bind_zero : s.bind (λ a, 0 : α → multiset β) = 0 := by simp [bind, join, nsmul_zero]
@[simp] lemma bind_add : s.bind (λ a, f a + g a) = s.bind f + s.bind g := by simp [bind, join]

@[simp] lemma bind_cons (f : α → β) (g : α → multiset β) :
  s.bind (λ a, f a ::ₘ g a) = map f s + s.bind g :=
multiset.induction_on s (by simp) (by simp [add_comm, add_left_comm] {contextual := tt})

@[simp] lemma bind_singleton (f : α → β) : s.bind (λ x, ({f x} : multiset β)) = map f s :=
multiset.induction_on s (by rw [zero_bind, map_zero]) (by simp [singleton_add])

@[simp] lemma mem_bind {b s} {f : α → multiset β} : b ∈ bind s f ↔ ∃ a ∈ s, b ∈ f a :=
by simp [bind]; simp [-exists_and_distrib_right, exists_and_distrib_right.symm];
   rw exists_swap; simp [and_assoc]

@[simp] lemma card_bind : (s.bind f).card = (s.map (card ∘ f)).sum := by simp [bind]

lemma bind_congr {f g : α → multiset β} {m : multiset α} :
  (∀ a ∈ m, f a = g a) → bind m f = bind m g :=
by simp [bind] {contextual := tt}

lemma bind_hcongr {β' : Type*} {m : multiset α} {f : α → multiset β} {f' : α → multiset β'}
  (h : β = β') (hf : ∀a ∈ m, f a == f' a) :
  bind m f == bind m f' :=
begin subst h, simp at hf, simp [bind_congr hf] end

lemma map_bind (m : multiset α) (n : α → multiset β) (f : β → γ) :
  map f (bind m n) = bind m (λ a, map f (n a)) :=
multiset.induction_on m (by simp) (by simp {contextual := tt})

lemma bind_map (m : multiset α) (n : β → multiset γ) (f : α → β) :
  bind (map f m) n = bind m (λ a, n (f a)) :=
multiset.induction_on m (by simp) (by simp {contextual := tt})

lemma bind_assoc {s : multiset α} {f : α → multiset β} {g : β → multiset γ} :
  (s.bind f).bind g = s.bind (λ a, (f a).bind g) :=
multiset.induction_on s (by simp) (by simp {contextual := tt})

lemma bind_bind (m : multiset α) (n : multiset β) {f : α → β → multiset γ} :
  (bind m $ λ a, bind n $ λ b, f a b) = (bind n $ λ b, bind m $ λ a, f a b) :=
multiset.induction_on m (by simp) (by simp {contextual := tt})

lemma bind_map_comm (m : multiset α) (n : multiset β) {f : α → β → γ} :
  (bind m $ λ a, n.map $ λ b, f a b) = (bind n $ λ b, m.map $ λ a, f a b) :=
multiset.induction_on m (by simp) (by simp {contextual := tt})

@[simp, to_additive]
lemma prod_bind [comm_monoid β] (s : multiset α) (t : α → multiset β) :
  (s.bind t).prod = (s.map $ λ a, (t a).prod).prod :=
multiset.induction_on s (by simp) (assume a s ih, by simp [ih, cons_bind])

lemma rel_bind {r : α → β → Prop} {p : γ → δ → Prop} {s t} {f : α → multiset γ} {g : β → multiset δ}
  (h : (r ⇒ rel p) f g) (hst : rel r s t) :
  rel p (s.bind f) (t.bind g) :=
by { apply rel_join, rw rel_map, exact hst.mono (λ a ha b hb hr, h hr) }

lemma count_sum [decidable_eq α] {m : multiset β} {f : β → multiset α} {a : α} :
  count a (map f m).sum = sum (m.map $ λ b, count a $ f b) :=
multiset.induction_on m (by simp) ( by simp)

lemma count_bind [decidable_eq α] {m : multiset β} {f : β → multiset α} {a : α} :
  count a (bind m f) = sum (m.map $ λ b, count a $ f b) := count_sum

end bind

/-! ### Product of two multisets -/

section product
variables (a : α) (b : β) (s : multiset α) (t : multiset β)

/-- The multiplicity of `(a, b)` in `s.product t` is
  the product of the multiplicity of `a` in `s` and `b` in `t`. -/
def product (s : multiset α) (t : multiset β) : multiset (α × β) := s.bind $ λ a, t.map $ prod.mk a

@[simp] lemma coe_product (l₁ : list α) (l₂ : list β) : @product α β l₁ l₂ = l₁.product l₂ :=
by { rw [product, list.product, ←coe_bind], simp }

@[simp] lemma zero_product : @product α β 0 t = 0 := rfl
--TODO: Add `product_zero`

@[simp] lemma cons_product : (a ::ₘ s).product t = map (prod.mk a) t + s.product t :=
by simp [product]

@[simp] lemma product_singleton : ({a} : multiset α).product ({b} : multiset β) = {(a, b)} :=
by simp only [product, bind_singleton, map_singleton]

@[simp] lemma add_product (s t : multiset α) (u : multiset β) :
  (s + t).product u = s.product u + product t u :=
by simp [product]

@[simp] lemma product_add (s : multiset α) : ∀ t u : multiset β,
  s.product (t + u) = s.product t + s.product u :=
multiset.induction_on s (λ t u, rfl) $ λ a s IH t u,
  by rw [cons_product, IH]; simp; cc

@[simp] lemma mem_product {s t} : ∀ {p : α × β}, p ∈ @product α β s t ↔ p.1 ∈ s ∧ p.2 ∈ t
| (a, b) := by simp [product, and.left_comm]

@[simp] lemma card_product : (s.product t).card = s.card * t.card :=
by simp [product, repeat, (∘), mul_comm]

end product

/-! ### Disjoint sum of multisets -/

section sigma
variables {σ : α → Type*} (a : α) (s : multiset α) (t : Π a, multiset (σ a))

/-- `sigma s t` is the dependent version of `product`. It is the sum of
  `(a, b)` as `a` ranges over `s` and `b` ranges over `t a`. -/
protected def sigma (s : multiset α) (t : Π a, multiset (σ a)) : multiset (Σ a, σ a) :=
s.bind $ λ a, (t a).map $ sigma.mk a

@[simp] lemma coe_sigma (l₁ : list α) (l₂ : Π a, list (σ a)) :
  @multiset.sigma α σ l₁ (λ a, l₂ a) = l₁.sigma l₂ :=
by rw [multiset.sigma, list.sigma, ←coe_bind]; simp

@[simp] lemma zero_sigma : @multiset.sigma α σ 0 t = 0 := rfl

@[simp] lemma cons_sigma : (a ::ₘ s).sigma t = (t a).map (sigma.mk a) + s.sigma t :=
by simp [multiset.sigma]

@[simp] lemma sigma_singleton (b : α → β) :
  ({a} : multiset α).sigma (λ a, ({b a} : multiset β)) = {⟨a, b a⟩} := rfl

@[simp] lemma add_sigma (s t : multiset α) (u : Π a, multiset (σ a)) :
  (s + t).sigma u = s.sigma u + t.sigma u :=
by simp [multiset.sigma]

@[simp] lemma sigma_add : ∀ t u : Π a, multiset (σ a),
  s.sigma (λ a, t a + u a) = s.sigma t + s.sigma u :=
multiset.induction_on s (λ t u, rfl) $ λ a s IH t u,
  by rw [cons_sigma, IH]; simp; cc

@[simp] lemma mem_sigma {s t} : ∀ {p : Σ a, σ a},
  p ∈ @multiset.sigma α σ s t ↔ p.1 ∈ s ∧ p.2 ∈ t p.1
| ⟨a, b⟩ := by simp [multiset.sigma, and_assoc, and.left_comm]

@[simp] lemma card_sigma :
  card (s.sigma t) = sum (map (λ a, card (t a)) s) :=
by simp [multiset.sigma, (∘)]

end sigma
end multiset


/-
Copyright (c) 2019 Sébastien Gouëzel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Sébastien Gouëzel
-/
import analysis.normed_space.multilinear

/-!
# Formal multilinear series

In this file we define `formal_multilinear_series 𝕜 E F` to be a family of `n`-multilinear maps for
all `n`, designed to model the sequence of derivatives of a function. In other files we use this
notion to define `C^n` functions (called `cont_diff` in `mathlib`) and analytic functions.

## Notations

We use the notation `E [×n]→L[𝕜] F` for the space of continuous multilinear maps on `E^n` with
values in `F`. This is the space in which the `n`-th derivative of a function from `E` to `F` lives.

## Tags

multilinear, formal series
-/

noncomputable theory

open set fin
open_locale topological_space

variables {𝕜 𝕜' E F G : Type*}

section
variables [comm_ring 𝕜]
  [add_comm_group E] [module 𝕜 E] [topological_space E] [topological_add_group E]
  [has_continuous_const_smul 𝕜 E]
  [add_comm_group F] [module 𝕜 F] [topological_space F] [topological_add_group F]
  [has_continuous_const_smul 𝕜 F]
  [add_comm_group G] [module 𝕜 G] [topological_space G] [topological_add_group G]
  [has_continuous_const_smul 𝕜 G]

/-- A formal multilinear series over a field `𝕜`, from `E` to `F`, is given by a family of
multilinear maps from `E^n` to `F` for all `n`. -/
@[derive add_comm_group, nolint unused_arguments]
def formal_multilinear_series (𝕜 : Type*) (E : Type*) (F : Type*)
  [ring 𝕜]
  [add_comm_group E] [module 𝕜 E] [topological_space E] [topological_add_group E]
    [has_continuous_const_smul 𝕜 E]
  [add_comm_group F] [module 𝕜 F] [topological_space F] [topological_add_group F]
    [has_continuous_const_smul 𝕜 F] :=
Π (n : ℕ), (E [×n]→L[𝕜] F)

instance : inhabited (formal_multilinear_series 𝕜 E F) := ⟨0⟩

section module
/- `derive` is not able to find the module structure, probably because Lean is confused by the
dependent types. We register it explicitly. -/

instance : module 𝕜 (formal_multilinear_series 𝕜 E F) :=
begin
  letI : Π n, module 𝕜 (continuous_multilinear_map 𝕜 (λ (i : fin n), E) F) :=
    λ n, by apply_instance,
  refine pi.module _ _ _,
end

end module

namespace formal_multilinear_series

/-- Killing the zeroth coefficient in a formal multilinear series -/
def remove_zero (p : formal_multilinear_series 𝕜 E F) : formal_multilinear_series 𝕜 E F
| 0       := 0
| (n + 1) := p (n + 1)

@[simp] lemma remove_zero_coeff_zero (p : formal_multilinear_series 𝕜 E F) :
  p.remove_zero 0 = 0 := rfl

@[simp] lemma remove_zero_coeff_succ (p : formal_multilinear_series 𝕜 E F) (n : ℕ) :
  p.remove_zero (n+1) = p (n+1) := rfl

lemma remove_zero_of_pos (p : formal_multilinear_series 𝕜 E F) {n : ℕ} (h : 0 < n) :
  p.remove_zero n = p n :=
by { rw ← nat.succ_pred_eq_of_pos h, refl }

/-- Convenience congruence lemma stating in a dependent setting that, if the arguments to a formal
multilinear series are equal, then the values are also equal. -/
lemma congr (p : formal_multilinear_series 𝕜 E F) {m n : ℕ} {v : fin m → E} {w : fin n → E}
  (h1 : m = n) (h2 : ∀ (i : ℕ) (him : i < m) (hin : i < n), v ⟨i, him⟩ = w ⟨i, hin⟩) :
  p m v = p n w :=
by { cases h1, congr' with ⟨i, hi⟩, exact h2 i hi hi }

/-- Composing each term `pₙ` in a formal multilinear series with `(u, ..., u)` where `u` is a fixed
continuous linear map, gives a new formal multilinear series `p.comp_continuous_linear_map u`. -/
def comp_continuous_linear_map (p : formal_multilinear_series 𝕜 F G) (u : E →L[𝕜] F) :
  formal_multilinear_series 𝕜 E G :=
λ n, (p n).comp_continuous_linear_map (λ (i : fin n), u)

@[simp] lemma comp_continuous_linear_map_apply
  (p : formal_multilinear_series 𝕜 F G) (u : E →L[𝕜] F) (n : ℕ) (v : fin n → E) :
  (p.comp_continuous_linear_map u) n v = p n (u ∘ v) := rfl

variables (𝕜) [comm_ring 𝕜'] [has_scalar 𝕜 𝕜']
variables [module 𝕜' E] [has_continuous_const_smul 𝕜' E] [is_scalar_tower 𝕜 𝕜' E]
variables [module 𝕜' F] [has_continuous_const_smul 𝕜' F] [is_scalar_tower 𝕜 𝕜' F]

/-- Reinterpret a formal `𝕜'`-multilinear series as a formal `𝕜`-multilinear series. -/
@[simp] protected def restrict_scalars (p : formal_multilinear_series 𝕜' E F) :
  formal_multilinear_series 𝕜 E F :=
λ n, (p n).restrict_scalars 𝕜

end formal_multilinear_series

end

namespace formal_multilinear_series

variables [nondiscrete_normed_field 𝕜]
  [normed_group E] [normed_space 𝕜 E]
  [normed_group F] [normed_space 𝕜 F]
  [normed_group G] [normed_space 𝕜 G]

variables (p : formal_multilinear_series 𝕜 E F)

/-- Forgetting the zeroth term in a formal multilinear series, and interpreting the following terms
as multilinear maps into `E →L[𝕜] F`. If `p` corresponds to the Taylor series of a function, then
`p.shift` is the Taylor series of the derivative of the function. -/
def shift : formal_multilinear_series 𝕜 E (E →L[𝕜] F) :=
λn, (p n.succ).curry_right

/-- Adding a zeroth term to a formal multilinear series taking values in `E →L[𝕜] F`. This
corresponds to starting from a Taylor series for the derivative of a function, and building a Taylor
series for the function itself. -/
def unshift (q : formal_multilinear_series 𝕜 E (E →L[𝕜] F)) (z : F) :
  formal_multilinear_series 𝕜 E F
| 0       := (continuous_multilinear_curry_fin0 𝕜 E F).symm z
| (n + 1) := continuous_multilinear_curry_right_equiv' 𝕜 n E F (q n)

end formal_multilinear_series

namespace continuous_linear_map
variables [comm_ring 𝕜]
  [add_comm_group E] [module 𝕜 E] [topological_space E] [topological_add_group E]
  [has_continuous_const_smul 𝕜 E]
  [add_comm_group F] [module 𝕜 F] [topological_space F] [topological_add_group F]
  [has_continuous_const_smul 𝕜 F]
  [add_comm_group G] [module 𝕜 G] [topological_space G] [topological_add_group G]
  [has_continuous_const_smul 𝕜 G]

/-- Composing each term `pₙ` in a formal multilinear series with a continuous linear map `f` on the
left gives a new formal multilinear series `f.comp_formal_multilinear_series p` whose general term
is `f ∘ pₙ`. -/
def comp_formal_multilinear_series (f : F →L[𝕜] G) (p : formal_multilinear_series 𝕜 E F) :
  formal_multilinear_series 𝕜 E G :=
λ n, f.comp_continuous_multilinear_map (p n)

@[simp] lemma comp_formal_multilinear_series_apply
  (f : F →L[𝕜] G) (p : formal_multilinear_series 𝕜 E F) (n : ℕ) :
  (f.comp_formal_multilinear_series p) n = f.comp_continuous_multilinear_map (p n) :=
rfl

lemma comp_formal_multilinear_series_apply'
  (f : F →L[𝕜] G) (p : formal_multilinear_series 𝕜 E F) (n : ℕ) (v : fin n → E) :
  (f.comp_formal_multilinear_series p) n v = f (p n v) :=
rfl

end continuous_linear_map


/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro, Chris Hughes
-/
import algebra.algebra.basic
import data.polynomial.field_division
import field_theory.minpoly.basic
import ring_theory.adjoin.basic
import ring_theory.finite_presentation
import ring_theory.finite_type
import ring_theory.power_basis
import ring_theory.principal_ideal_domain
import ring_theory.quotient_noetherian

/-!
# Adjoining roots of polynomials

This file defines the commutative ring `adjoin_root f`, the ring R[X]/(f) obtained from a
commutative ring `R` and a polynomial `f : R[X]`. If furthermore `R` is a field and `f` is
irreducible, the field structure on `adjoin_root f` is constructed.

We suggest stating results on `is_adjoin_root` instead of `adjoin_root` to achieve higher
generality, since `is_adjoin_root` works for all different constructions of `R[α]`
including `adjoin_root f = R[X]/(f)` itself.

## Main definitions and results

The main definitions are in the `adjoin_root` namespace.

*  `mk f : R[X] →+* adjoin_root f`, the natural ring homomorphism.

*  `of f : R →+* adjoin_root f`, the natural ring homomorphism.

* `root f : adjoin_root f`, the image of X in R[X]/(f).

* `lift (i : R →+* S) (x : S) (h : f.eval₂ i x = 0) : (adjoin_root f) →+* S`, the ring
  homomorphism from R[X]/(f) to S extending `i : R →+* S` and sending `X` to `x`.

* `lift_hom (x : S) (hfx : aeval x f = 0) : adjoin_root f →ₐ[R] S`, the algebra
  homomorphism from R[X]/(f) to S extending `algebra_map R S` and sending `X` to `x`

* `equiv : (adjoin_root f →ₐ[F] E) ≃ {x // x ∈ (f.map (algebra_map F E)).roots}` a
  bijection between algebra homomorphisms from `adjoin_root` and roots of `f` in `S`

-/
noncomputable theory
open_locale classical
open_locale big_operators polynomial

universes u v w

variables {R : Type u} {S : Type v} {K : Type w}

open polynomial ideal

/-- Adjoin a root of a polynomial `f` to a commutative ring `R`. We define the new ring
as the quotient of `R[X]` by the principal ideal generated by `f`. -/
def adjoin_root [comm_ring R] (f : R[X]) : Type u :=
polynomial R ⧸ (span {f} : ideal R[X])

namespace adjoin_root

section comm_ring
variables [comm_ring R] (f : R[X])

instance : comm_ring (adjoin_root f) := ideal.quotient.comm_ring _

instance : inhabited (adjoin_root f) := ⟨0⟩

instance : decidable_eq (adjoin_root f) := classical.dec_eq _

protected lemma nontrivial [is_domain R] (h : degree f ≠ 0) : nontrivial (adjoin_root f) :=
ideal.quotient.nontrivial
begin
  simp_rw [ne.def, span_singleton_eq_top, polynomial.is_unit_iff, not_exists, not_and],
  rintro x hx rfl,
  exact h (degree_C hx.ne_zero),
end

/-- Ring homomorphism from `R[x]` to `adjoin_root f` sending `X` to the `root`. -/
def mk : R[X] →+* adjoin_root f := ideal.quotient.mk _

@[elab_as_eliminator]
theorem induction_on {C : adjoin_root f → Prop} (x : adjoin_root f)
  (ih : ∀ p : R[X], C (mk f p)) : C x :=
quotient.induction_on' x ih

/-- Embedding of the original ring `R` into `adjoin_root f`. -/
def of : R →+* adjoin_root f := (mk f).comp C

instance [comm_semiring S] [algebra S R] : algebra S (adjoin_root f) :=
ideal.quotient.algebra S

instance [comm_semiring S] [comm_semiring K] [has_smul S K] [algebra S R] [algebra K R]
  [is_scalar_tower S K R] :
  is_scalar_tower S K (adjoin_root f) :=
submodule.quotient.is_scalar_tower _ _

instance [comm_semiring S] [comm_semiring K] [algebra S R] [algebra K R] [smul_comm_class S K R] :
  smul_comm_class S K (adjoin_root f) :=
submodule.quotient.smul_comm_class _ _

@[simp]

variables (S)

lemma algebra_map_eq' [comm_semiring S] [algebra S R] :
  algebra_map S (adjoin_root f) = (of f).comp (algebra_map S R) := rfl

variables {S}

lemma finite_type : algebra.finite_type R (adjoin_root f) :=
(algebra.finite_type.polynomial R).of_surjective _ (ideal.quotient.mkₐ_surjective R _)

lemma finite_presentation : algebra.finite_presentation R (adjoin_root f) :=
(algebra.finite_presentation.polynomial R).quotient (submodule.fg_span_singleton f)

/-- The adjoined root. -/
def root : adjoin_root f := mk f X

variables {f}

instance has_coe_t : has_coe_t R (adjoin_root f) := ⟨of f⟩

/-- Two `R`-`alg_hom` from `adjoin_root f` to the same `R`-algebra are the same iff
    they agree on `root f`. -/
@[ext] lemma alg_hom_ext [semiring S] [algebra R S] {g₁ g₂ : adjoin_root f →ₐ[R] S}
  (h : g₁ (root f) = g₂ (root f)) : g₁ = g₂ :=
ideal.quotient.alg_hom_ext R $ polynomial.alg_hom_ext h

@[simp] lemma mk_eq_mk {g h : R[X]} : mk f g = mk f h ↔ f ∣ g - h :=
ideal.quotient.eq.trans ideal.mem_span_singleton

@[simp] lemma mk_eq_zero {g : R[X]} : mk f g = 0 ↔ f ∣ g :=
mk_eq_mk.trans $ by rw sub_zero

@[simp] lemma mk_self : mk f f = 0 :=
quotient.sound' $ quotient_add_group.left_rel_apply.mpr (mem_span_singleton.2 $ by simp)

@[simp] lemma mk_C (x : R) : mk f (C x) = x := rfl

@[simp] lemma mk_X : mk f X = root f := rfl

lemma mk_ne_zero_of_degree_lt (hf : monic f)
  {g : R[X]} (h0 : g ≠ 0) (hd : degree g < degree f) : mk f g ≠ 0 :=
mk_eq_zero.not.2 $ hf.not_dvd_of_degree_lt h0 hd

lemma mk_ne_zero_of_nat_degree_lt (hf : monic f)
  {g : R[X]} (h0 : g ≠ 0) (hd : nat_degree g < nat_degree f) : mk f g ≠ 0 :=
mk_eq_zero.not.2 $ hf.not_dvd_of_nat_degree_lt h0 hd

@[simp] lemma aeval_eq (p : R[X]) : aeval (root f) p = mk f p :=
polynomial.induction_on p (λ x, by { rw aeval_C, refl })
  (λ p q ihp ihq, by rw [alg_hom.map_add, ring_hom.map_add, ihp, ihq])
  (λ n x ih, by { rw [alg_hom.map_mul, aeval_C, alg_hom.map_pow, aeval_X,
    ring_hom.map_mul, mk_C, ring_hom.map_pow, mk_X], refl })

theorem adjoin_root_eq_top : algebra.adjoin R ({root f} : set (adjoin_root f)) = ⊤ :=
algebra.eq_top_iff.2 $ λ x, induction_on f x $ λ p,
(algebra.adjoin_singleton_eq_range_aeval R (root f)).symm ▸ ⟨p, aeval_eq p⟩

@[simp] lemma eval₂_root (f : R[X]) : f.eval₂ (of f) (root f) = 0 :=
by rw [← algebra_map_eq, ← aeval_def, aeval_eq, mk_self]

lemma is_root_root (f : R[X]) : is_root (f.map (of f)) (root f) :=
by rw [is_root, eval_map, eval₂_root]

lemma is_algebraic_root (hf : f ≠ 0) : is_algebraic R (root f) :=
⟨f, hf, eval₂_root f⟩

lemma of.injective_of_degree_ne_zero [is_domain R] (hf : f.degree ≠ 0) :
  function.injective (adjoin_root.of f) :=
begin
  rw injective_iff_map_eq_zero,
  intros p hp,
  rw [adjoin_root.of, ring_hom.comp_apply, adjoin_root.mk_eq_zero] at hp,
  by_cases h : f = 0,
  { exact C_eq_zero.mp (eq_zero_of_zero_dvd (by rwa h at hp)) },
  { contrapose! hf with h_contra,
    rw ← degree_C h_contra,
    apply le_antisymm (degree_le_of_dvd hp (by rwa [ne.def, C_eq_zero])) _,
    rwa [degree_C h_contra, zero_le_degree_iff] },
end

variables [comm_ring S]

/-- Lift a ring homomorphism `i : R →+* S` to `adjoin_root f →+* S`. -/
def lift (i : R →+* S) (x : S) (h : f.eval₂ i x = 0) : (adjoin_root f) →+* S :=
begin
  apply ideal.quotient.lift _ (eval₂_ring_hom i x),
  intros g H,
  rcases mem_span_singleton.1 H with ⟨y, hy⟩,
  rw [hy, ring_hom.map_mul, coe_eval₂_ring_hom, h, zero_mul]
end

variables {i : R →+* S} {a : S} (h : f.eval₂ i a = 0)

@[simp] lemma lift_mk (g : R[X]) : lift i a h (mk f g) = g.eval₂ i a :=
ideal.quotient.lift_mk _ _ _

@[simp] lemma lift_root : lift i a h (root f) = a := by rw [root, lift_mk, eval₂_X]

@[simp] lemma lift_of {x : R} : lift i a h x = i x :=
by rw [← mk_C x, lift_mk, eval₂_C]

@[simp] lemma lift_comp_of : (lift i a h).comp (of f) = i :=
ring_hom.ext $ λ _, @lift_of _ _ _ _ _ _ _ h _

variables (f) [algebra R S]

/-- Produce an algebra homomorphism `adjoin_root f →ₐ[R] S` sending `root f` to
a root of `f` in `S`. -/
def lift_hom (x : S) (hfx : aeval x f = 0) : adjoin_root f →ₐ[R] S :=
{ commutes' := λ r, show lift _ _ hfx r = _, from lift_of hfx,
  .. lift (algebra_map R S) x hfx }

@[simp] lemma coe_lift_hom (x : S) (hfx : aeval x f = 0) :
  (lift_hom f x hfx : adjoin_root f →+* S) = lift (algebra_map R S) x hfx := rfl

@[simp] lemma aeval_alg_hom_eq_zero (ϕ : adjoin_root f →ₐ[R] S) : aeval (ϕ (root f)) f = 0 :=
begin
  have h : ϕ.to_ring_hom.comp (of f) = algebra_map R S := ring_hom.ext_iff.mpr (ϕ.commutes),
  rw [aeval_def, ←h, ←ring_hom.map_zero ϕ.to_ring_hom, ←eval₂_root f, hom_eval₂],
  refl,
end

@[simp] lemma lift_hom_eq_alg_hom (f : R[X]) (ϕ : adjoin_root f →ₐ[R] S) :
  lift_hom f (ϕ (root f)) (aeval_alg_hom_eq_zero f ϕ) = ϕ :=
begin
  suffices : ϕ.equalizer (lift_hom f (ϕ (root f)) (aeval_alg_hom_eq_zero f ϕ)) = ⊤,
  { exact (alg_hom.ext (λ x, (set_like.ext_iff.mp (this) x).mpr algebra.mem_top)).symm },
  rw [eq_top_iff, ←adjoin_root_eq_top, algebra.adjoin_le_iff, set.singleton_subset_iff],
  exact (@lift_root _ _ _ _ _ _ _ (aeval_alg_hom_eq_zero f ϕ)).symm,
end

variables (hfx : aeval a f = 0)

@[simp] lemma lift_hom_mk {g : R[X]} : lift_hom f a hfx (mk f g) = aeval a g :=
lift_mk hfx g

@[simp] lemma lift_hom_root : lift_hom f a hfx (root f) = a :=
lift_root hfx

@[simp] lemma lift_hom_of {x : R} : lift_hom f a hfx (of f x) = algebra_map _ _ x :=
lift_of hfx

section adjoin_inv

@[simp] lemma root_is_inv (r : R) : of _ r * root (C r * X - 1) = 1 :=
by convert sub_eq_zero.1 ((eval₂_sub _).symm.trans $ eval₂_root $ C r * X - 1);
  simp only [eval₂_mul, eval₂_C, eval₂_X, eval₂_one]

lemma alg_hom_subsingleton {S : Type*} [comm_ring S] [algebra R S] {r : R} :
  subsingleton (adjoin_root (C r * X - 1) →ₐ[R] S) :=
⟨λ f g, alg_hom_ext (@inv_unique _ _ (algebra_map R S r) _ _
  (by rw [← f.commutes, ← f.map_mul, algebra_map_eq, root_is_inv, map_one])
  (by rw [← g.commutes, ← g.map_mul, algebra_map_eq, root_is_inv, map_one]))⟩

end adjoin_inv

section prime

variable {f}

theorem is_domain_of_prime (hf : prime f) : is_domain (adjoin_root f) :=
(ideal.quotient.is_domain_iff_prime (span {f} : ideal R[X])).mpr $
  (ideal.span_singleton_prime hf.ne_zero).mpr hf

theorem no_zero_smul_divisors_of_prime_of_degree_ne_zero [is_domain R] (hf : prime f)
  (hf' : f.degree ≠ 0) : no_zero_smul_divisors R (adjoin_root f) :=
begin
  haveI := is_domain_of_prime hf,
  exact no_zero_smul_divisors.iff_algebra_map_injective.mpr (of.injective_of_degree_ne_zero hf')
end

end prime

end comm_ring

section irreducible

variables [field K] {f : K[X]}

instance span_maximal_of_irreducible [fact (irreducible f)] : (span {f}).is_maximal :=
principal_ideal_ring.is_maximal_of_irreducible $ fact.out _

noncomputable instance field [fact (irreducible f)] : field (adjoin_root f) :=
{ ..adjoin_root.comm_ring f,
  ..ideal.quotient.field (span {f} : ideal K[X]) }

lemma coe_injective (h : degree f ≠ 0) : function.injective (coe : K → adjoin_root f) :=
have _ := adjoin_root.nontrivial f h, by exactI (of f).injective

lemma coe_injective' [fact (irreducible f)] : function.injective (coe : K → adjoin_root f) :=
(of f).injective

variable (f)

lemma mul_div_root_cancel [fact (irreducible f)] :
  ((X - C (root f)) * (f.map (of f) / (X - C (root f)))) = f.map (of f) :=
mul_div_eq_iff_is_root.2 $ is_root_root _

end irreducible

section is_noetherian_ring

instance [comm_ring R] [is_noetherian_ring R] {f : R[X]} : is_noetherian_ring (adjoin_root f) :=
ideal.quotient.is_noetherian_ring _

end is_noetherian_ring

section power_basis

variables [comm_ring R] {g : R[X]}

lemma is_integral_root' (hg : g.monic) : is_integral R (root g) :=
⟨g, hg, eval₂_root g⟩

/-- `adjoin_root.mod_by_monic_hom` sends the equivalence class of `f` mod `g` to `f %ₘ g`.

This is a well-defined right inverse to `adjoin_root.mk`, see `adjoin_root.mk_left_inverse`. -/
def mod_by_monic_hom (hg : g.monic) :
  adjoin_root g →ₗ[R] R[X] :=
(submodule.liftq _ (polynomial.mod_by_monic_hom g)
  (λ f (hf : f ∈ (ideal.span {g}).restrict_scalars R),
    (mem_ker_mod_by_monic hg).mpr (ideal.mem_span_singleton.mp hf))).comp $
(submodule.quotient.restrict_scalars_equiv R (ideal.span {g} : ideal R[X]))
  .symm.to_linear_map

@[simp] lemma mod_by_monic_hom_mk (hg : g.monic) (f : R[X]) :
  mod_by_monic_hom hg (mk g f) = f %ₘ g := rfl

lemma mk_left_inverse (hg : g.monic) :
  function.left_inverse (mk g) (mod_by_monic_hom hg) :=
λ f, induction_on g f $ λ f, begin
  rw [mod_by_monic_hom_mk hg, mk_eq_mk, mod_by_monic_eq_sub_mul_div _ hg,
      sub_sub_cancel_left, dvd_neg],
  apply dvd_mul_right
end

lemma mk_surjective (hg : g.monic) : function.surjective (mk g) :=
(mk_left_inverse hg).surjective

/-- The elements `1, root g, ..., root g ^ (d - 1)` form a basis for `adjoin_root g`,
where `g` is a monic polynomial of degree `d`. -/
def power_basis_aux' (hg : g.monic) :
  basis (fin g.nat_degree) R (adjoin_root g) :=
basis.of_equiv_fun
{ to_fun := λ f i, (mod_by_monic_hom hg f).coeff i,
  inv_fun := λ c, mk g $ ∑ (i : fin g.nat_degree), monomial i (c i),
  map_add' := λ f₁ f₂, funext $ λ i,
    by simp only [(mod_by_monic_hom hg).map_add, coeff_add, pi.add_apply],
  map_smul' := λ f₁ f₂, funext $ λ i,
    by simp only [(mod_by_monic_hom hg).map_smul, coeff_smul, pi.smul_apply, ring_hom.id_apply],
  left_inv := λ f, induction_on g f (λ f, eq.symm $ mk_eq_mk.mpr $
    by { simp only [mod_by_monic_hom_mk, sum_mod_by_monic_coeff hg degree_le_nat_degree],
         rw [mod_by_monic_eq_sub_mul_div _ hg, sub_sub_cancel],
         exact dvd_mul_right _ _ }),
  right_inv := λ x, funext $ λ i, begin
    nontriviality R,
    simp only [mod_by_monic_hom_mk],
    rw [(mod_by_monic_eq_self_iff hg).mpr, finset_sum_coeff],
    { simp_rw [coeff_monomial, fin.coe_eq_coe, finset.sum_ite_eq', if_pos (finset.mem_univ _)] },
    { simp_rw ← C_mul_X_pow_eq_monomial,
      exact (degree_eq_nat_degree $ hg.ne_zero).symm ▸ degree_sum_fin_lt _ },
  end}

/-- This lemma could be autogenerated by `@[simps]` but unfortunately that would require
unfolding that causes a timeout. -/
@[simp] lemma power_basis_aux'_repr_symm_apply (hg : g.monic) (c : fin g.nat_degree →₀ R) :
  (power_basis_aux' hg).repr.symm c = mk g (∑ (i : fin _), monomial i (c i)) := rfl

/-- This lemma could be autogenerated by `@[simps]` but unfortunately that would require
unfolding that causes a timeout. -/
@[simp] theorem power_basis_aux'_repr_apply_to_fun (hg : g.monic) (f : adjoin_root g)
  (i : fin g.nat_degree) :
  (power_basis_aux' hg).repr f i = (mod_by_monic_hom hg f).coeff ↑i :=
rfl

/-- The power basis `1, root g, ..., root g ^ (d - 1)` for `adjoin_root g`,
where `g` is a monic polynomial of degree `d`. -/
@[simps] def power_basis' (hg : g.monic) : power_basis R (adjoin_root g) :=
{ gen := root g,
  dim := g.nat_degree,
  basis := power_basis_aux' hg,
  basis_eq_pow := λ i, begin
    simp only [power_basis_aux', basis.coe_of_equiv_fun, linear_equiv.coe_symm_mk],
    rw finset.sum_eq_single i,
    { rw [function.update_same, monomial_one_right_eq_X_pow, (mk g).map_pow, mk_X] },
    { intros j _ hj,
      rw ← monomial_zero_right _,
      convert congr_arg _ (function.update_noteq hj _ _) }, -- Fix `decidable_eq` mismatch
    { intros, have := finset.mem_univ i, contradiction },
  end}

variables [field K] {f : K[X]}

lemma is_integral_root (hf : f ≠ 0) : is_integral K (root f) :=
is_algebraic_iff_is_integral.mp (is_algebraic_root hf)

lemma minpoly_root (hf : f ≠ 0) : minpoly K (root f) = f * C (f.leading_coeff⁻¹) :=
begin
  have f'_monic : monic _ := monic_mul_leading_coeff_inv hf,
  refine (minpoly.unique K _ f'_monic _ _).symm,
  { rw [alg_hom.map_mul, aeval_eq, mk_self, zero_mul] },
  intros q q_monic q_aeval,
  have commutes : (lift (algebra_map K (adjoin_root f)) (root f) q_aeval).comp (mk q) = mk f,
  { ext,
    { simp only [ring_hom.comp_apply, mk_C, lift_of], refl },
    { simp only [ring_hom.comp_apply, mk_X, lift_root] } },
  rw [degree_eq_nat_degree f'_monic.ne_zero, degree_eq_nat_degree q_monic.ne_zero,
      with_bot.coe_le_coe, nat_degree_mul hf, nat_degree_C, add_zero],
  apply nat_degree_le_of_dvd,
  { have : mk f q = 0, by rw [←commutes, ring_hom.comp_apply, mk_self, ring_hom.map_zero],
    rwa [←ideal.mem_span_singleton, ←ideal.quotient.eq_zero_iff_mem] },
  { exact q_monic.ne_zero },
  { rwa [ne.def, C_eq_zero, inv_eq_zero, leading_coeff_eq_zero] },
end

/-- The elements `1, root f, ..., root f ^ (d - 1)` form a basis for `adjoin_root f`,
where `f` is an irreducible polynomial over a field of degree `d`. -/
def power_basis_aux (hf : f ≠ 0) : basis (fin f.nat_degree) K (adjoin_root f) :=
begin
  set f' := f * C (f.leading_coeff⁻¹) with f'_def,
  have deg_f' : f'.nat_degree = f.nat_degree,
  { rw [nat_degree_mul hf, nat_degree_C, add_zero],
    { rwa [ne.def, C_eq_zero, inv_eq_zero, leading_coeff_eq_zero] } },
  have minpoly_eq : minpoly K (root f) = f' := minpoly_root hf,
  apply @basis.mk _ _ _ (λ (i : fin f.nat_degree), (root f ^ i.val)),
  { rw [← deg_f', ← minpoly_eq],
    exact linear_independent_pow (root f) },
  { rintros y -,
    rw [← deg_f', ← minpoly_eq],
    apply (is_integral_root hf).mem_span_pow,
    obtain ⟨g⟩ := y,
    use g,
    rw aeval_eq,
    refl }
end

/-- The power basis `1, root f, ..., root f ^ (d - 1)` for `adjoin_root f`,
where `f` is an irreducible polynomial over a field of degree `d`. -/
@[simps] def power_basis (hf : f ≠ 0) :
  power_basis K (adjoin_root f) :=
{ gen := root f,
  dim := f.nat_degree,
  basis := power_basis_aux hf,
  basis_eq_pow := basis.mk_apply _ _ }

lemma minpoly_power_basis_gen (hf : f ≠ 0) :
  minpoly K (power_basis hf).gen = f * C (f.leading_coeff⁻¹) :=
by rw [power_basis_gen, minpoly_root hf]

lemma minpoly_power_basis_gen_of_monic (hf : f.monic) (hf' : f ≠ 0 := hf.ne_zero) :
  minpoly K (power_basis hf').gen = f :=
by rw [minpoly_power_basis_gen hf', hf.leading_coeff, inv_one, C.map_one, mul_one]

end power_basis

section equiv

section minpoly

variables [comm_ring R] [comm_ring S] [algebra R S] (x : S) (R)

open algebra polynomial

/-- The surjective algebra morphism `R[X]/(minpoly R x) → R[x]`.
If `R` is a GCD domain and `x` is integral, this is an isomorphism,
see `adjoin_root.minpoly.equiv_adjoin`. -/
@[simps] def minpoly.to_adjoin : adjoin_root (minpoly R x) →ₐ[R] adjoin R ({x} : set S) :=
lift_hom _ ⟨x, self_mem_adjoin_singleton R x⟩
  (by simp [← subalgebra.coe_eq_zero, aeval_subalgebra_coe])

variables {R x}

lemma minpoly.to_adjoin_apply' (a : adjoin_root (minpoly R x)) : minpoly.to_adjoin R x a =
  lift_hom (minpoly R x) (⟨x, self_mem_adjoin_singleton R x⟩ : adjoin R ({x} : set S))
  (by simp [← subalgebra.coe_eq_zero, aeval_subalgebra_coe]) a := rfl

lemma minpoly.to_adjoin.apply_X : minpoly.to_adjoin R x (mk (minpoly R x) X) =
  ⟨x, self_mem_adjoin_singleton R x⟩ :=
by simp

variables (R x)

lemma minpoly.to_adjoin.surjective : function.surjective (minpoly.to_adjoin R x) :=
begin
  rw [← range_top_iff_surjective, _root_.eq_top_iff, ← adjoin_adjoin_coe_preimage],
  refine adjoin_le _,
  simp only [alg_hom.coe_range, set.mem_range],
  rintro ⟨y₁, y₂⟩ h,
  refine ⟨mk (minpoly R x) X, by simpa using h.symm⟩
end

end minpoly

section equiv'

variables [comm_ring R] [comm_ring S] [algebra R S]
variables (g : R[X]) (pb : _root_.power_basis R S)

/-- If `S` is an extension of `R` with power basis `pb` and `g` is a monic polynomial over `R`
such that `pb.gen` has a minimal polynomial `g`, then `S` is isomorphic to `adjoin_root g`.

Compare `power_basis.equiv_of_root`, which would require
`h₂ : aeval pb.gen (minpoly R (root g)) = 0`; that minimal polynomial is not
guaranteed to be identical to `g`. -/
@[simps {fully_applied := ff}]
def equiv' (h₁ : aeval (root g) (minpoly R pb.gen) = 0) (h₂ : aeval pb.gen g = 0) :
  adjoin_root g ≃ₐ[R] S :=
{ to_fun := adjoin_root.lift_hom g pb.gen h₂,
  inv_fun := pb.lift (root g) h₁,
  left_inv := λ x, induction_on g x $ λ f, by rw [lift_hom_mk, pb.lift_aeval, aeval_eq],
  right_inv := λ x, begin
    nontriviality S,
    obtain ⟨f, hf, rfl⟩ := pb.exists_eq_aeval x,
    rw [pb.lift_aeval, aeval_eq, lift_hom_mk]
  end,
  .. adjoin_root.lift_hom g pb.gen h₂ }

@[simp] lemma equiv'_to_alg_hom
  (h₁ : aeval (root g) (minpoly R pb.gen) = 0) (h₂ : aeval pb.gen g = 0) :
  (equiv' g pb h₁ h₂).to_alg_hom = adjoin_root.lift_hom g pb.gen h₂ :=
rfl

@[simp] lemma equiv'_symm_to_alg_hom
  (h₁ : aeval (root g) (minpoly R pb.gen) = 0) (h₂ : aeval pb.gen g = 0) :
  (equiv' g pb h₁ h₂).symm.to_alg_hom = pb.lift (root g) h₁ :=
rfl

end equiv'

section field

variables (K) (L F : Type*) [field F] [field K] [field L] [algebra F K] [algebra F L]
variables (pb : _root_.power_basis F K)

/-- If `L` is a field extension of `F` and `f` is a polynomial over `F` then the set
of maps from `F[x]/(f)` into `L` is in bijection with the set of roots of `f` in `L`. -/
def equiv (f : F[X]) (hf : f ≠ 0) :
  (adjoin_root f →ₐ[F] L) ≃ {x // x ∈ (f.map (algebra_map F L)).roots} :=
(power_basis hf).lift_equiv'.trans ((equiv.refl _).subtype_equiv (λ x,
  begin
    rw [power_basis_gen, minpoly_root hf, polynomial.map_mul, roots_mul,
        polynomial.map_C, roots_C, add_zero, equiv.refl_apply],
    rw ← polynomial.map_mul, exact map_monic_ne_zero (monic_mul_leading_coeff_inv hf)
  end))

end field

end equiv

section

open ideal double_quot polynomial

variables [comm_ring R] (I : ideal R) (f : R[X])

/-- The natural isomorphism `R[α]/(I[α]) ≅ R[α]/((I[x] ⊔ (f)) / (f))` for `α` a root of
`f : R[X]` and `I : ideal R`.

See `adjoin_root.quot_map_of_equiv` for the isomorphism with `(R/I)[X] / (f mod I)`. -/
def quot_map_of_equiv_quot_map_C_map_span_mk :
  adjoin_root f ⧸ I.map (of f) ≃+*
    adjoin_root f ⧸ (I.map (C : R →+* R[X])).map (span {f})^.quotient.mk :=
ideal.quot_equiv_of_eq (by rw [of, adjoin_root.mk, ideal.map_map])

@[simp]
lemma quot_map_of_equiv_quot_map_C_map_span_mk_mk (x : adjoin_root f) :
  quot_map_of_equiv_quot_map_C_map_span_mk I f (ideal.quotient.mk (I.map (of f)) x) =
    ideal.quotient.mk _ x :=
rfl

--this lemma should have the simp tag but this causes a lint issue
lemma quot_map_of_equiv_quot_map_C_map_span_mk_symm_mk (x : adjoin_root f) :
  (quot_map_of_equiv_quot_map_C_map_span_mk I f).symm
  (ideal.quotient.mk ((I.map (C : R →+* R[X])).map (span {f})^.quotient.mk) x) =
    ideal.quotient.mk (I.map (of f)) x :=
by rw [quot_map_of_equiv_quot_map_C_map_span_mk, ideal.quot_equiv_of_eq_symm, quot_equiv_of_eq_mk]

/-- The natural isomorphism `R[α]/((I[x] ⊔ (f)) / (f)) ≅ (R[x]/I[x])/((f) ⊔ I[x] / I[x])`
  for `α` a root of `f : R[X]` and `I : ideal R`-/
def quot_map_C_map_span_mk_equiv_quot_map_C_quot_map_span_mk :
  (adjoin_root f) ⧸ (I.map (C : R →+* R[X])).map (span ({f} : set R[X]))^.quotient.mk ≃+*
    (R[X] ⧸ I.map (C : R →+* R[X])) ⧸ (span ({f} : set R[X])).map
    (I.map (C : R →+* R[X]))^.quotient.mk :=
quot_quot_equiv_comm (ideal.span ({f} : set R[X])) (I.map (C : R →+* R[X]))

@[simp]
lemma quot_map_C_map_span_mk_equiv_quot_map_C_quot_map_span_mk_mk (p : R[X]) :
  quot_map_C_map_span_mk_equiv_quot_map_C_quot_map_span_mk I f (ideal.quotient.mk _ (mk f p)) =
    quot_quot_mk (I.map C) (span {f}) p :=
rfl

@[simp]
lemma quot_map_C_map_span_mk_equiv_quot_map_C_quot_map_span_mk_symm_quot_quot_mk (p : R[X]) :
  (quot_map_C_map_span_mk_equiv_quot_map_C_quot_map_span_mk I f).symm
  (quot_quot_mk (I.map C) (span {f}) p) = (ideal.quotient.mk _ (mk f p)) :=
rfl

/-- The natural isomorphism `(R/I)[x]/(f mod I) ≅ (R[x]/I*R[x])/(f mod I[x])` where
  `f : R[X]` and `I : ideal R`-/
def polynomial.quot_quot_equiv_comm :
  (R ⧸ I)[X] ⧸ span ({f.map (I^.quotient.mk)} : set (polynomial (R ⧸ I))) ≃+*
    (R[X] ⧸ map C I) ⧸ span ({(ideal.quotient.mk (I.map C)) f} : set (R[X] ⧸ map C I)) :=
quotient_equiv (span ({f.map (I^.quotient.mk)} : set (polynomial (R ⧸ I))))
  (span {ideal.quotient.mk (I.map polynomial.C) f})
  (polynomial_quotient_equiv_quotient_polynomial I)
  (by rw [map_span, set.image_singleton, ring_equiv.coe_to_ring_hom,
    polynomial_quotient_equiv_quotient_polynomial_map_mk I f])

@[simp]
lemma polynomial.quot_quot_equiv_comm_mk (p : R[X]) :
  (polynomial.quot_quot_equiv_comm I f) (ideal.quotient.mk  _ (p.map I^.quotient.mk)) =
  (ideal.quotient.mk _ (ideal.quotient.mk _ p)) :=
by simp only [polynomial.quot_quot_equiv_comm, quotient_equiv_mk,
  polynomial_quotient_equiv_quotient_polynomial_map_mk]

@[simp]
lemma polynomial.quot_quot_equiv_comm_symm_mk_mk (p : R[X]) :
  (polynomial.quot_quot_equiv_comm I f).symm (ideal.quotient.mk _ (ideal.quotient.mk _ p)) =
    (ideal.quotient.mk  _ (p.map I^.quotient.mk)) :=
by simp only [polynomial.quot_quot_equiv_comm, quotient_equiv_symm_mk,
  polynomial_quotient_equiv_quotient_polynomial_symm_mk]

/-- The natural isomorphism `R[α]/I[α] ≅ (R/I)[X]/(f mod I)` for `α` a root of `f : R[X]`
  and `I : ideal R`.-/
def quot_adjoin_root_equiv_quot_polynomial_quot : (adjoin_root f) ⧸ (I.map (of f)) ≃+*
  (R ⧸ I)[X] ⧸ (span ({f.map (I^.quotient.mk)} : set (R ⧸ I)[X])) :=
(quot_map_of_equiv_quot_map_C_map_span_mk I f).trans
  ((quot_map_C_map_span_mk_equiv_quot_map_C_quot_map_span_mk I f).trans
  ((ideal.quot_equiv_of_eq
  (show (span ({f} : set R[X])).map (I.map (C : R →+* R[X]))^.quotient.mk =
    span ({(ideal.quotient.mk (I.map polynomial.C)) f} : set (R[X] ⧸ map C I)),
    from by rw [map_span, set.image_singleton])).trans
  (polynomial.quot_quot_equiv_comm I f).symm))

@[simp]
lemma quot_adjoin_root_equiv_quot_polynomial_quot_mk_of (p : R[X]) :
  quot_adjoin_root_equiv_quot_polynomial_quot I f (ideal.quotient.mk (I.map (of f)) (mk f p)) =
    ideal.quotient.mk (span ({f.map (I^.quotient.mk)} : set (R ⧸ I)[X]))
    (p.map I^.quotient.mk) :=
by rw [quot_adjoin_root_equiv_quot_polynomial_quot, ring_equiv.trans_apply, ring_equiv.trans_apply,
    ring_equiv.trans_apply, quot_map_of_equiv_quot_map_C_map_span_mk_mk,
    quot_map_C_map_span_mk_equiv_quot_map_C_quot_map_span_mk_mk, quot_quot_mk, ring_hom.comp_apply,
    quot_equiv_of_eq_mk, polynomial.quot_quot_equiv_comm_symm_mk_mk]

@[simp]
lemma quot_adjoin_root_equiv_quot_polynomial_quot_symm_mk_mk (p : R[X]) :
  (quot_adjoin_root_equiv_quot_polynomial_quot I f).symm
  (ideal.quotient.mk (span ({f.map (I^.quotient.mk)} : set (R ⧸ I)[X]))
    (p.map I^.quotient.mk)) = (ideal.quotient.mk (I.map (of f)) (mk f p)) :=
by rw [quot_adjoin_root_equiv_quot_polynomial_quot, ring_equiv.symm_trans_apply,
    ring_equiv.symm_trans_apply, ring_equiv.symm_trans_apply, ring_equiv.symm_symm,
    polynomial.quot_quot_equiv_comm_mk, ideal.quot_equiv_of_eq_symm,
    ideal.quot_equiv_of_eq_mk, ← ring_hom.comp_apply, ← double_quot.quot_quot_mk,
    quot_map_C_map_span_mk_equiv_quot_map_C_quot_map_span_mk_symm_quot_quot_mk,
    quot_map_of_equiv_quot_map_C_map_span_mk_symm_mk]

/-- Promote `adjoin_root.quot_adjoin_root_equiv_quot_polynomial_quot` to an alg_equiv.  -/
@[simps apply symm_apply]
noncomputable def quot_equiv_quot_map (f : R[X]) (I : ideal R) :
  ((adjoin_root f) ⧸ (ideal.map (of f) I)) ≃ₐ[R]
     ((R ⧸ I) [X]) ⧸ (ideal.span ({polynomial.map I^.quotient.mk f} : set ((R ⧸ I) [X]))) :=
alg_equiv.of_ring_equiv (show ∀ x, (quot_adjoin_root_equiv_quot_polynomial_quot I f)
  (algebra_map R _ x) = algebra_map R _ x, from λ x, begin
    have : algebra_map R ((adjoin_root f) ⧸ (ideal.map (of f) I)) x = ideal.quotient.mk
      (ideal.map (adjoin_root.of f) I) ((mk f) (C x)) := rfl,
    simpa only [this, quot_adjoin_root_equiv_quot_polynomial_quot_mk_of, map_C]
  end)

@[simp]
lemma quot_equiv_quot_map_apply_mk (f g : R[X]) (I : ideal R)  :
  adjoin_root.quot_equiv_quot_map f I (ideal.quotient.mk _ (adjoin_root.mk f g)) =
    ideal.quotient.mk _ (g.map I^.quotient.mk) :=
by rw [adjoin_root.quot_equiv_quot_map_apply,
    adjoin_root.quot_adjoin_root_equiv_quot_polynomial_quot_mk_of]

@[simp]
lemma quot_equiv_quot_map_symm_apply_mk (f g : R[X]) (I : ideal R)  :
  (adjoin_root.quot_equiv_quot_map f I).symm (ideal.quotient.mk _ (map (ideal.quotient.mk I) g)) =
    ideal.quotient.mk _ (adjoin_root.mk f g) :=
by rw [adjoin_root.quot_equiv_quot_map_symm_apply,
    adjoin_root.quot_adjoin_root_equiv_quot_polynomial_quot_symm_mk_mk]

end

end adjoin_root

namespace power_basis

open adjoin_root alg_equiv

variables [comm_ring R] [comm_ring S] [algebra R S]

/-- Let `α` have minimal polynomial `f` over `R` and `I` be an ideal of `R`,
then `R[α] / (I) = (R[x] / (f)) / pS = (R/p)[x] / (f mod p)`. -/
@[simps apply symm_apply]
noncomputable def quotient_equiv_quotient_minpoly_map (pb : power_basis R S)
  (I : ideal R) :
  (S ⧸ I.map (algebra_map R S)) ≃ₐ[R] (polynomial (R ⧸ I)) ⧸
    (ideal.span ({(minpoly R pb.gen).map I^.quotient.mk} : set (polynomial (R ⧸ I)))) :=
(of_ring_equiv
  (show ∀ x, (ideal.quotient_equiv _ (ideal.map (adjoin_root.of (minpoly R pb.gen)) I)
    (adjoin_root.equiv' (minpoly R pb.gen) pb
    (by rw [adjoin_root.aeval_eq, adjoin_root.mk_self])
    (minpoly.aeval _ _)).symm.to_ring_equiv
    (by rw [ideal.map_map, alg_equiv.to_ring_equiv_eq_coe, ← alg_equiv.coe_ring_hom_commutes,
          ← adjoin_root.algebra_map_eq, alg_hom.comp_algebra_map]))
    (algebra_map R (S ⧸ I.map (algebra_map R S)) x) = algebra_map R _ x, from
  (λ x, by rw [← ideal.quotient.mk_algebra_map, ideal.quotient_equiv_apply,
    ring_hom.to_fun_eq_coe, ideal.quotient_map_mk, alg_equiv.to_ring_equiv_eq_coe,
    ring_equiv.coe_to_ring_hom, alg_equiv.coe_ring_equiv, alg_equiv.commutes,
    quotient.mk_algebra_map]))).trans (adjoin_root.quot_equiv_quot_map _ _)

@[simp]
lemma quotient_equiv_quotient_minpoly_map_apply_mk (pb : power_basis R S) (I : ideal R)
  (g : R[X]) : pb.quotient_equiv_quotient_minpoly_map I
  (ideal.quotient.mk _ (aeval pb.gen g)) = ideal.quotient.mk _ (g.map I^.quotient.mk) :=
by rw [power_basis.quotient_equiv_quotient_minpoly_map, alg_equiv.trans_apply,
    alg_equiv.of_ring_equiv_apply, quotient_equiv_mk, alg_equiv.coe_ring_equiv',
    adjoin_root.equiv'_symm_apply, power_basis.lift_aeval,
    adjoin_root.aeval_eq, adjoin_root.quot_equiv_quot_map_apply_mk]

@[simp]
lemma quotient_equiv_quotient_minpoly_map_symm_apply_mk (pb : power_basis R S) (I : ideal R)
  (g : R[X]) : (pb.quotient_equiv_quotient_minpoly_map I).symm
  (ideal.quotient.mk _ (g.map I^.quotient.mk)) = (ideal.quotient.mk _ (aeval pb.gen g)) :=
begin simp only [quotient_equiv_quotient_minpoly_map, to_ring_equiv_eq_coe, symm_trans_apply,
    quot_equiv_quot_map_symm_apply_mk, of_ring_equiv_symm_apply, quotient_equiv_symm_mk,
    to_ring_equiv_symm, ring_equiv.symm_symm, adjoin_root.equiv'_apply, coe_ring_equiv,
    lift_hom_mk, symm_to_ring_equiv],

end

end power_basis


/-
Copyright (c) 2021 Adam Topaz. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Adam Topaz
-/
import category_theory.adjunction.whiskering
import category_theory.sites.sheafification
import category_theory.sites.whiskering

/-!

In this file, we show that an adjunction `F ⊣ G` induces an adjunction between
categories of sheaves, under certain hypotheses on `F` and `G`.

-/

namespace category_theory

open category_theory.grothendieck_topology
open category_theory
open category_theory.limits
open opposite

universes w₁ w₂ v u
variables {C : Type u} [category.{v} C] (J : grothendieck_topology C)
variables {D : Type w₁} [category.{max v u} D]
variables {E : Type w₂} [category.{max v u} E]
variables {F : D ⥤ E} {G : E ⥤ D}
variables [∀ (X : C) (S : J.cover X) (P : Cᵒᵖ ⥤ D),
  preserves_limit (S.index P).multicospan F]

variables
  [concrete_category.{max v u} D]
  [preserves_limits (forget D)]

/-- The forgetful functor from `Sheaf J D` to sheaves of types, for a concrete category `D`
whose forgetful functor preserves the correct limits. -/
abbreviation Sheaf_forget : Sheaf J D ⥤ SheafOfTypes J :=
Sheaf_compose J (forget D) ⋙ (Sheaf_equiv_SheafOfTypes J).functor

-- We need to sheafify...
variables
  [∀ (P : Cᵒᵖ ⥤ D) (X : C) (S : J.cover X), has_multiequalizer (S.index P)]
  [∀ (X : C), has_colimits_of_shape (J.cover X)ᵒᵖ D]
  [∀ (X : C), preserves_colimits_of_shape (J.cover X)ᵒᵖ (forget D)]
  [reflects_isomorphisms (forget D)]

namespace Sheaf
noncomputable theory

/-- This is the functor sending a sheaf `X : Sheaf J E` to the sheafification
of `X ⋙ G`. -/
abbreviation compose_and_sheafify (G : E ⥤ D) : Sheaf J E ⥤ Sheaf J D :=
Sheaf_to_presheaf J E ⋙ (whiskering_right _ _ _).obj G ⋙ presheaf_to_Sheaf J D

/-- An auxiliary definition to be used in defining `category_theory.Sheaf.adjunction` below. -/
@[simps]
def compose_equiv (adj : G ⊣ F) (X : Sheaf J E) (Y : Sheaf J D) :
((compose_and_sheafify J G).obj X ⟶ Y) ≃ (X ⟶ (Sheaf_compose J F).obj Y) :=
let A := adj.whisker_right Cᵒᵖ in
{ to_fun := λ η, ⟨A.hom_equiv _ _ (J.to_sheafify _  ≫ η.val)⟩,
  inv_fun := λ γ, ⟨J.sheafify_lift ((A.hom_equiv _ _).symm ((Sheaf_to_presheaf _ _).map γ)) Y.2⟩,
  left_inv := begin
    intros η,
    ext1,
    dsimp,
    symmetry,
    apply J.sheafify_lift_unique,
    rw equiv.symm_apply_apply,
  end,
  right_inv := begin
    intros γ,
    ext1,
    dsimp,
    rw [J.to_sheafify_sheafify_lift, equiv.apply_symm_apply],
  end }

/-- An adjunction `adj : G ⊣ F` with `F : D ⥤ E` and `G : E ⥤ D` induces an adjunction
between `Sheaf J D` and `Sheaf J E`, in contexts where one can sheafify `D`-valued presheaves,
and `F` preserves the correct limits. -/
@[simps unit_app_val counit_app_val]
def adjunction (adj : G ⊣ F) : compose_and_sheafify J G ⊣ Sheaf_compose J F :=
adjunction.mk_of_hom_equiv
{ hom_equiv := compose_equiv J adj,
  hom_equiv_naturality_left_symm' := λ X' X Y f g, by { ext1, dsimp, simp },
  hom_equiv_naturality_right' := λ X Y Y' f g, by { ext1, dsimp, simp } }

instance [is_right_adjoint F] : is_right_adjoint (Sheaf_compose J F) :=
⟨_, adjunction J (adjunction.of_right_adjoint F)⟩

section forget_to_type

/-- This is the functor sending a sheaf of types `X` to the sheafification of `X ⋙ G`. -/
abbreviation compose_and_sheafify_from_types (G : Type (max v u) ⥤ D) :
  SheafOfTypes J ⥤ Sheaf J D :=
(Sheaf_equiv_SheafOfTypes J).inverse ⋙ compose_and_sheafify _ G

/-- A variant of the adjunction between sheaf categories, in the case where the right adjoint
is the forgetful functor to sheaves of types. -/
def adjunction_to_types {G : Type (max v u) ⥤ D} (adj : G ⊣ forget D) :
  compose_and_sheafify_from_types J G ⊣ Sheaf_forget J :=
((Sheaf_equiv_SheafOfTypes J).symm.to_adjunction).comp (adjunction J adj)

@[simp]
lemma adjunction_to_types_unit_app_val {G : Type (max v u) ⥤ D} (adj : G ⊣ forget D)
  (Y : SheafOfTypes J) :
  ((adjunction_to_types J adj).unit.app Y).val =
  (adj.whisker_right _).unit.app ((SheafOfTypes_to_presheaf J).obj Y) ≫
  whisker_right (J.to_sheafify _) (forget D) :=
begin
  dsimp [adjunction_to_types, adjunction.comp],
  simpa,
end

@[simp]
lemma adjunction_to_types_counit_app_val {G : Type (max v u) ⥤ D} (adj : G ⊣ forget D)
  (X : Sheaf J D) :
  ((adjunction_to_types J adj).counit.app X).val =
  J.sheafify_lift ((functor.associator _ _ _).hom ≫ (adj.whisker_right _).counit.app _) X.2 :=
begin
  dsimp [adjunction_to_types, adjunction.comp, adjunction.whisker_right],
  rw category.id_comp,
  apply J.sheafify_lift_unique,
  rw [adjunction_counit_app_val, J.sheafify_map_sheafify_lift, J.to_sheafify_sheafify_lift],
  ext,
  dsimp [Sheaf_equiv_SheafOfTypes, equivalence.symm,
    equivalence.to_adjunction, nat_iso.of_components],
  simp,
end

instance [is_right_adjoint (forget D)] : is_right_adjoint (Sheaf_forget J) :=
⟨_, adjunction_to_types J (adjunction.of_right_adjoint (forget D))⟩

end forget_to_type

end Sheaf

end category_theory


import SciLean.Notation
import SciLean.Core.Attributes
import SciLean.Core.HasAdjoint
import SciLean.Core.Defs

import SciLean.Tactic.CustomSimp.AllPrePost

namespace SciLean

instance adjoint.arg_y.hasAdjoint {X Y} [SemiHilbert X] [SemiHilbert Y] (f : X → Y) [HasAdjointT f]
  : HasAdjoint (f†) := sorry_proof

instance adjoint.arg_fy.isSmooth_2 {X Y W} [Vec W] [SemiHilbert X] [SemiHilbert Y]
  (A : W → X → Y) [∀ x, HasAdjointT (A x)] [∀ w, IsSmoothT (A w)] [IsSmoothT λ w => λ x ⟿ A w x] (w : W)
  : IsSmoothT (λ y => (A w)† y) := sorry_proof

instance adjoint.arg_fy.isSmooth_1 {X Y W} [Vec W] [SemiHilbert X] [SemiHilbert Y]
  (A : W → X → Y) [∀ x, HasAdjointT (A x)] [∀ w, IsSmoothT (A w)] [IsSmoothT λ w => λ x ⟿ A w x]
  : IsSmoothT (λ w => λ y ⟿ (A w)† y) := sorry_proof

-- on Hilbert spaces any linear function has adjoint
-- We only want this to apply for atomic functions that is why we ask for `IsLin` and not for `IsLinT`
-- This causes some issues
-- instance {X Y} [Hilbert X] [Hilbert Y] (A : X → Y) [IsLin A] : HasAdjointT A := sorry_proof

-- example {X Y} [Hilbert X] [Hilbert Y] (A : X ⊸ Y) : IsLinT λ x => adjoint A x := by infer_instance

--------------------------------------------------------------------------------

variable {α β γ : Type}
variable {X Y Z : Type} [SemiHilbert X] [SemiHilbert Y] [SemiHilbert Z]
variable {Y₁ Y₂ : Type} [SemiHilbert Y₁] [SemiHilbert Y₂]
variable {ι : Type} [Enumtype ι]

@[simp ↓, diff]
theorem id.arg_x.adj_simp
  : (λ x : X => x)† = λ x => x := sorry_proof

@[simp ↓, diff]
theorem const.arg_x.adj_simp
  : (λ (x : X) (i : ι) => x)† = λ f => ∑ i, f i := sorry_proof

@[simp ↓, diff]
theorem const.arg_y.adj_simp
  : (λ (y : Y) => (0 : X))† = λ y' => (0 : Y) := sorry_proof

@[simp ↓ low-3, diff low-3]
theorem swap.arg_y.adj_simp
  (f : ι → Y → Z) [∀ i, HasAdjointT (f i)]
  : (λ y i => f i y)† = λ g => ∑ i, (f i)† (g i) := sorry_proof

@[simp ↓ low-4, diff low-4]
theorem swapDep.arg_y.adj_simp
  {ι Y} {Z : ι → Type} [SemiHilbert Y] [∀ i, SemiHilbert (Z i)] [Enumtype ι]
  (f : (i : ι) → Y → Z i) [∀ i, HasAdjointT (f i)]
  : (λ y i => f i y)† = λ g => ∑ i, (f i)† (g i) := sorry_proof

-- @[simp ↓ (low-1), diff low-4, simp_guard g (λ x => x)]
theorem scomb.arg_x.adj_simp
  (f : X → Y → Z) [HasAdjointNT 2 f]
  (g : X → Y) [HasAdjointT g]
  : (λ x => f x (g x))†
    =
    λ z' =>
      let (x',y') := (uncurryN 2 f)† z'
      x' + g† y'
  := sorry_proof

@[simp ↓ low, diff low-3, simp_guard g (λ x => x)]
theorem comp.arg_x.adj_simp
  (f : Y → Z) [HasAdjointT f]
  (g : X → Y) [HasAdjointT g]
  : (λ x => f (g x))† = λ z => g† (f† z) := sorry_proof

-- @[simp ↓ low]
-- theorem subst.arg_x.adj_simp
--   (f : X → Y → Z) [HasAdjoint (λ ((x,y) : X × Y) => f x y)]
--   (g : X → Y) [HasAdjoint g]
--   : (λ x => f x (g x))†
--     = λ z =>
--         let f' := (λ (x,y) => f x y)†
--         (f' z).1 + g† (f' z).2
-- := by sorry_proof

-- TODO: add simp guard!
@[simp ↓ low, diff low, simp_guard g₁ Prod.fst, g₂ Prod.snd]
theorem diag.arg_x.adj_simp
  (f : Y₁ → Y₂ → Z) [HasAdjointNT 2 f]
  (g₁ : X → Y₁) [HasAdjointT g₁]
  (g₂ : X → Y₂) [HasAdjointT g₂]
  : (λ x => f (g₁ x) (g₂ x))†
    = λ z =>
      let (y₁, y₂) := (uncurryN 2 f)† z
      (g₁† y₁) + (g₂† y₂)
:= by sorry_proof

-- This prevents an infinite loop when using `adjoint_of_diag`
-- with `g₁ = Prod.fst` and `g₂ = Prod.snd`
-- @[simp ↓ low+1, diff low+1]
-- theorem diag.arg_x.adj_simp_safeguard
--   (f : X → Y → Z) [HasAdjointNT 2 f]
--   : adjoint (λ xy => f xy.1 xy.2) = (uncurryN 2 f)† := by rfl; done

@[simp ↓ low, diff low]
theorem eval.arg_f.adj_simp
  (i : ι)
  : (λ (f : ι → X) => f i)† = (λ f' j => ([[i = j]] • f' : X))
:= sorry_proof

@[simp ↓ low-1, diff low-1]
theorem evalDep.arg_f.adj_simp
  {ι} {X : ι → Type} [∀ i, SemiHilbert (X i)] [Enumtype ι]
  (i : ι)
  : (λ (f : (i' : ι) → X i') => f i)† = (λ f' j => (if h : i = j then h ▸ f' else 0))
:= sorry_proof

@[simp ↓ low-1, diff low-1]
theorem eval.arg_x.parm1.adj_simp
  (f : X → ι → Z) [HasAdjointT f] (i : ι)
  : (λ x => f x i)† = (λ x' => f† (λ j => ([[i = j]] • x')))
:=
by
  rw [comp.arg_x.adj_simp (λ (x : ι → Z) => x i) f]
  simp; done

@[simp ↓ low-2, diff low-2]
theorem evalDep.arg_x.parm1.adj_simp
  {ι Y} {Z : ι → Type} [SemiHilbert Y] [∀ i, SemiHilbert (Z i)] [Enumtype ι]
  (f : X → (i : ι) → Z i) [HasAdjointT f] (i : ι)
  : (λ x => f x i)† = (λ x' => f† (λ j => (if h : i = j then h ▸ x' else 0)))
:=
by
  rw [comp.arg_x.adj_simp (λ (x : (i : ι) → Z i) => x i) f]
  simp; done

--------------------------------------------------------------------------------
-- Unification Hints
--------------------------------------------------------------------------------

unif_hint comp.arg_x.adj_simp.unif_hint_1 (f? : Y → Z)
  (f :  Y → α → Z) (g  : X → Y) (a : α)
where
  f? =?= λ x => f x a
  |-
  (λ x => f? (g x))† =?= (λ x => f (g x) a)†

unif_hint comp.arg_x.adj_simp.unif_hint_2 (f? : Y → Z)
  (f  : Y → α → β → Z) (g  : X → Y) (a : α) (b : β)
where
  f? =?= λ x => f x a b
  |-
  (λ x => f? (g x))† =?= (λ x => f (g x) a b)†

unif_hint comp.arg_x.adj_simp.unif_hint_3 (f? : Y → Z)
  (f  : Y → α → β → γ → Z) (g  : X → Y) (a : α) (b : β) (c : γ)
where
  f? =?= λ x => f x a b c
  |-
  (λ x => f? (g x))† =?= (λ x => f (g x) a b c)†

-- unif_hint scomb.arg_x.adj_simp.unif_hint_1
--   (a : α)
--   (g? : X → Y) (f? : X → Y → Z)
--   (g : X → Y) (f  : X → Y → α → Z) where
--   g? =?= g
--   f? =?= λ x y => f x y a
--   |-
--   (λ x => f? x (g? x))† =?= (λ x => f x (g x) a)†

unif_hint diag.arg_x.adj_simp.unif_hint_1 (f? : Y₁ → Y₂ → Z)
  (f : Y₁ → Y₂ → α → Z) (g₁ : X → Y₁) (g₂ : X → Y₂) (a : α)
where
  f? =?= λ y₁ y₂ => f y₁ y₂ a
  |-
  (λ x => f? (g₁ x) (g₂ x))† =?= (λ x => f (g₁ x) (g₂ x) a)†

unif_hint diag.arg_x.adj_simp.unif_hint_2 (f? : Y₁ → Y₂ → Z)
  (f : Y₁ → Y₂ → α → β → Z) (g₁ : X → Y₁) (g₂ : X → Y₂) (a : α) (b : β)
where
  f? =?= λ y₁ y₂ => f y₁ y₂ a b
  |-
  (λ x => f? (g₁ x) (g₂ x))† =?= (λ x => f (g₁ x) (g₂ x) a b)†

unif_hint diag.arg_x.adj_simp.unif_hint_3 (f? : Y₁ → Y₂ → Z)
  (f : Y₁ → Y₂ → α → β → γ → Z) (g₁ : X → Y₁) (g₂ : X → Y₂) (a : α) (b : β) (c : γ)
where
  f? =?= λ y₁ y₂ => f y₁ y₂ a b c
  |-
  (λ x => f? (g₁ x) (g₂ x))† =?= (λ x => f (g₁ x) (g₂ x) a b c)†