variables (G : Type) [has_mul G] [has_one G] [has_inv G]

-- Lean Group with one axiom missing.

-- I want to see mul, one and inv so I can see their types.
-- But I also want to use notation. Is it possible to do that?
class gripe (G : Type) [has_mul G] [has_one G] [has_inv G] :=
(mul_assoc : ∀ (a b c : G), a * b * c = a * (b * c))
(one_mul : ∀ (a : G), 1 * a = a)
(mul_left_inv : ∀ (a : G), a⁻¹ * a = 1)

-- new class and now lots of overloads and I always want my version to win.
namespace  gripe

-- wins the prize for simplicty

lemma mul_left_cancel' {G : Type} [has_mul G] [has_one G] [has_inv G]
(mul_assoc : ∀ (a b c : G), a * b * c = a * (b * c))
(one_mul : ∀ (a : G), 1 * a = a)
(mul_left_inv : ∀ (a : G), a⁻¹ * a = 1)
: ∀ (a b c : G), a * b = a * c → b = c :=
λ a b c Habac,
 calc b = 1 * b         : by rw one_mul
    ... = (a⁻¹ * a) * b : by rw mul_left_inv
    ... = a⁻¹ * (a * b) : by rw mul_assoc
    ... = a⁻¹ * (a * c) : by rw Habac
    ... = (a⁻¹ * a) * c : by rw mul_assoc
    ... = 1 * c         : by rw mul_left_inv
    ... = c             : by rw one_mul

-- this used to be easier when I wasn't using a class
lemma gripe.mul_left_cancel {G : Type} [has_mul G] [has_one G] [has_inv G] [gripe G]
: ∀ (a b c : G), a * b = a * c → b = c :=
begin
  intros a b c Habac,
  exact calc b = 1 * b : (one_mul b).symm
           ... = (a⁻¹ * a) * b : by rw [←gripe.mul_left_inv a]
           ... = a⁻¹ * (a * b) : mul_assoc _ _ _
           ... = a⁻¹ * (a * c) : by rw Habac
-- ... = c : by simp only [mul_assoc,one_mul,mul_left_inv] -- fails
           ... = (a⁻¹ * a) * c : (gripe.mul_assoc _ _ _).symm
           ... = 1 * c : by rw [gripe.mul_left_inv a]
           ... = c : one_mul _
end

#check @mul_left_cancel

theorem mul_one' {G : Type} [has_mul G] [has_one G] [has_inv G]
(mul_assoc : ∀ (a b c : G), a * b * c = a * (b * c))
(one_mul : ∀ (a : G), 1 * a = a)
(mul_left_inv : ∀ (a : G), a⁻¹ * a = 1)
: ∀ (a : G), a * 1 = a :=
begin
intro a,
 apply (mul_left_cancel' mul_assoc one_mul mul_left_inv a⁻¹ _ _), -- aargh
 rw [←mul_assoc,mul_left_inv,one_mul],
end

#check @group.mul_left_cancel

end gripe


import data.nat.prime

open nat

theorem exists_infinite_primes : ∀ n : ℕ, ∃ p, p ≥ n ∧ prime p :=
λ n,
  let p := min_fac (fact n + 1) in
  have fp : fact n > 0 := fact_pos n,
  have f1 : fact n + 1 ≠ 1, from ne_of_gt $ succ_lt_succ $ fact_pos n,
  have pp : prime p, from min_fac_prime f1,
  have w : n ≤ p, from le_of_not_ge $ λ h,
    have h₁ : p ∣ fact n, from dvd_fact (min_fac_pos (fact n + 1)) h,
    have h₂ : p ∣ 1, from (nat.dvd_add_iff_right h₁).2 (min_fac_dvd (fact n + 1)),
    pp.not_dvd_one h₂,
  ⟨p, w, pp⟩


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

Case bashing on variables in finite intervals.

In particular, `interval_cases n`
1) inspects hypotheses looking for lower and upper bounds of the form `a ≤ n` and `n < b`
   (although in `ℕ`, `ℤ`, and `ℕ+` bounds of the form `a < n` and `n ≤ b` are also allowed),
   and also makes use of lower and upper bounds found via `le_top` and `bot_le`
   (so for example if `n : ℕ`, then the bound `0 ≤ n` is found automatically), then
2) calls `fin_cases` on the synthesised hypothesis `n ∈ set.Ico a b`,
   assuming an appropriate `fintype` instance can be found for the type of `n`.

The variable `n` can belong to any type `α`, with the following restrictions:
* only bounds on which `expr.to_rat` succeeds will be considered "explicit" (TODO: generalise this?)
* an instance of `decidable_eq α` is available,
* an explicit lower bound can be found amongst the hypotheses, or from `bot_le n`,
* an explicit upper bound can be found amongst the hypotheses, or from `le_top n`,
* if multiple bounds are located, an instance of `linear_order α` is available, and
* an instance of `fintype set.Ico l u` is available for the relevant bounds.

You can also explicitly specify a lower and upper bound to use, as `interval_cases using hl hu`.
The hypotheses should be in the form `hl : a ≤ n` and `hu : n < b`,
in which case `interval_cases` calls `fin_cases` on the resulting fact `n ∈ set.Ico a b`.

-/
import tactic.fin_cases
import data.fintype.intervals

open set

namespace tactic

namespace interval_cases

/--
If `e` easily implies `(%%n < %%b)`
for some explicit `b`,
return that proof.
-/
-- We use `expr.to_rat` merely to decide if an `expr` is an explicit number.
-- It would be more natural to use `expr.to_int`, but that hasn't been implemented.
meta def gives_upper_bound (n e : expr) : tactic expr :=
do t ← infer_type e,
   match t with
   | `(%%n' < %%b) := do guard (n = n'), b ← b.to_rat, return e
   | `(%%b > %%n') := do guard (n = n'), b ← b.to_rat, return e
   | `(%%n' ≤ %%b) := do
      guard (n = n'),
      b ← b.to_rat,
      tn ← infer_type n,
      match tn with
      | `(ℕ) := to_expr ``(nat.lt_add_one_iff.mpr %%e)
      | `(ℕ+) := to_expr ``(pnat.lt_add_one_iff.mpr %%e)
      | `(ℤ) := to_expr ``(int.lt_add_one_iff.mpr %%e)
      | _ := failed
      end
   | `(%%b ≥ %%n') := do
      guard (n = n'),
      b ← b.to_rat,
      tn ← infer_type n,
      match tn with
      | `(ℕ) := to_expr ``(nat.lt_add_one_iff.mpr %%e)
      | `(ℕ+) := to_expr ``(pnat.lt_add_one_iff.mpr %%e)
      | `(ℤ) := to_expr ``(int.lt_add_one_iff.mpr %%e)
      | _ := failed
      end
   | _ := failed
   end

/--
If `e` easily implies `(%%n ≥ %%b)`
for some explicit `b`,
return that proof.
-/
meta def gives_lower_bound (n e : expr) : tactic expr :=
do t ← infer_type e,
   match t with
   | `(%%n' ≥ %%b) := do guard (n = n'), b ← b.to_rat, return e
   | `(%%b ≤ %%n') := do guard (n = n'), b ← b.to_rat, return e
   | `(%%n' > %%b) := do
      guard (n = n'),
      b ← b.to_rat,
      tn ← infer_type n,
      match tn with
      | `(ℕ) := to_expr ``(nat.add_one_le_iff.mpr %%e)
      | `(ℕ+) := to_expr ``(pnat.add_one_le_iff.mpr %%e)
      | `(ℤ) := to_expr ``(int.add_one_le_iff.mpr %%e)
      | _ := failed
      end
   | `(%%b < %%n') := do
      guard (n = n'),
      b ← b.to_rat,
      tn ← infer_type n,
      match tn with
      | `(ℕ) := to_expr ``(nat.add_one_le_iff.mpr %%e)
      | `(ℕ+) := to_expr ``(pnat.add_one_le_iff.mpr %%e)
      | `(ℤ) := to_expr ``(int.add_one_le_iff.mpr %%e)
      | _ := failed
      end
   | _ := failed
   end

/-- Combine two upper bounds. -/
meta def combine_upper_bounds : option expr → option expr → tactic (option expr)
| none none := return none
| (some prf) none := return $ some prf
| none (some prf) := return $ some prf
| (some prf₁) (some prf₂) :=
  do option.some <$> to_expr ``(lt_min %%prf₁ %%prf₂)

/-- Combine two lower bounds. -/
meta def combine_lower_bounds : option expr → option expr → tactic (option expr)
| none none := return $ none
| (some prf) none := return $ some prf
| none (some prf) := return $ some prf
| (some prf₁) (some prf₂) :=
  do option.some <$> to_expr ``(max_le %%prf₂ %%prf₁)

/-- Inspect a given expression, using it to update a set of upper and lower bounds on `n`. -/
meta def update_bounds (n : expr) (bounds : option expr × option expr) (e : expr) :
  tactic (option expr × option expr) :=
do nlb ← try_core $ gives_lower_bound n e,
   nub ← try_core $ gives_upper_bound n e,
   clb ← combine_lower_bounds bounds.1 nlb,
   cub ← combine_upper_bounds bounds.2 nub,
   return (clb, cub)

/--
Attempt to find a lower bound for the variable `n`, by evaluating `bot_le n`.
-/
meta def initial_lower_bound (n : expr) : tactic expr :=
do e ← to_expr ``(@bot_le _ _ %%n),
   t ← infer_type e,
   match t with
   | `(%%b ≤ %%n) := do return e
   | _ := failed
   end

/--
Attempt to find an upper bound for the variable `n`, by evaluating `le_top n`.
-/
meta def initial_upper_bound (n : expr) : tactic expr :=
do e ← to_expr ``(@le_top _ _ %%n),
   match e with
   | `(%%n ≤ %%b) := do
     tn ← infer_type n,
     e ← match tn with
     | `(ℕ) := to_expr ``(nat.add_one_le_iff.mpr %%e)
     | `(ℕ+) := to_expr ``(pnat.add_one_le_iff.mpr %%e)
     | `(ℤ) := to_expr ``(int.add_one_le_iff.mpr %%e)
     | _ := failed
     end,
     return e
   | _ := failed
   end

/-- Inspect the local hypotheses for upper and lower bounds on a variable `n`. -/
meta def get_bounds (n : expr) : tactic (expr × expr) :=
do
  hl ← try_core (initial_lower_bound n),
  hu ← try_core (initial_upper_bound n),
  lc ← local_context,
  r ← lc.mfoldl (update_bounds n) (hl, hu),
  match r with
  | (_, none) := fail "No upper bound located."
  | (none, _) := fail "No lower bound located."
  | (some lb_prf, some ub_prf) := return (lb_prf, ub_prf)
  end

/-- The finset of elements of a set `s` for which we have `fintype s`. -/
def set_elems {α} [decidable_eq α] (s : set α) [fintype s] : finset α :=
(fintype.elems s).image subtype.val

/-- Each element of `s` is a member of `set_elems s`. -/
lemma mem_set_elems {α} [decidable_eq α] (s : set α) [fintype s] {a : α} (h : a ∈ s) :
  a ∈ set_elems s :=
finset.mem_image.2 ⟨⟨a, h⟩, fintype.complete _, rfl⟩

end interval_cases

open interval_cases

/-- Call `fin_cases` on membership of the finset built from
an `Ico` interval corresponding to a lower and an upper bound.

Here `hl` should be an expression of the form `a ≤ n`, for some explicit `a`, and
`hu` should be of the form `n < b`, for some explicit `b`.

By default `interval_cases_using` automatically generates a name for the new hypothesis. The name
can be specified via the optional argument `n`.
-/
meta def interval_cases_using (hl hu : expr) (n : option name) : tactic unit :=
to_expr ``(mem_set_elems (Ico _ _) ⟨%%hl, %%hu⟩) >>=
(if hn : n.is_some then
  note (option.get hn)
else
  note_anon none) >>= fin_cases_at none

setup_tactic_parser

namespace interactive

local postfix `?`:9001 := optional

/--
`interval_cases n` searches for upper and lower bounds on a variable `n`,
and if bounds are found,
splits into separate cases for each possible value of `n`.

As an example, in
```
example (n : ℕ) (w₁ : n ≥ 3) (w₂ : n < 5) : n = 3 ∨ n = 4 :=
begin
  interval_cases n,
  all_goals {simp}
end
```
after `interval_cases n`, the goals are `3 = 3 ∨ 3 = 4` and `4 = 3 ∨ 4 = 4`.

You can also explicitly specify a lower and upper bound to use,
as `interval_cases using hl hu`.
The hypotheses should be in the form `hl : a ≤ n` and `hu : n < b`,
in which case `interval_cases` calls `fin_cases` on the resulting fact `n ∈ set.Ico a b`.

You can specify a name `h` for the new hypothesis,
as `interval_cases n with h` or `interval_cases n using hl hu with h`.
-/
meta def interval_cases (n : parse texpr?)
  (bounds : parse (tk "using" *> (prod.mk <$> ident <*> ident))?)
  (lname : parse (tk "with" *> ident)?) :
  tactic unit :=
do
  if h : n.is_some then (do
    guard bounds.is_none <|>
      fail "Do not use the `using` keyword if specifying the variable explicitly.",
    n ← to_expr (option.get h),
    (hl, hu) ← get_bounds n,
    tactic.interval_cases_using hl hu lname)
  else if h' : bounds.is_some then (do
    [hl, hu] ← [(option.get h').1, (option.get h').2].mmap get_local,
    tactic.interval_cases_using hl hu lname)
  else
    fail "Call `interval_cases n` (specifying a variable), or `interval_cases lb ub` (specifying a lower bound and upper bound on the same variable)."

/--
`interval_cases n` searches for upper and lower bounds on a variable `n`,
and if bounds are found,
splits into separate cases for each possible value of `n`.

As an example, in
```
example (n : ℕ) (w₁ : n ≥ 3) (w₂ : n < 5) : n = 3 ∨ n = 4 :=
begin
  interval_cases n,
  all_goals {simp}
