/-
Copyright (c) 2017 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Sébastien Gouëzel, Floris van Doorn, Mario Carneiro
-/
import data.list.big_operators

/-!
# Join of a list of lists

This file proves basic properties of `list.join`, which concatenates a list of lists. It is defined
in [`data.list.defs`](./data/list/defs).
-/

variables {α β : Type*}

namespace list

attribute [simp] join

@[simp] lemma join_nil : [([] : list α)].join = [] := rfl

@[simp] lemma join_eq_nil : ∀ {L : list (list α)}, join L = [] ↔ ∀ l ∈ L, l = []
| []       := iff_of_true rfl (forall_mem_nil _)
| (l :: L) := by simp only [join, append_eq_nil, join_eq_nil, forall_mem_cons]

@[simp] lemma join_append (L₁ L₂ : list (list α)) : join (L₁ ++ L₂) = join L₁ ++ join L₂ :=
by induction L₁; [refl, simp only [*, join, cons_append, append_assoc]]

@[simp] lemma join_filter_empty_eq_ff [decidable_pred (λ l : list α, l.empty = ff)] :
  ∀ {L : list (list α)}, join (L.filter (λ l, l.empty = ff)) = L.join
| []              := rfl
| ([] :: L)       := by simp [@join_filter_empty_eq_ff L]
| ((a :: l) :: L) := by simp [@join_filter_empty_eq_ff L]

@[simp] lemma join_filter_ne_nil [decidable_pred (λ l : list α, l ≠ [])] {L : list (list α)} :
  join (L.filter (λ l, l ≠ [])) = L.join :=
by simp [join_filter_empty_eq_ff, ← empty_iff_eq_nil]

lemma join_join (l : list (list (list α))) : l.join.join = (l.map join).join :=
by { induction l, simp, simp [l_ih] }

@[simp] lemma length_join (L : list (list α)) : length (join L) = sum (map length L) :=
by induction L; [refl, simp only [*, join, map, sum_cons, length_append]]

@[simp] lemma length_bind (l : list α) (f : α → list β) :
  length (list.bind l f) = sum (map (length ∘ f) l) :=
by rw [list.bind, length_join, map_map]

/-- In a join, taking the first elements up to an index which is the sum of the lengths of the
first `i` sublists, is the same as taking the join of the first `i` sublists. -/
lemma take_sum_join (L : list (list α)) (i : ℕ) :
  L.join.take ((L.map length).take i).sum = (L.take i).join :=
begin
  induction L generalizing i, { simp },
  cases i, { simp },
  simp [take_append, L_ih]
end

/-- In a join, dropping all the elements up to an index which is the sum of the lengths of the
first `i` sublists, is the same as taking the join after dropping the first `i` sublists. -/
lemma drop_sum_join (L : list (list α)) (i : ℕ) :
  L.join.drop ((L.map length).take i).sum = (L.drop i).join :=
begin
  induction L generalizing i, { simp },
  cases i, { simp },
  simp [drop_append, L_ih],
end

/-- Taking only the first `i+1` elements in a list, and then dropping the first `i` ones, one is
left with a list of length `1` made of the `i`-th element of the original list. -/
lemma drop_take_succ_eq_cons_nth_le (L : list α) {i : ℕ} (hi : i < L.length) :
  (L.take (i+1)).drop i = [nth_le L i hi] :=
begin
  induction L generalizing i,
  { simp only [length] at hi, exact (nat.not_succ_le_zero i hi).elim },
  cases i, { simp },
  have : i < L_tl.length,
  { simp at hi,
    exact nat.lt_of_succ_lt_succ hi },
  simp [L_ih this],
  refl
end

/-- In a join of sublists, taking the slice between the indices `A` and `B - 1` gives back the
original sublist of index `i` if `A` is the sum of the lenghts of sublists of index `< i`, and
`B` is the sum of the lengths of sublists of index `≤ i`. -/
lemma drop_take_succ_join_eq_nth_le (L : list (list α)) {i : ℕ} (hi : i < L.length) :
  (L.join.take ((L.map length).take (i+1)).sum).drop ((L.map length).take i).sum = nth_le L i hi :=
begin
  have : (L.map length).take i = ((L.take (i+1)).map length).take i, by simp [map_take, take_take],
  simp [take_sum_join, this, drop_sum_join, drop_take_succ_eq_cons_nth_le _ hi]
end

/-- Auxiliary lemma to control elements in a join. -/
lemma sum_take_map_length_lt1 (L : list (list α)) {i j : ℕ}
  (hi : i < L.length) (hj : j < (nth_le L i hi).length) :
  ((L.map length).take i).sum + j < ((L.map length).take (i+1)).sum :=
by simp [hi, sum_take_succ, hj]

/-- Auxiliary lemma to control elements in a join. -/
lemma sum_take_map_length_lt2 (L : list (list α)) {i j : ℕ}
  (hi : i < L.length) (hj : j < (nth_le L i hi).length) :
  ((L.map length).take i).sum + j < L.join.length :=
begin
  convert lt_of_lt_of_le (sum_take_map_length_lt1 L hi hj) (monotone_sum_take _ hi),
  have : L.length = (L.map length).length, by simp,
  simp [this, -length_map]
end

/-- The `n`-th element in a join of sublists is the `j`-th element of the `i`th sublist,
where `n` can be obtained in terms of `i` and `j` by adding the lengths of all the sublists
of index `< i`, and adding `j`. -/
lemma nth_le_join (L : list (list α)) {i j : ℕ}
  (hi : i < L.length) (hj : j < (nth_le L i hi).length) :
  nth_le L.join (((L.map length).take i).sum + j) (sum_take_map_length_lt2 L hi hj) =
  nth_le (nth_le L i hi) j hj :=
by rw [nth_le_take L.join (sum_take_map_length_lt2 L hi hj) (sum_take_map_length_lt1 L hi hj),
  nth_le_drop, nth_le_of_eq (drop_take_succ_join_eq_nth_le L hi)]

