import tactic.simps
import algebra.group.hom

universe variables v u w
-- set_option trace.simps.verbose true
-- set_option trace.simps.debug true
-- set_option trace.app_builder true

open function tactic expr

structure equiv (α : Sort*) (β : Sort*) :=
(to_fun    : α → β)
(inv_fun   : β → α)
(left_inv  : left_inverse inv_fun to_fun)
(right_inv : right_inverse inv_fun to_fun)

local infix ` ≃ `:25 := equiv

-- initialize_simps_projections equiv

/- Since `prod` and `pprod` are a special case for `@[simps]`, we define a new structure to test
  the basic functionality.-/
structure my_prod (α β : Type*) := (fst : α) (snd : β)

def myprod.map {α α' β β'} (f : α → α') (g : β → β') (x : my_prod α β) : my_prod α' β' :=
⟨f x.1, g x.2⟩

namespace foo
@[simps] protected def rfl {α} : α ≃ α :=
⟨id, λ x, x, λ x, rfl, λ x, rfl⟩

/- simps adds declarations -/
run_cmd do
  e ← get_env,
  e.get `foo.rfl_to_fun,
  e.get `foo.rfl_inv_fun,
  success_if_fail (e.get `foo.rfl_left_inv),
  success_if_fail (e.get `foo.rfl_right_inv)

example (n : ℕ) : foo.rfl.to_fun n = n := by rw [foo.rfl_to_fun, id]
example (n : ℕ) : foo.rfl.inv_fun n = n := by rw [foo.rfl_inv_fun]

/- the declarations are simp-lemmas -/
@[simps] def foo : ℕ × ℤ := (1, 2)

example : foo.1 = 1 := by simp
example : foo.2 = 2 := by simp
example : foo.1 = 1 := by { dsimp, refl } -- check that dsimp also unfolds
example : foo.2 = 2 := by { dsimp, refl }
example {α} (x : α) : foo.rfl.to_fun x = x := by simp
example {α} (x : α) : foo.rfl.inv_fun x = x := by simp
example {α} (x : α) : foo.rfl.to_fun = @id α := by { success_if_fail {simp}, refl }

/- check some failures -/
def bar1 : ℕ := 1 -- type is not a structure
noncomputable def bar2 {α} : α ≃ α :=
classical.choice ⟨foo.rfl⟩

