import defs

instance : has_add (set ℝ) := ⟨λ S T, {u : ℝ | ∃ (s ∈ S) (t ∈ T), u = s + t}⟩

/-
Goal: state and prove Richard Thomas' problem sheet question.
-/

namespace real_number_game

def is_nonempty (S : set ℝ) : Prop := ∃ s : ℝ, s ∈ S

def is_bounded_above (S : set ℝ) : Prop := ∃ b : ℝ, ∀ x ∈ S, x ≤ b

-- hide this from them
instance foo {S : set ℝ} [nonemptyP S] (x : ℝ) :
  nonemptyP {t : ℝ | ∃ s ∈ S, t = s + x} := ⟨
begin
  cases nonemptyP.thm S with s hs,
  use s + x,
  use s,
  use hs -- , refl
end⟩

-- they can do this
example (S : set ℝ) (hS : is_nonempty S) (x : ℝ) :
  is_nonempty {t : ℝ | ∃ s ∈ S, t = s + x} :=
begin
  cases hS with s hs,
  use s + x,
  use s,
  use hs, -- , refl
end

-- hide this from them
instance foo' {S : set ℝ} [bounded_aboveP S] (x : ℝ) :
  bounded_aboveP {t : ℝ | ∃ s ∈ S, t = s + x} := ⟨
begin
  cases bounded_aboveP.thm S with b hb,
  use b + x,
  intros t ht,
  rcases ht with ⟨s, hs, ht⟩,
  have hsb : s ≤ b,
    exact hb s hs,
  linarith,
end⟩

-- they can do this
example (S : set ℝ) (hs : is_bounded_above S) (x : ℝ) :
  is_bounded_above {t : ℝ | ∃ s ∈ S, t = s + x} :=
begin
  cases hs with b hb,
  use b + x,
  intros t ht,
  rcases ht with ⟨s, hs, ht⟩,
  have hsb : s ≤ b,
    exact hb s hs,
  linarith,
end

-- they can do this
theorem Sup_add_real {S : set ℝ} [nonemptyP S] [bounded_aboveP S] (x : ℝ) :
Sup {t : ℝ | ∃ s ∈ S, t = s + x} = Sup S + x :=
begin
  apply le_antisymm,
  { apply Sup_le,
    intros t ht,
    rcases ht with ⟨s, hs, ht2⟩,
    have hs2 : s ≤ Sup S,
      exact le_Sup s hs,
    linarith,
  },
  { apply add_le_of_le_sub_right,
    apply Sup_le,
    intros s hs,
    apply le_sub_right_of_add_le,
    apply le_Sup,
    use s,
    use hs,
  }
end
-- theorems which need to be done.

-- theorem --THIS NEEDS TO BE TAUGHT. Don't need contradiction?
theorem exists_gt_of_lt_Sup (S : set ℝ) [nonemptyP S] [bounded_aboveP S] :
  ∀ c, c < Sup S → ∃ s ∈ S, c < s :=
begin
  intros c hc,
  apply classical.by_contradiction,
  intro h,
  push_neg at h,
  have h2 := Sup_le c h,
  linarith,
end

theorem gt_Sup_minus_eps (S : set ℝ) [nonemptyP S] [bounded_aboveP S] :
  ∀ ε, 0 < ε → ∃ s ∈ S, Sup S - ε < s :=
begin
  intros ε hε,
  apply exists_gt_of_lt_Sup,
  linarith,
end

-- too hard?
instance (X Y : set ℝ) [nonemptyT X] [nonemptyT Y] : nonemptyT (X + Y) :=
{ x := nonemptyT.x X + nonemptyT.x Y,
  thm := ⟨nonemptyT.x X, nonemptyT.thm X, nonemptyT.x Y, nonemptyT.thm Y, rfl⟩
}

-- too hard?
instance (X Y : set ℝ) [nonemptyP X] [nonemptyP Y] : nonemptyP (X + Y) :=
⟨ begin
    cases nonemptyP.thm X with a ha,
    cases nonemptyP.thm Y with b hb,
    use a + b,
    use a, use ha, use b, use hb,
  end⟩

-- What they can do:

theorem nonempty.add (X Y : set ℝ) (hX : is_nonempty X) (hY : is_nonempty Y) :
  is_nonempty (X + Y) :=
begin
  cases hX with a ha,
  cases hY with b hb,
  use a + b,
  use a, use ha, use b, use hb, -- no refl :-
end

-- too hard :-( without chat about instances
instance bounded_above.sum (X Y : set ℝ) [bounded_aboveT X] [bounded_aboveT Y] :
  bounded_aboveT (X + Y) :=
{ b := bounded_aboveT.b X + bounded_aboveT.b Y,
  thm := begin
    rintro _ ⟨x, hx, y, hy, rfl⟩,
    have : x ≤ _ := bounded_aboveT.thm X x hx,
    have : y ≤ _ := bounded_aboveT.thm Y y hy,
    linarith
  end
}

instance bounded_aboveP.sum (X Y : set ℝ) [bounded_aboveP X] [bounded_aboveP Y] :
  bounded_aboveP (X + Y) :=
⟨ begin
    cases bounded_aboveP.thm X with a ha,
    cases bounded_aboveP.thm Y with b hb,
    use a + b,
    rintro _ ⟨x, hx, y, hy, rfl⟩,
    have : x ≤ a := ha x hx,
    have : y ≤ b := hb y hy,
    linarith
  end⟩

-- What they can do:

example (X Y : set ℝ) (hX : is_bounded_above X) (hY : is_bounded_above Y) : is_bounded_above (X + Y) :=
begin
  cases hX with a ha,
  cases hY with b hb,
  use a + b,
  intros z hz,
  rcases hz with ⟨x, hx, y, hy, h⟩,
  have h1 : x ≤ a := ha x hx,
  have h2 : y ≤ b := hb y hy,
  linarith,
end

-- Or maybe this?
def is_bounded_above_by (S : set ℝ) (b : ℝ) := ∀ s ∈ S, s ≤ b

example (X Y : set ℝ) (a b : ℝ) (haX : is_bounded_above_by X a) (hbY : is_bounded_above_by Y b) :
  is_bounded_above_by (X + Y) (a + b) :=
begin
  intros s hs,
  rcases hs with ⟨x, hx, y, hy, h⟩,
  have h1 : x ≤ a := haX x hx,
  have h2 : y ≤ b := hbY y hy,
  linarith,
end

-- theorem -- THIS NEEDS TO BE TAUGHT; this proof is *long*.
-- Probably should prove each direction separately
theorem real.Sup_add --
  (X : set ℝ) [h1X : nonemptyP X] [h2X : bounded_aboveP X]
  (Y : set ℝ) [h2Y : nonemptyP Y] [h2Y : bounded_aboveP Y] :
  Sup (X + Y) = Sup X + Sup Y  :=
begin
  apply le_antisymm,
  {
    apply Sup_le,
    unfold is_upper_bound,
    intros s hs,
    rcases hs with ⟨x, hx, y, hy, h⟩,
    rw h,
    have h1 : x ≤ Sup X,
      exact le_Sup x hx,
    have h2 : y ≤ Sup Y,
      exact le_Sup y hy,
    linarith,
  },
  { by_contradiction h,
    push_neg at h,
    set ε := (Sup X + Sup Y) - Sup (X + Y) with hε,
    have h1 : 0 < ε/2,
      linarith,
    have h2 := gt_Sup_minus_eps X (ε/2) h1,
    have h3 := gt_Sup_minus_eps Y (ε/2) h1,
    rcases h2 with ⟨a, ha, h4⟩,
    rcases h3 with ⟨b, hb, h5⟩,
    have h6 : a + b ∈ X + Y,
      use a, use ha, use b, use hb,
    have h7 := le_Sup (a + b) h6,
    linarith,
  }
end

-- now onto Richard Thomas' question about sup{sup(S1),sup(S2),sup(S3),...}=sup(union of S_i)

-- Hmm, we need a shedload of instances to make this make sense.
-- this is horrible, why not use ereal? If I used ereal then this is always true.

-- let me just start ploughing through this
instance foo3 (f : ℕ → set ℝ) (n : ℕ) [nonemptyP (f n)] : nonemptyP (⋃ i, f i) :=
⟨ begin
    cases nonemptyP.thm (f n) with x hx,
    use x,
    rw set.mem_Union,
    use n,
    assumption
  end⟩

-- still more typeclass issues with this.
example (f : ℕ → set ℝ) [∀ n, nonemptyP (f n)]
  [bounded_aboveP (⋃ i, f i)] :
Sup (⋃ i, f i) = Sup (set.range (λ n, Sup (f n))) := sorry

end real_number_game


/-
Copyright (c) 2018 Jeremy Avigad. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jeremy Avigad, Simon Hudon
-/
import data.pfunctor.multivariate.W
import data.qpf.multivariate.basic

/-!
# The initial algebra of a multivariate qpf is again a qpf.

For a `(n+1)`-ary QPF `F (α₀,..,αₙ)`, we take the least fixed point of `F` with
regards to its last argument `αₙ`. The result is a `n`-ary functor: `fix F (α₀,..,αₙ₋₁)`.
Making `fix F` into a functor allows us to take the fixed point, compose with other functors
and take a fixed point again.

## Main definitions

 * `fix.mk`     - constructor
 * `fix.dest    - destructor
 * `fix.rec`    - recursor: basis for defining functions by structural recursion on `fix F α`
 * `fix.drec`   - dependent recursor: generalization of `fix.rec` where
                  the result type of the function is allowed to depend on the `fix F α` value
 * `fix.rec_eq` - defining equation for `recursor`
 * `fix.ind`    - induction principle for `fix F α`

## Implementation notes

For `F` a QPF`, we define `fix F α` in terms of the W-type of the polynomial functor `P` of `F`.
We define the relation `Wequiv` and take its quotient as the definition of `fix F α`.

```lean
inductive Wequiv {α : typevec n} : q.P.W α → q.P.W α → Prop
| ind (a : q.P.A) (f' : q.P.drop.B a ⟹ α) (f₀ f₁ : q.P.last.B a → q.P.W α) :
    (∀ x, Wequiv (f₀ x) (f₁ x)) → Wequiv (q.P.W_mk a f' f₀) (q.P.W_mk a f' f₁)
| abs (a₀ : q.P.A) (f'₀ : q.P.drop.B a₀ ⟹ α) (f₀ : q.P.last.B a₀ → q.P.W α)
      (a₁ : q.P.A) (f'₁ : q.P.drop.B a₁ ⟹ α) (f₁ : q.P.last.B a₁ → q.P.W α) :
      abs ⟨a₀, q.P.append_contents f'₀ f₀⟩ = abs ⟨a₁, q.P.append_contents f'₁ f₁⟩ →
        Wequiv (q.P.W_mk a₀ f'₀ f₀) (q.P.W_mk a₁ f'₁ f₁)
| trans (u v w : q.P.W α) : Wequiv u v → Wequiv v w → Wequiv u w
```

See [avigad-carneiro-hudon2019] for more details.

## Reference

 * [Jeremy Avigad, Mario M. Carneiro and Simon Hudon, *Data Types as Quotients of Polynomial Functors*][avigad-carneiro-hudon2019]
-/

universes u v

namespace mvqpf
open typevec
open mvfunctor (liftp liftr)
open_locale mvfunctor

variables {n : ℕ} {F : typevec.{u} (n+1) → Type u} [mvfunctor F] [q : mvqpf F]
include q

/-- `recF` is used as a basis for defining the recursor on `fix F α`. `recF`
traverses recursively the W-type generated by `q.P` using a function on `F`
as a recursive step -/
def recF {α : typevec n} {β : Type*} (g : F (α.append1 β) → β) : q.P.W α → β :=
q.P.W_rec (λ a f' f rec, g (abs ⟨a, split_fun f' rec⟩))