end
```
after `interval_cases n`, the goals are `3 = 3 ∨ 3 = 4` and `4 = 3 ∨ 4 = 4`.

You can also explicitly specify a lower and upper bound to use,
as `interval_cases using hl hu`.
The hypotheses should be in the form `hl : a ≤ n` and `hu : n < b`,
in which case `interval_cases` calls `fin_cases` on the resulting fact `n ∈ set.Ico a b`.

You can also explicitly specify a name to use for the hypothesis added,
as `interval_cases n with hn` or `interval_cases n using hl hu with hn`.

In particular, `interval_cases n`
1) inspects hypotheses looking for lower and upper bounds of the form `a ≤ n` and `n < b`
   (although in `ℕ`, `ℤ`, and `ℕ+` bounds of the form `a < n` and `n ≤ b` are also allowed),
   and also makes use of lower and upper bounds found via `le_top` and `bot_le`
   (so for example if `n : ℕ`, then the bound `0 ≤ n` is found automatically), then
2) calls `fin_cases` on the synthesised hypothesis `n ∈ set.Ico a b`,
   assuming an appropriate `fintype` instance can be found for the type of `n`.

The variable `n` can belong to any type `α`, with the following restrictions:
* only bounds on which `expr.to_rat` succeeds will be considered "explicit" (TODO: generalise this?)
* an instance of `decidable_eq α` is available,
* an explicit lower bound can be found amongst the hypotheses, or from `bot_le n`,
* an explicit upper bound can be found amongst the hypotheses, or from `le_top n`,
* if multiple bounds are located, an instance of `linear_order α` is available, and
* an instance of `fintype set.Ico l u` is available for the relevant bounds.
-/
add_tactic_doc
{ name       := "interval_cases",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.interval_cases],
  tags       := ["case bashing"] }

end interactive

end tactic


import tactic

/-

# Further analysis of the universal property of quotients.

Let `X` be a type with an equivalence relation on it.
We say that a pair `Q` and `p : X → Q` is _universal_
if `p` is constant on equivalence classes, and furthermore
that `p` is "initial" for this property, which means that
for all types `T` and for all functions `f : X → T` which
are constant on equivalence classes, there's a unique `g : Q → T`
such that `f = g ∘ p`. Let's formalise this universal property in Lean.

-/
def is_universal {X : Type} [setoid X] (Q : Type) (p : X → Q) :=
(∀ x y, x ≈ y → p x = p y) ∧
∀ (T : Type) (f : X → T) (h : ∀ x y : X, x ≈ y → f x = f y),
  ∃ (g : Q → T), f = g ∘ p ∧ ∀ k : Q → T, f = k ∘ p → k = g

variables {X : Type} [setoid X] {Q : Type} {p : X → Q}

/-

`is_universal` is a definition, so we need to make a little API for it.
Let's start by giving us a way to get to that function `g` whose
existence is claimed by `is_universal`.

If `hu` is a proof that `(Q, p)` is universal, then given
`f : X → T` and a proof `h` that `f` is constant on equivalence classes,
let's define `g_univ hu h` to be the function `g : Q → T` which makes
the diagram commute. To define this we have to go from an "exists `g`"
statement in `is_universal` to an actual function `g`. We do this with
the `classical.some : (∃ (a : X), p a) → X` function. Note that this function
is noncomputable, but this doesn't matter because we are proving theorems.
-/

noncomputable def g_univ (hu : is_universal Q p)
  {T : Type} {f : X → T} (h : ∀ x y : X, x ≈ y → f x = f y) : Q → T :=
classical.some (hu.2 T f h)

/-

Now `g_univ` is also a definition, so we need to make an API for this too!

The proof that `g := g_univ hu h : Q → T` satisfies `f = g ∘ p` needs
a convenient name -- let's call it called `g_univ_spec hu h`

-/
lemma g_univ_spec (hu : is_universal Q p)
  {T : Type} {f : X → T} (h : ∀ x y : X, x ≈ y → f x = f y) :
    f = (g_univ hu h) ∘ p :=
(classical.some_spec (hu.2 T f h)).1

/-

And here's a variant which says that the functions take the same
values everywhere. This is sometimes more convenient. I prove it
by applying `congr_fun` to the previous proof.

-/

lemma g_univ_spec' (hu : is_universal Q p)
  {T : Type} {f : X → T} (h : ∀ x y : X, x ≈ y → f x = f y) (x : X) :
    f x = (g_univ hu h) (p x) :=
congr_fun (g_univ_spec hu h) x

/-

The proof of uniqueness of `g`, or more precisely that if `k : Q → T`
satisfies `f = k ∘ p` then `k = g`, also needs a convenient name --
let's call it `g_univ_unique hu h`.

-/

lemma g_univ_unique (hu : is_universal Q p)
  {T : Type} {f : X → T} (h : ∀ x y : X, x ≈ y → f x = f y) :
  ∀ (k : Q → T), f = k ∘ p → k = g_univ hu h :=
(classical.some_spec (hu.2 T f h)).2

/-

Let's make a variant where the conclusion is that `k q = g q` for all `q`,
other than just saying `k = g`. Again we just apply `congr_fun` to the
previous proof.

-/

lemma g_univ_unique' (hu : is_universal Q p)
  {T : Type} {f : X → T} (h : ∀ x y : X, x ≈ y → f x = f y) (k : Q → T)
  (hk : f = k ∘ p) (q : Q) : k q = g_univ hu h q :=
congr_fun (g_univ_unique hu h k hk) q

/-

Note that if `h : is_universal Q p` then `h` has type `P ∧ Q`
so `h.1` is a proof of `∀ x y, x ≈ y → p x = p y`.

Example: if `(Q, p)` is universal, then `p` is constant on equivalence classes.

-/

example (X : Type) [s : setoid X] (Q : Type) (p : X → Q) (h : is_universal Q p)
  (x y : X) (hxy : x ≈ y) : p x = p y :=
h.1 x y hxy

/-

Now let's go through the standard proof that universal objects
are unique up to isomorphism.

-/

-- Here's how to use `g_univ` to define functions between universal objects.
noncomputable example {X : Type} [s : setoid X] {Q1 Q2 : Type}
  {p1 : X → Q1} {p2 : X → Q2}
  (h1 : is_universal Q1 p1) (h2 : is_universal Q2 p2) :
  Q1 → Q2 :=
  g_univ h1 h2.1

-- Applying the universal property to `p : X → Q` gives us the
-- identity function `id : Q → Q`
lemma useful {X : Type} [s : setoid X] {Q : Type}
  {p : X → Q} (h1 : is_universal Q p) :
  g_univ h1 h1.1 = id :=
begin
  sorry
end

-- A variant of the previous lemma where we say `g q = q` rather than `g = id`
lemma useful2 {X : Type} [s : setoid X] {Q : Type}
  {p : X → Q} (h1 : is_universal Q p) (q : Q) :
  g_univ h1 h1.1 q = q :=
begin
  rw useful,
  refl
end

-- This is tricky. Ask if you need help.
noncomputable def univ_equiv {X : Type} [s : setoid X] {Q1 Q2 : Type}
  {p1 : X → Q1} {p2 : X → Q2}
  (h1 : is_universal Q1 p1) (h2 : is_universal Q2 p2) :
  Q1 ≃ Q2 :=
{ to_fun := g_univ h1 h2.1,
  inv_fun := g_univ h2 h1.1,
  left_inv := begin
    sorry
  end,
  right_inv := begin
    -- same proof, mutatis mutandis
    sorry
  end }

-- Lean's builtin quotients are universal
theorem quotient_is_universal {X : Type} [s : setoid X] :
  is_universal (quotient s) quotient.mk :=
begin
  sorry
end

-- so any universal object is isomorphic to the quotient object.
noncomputable def universal_equiv_quotient (X : Type) [s : setoid X]
  (Q : Type) (p : X → Q) (hu : is_universal Q p) :
Q ≃ (quotient s) :=
univ_equiv hu quotient_is_universal


/-
Copyright (c) 2022 Dagur Tómas Ásgeirsson. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Dagur Tómas Ásgeirsson, Leonardo de Moura

! This file was ported from Lean 3 source module data.set.bool_indicator
! leanprover-community/mathlib commit fc2ed6f838ce7c9b7c7171e58d78eaf7b438fb0e
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Data.Set.Image

/-!
# Indicator function valued in bool

See also `Set.indicator` and `Set.piecewise`.
-/

open Bool

namespace Set

variable {α : Type _} (s : Set α)

/-- `boolIndicator` maps `x` to `true` if `x ∈ s`, else to `false` -/
noncomputable def boolIndicator (x : α) :=
  @ite _ (x ∈ s) (Classical.propDecidable _) true false
#align set.bool_indicator Set.boolIndicator

theorem mem_iff_boolIndicator (x : α) : x ∈ s ↔ s.boolIndicator x = true := by
  unfold boolIndicator
  split_ifs with h <;> simp [h]
#align set.mem_iff_bool_indicator Set.mem_iff_boolIndicator

theorem not_mem_iff_boolIndicator (x : α) : x ∉ s ↔ s.boolIndicator x = false := by
  unfold boolIndicator
  split_ifs with h <;> simp [h]
#align set.not_mem_iff_bool_indicator Set.not_mem_iff_boolIndicator

theorem preimage_boolIndicator_true : s.boolIndicator ⁻¹' {true} = s :=
  ext fun x ↦ (s.mem_iff_boolIndicator x).symm
#align set.preimage_bool_indicator_true Set.preimage_boolIndicator_true

open Classical

theorem preimage_boolIndicator_eq_union (t : Set Bool) :
    s.boolIndicator ⁻¹' t = (if true ∈ t then s else ∅) ∪ if false ∈ t then sᶜ else ∅ := by
  ext x
  simp only [boolIndicator, mem_preimage]
  split_ifs <;> simp [*]
#align set.preimage_bool_indicator_eq_union Set.preimage_boolIndicator_eq_union

theorem preimage_boolIndicator (t : Set Bool) :
    s.boolIndicator ⁻¹' t = univ ∨
      s.boolIndicator ⁻¹' t = s ∨ s.boolIndicator ⁻¹' t = sᶜ ∨ s.boolIndicator ⁻¹' t = ∅ := by
  simp only [preimage_boolIndicator_eq_union]
  split_ifs <;> simp [s.union_compl_self]
#align set.preimage_bool_indicator Set.preimage_boolIndicator

end Set


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

/-!
# One-dimensional iterated derivatives

We define the `n`-th derivative of a function `f : 𝕜 → F` as a function
`iterated_deriv n f : 𝕜 → F`, as well as a version on domains `iterated_deriv_within n f s : 𝕜 → F`,
and prove their basic properties.

## Main definitions and results

Let `𝕜` be a nontrivially normed field, and `F` a normed vector space over `𝕜`. Let `f : 𝕜 → F`.

* `iterated_deriv n f` is the `n`-th derivative of `f`, seen as a function from `𝕜` to `F`.
  It is defined as the `n`-th Fréchet derivative (which is a multilinear map) applied to the
  vector `(1, ..., 1)`, to take advantage of all the existing framework, but we show that it
  coincides with the naive iterative definition.
* `iterated_deriv_eq_iterate` states that the `n`-th derivative of `f` is obtained by starting
  from `f` and differentiating it `n` times.
* `iterated_deriv_within n f s` is the `n`-th derivative of `f` within the domain `s`. It only
  behaves well when `s` has the unique derivative property.
* `iterated_deriv_within_eq_iterate` states that the `n`-th derivative of `f` in the domain `s` is
  obtained by starting from `f` and differentiating it `n` times within `s`. This only holds when
  `s` has the unique derivative property.

## Implementation details

The results are deduced from the corresponding results for the more general (multilinear) iterated
Fréchet derivative. For this, we write `iterated_deriv n f` as the composition of
`iterated_fderiv 𝕜 n f` and a continuous linear equiv. As continuous linear equivs respect
differentiability and commute with differentiation, this makes it possible to prove readily that
the derivative of the `n`-th derivative is the `n+1`-th derivative in `iterated_deriv_within_succ`,
by translating the corresponding result `iterated_fderiv_within_succ_apply_left` for the
iterated Fréchet derivative.
-/

noncomputable theory
open_locale classical topology big_operators
open filter asymptotics set

variables {𝕜 : Type*} [nontrivially_normed_field 𝕜]
variables {F : Type*} [normed_add_comm_group F] [normed_space 𝕜 F]
variables {E : Type*} [normed_add_comm_group E] [normed_space 𝕜 E]

/-- The `n`-th iterated derivative of a function from `𝕜` to `F`, as a function from `𝕜` to `F`. -/
def iterated_deriv (n : ℕ) (f : 𝕜 → F) (x : 𝕜) : F :=
(iterated_fderiv 𝕜 n f x : ((fin n) → 𝕜) → F) (λ(i : fin n), 1)

/-- The `n`-th iterated derivative of a function from `𝕜` to `F` within a set `s`, as a function
from `𝕜` to `F`. -/
def iterated_deriv_within (n : ℕ) (f : 𝕜 → F) (s : set 𝕜) (x : 𝕜) : F :=
(iterated_fderiv_within 𝕜 n f s x : ((fin n) → 𝕜) → F) (λ(i : fin n), 1)

variables {n : ℕ} {f : 𝕜 → F} {s : set 𝕜} {x : 𝕜}

lemma iterated_deriv_within_univ :
  iterated_deriv_within n f univ = iterated_deriv n f :=
by { ext x, rw [iterated_deriv_within, iterated_deriv, iterated_fderiv_within_univ] }

/-! ### Properties of the iterated derivative within a set -/

lemma iterated_deriv_within_eq_iterated_fderiv_within :
  iterated_deriv_within n f s x
  = (iterated_fderiv_within 𝕜 n f s x : ((fin n) → 𝕜) → F) (λ(i : fin n), 1) := rfl

/-- Write the iterated derivative as the composition of a continuous linear equiv and the iterated
Fréchet derivative -/
lemma iterated_deriv_within_eq_equiv_comp :
  iterated_deriv_within n f s
  = (continuous_multilinear_map.pi_field_equiv 𝕜 (fin n) F).symm ∘
    (iterated_fderiv_within 𝕜 n f s) :=
by { ext x, refl }

/-- Write the iterated Fréchet derivative as the composition of a continuous linear equiv and the
iterated derivative. -/
lemma iterated_fderiv_within_eq_equiv_comp :
  iterated_fderiv_within 𝕜 n f s
  = (continuous_multilinear_map.pi_field_equiv 𝕜 (fin n) F) ∘ (iterated_deriv_within n f s) :=
by rw [iterated_deriv_within_eq_equiv_comp, ← function.comp.assoc,
  linear_isometry_equiv.self_comp_symm, function.left_id]

/-- The `n`-th Fréchet derivative applied to a vector `(m 0, ..., m (n-1))` is the derivative
multiplied by the product of the `m i`s. -/
lemma iterated_fderiv_within_apply_eq_iterated_deriv_within_mul_prod {m : (fin n) → 𝕜} :
  (iterated_fderiv_within 𝕜 n f s x : ((fin n) → 𝕜) → F) m
  = (∏ i, m i) • iterated_deriv_within n f s x :=
begin
  rw [iterated_deriv_within_eq_iterated_fderiv_within, ← continuous_multilinear_map.map_smul_univ],
  simp
end

@[simp] lemma iterated_deriv_within_zero :
  iterated_deriv_within 0 f s = f :=
by { ext x, simp [iterated_deriv_within] }

@[simp] lemma iterated_deriv_within_one (hs : unique_diff_on 𝕜 s) {x : 𝕜} (hx : x ∈ s):
  iterated_deriv_within 1 f s x = deriv_within f s x :=
by { simp [iterated_deriv_within, iterated_fderiv_within_one_apply hs hx], refl }

/-- If the first `n` derivatives within a set of a function are continuous, and its first `n-1`
derivatives are differentiable, then the function is `C^n`. This is not an equivalence in general,
but this is an equivalence when the set has unique derivatives, see
`cont_diff_on_iff_continuous_on_differentiable_on_deriv`. -/
lemma cont_diff_on_of_continuous_on_differentiable_on_deriv {n : ℕ∞}
  (Hcont : ∀ (m : ℕ), (m : ℕ∞) ≤ n →
    continuous_on (λ x, iterated_deriv_within m f s x) s)
  (Hdiff : ∀ (m : ℕ), (m : ℕ∞) < n →
    differentiable_on 𝕜 (λ x, iterated_deriv_within m f s x) s) :
  cont_diff_on 𝕜 n f s :=
begin
  apply cont_diff_on_of_continuous_on_differentiable_on,
  { simpa [iterated_fderiv_within_eq_equiv_comp, linear_isometry_equiv.comp_continuous_on_iff] },
  { simpa [iterated_fderiv_within_eq_equiv_comp, linear_isometry_equiv.comp_differentiable_on_iff] }
end

/-- To check that a function is `n` times continuously differentiable, it suffices to check that its
first `n` derivatives are differentiable. This is slightly too strong as the condition we
require on the `n`-th derivative is differentiability instead of continuity, but it has the
advantage of avoiding the discussion of continuity in the proof (and for `n = ∞` this is optimal).
-/
lemma cont_diff_on_of_differentiable_on_deriv {n : ℕ∞}
  (h : ∀(m : ℕ), (m : ℕ∞) ≤ n → differentiable_on 𝕜 (iterated_deriv_within m f s) s) :
  cont_diff_on 𝕜 n f s :=
begin
  apply cont_diff_on_of_differentiable_on,
  simpa only [iterated_fderiv_within_eq_equiv_comp,
    linear_isometry_equiv.comp_differentiable_on_iff]
end

/-- On a set with unique derivatives, a `C^n` function has derivatives up to `n` which are
continuous. -/
lemma cont_diff_on.continuous_on_iterated_deriv_within {n : ℕ∞} {m : ℕ}
  (h : cont_diff_on 𝕜 n f s) (hmn : (m : ℕ∞) ≤ n) (hs : unique_diff_on 𝕜 s) :
  continuous_on (iterated_deriv_within m f s) s :=
by simpa only [iterated_deriv_within_eq_equiv_comp, linear_isometry_equiv.comp_continuous_on_iff]
  using h.continuous_on_iterated_fderiv_within hmn hs

/-- On a set with unique derivatives, a `C^n` function has derivatives less than `n` which are
differentiable. -/
lemma cont_diff_on.differentiable_on_iterated_deriv_within {n : ℕ∞} {m : ℕ}
  (h : cont_diff_on 𝕜 n f s) (hmn : (m : ℕ∞) < n) (hs : unique_diff_on 𝕜 s) :
  differentiable_on 𝕜 (iterated_deriv_within m f s) s :=
by simpa only [iterated_deriv_within_eq_equiv_comp,
  linear_isometry_equiv.comp_differentiable_on_iff]
  using h.differentiable_on_iterated_fderiv_within hmn hs

/-- The property of being `C^n`, initially defined in terms of the Fréchet derivative, can be
reformulated in terms of the one-dimensional derivative on sets with unique derivatives. -/
lemma cont_diff_on_iff_continuous_on_differentiable_on_deriv {n : ℕ∞}
  (hs : unique_diff_on 𝕜 s) :
  cont_diff_on 𝕜 n f s ↔
  (∀m:ℕ, (m : ℕ∞) ≤ n → continuous_on (iterated_deriv_within m f s) s)
  ∧ (∀m:ℕ, (m : ℕ∞) < n → differentiable_on 𝕜 (iterated_deriv_within m f s) s) :=
by simp only [cont_diff_on_iff_continuous_on_differentiable_on hs,
  iterated_fderiv_within_eq_equiv_comp, linear_isometry_equiv.comp_continuous_on_iff,
  linear_isometry_equiv.comp_differentiable_on_iff]

/-- The `n+1`-th iterated derivative within a set with unique derivatives can be obtained by
differentiating the `n`-th iterated derivative. -/
lemma iterated_deriv_within_succ {x : 𝕜} (hxs : unique_diff_within_at 𝕜 s x) :
  iterated_deriv_within (n + 1) f s x = deriv_within (iterated_deriv_within n f s) s x :=
begin
  rw [iterated_deriv_within_eq_iterated_fderiv_within, iterated_fderiv_within_succ_apply_left,
      iterated_fderiv_within_eq_equiv_comp, linear_isometry_equiv.comp_fderiv_within _ hxs,
      deriv_within],
  change ((continuous_multilinear_map.mk_pi_field 𝕜 (fin n)
    ((fderiv_within 𝕜 (iterated_deriv_within n f s) s x : 𝕜 → F) 1)) : (fin n → 𝕜 ) → F)
    (λ (i : fin n), 1)
    = (fderiv_within 𝕜 (iterated_deriv_within n f s) s x : 𝕜 → F) 1,
  simp
end

/-- The `n`-th iterated derivative within a set with unique derivatives can be obtained by
iterating `n` times the differentiation operation. -/
lemma iterated_deriv_within_eq_iterate {x : 𝕜} (hs : unique_diff_on 𝕜 s) (hx : x ∈ s) :
  iterated_deriv_within n f s x = ((λ (g : 𝕜 → F), deriv_within g s)^[n]) f x :=
begin
  induction n with n IH generalizing x,
  { simp },
  { rw [iterated_deriv_within_succ (hs x hx), function.iterate_succ'],
    exact deriv_within_congr (hs x hx) (λ y hy, IH hy) (IH hx) }
end

/-- The `n+1`-th iterated derivative within a set with unique derivatives can be obtained by
taking the `n`-th derivative of the derivative. -/
lemma iterated_deriv_within_succ' {x : 𝕜} (hxs : unique_diff_on 𝕜 s) (hx : x ∈ s) :
  iterated_deriv_within (n + 1) f s x = (iterated_deriv_within n (deriv_within f s) s) x :=
by { rw [iterated_deriv_within_eq_iterate hxs hx, iterated_deriv_within_eq_iterate hxs hx], refl }

/-! ### Properties of the iterated derivative on the whole space -/

lemma iterated_deriv_eq_iterated_fderiv :
  iterated_deriv n f x
  = (iterated_fderiv 𝕜 n f x : ((fin n) → 𝕜) → F) (λ(i : fin n), 1) := rfl

/-- Write the iterated derivative as the composition of a continuous linear equiv and the iterated
Fréchet derivative -/
lemma iterated_deriv_eq_equiv_comp :
  iterated_deriv n f
  = (continuous_multilinear_map.pi_field_equiv 𝕜 (fin n) F).symm ∘ (iterated_fderiv 𝕜 n f) :=
by { ext x, refl }

/-- Write the iterated Fréchet derivative as the composition of a continuous linear equiv and the
iterated derivative. -/
lemma iterated_fderiv_eq_equiv_comp :
  iterated_fderiv 𝕜 n f
  = (continuous_multilinear_map.pi_field_equiv 𝕜 (fin n) F) ∘ (iterated_deriv n f) :=
by rw [iterated_deriv_eq_equiv_comp, ← function.comp.assoc, linear_isometry_equiv.self_comp_symm,
  function.left_id]

/-- The `n`-th Fréchet derivative applied to a vector `(m 0, ..., m (n-1))` is the derivative
multiplied by the product of the `m i`s. -/
lemma iterated_fderiv_apply_eq_iterated_deriv_mul_prod {m : (fin n) → 𝕜} :
  (iterated_fderiv 𝕜 n f x : ((fin n) → 𝕜) → F) m = (∏ i, m i) • iterated_deriv n f x :=
by { rw [iterated_deriv_eq_iterated_fderiv, ← continuous_multilinear_map.map_smul_univ], simp }

@[simp] lemma iterated_deriv_zero :
  iterated_deriv 0 f = f :=
by { ext x, simp [iterated_deriv] }

@[simp] lemma iterated_deriv_one :
  iterated_deriv 1 f = deriv f :=
by { ext x, simp [iterated_deriv], refl }

/-- The property of being `C^n`, initially defined in terms of the Fréchet derivative, can be
reformulated in terms of the one-dimensional derivative. -/
lemma cont_diff_iff_iterated_deriv {n : ℕ∞} :
  cont_diff 𝕜 n f ↔
(∀m:ℕ, (m : ℕ∞) ≤ n → continuous (iterated_deriv m f))
∧ (∀m:ℕ, (m : ℕ∞) < n → differentiable 𝕜 (iterated_deriv m f)) :=
by simp only [cont_diff_iff_continuous_differentiable, iterated_fderiv_eq_equiv_comp,
  linear_isometry_equiv.comp_continuous_iff, linear_isometry_equiv.comp_differentiable_iff]

/-- To check that a function is `n` times continuously differentiable, it suffices to check that its
first `n` derivatives are differentiable. This is slightly too strong as the condition we
require on the `n`-th derivative is differentiability instead of continuity, but it has the
advantage of avoiding the discussion of continuity in the proof (and for `n = ∞` this is optimal).
-/
lemma cont_diff_of_differentiable_iterated_deriv {n : ℕ∞}
  (h : ∀(m : ℕ), (m : ℕ∞) ≤ n → differentiable 𝕜 (iterated_deriv m f)) :
  cont_diff 𝕜 n f :=
cont_diff_iff_iterated_deriv.2
  ⟨λ m hm, (h m hm).continuous, λ m hm, (h m (le_of_lt hm))⟩

lemma cont_diff.continuous_iterated_deriv {n : ℕ∞} (m : ℕ)
  (h : cont_diff 𝕜 n f) (hmn : (m : ℕ∞) ≤ n) :
  continuous (iterated_deriv m f) :=
(cont_diff_iff_iterated_deriv.1 h).1 m hmn

lemma cont_diff.differentiable_iterated_deriv {n : ℕ∞} (m : ℕ)
  (h : cont_diff 𝕜 n f) (hmn : (m : ℕ∞) < n) :
  differentiable 𝕜 (iterated_deriv m f) :=
(cont_diff_iff_iterated_deriv.1 h).2 m hmn

/-- The `n+1`-th iterated derivative can be obtained by differentiating the `n`-th
iterated derivative. -/
lemma iterated_deriv_succ : iterated_deriv (n + 1) f = deriv (iterated_deriv n f) :=
begin
  ext x,
  rw [← iterated_deriv_within_univ, ← iterated_deriv_within_univ, ← deriv_within_univ],
  exact iterated_deriv_within_succ unique_diff_within_at_univ,
end

/-- The `n`-th iterated derivative can be obtained by iterating `n` times the
differentiation operation. -/
lemma iterated_deriv_eq_iterate : iterated_deriv n f = (deriv^[n]) f :=
begin
  ext x,
  rw [← iterated_deriv_within_univ],
  convert iterated_deriv_within_eq_iterate unique_diff_on_univ (mem_univ x),
  simp [deriv_within_univ]
end

/-- The `n+1`-th iterated derivative can be obtained by taking the `n`-th derivative of the
derivative. -/
lemma iterated_deriv_succ' : iterated_deriv (n + 1) f = iterated_deriv n (deriv f) :=
by { rw [iterated_deriv_eq_iterate, iterated_deriv_eq_iterate], refl }


/-
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.fun_like.basic
import logic.embedding.basic
import order.rel_classes

/-!
# Relation homomorphisms, embeddings, isomorphisms

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

This file defines relation homomorphisms, embeddings, isomorphisms and order embeddings and
isomorphisms.

## Main declarations

* `rel_hom`: Relation homomorphism. A `rel_hom r s` is a function `f : α → β` such that
  `r a b → s (f a) (f b)`.
* `rel_embedding`: Relation embedding. A `rel_embedding r s` is an embedding `f : α ↪ β` such that
  `r a b ↔ s (f a) (f b)`.
* `rel_iso`: Relation isomorphism. A `rel_iso r s` is an equivalence `f : α ≃ β` such that
  `r a b ↔ s (f a) (f b)`.
* `sum_lex_congr`, `prod_lex_congr`: Creates a relation homomorphism between two `sum_lex` or two
  `prod_lex` from relation homomorphisms between their arguments.

## Notation

* `→r`: `rel_hom`
* `↪r`: `rel_embedding`
* `≃r`: `rel_iso`
-/

open function

universes u v w
variables {α β γ δ : Type*}
  {r : α → α → Prop} {s : β → β → Prop} {t : γ → γ → Prop} {u : δ → δ → Prop}

/-- A relation homomorphism with respect to a given pair of relations `r` and `s`
is a function `f : α → β` such that `r a b → s (f a) (f b)`. -/
@[nolint has_nonempty_instance]
structure rel_hom {α β : Type*} (r : α → α → Prop) (s : β → β → Prop) :=
(to_fun : α → β)
(map_rel' : ∀ {a b}, r a b → s (to_fun a) (to_fun b))

infix ` →r `:25 := rel_hom

section
set_option old_structure_cmd true

/-- `rel_hom_class F r s` asserts that `F` is a type of functions such that all `f : F`
satisfy `r a b → s (f a) (f b)`.

The relations `r` and `s` are `out_param`s since figuring them out from a goal is a higher-order
matching problem that Lean usually can't do unaided.
-/
class rel_hom_class (F : Type*) {α β : out_param $ Type*}
  (r : out_param $ α → α → Prop) (s : out_param $ β → β → Prop)
  extends fun_like F α (λ _, β) :=
(map_rel : ∀ (f : F) {a b}, r a b → s (f a) (f b))
export rel_hom_class (map_rel)

-- The free parameters `r` and `s` are `out_param`s so this is not dangerous.
attribute [nolint dangerous_instance] rel_hom_class.to_fun_like

end

namespace rel_hom_class

variables {F : Type*}

protected theorem is_irrefl [rel_hom_class F r s] (f : F) : ∀ [is_irrefl β s], is_irrefl α r
| ⟨H⟩ := ⟨λ a h, H _ (map_rel f h)⟩

protected theorem is_asymm [rel_hom_class F r s] (f : F) : ∀ [is_asymm β s], is_asymm α r
| ⟨H⟩ := ⟨λ a b h₁ h₂, H _ _ (map_rel f h₁) (map_rel f h₂)⟩

protected theorem acc [rel_hom_class F r s] (f : F) (a : α) : acc s (f a) → acc r a :=
begin
  generalize h : f a = b, intro ac,
  induction ac with _ H IH generalizing a, subst h,
  exact ⟨_, λ a' h, IH (f a') (map_rel f h) _ rfl⟩
end

protected theorem well_founded [rel_hom_class F r s] (f : F) :
  ∀ (h : well_founded s), well_founded r
| ⟨H⟩ := ⟨λ a, rel_hom_class.acc f _ (H _)⟩

end rel_hom_class

namespace rel_hom

instance : rel_hom_class (r →r s) r s :=
{ coe := λ o, o.to_fun,
  coe_injective' := λ f g h, by { cases f, cases g, congr' },
  map_rel := map_rel' }

/-- Auxiliary instance if `rel_hom_class.to_fun_like.to_has_coe_to_fun` isn't found -/
instance : has_coe_to_fun (r →r s) (λ _, α → β) := ⟨λ o, o.to_fun⟩

initialize_simps_projections rel_hom (to_fun → apply)

protected theorem map_rel (f : r →r s) {a b} : r a b → s (f a) (f b) := f.map_rel'

@[simp] theorem coe_fn_mk (f : α → β) (o) :
  (@rel_hom.mk _ _ r s f o : α → β) = f := rfl

@[simp] theorem coe_fn_to_fun (f : r →r s) : (f.to_fun : α → β) = f := rfl

/-- The map `coe_fn : (r →r s) → (α → β)` is injective. -/
theorem coe_fn_injective : @function.injective (r →r s) (α → β) coe_fn :=
fun_like.coe_injective

@[ext]

theorem ext_iff {f g : r →r s} : f = g ↔ ∀ x, f x = g x :=
fun_like.ext_iff

/-- Identity map is a relation homomorphism. -/
@[refl, simps] protected def id (r : α → α → Prop) : r →r r :=
⟨λ x, x, λ a b x, x⟩

/-- Composition of two relation homomorphisms is a relation homomorphism. -/
@[trans, simps] protected def comp (g : s →r t) (f : r →r s) : r →r t :=
⟨λ x, g (f x), λ a b h, g.2 (f.2 h)⟩

/-- A relation homomorphism is also a relation homomorphism between dual relations. -/
protected def swap (f : r →r s) : swap r →r swap s :=
⟨f, λ a b, f.map_rel⟩

/-- A function is a relation homomorphism from the preimage relation of `s` to `s`. -/
def preimage (f : α → β) (s : β → β → Prop) : f ⁻¹'o s →r s := ⟨f, λ a b, id⟩

end rel_hom

/-- An increasing function is injective -/
lemma injective_of_increasing (r : α → α → Prop) (s : β → β → Prop) [is_trichotomous α r]
  [is_irrefl β s] (f : α → β) (hf : ∀ {x y}, r x y → s (f x) (f y)) : injective f :=
begin
  intros x y hxy,
  rcases trichotomous_of r x y with h | h | h,
  have := hf h, rw hxy at this, exfalso, exact irrefl_of s (f y) this,
  exact h,
  have := hf h, rw hxy at this, exfalso, exact irrefl_of s (f y) this
end

/-- An increasing function is injective -/
lemma rel_hom.injective_of_increasing [is_trichotomous α r]
  [is_irrefl β s] (f : r →r s) : injective f :=
injective_of_increasing r s f (λ x y, f.map_rel)

-- TODO: define a `rel_iff_class` so we don't have to do all the `convert` trickery?
theorem surjective.well_founded_iff {f : α → β} (hf : surjective f)
  (o : ∀ {a b}, r a b ↔ s (f a) (f b)) : well_founded r ↔ well_founded s :=
iff.intro (begin
  refine rel_hom_class.well_founded (rel_hom.mk _ _ : s →r r),
  { exact classical.some hf.has_right_inverse },
  intros a b h, apply o.2, convert h,
  iterate 2 { apply classical.some_spec hf.has_right_inverse },
end) (rel_hom_class.well_founded (⟨f, λ _ _, o.1⟩ : r →r s))

/-- A relation embedding with respect to a given pair of relations `r` and `s`
is an embedding `f : α ↪ β` such that `r a b ↔ s (f a) (f b)`. -/
structure rel_embedding {α β : Type*} (r : α → α → Prop) (s : β → β → Prop) extends α ↪ β :=
(map_rel_iff' : ∀ {a b}, s (to_embedding a) (to_embedding b) ↔ r a b)

infix ` ↪r `:25 := rel_embedding

/-- The induced relation on a subtype is an embedding under the natural inclusion. -/
definition subtype.rel_embedding {X : Type*} (r : X → X → Prop) (p : X → Prop) :
  ((subtype.val : subtype p → X) ⁻¹'o r) ↪r r :=
⟨embedding.subtype p, λ x y, iff.rfl⟩

theorem preimage_equivalence {α β} (f : α → β) {s : β → β → Prop}
  (hs : equivalence s) : equivalence (f ⁻¹'o s) :=
⟨λ a, hs.1 _, λ a b h, hs.2.1 h, λ a b c h₁ h₂, hs.2.2 h₁ h₂⟩

namespace rel_embedding

/-- A relation embedding is also a relation homomorphism -/
def to_rel_hom (f : r ↪r s) : (r →r s) :=
{ to_fun := f.to_embedding.to_fun,
  map_rel' := λ x y, (map_rel_iff' f).mpr }

instance : has_coe (r ↪r s) (r →r s) := ⟨to_rel_hom⟩
-- see Note [function coercion]
instance : has_coe_to_fun (r ↪r s) (λ _, α → β) := ⟨λ o, o.to_embedding⟩

-- TODO: define and instantiate a `rel_embedding_class` when `embedding_like` is defined
instance : rel_hom_class (r ↪r s) r s :=
{ coe := coe_fn,
  coe_injective' := λ f g h, by { rcases f with ⟨⟨⟩⟩, rcases g with ⟨⟨⟩⟩, congr' },
  map_rel := λ f a b, iff.mpr (map_rel_iff' f) }

/-- See Note [custom simps projection]. We need to specify this projection explicitly in this case,
because it is a composition of multiple projections. -/
def simps.apply (h : r ↪r s) : α → β := h

initialize_simps_projections rel_embedding (to_embedding_to_fun → apply, -to_embedding)

@[simp] lemma to_rel_hom_eq_coe (f : r ↪r s) : f.to_rel_hom = f := rfl

@[simp] lemma coe_coe_fn (f : r ↪r s) : ((f : r →r s) : α → β) = f := rfl

theorem injective (f : r ↪r s) : injective f := f.inj'

@[simp] theorem inj (f : r ↪r s) {a b} : f a = f b ↔ a = b := f.injective.eq_iff

theorem map_rel_iff (f : r ↪r s) {a b} : s (f a) (f b) ↔ r a b := f.map_rel_iff'

@[simp] theorem coe_fn_mk (f : α ↪ β) (o) :
  (@rel_embedding.mk _ _ r s f o : α → β) = f := rfl

@[simp] theorem coe_fn_to_embedding (f : r ↪r s) : (f.to_embedding : α → β) = f := rfl

/-- The map `coe_fn : (r ↪r s) → (α → β)` is injective. -/
theorem coe_fn_injective : @function.injective (r ↪r s) (α → β) coe_fn := fun_like.coe_injective

@[ext] theorem ext ⦃f g : r ↪r s⦄ (h : ∀ x, f x = g x) : f = g := fun_like.ext _ _ h

theorem ext_iff {f g : r ↪r s} : f = g ↔ ∀ x, f x = g x := fun_like.ext_iff

/-- Identity map is a relation embedding. -/
@[refl, simps] protected def refl (r : α → α → Prop) : r ↪r r :=
⟨embedding.refl _, λ a b, iff.rfl⟩

/-- Composition of two relation embeddings is a relation embedding. -/
@[trans] protected def trans (f : r ↪r s) (g : s ↪r t) : r ↪r t :=
⟨f.1.trans g.1, λ a b, by simp [f.map_rel_iff, g.map_rel_iff]⟩

instance (r : α → α → Prop) : inhabited (r ↪r r) := ⟨rel_embedding.refl _⟩

theorem trans_apply (f : r ↪r s) (g : s ↪r t) (a : α) : (f.trans g) a = g (f a) := rfl

@[simp] theorem coe_trans (f : r ↪r s) (g : s ↪r t) : ⇑(f.trans g) = g ∘ f := rfl

/-- A relation embedding is also a relation embedding between dual relations. -/
protected def swap (f : r ↪r s) : swap r ↪r swap s :=
⟨f.to_embedding, λ a b, f.map_rel_iff⟩

/-- If `f` is injective, then it is a relation embedding from the
  preimage relation of `s` to `s`. -/
def preimage (f : α ↪ β) (s : β → β → Prop) : f ⁻¹'o s ↪r s := ⟨f, λ a b, iff.rfl⟩

theorem eq_preimage (f : r ↪r s) : r = f ⁻¹'o s :=
by { ext a b, exact f.map_rel_iff.symm }

protected theorem is_irrefl (f : r ↪r s) [is_irrefl β s] : is_irrefl α r :=
⟨λ a, mt f.map_rel_iff.2 (irrefl (f a))⟩

protected theorem is_refl (f : r ↪r s) [is_refl β s] : is_refl α r :=
⟨λ a, f.map_rel_iff.1 $ refl _⟩

protected theorem is_symm (f : r ↪r s) [is_symm β s] : is_symm α r :=
⟨λ a b, imp_imp_imp f.map_rel_iff.2 f.map_rel_iff.1 symm⟩

protected theorem is_asymm (f : r ↪r s) [is_asymm β s] : is_asymm α r :=
⟨λ a b h₁ h₂, asymm (f.map_rel_iff.2 h₁) (f.map_rel_iff.2 h₂)⟩

protected theorem is_antisymm : ∀ (f : r ↪r s) [is_antisymm β s], is_antisymm α r
| ⟨f, o⟩ ⟨H⟩ := ⟨λ a b h₁ h₂, f.inj' (H _ _ (o.2 h₁) (o.2 h₂))⟩

protected theorem is_trans : ∀ (f : r ↪r s) [is_trans β s], is_trans α r
| ⟨f, o⟩ ⟨H⟩ := ⟨λ a b c h₁ h₂, o.1 (H _ _ _ (o.2 h₁) (o.2 h₂))⟩

protected theorem is_total : ∀ (f : r ↪r s) [is_total β s], is_total α r
| ⟨f, o⟩ ⟨H⟩ := ⟨λ a b, (or_congr o o).1 (H _ _)⟩

protected theorem is_preorder : ∀ (f : r ↪r s) [is_preorder β s], is_preorder α r
| f H := by exactI {..f.is_refl, ..f.is_trans}

protected theorem is_partial_order : ∀ (f : r ↪r s) [is_partial_order β s], is_partial_order α r
| f H := by exactI {..f.is_preorder, ..f.is_antisymm}

protected theorem is_linear_order : ∀ (f : r ↪r s) [is_linear_order β s], is_linear_order α r
| f H := by exactI {..f.is_partial_order, ..f.is_total}

protected theorem is_strict_order : ∀ (f : r ↪r s) [is_strict_order β s], is_strict_order α r
| f H := by exactI {..f.is_irrefl, ..f.is_trans}

protected theorem is_trichotomous : ∀ (f : r ↪r s) [is_trichotomous β s], is_trichotomous α r
| ⟨f, o⟩ ⟨H⟩ := ⟨λ a b, (or_congr o (or_congr f.inj'.eq_iff o)).1 (H _ _)⟩

protected theorem is_strict_total_order :
  ∀ (f : r ↪r s) [is_strict_total_order β s], is_strict_total_order α r
| f H := by exactI {..f.is_trichotomous, ..f.is_strict_order}

protected theorem acc (f : r ↪r s) (a : α) : acc s (f a) → acc r a :=
begin
  generalize h : f a = b, intro ac,
  induction ac with _ H IH generalizing a, subst h,
  exact ⟨_, λ a' h, IH (f a') (f.map_rel_iff.2 h) _ rfl⟩
end

protected theorem well_founded : ∀ (f : r ↪r s) (h : well_founded s), well_founded r
| f ⟨H⟩ := ⟨λ a, f.acc _ (H _)⟩

protected theorem is_well_founded (f : r ↪r s) [is_well_founded β s] : is_well_founded α r :=
⟨f.well_founded is_well_founded.wf⟩

protected theorem is_well_order : ∀ (f : r ↪r s) [is_well_order β s], is_well_order α r
| f H := by exactI {wf := f.well_founded H.wf, ..f.is_strict_total_order}

instance _root_.subtype.well_founded_lt [has_lt α] [well_founded_lt α] (p : α → Prop) :
  well_founded_lt (subtype p) := (subtype.rel_embedding (<) p).is_well_founded

instance _root_.subtype.well_founded_gt [has_lt α] [well_founded_gt α] (p : α → Prop) :
  well_founded_gt (subtype p) := (subtype.rel_embedding (>) p).is_well_founded

/-- `quotient.mk` as a relation homomorphism between the relation and the lift of a relation. -/
@[simps] def _root_.quotient.mk_rel_hom [setoid α] {r : α → α → Prop} (H) :
  r →r quotient.lift₂ r H :=
⟨@quotient.mk α _, λ _ _, id⟩

/-- `quotient.out` as a relation embedding between the lift of a relation and the relation. -/
@[simps]
noncomputable def _root_.quotient.out_rel_embedding [setoid α] {r : α → α → Prop} (H) :
  quotient.lift₂ r H ↪r r :=
⟨embedding.quotient_out α, begin
  refine λ x y, quotient.induction_on₂ x y (λ a b, _),
  apply iff_iff_eq.2 (H _ _ _ _ _ _);
  apply quotient.mk_out
end⟩

/-- `quotient.out'` as a relation embedding between the lift of a relation and the relation. -/
@[simps]
noncomputable def _root_.quotient.out'_rel_embedding {s : setoid α} {r : α → α → Prop} (H) :
  (λ a b, quotient.lift_on₂' a b r H) ↪r r :=
{ to_fun := quotient.out',
  ..quotient.out_rel_embedding _ }

@[simp] theorem _root_.acc_lift₂_iff [setoid α] {r : α → α → Prop} {H} {a} :
  acc (quotient.lift₂ r H) ⟦a⟧ ↔ acc r a :=
begin
  split,
  { exact rel_hom_class.acc (quotient.mk_rel_hom H) a, },
  { intro ac,
    induction ac with _ H IH, dsimp at IH,
    refine ⟨_, λ q h, _⟩,
    obtain ⟨a', rfl⟩ := q.exists_rep,
    exact IH a' h, },
end

@[simp] theorem _root_.acc_lift_on₂'_iff {s : setoid α} {r : α → α → Prop} {H} {a} :
  acc (λ x y, quotient.lift_on₂' x y r H) (quotient.mk' a : quotient s) ↔ acc r a :=
acc_lift₂_iff

/-- A relation is well founded iff its lift to a quotient is. -/
theorem _root_.well_founded_lift₂_iff [setoid α] {r : α → α → Prop} {H} :
  well_founded (quotient.lift₂ r H) ↔ well_founded r :=
begin
  split,
  { exact rel_hom_class.well_founded (quotient.mk_rel_hom H), },
  { refine λ wf, ⟨λ q, _⟩,
    obtain ⟨a, rfl⟩ := q.exists_rep,
    exact acc_lift₂_iff.2 (wf.apply a), },
end

alias _root_.well_founded_lift₂_iff ↔
  _root_.well_founded.of_quotient_lift₂ _root_.well_founded.quotient_lift₂

@[simp] theorem _root_.well_founded_lift_on₂'_iff {s : setoid α} {r : α → α → Prop} {H} :
  well_founded (λ x y : quotient s, quotient.lift_on₂' x y r H) ↔ well_founded r :=
well_founded_lift₂_iff

alias _root_.well_founded_lift_on₂'_iff ↔
  _root_.well_founded.of_quotient_lift_on₂' _root_.well_founded.quotient_lift_on₂'

/--
To define an relation embedding from an antisymmetric relation `r` to a reflexive relation `s` it
suffices to give a function together with a proof that it satisfies `s (f a) (f b) ↔ r a b`.
-/
def of_map_rel_iff (f : α → β) [is_antisymm α r] [is_refl β s]
  (hf : ∀ a b, s (f a) (f b) ↔ r a b) : r ↪r s :=
{ to_fun := f,
  inj' := λ x y h, antisymm ((hf _ _).1 (h ▸ refl _)) ((hf _ _).1 (h ▸ refl _)),
  map_rel_iff' := hf }

@[simp]
lemma of_map_rel_iff_coe (f : α → β) [is_antisymm α r] [is_refl β s]
  (hf : ∀ a b, s (f a) (f b) ↔ r a b) :
  ⇑(of_map_rel_iff f hf : r ↪r s) = f :=
rfl

/-- It suffices to prove `f` is monotone between strict relations
  to show it is a relation embedding. -/
def of_monotone [is_trichotomous α r] [is_asymm β s] (f : α → β)
  (H : ∀ a b, r a b → s (f a) (f b)) : r ↪r s :=
begin
  haveI := @is_asymm.is_irrefl β s _,
  refine ⟨⟨f, λ a b e, _⟩, λ a b, ⟨λ h, _, H _ _⟩⟩,
  { refine ((@trichotomous _ r _ a b).resolve_left _).resolve_right _;
    exact λ h, @irrefl _ s _ _ (by simpa [e] using H _ _ h) },
  { refine (@trichotomous _ r _ a b).resolve_right (or.rec (λ e, _) (λ h', _)),
    { subst e, exact irrefl _ h },
    { exact asymm (H _ _ h') h } }
end

@[simp] theorem of_monotone_coe [is_trichotomous α r] [is_asymm β s] (f : α → β) (H) :
  (@of_monotone _ _ r s _ _ f H : α → β) = f := rfl

/-- A relation embedding from an empty type. -/
def of_is_empty (r : α → α → Prop) (s : β → β → Prop) [is_empty α] : r ↪r s :=
⟨embedding.of_is_empty, is_empty_elim⟩

/-- `sum.inl` as a relation embedding into `sum.lift_rel r s`. -/
@[simps] def sum_lift_rel_inl (r : α → α → Prop) (s : β → β → Prop) : r ↪r sum.lift_rel r s :=
{ to_fun := sum.inl,
  inj' := sum.inl_injective,
  map_rel_iff' := λ a b, sum.lift_rel_inl_inl }

/-- `sum.inr` as a relation embedding into `sum.lift_rel r s`. -/
@[simps] def sum_lift_rel_inr (r : α → α → Prop) (s : β → β → Prop) : s ↪r sum.lift_rel r s :=
{ to_fun := sum.inr,
  inj' := sum.inr_injective,
  map_rel_iff' := λ a b, sum.lift_rel_inr_inr }

/-- `sum.map` as a relation embedding between `sum.lift_rel` relations. -/
@[simps] def sum_lift_rel_map (f : r ↪r s) (g : t ↪r u) : sum.lift_rel r t ↪r sum.lift_rel s u :=
{ to_fun := sum.map f g,
  inj' := f.injective.sum_map g.injective,
  map_rel_iff' := by { rintro (a | b) (c | d); simp [f.map_rel_iff, g.map_rel_iff] } }

/-- `sum.inl` as a relation embedding into `sum.lex r s`. -/
@[simps] def sum_lex_inl (r : α → α → Prop) (s : β → β → Prop) : r ↪r sum.lex r s :=
{ to_fun := sum.inl,
  inj' := sum.inl_injective,
  map_rel_iff' := λ a b, sum.lex_inl_inl }

/-- `sum.inr` as a relation embedding into `sum.lex r s`. -/
@[simps] def sum_lex_inr (r : α → α → Prop) (s : β → β → Prop) : s ↪r sum.lex r s :=
{ to_fun := sum.inr,
  inj' := sum.inr_injective,
  map_rel_iff' := λ a b, sum.lex_inr_inr }

/-- `sum.map` as a relation embedding between `sum.lex` relations. -/
@[simps] def sum_lex_map (f : r ↪r s) (g : t ↪r u) : sum.lex r t ↪r sum.lex s u :=
{ to_fun := sum.map f g,
  inj' := f.injective.sum_map g.injective,
  map_rel_iff' := by { rintro (a | b) (c | d); simp [f.map_rel_iff, g.map_rel_iff] } }

/-- `λ b, prod.mk a b` as a relation embedding. -/
@[simps] def prod_lex_mk_left (s : β → β → Prop) {a : α} (h : ¬ r a a) : s ↪r prod.lex r s :=
{ to_fun := prod.mk a,
  inj' := prod.mk.inj_left a,
  map_rel_iff' := λ b₁ b₂, by simp [prod.lex_def, h] }

/-- `λ a, prod.mk a b` as a relation embedding. -/
@[simps] def prod_lex_mk_right (r : α → α → Prop) {b : β} (h : ¬ s b b) : r ↪r prod.lex r s :=
{ to_fun := λ a, (a, b),
  inj' := prod.mk.inj_right b,
  map_rel_iff' := λ a₁ a₂, by simp [prod.lex_def, h] }

/-- `prod.map` as a relation embedding. -/
@[simps] def prod_lex_map (f : r ↪r s) (g : t ↪r u) : prod.lex r t ↪r prod.lex s u :=
{ to_fun := prod.map f g,
  inj' := f.injective.prod_map g.injective,
  map_rel_iff' := λ a b, by simp [prod.lex_def, f.map_rel_iff, g.map_rel_iff] }

end rel_embedding

/-- A relation isomorphism is an equivalence that is also a relation embedding. -/
structure rel_iso {α β : Type*} (r : α → α → Prop) (s : β → β → Prop) extends α ≃ β :=
(map_rel_iff' : ∀ {a b}, s (to_equiv a) (to_equiv b) ↔ r a b)

infix ` ≃r `:25 := rel_iso

namespace rel_iso

/-- Convert an `rel_iso` to an `rel_embedding`. This function is also available as a coercion
but often it is easier to write `f.to_rel_embedding` than to write explicitly `r` and `s`
in the target type. -/
def to_rel_embedding (f : r ≃r s) : r ↪r s :=
⟨f.to_equiv.to_embedding, λ _ _, f.map_rel_iff'⟩

theorem to_equiv_injective : injective (to_equiv : (r ≃r s) → α ≃ β)
| ⟨e₁, o₁⟩ ⟨e₂, o₂⟩ h := by { congr, exact h }

instance : has_coe (r ≃r s) (r ↪r s) := ⟨to_rel_embedding⟩
-- see Note [function coercion]
instance : has_coe_to_fun (r ≃r s) (λ _, α → β) := ⟨λ f, f⟩

-- TODO: define and instantiate a `rel_iso_class` when `equiv_like` is defined
instance : rel_hom_class (r ≃r s) r s :=
{ coe := coe_fn,
  coe_injective' := equiv.coe_fn_injective.comp to_equiv_injective,
  map_rel := λ f a b, iff.mpr (map_rel_iff' f) }

@[simp] lemma to_rel_embedding_eq_coe (f : r ≃r s) : f.to_rel_embedding = f := rfl

@[simp] lemma coe_coe_fn (f : r ≃r s) : ((f : r ↪r s) : α → β) = f := rfl

theorem map_rel_iff (f : r ≃r s) {a b} : s (f a) (f b) ↔ r a b := f.map_rel_iff'

@[simp] theorem coe_fn_mk (f : α ≃ β) (o : ∀ ⦃a b⦄, s (f a) (f b) ↔ r a b) :
  (rel_iso.mk f o : α → β) = f := rfl

@[simp] theorem coe_fn_to_equiv (f : r ≃r s) : (f.to_equiv : α → β) = f := rfl

/-- The map `coe_fn : (r ≃r s) → (α → β)` is injective. Lean fails to parse
`function.injective (λ e : r ≃r s, (e : α → β))`, so we use a trick to say the same. -/
theorem coe_fn_injective : @function.injective (r ≃r s) (α → β) coe_fn := fun_like.coe_injective

@[ext] theorem ext ⦃f g : r ≃r s⦄ (h : ∀ x, f x = g x) : f = g := fun_like.ext f g h

theorem ext_iff {f g : r ≃r s} : f = g ↔ ∀ x, f x = g x := fun_like.ext_iff

/-- Inverse map of a relation isomorphism is a relation isomorphism. -/
@[symm] protected def symm (f : r ≃r s) : s ≃r r :=
⟨f.to_equiv.symm, λ a b, by erw [← f.map_rel_iff, f.1.apply_symm_apply, f.1.apply_symm_apply]⟩

/-- See Note [custom simps projection]. We need to specify this projection explicitly in this case,
  because it is a composition of multiple projections. -/
def simps.apply (h : r ≃r s) : α → β := h
/-- See Note [custom simps projection]. -/
def simps.symm_apply (h : r ≃r s) : β → α := h.symm

initialize_simps_projections rel_iso
  (to_equiv_to_fun → apply, to_equiv_inv_fun → symm_apply, -to_equiv)

/-- Identity map is a relation isomorphism. -/
@[refl, simps apply] protected def refl (r : α → α → Prop) : r ≃r r :=
⟨equiv.refl _, λ a b, iff.rfl⟩

/-- Composition of two relation isomorphisms is a relation isomorphism. -/
@[trans, simps apply] protected def trans (f₁ : r ≃r s) (f₂ : s ≃r t) : r ≃r t :=
⟨f₁.to_equiv.trans f₂.to_equiv, λ a b, f₂.map_rel_iff.trans f₁.map_rel_iff⟩

instance (r : α → α → Prop) : inhabited (r ≃r r) := ⟨rel_iso.refl _⟩

@[simp] lemma default_def (r : α → α → Prop) : default = rel_iso.refl r := rfl

/-- A relation isomorphism between equal relations on equal types. -/
@[simps to_equiv apply] protected def cast {α β : Type u} {r : α → α → Prop} {s : β → β → Prop}
  (h₁ : α = β) (h₂ : r == s) : r ≃r s :=
⟨equiv.cast h₁, λ a b, by { subst h₁, rw eq_of_heq h₂, refl }⟩

@[simp] protected theorem cast_symm {α β : Type u} {r : α → α → Prop} {s : β → β → Prop}
  (h₁ : α = β) (h₂ : r == s) : (rel_iso.cast h₁ h₂).symm = rel_iso.cast h₁.symm h₂.symm := rfl

@[simp] protected theorem cast_refl {α : Type u} {r : α → α → Prop}
  (h₁ : α = α := rfl) (h₂ : r == r := heq.rfl) : rel_iso.cast h₁ h₂ = rel_iso.refl r := rfl

@[simp] protected theorem cast_trans {α β γ : Type u}
  {r : α → α → Prop} {s : β → β → Prop} {t : γ → γ → Prop} (h₁ : α = β) (h₁' : β = γ)
  (h₂ : r == s) (h₂' : s == t): (rel_iso.cast h₁ h₂).trans (rel_iso.cast h₁' h₂') =
  rel_iso.cast (h₁.trans h₁') (h₂.trans h₂') :=
ext $ λ x, by { subst h₁, refl }

/-- a relation isomorphism is also a relation isomorphism between dual relations. -/
protected def swap (f : r ≃r s) : (swap r) ≃r (swap s) :=
⟨f.to_equiv, λ _ _, f.map_rel_iff⟩

@[simp] theorem coe_fn_symm_mk (f o) : ((@rel_iso.mk _ _ r s f o).symm : β → α) = f.symm :=
rfl

@[simp] theorem apply_symm_apply (e : r ≃r s) (x : β) : e (e.symm x) = x :=
e.to_equiv.apply_symm_apply x

@[simp] theorem symm_apply_apply (e : r ≃r s) (x : α) : e.symm (e x) = x :=
e.to_equiv.symm_apply_apply x

theorem rel_symm_apply (e : r ≃r s) {x y} : r x (e.symm y) ↔ s (e x) y :=
by rw [← e.map_rel_iff, e.apply_symm_apply]

theorem symm_apply_rel (e : r ≃r s) {x y} : r (e.symm x) y ↔ s x (e y) :=
by rw [← e.map_rel_iff, e.apply_symm_apply]

protected lemma bijective (e : r ≃r s) : bijective e := e.to_equiv.bijective
protected lemma injective (e : r ≃r s) : injective e := e.to_equiv.injective
protected lemma surjective (e : r ≃r s) : surjective e := e.to_equiv.surjective

@[simp] lemma eq_iff_eq (f : r ≃r s) {a b} : f a = f b ↔ a = b :=
f.injective.eq_iff

/-- Any equivalence lifts to a relation isomorphism between `s` and its preimage. -/
protected def preimage (f : α ≃ β) (s : β → β → Prop) : f ⁻¹'o s ≃r s := ⟨f, λ a b, iff.rfl⟩

instance is_well_order.preimage {α : Type u} (r : α → α → Prop) [is_well_order α r] (f : β ≃ α) :
  is_well_order β (f ⁻¹'o r) :=
@rel_embedding.is_well_order _ _ (f ⁻¹'o r) r (rel_iso.preimage f r) _

instance is_well_order.ulift {α : Type u} (r : α → α → Prop) [is_well_order α r] :
  is_well_order (ulift α) (ulift.down ⁻¹'o r) :=
is_well_order.preimage r equiv.ulift

/-- A surjective relation embedding is a relation isomorphism. -/
@[simps apply]
noncomputable def of_surjective (f : r ↪r s) (H : surjective f) : r ≃r s :=
⟨equiv.of_bijective f ⟨f.injective, H⟩, λ a b, f.map_rel_iff⟩

/--
Given relation isomorphisms `r₁ ≃r s₁` and `r₂ ≃r s₂`, construct a relation isomorphism for the
lexicographic orders on the sum.
-/
def sum_lex_congr {α₁ α₂ β₁ β₂ r₁ r₂ s₁ s₂}
  (e₁ : @rel_iso α₁ β₁ r₁ s₁) (e₂ : @rel_iso α₂ β₂ r₂ s₂) :
  sum.lex r₁ r₂ ≃r sum.lex s₁ s₂ :=
⟨equiv.sum_congr e₁.to_equiv e₂.to_equiv, λ a b,
 by cases e₁ with f hf; cases e₂ with g hg;
    cases a; cases b; simp [hf, hg]⟩

/--
Given relation isomorphisms `r₁ ≃r s₁` and `r₂ ≃r s₂`, construct a relation isomorphism for the
lexicographic orders on the product.
-/
def prod_lex_congr {α₁ α₂ β₁ β₂ r₁ r₂ s₁ s₂}
  (e₁ : @rel_iso α₁ β₁ r₁ s₁) (e₂ : @rel_iso α₂ β₂ r₂ s₂) :
  prod.lex r₁ r₂ ≃r prod.lex s₁ s₂ :=
⟨equiv.prod_congr e₁.to_equiv e₂.to_equiv,
  λ a b, by simp [prod.lex_def, e₁.map_rel_iff, e₂.map_rel_iff]⟩

/-- Two relations on empty types are isomorphic. -/
def rel_iso_of_is_empty (r : α → α → Prop) (s : β → β → Prop) [is_empty α] [is_empty β] : r ≃r s :=
⟨equiv.equiv_of_is_empty α β, is_empty_elim⟩

/-- Two irreflexive relations on a unique type are isomorphic. -/
def rel_iso_of_unique_of_irrefl (r : α → α → Prop) (s : β → β → Prop)
  [is_irrefl α r] [is_irrefl β s] [unique α] [unique β] : r ≃r s :=
⟨equiv.equiv_of_unique α β,
  λ x y, by simp [not_rel_of_subsingleton r, not_rel_of_subsingleton s]⟩

/-- Two reflexive relations on a unique type are isomorphic. -/
def rel_iso_of_unique_of_refl (r : α → α → Prop) (s : β → β → Prop)
  [is_refl α r] [is_refl β s] [unique α] [unique β] : r ≃r s :=
⟨equiv.equiv_of_unique α β,
  λ x y, by simp [rel_of_subsingleton r, rel_of_subsingleton s]⟩

end rel_iso


/-
Copyright (c) 2020 Anne Baanen. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Nathaniel Thomas, Jeremy Avigad, Johannes Hölzl, Mario Carneiro, Anne Baanen,
  Frédéric Dupuis, Heather Macbeth
-/
import algebra.hom.group
import algebra.hom.group_action
import algebra.module.basic
import algebra.module.pi
import algebra.ring.comp_typeclasses
import algebra.star.basic

/-!
# (Semi)linear maps

In this file we define

* `linear_map σ M M₂`, `M →ₛₗ[σ] M₂` : a semilinear map between two `module`s. Here,
  `σ` is a `ring_hom` from `R` to `R₂` and an `f : M →ₛₗ[σ] M₂` satisfies
  `f (c • x) = (σ c) • (f x)`. We recover plain linear maps by choosing `σ` to be `ring_hom.id R`.
  This is denoted by `M →ₗ[R] M₂`. We also add the notation `M →ₗ⋆[R] M₂` for star-linear maps.

* `is_linear_map R f` : predicate saying that `f : M → M₂` is a linear map. (Note that this
  was not generalized to semilinear maps.)

We then provide `linear_map` with the following instances:

* `linear_map.add_comm_monoid` and `linear_map.add_comm_group`: the elementwise addition structures
  corresponding to addition in the codomain
* `linear_map.distrib_mul_action` and `linear_map.module`: the elementwise scalar action structures
  corresponding to applying the action in the codomain.
* `module.End.semiring` and `module.End.ring`: the (semi)ring of endomorphisms formed by taking the
  additive structure above with composition as multiplication.

## Implementation notes

To ensure that composition works smoothly for semilinear maps, we use the typeclasses
`ring_hom_comp_triple`, `ring_hom_inv_pair` and `ring_hom_surjective` from
`algebra/ring/comp_typeclasses`.

## Notation

* Throughout the file, we denote regular linear maps by `fₗ`, `gₗ`, etc, and semilinear maps
  by `f`, `g`, etc.

## TODO

* Parts of this file have not yet been generalized to semilinear maps (i.e. `compatible_smul`)

## Tags

linear map
-/

open function
open_locale big_operators

universes u u' v w x y z
variables {R : Type*} {R₁ : Type*} {R₂ : Type*} {R₃ : Type*}
variables {k : Type*} {S : Type*} {S₃ : Type*} {T : Type*}
variables {M : Type*} {M₁ : Type*} {M₂ : Type*} {M₃ : Type*}
variables {N₁ : Type*} {N₂ : Type*} {N₃ : Type*} {ι : Type*}

/-- A map `f` between modules over a semiring is linear if it satisfies the two properties
`f (x + y) = f x + f y` and `f (c • x) = c • f x`. The predicate `is_linear_map R f` asserts this
property. A bundled version is available with `linear_map`, and should be favored over
`is_linear_map` most of the time. -/
structure is_linear_map (R : Type u) {M : Type v} {M₂ : Type w}
  [semiring R] [add_comm_monoid M] [add_comm_monoid M₂] [module R M] [module R M₂]
  (f : M → M₂) : Prop :=
(map_add : ∀ x y, f (x + y) = f x + f y)
(map_smul : ∀ (c : R) x, f (c • x) = c • f x)

section

set_option old_structure_cmd true

/-- A map `f` between an `R`-module and an `S`-module over a ring homomorphism `σ : R →+* S`
is semilinear if it satisfies the two properties `f (x + y) = f x + f y` and
`f (c • x) = (σ c) • f x`. Elements of `linear_map σ M M₂` (available under the notation
`M →ₛₗ[σ] M₂`) are bundled versions of such maps. For plain linear maps (i.e. for which
`σ = ring_hom.id R`), the notation `M →ₗ[R] M₂` is available. An unbundled version of plain linear
maps is available with the predicate `is_linear_map`, but it should be avoided most of the time. -/
structure linear_map {R : Type*} {S : Type*} [semiring R] [semiring S] (σ : R →+* S)
  (M : Type*) (M₂ : Type*)
  [add_comm_monoid M] [add_comm_monoid M₂] [module R M] [module S M₂]
  extends add_hom M M₂ :=
(map_smul' : ∀ (r : R) (x : M), to_fun (r • x) = (σ r) • to_fun x)

end

/-- The `add_hom` underlying a `linear_map`. -/
add_decl_doc linear_map.to_add_hom

notation M ` →ₛₗ[`:25 σ:25 `] `:0 M₂:0 := linear_map σ M M₂
notation M ` →ₗ[`:25 R:25 `] `:0 M₂:0 := linear_map (ring_hom.id R) M M₂
notation M ` →ₗ⋆[`:25 R:25 `] `:0 M₂:0 := linear_map (star_ring_end R) M M₂

namespace linear_map

section add_comm_monoid

variables [semiring R] [semiring S]

section
variables [add_comm_monoid M] [add_comm_monoid M₁] [add_comm_monoid M₂] [add_comm_monoid M₃]
variables [add_comm_monoid N₁] [add_comm_monoid N₂] [add_comm_monoid N₃]
variables [module R M] [module R M₂] [module S M₃]
variables {σ : R →+* S}

instance : add_monoid_hom_class (M →ₛₗ[σ] M₃) M M₃ :=
{ coe := linear_map.to_fun,
  coe_injective' := λ f g h, by cases f; cases g; congr',
  map_add := linear_map.map_add',
  map_zero := λ f, show f.to_fun 0 = 0, by { rw [← zero_smul R (0 : M), f.map_smul'], simp } }

/-- The `distrib_mul_action_hom` underlying a `linear_map`. -/
def to_distrib_mul_action_hom (f : M →ₗ[R] M₂) : distrib_mul_action_hom R M M₂ :=
{ map_zero' := show f 0 = 0, from map_zero f, ..f }

/-- Helper instance for when there's too many metavariables to apply `fun_like.has_coe_to_fun`
directly.
-/
instance : has_coe_to_fun (M →ₛₗ[σ] M₃) (λ _, M → M₃) := ⟨linear_map.to_fun⟩

@[simp] lemma to_fun_eq_coe {f : M →ₛₗ[σ] M₃} : f.to_fun = (f : M → M₃) := rfl

@[ext] theorem ext {f g : M →ₛₗ[σ] M₃} (h : ∀ x, f x = g x) : f = g := fun_like.ext f g h

/-- Copy of a `linear_map` with a new `to_fun` equal to the old one. Useful to fix definitional
equalities. -/
protected def copy (f : M →ₛₗ[σ] M₃) (f' : M → M₃) (h : f' = ⇑f) : M →ₛₗ[σ] M₃ :=
{ to_fun := f',
  map_add' := h.symm ▸ f.map_add',
  map_smul' := h.symm ▸ f.map_smul' }

initialize_simps_projections linear_map (to_fun → apply)

@[simp] lemma coe_mk {σ : R →+* S} (f : M → M₃) (h₁ h₂) :
  ((linear_map.mk f h₁ h₂ : M →ₛₗ[σ] M₃) : M → M₃) = f := rfl

/-- Identity map as a `linear_map` -/
def id : M →ₗ[R] M :=
{ to_fun := id, ..distrib_mul_action_hom.id R }

lemma id_apply (x : M) :
  @id R M _ _ _ x = x := rfl

@[simp, norm_cast] lemma id_coe : ((linear_map.id : M →ₗ[R] M) : M → M) = _root_.id := rfl

end

section
variables [add_comm_monoid M] [add_comm_monoid M₁] [add_comm_monoid M₂] [add_comm_monoid M₃]
variables [add_comm_monoid N₁] [add_comm_monoid N₂] [add_comm_monoid N₃]
variables [module R M] [module R M₂] [module S M₃]
variables (σ : R →+* S)
variables (fₗ gₗ : M →ₗ[R] M₂) (f g : M →ₛₗ[σ] M₃)

theorem is_linear : is_linear_map R fₗ := ⟨fₗ.map_add', fₗ.map_smul'⟩

variables {fₗ gₗ f g σ}

theorem coe_injective : @injective (M →ₛₗ[σ] M₃) (M → M₃) coe_fn :=
fun_like.coe_injective

protected lemma congr_arg {x x' : M} : x = x' → f x = f x' :=
fun_like.congr_arg f

/-- If two linear maps are equal, they are equal at each point. -/
protected lemma congr_fun (h : f = g) (x : M) : f x = g x :=
fun_like.congr_fun h x

theorem ext_iff : f = g ↔ ∀ x, f x = g x :=
fun_like.ext_iff

@[simp] lemma mk_coe (f : M →ₛₗ[σ] M₃) (h₁ h₂) :
  (linear_map.mk f h₁ h₂ : M →ₛₗ[σ] M₃) = f := ext $ λ _, rfl

variables (fₗ gₗ f g)

protected lemma map_add (x y : M) : f (x + y) = f x + f y := map_add f x y

@[simp] lemma map_smulₛₗ (c : R) (x : M) : f (c • x) = (σ c) • f x := f.map_smul' c x

lemma map_smul (c : R) (x : M) : fₗ (c • x) = c • fₗ x := fₗ.map_smul' c x

lemma map_smul_inv {σ' : S →+* R} [ring_hom_inv_pair σ σ'] (c : S) (x : M) :
  c • f x = f (σ' c • x) :=
by simp

protected lemma map_zero : f 0 = 0 := map_zero f

-- TODO: generalize to `zero_hom_class`
@[simp] lemma map_eq_zero_iff (h : function.injective f) {x : M} : f x = 0 ↔ x = 0 :=
⟨λ w, by { apply h, simp [w], }, λ w, by { subst w, simp, }⟩

section pointwise
open_locale pointwise

@[simp] lemma image_smul_setₛₗ (c : R) (s : set M) :
  f '' (c • s) = (σ c) • f '' s :=
begin
  apply set.subset.antisymm,
  { rintros x ⟨y, ⟨z, zs, rfl⟩, rfl⟩,
    exact ⟨f z, set.mem_image_of_mem _ zs, (f.map_smulₛₗ _ _).symm ⟩ },
  { rintros x ⟨y, ⟨z, hz, rfl⟩, rfl⟩,
    exact (set.mem_image _ _ _).2 ⟨c • z, set.smul_mem_smul_set hz, f.map_smulₛₗ _ _⟩ }
end

lemma image_smul_set (c : R) (s : set M) :
  fₗ '' (c • s) = c • fₗ '' s :=
by simp

lemma preimage_smul_setₛₗ {c : R} (hc : is_unit c) (s : set M₃) :
  f ⁻¹' (σ c • s) = c • f ⁻¹' s :=
begin
  apply set.subset.antisymm,
  { rintros x ⟨y, ys, hy⟩,
    refine ⟨(hc.unit.inv : R) • x, _, _⟩,
    { simp only [←hy, smul_smul, set.mem_preimage, units.inv_eq_coe_inv, map_smulₛₗ, ← σ.map_mul,
        is_unit.coe_inv_mul, one_smul, ring_hom.map_one, ys] },
    { simp only [smul_smul, is_unit.mul_coe_inv, one_smul, units.inv_eq_coe_inv] } },
  { rintros x ⟨y, hy, rfl⟩,
    refine ⟨f y, hy, by simp only [ring_hom.id_apply, linear_map.map_smulₛₗ]⟩ }
end

lemma preimage_smul_set {c : R} (hc : is_unit c) (s : set M₂) :
  fₗ ⁻¹' (c • s) = c • fₗ ⁻¹' s :=
fₗ.preimage_smul_setₛₗ hc s

end pointwise

variables (M M₂)
/--
A typeclass for `has_scalar` structures which can be moved through a `linear_map`.
This typeclass is generated automatically from a `is_scalar_tower` instance, but exists so that
we can also add an instance for `add_comm_group.int_module`, allowing `z •` to be moved even if
`R` does not support negation.
-/
class compatible_smul (R S : Type*) [semiring S] [has_scalar R M]
  [module S M] [has_scalar R M₂] [module S M₂] :=
(map_smul : ∀ (fₗ : M →ₗ[S] M₂) (c : R) (x : M), fₗ (c • x) = c • fₗ x)
variables {M M₂}

@[priority 100]
instance is_scalar_tower.compatible_smul
  {R S : Type*} [semiring S] [has_scalar R S]
  [has_scalar R M] [module S M] [is_scalar_tower R S M]
  [has_scalar R M₂] [module S M₂] [is_scalar_tower R S M₂] : compatible_smul M M₂ R S :=
⟨λ fₗ c x, by rw [← smul_one_smul S c x, ← smul_one_smul S c (fₗ x), map_smul]⟩

@[simp, priority 900]
lemma map_smul_of_tower {R S : Type*} [semiring S] [has_scalar R M]
  [module S M] [has_scalar R M₂] [module S M₂]
  [compatible_smul M M₂ R S] (fₗ : M →ₗ[S] M₂) (c : R) (x : M) :
  fₗ (c • x) = c • fₗ x :=
compatible_smul.map_smul fₗ c x

/-- convert a linear map to an additive map -/
def to_add_monoid_hom : M →+ M₃ :=
{ to_fun := f,
  map_zero' := f.map_zero,
  map_add' := f.map_add }

@[simp] lemma to_add_monoid_hom_coe : ⇑f.to_add_monoid_hom = f := rfl

section restrict_scalars

variables (R) [module S M] [module S M₂] [compatible_smul M M₂ R S]

/-- If `M` and `M₂` are both `R`-modules and `S`-modules and `R`-module structures
are defined by an action of `R` on `S` (formally, we have two scalar towers), then any `S`-linear
map from `M` to `M₂` is `R`-linear.

See also `linear_map.map_smul_of_tower`. -/
def restrict_scalars (fₗ : M →ₗ[S] M₂) : M →ₗ[R] M₂ :=
{ to_fun := fₗ,
  map_add' := fₗ.map_add,
  map_smul' := fₗ.map_smul_of_tower }

@[simp] lemma coe_restrict_scalars (fₗ : M →ₗ[S] M₂) : ⇑(restrict_scalars R fₗ) = fₗ :=
rfl

lemma restrict_scalars_apply (fₗ : M →ₗ[S] M₂) (x) : restrict_scalars R fₗ x = fₗ x :=
rfl

lemma restrict_scalars_injective :
  function.injective (restrict_scalars R : (M →ₗ[S] M₂) → (M →ₗ[R] M₂)) :=
λ fₗ gₗ h, ext (linear_map.congr_fun h : _)

@[simp]
lemma restrict_scalars_inj (fₗ gₗ : M →ₗ[S] M₂) :
  fₗ.restrict_scalars R = gₗ.restrict_scalars R ↔ fₗ = gₗ :=
(restrict_scalars_injective R).eq_iff

end restrict_scalars

variable {R}

@[simp] lemma map_sum {ι} {t : finset ι} {g : ι → M} :
  f (∑ i in t, g i) = (∑ i in t, f (g i)) :=
f.to_add_monoid_hom.map_sum _ _

theorem to_add_monoid_hom_injective :
  function.injective (to_add_monoid_hom : (M →ₛₗ[σ] M₃) → (M →+ M₃)) :=
λ f g h, ext $ add_monoid_hom.congr_fun h

/-- If two `σ`-linear maps from `R` are equal on `1`, then they are equal. -/
@[ext] theorem ext_ring {f g : R →ₛₗ[σ] M₃} (h : f 1 = g 1) : f = g :=
ext $ λ x, by rw [← mul_one x, ← smul_eq_mul, f.map_smulₛₗ, g.map_smulₛₗ, h]

theorem ext_ring_iff {σ : R →+* R} {f g : R →ₛₗ[σ] M} : f = g ↔ f 1 = g 1 :=
⟨λ h, h ▸ rfl, ext_ring⟩

end

/-- Interpret a `ring_hom` `f` as an `f`-semilinear map. -/
@[simps]
def _root_.ring_hom.to_semilinear_map (f : R →+* S) : R →ₛₗ[f] S :=
{ to_fun := f,
  map_smul' := f.map_mul,
  .. f}

section

variables [semiring R₁] [semiring R₂] [semiring R₃]
variables [add_comm_monoid M] [add_comm_monoid M₁] [add_comm_monoid M₂] [add_comm_monoid M₃]
variables {module_M₁ : module R₁ M₁} {module_M₂ : module R₂ M₂} {module_M₃ : module R₃ M₃}
variables {σ₁₂ : R₁ →+* R₂} {σ₂₃ : R₂ →+* R₃} {σ₁₃ : R₁ →+* R₃}
variables [ring_hom_comp_triple σ₁₂ σ₂₃ σ₁₃]
variables (f : M₂ →ₛₗ[σ₂₃] M₃) (g : M₁ →ₛₗ[σ₁₂] M₂)

include module_M₁ module_M₂ module_M₃
/-- Composition of two linear maps is a linear map -/
def comp : M₁ →ₛₗ[σ₁₃] M₃ :=
{ to_fun := f ∘ g,
  map_add' := by simp only [map_add, forall_const, eq_self_iff_true, comp_app],
  map_smul' := λ r x, by rw [comp_app, map_smulₛₗ, map_smulₛₗ, ring_hom_comp_triple.comp_apply] }
omit module_M₁ module_M₂ module_M₃

infixr ` ∘ₗ `:80 := @linear_map.comp _ _ _ _ _ _ _ _ _ _ _ _ _ _ _
  (ring_hom.id _) (ring_hom.id _) (ring_hom.id _) ring_hom_comp_triple.ids

include σ₁₃
lemma comp_apply (x : M₁) : f.comp g x = f (g x) := rfl
omit σ₁₃

include σ₁₃
@[simp, norm_cast] lemma coe_comp : (f.comp g : M₁ → M₃) = f ∘ g := rfl
omit σ₁₃

@[simp] theorem comp_id : f.comp id = f :=
linear_map.ext $ λ x, rfl

@[simp] theorem id_comp : id.comp f = f :=
linear_map.ext $ λ x, rfl

end

variables [add_comm_monoid M] [add_comm_monoid M₁] [add_comm_monoid M₂] [add_comm_monoid M₃]

/-- If a function `g` is a left and right inverse of a linear map `f`, then `g` is linear itself. -/
def inverse [module R M] [module S M₂] {σ : R →+* S} {σ' : S →+* R} [ring_hom_inv_pair σ σ']
  (f : M →ₛₗ[σ] M₂) (g : M₂ → M) (h₁ : left_inverse g f) (h₂ : right_inverse g f) :
  M₂ →ₛₗ[σ'] M :=
by dsimp [left_inverse, function.right_inverse] at h₁ h₂; exact
  { to_fun := g,
    map_add' := λ x y, by { rw [← h₁ (g (x + y)), ← h₁ (g x + g y)]; simp [h₂] },
    map_smul' := λ a b, by { rw [← h₁ (g (a • b)), ← h₁ ((σ' a) • g b)], simp [h₂] } }

end add_comm_monoid

section add_comm_group

variables [semiring R] [semiring S] [add_comm_group M] [add_comm_group M₂]
variables {module_M : module R M} {module_M₂ : module S M₂} {σ : R →+* S}
variables (f : M →ₛₗ[σ] M₂)

protected lemma map_neg (x : M) : f (- x) = - f x := map_neg f x

protected lemma map_sub (x y : M) : f (x - y) = f x - f y := map_sub f x y

instance compatible_smul.int_module
  {S : Type*} [semiring S] [module S M] [module S M₂] : compatible_smul M M₂ ℤ S :=
⟨λ fₗ c x, begin
  induction c using int.induction_on,
  case hz : { simp },
  case hp : n ih { simp [add_smul, ih] },
  case hn : n ih { simp [sub_smul, ih] }
end⟩

instance compatible_smul.units {R S : Type*}
  [monoid R] [mul_action R M] [mul_action R M₂] [semiring S] [module S M] [module S M₂]
  [compatible_smul M M₂ R S] :
  compatible_smul M M₂ Rˣ S :=
⟨λ fₗ c x, (compatible_smul.map_smul fₗ (c : R) x : _)⟩

end add_comm_group

end linear_map

namespace module

/-- `g : R →+* S` is `R`-linear when the module structure on `S` is `module.comp_hom S g` . -/
@[simps]
def comp_hom.to_linear_map {R S : Type*} [semiring R] [semiring S] (g : R →+* S) :
  (by haveI := comp_hom S g; exact (R →ₗ[R] S)) :=
by exact
{ to_fun := (g : R → S),
  map_add' := g.map_add,
  map_smul' := g.map_mul }

end module

namespace distrib_mul_action_hom

variables [semiring R] [add_comm_monoid M] [add_comm_monoid M₂] [module R M] [module R M₂]

/-- A `distrib_mul_action_hom` between two modules is a linear map. -/
def to_linear_map (fₗ : M →+[R] M₂) : M →ₗ[R] M₂ := { ..fₗ }

instance : has_coe (M →+[R] M₂) (M →ₗ[R] M₂) := ⟨to_linear_map⟩

@[simp] lemma to_linear_map_eq_coe (f : M →+[R] M₂) :
  f.to_linear_map = ↑f :=
rfl

@[simp, norm_cast] lemma coe_to_linear_map (f : M →+[R] M₂) :
  ((f : M →ₗ[R] M₂) : M → M₂) = f :=
rfl

lemma to_linear_map_injective {f g : M →+[R] M₂} (h : (f : M →ₗ[R] M₂) = (g : M →ₗ[R] M₂)) :
  f = g :=
by { ext m, exact linear_map.congr_fun h m, }

end distrib_mul_action_hom

namespace is_linear_map

section add_comm_monoid
variables [semiring R] [add_comm_monoid M] [add_comm_monoid M₂]
variables [module R M] [module R M₂]
include R

/-- Convert an `is_linear_map` predicate to a `linear_map` -/
def mk' (f : M → M₂) (H : is_linear_map R f) : M →ₗ[R] M₂ :=
{ to_fun := f, map_add' := H.1, map_smul' := H.2 }

@[simp] theorem mk'_apply {f : M → M₂} (H : is_linear_map R f) (x : M) :
  mk' f H x = f x := rfl

lemma is_linear_map_smul {R M : Type*} [comm_semiring R] [add_comm_monoid M] [module R M]
  (c : R) :
  is_linear_map R (λ (z : M), c • z) :=
begin
  refine is_linear_map.mk (smul_add c) _,
  intros _ _,
  simp only [smul_smul, mul_comm]
end

lemma is_linear_map_smul' {R M : Type*} [semiring R] [add_comm_monoid M] [module R M] (a : M) :
  is_linear_map R (λ (c : R), c • a) :=
is_linear_map.mk (λ x y, add_smul x y a) (λ x y, mul_smul x y a)

variables {f : M → M₂} (lin : is_linear_map R f)
include M M₂ lin

lemma map_zero : f (0 : M) = (0 : M₂) := (lin.mk' f).map_zero

end add_comm_monoid

section add_comm_group

variables [semiring R] [add_comm_group M] [add_comm_group M₂]
variables [module R M] [module R M₂]
include R

lemma is_linear_map_neg :
  is_linear_map R (λ (z : M), -z) :=
is_linear_map.mk neg_add (λ x y, (smul_neg x y).symm)

variables {f : M → M₂} (lin : is_linear_map R f)
include M M₂ lin

lemma map_neg (x : M) : f (- x) = - f x := (lin.mk' f).map_neg x

lemma map_sub (x y) : f (x - y) = f x - f y := (lin.mk' f).map_sub x y

end add_comm_group

end is_linear_map

/-- Linear endomorphisms of a module, with associated ring structure
`module.End.semiring` and algebra structure `module.End.algebra`. -/
abbreviation module.End (R : Type u) (M : Type v)
  [semiring R] [add_comm_monoid M] [module R M] := M →ₗ[R] M

/-- Reinterpret an additive homomorphism as a `ℕ`-linear map. -/
def add_monoid_hom.to_nat_linear_map [add_comm_monoid M] [add_comm_monoid M₂] (f : M →+ M₂) :
  M →ₗ[ℕ] M₂ :=
{ to_fun := f, map_add' := f.map_add, map_smul' := f.map_nat_module_smul }

lemma add_monoid_hom.to_nat_linear_map_injective [add_comm_monoid M] [add_comm_monoid M₂] :
  function.injective (@add_monoid_hom.to_nat_linear_map M M₂ _ _) :=
by { intros f g h, ext, exact linear_map.congr_fun h x }

/-- Reinterpret an additive homomorphism as a `ℤ`-linear map. -/
def add_monoid_hom.to_int_linear_map [add_comm_group M] [add_comm_group M₂] (f : M →+ M₂) :
  M →ₗ[ℤ] M₂ :=
{ to_fun := f, map_add' := f.map_add, map_smul' := f.map_int_module_smul }

lemma add_monoid_hom.to_int_linear_map_injective [add_comm_group M] [add_comm_group M₂] :
  function.injective (@add_monoid_hom.to_int_linear_map M M₂ _ _) :=
by { intros f g h, ext, exact linear_map.congr_fun h x }

@[simp] lemma add_monoid_hom.coe_to_int_linear_map [add_comm_group M] [add_comm_group M₂]
  (f : M →+ M₂) :
  ⇑f.to_int_linear_map = f := rfl

/-- Reinterpret an additive homomorphism as a `ℚ`-linear map. -/
def add_monoid_hom.to_rat_linear_map [add_comm_group M] [module ℚ M]
  [add_comm_group M₂] [module ℚ M₂] (f : M →+ M₂) :
  M →ₗ[ℚ] M₂ :=
{ map_smul' := f.map_rat_module_smul, ..f }

lemma add_monoid_hom.to_rat_linear_map_injective
  [add_comm_group M] [module ℚ M] [add_comm_group M₂] [module ℚ M₂] :
  function.injective (@add_monoid_hom.to_rat_linear_map M M₂ _ _ _ _) :=
by { intros f g h, ext, exact linear_map.congr_fun h x }

@[simp] lemma add_monoid_hom.coe_to_rat_linear_map [add_comm_group M] [module ℚ M]
  [add_comm_group M₂] [module ℚ M₂] (f : M →+ M₂) :
  ⇑f.to_rat_linear_map = f := rfl

namespace linear_map

section has_scalar

variables [semiring R] [semiring R₂] [semiring R₃]
variables [add_comm_monoid M] [add_comm_monoid M₂] [add_comm_monoid M₃]
variables [module R M] [module R₂ M₂] [module R₃ M₃]
variables {σ₁₂ : R →+* R₂} {σ₂₃ : R₂ →+* R₃} {σ₁₃ : R →+* R₃} [ring_hom_comp_triple σ₁₂ σ₂₃ σ₁₃]
variables [monoid S] [distrib_mul_action S M₂] [smul_comm_class R₂ S M₂]
variables [monoid S₃] [distrib_mul_action S₃ M₃] [smul_comm_class R₃ S₃ M₃]
variables [monoid T] [distrib_mul_action T M₂] [smul_comm_class R₂ T M₂]

instance : has_scalar S (M →ₛₗ[σ₁₂] M₂) :=
⟨λ a f, { to_fun := a • f,
          map_add' := λ x y, by simp only [pi.smul_apply, f.map_add, smul_add],
          map_smul' := λ c x, by simp [pi.smul_apply, smul_comm (σ₁₂ c)] }⟩

@[simp] lemma smul_apply (a : S) (f : M →ₛₗ[σ₁₂] M₂) (x : M) : (a • f) x = a • f x := rfl

lemma coe_smul (a : S) (f : M →ₛₗ[σ₁₂] M₂) : ⇑(a • f) = a • f := rfl

instance [smul_comm_class S T M₂] : smul_comm_class S T (M →ₛₗ[σ₁₂] M₂) :=
⟨λ a b f, ext $ λ x, smul_comm _ _ _⟩

-- example application of this instance: if S -> T -> R are homomorphisms of commutative rings and
-- M and M₂ are R-modules then the S-module and T-module structures on Hom_R(M,M₂) are compatible.
instance [has_scalar S T] [is_scalar_tower S T M₂] : is_scalar_tower S T (M →ₛₗ[σ₁₂] M₂) :=
{ smul_assoc := λ _ _ _, ext $ λ _, smul_assoc _ _ _ }

instance [distrib_mul_action Sᵐᵒᵖ M₂] [smul_comm_class R₂ Sᵐᵒᵖ M₂] [is_central_scalar S M₂] :
  is_central_scalar S (M →ₛₗ[σ₁₂] M₂) :=
{ op_smul_eq_smul := λ a b, ext $ λ x, op_smul_eq_smul _ _ }

end has_scalar

/-! ### Arithmetic on the codomain -/
section arithmetic

variables [semiring R₁] [semiring R₂] [semiring R₃]
variables [add_comm_monoid M] [add_comm_monoid M₂] [add_comm_monoid M₃]
variables [add_comm_group N₁] [add_comm_group N₂] [add_comm_group N₃]
variables [module R₁ M] [module R₂ M₂] [module R₃ M₃]
variables [module R₁ N₁] [module R₂ N₂] [module R₃ N₃]
variables {σ₁₂ : R₁ →+* R₂} {σ₂₃ : R₂ →+* R₃} {σ₁₃ : R₁ →+* R₃} [ring_hom_comp_triple σ₁₂ σ₂₃ σ₁₃]

/-- The constant 0 map is linear. -/
instance : has_zero (M →ₛₗ[σ₁₂] M₂) :=
⟨{ to_fun := 0, map_add' := by simp, map_smul' := by simp }⟩

@[simp] lemma zero_apply (x : M) : (0 : M →ₛₗ[σ₁₂] M₂) x = 0 := rfl

@[simp] theorem comp_zero (g : M₂ →ₛₗ[σ₂₃] M₃) : (g.comp (0 : M →ₛₗ[σ₁₂] M₂) : M →ₛₗ[σ₁₃] M₃) = 0 :=
ext $ assume c, by rw [comp_apply, zero_apply, zero_apply, g.map_zero]

@[simp] theorem zero_comp (f : M →ₛₗ[σ₁₂] M₂) : ((0 : M₂ →ₛₗ[σ₂₃] M₃).comp f : M →ₛₗ[σ₁₃] M₃) = 0 :=
rfl

instance : inhabited (M →ₛₗ[σ₁₂] M₂) := ⟨0⟩

@[simp] lemma default_def : (default : (M →ₛₗ[σ₁₂] M₂)) = 0 := rfl

/-- The sum of two linear maps is linear. -/
instance : has_add (M →ₛₗ[σ₁₂] M₂) :=
⟨λ f g, { to_fun := f + g,
          map_add' := by simp [add_comm, add_left_comm], map_smul' := by simp [smul_add] }⟩

@[simp] lemma add_apply (f g : M →ₛₗ[σ₁₂] M₂) (x : M) : (f + g) x = f x + g x := rfl

lemma add_comp (f : M →ₛₗ[σ₁₂] M₂) (g h : M₂ →ₛₗ[σ₂₃] M₃) :
  ((h + g).comp f : M →ₛₗ[σ₁₃] M₃) = h.comp f + g.comp f := rfl

lemma comp_add (f g : M →ₛₗ[σ₁₂] M₂) (h : M₂ →ₛₗ[σ₂₃] M₃) :
  (h.comp (f + g) : M →ₛₗ[σ₁₃] M₃) = h.comp f + h.comp g :=
ext $ λ _, h.map_add _ _

/-- The type of linear maps is an additive monoid. -/
instance : add_comm_monoid (M →ₛₗ[σ₁₂] M₂) :=
fun_like.coe_injective.add_comm_monoid _ rfl (λ _ _, rfl) (λ _ _, rfl)

/-- The negation of a linear map is linear. -/
instance : has_neg (M →ₛₗ[σ₁₂] N₂) :=
⟨λ f, { to_fun := -f, map_add' := by simp [add_comm], map_smul' := by simp }⟩

@[simp] lemma neg_apply (f : M →ₛₗ[σ₁₂] N₂) (x : M) : (- f) x = - f x := rfl

include σ₁₃
@[simp] lemma neg_comp (f : M →ₛₗ[σ₁₂] M₂) (g : M₂ →ₛₗ[σ₂₃] N₃) : (- g).comp f = - g.comp f := rfl

@[simp] lemma comp_neg (f : M →ₛₗ[σ₁₂] N₂) (g : N₂ →ₛₗ[σ₂₃] N₃) : g.comp (- f) = - g.comp f :=
ext $ λ _, g.map_neg _
omit σ₁₃

/-- The negation of a linear map is linear. -/
instance : has_sub (M →ₛₗ[σ₁₂] N₂) :=
⟨λ f g, { to_fun := f - g,
          map_add' := λ x y, by simp only [pi.sub_apply, map_add, add_sub_comm],
          map_smul' := λ r x, by simp [pi.sub_apply, map_smul, smul_sub] }⟩

@[simp] lemma sub_apply (f g : M →ₛₗ[σ₁₂] N₂) (x : M) : (f - g) x = f x - g x := rfl

include σ₁₃
lemma sub_comp (f : M →ₛₗ[σ₁₂] M₂) (g h : M₂ →ₛₗ[σ₂₃] N₃) :
  (g - h).comp f = g.comp f - h.comp f := rfl

lemma comp_sub (f g : M →ₛₗ[σ₁₂] N₂) (h : N₂ →ₛₗ[σ₂₃] N₃) :
  h.comp (g - f) = h.comp g - h.comp f :=
ext $ λ _, h.map_sub _ _
omit σ₁₃

/-- The type of linear maps is an additive group. -/
instance : add_comm_group (M →ₛₗ[σ₁₂] N₂) :=
fun_like.coe_injective.add_comm_group _
  rfl (λ _ _, rfl) (λ _, rfl) (λ _ _, rfl) (λ _ _, rfl)  (λ _ _, rfl)

end arithmetic

section actions

variables [semiring R] [semiring R₂] [semiring R₃]
variables [add_comm_monoid M] [add_comm_monoid M₂] [add_comm_monoid M₃]
variables [module R M] [module R₂ M₂] [module R₃ M₃]
variables {σ₁₂ : R →+* R₂} {σ₂₃ : R₂ →+* R₃} {σ₁₃ : R →+* R₃} [ring_hom_comp_triple σ₁₂ σ₂₃ σ₁₃]

section has_scalar
variables [monoid S] [distrib_mul_action S M₂] [smul_comm_class R₂ S M₂]
variables [monoid S₃] [distrib_mul_action S₃ M₃] [smul_comm_class R₃ S₃ M₃]
variables [monoid T] [distrib_mul_action T M₂] [smul_comm_class R₂ T M₂]

instance : distrib_mul_action S (M →ₛₗ[σ₁₂] M₂) :=
{ one_smul := λ f, ext $ λ _, one_smul _ _,
  mul_smul := λ c c' f, ext $ λ _, mul_smul _ _ _,
  smul_add := λ c f g, ext $ λ x, smul_add _ _ _,
  smul_zero := λ c, ext $ λ x, smul_zero _ }

include σ₁₃
theorem smul_comp (a : S₃) (g : M₂ →ₛₗ[σ₂₃] M₃) (f : M →ₛₗ[σ₁₂] M₂) :
  (a • g).comp f = a • (g.comp f) := rfl
omit σ₁₃

-- TODO: generalize this to semilinear maps
theorem comp_smul [module R M₂] [module R M₃] [smul_comm_class R S M₂] [distrib_mul_action S M₃]
  [smul_comm_class R S M₃] [compatible_smul M₃ M₂ S R]
  (g : M₃ →ₗ[R] M₂) (a : S) (f : M →ₗ[R] M₃) : g.comp (a • f) = a • (g.comp f) :=
ext $ λ x, g.map_smul_of_tower _ _

end has_scalar

section module
variables [semiring S] [module S M₂] [smul_comm_class R₂ S M₂]

instance : module S (M →ₛₗ[σ₁₂] M₂) :=
{ add_smul := λ a b f, ext $ λ x, add_smul _ _ _,
  zero_smul := λ f, ext $ λ x, zero_smul _ _ }

instance [no_zero_smul_divisors S M₂] : no_zero_smul_divisors S (M →ₛₗ[σ₁₂] M₂) :=
coe_injective.no_zero_smul_divisors _ rfl coe_smul

end module

end actions

/-!
### Monoid structure of endomorphisms

Lemmas about `pow` such as `linear_map.pow_apply` appear in later files.
-/
section endomorphisms

variables [semiring R] [add_comm_monoid M] [add_comm_group N₁] [module R M] [module R N₁]

instance : has_one (module.End R M) := ⟨linear_map.id⟩
instance : has_mul (module.End R M) := ⟨linear_map.comp⟩

lemma one_eq_id : (1 : module.End R M) = id := rfl
lemma mul_eq_comp (f g : module.End R M) : f * g = f.comp g := rfl

@[simp] lemma one_apply (x : M) : (1 : module.End R M) x = x := rfl
@[simp] lemma mul_apply (f g : module.End R M) (x : M) : (f * g) x = f (g x) := rfl

lemma coe_one : ⇑(1 : module.End R M) = _root_.id := rfl
lemma coe_mul (f g : module.End R M) : ⇑(f * g) = f ∘ g := rfl

instance _root_.module.End.monoid : monoid (module.End R M) :=
{ mul := (*),
  one := (1 : M →ₗ[R] M),
  mul_assoc := λ f g h, linear_map.ext $ λ x, rfl,
  mul_one := comp_id,
  one_mul := id_comp }

instance _root_.module.End.semiring : semiring (module.End R M) :=
{ mul := (*),
  one := (1 : M →ₗ[R] M),
  zero := 0,
  add := (+),
  npow := @npow_rec _ ⟨(1 : M →ₗ[R] M)⟩ ⟨(*)⟩,
  mul_zero := comp_zero,
  zero_mul := zero_comp,
  left_distrib := λ f g h, comp_add _ _ _,
  right_distrib := λ f g h, add_comp _ _ _,
  .. _root_.module.End.monoid,
  .. linear_map.add_comm_monoid }

instance _root_.module.End.ring : ring (module.End R N₁) :=
{ ..module.End.semiring, ..linear_map.add_comm_group }

section
variables [monoid S] [distrib_mul_action S M] [smul_comm_class R S M]

instance _root_.module.End.is_scalar_tower :
  is_scalar_tower S (module.End R M) (module.End R M) := ⟨smul_comp⟩

instance _root_.module.End.smul_comm_class [has_scalar S R] [is_scalar_tower S R M] :
  smul_comm_class S (module.End R M) (module.End R M) :=
⟨λ s _ _, (comp_smul _ s _).symm⟩

instance _root_.module.End.smul_comm_class' [has_scalar S R] [is_scalar_tower S R M] :
  smul_comm_class (module.End R M) S (module.End R M) :=
smul_comm_class.symm _ _ _

end

/-! ### Action by a module endomorphism. -/

/-- The tautological action by `module.End R M` (aka `M →ₗ[R] M`) on `M`.

This generalizes `function.End.apply_mul_action`. -/
instance apply_module : module (module.End R M) M :=
{ smul := ($),
  smul_zero := linear_map.map_zero,
  smul_add := linear_map.map_add,
  add_smul := linear_map.add_apply,
  zero_smul := (linear_map.zero_apply : ∀ m, (0 : M →ₗ[R] M) m = 0),
  one_smul := λ _, rfl,
  mul_smul := λ _ _ _, rfl }

@[simp] protected lemma smul_def (f : module.End R M) (a : M) : f • a = f a := rfl

/-- `linear_map.apply_module` is faithful. -/
instance apply_has_faithful_scalar : has_faithful_scalar (module.End R M) M :=
⟨λ _ _, linear_map.ext⟩

instance apply_smul_comm_class : smul_comm_class R (module.End R M) M :=
{ smul_comm := λ r e m, (e.map_smul r m).symm }

instance apply_smul_comm_class' : smul_comm_class (module.End R M) R M :=
{ smul_comm := linear_map.map_smul }

instance apply_is_scalar_tower {R M : Type*} [comm_semiring R] [add_comm_monoid M] [module R M] :
  is_scalar_tower R (module.End R M) M :=
⟨λ t f m, rfl⟩

end endomorphisms

end linear_map

/-! ### Actions as module endomorphisms -/

namespace distrib_mul_action

variables (R M) [semiring R] [add_comm_monoid M] [module R M]
variables [monoid S] [distrib_mul_action S M] [smul_comm_class S R M]

/-- Each element of the monoid defines a linear map.

This is a stronger version of `distrib_mul_action.to_add_monoid_hom`. -/
@[simps]
def to_linear_map (s : S) : M →ₗ[R] M :=
{ to_fun := has_scalar.smul s,
  map_add' := smul_add s,
  map_smul' := λ a b, smul_comm _ _ _ }

/-- Each element of the monoid defines a module endomorphism.

This is a stronger version of `distrib_mul_action.to_add_monoid_End`. -/
@[simps]
def to_module_End : S →* module.End R M :=
{ to_fun := to_linear_map R M,
  map_one' := linear_map.ext $ one_smul _,
  map_mul' := λ a b, linear_map.ext $ mul_smul _ _ }

end distrib_mul_action

namespace module

variables (R M) [semiring R] [add_comm_monoid M] [module R M]
variables [semiring S] [module S M] [smul_comm_class S R M]

/-- Each element of the monoid defines a module endomorphism.

This is a stronger version of `distrib_mul_action.to_module_End`. -/
@[simps]
def to_module_End : S →+* module.End R M :=
{ to_fun := distrib_mul_action.to_linear_map R M,
  map_zero' := linear_map.ext $ zero_smul _,
  map_add' := λ f g, linear_map.ext $ add_smul _ _,
  ..distrib_mul_action.to_module_End R M }

end module