run_cmd do
  success_if_fail_with_msg (simps_tac `foo.bar1)
    "Invalid `simps` attribute. Target nat is not a structure",
  success_if_fail_with_msg (simps_tac `foo.bar2)
    "Invalid `simps` attribute. The body is not a constructor application:
  classical.choice bar2._proof_1",
  e ← get_env,
  let nm := `foo.bar1,
  d ← e.get nm,
  let lhs : expr := const d.to_name (d.univ_params.map level.param),
  simps_add_projections e nm "" d.type lhs d.value [] d.univ_params ff {} [] []

/- test that if a non-constructor is given as definition, then
  `{rhs_md := semireducible, simp_rhs := tt}` is applied automatically. -/
@[simps] def rfl2 {α} : α ≃ α := foo.rfl

example {α} (x : α) : rfl2.to_fun x = x ∧ rfl2.inv_fun x = x :=
begin
  dsimp only [rfl2_to_fun, rfl2_inv_fun],
  guard_target (x = x ∧ x = x),
  exact ⟨rfl, rfl⟩
end

/- test `fully_applied` option -/

@[simps {fully_applied := ff}] def rfl3 {α} : α ≃ α := ⟨id, λ x, x, λ x, rfl, λ x, rfl⟩

end foo

/- we reduce the type when applying [simps] -/
def my_equiv := equiv
@[simps] def baz : my_equiv ℕ ℕ := ⟨id, λ x, x, λ x, rfl, λ x, rfl⟩

/- test name clashes -/
def name_clash_fst := 1
def name_clash_snd := 1
def name_clash_snd_2 := 1
@[simps] def name_clash := (2, 3)

run_cmd do
  e ← get_env,
  e.get `name_clash_fst_2,
  e.get `name_clash_snd_3

/- check projections for nested structures -/

namespace count_nested
@[simps {attrs := [`simp, `norm]}] def nested1 : my_prod ℕ $ my_prod ℤ ℕ :=
⟨2, -1, 1⟩

@[simps {attrs := []}] def nested2 : ℕ × my_prod ℕ ℕ :=
⟨2, myprod.map nat.succ nat.pred ⟨1, 2⟩⟩

end count_nested

run_cmd do
  e ← get_env,
  e.get `count_nested.nested1_fst,
  e.get `count_nested.nested1_snd_fst,
  e.get `count_nested.nested1_snd_snd,
  e.get `count_nested.nested2_fst,
  e.get `count_nested.nested2_snd,
  is_simp_lemma `count_nested.nested1_fst >>= λ b, guard b, -- simp attribute is global
  is_simp_lemma `count_nested.nested2_fst >>= λ b, guard $ ¬b, --lemmas_only doesn't add simp lemma
  guard $ 7 = e.fold 0 -- there are no other lemmas generated
    (λ d n, n + if d.to_name.components.init.ilast = `count_nested then 1 else 0)

-- testing with arguments
@[simps] def bar {α : Type*} (n m : ℕ) : ℕ × ℤ :=
⟨n - m, n + m⟩

structure equiv_plus_data (α β) extends α ≃ β :=
(P : (α → β) → Prop)
(data : P to_fun)

structure automorphism_plus_data α extends α ⊕ α ≃ α ⊕ α :=
(P : (α ⊕ α → α ⊕ α) → Prop)
(data : P to_fun)
(extra : bool → my_prod ℕ ℕ)

@[simps]
def refl_with_data {α} : equiv_plus_data α α :=
{ P := λ f, f = id,
  data := rfl,
  ..foo.rfl }

@[simps]
def refl_with_data' {α} : equiv_plus_data α α :=
{ P := λ f, f = id,
  data := rfl,
  to_equiv := foo.rfl }

/- test whether eta expansions are reduced correctly -/
@[simps]
def test {α} : automorphism_plus_data α :=
{ P := λ f, f = id,
  data := rfl,
  extra := λ b, ⟨(⟨3, 5⟩ : my_prod _ _).1, (⟨3, 5⟩ : my_prod _ _).2⟩,
  ..foo.rfl }

/- test whether this is indeed rejected as a valid eta expansion -/
@[simps]
def test_sneaky {α} : automorphism_plus_data α :=
{ P := λ f, f = id,
  data := rfl,
  extra := λ b, ⟨(3,5).1,(3,5).2⟩,
  ..foo.rfl }

run_cmd do
  e ← get_env,
  e.get `refl_with_data_to_equiv,
  e.get `refl_with_data'_to_equiv,
  e.get `test_extra,
  e.get `test_sneaky_extra_fst,
  success_if_fail (e.get `refl_with_data_to_equiv_to_fun),
  success_if_fail (e.get `refl_with_data'_to_equiv_to_fun),
  success_if_fail (e.get `test_extra_fst),
  success_if_fail (e.get `test_sneaky_extra)

structure partially_applied_str :=
(data : ℕ → my_prod ℕ ℕ)

/- if we have a partially applied constructor, we treat it as if it were eta-expanded -/
@[simps]
def partially_applied_term : partially_applied_str := ⟨my_prod.mk 3⟩

run_cmd do
  e ← get_env,
  e.get `partially_applied_term_data_fst,
  e.get `partially_applied_term_data_snd

structure very_partially_applied_str :=
(data : ∀β, ℕ → β → my_prod ℕ β)

/- if we have a partially applied constructor, we treat it as if it were eta-expanded.
  (this is not very useful, and we could remove this behavior if convenient) -/
@[simps]
def very_partially_applied_term : very_partially_applied_str := ⟨@my_prod.mk ℕ⟩

run_cmd do
  e ← get_env,
  e.get `very_partially_applied_term_data_fst,
  e.get `very_partially_applied_term_data_snd

@[simps] def let1 : ℕ × ℤ :=
let n := 3 in ⟨n + 4, 5⟩

@[simps] def let2 : ℕ × ℤ :=
let n := 3, m := 4 in let k := 5 in ⟨n + m, k⟩

@[simps] def let3 : ℕ → ℕ × ℤ :=
λ n, let m := 4, k := 5 in ⟨n + m, k⟩

@[simps] def let4 : ℕ → ℕ × ℤ :=
let m := 4, k := 5 in λ n, ⟨n + m, k⟩

run_cmd do
  e ← get_env,
  e.get `let1_fst, e.get `let2_fst, e.get `let3_fst, e.get `let4_fst,
  e.get `let1_snd, e.get `let2_snd, e.get `let3_snd, e.get `let4_snd

namespace specify
@[simps fst] def specify1 : ℕ × ℕ × ℕ := (1, 2, 3)
@[simps snd] def specify2 : ℕ × ℕ × ℕ := (1, 2, 3)
@[simps snd_fst] def specify3 : ℕ × ℕ × ℕ := (1, 2, 3)
@[simps snd snd_snd snd_snd] def specify4 : ℕ × ℕ × ℕ := (1, 2, 3) -- last argument is ignored
@[simps] noncomputable def specify5 : ℕ × ℕ × ℕ := (1, classical.choice ⟨(2, 3)⟩)
end specify

run_cmd do
  e ← get_env,
  e.get `specify.specify1_fst, e.get `specify.specify2_snd,
  e.get `specify.specify3_snd_fst, e.get `specify.specify4_snd_snd, e.get `specify.specify4_snd,
  e.get `specify.specify5_fst, e.get `specify.specify5_snd,
  guard $ 12 = e.fold 0 -- there are no other lemmas generated
    (λ d n, n + if d.to_name.components.init.ilast = `specify then 1 else 0),
  success_if_fail_with_msg (simps_tac `specify.specify1 {} ["fst_fst"])
    "Invalid simp-lemma specify.specify1_fst_fst.
Projection fst doesn't exist, because target is not a structure.",
  success_if_fail_with_msg (simps_tac `specify.specify1 {} ["foo_fst"])
    "Invalid simp-lemma specify.specify1_foo_fst. Structure prod does not have projection foo.
The known projections are:
  [fst, snd]
You can also see this information by running
  `initialize_simps_projections? prod`.
Note: these projection names might not correspond to the projection names of the structure.",
  success_if_fail_with_msg (simps_tac `specify.specify1 {} ["snd_bar"])
    "Invalid simp-lemma specify.specify1_snd_bar. Structure prod does not have projection bar.
The known projections are:
  [fst, snd]
You can also see this information by running
  `initialize_simps_projections? prod`.
Note: these projection names might not correspond to the projection names of the structure.",
  success_if_fail_with_msg (simps_tac `specify.specify5 {} ["snd_snd"])
    "Invalid simp-lemma specify.specify5_snd_snd.
The given definition is not a constructor application:
  classical.choice specify.specify5._proof_1"

/- We also eta-reduce if we explicitly specify the projection. -/
attribute [simps extra] test
run_cmd do
  e ← get_env,
  d1 ← e.get `test_extra,
  d2 ← e.get `test_extra_2,
  guard $ d1.type =ₐ d2.type,
  skip

/- check short_name option -/
@[simps {short_name := tt}] def short_name1 : my_prod ℕ ℕ × my_prod ℕ ℕ := ⟨⟨1, 2⟩, 3, 4⟩
run_cmd do
  e ← get_env,
  e.get `short_name1_fst, e.get `short_name1_fst_2,
  e.get `short_name1_snd, e.get `short_name1_snd_2

/- check simp_rhs option -/
@[simps {simp_rhs := tt}] def equiv.trans {α β γ} (f : α ≃ β) (g : β ≃ γ) : α ≃ γ :=
⟨g.to_fun ∘ f.to_fun, f.inv_fun ∘ g.inv_fun,
  by { intro x, simp [equiv.left_inv _ _] }, by { intro x, simp [equiv.right_inv _ _] }⟩

example {α β γ : Type} (f : α ≃ β) (g : β ≃ γ) (x : α) :
  (f.trans g).to_fun x = (f.trans g).to_fun x :=
begin
  dsimp only [equiv.trans_to_fun],
  guard_target g.to_fun (f.to_fun x) = g.to_fun (f.to_fun x),
  refl,
end

local attribute [simp] nat.zero_add nat.one_mul nat.mul_one
@[simps {simp_rhs := tt}] def my_nat_equiv : ℕ ≃ ℕ :=
⟨λ n, 0 + n, λ n, 1 * n * 1, by { intro n, simp }, by { intro n, simp }⟩

run_cmd success_if_fail (has_attribute `_refl_lemma `my_nat_equiv_to_fun) >>
  has_attribute `_refl_lemma `equiv.trans_to_fun

example (n : ℕ) : my_nat_equiv.to_fun (my_nat_equiv.to_fun $ my_nat_equiv.inv_fun n) = n :=
by { success_if_fail { refl }, simp only [my_nat_equiv_to_fun, my_nat_equiv_inv_fun] }

@[simps {simp_rhs := tt}] def succeed_without_simplification_possible : ℕ ≃ ℕ :=
⟨λ n, n, λ n, n, by { intro n, refl }, by { intro n, refl }⟩

/- test that we don't recursively take projections of `prod` and `pprod` -/
@[simps] def pprod_equiv_prod : pprod ℕ ℕ ≃ ℕ × ℕ :=
{ to_fun := λ x, ⟨x.1, x.2⟩,
  inv_fun := λ x, ⟨x.1, x.2⟩,
  left_inv := λ ⟨x, y⟩, rfl,
  right_inv := λ ⟨x, y⟩, rfl }

run_cmd do
  e ← get_env,
  e.get `pprod_equiv_prod_to_fun,
  e.get `pprod_equiv_prod_inv_fun

attribute [simps to_fun_fst inv_fun_snd] pprod_equiv_prod

run_cmd do
  e ← get_env,
  e.get `pprod_equiv_prod_to_fun_fst,
  e.get `pprod_equiv_prod_inv_fun_snd

-- we can disable this behavior with the option `not_recursive`.
@[simps {not_recursive := []}] def pprod_equiv_prod2 : pprod ℕ ℕ ≃ ℕ × ℕ :=
pprod_equiv_prod

run_cmd do
  e ← get_env,
  e.get `pprod_equiv_prod2_to_fun_fst,
  e.get `pprod_equiv_prod2_to_fun_snd,
  e.get `pprod_equiv_prod2_inv_fun_fst,
  e.get `pprod_equiv_prod2_inv_fun_snd

/- Tests with universe levels -/
class has_hom (obj : Type u) : Type (max u (v+1)) :=
(hom : obj → obj → Type v)

infixr ` ⟶ `:10 := has_hom.hom -- type as \h

class category_struct (obj : Type u) extends has_hom.{v} obj : Type (max u (v+1)) :=
(id       : Π X : obj, hom X X)
(comp     : Π {X Y Z : obj}, (X ⟶ Y) → (Y ⟶ Z) → (X ⟶ Z))

notation `𝟙` := category_struct.id -- type as \b1
infixr ` ≫ `:80 := category_struct.comp -- type as \gg

@[simps] instance types : category_struct (Type u) :=
{ hom     := λ a b, (a → b),
  id      := λ a, id,
  comp    := λ _ _ _ f g, g ∘ f }

example (X : Type u) : (X ⟶ X) = (X → X) := by simp
example (X : Type u) : 𝟙 X = (λ x, x) := by { funext, simp }
example (X Y Z : Type u) (f : X ⟶ Y) (g : Y ⟶ Z) : f ≫ g = g ∘ f := by { funext, simp }

namespace coercing

structure foo_str :=
 (c : Type)
 (x : c)

instance : has_coe_to_sort foo_str := ⟨_, foo_str.c⟩

@[simps] def foo : foo_str := ⟨ℕ, 3⟩
@[simps] def foo2 : foo_str := ⟨ℕ, 34⟩

example : ↥foo = ℕ := by simp only [foo_c]
example : foo.x = (3 : ℕ) := by simp only [foo_x]

structure voo_str (n : ℕ) :=
 (c : Type)
 (x : c)

instance has_coe_voo_str (n : ℕ) : has_coe_to_sort (voo_str n) := ⟨_, voo_str.c⟩

@[simps] def voo : voo_str 7 := ⟨ℕ, 3⟩
@[simps] def voo2 : voo_str 4 := ⟨ℕ, 34⟩

example : ↥voo = ℕ := by simp only [voo_c]
example : voo.x = (3 : ℕ) := by simp only [voo_x]

structure equiv2 (α : Sort*) (β : Sort*) :=
(to_fun    : α → β)
(inv_fun   : β → α)
(left_inv  : left_inverse inv_fun to_fun)
(right_inv : right_inverse inv_fun to_fun)

instance {α β} : has_coe_to_fun $ equiv2 α β := ⟨_, equiv2.to_fun⟩

@[simps] protected def rfl2 {α} : equiv2 α α :=
⟨λ x, x, λ x, x, λ x, rfl, λ x, rfl⟩

example {α} (x : α) : coercing.rfl2 x = x := by rw [coercing.rfl2_to_fun]
example {α} (x : α) : coercing.rfl2 x = x := by simp
example {α} (x : α) : coercing.rfl2.inv_fun x = x := by simp

@[simps] protected def equiv2.symm {α β} (f : equiv2 α β) : equiv2 β α :=
⟨f.inv_fun, f, f.right_inv, f.left_inv⟩

@[simps] protected def equiv2.symm2 {α β} (f : equiv2 α β) : equiv2 β α :=
⟨f.inv_fun, f.to_fun, f.right_inv, f.left_inv⟩

/- we can use the `md` attribute to not unfold the `has_coe_to_fun` attribute, so that `@[simps]`
  doesn't recognize that the type of `⇑f` is still a function type. -/
@[simps {type_md := reducible}] protected def equiv2.symm3 {α β} (f : equiv2 α β) : equiv2 β α :=
⟨f.inv_fun, f, f.right_inv, f.left_inv⟩

example {α β} (f : equiv2 α β) (y : β) : f.symm y = f.inv_fun y := by simp
example {α β} (f : equiv2 α β) (x : α) : f.symm.inv_fun x = f x := by simp

example {α β} (f : equiv2 α β) : f.symm.inv_fun = f := by { success_if_fail {simp}, refl }
example {α β} (f : equiv2 α β) : f.symm3.inv_fun = f := by simp

section
set_option old_structure_cmd true
class semigroup (G : Type u) extends has_mul G :=
(mul_assoc : ∀ a b c : G, a * b * c = a * (b * c))
end

@[simps] instance {α β} [semigroup α] [semigroup β] : semigroup (α × β) :=
{ mul := λ x y, (x.1 * y.1, x.2 * y.2),
  mul_assoc := by { intros, simp only [semigroup.mul_assoc], refl } }

example {α β} [semigroup α] [semigroup β] (x y : α × β) : x * y = (x.1 * y.1, x.2 * y.2) :=
by simp
example {α β} [semigroup α] [semigroup β] (x y : α × β) : (x * y).1 = x.1 * y.1 := by simp

structure Semigroup :=
  (G : Type*)
  (op : G → G → G)
  (infix * := op)
  (op_assoc : ∀ (x y z : G), (x * y) * z = x * (y * z))

namespace Group

instance : has_coe_to_sort Semigroup := ⟨_, Semigroup.G⟩
-- We could try to generate lemmas with this `has_mul` instance, but it is unused in mathlib.
-- Therefore, this is ignored.
instance (G : Semigroup) : has_mul G := ⟨G.op⟩

@[simps] def prod_Semigroup (G H : Semigroup) : Semigroup :=
{ G := G × H,
  op := λ x y, (x.1 * y.1, x.2 * y.2),
  op_assoc := by { intros, dsimp [Group.has_mul], simp [Semigroup.op_assoc] }}

end Group

section
set_option old_structure_cmd true
class extending_stuff (G : Type u) extends has_mul G, has_zero G, has_neg G, has_subset G :=
(new_axiom : ∀ x : G, x * - 0 ⊆ - x)
end

@[simps] def bar : extending_stuff ℕ :=
{ mul := (*),
  zero := 0,
  neg := nat.succ,
  subset := λ x y, true,
  new_axiom := λ x, trivial }

section
local attribute [instance] bar
example (x : ℕ) : x * - 0 ⊆ - x := by simp
end

class new_extending_stuff (G : Type u) extends has_mul G, has_zero G, has_neg G, has_subset G :=
(new_axiom : ∀ x : G, x * - 0 ⊆ - x)

@[simps] def new_bar : new_extending_stuff ℕ :=
{ mul := (*),
  zero := 0,
  neg := nat.succ,
  subset := λ x y, true,
  new_axiom := λ x, trivial }

section
local attribute [instance] new_bar
example (x : ℕ) : x * - 0 ⊆ - x := by simp
end

end coercing

namespace manual_coercion

structure equiv (α : Sort*) (β : Sort*) :=
(to_fun    : α → β)
(inv_fun   : β → α)

local infix ` ≃ `:25 := manual_coercion.equiv

variables {α β γ : Sort*}

instance : has_coe_to_fun $ α ≃ β := ⟨_, equiv.to_fun⟩

def equiv.symm (e : α ≃ β) : β ≃ α := ⟨e.inv_fun, e.to_fun⟩

/-- See Note [custom simps projection] -/
def equiv.simps.inv_fun (e : α ≃ β) : β → α := e.symm

/-- Composition of equivalences `e₁ : α ≃ β` and `e₂ : β ≃ γ`. -/
@[simps {simp_rhs := tt}] protected def equiv.trans (e₁ : α ≃ β) (e₂ : β ≃ γ) : α ≃ γ :=
⟨e₂ ∘ e₁, e₁.symm ∘ e₂.symm⟩

example (e₁ : α ≃ β) (e₂ : β ≃ γ) (x : γ) : (e₁.trans e₂).symm x = e₁.symm (e₂.symm x) :=
by simp only [equiv.trans_inv_fun]

end manual_coercion

namespace faulty_manual_coercion

structure equiv (α : Sort*) (β : Sort*) :=
(to_fun    : α → β)
(inv_fun   : β → α)

local infix ` ≃ `:25 := faulty_manual_coercion.equiv

variables {α β γ : Sort*}

/-- See Note [custom simps projection] -/
noncomputable def equiv.simps.inv_fun (e : α ≃ β) : β → α := classical.choice ⟨e.inv_fun⟩

run_cmd do e ← get_env, success_if_fail_with_msg (simps_get_raw_projections e `faulty_manual_coercion.equiv)
"Invalid custom projection:
  λ {α : Sort u_1} {β : Sort u_2} (e : α ≃ β), classical.choice _
Expression is not definitionally equal to λ (α : Sort u_1) (β : Sort u_2) (x : α ≃ β), x.inv_fun."

end faulty_manual_coercion

namespace manual_initialize
/- defining a manual coercion. -/
variables {α β γ : Sort*}

structure equiv (α : Sort*) (β : Sort*) :=
(to_fun    : α → β)
(inv_fun   : β → α)

local infix ` ≃ `:25 := manual_initialize.equiv

instance : has_coe_to_fun $ α ≃ β := ⟨_, equiv.to_fun⟩

def equiv.symm (e : α ≃ β) : β ≃ α := ⟨e.inv_fun, e.to_fun⟩

/-- See Note [custom simps projection] -/
-- test: intentionally using different unvierse levels for equiv.symm than for equiv
def equiv.simps.inv_fun (e : α ≃ β) : β → α := e.symm

initialize_simps_projections equiv

run_cmd has_attribute `_simps_str `manual_initialize.equiv

/-- Composition of equivalences `e₁ : α ≃ β` and `e₂ : β ≃ γ`. -/
@[simps {simp_rhs := tt}] protected def equiv.trans (e₁ : α ≃ β) (e₂ : β ≃ γ) : α ≃ γ :=
⟨e₂ ∘ e₁, e₁.symm ∘ e₂.symm⟩

end manual_initialize

namespace faulty_universes

variables {α β γ : Sort*}

structure equiv (α : Sort u) (β : Sort v) :=
(to_fun    : α → β)
(inv_fun   : β → α)

local infix ` ≃ `:25 := faulty_universes.equiv

instance : has_coe_to_fun $ α ≃ β := ⟨_, equiv.to_fun⟩

def equiv.symm (e : α ≃ β) : β ≃ α := ⟨e.inv_fun, e.to_fun⟩

/-- See Note [custom simps projection] -/
-- test: intentionally using different names for the universe variables for equiv.symm than for
-- equiv
def equiv.simps.inv_fun {α : Type u} {β : Type v} (e : α ≃ β) : β → α := e.symm

run_cmd do e ← get_env,
  success_if_fail_with_msg (simps_get_raw_projections e `faulty_universes.equiv)
"Invalid custom projection:
  λ {α : Type u} {β : Type v} (e : α ≃ β), ⇑(e.symm)
Expression has different type than faulty_universes.equiv.inv_fun. Given type:
  Π {α : Type u} {β : Type v} (e : α ≃ β), has_coe_to_fun.F e.symm
Expected type:
  Π (α : Sort u) (β : Sort v), α ≃ β → β → α"

end faulty_universes

namespace manual_universes

variables {α β γ : Sort*}

structure equiv (α : Sort u) (β : Sort v) :=
(to_fun    : α → β)
(inv_fun   : β → α)

local infix ` ≃ `:25 := manual_universes.equiv

instance : has_coe_to_fun $ α ≃ β := ⟨_, equiv.to_fun⟩

def equiv.symm (e : α ≃ β) : β ≃ α := ⟨e.inv_fun, e.to_fun⟩

/-- See Note [custom simps projection] -/
-- test: intentionally using different unvierse levels for equiv.symm than for equiv
def equiv.simps.inv_fun {α : Sort w} {β : Sort u} (e : α ≃ β) : β → α := e.symm

-- check whether we can generate custom projections even if the universe names don't match
initialize_simps_projections equiv

end manual_universes

namespace manual_projection_names

structure equiv (α : Sort*) (β : Sort*) :=
(to_fun    : α → β)
(inv_fun   : β → α)

local infix ` ≃ `:25 := manual_projection_names.equiv

variables {α β γ : Sort*}

instance : has_coe_to_fun $ α ≃ β := ⟨_, equiv.to_fun⟩

def equiv.symm (e : α ≃ β) : β ≃ α := ⟨e.inv_fun, e.to_fun⟩

/-- See Note [custom simps projection] -/
def equiv.simps.symm_apply (e : α ≃ β) : β → α := e.symm
-- set_option trace.simps.debug true
initialize_simps_projections equiv (to_fun → apply, inv_fun → symm_apply)

run_cmd do
  e ← get_env,
  data ← simps_get_raw_projections e `manual_projection_names.equiv,
  guard $ data.2.map prod.fst = [`apply, `symm_apply]

@[simps {simp_rhs := tt}] protected def equiv.trans (e₁ : α ≃ β) (e₂ : β ≃ γ) : α ≃ γ :=
⟨e₂ ∘ e₁, e₁.symm ∘ e₂.symm⟩

example (e₁ : α ≃ β) (e₂ : β ≃ γ) (x : α) : (e₁.trans e₂) x = e₂ (e₁ x) :=
by simp only [equiv.trans_apply]

example (e₁ : α ≃ β) (e₂ : β ≃ γ) (x : γ) : (e₁.trans e₂).symm x = e₁.symm (e₂.symm x) :=
by simp only [equiv.trans_symm_apply]

-- the new projection names are parsed correctly (the old projection names won't work anymore)
@[simps apply symm_apply] protected def equiv.trans2 (e₁ : α ≃ β) (e₂ : β ≃ γ) : α ≃ γ :=
⟨e₂ ∘ e₁, e₁.symm ∘ e₂.symm⟩

-- initialize_simps_projections equiv

end manual_projection_names

-- test transparency setting
structure set_plus (α : Type) :=
(s : set α)
(x : α)
(h : x ∈ s)

@[simps] def nat_set_plus : set_plus ℕ := ⟨set.univ, 1, trivial⟩

example : nat_set_plus.s = set.univ :=
begin
  dsimp only [nat_set_plus_s],
  guard_target @set.univ ℕ = set.univ,
  refl
end

@[simps {type_md := semireducible}] def nat_set_plus2 : set_plus ℕ := ⟨set.univ, 1, trivial⟩

example : nat_set_plus2.s = set.univ :=
begin
  success_if_fail { dsimp only [nat_set_plus2_s] }, refl
end

@[simps {rhs_md := semireducible}] def nat_set_plus3 : set_plus ℕ := nat_set_plus

example : nat_set_plus3.s = set.univ :=
begin
  dsimp only [nat_set_plus3_s],
  guard_target @set.univ ℕ = set.univ,
  refl
end

namespace nested_non_fully_applied

structure equiv (α : Sort*) (β : Sort*) :=
(to_fun    : α → β)
(inv_fun   : β → α)

local infix ` ≃ `:25 := nested_non_fully_applied.equiv

variables {α β γ : Sort*}

@[simps] def equiv.symm (e : α ≃ β) : β ≃ α := ⟨e.inv_fun, e.to_fun⟩

@[simps {rhs_md := semireducible, fully_applied := ff}] def equiv.symm2 : (α ≃ β) ≃ (β ≃ α) :=
⟨equiv.symm, equiv.symm⟩

example (e : α ≃ β) : (equiv.symm2.inv_fun e).to_fun = e.inv_fun :=
begin
  dsimp only [equiv.symm2_inv_fun_to_fun],
  guard_target e.inv_fun = e.inv_fun,
  refl
end

/- do not prematurely unfold `equiv.symm`, unless necessary -/
@[simps to_fun to_fun_to_fun {rhs_md := semireducible}] def equiv.symm3 : (α ≃ β) ≃ (β ≃ α) :=
equiv.symm2

example (e : α ≃ β) (y : β) : (equiv.symm3.to_fun e).to_fun y = e.inv_fun y ∧
  (equiv.symm3.to_fun e).to_fun y = e.inv_fun y :=
begin
  split,
  { dsimp only [equiv.symm3_to_fun], guard_target e.symm.to_fun y = e.inv_fun y, refl },
  { dsimp only [equiv.symm3_to_fun_to_fun], guard_target e.inv_fun y = e.inv_fun y, refl }
end

end nested_non_fully_applied

-- test that type classes which are props work
class prop_class (n : ℕ) : Prop :=
(has_true : true)

instance has_prop_class (n : ℕ) : prop_class n := ⟨trivial⟩

structure needs_prop_class (n : ℕ) [prop_class n] :=
(t : true)

@[simps] def test_prop_class : needs_prop_class 1 :=
{ t := trivial }

/- check that when the coercion is given in eta-expanded form, we can also find the coercion. -/
structure alg_hom (R A B : Type*) :=
(to_fun : A → B)

instance (R A B : Type*) : has_coe_to_fun (alg_hom R A B) := ⟨_, λ f, f.to_fun⟩

@[simps] def my_alg_hom : alg_hom unit bool bool :=
{ to_fun := id }

example (x : bool) : my_alg_hom x = id x := by simp only [my_alg_hom_to_fun]

structure ring_hom (A B : Type*) :=
(to_fun : A → B)

instance (A B : Type*) : has_coe_to_fun (ring_hom A B) := ⟨_, λ f, f.to_fun⟩

@[simps] def my_ring_hom : ring_hom bool bool :=
{ to_fun := id }

example (x : bool) : my_ring_hom x = id x := by simp only [my_ring_hom_to_fun]

/- check interaction with the `@[to_additive]` attribute -/

@[to_additive, simps]
instance {M N} [has_mul M] [has_mul N] : has_mul (M × N) := ⟨λ p q, ⟨p.1 * q.1, p.2 * q.2⟩⟩

run_cmd do
  e ← get_env,
  e.get `prod.has_mul_mul,
  e.get `prod.has_add_add,
  has_attribute `to_additive `prod.has_mul,
  has_attribute `to_additive `prod.has_mul_mul,
  has_attribute `simp `prod.has_mul_mul,
  has_attribute `simp `prod.has_add_add

example {M N} [has_mul M] [has_mul N] (p q : M × N) : p * q = ⟨p.1 * q.1, p.2 * q.2⟩ := by simp
example {M N} [has_add M] [has_add N] (p q : M × N) : p + q = ⟨p.1 + q.1, p.2 + q.2⟩ := by simp

/- The names of the generated simp lemmas for the additive version are not great if the definition
  had a custom additive name -/
@[to_additive my_add_instance, simps]
instance my_instance {M N} [has_one M] [has_one N] : has_one (M × N) := ⟨(1, 1)⟩

run_cmd do
  e ← get_env,
  e.get `my_instance_one,
  e.get `my_instance_zero,
  has_attribute `to_additive `my_instance,
  has_attribute `to_additive `my_instance_one,
  has_attribute `simp `my_instance_one,
  has_attribute `simp `my_instance_zero

example {M N} [has_one M] [has_one N] : (1 : M × N) = ⟨1, 1⟩ := by simp
example {M N} [has_zero M] [has_zero N] : (0 : M × N) = ⟨0, 0⟩ := by simp

section
/-! Test `dsimp, simp` with the option `simp_rhs` -/

local attribute [simp] nat.add

structure my_type :=
(A : Type)

@[simps {simp_rhs := tt}] def my_type_def : my_type := ⟨{ x : fin (nat.add 3 0) // 1 + 1 = 2 }⟩

example (h : false) (x y : { x : fin (nat.add 3 0) // 1 + 1 = 2 }) : my_type_def.A = unit :=
begin
  simp only [my_type_def_A],
  guard_target ({ x : fin 3 // true } = unit),
  /- note: calling only one of `simp` or `dsimp` does not produce the current target,
  as the following tests show. -/
  success_if_fail { guard_hyp x : { x : fin 3 // true } },
  dsimp at x,
  success_if_fail { guard_hyp x : { x : fin 3 // true } },
  simp at y,
  success_if_fail { guard_hyp y : { x : fin 3 // true } },
  simp at x, dsimp at y,
  guard_hyp x : { x : fin 3 // true },
  guard_hyp y : { x : fin 3 // true },
  contradiction
end

/- Test that `to_additive` copies the `@[_refl_lemma]` attribute correctly -/
@[to_additive, simps]
def monoid_hom.my_comp {M N P : Type*} [mul_one_class M] [mul_one_class N] [mul_one_class P]
  (hnp : N →* P) (hmn : M →* N) : M →* P :=
{ to_fun := hnp ∘ hmn, map_one' := by simp, map_mul' := by simp, }

-- `simps` adds the `_refl_lemma` attribute to `monoid_hom.my_comp_apply`
example {M N P : Type*} [mul_one_class M] [mul_one_class N] [mul_one_class P]
  (hnp : N →* P) (hmn : M →* N) (m : M) : hnp.my_comp hmn m = hnp (hmn m) :=
by { dsimp, guard_target (hnp (hmn m) = hnp (hmn m)), refl }

-- `to_additive` adds the `_refl_lemma` attribute to `add_monoid_hom.my_comp_apply`
example {M N P : Type*} [add_zero_class M] [add_zero_class N] [add_zero_class P]
  (hnp : N →+ P) (hmn : M →+ N) (m : M) : hnp.my_comp hmn m = hnp (hmn m) :=
by { dsimp, guard_target (hnp (hmn m) = hnp (hmn m)), refl }

end

/- Test custom compositions of projections. -/

section comp_projs

instance {α β} : has_coe_to_fun (α ≃ β) := ⟨λ _, α → β, equiv.to_fun⟩

@[simps] protected def equiv.symm {α β} (f : α ≃ β) : β ≃ α :=
⟨f.inv_fun, f, f.right_inv, f.left_inv⟩

structure decorated_equiv (α : Sort*) (β : Sort*) extends equiv α β :=
(P_to_fun    : function.injective to_fun )
(P_inv_fun   : function.injective inv_fun)

instance {α β} : has_coe_to_fun (decorated_equiv α β) := ⟨λ _, α → β, λ f, f.to_equiv⟩

def decorated_equiv.symm {α β : Sort*} (e : decorated_equiv α β) : decorated_equiv β α :=
{ to_equiv := e.to_equiv.symm,
  P_to_fun := e.P_inv_fun,
  P_inv_fun := e.P_to_fun }

def decorated_equiv.simps.apply {α β : Sort*} (e : decorated_equiv α β) : α → β := e
def decorated_equiv.simps.symm_apply {α β : Sort*} (e : decorated_equiv α β) : β → α := e.symm

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

@[simps] def foo (α : Type) : decorated_equiv α α :=
{ to_fun    := λ x, x,
  inv_fun   := λ x, x,
  left_inv  := λ x, rfl,
  right_inv := λ x, rfl,
  P_to_fun  := λ x y h, h,
  P_inv_fun := λ x y h, h }

example {α : Type} (x : α) : (foo α).symm x = x :=
by { dsimp, guard_target (x = x), refl }

@[simps to_equiv apply symm_apply] def foo2 (α : Type) : decorated_equiv α α :=
{ P_to_fun  := λ x y h, h,
  P_inv_fun := λ x y h, h, ..foo.rfl }

example {α : Type} (x : α) : (foo2 α).to_equiv x = x :=
by { dsimp, guard_target (foo.rfl x = x), refl }

example {α : Type} (x : α) : foo2 α x = x :=
by { dsimp, guard_target (x = x), refl }

structure further_decorated_equiv (α : Sort*) (β : Sort*) extends decorated_equiv α β :=
(Q_to_fun    : function.surjective to_fun )
(Q_inv_fun   : function.surjective inv_fun )

instance {α β} : has_coe_to_fun (further_decorated_equiv α β) :=
⟨λ _, α → β, λ f, f.to_decorated_equiv⟩

def further_decorated_equiv.symm {α β : Sort*} (e : further_decorated_equiv α β) :
  further_decorated_equiv β α :=
{ to_decorated_equiv := e.to_decorated_equiv.symm,
  Q_to_fun := e.Q_inv_fun,
  Q_inv_fun := e.Q_to_fun }

def further_decorated_equiv.simps.apply {α β : Sort*} (e : further_decorated_equiv α β) : α → β := e
def further_decorated_equiv.simps.symm_apply {α β : Sort*} (e : further_decorated_equiv α β) :
  β → α := e.symm

initialize_simps_projections further_decorated_equiv
  (to_decorated_equiv_to_equiv_to_fun → apply, to_decorated_equiv_to_equiv_inv_fun → symm_apply,
  -to_decorated_equiv, to_decorated_equiv_to_equiv → to_equiv, -to_equiv)

@[simps] def ffoo (α : Type) : further_decorated_equiv α α :=
{ to_fun    := λ x, x,
  inv_fun   := λ x, x,
  left_inv  := λ x, rfl,
  right_inv := λ x, rfl,
  P_to_fun  := λ x y h, h,
  P_inv_fun := λ x y h, h,
  Q_to_fun  := λ y, ⟨y, rfl⟩,
  Q_inv_fun := λ y, ⟨y, rfl⟩ }

example {α : Type} (x : α) : (ffoo α).symm x = x :=
by { dsimp, guard_target (x = x), refl }

@[simps] def ffoo3 (α : Type) : further_decorated_equiv α α :=
{ Q_to_fun  := λ y, ⟨y, rfl⟩, Q_inv_fun  := λ y, ⟨y, rfl⟩, .. foo α }

@[simps apply to_equiv_to_fun to_decorated_equiv_apply]
def ffoo4 (α : Type) : further_decorated_equiv α α :=
{ Q_to_fun  := λ y, ⟨y, rfl⟩, Q_inv_fun  := λ y, ⟨y, rfl⟩, to_decorated_equiv := foo α }

structure one_more (α : Sort*) (β : Sort*) extends further_decorated_equiv α β

instance {α β} : has_coe_to_fun (one_more α β) :=
⟨λ _, α → β, λ f, f.to_further_decorated_equiv⟩

def one_more.symm {α β : Sort*} (e : one_more α β) :
  one_more β α :=
{ to_further_decorated_equiv := e.to_further_decorated_equiv.symm }

def one_more.simps.apply {α β : Sort*} (e : one_more α β) : α → β := e
def one_more.simps.symm_apply {α β : Sort*} (e : one_more α β) : β → α := e.symm

initialize_simps_projections one_more
  (to_further_decorated_equiv_to_decorated_equiv_to_equiv_to_fun → apply,
   to_further_decorated_equiv_to_decorated_equiv_to_equiv_inv_fun → symm_apply,
  -to_further_decorated_equiv, to_further_decorated_equiv_to_decorated_equiv → to_dequiv,
  -to_dequiv)

@[simps] def fffoo (α : Type) : one_more α α :=
{ to_fun    := λ x, x,
  inv_fun   := λ x, x,
  left_inv  := λ x, rfl,
  right_inv := λ x, rfl,
  P_to_fun  := λ x y h, h,
  P_inv_fun := λ x y h, h,
  Q_to_fun  := λ y, ⟨y, rfl⟩,
  Q_inv_fun := λ y, ⟨y, rfl⟩ }

example {α : Type} (x : α) : (fffoo α).symm x = x :=
by { dsimp, guard_target (x = x), refl }

@[simps apply to_dequiv_apply to_further_decorated_equiv_apply to_dequiv]
def fffoo2 (α : Type) : one_more α α := fffoo α

end comp_projs


/-
Copyright (c) 2022 Joseph Hua. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Bhavik Mehta, Johan Commelin, Reid Barton, Rob Lewis, Joseph Hua

! This file was ported from Lean 3 source module category_theory.endofunctor.algebra
! leanprover-community/mathlib commit 70fd9563a21e7b963887c9360bd29b2393e6225a
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.CategoryTheory.Functor.ReflectsIsomorphisms
import Mathbin.CategoryTheory.Limits.Shapes.Terminal

/-!

# Algebras of endofunctors

This file defines (co)algebras of an endofunctor, and provides the category instance for them.
It also defines the forgetful functor from the category of (co)algebras. It is shown that the
structure map of the initial algebra of an endofunctor is an isomorphism. Furthermore, it is shown
that for an adjunction `F ⊣ G` the category of algebras over `F` is equivalent to the category of
coalgebras over `G`.

## TODO

* Prove the dual result about the structure map of the terminal coalgebra of an endofunctor.
* Prove that if the countable infinite product over the powers of the endofunctor exists, then
  algebras over the endofunctor coincide with algebras over the free monad on the endofunctor.
-/

universe v u

namespace CategoryTheory

namespace Endofunctor

variable {C : Type u} [Category.{v} C]

/-- An algebra of an endofunctor; `str` stands for "structure morphism" -/
structure Algebra (F : C ⥤ C) where
  a : C
  str : F.obj A ⟶ A
#align category_theory.endofunctor.algebra CategoryTheory.Endofunctor.Algebra

instance [Inhabited C] : Inhabited (Algebra (𝟭 C)) :=
  ⟨⟨default, 𝟙 _⟩⟩

namespace Algebra

variable {F : C ⥤ C} (A : Algebra F) {A₀ A₁ A₂ : Algebra F}

/-
```
        str
   F A₀ -----> A₀
    |          |
F f |          | f
    V          V
   F A₁ -----> A₁
        str
```
-/
/-- A morphism between algebras of endofunctor `F` -/
@[ext]
structure Hom (A₀ A₁ : Algebra F) where
  f : A₀.1 ⟶ A₁.1
  h' : F.map f ≫ A₁.str = A₀.str ≫ f := by obviously
#align category_theory.endofunctor.algebra.hom CategoryTheory.Endofunctor.Algebra.Hom

restate_axiom hom.h'

attribute [simp, reassoc.1] hom.h

namespace Hom

/-- The identity morphism of an algebra of endofunctor `F` -/
def id : Hom A A where f := 𝟙 _
#align category_theory.endofunctor.algebra.hom.id CategoryTheory.Endofunctor.Algebra.Hom.id

instance : Inhabited (Hom A A) :=
  ⟨{ f := 𝟙 _ }⟩

/-- The composition of morphisms between algebras of endofunctor `F` -/
def comp (f : Hom A₀ A₁) (g : Hom A₁ A₂) : Hom A₀ A₂ where f := f.1 ≫ g.1
#align category_theory.endofunctor.algebra.hom.comp CategoryTheory.Endofunctor.Algebra.Hom.comp

end Hom

instance (F : C ⥤ C) : CategoryStruct (Algebra F)
    where
  Hom := Hom
  id := Hom.id
  comp := @Hom.comp _ _ _

@[simp]
theorem id_eq_id : Algebra.Hom.id A = 𝟙 A :=
  rfl
#align category_theory.endofunctor.algebra.id_eq_id CategoryTheory.Endofunctor.Algebra.id_eq_id

@[simp]
theorem id_f : (𝟙 _ : A ⟶ A).1 = 𝟙 A.1 :=
  rfl
#align category_theory.endofunctor.algebra.id_f CategoryTheory.Endofunctor.Algebra.id_f

variable {A₀ A₁ A₂} (f : A₀ ⟶ A₁) (g : A₁ ⟶ A₂)

@[simp]
theorem comp_eq_comp : Algebra.Hom.comp f g = f ≫ g :=
  rfl
#align category_theory.endofunctor.algebra.comp_eq_comp CategoryTheory.Endofunctor.Algebra.comp_eq_comp

@[simp]
theorem comp_f : (f ≫ g).1 = f.1 ≫ g.1 :=
  rfl
#align category_theory.endofunctor.algebra.comp_f CategoryTheory.Endofunctor.Algebra.comp_f

/-- Algebras of an endofunctor `F` form a category -/
instance (F : C ⥤ C) : Category (Algebra F) where

/-- To construct an isomorphism of algebras, it suffices to give an isomorphism of the As which
commutes with the structure morphisms.
-/
@[simps]
def isoMk (h : A₀.1 ≅ A₁.1) (w : F.map h.Hom ≫ A₁.str = A₀.str ≫ h.Hom) : A₀ ≅ A₁
    where
  Hom := { f := h.Hom }
  inv :=
    { f := h.inv
      h' := by
        rw [h.eq_comp_inv, category.assoc, ← w, ← functor.map_comp_assoc]
        simp }
#align category_theory.endofunctor.algebra.iso_mk CategoryTheory.Endofunctor.Algebra.isoMk

/-- The forgetful functor from the category of algebras, forgetting the algebraic structure. -/
@[simps]
def forget (F : C ⥤ C) : Algebra F ⥤ C where
  obj A := A.1
  map A B f := f.1
#align category_theory.endofunctor.algebra.forget CategoryTheory.Endofunctor.Algebra.forget

/-- An algebra morphism with an underlying isomorphism hom in `C` is an algebra isomorphism. -/
theorem iso_of_iso (f : A₀ ⟶ A₁) [IsIso f.1] : IsIso f :=
  ⟨⟨{   f := inv f.1
        h' := by
          rw [is_iso.eq_comp_inv f.1, category.assoc, ← f.h]
          simp },
      by tidy⟩⟩
#align category_theory.endofunctor.algebra.iso_of_iso CategoryTheory.Endofunctor.Algebra.iso_of_iso

instance forget_reflects_iso : ReflectsIsomorphisms (forget F) where reflects A B := iso_of_iso
#align category_theory.endofunctor.algebra.forget_reflects_iso CategoryTheory.Endofunctor.Algebra.forget_reflects_iso

instance forget_faithful : Faithful (forget F) where
#align category_theory.endofunctor.algebra.forget_faithful CategoryTheory.Endofunctor.Algebra.forget_faithful

/-- An algebra morphism with an underlying epimorphism hom in `C` is an algebra epimorphism. -/
theorem epi_of_epi {X Y : Algebra F} (f : X ⟶ Y) [h : Epi f.1] : Epi f :=
  (forget F).epi_of_epi_map h
#align category_theory.endofunctor.algebra.epi_of_epi CategoryTheory.Endofunctor.Algebra.epi_of_epi

/-- An algebra morphism with an underlying monomorphism hom in `C` is an algebra monomorphism. -/
theorem mono_of_mono {X Y : Algebra F} (f : X ⟶ Y) [h : Mono f.1] : Mono f :=
  (forget F).mono_of_mono_map h
#align category_theory.endofunctor.algebra.mono_of_mono CategoryTheory.Endofunctor.Algebra.mono_of_mono

/-- From a natural transformation `α : G → F` we get a functor from
algebras of `F` to algebras of `G`.
-/
@[simps]
def functorOfNatTrans {F G : C ⥤ C} (α : G ⟶ F) : Algebra F ⥤ Algebra G
    where
  obj A :=
    { a := A.1
      str := α.app A.1 ≫ A.str }
  map A₀ A₁ f := { f := f.1 }
#align category_theory.endofunctor.algebra.functor_of_nat_trans CategoryTheory.Endofunctor.Algebra.functorOfNatTrans

/-- The identity transformation induces the identity endofunctor on the category of algebras. -/
@[simps (config := { rhsMd := semireducible })]
def functorOfNatTransId : functorOfNatTrans (𝟙 F) ≅ 𝟭 _ :=
  NatIso.ofComponents
    (fun X =>
      isoMk (Iso.refl _)
        (by
          dsimp
          simp))
    fun X Y f => by
    ext
    dsimp
    simp
#align category_theory.endofunctor.algebra.functor_of_nat_trans_id CategoryTheory.Endofunctor.Algebra.functorOfNatTransId

/-- A composition of natural transformations gives the composition of corresponding functors. -/
@[simps (config := { rhsMd := semireducible })]
def functorOfNatTransComp {F₀ F₁ F₂ : C ⥤ C} (α : F₀ ⟶ F₁) (β : F₁ ⟶ F₂) :
    functorOfNatTrans (α ≫ β) ≅ functorOfNatTrans β ⋙ functorOfNatTrans α :=
  NatIso.ofComponents
    (fun X =>
      isoMk (Iso.refl _)
        (by
          dsimp
          simp))
    fun X Y f => by
    ext
    dsimp
    simp
#align category_theory.endofunctor.algebra.functor_of_nat_trans_comp CategoryTheory.Endofunctor.Algebra.functorOfNatTransComp

/--
If `α` and `β` are two equal natural transformations, then the functors of algebras induced by them
are isomorphic.
We define it like this as opposed to using `eq_to_iso` so that the components are nicer to prove
lemmas about.
-/
@[simps (config := { rhsMd := semireducible })]
def functorOfNatTransEq {F G : C ⥤ C} {α β : F ⟶ G} (h : α = β) :
    functorOfNatTrans α ≅ functorOfNatTrans β :=
  NatIso.ofComponents
    (fun X =>
      isoMk (Iso.refl _)
        (by
          dsimp
          simp [h]))
    fun X Y f => by
    ext
    dsimp
    simp
#align category_theory.endofunctor.algebra.functor_of_nat_trans_eq CategoryTheory.Endofunctor.Algebra.functorOfNatTransEq

/-- Naturally isomorphic endofunctors give equivalent categories of algebras.
Furthermore, they are equivalent as categories over `C`, that is,
we have `equiv_of_nat_iso h ⋙ forget = forget`.
-/
@[simps]
def equivOfNatIso {F G : C ⥤ C} (α : F ≅ G) : Algebra F ≌ Algebra G
    where
  Functor := functorOfNatTrans α.inv
  inverse := functorOfNatTrans α.Hom
  unitIso := functorOfNatTransId.symm ≪≫ functorOfNatTransEq (by simp) ≪≫ functorOfNatTransComp _ _
  counitIso :=
    (functorOfNatTransComp _ _).symm ≪≫ functorOfNatTransEq (by simp) ≪≫ functorOfNatTransId
#align category_theory.endofunctor.algebra.equiv_of_nat_iso CategoryTheory.Endofunctor.Algebra.equivOfNatIso

namespace Initial

variable {A} (h : Limits.IsInitial A)

/-- The inverse of the structure map of an initial algebra -/
@[simp]
def strInv : A.1 ⟶ F.obj A.1 :=
  (h.to ⟨F.obj A.1, F.map A.str⟩).1
#align category_theory.endofunctor.algebra.initial.str_inv CategoryTheory.Endofunctor.Algebra.Initial.strInv

theorem left_inv' : (⟨strInv h ≫ A.str⟩ : A ⟶ A) = 𝟙 A :=
  Limits.IsInitial.hom_ext h _ (𝟙 A)
#align category_theory.endofunctor.algebra.initial.left_inv' CategoryTheory.Endofunctor.Algebra.Initial.left_inv'

theorem left_inv : strInv h ≫ A.str = 𝟙 _ :=
  congr_arg Hom.f (left_inv' h)
#align category_theory.endofunctor.algebra.initial.left_inv CategoryTheory.Endofunctor.Algebra.Initial.left_inv

theorem right_inv : A.str ≫ strInv h = 𝟙 _ :=
  by
  rw [str_inv, ← (h.to ⟨F.obj A.1, F.map A.str⟩).h, ← F.map_id, ← F.map_comp]
  congr
  exact left_inv h
#align category_theory.endofunctor.algebra.initial.right_inv CategoryTheory.Endofunctor.Algebra.Initial.right_inv

/-- The structure map of the inital algebra is an isomorphism,
hence endofunctors preserve their initial algebras
-/
theorem str_isIso (h : Limits.IsInitial A) : IsIso A.str :=
  { out := ⟨strInv h, right_inv _, left_inv _⟩ }
#align category_theory.endofunctor.algebra.initial.str_is_iso CategoryTheory.Endofunctor.Algebra.Initial.str_isIso

end Initial

end Algebra

/-- A coalgebra of an endofunctor; `str` stands for "structure morphism" -/
structure Coalgebra (F : C ⥤ C) where
  V : C
  str : V ⟶ F.obj V
#align category_theory.endofunctor.coalgebra CategoryTheory.Endofunctor.Coalgebra

instance [Inhabited C] : Inhabited (Coalgebra (𝟭 C)) :=
  ⟨⟨default, 𝟙 _⟩⟩

namespace Coalgebra

variable {F : C ⥤ C} (V : Coalgebra F) {V₀ V₁ V₂ : Coalgebra F}

/-
```
        str
    V₀ -----> F V₀
    |          |
  f |          | F f
    V          V
    V₁ -----> F V₁
        str
```
-/
/-- A morphism between coalgebras of an endofunctor `F` -/
@[ext]
structure Hom (V₀ V₁ : Coalgebra F) where
  f : V₀.1 ⟶ V₁.1
  h' : V₀.str ≫ F.map f = f ≫ V₁.str := by obviously
#align category_theory.endofunctor.coalgebra.hom CategoryTheory.Endofunctor.Coalgebra.Hom

restate_axiom hom.h'

attribute [simp, reassoc.1] hom.h

namespace Hom

/-- The identity morphism of an algebra of endofunctor `F` -/
def id : Hom V V where f := 𝟙 _
#align category_theory.endofunctor.coalgebra.hom.id CategoryTheory.Endofunctor.Coalgebra.Hom.id

instance : Inhabited (Hom V V) :=
  ⟨{ f := 𝟙 _ }⟩

/-- The composition of morphisms between algebras of endofunctor `F` -/
def comp (f : Hom V₀ V₁) (g : Hom V₁ V₂) : Hom V₀ V₂ where f := f.1 ≫ g.1
#align category_theory.endofunctor.coalgebra.hom.comp CategoryTheory.Endofunctor.Coalgebra.Hom.comp

end Hom

instance (F : C ⥤ C) : CategoryStruct (Coalgebra F)
    where
  Hom := Hom
  id := Hom.id
  comp := @Hom.comp _ _ _

@[simp]
theorem id_eq_id : Coalgebra.Hom.id V = 𝟙 V :=
  rfl
#align category_theory.endofunctor.coalgebra.id_eq_id CategoryTheory.Endofunctor.Coalgebra.id_eq_id

@[simp]
theorem id_f : (𝟙 _ : V ⟶ V).1 = 𝟙 V.1 :=
  rfl
#align category_theory.endofunctor.coalgebra.id_f CategoryTheory.Endofunctor.Coalgebra.id_f

variable {V₀ V₁ V₂} (f : V₀ ⟶ V₁) (g : V₁ ⟶ V₂)

@[simp]
theorem comp_eq_comp : Coalgebra.Hom.comp f g = f ≫ g :=
  rfl
#align category_theory.endofunctor.coalgebra.comp_eq_comp CategoryTheory.Endofunctor.Coalgebra.comp_eq_comp

@[simp]
theorem comp_f : (f ≫ g).1 = f.1 ≫ g.1 :=
  rfl
#align category_theory.endofunctor.coalgebra.comp_f CategoryTheory.Endofunctor.Coalgebra.comp_f

/-- Coalgebras of an endofunctor `F` form a category -/
instance (F : C ⥤ C) : Category (Coalgebra F) where

/-- To construct an isomorphism of coalgebras, it suffices to give an isomorphism of the Vs which
commutes with the structure morphisms.
-/
@[simps]
def isoMk (h : V₀.1 ≅ V₁.1) (w : V₀.str ≫ F.map h.Hom = h.Hom ≫ V₁.str) : V₀ ≅ V₁
    where
  Hom := { f := h.Hom }
  inv :=
    { f := h.inv
      h' := by
        rw [h.eq_inv_comp, ← category.assoc, ← w, category.assoc, ← functor.map_comp]
        simp only [iso.hom_inv_id, Functor.map_id, category.comp_id] }
#align category_theory.endofunctor.coalgebra.iso_mk CategoryTheory.Endofunctor.Coalgebra.isoMk

/-- The forgetful functor from the category of coalgebras, forgetting the coalgebraic structure. -/
@[simps]
def forget (F : C ⥤ C) : Coalgebra F ⥤ C
    where
  obj A := A.1
  map A B f := f.1
#align category_theory.endofunctor.coalgebra.forget CategoryTheory.Endofunctor.Coalgebra.forget

/-- A coalgebra morphism with an underlying isomorphism hom in `C` is a coalgebra isomorphism. -/
theorem iso_of_iso (f : V₀ ⟶ V₁) [IsIso f.1] : IsIso f :=
  ⟨⟨{   f := inv f.1
        h' := by
          rw [is_iso.eq_inv_comp f.1, ← category.assoc, ← f.h, category.assoc]
          simp },
      by tidy⟩⟩
#align category_theory.endofunctor.coalgebra.iso_of_iso CategoryTheory.Endofunctor.Coalgebra.iso_of_iso

instance forget_reflects_iso : ReflectsIsomorphisms (forget F) where reflects A B := iso_of_iso
#align category_theory.endofunctor.coalgebra.forget_reflects_iso CategoryTheory.Endofunctor.Coalgebra.forget_reflects_iso

instance forget_faithful : Faithful (forget F) where
#align category_theory.endofunctor.coalgebra.forget_faithful CategoryTheory.Endofunctor.Coalgebra.forget_faithful

/-- An algebra morphism with an underlying epimorphism hom in `C` is an algebra epimorphism. -/
theorem epi_of_epi {X Y : Coalgebra F} (f : X ⟶ Y) [h : Epi f.1] : Epi f :=
  (forget F).epi_of_epi_map h
#align category_theory.endofunctor.coalgebra.epi_of_epi CategoryTheory.Endofunctor.Coalgebra.epi_of_epi

/-- An algebra morphism with an underlying monomorphism hom in `C` is an algebra monomorphism. -/
theorem mono_of_mono {X Y : Coalgebra F} (f : X ⟶ Y) [h : Mono f.1] : Mono f :=
  (forget F).mono_of_mono_map h
#align category_theory.endofunctor.coalgebra.mono_of_mono CategoryTheory.Endofunctor.Coalgebra.mono_of_mono

/-- From a natural transformation `α : F → G` we get a functor from
coalgebras of `F` to coalgebras of `G`.
-/
@[simps]
def functorOfNatTrans {F G : C ⥤ C} (α : F ⟶ G) : Coalgebra F ⥤ Coalgebra G
    where
  obj V :=
    { V := V.1
      str := V.str ≫ α.app V.1 }
  map V₀ V₁ f :=
    { f := f.1
      h' := by rw [category.assoc, ← α.naturality, ← category.assoc, f.h, category.assoc] }
#align category_theory.endofunctor.coalgebra.functor_of_nat_trans CategoryTheory.Endofunctor.Coalgebra.functorOfNatTrans

/-- The identity transformation induces the identity endofunctor on the category of coalgebras. -/
@[simps (config := { rhsMd := semireducible })]
def functorOfNatTransId : functorOfNatTrans (𝟙 F) ≅ 𝟭 _ :=
  NatIso.ofComponents
    (fun X =>
      isoMk (Iso.refl _)
        (by
          dsimp
          simp))
    fun X Y f => by
    ext
    dsimp
    simp
#align category_theory.endofunctor.coalgebra.functor_of_nat_trans_id CategoryTheory.Endofunctor.Coalgebra.functorOfNatTransId

/-- A composition of natural transformations gives the composition of corresponding functors. -/
@[simps (config := { rhsMd := semireducible })]
def functorOfNatTransComp {F₀ F₁ F₂ : C ⥤ C} (α : F₀ ⟶ F₁) (β : F₁ ⟶ F₂) :
    functorOfNatTrans (α ≫ β) ≅ functorOfNatTrans α ⋙ functorOfNatTrans β :=
  NatIso.ofComponents
    (fun X =>
      isoMk (Iso.refl _)
        (by
          dsimp
          simp))
    fun X Y f => by
    ext
    dsimp
    simp
#align category_theory.endofunctor.coalgebra.functor_of_nat_trans_comp CategoryTheory.Endofunctor.Coalgebra.functorOfNatTransComp

/-- If `α` and `β` are two equal natural transformations, then the functors of coalgebras induced by
them are isomorphic.
We define it like this as opposed to using `eq_to_iso` so that the components are nicer to prove
lemmas about.
-/
@[simps (config := { rhsMd := semireducible })]
def functorOfNatTransEq {F G : C ⥤ C} {α β : F ⟶ G} (h : α = β) :
    functorOfNatTrans α ≅ functorOfNatTrans β :=
  NatIso.ofComponents
    (fun X =>
      isoMk (Iso.refl _)
        (by
          dsimp
          simp [h]))
    fun X Y f => by
    ext
    dsimp
    simp
#align category_theory.endofunctor.coalgebra.functor_of_nat_trans_eq CategoryTheory.Endofunctor.Coalgebra.functorOfNatTransEq

/-- Naturally isomorphic endofunctors give equivalent categories of coalgebras.
Furthermore, they are equivalent as categories over `C`, that is,
we have `equiv_of_nat_iso h ⋙ forget = forget`.
-/
@[simps]
def equivOfNatIso {F G : C ⥤ C} (α : F ≅ G) : Coalgebra F ≌ Coalgebra G
    where
  Functor := functorOfNatTrans α.Hom
  inverse := functorOfNatTrans α.inv
  unitIso := functorOfNatTransId.symm ≪≫ functorOfNatTransEq (by simp) ≪≫ functorOfNatTransComp _ _
  counitIso :=
    (functorOfNatTransComp _ _).symm ≪≫ functorOfNatTransEq (by simp) ≪≫ functorOfNatTransId
#align category_theory.endofunctor.coalgebra.equiv_of_nat_iso CategoryTheory.Endofunctor.Coalgebra.equivOfNatIso

end Coalgebra

namespace Adjunction

variable {F : C ⥤ C} {G : C ⥤ C}

theorem Algebra.homEquiv_naturality_str (adj : F ⊣ G) (A₁ A₂ : Algebra F) (f : A₁ ⟶ A₂) :
    (adj.homEquiv A₁.a A₁.a) A₁.str ≫ G.map f.f = f.f ≫ (adj.homEquiv A₂.a A₂.a) A₂.str := by
  rw [← adjunction.hom_equiv_naturality_right, ← adjunction.hom_equiv_naturality_left, f.h]
#align category_theory.endofunctor.adjunction.algebra.hom_equiv_naturality_str CategoryTheory.Endofunctor.Adjunction.Algebra.homEquiv_naturality_str

theorem Coalgebra.homEquiv_naturality_str_symm (adj : F ⊣ G) (V₁ V₂ : Coalgebra G) (f : V₁ ⟶ V₂) :
    F.map f.f ≫ (adj.homEquiv V₂.V V₂.V).symm V₂.str = (adj.homEquiv V₁.V V₁.V).symm V₁.str ≫ f.f :=
  by
  rw [← adjunction.hom_equiv_naturality_left_symm, ← adjunction.hom_equiv_naturality_right_symm,
    f.h]
#align category_theory.endofunctor.adjunction.coalgebra.hom_equiv_naturality_str_symm CategoryTheory.Endofunctor.Adjunction.Coalgebra.homEquiv_naturality_str_symm

/-- Given an adjunction `F ⊣ G`, the functor that associates to an algebra over `F` a
coalgebra over `G` defined via adjunction applied to the structure map. -/
def Algebra.toCoalgebraOf (adj : F ⊣ G) : Algebra F ⥤ Coalgebra G
    where
  obj A :=
    { V := A.1
      str := (adj.homEquiv A.1 A.1).toFun A.2 }
  map A₁ A₂ f :=
    { f := f.1
      h' := Algebra.homEquiv_naturality_str adj A₁ A₂ f }
#align category_theory.endofunctor.adjunction.algebra.to_coalgebra_of CategoryTheory.Endofunctor.Adjunction.Algebra.toCoalgebraOf

/-- Given an adjunction `F ⊣ G`, the functor that associates to a coalgebra over `G` an algebra over
`F` defined via adjunction applied to the structure map. -/
def Coalgebra.toAlgebraOf (adj : F ⊣ G) : Coalgebra G ⥤ Algebra F
    where
  obj V :=
    { a := V.1
      str := (adj.homEquiv V.1 V.1).invFun V.2 }
  map V₁ V₂ f :=
    { f := f.1
      h' := Coalgebra.homEquiv_naturality_str_symm adj V₁ V₂ f }
#align category_theory.endofunctor.adjunction.coalgebra.to_algebra_of CategoryTheory.Endofunctor.Adjunction.Coalgebra.toAlgebraOf

/-- Given an adjunction, assigning to an algebra over the left adjoint a coalgebra over its right
adjoint and going back is isomorphic to the identity functor. -/
def AlgCoalgEquiv.unitIso (adj : F ⊣ G) :
    𝟭 (Algebra F) ≅ Algebra.toCoalgebraOf adj ⋙ Coalgebra.toAlgebraOf adj
    where
  Hom :=
    { app := fun A =>
        { f := 𝟙 A.1
          h' := by
            erw [F.map_id, category.id_comp, category.comp_id]
            apply (adj.hom_equiv _ _).left_inv A.str }
      naturality' := fun A₁ A₂ f => by
        ext1
        dsimp
        erw [category.id_comp, category.comp_id]
        rfl }
  inv :=
    { app := fun A =>
        { f := 𝟙 A.1
          h' := by
            erw [F.map_id, category.id_comp, category.comp_id]
            apply ((adj.hom_equiv _ _).left_inv A.str).symm }
      naturality' := fun A₁ A₂ f => by
        ext1
        dsimp
        erw [category.comp_id, category.id_comp]
        rfl }
  hom_inv_id' := by
    ext
    exact category.comp_id _
  inv_hom_id' := by
    ext
    exact category.comp_id _
#align category_theory.endofunctor.adjunction.alg_coalg_equiv.unit_iso CategoryTheory.Endofunctor.Adjunction.AlgCoalgEquiv.unitIso

/-- Given an adjunction, assigning to a coalgebra over the right adjoint an algebra over the left
adjoint and going back is isomorphic to the identity functor. -/
def AlgCoalgEquiv.counitIso (adj : F ⊣ G) :
    Coalgebra.toAlgebraOf adj ⋙ Algebra.toCoalgebraOf adj ≅ 𝟭 (Coalgebra G)
    where
  Hom :=
    { app := fun V =>
        { f := 𝟙 V.1
          h' := by
            dsimp
            erw [G.map_id, category.id_comp, category.comp_id]
            apply (adj.hom_equiv _ _).right_inv V.str }
      naturality' := fun V₁ V₂ f => by
        ext1
        dsimp
        erw [category.comp_id, category.id_comp]
        rfl }
  inv :=
    { app := fun V =>
        { f := 𝟙 V.1
          h' := by
            dsimp
            rw [G.map_id, category.comp_id, category.id_comp]
            apply ((adj.hom_equiv _ _).right_inv V.str).symm }
      naturality' := fun V₁ V₂ f => by
        ext1
        dsimp
        erw [category.comp_id, category.id_comp]
        rfl }
  hom_inv_id' := by
    ext
    exact category.comp_id _
  inv_hom_id' := by
    ext
    exact category.comp_id _
#align category_theory.endofunctor.adjunction.alg_coalg_equiv.counit_iso CategoryTheory.Endofunctor.Adjunction.AlgCoalgEquiv.counitIso

/-- If `F` is left adjoint to `G`, then the category of algebras over `F` is equivalent to the
category of coalgebras over `G`. -/
def algebraCoalgebraEquiv (adj : F ⊣ G) : Algebra F ≌ Coalgebra G
    where
  Functor := Algebra.toCoalgebraOf adj
  inverse := Coalgebra.toAlgebraOf adj
  unitIso := AlgCoalgEquiv.unitIso adj
  counitIso := AlgCoalgEquiv.counitIso adj
  functor_unitIso_comp' A := by
    ext
    exact category.comp_id _
#align category_theory.endofunctor.adjunction.algebra_coalgebra_equiv CategoryTheory.Endofunctor.Adjunction.algebraCoalgebraEquiv

end Adjunction

end Endofunctor

end CategoryTheory


/-
Copyright (c) 2020 Yury Kudryashov All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury Kudryashov
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.linear_algebra.basic
import Mathlib.PostPort

universes u v w l u_1 u_2 u_3 u_4

namespace Mathlib

/-!
# Partially defined linear maps

A `linear_pmap R E F` is a linear map from a submodule of `E` to `F`. We define
a `semilattice_inf_bot` instance on this this, and define three operations:

* `mk_span_singleton` defines a partial linear map defined on the span of a singleton.
* `sup` takes two partial linear maps `f`, `g` that agree on the intersection of their
  domains, and returns the unique partial linear map on `f.domain ⊔ g.domain` that
  extends both `f` and `g`.
* `Sup` takes a `directed_on (≤)` set of partial linear maps, and returns the unique
  partial linear map on the `Sup` of their domains that extends all these maps.

Partially defined maps are currently used in `mathlib` to prove Hahn-Banach theorem
and its variations. Namely, `linear_pmap.Sup` implies that every chain of `linear_pmap`s
is bounded above.

Another possible use (not yet in `mathlib`) would be the theory of unbounded linear operators.
-/

/-- A `linear_pmap R E F` is a linear map from a submodule of `E` to `F`. -/
structure linear_pmap (R : Type u) [ring R] (E : Type v) [add_comm_group E] [module R E] (F : Type w) [add_comm_group F] [module R F]
where
  domain : submodule R E
  to_fun : linear_map R (↥domain) F

namespace linear_pmap

protected instance has_coe_to_fun {R : Type u_1} [ring R] {E : Type u_2} [add_comm_group E] [module R E] {F : Type u_3} [add_comm_group F] [module R F] : has_coe_to_fun (linear_pmap R E F) :=
  has_coe_to_fun.mk (fun (f : linear_pmap R E F) => ↥(domain f) → F) fun (f : linear_pmap R E F) => ⇑(to_fun f)

@[simp] theorem to_fun_eq_coe {R : Type u_1} [ring R] {E : Type u_2} [add_comm_group E] [module R E] {F : Type u_3} [add_comm_group F] [module R F] (f : linear_pmap R E F) (x : ↥(domain f)) : coe_fn (to_fun f) x = coe_fn f x :=
  rfl

@[simp] theorem map_zero {R : Type u_1} [ring R] {E : Type u_2} [add_comm_group E] [module R E] {F : Type u_3} [add_comm_group F] [module R F] (f : linear_pmap R E F) : coe_fn f 0 = 0 :=
  linear_map.map_zero (to_fun f)

theorem map_add {R : Type u_1} [ring R] {E : Type u_2} [add_comm_group E] [module R E] {F : Type u_3} [add_comm_group F] [module R F] (f : linear_pmap R E F) (x : ↥(domain f)) (y : ↥(domain f)) : coe_fn f (x + y) = coe_fn f x + coe_fn f y :=
  linear_map.map_add (to_fun f) x y

theorem map_neg {R : Type u_1} [ring R] {E : Type u_2} [add_comm_group E] [module R E] {F : Type u_3} [add_comm_group F] [module R F] (f : linear_pmap R E F) (x : ↥(domain f)) : coe_fn f (-x) = -coe_fn f x :=
  linear_map.map_neg (to_fun f) x

theorem map_sub {R : Type u_1} [ring R] {E : Type u_2} [add_comm_group E] [module R E] {F : Type u_3} [add_comm_group F] [module R F] (f : linear_pmap R E F) (x : ↥(domain f)) (y : ↥(domain f)) : coe_fn f (x - y) = coe_fn f x - coe_fn f y :=
  linear_map.map_sub (to_fun f) x y

theorem map_smul {R : Type u_1} [ring R] {E : Type u_2} [add_comm_group E] [module R E] {F : Type u_3} [add_comm_group F] [module R F] (f : linear_pmap R E F) (c : R) (x : ↥(domain f)) : coe_fn f (c • x) = c • coe_fn f x :=
  linear_map.map_smul (to_fun f) c x

@[simp] theorem mk_apply {R : Type u_1} [ring R] {E : Type u_2} [add_comm_group E] [module R E] {F : Type u_3} [add_comm_group F] [module R F] (p : submodule R E) (f : linear_map R (↥p) F) (x : ↥p) : coe_fn (mk p f) x = coe_fn f x :=
  rfl

/-- The unique `linear_pmap` on `R ∙ x` that sends `x` to `y`. This version works for modules
over rings, and requires a proof of `∀ c, c • x = 0 → c • y = 0`. -/
def mk_span_singleton' {R : Type u_1} [ring R] {E : Type u_2} [add_comm_group E] [module R E] {F : Type u_3} [add_comm_group F] [module R F] (x : E) (y : F) (H : ∀ (c : R), c • x = 0 → c • y = 0) : linear_pmap R E F :=
  mk (submodule.span R (singleton x))
    (linear_map.mk (fun (z : ↥(submodule.span R (singleton x))) => classical.some sorry • y) sorry sorry)

@[simp] theorem domain_mk_span_singleton {R : Type u_1} [ring R] {E : Type u_2} [add_comm_group E] [module R E] {F : Type u_3} [add_comm_group F] [module R F] (x : E) (y : F) (H : ∀ (c : R), c • x = 0 → c • y = 0) : domain (mk_span_singleton' x y H) = submodule.span R (singleton x) :=
  rfl

@[simp] theorem mk_span_singleton_apply {R : Type u_1} [ring R] {E : Type u_2} [add_comm_group E] [module R E] {F : Type u_3} [add_comm_group F] [module R F] (x : E) (y : F) (H : ∀ (c : R), c • x = 0 → c • y = 0) (c : R) (h : c • x ∈ domain (mk_span_singleton' x y H)) : coe_fn (mk_span_singleton' x y H) { val := c • x, property := h } = c • y := sorry

/-- The unique `linear_pmap` on `span R {x}` that sends a non-zero vector `x` to `y`.
This version works for modules over division rings. -/
def mk_span_singleton {K : Type u_1} {E : Type u_2} {F : Type u_3} [division_ring K] [add_comm_group E] [module K E] [add_comm_group F] [module K F] (x : E) (y : F) (hx : x ≠ 0) : linear_pmap K E F :=
  mk_span_singleton' x y sorry

/-- Projection to the first coordinate as a `linear_pmap` -/
protected def fst {R : Type u_1} [ring R] {E : Type u_2} [add_comm_group E] [module R E] {F : Type u_3} [add_comm_group F] [module R F] (p : submodule R E) (p' : submodule R F) : linear_pmap R (E × F) E :=
  mk (submodule.prod p p') (linear_map.comp (linear_map.fst R E F) (submodule.subtype (submodule.prod p p')))

@[simp] theorem fst_apply {R : Type u_1} [ring R] {E : Type u_2} [add_comm_group E] [module R E] {F : Type u_3} [add_comm_group F] [module R F] (p : submodule R E) (p' : submodule R F) (x : ↥(submodule.prod p p')) : coe_fn (linear_pmap.fst p p') x = prod.fst ↑x :=
  rfl

/-- Projection to the second coordinate as a `linear_pmap` -/
protected def snd {R : Type u_1} [ring R] {E : Type u_2} [add_comm_group E] [module R E] {F : Type u_3} [add_comm_group F] [module R F] (p : submodule R E) (p' : submodule R F) : linear_pmap R (E × F) F :=
  mk (submodule.prod p p') (linear_map.comp (linear_map.snd R E F) (submodule.subtype (submodule.prod p p')))

@[simp] theorem snd_apply {R : Type u_1} [ring R] {E : Type u_2} [add_comm_group E] [module R E] {F : Type u_3} [add_comm_group F] [module R F] (p : submodule R E) (p' : submodule R F) (x : ↥(submodule.prod p p')) : coe_fn (linear_pmap.snd p p') x = prod.snd ↑x :=
  rfl

protected instance has_neg {R : Type u_1} [ring R] {E : Type u_2} [add_comm_group E] [module R E] {F : Type u_3} [add_comm_group F] [module R F] : Neg (linear_pmap R E F) :=
  { neg := fun (f : linear_pmap R E F) => mk (domain f) (-to_fun f) }

@[simp] theorem neg_apply {R : Type u_1} [ring R] {E : Type u_2} [add_comm_group E] [module R E] {F : Type u_3} [add_comm_group F] [module R F] (f : linear_pmap R E F) (x : ↥(domain (-f))) : coe_fn (-f) x = -coe_fn f x :=
  rfl

protected instance has_le {R : Type u_1} [ring R] {E : Type u_2} [add_comm_group E] [module R E] {F : Type u_3} [add_comm_group F] [module R F] : HasLessEq (linear_pmap R E F) :=
  { LessEq :=
      fun (f g : linear_pmap R E F) =>
        domain f ≤ domain g ∧ ∀ {x : ↥(domain f)} {y : ↥(domain g)}, ↑x = ↑y → coe_fn f x = coe_fn g y }

theorem eq_of_le_of_domain_eq {R : Type u_1} [ring R] {E : Type u_2} [add_comm_group E] [module R E] {F : Type u_3} [add_comm_group F] [module R F] {f : linear_pmap R E F} {g : linear_pmap R E F} (hle : f ≤ g) (heq : domain f = domain g) : f = g := sorry

/-- Given two partial linear maps `f`, `g`, the set of points `x` such that
both `f` and `g` are defined at `x` and `f x = g x` form a submodule. -/
def eq_locus {R : Type u_1} [ring R] {E : Type u_2} [add_comm_group E] [module R E] {F : Type u_3} [add_comm_group F] [module R F] (f : linear_pmap R E F) (g : linear_pmap R E F) : submodule R E :=
  submodule.mk
    (set_of
      fun (x : E) =>
        ∃ (hf : x ∈ domain f),
          ∃ (hg : x ∈ domain g), coe_fn f { val := x, property := hf } = coe_fn g { val := x, property := hg })
    sorry sorry sorry

protected instance has_inf {R : Type u_1} [ring R] {E : Type u_2} [add_comm_group E] [module R E] {F : Type u_3} [add_comm_group F] [module R F] : has_inf (linear_pmap R E F) :=
  has_inf.mk fun (f g : linear_pmap R E F) => mk (eq_locus f g) (linear_map.comp (to_fun f) (submodule.of_le sorry))

protected instance has_bot {R : Type u_1} [ring R] {E : Type u_2} [add_comm_group E] [module R E] {F : Type u_3} [add_comm_group F] [module R F] : has_bot (linear_pmap R E F) :=
  has_bot.mk (mk ⊥ 0)

protected instance inhabited {R : Type u_1} [ring R] {E : Type u_2} [add_comm_group E] [module R E] {F : Type u_3} [add_comm_group F] [module R F] : Inhabited (linear_pmap R E F) :=
  { default := ⊥ }

protected instance semilattice_inf_bot {R : Type u_1} [ring R] {E : Type u_2} [add_comm_group E] [module R E] {F : Type u_3} [add_comm_group F] [module R F] : semilattice_inf_bot (linear_pmap R E F) :=
  semilattice_inf_bot.mk ⊥ LessEq (order_bot.lt._default LessEq) sorry sorry sorry sorry has_inf.inf sorry sorry sorry

theorem le_of_eq_locus_ge {R : Type u_1} [ring R] {E : Type u_2} [add_comm_group E] [module R E] {F : Type u_3} [add_comm_group F] [module R F] {f : linear_pmap R E F} {g : linear_pmap R E F} (H : domain f ≤ eq_locus f g) : f ≤ g := sorry

theorem domain_mono {R : Type u_1} [ring R] {E : Type u_2} [add_comm_group E] [module R E] {F : Type u_3} [add_comm_group F] [module R F] : strict_mono domain :=
  fun (f g : linear_pmap R E F) (hlt : f < g) =>
    lt_of_le_of_ne (and.left (and.left hlt))
      fun (heq : domain f = domain g) => ne_of_lt hlt (eq_of_le_of_domain_eq (le_of_lt hlt) heq)

/-- Given two partial linear maps that agree on the intersection of their domains,
`f.sup g h` is the unique partial linear map on `f.domain ⊔ g.domain` that agrees
with `f` and `g`. -/
protected def sup {R : Type u_1} [ring R] {E : Type u_2} [add_comm_group E] [module R E] {F : Type u_3} [add_comm_group F] [module R F] (f : linear_pmap R E F) (g : linear_pmap R E F) (h : ∀ (x : ↥(domain f)) (y : ↥(domain g)), ↑x = ↑y → coe_fn f x = coe_fn g y) : linear_pmap R E F :=
  mk (domain f ⊔ domain g) (classical.some (sup_aux f g h))

@[simp] theorem domain_sup {R : Type u_1} [ring R] {E : Type u_2} [add_comm_group E] [module R E] {F : Type u_3} [add_comm_group F] [module R F] (f : linear_pmap R E F) (g : linear_pmap R E F) (h : ∀ (x : ↥(domain f)) (y : ↥(domain g)), ↑x = ↑y → coe_fn f x = coe_fn g y) : domain (linear_pmap.sup f g h) = domain f ⊔ domain g :=
  rfl

theorem sup_apply {R : Type u_1} [ring R] {E : Type u_2} [add_comm_group E] [module R E] {F : Type u_3} [add_comm_group F] [module R F] {f : linear_pmap R E F} {g : linear_pmap R E F} (H : ∀ (x : ↥(domain f)) (y : ↥(domain g)), ↑x = ↑y → coe_fn f x = coe_fn g y) (x : ↥(domain f)) (y : ↥(domain g)) (z : ↥(domain (linear_pmap.sup f g H))) (hz : ↑x + ↑y = ↑z) : coe_fn (linear_pmap.sup f g H) z = coe_fn f x + coe_fn g y :=
  classical.some_spec (sup_aux f g H) x y z hz

protected theorem left_le_sup {R : Type u_1} [ring R] {E : Type u_2} [add_comm_group E] [module R E] {F : Type u_3} [add_comm_group F] [module R F] (f : linear_pmap R E F) (g : linear_pmap R E F) (h : ∀ (x : ↥(domain f)) (y : ↥(domain g)), ↑x = ↑y → coe_fn f x = coe_fn g y) : f ≤ linear_pmap.sup f g h := sorry

protected theorem right_le_sup {R : Type u_1} [ring R] {E : Type u_2} [add_comm_group E] [module R E] {F : Type u_3} [add_comm_group F] [module R F] (f : linear_pmap R E F) (g : linear_pmap R E F) (h : ∀ (x : ↥(domain f)) (y : ↥(domain g)), ↑x = ↑y → coe_fn f x = coe_fn g y) : g ≤ linear_pmap.sup f g h := sorry

protected theorem sup_le {R : Type u_1} [ring R] {E : Type u_2} [add_comm_group E] [module R E] {F : Type u_3} [add_comm_group F] [module R F] {f : linear_pmap R E F} {g : linear_pmap R E F} {h : linear_pmap R E F} (H : ∀ (x : ↥(domain f)) (y : ↥(domain g)), ↑x = ↑y → coe_fn f x = coe_fn g y) (fh : f ≤ h) (gh : g ≤ h) : linear_pmap.sup f g H ≤ h := sorry

/-- Hypothesis for `linear_pmap.sup` holds, if `f.domain` is disjoint with `g.domain`. -/
theorem sup_h_of_disjoint {R : Type u_1} [ring R] {E : Type u_2} [add_comm_group E] [module R E] {F : Type u_3} [add_comm_group F] [module R F] (f : linear_pmap R E F) (g : linear_pmap R E F) (h : disjoint (domain f) (domain g)) (x : ↥(domain f)) (y : ↥(domain g)) (hxy : ↑x = ↑y) : coe_fn f x = coe_fn g y := sorry

/-- Glue a collection of partially defined linear maps to a linear map defined on `Sup`
of these submodules. -/
protected def Sup {R : Type u_1} [ring R] {E : Type u_2} [add_comm_group E] [module R E] {F : Type u_3} [add_comm_group F] [module R F] (c : set (linear_pmap R E F)) (hc : directed_on LessEq c) : linear_pmap R E F :=
  mk (Sup (domain '' c)) (classical.some (Sup_aux c hc))

protected theorem le_Sup {R : Type u_1} [ring R] {E : Type u_2} [add_comm_group E] [module R E] {F : Type u_3} [add_comm_group F] [module R F] {c : set (linear_pmap R E F)} (hc : directed_on LessEq c) {f : linear_pmap R E F} (hf : f ∈ c) : f ≤ linear_pmap.Sup c hc :=
  classical.some_spec (Sup_aux c hc) f hf

protected theorem Sup_le {R : Type u_1} [ring R] {E : Type u_2} [add_comm_group E] [module R E] {F : Type u_3} [add_comm_group F] [module R F] {c : set (linear_pmap R E F)} (hc : directed_on LessEq c) {g : linear_pmap R E F} (hg : ∀ (f : linear_pmap R E F), f ∈ c → f ≤ g) : linear_pmap.Sup c hc ≤ g := sorry

end linear_pmap

namespace linear_map

/-- Restrict a linear map to a submodule, reinterpreting the result as a `linear_pmap`. -/
def to_pmap {R : Type u_1} [ring R] {E : Type u_2} [add_comm_group E] [module R E] {F : Type u_3} [add_comm_group F] [module R F] (f : linear_map R E F) (p : submodule R E) : linear_pmap R E F :=
  linear_pmap.mk p (comp f (submodule.subtype p))

@[simp] theorem to_pmap_apply {R : Type u_1} [ring R] {E : Type u_2} [add_comm_group E] [module R E] {F : Type u_3} [add_comm_group F] [module R F] (f : linear_map R E F) (p : submodule R E) (x : ↥p) : coe_fn (to_pmap f p) x = coe_fn f ↑x :=
  rfl

/-- Compose a linear map with a `linear_pmap` -/
def comp_pmap {R : Type u_1} [ring R] {E : Type u_2} [add_comm_group E] [module R E] {F : Type u_3} [add_comm_group F] [module R F] {G : Type u_4} [add_comm_group G] [module R G] (g : linear_map R F G) (f : linear_pmap R E F) : linear_pmap R E G :=
  linear_pmap.mk (linear_pmap.domain f) (comp g (linear_pmap.to_fun f))

@[simp] theorem comp_pmap_apply {R : Type u_1} [ring R] {E : Type u_2} [add_comm_group E] [module R E] {F : Type u_3} [add_comm_group F] [module R F] {G : Type u_4} [add_comm_group G] [module R G] (g : linear_map R F G) (f : linear_pmap R E F) (x : ↥(linear_pmap.domain (comp_pmap g f))) : coe_fn (comp_pmap g f) x = coe_fn g (coe_fn f x) :=
  rfl

end linear_map

namespace linear_pmap

/-- Restrict codomain of a `linear_pmap` -/
def cod_restrict {R : Type u_1} [ring R] {E : Type u_2} [add_comm_group E] [module R E] {F : Type u_3} [add_comm_group F] [module R F] (f : linear_pmap R E F) (p : submodule R F) (H : ∀ (x : ↥(domain f)), coe_fn f x ∈ p) : linear_pmap R E ↥p :=
  mk (domain f) (linear_map.cod_restrict p (to_fun f) H)

/-- Compose two `linear_pmap`s -/
def comp {R : Type u_1} [ring R] {E : Type u_2} [add_comm_group E] [module R E] {F : Type u_3} [add_comm_group F] [module R F] {G : Type u_4} [add_comm_group G] [module R G] (g : linear_pmap R F G) (f : linear_pmap R E F) (H : ∀ (x : ↥(domain f)), coe_fn f x ∈ domain g) : linear_pmap R E G :=
  linear_map.comp_pmap (to_fun g) (cod_restrict f (domain g) H)

/-- `f.coprod g` is the partially defined linear map defined on `f.domain × g.domain`,
and sending `p` to `f p.1 + g p.2`. -/
def coprod {R : Type u_1} [ring R] {E : Type u_2} [add_comm_group E] [module R E] {F : Type u_3} [add_comm_group F] [module R F] {G : Type u_4} [add_comm_group G] [module R G] (f : linear_pmap R E G) (g : linear_pmap R F G) : linear_pmap R (E × F) G :=
  mk (submodule.prod (domain f) (domain g))
    (to_fun (comp f (linear_pmap.fst (domain f) (domain g)) sorry) +
      to_fun (comp g (linear_pmap.snd (domain f) (domain g)) sorry))

@[simp] theorem coprod_apply {R : Type u_1} [ring R] {E : Type u_2} [add_comm_group E] [module R E] {F : Type u_3} [add_comm_group F] [module R F] {G : Type u_4} [add_comm_group G] [module R G] (f : linear_pmap R E G) (g : linear_pmap R F G) (x : ↥(domain (coprod f g))) : coe_fn (coprod f g) x =
  coe_fn f { val := prod.fst ↑x, property := and.left (subtype.property x) } +
    coe_fn g { val := prod.snd ↑x, property := and.right (subtype.property x) } :=
  rfl