theorem recF_eq {α : typevec n} {β : Type*} (g : F (α.append1 β) → β)
    (a : q.P.A) (f' : q.P.drop.B a ⟹ α) (f : q.P.last.B a → q.P.W α) :
  recF g (q.P.W_mk a f' f) =  g (abs ⟨a, split_fun f' (recF g ∘ f)⟩) :=
by rw [recF, mvpfunctor.W_rec_eq]; refl

theorem recF_eq' {α : typevec n} {β : Type*} (g : F (α.append1 β) → β)
    (x : q.P.W α) :
  recF g x = g (abs ((append_fun id (recF g)) <$$> q.P.W_dest' x)) :=
begin
  apply q.P.W_cases _ x,
  intros a f' f,
  rw [recF_eq, q.P.W_dest'_W_mk, mvpfunctor.map_eq, append_fun_comp_split_fun,
    typevec.id_comp]
end

/-- Equivalence relation on W-types that represent the same `fix F`
value -/
inductive Wequiv {α : typevec n} : q.P.W α → q.P.W α → Prop
| ind (a : q.P.A) (f' : q.P.drop.B a ⟹ α) (f₀ f₁ : q.P.last.B a → q.P.W α) :
    (∀ x, Wequiv (f₀ x) (f₁ x)) → Wequiv (q.P.W_mk a f' f₀) (q.P.W_mk a f' f₁)
| abs (a₀ : q.P.A) (f'₀ : q.P.drop.B a₀ ⟹ α) (f₀ : q.P.last.B a₀ → q.P.W α)
      (a₁ : q.P.A) (f'₁ : q.P.drop.B a₁ ⟹ α) (f₁ : q.P.last.B a₁ → q.P.W α) :
      abs ⟨a₀, q.P.append_contents f'₀ f₀⟩ = abs ⟨a₁, q.P.append_contents f'₁ f₁⟩ →
        Wequiv (q.P.W_mk a₀ f'₀ f₀) (q.P.W_mk a₁ f'₁ f₁)
| trans (u v w : q.P.W α) : Wequiv u v → Wequiv v w → Wequiv u w

theorem recF_eq_of_Wequiv (α : typevec n) {β : Type*} (u : F (α.append1 β) → β)
    (x y : q.P.W α) :
  Wequiv x y → recF u x = recF u y :=
begin
  apply q.P.W_cases _ x,
  intros a₀ f'₀ f₀,
  apply q.P.W_cases _ y,
  intros a₁ f'₁ f₁,
  intro h, induction h,
  case mvqpf.Wequiv.ind : a f' f₀ f₁ h ih { simp only [recF_eq, function.comp, ih] },
  case mvqpf.Wequiv.abs : a₀ f'₀ f₀ a₁ f'₁ f₁ h
    { simp only [recF_eq', abs_map, mvpfunctor.W_dest'_W_mk, h] },
  case mvqpf.Wequiv.trans : x y z e₁ e₂ ih₁ ih₂
    { exact eq.trans ih₁ ih₂ }
end

theorem Wequiv.abs' {α : typevec n} (x y : q.P.W α)
    (h : abs (q.P.W_dest' x) = abs (q.P.W_dest' y)) :
  Wequiv x y :=
begin
  revert h,
  apply q.P.W_cases _ x,
  intros a₀ f'₀ f₀,
  apply q.P.W_cases _ y,
  intros a₁ f'₁ f₁,
  apply Wequiv.abs
end

theorem Wequiv.refl {α : typevec n} (x : q.P.W α) : Wequiv x x :=
by apply q.P.W_cases _ x; intros a f' f; exact Wequiv.abs a f' f a f' f rfl

theorem Wequiv.symm {α : typevec n} (x y : q.P.W α) : Wequiv x y → Wequiv y x :=
begin
  intro h, induction h,
  case mvqpf.Wequiv.ind : a f' f₀ f₁ h ih
    { exact Wequiv.ind _ _ _ _ ih },
  case mvqpf.Wequiv.abs : a₀ f'₀ f₀ a₁ f'₁ f₁ h
    { exact Wequiv.abs _ _ _ _ _ _ h.symm },
  case mvqpf.Wequiv.trans : x y z e₁ e₂ ih₁ ih₂
    { exact mvqpf.Wequiv.trans _ _ _ ih₂ ih₁}
end

/-- maps every element of the W type to a canonical representative -/
def Wrepr {α : typevec n} : q.P.W α → q.P.W α := recF (q.P.W_mk' ∘ repr)

theorem Wrepr_W_mk  {α : typevec n}
    (a : q.P.A) (f' : q.P.drop.B a ⟹ α) (f : q.P.last.B a → q.P.W α) :
  Wrepr (q.P.W_mk a f' f) =
    q.P.W_mk' (repr (abs ((append_fun id Wrepr) <$$> ⟨a, q.P.append_contents f' f⟩))) :=
by rw [Wrepr, recF_eq', q.P.W_dest'_W_mk]; refl

theorem Wrepr_equiv {α : typevec n} (x : q.P.W α) : Wequiv (Wrepr x) x :=
begin
  apply q.P.W_ind _ x, intros a f' f ih,
  apply Wequiv.trans _ (q.P.W_mk' ((append_fun id Wrepr) <$$> ⟨a, q.P.append_contents f' f⟩)),
  { apply Wequiv.abs',
    rw [Wrepr_W_mk, q.P.W_dest'_W_mk', q.P.W_dest'_W_mk', abs_repr] },
  rw [q.P.map_eq, mvpfunctor.W_mk', append_fun_comp_split_fun, id_comp],
  apply Wequiv.ind, exact ih
end

theorem Wequiv_map {α β : typevec n} (g : α ⟹ β) (x y : q.P.W α) :
  Wequiv x y → Wequiv (g <$$> x) (g <$$> y) :=
begin
  intro h, induction h,
  case mvqpf.Wequiv.ind : a f' f₀ f₁ h ih
    { rw [q.P.W_map_W_mk, q.P.W_map_W_mk], apply Wequiv.ind, apply ih },
  case mvqpf.Wequiv.abs : a₀ f'₀ f₀ a₁ f'₁ f₁ h
    { rw [q.P.W_map_W_mk, q.P.W_map_W_mk], apply Wequiv.abs,
      show abs (q.P.obj_append1 a₀ (g ⊚ f'₀) (λ x, q.P.W_map g (f₀ x))) =
           abs (q.P.obj_append1 a₁ (g ⊚ f'₁) (λ x, q.P.W_map g (f₁ x))),
      rw [←q.P.map_obj_append1, ←q.P.map_obj_append1, abs_map, abs_map, h] },
  case mvqpf.Wequiv.trans : x y z e₁ e₂ ih₁ ih₂
    { apply mvqpf.Wequiv.trans, apply ih₁, apply ih₂ }
end

/--
Define the fixed point as the quotient of trees under the equivalence relation.
-/
def W_setoid (α : typevec n) : setoid (q.P.W α) :=
⟨Wequiv, @Wequiv.refl _ _ _ _ _, @Wequiv.symm _ _ _ _ _, @Wequiv.trans _ _ _ _ _⟩

local attribute [instance] W_setoid

/-- Least fixed point of functor F. The result is a functor with one fewer parameters
than the input. For `F a b c` a ternary functor, fix F is a binary functor such that

```lean
fix F a b = F a b (fix F a b)
```
-/
def fix {n : ℕ} (F : typevec (n+1) → Type*) [mvfunctor F] [q : mvqpf F] (α : typevec n) :=
quotient (W_setoid α : setoid (q.P.W α))

attribute [nolint has_inhabited_instance] fix

/-- `fix F` is a functor -/
def fix.map {α β : typevec n} (g : α ⟹ β) : fix F α → fix F β :=
quotient.lift (λ x : q.P.W α, ⟦q.P.W_map g x⟧)
  (λ a b h, quot.sound (Wequiv_map _ _ _ h))

instance fix.mvfunctor : mvfunctor (fix F) :=
{ map := @fix.map _ _ _ _}

variable {α : typevec.{u} n}

/-- Recursor for `fix F` -/
def fix.rec {β : Type u} (g : F (α ::: β) → β) : fix F α → β :=
quot.lift (recF g) (recF_eq_of_Wequiv α g)

/-- Access W-type underlying `fix F`  -/
def fix_to_W : fix F α → q.P.W α :=
quotient.lift Wrepr (recF_eq_of_Wequiv α (λ x, q.P.W_mk' (repr x)))

/-- Constructor for `fix F` -/
def fix.mk (x : F (append1 α (fix F α))) : fix F α :=
  quot.mk _ (q.P.W_mk' (append_fun id fix_to_W <$$> repr x))

/-- Destructor for `fix F` -/
def fix.dest : fix F α → F (append1 α (fix F α)) :=
fix.rec (mvfunctor.map (append_fun id fix.mk))

theorem fix.rec_eq {β : Type u} (g : F (append1 α β) → β) (x : F (append1 α (fix F α))) :
  fix.rec g (fix.mk x) = g (append_fun id (fix.rec g) <$$> x) :=
have recF g ∘ fix_to_W = fix.rec g,
  by { apply funext, apply quotient.ind, intro x, apply recF_eq_of_Wequiv,
       apply Wrepr_equiv },
begin
  conv { to_lhs, rw [fix.rec, fix.mk], dsimp },
  cases h : repr x with a f,
  rw [mvpfunctor.map_eq, recF_eq', ←mvpfunctor.map_eq, mvpfunctor.W_dest'_W_mk'],
  rw [←mvpfunctor.comp_map, abs_map, ←h, abs_repr, ←append_fun_comp, id_comp, this]
end

theorem fix.ind_aux (a : q.P.A) (f' : q.P.drop.B a ⟹ α) (f : q.P.last.B a → q.P.W α) :
  fix.mk (abs ⟨a, q.P.append_contents f' (λ x, ⟦f x⟧)⟩) = ⟦q.P.W_mk a f' f⟧ :=
have fix.mk (abs ⟨a, q.P.append_contents f' (λ x, ⟦f x⟧)⟩) = ⟦Wrepr (q.P.W_mk a f' f)⟧,
  begin
    apply quot.sound, apply Wequiv.abs',
    rw [mvpfunctor.W_dest'_W_mk', abs_map, abs_repr, ←abs_map, mvpfunctor.map_eq],
    conv { to_rhs, rw [Wrepr_W_mk, q.P.W_dest'_W_mk', abs_repr, mvpfunctor.map_eq] },
    congr' 2, rw [mvpfunctor.append_contents, mvpfunctor.append_contents],
    rw [append_fun, append_fun, ←split_fun_comp, ←split_fun_comp],
    reflexivity
  end,
by { rw this, apply quot.sound, apply Wrepr_equiv }

theorem fix.ind_rec {β : Type*} (g₁ g₂ : fix F α → β)
    (h : ∀ x : F (append1 α (fix F α)),
      (append_fun id g₁) <$$> x = (append_fun id g₂) <$$> x → g₁ (fix.mk x) = g₂ (fix.mk x)) :
  ∀ x, g₁ x = g₂ x :=
begin
  apply quot.ind,
  intro x,
  apply q.P.W_ind _ x, intros a f' f ih,
  show g₁ ⟦q.P.W_mk a f' f⟧ = g₂ ⟦q.P.W_mk a f' f⟧,
  rw [←fix.ind_aux a f' f], apply h,
  rw [←abs_map, ←abs_map, mvpfunctor.map_eq, mvpfunctor.map_eq],
  congr' 2,
  rw [mvpfunctor.append_contents, append_fun, append_fun, ←split_fun_comp, ←split_fun_comp],
  have : g₁ ∘ (λ x, ⟦f x⟧) = g₂ ∘ (λ x, ⟦f x⟧),
  { ext x, exact ih x },
  rw this
end

theorem fix.rec_unique {β : Type*} (g : F (append1 α β) → β) (h : fix F α → β)
    (hyp : ∀ x, h (fix.mk x) = g (append_fun id h <$$> x)) :
  fix.rec g = h :=
begin
  ext x,
  apply fix.ind_rec,
  intros x hyp',
  rw [hyp, ←hyp', fix.rec_eq]
end

theorem fix.mk_dest (x : fix F α) : fix.mk (fix.dest x) = x :=
begin
  change (fix.mk ∘ fix.dest) x = x,
  apply fix.ind_rec,
  intro x, dsimp,
  rw [fix.dest, fix.rec_eq, ←comp_map, ←append_fun_comp, id_comp],
  intro h, rw h,
  show fix.mk (append_fun id id <$$> x) = fix.mk x,
  rw [append_fun_id_id, mvfunctor.id_map]
end

theorem fix.dest_mk (x : F (append1 α (fix F α))) : fix.dest (fix.mk x) = x :=
begin
  unfold fix.dest, rw [fix.rec_eq, ←fix.dest, ←comp_map],
  conv { to_rhs, rw ←(mvfunctor.id_map x) },
  rw [←append_fun_comp, id_comp],
  have : fix.mk ∘ fix.dest = id, {ext x, apply fix.mk_dest },
  rw [this, append_fun_id_id]
end

theorem fix.ind {α : typevec n} (p : fix F α → Prop)
    (h : ∀ x : F (α.append1 (fix F α)), liftp (pred_last α p) x → p (fix.mk x)) :
  ∀ x, p x :=
begin
  apply quot.ind,
  intro x,
  apply q.P.W_ind _ x, intros a f' f ih,
  change p ⟦q.P.W_mk a f' f⟧,
  rw [←fix.ind_aux a f' f],
  apply h,
  rw mvqpf.liftp_iff,
  refine ⟨_, _, rfl, _⟩,
  intros i j,
  cases i,
  { apply ih },
  { triv },
end

instance mvqpf_fix : mvqpf (fix F) :=
{ P         := q.P.Wp,
  abs       := λ α, quot.mk Wequiv,
  repr      := λ α, fix_to_W,
  abs_repr  := by { intros α, apply quot.ind, intro a, apply quot.sound, apply Wrepr_equiv },
  abs_map   :=
    begin
      intros α β g x, conv { to_rhs, dsimp [mvfunctor.map]},
      rw fix.map, apply quot.sound,
      apply Wequiv.refl
    end }

/-- Dependent recursor for `fix F` -/
def fix.drec {β : fix F α → Type u}
  (g : Π x : F (α ::: sigma β), β (fix.mk $ (id ::: sigma.fst) <$$> x)) (x : fix F α) : β x :=
let y := @fix.rec _ F _ _ α (sigma β) (λ i, ⟨_,g i⟩) x in
have x = y.1,
  by { symmetry, dsimp [y], apply fix.ind_rec _ id _ x, intros x' ih,
       rw fix.rec_eq, dsimp, simp [append_fun_id_id] at ih,
       congr, conv { to_rhs, rw [← ih] }, rw [mvfunctor.map_map,← append_fun_comp,id_comp], },
cast (by rw this) y.2

end mvqpf


/-
Copyright (c) 2021 Jon Eugster. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jon Eugster, Eric Wieser

! This file was ported from Lean 3 source module algebra.char_p.algebra
! leanprover-community/mathlib commit 97eab48559068f3d6313da387714ef25768fb730
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Algebra.CharP.Basic
import Mathbin.RingTheory.Localization.FractionRing
import Mathbin.Algebra.FreeAlgebra

/-!
# Characteristics of algebras

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

In this file we describe the characteristic of `R`-algebras.

In particular we are interested in the characteristic of free algebras over `R`
and the fraction field `fraction_ring R`.

## Main results

- `char_p_of_injective_algebra_map` If `R →+* A` is an injective algebra map
  then `A` has the same characteristic as `R`.

Instances constructed from this result:
- Any `free_algebra R X` has the same characteristic as `R`.
- The `fraction_ring R` of an integral domain `R` has the same characteristic as `R`.

-/

/- warning: char_p_of_injective_algebra_map -> charP_of_injective_algebraMap is a dubious translation:
lean 3 declaration is
  forall {R : Type.{u1}} {A : Type.{u2}} [_inst_1 : CommSemiring.{u1} R] [_inst_2 : Semiring.{u2} A] [_inst_3 : Algebra.{u1, u2} R A _inst_1 _inst_2], (Function.Injective.{succ u1, succ u2} R A (coeFn.{max (succ u1) (succ u2), max (succ u1) (succ u2)} (RingHom.{u1, u2} R A (Semiring.toNonAssocSemiring.{u1} R (CommSemiring.toSemiring.{u1} R _inst_1)) (Semiring.toNonAssocSemiring.{u2} A _inst_2)) (fun (_x : RingHom.{u1, u2} R A (Semiring.toNonAssocSemiring.{u1} R (CommSemiring.toSemiring.{u1} R _inst_1)) (Semiring.toNonAssocSemiring.{u2} A _inst_2)) => R -> A) (RingHom.hasCoeToFun.{u1, u2} R A (Semiring.toNonAssocSemiring.{u1} R (CommSemiring.toSemiring.{u1} R _inst_1)) (Semiring.toNonAssocSemiring.{u2} A _inst_2)) (algebraMap.{u1, u2} R A _inst_1 _inst_2 _inst_3))) -> (forall (p : Nat) [_inst_4 : CharP.{u1} R (AddCommMonoidWithOne.toAddMonoidWithOne.{u1} R (NonAssocSemiring.toAddCommMonoidWithOne.{u1} R (Semiring.toNonAssocSemiring.{u1} R (CommSemiring.toSemiring.{u1} R _inst_1)))) p], CharP.{u2} A (AddCommMonoidWithOne.toAddMonoidWithOne.{u2} A (NonAssocSemiring.toAddCommMonoidWithOne.{u2} A (Semiring.toNonAssocSemiring.{u2} A _inst_2))) p)
but is expected to have type
  forall {R : Type.{u2}} {A : Type.{u1}} [_inst_1 : CommSemiring.{u2} R] [_inst_2 : Semiring.{u1} A] [_inst_3 : Algebra.{u2, u1} R A _inst_1 _inst_2], (Function.Injective.{succ u2, succ u1} R A (FunLike.coe.{max (succ u2) (succ u1), succ u2, succ u1} (RingHom.{u2, u1} R A (Semiring.toNonAssocSemiring.{u2} R (CommSemiring.toSemiring.{u2} R _inst_1)) (Semiring.toNonAssocSemiring.{u1} A _inst_2)) R (fun (_x : R) => (fun (x._@.Mathlib.Algebra.Hom.Group._hyg.2391 : R) => A) _x) (MulHomClass.toFunLike.{max u2 u1, u2, u1} (RingHom.{u2, u1} R A (Semiring.toNonAssocSemiring.{u2} R (CommSemiring.toSemiring.{u2} R _inst_1)) (Semiring.toNonAssocSemiring.{u1} A _inst_2)) R A (NonUnitalNonAssocSemiring.toMul.{u2} R (NonAssocSemiring.toNonUnitalNonAssocSemiring.{u2} R (Semiring.toNonAssocSemiring.{u2} R (CommSemiring.toSemiring.{u2} R _inst_1)))) (NonUnitalNonAssocSemiring.toMul.{u1} A (NonAssocSemiring.toNonUnitalNonAssocSemiring.{u1} A (Semiring.toNonAssocSemiring.{u1} A _inst_2))) (NonUnitalRingHomClass.toMulHomClass.{max u2 u1, u2, u1} (RingHom.{u2, u1} R A (Semiring.toNonAssocSemiring.{u2} R (CommSemiring.toSemiring.{u2} R _inst_1)) (Semiring.toNonAssocSemiring.{u1} A _inst_2)) R A (NonAssocSemiring.toNonUnitalNonAssocSemiring.{u2} R (Semiring.toNonAssocSemiring.{u2} R (CommSemiring.toSemiring.{u2} R _inst_1))) (NonAssocSemiring.toNonUnitalNonAssocSemiring.{u1} A (Semiring.toNonAssocSemiring.{u1} A _inst_2)) (RingHomClass.toNonUnitalRingHomClass.{max u2 u1, u2, u1} (RingHom.{u2, u1} R A (Semiring.toNonAssocSemiring.{u2} R (CommSemiring.toSemiring.{u2} R _inst_1)) (Semiring.toNonAssocSemiring.{u1} A _inst_2)) R A (Semiring.toNonAssocSemiring.{u2} R (CommSemiring.toSemiring.{u2} R _inst_1)) (Semiring.toNonAssocSemiring.{u1} A _inst_2) (RingHom.instRingHomClassRingHom.{u2, u1} R A (Semiring.toNonAssocSemiring.{u2} R (CommSemiring.toSemiring.{u2} R _inst_1)) (Semiring.toNonAssocSemiring.{u1} A _inst_2))))) (algebraMap.{u2, u1} R A _inst_1 _inst_2 _inst_3))) -> (forall (p : Nat) [_inst_4 : CharP.{u2} R (AddCommMonoidWithOne.toAddMonoidWithOne.{u2} R (NonAssocSemiring.toAddCommMonoidWithOne.{u2} R (Semiring.toNonAssocSemiring.{u2} R (CommSemiring.toSemiring.{u2} R _inst_1)))) p], CharP.{u1} A (AddCommMonoidWithOne.toAddMonoidWithOne.{u1} A (NonAssocSemiring.toAddCommMonoidWithOne.{u1} A (Semiring.toNonAssocSemiring.{u1} A _inst_2))) p)
Case conversion may be inaccurate. Consider using '#align char_p_of_injective_algebra_map charP_of_injective_algebraMapₓ'. -/
/-- If the algebra map `R →+* A` is injective then `A` has the same characteristic as `R`. -/
theorem charP_of_injective_algebraMap {R A : Type _} [CommSemiring R] [Semiring A] [Algebra R A]
    (h : Function.Injective (algebraMap R A)) (p : ℕ) [CharP R p] : CharP A p :=
  {
    cast_eq_zero_iff := fun x => by
      rw [← CharP.cast_eq_zero_iff R p x]
      change algebraMap ℕ A x = 0 ↔ algebraMap ℕ R x = 0
      rw [IsScalarTower.algebraMap_apply ℕ R A x]
      refine' Iff.trans _ h.eq_iff
      rw [RingHom.map_zero] }
#align char_p_of_injective_algebra_map charP_of_injective_algebraMap

/- warning: char_p_of_injective_algebra_map' -> charP_of_injective_algebraMap' is a dubious translation:
lean 3 declaration is
  forall (R : Type.{u1}) (A : Type.{u2}) [_inst_1 : Field.{u1} R] [_inst_2 : Semiring.{u2} A] [_inst_3 : Algebra.{u1, u2} R A (Semifield.toCommSemiring.{u1} R (Field.toSemifield.{u1} R _inst_1)) _inst_2] [_inst_4 : Nontrivial.{u2} A] (p : Nat) [_inst_5 : CharP.{u1} R (AddGroupWithOne.toAddMonoidWithOne.{u1} R (AddCommGroupWithOne.toAddGroupWithOne.{u1} R (Ring.toAddCommGroupWithOne.{u1} R (DivisionRing.toRing.{u1} R (Field.toDivisionRing.{u1} R _inst_1))))) p], CharP.{u2} A (AddCommMonoidWithOne.toAddMonoidWithOne.{u2} A (NonAssocSemiring.toAddCommMonoidWithOne.{u2} A (Semiring.toNonAssocSemiring.{u2} A _inst_2))) p
but is expected to have type
  forall (R : Type.{u2}) (A : Type.{u1}) [_inst_1 : Field.{u2} R] [_inst_2 : Semiring.{u1} A] [_inst_3 : Algebra.{u2, u1} R A (Semifield.toCommSemiring.{u2} R (Field.toSemifield.{u2} R _inst_1)) _inst_2] [_inst_4 : Nontrivial.{u1} A] (p : Nat) [_inst_5 : CharP.{u2} R (AddGroupWithOne.toAddMonoidWithOne.{u2} R (Ring.toAddGroupWithOne.{u2} R (DivisionRing.toRing.{u2} R (Field.toDivisionRing.{u2} R _inst_1)))) p], CharP.{u1} A (AddCommMonoidWithOne.toAddMonoidWithOne.{u1} A (NonAssocSemiring.toAddCommMonoidWithOne.{u1} A (Semiring.toNonAssocSemiring.{u1} A _inst_2))) p
Case conversion may be inaccurate. Consider using '#align char_p_of_injective_algebra_map' charP_of_injective_algebraMap'ₓ'. -/
theorem charP_of_injective_algebraMap' (R A : Type _) [Field R] [Semiring A] [Algebra R A]
    [Nontrivial A] (p : ℕ) [CharP R p] : CharP A p :=
  charP_of_injective_algebraMap (algebraMap R A).Injective p
#align char_p_of_injective_algebra_map' charP_of_injective_algebraMap'

/- warning: char_zero_of_injective_algebra_map -> charZero_of_injective_algebraMap is a dubious translation:
lean 3 declaration is
  forall {R : Type.{u1}} {A : Type.{u2}} [_inst_1 : CommSemiring.{u1} R] [_inst_2 : Semiring.{u2} A] [_inst_3 : Algebra.{u1, u2} R A _inst_1 _inst_2], (Function.Injective.{succ u1, succ u2} R A (coeFn.{max (succ u1) (succ u2), max (succ u1) (succ u2)} (RingHom.{u1, u2} R A (Semiring.toNonAssocSemiring.{u1} R (CommSemiring.toSemiring.{u1} R _inst_1)) (Semiring.toNonAssocSemiring.{u2} A _inst_2)) (fun (_x : RingHom.{u1, u2} R A (Semiring.toNonAssocSemiring.{u1} R (CommSemiring.toSemiring.{u1} R _inst_1)) (Semiring.toNonAssocSemiring.{u2} A _inst_2)) => R -> A) (RingHom.hasCoeToFun.{u1, u2} R A (Semiring.toNonAssocSemiring.{u1} R (CommSemiring.toSemiring.{u1} R _inst_1)) (Semiring.toNonAssocSemiring.{u2} A _inst_2)) (algebraMap.{u1, u2} R A _inst_1 _inst_2 _inst_3))) -> (forall [_inst_4 : CharZero.{u1} R (AddCommMonoidWithOne.toAddMonoidWithOne.{u1} R (NonAssocSemiring.toAddCommMonoidWithOne.{u1} R (Semiring.toNonAssocSemiring.{u1} R (CommSemiring.toSemiring.{u1} R _inst_1))))], CharZero.{u2} A (AddCommMonoidWithOne.toAddMonoidWithOne.{u2} A (NonAssocSemiring.toAddCommMonoidWithOne.{u2} A (Semiring.toNonAssocSemiring.{u2} A _inst_2))))
but is expected to have type
  forall {R : Type.{u2}} {A : Type.{u1}} [_inst_1 : CommSemiring.{u2} R] [_inst_2 : Semiring.{u1} A] [_inst_3 : Algebra.{u2, u1} R A _inst_1 _inst_2], (Function.Injective.{succ u2, succ u1} R A (FunLike.coe.{max (succ u2) (succ u1), succ u2, succ u1} (RingHom.{u2, u1} R A (Semiring.toNonAssocSemiring.{u2} R (CommSemiring.toSemiring.{u2} R _inst_1)) (Semiring.toNonAssocSemiring.{u1} A _inst_2)) R (fun (_x : R) => (fun (x._@.Mathlib.Algebra.Hom.Group._hyg.2391 : R) => A) _x) (MulHomClass.toFunLike.{max u2 u1, u2, u1} (RingHom.{u2, u1} R A (Semiring.toNonAssocSemiring.{u2} R (CommSemiring.toSemiring.{u2} R _inst_1)) (Semiring.toNonAssocSemiring.{u1} A _inst_2)) R A (NonUnitalNonAssocSemiring.toMul.{u2} R (NonAssocSemiring.toNonUnitalNonAssocSemiring.{u2} R (Semiring.toNonAssocSemiring.{u2} R (CommSemiring.toSemiring.{u2} R _inst_1)))) (NonUnitalNonAssocSemiring.toMul.{u1} A (NonAssocSemiring.toNonUnitalNonAssocSemiring.{u1} A (Semiring.toNonAssocSemiring.{u1} A _inst_2))) (NonUnitalRingHomClass.toMulHomClass.{max u2 u1, u2, u1} (RingHom.{u2, u1} R A (Semiring.toNonAssocSemiring.{u2} R (CommSemiring.toSemiring.{u2} R _inst_1)) (Semiring.toNonAssocSemiring.{u1} A _inst_2)) R A (NonAssocSemiring.toNonUnitalNonAssocSemiring.{u2} R (Semiring.toNonAssocSemiring.{u2} R (CommSemiring.toSemiring.{u2} R _inst_1))) (NonAssocSemiring.toNonUnitalNonAssocSemiring.{u1} A (Semiring.toNonAssocSemiring.{u1} A _inst_2)) (RingHomClass.toNonUnitalRingHomClass.{max u2 u1, u2, u1} (RingHom.{u2, u1} R A (Semiring.toNonAssocSemiring.{u2} R (CommSemiring.toSemiring.{u2} R _inst_1)) (Semiring.toNonAssocSemiring.{u1} A _inst_2)) R A (Semiring.toNonAssocSemiring.{u2} R (CommSemiring.toSemiring.{u2} R _inst_1)) (Semiring.toNonAssocSemiring.{u1} A _inst_2) (RingHom.instRingHomClassRingHom.{u2, u1} R A (Semiring.toNonAssocSemiring.{u2} R (CommSemiring.toSemiring.{u2} R _inst_1)) (Semiring.toNonAssocSemiring.{u1} A _inst_2))))) (algebraMap.{u2, u1} R A _inst_1 _inst_2 _inst_3))) -> (forall [_inst_4 : CharZero.{u2} R (AddCommMonoidWithOne.toAddMonoidWithOne.{u2} R (NonAssocSemiring.toAddCommMonoidWithOne.{u2} R (Semiring.toNonAssocSemiring.{u2} R (CommSemiring.toSemiring.{u2} R _inst_1))))], CharZero.{u1} A (AddCommMonoidWithOne.toAddMonoidWithOne.{u1} A (NonAssocSemiring.toAddCommMonoidWithOne.{u1} A (Semiring.toNonAssocSemiring.{u1} A _inst_2))))
Case conversion may be inaccurate. Consider using '#align char_zero_of_injective_algebra_map charZero_of_injective_algebraMapₓ'. -/
/-- If the algebra map `R →+* A` is injective and `R` has characteristic zero then so does `A`. -/
theorem charZero_of_injective_algebraMap {R A : Type _} [CommSemiring R] [Semiring A] [Algebra R A]
    (h : Function.Injective (algebraMap R A)) [CharZero R] : CharZero A :=
  {
    cast_injective := fun x y hxy =>
      by
      change algebraMap ℕ A x = algebraMap ℕ A y at hxy
      rw [IsScalarTower.algebraMap_apply ℕ R A x] at hxy
      rw [IsScalarTower.algebraMap_apply ℕ R A y] at hxy
      exact CharZero.cast_injective (h hxy) }
#align char_zero_of_injective_algebra_map charZero_of_injective_algebraMap

/-!
As an application, a `ℚ`-algebra has characteristic zero.
-/

-- `char_p.char_p_to_char_zero A _ (char_p_of_injective_algebra_map h 0)` does not work
-- here as it would require `ring A`.
section QAlgebra

variable (R : Type _) [Nontrivial R]

#print algebraRat.charP_zero /-
/-- A nontrivial `ℚ`-algebra has `char_p` equal to zero.

This cannot be a (local) instance because it would immediately form a loop with the
instance `algebra_rat`. It's probably easier to go the other way: prove `char_zero R` and
automatically receive an `algebra ℚ R` instance.
-/
theorem algebraRat.charP_zero [Semiring R] [Algebra ℚ R] : CharP R 0 :=
  charP_of_injective_algebraMap (algebraMap ℚ R).Injective 0
#align algebra_rat.char_p_zero algebraRat.charP_zero
-/

/- warning: algebra_rat.char_zero -> algebraRat.charZero is a dubious translation:
lean 3 declaration is
  forall (R : Type.{u1}) [_inst_1 : Nontrivial.{u1} R] [_inst_2 : Ring.{u1} R] [_inst_3 : Algebra.{0, u1} Rat R Rat.commSemiring (Ring.toSemiring.{u1} R _inst_2)], CharZero.{u1} R (AddGroupWithOne.toAddMonoidWithOne.{u1} R (AddCommGroupWithOne.toAddGroupWithOne.{u1} R (Ring.toAddCommGroupWithOne.{u1} R _inst_2)))
but is expected to have type
  forall (R : Type.{u1}) [_inst_1 : Nontrivial.{u1} R] [_inst_2 : Ring.{u1} R] [_inst_3 : Algebra.{0, u1} Rat R Rat.commSemiring (Ring.toSemiring.{u1} R _inst_2)], CharZero.{u1} R (AddGroupWithOne.toAddMonoidWithOne.{u1} R (Ring.toAddGroupWithOne.{u1} R _inst_2))
Case conversion may be inaccurate. Consider using '#align algebra_rat.char_zero algebraRat.charZeroₓ'. -/
/-- A nontrivial `ℚ`-algebra has characteristic zero.

This cannot be a (local) instance because it would immediately form a loop with the
instance `algebra_rat`. It's probably easier to go the other way: prove `char_zero R` and
automatically receive an `algebra ℚ R` instance.
-/
theorem algebraRat.charZero [Ring R] [Algebra ℚ R] : CharZero R :=
  @CharP.charP_to_charZero R _ (algebraRat.charP_zero R)
#align algebra_rat.char_zero algebraRat.charZero

end QAlgebra

/-!
An algebra over a field has the same characteristic as the field.
-/

section

variable (K L : Type _) [Field K] [CommSemiring L] [Nontrivial L] [Algebra K L]

/- warning: algebra.char_p_iff -> Algebra.charP_iff is a dubious translation:
lean 3 declaration is
  forall (K : Type.{u1}) (L : Type.{u2}) [_inst_1 : Field.{u1} K] [_inst_2 : CommSemiring.{u2} L] [_inst_3 : Nontrivial.{u2} L] [_inst_4 : Algebra.{u1, u2} K L (Semifield.toCommSemiring.{u1} K (Field.toSemifield.{u1} K _inst_1)) (CommSemiring.toSemiring.{u2} L _inst_2)] (p : Nat), Iff (CharP.{u1} K (AddGroupWithOne.toAddMonoidWithOne.{u1} K (AddCommGroupWithOne.toAddGroupWithOne.{u1} K (Ring.toAddCommGroupWithOne.{u1} K (DivisionRing.toRing.{u1} K (Field.toDivisionRing.{u1} K _inst_1))))) p) (CharP.{u2} L (AddCommMonoidWithOne.toAddMonoidWithOne.{u2} L (NonAssocSemiring.toAddCommMonoidWithOne.{u2} L (Semiring.toNonAssocSemiring.{u2} L (CommSemiring.toSemiring.{u2} L _inst_2)))) p)
but is expected to have type
  forall (K : Type.{u2}) (L : Type.{u1}) [_inst_1 : Field.{u2} K] [_inst_2 : CommSemiring.{u1} L] [_inst_3 : Nontrivial.{u1} L] [_inst_4 : Algebra.{u2, u1} K L (Semifield.toCommSemiring.{u2} K (Field.toSemifield.{u2} K _inst_1)) (CommSemiring.toSemiring.{u1} L _inst_2)] (p : Nat), Iff (CharP.{u2} K (AddGroupWithOne.toAddMonoidWithOne.{u2} K (Ring.toAddGroupWithOne.{u2} K (DivisionRing.toRing.{u2} K (Field.toDivisionRing.{u2} K _inst_1)))) p) (CharP.{u1} L (AddCommMonoidWithOne.toAddMonoidWithOne.{u1} L (NonAssocSemiring.toAddCommMonoidWithOne.{u1} L (Semiring.toNonAssocSemiring.{u1} L (CommSemiring.toSemiring.{u1} L _inst_2)))) p)
Case conversion may be inaccurate. Consider using '#align algebra.char_p_iff Algebra.charP_iffₓ'. -/
theorem Algebra.charP_iff (p : ℕ) : CharP K p ↔ CharP L p :=
  (algebraMap K L).charP_iff_charP p
#align algebra.char_p_iff Algebra.charP_iff

/- warning: algebra.ring_char_eq -> Algebra.ringChar_eq is a dubious translation:
lean 3 declaration is
  forall (K : Type.{u1}) (L : Type.{u2}) [_inst_1 : Field.{u1} K] [_inst_2 : CommSemiring.{u2} L] [_inst_3 : Nontrivial.{u2} L] [_inst_4 : Algebra.{u1, u2} K L (Semifield.toCommSemiring.{u1} K (Field.toSemifield.{u1} K _inst_1)) (CommSemiring.toSemiring.{u2} L _inst_2)], Eq.{1} Nat (ringChar.{u1} K (NonAssocRing.toNonAssocSemiring.{u1} K (Ring.toNonAssocRing.{u1} K (DivisionRing.toRing.{u1} K (Field.toDivisionRing.{u1} K _inst_1))))) (ringChar.{u2} L (Semiring.toNonAssocSemiring.{u2} L (CommSemiring.toSemiring.{u2} L _inst_2)))
but is expected to have type
  forall (K : Type.{u2}) (L : Type.{u1}) [_inst_1 : Field.{u2} K] [_inst_2 : CommSemiring.{u1} L] [_inst_3 : Nontrivial.{u1} L] [_inst_4 : Algebra.{u2, u1} K L (Semifield.toCommSemiring.{u2} K (Field.toSemifield.{u2} K _inst_1)) (CommSemiring.toSemiring.{u1} L _inst_2)], Eq.{1} Nat (ringChar.{u2} K (NonAssocRing.toNonAssocSemiring.{u2} K (Ring.toNonAssocRing.{u2} K (DivisionRing.toRing.{u2} K (Field.toDivisionRing.{u2} K _inst_1))))) (ringChar.{u1} L (Semiring.toNonAssocSemiring.{u1} L (CommSemiring.toSemiring.{u1} L _inst_2)))
Case conversion may be inaccurate. Consider using '#align algebra.ring_char_eq Algebra.ringChar_eqₓ'. -/
theorem Algebra.ringChar_eq : ringChar K = ringChar L :=
  by
  rw [ringChar.eq_iff, Algebra.charP_iff K L]
  apply ringChar.charP
#align algebra.ring_char_eq Algebra.ringChar_eq

end

namespace FreeAlgebra

variable {R X : Type _} [CommSemiring R] (p : ℕ)

/- warning: free_algebra.char_p -> FreeAlgebra.charP is a dubious translation:
lean 3 declaration is
  forall {R : Type.{u1}} {X : Type.{u2}} [_inst_1 : CommSemiring.{u1} R] (p : Nat) [_inst_2 : CharP.{u1} R (AddCommMonoidWithOne.toAddMonoidWithOne.{u1} R (NonAssocSemiring.toAddCommMonoidWithOne.{u1} R (Semiring.toNonAssocSemiring.{u1} R (CommSemiring.toSemiring.{u1} R _inst_1)))) p], CharP.{max u1 u2} (FreeAlgebra.{u1, u2} R _inst_1 X) (AddCommMonoidWithOne.toAddMonoidWithOne.{max u1 u2} (FreeAlgebra.{u1, u2} R _inst_1 X) (NonAssocSemiring.toAddCommMonoidWithOne.{max u1 u2} (FreeAlgebra.{u1, u2} R _inst_1 X) (Semiring.toNonAssocSemiring.{max u1 u2} (FreeAlgebra.{u1, u2} R _inst_1 X) (FreeAlgebra.semiring.{u1, u2} R _inst_1 X)))) p
but is expected to have type
  forall {R : Type.{u1}} {X : Type.{u2}} [_inst_1 : CommSemiring.{u1} R] (p : Nat) [_inst_2 : CharP.{u1} R (AddCommMonoidWithOne.toAddMonoidWithOne.{u1} R (NonAssocSemiring.toAddCommMonoidWithOne.{u1} R (Semiring.toNonAssocSemiring.{u1} R (CommSemiring.toSemiring.{u1} R _inst_1)))) p], CharP.{max u2 u1} (FreeAlgebra.{u1, u2} R _inst_1 X) (AddCommMonoidWithOne.toAddMonoidWithOne.{max u1 u2} (FreeAlgebra.{u1, u2} R _inst_1 X) (NonAssocSemiring.toAddCommMonoidWithOne.{max u1 u2} (FreeAlgebra.{u1, u2} R _inst_1 X) (Semiring.toNonAssocSemiring.{max u1 u2} (FreeAlgebra.{u1, u2} R _inst_1 X) (FreeAlgebra.instSemiringFreeAlgebra.{u1, u2} R _inst_1 X)))) p
Case conversion may be inaccurate. Consider using '#align free_algebra.char_p FreeAlgebra.charPₓ'. -/
/-- If `R` has characteristic `p`, then so does `free_algebra R X`. -/
instance charP [CharP R p] : CharP (FreeAlgebra R X) p :=
  charP_of_injective_algebraMap FreeAlgebra.algebraMap_leftInverse.Injective p
#align free_algebra.char_p FreeAlgebra.charP

/- warning: free_algebra.char_zero -> FreeAlgebra.charZero is a dubious translation:
lean 3 declaration is
  forall {R : Type.{u1}} {X : Type.{u2}} [_inst_1 : CommSemiring.{u1} R] [_inst_2 : CharZero.{u1} R (AddCommMonoidWithOne.toAddMonoidWithOne.{u1} R (NonAssocSemiring.toAddCommMonoidWithOne.{u1} R (Semiring.toNonAssocSemiring.{u1} R (CommSemiring.toSemiring.{u1} R _inst_1))))], CharZero.{max u1 u2} (FreeAlgebra.{u1, u2} R _inst_1 X) (AddCommMonoidWithOne.toAddMonoidWithOne.{max u1 u2} (FreeAlgebra.{u1, u2} R _inst_1 X) (NonAssocSemiring.toAddCommMonoidWithOne.{max u1 u2} (FreeAlgebra.{u1, u2} R _inst_1 X) (Semiring.toNonAssocSemiring.{max u1 u2} (FreeAlgebra.{u1, u2} R _inst_1 X) (FreeAlgebra.semiring.{u1, u2} R _inst_1 X))))
but is expected to have type
  forall {R : Type.{u1}} {X : Type.{u2}} [_inst_1 : CommSemiring.{u1} R] [_inst_2 : CharZero.{u1} R (AddCommMonoidWithOne.toAddMonoidWithOne.{u1} R (NonAssocSemiring.toAddCommMonoidWithOne.{u1} R (Semiring.toNonAssocSemiring.{u1} R (CommSemiring.toSemiring.{u1} R _inst_1))))], CharZero.{max u2 u1} (FreeAlgebra.{u1, u2} R _inst_1 X) (AddCommMonoidWithOne.toAddMonoidWithOne.{max u1 u2} (FreeAlgebra.{u1, u2} R _inst_1 X) (NonAssocSemiring.toAddCommMonoidWithOne.{max u1 u2} (FreeAlgebra.{u1, u2} R _inst_1 X) (Semiring.toNonAssocSemiring.{max u1 u2} (FreeAlgebra.{u1, u2} R _inst_1 X) (FreeAlgebra.instSemiringFreeAlgebra.{u1, u2} R _inst_1 X))))
Case conversion may be inaccurate. Consider using '#align free_algebra.char_zero FreeAlgebra.charZeroₓ'. -/
/-- If `R` has characteristic `0`, then so does `free_algebra R X`. -/
instance charZero [CharZero R] : CharZero (FreeAlgebra R X) :=
  charZero_of_injective_algebraMap FreeAlgebra.algebraMap_leftInverse.Injective
#align free_algebra.char_zero FreeAlgebra.charZero

end FreeAlgebra

namespace IsFractionRing

variable (R : Type _) {K : Type _} [CommRing R] [Field K] [Algebra R K] [IsFractionRing R K]

variable (p : ℕ)

/- warning: is_fraction_ring.char_p_of_is_fraction_ring -> IsFractionRing.charP_of_isFractionRing is a dubious translation:
lean 3 declaration is
  forall (R : Type.{u1}) {K : Type.{u2}} [_inst_1 : CommRing.{u1} R] [_inst_2 : Field.{u2} K] [_inst_3 : Algebra.{u1, u2} R K (CommRing.toCommSemiring.{u1} R _inst_1) (Ring.toSemiring.{u2} K (DivisionRing.toRing.{u2} K (Field.toDivisionRing.{u2} K _inst_2)))] [_inst_4 : IsFractionRing.{u1, u2} R _inst_1 K (Field.toCommRing.{u2} K _inst_2) _inst_3] (p : Nat) [_inst_5 : CharP.{u1} R (AddGroupWithOne.toAddMonoidWithOne.{u1} R (AddCommGroupWithOne.toAddGroupWithOne.{u1} R (Ring.toAddCommGroupWithOne.{u1} R (CommRing.toRing.{u1} R _inst_1)))) p], CharP.{u2} K (AddGroupWithOne.toAddMonoidWithOne.{u2} K (AddCommGroupWithOne.toAddGroupWithOne.{u2} K (Ring.toAddCommGroupWithOne.{u2} K (DivisionRing.toRing.{u2} K (Field.toDivisionRing.{u2} K _inst_2))))) p
but is expected to have type
  forall (R : Type.{u2}) {K : Type.{u1}} [_inst_1 : CommRing.{u2} R] [_inst_2 : Field.{u1} K] [_inst_3 : Algebra.{u2, u1} R K (CommRing.toCommSemiring.{u2} R _inst_1) (DivisionSemiring.toSemiring.{u1} K (Semifield.toDivisionSemiring.{u1} K (Field.toSemifield.{u1} K _inst_2)))] [_inst_4 : IsFractionRing.{u2, u1} R _inst_1 K (Field.toCommRing.{u1} K _inst_2) _inst_3] (p : Nat) [_inst_5 : CharP.{u2} R (AddGroupWithOne.toAddMonoidWithOne.{u2} R (Ring.toAddGroupWithOne.{u2} R (CommRing.toRing.{u2} R _inst_1))) p], CharP.{u1} K (AddGroupWithOne.toAddMonoidWithOne.{u1} K (Ring.toAddGroupWithOne.{u1} K (DivisionRing.toRing.{u1} K (Field.toDivisionRing.{u1} K _inst_2)))) p
Case conversion may be inaccurate. Consider using '#align is_fraction_ring.char_p_of_is_fraction_ring IsFractionRing.charP_of_isFractionRingₓ'. -/
/-- If `R` has characteristic `p`, then so does Frac(R). -/
theorem charP_of_isFractionRing [CharP R p] : CharP K p :=
  charP_of_injective_algebraMap (IsFractionRing.injective R K) p
#align is_fraction_ring.char_p_of_is_fraction_ring IsFractionRing.charP_of_isFractionRing

/- warning: is_fraction_ring.char_zero_of_is_fraction_ring -> IsFractionRing.charZero_of_isFractionRing is a dubious translation:
lean 3 declaration is
  forall (R : Type.{u1}) {K : Type.{u2}} [_inst_1 : CommRing.{u1} R] [_inst_2 : Field.{u2} K] [_inst_3 : Algebra.{u1, u2} R K (CommRing.toCommSemiring.{u1} R _inst_1) (Ring.toSemiring.{u2} K (DivisionRing.toRing.{u2} K (Field.toDivisionRing.{u2} K _inst_2)))] [_inst_4 : IsFractionRing.{u1, u2} R _inst_1 K (Field.toCommRing.{u2} K _inst_2) _inst_3] [_inst_5 : CharZero.{u1} R (AddGroupWithOne.toAddMonoidWithOne.{u1} R (AddCommGroupWithOne.toAddGroupWithOne.{u1} R (Ring.toAddCommGroupWithOne.{u1} R (CommRing.toRing.{u1} R _inst_1))))], CharZero.{u2} K (AddGroupWithOne.toAddMonoidWithOne.{u2} K (AddCommGroupWithOne.toAddGroupWithOne.{u2} K (Ring.toAddCommGroupWithOne.{u2} K (DivisionRing.toRing.{u2} K (Field.toDivisionRing.{u2} K _inst_2)))))
but is expected to have type
  forall (R : Type.{u2}) {K : Type.{u1}} [_inst_1 : CommRing.{u2} R] [_inst_2 : Field.{u1} K] [_inst_3 : Algebra.{u2, u1} R K (CommRing.toCommSemiring.{u2} R _inst_1) (DivisionSemiring.toSemiring.{u1} K (Semifield.toDivisionSemiring.{u1} K (Field.toSemifield.{u1} K _inst_2)))] [_inst_4 : IsFractionRing.{u2, u1} R _inst_1 K (Field.toCommRing.{u1} K _inst_2) _inst_3] [_inst_5 : CharZero.{u2} R (AddGroupWithOne.toAddMonoidWithOne.{u2} R (Ring.toAddGroupWithOne.{u2} R (CommRing.toRing.{u2} R _inst_1)))], CharZero.{u1} K (AddGroupWithOne.toAddMonoidWithOne.{u1} K (Ring.toAddGroupWithOne.{u1} K (DivisionRing.toRing.{u1} K (Field.toDivisionRing.{u1} K _inst_2))))
Case conversion may be inaccurate. Consider using '#align is_fraction_ring.char_zero_of_is_fraction_ring IsFractionRing.charZero_of_isFractionRingₓ'. -/
/-- If `R` has characteristic `0`, then so does Frac(R). -/
theorem charZero_of_isFractionRing [CharZero R] : CharZero K :=
  @CharP.charP_to_charZero K _ (charP_of_isFractionRing R 0)
#align is_fraction_ring.char_zero_of_is_fraction_ring IsFractionRing.charZero_of_isFractionRing

variable [IsDomain R]

/- warning: is_fraction_ring.char_p -> IsFractionRing.charP is a dubious translation:
lean 3 declaration is
  forall (R : Type.{u1}) [_inst_1 : CommRing.{u1} R] (p : Nat) [_inst_5 : IsDomain.{u1} R (Ring.toSemiring.{u1} R (CommRing.toRing.{u1} R _inst_1))] [_inst_6 : CharP.{u1} R (AddGroupWithOne.toAddMonoidWithOne.{u1} R (AddCommGroupWithOne.toAddGroupWithOne.{u1} R (Ring.toAddCommGroupWithOne.{u1} R (CommRing.toRing.{u1} R _inst_1)))) p], CharP.{u1} (FractionRing.{u1} R _inst_1) (AddGroupWithOne.toAddMonoidWithOne.{u1} (FractionRing.{u1} R _inst_1) (AddCommGroupWithOne.toAddGroupWithOne.{u1} (FractionRing.{u1} R _inst_1) (Ring.toAddCommGroupWithOne.{u1} (FractionRing.{u1} R _inst_1) (DivisionRing.toRing.{u1} (FractionRing.{u1} R _inst_1) (Field.toDivisionRing.{u1} (FractionRing.{u1} R _inst_1) (FractionRing.field.{u1} R _inst_1 _inst_5)))))) p
but is expected to have type
  forall (R : Type.{u1}) [_inst_1 : CommRing.{u1} R] (p : Nat) [_inst_5 : IsDomain.{u1} R (Ring.toSemiring.{u1} R (CommRing.toRing.{u1} R _inst_1))] [_inst_6 : CharP.{u1} R (AddGroupWithOne.toAddMonoidWithOne.{u1} R (Ring.toAddGroupWithOne.{u1} R (CommRing.toRing.{u1} R _inst_1))) p], CharP.{u1} (FractionRing.{u1} R _inst_1) (AddGroupWithOne.toAddMonoidWithOne.{u1} (FractionRing.{u1} R _inst_1) (Ring.toAddGroupWithOne.{u1} (FractionRing.{u1} R _inst_1) (DivisionRing.toRing.{u1} (FractionRing.{u1} R _inst_1) (Field.toDivisionRing.{u1} (FractionRing.{u1} R _inst_1) (FractionRing.instFieldFractionRing.{u1} R _inst_1 _inst_5))))) p
Case conversion may be inaccurate. Consider using '#align is_fraction_ring.char_p IsFractionRing.charPₓ'. -/
/-- If `R` has characteristic `p`, then so does `fraction_ring R`. -/
instance charP [CharP R p] : CharP (FractionRing R) p :=
  charP_of_isFractionRing R p
#align is_fraction_ring.char_p IsFractionRing.charP

/- warning: is_fraction_ring.char_zero -> IsFractionRing.charZero is a dubious translation:
lean 3 declaration is
  forall (R : Type.{u1}) [_inst_1 : CommRing.{u1} R] [_inst_5 : IsDomain.{u1} R (Ring.toSemiring.{u1} R (CommRing.toRing.{u1} R _inst_1))] [_inst_6 : CharZero.{u1} R (AddGroupWithOne.toAddMonoidWithOne.{u1} R (AddCommGroupWithOne.toAddGroupWithOne.{u1} R (Ring.toAddCommGroupWithOne.{u1} R (CommRing.toRing.{u1} R _inst_1))))], CharZero.{u1} (FractionRing.{u1} R _inst_1) (AddGroupWithOne.toAddMonoidWithOne.{u1} (FractionRing.{u1} R _inst_1) (AddCommGroupWithOne.toAddGroupWithOne.{u1} (FractionRing.{u1} R _inst_1) (Ring.toAddCommGroupWithOne.{u1} (FractionRing.{u1} R _inst_1) (DivisionRing.toRing.{u1} (FractionRing.{u1} R _inst_1) (Field.toDivisionRing.{u1} (FractionRing.{u1} R _inst_1) (FractionRing.field.{u1} R _inst_1 _inst_5))))))
but is expected to have type
  forall (R : Type.{u1}) [_inst_1 : CommRing.{u1} R] [_inst_5 : IsDomain.{u1} R (Ring.toSemiring.{u1} R (CommRing.toRing.{u1} R _inst_1))] [_inst_6 : CharZero.{u1} R (AddGroupWithOne.toAddMonoidWithOne.{u1} R (Ring.toAddGroupWithOne.{u1} R (CommRing.toRing.{u1} R _inst_1)))], CharZero.{u1} (FractionRing.{u1} R _inst_1) (AddGroupWithOne.toAddMonoidWithOne.{u1} (FractionRing.{u1} R _inst_1) (Ring.toAddGroupWithOne.{u1} (FractionRing.{u1} R _inst_1) (DivisionRing.toRing.{u1} (FractionRing.{u1} R _inst_1) (Field.toDivisionRing.{u1} (FractionRing.{u1} R _inst_1) (FractionRing.instFieldFractionRing.{u1} R _inst_1 _inst_5)))))
Case conversion may be inaccurate. Consider using '#align is_fraction_ring.char_zero IsFractionRing.charZeroₓ'. -/
/-- If `R` has characteristic `0`, then so does `fraction_ring R`. -/
instance charZero [CharZero R] : CharZero (FractionRing R) :=
  charZero_of_isFractionRing R
#align is_fraction_ring.char_zero IsFractionRing.charZero

end IsFractionRing


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

! This file was ported from Lean 3 source module category_theory.pi.basic
! leanprover-community/mathlib commit dc6c365e751e34d100e80fe6e314c3c3e0fd2988
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.CategoryTheory.NatIso
import Mathlib.CategoryTheory.EqToHom
import Mathlib.Data.Sum.Basic

/-!
# Categories of indexed families of objects.

We define the pointwise category structure on indexed families of objects in a category
(and also the dependent generalization).

-/

namespace CategoryTheory

universe w₀ w₁ w₂ v₁ v₂ u₁ u₂

variable {I : Type w₀} {J : Type w₁} (C : I → Type u₁) [∀ i, Category.{v₁} (C i)]

/-- `pi C` gives the cartesian product of an indexed family of categories.
-/
instance pi : Category.{max w₀ v₁} (∀ i, C i) where
  Hom X Y := ∀ i, X i ⟶ Y i
  id X i := 𝟙 (X i)
  comp f g i := f i ≫ g i
#align category_theory.pi CategoryTheory.pi

/-- This provides some assistance to typeclass search in a common situation,
which otherwise fails. (Without this `CategoryTheory.Pi.has_limit_of_has_limit_comp_eval` fails.)
-/
abbrev pi' {I : Type v₁} (C : I → Type u₁) [∀ i, Category.{v₁} (C i)] : Category.{v₁} (∀ i, C i) :=
  CategoryTheory.pi C
#align category_theory.pi' CategoryTheory.pi'

attribute [instance] pi'

namespace Pi

@[simp]
theorem id_apply (X : ∀ i, C i) (i) : (𝟙 X : ∀ i, X i ⟶ X i) i = 𝟙 (X i) :=
  rfl
#align category_theory.pi.id_apply CategoryTheory.Pi.id_apply

@[simp]
theorem comp_apply {X Y Z : ∀ i, C i} (f : X ⟶ Y) (g : Y ⟶ Z) (i) :
    (f ≫ g : ∀ i, X i ⟶ Z i) i = f i ≫ g i :=
  rfl
#align category_theory.pi.comp_apply CategoryTheory.Pi.comp_apply

/--
The evaluation functor at `i : I`, sending an `I`-indexed family of objects to the object over `i`.
-/
@[simps]
def eval (i : I) : (∀ i, C i) ⥤ C i where
  obj f := f i
  map α := α i
#align category_theory.pi.eval CategoryTheory.Pi.eval

section

variable {J : Type w₁}

/- Porting note: add this because Lean cannot see directly through the `∘` for
`Function.comp` -/

instance (f : J → I) : (j : J) → Category ((C ∘ f) j) := by
  dsimp
  infer_instance

/-- Pull back an `I`-indexed family of objects to an `J`-indexed family, along a function `J → I`.
-/
@[simps]
def comap (h : J → I) : (∀ i, C i) ⥤  (∀ j, C (h j)) where
  obj f i := f (h i)
  map α i := α (h i)
#align category_theory.pi.comap CategoryTheory.Pi.comap

variable (I)

/-- The natural isomorphism between
pulling back a grading along the identity function,
and the identity functor. -/
@[simps]
def comapId : comap C (id : I → I) ≅ 𝟭 (∀ i, C i) where
  hom := { app := fun X => 𝟙 X, naturality := by simp only [comap]; aesop_cat}
  inv := { app := fun X => 𝟙 X }
#align category_theory.pi.comap_id CategoryTheory.Pi.comapId

example (g : J → I) : (j : J) → Category (C (g j)) := by infer_instance

variable {I}

variable {K : Type w₂}

/-- The natural isomorphism comparing between
pulling back along two successive functions, and
pulling back along their composition
-/
@[simps!]
def comapComp (f : K → J) (g : J → I) : comap C g ⋙ comap (C ∘ g) f ≅ comap C (g ∘ f) where
  hom := {
    app := fun X b => 𝟙 (X (g (f b)))
    naturality := fun X Y f' => by simp only [comap,Function.comp]; funext; simp
    }
  inv := {
    app := fun X b => 𝟙 (X (g (f b)))
    naturality := fun X Y f' => by simp only [comap,Function.comp]; funext; simp
    }
  hom_inv_id := by
    simp only [comap]
    ext Y
    simp [CategoryStruct.comp,CategoryStruct.id]
  inv_hom_id := by
    simp only [comap]
    ext X
    simp [CategoryStruct.comp,CategoryStruct.id]
#align category_theory.pi.comap_comp CategoryTheory.Pi.comapComp

/-- The natural isomorphism between pulling back then evaluating, and just evaluating. -/
@[simps!]
def comapEvalIsoEval (h : J → I) (j : J) : comap C h ⋙ eval (C ∘ h) j ≅ eval C (h j) :=
  NatIso.ofComponents (fun f => Iso.refl _) (by simp only [Iso.refl]; aesop_cat)
#align category_theory.pi.comap_eval_iso_eval CategoryTheory.Pi.comapEvalIsoEval

end

section

variable {J : Type w₀} {D : J → Type u₁} [∀ j, Category.{v₁} (D j)]

/- Porting note: maybe mixing up universes -/
instance sumElimCategory : ∀ s : Sum I J, Category.{v₁} (Sum.elim C D s)
  | Sum.inl i => by
    dsimp
    infer_instance
  | Sum.inr j => by
    dsimp
    infer_instance
#align category_theory.pi.sum_elim_category CategoryTheory.Pi.sumElimCategoryₓ

/- Porting note: replaced `Sum.rec` with `match`'s per the error about
current state of code generation -/

/-- The bifunctor combining an `I`-indexed family of objects with a `J`-indexed family of objects
to obtain an `I ⊕ J`-indexed family of objects.
-/
@[simps]
def sum : (∀ i, C i) ⥤ (∀ j, D j) ⥤ ∀ s : Sum I J, Sum.elim C D s where
  obj X :=
    { obj := fun Y s =>
        match s with
        | .inl i => X i
        | .inr j => Y j
      map := fun {Y} {Y'} f s =>
        match s with
        | .inl i => 𝟙 (X i)
        | .inr j => f j
      map_id := fun Y => by
          dsimp
          simp only [CategoryStruct.id]
          funext s
          match s with
          | .inl i => simp
          | .inr j => simp
      map_comp := fun {Y₁} {Y₂} {Y₃} f g => by funext s; cases s; repeat {simp} }
  map {X} {X'} f :=
    { app := fun Y s =>
        match s with
        | .inl i => f i
        | .inr j => 𝟙 (Y j)
      naturality := fun {Y} {Y'} g => by funext s; cases s; repeat {simp} }
  map_id := fun X => by
    ext Y; dsimp; simp only [CategoryStruct.id]; funext s; cases s; repeat {simp}
  map_comp := fun f g => by
    ext Y; dsimp; simp only [CategoryStruct.comp]; funext s; cases s; repeat {simp}
#align category_theory.pi.sum CategoryTheory.Pi.sum

end

variable {C}

/-- An isomorphism between `I`-indexed objects gives an isomorphism between each
pair of corresponding components. -/
@[simps]
def isoApp {X Y : ∀ i, C i} (f : X ≅ Y) (i : I) : X i ≅ Y i :=
  ⟨f.hom i, f.inv i, by
    dsimp
    rw [← comp_apply, Iso.hom_inv_id, id_apply],
    by
    dsimp
    rw [← comp_apply, Iso.inv_hom_id, id_apply]⟩
#align category_theory.pi.iso_app CategoryTheory.Pi.isoApp

@[simp]
theorem isoApp_refl (X : ∀ i, C i) (i : I) : isoApp (Iso.refl X) i = Iso.refl (X i) :=
  rfl
#align category_theory.pi.iso_app_refl CategoryTheory.Pi.isoApp_refl

@[simp]
theorem isoApp_symm {X Y : ∀ i, C i} (f : X ≅ Y) (i : I) : isoApp f.symm i = (isoApp f i).symm :=
  rfl
#align category_theory.pi.iso_app_symm CategoryTheory.Pi.isoApp_symm

@[simp]
theorem isoApp_trans {X Y Z : ∀ i, C i} (f : X ≅ Y) (g : Y ≅ Z) (i : I) :
    isoApp (f ≪≫ g) i = isoApp f i ≪≫ isoApp g i :=
  rfl
#align category_theory.pi.iso_app_trans CategoryTheory.Pi.isoApp_trans

end Pi

namespace Functor

variable {C}

variable {D : I → Type u₁} [∀ i, Category.{v₁} (D i)] {A : Type u₁} [Category.{u₁} A]

/-- Assemble an `I`-indexed family of functors into a functor between the pi types.
-/
@[simps]
def pi (F : ∀ i, C i ⥤ D i) : (∀ i, C i) ⥤ ∀ i, D i where
  obj f i := (F i).obj (f i)
  map α i := (F i).map (α i)
#align category_theory.functor.pi CategoryTheory.Functor.pi

/-- Similar to `pi`, but all functors come from the same category `A`
-/
@[simps]
def pi' (f : ∀ i, A ⥤ C i) : A ⥤ ∀ i, C i where
  obj a i := (f i).obj a
  map h i := (f i).map h
#align category_theory.functor.pi' CategoryTheory.Functor.pi'

section EqToHom

@[simp]
theorem eqToHom_proj {x x' : ∀ i, C i} (h : x = x') (i : I) :
    (eqToHom h : x ⟶ x') i = eqToHom (Function.funext_iff.mp h i) := by
  subst h
  rfl
#align category_theory.functor.eq_to_hom_proj CategoryTheory.Functor.eqToHom_proj

end EqToHom

-- One could add some natural isomorphisms showing
-- how `Functor.pi` commutes with `Pi.eval` and `Pi.comap`.
@[simp]
theorem pi'_eval (f : ∀ i, A ⥤ C i) (i : I) : pi' f ⋙  Pi.eval C i = f i := by
  apply Functor.ext
  intro _ _ _
  · simp
  · intro _
    rfl
#align category_theory.functor.pi'_eval CategoryTheory.Functor.pi'_eval

/-- Two functors to a product category are equal iff they agree on every coordinate. -/
theorem pi_ext (f f' : A ⥤ ∀ i, C i) (h : ∀ i, f ⋙ (Pi.eval C i) = f' ⋙ (Pi.eval C i))
    : f = f' := by
  apply Functor.ext; rotate_left
  · intro X
    ext i
    specialize h i
    have := congr_obj h X
    simpa
  · intro X Y g
    dsimp
    funext i
    specialize h i
    have := congr_hom h g
    simpa
#align category_theory.functor.pi_ext CategoryTheory.Functor.pi_ext

end Functor

namespace NatTrans

variable {C}

variable {D : I → Type u₁} [∀ i, Category.{v₁} (D i)]

variable {F G : ∀ i, C i ⥤ D i}

/-- Assemble an `I`-indexed family of natural transformations into a single natural transformation.
-/
@[simps!]
def pi (α : ∀ i, F i ⟶ G i) : Functor.pi F ⟶ Functor.pi G where
  app f i := (α i).app (f i)
  naturality := fun X Y f => by simp [Functor.pi,CategoryStruct.comp]
#align category_theory.nat_trans.pi CategoryTheory.NatTrans.pi

end NatTrans

end CategoryTheory


/-
Copyright (c) 2022 Yaël Dillies. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies
-/
import data.finset.lattice
import order.hom.bounded

/-!
# Lattice homomorphisms

This file defines (bounded) lattice homomorphisms.

We use the `fun_like` design, so each type of morphisms has a companion typeclass which is meant to
be satisfied by itself and all stricter types.

## Types of morphisms

* `sup_hom`: Maps which preserve `⊔`.
* `inf_hom`: Maps which preserve `⊓`.
* `sup_bot_hom`: Finitary supremum homomorphisms. Maps which preserve `⊔` and `⊥`.
* `inf_top_hom`: Finitary infimum homomorphisms. Maps which preserve `⊓` and `⊤`.
* `lattice_hom`: Lattice homomorphisms. Maps which preserve `⊔` and `⊓`.
* `bounded_lattice_hom`: Bounded lattice homomorphisms. Maps which preserve `⊤`, `⊥`, `⊔` and `⊓`.

## Typeclasses

* `sup_hom_class`
* `inf_hom_class`
* `sup_bot_hom_class`
* `inf_top_hom_class`
* `lattice_hom_class`
* `bounded_lattice_hom_class`

## TODO

Do we need more intersections between `bot_hom`, `top_hom` and lattice homomorphisms?
-/

open function order_dual

variables {F ι α β γ δ : Type*}

/-- The type of `⊔`-preserving functions from `α` to `β`. -/
structure sup_hom (α β : Type*) [has_sup α] [has_sup β] :=
(to_fun   : α → β)
(map_sup' (a b : α) : to_fun (a ⊔ b) = to_fun a ⊔ to_fun b)

/-- The type of `⊓`-preserving functions from `α` to `β`. -/
structure inf_hom (α β : Type*) [has_inf α] [has_inf β] :=
(to_fun   : α → β)
(map_inf' (a b : α) : to_fun (a ⊓ b) = to_fun a ⊓ to_fun b)

/-- The type of finitary supremum-preserving homomorphisms from `α` to `β`. -/
structure sup_bot_hom (α β : Type*) [has_sup α] [has_sup β] [has_bot α] [has_bot β]
  extends sup_hom α β :=
(map_bot' : to_fun ⊥ = ⊥)

/-- The type of finitary infimum-preserving homomorphisms from `α` to `β`. -/
structure inf_top_hom (α β : Type*) [has_inf α] [has_inf β] [has_top α] [has_top β]
  extends inf_hom α β :=
(map_top' : to_fun ⊤ = ⊤)

/-- The type of lattice homomorphisms from `α` to `β`. -/
structure lattice_hom (α β : Type*) [lattice α] [lattice β] extends sup_hom α β :=
(map_inf' (a b : α) : to_fun (a ⊓ b) = to_fun a ⊓ to_fun b)

/-- The type of bounded lattice homomorphisms from `α` to `β`. -/
structure bounded_lattice_hom (α β : Type*) [lattice α] [lattice β] [bounded_order α]
  [bounded_order β]
  extends lattice_hom α β :=
(map_top' : to_fun ⊤ = ⊤)
(map_bot' : to_fun ⊥ = ⊥)

/-- `sup_hom_class F α β` states that `F` is a type of `⊔`-preserving morphisms.

You should extend this class when you extend `sup_hom`. -/
class sup_hom_class (F : Type*) (α β : out_param $ Type*) [has_sup α] [has_sup β]
  extends fun_like F α (λ _, β) :=
(map_sup (f : F) (a b : α) : f (a ⊔ b) = f a ⊔ f b)

/-- `inf_hom_class F α β` states that `F` is a type of `⊓`-preserving morphisms.

You should extend this class when you extend `inf_hom`. -/
class inf_hom_class (F : Type*) (α β : out_param $ Type*) [has_inf α] [has_inf β]
  extends fun_like F α (λ _, β) :=
(map_inf (f : F) (a b : α) : f (a ⊓ b) = f a ⊓ f b)

/-- `sup_bot_hom_class F α β` states that `F` is a type of finitary supremum-preserving morphisms.

You should extend this class when you extend `sup_bot_hom`. -/
class sup_bot_hom_class (F : Type*) (α β : out_param $ Type*) [has_sup α] [has_sup β] [has_bot α]
  [has_bot β] extends sup_hom_class F α β :=
(map_bot (f : F) : f ⊥ = ⊥)

/-- `inf_top_hom_class F α β` states that `F` is a type of finitary infimum-preserving morphisms.

You should extend this class when you extend `sup_bot_hom`. -/
class inf_top_hom_class (F : Type*) (α β : out_param $ Type*) [has_inf α]
  [has_inf β] [has_top α] [has_top β] extends inf_hom_class F α β :=
(map_top (f : F) : f ⊤ = ⊤)

/-- `lattice_hom_class F α β` states that `F` is a type of lattice morphisms.

You should extend this class when you extend `lattice_hom`. -/
class lattice_hom_class (F : Type*) (α β : out_param $ Type*) [lattice α] [lattice β]
  extends sup_hom_class F α β :=
(map_inf (f : F) (a b : α) : f (a ⊓ b) = f a ⊓ f b)

/-- `bounded_lattice_hom_class F α β` states that `F` is a type of bounded lattice morphisms.

You should extend this class when you extend `bounded_lattice_hom`. -/
class bounded_lattice_hom_class (F : Type*) (α β : out_param $ Type*) [lattice α] [lattice β]
  [bounded_order α] [bounded_order β]
  extends lattice_hom_class F α β :=
(map_top (f : F) : f ⊤ = ⊤)
(map_bot (f : F) : f ⊥ = ⊥)

export sup_hom_class (map_sup)
export inf_hom_class (map_inf)

attribute [simp] map_top map_bot map_sup map_inf

@[priority 100] -- See note [lower instance priority]
instance sup_hom_class.to_order_hom_class [semilattice_sup α] [semilattice_sup β]
  [sup_hom_class F α β] :
  order_hom_class F α β :=
⟨λ f a b h, by rw [←sup_eq_right, ←map_sup, sup_eq_right.2 h]⟩

@[priority 100] -- See note [lower instance priority]
instance inf_hom_class.to_order_hom_class [semilattice_inf α] [semilattice_inf β]
  [inf_hom_class F α β] : order_hom_class F α β :=
⟨λ f a b h, by rw [←inf_eq_left, ←map_inf, inf_eq_left.2 h]⟩

@[priority 100] -- See note [lower instance priority]
instance sup_bot_hom_class.to_bot_hom_class [has_sup α] [has_sup β] [has_bot α] [has_bot β]
  [sup_bot_hom_class F α β] :
  bot_hom_class F α β :=
{ .. ‹sup_bot_hom_class F α β› }

@[priority 100] -- See note [lower instance priority]
instance inf_top_hom_class.to_top_hom_class [has_inf α] [has_inf β] [has_top α] [has_top β]
  [inf_top_hom_class F α β] :
  top_hom_class F α β :=
{ .. ‹inf_top_hom_class F α β› }

@[priority 100] -- See note [lower instance priority]
instance lattice_hom_class.to_inf_hom_class [lattice α] [lattice β] [lattice_hom_class F α β] :
  inf_hom_class F α β :=
{ .. ‹lattice_hom_class F α β› }

@[priority 100] -- See note [lower instance priority]
instance bounded_lattice_hom_class.to_sup_bot_hom_class [lattice α] [lattice β]
  [bounded_order α] [bounded_order β] [bounded_lattice_hom_class F α β] :
  sup_bot_hom_class F α β :=
{ .. ‹bounded_lattice_hom_class F α β› }

@[priority 100] -- See note [lower instance priority]
instance bounded_lattice_hom_class.to_inf_top_hom_class [lattice α] [lattice β]
  [bounded_order α] [bounded_order β] [bounded_lattice_hom_class F α β] :
  inf_top_hom_class F α β :=
{ .. ‹bounded_lattice_hom_class F α β› }

@[priority 100] -- See note [lower instance priority]
instance bounded_lattice_hom_class.to_bounded_order_hom_class [lattice α] [lattice β]
  [bounded_order α] [bounded_order β] [bounded_lattice_hom_class F α β] :
  bounded_order_hom_class F α β :=
{ .. ‹bounded_lattice_hom_class F α β› }

@[priority 100] -- See note [lower instance priority]
instance order_iso_class.to_sup_hom_class [semilattice_sup α] [semilattice_sup β]
  [order_iso_class F α β] :
  sup_hom_class F α β :=
⟨λ f a b, eq_of_forall_ge_iff $ λ c, by simp only [←le_map_inv_iff, sup_le_iff]⟩

@[priority 100] -- See note [lower instance priority]
instance order_iso_class.to_inf_hom_class [semilattice_inf α] [semilattice_inf β]
  [order_iso_class F α β] :
  inf_hom_class F α β :=
⟨λ f a b, eq_of_forall_le_iff $ λ c, by simp only [←map_inv_le_iff, le_inf_iff]⟩

@[priority 100] -- See note [lower instance priority]
instance order_iso_class.to_sup_bot_hom_class [semilattice_sup α] [order_bot α] [semilattice_sup β]
  [order_bot β] [order_iso_class F α β] :
  sup_bot_hom_class F α β :=
{ ..order_iso_class.to_sup_hom_class, ..order_iso_class.to_bot_hom_class }

@[priority 100] -- See note [lower instance priority]
instance order_iso_class.to_inf_top_hom_class [semilattice_inf α] [order_top α] [semilattice_inf β]
  [order_top β] [order_iso_class F α β] :
  inf_top_hom_class F α β :=
{ ..order_iso_class.to_inf_hom_class, ..order_iso_class.to_top_hom_class }

@[priority 100] -- See note [lower instance priority]
instance order_iso_class.to_lattice_hom_class [lattice α] [lattice β] [order_iso_class F α β] :
  lattice_hom_class F α β :=
{ ..order_iso_class.to_sup_hom_class, ..order_iso_class.to_inf_hom_class }

@[priority 100] -- See note [lower instance priority]
instance order_iso_class.to_bounded_lattice_hom_class [lattice α] [lattice β] [bounded_order α]
  [bounded_order β] [order_iso_class F α β] :
  bounded_lattice_hom_class F α β :=
{ ..order_iso_class.to_lattice_hom_class, ..order_iso_class.to_bounded_order_hom_class }

@[simp] lemma map_finset_sup [semilattice_sup α] [order_bot α] [semilattice_sup β] [order_bot β]
  [sup_bot_hom_class F α β] (f : F) (s : finset ι) (g : ι → α) :
  f (s.sup g) = s.sup (f ∘ g) :=
finset.cons_induction_on s (map_bot f) $ λ i s _ h,
  by rw [finset.sup_cons, finset.sup_cons, map_sup, h]

@[simp] lemma map_finset_inf [semilattice_inf α] [order_top α] [semilattice_inf β] [order_top β]
  [inf_top_hom_class F α β] (f : F) (s : finset ι) (g : ι → α) :
  f (s.inf g) = s.inf (f ∘ g) :=
finset.cons_induction_on s (map_top f) $ λ i s _ h,
  by rw [finset.inf_cons, finset.inf_cons, map_inf, h]

instance [has_sup α] [has_sup β] [sup_hom_class F α β] : has_coe_t F (sup_hom α β) :=
⟨λ f, ⟨f, map_sup f⟩⟩

instance [has_inf α] [has_inf β] [inf_hom_class F α β] : has_coe_t F (inf_hom α β) :=
⟨λ f, ⟨f, map_inf f⟩⟩

instance [has_sup α] [has_sup β] [has_bot α] [has_bot β] [sup_bot_hom_class F α β] :
  has_coe_t F (sup_bot_hom α β) :=
⟨λ f, ⟨f, map_bot f⟩⟩

instance [has_inf α] [has_inf β] [has_top α] [has_top β] [inf_top_hom_class F α β] :
  has_coe_t F (inf_top_hom α β) :=
⟨λ f, ⟨f, map_top f⟩⟩

instance [lattice α] [lattice β] [lattice_hom_class F α β] : has_coe_t F (lattice_hom α β) :=
⟨λ f, { to_fun := f, map_sup' := map_sup f, map_inf' := map_inf f }⟩

instance [lattice α] [lattice β] [bounded_order α] [bounded_order β]
  [bounded_lattice_hom_class F α β] : has_coe_t F (bounded_lattice_hom α β) :=
⟨λ f, { to_fun := f, map_top' := map_top f, map_bot' := map_bot f, ..(f : lattice_hom α β) }⟩

/-! ### Supremum homomorphisms -/

namespace sup_hom
variables [has_sup α]

section has_sup
variables [has_sup β] [has_sup γ] [has_sup δ]

instance : sup_hom_class (sup_hom α β) α β :=
{ coe := sup_hom.to_fun,
  coe_injective' := λ f g h, by cases f; cases g; congr',
  map_sup := sup_hom.map_sup' }

/-- Helper instance for when there's too many metavariables to apply `fun_like.has_coe_to_fun`
directly. -/
instance : has_coe_to_fun (sup_hom α β) (λ _, α → β) := ⟨λ f, f.to_fun⟩

@[simp] lemma to_fun_eq_coe {f : sup_hom α β} : f.to_fun = (f : α → β) := rfl

@[ext] lemma ext {f g : sup_hom α β} (h : ∀ a, f a = g a) : f = g := fun_like.ext f g h

/-- Copy of a `sup_hom` with a new `to_fun` equal to the old one. Useful to fix definitional
equalities. -/
protected def copy (f : sup_hom α β) (f' : α → β) (h : f' = f) : sup_hom α β :=
{ to_fun := f',
  map_sup' := h.symm ▸ f.map_sup' }

variables (α)

/-- `id` as a `sup_hom`. -/
protected def id : sup_hom α α := ⟨id, λ a b, rfl⟩

instance : inhabited (sup_hom α α) := ⟨sup_hom.id α⟩

@[simp] lemma coe_id : ⇑(sup_hom.id α) = id := rfl

variables {α}

@[simp] lemma id_apply (a : α) : sup_hom.id α a = a := rfl

/-- Composition of `sup_hom`s as a `sup_hom`. -/
def comp (f : sup_hom β γ) (g : sup_hom α β) : sup_hom α γ :=
{ to_fun := f ∘ g,
  map_sup' := λ a b, by rw [comp_apply, map_sup, map_sup] }

@[simp] lemma coe_comp (f : sup_hom β γ) (g : sup_hom α β) : (f.comp g : α → γ) = f ∘ g := rfl
@[simp] lemma comp_apply (f : sup_hom β γ) (g : sup_hom α β) (a : α) :
  (f.comp g) a = f (g a) := rfl
@[simp] lemma comp_assoc (f : sup_hom γ δ) (g : sup_hom β γ) (h : sup_hom α β) :
  (f.comp g).comp h = f.comp (g.comp h) := rfl
@[simp] lemma comp_id (f : sup_hom α β) : f.comp (sup_hom.id α) = f := sup_hom.ext $ λ a, rfl
@[simp] lemma id_comp (f : sup_hom α β) : (sup_hom.id β).comp f = f := sup_hom.ext $ λ a, rfl

lemma cancel_right {g₁ g₂ : sup_hom β γ} {f : sup_hom α β} (hf : surjective f) :
  g₁.comp f = g₂.comp f ↔ g₁ = g₂ :=
⟨λ h, sup_hom.ext $ hf.forall.2 $ fun_like.ext_iff.1 h, congr_arg _⟩

lemma cancel_left {g : sup_hom β γ} {f₁ f₂ : sup_hom α β} (hg : injective g) :
  g.comp f₁ = g.comp f₂ ↔ f₁ = f₂ :=
⟨λ h, sup_hom.ext $ λ a, hg $
  by rw [←sup_hom.comp_apply, h, sup_hom.comp_apply], congr_arg _⟩

end has_sup

variables (α) [semilattice_sup β]

/-- The constant function as a `sup_hom`. -/
def const (b : β) : sup_hom α β := ⟨λ _, b, λ _ _, sup_idem.symm⟩

@[simp] lemma coe_const (b : β) : ⇑(const α b) = function.const α b := rfl
@[simp] lemma const_apply (b : β) (a : α) : const α b a = b := rfl

variables {α}

instance : has_sup (sup_hom α β) :=
⟨λ f g, ⟨f ⊔ g, λ a b, by { rw [pi.sup_apply, map_sup, map_sup], exact sup_sup_sup_comm _ _ _ _ }⟩⟩

instance : semilattice_sup (sup_hom α β) := fun_like.coe_injective.semilattice_sup _ $ λ f g, rfl

instance [has_bot β] : has_bot (sup_hom α β) := ⟨sup_hom.const α ⊥⟩
instance [has_top β] : has_top (sup_hom α β) := ⟨sup_hom.const α ⊤⟩

instance [order_bot β] : order_bot (sup_hom α β) :=
order_bot.lift (coe_fn : _ → α → β) (λ _ _, id) rfl

instance [order_top β] : order_top (sup_hom α β) :=
order_top.lift (coe_fn : _ → α → β) (λ _ _, id) rfl

instance [bounded_order β] : bounded_order (sup_hom α β) :=
bounded_order.lift (coe_fn : _ → α → β) (λ _ _, id) rfl rfl

@[simp] lemma coe_sup (f g : sup_hom α β) : ⇑(f ⊔ g) = f ⊔ g := rfl
@[simp] lemma coe_bot [has_bot β] : ⇑(⊥ : sup_hom α β) = ⊥ := rfl
@[simp] lemma coe_top [has_top β] : ⇑(⊤ : sup_hom α β) = ⊤ := rfl
@[simp] lemma sup_apply (f g : sup_hom α β) (a : α) : (f ⊔ g) a = f a ⊔ g a := rfl
@[simp] lemma bot_apply [has_bot β] (a : α) : (⊥ : sup_hom α β) a = ⊥ := rfl
@[simp] lemma top_apply [has_top β] (a : α) : (⊤ : sup_hom α β) a = ⊤ := rfl

end sup_hom

/-! ### Infimum homomorphisms -/

namespace inf_hom
variables [has_inf α]

section has_inf
variables [has_inf β] [has_inf γ] [has_inf δ]

instance : inf_hom_class (inf_hom α β) α β :=
{ coe := inf_hom.to_fun,
  coe_injective' := λ f g h, by cases f; cases g; congr',
  map_inf := inf_hom.map_inf' }

/-- Helper instance for when there's too many metavariables to apply `fun_like.has_coe_to_fun`
directly. -/
instance : has_coe_to_fun (inf_hom α β) (λ _, α → β) := ⟨λ f, f.to_fun⟩

@[simp] lemma to_fun_eq_coe {f : inf_hom α β} : f.to_fun = (f : α → β) := rfl

@[ext] lemma ext {f g : inf_hom α β} (h : ∀ a, f a = g a) : f = g := fun_like.ext f g h

/-- Copy of an `inf_hom` with a new `to_fun` equal to the old one. Useful to fix definitional
equalities. -/
protected def copy (f : inf_hom α β) (f' : α → β) (h : f' = f) : inf_hom α β :=
{ to_fun := f',
  map_inf' := h.symm ▸ f.map_inf' }

variables (α)

/-- `id` as an `inf_hom`. -/
protected def id : inf_hom α α := ⟨id, λ a b, rfl⟩

instance : inhabited (inf_hom α α) := ⟨inf_hom.id α⟩

@[simp] lemma coe_id : ⇑(inf_hom.id α) = id := rfl

variables {α}

@[simp] lemma id_apply (a : α) : inf_hom.id α a = a := rfl

/-- Composition of `inf_hom`s as an `inf_hom`. -/
def comp (f : inf_hom β γ) (g : inf_hom α β) : inf_hom α γ :=
{ to_fun := f ∘ g,
  map_inf' := λ a b, by rw [comp_apply, map_inf, map_inf] }

@[simp] lemma coe_comp (f : inf_hom β γ) (g : inf_hom α β) : (f.comp g : α → γ) = f ∘ g := rfl
@[simp] lemma comp_apply (f : inf_hom β γ) (g : inf_hom α β) (a : α) :
  (f.comp g) a = f (g a) := rfl
@[simp] lemma comp_assoc (f : inf_hom γ δ) (g : inf_hom β γ) (h : inf_hom α β) :
  (f.comp g).comp h = f.comp (g.comp h) := rfl
@[simp] lemma comp_id (f : inf_hom α β) : f.comp (inf_hom.id α) = f := inf_hom.ext $ λ a, rfl
@[simp] lemma id_comp (f : inf_hom α β) : (inf_hom.id β).comp f = f := inf_hom.ext $ λ a, rfl

lemma cancel_right {g₁ g₂ : inf_hom β γ} {f : inf_hom α β} (hf : surjective f) :
  g₁.comp f = g₂.comp f ↔ g₁ = g₂ :=
⟨λ h, inf_hom.ext $ hf.forall.2 $ fun_like.ext_iff.1 h, congr_arg _⟩

lemma cancel_left {g : inf_hom β γ} {f₁ f₂ : inf_hom α β} (hg : injective g) :
  g.comp f₁ = g.comp f₂ ↔ f₁ = f₂ :=
⟨λ h, inf_hom.ext $ λ a, hg $
  by rw [←inf_hom.comp_apply, h, inf_hom.comp_apply], congr_arg _⟩

end has_inf

variables (α) [semilattice_inf β]

/-- The constant function as an `inf_hom`. -/
def const (b : β) : inf_hom α β := ⟨λ _, b, λ _ _, inf_idem.symm⟩

@[simp] lemma coe_const (b : β) : ⇑(const α b) = function.const α b := rfl
@[simp] lemma const_apply (b : β) (a : α) : const α b a = b := rfl

variables {α}

instance : has_inf (inf_hom α β) :=
⟨λ f g, ⟨f ⊓ g, λ a b, by { rw [pi.inf_apply, map_inf, map_inf], exact inf_inf_inf_comm _ _ _ _ }⟩⟩

instance : semilattice_inf (inf_hom α β) := fun_like.coe_injective.semilattice_inf _ $ λ f g, rfl

instance [has_bot β] : has_bot (inf_hom α β) := ⟨inf_hom.const α ⊥⟩
instance [has_top β] : has_top (inf_hom α β) := ⟨inf_hom.const α ⊤⟩

instance [order_bot β] : order_bot (inf_hom α β) :=
order_bot.lift (coe_fn : _ → α → β) (λ _ _, id) rfl

instance [order_top β] : order_top (inf_hom α β) :=
order_top.lift (coe_fn : _ → α → β) (λ _ _, id) rfl

instance [bounded_order β] : bounded_order (inf_hom α β) :=
bounded_order.lift (coe_fn : _ → α → β) (λ _ _, id) rfl rfl

@[simp] lemma coe_inf (f g : inf_hom α β) : ⇑(f ⊓ g) = f ⊓ g := rfl
@[simp] lemma coe_bot [has_bot β] : ⇑(⊥ : inf_hom α β) = ⊥ := rfl
@[simp] lemma coe_top [has_top β] : ⇑(⊤ : inf_hom α β) = ⊤ := rfl
@[simp] lemma inf_apply (f g : inf_hom α β) (a : α) : (f ⊓ g) a = f a ⊓ g a := rfl
@[simp] lemma bot_apply [has_bot β] (a : α) : (⊥ : inf_hom α β) a = ⊥ := rfl
@[simp] lemma top_apply [has_top β] (a : α) : (⊤ : inf_hom α β) a = ⊤ := rfl

end inf_hom

/-! ### Finitary supremum homomorphisms -/

namespace sup_bot_hom
variables [has_sup α] [has_bot α]

section has_sup
variables [has_sup β] [has_bot β] [has_sup γ] [has_bot γ] [has_sup δ] [has_bot δ]

/-- Reinterpret a `sup_bot_hom` as a `bot_hom`. -/
def to_bot_hom (f : sup_bot_hom α β) : bot_hom α β := { ..f }

instance : sup_bot_hom_class (sup_bot_hom α β) α β :=
{ coe :=  λ f, f.to_fun,
  coe_injective' := λ f g h, by { obtain ⟨⟨_, _⟩, _⟩ := f, obtain ⟨⟨_, _⟩, _⟩ := g, congr' },
  map_sup := λ f, f.map_sup',
  map_bot := λ f, f.map_bot' }

/-- Helper instance for when there's too many metavariables to apply `fun_like.has_coe_to_fun`
directly. -/
instance : has_coe_to_fun (sup_bot_hom α β) (λ _, α → β) := fun_like.has_coe_to_fun

@[simp] lemma to_fun_eq_coe {f : sup_bot_hom α β} : f.to_fun = (f : α → β) := rfl

@[ext] lemma ext {f g : sup_bot_hom α β} (h : ∀ a, f a = g a) : f = g := fun_like.ext f g h

/-- Copy of a `sup_bot_hom` with a new `to_fun` equal to the old one. Useful to fix definitional
equalities. -/
protected def copy (f : sup_bot_hom α β) (f' : α → β) (h : f' = f) : sup_bot_hom α β :=
{ to_sup_hom := f.to_sup_hom.copy f' h, ..f.to_bot_hom.copy f' h }

variables (α)

/-- `id` as a `sup_bot_hom`. -/
@[simps] protected def id : sup_bot_hom α α := ⟨sup_hom.id α, rfl⟩

instance : inhabited (sup_bot_hom α α) := ⟨sup_bot_hom.id α⟩

@[simp] lemma coe_id : ⇑(sup_bot_hom.id α) = id := rfl

variables {α}

@[simp] lemma id_apply (a : α) : sup_bot_hom.id α a = a := rfl

/-- Composition of `sup_bot_hom`s as a `sup_bot_hom`. -/
def comp (f : sup_bot_hom β γ) (g : sup_bot_hom α β) : sup_bot_hom α γ :=
{ ..f.to_sup_hom.comp g.to_sup_hom, ..f.to_bot_hom.comp g.to_bot_hom }

@[simp] lemma coe_comp (f : sup_bot_hom β γ) (g : sup_bot_hom α β) : (f.comp g : α → γ) = f ∘ g :=
rfl
@[simp] lemma comp_apply (f : sup_bot_hom β γ) (g : sup_bot_hom α β) (a : α) :
  (f.comp g) a = f (g a) := rfl
@[simp] lemma comp_assoc (f : sup_bot_hom γ δ) (g : sup_bot_hom β γ) (h : sup_bot_hom α β) :
  (f.comp g).comp h = f.comp (g.comp h) := rfl
@[simp] lemma comp_id (f : sup_bot_hom α β) : f.comp (sup_bot_hom.id α) = f := ext $ λ a, rfl
@[simp] lemma id_comp (f : sup_bot_hom α β) : (sup_bot_hom.id β).comp f = f := ext $ λ a, rfl

lemma cancel_right {g₁ g₂ : sup_bot_hom β γ} {f : sup_bot_hom α β} (hf : surjective f) :
  g₁.comp f = g₂.comp f ↔ g₁ = g₂ :=
⟨λ h, ext $ hf.forall.2 $ fun_like.ext_iff.1 h, congr_arg _⟩

lemma cancel_left {g : sup_bot_hom β γ} {f₁ f₂ : sup_bot_hom α β} (hg : injective g) :
  g.comp f₁ = g.comp f₂ ↔ f₁ = f₂ :=
⟨λ h, sup_bot_hom.ext $ λ a, hg $
  by rw [←comp_apply, h, comp_apply], congr_arg _⟩

end has_sup

variables [semilattice_sup β] [order_bot β]

instance : has_sup (sup_bot_hom α β) :=
⟨λ f g, { to_sup_hom := f.to_sup_hom ⊔ g.to_sup_hom, ..f.to_bot_hom ⊔ g.to_bot_hom }⟩

instance : semilattice_sup (sup_bot_hom α β) :=
fun_like.coe_injective.semilattice_sup _ $ λ f g, rfl

instance : order_bot (sup_bot_hom α β) := { bot := ⟨⊥, rfl⟩, bot_le := λ f, bot_le }

@[simp] lemma coe_sup (f g : sup_bot_hom α β) : ⇑(f ⊔ g) = f ⊔ g := rfl
@[simp] lemma coe_bot : ⇑(⊥ : sup_bot_hom α β) = ⊥ := rfl
@[simp] lemma sup_apply (f g : sup_bot_hom α β) (a : α) : (f ⊔ g) a = f a ⊔ g a := rfl
@[simp] lemma bot_apply (a : α) : (⊥ : sup_bot_hom α β) a = ⊥ := rfl

end sup_bot_hom

/-! ### Finitary infimum homomorphisms -/

namespace inf_top_hom
variables [has_inf α] [has_top α]

section has_inf
variables [has_inf β] [has_top β] [has_inf γ] [has_top γ] [has_inf δ] [has_top δ]

/-- Reinterpret an `inf_top_hom` as a `top_hom`. -/
def to_top_hom (f : inf_top_hom α β) : top_hom α β := { ..f }

instance : inf_top_hom_class (inf_top_hom α β) α β :=
{ coe :=  λ f, f.to_fun,
  coe_injective' := λ f g h, by { obtain ⟨⟨_, _⟩, _⟩ := f, obtain ⟨⟨_, _⟩, _⟩ := g, congr' },
  map_inf := λ f, f.map_inf',
  map_top := λ f, f.map_top' }

/-- Helper instance for when there's too many metavariables to apply `fun_like.has_coe_to_fun`
directly. -/
instance : has_coe_to_fun (inf_top_hom α β) (λ _, α → β) := fun_like.has_coe_to_fun

@[simp] lemma to_fun_eq_coe {f : inf_top_hom α β} : f.to_fun = (f : α → β) := rfl

@[ext] lemma ext {f g : inf_top_hom α β} (h : ∀ a, f a = g a) : f = g := fun_like.ext f g h

/-- Copy of an `inf_top_hom` with a new `to_fun` equal to the old one. Useful to fix definitional
equalities. -/
protected def copy (f : inf_top_hom α β) (f' : α → β) (h : f' = f) : inf_top_hom α β :=
{ to_inf_hom := f.to_inf_hom.copy f' h, ..f.to_top_hom.copy f' h }

variables (α)

/-- `id` as an `inf_top_hom`. -/
@[simps] protected def id : inf_top_hom α α := ⟨inf_hom.id α, rfl⟩

instance : inhabited (inf_top_hom α α) := ⟨inf_top_hom.id α⟩

@[simp] lemma coe_id : ⇑(inf_top_hom.id α) = id := rfl

variables {α}

@[simp] lemma id_apply (a : α) : inf_top_hom.id α a = a := rfl

/-- Composition of `inf_top_hom`s as an `inf_top_hom`. -/
def comp (f : inf_top_hom β γ) (g : inf_top_hom α β) : inf_top_hom α γ :=
{ ..f.to_inf_hom.comp g.to_inf_hom, ..f.to_top_hom.comp g.to_top_hom }

@[simp] lemma coe_comp (f : inf_top_hom β γ) (g : inf_top_hom α β) : (f.comp g : α → γ) = f ∘ g :=
rfl
@[simp] lemma comp_apply (f : inf_top_hom β γ) (g : inf_top_hom α β) (a : α) :
  (f.comp g) a = f (g a) := rfl
@[simp] lemma comp_assoc (f : inf_top_hom γ δ) (g : inf_top_hom β γ) (h : inf_top_hom α β) :
  (f.comp g).comp h = f.comp (g.comp h) := rfl
@[simp] lemma comp_id (f : inf_top_hom α β) : f.comp (inf_top_hom.id α) = f := ext $ λ a, rfl
@[simp] lemma id_comp (f : inf_top_hom α β) : (inf_top_hom.id β).comp f = f := ext $ λ a, rfl

lemma cancel_right {g₁ g₂ : inf_top_hom β γ} {f : inf_top_hom α β} (hf : surjective f) :
  g₁.comp f = g₂.comp f ↔ g₁ = g₂ :=
⟨λ h, ext $ hf.forall.2 $ fun_like.ext_iff.1 h, congr_arg _⟩

lemma cancel_left {g : inf_top_hom β γ} {f₁ f₂ : inf_top_hom α β} (hg : injective g) :
  g.comp f₁ = g.comp f₂ ↔ f₁ = f₂ :=
⟨λ h, inf_top_hom.ext $ λ a, hg $
  by rw [←comp_apply, h, comp_apply], congr_arg _⟩

end has_inf

variables [semilattice_inf β] [order_top β]

instance : has_inf (inf_top_hom α β) :=
⟨λ f g, { to_inf_hom := f.to_inf_hom ⊓ g.to_inf_hom, ..f.to_top_hom ⊓ g.to_top_hom }⟩

instance : semilattice_inf (inf_top_hom α β) :=
fun_like.coe_injective.semilattice_inf _ $ λ f g, rfl

instance : order_top (inf_top_hom α β) := { top := ⟨⊤, rfl⟩, le_top := λ f, le_top }

@[simp] lemma coe_inf (f g : inf_top_hom α β) : ⇑(f ⊓ g) = f ⊓ g := rfl
@[simp] lemma coe_top : ⇑(⊤ : inf_top_hom α β) = ⊤ := rfl
@[simp] lemma inf_apply (f g : inf_top_hom α β) (a : α) : (f ⊓ g) a = f a ⊓ g a := rfl
@[simp] lemma top_apply (a : α) : (⊤ : inf_top_hom α β) a = ⊤ := rfl

end inf_top_hom

/-! ### Lattice homomorphisms -/

namespace lattice_hom
variables [lattice α] [lattice β] [lattice γ] [lattice δ]

/-- Reinterpret a `lattice_hom` as an `inf_hom`. -/
def to_inf_hom (f : lattice_hom α β) : inf_hom α β := { ..f }

instance : lattice_hom_class (lattice_hom α β) α β :=
{ coe := λ f, f.to_fun,
  coe_injective' := λ f g h, by obtain ⟨⟨_, _⟩, _⟩ := f; obtain ⟨⟨_, _⟩, _⟩ := g; congr',
  map_sup := λ f, f.map_sup',
  map_inf := λ f, f.map_inf' }

/-- Helper instance for when there's too many metavariables to apply `fun_like.has_coe_to_fun`
directly. -/
instance : has_coe_to_fun (lattice_hom α β) (λ _, α → β) := ⟨λ f, f.to_fun⟩

@[simp] lemma to_fun_eq_coe {f : lattice_hom α β} : f.to_fun = (f : α → β) := rfl

@[ext] lemma ext {f g : lattice_hom α β} (h : ∀ a, f a = g a) : f = g := fun_like.ext f g h

/-- Copy of a `lattice_hom` with a new `to_fun` equal to the old one. Useful to fix definitional
equalities. -/
protected def copy (f : lattice_hom α β) (f' : α → β) (h : f' = f) : lattice_hom α β :=
{ .. f.to_sup_hom.copy f' h, .. f.to_inf_hom.copy f' h }

variables (α)

/-- `id` as a `lattice_hom`. -/
protected def id : lattice_hom α α :=
{ to_fun := id,
  map_sup' := λ _ _, rfl,
  map_inf' := λ _ _, rfl }

instance : inhabited (lattice_hom α α) := ⟨lattice_hom.id α⟩

@[simp] lemma coe_id : ⇑(lattice_hom.id α) = id := rfl

variables {α}

@[simp] lemma id_apply (a : α) : lattice_hom.id α a = a := rfl

/-- Composition of `lattice_hom`s as a `lattice_hom`. -/
def comp (f : lattice_hom β γ) (g : lattice_hom α β) : lattice_hom α γ :=
{ ..f.to_sup_hom.comp g.to_sup_hom, ..f.to_inf_hom.comp g.to_inf_hom }

@[simp] lemma coe_comp (f : lattice_hom β γ) (g : lattice_hom α β) : (f.comp g : α → γ) = f ∘ g :=
rfl
@[simp] lemma comp_apply (f : lattice_hom β γ) (g : lattice_hom α β) (a : α) :
  (f.comp g) a = f (g a) := rfl
@[simp] lemma coe_comp_sup_hom (f : lattice_hom β γ) (g : lattice_hom α β) :
  (f.comp g : sup_hom α γ) = (f : sup_hom β γ).comp g := rfl
@[simp] lemma coe_comp_inf_hom (f : lattice_hom β γ) (g : lattice_hom α β) :
  (f.comp g : inf_hom α γ) = (f : inf_hom β γ).comp g := rfl
@[simp] lemma comp_assoc (f : lattice_hom γ δ) (g : lattice_hom β γ) (h : lattice_hom α β) :
  (f.comp g).comp h = f.comp (g.comp h) := rfl
@[simp] lemma comp_id (f : lattice_hom α β) : f.comp (lattice_hom.id α) = f :=
lattice_hom.ext $ λ a, rfl
@[simp] lemma id_comp (f : lattice_hom α β) : (lattice_hom.id β).comp f = f :=
lattice_hom.ext $ λ a, rfl

lemma cancel_right {g₁ g₂ : lattice_hom β γ} {f : lattice_hom α β} (hf : surjective f) :
  g₁.comp f = g₂.comp f ↔ g₁ = g₂ :=
⟨λ h, lattice_hom.ext $ hf.forall.2 $ fun_like.ext_iff.1 h, congr_arg _⟩

lemma cancel_left {g : lattice_hom β γ} {f₁ f₂ : lattice_hom α β} (hg : injective g) :
  g.comp f₁ = g.comp f₂ ↔ f₁ = f₂ :=
⟨λ h, lattice_hom.ext $ λ a, hg $
  by rw [←lattice_hom.comp_apply, h, lattice_hom.comp_apply], congr_arg _⟩

end lattice_hom

namespace order_hom_class
variables (α β) [linear_order α] [lattice β] [order_hom_class F α β]

/-- An order homomorphism from a linear order is a lattice homomorphism. -/
@[reducible] def to_lattice_hom_class : lattice_hom_class F α β :=
{ map_sup := λ f a b, begin
    obtain h | h := le_total a b,
    { rw [sup_eq_right.2 h, sup_eq_right.2 (order_hom_class.mono f h : f a ≤ f b)] },
    { rw [sup_eq_left.2 h, sup_eq_left.2 (order_hom_class.mono f h : f b ≤ f a)] }
  end,
  map_inf := λ f a b, begin
    obtain h | h := le_total a b,
    { rw [inf_eq_left.2 h, inf_eq_left.2 (order_hom_class.mono f h : f a ≤ f b)] },
    { rw [inf_eq_right.2 h, inf_eq_right.2 (order_hom_class.mono f h : f b ≤ f a)] }
  end,
  .. ‹order_hom_class F α β› }

/-- Reinterpret an order homomorphism to a linear order as a `lattice_hom`. -/
def to_lattice_hom (f : F) : lattice_hom α β :=
by { haveI : lattice_hom_class F α β := order_hom_class.to_lattice_hom_class α β, exact f }

@[simp] lemma coe_to_lattice_hom (f : F) : ⇑(to_lattice_hom α β f) = f := rfl
@[simp] lemma to_lattice_hom_apply (f : F) (a : α) : to_lattice_hom α β f a = f a := rfl

end order_hom_class

/-! ### Bounded lattice homomorphisms -/

namespace bounded_lattice_hom
variables [lattice α] [lattice β] [lattice γ] [lattice δ] [bounded_order α] [bounded_order β]
  [bounded_order γ] [bounded_order δ]

/-- Reinterpret a `bounded_lattice_hom` as a `sup_bot_hom`. -/
def to_sup_bot_hom (f : bounded_lattice_hom α β) : sup_bot_hom α β := { ..f }

/-- Reinterpret a `bounded_lattice_hom` as an `inf_top_hom`. -/
def to_inf_top_hom (f : bounded_lattice_hom α β) : inf_top_hom α β := { ..f }

/-- Reinterpret a `bounded_lattice_hom` as a `bounded_order_hom`. -/
def to_bounded_order_hom (f : bounded_lattice_hom α β) : bounded_order_hom α β :=
{ ..f, ..(f.to_lattice_hom : α →o β) }

instance : bounded_lattice_hom_class (bounded_lattice_hom α β) α β :=
{ coe := λ f, f.to_fun,
  coe_injective' := λ f g h, by obtain ⟨⟨⟨_, _⟩, _⟩, _⟩ := f; obtain ⟨⟨⟨_, _⟩, _⟩, _⟩ := g; congr',
  map_sup := λ f, f.map_sup',
  map_inf := λ f, f.map_inf',
  map_top := λ f, f.map_top',
  map_bot := λ f, f.map_bot' }

/-- Helper instance for when there's too many metavariables to apply `fun_like.has_coe_to_fun`
directly. -/
instance : has_coe_to_fun (bounded_lattice_hom α β) (λ _, α → β) := ⟨λ f, f.to_fun⟩

@[simp] lemma to_fun_eq_coe {f : bounded_lattice_hom α β} : f.to_fun = (f : α → β) := rfl

@[ext] lemma ext {f g : bounded_lattice_hom α β} (h : ∀ a, f a = g a) : f = g := fun_like.ext f g h

/-- Copy of a `bounded_lattice_hom` with a new `to_fun` equal to the old one. Useful to fix
definitional equalities. -/
protected def copy (f : bounded_lattice_hom α β) (f' : α → β) (h : f' = f) :
  bounded_lattice_hom α β :=
{ .. f.to_lattice_hom.copy f' h, .. f.to_bounded_order_hom.copy f' h }

variables (α)

/-- `id` as a `bounded_lattice_hom`. -/
protected def id : bounded_lattice_hom α α := { ..lattice_hom.id α, ..bounded_order_hom.id α }

instance : inhabited (bounded_lattice_hom α α) := ⟨bounded_lattice_hom.id α⟩

@[simp] lemma coe_id : ⇑(bounded_lattice_hom.id α) = id := rfl

variables {α}

@[simp] lemma id_apply (a : α) : bounded_lattice_hom.id α a = a := rfl

/-- Composition of `bounded_lattice_hom`s as a `bounded_lattice_hom`. -/
def comp (f : bounded_lattice_hom β γ) (g : bounded_lattice_hom α β) : bounded_lattice_hom α γ :=
{ ..f.to_lattice_hom.comp g.to_lattice_hom, ..f.to_bounded_order_hom.comp g.to_bounded_order_hom }

@[simp] lemma coe_comp (f : bounded_lattice_hom β γ) (g : bounded_lattice_hom α β) :
  (f.comp g : α → γ) = f ∘ g := rfl
@[simp] lemma comp_apply (f : bounded_lattice_hom β γ) (g : bounded_lattice_hom α β) (a : α) :
  (f.comp g) a = f (g a) := rfl
@[simp] lemma coe_comp_lattice_hom (f : bounded_lattice_hom β γ) (g : bounded_lattice_hom α β) :
  (f.comp g : lattice_hom α γ) = (f : lattice_hom β γ).comp g := rfl
@[simp] lemma coe_comp_sup_hom (f : bounded_lattice_hom β γ) (g : bounded_lattice_hom α β) :
  (f.comp g : sup_hom α γ) = (f : sup_hom β γ).comp g := rfl
@[simp] lemma coe_comp_inf_hom (f : bounded_lattice_hom β γ) (g : bounded_lattice_hom α β) :
  (f.comp g : inf_hom α γ) = (f : inf_hom β γ).comp g := rfl
@[simp] lemma comp_assoc (f : bounded_lattice_hom γ δ) (g : bounded_lattice_hom β γ)
  (h : bounded_lattice_hom α β) :
  (f.comp g).comp h = f.comp (g.comp h) := rfl
@[simp] lemma comp_id (f : bounded_lattice_hom α β) : f.comp (bounded_lattice_hom.id α) = f :=
bounded_lattice_hom.ext $ λ a, rfl
@[simp] lemma id_comp (f : bounded_lattice_hom α β) : (bounded_lattice_hom.id β).comp f = f :=
bounded_lattice_hom.ext $ λ a, rfl

lemma cancel_right {g₁ g₂ : bounded_lattice_hom β γ} {f : bounded_lattice_hom α β}
  (hf : surjective f) :
  g₁.comp f = g₂.comp f ↔ g₁ = g₂ :=
⟨λ h, bounded_lattice_hom.ext $ hf.forall.2 $ fun_like.ext_iff.1 h, congr_arg _⟩

lemma cancel_left {g : bounded_lattice_hom β γ} {f₁ f₂ : bounded_lattice_hom α β}
  (hg : injective g) :
  g.comp f₁ = g.comp f₂ ↔ f₁ = f₂ :=
⟨λ h, ext $ λ a, hg $ by rw [←comp_apply, h, comp_apply], congr_arg _⟩

end bounded_lattice_hom

/-! ### Dual homs -/

namespace sup_hom
variables [has_sup α] [has_sup β] [has_sup γ]

/-- Reinterpret a supremum homomorphism as an infimum homomorphism between the dual lattices. -/
@[simps] protected def dual : sup_hom α β ≃ inf_hom (order_dual α) (order_dual β) :=
{ to_fun := λ f, ⟨f, f.map_sup'⟩,
  inv_fun := λ f, ⟨f, f.map_inf'⟩,
  left_inv := λ f, sup_hom.ext $ λ _, rfl,
  right_inv := λ f, inf_hom.ext $ λ _, rfl }

@[simp] lemma dual_id : (sup_hom.id α).dual = inf_hom.id _ := rfl
@[simp] lemma dual_comp (g : sup_hom β γ) (f : sup_hom α β) :
  (g.comp f).dual = g.dual.comp f.dual := rfl

@[simp] lemma symm_dual_id : sup_hom.dual.symm (inf_hom.id _) = sup_hom.id α := rfl
@[simp] lemma symm_dual_comp (g : inf_hom (order_dual β) (order_dual γ))
  (f : inf_hom (order_dual α) (order_dual β)) :
  sup_hom.dual.symm (g.comp f) = (sup_hom.dual.symm g).comp (sup_hom.dual.symm f) := rfl

end sup_hom

namespace inf_hom
variables [has_inf α] [has_inf β] [has_inf γ]

/-- Reinterpret an infimum homomorphism as a supremum homomorphism between the dual lattices. -/
@[simps] protected def dual : inf_hom α β ≃ sup_hom (order_dual α) (order_dual β) :=
{ to_fun := λ f, ⟨f, f.map_inf'⟩,
  inv_fun := λ f, ⟨f, f.map_sup'⟩,
  left_inv := λ f, inf_hom.ext $ λ _, rfl,
  right_inv := λ f, sup_hom.ext $ λ _, rfl }

@[simp] lemma dual_id : (inf_hom.id α).dual = sup_hom.id _ := rfl
@[simp] lemma dual_comp (g : inf_hom β γ) (f : inf_hom α β) :
  (g.comp f).dual = g.dual.comp f.dual := rfl

@[simp] lemma symm_dual_id : inf_hom.dual.symm (sup_hom.id _) = inf_hom.id α := rfl
@[simp] lemma symm_dual_comp (g : sup_hom (order_dual β) (order_dual γ))
  (f : sup_hom (order_dual α) (order_dual β)) :
  inf_hom.dual.symm (g.comp f) = (inf_hom.dual.symm g).comp (inf_hom.dual.symm f) := rfl

end inf_hom

namespace sup_bot_hom
variables [has_sup α] [has_bot α] [has_sup β] [has_bot β] [has_sup γ] [has_bot γ]

/-- Reinterpret a finitary supremum homomorphism as a finitary infimum homomorphism between the dual
lattices. -/
def dual : sup_bot_hom α β ≃ inf_top_hom (order_dual α) (order_dual β) :=
{ to_fun := λ f, ⟨f.to_sup_hom.dual, f.map_bot'⟩,
  inv_fun := λ f, ⟨sup_hom.dual.symm f.to_inf_hom, f.map_top'⟩,
  left_inv := λ f, sup_bot_hom.ext $ λ _, rfl,
  right_inv := λ f, inf_top_hom.ext $ λ _, rfl }

@[simp] lemma dual_id : (sup_bot_hom.id α).dual = inf_top_hom.id _ := rfl
@[simp] lemma dual_comp (g : sup_bot_hom β γ) (f : sup_bot_hom α β) :
  (g.comp f).dual = g.dual.comp f.dual := rfl

@[simp] lemma symm_dual_id : sup_bot_hom.dual.symm (inf_top_hom.id _) = sup_bot_hom.id α := rfl
@[simp] lemma symm_dual_comp (g : inf_top_hom (order_dual β) (order_dual γ))
  (f : inf_top_hom (order_dual α) (order_dual β)) :
  sup_bot_hom.dual.symm (g.comp f) = (sup_bot_hom.dual.symm g).comp (sup_bot_hom.dual.symm f) := rfl

end sup_bot_hom

namespace inf_top_hom
variables [has_inf α] [has_top α] [has_inf β] [has_top β] [has_inf γ] [has_top γ]

/-- Reinterpret a finitary infimum homomorphism as a finitary supremum homomorphism between the dual
lattices. -/
@[simps] protected def dual : inf_top_hom α β ≃ sup_bot_hom (order_dual α) (order_dual β) :=
{ to_fun := λ f, ⟨f.to_inf_hom.dual, f.map_top'⟩,
  inv_fun := λ f, ⟨inf_hom.dual.symm f.to_sup_hom, f.map_bot'⟩,
  left_inv := λ f, inf_top_hom.ext $ λ _, rfl,
  right_inv := λ f, sup_bot_hom.ext $ λ _, rfl }

@[simp] lemma dual_id : (inf_top_hom.id α).dual = sup_bot_hom.id _ := rfl
@[simp] lemma dual_comp (g : inf_top_hom β γ) (f : inf_top_hom α β) :
  (g.comp f).dual = g.dual.comp f.dual := rfl

@[simp] lemma symm_dual_id : inf_top_hom.dual.symm (sup_bot_hom.id _) = inf_top_hom.id α := rfl
@[simp] lemma symm_dual_comp (g : sup_bot_hom (order_dual β) (order_dual γ))
  (f : sup_bot_hom (order_dual α) (order_dual β)) :
  inf_top_hom.dual.symm (g.comp f) = (inf_top_hom.dual.symm g).comp (inf_top_hom.dual.symm f) := rfl

end inf_top_hom

namespace lattice_hom
variables [lattice α] [lattice β] [lattice γ]

/-- Reinterpret a lattice homomorphism as a lattice homomorphism between the dual lattices. -/
@[simps] protected def dual : lattice_hom α β ≃ lattice_hom (order_dual α) (order_dual β) :=
{ to_fun := λ f, ⟨f.to_inf_hom.dual, f.map_sup'⟩,
  inv_fun := λ f, ⟨f.to_inf_hom.dual, f.map_sup'⟩,
  left_inv := λ f, ext $ λ a, rfl,
  right_inv := λ f, ext $ λ a, rfl }

@[simp] lemma dual_id : (lattice_hom.id α).dual = lattice_hom.id _ := rfl
@[simp] lemma dual_comp (g : lattice_hom β γ) (f : lattice_hom α β) :
  (g.comp f).dual = g.dual.comp f.dual := rfl

@[simp] lemma symm_dual_id : lattice_hom.dual.symm (lattice_hom.id _) = lattice_hom.id α := rfl
@[simp] lemma symm_dual_comp (g : lattice_hom (order_dual β) (order_dual γ))
  (f : lattice_hom (order_dual α) (order_dual β)) :
  lattice_hom.dual.symm (g.comp f) = (lattice_hom.dual.symm g).comp (lattice_hom.dual.symm f) := rfl

end lattice_hom

namespace bounded_lattice_hom
variables [lattice α] [bounded_order α] [lattice β] [bounded_order β] [lattice γ] [bounded_order γ]

/-- Reinterpret a bounded lattice homomorphism as a bounded lattice homomorphism between the dual
bounded lattices. -/
@[simps] protected def dual :
   bounded_lattice_hom α β ≃ bounded_lattice_hom (order_dual α) (order_dual β) :=
{ to_fun := λ f, ⟨f.to_lattice_hom.dual, f.map_bot', f.map_top'⟩,
  inv_fun := λ f, ⟨lattice_hom.dual.symm f.to_lattice_hom, f.map_bot', f.map_top'⟩,
  left_inv := λ f, ext $ λ a, rfl,
  right_inv := λ f, ext $ λ a, rfl }

@[simp] lemma dual_id : (bounded_lattice_hom.id α).dual = bounded_lattice_hom.id _ := rfl
@[simp] lemma dual_comp (g : bounded_lattice_hom β γ) (f : bounded_lattice_hom α β) :
  (g.comp f).dual = g.dual.comp f.dual := rfl

@[simp] lemma symm_dual_id :
  bounded_lattice_hom.dual.symm (bounded_lattice_hom.id _) = bounded_lattice_hom.id α := rfl
@[simp] lemma symm_dual_comp (g : bounded_lattice_hom (order_dual β) (order_dual γ))
  (f : bounded_lattice_hom (order_dual α) (order_dual β)) :
  bounded_lattice_hom.dual.symm (g.comp f) =
    (bounded_lattice_hom.dual.symm g).comp (bounded_lattice_hom.dual.symm f) := rfl

end bounded_lattice_hom