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

import tactic.apply
import control.fix
import order.omega_complete_partial_order

/-!
# Lawful fixed point operators

This module defines the laws required of a `has_fix` instance, using the theory of
omega complete partial orders (ωCPO). Proofs of the lawfulness of all `has_fix` instances in
`control.fix` are provided.

## Main definition

 * class `lawful_fix`
-/

universes u v

open_locale classical
variables {α : Type*} {β : α → Type*}

open omega_complete_partial_order

/-- Intuitively, a fixed point operator `fix` is lawful if it satisfies `fix f = f (fix f)` for all
`f`, but this is inconsistent / uninteresting in most cases due to the existence of "exotic"
functions `f`, such as the function that is defined iff its argument is not, familiar from the
halting problem. Instead, this requirement is limited to only functions that are `continuous` in the
sense of `ω`-complete partial orders, which excludes the example because it is not monotone
(making the input argument less defined can make `f` more defined). -/
class lawful_fix (α : Type*) [omega_complete_partial_order α] extends has_fix α :=
(fix_eq : ∀ {f : α →ₘ α}, continuous f → has_fix.fix f = f (has_fix.fix f))

lemma lawful_fix.fix_eq' {α} [omega_complete_partial_order α] [lawful_fix α]
  {f : α → α} (hf : continuous' f) :
  has_fix.fix f = f (has_fix.fix f) :=
lawful_fix.fix_eq (hf.to_bundled _)

namespace part

open part nat nat.upto

namespace fix

variables (f : (Π a, part $ β a) →ₘ (Π a, part $ β a))

lemma approx_mono' {i : ℕ} : fix.approx f i ≤ fix.approx f (succ i) :=
begin
  induction i, dsimp [approx], apply @bot_le _ _ _ (f ⊥),
  intro, apply f.monotone, apply i_ih
end

lemma approx_mono ⦃i j : ℕ⦄ (hij : i ≤ j) : approx f i ≤ approx f j :=
begin
  induction j, cases hij, refine @le_refl _ _ _,
  cases hij, apply @le_refl _ _ _,
  apply @le_trans _ _ _ (approx f j_n) _ (j_ih ‹_›),
  apply approx_mono' f
end

lemma mem_iff (a : α) (b : β a) : b ∈ part.fix f a ↔ ∃ i, b ∈ approx f i a :=
begin
  by_cases h₀ : ∃ (i : ℕ), (approx f i a).dom,
  { simp only [part.fix_def f h₀],
    split; intro hh, exact ⟨_,hh⟩,
    have h₁ := nat.find_spec h₀,
    rw [dom_iff_mem] at h₁,
    cases h₁ with y h₁,
    replace h₁ := approx_mono' f _ _ h₁,
    suffices : y = b, subst this, exact h₁,
    cases hh with i hh,
    revert h₁, generalize : (succ (nat.find h₀)) = j, intro,
    wlog : i ≤ j := le_total i j using [i j b y,j i y b],
    replace hh := approx_mono f case _ _ hh,
    apply part.mem_unique h₁ hh },
  { simp only [fix_def' ⇑f h₀, not_exists, false_iff, not_mem_none],
    simp only [dom_iff_mem, not_exists] at h₀,
    intro, apply h₀ }
end

lemma approx_le_fix (i : ℕ) : approx f i ≤ part.fix f :=
assume a b hh,
by { rw [mem_iff f], exact ⟨_,hh⟩ }

lemma exists_fix_le_approx (x : α) : ∃ i, part.fix f x ≤ approx f i x :=
begin
  by_cases hh : ∃ i b, b ∈ approx f i x,
  { rcases hh with ⟨i,b,hb⟩, existsi i,
    intros b' h',
    have hb' := approx_le_fix f i _ _ hb,
    have hh := part.mem_unique h' hb',
    subst hh, exact hb },
  { simp only [not_exists] at hh, existsi 0,
    intros b' h',
    simp only [mem_iff f] at h',
    cases h' with i h',
    cases hh _ _ h' }
end

include f

/-- The series of approximations of `fix f` (see `approx`) as a `chain` -/
def approx_chain : chain (Π a, part $ β a) := ⟨approx f, approx_mono f⟩

lemma le_f_of_mem_approx {x} (hx : x ∈ approx_chain f) : x ≤ f x :=
begin
  revert hx, simp [(∈)],
  intros i hx, subst x,
  apply approx_mono'
end

lemma approx_mem_approx_chain {i} : approx f i ∈ approx_chain f :=
stream.mem_of_nth_eq rfl

end fix

open fix

variables {α}
variables (f : (Π a, part $ β a) →ₘ (Π a, part $ β a))

open omega_complete_partial_order

open part (hiding ωSup) nat
open nat.upto omega_complete_partial_order

lemma fix_eq_ωSup : part.fix f = ωSup (approx_chain f) :=
begin
  apply le_antisymm,
  { intro x, cases exists_fix_le_approx f x with i hx,
    transitivity' approx f i.succ x,
    { transitivity', apply hx, apply approx_mono' f },
    apply' le_ωSup_of_le i.succ,
    dsimp [approx], refl', },
  { apply ωSup_le _ _ _,
    simp only [fix.approx_chain, preorder_hom.coe_fun_mk],
    intros y x, apply approx_le_fix f },
end

lemma fix_le {X : Π a, part $ β a} (hX : f X ≤ X) : part.fix f ≤ X :=
begin
  rw fix_eq_ωSup f,
  apply ωSup_le _ _ _,
  simp only [fix.approx_chain, preorder_hom.coe_fun_mk],
  intros i,
  induction i, dsimp [fix.approx], apply' bot_le,
  transitivity' f X, apply f.monotone i_ih,
  apply hX
end

variables {f} (hc : continuous f)
include hc

lemma fix_eq : part.fix f = f (part.fix f) :=
begin
  rw [fix_eq_ωSup f,hc],
  apply le_antisymm,
  { apply ωSup_le_ωSup_of_le _,
    intros i, existsi [i], intro x, -- intros x y hx,
    apply le_f_of_mem_approx _ ⟨i, rfl⟩, },
  { apply ωSup_le_ωSup_of_le _,
    intros i, existsi i.succ, refl', }
end

end part

namespace part

/-- `to_unit` as a monotone function -/
@[simps]
def to_unit_mono (f : part α →ₘ part α) : (unit → part α) →ₘ (unit → part α) :=
{ to_fun := λ x u, f (x u),
  monotone' := λ x y (h : x ≤ y) u, f.monotone $ h u }

lemma to_unit_cont (f : part α →ₘ part α) (hc : continuous f) : continuous (to_unit_mono f)
| c := begin
  ext ⟨⟩ : 1,
  dsimp [omega_complete_partial_order.ωSup],
  erw [hc, chain.map_comp], refl
end

noncomputable instance : lawful_fix (part α) :=
⟨λ f hc, show part.fix (to_unit_mono f) () = _, by rw part.fix_eq (to_unit_cont f hc); refl⟩

end part

open sigma

namespace pi

noncomputable instance {β} : lawful_fix (α → part β) := ⟨λ f, part.fix_eq⟩

variables {γ : Π a : α, β a → Type*}

section monotone

variables (α β γ)

/-- `sigma.curry` as a monotone function. -/
@[simps]
def monotone_curry [∀ x y, preorder $ γ x y] :
  (Π x : Σ a, β a, γ x.1 x.2) →ₘ (Π a (b : β a), γ a b) :=
{ to_fun := curry,
  monotone' := λ x y h a b, h ⟨a,b⟩ }

/-- `sigma.uncurry` as a monotone function. -/
@[simps]
def monotone_uncurry [∀ x y, preorder $ γ x y] :
  (Π a (b : β a), γ a b) →ₘ (Π x : Σ a, β a, γ x.1 x.2) :=
{ to_fun := uncurry,
  monotone' := λ x y h a, h a.1 a.2 }

variables [∀ x y, omega_complete_partial_order $ γ x y]

open omega_complete_partial_order.chain

lemma continuous_curry : continuous $ monotone_curry α β γ :=
λ c, by { ext x y, dsimp [curry,ωSup], rw [map_comp,map_comp], refl }

lemma continuous_uncurry : continuous $ monotone_uncurry α β γ :=
λ c, by { ext x y, dsimp [uncurry,ωSup], rw [map_comp,map_comp], refl }

end monotone

open has_fix

instance [has_fix $ Π x : sigma β, γ x.1 x.2] : has_fix (Π x (y : β x), γ x y) :=
⟨ λ f, curry (fix $ uncurry ∘ f ∘ curry) ⟩

variables [∀ x y, omega_complete_partial_order $ γ x y]

section curry

variables {f : (Π x (y : β x), γ x y) →ₘ (Π x (y : β x), γ x y)}
variables (hc : continuous f)

lemma uncurry_curry_continuous :
  continuous $ (monotone_uncurry α β γ).comp $ f.comp $ monotone_curry α β γ :=
continuous_comp _ _
  (continuous_comp _ _ (continuous_curry _ _ _) hc)
  (continuous_uncurry _ _ _)

end curry

instance pi.lawful_fix' [lawful_fix $ Π x : sigma β, γ x.1 x.2] : lawful_fix (Π x y, γ x y) :=
{ fix_eq := λ f hc,
    begin
      dsimp [fix],
      conv { to_lhs, erw [lawful_fix.fix_eq (uncurry_curry_continuous hc)] },
      refl,
    end, }

end pi


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

! This file was ported from Lean 3 source module data.fintype.powerset
! leanprover-community/mathlib commit 327c3c0d9232d80e250dc8f65e7835b82b266ea5
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Data.Fintype.Card
import Mathbin.Data.Finset.Powerset

/-!
# fintype instance for `set α`, when `α` is a fintype

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

variable {α : Type _}

open Finset

#print Finset.fintype /-
instance Finset.fintype [Fintype α] : Fintype (Finset α) :=
  ⟨univ.powerset, fun x => Finset.mem_powerset.2 (Finset.subset_univ _)⟩
#align finset.fintype Finset.fintype
-/

#print Fintype.card_finset /-
@[simp]
theorem Fintype.card_finset [Fintype α] : Fintype.card (Finset α) = 2 ^ Fintype.card α :=
  Finset.card_powerset Finset.univ
#align fintype.card_finset Fintype.card_finset
-/

#print Finset.powerset_univ /-
@[simp]
theorem Finset.powerset_univ [Fintype α] : (univ : Finset α).powerset = univ :=
  coe_injective <| by simp [-coe_eq_univ]
#align finset.powerset_univ Finset.powerset_univ
-/

#print Finset.powerset_eq_univ /-
@[simp]
theorem Finset.powerset_eq_univ [Fintype α] {s : Finset α} : s.powerset = univ ↔ s = univ := by
  rw [← Finset.powerset_univ, powerset_inj]
#align finset.powerset_eq_univ Finset.powerset_eq_univ
-/

#print Finset.mem_powerset_len_univ_iff /-
theorem Finset.mem_powerset_len_univ_iff [Fintype α] {s : Finset α} {k : ℕ} :
    s ∈ powersetLen k (univ : Finset α) ↔ card s = k :=
  mem_powersetLen.trans <| and_iff_right <| subset_univ _
#align finset.mem_powerset_len_univ_iff Finset.mem_powerset_len_univ_iff
-/

/- warning: finset.univ_filter_card_eq -> Finset.univ_filter_card_eq is a dubious translation:
lean 3 declaration is
  forall (α : Type.{u1}) [_inst_1 : Fintype.{u1} α] (k : Nat), Eq.{succ u1} (Finset.{u1} (Finset.{u1} α)) (Finset.filter.{u1} (Finset.{u1} α) (fun (s : Finset.{u1} α) => Eq.{1} Nat (Finset.card.{u1} α s) k) (fun (a : Finset.{u1} α) => Nat.decidableEq (Finset.card.{u1} α a) k) (Finset.univ.{u1} (Finset.{u1} α) (Finset.fintype.{u1} α _inst_1))) (Finset.powersetLen.{u1} α k (Finset.univ.{u1} α _inst_1))
but is expected to have type
  forall (α : Type.{u1}) [_inst_1 : Fintype.{u1} α] (k : Nat), Eq.{succ u1} (Finset.{u1} (Finset.{u1} α)) (Finset.filter.{u1} (Finset.{u1} α) (fun (s : Finset.{u1} α) => Eq.{1} Nat (Finset.card.{u1} α s) k) (fun (a : Finset.{u1} α) => instDecidableEqNat (Finset.card.{u1} α a) k) (Finset.univ.{u1} (Finset.{u1} α) (Finset.fintype.{u1} α _inst_1))) (Finset.powersetLen.{u1} α k (Finset.univ.{u1} α _inst_1))
Case conversion may be inaccurate. Consider using '#align finset.univ_filter_card_eq Finset.univ_filter_card_eqₓ'. -/
@[simp]
theorem Finset.univ_filter_card_eq (α : Type _) [Fintype α] (k : ℕ) :
    ((Finset.univ : Finset (Finset α)).filterₓ fun s => s.card = k) = Finset.univ.powersetLen k :=
  by
  ext
  simp [Finset.mem_powersetLen]
#align finset.univ_filter_card_eq Finset.univ_filter_card_eq

/- warning: fintype.card_finset_len -> Fintype.card_finset_len is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} [_inst_1 : Fintype.{u1} α] (k : Nat), Eq.{1} Nat (Fintype.card.{u1} (Subtype.{succ u1} (Finset.{u1} α) (fun (s : Finset.{u1} α) => Eq.{1} Nat (Finset.card.{u1} α s) k)) (Subtype.fintype.{u1} (Finset.{u1} α) (fun (s : Finset.{u1} α) => Eq.{1} Nat (Finset.card.{u1} α s) k) (fun (a : Finset.{u1} α) => Nat.decidableEq (Finset.card.{u1} α a) k) (Finset.fintype.{u1} α _inst_1))) (Nat.choose (Fintype.card.{u1} α _inst_1) k)
but is expected to have type
  forall {α : Type.{u1}} [_inst_1 : Fintype.{u1} α] (k : Nat), Eq.{1} Nat (Fintype.card.{u1} (Subtype.{succ u1} (Finset.{u1} α) (fun (s : Finset.{u1} α) => Eq.{1} Nat (Finset.card.{u1} α s) k)) (Subtype.fintype.{u1} (Finset.{u1} α) (fun (s : Finset.{u1} α) => Eq.{1} Nat (Finset.card.{u1} α s) k) (fun (a : Finset.{u1} α) => instDecidableEqNat (Finset.card.{u1} α a) k) (Finset.fintype.{u1} α _inst_1))) (Nat.choose (Fintype.card.{u1} α _inst_1) k)
Case conversion may be inaccurate. Consider using '#align fintype.card_finset_len Fintype.card_finset_lenₓ'. -/
@[simp]
theorem Fintype.card_finset_len [Fintype α] (k : ℕ) :
    Fintype.card { s : Finset α // s.card = k } = Nat.choose (Fintype.card α) k := by
  simp [Fintype.subtype_card, Finset.card_univ]
#align fintype.card_finset_len Fintype.card_finset_len

#print Set.fintype /-
instance Set.fintype [Fintype α] : Fintype (Set α) :=
  ⟨(@Finset.univ α _).powerset.map ⟨coe, coe_injective⟩, fun s => by
    classical
      refine' mem_map.2 ⟨finset.univ.filter s, mem_powerset.2 (subset_univ _), _⟩
      apply (coe_filter _ _).trans
      rw [coe_univ, Set.sep_univ]
      rfl⟩
#align set.fintype Set.fintype
-/

#print Set.finite' /-
-- Not to be confused with `set.finite`, the predicate
instance Set.finite' [Finite α] : Finite (Set α) :=
  by
  cases nonempty_fintype α
  infer_instance
#align set.finite' Set.finite'
-/

#print Fintype.card_set /-
@[simp]
theorem Fintype.card_set [Fintype α] : Fintype.card (Set α) = 2 ^ Fintype.card α :=
  (Finset.card_map _).trans (Finset.card_powerset _)
#align fintype.card_set Fintype.card_set
-/


/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl
-/
import order.complete_lattice
import order.rel_iso
/-!
# Galois connections, insertions and coinsertions

Galois connections are order theoretic adjoints, i.e. a pair of functions `u` and `l`,
  such that `∀a b, l a ≤ b ↔ a ≤ u b`.

## Main definitions

* `galois_connection`: A Galois connection is a pair of functions `l` and `u` satisfying
  `l a ≤ b ↔ a ≤ u b`. They are special cases of  adjoint functors in category theory,
  but do not depend on the category theory library in mathlib.
* `galois_insertion`: A Galois insertion is a Galois connection where `l ∘ u = id`
* `galois_coinsertion`: A Galois coinsertion is a Galois connection where `u ∘ l = id`

## Implementation details

Galois insertions can be used to lift order structures from one type to another.
For example if `α` is a complete lattice, and `l : α → β`, and `u : β → α` form
a Galois insertion, then `β` is also a complete lattice. `l` is the lower adjoint and
`u` is the upper adjoint.

An example of this is the Galois insertion is in group thery. If `G` is a topological space,
then there is a Galois insertion between the set of subsets of `G`, `set G`, and the
set of subgroups of `G`, `subgroup G`. The left adjoint is `subgroup.closure`,
taking the `subgroup` generated by a `set`, The right adjoint is the coercion from `subgroup G` to
`set G`, taking the underlying set of a subgroup.

Naively lifting a lattice structure along this Galois insertion would mean that the definition
of `inf` on subgroups would be `subgroup.closure (↑S ∩ ↑T)`. This is an undesirable definition
because the intersection of subgroups is already a subgroup, so there is no need to take the
closure. For this reason a `choice` function is added as a field to the `galois_insertion`
structure. It has type `Π S : set G, ↑(closure S) ≤ S → subgroup G`. When `↑(closure S) ≤ S`, then
`S` is already a subgroup, so this function can be defined using `subgroup.mk` and not `closure`.
This means the infimum of subgroups will be defined to be the intersection of sets, paired
with a proof that intersection of subgroups is a subgroup, rather than the closure of the
intersection.

-/
open function set

universes u v w x
variables {α : Type u} {β : Type v} {γ : Type w} {ι : Sort x} {a a₁ a₂ : α} {b b₁ b₂ : β}

/-- A Galois connection is a pair of functions `l` and `u` satisfying
  `l a ≤ b ↔ a ≤ u b`. They are special cases of  adjoint functors in category theory,
    but do not depend on the category theory library in mathlib. -/
def galois_connection [preorder α] [preorder β] (l : α → β) (u : β → α) := ∀a b, l a ≤ b ↔ a ≤ u b

/-- Makes a Galois connection from an order-preserving bijection. -/
theorem order_iso.to_galois_connection [preorder α] [preorder β] (oi : α ≃o β) :
  galois_connection oi oi.symm :=
λ b g, oi.rel_symm_apply.symm

namespace galois_connection

section
variables [preorder α] [preorder β] {l : α → β} {u : β → α} (gc : galois_connection l u)

lemma monotone_intro (hu : monotone u) (hl : monotone l)
  (hul : ∀ a, a ≤ u (l a)) (hlu : ∀ a, l (u a) ≤ a) : galois_connection l u :=
assume a b, ⟨assume h, le_trans (hul _) (hu h), assume h, le_trans (hl h) (hlu _)⟩

include gc

lemma l_le {a : α} {b : β} : a ≤ u b → l a ≤ b :=
(gc _ _).mpr

lemma le_u {a : α} {b : β} : l a ≤ b → a ≤ u b :=
(gc _ _).mp

lemma le_u_l (a) : a ≤ u (l a) :=
gc.le_u $ le_refl _

lemma l_u_le (a) : l (u a) ≤ a :=
gc.l_le $ le_refl _

lemma monotone_u : monotone u :=
assume a b H, gc.le_u (le_trans (gc.l_u_le a) H)

lemma monotone_l : monotone l :=
assume a b H, gc.l_le (le_trans H (gc.le_u_l b))

lemma upper_bounds_l_image_subset {s : set α} : upper_bounds (l '' s) ⊆ u ⁻¹' upper_bounds s :=
assume b hb c, assume : c ∈ s, gc.le_u (hb (mem_image_of_mem _ ‹c ∈ s›))

lemma lower_bounds_u_image_subset {s : set β} : lower_bounds (u '' s) ⊆ l ⁻¹' lower_bounds s :=
assume a ha c, assume : c ∈ s, gc.l_le (ha (mem_image_of_mem _ ‹c ∈ s›))

lemma is_lub_l_image {s : set α} {a : α} (h : is_lub s a) : is_lub (l '' s) (l a) :=
⟨gc.monotone_l.mem_upper_bounds_image $ and.elim_left ‹is_lub s a›,
  assume b hb, gc.l_le $ and.elim_right ‹is_lub s a› $ gc.upper_bounds_l_image_subset hb⟩

lemma is_glb_u_image {s : set β} {b : β} (h : is_glb s b) : is_glb (u '' s) (u b) :=
⟨gc.monotone_u.mem_lower_bounds_image $ and.elim_left ‹is_glb s b›,
  assume a ha, gc.le_u $ and.elim_right ‹is_glb s b› $ gc.lower_bounds_u_image_subset ha⟩

lemma is_glb_l {a : α} : is_glb { b | a ≤ u b } (l a) :=
⟨assume b, gc.l_le, assume b h, h $ gc.le_u_l _⟩

lemma is_lub_u {b : β} : is_lub { a | l a ≤ b } (u b) :=
⟨assume b, gc.le_u, assume b h, h $ gc.l_u_le _⟩

end

section partial_order
variables [partial_order α] [partial_order β] {l : α → β} {u : β → α} (gc : galois_connection l u)
include gc

lemma u_l_u_eq_u : u ∘ l ∘ u = u :=
funext (assume x, le_antisymm (gc.monotone_u (gc.l_u_le _)) (gc.le_u_l _))

lemma l_u_l_eq_l : l ∘ u ∘ l = l :=
funext (assume x, le_antisymm (gc.l_u_le _) (gc.monotone_l (gc.le_u_l _)))

lemma l_unique {l' : α → β} {u' : β → α} (gc' : galois_connection l' u')
  (hu : ∀ b, u b = u' b) {a : α} : l a = l' a :=
le_antisymm (gc.l_le $ (hu (l' a)).symm ▸ gc'.le_u_l _)
  (gc'.l_le $ hu (l a) ▸ gc.le_u_l _)

lemma u_unique {l' : α → β} {u' : β → α} (gc' : galois_connection l' u')
  (hl : ∀ a, l a = l' a) {b : β} : u b = u' b :=
le_antisymm (gc'.le_u $ hl (u b) ▸ gc.l_u_le _)
  (gc.le_u $ (hl (u' b)).symm ▸ gc'.l_u_le _)

end partial_order

section order_top
variables [order_top α] [order_top β] {l : α → β} {u : β → α} (gc : galois_connection l u)
include gc

lemma u_top : u ⊤ = ⊤ :=
(gc.is_glb_u_image is_glb_empty).unique $ by simp only [is_glb_empty, image_empty]

end order_top

section order_bot
variables [order_bot α] [order_bot β] {l : α → β} {u : β → α} (gc : galois_connection l u)
include gc

lemma l_bot : l ⊥ = ⊥ :=
(gc.is_lub_l_image is_lub_empty).unique $ by simp only [is_lub_empty, image_empty]

end order_bot

section semilattice_sup
variables [semilattice_sup α] [semilattice_sup β] {l : α → β} {u : β → α}
  (gc : galois_connection l u)
include gc

lemma l_sup : l (a₁ ⊔ a₂) = l a₁ ⊔ l a₂ :=
(gc.is_lub_l_image is_lub_pair).unique $ by simp only [image_pair, is_lub_pair]

end semilattice_sup

section semilattice_inf
variables [semilattice_inf α] [semilattice_inf β] {l : α → β} {u : β → α}
  (gc : galois_connection l u)
include gc

lemma u_inf : u (b₁ ⊓ b₂) = u b₁ ⊓ u b₂ :=
(gc.is_glb_u_image is_glb_pair).unique $ by simp only [image_pair, is_glb_pair]

end semilattice_inf

section complete_lattice
variables [complete_lattice α] [complete_lattice β] {l : α → β} {u : β → α}
  (gc : galois_connection l u)
include gc

lemma l_supr {f : ι → α} : l (supr f) = (⨆i, l (f i)) :=
eq.symm $ is_lub.supr_eq $ show is_lub (range (l ∘ f)) (l (supr f)),
  by rw [range_comp, ← Sup_range]; exact gc.is_lub_l_image (is_lub_Sup _)

lemma u_infi {f : ι → β} : u (infi f) = (⨅i, u (f i)) :=
eq.symm $ is_glb.infi_eq $ show is_glb (range (u ∘ f)) (u (infi f)),
  by rw [range_comp, ← Inf_range]; exact gc.is_glb_u_image (is_glb_Inf _)

lemma l_Sup {s : set α} : l (Sup s) = (⨆a∈s, l a) :=
by simp only [Sup_eq_supr, gc.l_supr]

lemma u_Inf {s : set β} : u (Inf s) = (⨅a∈s, u a) :=
by simp only [Inf_eq_infi, gc.u_infi]

end complete_lattice

/- Constructing Galois connections -/
section constructions

protected lemma id [pα : preorder α] : @galois_connection α α pα pα id id :=
assume a b, iff.intro (λx, x) (λx, x)

protected lemma compose [preorder α] [preorder β] [preorder γ]
  (l1 : α → β) (u1 : β → α) (l2 : β → γ) (u2 : γ → β)
  (gc1 : galois_connection l1 u1) (gc2 : galois_connection l2 u2) :
  galois_connection (l2 ∘ l1) (u1 ∘ u2) :=
by intros a b; rw [gc2, gc1]

protected lemma dual [pα : preorder α] [pβ : preorder β]
  {l : α → β} {u : β → α} (gc : galois_connection l u) :
  @galois_connection (order_dual β) (order_dual α) _ _ u l :=
assume a b, (gc _ _).symm

protected lemma dfun {ι : Type u} {α : ι → Type v} {β : ι → Type w}
  [∀i, preorder (α i)] [∀i, preorder (β i)]
  (l : Πi, α i → β i) (u : Πi, β i → α i) (gc : ∀i, galois_connection (l i) (u i)) :
  @galois_connection (Π i, α i) (Π i, β i) _ _ (λa i, l i (a i)) (λb i, u i (b i)) :=
assume a b, forall_congr $ assume i, gc i (a i) (b i)

end constructions

end galois_connection

namespace nat

lemma galois_connection_mul_div {k : ℕ} (h : 0 < k) : galois_connection (λn, n * k) (λn, n / k) :=
assume x y, (le_div_iff_mul_le x y h).symm

end nat

/-- A Galois insertion is a Galois connection where `l ∘ u = id`. It also contains a constructive
choice function, to give better definitional equalities when lifting order structures. Dual
to `galois_coinsertion` -/
@[nolint has_inhabited_instance]
structure galois_insertion {α β : Type*} [preorder α] [preorder β] (l : α → β) (u : β → α) :=
(choice : Πx:α, u (l x) ≤ x → β)
(gc : galois_connection l u)
(le_l_u : ∀x, x ≤ l (u x))
(choice_eq : ∀a h, choice a h = l a)

/-- A constructor for a Galois insertion with the trivial `choice` function. -/
def galois_insertion.monotone_intro {α β : Type*} [preorder α] [preorder β] {l : α → β} {u : β → α}
  (hu : monotone u) (hl : monotone l) (hul : ∀ a, a ≤ u (l a)) (hlu : ∀ b, l (u b) = b) :
  galois_insertion l u :=
{ choice := λ x _, l x,
  gc := galois_connection.monotone_intro hu hl hul (λ b, le_of_eq (hlu b)),
  le_l_u := λ b, le_of_eq $ (hlu b).symm,
  choice_eq := λ _ _, rfl }

/-- Makes a Galois insertion from an order-preserving bijection. -/
protected def rel_iso.to_galois_insertion [preorder α] [preorder β] (oi : α ≃o β) :
@galois_insertion α β _ _ (oi) (oi.symm) :=
{ choice := λ b h, oi b,
  gc := oi.to_galois_connection,
  le_l_u := λ g, le_of_eq (oi.right_inv g).symm,
  choice_eq := λ b h, rfl }

/-- Make a `galois_insertion l u` from a `galois_connection l u` such that `∀ b, b ≤ l (u b)` -/
def galois_connection.to_galois_insertion {α β : Type*} [preorder α] [preorder β]
  {l : α → β} {u : β → α} (gc : galois_connection l u) (h : ∀ b, b ≤ l (u b)) :
  galois_insertion l u :=
{ choice := λ x _, l x,
  gc := gc,
  le_l_u := h,
  choice_eq := λ _ _, rfl }

/-- Lift the bottom along a Galois connection -/
def galois_connection.lift_order_bot {α β : Type*} [order_bot α] [partial_order β]
  {l : α → β} {u : β → α} (gc : galois_connection l u) :
  order_bot β :=
{ bot    := l ⊥,
  bot_le := assume b, gc.l_le $ bot_le,
  .. ‹partial_order β› }

namespace galois_insertion

variables {l : α → β} {u : β → α}

lemma l_u_eq [preorder α] [partial_order β] (gi : galois_insertion l u) (b : β) :
  l (u b) = b :=
le_antisymm (gi.gc.l_u_le _) (gi.le_l_u _)

lemma l_surjective [preorder α] [partial_order β] (gi : galois_insertion l u) :
  surjective l :=
assume b, ⟨u b, gi.l_u_eq b⟩

lemma u_injective [preorder α] [partial_order β] (gi : galois_insertion l u) :
  injective u :=
assume a b h,
calc a = l (u a) : (gi.l_u_eq a).symm
   ... = l (u b) : congr_arg l h
   ... = b       : gi.l_u_eq b

lemma l_sup_u [semilattice_sup α] [semilattice_sup β] (gi : galois_insertion l u) (a b : β) :
  l (u a ⊔ u b) = a ⊔ b :=
calc l (u a ⊔ u b) = l (u a) ⊔ l (u b) : gi.gc.l_sup
               ... = a ⊔ b : by simp only [gi.l_u_eq]

lemma l_supr_u [complete_lattice α] [complete_lattice β] (gi : galois_insertion l u)
  {ι : Sort x} (f : ι → β) :
  l (⨆ i, u (f i)) = ⨆ i, (f i) :=
calc l (⨆ (i : ι), u (f i)) = ⨆ (i : ι), l (u (f i)) : gi.gc.l_supr
                        ... = ⨆ (i : ι), f i : congr_arg _ $ funext $ λ i, gi.l_u_eq (f i)

lemma l_supr_of_ul_eq_self [complete_lattice α] [complete_lattice β] (gi : galois_insertion l u)
  {ι : Sort x} (f : ι → α) (hf : ∀ i, u (l (f i)) = f i) :
  l (⨆ i, (f i)) = ⨆ i, l (f i) :=
calc l (⨆ (i : ι), (f i)) = l ⨆ (i : ι), (u (l (f i))) : by simp [hf]
                        ... = ⨆ (i : ι), l (f i) : gi.l_supr_u _

lemma l_inf_u [semilattice_inf α] [semilattice_inf β] (gi : galois_insertion l u) (a b : β) :
  l (u a ⊓ u b) = a ⊓ b :=
calc l (u a ⊓ u b) = l (u (a ⊓ b)) : congr_arg l gi.gc.u_inf.symm
               ... = a ⊓ b : by simp only [gi.l_u_eq]

lemma l_infi_u [complete_lattice α] [complete_lattice β] (gi : galois_insertion l u)
  {ι : Sort x} (f : ι → β) :
  l (⨅ i, u (f i)) = ⨅ i, (f i) :=
calc l (⨅ (i : ι), u (f i)) = l (u (⨅ (i : ι), (f i))) : congr_arg l gi.gc.u_infi.symm
                        ... = ⨅ (i : ι), f i : gi.l_u_eq _

lemma l_infi_of_ul_eq_self [complete_lattice α] [complete_lattice β] (gi : galois_insertion l u)
  {ι : Sort x} (f : ι → α) (hf : ∀ i, u (l (f i)) = f i) :
  l (⨅ i, (f i)) = ⨅ i, l (f i) :=
calc l (⨅ i, (f i)) =  l ⨅ (i : ι), (u (l (f i))) : by simp [hf]
                ... = ⨅ i, l (f i) : gi.l_infi_u _

lemma u_le_u_iff [preorder α] [preorder β] (gi : galois_insertion l u) {a b} :
  u a ≤ u b ↔ a ≤ b :=
⟨λ h, le_trans (gi.le_l_u _) (gi.gc.l_le h),
    λ h, gi.gc.monotone_u h⟩

lemma strict_mono_u [preorder α] [partial_order β] (gi : galois_insertion l u) : strict_mono u :=
strict_mono_of_le_iff_le $ λ _ _, gi.u_le_u_iff.symm

section lift

variables [partial_order β]

/-- Lift the suprema along a Galois insertion -/
def lift_semilattice_sup [semilattice_sup α] (gi : galois_insertion l u) : semilattice_sup β :=
{ sup := λa b, l (u a ⊔ u b),
  le_sup_left  := assume a b, le_trans (gi.le_l_u a) $ gi.gc.monotone_l $ le_sup_left,
  le_sup_right := assume a b, le_trans (gi.le_l_u b) $ gi.gc.monotone_l $ le_sup_right,
  sup_le       := assume a b c hac hbc,
    gi.gc.l_le $ sup_le (gi.gc.monotone_u hac) (gi.gc.monotone_u hbc),
  .. ‹partial_order β› }

/-- Lift the infima along a Galois insertion -/
def lift_semilattice_inf [semilattice_inf α] (gi : galois_insertion l u) : semilattice_inf β :=
{ inf := λa b, gi.choice (u a ⊓ u b) $
    (le_inf (gi.gc.monotone_u $ gi.gc.l_le $ inf_le_left)
      (gi.gc.monotone_u $ gi.gc.l_le $ inf_le_right)),
  inf_le_left  := by simp only [gi.choice_eq]; exact assume a b, gi.gc.l_le inf_le_left,
  inf_le_right := by simp only [gi.choice_eq]; exact assume a b, gi.gc.l_le inf_le_right,
  le_inf       := by simp only [gi.choice_eq]; exact assume a b c hac hbc,
    (gi.le_l_u a).trans $ gi.gc.monotone_l $ le_inf (gi.gc.monotone_u hac) (gi.gc.monotone_u hbc),
  .. ‹partial_order β› }

/-- Lift the suprema and infima along a Galois insertion -/
def lift_lattice [lattice α] (gi : galois_insertion l u) : lattice β :=
{ .. gi.lift_semilattice_sup, .. gi.lift_semilattice_inf }

/-- Lift the top along a Galois insertion -/
def lift_order_top [order_top α] (gi : galois_insertion l u) : order_top β :=
{ top    := gi.choice ⊤ $ le_top,
  le_top := by simp only [gi.choice_eq]; exact λ b, (gi.le_l_u b).trans (gi.gc.monotone_l le_top),
  .. ‹partial_order β› }

/-- Lift the top, bottom, suprema, and infima along a Galois insertion -/
def lift_bounded_lattice [bounded_lattice α] (gi : galois_insertion l u) : bounded_lattice β :=
{ .. gi.lift_lattice, .. gi.lift_order_top, .. gi.gc.lift_order_bot }

/-- Lift all suprema and infima along a Galois insertion -/
def lift_complete_lattice [complete_lattice α] (gi : galois_insertion l u) : complete_lattice β :=
{ Sup := λs, l (⨆ b∈s, u b),
  Sup_le := λ s a hs, gi.gc.l_le $ supr_le $ λ b, supr_le $ λ hb, gi.gc.monotone_u $ hs _ hb,
  le_Sup := λ s a ha, le_trans (gi.le_l_u a) $
    gi.gc.monotone_l $ le_supr_of_le a $ le_supr_of_le ha $ le_refl _,
  Inf := λs, gi.choice (⨅ b∈s, u b) $ le_infi $ assume b, le_infi $ assume hb,
    gi.gc.monotone_u $ gi.gc.l_le $ infi_le_of_le b $ infi_le_of_le hb $ le_refl _,
  Inf_le := by simp only [gi.choice_eq]; exact
    assume s a ha, gi.gc.l_le $ infi_le_of_le a $ infi_le_of_le ha $ le_refl _,
  le_Inf := by simp only [gi.choice_eq]; exact
    assume s a hs, le_trans (gi.le_l_u a) $ gi.gc.monotone_l $ le_infi $ assume b,
    show u a ≤ ⨅ (H : b ∈ s), u b, from le_infi $ assume hb, gi.gc.monotone_u $ hs _ hb,
  .. gi.lift_bounded_lattice }

end lift

end galois_insertion

/-- A Galois coinsertion is a Galois connection where `u ∘ l = id`. It also contains a constructive
choice function, to give better definitional equalities when lifting order structures. Dual to
`galois_insertion` -/
@[nolint has_inhabited_instance]
structure galois_coinsertion {α β : Type*} [preorder α] [preorder β] (l : α → β) (u : β → α) :=
(choice : Πx:β, x ≤ l (u x) → α)
(gc : galois_connection l u)
(u_l_le : ∀x, u (l x) ≤ x)
(choice_eq : ∀a h, choice a h = u a)

/-- Make a `galois_insertion u l` in the `order_dual`, from a `galois_coinsertion l u` -/
def galois_coinsertion.dual {α β : Type*} [preorder α] [preorder β] {l : α → β} {u : β → α} :
  galois_coinsertion l u → @galois_insertion (order_dual β) (order_dual α) _ _ u l :=
λ x, ⟨x.1, x.2.dual, x.3, x.4⟩

/-- Make a `galois_coinsertion u l` in the `order_dual`, from a `galois_insertion l u` -/
def galois_insertion.dual {α β : Type*} [preorder α] [preorder β] {l : α → β} {u : β → α} :
  galois_insertion l u → @galois_coinsertion (order_dual β) (order_dual α) _ _ u l :=
λ x, ⟨x.1, x.2.dual, x.3, x.4⟩

/-- Make a `galois_coinsertion l u` from a `galois_insertion l u` in the `order_dual` -/
def galois_coinsertion.of_dual {α β : Type*} [preorder α] [preorder β] {l : α → β} {u : β → α} :
  @galois_insertion (order_dual β) (order_dual α) _ _ u l → galois_coinsertion l u :=
λ x, ⟨x.1, x.2.dual, x.3, x.4⟩

/-- Make a `galois_insertion l u` from a `galois_coinsertion l u` in the `order_dual` -/
def galois_insertion.of_dual {α β : Type*} [preorder α] [preorder β] {l : α → β} {u : β → α} :
  @galois_coinsertion (order_dual β) (order_dual α) _ _ u l → galois_insertion l u :=
λ x, ⟨x.1, x.2.dual, x.3, x.4⟩

/-- Makes a Galois coinsertion from an order-preserving bijection. -/
protected def rel_iso.to_galois_coinsertion [preorder α] [preorder β] (oi : α ≃o β) :
@galois_coinsertion α β _ _ (oi) (oi.symm) :=
{ choice := λ b h, oi.symm b,
  gc := oi.to_galois_connection,
  u_l_le := λ g, le_of_eq (oi.left_inv g),
  choice_eq := λ b h, rfl }

/-- A constructor for a Galois coinsertion with the trivial `choice` function. -/
def galois_coinsertion.monotone_intro [preorder α] [preorder β] {l : α → β} {u : β → α}
  (hu : monotone u) (hl : monotone l) (hlu : ∀ b, l (u b) ≤ b)
  (hul : ∀ a, u (l a) = a) :
  galois_coinsertion l u :=
galois_coinsertion.of_dual (galois_insertion.monotone_intro hl.order_dual hu.order_dual hlu hul)

/-- Make a `galois_coinsertion l u` from a `galois_connection l u` such that `∀ b, b ≤ l (u b)` -/
def galois_connection.to_galois_coinsertion {α β : Type*} [preorder α] [preorder β]
  {l : α → β} {u : β → α} (gc : galois_connection l u) (h : ∀ a, u (l a) ≤ a) :
  galois_coinsertion l u :=
{ choice := λ x _, u x,
  gc := gc,
  u_l_le := h,
  choice_eq := λ _ _, rfl }

/-- Lift the top along a Galois connection -/
def galois_connection.lift_order_top {α β : Type*} [partial_order α] [order_top β]
  {l : α → β} {u : β → α} (gc : galois_connection l u) :
  order_top α :=
{ top    := u ⊤,
  le_top := assume b, gc.le_u $ le_top,
  .. ‹partial_order α› }

namespace galois_coinsertion

variables {l : α → β} {u : β → α}

lemma u_l_eq [partial_order α] [preorder β] (gi : galois_coinsertion l u) (a : α) :
  u (l a) = a :=
gi.dual.l_u_eq a

lemma u_surjective [partial_order α] [preorder β] (gi : galois_coinsertion l u) :
  surjective u :=
gi.dual.l_surjective

lemma l_injective [partial_order α] [preorder β] (gi : galois_coinsertion l u) :
  injective l :=
gi.dual.u_injective

lemma u_inf_l [semilattice_inf α] [semilattice_inf β] (gi : galois_coinsertion l u) (a b : α) :
  u (l a ⊓ l b) = a ⊓ b :=
gi.dual.l_sup_u a b

lemma u_infi_l [complete_lattice α] [complete_lattice β] (gi : galois_coinsertion l u)
  {ι : Sort x} (f : ι → α) :
  u (⨅ i, l (f i)) = ⨅ i, (f i) :=
gi.dual.l_supr_u _

lemma u_infi_of_lu_eq_self [complete_lattice α] [complete_lattice β] (gi : galois_coinsertion l u)
  {ι : Sort x} (f : ι → β) (hf : ∀ i, l (u (f i)) = f i) :
  u (⨅ i, (f i)) = ⨅ i, u (f i) :=
gi.dual.l_supr_of_ul_eq_self _ hf

lemma u_sup_l [semilattice_sup α] [semilattice_sup β] (gi : galois_coinsertion l u) (a b : α) :
  u (l a ⊔ l b) = a ⊔ b :=
gi.dual.l_inf_u _ _

lemma u_supr_l [complete_lattice α] [complete_lattice β] (gi : galois_coinsertion l u)
  {ι : Sort x} (f : ι → α) :
  u (⨆ i, l (f i)) = ⨆ i, (f i) :=
gi.dual.l_infi_u _

lemma u_supr_of_lu_eq_self [complete_lattice α] [complete_lattice β] (gi : galois_coinsertion l u)
  {ι : Sort x} (f : ι → β) (hf : ∀ i, l (u (f i)) = f i) :
  u (⨆ i, (f i)) = ⨆ i, u (f i) :=
gi.dual.l_infi_of_ul_eq_self _ hf

lemma l_le_l_iff [preorder α] [preorder β] (gi : galois_coinsertion l u) {a b} :
  l a ≤ l b ↔ a ≤ b :=
gi.dual.u_le_u_iff

lemma strict_mono_l [partial_order α] [preorder β] (gi : galois_coinsertion l u) : strict_mono l :=
λ a b h, gi.dual.strict_mono_u h

section lift

variables [partial_order α]

/-- Lift the infima along a Galois coinsertion -/
def lift_semilattice_inf [semilattice_inf β] (gi : galois_coinsertion l u) : semilattice_inf α :=
{ inf := λa b, u (l a ⊓ l b),
  inf_le_left  := assume a b, le_trans (gi.gc.monotone_u $ inf_le_left) (gi.u_l_le a),
  inf_le_right := assume a b, le_trans (gi.gc.monotone_u $ inf_le_right) (gi.u_l_le b),
  le_inf       := assume a b c hac hbc, gi.gc.le_u $ le_inf (gi.gc.monotone_l hac)
    (gi.gc.monotone_l hbc),
  .. ‹partial_order α› }

/-- Lift the suprema along a Galois coinsertion -/
def lift_semilattice_sup [semilattice_sup β] (gi : galois_coinsertion l u) : semilattice_sup α :=
{ sup := λa b, gi.choice (l a ⊔ l b) $
    (sup_le (gi.gc.monotone_l $ gi.gc.le_u $ le_sup_left)
      (gi.gc.monotone_l $ gi.gc.le_u $ le_sup_right)),
  le_sup_left  := by simp only [gi.choice_eq]; exact assume a b, gi.gc.le_u le_sup_left,
  le_sup_right := by simp only [gi.choice_eq]; exact assume a b, gi.gc.le_u le_sup_right,
  sup_le       := by simp only [gi.choice_eq]; exact assume a b c hac hbc,
    (gi.gc.monotone_u $ sup_le (gi.gc.monotone_l hac) (gi.gc.monotone_l hbc)).trans (gi.u_l_le c),
  .. ‹partial_order α› }

/-- Lift the suprema and infima along a Galois coinsertion -/
def lift_lattice [lattice β] (gi : galois_coinsertion l u) : lattice α :=
{ .. gi.lift_semilattice_sup, .. gi.lift_semilattice_inf }

/-- Lift the bot along a Galois coinsertion -/
def lift_order_bot [order_bot β] (gi : galois_coinsertion l u) : order_bot α :=
{ bot    := gi.choice ⊥ $ bot_le,
  bot_le := by simp only [gi.choice_eq];
    exact assume b, le_trans (gi.gc.monotone_u bot_le) (gi.u_l_le b),
  .. ‹partial_order α› }

/-- Lift the top, bottom, suprema, and infima along a Galois coinsertion -/
def lift_bounded_lattice [bounded_lattice β] (gi : galois_coinsertion l u) : bounded_lattice α :=
{ .. gi.lift_lattice, .. gi.lift_order_bot, .. gi.gc.lift_order_top }

/-- Lift all suprema and infima along a Galois coinsertion -/
def lift_complete_lattice [complete_lattice β] (gi : galois_coinsertion l u) : complete_lattice α :=
{ Inf := λs, u (⨅ a∈s, l a),
  le_Inf := assume s a hs, gi.gc.le_u $ le_infi $ assume b, le_infi $
    assume hb, gi.gc.monotone_l $ hs _ hb,
  Inf_le := assume s a ha, le_trans (gi.gc.monotone_u $ infi_le_of_le a $
    infi_le_of_le ha $ le_refl _) (gi.u_l_le a),
  Sup := λs, gi.choice (⨆ a∈s, l a) $ supr_le $ assume b, supr_le $ assume hb,
    gi.gc.monotone_l $ gi.gc.le_u $ le_supr_of_le b $ le_supr_of_le hb $ le_refl _,
  le_Sup := by simp only [gi.choice_eq]; exact
    assume s a ha, gi.gc.le_u $ le_supr_of_le a $ le_supr_of_le ha $ le_refl _,
  Sup_le := by simp only [gi.choice_eq]; exact
    assume s a hs, le_trans (gi.gc.monotone_u $ supr_le $ assume b,
        show (⨆ (hb : b ∈ s), l b) ≤ l a, from supr_le $ assume hb, gi.gc.monotone_l $ hs b hb)
      (gi.u_l_le a),
  .. gi.lift_bounded_lattice }

end lift

end galois_coinsertion

/-- If `α` is a partial order with bottom element (e.g., `ℕ`, `ℝ≥0`), then
`λ o : with_bot α, o.get_or_else ⊥` and coercion form a Galois insertion. -/
def with_bot.gi_get_or_else_bot [order_bot α] :
  galois_insertion (λ o : with_bot α, o.get_or_else ⊥) coe :=
{ gc := λ a b, with_bot.get_or_else_bot_le_iff,
  le_l_u := λ a, le_rfl,
  choice := λ o ho, _,
  choice_eq := λ _ _, rfl }


/-
Copyright (c) 2021 Eric Wieser. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Eric Wieser, Frédéric Dupuis
-/
import algebra.star.self_adjoint
import algebra.module.equiv
import linear_algebra.prod

/-!
# The star operation, bundled as a star-linear equiv

We define `star_linear_equiv`, which is the star operation bundled as a star-linear map.
It is defined on a star algebra `A` over the base ring `R`.

## TODO

- Define `star_linear_equiv` for noncommutative `R`. We only the commutative case for now since,
  in the noncommutative case, the ring hom needs to reverse the order of multiplication. This
  requires a ring hom of type `R →+* Rᵐᵒᵖ`, which is very undesirable in the commutative case.
  One way out would be to define a new typeclass `is_op R S` and have an instance `is_op R R`
  for commutative `R`.
- Also note that such a definition involving `Rᵐᵒᵖ` or `is_op R S` would require adding
  the appropriate `ring_hom_inv_pair` instances to be able to define the semilinear
  equivalence.
-/

/-- If `A` is a module over a commutative `R` with compatible actions,
then `star` is a semilinear equivalence. -/
@[simps]
def star_linear_equiv (R : Type*) {A : Type*}
  [comm_ring R] [star_ring R] [semiring A] [star_ring A] [module R A] [star_module R A]  :
    A ≃ₗ⋆[R] A :=
{ to_fun := star,
  map_smul' := star_smul,
  .. star_add_equiv }

variables (R : Type*) (A : Type*)
  [semiring R] [star_semigroup R] [has_trivial_star R]
  [add_comm_group A] [module R A] [star_add_monoid A] [star_module R A]

/-- The self-adjoint elements of a star module, as a submodule. -/
def self_adjoint.submodule : submodule R A :=
{ smul_mem' := self_adjoint.smul_mem,
  ..self_adjoint A }

/-- The skew-adjoint elements of a star module, as a submodule. -/
def skew_adjoint.submodule : submodule R A :=
{ smul_mem' := skew_adjoint.smul_mem,
  ..skew_adjoint A }

variables {A} [invertible (2 : R)]

/-- The self-adjoint part of an element of a star module, as a linear map. -/
@[simps] def self_adjoint_part : A →ₗ[R] self_adjoint A :=
{ to_fun := λ x, ⟨(⅟2 : R) • (x + star x),
  by simp only [self_adjoint.mem_iff, star_smul, add_comm,
                  star_add_monoid.star_add, star_inv', star_bit0,
                  star_one, star_star, star_inv_of (2 : R), star_trivial]⟩,
  map_add' := λ x y, by { ext, simp [add_add_add_comm] },
  map_smul' := λ r x, by { ext, simp [←mul_smul,
          show ⅟ 2 * r = r * ⅟ 2, from commute.inv_of_left (commute.one_left r).bit0_left] } }

/-- The skew-adjoint part of an element of a star module, as a linear map. -/
@[simps] def skew_adjoint_part : A →ₗ[R] skew_adjoint A :=
{ to_fun := λ x, ⟨(⅟2 : R) • (x - star x),
    by simp only [skew_adjoint.mem_iff, star_smul, star_sub, star_star, star_trivial, ←smul_neg,
                  neg_sub]⟩,
  map_add' := λ x y, by { ext, simp only [sub_add, ←smul_add, sub_sub_assoc_swap, star_add,
                                          add_subgroup.coe_mk, add_subgroup.coe_add] },
  map_smul' := λ r x, by { ext, simp [←mul_smul, ←smul_sub,
            show r * ⅟ 2 = ⅟ 2 * r, from commute.inv_of_right (commute.one_right r).bit0_right] } }

lemma star_module.self_adjoint_part_add_skew_adjoint_part (x : A) :
  (self_adjoint_part R x : A) + skew_adjoint_part R x = x :=
by simp only [smul_sub, self_adjoint_part_apply_coe, smul_add, skew_adjoint_part_apply_coe,
              add_add_sub_cancel, inv_of_two_smul_add_inv_of_two_smul]

variables (A)

/-- The decomposition of elements of a star module into their self- and skew-adjoint parts,
as a linear equivalence. -/
@[simps] def star_module.decompose_prod_adjoint : A ≃ₗ[R] self_adjoint A × skew_adjoint A :=
linear_equiv.of_linear
  ((self_adjoint_part R).prod (skew_adjoint_part R))
  ((self_adjoint.submodule R A).subtype.coprod (skew_adjoint.submodule R A).subtype)
  (by ext; simp)
  (linear_map.ext $ star_module.self_adjoint_part_add_skew_adjoint_part R)


/- Tactic : refl

## Summary

`refl` is a tactic which proves goals of the form `X = X`.

## Details

The `refl` tactic will close any goal of the form `A = B`
where `A` and `B` are *exactly the same thing*.

### Example:
If it looks like this in the top right hand box:
```
A : Point
⊢ A = A
```

then

`refl,`

will close the goal and solve the level. Don't forget the comma.

-/

/-
We will start by practising with the simplest tactic, namely *refl*. This just proves goals
of the form $A = A$, no matter how complicated $A$ is. Let's see it in action!
-/

/- Hint : Click here for a hint, in case you get stuck.
Just delete `sorry` and type `refl,` (don't forget the comma!).
-/

variables {Ω : Type} -- hide

/- Lemma : no-side-bar
If A is a point, then A = A.
-/
lemma refl_example (A : Ω) : A = A :=
begin
  refl,

end


/-
Copyright (c) 2018 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Callum Sutton, Yury Kudryashov
-/
import data.equiv.mul_add
import algebra.field
import algebra.opposites

/-!
# (Semi)ring equivs

In this file we define extension of `equiv` called `ring_equiv`, which is a datatype representing an
isomorphism of `semiring`s, `ring`s, `division_ring`s, or `field`s. We also introduce the
corresponding group of automorphisms `ring_aut`.

## Notations

* ``infix ` ≃+* `:25 := ring_equiv``

The extended equiv have coercions to functions, and the coercion is the canonical notation when
treating the isomorphism as maps.

## Implementation notes

The fields for `ring_equiv` now avoid the unbundled `is_mul_hom` and `is_add_hom`, as these are
deprecated.

Definition of multiplication in the groups of automorphisms agrees with function composition,
multiplication in `equiv.perm`, and multiplication in `category_theory.End`, not with
`category_theory.comp`.

## Tags

equiv, mul_equiv, add_equiv, ring_equiv, mul_aut, add_aut, ring_aut
-/

variables {R : Type*} {S : Type*} {S' : Type*}

set_option old_structure_cmd true

/-- An equivalence between two (semi)rings that preserves the algebraic structure. -/
structure ring_equiv (R S : Type*) [has_mul R] [has_add R] [has_mul S] [has_add S]
  extends R ≃ S, R ≃* S, R ≃+ S

infix ` ≃+* `:25 := ring_equiv

/-- The "plain" equivalence of types underlying an equivalence of (semi)rings. -/
add_decl_doc ring_equiv.to_equiv

/-- The equivalence of additive monoids underlying an equivalence of (semi)rings. -/
add_decl_doc ring_equiv.to_add_equiv

/-- The equivalence of multiplicative monoids underlying an equivalence of (semi)rings. -/
add_decl_doc ring_equiv.to_mul_equiv

namespace ring_equiv

section basic

variables [has_mul R] [has_add R] [has_mul S] [has_add S] [has_mul S'] [has_add S']

instance : has_coe_to_fun (R ≃+* S) := ⟨_, ring_equiv.to_fun⟩

@[simp] lemma to_fun_eq_coe (f : R ≃+* S) : f.to_fun = f := rfl

/-- A ring isomorphism preserves multiplication. -/
@[simp] lemma map_mul (e : R ≃+* S) (x y : R) : e (x * y) = e x * e y := e.map_mul' x y

/-- A ring isomorphism preserves addition. -/
@[simp] lemma map_add (e : R ≃+* S) (x y : R) : e (x + y) = e x + e y := e.map_add' x y

/-- Two ring isomorphisms agree if they are defined by the
    same underlying function. -/
@[ext] lemma ext {f g : R ≃+* S} (h : ∀ x, f x = g x) : f = g :=
begin
  have h₁ : f.to_equiv = g.to_equiv := equiv.ext h,
  cases f, cases g, congr,
  { exact (funext h) },
  { exact congr_arg equiv.inv_fun h₁ }
end

@[simp] theorem coe_mk (e e' h₁ h₂ h₃ h₄) :
  ⇑(⟨e, e', h₁, h₂, h₃, h₄⟩ : R ≃+* S) = e := rfl

@[simp] theorem mk_coe (e : R ≃+* S) (e' h₁ h₂ h₃ h₄) :
  (⟨e, e', h₁, h₂, h₃, h₄⟩ : R ≃+* S) = e := ext $ λ _, rfl

protected lemma congr_arg {f : R ≃+* S} : Π {x x' : R}, x = x' → f x = f x'
| _ _ rfl := rfl

protected lemma congr_fun {f g : R ≃+* S} (h : f = g) (x : R) : f x = g x := h ▸ rfl

lemma ext_iff {f g : R ≃+* S} : f = g ↔ ∀ x, f x = g x :=
⟨λ h x, h ▸ rfl, ext⟩

instance has_coe_to_mul_equiv : has_coe (R ≃+* S) (R ≃* S) := ⟨ring_equiv.to_mul_equiv⟩

instance has_coe_to_add_equiv : has_coe (R ≃+* S) (R ≃+ S) := ⟨ring_equiv.to_add_equiv⟩

lemma to_add_equiv_eq_coe (f : R ≃+* S) : f.to_add_equiv = ↑f := rfl

lemma to_mul_equiv_eq_coe (f : R ≃+* S) : f.to_mul_equiv = ↑f := rfl

@[simp, norm_cast] lemma coe_to_mul_equiv (f : R ≃+* S) : ⇑(f : R ≃* S) = f := rfl

@[simp, norm_cast] lemma coe_to_add_equiv (f : R ≃+* S) : ⇑(f : R ≃+ S) = f := rfl

/-- The `ring_equiv` between two semirings with a unique element. -/
def ring_equiv_of_unique_of_unique {M N}
  [unique M] [unique N] [has_add M] [has_mul M] [has_add N] [has_mul N] : M ≃+* N :=
{ ..add_equiv.add_equiv_of_unique_of_unique,
  ..mul_equiv.mul_equiv_of_unique_of_unique}

instance {M N} [unique M] [unique N] [has_add M] [has_mul M] [has_add N] [has_mul N] :
  unique (M ≃+* N) :=
{ default := ring_equiv_of_unique_of_unique,
  uniq := λ _, ext $ λ x, subsingleton.elim _ _ }

variable (R)

/-- The identity map is a ring isomorphism. -/
@[refl] protected def refl : R ≃+* R := { .. mul_equiv.refl R, .. add_equiv.refl R }

@[simp] lemma refl_apply (x : R) : ring_equiv.refl R x = x := rfl

@[simp] lemma coe_add_equiv_refl : (ring_equiv.refl R : R ≃+ R) = add_equiv.refl R := rfl

@[simp] lemma coe_mul_equiv_refl : (ring_equiv.refl R : R ≃* R) = mul_equiv.refl R := rfl

instance : inhabited (R ≃+* R) := ⟨ring_equiv.refl R⟩

variables {R}

/-- The inverse of a ring isomorphism is a ring isomorphism. -/
@[symm] protected def symm (e : R ≃+* S) : S ≃+* R :=
{ .. e.to_mul_equiv.symm, .. e.to_add_equiv.symm }

/-- See Note [custom simps projection] -/
def simps.symm_apply (e : R ≃+* S) : S → R := e.symm

initialize_simps_projections ring_equiv (to_fun → apply, inv_fun → symm_apply)

@[simp] lemma symm_symm (e : R ≃+* S) : e.symm.symm = e := ext $ λ x, rfl

lemma symm_bijective : function.bijective (ring_equiv.symm : (R ≃+* S) → (S ≃+* R)) :=
equiv.bijective ⟨ring_equiv.symm, ring_equiv.symm, symm_symm, symm_symm⟩

@[simp] lemma mk_coe' (e : R ≃+* S) (f h₁ h₂ h₃ h₄) :
  (ring_equiv.mk f ⇑e h₁ h₂ h₃ h₄ : S ≃+* R) = e.symm :=
symm_bijective.injective $ ext $ λ x, rfl

@[simp] lemma symm_mk (f : R → S) (g h₁ h₂ h₃ h₄) :
  (mk f g h₁ h₂ h₃ h₄).symm =
  { to_fun := g, inv_fun := f, ..(mk f g h₁ h₂ h₃ h₄).symm} := rfl

/-- Transitivity of `ring_equiv`. -/
@[trans] protected def trans (e₁ : R ≃+* S) (e₂ : S ≃+* S') : R ≃+* S' :=
{ .. (e₁.to_mul_equiv.trans e₂.to_mul_equiv), .. (e₁.to_add_equiv.trans e₂.to_add_equiv) }

@[simp] lemma trans_apply (e₁ : R ≃+* S) (e₂ : S ≃+* S') (a : R) :
  e₁.trans e₂ a = e₂ (e₁ a) := rfl

protected lemma bijective (e : R ≃+* S) : function.bijective e := e.to_equiv.bijective
protected lemma injective (e : R ≃+* S) : function.injective e := e.to_equiv.injective
protected lemma surjective (e : R ≃+* S) : function.surjective e := e.to_equiv.surjective

@[simp] lemma apply_symm_apply (e : R ≃+* S) : ∀ x, e (e.symm x) = x := e.to_equiv.apply_symm_apply
@[simp] lemma symm_apply_apply (e : R ≃+* S) : ∀ x, e.symm (e x) = x := e.to_equiv.symm_apply_apply

lemma image_eq_preimage (e : R ≃+* S) (s : set R) : e '' s = e.symm ⁻¹' s :=
e.to_equiv.image_eq_preimage s

end basic

section comm_semiring
open opposite

variables (R) [comm_semiring R]

/-- A commutative ring is isomorphic to its opposite. -/
def to_opposite : R ≃+* Rᵒᵖ :=
{ map_add' := λ x y, rfl,
  map_mul' := λ x y, mul_comm (op y) (op x),
  ..equiv_to_opposite }

@[simp]
lemma to_opposite_apply (r : R) : to_opposite R r = op r := rfl

@[simp]
lemma to_opposite_symm_apply (r : Rᵒᵖ) : (to_opposite R).symm r = unop r := rfl

end comm_semiring

section semiring

variables [semiring R] [semiring S] (f : R ≃+* S) (x y : R)

/-- A ring isomorphism sends one to one. -/
@[simp] lemma map_one : f 1 = 1 := (f : R ≃* S).map_one

/-- A ring isomorphism sends zero to zero. -/
@[simp] lemma map_zero : f 0 = 0 := (f : R ≃+ S).map_zero

variable {x}

@[simp] lemma map_eq_one_iff : f x = 1 ↔ x = 1 := (f : R ≃* S).map_eq_one_iff
@[simp] lemma map_eq_zero_iff : f x = 0 ↔ x = 0 := (f : R ≃+ S).map_eq_zero_iff

lemma map_ne_one_iff : f x ≠ 1 ↔ x ≠ 1 := (f : R ≃* S).map_ne_one_iff
lemma map_ne_zero_iff : f x ≠ 0 ↔ x ≠ 0 := (f : R ≃+ S).map_ne_zero_iff

/-- Produce a ring isomorphism from a bijective ring homomorphism. -/
noncomputable def of_bijective (f : R →+* S) (hf : function.bijective f) : R ≃+* S :=
{ .. equiv.of_bijective f hf, .. f }

end semiring

section

variables [ring R] [ring S] (f : R ≃+* S) (x y : R)

@[simp] lemma map_neg : f (-x) = -f x := (f : R ≃+ S).map_neg x

@[simp] lemma map_sub : f (x - y) = f x - f y := (f : R ≃+ S).map_sub x y

@[simp] lemma map_neg_one : f (-1) = -1 := f.map_one ▸ f.map_neg 1

end

section semiring_hom

variables [semiring R] [semiring S] [semiring S']

/-- Reinterpret a ring equivalence as a ring homomorphism. -/
def to_ring_hom (e : R ≃+* S) : R →+* S :=
{ .. e.to_mul_equiv.to_monoid_hom, .. e.to_add_equiv.to_add_monoid_hom }

lemma to_ring_hom_injective : function.injective (to_ring_hom : (R ≃+* S) → R →+* S) :=
λ f g h, ring_equiv.ext (ring_hom.ext_iff.1 h)

instance has_coe_to_ring_hom : has_coe (R ≃+* S) (R →+* S) := ⟨ring_equiv.to_ring_hom⟩

lemma to_ring_hom_eq_coe (f : R ≃+* S) : f.to_ring_hom = ↑f := rfl

@[simp, norm_cast] lemma coe_to_ring_hom (f : R ≃+* S) : ⇑(f : R →+* S) = f := rfl

lemma coe_ring_hom_inj_iff {R S : Type*} [semiring R] [semiring S] (f g : R ≃+* S) :
  f = g ↔ (f : R →+* S) = g :=
⟨congr_arg _, λ h, ext $ ring_hom.ext_iff.mp h⟩

/-- Reinterpret a ring equivalence as a monoid homomorphism. -/
abbreviation to_monoid_hom (e : R ≃+* S) : R →* S := e.to_ring_hom.to_monoid_hom

/-- Reinterpret a ring equivalence as an `add_monoid` homomorphism. -/
abbreviation to_add_monoid_hom (e : R ≃+* S) : R →+ S := e.to_ring_hom.to_add_monoid_hom

/-- The two paths coercion can take to an `add_monoid_hom` are equivalent -/
lemma to_add_monoid_hom_commutes (f : R ≃+* S) :
  (f : R →+* S).to_add_monoid_hom = (f : R ≃+ S).to_add_monoid_hom :=
rfl

/-- The two paths coercion can take to an `monoid_hom` are equivalent -/
lemma to_monoid_hom_commutes (f : R ≃+* S) :
  (f : R →+* S).to_monoid_hom = (f : R ≃* S).to_monoid_hom :=
rfl

/-- The two paths coercion can take to an `equiv` are equivalent -/
lemma to_equiv_commutes (f : R ≃+* S) :
  (f : R ≃+ S).to_equiv = (f : R ≃* S).to_equiv :=
rfl

@[simp]
lemma to_ring_hom_refl : (ring_equiv.refl R).to_ring_hom = ring_hom.id R := rfl

@[simp]
lemma to_monoid_hom_refl : (ring_equiv.refl R).to_monoid_hom = monoid_hom.id R := rfl

@[simp]
lemma to_add_monoid_hom_refl : (ring_equiv.refl R).to_add_monoid_hom = add_monoid_hom.id R := rfl

@[simp]
lemma to_ring_hom_apply_symm_to_ring_hom_apply (e : R ≃+* S) :
  ∀ (y : S), e.to_ring_hom (e.symm.to_ring_hom y) = y :=
e.to_equiv.apply_symm_apply

@[simp]
lemma symm_to_ring_hom_apply_to_ring_hom_apply (e : R ≃+* S) :
  ∀ (x : R), e.symm.to_ring_hom (e.to_ring_hom x) = x :=
equiv.symm_apply_apply (e.to_equiv)

@[simp]
lemma to_ring_hom_trans (e₁ : R ≃+* S) (e₂ : S ≃+* S') :
  (e₁.trans e₂).to_ring_hom = e₂.to_ring_hom.comp e₁.to_ring_hom := rfl

@[simp]
lemma to_ring_hom_comp_symm_to_ring_hom (e : R ≃+* S) :
  e.to_ring_hom.comp e.symm.to_ring_hom = ring_hom.id _ :=
by { ext, simp }

@[simp]
lemma symm_to_ring_hom_comp_to_ring_hom (e : R ≃+* S) :
  e.symm.to_ring_hom.comp e.to_ring_hom = ring_hom.id _ :=
by { ext, simp }

/--
Construct an equivalence of rings from homomorphisms in both directions, which are inverses.
-/
def of_hom_inv (hom : R →+* S) (inv : S →+* R)
  (hom_inv_id : inv.comp hom = ring_hom.id R) (inv_hom_id : hom.comp inv = ring_hom.id S) :
  R ≃+* S :=
{ inv_fun := inv,
  left_inv := λ x, ring_hom.congr_fun hom_inv_id x,
  right_inv := λ x, ring_hom.congr_fun inv_hom_id x,
  ..hom }

@[simp]
lemma of_hom_inv_apply (hom : R →+* S) (inv : S →+* R) (hom_inv_id inv_hom_id) (r : R) :
  (of_hom_inv hom inv hom_inv_id inv_hom_id) r = hom r := rfl

@[simp]
lemma of_hom_inv_symm_apply (hom : R →+* S) (inv : S →+* R) (hom_inv_id inv_hom_id) (s : S) :
  (of_hom_inv hom inv hom_inv_id inv_hom_id).symm s = inv s := rfl

end semiring_hom

end ring_equiv

namespace mul_equiv

/-- Gives a `ring_equiv` from a `mul_equiv` preserving addition.-/
def to_ring_equiv {R : Type*} {S : Type*} [has_add R] [has_add S] [has_mul R] [has_mul S]
  (h : R ≃* S) (H : ∀ x y : R, h (x + y) = h x + h y) : R ≃+* S :=
{..h.to_equiv, ..h, ..add_equiv.mk' h.to_equiv H }

end mul_equiv

namespace ring_equiv

variables [has_add R] [has_add S] [has_mul R] [has_mul S]

@[simp] theorem trans_symm (e : R ≃+* S) : e.trans e.symm = ring_equiv.refl R := ext e.3
@[simp] theorem symm_trans (e : R ≃+* S) : e.symm.trans e = ring_equiv.refl S := ext e.4

/-- If two rings are isomorphic, and the second is an integral domain, then so is the first. -/
protected lemma is_integral_domain {A : Type*} (B : Type*) [ring A] [ring B]
  (hB : is_integral_domain B) (e : A ≃+* B) : is_integral_domain A :=
{ mul_comm := λ x y, have e.symm (e x * e y) = e.symm (e y * e x), by rw hB.mul_comm, by simpa,
  eq_zero_or_eq_zero_of_mul_eq_zero := λ x y hxy,
    have e x * e y = 0, by rw [← e.map_mul, hxy, e.map_zero],
    (hB.eq_zero_or_eq_zero_of_mul_eq_zero _ _ this).imp (λ hx, by simpa using congr_arg e.symm hx)
      (λ hy, by simpa using congr_arg e.symm hy),
  exists_pair_ne := ⟨e.symm 0, e.symm 1,
    by { haveI : nontrivial B := hB.to_nontrivial, exact e.symm.injective.ne zero_ne_one }⟩ }

/-- If two rings are isomorphic, and the second is an integral domain, then so is the first. -/
protected def integral_domain {A : Type*} (B : Type*) [ring A] [integral_domain B]
  (e : A ≃+* B) : integral_domain A :=
{ .. (‹_› : ring A), .. e.is_integral_domain B (integral_domain.to_is_integral_domain B) }

end ring_equiv

namespace equiv

variables (K : Type*) [division_ring K]

/-- In a division ring `K`, the unit group `units K`
is equivalent to the subtype of nonzero elements. -/
-- TODO: this might already exist elsewhere for `group_with_zero`
-- deduplicate or generalize
def units_equiv_ne_zero : units K ≃ {a : K | a ≠ 0} :=
⟨λ a, ⟨a.1, a.ne_zero⟩, λ a, units.mk0 _ a.2, λ ⟨_, _, _, _⟩, units.ext rfl, λ ⟨_, _⟩, rfl⟩

variable {K}

@[simp]
lemma coe_units_equiv_ne_zero (a : units K) :
  ((units_equiv_ne_zero K a) : K) = a := rfl

end equiv


/- Copyright (c) 2020 Floris van Doorn. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Michael Douglas, Floris van Doorn
-/
import linear_algebra.finite_dimensional linear_algebra.bilinear_form
import data.fintype.card tactic.apply_fun
import misc

universe variables u v w w' w''

open linear_map

variables {G : Type u} {R : Type v} {M : Type w} {M' : Type w'} {M'' : Type w''}
  [group G] [comm_ring R] [add_comm_group M] [module R M] [add_comm_group M'] [module R M']
  [add_comm_group M''] [module R M''] {N N' : submodule R M}
  {K : Type v} [field K] {V : Type w} [add_comm_group V] [vector_space K V]

namespace submodule

/- module facts -/

lemma eq_bot_iff' (N : submodule R M) : N = ⊥ ↔ ∀ x : M, x ∈ N → x = 0 :=
begin
  rw [eq_bot_iff], split,
  { intros h x hx, simpa using h hx },
  { intros h x hx, simp [h x hx] }
end

@[simp] lemma range_coprod (f : M →ₗ[R] M'') (g : M' →ₗ[R] M'') :
  (f.coprod g).range = f.range ⊔ g.range :=
begin
  unfold linear_map.range,
  convert map_coprod_prod _ _ _ _,
  rw prod_top,
end

lemma mem_sup_left {p p' : submodule R M} {x : M} (h : x ∈ p) : x ∈ p ⊔ p' :=
by { have : p ≤ p ⊔ p' := le_sup_left, exact this h }

lemma mem_sup_right {p p' : submodule R M} {x : M} (h : x ∈ p') : x ∈ p ⊔ p' :=
by { have : p' ≤ p ⊔ p' := le_sup_right, exact this h }

/-- A projection is an idempotent linear map -/
@[reducible] def is_projection (π : M →ₗ[R] M) : Prop := ∀ x, π (π x) = π x

-- def is_projection_on (N : submodule R M) (π : M →ₗ[R] M): Prop := ∀ x : N, π x = x ∧ range π ≤ N

-- lemma projections (N : submodule R M) (π : M →ₗ[R] M) : is_projection_on N π → is_projection π :=
-- sorry

/-- Two elements in a lattice are complementary if they have meet ⊥ and join ⊤. -/
def complementary {α} [bounded_lattice α] (x x' : α) : Prop :=
covering x x' ∧ disjoint x x'

lemma complementary.comm {α} [bounded_lattice α] {x x' : α} :
  complementary x x' ↔ complementary x' x :=
by { dsimp [complementary], rw [covering.comm, disjoint.comm] }

namespace complementary
/-- Given two complementary submodules `N` and `N'` of an `R`-module `M`, we get a linear equivalence from `N × N'` to `M` by adding the elements of `N` and `N'`. -/
protected noncomputable def linear_equiv (h : complementary N N') :
  (N × N') ≃ₗ[R] M := -- default precendences are wrong
begin
  apply linear_equiv.of_bijective (N.subtype.coprod N'.subtype),
  { refine (eq_bot_iff' _).mpr _, rintro ⟨⟨x, hx⟩, ⟨x', hx'⟩⟩ hxx',
    simp only [mem_ker, subtype_apply, submodule.coe_mk, coprod_apply] at hxx',
    have : x = 0,
    { apply disjoint_def.mp h.2 x hx,
      rw [← eq_neg_iff_add_eq_zero] at hxx', rw hxx', exact neg_mem _ hx' },
    subst this, rw [zero_add] at hxx', subst hxx', refl },
  { simp only [range_coprod, range_subtype, h.1.eq_top] }
end

/-- Given two complementary submodules `N` and `N'` of an `R`-module `M`, the projection onto `N` along `N'`. -/
protected noncomputable def pr1 (h : complementary N N') :
  M →ₗ[R] M :=
N.subtype.comp $ (fst R N N').comp h.linear_equiv.symm

lemma pr1_mem (h : complementary N N') (x : M) :
  h.pr1 x ∈ N :=
(fst R N N' $ h.linear_equiv.symm x).2

/-- Given two complementary submodules `N` and `N'` of an `R`-module `M`, the projection onto `N'` along `N`. -/
protected noncomputable def pr2 (h : complementary N N') :
  M →ₗ[R] M :=
N'.subtype.comp $ (snd R N N').comp h.linear_equiv.symm

lemma pr2_mem (h : complementary N N') (x : M) :
  h.pr2 x ∈ N' :=
(snd R N N' $ h.linear_equiv.symm x).2

@[simp] lemma pr1_add_pr2 (h : complementary N N') (x : M) :
  h.pr1 x + h.pr2 x = x :=
h.linear_equiv.right_inv x

lemma pr1_eq_and_pr2_eq (h : complementary N N') {x y z : M}
  (hx : x ∈ N) (hy : y ∈ N') (hz : z = x + y) : h.pr1 z = x ∧ h.pr2 z = y :=
begin
 subst z, have h2 := h.linear_equiv.left_inv (⟨x, hx⟩, ⟨y, hy⟩),
 simp only [prod.ext_iff, subtype.ext] at h2, exact h2
end

lemma pr1_pr1 (h : complementary N N') (x : M) :
  h.pr1 (h.pr1 x) = h.pr1 x :=
(h.pr1_eq_and_pr2_eq (h.pr1_mem x) (zero_mem _) (by rw add_zero)).1

lemma pr2_pr2 (h : complementary N N') (x : M) :
  h.pr2 (h.pr2 x) = h.pr2 x :=
(h.pr1_eq_and_pr2_eq (zero_mem _) (h.pr2_mem x) (by rw zero_add)).2

lemma range_pr1 (h : complementary N N') : range h.pr1 = N :=
by simp [complementary.pr1, range_comp]

lemma range_pr2 (h : complementary N N') : range h.pr2 = N' :=
by simp [complementary.pr2, range_comp]

end complementary

lemma complementary_ker_range {π : M →ₗ[R] M} (hp : is_projection π) :
  complementary (ker π) (range π) :=
begin
  unfold is_projection at hp, split,
  { rw [covering_iff, eq_top_iff'], intro x, rw mem_sup, use (linear_map.id - π) x,
    split, { simp [hp] },
    use π x, simp only [and_true, sub_apply, sub_add_cancel, mem_range, eq_self_iff_true, id_apply],
    use x },
  { intros, rw [disjoint_def], simp only [and_imp, mem_ker, mem_range, mem_inf, exists_imp_distrib],
    intros x hx x' hx', have h2x' := hx', apply_fun π at hx', simp [hp, hx] at hx', cc }
end

-- instance general_linear_group.coe : has_coe (general_linear_group R M) (M →ₗ[R] M) := ⟨λ x, x.1⟩

end submodule
open submodule

section subspace

noncomputable example (s : set V) (hs1 : is_basis K (subtype.val : s → V))
  (hs2 : s.finite) (f : V → K) : K :=
begin let sfin := hs2.to_finset, exact sfin.sum f,
end

/- finding a complementary subspace -/

/-- The set of subspaces disjoint from N (which means they only have 0 in common) -/
def disjoint_subspaces (N : subspace K V) : set (subspace K V) :=
{ N' | disjoint N N' }

lemma mem_disjoint_subspaces {N M : subspace K V} : M ∈ disjoint_subspaces N ↔
  ∀ x : V, x ∈ N → x ∈ M → x = 0 :=
disjoint_def

instance (N : subspace K V) : nonempty (disjoint_subspaces N) :=
⟨⟨⊥, disjoint_bot_right⟩⟩

theorem exists_maximal_disjoint_subspaces (N : subspace K V) :
  ∃ Nmax : disjoint_subspaces N, ∀N, Nmax ≤ N → N = Nmax :=
begin
  apply zorn.zorn_partial_order_nonempty,
  intros c hc h0c, refine ⟨⟨Sup (subtype.val '' c), _⟩, _⟩,
  { rw [mem_disjoint_subspaces],
    intros x h1x h2x, rw [mem_Sup_of_directed] at h2x,
    { rcases h2x with ⟨_, ⟨⟨y, h0y⟩, h1y, rfl⟩, h2y⟩,
      rw [mem_disjoint_subspaces] at h0y, exact h0y x h1x h2y },
    { simp only [set.nonempty_image_iff, h0c] },
    { rw directed_on_image, exact hc.directed_on }},
  { intros N hN, change N.1 ≤ Sup (subtype.val '' c), refine le_Sup _, simp [hN] }
end

theorem exists_complementary_subspace (N : subspace K V) :
  ∃ N' : subspace K V, complementary N N' :=
begin
  rcases exists_maximal_disjoint_subspaces N with ⟨⟨N', h1N'⟩, h2N'⟩,
  use N',
  refine ⟨_, h1N'⟩,
  classical,
  rw [covering_iff, eq_top_iff'], intro x, by_contra H,
  have : disjoint N (N' ⊔ span K {x}),
  { rw disjoint_def, intros y h1y h2y, rw mem_sup at h2y,
    rcases h2y with ⟨z, hz, w, hw, rfl⟩,
    rw mem_span_singleton at hw, rcases hw with ⟨r, rfl⟩,
    by_cases hr : r = 0,
    { subst hr, rw [zero_smul, add_zero] at h1y ⊢, apply mem_disjoint_subspaces.1 h1N' _ h1y hz },
    { exfalso, apply H,
      rw [← smul_mem_iff _ hr],
      rw [← add_mem_iff_right _ (mem_sup_right hz)],
      apply mem_sup_left h1y }},
  have : N' ⊔ span K {x} = N',
  { have := h2N' ⟨_, this⟩ _, rwa [subtype.mk_eq_mk] at this, rw subtype.le_def, exact le_sup_left },
  apply H, apply mem_sup_right, rw ←this, apply mem_sup_right, apply subset_span,
  apply set.mem_singleton
end

end subspace

/-- A representation of a group `G` on an `R`-module `M` is a group homomorphism from `G` to
  `GL(M)`. Normally `M` is a vector space, but we don't need that for the definition. -/
@[derive inhabited] def group_representation (G R M : Type*) [group G] [ring R] [add_comm_group M]
  [module R M] : Type* :=
G →* M →ₗ[R] M

variables {ρ : group_representation G R M} {π : M →ₗ[R] M}

instance : has_coe_to_fun (group_representation G R M) := ⟨_, λ f, f.to_fun⟩

/-- A submodule `N` is invariant under a representation `ρ` if `ρ g` maps `N` into `N` for all `g`. -/
def submodule.invariant_under (ρ : group_representation G R M) (N : submodule R M) : Prop :=
∀ x ∈ N, ∀ g : G, ρ g x ∈ N

open submodule

namespace group_representation

/-- An equivalence between two group representations. -/
protected structure equiv (ρ : group_representation G R M) (ρ' : group_representation G R M') :
  Type (max w w') :=
  (α : M ≃ₗ[R] M')
  (commute : ∀(g : G), α ∘ ρ g = ρ' g ∘ α)

--structure subrepresentation (ρ : group_representation G R M) (π : group_representation G R M') :
--  Type (max w w') :=
  --(α : M →ₗ[R] M')
  --(commute : ∀(g : G), α ∘ ρ g = π g ∘ α)
  --left_inv := λ m, show (f.inv * f.val) m = m

/-- An `R`-module `M` is irreducible if every invariant submodule is either `⊥` or `⊤`. -/
def irreducible (ρ : group_representation G R M) : Prop :=
∀ N : submodule R M, N.invariant_under ρ → N = ⊥ ∨ N = ⊤

/- Maschke's theorem -/

/-- A function is equivariant if it commutes with `ρ g` for all `g : G`. -/
def is_equivariant (ρ : group_representation G R M) (π : M →ₗ[R] M) : Prop :=
∀ g : G, ∀ x : M, π (ρ g x) = ρ g (π x)

/-- The invariant projector modifies a projector `π` to be equivariant. -/
def invariant_multiple_of_projector [fintype G] (ρ : group_representation G R M) (π : M →ₗ[R] M) : M →ₗ[R] M :=
finset.univ.sum (λ g : G, ((ρ g⁻¹).comp π).comp (ρ g))

-- lemma invariant_multiple_of_projector_is_scalar_on [fintype G] (r : R) (ρ : group_representation G R M) (π : M →ₗ[R] M)
--    {N : submodule R M} (hR : N.invariant_under ρ) (hp : is_projection_on N π) :
--   ∀ x : N, invariant_multiple_of_projector ρ π x = r • x :=
-- begin dunfold invariant_multiple_of_projector, intro,
--   suffices : ∀ g : G, (comp (comp (ρ g⁻¹) π) (ρ g)) ↑x = r • ↑x,
--   { sorry },
--   unfold is_projection_on at hp,
--   unfold invariant_under at hR,
--  simp, intro, sorry -- simp [(hp ↥N ((ρ g) x)).1, hR x],
-- end

noncomputable def invariant_projector [fintype G] (hG : is_unit (fintype.card G : R)) (ρ : group_representation G R M) (π : M →ₗ[R] M) : M →ₗ[R] M :=
begin
  let invr := is_unit_iff_exists_inv.1 hG,
  exact (classical.some invr) • invariant_multiple_of_projector ρ π
end

-- /-- `π` is a multiple `r` times a projection. -/
-- def is_multiple_of_projection (π : M →ₗ[R] M) (r : R) : Prop := ∀ x, π (π x) = r • π x

-- lemma is_multiple_of_projection_invariant_multiple_of_projector [fintype G] (ρ : group_representation G R M)
--   (π : M →ₗ[R] M) : is_multiple_of_projection (invariant_multiple_of_projector ρ π) (fintype.card G) :=
-- begin sorry
-- end

lemma is_invariant_ker (h : is_equivariant ρ π) : (ker π).invariant_under ρ :=
by { rintros x hx g, rw [mem_ker, h g x, mem_ker.mp hx, linear_map.map_zero] }

lemma sum_apply {α} (s : finset α) (f : α → M →ₗ[R] M) (m : M) :
  s.sum f m = s.sum (λ x, f x m) :=
begin
  classical,
  refine finset.induction _ _ s,
  { refl },
  { intros x s hx h_ind,
    have : finset.sum (insert x s) f = f x + finset.sum s f := by simp [hx],
    rw this, simp [hx, h_ind] }
end

lemma is_equivariant_invariant_projector [fintype G] (hG : is_unit (fintype.card G : R)) (ρ : group_representation G R M)
  (π : M →ₗ[R] M) : is_equivariant ρ (invariant_projector hG ρ π) :=
begin intros g1 x, dunfold invariant_projector, dsimp, rw linear_map.map_smul, congr' 1,
  dunfold invariant_multiple_of_projector, simp [sum_apply],
  apply finset.sum_bij (λ g _, g * g1),
  { intros, apply finset.mem_univ },
  { intros, dsimp, rw [ ρ.map_mul ],
    suffices : (ρ a⁻¹) (π ((ρ a) ((ρ g1) x))) = (ρ (g1 * (a * g1)⁻¹) (π ((ρ a * ρ g1) x))),
    { rw this, rw ρ.map_mul, refl },
    apply congr_fun, congr, simp [mul_inv] },
  { intros g g' _ _ h, simpa using h },
  { intros, use b * g1⁻¹, simp }
end

lemma submodule_comap_smul (f : M →ₗ[R] M) (p : submodule R M) (r : R) (h : is_unit r) :
  p.comap (r • f) = p.comap f :=
begin
  let ur :=  (classical.some h),
  have : r = (ur : R) := (classical.some_spec h).symm,
  ext b; simp only [submodule.mem_comap, linear_map.smul_apply, this, p.smul_mem_iff' ur],
end

lemma submodule_map_smul (f : M →ₗ[R] M) (p : submodule R M) (r : R) (h : is_unit r) :
  p.map (r • f) = p.map f :=
le_antisymm
  begin rw [map_le_iff_le_comap, submodule_comap_smul f _ r h, ← map_le_iff_le_comap], exact le_refl _ end
  begin rw [map_le_iff_le_comap, ← submodule_comap_smul f _ r h, ← map_le_iff_le_comap], exact le_refl _ end

lemma range_smul (f : M →ₗ[R] M) (r : R) (h : is_unit r) : range (r • f) = range f :=
begin exact submodule_map_smul f _ r h
end

lemma invariant_multiple_of_projector_on_range [fintype G] (ρ : group_representation G R M)
  (π : M →ₗ[R] M) (hp : is_projection π) (hR : (range π).invariant_under ρ) {x : M} (h1 : x ∈ range π) :
  invariant_multiple_of_projector ρ π x = (fintype.card G : R) • x :=
begin
  dunfold invariant_multiple_of_projector, rw sum_apply,
  convert finset.sum_const x, ext g, dsimp, {
    have h2 : (ρ g) x ∈ range π := by { apply hR, exact h1 },
    rw mem_range at h2,
    cases h2 with y h3,
    rw [← h3, hp y, h3],
    suffices : (ρ (g⁻¹ * g)) x = x,
    { rw [ρ.map_mul] at this, exact this },
    rw [mul_left_inv, ρ.map_one], refl },
  rw finset.card_univ, symmetry, apply semimodule.smul_eq_smul
end

lemma invariant_projector_on_range [fintype G] (hG : is_unit (fintype.card G : R))
  (ρ : group_representation G R M)
  (π : M →ₗ[R] M) (hp : is_projection π) (hR : (range π).invariant_under ρ) {x : M} (h1 : x ∈ range π) :
  invariant_projector hG ρ π x = x :=
begin
  dunfold invariant_projector, dsimp,
  rw [invariant_multiple_of_projector_on_range ρ π hp hR h1],
  rw [← mul_smul, mul_comm, classical.some_spec (is_unit_iff_exists_inv.1 hG), one_smul],
end

lemma range_invariant_projector [fintype G] (hG : is_unit (fintype.card G : R)) (ρ : group_representation G R M)
  (π : M →ₗ[R] M) (hp : is_projection π) (hR : (range π).invariant_under ρ) :
  range (invariant_projector hG ρ π) = range π :=
begin  unfold invariant_projector,
  let invr :=  classical.some(is_unit_iff_exists_inv.1 hG),
  have h_invr : (fintype.card G : R) * invr = 1 :=
        classical.some_spec (is_unit_iff_exists_inv.1 hG),
  rw [range_smul _ invr],
  ext x, split,
  { rintro ⟨x,hx,rfl⟩, dunfold invariant_multiple_of_projector, rw sum_apply, apply sum_mem, intros, dsimp, apply hR, rw mem_range, exact ⟨_, rfl⟩ },
  { intro hx,
    let x' := invr • π x,
    use x', use trivial,
    have h1 : x' ∈ range π := by { apply smul_mem, rw mem_range, exact ⟨_, rfl⟩ },
    rw [invariant_multiple_of_projector_on_range ρ π hp hR h1],
    simp only [x'], rw [← mul_smul, h_invr, one_smul], rcases hx with ⟨x, hx, rfl⟩, rw hp x },
    { apply is_unit_iff_exists_inv'.mpr, exact ⟨_, h_invr⟩ }
end

lemma is_projection_invariant_projector [fintype G] (hG : is_unit (fintype.card G : R))
  (ρ : group_representation G R M) (π : M →ₗ[R] M) (hp : is_projection π)
  (hR : (range π).invariant_under ρ) : is_projection (invariant_projector hG ρ π) :=
begin
  intro x,
  have : (invariant_projector hG ρ π) x ∈ range (invariant_projector hG ρ π),
  { rw mem_range, exact ⟨_, rfl⟩ },
  rw [range_invariant_projector hG ρ π hp hR] at this,
  rw [invariant_projector_on_range hG ρ π hp hR this]
end

theorem maschke [fintype G] (ρ : group_representation G R M) (N N' : submodule R M)
  (h : complementary N N') (hN : N.invariant_under ρ) (hG : is_unit (fintype.card G : R)) :
  ∃ N' : submodule R M, N'.invariant_under ρ ∧ complementary N N' :=
begin
  let π := invariant_projector hG ρ h.pr1, use ker π,
  use is_invariant_ker (is_equivariant_invariant_projector hG ρ h.pr1),
  suffices hR : (range (complementary.pr1 h)).invariant_under ρ,
  rw [complementary.comm, ← h.range_pr1, ← range_invariant_projector hG ρ h.pr1 h.pr1_pr1 hR],
  convert complementary_ker_range (is_projection_invariant_projector hG ρ h.pr1 h.pr1_pr1 hR),
  rw complementary.range_pr1, exact hN
end

end group_representation

/- from [https://github.com/Shenyang1995/M4R/blob/66f1450f206dc05c3093bc4eaa1361309bf8633b/src/G_module/basic.lean#L10-L14].

  Do we want to use this definition instead? This might allow us to write `g • x` instead of `ρ g x` -/
class G_module (G : Type*) [group G] (M : Type*) [add_comm_group M]
  extends has_scalar G M :=
(id : ∀ m : M, (1 : G) • m = m)
(mul : ∀ g h : G, ∀ m : M, g • (h • m) = (g * h) • m)
(linear : ∀ g : G, ∀ m n : M, g • (m + n) = g • m + g • n)


/-
Copyright (c) 2022 Anne Baanen. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Anne Baanen
-/
import data.polynomial.algebra_map
import field_theory.minpoly.is_integrally_closed
import ring_theory.power_basis

/-!
# A predicate on adjoining roots of polynomial

This file defines a predicate `is_adjoin_root S f`, which states that the ring `S` can be
constructed by adjoining a specified root of the polynomial `f : R[X]` to `R`.
This predicate is useful when the same ring can be generated by adjoining the root of different
polynomials, and you want to vary which polynomial you're considering.

The results in this file are intended to mirror those in `ring_theory.adjoin_root`,
in order to provide an easier way to translate results from one to the other.

## Motivation

`adjoin_root` presents one construction of a ring `R[α]`. However, it is possible to obtain
rings of this form in many ways, such as `number_field.ring_of_integers ℚ(√-5)`,
or `algebra.adjoin R {α, α^2}`, or `intermediate_field.adjoin R {α, 2 - α}`,
or even if we want to view `ℂ` as adjoining a root of `X^2 + 1` to `ℝ`.

## Main definitions

The two main predicates in this file are:

 * `is_adjoin_root S f`: `S` is generated by adjoining a specified root of `f : R[X]` to `R`
 * `is_adjoin_root_monic S f`: `S` is generated by adjoining a root of the monic polynomial
   `f : R[X]` to `R`

Using `is_adjoin_root` to map into `S`:

 * `is_adjoin_root.map`: inclusion from `R[X]` to `S`
 * `is_adjoin_root.root`: the specific root adjoined to `R` to give `S`

Using `is_adjoin_root` to map out of `S`:

 * `is_adjoin_root.repr`: choose a non-unique representative in `R[X]`
 * `is_adjoin_root.lift`, `is_adjoin_root.lift_hom`: lift a morphism `R →+* T` to `S →+* T`
 * `is_adjoin_root_monic.mod_by_monic_hom`: a unique representative in `R[X]` if `f` is monic

## Main results

 * `adjoin_root.is_adjoin_root` and `adjoin_root.is_adjoin_root_monic`:
   `adjoin_root` satisfies the conditions on `is_adjoin_root`(`_monic`)
 * `is_adjoin_root_monic.power_basis`: the `root` generates a power basis on `S` over `R`
 * `is_adjoin_root.aequiv`: algebra isomorphism showing adjoining a root gives a unique ring
   up to isomorphism
 * `is_adjoin_root.of_equiv`: transfer `is_adjoin_root` across an algebra isomorphism
 * `is_adjoin_root_eq.minpoly_eq`: the minimal polynomial of the adjoined root of `f` is equal to
   `f`, if `f` is irreducible and monic, and `R` is a GCD domain
-/

open_locale polynomial
open polynomial
noncomputable theory

universes u v

section move_me

end move_me

/-- `is_adjoin_root S f` states that the ring `S` can be constructed by adjoining a specified root
of the polynomial `f : R[X]` to `R`.

Compare `power_basis R S`, which does not explicitly specify which polynomial we adjoin a root of
(in particular `f` does not need to be the minimal polynomial of the root we adjoin),
and `adjoin_root` which constructs a new type.

This is not a typeclass because the choice of root given `S` and `f` is not unique.
-/
@[nolint has_nonempty_instance] -- This class doesn't really make sense on a predicate
structure is_adjoin_root {R : Type u} (S : Type v) [comm_semiring R] [semiring S] [algebra R S]
  (f : R[X]) : Type (max u v) :=
(map : R[X] →+* S)
(map_surjective : function.surjective map)
(ker_map : ring_hom.ker map = ideal.span {f})
(algebra_map_eq : algebra_map R S = map.comp polynomial.C)

/-- `is_adjoin_root_monic S f` states that the ring `S` can be constructed by adjoining a specified
root of the monic polynomial `f : R[X]` to `R`.

As long as `f` is monic, there is a well-defined representation of elements of `S` as polynomials
in `R[X]` of degree lower than `deg f` (see `mod_by_monic_hom` and `coeff`). In particular,
we have `is_adjoin_root_monic.power_basis`.

Bundling `monic` into this structure is very useful when working with explicit `f`s such as
`X^2 - C a * X - C b` since it saves you carrying around the proofs of monicity.
-/
@[nolint has_nonempty_instance] -- This class doesn't really make sense on a predicate
structure is_adjoin_root_monic {R : Type u} (S : Type v) [comm_semiring R] [semiring S]
  [algebra R S] (f : R[X]) extends is_adjoin_root S f :=
(monic : monic f)

section ring

variables {R : Type u} {S : Type v} [comm_ring R] [ring S] {f : R[X]} [algebra R S]

namespace is_adjoin_root

/-- `(h : is_adjoin_root S f).root` is the root of `f` that can be adjoined to generate `S`. -/
def root (h : is_adjoin_root S f) : S := h.map X

lemma subsingleton (h : is_adjoin_root S f) [subsingleton R] : subsingleton S :=
h.map_surjective.subsingleton

lemma algebra_map_apply (h : is_adjoin_root S f) (x : R) :
  algebra_map R S x = h.map (polynomial.C x) :=
by rw [h.algebra_map_eq, ring_hom.comp_apply]

@[simp] lemma mem_ker_map (h : is_adjoin_root S f) {p} : p ∈ ring_hom.ker h.map ↔ f ∣ p :=
by rw [h.ker_map, ideal.mem_span_singleton]

lemma map_eq_zero_iff (h : is_adjoin_root S f) {p} : h.map p = 0 ↔ f ∣ p :=
by rw [← h.mem_ker_map, ring_hom.mem_ker]

@[simp] lemma map_X (h : is_adjoin_root S f) : h.map X = h.root := rfl

@[simp] lemma map_self (h : is_adjoin_root S f) : h.map f = 0 :=
h.map_eq_zero_iff.mpr dvd_rfl

@[simp] lemma aeval_eq (h : is_adjoin_root S f) (p : R[X]) : aeval h.root p = h.map p :=
polynomial.induction_on p (λ x, by { rw [aeval_C, h.algebra_map_apply] })
  (λ 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,
    ← h.algebra_map_apply, ring_hom.map_pow, map_X] })

@[simp] lemma aeval_root (h : is_adjoin_root S f) : aeval h.root f = 0 :=
by rw [aeval_eq, map_self]

/-- Choose an arbitrary representative so that `h.map (h.repr x) = x`.

If `f` is monic, use `is_adjoin_root_monic.mod_by_monic_hom` for a unique choice of representative.
-/
def repr (h : is_adjoin_root S f) (x : S) : R[X] :=
(h.map_surjective x).some

lemma map_repr (h : is_adjoin_root S f) (x : S) : h.map (h.repr x) = x :=
(h.map_surjective x).some_spec

/-- `repr` preserves zero, up to multiples of `f` -/
lemma repr_zero_mem_span (h : is_adjoin_root S f) : h.repr 0 ∈ ideal.span ({f} : set R[X]) :=
by rw [← h.ker_map, ring_hom.mem_ker, h.map_repr]

/-- `repr` preserves addition, up to multiples of `f` -/
lemma repr_add_sub_repr_add_repr_mem_span (h : is_adjoin_root S f) (x y : S) :
  h.repr (x + y) - (h.repr x + h.repr y) ∈ ideal.span ({f} : set R[X]) :=
by rw [← h.ker_map, ring_hom.mem_ker, map_sub, h.map_repr, map_add, h.map_repr, h.map_repr,
       sub_self]

/-- Extensionality of the `is_adjoin_root` structure itself. See `is_adjoin_root_monic.ext_elem`
for extensionality of the ring elements. -/
lemma ext_map (h h' : is_adjoin_root S f) (eq : ∀ x, h.map x = h'.map x) : h = h' :=
begin
  cases h, cases h', congr,
  exact ring_hom.ext eq
end

/-- Extensionality of the `is_adjoin_root` structure itself. See `is_adjoin_root_monic.ext_elem`
for extensionality of the ring elements. -/
@[ext]
lemma ext (h h' : is_adjoin_root S f) (eq : h.root = h'.root) : h = h' :=
h.ext_map h' (λ x, by rw [← h.aeval_eq, ← h'.aeval_eq, eq])

section lift

variables {T : Type*} [comm_ring T] {i : R →+* T} {x : T} (hx : f.eval₂ i x = 0)

include hx

/-- Auxiliary lemma for `is_adjoin_root.lift` -/
lemma eval₂_repr_eq_eval₂_of_map_eq (h : is_adjoin_root S f) (z : S) (w : R[X])
  (hzw : h.map w = z) :
  (h.repr z).eval₂ i x = w.eval₂ i x :=
begin
  rw [eq_comm, ← sub_eq_zero, ← h.map_repr z, ← map_sub, h.map_eq_zero_iff] at hzw,
  obtain ⟨y, hy⟩ := hzw,
  rw [← sub_eq_zero, ← eval₂_sub, hy, eval₂_mul, hx, zero_mul]
end

variables (i x) -- To match `adjoin_root.lift`

/-- Lift a ring homomorphism `R →+* T` to `S →+* T` by specifying a root `x` of `f` in `T`,
where `S` is given by adjoining a root of `f` to `R`. -/
def lift (h : is_adjoin_root S f) : S →+* T :=
{ to_fun := λ z, (h.repr z).eval₂ i x,
  map_zero' := by rw [h.eval₂_repr_eq_eval₂_of_map_eq hx _ _ (map_zero _), eval₂_zero],
  map_add' := λ z w, begin
    rw [h.eval₂_repr_eq_eval₂_of_map_eq hx _ (h.repr z + h.repr w), eval₂_add],
    { rw [map_add, map_repr, map_repr] }
  end,
  map_one' := by rw [h.eval₂_repr_eq_eval₂_of_map_eq hx _ _ (map_one _), eval₂_one],
  map_mul' := λ z w, begin
    rw [h.eval₂_repr_eq_eval₂_of_map_eq hx _ (h.repr z * h.repr w), eval₂_mul],
    { rw [map_mul, map_repr, map_repr] }
  end }

variables {i x}

@[simp] lemma lift_map (h : is_adjoin_root S f) (z : R[X]) :
  h.lift i x hx (h.map z) = z.eval₂ i x :=
by rw [lift, ring_hom.coe_mk, h.eval₂_repr_eq_eval₂_of_map_eq hx _ _ rfl]

@[simp] lemma lift_root (h : is_adjoin_root S f) :
  h.lift i x hx h.root = x :=
by rw [← h.map_X, lift_map, eval₂_X]

@[simp] lemma lift_algebra_map (h : is_adjoin_root S f) (a : R) :
  h.lift i x hx (algebra_map R S a) = i a :=
by rw [h.algebra_map_apply, lift_map, eval₂_C]

/-- Auxiliary lemma for `apply_eq_lift` -/
lemma apply_eq_lift (h : is_adjoin_root S f) (g : S →+* T)
  (hmap : ∀ a, g (algebra_map R S a) = i a) (hroot : g h.root = x) (a : S):
  g a = h.lift i x hx a :=
begin
  rw [← h.map_repr a, polynomial.as_sum_range_C_mul_X_pow (h.repr a)],
  simp only [map_sum, map_mul, map_pow, h.map_X, hroot, ← h.algebra_map_apply, hmap, lift_root,
    lift_algebra_map]
end

/-- Unicity of `lift`: a map that agrees on `R` and `h.root` agrees with `lift` everywhere. -/
lemma eq_lift (h : is_adjoin_root S f) (g : S →+* T)
  (hmap : ∀ a, g (algebra_map R S a) = i a) (hroot : g h.root = x) :
  g = h.lift i x hx :=
ring_hom.ext (h.apply_eq_lift hx g hmap hroot)

variables [algebra R T] (hx' : aeval x f = 0)

omit hx

variables (x) -- To match `adjoin_root.lift_hom`

/-- Lift the algebra map `R → T` to `S →ₐ[R] T` by specifying a root `x` of `f` in `T`,
where `S` is given by adjoining a root of `f` to `R`. -/
def lift_hom (h : is_adjoin_root S f) : S →ₐ[R] T :=
{ commutes' := λ a, h.lift_algebra_map hx' a,
  .. h.lift (algebra_map R T) x hx' }

variables {x}

@[simp] lemma coe_lift_hom (h : is_adjoin_root S f) :
  (h.lift_hom x hx' : S →+* T) = h.lift (algebra_map R T) x hx' := rfl

lemma lift_algebra_map_apply (h : is_adjoin_root S f) (z : S) :
  h.lift (algebra_map R T) x hx' z = h.lift_hom x hx' z := rfl

@[simp] lemma lift_hom_map (h : is_adjoin_root S f) (z : R[X]) :
  h.lift_hom x hx' (h.map z) = aeval x z :=
by rw [← lift_algebra_map_apply, lift_map, aeval_def]

@[simp] lemma lift_hom_root (h : is_adjoin_root S f) :
  h.lift_hom x hx' h.root = x :=
by rw [← lift_algebra_map_apply, lift_root]

/-- Unicity of `lift_hom`: a map that agrees on `h.root` agrees with `lift_hom` everywhere. -/
lemma eq_lift_hom (h : is_adjoin_root S f) (g : S →ₐ[R] T) (hroot : g h.root = x) :
  g = h.lift_hom x hx' :=
alg_hom.ext (h.apply_eq_lift hx' g g.commutes hroot)

end lift

end is_adjoin_root

namespace adjoin_root

variables (f)

/-- `adjoin_root f` is indeed given by adjoining a root of `f`. -/
protected def is_adjoin_root : is_adjoin_root (adjoin_root f) f :=
{ map := adjoin_root.mk f,
  map_surjective := ideal.quotient.mk_surjective,
  ker_map := begin
    ext,
    rw [ring_hom.mem_ker, ← @adjoin_root.mk_self _ _ f, adjoin_root.mk_eq_mk,
        ideal.mem_span_singleton, ← dvd_add_left (dvd_refl f), sub_add_cancel]
  end,
  algebra_map_eq := adjoin_root.algebra_map_eq f }

/-- `adjoin_root f` is indeed given by adjoining a root of `f`. If `f` is monic this is more
powerful than `adjoin_root.is_adjoin_root`. -/
protected def is_adjoin_root_monic (hf : monic f) :
  is_adjoin_root_monic (adjoin_root f) f :=
{ monic := hf,
  .. adjoin_root.is_adjoin_root f }

@[simp]
lemma is_adjoin_root_map_eq_mk :
  (adjoin_root.is_adjoin_root f).map = adjoin_root.mk f := rfl

@[simp]
lemma is_adjoin_root_monic_map_eq_mk (hf : f.monic) :
  (adjoin_root.is_adjoin_root_monic f hf).map = adjoin_root.mk f := rfl

@[simp]
lemma is_adjoin_root_root_eq_root :
  (adjoin_root.is_adjoin_root f).root = adjoin_root.root f :=
by simp only [is_adjoin_root.root, adjoin_root.root, adjoin_root.is_adjoin_root_map_eq_mk]

@[simp]
lemma is_adjoin_root_monic_root_eq_root (hf : monic f) :
  (adjoin_root.is_adjoin_root_monic f hf).root = adjoin_root.root f :=
by simp only [is_adjoin_root.root, adjoin_root.root, adjoin_root.is_adjoin_root_monic_map_eq_mk]

end adjoin_root

namespace is_adjoin_root_monic

open is_adjoin_root

lemma map_mod_by_monic (h : is_adjoin_root_monic S f) (g : R[X]) :
  h.map (g %ₘ f) = h.map g :=
begin
  rw [← ring_hom.sub_mem_ker_iff, mem_ker_map, mod_by_monic_eq_sub_mul_div _ h.monic,
      sub_right_comm, sub_self, zero_sub, dvd_neg],
  exact ⟨_, rfl⟩
end

lemma mod_by_monic_repr_map (h : is_adjoin_root_monic S f) (g : R[X]) :
  h.repr (h.map g) %ₘ f = g %ₘ f :=
mod_by_monic_eq_of_dvd_sub h.monic $ by rw [← h.mem_ker_map, ring_hom.sub_mem_ker_iff, map_repr]

/-- `is_adjoin_root.mod_by_monic_hom` sends the equivalence class of `f` mod `g` to `f %ₘ g`. -/
def mod_by_monic_hom (h : is_adjoin_root_monic S f) : S →ₗ[R] R[X] :=
{ to_fun := λ x, h.repr x %ₘ f,
  map_add' := λ x y,
    by conv_lhs { rw [← h.map_repr x, ← h.map_repr y, ← map_add, h.mod_by_monic_repr_map,
                      add_mod_by_monic] },
  map_smul' := λ c x,
    by rw [ring_hom.id_apply, ← h.map_repr x, algebra.smul_def, h.algebra_map_apply, ← map_mul,
           h.mod_by_monic_repr_map, ← smul_eq_C_mul, smul_mod_by_monic, h.map_repr] }

@[simp] lemma mod_by_monic_hom_map (h : is_adjoin_root_monic S f) (g : R[X]) :
  h.mod_by_monic_hom (h.map g) = g %ₘ f :=
h.mod_by_monic_repr_map g

@[simp] lemma map_mod_by_monic_hom (h : is_adjoin_root_monic S f) (x : S) :
  h.map (h.mod_by_monic_hom x) = x :=
by rw [mod_by_monic_hom, linear_map.coe_mk, map_mod_by_monic, map_repr]

@[simp] lemma mod_by_monic_hom_root_pow (h : is_adjoin_root_monic S f) {n : ℕ}
  (hdeg : n < nat_degree f) :
  h.mod_by_monic_hom (h.root ^ n) = X ^ n :=
begin
  nontriviality R,
  rwa [← h.map_X, ← map_pow, mod_by_monic_hom_map, mod_by_monic_eq_self_iff h.monic, degree_X_pow],
  contrapose! hdeg,
  simpa [nat_degree_le_iff_degree_le] using hdeg
end

@[simp] lemma mod_by_monic_hom_root (h : is_adjoin_root_monic S f) (hdeg : 1 < nat_degree f) :
  h.mod_by_monic_hom h.root = X :=
by simpa using mod_by_monic_hom_root_pow h hdeg

/-- The basis on `S` generated by powers of `h.root`.

Auxiliary definition for `is_adjoin_root_monic.power_basis`. -/
def basis (h : is_adjoin_root_monic S f) : basis (fin (nat_degree f)) R S :=
basis.of_repr
{ to_fun := λ x, (h.mod_by_monic_hom x).to_finsupp.comap_domain coe (fin.coe_injective.inj_on _),
  inv_fun := λ g, h.map (of_finsupp (g.map_domain coe)),
  left_inv := λ x, begin
    casesI subsingleton_or_nontrivial R,
    { haveI := h.subsingleton,
      exact subsingleton.elim _ _ },
    simp only,
    rw [finsupp.map_domain_comap_domain, polynomial.eta, h.map_mod_by_monic_hom x],
    intros i hi,
    refine set.mem_range.mpr ⟨⟨i, _⟩, rfl⟩,
    contrapose! hi,
    simp only [polynomial.to_finsupp_apply, not_not, finsupp.mem_support_iff, ne.def,
        mod_by_monic_hom, linear_map.coe_mk, finset.mem_coe],
    by_cases hx : h.to_is_adjoin_root.repr x %ₘ f = 0,
    { simp [hx] },
    refine coeff_eq_zero_of_nat_degree_lt (lt_of_lt_of_le _ hi),
    rw nat_degree_lt_nat_degree_iff hx,
    { exact degree_mod_by_monic_lt _ h.monic },
  end,
  right_inv := λ g, begin
    nontriviality R,
    ext i,
    simp only [h.mod_by_monic_hom_map, finsupp.comap_domain_apply, polynomial.to_finsupp_apply],
    rw [(polynomial.mod_by_monic_eq_self_iff h.monic).mpr, polynomial.coeff,
        finsupp.map_domain_apply fin.coe_injective],
    rw [degree_eq_nat_degree h.monic.ne_zero, degree_lt_iff_coeff_zero],
    intros m hm,
    rw [polynomial.coeff, finsupp.map_domain_notin_range],
    rw [set.mem_range, not_exists],
    rintro i rfl,
    exact i.prop.not_le hm
  end,
  map_add' := λ x y,
    by simp only [map_add, finsupp.comap_domain_add_of_injective fin.coe_injective, to_finsupp_add],
  map_smul' := λ c x,
    by simp only [map_smul, finsupp.comap_domain_smul_of_injective fin.coe_injective,
        ring_hom.id_apply, to_finsupp_smul] }

@[simp] lemma basis_apply (h : is_adjoin_root_monic S f) (i) : h.basis i = h.root ^ (i : ℕ) :=
basis.apply_eq_iff.mpr $
show (h.mod_by_monic_hom (h.to_is_adjoin_root.root ^ (i : ℕ))).to_finsupp
  .comap_domain coe (fin.coe_injective.inj_on _) = finsupp.single _ _,
begin
  ext j,
  rw [finsupp.comap_domain_apply, mod_by_monic_hom_root_pow],
  { rw [X_pow_eq_monomial, to_finsupp_monomial, finsupp.single_apply_left fin.coe_injective] },
  { exact i.is_lt },
end

lemma deg_pos [nontrivial S] (h : is_adjoin_root_monic S f) : 0 < nat_degree f :=
begin
  rcases h.basis.index_nonempty with ⟨⟨i, hi⟩⟩,
  exact (nat.zero_le _).trans_lt hi
end

lemma deg_ne_zero [nontrivial S] (h : is_adjoin_root_monic S f) : nat_degree f ≠ 0 :=
h.deg_pos.ne'

/-- If `f` is monic, the powers of `h.root` form a basis. -/
@[simps gen dim basis]
def power_basis (h : is_adjoin_root_monic S f) : power_basis R S :=
{ gen := h.root,
  dim := nat_degree f,
  basis := h.basis,
  basis_eq_pow := h.basis_apply }

@[simp] lemma basis_repr (h : is_adjoin_root_monic S f) (x : S) (i : fin (nat_degree f)) :
  h.basis.repr x i = (h.mod_by_monic_hom x).coeff (i : ℕ) :=
begin
  change (h.mod_by_monic_hom x).to_finsupp.comap_domain coe (fin.coe_injective.inj_on _) i = _,
  rw [finsupp.comap_domain_apply, polynomial.to_finsupp_apply]
end

lemma basis_one (h : is_adjoin_root_monic S f) (hdeg : 1 < nat_degree f) :
  h.basis ⟨1, hdeg⟩ = h.root :=
by rw [h.basis_apply, fin.coe_mk, pow_one]

/-- `is_adjoin_root_monic.lift_polyₗ` lifts a linear map on polynomials to a linear map on `S`. -/
@[simps]
def lift_polyₗ {T : Type*} [add_comm_group T] [module R T] (h : is_adjoin_root_monic S f)
  (g : R[X] →ₗ[R] T) : S →ₗ[R] T :=
g.comp h.mod_by_monic_hom

/-- `is_adjoin_root_monic.coeff h x i` is the `i`th coefficient of the representative of `x : S`.
-/
def coeff (h : is_adjoin_root_monic S f) : S →ₗ[R] (ℕ → R) :=
h.lift_polyₗ
{ to_fun := polynomial.coeff,
  map_add' := λ p q, funext (polynomial.coeff_add p q),
  map_smul' := λ c p, funext (polynomial.coeff_smul c p) }

lemma coeff_apply_lt (h : is_adjoin_root_monic S f) (z : S) (i : ℕ) (hi : i < nat_degree f) :
  h.coeff z i = h.basis.repr z ⟨i, hi⟩ :=
begin
  simp only [coeff, linear_map.comp_apply, finsupp.lcoe_fun_apply, finsupp.lmap_domain_apply,
             linear_equiv.coe_coe, lift_polyₗ_apply, linear_map.coe_mk, h.basis_repr],
  refl
end

lemma coeff_apply_coe (h : is_adjoin_root_monic S f) (z : S) (i : fin (nat_degree f)) :
  h.coeff z i = h.basis.repr z i :=
h.coeff_apply_lt z i i.prop

lemma coeff_apply_le (h : is_adjoin_root_monic S f) (z : S) (i : ℕ) (hi : nat_degree f ≤ i) :
  h.coeff z i = 0 :=
begin
  simp only [coeff, linear_map.comp_apply, finsupp.lcoe_fun_apply, finsupp.lmap_domain_apply,
             linear_equiv.coe_coe, lift_polyₗ_apply, linear_map.coe_mk, h.basis_repr],
  nontriviality R,
  exact polynomial.coeff_eq_zero_of_degree_lt ((degree_mod_by_monic_lt _ h.monic).trans_le
    (polynomial.degree_le_of_nat_degree_le hi)),
end

lemma coeff_apply (h : is_adjoin_root_monic S f) (z : S) (i : ℕ) :
  h.coeff z i = if hi : i < nat_degree f then h.basis.repr z ⟨i, hi⟩ else 0 :=
begin
  split_ifs with hi,
  { exact h.coeff_apply_lt z i hi },
  { exact h.coeff_apply_le z i (le_of_not_lt hi) },
end

lemma coeff_root_pow (h : is_adjoin_root_monic S f) {n} (hn : n < nat_degree f) :
  h.coeff (h.root ^ n) = pi.single n 1 :=
begin
  ext i,
  rw coeff_apply,
  split_ifs with hi,
  { calc h.basis.repr (h.root ^ n) ⟨i, _⟩
        = h.basis.repr (h.basis ⟨n, hn⟩) ⟨i, hi⟩
      : by rw [h.basis_apply, fin.coe_mk]
    ... = pi.single ((⟨n, hn⟩ : fin _) : ℕ) (1 : (λ _, R) _) ↑(⟨i, _⟩ : fin _) :
      by rw [h.basis.repr_self, ← finsupp.single_eq_pi_single,
             finsupp.single_apply_left fin.coe_injective]
    ... = pi.single n 1 i : by rw [fin.coe_mk, fin.coe_mk] },
  { refine (pi.single_eq_of_ne _ (1 : (λ _, R) _)).symm,
    rintro rfl,
    simpa [hi] using hn },
end

lemma coeff_one [nontrivial S] (h : is_adjoin_root_monic S f) :
  h.coeff 1 = pi.single 0 1 :=
by rw [← h.coeff_root_pow h.deg_pos, pow_zero]

lemma coeff_root (h : is_adjoin_root_monic S f) (hdeg : 1 < (nat_degree f)) :
  h.coeff h.root = pi.single 1 1 :=
by rw [← h.coeff_root_pow hdeg, pow_one]

lemma coeff_algebra_map [nontrivial S] (h : is_adjoin_root_monic S f) (x : R) :
  h.coeff (algebra_map R S x) = pi.single 0 x :=
begin
  ext i,
  rw [algebra.algebra_map_eq_smul_one, map_smul, coeff_one, pi.smul_apply, smul_eq_mul],
  refine (pi.apply_single (λ _ y, x * y) _ 0 1 i).trans (by simp),
  intros,
  simp
end

lemma ext_elem (h : is_adjoin_root_monic S f) ⦃x y : S⦄
  (hxy : ∀ i < (nat_degree f), h.coeff x i = h.coeff y i) : x = y :=
equiv_like.injective h.basis.equiv_fun $ funext $ λ i,
show h.basis.equiv_fun x i = h.basis.equiv_fun y i,
by rw [basis.equiv_fun_apply, ← h.coeff_apply_coe, basis.equiv_fun_apply, ← h.coeff_apply_coe,
       hxy i i.prop]

lemma ext_elem_iff (h : is_adjoin_root_monic S f) {x y : S} :
  x = y ↔ ∀ i < (nat_degree f), h.coeff x i = h.coeff y i :=
⟨λ hxy i hi, hxy ▸ rfl, λ hxy, h.ext_elem hxy⟩

lemma coeff_injective (h : is_adjoin_root_monic S f) : function.injective h.coeff :=
λ x y hxy, h.ext_elem (λ i hi, hxy ▸ rfl)

lemma is_integral_root (h : is_adjoin_root_monic S f) : is_integral R h.root :=
⟨f, h.monic, h.aeval_root⟩

end is_adjoin_root_monic

end ring

section comm_ring

variables {R : Type u} {S : Type v} [comm_ring R] [comm_ring S] [algebra R S] {f : R[X]}

namespace is_adjoin_root

section lift

@[simp] lemma lift_self_apply (h : is_adjoin_root S f) (x : S) :
  h.lift (algebra_map R S) h.root h.aeval_root x = x :=
by rw [← h.map_repr x, lift_map, ← aeval_def, h.aeval_eq]

lemma lift_self (h : is_adjoin_root S f) :
  h.lift (algebra_map R S) h.root h.aeval_root = ring_hom.id S :=
ring_hom.ext (h.lift_self_apply)

end lift

section equiv

variables {T : Type*} [comm_ring T] [algebra R T]

/-- Adjoining a root gives a unique ring up to algebra isomorphism.

This is the converse of `is_adjoin_root.of_equiv`: this turns an `is_adjoin_root` into an
`alg_equiv`, and `is_adjoin_root.of_equiv` turns an `alg_equiv` into an `is_adjoin_root`.
-/
def aequiv (h : is_adjoin_root S f) (h' : is_adjoin_root T f) : S ≃ₐ[R] T :=
{ to_fun := h.lift_hom h'.root h'.aeval_root,
  inv_fun := h'.lift_hom h.root h.aeval_root,
  left_inv := λ x, by rw [← h.map_repr x, lift_hom_map, aeval_eq, lift_hom_map, aeval_eq],
  right_inv := λ x, by rw [← h'.map_repr x, lift_hom_map, aeval_eq, lift_hom_map, aeval_eq],
  .. h.lift_hom h'.root h'.aeval_root }

@[simp] lemma aequiv_map (h : is_adjoin_root S f) (h' : is_adjoin_root T f) (z : R[X]) :
  h.aequiv h' (h.map z) = h'.map z :=
by rw [aequiv, alg_equiv.coe_mk, lift_hom_map, aeval_eq]

@[simp]

@[simp] lemma aequiv_self (h : is_adjoin_root S f) : h.aequiv h = alg_equiv.refl :=
by { ext a, exact h.lift_self_apply a }

@[simp] lemma aequiv_symm (h : is_adjoin_root S f) (h' : is_adjoin_root T f) :
  (h.aequiv h').symm = h'.aequiv h :=
by { ext, refl }

@[simp] lemma lift_aequiv {U : Type*} [comm_ring U]
  (h : is_adjoin_root S f) (h' : is_adjoin_root T f) (i : R →+* U) (x hx z) :
  (h'.lift i x hx (h.aequiv h' z)) = h.lift i x hx z :=
by rw [← h.map_repr z, aequiv_map, lift_map, lift_map]

@[simp] lemma lift_hom_aequiv {U : Type*} [comm_ring U] [algebra R U]
  (h : is_adjoin_root S f) (h' : is_adjoin_root T f) (x : U) (hx z) :
  (h'.lift_hom x hx (h.aequiv h' z)) = h.lift_hom x hx z :=
h.lift_aequiv h' _ _ hx _

@[simp] lemma aequiv_aequiv {U : Type*} [comm_ring U] [algebra R U]
  (h : is_adjoin_root S f) (h' : is_adjoin_root T f) (h'' : is_adjoin_root U f) (x) :
  (h'.aequiv h'') (h.aequiv h' x) = h.aequiv h'' x :=
h.lift_hom_aequiv _ _ h''.aeval_root _

@[simp] lemma aequiv_trans {U : Type*} [comm_ring U] [algebra R U]
  (h : is_adjoin_root S f) (h' : is_adjoin_root T f) (h'' : is_adjoin_root U f) :
  (h.aequiv h').trans (h'.aequiv h'') = h.aequiv h'' :=
by { ext z, exact h.aequiv_aequiv h' h'' z }

/-- Transfer `is_adjoin_root` across an algebra isomorphism.

This is the converse of `is_adjoin_root.aequiv`: this turns an `alg_equiv` into an `is_adjoin_root`,
and `is_adjoin_root.aequiv` turns an `is_adjoin_root` into an `alg_equiv`.
-/
@[simps map_apply]
def of_equiv (h : is_adjoin_root S f) (e : S ≃ₐ[R] T) : is_adjoin_root T f :=
{ map := ((e : S ≃+* T) : S →+* T).comp h.map,
  map_surjective := e.surjective.comp h.map_surjective,
  ker_map := by rw [← ring_hom.comap_ker, ring_hom.ker_coe_equiv, ← ring_hom.ker_eq_comap_bot,
                    h.ker_map],
  algebra_map_eq := by ext;
    simp only [alg_equiv.commutes, ring_hom.comp_apply, alg_equiv.coe_ring_equiv,
               ring_equiv.coe_to_ring_hom, ← h.algebra_map_apply] }

@[simp] lemma of_equiv_root (h : is_adjoin_root S f) (e : S ≃ₐ[R] T) :
  (h.of_equiv e).root = e h.root := rfl

@[simp] lemma aequiv_of_equiv {U : Type*} [comm_ring U] [algebra R U]
  (h : is_adjoin_root S f) (h' : is_adjoin_root T f) (e : T ≃ₐ[R] U) :
  h.aequiv (h'.of_equiv e) = (h.aequiv h').trans e :=
by ext a; rw [← h.map_repr a, aequiv_map, alg_equiv.trans_apply, aequiv_map, of_equiv_map_apply]

@[simp] lemma of_equiv_aequiv {U : Type*} [comm_ring U] [algebra R U]
  (h : is_adjoin_root S f) (h' : is_adjoin_root U f) (e : S ≃ₐ[R] T) :
  (h.of_equiv e).aequiv h' = e.symm.trans (h.aequiv h') :=
by ext a; rw [← (h.of_equiv e).map_repr a, aequiv_map, alg_equiv.trans_apply, of_equiv_map_apply,
              e.symm_apply_apply, aequiv_map]

end equiv

end is_adjoin_root

namespace is_adjoin_root_monic

lemma minpoly_eq [is_domain R] [is_domain S] [no_zero_smul_divisors R S] [is_integrally_closed R]
  (h : is_adjoin_root_monic S f) (hirr : irreducible f) :
  minpoly R h.root = f :=
let ⟨q, hq⟩ := minpoly.is_integrally_closed_dvd h.is_integral_root h.aeval_root in
symm $ eq_of_monic_of_associated h.monic (minpoly.monic h.is_integral_root) $
by convert (associated.mul_left (minpoly R h.root) $
    associated_one_iff_is_unit.2 $ (hirr.is_unit_or_is_unit hq).resolve_left $
    minpoly.not_is_unit R h.root);
  rw mul_one

end is_adjoin_root_monic

section algebra

open adjoin_root is_adjoin_root minpoly power_basis is_adjoin_root_monic algebra

lemma algebra.adjoin.power_basis'_minpoly_gen [is_domain R] [is_domain S]
  [no_zero_smul_divisors R S] [is_integrally_closed R] {x : S} (hx' : is_integral R x) :
  minpoly R x = minpoly R (algebra.adjoin.power_basis' hx').gen :=
begin
  haveI := is_domain_of_prime (prime_of_is_integrally_closed hx'),
  haveI := no_zero_smul_divisors_of_prime_of_degree_ne_zero
    (prime_of_is_integrally_closed hx') (ne_of_lt (degree_pos hx')).symm,
  rw [← minpoly_gen_eq, adjoin.power_basis', minpoly_gen_map, minpoly_gen_eq, power_basis'_gen,
    ← is_adjoin_root_monic_root_eq_root _ (monic hx'), minpoly_eq],
  exact irreducible hx',
end

end algebra

end comm_ring