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

! This file was ported from Lean 3 source module logic.equiv.functor
! leanprover-community/mathlib commit 9407b03373c8cd201df99d6bc5514fc2db44054f
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Control.Bifunctor
import Mathlib.Logic.Equiv.Defs

/-!
# Functor and bifunctors can be applied to `Equiv`s.

We define
```lean
def Functor.mapEquiv (f : Type u → Type v) [Functor f] [LawfulFunctor f] :
  α ≃ β → f α ≃ f β
```
and
```lean
def Bifunctor.mapEquiv (F : Type u → Type v → Type w) [Bifunctor F] [LawfulBifunctor F] :
  α ≃ β → α' ≃ β' → F α α' ≃ F β β'
```
-/

universe u v w

variable {α β : Type u}

open Equiv

namespace Functor

variable (f : Type u → Type v) [Functor f] [LawfulFunctor f]

/-- Apply a functor to an `Equiv`. -/
def mapEquiv (h : α ≃ β) : f α ≃ f β where
  toFun := map h
  invFun := map h.symm
  left_inv x := by simp [map_map]
  right_inv x := by simp [map_map]
#align functor.map_equiv Functor.mapEquiv

@[simp]
theorem mapEquiv_apply (h : α ≃ β) (x : f α) : (mapEquiv f h : f α ≃ f β) x = map h x :=
  rfl
#align functor.map_equiv_apply Functor.mapEquiv_apply

@[simp]
theorem mapEquiv_symm_apply (h : α ≃ β) (y : f β) :
    (mapEquiv f h : f α ≃ f β).symm y = map h.symm y :=
  rfl
#align functor.map_equiv_symm_apply Functor.mapEquiv_symm_apply

@[simp]
theorem mapEquiv_refl : mapEquiv f (Equiv.refl α) = Equiv.refl (f α) := by
  ext x
  simp only [mapEquiv_apply, refl_apply]
  exact LawfulFunctor.id_map x
#align functor.map_equiv_refl Functor.mapEquiv_refl

end Functor

namespace Bifunctor

variable {α' β' : Type v} (F : Type u → Type v → Type w) [Bifunctor F] [LawfulBifunctor F]