/-- Two lists of sublists are equal iff their joins coincide, as well as the lengths of the
sublists. -/
theorem eq_iff_join_eq (L L' : list (list α)) :
  L = L' ↔ L.join = L'.join ∧ map length L = map length L' :=
begin
  refine ⟨λ H, by simp [H], _⟩,
  rintros ⟨join_eq, length_eq⟩,
  apply ext_le,
  { have : length (map length L) = length (map length L'), by rw length_eq,
    simpa using this },
  { assume n h₁ h₂,
    rw [← drop_take_succ_join_eq_nth_le, ← drop_take_succ_join_eq_nth_le, join_eq, length_eq] }
end

end list


import Mathlib.Algebra.Group.Defs
import Mathlib.Tactic.NormCast
import Mathlib.Tactic.RunCmd
import Mathlib.Lean.Exception
import Mathlib.Util.Time
import Qq.MetaM
open Qq Lean Meta Elab Command ToAdditive

-- work in a namespace so that it doesn't matter if names clash
namespace Test

-- [note] use the below options for diagnostics:
-- set_option trace.to_additive true
-- set_option trace.to_additive_detail true
-- set_option pp.universes true
-- set_option pp.explicit true
-- set_option pp.notation false

@[to_additive bar0]
def foo0 {α} [Mul α] [One α] (x y : α) : α := x * y * 1

theorem bar0_works : bar0 3 4 = 7 := by decide

class my_has_pow (α : Type u) (β : Type v) :=
(pow : α → β → α)

instance : my_has_pow Nat Nat := ⟨fun a b => a ^ b⟩

class my_has_scalar (M : Type u) (α : Type v) :=
(smul : M → α → α)

instance : my_has_scalar Nat Nat := ⟨fun a b => a * b⟩
attribute [to_additive (reorder := 1) my_has_scalar] my_has_pow
attribute [to_additive (reorder := 1 4)] my_has_pow.pow

@[to_additive bar1]
def foo1 {α : Type u} [my_has_pow α ℕ] (x : α) (n : ℕ) : α := @my_has_pow.pow α ℕ _ x n

theorem foo1_works : foo1 3 4 = Nat.pow 3 4 := by decide
theorem bar1_works : bar1 3 4 = 3 * 4 := by decide

infix:80 " ^ " => my_has_pow.pow

instance dummy_pow : my_has_pow ℕ $ PLift ℤ := ⟨fun _ _ => 5⟩

@[to_additive bar2]
def foo2 {α} [my_has_pow α ℕ] (x : α) (n : ℕ) (m : PLift ℤ) : α := x ^ (n ^ m)

theorem foo2_works : foo2 2 3 (PLift.up 2) = Nat.pow 2 5 := by decide
theorem bar2_works : bar2 2 3 (PLift.up 2) =  2 * 5 := by decide

@[to_additive bar3]
def foo3 {α} [my_has_pow α ℕ] (x : α) : ℕ → α := @my_has_pow.pow α ℕ _ x

theorem foo3_works : foo3 2 3 = Nat.pow 2 3 := by decide
theorem bar3_works : bar3 2 3 =  2 * 3 := by decide

@[to_additive bar4]
def foo4 {α : Type u} : Type v → Type (max u v) := @my_has_pow α

@[to_additive bar4_test]
lemma foo4_test {α β : Type u} : @foo4 α β = @my_has_pow α β := rfl

@[to_additive bar5]
def foo5 {α} [my_has_pow α ℕ] [my_has_pow ℕ ℤ] : True := True.intro

@[to_additive bar6]
def foo6 {α} [my_has_pow α ℕ] : α → ℕ → α := @my_has_pow.pow α ℕ _

-- fails because of workaround in `transform`. Not sure if this will show up in practice
-- @[to_additive bar7]
-- def foo7 := @my_has_pow.pow

-- theorem foo7_works : foo7 2 3 = Nat.pow 2 3 := by decide
-- theorem bar7_works : bar7 2 3 =  2 * 3 := by decide

/-- Check that we don't additivize `Nat` expressions. -/
@[to_additive bar8]
def foo8 (a b : ℕ) := a * b

theorem bar8_works : bar8 2 3 = 6 := by decide

/-- Check that we don't additivize `Nat` numerals. -/
@[to_additive bar9]
def foo9 := 1

theorem bar9_works : bar9 = 1 := by decide

@[to_additive bar10]
def foo10 (n m : ℕ) := HPow.hPow n m + n * m * 2 + 1 * 0 + 37 * 1 + 2

theorem bar10_works : bar10 = foo10 := by rfl

@[to_additive bar11]
def foo11 (n : ℕ) (m : ℤ) := n * m * 2 + 1 * 0 + 37 * 1 + 2

theorem bar11_works : bar11 = foo11 := by rfl

@[to_additive bar12]
def foo12 (_ : Nat) (_ : Int) : Fin 37 := ⟨2, by decide⟩

@[to_additive (reorder := 1 4) bar13]
lemma foo13 {α β : Type u} [my_has_pow α β] (x : α) (y : β) : x ^ y = x ^ y := rfl

@[to_additive (reorder := 1 4) bar14]
def foo14 {α β : Type u} [my_has_pow α β] (x : α) (y : β) : α := (x ^ y) ^ y

@[to_additive (reorder := 1 4) bar15]
lemma foo15 {α β : Type u} [my_has_pow α β] (x : α) (y : β) : foo14 x y = (x ^ y) ^ y := rfl

@[to_additive (reorder := 1 4) bar16]
lemma foo16 {α β : Type u} [my_has_pow α β] (x : α) (y : β) : foo14 x y = (x ^ y) ^ y := foo15 x y

initialize testExt : SimpExtension ←
  registerSimpAttr `simp_test "test"

@[to_additive bar17]
def foo17 [Group α] (x : α) : α := x * 1

@[to_additive (attr := simp) bar18]
lemma foo18 [Group α] (x : α) : foo17 x = x ∧ foo17 x = 1 * x :=
  ⟨mul_one x, mul_one x |>.trans <| one_mul x |>.symm⟩

example [Group α] (x : α) : foo17 x = 1 * x := by simp
example [Group α] (x : α) : foo17 x = x := by simp
example [AddGroup α] (x : α) : bar17 x = 0 + x := by simp
example [AddGroup α] (x : α) : bar17 x = x := by simp

run_cmd do
  let mul1 := `test.toAdditive._auxLemma |>.mkNum 1
  let mul2 := `test.toAdditive._auxLemma |>.mkNum 2
  let add1 := `test.toAdditive._auxLemma |>.mkNum 3
  let add2 := `test.toAdditive._auxLemma |>.mkNum 4
  unless findTranslation? (← getEnv) mul1 == some add1 do throwError "1"
  unless findTranslation? (← getEnv) mul2 == some add2 do throwError "2"

/- Testing nested to_additive calls -/
@[to_additive (attr := simp, to_additive baz19) bar19]
def foo19 := 1

example {x} (h : 1 = x) : foo19 = x := by simp; guard_target = 1 = x; exact h
example {x} (h : 1 = x) : bar19 = x := by simp; guard_target = 1 = x; exact h
example {x} (h : 1 = x) : baz19 = x := by simp; guard_target = 1 = x; exact h

/- Testing that the order of the attributes doesn't matter -/
@[to_additive (attr := to_additive baz20, simp) bar20]
def foo20 := 1

example {x} (h : 1 = x) : foo20 = x := by simp; guard_target = 1 = x; exact h
example {x} (h : 1 = x) : bar20 = x := by simp; guard_target = 1 = x; exact h
example {x} (h : 1 = x) : baz20 = x := by simp; guard_target = 1 = x; exact h

@[to_additive bar21]
def foo21 {N} {A} [Pow A N] (a : A) (n : N) : A := a ^ n

run_cmd liftCoreM <| MetaM.run' <| guard <| relevantArgAttr.find? (← getEnv) `Test.foo21 == some 1

/- test the eta-expansion applied on `foo6`. -/
run_cmd do
  let c ← getConstInfo `Test.foo6
  let e : Expr ← liftCoreM <| MetaM.run' <| expand c.value!
  let t ← liftCoreM <| MetaM.run' <| expand c.type
  let decl := c |>.updateName `Test.barr6 |>.updateType t |>.updateValue e |>.toDeclaration!
  liftCoreM <| addAndCompile decl
  -- test that we cannot transport a declaration to itself
  successIfFail <| liftCoreM <| addToAdditiveAttr `bar11_works { ref := ← getRef }

/- Test on inductive types -/
inductive AddInd : ℕ → Prop where
  | basic : AddInd 2
  | zero : AddInd 0

@[to_additive]
inductive MulInd : ℕ → Prop where
  | basic : MulInd 2
  | one : MulInd 1

run_cmd do
  unless findTranslation? (← getEnv) `Test.MulInd.one == some `Test.AddInd.zero do throwError "1"
  unless findTranslation? (← getEnv) `Test.MulInd.basic == none do throwError "2"
  unless findTranslation? (← getEnv) `Test.MulInd == some `Test.AddInd do throwError "3"

@[to_additive addFixedNumeralTest]
def fixedNumeralTest {α} [One α] :=
@OfNat.ofNat ((fun _ => ℕ) (1 : α)) 1 _

@[to_additive addFixedNumeralTest2]
def fixedNumeralTest2 {α} [One α] :=
@OfNat.ofNat ((fun _ => ℕ) (1 : α)) 1 (@One.toOfNat1 ((fun _ => ℕ) (1 : α)) _)

/-! Test the namespace bug (#8733). This code should *not* generate a lemma
  `add_some_def.in_namespace`. -/
def some_def.in_namespace : Bool := false

def some_def {α : Type u} [Mul α] (x : α) : α :=
if some_def.in_namespace then x * x else x

def myFin (_ : ℕ) := ℕ

instance : One (myFin n) := ⟨(1 : ℕ)⟩

@[to_additive bar]
def myFin.foo : myFin (n+1) := 1

/-- We can pattern-match with `1`, which creates a term with a pure nat literal. See #2046 -/
@[to_additive]
def mul_foo {α} [Monoid α] (a : α) : ℕ → α
| 0 => 1
| 1 => 1
| (_ + 2) => a

-- cannot apply `@[to_additive]` to `some_def` if `some_def.in_namespace` doesn't have the attribute
run_cmd liftCoreM <| successIfFail <|
    transformDecl { ref := ← getRef} `Test.some_def `Test.add_some_def

attribute [to_additive some_other_name] some_def.in_namespace
attribute [to_additive add_some_def] some_def

run_cmd do liftCoreM <| successIfFail (getConstInfo `Test.add_some_def.in_namespace)

-- [todo] currently this test breaks.
-- example : (AddUnits.mk_of_add_eq_zero 0 0 (by simp) : ℕ)
--         = (AddUnits.mk_of_add_eq_zero 0 0 (by simp) : ℕ) :=
-- by norm_cast

section

set_option linter.unusedVariables false
-- porting note : not sure what the tests do, but the linter complains.

def foo_mul {I J K : Type} (n : ℕ) {f : I → Type} (L : Type) [∀ i, One (f i)]
  [Add I] [Mul L] : true := by trivial

@[to_additive]
instance pi.has_one {I : Type} {f : I → Type} [(i : I) → One $ f i] : One ((i : I) → f i) :=
  ⟨fun _ => 1⟩

run_cmd do
  let n ← liftCoreM <| MetaM.run' <| firstMultiplicativeArg `Test.pi.has_one
  if n != 1 then throwError "{n} != 1"
  let n ← liftCoreM <| MetaM.run' <| firstMultiplicativeArg `Test.foo_mul
  if n != 4 then throwError "{n} != 4"

end

@[to_additive]
def nat_pi_has_one {α : Type} [One α] : One ((x : Nat) → α) := by infer_instance

@[to_additive]
def pi_nat_has_one {I : Type} : One ((x : I) → Nat)  := pi.has_one

example : @pi_nat_has_one = @pi_nat_has_zero := rfl

section test_noncomputable

@[to_additive Bar.bar]
noncomputable def Foo.foo (h : ∃ _ : α, True) : α := Classical.choose h

@[to_additive Bar.bar']
def Foo.foo' : ℕ := 2

theorem Bar.bar'_works : Bar.bar' = 2 := by decide

run_cmd (do
  if !isNoncomputable (← getEnv) `Test.Bar.bar then throwError "bar shouldn't be computable"
  if isNoncomputable (← getEnv) `Test.Bar.bar' then throwError "bar' should be computable")
end test_noncomputable

section instances

class FooClass (α) : Prop where
  refle : ∀ a : α, a = a

@[to_additive]
instance FooClass_one [One α] : FooClass α := ⟨λ _ => rfl ⟩

lemma one_fooClass [One α] : FooClass α := by infer_instance

lemma zero_fooClass [Zero α] : FooClass α := by infer_instance

end instances

/- Test that we can rewrite with definitions with the `@[to_additive]` attribute. -/
@[to_additive]
lemma npowRec_zero [One M] [Mul M] (x : M) : npowRec 0 x = 1 :=
  by rw [npowRec]

/- Test that we can rewrite with definitions without the `@[to_additive]` attribute. -/
@[to_additive addoptiontest]
lemma optiontest (x : Option α) : x.elim .none Option.some = x :=
  by cases x <;> rw [Option.elim]

/- Check that `to_additive` works if a `_match` aux declaration is created. -/
@[to_additive]
def IsUnit [Mul M] (a : M) : Prop := a ≠ a

@[to_additive]
theorem isUnit_iff_exists_inv [Mul M] {a : M} : IsUnit a ↔ ∃ _ : α, a ≠ a :=
  ⟨fun h => absurd rfl h, fun ⟨_, hab⟩ => hab⟩

/-! Test that `@[to_additive]` correctly translates auxiliary declarations that do not have the
original declaration name as prefix.-/
@[to_additive]
def IsUnit' [Monoid M] (a : M) : Prop := ∃ b : M, a * b = 1

@[to_additive]
theorem isUnit'_iff_exists_inv [CommMonoid M] {a : M} : IsUnit' a ↔ ∃ b, a * b = 1 := Iff.rfl

@[to_additive]
theorem isUnit'_iff_exists_inv' [CommMonoid M] {a : M} : IsUnit' a ↔ ∃ b, b * a = 1 := by
  simp [isUnit'_iff_exists_inv, mul_comm]

def Ones : ℕ → Q(Nat)
| 0     => q(1)
| (n+1) => q($(Ones n) + $(Ones n))

-- this test just exists to see if this finishes in finite time. It should take <100ms.
-- #time
run_cmd do
  let e : Expr := Ones 300
  let _ ← liftCoreM <| MetaM.run' <| applyReplacementFun e

-- testing `isConstantApplication`
run_cmd do
  unless !(q((fun _ y => y) 3 4) : Q(Nat)).isConstantApplication do throwError "1"
  unless (q((fun x _ => x) 3 4) : Q(Nat)).isConstantApplication do throwError "2"
  unless !(q((fun x => x) 3) : Q(Nat)).isConstantApplication do throwError "3"
  unless (q((fun _ => 5) 3) : Q(Nat)).isConstantApplication do throwError "4"

/-!
Some arbitrary tests to check whether additive names are guessed correctly.
-/
section guessName

def checkGuessName (s t : String) : Elab.Command.CommandElabM Unit :=
  unless guessName s == t do throwError "failed: {guessName s} != {t}"

run_cmd
  checkGuessName "HMul_Eq_LEOne_Conj₂MulLT'" "HAdd_Eq_Nonpos_Conj₂AddLT'"
  checkGuessName "OneMulSMulInvDivPow"       "ZeroAddVAddNegSubNSMul"
  checkGuessName "ProdFinprodNPowZPow"       "SumFinsumNSMulZSMul"

  -- The current design swaps all instances of `Comm`+`Add` in order to have
  -- `AddCommMonoid` instead of `CommAddMonoid`.
  checkGuessName "comm_mul_CommMul_commMul" "comm_add_AddComm_addComm"
  checkGuessName "mul_comm_MulComm_mulComm" "add_comm_AddComm_addComm"
  checkGuessName "mul_single_eq_same" "single_eq_same"
  checkGuessName "mul_support" "support"
  checkGuessName "mul_tsupport" "tsupport"
  checkGuessName "mul_indicator" "indicator"

  checkGuessName "CommMonoid" "AddCommMonoid"
  checkGuessName "commMonoid" "addCommMonoid"

  checkGuessName "CancelCommMonoid" "AddCancelCommMonoid"
  checkGuessName "cancelCommMonoid" "addCancelCommMonoid"
  checkGuessName "CancelMonoid" "AddCancelMonoid"
  checkGuessName "cancelMonoid" "addCancelMonoid"
  checkGuessName "RightCancelMonoid" "AddRightCancelMonoid"
  checkGuessName "rightCancelMonoid" "addRightCancelMonoid"
  checkGuessName "LeftCancelMonoid" "AddLeftCancelMonoid"
  checkGuessName "leftCancelMonoid" "addLeftCancelMonoid"

  checkGuessName "IsLeftRegular" "IsAddLeftRegular"
  checkGuessName "isRightRegular" "isAddRightRegular"
  checkGuessName "IsRegular" "IsAddRegular"

  checkGuessName "LTOne_LEOne_OneLE_OneLT" "Neg_Nonpos_Nonneg_Pos"
  checkGuessName "LTHMulHPowLEHDiv" "LTHAddHSMulLEHSub"
  checkGuessName "OneLEHMul" "NonnegHAdd"
  checkGuessName "OneLTHPow" "PosHSMul"
  checkGuessName "OneLTPow" "PosNSMul"
  checkGuessName "instCoeTCOneHom" "instCoeTCZeroHom"
  checkGuessName "instCoeTOneHom" "instCoeTZeroHom"
  checkGuessName "instCoeOneHom" "instCoeZeroHom"
  checkGuessName "invFun_eq_symm" "invFun_eq_symm"
  checkGuessName "MulEquiv.symmInvFun" "AddEquiv.symmInvFun"

end guessName

end Test

run_cmd Elab.Command.liftCoreM <| ToAdditive.insertTranslation `localize `add_localize

@[to_additive] def localize.r := Nat
@[to_additive add_localize] def localize := Nat
@[to_additive] def localize.s := Nat

run_cmd do
  unless findTranslation? (← getEnv) `localize.r == some `add_localize.r do throwError "1"
  unless findTranslation? (← getEnv) `localize   == some `add_localize   do throwError "2"
  unless findTranslation? (← getEnv) `localize.s == some `add_localize.s do throwError "3"


/-
Copyright (c) 2019 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau
-/
import algebra.hom.group
import control.applicative
import control.traversable.basic
import logic.equiv.basic

/-!
# Free constructions

## Main definitions

* `free_magma α`: free magma (structure with binary operation without any axioms) over alphabet `α`,
  defined inductively, with traversable instance and decidable equality.
* `magma.free_semigroup α`: free semigroup over magma `α`.
* `free_semigroup α`: free semigroup over alphabet `α`, defined as a synonym for `α × list α`
  (i.e. nonempty lists), with traversable instance and decidable equality.
* `free_semigroup_free_magma α`: isomorphism between `magma.free_semigroup (free_magma α)` and
  `free_semigroup α`.
* `free_magma.lift`: the universal property of the free magma, expressing its adjointness.
-/

universes u v l

/-- Free magma over a given alphabet. -/
@[derive decidable_eq]
inductive free_magma (α : Type u) : Type u
| of : α → free_magma
| mul : free_magma → free_magma → free_magma

/-- Free nonabelian additive magma over a given alphabet. -/
@[derive decidable_eq]
inductive free_add_magma (α : Type u) : Type u
| of : α → free_add_magma
| add : free_add_magma → free_add_magma → free_add_magma

attribute [to_additive] free_magma

namespace free_magma

variables {α : Type u}

@[to_additive]
instance [inhabited α] : inhabited (free_magma α) := ⟨of default⟩

@[to_additive]
instance : has_mul (free_magma α) := ⟨free_magma.mul⟩

attribute [pattern] has_mul.mul

@[simp, to_additive]
theorem mul_eq (x y : free_magma α) : mul x y = x * y := rfl

/-- Recursor for `free_magma` using `x * y` instead of `free_magma.mul x y`. -/
@[elab_as_eliminator, to_additive
  "Recursor for `free_add_magma` using `x + y` instead of `free_add_magma.add x y`."]
def rec_on_mul {C : free_magma α → Sort l} (x)
  (ih1 : ∀ x, C (of x)) (ih2 : ∀ x y, C x → C y → C (x * y)) :
  C x :=
free_magma.rec_on x ih1 ih2

end free_magma

/-- Lifts a function `α → β` to a magma homomorphism `free_magma α → β` given a magma `β`. -/
def free_magma.lift_aux {α : Type u} {β : Type v} [has_mul β] (f : α → β) : free_magma α → β
| (free_magma.of x) := f x
| (x * y)           := x.lift_aux * y.lift_aux

/-- Lifts a function `α → β` to an additive magma homomorphism `free_add_magma α → β` given
an additive magma `β`. -/
def free_add_magma.lift_aux {α : Type u} {β : Type v} [has_add β] (f : α → β) : free_add_magma α → β
| (free_add_magma.of x) := f x
| (x + y)               := x.lift_aux + y.lift_aux

attribute [to_additive free_add_magma.lift_aux] free_magma.lift_aux

namespace free_magma

variables {α : Type u} {β : Type v} [has_mul β] (f : α → β)

@[to_additive]
theorem lift_aux_unique (F : mul_hom (free_magma α) β) : ⇑F = lift_aux (F ∘ of) :=
funext $ λ x, free_magma.rec_on x (λ x, rfl) $ λ x y ih1 ih2,
(F.map_mul x y).trans $ congr (congr_arg _ ih1) ih2

/-- The universal property of the free magma expressing its adjointness. -/
@[to_additive "The universal property of the free additive magma expressing its adjointness."]
def lift : (α → β) ≃ mul_hom (free_magma α) β :=
{ to_fun    := λ f,
  { to_fun := lift_aux f,
    map_mul' := λ x y, rfl, },
  inv_fun   := λ F, F ∘ of,
  left_inv  := λ f, by { ext, simp only [lift_aux, mul_hom.coe_mk, function.comp_app], },
  right_inv := λ F, by { ext, rw [mul_hom.coe_mk, lift_aux_unique], } }

@[simp, to_additive] lemma lift_of (x) : lift f (of x) = f x := rfl

end free_magma

/-- The unique magma homomorphism `free_magma α → free_magma β` that sends
each `of x` to `of (f x)`. -/
def free_magma.map {α : Type u} {β : Type v} (f : α → β) : free_magma α → free_magma β
| (free_magma.of x) := free_magma.of (f x)
| (x * y)           := x.map * y.map

/-- The unique additive magma homomorphism `free_add_magma α → free_add_magma β` that sends
each `of x` to `of (f x)`. -/
def free_add_magma.map {α : Type u} {β : Type v} (f : α → β) : free_add_magma α → free_add_magma β
| (free_add_magma.of x) := free_add_magma.of (f x)
| (x + y)               := x.map + y.map

attribute [to_additive free_add_magma.map] free_magma.map

namespace free_magma

variables {α : Type u}

section map

variables {β : Type v} (f : α → β)

@[simp, to_additive] lemma map_of (x) : map f (of x) = of (f x) := rfl
@[simp, to_additive] lemma map_mul (x y) : map f (x * y) = map f x * map f y := rfl

end map

section category

@[to_additive]
instance : monad free_magma :=
{ pure := λ _, of,
  bind := λ _ _ x f, lift f x }

/-- Recursor on `free_magma` using `pure` instead of `of`. -/
@[elab_as_eliminator, to_additive "Recursor on `free_add_magma` using `pure` instead of `of`."]
protected def rec_on_pure {C : free_magma α → Sort l} (x)
  (ih1 : ∀ x, C (pure x)) (ih2 : ∀ x y, C x → C y → C (x * y)) :
  C x :=
free_magma.rec_on_mul x ih1 ih2

variables {β : Type u}

@[simp, to_additive]
lemma map_pure (f : α → β) (x) : (f <$> pure x : free_magma β) = pure (f x) := rfl

@[simp, to_additive]
lemma map_mul' (f : α → β) (x y : free_magma α) : (f <$> (x * y)) = (f <$> x * f <$> y) := rfl

@[simp, to_additive]
lemma pure_bind (f : α → free_magma β) (x) : (pure x >>= f) = f x := rfl

@[simp, to_additive]
lemma mul_bind (f : α → free_magma β) (x y : free_magma α) :
  (x * y >>= f) = ((x >>= f) * (y >>= f)) := rfl

@[simp, to_additive]
lemma pure_seq {α β : Type u} {f : α → β} {x : free_magma α} : pure f <*> x = f <$> x := rfl

@[simp, to_additive]
lemma mul_seq {α β : Type u} {f g : free_magma (α → β)} {x : free_magma α} :
  (f * g) <*> x = (f <*> x) * (g <*> x) := rfl

@[to_additive]
instance : is_lawful_monad free_magma.{u} :=
{ pure_bind := λ _ _ _ _, rfl,
  bind_assoc := λ α β γ x f g, free_magma.rec_on_pure x (λ x, rfl)
    (λ x y ih1 ih2, by rw [mul_bind, mul_bind, mul_bind, ih1, ih2]),
  id_map := λ α x, free_magma.rec_on_pure x (λ _, rfl)
    (λ x y ih1 ih2, by rw [map_mul', ih1, ih2]) }

end category

end free_magma

/-- `free_magma` is traversable. -/
protected def free_magma.traverse {m : Type u → Type u} [applicative m] {α β : Type u}
  (F : α → m β) :
  free_magma α → m (free_magma β)
| (free_magma.of x) := free_magma.of <$> F x
| (x * y)           := (*) <$> x.traverse <*> y.traverse

/-- `free_add_magma` is traversable. -/
protected def free_add_magma.traverse {m : Type u → Type u} [applicative m] {α β : Type u}
  (F : α → m β) :
  free_add_magma α → m (free_add_magma β)
| (free_add_magma.of x) := free_add_magma.of <$> F x
| (x + y)               := (+) <$> x.traverse <*> y.traverse

attribute [to_additive free_add_magma.traverse] free_magma.traverse

namespace free_magma

variables {α : Type u}

section category

variables {β : Type u}

@[to_additive]
instance : traversable free_magma := ⟨@free_magma.traverse⟩

variables {m : Type u → Type u} [applicative m] (F : α → m β)

@[simp, to_additive]
lemma traverse_pure (x) : traverse F (pure x : free_magma α) = pure <$> F x := rfl

@[simp, to_additive]
lemma traverse_pure' : traverse F ∘ pure = λ x, (pure <$> F x : m (free_magma β)) := rfl

@[simp, to_additive]
lemma traverse_mul (x y : free_magma α) :
  traverse F (x * y) = (*) <$> traverse F x <*> traverse F y := rfl

@[simp, to_additive]
lemma traverse_mul' :
  function.comp (traverse F) ∘ @has_mul.mul (free_magma α) _ =
    λ x y, (*) <$> traverse F x <*> traverse F y := rfl

@[simp, to_additive]
lemma traverse_eq (x) : free_magma.traverse F x = traverse F x := rfl

@[simp, to_additive]
lemma mul_map_seq (x y : free_magma α) :
  ((*) <$> x <*> y : id (free_magma α)) = (x * y : free_magma α) := rfl

@[to_additive]
instance : is_lawful_traversable free_magma.{u} :=
{ id_traverse := λ α x, free_magma.rec_on_pure x (λ x, rfl)
    (λ x y ih1 ih2, by rw [traverse_mul, ih1, ih2, mul_map_seq]),
  comp_traverse := λ F G hf1 hg1 hf2 hg2 α β γ f g x, free_magma.rec_on_pure x
    (λ x, by resetI; simp only [traverse_pure, traverse_pure'] with functor_norm)
    (λ x y ih1 ih2, by resetI; rw [traverse_mul, ih1, ih2, traverse_mul];
      simp only [traverse_mul'] with functor_norm),
  naturality := λ F G hf1 hg1 hf2 hg2 η α β f x, free_magma.rec_on_pure x
    (λ x, by simp only [traverse_pure] with functor_norm)
    (λ x y ih1 ih2, by simp only [traverse_mul] with functor_norm; rw [ih1, ih2]),
  traverse_eq_map_id := λ α β f x, free_magma.rec_on_pure x (λ _, rfl)
    (λ x y ih1 ih2, by rw [traverse_mul, ih1, ih2, map_mul', mul_map_seq]; refl),
  .. free_magma.is_lawful_monad }

end category

end free_magma

/-- Representation of an element of a free magma. -/
protected def free_magma.repr {α : Type u} [has_repr α] : free_magma α → string
| (free_magma.of x) := repr x
| (x * y)           := "( " ++ x.repr ++ " * " ++ y.repr ++ " )"

/-- Representation of an element of a free additive magma. -/
protected def free_add_magma.repr {α : Type u} [has_repr α] : free_add_magma α → string
| (free_add_magma.of x) := repr x
| (x + y)               := "( " ++ x.repr ++ " + " ++ y.repr ++ " )"

attribute [to_additive free_add_magma.repr] free_magma.repr

@[to_additive]
instance {α : Type u} [has_repr α] : has_repr (free_magma α) := ⟨free_magma.repr⟩

/-- Length of an element of a free magma. -/
def free_magma.length {α : Type u} : free_magma α → ℕ
| (free_magma.of x) := 1
| (x * y)           := x.length + y.length

/-- Length of an element of a free additive magma. -/
def free_add_magma.length {α : Type u} : free_add_magma α → ℕ
| (free_add_magma.of x) := 1
| (x + y)               := x.length + y.length

attribute [to_additive free_add_magma.length] free_magma.length

/-- Associativity relations for a magma. -/
inductive magma.free_semigroup.r (α : Type u) [has_mul α] : α → α → Prop
| intro : ∀ x y z, magma.free_semigroup.r ((x * y) * z) (x * (y * z))
| left : ∀ w x y z, magma.free_semigroup.r (w * ((x * y) * z)) (w * (x * (y * z)))

/-- Associativity relations for an additive magma. -/
inductive add_magma.free_add_semigroup.r (α : Type u) [has_add α] : α → α → Prop
| intro : ∀ x y z, add_magma.free_add_semigroup.r ((x + y) + z) (x + (y + z))
| left : ∀ w x y z, add_magma.free_add_semigroup.r (w + ((x + y) + z)) (w + (x + (y + z)))

attribute [to_additive add_magma.free_add_semigroup.r] magma.free_semigroup.r

namespace magma

/-- Free semigroup over a magma. -/
@[to_additive add_magma.free_add_semigroup "Free additive semigroup over an additive magma."]
def free_semigroup (α : Type u) [has_mul α] : Type u :=
quot $ free_semigroup.r α

namespace free_semigroup

variables {α : Type u} [has_mul α]

/-- Embedding from magma to its free semigroup. -/
@[to_additive "Embedding from additive magma to its free additive semigroup."]
def of : α → free_semigroup α := quot.mk _

@[to_additive]
instance [inhabited α] : inhabited (free_semigroup α) := ⟨of default⟩

@[elab_as_eliminator, to_additive]
protected lemma induction_on {C : free_semigroup α → Prop} (x : free_semigroup α)
  (ih : ∀ x, C (of x)) : C x :=
quot.induction_on x ih

@[to_additive]
theorem of_mul_assoc (x y z : α) : of ((x * y) * z) = of (x * (y * z)) :=
quot.sound $ r.intro x y z

@[to_additive]
theorem of_mul_assoc_left (w x y z : α) : of (w * ((x * y) * z)) = of (w * (x * (y * z))) :=
quot.sound $ r.left w x y z

@[to_additive]
theorem of_mul_assoc_right (w x y z : α) : of (((w * x) * y) * z) = of ((w * (x * y)) * z) :=
by rw [of_mul_assoc, of_mul_assoc, of_mul_assoc, of_mul_assoc_left]

@[to_additive]
instance : semigroup (free_semigroup α) :=
{ mul := λ x y, begin
    refine quot.lift_on x (λ p, quot.lift_on y (λ q, (quot.mk _ $ p * q : free_semigroup α)) _) _,
    { rintros a b (⟨c, d, e⟩ | ⟨c, d, e, f⟩); change of _ = of _,
      { rw of_mul_assoc_left },
      { rw [← of_mul_assoc, of_mul_assoc_left, of_mul_assoc] } },
    { refine quot.induction_on y (λ q, _),
      rintros a b (⟨c, d, e⟩ | ⟨c, d, e, f⟩); change of _ = of _,
      { rw of_mul_assoc_right },
      { rw [of_mul_assoc, of_mul_assoc, of_mul_assoc_left, of_mul_assoc_left, of_mul_assoc_left,
          ← of_mul_assoc c d, ← of_mul_assoc c d, of_mul_assoc_left] } }
  end,
  mul_assoc := λ x y z, quot.induction_on x $ λ p, quot.induction_on y $ λ q,
    quot.induction_on z $ λ r, of_mul_assoc p q r }

@[to_additive]
theorem of_mul (x y : α) : of (x * y) = of x * of y := rfl

section lift

variables {β : Type v} [semigroup β] (f : α → β)

/-- Lifts a magma homomorphism `α → β` to a semigroup homomorphism `magma.free_semigroup α → β`
given a semigroup `β`. -/
@[to_additive "Lifts an additive magma homomorphism `α → β` to an additive semigroup homomorphism
`add_magma.free_add_semigroup α → β` given an additive semigroup `β`."]
def lift (hf : ∀ x y, f (x * y) = f x * f y) : free_semigroup α → β :=
quot.lift f $ by rintros a b (⟨c, d, e⟩ | ⟨c, d, e, f⟩); simp only [hf, mul_assoc]

@[simp, to_additive] lemma lift_of {hf} (x : α) : lift f hf (of x) = f x := rfl

@[simp, to_additive] lemma lift_mul {hf} (x y) : lift f hf (x * y) = lift f hf x * lift f hf y :=
quot.induction_on x $ λ p, quot.induction_on y $ λ q, hf p q

@[to_additive]
theorem lift_unique (f : free_semigroup α → β) (hf : ∀ x y, f (x * y) = f x * f y) :
  f = lift (f ∘ of) (λ p q, hf (of p) (of q)) :=
funext $ λ x, quot.induction_on x $ λ p, rfl

end lift

variables {β : Type v} [has_mul β] (f : α → β)

/-- From a magma homomorphism `α → β` to a semigroup homomorphism
`magma.free_semigroup α → magma.free_semigroup β`. -/
@[to_additive "From an additive magma homomorphism `α → β` to an additive semigroup homomorphism
`add_magma.free_add_semigroup α → add_magma.free_add_semigroup β`."]
def map (hf : ∀ x y, f (x * y) = f x * f y) : free_semigroup α → free_semigroup β :=
lift (of ∘ f) (λ x y, congr_arg of $ hf x y)

@[simp, to_additive] lemma map_of {hf} (x) : map f hf (of x) = of (f x) := rfl
@[simp, to_additive] lemma map_mul {hf} (x y) : map f hf (x * y) = map f hf x * map f hf y :=
lift_mul _ _ _

end free_semigroup

end magma

/-- Free semigroup over a given alphabet.
(Note: In this definition, the free semigroup does not contain the empty word.) -/
@[to_additive "Free additive semigroup over a given alphabet."]
def free_semigroup (α : Type u) : Type u :=
α × list α

namespace free_semigroup

variables {α : Type u}

@[to_additive]
instance : semigroup (free_semigroup α) :=
{ mul := λ L1 L2, (L1.1, L1.2 ++ L2.1 :: L2.2),
  mul_assoc := λ L1 L2 L3, prod.ext rfl $ list.append_assoc _ _ _ }

/-- The embedding `α → free_semigroup α`. -/
@[to_additive "The embedding `α → free_add_semigroup α`."]
def of (x : α) : free_semigroup α :=
(x, [])

@[to_additive]
instance [inhabited α] : inhabited (free_semigroup α) := ⟨of default⟩

/-- Recursor for free semigroup using `of` and `*`. -/
@[elab_as_eliminator, to_additive "Recursor for free additive semigroup using `of` and `+`."]
protected def rec_on {C : free_semigroup α → Sort l} (x)
  (ih1 : ∀ x, C (of x)) (ih2 : ∀ x y, C (of x) → C y → C (of x * y)) :
  C x :=
prod.rec_on x $ λ f s, list.rec_on s ih1 (λ hd tl ih f, ih2 f (hd, tl) (ih1 f) (ih hd)) f

end free_semigroup

/-- Auxiliary function for `free_semigroup.lift`. -/
def free_semigroup.lift' {α : Type u} {β : Type v} [semigroup β] (f : α → β) : α → list α → β
| x [] := f x
| x (hd::tl) := f x * free_semigroup.lift' hd tl

/-- Auxiliary function for `free_semigroup.lift`. -/
def free_add_semigroup.lift' {α : Type u} {β : Type v} [add_semigroup β] (f : α → β) :
  α → list α → β
| x [] := f x
| x (hd::tl) := f x + free_add_semigroup.lift' hd tl

attribute [to_additive free_add_semigroup.lift'] free_semigroup.lift'

namespace free_semigroup

variables {α : Type u}

section lift

variables {β : Type v} [semigroup β] (f : α → β)

/-- Lifts a function `α → β` to a semigroup homomorphism `free_semigroup α → β` given
a semigroup `β`. -/
@[to_additive "Lifts a function `α → β` to an additive semigroup homomorphism
`free_add_semigroup α → β` given an additive semigroup `β`."]
def lift (x : free_semigroup α) : β :=
lift' f x.1 x.2

@[simp, to_additive] lemma lift_of (x : α) : lift f (of x) = f x := rfl
@[to_additive] lemma lift_of_mul (x y) : lift f (of x * y) = f x * lift f y := rfl

@[simp, to_additive] lemma lift_mul (x y) : lift f (x * y) = lift f x * lift f y :=
free_semigroup.rec_on x (λ p, rfl)
  (λ p x ih1 ih2, by rw [mul_assoc, lift_of_mul, lift_of_mul, mul_assoc, ih2])

@[to_additive]
theorem lift_unique (f : free_semigroup α → β) (hf : ∀ x y, f (x * y) = f x * f y) :
  f = lift (f ∘ of) :=
funext $ λ ⟨x, L⟩, list.rec_on L (λ x, rfl) (λ hd tl ih x,
  (hf (of x) (hd, tl)).trans $ congr_arg _ $ ih _) x

end lift

section map

variables {β : Type v} (f : α → β)

/-- The unique semigroup homomorphism that sends `of x` to `of (f x)`. -/
@[to_additive "The unique additive semigroup homomorphism that sends `of x` to `of (f x)`."]
def map : free_semigroup α → free_semigroup β :=
lift $ of ∘ f

@[simp, to_additive] lemma map_of (x) : map f (of x) = of (f x) := rfl
@[simp, to_additive] lemma map_mul (x y) : map f (x * y) = map f x * map f y :=
lift_mul _ _ _

end map

section category

variables {β : Type u}

@[to_additive]
instance : monad free_semigroup :=
{ pure := λ _, of,
  bind := λ _ _ x f, lift f x }

/-- Recursor that uses `pure` instead of `of`. -/
@[elab_as_eliminator, to_additive "Recursor that uses `pure` instead of `of`."]
def rec_on_pure {C : free_semigroup α → Sort l} (x)
  (ih1 : ∀ x, C (pure x)) (ih2 : ∀ x y, C (pure x) → C y → C (pure x * y)) :
  C x :=
free_semigroup.rec_on x ih1 ih2

@[simp, to_additive]
lemma map_pure (f : α → β) (x) : (f <$> pure x : free_semigroup β) = pure (f x) := rfl

@[simp, to_additive]
lemma map_mul' (f : α → β) (x y : free_semigroup α) :
  (f <$> (x * y)) = (f <$> x * f <$> y) :=
map_mul _ _ _

@[simp, to_additive] lemma pure_bind (f : α → free_semigroup β) (x) :
  (pure x >>= f) = f x := rfl

@[simp, to_additive]
lemma mul_bind (f : α → free_semigroup β) (x y : free_semigroup α) :
  (x * y >>= f) = ((x >>= f) * (y >>= f)) :=
lift_mul _ _ _

@[simp, to_additive] lemma pure_seq {f : α → β} {x : free_semigroup α} :
  pure f <*> x = f <$> x := rfl

@[simp, to_additive]
lemma mul_seq {f g : free_semigroup (α → β)} {x : free_semigroup α} :
  (f * g) <*> x = (f <*> x) * (g <*> x) :=
mul_bind _ _ _

@[to_additive]
instance : is_lawful_monad free_semigroup.{u} :=
{ pure_bind := λ _ _ _ _, rfl,
  bind_assoc := λ α β γ x f g, rec_on_pure x (λ x, rfl)
    (λ x y ih1 ih2, by rw [mul_bind, mul_bind, mul_bind, ih1, ih2]),
  id_map := λ α x, rec_on_pure x (λ _, rfl) (λ x y ih1 ih2, by rw [map_mul', ih1, ih2]) }

/-- `free_semigroup` is traversable. -/
@[to_additive "`free_add_semigroup` is traversable."]
protected def traverse {m : Type u → Type u} [applicative m]
  {α β : Type u} (F : α → m β) (x : free_semigroup α) : m (free_semigroup β) :=
rec_on_pure x (λ x, pure <$> F x) (λ x y ihx ihy, (*) <$> ihx <*> ihy)

@[to_additive]
instance : traversable free_semigroup := ⟨@free_semigroup.traverse⟩

variables {m : Type u → Type u} [applicative m] (F : α → m β)

@[simp, to_additive]
lemma traverse_pure (x) :traverse F (pure x : free_semigroup α) = pure <$> F x := rfl
@[simp, to_additive]
lemma traverse_pure' : traverse F ∘ pure = λ x, (pure <$> F x : m (free_semigroup β)) := rfl

section
variables [is_lawful_applicative m]
@[simp, to_additive] lemma traverse_mul (x y : free_semigroup α) :
  traverse F (x * y) = (*) <$> traverse F x <*> traverse F y :=
let ⟨x, L1⟩ := x, ⟨y, L2⟩ := y in
list.rec_on L1 (λ x, rfl) (λ hd tl ih x,
  show (*) <$> pure <$> F x <*> traverse F ((hd, tl) * (y, L2) : free_semigroup α) =
  (*) <$> ((*) <$> pure <$> F x <*> traverse F (hd, tl)) <*> traverse F (y, L2),
  by rw ih; simp only [(∘), (mul_assoc _ _ _).symm] with functor_norm) x

@[simp, to_additive] lemma traverse_mul' :
  function.comp (traverse F) ∘ @has_mul.mul (free_semigroup α) _ =
    λ x y, (*) <$> traverse F x <*> traverse F y :=
funext $ λ x, funext $ λ y, traverse_mul F x y
end

@[simp, to_additive] lemma traverse_eq (x) : free_semigroup.traverse F x = traverse F x := rfl

@[simp, to_additive] lemma mul_map_seq (x y : free_semigroup α) :
  ((*) <$> x <*> y : id (free_semigroup α)) = (x * y : free_semigroup α) := rfl

@[to_additive]
instance : is_lawful_traversable free_semigroup.{u} :=
{ id_traverse := λ α x, free_semigroup.rec_on x (λ x, rfl)
    (λ x y ih1 ih2, by rw [traverse_mul, ih1, ih2, mul_map_seq]),
  comp_traverse := λ F G hf1 hg1 hf2 hg2 α β γ f g x, rec_on_pure x
    (λ x, by resetI; simp only [traverse_pure, traverse_pure'] with functor_norm)
    (λ x y ih1 ih2, by resetI; rw [traverse_mul, ih1, ih2, traverse_mul];
      simp only [traverse_mul'] with functor_norm),
  naturality := λ F G hf1 hg1 hf2 hg2 η α β f x, rec_on_pure x
    (λ x, by simp only [traverse_pure] with functor_norm)
    (λ x y ih1 ih2, by resetI; simp only [traverse_mul] with functor_norm; rw [ih1, ih2]),
  traverse_eq_map_id := λ α β f x, free_semigroup.rec_on x (λ _, rfl)
    (λ x y ih1 ih2, by rw [traverse_mul, ih1, ih2, map_mul', mul_map_seq]; refl),
  .. free_semigroup.is_lawful_monad }

end category

@[to_additive]
instance [decidable_eq α] : decidable_eq (free_semigroup α) := prod.decidable_eq

end free_semigroup

/-- Isomorphism between `magma.free_semigroup (free_magma α)` and `free_semigroup α`. -/
@[to_additive "Isomorphism between
`add_magma.free_add_semigroup (free_add_magma α)` and `free_add_semigroup α`."]
def free_semigroup_free_magma (α : Type u) :
  magma.free_semigroup (free_magma α) ≃ free_semigroup α :=
{ to_fun    :=
    magma.free_semigroup.lift (free_magma.lift free_semigroup.of) (free_magma.lift _).map_mul,
  inv_fun   := free_semigroup.lift (magma.free_semigroup.of ∘ free_magma.of),
  left_inv  := λ x, magma.free_semigroup.induction_on x $ λ p, by rw magma.free_semigroup.lift_of;
    exact free_magma.rec_on_mul p
      (λ x, by rw [free_magma.lift_of, free_semigroup.lift_of])
      (λ x y ihx ihy, by rw [mul_hom.map_mul, free_semigroup.lift_mul, ihx, ihy,
        magma.free_semigroup.of_mul]),
  right_inv := λ x, free_semigroup.rec_on x
    (λ x, by rw [free_semigroup.lift_of, magma.free_semigroup.lift_of, free_magma.lift_of])
    (λ x y ihx ihy, by rw [free_semigroup.lift_mul, magma.free_semigroup.lift_mul, ihx, ihy]) }

@[simp, to_additive] lemma free_semigroup_free_magma_mul {α : Type u} (x y) :
  free_semigroup_free_magma α (x * y) = free_semigroup_free_magma α x *
    free_semigroup_free_magma α y :=
magma.free_semigroup.lift_mul _ _ _


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

import field_theory.minpoly.field
import field_theory.subfield
import field_theory.tower

/-!
# Intermediate fields

Let `L / K` be a field extension, given as an instance `algebra K L`.
This file defines the type of fields in between `K` and `L`, `intermediate_field K L`.
An `intermediate_field K L` is a subfield of `L` which contains (the image of) `K`,
i.e. it is a `subfield L` and a `subalgebra K L`.

## Main definitions

* `intermediate_field K L` : the type of intermediate fields between `K` and `L`.
* `subalgebra.to_intermediate_field`: turns a subalgebra closed under `⁻¹`
  into an intermediate field
* `subfield.to_intermediate_field`: turns a subfield containing the image of `K`
  into an intermediate field
* `intermediate_field.map`: map an intermediate field along an `alg_hom`
* `intermediate_field.restrict_scalars`: restrict the scalars of an intermediate field to a smaller
  field in a tower of fields.

## Implementation notes

Intermediate fields are defined with a structure extending `subfield` and `subalgebra`.
A `subalgebra` is closed under all operations except `⁻¹`,

## Tags
intermediate field, field extension
-/

open finite_dimensional polynomial
open_locale big_operators polynomial

variables (K L L' : Type*) [field K] [field L] [field L'] [algebra K L] [algebra K L']

/-- `S : intermediate_field K L` is a subset of `L` such that there is a field
tower `L / S / K`. -/
structure intermediate_field extends subalgebra K L :=
(neg_mem' : ∀ x ∈ carrier, -x ∈ carrier)
(inv_mem' : ∀ x ∈ carrier, x⁻¹ ∈ carrier)

/-- Reinterpret an `intermediate_field` as a `subalgebra`. -/
add_decl_doc intermediate_field.to_subalgebra

variables {K L L'} (S : intermediate_field K L)

namespace intermediate_field

/-- Reinterpret an `intermediate_field` as a `subfield`. -/
def to_subfield : subfield L := { ..S.to_subalgebra, ..S }

instance : set_like (intermediate_field K L) L :=
⟨λ S, S.to_subalgebra.carrier, by { rintros ⟨⟨⟩⟩ ⟨⟨⟩⟩ ⟨h⟩, congr, }⟩

instance : subfield_class (intermediate_field K L) L :=
{ add_mem := λ s _ _, s.add_mem',
  zero_mem := λ s, s.zero_mem',
  neg_mem := neg_mem',
  mul_mem := λ s _ _, s.mul_mem',
  one_mem := λ s, s.one_mem',
  inv_mem := inv_mem' }

@[simp]
lemma mem_carrier {s : intermediate_field K L} {x : L} : x ∈ s.carrier ↔ x ∈ s := iff.rfl

/-- Two intermediate fields are equal if they have the same elements. -/
@[ext] theorem ext {S T : intermediate_field K L} (h : ∀ x, x ∈ S ↔ x ∈ T) : S = T :=
set_like.ext h

@[simp] lemma coe_to_subalgebra : (S.to_subalgebra : set L) = S := rfl

@[simp] lemma coe_to_subfield : (S.to_subfield : set L) = S := rfl

@[simp] lemma mem_mk (s : set L) (hK : ∀ x, algebra_map K L x ∈ s)
  (ho hm hz ha hn hi) (x : L) :
  x ∈ intermediate_field.mk (subalgebra.mk s ho hm hz ha hK) hn hi ↔ x ∈ s := iff.rfl

@[simp] lemma mem_to_subalgebra (s : intermediate_field K L) (x : L) :
  x ∈ s.to_subalgebra ↔ x ∈ s := iff.rfl

@[simp] lemma mem_to_subfield (s : intermediate_field K L) (x : L) :
  x ∈ s.to_subfield ↔ x ∈ s := iff.rfl

/-- Copy of an intermediate field with a new `carrier` equal to the old one. Useful to fix
definitional equalities. -/
protected def copy (S : intermediate_field K L) (s : set L) (hs : s = ↑S) :
  intermediate_field K L :=
{ to_subalgebra := S.to_subalgebra.copy s (hs : s = (S.to_subalgebra).carrier),
  neg_mem' :=
    have hs' : (S.to_subalgebra.copy s hs).carrier = (S.to_subalgebra).carrier := hs,
    hs'.symm ▸ S.neg_mem',
  inv_mem' :=
    have hs' : (S.to_subalgebra.copy s hs).carrier = (S.to_subalgebra).carrier := hs,
    hs'.symm ▸ S.inv_mem' }

@[simp] lemma coe_copy (S : intermediate_field K L) (s : set L) (hs : s = ↑S) :
  (S.copy s hs : set L) = s := rfl

lemma copy_eq (S : intermediate_field K L) (s : set L) (hs : s = ↑S) : S.copy s hs = S :=
set_like.coe_injective hs

section inherited_lemmas

/-! ### Lemmas inherited from more general structures

The declarations in this section derive from the fact that an `intermediate_field` is also a
subalgebra or subfield. Their use should be replaceable with the corresponding lemma from a
subobject class.
-/

/-- An intermediate field contains the image of the smaller field. -/
theorem algebra_map_mem (x : K) : algebra_map K L x ∈ S :=
S.algebra_map_mem' x

/-- An intermediate field is closed under scalar multiplication. -/

/-- An intermediate field contains the ring's 1. -/
protected theorem one_mem : (1 : L) ∈ S := one_mem S
/-- An intermediate field contains the ring's 0. -/
protected theorem zero_mem : (0 : L) ∈ S := zero_mem S
/-- An intermediate field is closed under multiplication. -/
protected theorem mul_mem {x y : L} : x ∈ S → y ∈ S → x * y ∈ S := mul_mem
/-- An intermediate field is closed under addition. -/
protected theorem add_mem {x y : L} : x ∈ S → y ∈ S → x + y ∈ S := add_mem
/-- An intermediate field is closed under subtraction -/
protected theorem sub_mem {x y : L} : x ∈ S → y ∈ S → x - y ∈ S := sub_mem
/-- An intermediate field is closed under negation. -/
protected theorem neg_mem {x : L} : x ∈ S → -x ∈ S := neg_mem
/-- An intermediate field is closed under inverses. -/
protected theorem inv_mem {x : L} : x ∈ S → x⁻¹ ∈ S := inv_mem
/-- An intermediate field is closed under division. -/
protected theorem div_mem {x y : L} : x ∈ S → y ∈ S → x / y ∈ S := div_mem

/-- Product of a list of elements in an intermediate_field is in the intermediate_field. -/
protected lemma list_prod_mem {l : list L} : (∀ x ∈ l, x ∈ S) → l.prod ∈ S := list_prod_mem
/-- Sum of a list of elements in an intermediate field is in the intermediate_field. -/
protected lemma list_sum_mem {l : list L} : (∀ x ∈ l, x ∈ S) → l.sum ∈ S := list_sum_mem
/-- Product of a multiset of elements in an intermediate field is in the intermediate_field. -/
protected lemma multiset_prod_mem (m : multiset L) : (∀ a ∈ m, a ∈ S) → m.prod ∈ S :=
multiset_prod_mem m
/-- Sum of a multiset of elements in a `intermediate_field` is in the `intermediate_field`. -/
protected lemma multiset_sum_mem (m : multiset L) : (∀ a ∈ m, a ∈ S) → m.sum ∈ S :=
multiset_sum_mem m

/-- Product of elements of an intermediate field indexed by a `finset` is in the intermediate_field.
-/
protected lemma prod_mem {ι : Type*} {t : finset ι} {f : ι → L} (h : ∀ c ∈ t, f c ∈ S) :
  ∏ i in t, f i ∈ S := prod_mem h
/-- Sum of elements in a `intermediate_field` indexed by a `finset` is in the `intermediate_field`.
-/
protected lemma sum_mem {ι : Type*} {t : finset ι} {f : ι → L} (h : ∀ c ∈ t, f c ∈ S) :
  ∑ i in t, f i ∈ S := sum_mem h
protected lemma pow_mem {x : L} (hx : x ∈ S) (n : ℤ) : x^n ∈ S := zpow_mem hx n
protected lemma zsmul_mem {x : L} (hx : x ∈ S) (n : ℤ) : n • x ∈ S := zsmul_mem hx n
protected lemma coe_int_mem (n : ℤ) : (n : L) ∈ S := coe_int_mem S n

protected lemma coe_add (x y : S) : (↑(x + y) : L) = ↑x + ↑y := rfl
protected lemma coe_neg (x : S) : (↑(-x) : L) = -↑x := rfl
protected lemma coe_mul (x y : S) : (↑(x * y) : L) = ↑x * ↑y := rfl
protected lemma coe_inv (x : S) : (↑(x⁻¹) : L) = (↑x)⁻¹ := rfl
protected lemma coe_zero : ((0 : S) : L) = 0 := rfl
protected lemma coe_one : ((1 : S) : L) = 1 := rfl
protected lemma coe_pow (x : S) (n : ℕ) : (↑(x ^ n) : L) = ↑x ^ n := submonoid_class.coe_pow x n

end inherited_lemmas

lemma coe_nat_mem (n : ℕ) : (n : L) ∈ S :=
by simpa using coe_int_mem S n

end intermediate_field

/-- Turn a subalgebra closed under inverses into an intermediate field -/
def subalgebra.to_intermediate_field (S : subalgebra K L) (inv_mem : ∀ x ∈ S, x⁻¹ ∈ S) :
  intermediate_field K L :=
{ neg_mem' := λ x, S.neg_mem,
  inv_mem' := inv_mem,
  .. S }

@[simp] lemma to_subalgebra_to_intermediate_field
  (S : subalgebra K L) (inv_mem : ∀ x ∈ S, x⁻¹ ∈ S) :
  (S.to_intermediate_field inv_mem).to_subalgebra = S :=
by { ext, refl }

@[simp] lemma to_intermediate_field_to_subalgebra (S : intermediate_field K L) :
  S.to_subalgebra.to_intermediate_field (λ x, S.inv_mem) = S :=
by { ext, refl }

/-- Turn a subalgebra satisfying `is_field` into an intermediate_field -/
def subalgebra.to_intermediate_field' (S : subalgebra K L) (hS : is_field S) :
  intermediate_field K L :=
S.to_intermediate_field $ λ x hx, begin
  by_cases hx0 : x = 0,
  { rw [hx0, inv_zero],
    exact S.zero_mem },
  letI hS' := hS.to_field,
  obtain ⟨y, hy⟩ := hS.mul_inv_cancel (show (⟨x, hx⟩ : S) ≠ 0, from subtype.ne_of_val_ne hx0),
  rw [subtype.ext_iff, S.coe_mul, S.coe_one, subtype.coe_mk, mul_eq_one_iff_inv_eq₀ hx0] at hy,
  exact hy.symm ▸ y.2,
end

@[simp] lemma to_subalgebra_to_intermediate_field' (S : subalgebra K L) (hS : is_field S) :
  (S.to_intermediate_field' hS).to_subalgebra = S :=
by { ext, refl }

@[simp] lemma to_intermediate_field'_to_subalgebra (S : intermediate_field K L) :
  S.to_subalgebra.to_intermediate_field' (field.to_is_field S) = S :=
by { ext, refl }

/-- Turn a subfield of `L` containing the image of `K` into an intermediate field -/
def subfield.to_intermediate_field (S : subfield L)
  (algebra_map_mem : ∀ x, algebra_map K L x ∈ S) :
  intermediate_field K L :=
{ algebra_map_mem' := algebra_map_mem,
  .. S }

namespace intermediate_field

/-- An intermediate field inherits a field structure -/
instance to_field : field S :=
S.to_subfield.to_field

@[simp, norm_cast]
lemma coe_sum {ι : Type*} [fintype ι] (f : ι → S) : (↑∑ i, f i : L) = ∑ i, (f i : L) :=
begin
  classical,
  induction finset.univ using finset.induction_on with i s hi H,
  { simp },
  { rw [finset.sum_insert hi, add_mem_class.coe_add, H, finset.sum_insert hi] }
end

@[simp, norm_cast]
lemma coe_prod {ι : Type*} [fintype ι] (f : ι → S) : (↑∏ i, f i : L) = ∏ i, (f i : L) :=
begin
  classical,
  induction finset.univ using finset.induction_on with i s hi H,
  { simp },
  { rw [finset.prod_insert hi, mul_mem_class.coe_mul, H, finset.prod_insert hi] }
end

/-! `intermediate_field`s inherit structure from their `subalgebra` coercions. -/

instance module' {R} [semiring R] [has_smul R K] [module R L] [is_scalar_tower R K L] :
  module R S :=
S.to_subalgebra.module'
instance module : module K S := S.to_subalgebra.module

instance is_scalar_tower {R} [semiring R] [has_smul R K] [module R L]
  [is_scalar_tower R K L] :
  is_scalar_tower R K S :=
S.to_subalgebra.is_scalar_tower

@[simp] lemma coe_smul {R} [semiring R] [has_smul R K] [module R L] [is_scalar_tower R K L]
  (r : R) (x : S) :
  ↑(r • x) = (r • x : L) := rfl

instance algebra' {K'} [comm_semiring K'] [has_smul K' K] [algebra K' L]
  [is_scalar_tower K' K L] :
  algebra K' S :=
S.to_subalgebra.algebra'
instance algebra : algebra K S := S.to_subalgebra.algebra

instance to_algebra {R : Type*} [semiring R] [algebra L R] : algebra S R :=
S.to_subalgebra.to_algebra

instance is_scalar_tower_bot {R : Type*} [semiring R] [algebra L R] :
  is_scalar_tower S L R :=
is_scalar_tower.subalgebra _ _ _ S.to_subalgebra

instance is_scalar_tower_mid {R : Type*} [semiring R] [algebra L R] [algebra K R]
  [is_scalar_tower K L R] : is_scalar_tower K S R :=
is_scalar_tower.subalgebra' _ _ _ S.to_subalgebra

/-- Specialize `is_scalar_tower_mid` to the common case where the top field is `L` -/
instance is_scalar_tower_mid' : is_scalar_tower K S L :=
S.is_scalar_tower_mid

/-- If `f : L →+* L'` fixes `K`, `S.map f` is the intermediate field between `L'` and `K`
such that `x ∈ S ↔ f x ∈ S.map f`. -/
def map (f : L →ₐ[K] L') (S : intermediate_field K L) : intermediate_field K L' :=
{ inv_mem' := by { rintros _ ⟨x, hx, rfl⟩, exact ⟨x⁻¹, S.inv_mem hx, map_inv₀ f x⟩ },
  neg_mem' := λ x hx, (S.to_subalgebra.map f).neg_mem hx,
  .. S.to_subalgebra.map f}

@[simp] lemma coe_map (f : L →ₐ[K] L') : (S.map f : set L') = f '' S := rfl

lemma map_map {K L₁ L₂ L₃ : Type*} [field K] [field L₁] [algebra K L₁]
  [field L₂] [algebra K L₂] [field L₃] [algebra K L₃]
  (E : intermediate_field K L₁) (f : L₁ →ₐ[K] L₂) (g : L₂ →ₐ[K] L₃) :
  (E.map f).map g = E.map (g.comp f) :=
set_like.coe_injective $ set.image_image _ _ _

/-- Given an equivalence `e : L ≃ₐ[K] L'` of `K`-field extensions and an intermediate
field `E` of `L/K`, `intermediate_field_equiv_map e E` is the induced equivalence
between `E` and `E.map e` -/
def intermediate_field_map (e : L ≃ₐ[K] L') (E : intermediate_field K L) :
  E ≃ₐ[K] (E.map e.to_alg_hom) :=
e.subalgebra_map E.to_subalgebra

/- We manually add these two simp lemmas because `@[simps]` before `intermediate_field_map`
  led to a timeout. -/
@[simp] lemma intermediate_field_map_apply_coe (e : L ≃ₐ[K] L') (E : intermediate_field K L)
  (a : E) : ↑(intermediate_field_map e E a) = e a := rfl

@[simp] lemma intermediate_field_map_symm_apply_coe (e : L ≃ₐ[K] L') (E : intermediate_field K L)
  (a : E.map e.to_alg_hom) : ↑((intermediate_field_map e E).symm a) = e.symm a := rfl

end intermediate_field

namespace alg_hom

variables (f : L →ₐ[K] L')

/-- The range of an algebra homomorphism, as an intermediate field. -/
@[simps to_subalgebra]
def field_range : intermediate_field K L' :=
{ .. f.range,
  .. (f : L →+* L').field_range }

@[simp] lemma coe_field_range : ↑f.field_range = set.range f := rfl

@[simp] lemma field_range_to_subfield :
  f.field_range.to_subfield = (f : L →+* L').field_range := rfl

variables {f}

@[simp] lemma mem_field_range {y : L'} : y ∈ f.field_range ↔ ∃ x, f x = y := iff.rfl

end alg_hom

namespace intermediate_field

/-- The embedding from an intermediate field of `L / K` to `L`. -/
def val : S →ₐ[K] L :=
S.to_subalgebra.val

@[simp] theorem coe_val : ⇑S.val = coe := rfl

@[simp] lemma val_mk {x : L} (hx : x ∈ S) : S.val ⟨x, hx⟩ = x := rfl

lemma range_val : S.val.range = S.to_subalgebra :=
S.to_subalgebra.range_val

lemma aeval_coe {R : Type*} [comm_ring R] [algebra R K] [algebra R L]
  [is_scalar_tower R K L] (x : S) (P : R[X]) : aeval (x : L) P = aeval x P :=
begin
  refine polynomial.induction_on' P (λ f g hf hg, _) (λ n r, _),
  { rw [aeval_add, aeval_add, add_mem_class.coe_add, hf, hg] },
  { simp only [mul_mem_class.coe_mul, aeval_monomial, submonoid_class.coe_pow,
               mul_eq_mul_right_iff],
    left, refl }
end

lemma coe_is_integral_iff {R : Type*} [comm_ring R] [algebra R K] [algebra R L]
  [is_scalar_tower R K L] {x : S} : is_integral R (x : L) ↔ is_integral R x :=
begin
  refine ⟨λ h, _, λ h, _⟩,
  { obtain ⟨P, hPmo, hProot⟩ := h,
    refine ⟨P, hPmo, (injective_iff_map_eq_zero _).1 (algebra_map ↥S L).injective _ _⟩,
    letI : is_scalar_tower R S L := is_scalar_tower.of_algebra_map_eq (congr_fun rfl),
    rwa [eval₂_eq_eval_map, ← eval₂_at_apply, eval₂_eq_eval_map, polynomial.map_map,
      ← is_scalar_tower.algebra_map_eq, ← eval₂_eq_eval_map] },
  { obtain ⟨P, hPmo, hProot⟩ := h,
    refine ⟨P, hPmo, _⟩,
    rw [← aeval_def, aeval_coe, aeval_def, hProot, zero_mem_class.coe_zero] },
end

/-- The map `E → F` when `E` is an intermediate field contained in the intermediate field `F`.

This is the intermediate field version of `subalgebra.inclusion`. -/
def inclusion {E F : intermediate_field K L} (hEF : E ≤ F) : E →ₐ[K] F :=
subalgebra.inclusion hEF

lemma inclusion_injective {E F : intermediate_field K L} (hEF : E ≤ F) :
  function.injective (inclusion hEF) :=
subalgebra.inclusion_injective hEF

@[simp] lemma inclusion_self {E : intermediate_field K L}:
  inclusion (le_refl E) = alg_hom.id K E :=
subalgebra.inclusion_self

@[simp] lemma inclusion_inclusion {E F G : intermediate_field K L} (hEF : E ≤ F) (hFG : F ≤ G)
  (x : E) : inclusion hFG (inclusion hEF x) = inclusion (le_trans hEF hFG) x :=
subalgebra.inclusion_inclusion hEF hFG x

@[simp] lemma coe_inclusion {E F : intermediate_field K L} (hEF : E ≤ F) (e : E) :
  (inclusion hEF e : L) = e := rfl

variables {S}

lemma to_subalgebra_injective {S S' : intermediate_field K L}
  (h : S.to_subalgebra = S'.to_subalgebra) : S = S' :=
by { ext, rw [← mem_to_subalgebra, ← mem_to_subalgebra, h] }

variables (S)

lemma set_range_subset : set.range (algebra_map K L) ⊆ S :=
S.to_subalgebra.range_subset

lemma field_range_le : (algebra_map K L).field_range ≤ S.to_subfield :=
λ x hx, S.to_subalgebra.range_subset (by rwa [set.mem_range, ← ring_hom.mem_field_range])

@[simp] lemma to_subalgebra_le_to_subalgebra {S S' : intermediate_field K L} :
  S.to_subalgebra ≤ S'.to_subalgebra ↔ S ≤ S' := iff.rfl

@[simp] lemma to_subalgebra_lt_to_subalgebra {S S' : intermediate_field K L} :
  S.to_subalgebra < S'.to_subalgebra ↔ S < S' := iff.rfl

variables {S}

section tower

/-- Lift an intermediate_field of an intermediate_field -/
def lift {F : intermediate_field K L} (E : intermediate_field K F) : intermediate_field K L :=
E.map (val F)

instance has_lift {F : intermediate_field K L} :
  has_lift_t (intermediate_field K F) (intermediate_field K L) := ⟨lift⟩

section restrict_scalars
variables (K) [algebra L' L] [is_scalar_tower K L' L]

/-- Given a tower `L / ↥E / L' / K` of field extensions, where `E` is an `L'`-intermediate field of
`L`, reinterpret `E` as a `K`-intermediate field of `L`. -/
def restrict_scalars (E : intermediate_field L' L) :
  intermediate_field K L :=
{ carrier := E.carrier,
  ..E.to_subfield,
  ..E.to_subalgebra.restrict_scalars K }

@[simp] lemma coe_restrict_scalars {E : intermediate_field L' L} :
  (restrict_scalars K E : set L) = (E : set L) := rfl

@[simp] lemma restrict_scalars_to_subalgebra {E : intermediate_field L' L} :
  (E.restrict_scalars K).to_subalgebra = E.to_subalgebra.restrict_scalars K :=
set_like.coe_injective rfl

@[simp] lemma restrict_scalars_to_subfield {E : intermediate_field L' L} :
  (E.restrict_scalars K).to_subfield = E.to_subfield :=
set_like.coe_injective rfl

@[simp] lemma mem_restrict_scalars {E : intermediate_field L' L} {x : L} :
  x ∈ restrict_scalars K E ↔ x ∈ E := iff.rfl

lemma restrict_scalars_injective :
  function.injective (restrict_scalars K : intermediate_field L' L → intermediate_field K L) :=
λ U V H, ext $ λ x, by rw [← mem_restrict_scalars K, H, mem_restrict_scalars]

end restrict_scalars

/-- This was formerly an instance called `lift2_alg`, but an instance above already provides it. -/
example {F : intermediate_field K L} {E : intermediate_field F L} : algebra K E :=
by apply_instance

end tower

section finite_dimensional

variables (F E : intermediate_field K L)

instance finite_dimensional_left [finite_dimensional K L] : finite_dimensional K F :=
left K F L

instance finite_dimensional_right [finite_dimensional K L] : finite_dimensional F L :=
right K F L

@[simp] lemma dim_eq_dim_subalgebra :
  module.rank K F.to_subalgebra = module.rank K F := rfl

@[simp] lemma finrank_eq_finrank_subalgebra :
  finrank K F.to_subalgebra = finrank K F := rfl

variables {F} {E}

@[simp] lemma to_subalgebra_eq_iff : F.to_subalgebra = E.to_subalgebra ↔ F = E :=
by { rw [set_like.ext_iff, set_like.ext'_iff, set.ext_iff], refl }

lemma eq_of_le_of_finrank_le [finite_dimensional K L] (h_le : F ≤ E)
  (h_finrank : finrank K E ≤ finrank K F) : F = E :=
to_subalgebra_injective $ subalgebra.to_submodule.injective $ eq_of_le_of_finrank_le h_le h_finrank

lemma eq_of_le_of_finrank_eq [finite_dimensional K L] (h_le : F ≤ E)
  (h_finrank : finrank K F = finrank K E) : F = E :=
eq_of_le_of_finrank_le h_le h_finrank.ge

lemma eq_of_le_of_finrank_le' [finite_dimensional K L] (h_le : F ≤ E)
  (h_finrank : finrank F L ≤ finrank E L) : F = E :=
begin
  apply eq_of_le_of_finrank_le h_le,
  have h1 := finrank_mul_finrank K F L,
  have h2 := finrank_mul_finrank K E L,
  have h3 : 0 < finrank E L := finrank_pos,
  nlinarith,
end

lemma eq_of_le_of_finrank_eq' [finite_dimensional K L] (h_le : F ≤ E)
  (h_finrank : finrank F L = finrank E L) : F = E :=
eq_of_le_of_finrank_le' h_le h_finrank.le

end finite_dimensional

lemma is_algebraic_iff {x : S} : is_algebraic K x ↔ is_algebraic K (x : L) :=
(is_algebraic_algebra_map_iff (algebra_map S L).injective).symm

lemma is_integral_iff {x : S} : is_integral K x ↔ is_integral K (x : L) :=
by rw [←is_algebraic_iff_is_integral, is_algebraic_iff, is_algebraic_iff_is_integral]

lemma minpoly_eq (x : S) : minpoly K x = minpoly K (x : L) :=
begin
  by_cases hx : is_integral K x,
  { exact minpoly.eq_of_algebra_map_eq (algebra_map S L).injective hx rfl },
  { exact (minpoly.eq_zero hx).trans (minpoly.eq_zero (mt is_integral_iff.mpr hx)).symm },
end

end intermediate_field

/-- If `L/K` is algebraic, the `K`-subalgebras of `L` are all fields.  -/
def subalgebra_equiv_intermediate_field (alg : algebra.is_algebraic K L) :
  subalgebra K L ≃o intermediate_field K L :=
{ to_fun := λ S, S.to_intermediate_field (λ x hx, S.inv_mem_of_algebraic (alg (⟨x, hx⟩ : S))),
  inv_fun := λ S, S.to_subalgebra,
  left_inv := λ S, to_subalgebra_to_intermediate_field _ _,
  right_inv := to_intermediate_field_to_subalgebra,
  map_rel_iff' := λ S S', iff.rfl }

@[simp] lemma mem_subalgebra_equiv_intermediate_field (alg : algebra.is_algebraic K L)
  {S : subalgebra K L} {x : L} :
  x ∈ subalgebra_equiv_intermediate_field alg S ↔ x ∈ S :=
iff.rfl

@[simp] lemma mem_subalgebra_equiv_intermediate_field_symm (alg : algebra.is_algebraic K L)
  {S : intermediate_field K L} {x : L} :
  x ∈ (subalgebra_equiv_intermediate_field alg).symm S ↔ x ∈ S :=
iff.rfl


import representation
import ring_theory.algebra
import algebra.module

variables (G : Type*) [group G] (𝕜 : Type*) [field 𝕜]
variables (V : Type*) [add_comm_group V] [has_scalar G V] [vector_space 𝕜 V]
variables (W : Type*) [add_comm_group W] [has_scalar G W] [vector_space 𝕜 W]

variables [rep G 𝕜 V] [rep G 𝕜 W]

structure hom :=
(to_fun : V → W)
(equivariant' : ∀ g : G, ∀ v : V, to_fun (g • v) = g • to_fun v)
(scalar' : ∀ k : 𝕜, ∀ v : V, to_fun (k • v) = k • to_fun v)
(add' : ∀ v w : V, to_fun (v + w) = to_fun v + to_fun w)

instance : has_coe_to_fun (hom G 𝕜 V W) := ⟨_, λ m, m.to_fun⟩

@[simp] lemma to_fun_eq_coe (φ : hom G 𝕜 V W) : φ.to_fun = φ := rfl

lemma equivariant (φ : hom G 𝕜 V W) (g : G) (v : V) : φ (g • v) = g • φ v := φ.equivariant' g v

lemma scalar (φ : hom G 𝕜 V W) (k : 𝕜) (v : V) : φ (k • v) = k • φ v := φ.scalar' k v

lemma add (φ : hom G 𝕜 V W) (v w : V) : φ (v + w) = φ v + φ w := φ.add' v w

lemma hom_zero (φ : hom G 𝕜 V W) : φ 0 = 0 :=
begin
    have h := add G 𝕜 V W φ 0 0,
    rw add_zero at h,
    exact add_left_eq_self.1 h.symm,
end

@[ext] theorem fun_ext (φ ψ : hom G 𝕜 V W) (h : ∀ v, φ v = ψ v) : φ = ψ :=
by cases φ; cases ψ; congr'; exact funext h

theorem ext_iff (φ ψ : hom G 𝕜 V W) : φ = ψ ↔ ∀ v, φ v = ψ v :=
⟨by { rintro rfl v, refl } , fun_ext G 𝕜 V W φ ψ⟩

instance : add_comm_group (hom G 𝕜 V W) := {
    add := λ φ ψ, ⟨λ v, (φ v) + (ψ v),
    begin
        intros g v,
        rw group_module.distrib,
        rw equivariant,
        rw equivariant,
    end,
    begin
        intros k v,
        rw smul_add,
        rw scalar,
        rw scalar,
    end,
    begin
        intros v w,
        rw add,
        rw add,
        abel,
    end⟩,
    add_assoc :=
    begin
        intros φ ψ χ,
        rw ext_iff,
        intro v,
        change φ v + ψ v + χ v = φ v + (ψ v + χ v),
        rw add_assoc,
    end,
    zero := ⟨λ v, 0,
    begin
        intros g v,
        rw act_zero,
    end,
    begin
        intros k v,
        rw smul_zero,
    end,
    begin
        intros v w,
        rw zero_add,
    end⟩,
    zero_add :=
    begin
        intro φ,
        rw ext_iff,
        intro v,
        change 0 + φ v = φ v,
        rw zero_add,
    end,
    add_zero :=
    begin
        intro φ,
        rw ext_iff,
        intro v,
        change φ v + 0 = φ v,
        rw add_zero,
    end,
    neg := λ φ, ⟨λ v, - φ v,
    begin
        intros g v,
        rw equivariant,
        rw act_neg,
    end,
    begin
        intros k v,
        rw scalar,
        rw smul_neg,
    end,
    begin
        intros v w,
        rw add,
        rw neg_add,
    end⟩,
    add_left_neg :=
    begin
        intro φ,
        rw ext_iff,
        intro v,
        change -φ v + φ v = 0,
        rw add_left_neg,
    end,
    add_comm :=
    begin
        intros φ ψ,
        rw ext_iff,
        intro v,
        change φ v + ψ v = ψ v + φ v,
        rw add_comm,
    end
}

instance : module 𝕜 (hom G 𝕜 V W) := {
    smul := λ k, λ φ, ⟨λ v, k • φ v,
    begin
        intros g v,
        rw equivariant,
        rw rep.linear,
    end,
    begin
        intros k v,
        rw scalar,
        rw smul_comm,
    end,
    begin
        intros v w,
        rw add,
        rw smul_add,
    end⟩,
    one_smul :=
    begin
        intro φ,
        rw ext_iff,
        intro v,
        change (1 : 𝕜) • φ v = φ v,
        rw one_smul,
    end,
    mul_smul :=
    begin
        intros k l φ,
        rw ext_iff,
        intro v,
        change (k * l) • φ v = k • l • φ v,
        rw mul_smul,
    end,
    smul_add :=
    begin
        intros k φ ψ,
        rw ext_iff,
        intro v,
        change k • (φ v + ψ v) = k • φ v + k • ψ v,
        rw smul_add,
    end,
    smul_zero :=
    begin
        intro k,
        rw ext_iff,
        intro v,
        change k • (0 : W) = 0,
        rw smul_zero,
    end,
    add_smul :=
    begin
        intros k l φ,
        rw ext_iff,
        intro v,
        change (k + l) • φ v = k • φ v + l • φ v,
        rw add_smul,
    end,
    zero_smul :=
    begin
        intro φ,
        rw ext_iff,
        intro v,
        change (0 : 𝕜) • φ v = 0,
        rw zero_smul,
    end
}

instance : semiring (hom G 𝕜 V V) := {
    add := add_comm_group.add,
    add_assoc := add_comm_group.add_assoc,
    zero := add_comm_group.zero,
    zero_add := add_comm_group.zero_add,
    add_zero := add_comm_group.add_zero,
    add_comm := add_comm_group.add_comm,
    mul := λ φ ψ, ⟨λ v, φ (ψ v),
    begin
        intros g v,
        rw equivariant,
        rw equivariant,
    end,
    begin
        intros k v,
        rw scalar,
        rw scalar,
    end,
    begin
        intros v w,
        rw add,
        rw add,
    end⟩,
    mul_assoc :=
    begin
        intros φ ψ χ,
        rw ext_iff,
        intro v,
        refl,
    end,
    one := ⟨λ v, v,
    begin
        intros g v,
        refl,
    end,
    begin
        intros g k,
        refl,
    end,
    begin
        intros v w,
        refl,
    end⟩,
    one_mul :=
    begin
        intro φ,
        rw ext_iff,
        intro v,
        refl,
    end,
    mul_one :=
    begin
        intro φ,
        rw ext_iff,
        intro v,
        refl,
    end,
    left_distrib :=
    begin
        intros φ ψ χ,
        rw ext_iff,
        intro v,
        change φ (ψ v + χ v) = φ (ψ v) + φ (χ v),
        rw add,
    end,
    right_distrib :=
    begin
        intros φ ψ χ,
        rw ext_iff,
        intro v,
        refl,
    end,
    zero_mul :=
    begin
        intro φ,
        rw ext_iff,
        intro v,
        refl,
    end,
    mul_zero :=
    begin
        intro φ,
        rw ext_iff,
        intro v,
        change φ 0 = 0,
        rw hom_zero,
    end,
}

instance : algebra 𝕜 (hom G 𝕜 V V) := {
    to_fun := λ k, k • 1,
    map_one' :=
    begin
        rw one_smul,
    end,
    map_mul' :=
    begin
        intros k l,
        rw ext_iff,
        intro v,
        rw mul_smul,
        refl,
    end,
    map_zero' :=
    begin
        rw ext_iff,
        intro v,
        rw zero_smul,
    end,
    map_add' :=
    begin
        intros k l,
        rw ext_iff,
        intro v,
        rw add_smul,
    end,
    commutes' :=
    begin
        intros k φ,
        rw ext_iff,
        intro v,
        change k • φ v = φ (k • v),
        rw scalar,
    end,
    smul_def' :=
    begin
        intros k φ,
        rw ext_iff,
        intro v,
        refl,
    end
}


/-
Copyright (c) 2018 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import category_theory.natural_isomorphism
import logic.equiv.basic

/-!
# Full and faithful functors

We define typeclasses `full` and `faithful`, decorating functors.

Use `F.map_injective` to retrieve the fact that `F.map` is injective when `[faithful F]`,
and `F.preimage` to obtain preimages of morphisms when `[full F]`.

We prove some basic "cancellation" lemmas for full and/or faithful functors.

See `category_theory.equivalence` for the fact that a functor is an equivalence if and only if
it is fully faithful and essentially surjective.

-/

-- declare the `v`'s first; see `category_theory.category` for an explanation
universes v₁ v₂ v₃ u₁ u₂ u₃

namespace category_theory

variables {C : Type u₁} [category.{v₁} C] {D : Type u₂} [category.{v₂} D]

/--
A functor `F : C ⥤ D` is full if for each `X Y : C`, `F.map` is surjective.
In fact, we use a constructive definition, so the `full F` typeclass contains data,
specifying a particular preimage of each `f : F.obj X ⟶ F.obj Y`.

See <https://stacks.math.columbia.edu/tag/001C>.
-/
class full (F : C ⥤ D) :=
(preimage : ∀ {X Y : C} (f : (F.obj X) ⟶ (F.obj Y)), X ⟶ Y)
(witness' : ∀ {X Y : C} (f : (F.obj X) ⟶ (F.obj Y)), F.map (preimage f) = f . obviously)

restate_axiom full.witness'
attribute [simp] full.witness

/--
A functor `F : C ⥤ D` is faithful if for each `X Y : C`, `F.map` is injective.

See <https://stacks.math.columbia.edu/tag/001C>.
-/
class faithful (F : C ⥤ D) : Prop :=
(map_injective' [] : ∀ {X Y : C}, function.injective (@functor.map _ _ _ _ F X Y) . obviously)

restate_axiom faithful.map_injective'

namespace functor
variables {X Y : C}

lemma map_injective (F : C ⥤ D) [faithful F] :
  function.injective $ @functor.map _ _ _ _ F X Y :=
faithful.map_injective F

lemma map_iso_injective (F : C ⥤ D) [faithful F] :
  function.injective $ @functor.map_iso _ _ _ _ F X Y :=
λ i j h, iso.ext (map_injective F (congr_arg iso.hom h : _))

/-- The specified preimage of a morphism under a full functor. -/
def preimage (F : C ⥤ D) [full F] (f : F.obj X ⟶ F.obj Y) : X ⟶ Y :=
full.preimage.{v₁ v₂} f
@[simp] lemma image_preimage (F : C ⥤ D) [full F] {X Y : C} (f : F.obj X ⟶ F.obj Y) :
  F.map (preimage F f) = f :=
by unfold preimage; obviously

end functor

section
variables {F : C ⥤ D} [full F] [faithful F] {X Y Z : C}

@[simp] lemma preimage_id : F.preimage (𝟙 (F.obj X)) = 𝟙 X :=
F.map_injective (by simp)
@[simp] lemma preimage_comp (f : F.obj X ⟶ F.obj Y) (g : F.obj Y ⟶ F.obj Z) :
  F.preimage (f ≫ g) = F.preimage f ≫ F.preimage g :=
F.map_injective (by simp)
@[simp] lemma preimage_map (f : X ⟶ Y) :
  F.preimage (F.map f) = f :=
F.map_injective (by simp)

variables (F)

namespace functor

/-- If `F : C ⥤ D` is fully faithful, every isomorphism `F.obj X ≅ F.obj Y` has a preimage. -/
@[simps]
def preimage_iso (f : (F.obj X) ≅ (F.obj Y)) : X ≅ Y :=
{ hom := F.preimage f.hom,
  inv := F.preimage f.inv,
  hom_inv_id' := F.map_injective (by simp),
  inv_hom_id' := F.map_injective (by simp), }

@[simp] lemma preimage_iso_map_iso (f : X ≅ Y) :
  F.preimage_iso (F.map_iso f) = f :=
by { ext, simp, }

end functor

/--
If the image of a morphism under a fully faithful functor in an isomorphism,
then the original morphisms is also an isomorphism.
-/
lemma is_iso_of_fully_faithful (f : X ⟶ Y) [is_iso (F.map f)] : is_iso f :=
⟨⟨F.preimage (inv (F.map f)),
  ⟨F.map_injective (by simp), F.map_injective (by simp)⟩⟩⟩

/-- If `F` is fully faithful, we have an equivalence of hom-sets `X ⟶ Y` and `F X ⟶ F Y`. -/
@[simps]
def equiv_of_fully_faithful {X Y} : (X ⟶ Y) ≃ (F.obj X ⟶ F.obj Y) :=
{ to_fun := λ f, F.map f,
  inv_fun := λ f, F.preimage f,
  left_inv := λ f, by simp,
  right_inv := λ f, by simp }

/-- If `F` is fully faithful, we have an equivalence of iso-sets `X ≅ Y` and `F X ≅ F Y`. -/
@[simps]
def iso_equiv_of_fully_faithful {X Y} : (X ≅ Y) ≃ (F.obj X ≅ F.obj Y) :=
{ to_fun := λ f, F.map_iso f,
  inv_fun := λ f, F.preimage_iso f,
  left_inv := λ f, by simp,
  right_inv := λ f, by { ext, simp, } }

end

section
variables {E : Type*} [category E] {F G : C ⥤ D} (H : D ⥤ E) [full H] [faithful H]

/-- We can construct a natural transformation between functors by constructing a
natural transformation between those functors composed with a fully faithful functor. -/
@[simps]
def nat_trans_of_comp_fully_faithful (α : F ⋙ H ⟶ G ⋙ H) : F ⟶ G :=
{ app := λ X, (equiv_of_fully_faithful H).symm (α.app X),
  naturality' := λ X Y f, by { dsimp, apply H.map_injective, simpa using α.naturality f, } }

/-- We can construct a natural isomorphism between functors by constructing a natural isomorphism
between those functors composed with a fully faithful functor. -/
@[simps]
def nat_iso_of_comp_fully_faithful (i : F ⋙ H ≅ G ⋙ H) : F ≅ G :=
nat_iso.of_components
  (λ X, (iso_equiv_of_fully_faithful H).symm (i.app X))
  (λ X Y f, by { dsimp, apply H.map_injective, simpa using i.hom.naturality f, })

lemma nat_iso_of_comp_fully_faithful_hom (i : F ⋙ H ≅ G ⋙ H) :
  (nat_iso_of_comp_fully_faithful H i).hom = nat_trans_of_comp_fully_faithful H i.hom :=
by { ext, simp [nat_iso_of_comp_fully_faithful], }

lemma nat_iso_of_comp_fully_faithful_inv (i : F ⋙ H ≅ G ⋙ H) :
  (nat_iso_of_comp_fully_faithful H i).inv = nat_trans_of_comp_fully_faithful H i.inv :=
by { ext, simp [←preimage_comp], dsimp, simp, }

end

end category_theory

namespace category_theory

variables {C : Type u₁} [category.{v₁} C]

instance full.id : full (𝟭 C) :=
{ preimage := λ _ _ f, f }

instance faithful.id : faithful (𝟭 C) := by obviously

variables {D : Type u₂} [category.{v₂} D] {E : Type u₃} [category.{v₃} E]
variables (F F' : C ⥤ D) (G : D ⥤ E)

instance faithful.comp [faithful F] [faithful G] : faithful (F ⋙ G) :=
{ map_injective' := λ _ _ _ _ p, F.map_injective (G.map_injective p) }

lemma faithful.of_comp [faithful $ F ⋙ G] : faithful F :=
{ map_injective' := λ X Y, (F ⋙ G).map_injective.of_comp }

section
variables {F F'}

/-- If `F` is full, and naturally isomorphic to some `F'`, then `F'` is also full. -/
def full.of_iso [full F] (α : F ≅ F') : full F' :=
{ preimage := λ X Y f, F.preimage ((α.app X).hom ≫ f ≫ (α.app Y).inv),
  witness' := λ X Y f, by simp [←nat_iso.naturality_1 α], }

lemma faithful.of_iso [faithful F] (α : F ≅ F') : faithful F' :=
{ map_injective' := λ X Y f f' h, F.map_injective
  (by rw [←nat_iso.naturality_1 α.symm, h, nat_iso.naturality_1 α.symm]) }
end

variables {F G}

lemma faithful.of_comp_iso {H : C ⥤ E} [ℋ : faithful H] (h : F ⋙ G ≅ H) : faithful F :=
@faithful.of_comp _ _ _ _ _ _ F G (faithful.of_iso h.symm)

alias faithful.of_comp_iso ← category_theory.iso.faithful_of_comp

-- We could prove this from `faithful.of_comp_iso` using `eq_to_iso`,
-- but that would introduce a cyclic import.
lemma faithful.of_comp_eq {H : C ⥤ E} [ℋ : faithful H] (h : F ⋙ G = H) : faithful F :=
@faithful.of_comp _ _ _ _ _ _ F G (h.symm ▸ ℋ)

alias faithful.of_comp_eq ← eq.faithful_of_comp

variables (F G)

/-- “Divide” a functor by a faithful functor. -/
protected def faithful.div (F : C ⥤ E) (G : D ⥤ E) [faithful G]
  (obj : C → D) (h_obj : ∀ X, G.obj (obj X) = F.obj X)
  (map : Π {X Y}, (X ⟶ Y) → (obj X ⟶ obj Y))
  (h_map : ∀ {X Y} {f : X ⟶ Y}, G.map (map f) == F.map f) :
  C ⥤ D :=
{ obj := obj,
  map := @map,
  map_id' :=
  begin
    assume X,
    apply G.map_injective,
    apply eq_of_heq,
    transitivity F.map (𝟙 X), from h_map,
    rw [F.map_id, G.map_id, h_obj X]
  end,
  map_comp' :=
  begin
    assume X Y Z f g,
    apply G.map_injective,
    apply eq_of_heq,
    transitivity F.map (f ≫ g), from h_map,
    rw [F.map_comp, G.map_comp],
    congr' 1;
      try { exact (h_obj _).symm };
      exact h_map.symm
  end }

-- This follows immediately from `functor.hext` (`functor.hext h_obj @h_map`),
-- but importing `category_theory.eq_to_hom` causes an import loop:
-- category_theory.eq_to_hom → category_theory.opposites →
-- category_theory.equivalence → category_theory.fully_faithful
lemma faithful.div_comp (F : C ⥤ E) [faithful F] (G : D ⥤ E) [faithful G]
  (obj : C → D) (h_obj : ∀ X, G.obj (obj X) = F.obj X)
  (map : Π {X Y}, (X ⟶ Y) → (obj X ⟶ obj Y))
  (h_map : ∀ {X Y} {f : X ⟶ Y}, G.map (map f) == F.map f) :
  (faithful.div F G obj @h_obj @map @h_map) ⋙ G = F :=
begin
  casesI F with F_obj _ _ _, casesI G with G_obj _ _ _,
  unfold faithful.div functor.comp,
  unfold_projs at h_obj,
  have: F_obj = G_obj ∘ obj := (funext h_obj).symm,
  substI this,
  congr,
  funext,
  exact eq_of_heq h_map
end

lemma faithful.div_faithful (F : C ⥤ E) [faithful F] (G : D ⥤ E) [faithful G]
  (obj : C → D) (h_obj : ∀ X, G.obj (obj X) = F.obj X)
  (map : Π {X Y}, (X ⟶ Y) → (obj X ⟶ obj Y))
  (h_map : ∀ {X Y} {f : X ⟶ Y}, G.map (map f) == F.map f) :
  faithful (faithful.div F G obj @h_obj @map @h_map) :=
(faithful.div_comp F G _ h_obj _ @h_map).faithful_of_comp

instance full.comp [full F] [full G] : full (F ⋙ G) :=
{ preimage := λ _ _ f, F.preimage (G.preimage f) }

/-- If `F ⋙ G` is full and `G` is faithful, then `F` is full. -/
def full.of_comp_faithful [full $ F ⋙ G] [faithful G] : full F :=
{ preimage := λ X Y f, (F ⋙ G).preimage (G.map f),
  witness' := λ X Y f, G.map_injective ((F ⋙ G).image_preimage _) }

/-- If `F ⋙ G` is full and `G` is faithful, then `F` is full. -/
def full.of_comp_faithful_iso {F : C ⥤ D} {G : D ⥤ E} {H : C ⥤ E} [full H] [faithful G]
  (h : F ⋙ G ≅ H) : full F :=
@full.of_comp_faithful _ _ _ _ _ _ F G (full.of_iso h.symm) _

/--
Given a natural isomorphism between `F ⋙ H` and `G ⋙ H` for a fully faithful functor `H`, we
can 'cancel' it to give a natural iso between `F` and `G`.
-/
def fully_faithful_cancel_right {F G : C ⥤ D} (H : D ⥤ E)
  [full H] [faithful H] (comp_iso: F ⋙ H ≅ G ⋙ H) : F ≅ G :=
nat_iso.of_components
  (λ X, H.preimage_iso (comp_iso.app X))
  (λ X Y f, H.map_injective (by simpa using comp_iso.hom.naturality f))

@[simp]
lemma fully_faithful_cancel_right_hom_app {F G : C ⥤ D} {H : D ⥤ E}
  [full H] [faithful H] (comp_iso: F ⋙ H ≅ G ⋙ H) (X : C) :
  (fully_faithful_cancel_right H comp_iso).hom.app X = H.preimage (comp_iso.hom.app X) :=
rfl

@[simp]
lemma fully_faithful_cancel_right_inv_app {F G : C ⥤ D} {H : D ⥤ E}
  [full H] [faithful H] (comp_iso: F ⋙ H ≅ G ⋙ H) (X : C) :
  (fully_faithful_cancel_right H comp_iso).inv.app X = H.preimage (comp_iso.inv.app X) :=
rfl

end category_theory


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

/-!
# fintype instances for `equiv` and `perm`

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

Main declarations:
* `perms_of_finset s`: The finset of permutations of the finset `s`.

-/

open function
open_locale nat

universes u v

variables {α β γ : Type*}

open finset function list equiv equiv.perm

variables [decidable_eq α] [decidable_eq β]

/-- Given a list, produce a list of all permutations of its elements. -/
def perms_of_list : list α → list (perm α)
| []       := [1]
| (a :: l) := perms_of_list l ++ l.bind (λ b, (perms_of_list l).map (λ f, swap a b * f))

lemma length_perms_of_list : ∀ l : list α, length (perms_of_list l) = l.length!
| []       := rfl
| (a :: l) :=
begin
  rw [length_cons, nat.factorial_succ],
  simp [perms_of_list, length_bind, length_perms_of_list, function.comp, nat.succ_mul],
  cc
end

lemma mem_perms_of_list_of_mem {l : list α} {f : perm α} (h : ∀ x, f x ≠ x → x ∈ l) :
  f ∈ perms_of_list l :=
begin
  induction l with a l IH generalizing f h,
  { exact list.mem_singleton.2 (equiv.ext $ λ x, decidable.by_contradiction $ h _) },
  by_cases hfa : f a = a,
  { refine mem_append_left _ (IH (λ x hx, mem_of_ne_of_mem _ (h x hx))),
    rintro rfl, exact hx hfa },
  have hfa' : f (f a) ≠ f a := mt (λ h, f.injective h) hfa,
  have : ∀ (x : α), (swap a (f a) * f) x ≠ x → x ∈ l,
  { intros x hx,
    have hxa : x ≠ a,
    { rintro rfl, apply hx, simp only [mul_apply, swap_apply_right] },
    refine list.mem_of_ne_of_mem hxa (h x (λ h, _)),
    simp only [h, mul_apply, swap_apply_def, mul_apply, ne.def, apply_eq_iff_eq] at hx;
    split_ifs at hx, exacts [hxa (h.symm.trans h_1), hx h] },
  suffices : f ∈ perms_of_list l ∨ ∃ (b ∈ l) (g ∈ perms_of_list l), swap a b * g = f,
  { simpa only [perms_of_list, exists_prop, list.mem_map, mem_append, list.mem_bind] },
  refine or_iff_not_imp_left.2 (λ hfl, ⟨f a, _, swap a (f a) * f, IH this, _⟩),
  { exact mem_of_ne_of_mem hfa (h _ hfa') },
  { rw [←mul_assoc, mul_def (swap a (f a)) (swap a (f a)),
        swap_swap, ←perm.one_def, one_mul] }
end

lemma mem_of_mem_perms_of_list :
  ∀ {l : list α} {f : perm α}, f ∈ perms_of_list l → ∀ {x}, f x ≠ x → x ∈ l
| []       f h := have f = 1 := by simpa [perms_of_list] using h, by rw this; simp
| (a :: l) f h :=
(mem_append.1 h).elim
  (λ h x hx, mem_cons_of_mem _ (mem_of_mem_perms_of_list h hx))
  (λ h x hx,
    let ⟨y, hy, hy'⟩ := list.mem_bind.1 h in
    let ⟨g, hg₁, hg₂⟩ := list.mem_map.1 hy' in
    if hxa : x = a then by simp [hxa]
    else if hxy : x = y then mem_cons_of_mem _ $ by rwa hxy
    else mem_cons_of_mem _ $
    mem_of_mem_perms_of_list hg₁ $
      by rw [eq_inv_mul_iff_mul_eq.2 hg₂, mul_apply, swap_inv, swap_apply_def];
        split_ifs; [exact ne.symm hxy, exact ne.symm hxa, exact hx])

lemma mem_perms_of_list_iff {l : list α} {f : perm α} :
  f ∈ perms_of_list l ↔ ∀ {x}, f x ≠ x → x ∈ l :=
⟨mem_of_mem_perms_of_list, mem_perms_of_list_of_mem⟩

lemma nodup_perms_of_list : ∀ {l : list α} (hl : l.nodup), (perms_of_list l).nodup
| []       hl := by simp [perms_of_list]
| (a :: l) hl :=
have hl' : l.nodup, from hl.of_cons,
have hln' : (perms_of_list l).nodup, from nodup_perms_of_list hl',
have hmeml : ∀ {f : perm α}, f ∈ perms_of_list l → f a = a,
  from λ f hf, not_not.1 (mt (mem_of_mem_perms_of_list hf) (nodup_cons.1 hl).1),
by rw [perms_of_list, list.nodup_append, list.nodup_bind, pairwise_iff_nth_le]; exact
⟨hln', ⟨λ _ _, hln'.map $ λ _ _, mul_left_cancel,
  λ i j hj hij x hx₁ hx₂,
    let ⟨f, hf⟩ := list.mem_map.1 hx₁ in
    let ⟨g, hg⟩ := list.mem_map.1 hx₂ in
    have hix : x a = nth_le l i (lt_trans hij hj),
      by rw [←hf.2, mul_apply, hmeml hf.1, swap_apply_left],
    have hiy : x a = nth_le l j hj,
      by rw [← hg.2, mul_apply, hmeml hg.1, swap_apply_left],
    absurd (hf.2.trans (hg.2.symm)) $
      λ h, ne_of_lt hij $ nodup_iff_nth_le_inj.1 hl' i j (lt_trans hij hj) hj $
        by rw [← hix, hiy]⟩,
  λ f hf₁ hf₂,
    let ⟨x, hx, hx'⟩ := list.mem_bind.1 hf₂ in
    let ⟨g, hg⟩ := list.mem_map.1 hx' in
    have hgxa : g⁻¹ x = a, from f.injective $
      by rw [hmeml hf₁, ← hg.2]; simp,
    have hxa : x ≠ a, from λ h, (list.nodup_cons.1 hl).1 (h ▸ hx),
    (list.nodup_cons.1 hl).1 $
      hgxa ▸ mem_of_mem_perms_of_list hg.1 (by rwa [apply_inv_self, hgxa])⟩

/-- Given a finset, produce the finset of all permutations of its elements. -/
def perms_of_finset (s : finset α) : finset (perm α) :=
quotient.hrec_on s.1 (λ l hl, ⟨perms_of_list l, nodup_perms_of_list hl⟩)
  (λ a b hab, hfunext (congr_arg _ (quotient.sound hab))
    (λ ha hb _, heq_of_eq $ finset.ext $
      by simp [mem_perms_of_list_iff, hab.mem_iff]))
  s.2

lemma mem_perms_of_finset_iff : ∀ {s : finset α} {f : perm α},
  f ∈ perms_of_finset s ↔ ∀ {x}, f x ≠ x → x ∈ s :=
by rintros ⟨⟨l⟩, hs⟩ f; exact mem_perms_of_list_iff

lemma card_perms_of_finset : ∀ (s : finset α),
  (perms_of_finset s).card = s.card! :=
by rintros ⟨⟨l⟩, hs⟩; exact length_perms_of_list l

/-- The collection of permutations of a fintype is a fintype. -/
def fintype_perm [fintype α] : fintype (perm α) :=
⟨perms_of_finset (@finset.univ α _), by simp [mem_perms_of_finset_iff]⟩

instance [fintype α] [fintype β] : fintype (α ≃ β) :=
if h : fintype.card β = fintype.card α
then trunc.rec_on_subsingleton (fintype.trunc_equiv_fin α)
  (λ eα, trunc.rec_on_subsingleton (fintype.trunc_equiv_fin β)
    (λ eβ, @fintype.of_equiv _ (perm α) fintype_perm
      (equiv_congr (equiv.refl α) (eα.trans (eq.rec_on h eβ.symm)) : (α ≃ α) ≃ (α ≃ β))))
else ⟨∅, λ x, false.elim (h (fintype.card_eq.2 ⟨x.symm⟩))⟩

lemma fintype.card_perm [fintype α] : fintype.card (perm α) = (fintype.card α)! :=
subsingleton.elim (@fintype_perm α _ _) (@equiv.fintype α α _ _ _ _) ▸
card_perms_of_finset _

lemma fintype.card_equiv [fintype α] [fintype β] (e : α ≃ β) :
  fintype.card (α ≃ β) = (fintype.card α)! :=
fintype.card_congr (equiv_congr (equiv.refl α) e) ▸ fintype.card_perm