/-- Apply a bifunctor to a pair of `Equiv`s. -/
def mapEquiv (h : α ≃ β) (h' : α' ≃ β') : F α α' ≃ F β β' where
  toFun := bimap h h'
  invFun := bimap h.symm h'.symm
  left_inv x := by simp [bimap_bimap, id_bimap]
  right_inv x := by simp [bimap_bimap, id_bimap]
#align bifunctor.map_equiv Bifunctor.mapEquiv

@[simp]
theorem mapEquiv_apply (h : α ≃ β) (h' : α' ≃ β') (x : F α α') :
    (mapEquiv F h h' : F α α' ≃ F β β') x = bimap h h' x :=
  rfl
#align bifunctor.map_equiv_apply Bifunctor.mapEquiv_apply

@[simp]
theorem mapEquiv_symm_apply (h : α ≃ β) (h' : α' ≃ β') (y : F β β') :
    (mapEquiv F h h' : F α α' ≃ F β β').symm y = bimap h.symm h'.symm y :=
  rfl
#align bifunctor.map_equiv_symm_apply Bifunctor.mapEquiv_symm_apply

@[simp]
theorem mapEquiv_refl_refl : mapEquiv F (Equiv.refl α) (Equiv.refl α') = Equiv.refl (F α α') := by
  ext x
  simp [id_bimap]
#align bifunctor.map_equiv_refl_refl Bifunctor.mapEquiv_refl_refl

end Bifunctor


-- vim: ts=2 sw=0 sts=-1 et ai tw=70

import ..logic

namespace hidden

universes u v w

-- A set of elements of type α is a function from elements of type α
-- to propositions
def myset (α : Type u) := α → Prop

 -- Not sure if we want this, but I don't think it hurts
namespace myset

-- Need u and v to be most general
variables {α : Type u} {β : Type v}

def mem (a : α) (s : myset α) : Prop := s a
instance: has_mem α (myset α) := ⟨myset.mem⟩

theorem mem_def {a : α} {s : myset α} : a ∈ s = s a := rfl

theorem setext (A B : myset α) : (∀ x : α, x ∈ A ↔ x ∈ B) → A = B :=
begin
  assume h,
  apply funext,
  intro x,
  apply propext,
  from h x,
end

def subset (s : myset α) (t : myset α) : Prop :=
∀ a : α, s a → t a
-- Use \subseteq
instance: has_subset (myset α) := ⟨myset.subset⟩

theorem setext_subs (A B: myset α): A ⊆ B → B ⊆ A → A = B :=
begin
  assume hAB hBA,
  apply setext,
  intro x,
  split; assume hx, {
    apply hAB,
    assumption,
  }, {
    apply hBA,
    assumption,
  },
end

@[refl]
theorem subset_refl (s: myset α):
s ⊆ s :=
λ x hxs, hxs

@[trans]
theorem subset_trans (A B C: myset α):
A ⊆ B → B ⊆ C → A ⊆ C :=
λ hAB hBC x hx, hBC x (hAB x hx)

def power_set (s : myset α) : myset (myset α) :=
λ t, t ⊆ s

def intersection (s : myset α) (t : myset α) : myset α :=
λ a, s a ∧ t a
instance: has_inter (myset α) := ⟨intersection⟩
def union (s : myset α) (t : myset α) : myset α :=
λ a, s a ∨ t a
instance: has_union (myset α) := ⟨union⟩

-- Construct an empty set with type α
def empty_of (α : Type u) : myset α := λ a, false
def empty {α : Type u} (s : myset α) : Prop := ∀ a : α, ¬(a ∈ s)
def all_of (α : Type u) : myset α := λ a, true

theorem exists_iff_nempty {s : myset α} :
(∃ x, x ∈ s) ↔ ¬empty s :=
begin
  split; assume h, {
    assume hemp,
    cases h with x hx,
    have := hemp x,
    contradiction,
  }, {
    unfold myset.empty at h,
    rw not_forall at h,
    cases h with k hk,
    existsi k,
    rw not_not at hk,
    assumption,
  },
end

-- Set product, gives myset (α × β)
def set_prod (U : myset α) (V : myset β) : myset (α × β) :=
{t | t.1 ∈ U ∧ t.2 ∈ V}

notation U × V := set_prod U V

instance : has_emptyc (myset α) :=
⟨λ a, false⟩

theorem in_empty_false (x : α) : x ∈ (∅ : myset α) → false :=
begin
  assume hx,
  assumption,
end

theorem empty_iff_eq_empty {s: myset α}: empty s ↔ s = ∅ :=
begin
  split; assume h, {
    apply setext,
    intro a,
    have := h a,
    split, {
      assume hs, contradiction,
    }, {
      assume he,
      exfalso,
      from he,
    },
  }, {
    intro a,
    assume hs,
    rw h at hs,
    from hs,
  },
end

theorem exists_iff_neq_empty {S: myset α}:
(∃ x, x ∈ S) ↔ S ≠ ∅ :=
begin
  have: S ≠ ∅ ↔ ¬S = ∅ := iff.rfl,
  rw this,
  rw ←empty_iff_eq_empty,
  rw ←exists_iff_nempty,
end

@[reducible]
def sUnion (s : myset (myset α)) : myset α := {t | ∃ a ∈ s, t ∈ a}
prefix `⋃₀`:120 := sUnion

@[reducible]
def sIntersection (s : myset (myset α)) : myset α :=
{t | ∀ a ∈ s, t ∈ a}
prefix `⋂₀`:120 := sIntersection

theorem union_two_sUnion
{α: Type u} (U V: myset α):
(U ∪ V) = ⋃₀ {S | S = U ∨ S = V} :=
begin
  apply setext,
  intro x,
  split, {
    assume hUVx,
    cases hUVx with hUx hVx, {
      existsi U,
      existsi (or.inl rfl),
      assumption,
    }, {
      existsi V,
      existsi (or.inr rfl),
      assumption,
    },
  }, {
    assume hUVx,
    cases hUVx with S hS,
    cases hS with hS hx,
    cases hS with hU hV, {
      left,
      rw ←hU,
      assumption,
    }, {
      right,
      rw ←hV,
      assumption,
    },
  },
end

theorem intersect_two_sIntersection
{α: Type u} (U V: myset α):
(U ∩ V) = ⋂₀ {S | S = U ∨ S = V} :=
begin
  apply setext,
  intro x,
  split, {
    assume hUVx,
    cases hUVx with hUx hVx,
    intro S,
    assume hS,
    cases hS; {rw hS; assumption},
  }, {
    assume hUVx,
    split, {
      from hUVx U (or.inl rfl),
    }, {
      from hUVx V (or.inr rfl),
    },
  },
end

def univ : myset α :=
λ a, true

def singleton (x: α): myset α :=
{y | y = x}

theorem singleton_eq (x y: α): y ∈ singleton x → y = x :=
begin
  assume hyx,
  from hyx,
end

def image {α β : Type u} (f : α → β) (U : myset α) := {b | ∃ a, a ∈ U ∧ f a = b}

-- comes up often in algebra & topology etc
def imageu {α β: Type u} (f: α → β) := {b: β | ∃ a: α, f a = b}

def inverse_image {α β : Type u} (f : α → β) (V : myset β) := {a | f a ∈ V}

def cartprod {α: Type u} (I: Type u) (sets: I → myset α): Type u :=
{f: I → α // ∀ i: I, f i ∈ sets i}

theorem inverse_image_of_image
{α β : Type} (f: α → β) (U : myset α):
U ⊆ inverse_image f (image f U) :=
begin
  intro x,
  assume hx,
  existsi x,
  split, assumption, trivial,
end

theorem image_of_inverse_image
{α β : Type} (f: α → β) (U : myset β):
image f (inverse_image f U) ⊆ U :=
begin
  intro x,
  assume hx,
  cases hx with y hy,
  rw ←hy.right,
  from hy.left,
end

theorem subset_empty_impl_empty
{α: Type} (U: myset α):
U ⊆ ∅ → U = ∅ :=
begin
  assume hUe,
  apply setext,
  intro x,
  split; assume h, {
    from hUe _ h,
  }, {
    exfalso, from h,
  },
end

theorem univ_subset_impl_univ
{α: Type} (U: myset α):
myset.univ ⊆ U → U = myset.univ :=
begin
  assume h,
  apply setext,
  intro x,
  split; assume hux, {
    trivial,
  }, {
    from h x trivial,
  },
end

theorem image_nonempty
{α β : Type} (f: α → β) (U: myset α):
U ≠ ∅ → image f U ≠ ∅ :=
begin
  assume hUne,
  assume hpreUe,
  rw ←empty_iff_eq_empty at hpreUe,
  change ¬(U = ∅) at hUne,
  rw ←empty_iff_eq_empty at hUne,
  rw ←exists_iff_nempty at hUne,
  cases hUne with x hx,
  apply hpreUe (f x),
  existsi x,
  split, assumption, refl,
end

theorem image_empty
{α β : Type} (f: α → β) (U: myset α):
U = ∅ → image f U = ∅ :=
begin
  assume hUe,
  apply setext,
  intro x,
  split; assume h, {
    cases h with y hy,
    rw hUe at hy,
    from hy.left,
  }, {
    exfalso, from h,
  },
end

theorem inverse_image_empty
{α β : Type} (f: α → β) (U: myset β):
U = ∅ → inverse_image f U = ∅ :=
begin
  assume hUe,
  apply setext,
  intro x,
  split; assume h, {
    rw hUe at h,
    from h,
  }, {
    exfalso, from h,
  },
end

theorem inverse_image_intersection
{α β : Type} (f: α → β) (U V: myset β):
inverse_image f (U ∩ V) = inverse_image f U ∩ inverse_image f V :=
begin
  refl,
end

theorem inverse_image_union
{α β : Type} (f: α → β) (U V: myset β):
inverse_image f (U ∪ V) = inverse_image f U ∪ inverse_image f V :=
begin
  refl,
end

theorem inverse_image_sUnion
{α β : Type} (f: α → β) (S: myset (myset β)):
inverse_image f ⋃₀ S = ⋃₀ image (inverse_image f) S :=
begin
  apply setext,
  intro x,
  split; assume hx, {
    cases hx with U hU,
    cases hU with hU hxU,
    existsi (inverse_image f U),
    split, {
      existsi U,
      split, {
        assumption,
      }, {
        refl,
      },
    }, {
      assumption,
    },
  }, {
    cases hx with U hU,
    cases hU with hU hxU,
    cases hU with V hV,
    existsi V,
    split, {
      from hV.left,
    }, {
      rw ←hV.right at hxU,
      from hxU,
    },
  },
end

theorem inverse_image_sIntersection
{α β : Type} (f: α → β) (S: myset (myset β)):
inverse_image f ⋂₀ S = ⋂₀ image (inverse_image f) S :=
begin
  apply setext,
  intro x,
  split; assume hx, {
    intro U,
    assume hUS,
    cases hUS with V hV,
    rw ←hV.right,
    from hx V hV.left,
  }, {
    intro U,
    assume hUs,
    apply hx,
    existsi U,
    split, {
      assumption,
    }, {
      refl,
    },
  },
end

theorem image_intersection
{α β : Type} (f: α → β) (U V: myset α):
image f (U ∩ V) ⊆ image f U ∩ image f V :=
begin
  intro x,
  assume hx,
  cases hx with y hy,
  split, {
    existsi y,
    split, {
      from hy.left.left,
    }, {
      from hy.right,
    },
  }, {
    existsi y,
    split, {
      from hy.left.right,
    }, {
      from hy.right,
    },
  },
end

theorem image_union
{α β : Type} (f: α → β) (U V: myset α):
image f (U ∪ V) = image f U ∪ image f V :=
begin
  apply setext,
  intro x,
  split; assume hx, {
    cases hx with y hy,
    cases hy with hyUV hfyx,
    rw ←hfyx,
    cases hyUV with hyU hyV, {
      left,
      existsi y,
      split, {
        assumption,
      }, {
        refl,
      },
    }, {
      right,
      existsi y,
      split, {
        assumption,
      }, {
        refl,
      },
    },
  }, {
    cases hx with hxfU hxfV, {
      cases hxfU with y hy,
      existsi y,
      split, {
        left,
        from hy.left,
      }, {
        from hy.right,
      },
    }, {
      cases hxfV with y hy,
      existsi y,
      split, {
        right,
        from hy.left,
      }, {
        from hy.right,
      },
    },
  },
end

theorem image_sUnion
{α β : Type} (f: α → β) (S: myset (myset α)):
image f ⋃₀ S = ⋃₀ image (image f) S :=
begin
  apply setext,
  intro x,
  split; assume hx, {
    cases hx with y hy,
    cases hy with hy hfyx,
    cases hy with U hU,
    cases hU with hU hyU,
    existsi image f U,
    split, {
      existsi U,
      split, {
        assumption,
      }, {
        refl,
      },
    }, {
      existsi y,
      split; assumption,
    },
  }, {
    cases hx with U hU,
    cases hU with hU hxU,
    cases hU with V hV,
    rw ←hV.right at hxU,
    cases hxU with y hy,
    existsi y,
    split, {
      existsi V,
      split, {
        from hV.left,
      }, {
        from hy.left,
      },
    }, {
      from hy.right,
    },
  },
end

theorem image_sIntersection
{α β : Type} (f: α → β) (S: myset (myset α)):
image f ⋂₀ S ⊆ ⋂₀ image (image f) S :=
begin
  intro x,
  assume hx,
  intro U,
  assume hU,
  cases hU with V hV,
  cases hx with y hy,
  rw ←hy.right,
  rw ←hV.right,
  existsi y,
  split, {
    apply hy.left,
    from hV.left,
  }, {
    refl,
  },
end

theorem inverse_image_composition
{α β γ: Type} (f: α → β) (g: β → γ) (U: myset γ):
inverse_image (g ∘ f) U =
inverse_image f (inverse_image g U) :=
begin
  apply setext,
  intro x,
  refl,
end

theorem image_composition
{α β γ: Type} (f: α → β) (g: β → γ) (U: myset α):
image (g ∘ f) U =
image g (image f U) :=
begin
  apply setext,
  intro x,
  split; assume h, {
    cases h with y hy,
    existsi f y,
    split, {
      existsi y, {
        split, {
          from hy.left,
        }, {
          refl,
        },
      },
    }, {
      from hy.right,
    },
  }, {
    cases h with y hy,
    cases hy with hy hgyx,
    cases hy with z hz,
    existsi z,
    split, {
      from hz.left,
    }, {
      change g (f z) = x,
      rw hz.right,
      assumption,
    },
  },
end

theorem image_subset
{α β: Type} (f: α → β) (U V: myset α):
U ⊆ V → image f U ⊆ image f V :=
begin
  assume hUV,
  intro x,
  assume hximf,
  cases hximf with y hy,
  existsi y,
  split, {
    apply hUV,
    from hy.left,
  }, {
    from hy.right,
  },
end

theorem inverse_image_subset
{α β: Type} (f: α → β) (U V: myset β):
U ⊆ V → inverse_image f U ⊆ inverse_image f V :=
begin
  assume hUV,
  intro x,
  assume hximf,
  apply hUV,
  from hximf,
end

theorem inverse_image_of_image_of_univ
{α β : Type} (f: α → β):
myset.univ = inverse_image f (image f myset.univ) :=
begin
  symmetry,
  apply univ_subset_impl_univ,
  apply inverse_image_of_image,
end

def compl (s : myset α) : myset α :=
{a | a ∉ s}

theorem inverse_image_compl
{α β: Type} (S: myset β) (f: α → β):
inverse_image f S.compl = (inverse_image f S).compl :=
begin
  refl,
end

theorem compl_compl
{α: Type} (S: myset α) [∀ x: α, decidable (x ∈ S)]:
S.compl.compl = S :=
begin
  apply setext,
  intro x,
  from decidable.not_not_iff _,
end

theorem compl_cancel {α: Type} (S: myset α) (T: myset α) [∀ x: α, decidable (x ∈ S)]
[∀ x: α, decidable (x ∈ T)]:
S.compl = T.compl → S = T :=
begin
  assume h,
  rw [←compl_compl S, ←compl_compl T, h],
end

theorem compl_intersection {α : Type} (S T : myset α) :
(S ∩ T).compl = S.compl ∪ T.compl :=
begin
  apply setext,
  intro x,
  from not_and_distrib,
end

-- Stronk decidability
theorem compl_sIntersection {α : Type} (σ : myset (myset α)) [∀ (x : α) (S: myset α), decidable (x ∈ S)] :
(⋂₀ σ).compl = ⋃₀ (image compl σ) :=
begin
  apply setext,
  intro x,
  split; assume h, {
    change ¬(∀ S ∈ σ, x ∈ S) at h,
    rw not_forall at h,
    cases h with S hS,
    rw not_imp at hS,
    existsi S.compl,
    suffices : S.compl ∈ image compl σ,
      existsi this,
      from hS.right,
    existsi S,
    split,
      from hS.left,
    refl,
  }, {
    change ¬(∀ S ∈ σ, x ∈ S),
    rw not_forall,
    change ∃ S ∈ (image compl σ), x ∈ S at h,
    cases h with S hS,
    cases hS with hS hxS,
    existsi S.compl,
    assume h,
    apply h,
      cases hS with T hT,
      rw [hT.right.symm, compl_compl],
      from hT.left,
    from hxS,
  },
end

section

open classical

local attribute [instance] classical.prop_decidable

theorem compl_sUnion {α : Type} (σ : myset (myset α)) :
(⋃₀ σ).compl = ⋂₀ (image compl σ) :=
begin
  apply compl_cancel,
  rw [compl_compl, compl_sIntersection],
  congr,
  apply setext,
  intro S,
  split; assume hS,
    existsi S.compl,
    split,
      existsi S,
      split,
        assumption,
      refl,
    rw compl_compl,
  cases hS with T hT,
  rw hT.right.symm,
  cases hT.left with U hU,
  rw [hU.right.symm, compl_compl],
  from hU.left,
end

theorem compl_subset_compl {α : Type}  (S T : myset α) :
S.compl ⊆ T.compl ↔ T ⊆ S :=
begin
  split; assume h,
    intros x hx,
    by_contradiction,
    from h _ a hx,
  intros x hx,
  assume hxT,
  from hx (h _ hxT),
end

end

theorem disjoint_iff_subset_compl {α : Type}  (S T : myset α) :
S ∩ T = ∅ ↔ S ⊆ T.compl :=
begin
  split; assume h,
    intros x hxS,
    assume hx,
    apply in_empty_false x, --??
    rw ←h,
    change x ∈ S ∧ x ∈ T,
    split,
      from hxS,
    from hx,
  apply setext,
  intro x,
  split; assume hx,
    exfalso,
    apply h _ hx.left,
    from hx.right,
  exfalso,
  assumption,
end

theorem intersection_comm {α : Type}  (S T : myset α) :
S ∩ T = T ∩ S :=
begin
  apply setext,
  intro x,
  split; from λ h, ⟨h.right, h.left⟩,
end

theorem subset_compl_symm {α : Type}  (S T : myset α) :
S ⊆ T.compl → T ⊆ S.compl :=
begin
  assume h,
  rwa [←disjoint_iff_subset_compl, intersection_comm, disjoint_iff_subset_compl],
end

-- Used to restrict some set to a subtype ("intersect" a set with a subtype)
def subtype_restriction (Y : myset α) (U : myset α) : myset (subtype Y) :=
{ w | ↑w ∈ U }

-- pffffff
def subtype_unrestriction (Y: myset α) (U: myset (subtype Y)): myset α :=
{x | ∃ hxS: x ∈ Y, (⟨x, hxS⟩: subtype Y) ∈ U}

def function_restrict_to_image
{α β: Type} (f: α → β): α → subtype (myset.imageu f)
:= λ x, ⟨f x, ⟨x, rfl⟩⟩

def function_restrict_to_set_image
{α β: Type} (f: α → β) (U: myset α): (subtype U) → subtype (myset.image f U)
:= λ x, ⟨f x, ⟨x.val, ⟨x.property, rfl⟩⟩⟩

theorem restrict_to_set_image_composition
{α β: Type} (f: α → β) (U: myset α):
function_restrict_to_set_image f U =
(λ y: subtype (imageu (λ x: subtype U, f x.val)), ⟨y.val,
  begin
    cases y.property with u hu,
    rw ←hu,
    existsi u.val,
    split, {
      from u.property,
    }, {
      refl,
    },
  end⟩) ∘
function_restrict_to_image (λ x: subtype U, f x.val) :=
rfl

theorem to_image_surjective
{α β: Type} (f: α → β):
(image (function_restrict_to_image f) univ) = univ :=
begin
  apply setext,
  intro x,
  split; assume h, {
    trivial,
  }, {
    cases x.property with y hy,
    unfold image,
    existsi y,
    split, {
      trivial,
    }, {
      apply subtype.eq,
      rw ←hy,
      refl,
    },
  },
end

theorem nonempty_inverse_image_surjective
{α β: Type} (f: α → β) (U: myset (subtype (imageu f))):
U ≠ ∅ →
inverse_image (function_restrict_to_image f) U ≠ ∅ :=
begin
  assume hUne,
  assume hpreUe,
  rw ←empty_iff_eq_empty at hpreUe,
  change ¬(U = ∅) at hUne,
  rw ←empty_iff_eq_empty at hUne,
  rw ←exists_iff_nempty at hUne,
  cases hUne with x hx,
  cases x.property with y hy,
  apply hpreUe y,
  unfold inverse_image,
  have: x = ⟨f y, begin rw hy, from x.property end⟩, {
    apply subtype.eq,
    from hy.symm,
  },
  rw this at hx, clear this,
  from hx,
end

end myset

end hidden


/-
Copyright (c) 2015 Floris van Doorn. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Floris van Doorn

Ported from Coq HoTT
Theorems about embeddings and surjections
-/
import .hit.trunc .types.equiv .cubical.square .types.nat.hott
universes u v w
hott_theory
namespace hott

open hott.equiv hott.sigma trunc is_trunc hott.pi hott.is_equiv fiber hott.prod pointed hott.nat

variables  {A : Type _} {B : Type _} {C : Type _} (f f' : A → B) {b : B}

/- the image of a map is the (-1)-truncated fiber -/
@[hott] def image' (f : A → B) (b : B) : Type _ := ∥ fiber f b ∥
@[hott, instance] def is_prop_image' (f : A → B) (b : B) : is_prop (image' f b) :=
is_trunc_trunc _ _
@[hott] def image (f : A → B) (b : B) : Prop := Prop.mk (image' f b) (by apply_instance)

@[hott] def total_image {A B : Type _} (f : A → B) : Type _ := Σx, image f x

@[hott, class] def is_embedding (f : A → B) := Π(a a' : A), is_equiv (ap f : a = a' → f a = f a')

@[hott, class] def is_surjective (f : A → B) := Π(b : B), image f b

@[hott, class] def is_split_surjective (f : A → B) := Π(b : B), fiber f b

@[hott, class] structure is_retraction (f : A → B) :=
  (sect : B → A)
  (right_inverse : Π(b : B), f (sect b) = b)

@[hott, class] structure is_section (f : A → B) :=
  (retr : B → A)
  (left_inverse : Π(a : A), retr (f a) = a)

@[hott, class] structure is_constant (f : A → B) :=
  (pt : B)
  (eq : Π(a : A), f a = pt)

@[hott, class] structure is_conditionally_constant (f : A → B) :=
  (g : ∥A∥ → B)
  (eq : Π(a : A), f a = g (tr a))

section image
@[hott] protected def image.mk {f : A → B} {b : B} (a : A) (p : f a = b)
  : image f b :=
tr (fiber.mk a p)

@[hott, induction] protected def image.rec {f : A → B} {b : B} {P : image' f b → Type _}
  [HP : Πv, is_prop (P v)] (H : Π(a : A) (p : f a = b), P (image.mk a p)) (v : image' f b) : P v :=
begin dsimp [image'] at *, hinduction v with v, hinduction v with a p, exact H a p end

@[hott] def image.elim {A B : Type _} {f : A → B} {C : Type _} [is_prop C] {b : B}
  (H : image f b) (H' : ∀ (a : A), f a = b → C) : C :=
begin
  refine (trunc.elim _ H),
  intro H'', cases H'' with a Ha, exact H' a Ha
end

@[hott] def image.equiv_exists {A B : Type _} {f : A → B} {b : B} : image f b ≃ ∃a, f a = b :=
trunc_equiv_trunc _ (fiber.sigma_char _ _)

@[hott] def image_pathover {f : A → B} {x y : B} (p : x = y) (u : image f x) (v : image f y) :
  u =[p; λb, image f b] v :=
is_prop.elimo _ _ _

@[hott] def total_image.rec
  {A B : Type _} {f : A → B} {C : total_image f → Type _} [H : Πx, is_prop (C x)]
  (g : Πa, C ⟨f a, image.mk a idp⟩)
  (x : total_image f) : C x :=
begin
  induction x with b v,
  refine @image.rec _ _ _ _ _ (λv, H ⟨b, v⟩) _ v,
  intros a p,
  induction p, exact g a
end

/- total_image.elim_set is in hit.prop_trunc to avoid dependency cycle -/

end image

namespace function

  abbreviation sect          := @is_retraction.sect
  abbreviation right_inverse := @is_retraction.right_inverse
  abbreviation retr          := @is_section.retr
  abbreviation left_inverse  := @is_section.left_inverse

  @[hott, instance] def is_equiv_ap_of_embedding [H : is_embedding f] (a a' : A)
    : is_equiv (ap f : a = a' → f a = f a') :=
  H a a'

  @[hott] def ap_inv_idp {a : A} {H : is_equiv (ap f : a = a → f a = f a)}
    : (ap f)⁻¹ᶠ idp = idp :> a = a :=
  left_inv (ap f) idp

  variable {f}
  @[hott, reducible] def is_injective_of_is_embedding [H : is_embedding f] {a a' : A}
    : f a = f a' → a = a' :=
  (ap f)⁻¹ᶠ

  @[hott] def is_embedding_of_is_injective [HA : is_set A] [HB : is_set B]
    (H : Π(a a' : A), f a = f a' → a = a') : is_embedding f :=
  begin
  intros a a',
  fapply adjointify,
    {exact (H a a')},
    {intro p, apply is_set.elim},
    {intro p, apply is_set.elim}
  end

  variable (f)

  @[hott, instance] def is_prop_is_embedding : is_prop (is_embedding f) :=
  by dsimp [is_embedding]; apply_instance

  @[hott] def is_embedding_equiv_is_injective [HA : is_set A] [HB : is_set B]
    : is_embedding f ≃ (Π(a a' : A), f a = f a' → a = a') :=
  begin
  fapply equiv.MK,
    { apply @is_injective_of_is_embedding},
    { apply is_embedding_of_is_injective},
    { intro H, apply is_prop.elim},
    { intro H, apply is_prop.elim, }
  end

  @[hott] def is_prop_fiber_of_is_embedding [H : is_embedding f] (b : B) :
    is_prop (fiber f b) :=
  begin
    apply is_prop.mk, intros v w,
    induction v with a p, induction w with a' q, induction q,
    fapply fiber_eq,
    { apply is_injective_of_is_embedding p},
    { dsimp [is_injective_of_is_embedding], symmetry, apply right_inv}
  end

  @[hott] def is_prop_fun_of_is_embedding [H : is_embedding f] : is_trunc_fun -1 f :=
  is_prop_fiber_of_is_embedding f

  @[hott] def is_embedding_of_is_prop_fun [H : is_trunc_fun -1 f] : is_embedding f :=
  begin
    intros a a', fapply adjointify,
    { intro p, exact ap point (@is_prop.elim (fiber f (f a')) _ (fiber.mk a p) (fiber.mk a' idp))},
    { intro p, rwr [←ap_compose],
      exact ap_con_eq (@point_eq _ _ f (f a')) (is_prop.elim ⟨a, p⟩ ⟨a', idp⟩) },
    { intro p, induction p, apply ap02 point (is_prop_elim_self _) }
  end

  variable {f}
  @[hott] def is_surjective_rec_on {P : Type _} (H : is_surjective f) (b : B) [Pt : is_prop P]
    (IH : fiber f b → P) : P :=
  trunc.rec_on (H b) IH
  variable (f)

  @[hott, instance] def is_surjective_of_is_split_surjective [H : is_split_surjective f]
    : is_surjective f :=
  λb, tr (H b)

  @[hott, instance] def is_prop_is_surjective : is_prop (is_surjective f) :=
  begin dsimp [is_surjective], apply_instance end

  @[hott] def is_surjective_cancel_right {A B C : Type _} (g : B → C) (f : A → B)
    [H : is_surjective (g ∘ f)] : is_surjective g :=
  begin
    intro c,
    have := H c,
    hinduction H c with q p, hinduction p with a p,
    exact tr (fiber.mk (f a) p)
  end

  @[hott, instance] def is_weakly_constant_ap [H : is_weakly_constant f] (a a' : A) :
    is_weakly_constant (ap f : a = a' → f a = f a') :=
  λp q : a = a',
  have Π{b c : A} {r : b = c}, (H a b)⁻¹ ⬝ H a c = ap f r, from
    (λb c r, by hinduction r; apply con.left_inv),
  this⁻¹ ⬝ this

  @[hott, instance] def is_constant_ap [H : is_constant f] (a a' : A)
    : is_constant (ap f : a = a' → f a = f a') :=
  begin
    unfreezeI; induction H with b q,
    fapply is_constant.mk,
    { exact q a ⬝ (q a')⁻¹},
    { intro p, induction p, exact (con.right_inv _)⁻¹}
  end

  @[hott, instance] def is_contr_is_retraction [H : is_equiv f] : is_contr (is_retraction f) :=
  begin
    have H2 : (Σ(g : B → A), Πb, f (g b) = b) ≃ is_retraction f,
    begin
      fapply equiv.MK,
        {intro x, induction x with g p, constructor, exact p},
        {intro h, induction h, apply sigma.mk, assumption},
        {intro h, induction h, reflexivity},
        {intro x, induction x, reflexivity},
    end,
    apply is_trunc_equiv_closed, exact H2,
    apply is_equiv.is_contr_right_inverse
  end

  @[hott, instance] def is_contr_is_section [H : is_equiv f] : is_contr (is_section f) :=
  begin
    have H2 : (Σ(g : B → A), Πa, g (f a) = a) ≃ is_section f,
    begin
      fapply equiv.MK,
        {intro x, induction x with g p, constructor, exact p},
        {intro h, induction h with h hp, apply sigma.mk, exact hp },
        {intro h, induction h, reflexivity},
        {intro x, induction x, reflexivity},
    end,
    apply is_trunc_equiv_closed, exact H2,
    apply is_trunc_equiv_closed,
      {apply sigma_equiv_sigma_right, intro g, apply eq_equiv_homotopy (g ∘ f) id},
    apply is_trunc_equiv_closed,
      {apply fiber.sigma_char},
    apply is_contr_fiber_of_is_equiv _,
    exact to_is_equiv (arrow_equiv_arrow_left_rev A (equiv.mk f H)),
  end

  @[hott, instance] def is_embedding_of_is_equiv [H : is_equiv f] : is_embedding f :=
  λa a', by apply_instance

  @[hott] def is_equiv_of_is_surjective_of_is_embedding
    [H : is_embedding f] [H' : is_surjective f] : is_equiv f :=
  @is_equiv_of_is_contr_fun _ _ _
    (λb, is_surjective_rec_on H' b
      (λa, is_contr.mk a
        (λa',
          fiber_eq ((ap f)⁻¹ᶠ ((point_eq a) ⬝ (point_eq a')⁻¹))
                   (by rwr (right_inv (ap f)); rwr inv_con_cancel_right))))

  @[hott] def is_split_surjective_of_is_retraction [H : is_retraction f] : is_split_surjective f :=
  λb, fiber.mk (sect f b) (right_inverse f b)

  @[hott, instance] def is_constant_compose_point (b : B)
    : is_constant (f ∘ point : fiber f b → B) :=
  is_constant.mk b (λv, by induction v with a p;exact p)

  @[hott] def is_embedding_of_is_prop_fiber [H : Π(b : B), is_prop (fiber f b)] : is_embedding f :=
  is_embedding_of_is_prop_fun _

  @[hott, instance] def is_retraction_of_is_equiv [H : is_equiv f] : is_retraction f :=
  is_retraction.mk f⁻¹ᶠ (right_inv f)

  @[hott, instance] def is_section_of_is_equiv [H : is_equiv f] : is_section f :=
  is_section.mk f⁻¹ᶠ (left_inv f)

  @[hott] def is_equiv_of_is_section_of_is_retraction [H1 : is_retraction f] [H2 : is_section f]
    : is_equiv f :=
  let g := sect f in let h := retr f in
  adjointify f
             g
             (right_inverse f)
             (λa, calc
                    g (f a) = h (f (g (f a))) : (left_inverse _ _)⁻¹
                    ... = h (f a) : by rwr right_inverse f _
                    ... = a : left_inverse _ _)

  section
    local attribute [instance] [priority 10000] is_equiv_of_is_section_of_is_retraction
    --local attribute [instance] [priority 1] trunctype.struct -- remove after #842 is closed
    variable (f)
    @[hott] def is_prop_is_retraction_prod_is_section : is_prop (is_retraction f × is_section f) :=
    begin
      apply is_prop_of_imp_is_contr, intro H, induction H with H1 H2,
      resetI, apply_instance,
    end
  end

  @[hott, instance] def is_retraction_trunc_functor (r : A → B) [H : is_retraction r]
    (n : trunc_index) : is_retraction (trunc_functor n r) :=
  is_retraction.mk
    (trunc_functor n (sect r))
    (λb,
      ((trunc_functor_compose n r (sect r)) b)⁻¹
      ⬝ trunc_homotopy n (right_inverse r) b
      ⬝ trunc_functor_id n B b)

  -- @[hott] lemma 3.11.7
  @[hott] def is_contr_retract (r : A → B) [H : is_retraction r] : is_contr A → is_contr B :=
  begin
    intro CA,
    applyI is_contr.mk (r (center A)),
    intro b,
    exact ap r (center_eq (is_retraction.sect r b)) ⬝ (is_retraction.right_inverse r b)
  end

  local attribute [instance] is_prop_is_retraction_prod_is_section
  @[hott] def is_retraction_prod_is_section_equiv_is_equiv
    : (is_retraction f × is_section f) ≃ is_equiv f :=
  begin
    apply equiv_of_is_prop,
    intro H, induction H, apply is_equiv_of_is_section_of_is_retraction _; assumption,
    intro H, resetI, split, apply_instance, apply_instance
  end

  @[hott] def is_retraction_equiv_is_split_surjective :
    is_retraction f ≃ is_split_surjective f :=
  begin
    fapply equiv.MK,
    { intro H, induction H with g p, intro b, constructor, exact p b},
    { intro H, constructor, intro b, exact point_eq (H b)},
    { intro H, apply eq_of_homotopy, intro b, dsimp,
      hinduction H b with q a p, refl },
    { intro H, induction H with g p, reflexivity},
  end

  @[hott] def is_embedding_compose (g : B → C) (f : A → B)
    (H₁ : is_embedding g) (H₂ : is_embedding f) : is_embedding (g ∘ f) :=
  begin
    intros a a', apply is_equiv.homotopy_closed (ap g ∘ ap f),
      symmetry, exact ap_compose g f,
      apply is_equiv_compose,
  end

  @[hott] def is_surjective_compose (g : B → C) (f : A → B)
    (H₁ : is_surjective g) (H₂ : is_surjective f) : is_surjective (g ∘ f) :=
  begin
    intro c, hinduction H₁ c with x p, hinduction p with b p,
    hinduction H₂ b with y q, hinduction q with a q,
    exact image.mk a (ap g q ⬝ p)
  end

  @[hott] def is_split_surjective_compose (g : B → C) (f : A → B)
    (H₁ : is_split_surjective g) (H₂ : is_split_surjective f) : is_split_surjective (g ∘ f) :=
  begin
    intro c, hinduction H₁ c with x b p, hinduction H₂ b with y a q,
    exact fiber.mk a (ap g q ⬝ p)
  end

  @[hott] def is_injective_compose (g : B → C) (f : A → B)
    (H₁ : Π⦃b b'⦄, g b = g b' → b = b') (H₂ : Π⦃a a'⦄, f a = f a' → a = a')
    ⦃a a' : A⦄ (p : g (f a) = g (f a')) : a = a' :=
  H₂ (H₁ p)

  @[hott, instance] def is_embedding_pr1 {A : Type _} (B : A → Type _) [H : Π a, is_prop (B a)]
      : is_embedding (@sigma.fst A B) :=
  λv v', to_is_equiv (sigma_eq_equiv v v' ⬝e sigma_equiv_of_is_contr_right _)

  variables {f f'}
  @[hott] def is_embedding_homotopy_closed (p : f ~ f') (H : is_embedding f) : is_embedding f' :=
  begin
    intros a a', fapply is_equiv_of_equiv_of_homotopy,
    exact equiv.mk (ap f) (by apply_instance) ⬝e
      equiv_eq_closed_left _ (p a) ⬝e equiv_eq_closed_right _ (p a'),
    intro q, exact (eq_bot_of_square (transpose (natural_square p q)))⁻¹
  end

  @[hott] def is_embedding_homotopy_closed_rev (p : f' ~ f) (H : is_embedding f) : is_embedding f' :=
  is_embedding_homotopy_closed p⁻¹ʰᵗʸ H

  @[hott] def is_surjective_homotopy_closed (p : f ~ f') (H : is_surjective f) : is_surjective f' :=
  begin
    intro b, hinduction H b with x q, hinduction q with a q,
    exact image.mk a ((p a)⁻¹ ⬝ q)
  end

  @[hott] def is_surjective_homotopy_closed_rev (p : f' ~ f) (H : is_surjective f) :
    is_surjective f' :=
  is_surjective_homotopy_closed p⁻¹ʰᵗʸ H

  @[hott] def is_equiv_ap1_gen_of_is_embedding {A B : Type _} (f : A → B) [is_embedding f]
    {a a' : A} {b b' : B} (q : f a = b) (q' : f a' = b') : is_equiv (ap1_gen f q q') :=
  begin
    induction q, induction q',
    exact is_equiv.homotopy_closed _ (ap1_gen_idp_left f)⁻¹ʰᵗʸ,
  end

  @[hott] def is_equiv_ap1_of_is_embedding {A B : Type*} (f : A →* B) [is_embedding f] :
    is_equiv (Ω→ f) :=
  is_equiv_ap1_gen_of_is_embedding f (respect_pt f) (respect_pt f)

  @[hott] def loop_pequiv_loop_of_is_embedding {A B : Type*} (f : A →* B)
    [is_embedding f] : Ω A ≃* Ω B :=
  pequiv_of_pmap (Ω→ f) (is_equiv_ap1_of_is_embedding f)

  @[hott] def loopn_pequiv_loopn_of_is_embedding (n : ℕ) [H : is_succ n]
    {A B : Type*} (f : A →* B) [is_embedding f] : Ω[n] A ≃* Ω[n] B :=
  begin
    unfreezeI, induction H with n,
    exact loopn_succ_in _ _ ⬝e*
      loopn_pequiv_loopn n (loop_pequiv_loop_of_is_embedding f) ⬝e*
      (loopn_succ_in _ _)⁻¹ᵉ*
  end

  /-
    The definitions
      is_surjective_of_is_equiv
      is_equiv_equiv_is_embedding_times_is_surjective
    are in types.trunc

    See types.arrow_2 for retractions
  -/

end function
end hott


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

! This file was ported from Lean 3 source module algebra.star.module
! leanprover-community/mathlib commit 30413fc89f202a090a54d78e540963ed3de0056e
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Algebra.Star.SelfAdjoint
import Mathlib.Algebra.Module.Equiv
import Mathlib.LinearAlgebra.Prod

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

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

This file also provides some lemmas that need `Algebra.Module.Basic` imported to prove.

## TODO

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

section SmulLemmas

variable {R M : Type _}

@[simp]
theorem star_nat_cast_smul [Semiring R] [AddCommMonoid M] [Module R M] [StarAddMonoid M] (n : ℕ)
    (x : M) : star ((n : R) • x) = (n : R) • star x :=
  map_nat_cast_smul (starAddEquiv : M ≃+ M) R R n x
#align star_nat_cast_smul star_nat_cast_smul

@[simp]
theorem star_int_cast_smul [Ring R] [AddCommGroup M] [Module R M] [StarAddMonoid M] (n : ℤ)
    (x : M) : star ((n : R) • x) = (n : R) • star x :=
  map_int_cast_smul (starAddEquiv : M ≃+ M) R R n x
#align star_int_cast_smul star_int_cast_smul

@[simp]
theorem star_inv_nat_cast_smul [DivisionSemiring R] [AddCommMonoid M] [Module R M] [StarAddMonoid M]
    (n : ℕ) (x : M) : star ((n⁻¹ : R) • x) = (n⁻¹ : R) • star x :=
  map_inv_nat_cast_smul (starAddEquiv : M ≃+ M) R R n x
#align star_inv_nat_cast_smul star_inv_nat_cast_smul

@[simp]
theorem star_inv_int_cast_smul [DivisionRing R] [AddCommGroup M] [Module R M] [StarAddMonoid M]
    (n : ℤ) (x : M) : star ((n⁻¹ : R) • x) = (n⁻¹ : R) • star x :=
  map_inv_int_cast_smul (starAddEquiv : M ≃+ M) R R n x
#align star_inv_int_cast_smul star_inv_int_cast_smul

@[simp]
theorem star_rat_cast_smul [DivisionRing R] [AddCommGroup M] [Module R M] [StarAddMonoid M] (n : ℚ)
    (x : M) : star ((n : R) • x) = (n : R) • star x :=
  map_rat_cast_smul (starAddEquiv : M ≃+ M) _ _ _ x
#align star_rat_cast_smul star_rat_cast_smul

@[simp]
theorem star_rat_smul {R : Type _} [AddCommGroup R] [StarAddMonoid R] [Module ℚ R] (x : R) (n : ℚ) :
    star (n • x) = n • star x :=
  map_rat_smul (starAddEquiv : R ≃+ R) _ _
#align star_rat_smul star_rat_smul

end SmulLemmas

section deinstance
-- porting note: this is lean#2074 at play
attribute [-instance] Ring.toNonUnitalRing
attribute [-instance] CommRing.toNonUnitalCommRing

/-- If `A` is a module over a commutative `R` with compatible actions,
then `star` is a semilinear equivalence. -/
@[simps]
def starLinearEquiv (R : Type _) {A : Type _} [CommRing R] [StarRing R] [Semiring A] [StarRing A]
    [Module R A] [StarModule R A] : A ≃ₗ⋆[R] A :=
  { starAddEquiv with
    toFun := star
    map_smul' := star_smul }
#align star_linear_equiv starLinearEquiv

end deinstance

variable (R : Type _) (A : Type _) [Semiring R] [StarSemigroup R] [TrivialStar R] [AddCommGroup A]
  [Module R A] [StarAddMonoid A] [StarModule R A]

/-- The self-adjoint elements of a star module, as a submodule. -/
def selfAdjoint.submodule : Submodule R A :=
  { selfAdjoint A with smul_mem' := fun _ _ => (IsSelfAdjoint.all _).smul }
#align self_adjoint.submodule selfAdjoint.submodule

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

variable {A} [Invertible (2 : R)]

/-- The self-adjoint part of an element of a star module, as a linear map. -/
@[simps]
def selfAdjointPart : A →ₗ[R] selfAdjoint A
    where
  toFun x :=
    ⟨(⅟ 2 : R) • (x + star x), by
      simp only [selfAdjoint.mem_iff, star_smul, add_comm, StarAddMonoid.star_add, star_inv',
        star_bit0, star_one, star_star, star_invOf (2 : R), star_trivial]⟩
  map_add' x y := by
    ext
    simp [add_add_add_comm]
  map_smul' r x := by
    ext
    simp [← mul_smul, show ⅟ 2 * r = r * ⅟ 2 from Commute.invOf_left <| (2 : ℕ).cast_commute r]
#align self_adjoint_part selfAdjointPart

/-- The skew-adjoint part of an element of a star module, as a linear map. -/
@[simps]
def skewAdjointPart : A →ₗ[R] skewAdjoint A
    where
  toFun x :=
    ⟨(⅟ 2 : R) • (x - star x), by
      simp only [skewAdjoint.mem_iff, star_smul, star_sub, star_star, star_trivial, ← smul_neg,
        neg_sub]⟩
  map_add' x y := by
    ext
    simp only [sub_add, ← smul_add, sub_sub_eq_add_sub, star_add, AddSubgroup.coe_mk,
      AddSubgroup.coe_add]
  map_smul' r x := by
    ext
    simp [← mul_smul, ← smul_sub,
      show r * ⅟ 2 = ⅟ 2 * r from Commute.invOf_right <| (2 : ℕ).commute_cast r]
#align skew_adjoint_part skewAdjointPart

theorem StarModule.selfAdjointPart_add_skewAdjointPart (x : A) :
    (selfAdjointPart R x : A) + skewAdjointPart R x = x := by
  simp only [smul_sub, selfAdjointPart_apply_coe, smul_add, skewAdjointPart_apply_coe,
    add_add_sub_cancel, inv_of_two_smul_add_inv_of_two_smul]
#align star_module.self_adjoint_part_add_skew_adjoint_part StarModule.selfAdjointPart_add_skewAdjointPart

variable (A)

/-- The decomposition of elements of a star module into their self- and skew-adjoint parts,
as a linear equivalence. -/
-- Porting note: This attribute causes a `timeout at 'whnf'`.
-- @[simps!]
def StarModule.decomposeProdAdjoint : A ≃ₗ[R] selfAdjoint A × skewAdjoint A := by
  refine LinearEquiv.ofLinear ((selfAdjointPart R).prod (skewAdjointPart R))
    (LinearMap.coprod ((selfAdjoint.submodule R A).subtype) (skewAdjoint.submodule R A).subtype)
    ?_ (LinearMap.ext <| StarModule.selfAdjointPart_add_skewAdjointPart R)
  -- Porting note: The remaining proof at this point used to be `ext <;> simp`.
  ext
  · rw [LinearMap.id_coe, id.def]
    rw [LinearMap.coe_comp, Function.comp_apply, LinearMap.coprod_apply]

    -- Porting note: It seems that in mathlib4 simp got a problem with defEq things.
    -- It seems that in mathlib3 this was `submodule.coe_subtype`.
    -- i.e. `rw [Submodule.coeSubtype]`
    rename_i x
    change ↑((LinearMap.prod (selfAdjointPart R) (skewAdjointPart R))
      (Subtype.val x.fst + Subtype.val x.snd)).fst = (x.fst : A)

    simp
  · rw [LinearMap.id_coe, id.def]
    rw [LinearMap.coe_comp, Function.comp_apply, LinearMap.coprod_apply]

    -- Porting note: See note above.
    rename_i x
    change ↑((LinearMap.prod (selfAdjointPart R) (skewAdjointPart R))
      (Subtype.val x.fst + Subtype.val x.snd)).snd = (x.snd : A)

    -- Porting note: With `set_option synthInstance.etaExperiment true` (lean4#2074) one needs the
    -- 2 lines below (in particular `Pi.prod`).
    -- With `etaExperiment false` they are uneccessary as `simp` would succeed without.
    rw [LinearMap.prod_apply]
    rw [Pi.prod]

    simp
#align star_module.decompose_prod_adjoint StarModule.decomposeProdAdjoint

@[simp]
theorem algebraMap_star_comm {R A : Type _} [CommSemiring R] [StarRing R] [Semiring A]
    [StarSemigroup A] [Algebra R A] [StarModule R A] (r : R) :
    algebraMap R A (star r) = star (algebraMap R A r) := by
  simp only [Algebra.algebraMap_eq_smul_one, star_smul, star_one]
#align algebra_map_star_comm algebraMap_star_comm


/-
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.multiset.sum
import data.finset.card

/-!
# Disjoint sum of finsets

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

This file defines the disjoint sum of two finsets as `finset (α ⊕ β)`. Beware not to confuse with
the `finset.sum` operation which computes the additive sum.

## Main declarations

* `finset.disj_sum`: `s.disj_sum t` is the disjoint sum of `s` and `t`.
-/

open function multiset sum

namespace finset
variables {α β : Type*} (s : finset α) (t : finset β)

/-- Disjoint sum of finsets. -/
def disj_sum : finset (α ⊕ β) := ⟨s.1.disj_sum t.1, s.2.disj_sum t.2⟩

@[simp] lemma val_disj_sum : (s.disj_sum t).1 = s.1.disj_sum t.1 := rfl

@[simp] lemma empty_disj_sum : (∅ : finset α).disj_sum t = t.map embedding.inr :=
val_inj.1 $ multiset.zero_disj_sum _

@[simp] lemma disj_sum_empty : s.disj_sum (∅ : finset β) = s.map embedding.inl :=
val_inj.1 $ multiset.disj_sum_zero _

@[simp] lemma card_disj_sum : (s.disj_sum t).card = s.card + t.card := multiset.card_disj_sum _ _

lemma disjoint_map_inl_map_inr : disjoint (s.map embedding.inl) (t.map embedding.inr) :=
by { simp_rw [disjoint_left, mem_map], rintro x ⟨a, _, rfl⟩ ⟨b, _, ⟨⟩⟩ }

@[simp]
lemma map_inl_disj_union_map_inr :
  (s.map embedding.inl).disj_union (t.map embedding.inr) (disjoint_map_inl_map_inr _ _) =
    s.disj_sum t := rfl

variables {s t} {s₁ s₂ : finset α} {t₁ t₂ : finset β} {a : α} {b : β} {x : α ⊕ β}

lemma mem_disj_sum : x ∈ s.disj_sum t ↔ (∃ a, a ∈ s ∧ inl a = x) ∨ ∃ b, b ∈ t ∧ inr b = x :=
multiset.mem_disj_sum

@[simp] lemma inl_mem_disj_sum : inl a ∈ s.disj_sum t ↔ a ∈ s := inl_mem_disj_sum
@[simp] lemma inr_mem_disj_sum : inr b ∈ s.disj_sum t ↔ b ∈ t := inr_mem_disj_sum

lemma disj_sum_mono (hs : s₁ ⊆ s₂) (ht : t₁ ⊆ t₂) : s₁.disj_sum t₁ ⊆ s₂.disj_sum t₂ :=
val_le_iff.1 $ disj_sum_mono (val_le_iff.2 hs) (val_le_iff.2 ht)

lemma disj_sum_mono_left (t : finset β) : monotone (λ s : finset α, s.disj_sum t) :=
λ s₁ s₂ hs, disj_sum_mono hs subset.rfl

lemma disj_sum_mono_right (s : finset α) : monotone (s.disj_sum : finset β → finset (α ⊕ β)) :=
λ t₁ t₂, disj_sum_mono subset.rfl

lemma disj_sum_ssubset_disj_sum_of_ssubset_of_subset (hs : s₁ ⊂ s₂) (ht : t₁ ⊆ t₂) :
  s₁.disj_sum t₁ ⊂ s₂.disj_sum t₂ :=
val_lt_iff.1 $ disj_sum_lt_disj_sum_of_lt_of_le (val_lt_iff.2 hs) (val_le_iff.2 ht)

lemma disj_sum_ssubset_disj_sum_of_subset_of_ssubset (hs : s₁ ⊆ s₂) (ht : t₁ ⊂ t₂) :
  s₁.disj_sum t₁ ⊂ s₂.disj_sum t₂ :=
val_lt_iff.1 $ disj_sum_lt_disj_sum_of_le_of_lt (val_le_iff.2 hs) (val_lt_iff.2 ht)

lemma disj_sum_strict_mono_left (t : finset β) : strict_mono (λ s : finset α, s.disj_sum t) :=
λ s₁ s₂ hs, disj_sum_ssubset_disj_sum_of_ssubset_of_subset hs subset.rfl

lemma disj_sum_strict_mono_right (s : finset α) :
  strict_mono (s.disj_sum : finset β → finset (α ⊕ β)) :=
λ s₁ s₂, disj_sum_ssubset_disj_sum_of_subset_of_ssubset subset.rfl

end finset


/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro, Kenny Lau, Scott Morrison
-/
import data.list.chain
import data.list.nodup
import data.list.of_fn
import data.list.zip

open nat

namespace list
/- iota and range(') -/

universe u

variables {α : Type u}

@[simp] theorem length_range' : ∀ (s n : ℕ), length (range' s n) = n
| s 0     := rfl
| s (n+1) := congr_arg succ (length_range' _ _)

@[simp] theorem range'_eq_nil {s n : ℕ} : range' s n = [] ↔ n = 0 :=
by rw [← length_eq_zero, length_range']

@[simp] theorem mem_range' {m : ℕ} : ∀ {s n : ℕ}, m ∈ range' s n ↔ s ≤ m ∧ m < s + n
| s 0     := (false_iff _).2 $ λ ⟨H1, H2⟩, not_le_of_lt H2 H1
| s (succ n) :=
  have m = s → m < s + n + 1,
    from λ e, e ▸ lt_succ_of_le (le_add_right _ _),
  have l : m = s ∨ s + 1 ≤ m ↔ s ≤ m,
    by simpa only [eq_comm] using (@le_iff_eq_or_lt _ _ s m).symm,
  (mem_cons_iff _ _ _).trans $ by simp only [mem_range',
    or_and_distrib_left, or_iff_right_of_imp this, l, add_right_comm]; refl

theorem map_add_range' (a) : ∀ s n : ℕ, map ((+) a) (range' s n) = range' (a + s) n
| s 0     := rfl
| s (n+1) := congr_arg (cons _) (map_add_range' (s+1) n)

theorem map_sub_range' (a) :
  ∀ (s n : ℕ) (h : a ≤ s), map (λ x, x - a) (range' s n) = range' (s - a) n
| s 0     _ := rfl
| s (n+1) h :=
begin
  convert congr_arg (cons (s-a)) (map_sub_range' (s+1) n (nat.le_succ_of_le h)),
  rw nat.succ_sub h,
  refl,
end

theorem chain_succ_range' : ∀ s n : ℕ, chain (λ a b, b = succ a) s (range' (s+1) n)
| s 0     := chain.nil
| s (n+1) := (chain_succ_range' (s+1) n).cons rfl

theorem chain_lt_range' (s n : ℕ) : chain (<) s (range' (s+1) n) :=
(chain_succ_range' s n).imp (λ a b e, e.symm ▸ lt_succ_self _)

theorem pairwise_lt_range' : ∀ s n : ℕ, pairwise (<) (range' s n)
| s 0     := pairwise.nil
| s (n+1) := (chain_iff_pairwise (by exact λ a b c, lt_trans)).1 (chain_lt_range' s n)

theorem nodup_range' (s n : ℕ) : nodup (range' s n) :=
(pairwise_lt_range' s n).imp (λ a b, ne_of_lt)

@[simp] theorem range'_append : ∀ s m n : ℕ, range' s m ++ range' (s+m) n = range' s (n+m)
| s 0     n := rfl
| s (m+1) n := show s :: (range' (s+1) m ++ range' (s+m+1) n) = s :: range' (s+1) (n+m),
               by rw [add_right_comm, range'_append]

theorem range'_sublist_right {s m n : ℕ} : range' s m <+ range' s n ↔ m ≤ n :=
⟨λ h, by simpa only [length_range'] using length_le_of_sublist h,
 λ h, by rw [← nat.sub_add_cancel h, ← range'_append]; apply sublist_append_left⟩

theorem range'_subset_right {s m n : ℕ} : range' s m ⊆ range' s n ↔ m ≤ n :=
⟨λ h, le_of_not_lt $ λ hn, lt_irrefl (s+n) $
  (mem_range'.1 $ h $ mem_range'.2 ⟨le_add_right _ _, nat.add_lt_add_left hn s⟩).2,
 λ h, (range'_sublist_right.2 h).subset⟩

theorem nth_range' : ∀ s {m n : ℕ}, m < n → nth (range' s n) m = some (s + m)
| s 0     (n+1) _ := rfl
| s (m+1) (n+1) h := (nth_range' (s+1) (lt_of_add_lt_add_right h)).trans $
    by rw add_right_comm; refl

@[simp] lemma nth_le_range' {n m} (i) (H : i < (range' n m).length) :
  nth_le (range' n m) i H = n + i :=
option.some.inj $ by rw [←nth_le_nth _, nth_range' _ (by simpa using H)]

theorem range'_concat (s n : ℕ) : range' s (n + 1) = range' s n ++ [s+n] :=
by rw add_comm n 1; exact (range'_append s n 1).symm

theorem range_core_range' : ∀ s n : ℕ, range_core s (range' s n) = range' 0 (n + s)
| 0     n := rfl
| (s+1) n := by rw [show n+(s+1) = n+1+s, from add_right_comm n s 1];
    exact range_core_range' s (n+1)

theorem range_eq_range' (n : ℕ) : range n = range' 0 n :=
(range_core_range' n 0).trans $ by rw zero_add

theorem range_succ_eq_map (n : ℕ) : range (n + 1) = 0 :: map succ (range n) :=
by rw [range_eq_range', range_eq_range', range',
       add_comm, ← map_add_range'];
   congr; exact funext one_add

@[simp] theorem length_range (n : ℕ) : length (range n) = n :=
by simp only [range_eq_range', length_range']

@[simp] theorem range_eq_nil {n : ℕ} : range n = [] ↔ n = 0 :=
by rw [← length_eq_zero, length_range]

theorem pairwise_lt_range (n : ℕ) : pairwise (<) (range n) :=
by simp only [range_eq_range', pairwise_lt_range']

theorem nodup_range (n : ℕ) : nodup (range n) :=
by simp only [range_eq_range', nodup_range']

theorem range_sublist {m n : ℕ} : range m <+ range n ↔ m ≤ n :=
by simp only [range_eq_range', range'_sublist_right]

theorem range_subset {m n : ℕ} : range m ⊆ range n ↔ m ≤ n :=
by simp only [range_eq_range', range'_subset_right]

@[simp] theorem mem_range {m n : ℕ} : m ∈ range n ↔ m < n :=
by simp only [range_eq_range', mem_range', nat.zero_le, true_and, zero_add]

@[simp] theorem not_mem_range_self {n : ℕ} : n ∉ range n :=
mt mem_range.1 $ lt_irrefl _

@[simp] theorem self_mem_range_succ (n : ℕ) : n ∈ range (n + 1) :=
by simp only [succ_pos', lt_add_iff_pos_right, mem_range]

theorem nth_range {m n : ℕ} (h : m < n) : nth (range n) m = some m :=
by simp only [range_eq_range', nth_range' _ h, zero_add]

theorem range_succ (n : ℕ) : range (succ n) = range n ++ [n] :=
by simp only [range_eq_range', range'_concat, zero_add]

@[simp] lemma range_zero : range 0 = [] := rfl

theorem iota_eq_reverse_range' : ∀ n : ℕ, iota n = reverse (range' 1 n)
| 0     := rfl
| (n+1) := by simp only [iota, range'_concat, iota_eq_reverse_range' n,
             reverse_append, add_comm]; refl

@[simp] theorem length_iota (n : ℕ) : length (iota n) = n :=
by simp only [iota_eq_reverse_range', length_reverse, length_range']

theorem pairwise_gt_iota (n : ℕ) : pairwise (>) (iota n) :=
by simp only [iota_eq_reverse_range', pairwise_reverse, pairwise_lt_range']

theorem nodup_iota (n : ℕ) : nodup (iota n) :=
by simp only [iota_eq_reverse_range', nodup_reverse, nodup_range']

theorem mem_iota {m n : ℕ} : m ∈ iota n ↔ 1 ≤ m ∧ m ≤ n :=
by simp only [iota_eq_reverse_range', mem_reverse, mem_range', add_comm, lt_succ_iff]

theorem reverse_range' : ∀ s n : ℕ,
  reverse (range' s n) = map (λ i, s + n - 1 - i) (range n)
| s 0     := rfl
| s (n+1) := by rw [range'_concat, reverse_append, range_succ_eq_map];
  simpa only [show s + (n + 1) - 1 = s + n, from rfl, (∘),
    λ a i, show a - 1 - i = a - succ i, from pred_sub _ _,
    reverse_singleton, map_cons, nat.sub_zero, cons_append,
    nil_append, eq_self_iff_true, true_and, map_map]
  using reverse_range' s n

/-- All elements of `fin n`, from `0` to `n-1`. -/
def fin_range (n : ℕ) : list (fin n) :=
(range n).pmap fin.mk (λ _, list.mem_range.1)

@[simp] lemma fin_range_zero : fin_range 0 = [] := rfl

@[simp] lemma mem_fin_range {n : ℕ} (a : fin n) : a ∈ fin_range n :=
mem_pmap.2 ⟨a.1, mem_range.2 a.2, fin.eta _ _⟩

lemma nodup_fin_range (n : ℕ) : (fin_range n).nodup :=
nodup_pmap (λ _ _ _ _, fin.veq_of_eq) (nodup_range _)

@[simp] lemma length_fin_range (n : ℕ) : (fin_range n).length = n :=
by rw [fin_range, length_pmap, length_range]

@[simp] lemma fin_range_eq_nil {n : ℕ} : fin_range n = [] ↔ n = 0 :=
by rw [← length_eq_zero, length_fin_range]

@[to_additive]
theorem prod_range_succ {α : Type u} [monoid α] (f : ℕ → α) (n : ℕ) :
  ((range n.succ).map f).prod = ((range n).map f).prod * f n :=
by rw [range_succ, map_append, map_singleton,
  prod_append, prod_cons, prod_nil, mul_one]

/-- A variant of `prod_range_succ` which pulls off the first
  term in the product rather than the last.-/
@[to_additive "A variant of `sum_range_succ` which pulls off the first term in the sum
  rather than the last."]
theorem prod_range_succ' {α : Type u} [monoid α] (f : ℕ → α) (n : ℕ) :
  ((range n.succ).map f).prod = f 0 * ((range n).map (λ i, f (succ i))).prod :=
nat.rec_on n
  (show 1 * f 0 = f 0 * 1, by rw [one_mul, mul_one])
  (λ _ hd, by rw [list.prod_range_succ, hd, mul_assoc, ←list.prod_range_succ])

@[simp] theorem enum_from_map_fst : ∀ n (l : list α),
  map prod.fst (enum_from n l) = range' n l.length
| n []       := rfl
| n (a :: l) := congr_arg (cons _) (enum_from_map_fst _ _)

@[simp] theorem enum_map_fst (l : list α) :
  map prod.fst (enum l) = range l.length :=
by simp only [enum, enum_from_map_fst, range_eq_range']

lemma enum_eq_zip_range (l : list α) :
  l.enum = (range l.length).zip l :=
zip_of_prod (enum_map_fst _) (enum_map_snd _)

@[simp] lemma unzip_enum_eq_prod (l : list α) :
  l.enum.unzip = (range l.length, l) :=
by simp only [enum_eq_zip_range, unzip_zip, length_range]

lemma enum_from_eq_zip_range' (l : list α) {n : ℕ} :
  l.enum_from n = (range' n l.length).zip l :=
zip_of_prod (enum_from_map_fst _ _) (enum_from_map_snd _ _)

@[simp] lemma unzip_enum_from_eq_prod (l : list α) {n : ℕ} :
  (l.enum_from n).unzip = (range' n l.length, l) :=
by simp only [enum_from_eq_zip_range', unzip_zip, length_range']

@[simp] lemma nth_le_range {n} (i) (H : i < (range n).length) :
  nth_le (range n) i H = i :=
option.some.inj $ by rw [← nth_le_nth _, nth_range (by simpa using H)]

@[simp] lemma nth_le_fin_range {n : ℕ} {i : ℕ} (h) :
  (fin_range n).nth_le i h = ⟨i, length_fin_range n ▸ h⟩ :=
by simp only [fin_range, nth_le_range, nth_le_pmap, fin.mk_eq_subtype_mk]

theorem of_fn_eq_pmap {α n} {f : fin n → α} :
  of_fn f = pmap (λ i hi, f ⟨i, hi⟩) (range n) (λ _, mem_range.1) :=
by rw [pmap_eq_map_attach]; from ext_le (by simp)
  (λ i hi1 hi2, by { simp at hi1, simp [nth_le_of_fn f ⟨i, hi1⟩, -subtype.val_eq_coe] })

theorem of_fn_id (n) : of_fn id = fin_range n := of_fn_eq_pmap

theorem of_fn_eq_map {α n} {f : fin n → α} :
  of_fn f = (fin_range n).map f :=
by rw [← of_fn_id, map_of_fn, function.right_id]

theorem nodup_of_fn {α n} {f : fin n → α} (hf : function.injective f) :
  nodup (of_fn f) :=
by rw of_fn_eq_pmap; from nodup_pmap
  (λ _ _ _ _ H, fin.veq_of_eq $ hf H) (nodup_range n)

end list


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

! This file was ported from Lean 3 source module order.order_iso_nat
! leanprover-community/mathlib commit 6623e6af705e97002a9054c1c05a980180276fc1
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/

import Mathlib.Data.Nat.Lattice
import Mathlib.Logic.Denumerable
import Mathlib.Logic.Function.Iterate
import Mathlib.Order.Hom.Basic

/-!
# Relation embeddings from the naturals

This file allows translation from monotone functions `ℕ → α` to order embeddings `ℕ ↪ α` and
defines the limit value of an eventually-constant sequence.

## Main declarations

* `natLt`/`natGt`: Make an order embedding `Nat ↪ α` from
   an increasing/decreasing function `Nat → α`.
* `monotonicSequenceLimit`: The limit of an eventually-constant monotone sequence `Nat →o α`.
* `monotonicSequenceLimitIndex`: The index of the first occurence of `monotonicSequenceLimit`
  in the sequence.
-/

variable {α : Type _}

namespace RelEmbedding

variable {r : α → α → Prop} [IsStrictOrder α r]

/-- If `f` is a strictly `r`-increasing sequence, then this returns `f` as an order embedding. -/
def natLt (f : ℕ → α) (H : ∀ n : ℕ, r (f n) (f (n + 1))) : ((· < ·) : ℕ → ℕ → Prop) ↪r r :=
  ofMonotone f <| Nat.rel_of_forall_rel_succ_of_lt r H
#align rel_embedding.nat_lt RelEmbedding.natLt

@[simp]
theorem coe_natLt {f : ℕ → α} {H : ∀ n : ℕ, r (f n) (f (n + 1))} : ⇑(natLt f H) = f :=
  rfl
#align rel_embedding.coe_nat_lt RelEmbedding.coe_natLt

/-- If `f` is a strictly `r`-decreasing sequence, then this returns `f` as an order embedding. -/
def natGt (f : ℕ → α) (H : ∀ n : ℕ, r (f (n + 1)) (f n)) : ((· > ·) : ℕ → ℕ → Prop) ↪r r :=
  haveI := IsStrictOrder.swap r
  RelEmbedding.swap (natLt f H)
#align rel_embedding.nat_gt RelEmbedding.natGt

@[simp]
theorem coe_natGt {f : ℕ → α} {H : ∀ n : ℕ, r (f (n + 1)) (f n)} : ⇑(natGt f H) = f :=
  rfl
#align rel_embedding.coe_nat_gt RelEmbedding.coe_natGt

theorem exists_not_acc_lt_of_not_acc {a : α} {r} (h : ¬Acc r a) : ∃ b, ¬Acc r b ∧ r b a := by
  contrapose! h
  refine' ⟨_, fun b hr => _⟩
  by_contra hb
  exact h b hb hr
#align rel_embedding.exists_not_acc_lt_of_not_acc RelEmbedding.exists_not_acc_lt_of_not_acc

/-- A value is accessible iff it isn't contained in any infinite decreasing sequence. -/
theorem acc_iff_no_decreasing_seq {x} :
    Acc r x ↔ IsEmpty { f : ((· > ·) : ℕ → ℕ → Prop) ↪r r // x ∈ Set.range f } := by
  constructor
  · refine' fun h => h.recOn fun x _ IH => _
    constructor
    rintro ⟨f, k, hf⟩
    exact IsEmpty.elim' (IH (f (k + 1)) (hf ▸ f.map_rel_iff.2 (lt_add_one k))) ⟨f, _, rfl⟩
  · have : ∀ x : { a // ¬Acc r a }, ∃ y : { a // ¬Acc r a }, r y.1 x.1 :=
      by
      rintro ⟨x, hx⟩
      cases exists_not_acc_lt_of_not_acc hx with
      | intro w h => exact ⟨⟨w, h.1⟩, h.2⟩
    obtain ⟨f, h⟩ := Classical.axiom_of_choice this
    refine' fun E =>
      by_contradiction fun hx => E.elim' ⟨natGt (fun n => ((f^[n]) ⟨x, hx⟩).1) fun n => _, 0, rfl⟩
    simp only [Function.iterate_succ']
    apply h
#align rel_embedding.acc_iff_no_decreasing_seq RelEmbedding.acc_iff_no_decreasing_seq

theorem not_acc_of_decreasing_seq (f : ((· > ·) : ℕ → ℕ → Prop) ↪r r) (k : ℕ) : ¬Acc r (f k) := by
  rw [acc_iff_no_decreasing_seq, not_isEmpty_iff]
  exact ⟨⟨f, k, rfl⟩⟩
#align rel_embedding.not_acc_of_decreasing_seq RelEmbedding.not_acc_of_decreasing_seq

/-- A relation is well-founded iff it doesn't have any infinite decreasing sequence. -/
theorem wellFounded_iff_no_descending_seq :
    WellFounded r ↔ IsEmpty (((· > ·) : ℕ → ℕ → Prop) ↪r r) := by
  constructor
  · rintro ⟨h⟩
    exact ⟨fun f => not_acc_of_decreasing_seq f 0 (h _)⟩
  · intro h
    exact ⟨fun x => acc_iff_no_decreasing_seq.2 inferInstance⟩
#align rel_embedding.well_founded_iff_no_descending_seq RelEmbedding.wellFounded_iff_no_descending_seq

theorem not_wellFounded_of_decreasing_seq (f : ((· > ·) : ℕ → ℕ → Prop) ↪r r) : ¬WellFounded r := by
  rw [wellFounded_iff_no_descending_seq, not_isEmpty_iff]
  exact ⟨f⟩
#align rel_embedding.not_well_founded_of_decreasing_seq RelEmbedding.not_wellFounded_of_decreasing_seq

end RelEmbedding

namespace Nat

variable (s : Set ℕ) [Infinite s]

/-- An order embedding from `ℕ` to itself with a specified range -/
def orderEmbeddingOfSet [DecidablePred (· ∈ s)] : ℕ ↪o ℕ :=
  (RelEmbedding.orderEmbeddingOfLTEmbedding
    (RelEmbedding.natLt (Nat.Subtype.ofNat s) fun _ => Nat.Subtype.lt_succ_self _)).trans
    (OrderEmbedding.subtype s)
#align nat.order_embedding_of_set Nat.orderEmbeddingOfSet

/-- `Nat.Subtype.ofNat` as an order isomorphism between `ℕ` and an infinite subset. See also
`Nat.Nth` for a version where the subset may be finite. -/
noncomputable def Subtype.orderIsoOfNat : ℕ ≃o s := by
  classical
  exact
    RelIso.ofSurjective
      (RelEmbedding.orderEmbeddingOfLTEmbedding
        (RelEmbedding.natLt (Nat.Subtype.ofNat s) fun n => Nat.Subtype.lt_succ_self _))
      Nat.Subtype.ofNat_surjective
#align nat.subtype.order_iso_of_nat Nat.Subtype.orderIsoOfNat

variable {s}

@[simp]

theorem orderEmbeddingOfSet_apply [DecidablePred (· ∈ s)] {n : ℕ} :
    orderEmbeddingOfSet s n = Subtype.ofNat s n :=
  rfl
#align nat.order_embedding_of_set_apply Nat.orderEmbeddingOfSet_apply

@[simp]
theorem Subtype.orderIsoOfNat_apply [dP : DecidablePred (· ∈ s)] {n : ℕ} :
    Subtype.orderIsoOfNat s n = Subtype.ofNat s n := by
  simp [orderIsoOfNat]; congr!
#align nat.subtype.order_iso_of_nat_apply Nat.Subtype.orderIsoOfNat_apply

variable (s)

theorem orderEmbeddingOfSet_range [DecidablePred (· ∈ s)] :
    Set.range (Nat.orderEmbeddingOfSet s) = s :=
  Subtype.coe_comp_ofNat_range
#align nat.order_embedding_of_set_range Nat.orderEmbeddingOfSet_range

theorem exists_subseq_of_forall_mem_union {s t : Set α} (e : ℕ → α) (he : ∀ n, e n ∈ s ∪ t) :
    ∃ g : ℕ ↪o ℕ, (∀ n, e (g n) ∈ s) ∨ ∀ n, e (g n) ∈ t := by
  classical
    have : Infinite (e ⁻¹' s) ∨ Infinite (e ⁻¹' t) := by
      simp only [Set.infinite_coe_iff, ← Set.infinite_union, ← Set.preimage_union,
        Set.eq_univ_of_forall fun n => Set.mem_preimage.2 (he n), Set.infinite_univ]
    cases this
    exacts[⟨Nat.orderEmbeddingOfSet (e ⁻¹' s), Or.inl fun n => (Nat.Subtype.ofNat (e ⁻¹' s) _).2⟩,
      ⟨Nat.orderEmbeddingOfSet (e ⁻¹' t), Or.inr fun n => (Nat.Subtype.ofNat (e ⁻¹' t) _).2⟩]
#align nat.exists_subseq_of_forall_mem_union Nat.exists_subseq_of_forall_mem_union

end Nat

theorem exists_increasing_or_nonincreasing_subseq' (r : α → α → Prop) (f : ℕ → α) :
    ∃ g : ℕ ↪o ℕ,
      (∀ n : ℕ, r (f (g n)) (f (g (n + 1)))) ∨ ∀ m n : ℕ, m < n → ¬r (f (g m)) (f (g n)) := by
  classical
    let bad : Set ℕ := { m | ∀ n, m < n → ¬r (f m) (f n) }
    by_cases hbad : Infinite bad
    · haveI := hbad
      refine' ⟨Nat.orderEmbeddingOfSet bad, Or.intro_right _ fun m n mn => _⟩
      have h := @Set.mem_range_self _ _ ↑(Nat.orderEmbeddingOfSet bad) m
      rw [Nat.orderEmbeddingOfSet_range bad] at h
      exact h _ ((OrderEmbedding.lt_iff_lt _).2 mn)
    · rw [Set.infinite_coe_iff, Set.Infinite, not_not] at hbad
      obtain ⟨m, hm⟩ : ∃ m, ∀ n, m ≤ n → ¬n ∈ bad :=
        by
        by_cases he : hbad.toFinset.Nonempty
        ·
          refine'
            ⟨(hbad.toFinset.max' he).succ, fun n hn nbad =>
              Nat.not_succ_le_self _
                (hn.trans (hbad.toFinset.le_max' n (hbad.mem_toFinset.2 nbad)))⟩
        · exact ⟨0, fun n _ nbad => he ⟨n, hbad.mem_toFinset.2 nbad⟩⟩
      have h : ∀ n : ℕ, ∃ n' : ℕ, n < n' ∧ r (f (n + m)) (f (n' + m)) :=
        by
        intro n
        have h := hm _ (le_add_of_nonneg_left n.zero_le)
        simp only [exists_prop, not_not, Set.mem_setOf_eq, not_forall] at h
        obtain ⟨n', hn1, hn2⟩ := h
        obtain ⟨x, hpos, rfl⟩ := exists_pos_add_of_lt hn1
        refine' ⟨n + x, add_lt_add_left hpos n, _⟩
        rw [add_assoc, add_comm x m, ← add_assoc]
        exact hn2
      let g' : ℕ → ℕ := @Nat.rec (fun _ => ℕ) m fun n gn => Nat.find (h gn)
      exact
        ⟨(RelEmbedding.natLt (fun n => g' n + m) fun n =>
              Nat.add_lt_add_right (Nat.find_spec (h (g' n))).1 m).orderEmbeddingOfLTEmbedding,
          Or.intro_left _ fun n => (Nat.find_spec (h (g' n))).2⟩
#align exists_increasing_or_nonincreasing_subseq' exists_increasing_or_nonincreasing_subseq'

/-- This is the infinitary Erdős–Szekeres theorem, and an important lemma in the usual proof of
    Bolzano-Weierstrass for `ℝ`. -/
theorem exists_increasing_or_nonincreasing_subseq (r : α → α → Prop) [IsTrans α r] (f : ℕ → α) :
    ∃ g : ℕ ↪o ℕ,
      (∀ m n : ℕ, m < n → r (f (g m)) (f (g n))) ∨ ∀ m n : ℕ, m < n → ¬r (f (g m)) (f (g n)) := by
  obtain ⟨g, hr | hnr⟩ := exists_increasing_or_nonincreasing_subseq' r f
  · refine' ⟨g, Or.intro_left _ fun m n mn => _⟩
    obtain ⟨x, rfl⟩ := exists_add_of_le (Nat.succ_le_iff.2 mn)
    induction' x with x ih
    · apply hr
    · apply IsTrans.trans _ _ _ _ (hr _)
      exact ih (lt_of_lt_of_le m.lt_succ_self (Nat.le_add_right _ _))
  · exact ⟨g, Or.intro_right _ hnr⟩
#align exists_increasing_or_nonincreasing_subseq exists_increasing_or_nonincreasing_subseq

theorem WellFounded.monotone_chain_condition' [Preorder α] :
    WellFounded ((· > ·) : α → α → Prop) ↔ ∀ a : ℕ →o α, ∃ n, ∀ m, n ≤ m → ¬a n < a m := by
  refine' ⟨fun h a => _, fun h => _⟩
  · have hne : (Set.range a).Nonempty := ⟨a 0, by simp⟩
    obtain ⟨x, ⟨n, rfl⟩, H⟩ := h.has_min _ hne
    exact ⟨n, fun m _ => H _ (Set.mem_range_self _)⟩
  · refine' RelEmbedding.wellFounded_iff_no_descending_seq.2 ⟨fun a => _⟩
    obtain ⟨n, hn⟩ := h (a.swap : ((· < ·) : ℕ → ℕ → Prop) →r ((· < ·) : α → α → Prop)).toOrderHom
    exact hn n.succ n.lt_succ_self.le ((RelEmbedding.map_rel_iff _).2 n.lt_succ_self)
#align well_founded.monotone_chain_condition' WellFounded.monotone_chain_condition'

/-- The "monotone chain condition" below is sometimes a convenient form of well foundedness. -/
theorem WellFounded.monotone_chain_condition [PartialOrder α] :
    WellFounded ((· > ·) : α → α → Prop) ↔ ∀ a : ℕ →o α, ∃ n, ∀ m, n ≤ m → a n = a m :=
  WellFounded.monotone_chain_condition'.trans <| by
  -- porting note: was congrm ∀ a, ∃ n, ∀ m (h : n ≤ m), (_ : Prop)
  congr! 4
  rename_i a n m
  simp (config := {contextual := true}) [lt_iff_le_and_ne, fun h => a.mono h]
#align well_founded.monotone_chain_condition WellFounded.monotone_chain_condition

/-- Given an eventually-constant monotone sequence `a₀ ≤ a₁ ≤ a₂ ≤ ...` in a partially-ordered
type, `monotonicSequenceLimitIndex a` is the least natural number `n` for which `aₙ` reaches the
constant value. For sequences that are not eventually constant, `monotonicSequenceLimitIndex a`
is defined, but is a junk value. -/
noncomputable def monotonicSequenceLimitIndex [Preorder α] (a : ℕ →o α) : ℕ :=
  infₛ { n | ∀ m, n ≤ m → a n = a m }
#align monotonic_sequence_limit_index monotonicSequenceLimitIndex

/-- The constant value of an eventually-constant monotone sequence `a₀ ≤ a₁ ≤ a₂ ≤ ...` in a
partially-ordered type. -/
noncomputable def monotonicSequenceLimit [Preorder α] (a : ℕ →o α) :=
  a (monotonicSequenceLimitIndex a)
#align monotonic_sequence_limit monotonicSequenceLimit

theorem WellFounded.supᵢ_eq_monotonicSequenceLimit [CompleteLattice α]
    (h : WellFounded ((· > ·) : α → α → Prop)) (a : ℕ →o α) : supᵢ a = monotonicSequenceLimit a :=
  by
  suffices (⨆ m : ℕ, a m) ≤ monotonicSequenceLimit a by exact le_antisymm this (le_supᵢ a _)
  apply supᵢ_le
  intro m
  by_cases hm : m ≤ monotonicSequenceLimitIndex a
  · exact a.monotone hm
  · replace hm := le_of_not_le hm
    let S := { n | ∀ m, n ≤ m → a n = a m }
    have hInf : infₛ S ∈ S := by
      refine' Nat.infₛ_mem _
      rw [WellFounded.monotone_chain_condition] at h
      exact h a
    change a m ≤ a (infₛ S)
    rw [hInf m hm]
#align well_founded.supr_eq_monotonic_sequence_limit WellFounded.supᵢ_eq_monotonicSequenceLimit


-- http://page.mi.fu-berlin.de/cbenzmueller/papers/C44.pdf

namespace main
  -- α is type of individuals, β is type of worlds
  variables (i u : Type)

  -- accessibility relation
  variable (r : i → i → Prop)

  -- type of modal propositions
  constant o : i → Prop

  -- modal connectives
  /-
  def mnot (p : o) (w : i) : Prop := p w
  def mand (p q : o) (w : i) : Prop := p w ∧ q w
  def mor (p q : o) (w : i) : Prop := p w ∨ q w
  def mimplies (p q : o) (w : i) : Prop : (p w) → (q w)
  def mimplies (p q : o) (w : i) : Prop : (p w) ↔ (q w)
  def mequal (x y : u) (w : i) : Prop : x = y
  -/

  -- modal quantifiers
  -- def A
  -- def E

  -- modal operators
  -- def box
  -- def diamond

  -- validity
  -- def V

  -- tactics
  -- box_i - introduce box - from p infer box p
  -- box_elim - eliminate box - from box p infer p
  -- dia_e - eliminate diamond
  -- dia_i - reduces diam p to p and enforce that world is reachable
  -- mv - modal validity - replaces goal V p with a goal of form (p w)

  -- lemmas
  -- theorem mp_dia - modus ponens with modal operators
  -- theorem not_dia_box_not - push negations inside modalities

  -- working with K
  -- theorem K
  -- axiom reflexivity
  -- axiom symmetry
  -- axiom transitivity
  -- theorem T
  -- theorem collapse (in S5, dia dia box p to box p)
end main


/-
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

! This file was ported from Lean 3 source module data.pfunctor.multivariate.W
! 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.Data.PFunctor.Multivariate.Basic

/-!
# The W construction as a multivariate polynomial functor.

W types are well-founded tree-like structures. They are defined
as the least fixpoint of a polynomial functor.

## Main definitions

 * `W_mk`     - constructor
 * `W_dest    - destructor
 * `W_rec`    - recursor: basis for defining functions by structural recursion on `P.W α`
 * `W_rec_eq` - defining equation for `W_rec`
 * `W_ind`    - induction principle for `P.W α`

## Implementation notes

Three views of M-types:

 * `wp`: polynomial functor
 * `W`: data type inductively defined by a triple:
     shape of the root, data in the root and children of the root
 * `W`: least fixed point of a polynomial functor

Specifically, we define the polynomial functor `wp` as:

 * A := a tree-like structure without information in the nodes
 * B := given the tree-like structure `t`, `B t` is a valid path
   (specified inductively by `W_path`) from the root of `t` to any given node.

As a result `wp.Obj α` is made of a dataless tree and a function from
its valid paths to values of `α`

## Reference

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

universe u v

namespace MvPFunctor

open TypeVec

open MvFunctor

variable {n : ℕ} (P : MvPFunctor.{u} (n + 1))

/-- A path from the root of a tree to one of its node -/
inductive WPath : P.last.W → Fin2 n → Type u
  | root (a : P.A) (f : P.last.B a → P.last.W) (i : Fin2 n) (c : P.drop.B a i) : WPath ⟨a, f⟩ i
  | child (a : P.A) (f : P.last.B a → P.last.W) (i : Fin2 n) (j : P.last.B a)
    (c : WPath (f j) i) : WPath ⟨a, f⟩ i
set_option linter.uppercaseLean3 false in
#align mvpfunctor.W_path MvPFunctor.WPath

instance WPath.inhabited (x : P.last.W) {i} [I : Inhabited (P.drop.B x.head i)] :
    Inhabited (WPath P x i) :=
  ⟨match x, I with
    | ⟨a, f⟩, I => WPath.root a f i (@default _ I)⟩
set_option linter.uppercaseLean3 false in
#align mvpfunctor.W_path.inhabited MvPFunctor.WPath.inhabited

/-- Specialized destructor on `WPath` -/
def wPathCasesOn {α : TypeVec n} {a : P.A} {f : P.last.B a → P.last.W} (g' : P.drop.B a ⟹ α)
    (g : ∀ j : P.last.B a, P.WPath (f j) ⟹ α) : P.WPath ⟨a, f⟩ ⟹ α := by
  intro i x;
  match x with
  | WPath.root _ _ i c => exact g' i c
  | WPath.child _ _ i j c => exact g j i c
set_option linter.uppercaseLean3 false in
#align mvpfunctor.W_path_cases_on MvPFunctor.wPathCasesOn

/-- Specialized destructor on `WPath` -/
def wPathDestLeft {α : TypeVec n} {a : P.A} {f : P.last.B a → P.last.W}
    (h : P.WPath ⟨a, f⟩ ⟹ α) : P.drop.B a ⟹ α := fun i c => h i (WPath.root a f i c)
set_option linter.uppercaseLean3 false in
#align mvpfunctor.W_path_dest_left MvPFunctor.wPathDestLeft

/-- Specialized destructor on `WPath` -/
def wPathDestRight {α : TypeVec n} {a : P.A} {f : P.last.B a → P.last.W}
    (h : P.WPath ⟨a, f⟩ ⟹ α) : ∀ j : P.last.B a, P.WPath (f j) ⟹ α := fun j i c =>
  h i (WPath.child a f i j c)
set_option linter.uppercaseLean3 false in
#align mvpfunctor.W_path_dest_right MvPFunctor.wPathDestRight

theorem wPathDestLeft_wPathCasesOn {α : TypeVec n} {a : P.A} {f : P.last.B a → P.last.W}
    (g' : P.drop.B a ⟹ α) (g : ∀ j : P.last.B a, P.WPath (f j) ⟹ α) :
    P.wPathDestLeft (P.wPathCasesOn g' g) = g' := rfl
set_option linter.uppercaseLean3 false in
#align mvpfunctor.W_path_dest_left_W_path_cases_on MvPFunctor.wPathDestLeft_wPathCasesOn

theorem wPathDestRight_wPathCasesOn {α : TypeVec n} {a : P.A} {f : P.last.B a → P.last.W}
    (g' : P.drop.B a ⟹ α) (g : ∀ j : P.last.B a, P.WPath (f j) ⟹ α) :
    P.wPathDestRight (P.wPathCasesOn g' g) = g := rfl
set_option linter.uppercaseLean3 false in
#align mvpfunctor.W_path_dest_right_W_path_cases_on MvPFunctor.wPathDestRight_wPathCasesOn

theorem wPathCasesOn_eta {α : TypeVec n} {a : P.A} {f : P.last.B a → P.last.W}
    (h : P.WPath ⟨a, f⟩ ⟹ α) : P.wPathCasesOn (P.wPathDestLeft h) (P.wPathDestRight h) = h := by
  ext (i x) ; cases x <;> rfl
set_option linter.uppercaseLean3 false in
#align mvpfunctor.W_path_cases_on_eta MvPFunctor.wPathCasesOn_eta

theorem comp_wPathCasesOn {α β : TypeVec n} (h : α ⟹ β) {a : P.A} {f : P.last.B a → P.last.W}
    (g' : P.drop.B a ⟹ α) (g : ∀ j : P.last.B a, P.WPath (f j) ⟹ α) :
    h ⊚ P.wPathCasesOn g' g = P.wPathCasesOn (h ⊚ g') fun i => h ⊚ g i := by
  ext (i x) ; cases x <;> rfl
set_option linter.uppercaseLean3 false in
#align mvpfunctor.comp_W_path_cases_on MvPFunctor.comp_wPathCasesOn

/-- Polynomial functor for the W-type of `P`. `A` is a data-less well-founded
tree whereas, for a given `a : A`, `B a` is a valid path in tree `a` so
that `Wp.obj α` is made of a tree and a function from its valid paths to
the values it contains  -/
def wp : MvPFunctor n where
  A := P.last.W
  B := P.WPath
set_option linter.uppercaseLean3 false in
#align mvpfunctor.Wp MvPFunctor.wp

/-- W-type of `P` -/
-- Porting note: used to have @[nolint has_nonempty_instance]
def W (α : TypeVec n) : Type _ :=
  P.wp.Obj α
set_option linter.uppercaseLean3 false in
#align mvpfunctor.W MvPFunctor.W

instance mvfunctorW : MvFunctor P.W := by delta MvPFunctor.W ; infer_instance
set_option linter.uppercaseLean3 false in
#align mvpfunctor.mvfunctor_W MvPFunctor.mvfunctorW

/-!
First, describe operations on `W` as a polynomial functor.
-/

/-- Constructor for `wp` -/
def wpMk {α : TypeVec n} (a : P.A) (f : P.last.B a → P.last.W) (f' : P.WPath ⟨a, f⟩ ⟹ α) :
    P.W α :=
  ⟨⟨a, f⟩, f'⟩
set_option linter.uppercaseLean3 false in
#align mvpfunctor.Wp_mk MvPFunctor.wpMk

def wpRec {α : TypeVec n} {C : Type _}
    (g : ∀ (a : P.A) (f : P.last.B a → P.last.W), P.WPath ⟨a, f⟩ ⟹ α → (P.last.B a → C) → C) :
    ∀ (x : P.last.W) (_ : P.WPath x ⟹ α), C
  | ⟨a, f⟩, f' => g a f f' fun i => wpRec g (f i) (P.wPathDestRight f' i)
set_option linter.uppercaseLean3 false in
#align mvpfunctor.Wp_rec MvPFunctor.wpRec

theorem wpRec_eq {α : TypeVec n} {C : Type _}
    (g : ∀ (a : P.A) (f : P.last.B a → P.last.W), P.WPath ⟨a, f⟩ ⟹ α → (P.last.B a → C) → C)
    (a : P.A) (f : P.last.B a → P.last.W) (f' : P.WPath ⟨a, f⟩ ⟹ α) :
    P.wpRec g ⟨a, f⟩ f' = g a f f' fun i => P.wpRec g (f i) (P.wPathDestRight f' i) := rfl
set_option linter.uppercaseLean3 false in
#align mvpfunctor.Wp_rec_eq MvPFunctor.wpRec_eq

-- Note: we could replace Prop by Type _ and obtain a dependent recursor
theorem wp_ind {α : TypeVec n} {C : ∀ x : P.last.W, P.WPath x ⟹ α → Prop}
    (ih : ∀ (a : P.A) (f : P.last.B a → P.last.W) (f' : P.WPath ⟨a, f⟩ ⟹ α),
        (∀ i : P.last.B a, C (f i) (P.wPathDestRight f' i)) → C ⟨a, f⟩ f') :
    ∀ (x : P.last.W) (f' : P.WPath x ⟹ α), C x f'
  | ⟨a, f⟩, f' => ih a f f' fun _i => wp_ind ih _ _
set_option linter.uppercaseLean3 false in
#align mvpfunctor.Wp_ind MvPFunctor.wp_ind

/-!
Now think of W as defined inductively by the data ⟨a, f', f⟩ where
- `a  : P.A` is the shape of the top node
- `f' : P.drop.B a ⟹ α` is the contents of the top node
- `f  : P.last.B a → P.last.W` are the subtrees
 -/

/-- Constructor for `W` -/
def wMk {α : TypeVec n} (a : P.A) (f' : P.drop.B a ⟹ α) (f : P.last.B a → P.W α) : P.W α :=
  let g : P.last.B a → P.last.W := fun i => (f i).fst
  let g' : P.WPath ⟨a, g⟩ ⟹ α := P.wPathCasesOn f' fun i => (f i).snd
  ⟨⟨a, g⟩, g'⟩
set_option linter.uppercaseLean3 false in
#align mvpfunctor.W_mk MvPFunctor.wMk

/-- Recursor for `W` -/
def wRec {α : TypeVec n} {C : Type _}
    (g : ∀ a : P.A, P.drop.B a ⟹ α → (P.last.B a → P.W α) → (P.last.B a → C) → C) : P.W α → C
  | ⟨a, f'⟩ =>
    let g' (a : P.A) (f : P.last.B a → P.last.W) (h : P.WPath ⟨a, f⟩ ⟹ α)
      (h' : P.last.B a → C) : C :=
      g a (P.wPathDestLeft h) (fun i => ⟨f i, P.wPathDestRight h i⟩) h'
    P.wpRec g' a f'
set_option linter.uppercaseLean3 false in
#align mvpfunctor.W_rec MvPFunctor.wRec

/-- Defining equation for the recursor of `W` -/
theorem wRec_eq {α : TypeVec n} {C : Type _}
    (g : ∀ a : P.A, P.drop.B a ⟹ α → (P.last.B a → P.W α) → (P.last.B a → C) → C) (a : P.A)
    (f' : P.drop.B a ⟹ α) (f : P.last.B a → P.W α) :
    P.wRec g (P.wMk a f' f) = g a f' f fun i => P.wRec g (f i) := by
  rw [wMk, wRec]; dsimp; rw [wpRec_eq]
  dsimp only [wPathDestLeft_wPathCasesOn, wPathDestRight_wPathCasesOn]
  congr
set_option linter.uppercaseLean3 false in
#align mvpfunctor.W_rec_eq MvPFunctor.wRec_eq

/-- Induction principle for `W` -/
theorem w_ind {α : TypeVec n} {C : P.W α → Prop}
    (ih : ∀ (a : P.A) (f' : P.drop.B a ⟹ α) (f : P.last.B a → P.W α),
        (∀ i, C (f i)) → C (P.wMk a f' f)) :
    ∀ x, C x := by
  intro x; cases' x with a f
  apply @wp_ind n P α fun a f => C ⟨a, f⟩; dsimp
  intro a f f' ih'
  dsimp [wMk] at ih
  let ih'' := ih a (P.wPathDestLeft f') fun i => ⟨f i, P.wPathDestRight f' i⟩
  dsimp at ih''; rw [wPathCasesOn_eta] at ih''
  apply ih''
  apply ih'
set_option linter.uppercaseLean3 false in
#align mvpfunctor.W_ind MvPFunctor.w_ind

theorem w_cases {α : TypeVec n} {C : P.W α → Prop}
    (ih : ∀ (a : P.A) (f' : P.drop.B a ⟹ α) (f : P.last.B a → P.W α), C (P.wMk a f' f)) :
    ∀ x, C x := P.w_ind fun a f' f _ih' => ih a f' f
set_option linter.uppercaseLean3 false in
#align mvpfunctor.W_cases MvPFunctor.w_cases

/-- W-types are functorial -/
def wMap {α β : TypeVec n} (g : α ⟹ β) : P.W α → P.W β := fun x => g <$$> x
set_option linter.uppercaseLean3 false in
#align mvpfunctor.W_map MvPFunctor.wMap

theorem wMk_eq {α : TypeVec n} (a : P.A) (f : P.last.B a → P.last.W) (g' : P.drop.B a ⟹ α)
    (g : ∀ j : P.last.B a, P.WPath (f j) ⟹ α) :
    (P.wMk a g' fun i => ⟨f i, g i⟩) = ⟨⟨a, f⟩, P.wPathCasesOn g' g⟩ := rfl
set_option linter.uppercaseLean3 false in
#align mvpfunctor.W_mk_eq MvPFunctor.wMk_eq

theorem w_map_wMk {α β : TypeVec n} (g : α ⟹ β) (a : P.A) (f' : P.drop.B a ⟹ α)
    (f : P.last.B a → P.W α) : g <$$> P.wMk a f' f = P.wMk a (g ⊚ f') fun i => g <$$> f i := by
  show _ = P.wMk a (g ⊚ f') (MvFunctor.map g ∘ f)
  have : MvFunctor.map g ∘ f = fun i => ⟨(f i).fst, g ⊚ (f i).snd⟩ := by
    ext i : 1
    dsimp [Function.comp]
    cases f i
    rfl
  rw [this]
  have : f = fun i => ⟨(f i).fst, (f i).snd⟩ := by
    ext1 x
    cases f x
    rfl
  rw [this]
  dsimp
  rw [wMk_eq, wMk_eq]
  have h := MvPFunctor.map_eq P.wp g
  rw [h, comp_wPathCasesOn]
set_option linter.uppercaseLean3 false in
#align mvpfunctor.W_map_W_mk MvPFunctor.w_map_wMk

-- TODO: this technical theorem is used in one place in constructing the initial algebra.
-- Can it be avoided?
/-- Constructor of a value of `P.obj (α ::: β)` from components.
Useful to avoid complicated type annotation -/
@[reducible]
def objAppend1 {α : TypeVec n} {β : Type _} (a : P.A) (f' : P.drop.B a ⟹ α)
    (f : P.last.B a → β) : P.Obj (α ::: β) :=
  ⟨a, splitFun f' f⟩
#align mvpfunctor.obj_append1 MvPFunctor.objAppend1

theorem map_objAppend1 {α γ : TypeVec n} (g : α ⟹ γ) (a : P.A) (f' : P.drop.B a ⟹ α)
    (f : P.last.B a → P.W α) :
    appendFun g (P.wMap g) <$$> P.objAppend1 a f' f =
      P.objAppend1 a (g ⊚ f') fun x => P.wMap g (f x) :=
  by rw [objAppend1, objAppend1, map_eq, appendFun, ← splitFun_comp] ; rfl
#align mvpfunctor.map_obj_append1 MvPFunctor.map_objAppend1

/-!
Yet another view of the W type: as a fixed point for a multivariate polynomial functor.
These are needed to use the W-construction to construct a fixed point of a qpf, since
the qpf axioms are expressed in terms of `map` on `P`.
-/

/-- Constructor for the W-type of `P` -/
def wMk' {α : TypeVec n} : P.Obj (α ::: P.W α) → P.W α
  | ⟨a, f⟩ => P.wMk a (dropFun f) (lastFun f)
set_option linter.uppercaseLean3 false in
#align mvpfunctor.W_mk' MvPFunctor.wMk'

/-- Destructor for the W-type of `P` -/
def wDest' {α : TypeVec.{u} n} : P.W α → P.Obj (α.append1 (P.W α)) :=
  P.wRec fun a f' f _ => ⟨a, splitFun f' f⟩
set_option linter.uppercaseLean3 false in
#align mvpfunctor.W_dest' MvPFunctor.wDest'

theorem wDest'_wMk {α : TypeVec n} (a : P.A) (f' : P.drop.B a ⟹ α) (f : P.last.B a → P.W α) :
    P.wDest' (P.wMk a f' f) = ⟨a, splitFun f' f⟩ := by rw [wDest', wRec_eq]
set_option linter.uppercaseLean3 false in
#align mvpfunctor.W_dest'_W_mk MvPFunctor.wDest'_wMk

theorem wDest'_wMk' {α : TypeVec n} (x : P.Obj (α.append1 (P.W α))) : P.wDest' (P.wMk' x) = x := by
  cases' x with a f ; rw [wMk', wDest'_wMk, split_dropFun_lastFun]
set_option linter.uppercaseLean3 false in
#align mvpfunctor.W_dest'_W_mk' MvPFunctor.wDest'_wMk'

end MvPFunctor