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

! This file was ported from Lean 3 source module data.pfunctor.univariate.M
! leanprover-community/mathlib commit 8631e2d5ea77f6c13054d9151d82b83069680cb1
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Data.PFunctor.Univariate.Basic

/-!
# M-types

M types are potentially infinite tree-like structures. They are defined
as the greatest fixpoint of a polynomial functor.
-/

universe u v w

open Nat Function

open List

variable (F : PFunctor.{u})

-- porting note: the ♯ tactic is never used
-- local prefix:0 "♯" => cast (by first |simp [*]|cc|solve_by_elim)

namespace PFunctor

namespace Approx

/-- `CofixA F n` is an `n` level approximation of an M-type -/
inductive CofixA : ℕ → Type u
  | continue : CofixA 0
  | intro {n} : ∀ a, (F.B a → CofixA n) → CofixA (succ n)
#align pfunctor.approx.cofix_a PFunctor.Approx.CofixA

/-- default inhabitant of `CofixA` -/
protected def CofixA.default [Inhabited F.A] : ∀ n, CofixA F n
  | 0 => CofixA.continue
  | succ n => CofixA.intro default fun _ => CofixA.default n
#align pfunctor.approx.cofix_a.default PFunctor.Approx.CofixA.default

instance [Inhabited F.A] {n} : Inhabited (CofixA F n) :=
  ⟨CofixA.default F n⟩

theorem cofixA_eq_zero : ∀ x y : CofixA F 0, x = y
  | CofixA.continue, CofixA.continue => rfl
#align pfunctor.approx.cofix_a_eq_zero PFunctor.Approx.cofixA_eq_zero

variable {F}

/-- The label of the root of the tree for a non-trivial
approximation of the cofix of a pfunctor.
-/
def head' : ∀ {n}, CofixA F (succ n) → F.A
  | _, CofixA.intro i _ => i
#align pfunctor.approx.head' PFunctor.Approx.head'

/-- for a non-trivial approximation, return all the subtrees of the root -/
def children' : ∀ {n} (x : CofixA F (succ n)), F.B (head' x) → CofixA F n
  | _, CofixA.intro _ f => f
#align pfunctor.approx.children' PFunctor.Approx.children'

theorem approx_eta {n : ℕ} (x : CofixA F (n + 1)) : x = CofixA.intro (head' x) (children' x) := by
  cases x; rfl
#align pfunctor.approx.approx_eta PFunctor.Approx.approx_eta

/-- Relation between two approximations of the cofix of a pfunctor
that state they both contain the same data until one of them is truncated -/
inductive Agree : ∀ {n : ℕ}, CofixA F n → CofixA F (n + 1) → Prop
  | continu (x : CofixA F 0) (y : CofixA F 1) : Agree x y
  | intro {n} {a} (x : F.B a → CofixA F n) (x' : F.B a → CofixA F (n + 1)) :
    (∀ i : F.B a, Agree (x i) (x' i)) → Agree (CofixA.intro a x) (CofixA.intro a x')
#align pfunctor.approx.agree PFunctor.Approx.Agree

/-- Given an infinite series of approximations `approx`,
`AllAgree approx` states that they are all consistent with each other.
-/
def AllAgree (x : ∀ n, CofixA F n) :=
  ∀ n, Agree (x n) (x (succ n))
#align pfunctor.approx.all_agree PFunctor.Approx.AllAgree

@[simp]
theorem agree_trival {x : CofixA F 0} {y : CofixA F 1} : Agree x y := by constructor
#align pfunctor.approx.agree_trival PFunctor.Approx.agree_trival

theorem agree_children {n : ℕ} (x : CofixA F (succ n)) (y : CofixA F (succ n + 1)) {i j}
    (h₀ : HEq i j) (h₁ : Agree x y) : Agree (children' x i) (children' y j) := by
  cases' h₁ with _ _ _ _ _ _ hagree; cases h₀
  apply hagree
#align pfunctor.approx.agree_children PFunctor.Approx.agree_children

/-- `truncate a` turns `a` into a more limited approximation -/
def truncate : ∀ {n : ℕ}, CofixA F (n + 1) → CofixA F n
  | 0, CofixA.intro _ _ => CofixA.continue
  | succ _, CofixA.intro i f => CofixA.intro i <| truncate ∘ f
#align pfunctor.approx.truncate PFunctor.Approx.truncate

theorem truncate_eq_of_agree {n : ℕ} (x : CofixA F n) (y : CofixA F (succ n)) (h : Agree x y) :
    truncate y = x := by
  induction n <;> cases x <;> cases y
  · rfl
  · -- cases' h with _ _ _ _ _ h₀ h₁
    cases h
    simp only [truncate, Function.comp, true_and_iff, eq_self_iff_true, heq_iff_eq]
    -- porting note: used to be `ext y`
    rename_i n_ih a f y h₁
    suffices (fun x => truncate (y x)) = f
      by simp [this]; try (exact HEq.rfl;)
    funext y

    apply n_ih
    apply h₁
#align pfunctor.approx.truncate_eq_of_agree PFunctor.Approx.truncate_eq_of_agree

variable {X : Type w}

variable (f : X → F.Obj X)

/-- `sCorec f i n` creates an approximation of height `n`
of the final coalgebra of `f` -/
def sCorec : X → ∀ n, CofixA F n
  | _, 0 => CofixA.continue
  | j, succ _ => CofixA.intro (f j).1 fun i => sCorec ((f j).2 i) _
#align pfunctor.approx.s_corec PFunctor.Approx.sCorec

theorem P_corec (i : X) (n : ℕ) : Agree (sCorec f i n) (sCorec f i (succ n)) := by
  induction' n with n n_ih generalizing i
  constructor
  cases' h : f i with y g
  constructor
  introv
  apply n_ih
set_option linter.uppercaseLean3 false in
#align pfunctor.approx.P_corec PFunctor.Approx.P_corec

/-- `Path F` provides indices to access internal nodes in `Corec F` -/
def Path (F : PFunctor.{u}) :=
  List F.IdxCat
#align pfunctor.approx.path PFunctor.Approx.Path

instance Path.inhabited : Inhabited (Path F) :=
  ⟨[]⟩
#align pfunctor.approx.path.inhabited PFunctor.Approx.Path.inhabited

open List Nat

instance CofixA.instSubsingleton : Subsingleton (CofixA F 0) :=
  ⟨by rintro ⟨⟩ ⟨⟩; rfl⟩

theorem head_succ' (n m : ℕ) (x : ∀ n, CofixA F n) (Hconsistent : AllAgree x) :
    head' (x (succ n)) = head' (x (succ m)) := by
  suffices ∀ n, head' (x (succ n)) = head' (x 1) by simp [this]
  clear m n
  intro n
  cases' h₀ : x (succ n) with _ i₀ f₀
  cases' h₁ : x 1 with _ i₁ f₁
  dsimp only [head']
  induction' n with n n_ih
  · rw [h₁] at h₀
    cases h₀
    trivial
  · have H := Hconsistent (succ n)
    cases' h₂ : x (succ n) with _ i₂ f₂
    rw [h₀, h₂] at H
    apply n_ih (truncate ∘ f₀)
    rw [h₂]
    cases' H with _ _ _ _ _ _ hagree
    congr
    funext j
    dsimp only [comp_apply]
    rw [truncate_eq_of_agree]
    apply hagree
#align pfunctor.approx.head_succ' PFunctor.Approx.head_succ'

end Approx

open Approx

/-- Internal definition for `M`. It is needed to avoid name clashes
between `M.mk` and `M.cases_on` and the declarations generated for
the structure -/
structure MIntl where
  /-- An `n`-th level approximation, for each depth `n` -/
  approx : ∀ n, CofixA F n
  /-- Each approximation agrees with the next -/
  consistent : AllAgree approx
set_option linter.uppercaseLean3 false in
#align pfunctor.M_intl PFunctor.MIntl

/-- For polynomial functor `F`, `M F` is its final coalgebra -/
def M :=
  MIntl F
set_option linter.uppercaseLean3 false in
#align pfunctor.M PFunctor.M

theorem M.default_consistent [Inhabited F.A] : ∀ n, Agree (default : CofixA F n) default
  | 0 => Agree.continu _ _
  | succ n => Agree.intro _ _ fun _ => M.default_consistent n
set_option linter.uppercaseLean3 false in
#align pfunctor.M.default_consistent PFunctor.M.default_consistent

instance M.inhabited [Inhabited F.A] : Inhabited (M F) :=
  ⟨{  approx := default
      consistent := M.default_consistent _ }⟩
set_option linter.uppercaseLean3 false in
#align pfunctor.M.inhabited PFunctor.M.inhabited

instance MIntl.inhabited [Inhabited F.A] : Inhabited (MIntl F) :=
  show Inhabited (M F) by infer_instance
set_option linter.uppercaseLean3 false in
#align pfunctor.M_intl.inhabited PFunctor.MIntl.inhabited

namespace M

theorem ext' (x y : M F) (H : ∀ i : ℕ, x.approx i = y.approx i) : x = y := by
  cases x
  cases y
  congr with n
  apply H
set_option linter.uppercaseLean3 false in
#align pfunctor.M.ext' PFunctor.M.ext'

variable {X : Type _}

variable (f : X → F.Obj X)

variable {F}

/-- Corecursor for the M-type defined by `F`. -/
protected def corec (i : X) : M F where
  approx := sCorec f i
  consistent := P_corec _ _
set_option linter.uppercaseLean3 false in
#align pfunctor.M.corec PFunctor.M.corec

/-- given a tree generated by `F`, `head` gives us the first piece of data
it contains -/
def head (x : M F) :=
  head' (x.1 1)
set_option linter.uppercaseLean3 false in
#align pfunctor.M.head PFunctor.M.head

/-- return all the subtrees of the root of a tree `x : M F` -/
def children (x : M F) (i : F.B (head x)) : M F :=
  let H := fun n : ℕ => @head_succ' _ n 0 x.1 x.2
  { approx := fun n => children' (x.1 _) (cast (congr_arg _ <| by simp only [head, H]) i)
    consistent := by
      intro n
      have P' := x.2 (succ n)
      apply agree_children _ _ _ P'
      trans i
      apply cast_heq
      symm
      apply cast_heq }
set_option linter.uppercaseLean3 false in
#align pfunctor.M.children PFunctor.M.children

/-- select a subtree using a `i : F.Idx` or return an arbitrary tree if
`i` designates no subtree of `x` -/
def ichildren [Inhabited (M F)] [DecidableEq F.A] (i : F.IdxCat) (x : M F) : M F :=
  if H' : i.1 = head x then children x (cast (congr_arg _ <| by simp only [head, H']) i.2)
  else default
set_option linter.uppercaseLean3 false in
#align pfunctor.M.ichildren PFunctor.M.ichildren

theorem head_succ (n m : ℕ) (x : M F) : head' (x.approx (succ n)) = head' (x.approx (succ m)) :=
  head_succ' n m _ x.consistent
set_option linter.uppercaseLean3 false in
#align pfunctor.M.head_succ PFunctor.M.head_succ

theorem head_eq_head' : ∀ (x : M F) (n : ℕ), head x = head' (x.approx <| n + 1)
  | ⟨_, h⟩, _ => head_succ' _ _ _ h
set_option linter.uppercaseLean3 false in
#align pfunctor.M.head_eq_head' PFunctor.M.head_eq_head'

theorem head'_eq_head : ∀ (x : M F) (n : ℕ), head' (x.approx <| n + 1) = head x
  | ⟨_, h⟩, _ => head_succ' _ _ _ h
set_option linter.uppercaseLean3 false in
#align pfunctor.M.head'_eq_head PFunctor.M.head'_eq_head

theorem truncate_approx (x : M F) (n : ℕ) : truncate (x.approx <| n + 1) = x.approx n :=
  truncate_eq_of_agree _ _ (x.consistent _)
set_option linter.uppercaseLean3 false in
#align pfunctor.M.truncate_approx PFunctor.M.truncate_approx

/-- unfold an M-type -/
def dest : M F → F.Obj (M F)
  | x => ⟨head x, fun i => children x i⟩
set_option linter.uppercaseLean3 false in
#align pfunctor.M.dest PFunctor.M.dest

namespace Approx

/-- generates the approximations needed for `M.mk` -/
protected def sMk (x : F.Obj <| M F) : ∀ n, CofixA F n
  | 0 => CofixA.continue
  | succ n => CofixA.intro x.1 fun i => (x.2 i).approx n
set_option linter.uppercaseLean3 false in
#align pfunctor.M.approx.s_mk PFunctor.M.Approx.sMk

protected theorem P_mk (x : F.Obj <| M F) : AllAgree (Approx.sMk x)
  | 0 => by constructor
  | succ n => by
    constructor
    introv
    apply (x.2 i).consistent
set_option linter.uppercaseLean3 false in
#align pfunctor.M.approx.P_mk PFunctor.M.Approx.P_mk

end Approx

/-- constructor for M-types -/
protected def mk (x : F.Obj <| M F) : M F
    where
  approx := Approx.sMk x
  consistent := Approx.P_mk x
set_option linter.uppercaseLean3 false in
#align pfunctor.M.mk PFunctor.M.mk

/-- `Agree' n` relates two trees of type `M F` that
are the same up to dept `n` -/
inductive Agree' : ℕ → M F → M F → Prop
  | trivial (x y : M F) : Agree' 0 x y
  | step {n : ℕ} {a} (x y : F.B a → M F) {x' y'} :
      x' = M.mk ⟨a, x⟩ → y' = M.mk ⟨a, y⟩ → (∀ i, Agree' n (x i) (y i)) → Agree' (succ n) x' y'
set_option linter.uppercaseLean3 false in
#align pfunctor.M.agree' PFunctor.M.Agree'

@[simp]
theorem dest_mk (x : F.Obj <| M F) : dest (M.mk x) = x := by rfl
set_option linter.uppercaseLean3 false in
#align pfunctor.M.dest_mk PFunctor.M.dest_mk

@[simp]

theorem mk_inj {x y : F.Obj <| M F} (h : M.mk x = M.mk y) : x = y := by rw [← dest_mk x, h, dest_mk]
set_option linter.uppercaseLean3 false in
#align pfunctor.M.mk_inj PFunctor.M.mk_inj

/-- destructor for M-types -/
protected def cases {r : M F → Sort w} (f : ∀ x : F.Obj <| M F, r (M.mk x)) (x : M F) : r x :=
  suffices r (M.mk (dest x)) by
    rw [← mk_dest x]
    exact this
  f _
set_option linter.uppercaseLean3 false in
#align pfunctor.M.cases PFunctor.M.cases

/-- destructor for M-types -/
protected def casesOn {r : M F → Sort w} (x : M F) (f : ∀ x : F.Obj <| M F, r (M.mk x)) : r x :=
  M.cases f x
set_option linter.uppercaseLean3 false in
#align pfunctor.M.cases_on PFunctor.M.casesOn

/-- destructor for M-types, similar to `casesOn` but also
gives access directly to the root and subtrees on an M-type -/
protected def casesOn' {r : M F → Sort w} (x : M F) (f : ∀ a f, r (M.mk ⟨a, f⟩)) : r x :=
  M.casesOn x (fun ⟨a, g⟩ => f a g)
set_option linter.uppercaseLean3 false in
#align pfunctor.M.cases_on' PFunctor.M.casesOn'

theorem approx_mk (a : F.A) (f : F.B a → M F) (i : ℕ) :
    (M.mk ⟨a, f⟩).approx (succ i) = CofixA.intro a fun j => (f j).approx i :=
  rfl
set_option linter.uppercaseLean3 false in
#align pfunctor.M.approx_mk PFunctor.M.approx_mk

@[simp]
theorem agree'_refl {n : ℕ} (x : M F) : Agree' n x x := by
  induction' n with _ n_ih generalizing x <;>
  induction x using PFunctor.M.casesOn' <;> constructor <;> try rfl
  intros
  apply n_ih
set_option linter.uppercaseLean3 false in
#align pfunctor.M.agree'_refl PFunctor.M.agree'_refl

theorem agree_iff_agree' {n : ℕ} (x y : M F) :
    Agree (x.approx n) (y.approx <| n + 1) ↔ Agree' n x y := by
  constructor <;> intro h
  · induction' n with _ n_ih generalizing x y
    constructor
    · induction x using PFunctor.M.casesOn'
      induction y using PFunctor.M.casesOn'
      simp only [approx_mk] at h
      cases' h with _ _ _ _ _ _ hagree
      constructor <;> try rfl
      intro i
      apply n_ih
      apply hagree
  · induction' n with _ n_ih generalizing x y
    constructor
    · cases' h with _ _ _ a x' y'
      induction' x using PFunctor.M.casesOn' with x_a x_f
      induction' y using PFunctor.M.casesOn' with y_a y_f
      simp only [approx_mk]
      have h_a_1 := mk_inj ‹M.mk ⟨x_a, x_f⟩ = M.mk ⟨a, x'⟩›
      cases h_a_1
      replace h_a_2 := mk_inj ‹M.mk ⟨y_a, y_f⟩ = M.mk ⟨a, y'⟩›
      cases h_a_2
      constructor
      intro i
      apply n_ih
      simp [*]
set_option linter.uppercaseLean3 false in
#align pfunctor.M.agree_iff_agree' PFunctor.M.agree_iff_agree'

@[simp]
theorem cases_mk {r : M F → Sort _} (x : F.Obj <| M F) (f : ∀ x : F.Obj <| M F, r (M.mk x)) :
    PFunctor.M.cases f (M.mk x) = f x := by
  dsimp only [M.mk, PFunctor.M.cases, dest, head, Approx.sMk, head']
  cases x; dsimp only [Approx.sMk]
  simp only [Eq.mpr]
  apply congrFun
  rfl
set_option linter.uppercaseLean3 false in
#align pfunctor.M.cases_mk PFunctor.M.cases_mk

@[simp]
theorem casesOn_mk {r : M F → Sort _} (x : F.Obj <| M F) (f : ∀ x : F.Obj <| M F, r (M.mk x)) :
    PFunctor.M.casesOn (M.mk x) f = f x :=
  cases_mk x f
set_option linter.uppercaseLean3 false in
#align pfunctor.M.cases_on_mk PFunctor.M.casesOn_mk

@[simp]
theorem casesOn_mk' {r : M F → Sort _} {a} (x : F.B a → M F)
                    (f : ∀ (a) (f : F.B a → M F), r (M.mk ⟨a, f⟩)) :
    PFunctor.M.casesOn' (M.mk ⟨a, x⟩) f = f a x :=
  @cases_mk F r ⟨a, x⟩ (fun ⟨a, g⟩ => f a g)
set_option linter.uppercaseLean3 false in
#align pfunctor.M.cases_on_mk' PFunctor.M.casesOn_mk'

/-- `IsPath p x` tells us if `p` is a valid path through `x` -/
inductive IsPath : Path F → M F → Prop
  | nil (x : M F) : IsPath [] x
  |
  cons (xs : Path F) {a} (x : M F) (f : F.B a → M F) (i : F.B a) :
    x = M.mk ⟨a, f⟩ → IsPath xs (f i) → IsPath (⟨a, i⟩ :: xs) x
set_option linter.uppercaseLean3 false in
#align pfunctor.M.is_path PFunctor.M.IsPath

theorem isPath_cons {xs : Path F} {a a'} {f : F.B a → M F} {i : F.B a'} :
    IsPath (⟨a', i⟩ :: xs) (M.mk ⟨a, f⟩) → a = a' := by
  generalize h : M.mk ⟨a, f⟩ = x
  rintro (_ | ⟨_, _, _, _, rfl, _⟩)
  cases mk_inj h
  rfl
set_option linter.uppercaseLean3 false in
#align pfunctor.M.is_path_cons PFunctor.M.isPath_cons

theorem isPath_cons' {xs : Path F} {a} {f : F.B a → M F} {i : F.B a} :
    IsPath (⟨a, i⟩ :: xs) (M.mk ⟨a, f⟩) → IsPath xs (f i) := by
  generalize h : M.mk ⟨a, f⟩ = x
  rintro (_ | ⟨_, _, _, _, rfl, hp⟩)
  cases mk_inj h
  exact hp
set_option linter.uppercaseLean3 false in
#align pfunctor.M.is_path_cons' PFunctor.M.isPath_cons'

/-- follow a path through a value of `M F` and return the subtree
found at the end of the path if it is a valid path for that value and
return a default tree -/
def isubtree [DecidableEq F.A] [Inhabited (M F)] : Path F → M F → M F
  | [], x => x
  | ⟨a, i⟩ :: ps, x =>
    PFunctor.M.casesOn' (r := fun _ => M F) x (fun a' f =>
      if h : a = a' then
        isubtree ps (f <| cast (by rw [h]) i)
      else
        default (α := M F)
    )

set_option linter.uppercaseLean3 false in
#align pfunctor.M.isubtree PFunctor.M.isubtree

/-- similar to `isubtree` but returns the data at the end of the path instead
of the whole subtree -/
def iselect [DecidableEq F.A] [Inhabited (M F)] (ps : Path F) : M F → F.A := fun x : M F =>
  head <| isubtree ps x
set_option linter.uppercaseLean3 false in
#align pfunctor.M.iselect PFunctor.M.iselect

theorem iselect_eq_default [DecidableEq F.A] [Inhabited (M F)] (ps : Path F) (x : M F)
    (h : ¬IsPath ps x) : iselect ps x = head default := by
  induction' ps with ps_hd ps_tail ps_ih generalizing x
  · exfalso
    apply h
    constructor
  · cases' ps_hd with a i
    induction' x using PFunctor.M.casesOn' with x_a x_f
    simp only [iselect, isubtree] at ps_ih⊢
    by_cases h'' : a = x_a
    subst x_a
    · simp only [dif_pos, eq_self_iff_true, casesOn_mk']
      rw [ps_ih]
      intro h'
      apply h
      constructor <;> try rfl
      apply h'
    · simp [*]
set_option linter.uppercaseLean3 false in
#align pfunctor.M.iselect_eq_default PFunctor.M.iselect_eq_default

@[simp]
theorem head_mk (x : F.Obj (M F)) : head (M.mk x) = x.1 :=
  Eq.symm <|
    calc
      x.1 = (dest (M.mk x)).1 := by rw [dest_mk]
      _ = head (M.mk x) := by rfl

set_option linter.uppercaseLean3 false in
#align pfunctor.M.head_mk PFunctor.M.head_mk

theorem children_mk {a} (x : F.B a → M F) (i : F.B (head (M.mk ⟨a, x⟩))) :
    children (M.mk ⟨a, x⟩) i = x (cast (by rw [head_mk]) i) := by apply ext'; intro n; rfl
set_option linter.uppercaseLean3 false in
#align pfunctor.M.children_mk PFunctor.M.children_mk

@[simp]
theorem ichildren_mk [DecidableEq F.A] [Inhabited (M F)] (x : F.Obj (M F)) (i : F.IdxCat) :
    ichildren i (M.mk x) = x.iget i := by
  dsimp only [ichildren, PFunctor.Obj.iget]
  congr with h
set_option linter.uppercaseLean3 false in
#align pfunctor.M.ichildren_mk PFunctor.M.ichildren_mk

@[simp]
theorem isubtree_cons [DecidableEq F.A] [Inhabited (M F)] (ps : Path F) {a} (f : F.B a → M F)
    {i : F.B a} : isubtree (⟨_, i⟩ :: ps) (M.mk ⟨a, f⟩) = isubtree ps (f i) := by
  simp only [isubtree, ichildren_mk, PFunctor.Obj.iget, dif_pos, isubtree, M.casesOn_mk']; rfl
set_option linter.uppercaseLean3 false in
#align pfunctor.M.isubtree_cons PFunctor.M.isubtree_cons

@[simp]
theorem iselect_nil [DecidableEq F.A] [Inhabited (M F)] {a} (f : F.B a → M F) :
    iselect nil (M.mk ⟨a, f⟩) = a := by rfl
set_option linter.uppercaseLean3 false in
#align pfunctor.M.iselect_nil PFunctor.M.iselect_nil

@[simp]
theorem iselect_cons [DecidableEq F.A] [Inhabited (M F)] (ps : Path F) {a} (f : F.B a → M F) {i} :
    iselect (⟨a, i⟩ :: ps) (M.mk ⟨a, f⟩) = iselect ps (f i) := by simp only [iselect, isubtree_cons]
set_option linter.uppercaseLean3 false in
#align pfunctor.M.iselect_cons PFunctor.M.iselect_cons

theorem corec_def {X} (f : X → F.Obj X) (x₀ : X) : M.corec f x₀ = M.mk (M.corec f <$> f x₀) := by
  dsimp only [M.corec, M.mk]
  congr with n
  cases' n with n
  · dsimp only [sCorec, Approx.sMk]
  · dsimp only [sCorec, Approx.sMk]
    cases h : f x₀
    dsimp only [(· <$> ·), PFunctor.map]
    congr
set_option linter.uppercaseLean3 false in
#align pfunctor.M.corec_def PFunctor.M.corec_def

theorem ext_aux [Inhabited (M F)] [DecidableEq F.A] {n : ℕ} (x y z : M F) (hx : Agree' n z x)
    (hy : Agree' n z y) (hrec : ∀ ps : Path F, n = ps.length → iselect ps x = iselect ps y) :
    x.approx (n + 1) = y.approx (n + 1) := by
  induction' n with n n_ih generalizing x y z
  · specialize hrec [] rfl
    induction x using PFunctor.M.casesOn'
    induction y using PFunctor.M.casesOn'
    simp only [iselect_nil] at hrec
    subst hrec
    simp only [approx_mk, true_and_iff, eq_self_iff_true, heq_iff_eq, zero_eq, CofixA.intro.injEq,
                heq_eq_eq, eq_iff_true_of_subsingleton, and_self]
  · cases hx
    cases hy
    induction x using PFunctor.M.casesOn'
    induction y using PFunctor.M.casesOn'
    subst z
    iterate 3 (have := mk_inj ‹_›; cases this)
    rename_i n_ih a f₃ f₂ hAgree₂ _ _ h₂ _ _ f₁ h₁ hAgree₁ clr
    simp only [approx_mk, true_and_iff, eq_self_iff_true, heq_iff_eq]

    have := mk_inj h₁
    cases this; clear h₁
    have := mk_inj h₂
    cases this; clear h₂

    congr
    ext i
    apply n_ih
    · solve_by_elim
    · solve_by_elim
    introv h
    specialize hrec (⟨_, i⟩ :: ps) (congr_arg _ h)
    simp only [iselect_cons] at hrec
    exact hrec
set_option linter.uppercaseLean3 false in
#align pfunctor.M.ext_aux PFunctor.M.ext_aux

open PFunctor.Approx

attribute [local instance] Classical.propDecidable

theorem ext [Inhabited (M F)] (x y : M F) (H : ∀ ps : Path F, iselect ps x = iselect ps y) :
    x = y := by
  apply ext'; intro i
  induction' i with i i_ih
  · cases x.approx 0
    cases y.approx 0
    constructor
  · apply ext_aux x y x
    · rw [← agree_iff_agree']
      apply x.consistent
    · rw [← agree_iff_agree', i_ih]
      apply y.consistent
    introv H'
    dsimp only [iselect] at H
    cases H'
    apply H ps
set_option linter.uppercaseLean3 false in
#align pfunctor.M.ext PFunctor.M.ext

section Bisim

variable (R : M F → M F → Prop)

local infixl:50 " ~ " => R

/-- Bisimulation is the standard proof technique for equality between
infinite tree-like structures -/
structure IsBisimulation : Prop where
  /-- The head of the trees are equal -/
  head : ∀ {a a'} {f f'}, M.mk ⟨a, f⟩ ~ M.mk ⟨a', f'⟩ → a = a'
  /-- The tails are equal -/
  tail : ∀ {a} {f f' : F.B a → M F}, M.mk ⟨a, f⟩ ~ M.mk ⟨a, f'⟩ → ∀ i : F.B a, f i ~ f' i
set_option linter.uppercaseLean3 false in
#align pfunctor.M.is_bisimulation PFunctor.M.IsBisimulation

theorem nth_of_bisim [Inhabited (M F)] (bisim : IsBisimulation R) (s₁ s₂) (ps : Path F) :
    (R s₁ s₂) →
      IsPath ps s₁ ∨ IsPath ps s₂ →
        iselect ps s₁ = iselect ps s₂ ∧
          ∃ (a : _)(f f' : F.B a → M F),
            isubtree ps s₁ = M.mk ⟨a, f⟩ ∧
              isubtree ps s₂ = M.mk ⟨a, f'⟩ ∧ ∀ i : F.B a, f i ~ f' i := by
  intro h₀ hh
  induction' s₁ using PFunctor.M.casesOn' with a f
  rename_i h₁ hh₁
  induction' s₂ using PFunctor.M.casesOn' with a' f'
  rename_i h₁' hh₁' h₂ hh₂
  clear h₁ hh₁ h₂ hh₂ hh₁'
  obtain rfl : a = a' := bisim.head h₀
  induction' ps with i ps ps_ih generalizing a f f'
  · exists rfl, a, f, f', rfl, rfl
    apply bisim.tail h₀
  cases' i with a' i
  obtain rfl : a = a' := by rcases hh with hh|hh <;> cases isPath_cons hh <;> rfl
  dsimp only [iselect] at ps_ih⊢
  have h₁ := bisim.tail h₀ i
  induction' h : f i using PFunctor.M.casesOn' with a₀ f₀
  induction' h' : f' i using PFunctor.M.casesOn' with a₁ f₁
  simp only [h, h', isubtree_cons] at ps_ih⊢
  rw [h, h'] at h₁
  obtain rfl : a₀ = a₁ := bisim.head h₁
  apply ps_ih _ _ _ h₁
  rw [← h, ← h']
  apply Or.imp isPath_cons' isPath_cons' hh
set_option linter.uppercaseLean3 false in
#align pfunctor.M.nth_of_bisim PFunctor.M.nth_of_bisim

theorem eq_of_bisim [Nonempty (M F)] (bisim : IsBisimulation R) : ∀ s₁ s₂, R s₁ s₂ → s₁ = s₂ := by
  inhabit M F
  introv Hr; apply ext
  introv
  by_cases h : IsPath ps s₁ ∨ IsPath ps s₂
  · have H := nth_of_bisim R bisim _ _ ps Hr h
    exact H.left
  · rw [not_or] at h
    cases' h with h₀ h₁
    simp only [iselect_eq_default, *, not_false_iff]
set_option linter.uppercaseLean3 false in
#align pfunctor.M.eq_of_bisim PFunctor.M.eq_of_bisim

end Bisim

universe u' v'

/-- corecursor for `M F` with swapped arguments -/
def corecOn {X : Type _} (x₀ : X) (f : X → F.Obj X) : M F :=
  M.corec f x₀
set_option linter.uppercaseLean3 false in
#align pfunctor.M.corec_on PFunctor.M.corecOn

variable {P : PFunctor.{u}} {α : Type u}

theorem dest_corec (g : α → P.Obj α) (x : α) : M.dest (M.corec g x) = M.corec g <$> g x := by
  rw [corec_def, dest_mk]
set_option linter.uppercaseLean3 false in
#align pfunctor.M.dest_corec PFunctor.M.dest_corec

theorem bisim (R : M P → M P → Prop)
    (h : ∀ x y, R x y → ∃ a f f', M.dest x = ⟨a, f⟩ ∧ M.dest y = ⟨a, f'⟩ ∧ ∀ i, R (f i) (f' i)) :
    ∀ x y, R x y → x = y := by
  introv h'
  haveI := Inhabited.mk x.head
  apply eq_of_bisim R _ _ _ h'; clear h' x y
  constructor <;> introv ih <;> rcases h _ _ ih with ⟨a'', g, g', h₀, h₁, h₂⟩ <;> clear h
  · replace h₀ := congr_arg Sigma.fst h₀
    replace h₁ := congr_arg Sigma.fst h₁
    simp only [dest_mk] at h₀ h₁
    rw [h₀, h₁]
  · simp only [dest_mk] at h₀ h₁
    cases h₀
    cases h₁
    apply h₂
set_option linter.uppercaseLean3 false in
#align pfunctor.M.bisim PFunctor.M.bisim

theorem bisim' {α : Type _} (Q : α → Prop) (u v : α → M P)
    (h : ∀ x, Q x → ∃ a f f',
          M.dest (u x) = ⟨a, f⟩
          ∧ M.dest (v x) = ⟨a, f'⟩
          ∧ ∀ i, ∃ x', Q x' ∧ f i = u x' ∧ f' i = v x'
      ) :
    ∀ x, Q x → u x = v x := fun x Qx =>
  let R := fun w z : M P => ∃ x', Q x' ∧ w = u x' ∧ z = v x'
  @M.bisim P R
    (fun _ _ ⟨x', Qx', xeq, yeq⟩ =>
      let ⟨a, f, f', ux'eq, vx'eq, h'⟩ := h x' Qx'
      ⟨a, f, f', xeq.symm ▸ ux'eq, yeq.symm ▸ vx'eq, h'⟩)
    _ _ ⟨x, Qx, rfl, rfl⟩
set_option linter.uppercaseLean3 false in
#align pfunctor.M.bisim' PFunctor.M.bisim'

-- for the record, show M_bisim follows from _bisim'
theorem bisim_equiv (R : M P → M P → Prop)
    (h : ∀ x y, R x y → ∃ a f f', M.dest x = ⟨a, f⟩ ∧ M.dest y = ⟨a, f'⟩ ∧ ∀ i, R (f i) (f' i)) :
    ∀ x y, R x y → x = y := fun x y Rxy =>
  let Q : M P × M P → Prop := fun p => R p.fst p.snd
  bisim' Q Prod.fst Prod.snd
    (fun p Qp =>
      let ⟨a, f, f', hx, hy, h'⟩ := h p.fst p.snd Qp
      ⟨a, f, f', hx, hy, fun i => ⟨⟨f i, f' i⟩, h' i, rfl, rfl⟩⟩)
    ⟨x, y⟩ Rxy
set_option linter.uppercaseLean3 false in
#align pfunctor.M.bisim_equiv PFunctor.M.bisim_equiv

theorem corec_unique (g : α → P.Obj α) (f : α → M P) (hyp : ∀ x, M.dest (f x) = f <$> g x) :
    f = M.corec g := by
  ext x
  apply bisim' (fun _ => True) _ _ _ _ trivial
  clear x
  intro x _
  cases' gxeq : g x with a f'
  have h₀ : M.dest (f x) = ⟨a, f ∘ f'⟩ := by rw [hyp, gxeq, PFunctor.map_eq]
  have h₁ : M.dest (M.corec g x) = ⟨a, M.corec g ∘ f'⟩ := by rw [dest_corec, gxeq, PFunctor.map_eq]
  refine' ⟨_, _, _, h₀, h₁, _⟩
  intro i
  exact ⟨f' i, trivial, rfl, rfl⟩
set_option linter.uppercaseLean3 false in
#align pfunctor.M.corec_unique PFunctor.M.corec_unique

/-- corecursor where the state of the computation can be sent downstream
in the form of a recursive call -/
def corec₁ {α : Type u} (F : ∀ X, (α → X) → α → P.Obj X) : α → M P :=
  M.corec (F _ id)
set_option linter.uppercaseLean3 false in
#align pfunctor.M.corec₁ PFunctor.M.corec₁

/-- corecursor where it is possible to return a fully formed value at any point
of the computation -/
def corec' {α : Type u} (F : ∀ {X : Type u}, (α → X) → α → Sum (M P) (P.Obj X)) (x : α) : M P :=
  corec₁
    (fun _ rec (a : Sum (M P) α) =>
      let y := a >>= F (rec ∘ Sum.inr)
      match y with
      | Sum.inr y => y
      | Sum.inl y => (rec ∘ Sum.inl) <$> M.dest y)
    (@Sum.inr (M P) _ x)
set_option linter.uppercaseLean3 false in
#align pfunctor.M.corec' PFunctor.M.corec'

end M

end PFunctor


/-
Copyright (c) 2022 Joël Riou. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Joël Riou
-/

import category_theory.equivalence

/-! Tools for compatibilities between Dold-Kan equivalences

The purpose of this file is to introduce tools which will enable the
construction of the Dold-Kan equivalence `simplicial_object C ≌ chain_complex C ℕ`
for a pseudoabelian category `C` from the equivalence
`karoubi (simplicial_object C) ≌ karoubi (chain_complex C ℕ)` and the two
equivalences `simplicial_object C ≅ karoubi (simplicial_object C)` and
`chain_complex C ℕ ≅ karoubi (chain_complex C ℕ)`.

It is certainly possible to get an equivalence `simplicial_object C ≌ chain_complex C ℕ`
using a compositions of the three equivalences above, but then neither the functor
nor the inverse would have good definitional properties. For example, it would be better
if the inverse functor of the equivalence was exactly the functor
`Γ₀ : simplicial_object C ⥤ chain_complex C ℕ` which was constructed in `functor_gamma.lean`.

In this file, given four categories `A`, `A'`, `B`, `B'`, equivalences `eA : A ≅ A'`,
`eB : B ≅ B'`, `e' : A' ≅ B'`, functors `F : A ⥤ B'`, `G : B ⥤ A` equipped with certain
compatibilities, we construct successive equivalences:
- `equivalence₀` from `A` to `B'`, which is the composition of `eA` and `e'`.
- `equivalence₁` from `A` to `B'`, with the same inverse functor as `equivalence₀`,
but whose functor is `F`.
- `equivalence₂` from `A` to `B`, which is the composition of `equivalence₁` and the
inverse of `eB`:
- `equivalence` from `A` to `B`, which has the same functor `F ⋙ eB.inverse` as `equivalence₂`,
but whose inverse functor is `G`.

When extra assumptions are given, we shall also provide simplification lemmas for the
unit and counit isomorphisms of `equivalence`. (TODO)

-/

open category_theory category_theory.category

namespace algebraic_topology

namespace dold_kan

namespace compatibility

variables {A A' B B' : Type*} [category A] [category A'] [category B] [category B']
  (eA : A ≌ A') (eB : B ≌ B') (e' : A' ≌ B')
  {F : A ⥤ B'} (hF : eA.functor ⋙ e'.functor ≅ F)
  {G : B ⥤ A} (hG : eB.functor ⋙ e'.inverse ≅ G ⋙ eA.functor)

/-- A basic equivalence `A ≅ B'` obtained by composing `eA : A ≅ A'` and `e' : A' ≅ B'`. -/
@[simps functor inverse unit_iso_hom_app]
def equivalence₀ : A ≌ B' := eA.trans e'

include hF
variables {eA} {e'}

/-- An intermediate equivalence `A ≅ B'` whose functor is `F` and whose inverse is
`e'.inverse ⋙ eA.inverse`. -/
@[simps functor]
def equivalence₁ : A ≌ B' :=
begin
  letI : is_equivalence F :=
    is_equivalence.of_iso hF (is_equivalence.of_equivalence (equivalence₀ eA e')),
  exact F.as_equivalence,
end

lemma equivalence₁_inverse : (equivalence₁ hF).inverse = e'.inverse ⋙ eA.inverse := rfl

/-- The counit isomorphism of the equivalence `equivalence₁` between `A` and `B'`. -/
@[simps]
def equivalence₁_counit_iso :
  (e'.inverse ⋙ eA.inverse) ⋙ F ≅ 𝟭 B' :=
calc (e'.inverse ⋙ eA.inverse) ⋙ F
  ≅ (e'.inverse ⋙ eA.inverse) ⋙ (eA.functor ⋙ e'.functor) : iso_whisker_left _ hF.symm
... ≅ e'.inverse ⋙ (eA.inverse ⋙ eA.functor) ⋙ e'.functor : iso.refl _
... ≅ e'.inverse ⋙ 𝟭 _ ⋙ e'.functor : iso_whisker_left _ (iso_whisker_right eA.counit_iso _)
... ≅ e'.inverse ⋙ e'.functor : iso.refl _
... ≅ 𝟭 B' : e'.counit_iso

lemma equivalence₁_counit_iso_eq : (equivalence₁ hF).counit_iso = equivalence₁_counit_iso hF :=
begin
  ext Y,
  dsimp [equivalence₀, equivalence₁, is_equivalence.inverse, is_equivalence.of_equivalence],
  simp only [equivalence₁_counit_iso_hom_app, category_theory.functor.map_id, comp_id],
end

/-- The unit isomorphism of the equivalence `equivalence₁` between `A` and `B'`. -/
@[simps]
def equivalence₁_unit_iso :
  𝟭 A ≅ F ⋙ (e'.inverse ⋙ eA.inverse) :=
calc 𝟭 A ≅ eA.functor ⋙ eA.inverse : eA.unit_iso
... ≅ eA.functor ⋙ 𝟭 A' ⋙ eA.inverse : iso.refl _
... ≅ eA.functor ⋙ (e'.functor ⋙ e'.inverse) ⋙ eA.inverse :
  iso_whisker_left _ (iso_whisker_right e'.unit_iso _)
... ≅ (eA.functor ⋙ e'.functor) ⋙ (e'.inverse ⋙ eA.inverse) : iso.refl _
... ≅ F ⋙ (e'.inverse ⋙ eA.inverse) : iso_whisker_right hF _

lemma equivalence₁_unit_iso_eq : (equivalence₁ hF).unit_iso = equivalence₁_unit_iso hF :=
begin
  ext X,
  dsimp [equivalence₀, equivalence₁, nat_iso.hcomp,
    is_equivalence.of_equivalence],
  simp only [id_comp, assoc, equivalence₁_unit_iso_hom_app],
end

include eB

/-- An intermediate equivalence `A ≅ B` obtained as the composition of `equivalence₁` and
the inverse of `eB : B ≌ B'`. -/
@[simps functor]
def equivalence₂ : A ≌ B := (equivalence₁ hF).trans eB.symm

lemma equivalence₂_inverse : (equivalence₂ eB hF).inverse =
  eB.functor ⋙ e'.inverse ⋙ eA.inverse := rfl

/-- The counit isomorphism of the equivalence `equivalence₂` between `A` and `B`. -/
@[simps]
def equivalence₂_counit_iso :
  (eB.functor ⋙ e'.inverse ⋙ eA.inverse) ⋙ (F ⋙ eB.inverse) ≅ 𝟭 B :=
calc (eB.functor ⋙ e'.inverse ⋙ eA.inverse) ⋙ (F ⋙ eB.inverse)
  ≅ eB.functor ⋙ (e'.inverse ⋙ eA.inverse ⋙ F) ⋙ eB.inverse : iso.refl _
... ≅ eB.functor ⋙ 𝟭 _ ⋙ eB.inverse :
  iso_whisker_left _ (iso_whisker_right (equivalence₁_counit_iso hF) _)
... ≅ eB.functor ⋙ eB.inverse : iso.refl _
... ≅ 𝟭 B : eB.unit_iso.symm

/-- The unit isomorphism of the equivalence `equivalence₂` between `A` and `B`. -/
@[simps]
def equivalence₂_unit_iso :
  𝟭 A ≅ (F ⋙ eB.inverse) ⋙ (eB.functor ⋙ e'.inverse ⋙ eA.inverse) :=
calc 𝟭 A ≅ F ⋙ e'.inverse ⋙ eA.inverse : equivalence₁_unit_iso hF
... ≅ F ⋙ 𝟭 B' ⋙ (e'.inverse ⋙ eA.inverse) : iso.refl _
... ≅ F ⋙ (eB.inverse ⋙ eB.functor) ⋙ e'.inverse ⋙ eA.inverse :
  iso_whisker_left _ (iso_whisker_right eB.counit_iso.symm _)
... ≅ (F ⋙ eB.inverse) ⋙ (eB.functor ⋙ e'.inverse ⋙ eA.inverse) : iso.refl _

lemma equivalence₂_unit_iso_eq :
  (equivalence₂ eB hF).unit_iso = equivalence₂_unit_iso eB hF :=
begin
  ext X,
  dsimp [equivalence₂],
  simpa only [equivalence₂_unit_iso_hom_app, equivalence₁_unit_iso_eq,
    equivalence₁_unit_iso_hom_app, assoc, nat_iso.cancel_nat_iso_hom_left],
end

variable {eB}
include hG

/-- The equivalence `A ≅ B` whose functor is `F ⋙ eB.inverse` and
whose inverse is `G : B ≅ A`. -/
@[simps inverse]
def equivalence : A ≌ B :=
begin
  letI : is_equivalence G := begin
    refine is_equivalence.of_iso _ (is_equivalence.of_equivalence (equivalence₂ eB hF).symm),
    calc eB.functor ⋙ e'.inverse ⋙ eA.inverse
      ≅ (eB.functor ⋙ e'.inverse) ⋙ eA.inverse : iso.refl _
    ... ≅ (G ⋙ eA.functor) ⋙ eA.inverse : iso_whisker_right hG _
    ... ≅ G ⋙ 𝟭 A : iso_whisker_left _ eA.unit_iso.symm
    ... ≅ G : functor.right_unitor G,
  end,
  exact G.as_equivalence.symm,
end

lemma equivalence_functor : (equivalence hF hG).functor = F ⋙ eB.inverse := rfl

end compatibility

end dold_kan

end algebraic_topology


/-
Copyright (c) 2020 Markus Himmel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Markus Himmel
-/
import category_theory.comma

/-!
# The category of arrows

The category of arrows, with morphisms commutative squares.
We set this up as a specialization of the comma category `comma L R`,
where `L` and `R` are both the identity functor.

We also define the typeclass `has_lift`, representing a choice of a lift
of a commutative square (that is, a diagonal morphism making the two triangles commute).

## Tags

comma, arrow
-/

namespace category_theory

universes v u -- morphism levels before object levels. See note [category_theory universes].
variables {T : Type u} [category.{v} T]

section
variables (T)

/-- The arrow category of `T` has as objects all morphisms in `T` and as morphisms commutative
     squares in `T`. -/
@[derive category]
def arrow := comma.{v v v} (𝟭 T) (𝟭 T)

-- Satisfying the inhabited linter
instance arrow.inhabited [inhabited T] : inhabited (arrow T) :=
{ default := show comma (𝟭 T) (𝟭 T), from default (comma (𝟭 T) (𝟭 T)) }

end

namespace arrow

@[simp] lemma id_left (f : arrow T) : comma_morphism.left (𝟙 f) = 𝟙 (f.left) := rfl
@[simp] lemma id_right (f : arrow T) : comma_morphism.right (𝟙 f) = 𝟙 (f.right) := rfl

/-- An object in the arrow category is simply a morphism in `T`. -/
@[simps]
def mk {X Y : T} (f : X ⟶ Y) : arrow T :=
{ left := X,
  right := Y,
  hom := f }

theorem mk_injective (A B : T) :
  function.injective (arrow.mk : (A ⟶ B) → arrow T) :=
λ f g h, by { cases h, refl }

theorem mk_inj (A B : T) {f g : A ⟶ B} : arrow.mk f = arrow.mk g ↔ f = g :=
(mk_injective A B).eq_iff
instance {X Y : T} : has_coe (X ⟶ Y) (arrow T) := ⟨mk⟩

/-- A morphism in the arrow category is a commutative square connecting two objects of the arrow
    category. -/
@[simps]
def hom_mk {f g : arrow T} {u : f.left ⟶ g.left} {v : f.right ⟶ g.right}
  (w : u ≫ g.hom = f.hom ≫ v) : f ⟶ g :=
{ left := u,
  right := v,
  w' := w }

/-- We can also build a morphism in the arrow category out of any commutative square in `T`. -/
@[simps]
def hom_mk' {X Y : T} {f : X ⟶ Y} {P Q : T} {g : P ⟶ Q} {u : X ⟶ P} {v : Y ⟶ Q}
  (w : u ≫ g = f ≫ v) : arrow.mk f ⟶ arrow.mk g :=
{ left := u,
  right := v,
  w' := w }

@[simp, reassoc] lemma w {f g : arrow T} (sq : f ⟶ g) : sq.left ≫ g.hom = f.hom ≫ sq.right := sq.w

-- `w_mk_left` is not needed, as it is a consequence of `w` and `mk_hom`.
@[simp, reassoc] lemma w_mk_right {f : arrow T} {X Y : T} {g : X ⟶ Y} (sq : f ⟶ mk g) :
  sq.left ≫ g = f.hom ≫ sq.right :=
sq.w

lemma is_iso_of_iso_left_of_is_iso_right
  {f g : arrow T} (ff : f ⟶ g) [is_iso ff.left] [is_iso ff.right] : is_iso ff :=
{ out := ⟨⟨inv ff.left, inv ff.right⟩,
          by { ext; dsimp; simp only [is_iso.hom_inv_id] },
          by { ext; dsimp; simp only [is_iso.inv_hom_id] }⟩ }

/-- Create an isomorphism between arrows,
by providing isomorphisms between the domains and codomains,
and a proof that the square commutes. -/
@[simps] def iso_mk {f g : arrow T}
  (l : f.left ≅ g.left) (r : f.right ≅ g.right) (h : l.hom ≫ g.hom = f.hom ≫ r.hom) :
  f ≅ g :=
comma.iso_mk l r h

section

variables {f g : arrow T} (sq : f ⟶ g)

instance is_iso_left [is_iso sq] : is_iso sq.left :=
{ out := ⟨(inv sq).left, by simp only [← comma.comp_left, is_iso.hom_inv_id, is_iso.inv_hom_id,
    arrow.id_left, eq_self_iff_true, and_self]⟩ }

instance is_iso_right [is_iso sq] : is_iso sq.right :=
{ out := ⟨(inv sq).right, by simp only [← comma.comp_right, is_iso.hom_inv_id, is_iso.inv_hom_id,
    arrow.id_right, eq_self_iff_true, and_self]⟩ }

@[simp] lemma inv_left [is_iso sq] : (inv sq).left = inv sq.left :=
is_iso.eq_inv_of_hom_inv_id $ by rw [← comma.comp_left, is_iso.hom_inv_id, id_left]

@[simp] lemma inv_right [is_iso sq] : (inv sq).right = inv sq.right :=
is_iso.eq_inv_of_hom_inv_id $ by rw [← comma.comp_right, is_iso.hom_inv_id, id_right]

@[simp] lemma left_hom_inv_right [is_iso sq] : sq.left ≫ g.hom ≫ inv sq.right = f.hom :=
by simp only [← category.assoc, is_iso.comp_inv_eq, w]

-- simp proves this
lemma inv_left_hom_right [is_iso sq] : inv sq.left ≫ f.hom ≫ sq.right = g.hom :=
by simp only [w, is_iso.inv_comp_eq]

instance mono_left [mono sq] : mono sq.left :=
{ right_cancellation := λ Z φ ψ h, begin
    let aux : (Z ⟶ f.left) → (arrow.mk (𝟙 Z) ⟶ f) := λ φ, { left := φ, right := φ ≫ f.hom },
    show (aux φ).left = (aux ψ).left,
    congr' 1,
    rw ← cancel_mono sq,
    ext,
    { exact h },
    { simp only [comma.comp_right, category.assoc, ← arrow.w],
      simp only [← category.assoc, h], },
  end }

instance epi_right [epi sq] : epi sq.right :=
{ left_cancellation := λ Z φ ψ h, begin
    let aux : (g.right ⟶ Z) → (g ⟶ arrow.mk (𝟙 Z)) := λ φ, { right := φ, left := g.hom ≫ φ },
    show (aux φ).right = (aux ψ).right,
    congr' 1,
    rw ← cancel_epi sq,
    ext,
    { simp only [comma.comp_left, category.assoc, arrow.w_assoc, h], },
    { exact h },
  end }

end

/-- Given a square from an arrow `i` to an isomorphism `p`, express the source part of `sq`
in terms of the inverse of `p`. -/
@[simp] lemma square_to_iso_invert (i : arrow T) {X Y : T} (p : X ≅ Y) (sq : i ⟶ arrow.mk p.hom) :
  i.hom ≫ sq.right ≫ p.inv = sq.left :=
by simpa only [category.assoc] using (iso.comp_inv_eq p).mpr ((arrow.w_mk_right sq).symm)

/-- Given a square from an isomorphism `i` to an arrow `p`, express the target part of `sq`
in terms of the inverse of `i`. -/
lemma square_from_iso_invert {X Y : T} (i : X ≅ Y) (p : arrow T) (sq : arrow.mk i.hom ⟶ p) :
  i.inv ≫ sq.left ≫ p.hom = sq.right :=
by simp only [iso.inv_hom_id_assoc, arrow.w, arrow.mk_hom]

/-- A lift of a commutative square is a diagonal morphism making the two triangles commute. -/
@[ext] structure lift_struct {f g : arrow T} (sq : f ⟶ g) :=
(lift : f.right ⟶ g.left)
(fac_left' : f.hom ≫ lift = sq.left . obviously)
(fac_right' : lift ≫ g.hom = sq.right . obviously)

restate_axiom lift_struct.fac_left'
restate_axiom lift_struct.fac_right'

instance lift_struct_inhabited {X : T} : inhabited (lift_struct (𝟙 (arrow.mk (𝟙 X)))) :=
⟨⟨𝟙 _, category.id_comp _, category.comp_id _⟩⟩

/-- `has_lift sq` says that there is some `lift_struct sq`, i.e., that it is possible to find a
    diagonal morphism making the two triangles commute. -/
class has_lift {f g : arrow T} (sq : f ⟶ g) : Prop :=
mk' :: (exists_lift : nonempty (lift_struct sq))

lemma has_lift.mk {f g : arrow T} {sq : f ⟶ g} (s : lift_struct sq) : has_lift sq :=
⟨nonempty.intro s⟩

attribute [simp, reassoc] lift_struct.fac_left lift_struct.fac_right

/-- Given `has_lift sq`, obtain a lift. -/
noncomputable def has_lift.struct {f g : arrow T} (sq : f ⟶ g) [has_lift sq] : lift_struct sq :=
classical.choice has_lift.exists_lift

/-- If there is a lift of a commutative square `sq`, we can access it by saying `lift sq`. -/
noncomputable abbreviation lift {f g : arrow T} (sq : f ⟶ g) [has_lift sq] : f.right ⟶ g.left :=
(has_lift.struct sq).lift

lemma lift.fac_left {f g : arrow T} (sq : f ⟶ g) [has_lift sq] : f.hom ≫ lift sq = sq.left :=
by simp

lemma lift.fac_right {f g : arrow T} (sq : f ⟶ g) [has_lift sq] : lift sq ≫ g.hom = sq.right :=
by simp

@[simp, reassoc]
lemma lift.fac_right_of_to_mk {X Y : T} {f : arrow T} {g : X ⟶ Y} (sq : f ⟶ mk g) [has_lift sq] :
  lift sq ≫ g = sq.right :=
by simp only [←mk_hom g, lift.fac_right]

@[simp, reassoc]
lemma lift.fac_left_of_from_mk {X Y : T} {f : X ⟶ Y} {g : arrow T} (sq : mk f ⟶ g) [has_lift sq] :
  f ≫ lift sq = sq.left :=
by simp only [←mk_hom f, lift.fac_left]

@[simp, reassoc]
lemma lift_mk'_left {X Y P Q : T} {f : X ⟶ Y} {g : P ⟶ Q} {u : X ⟶ P} {v : Y ⟶ Q}
  (h : u ≫ g = f ≫ v) [has_lift $ arrow.hom_mk' h] : f ≫ lift (arrow.hom_mk' h) = u :=
by simp only [←arrow.mk_hom f, lift.fac_left, arrow.hom_mk'_left]

@[simp, reassoc]
lemma lift_mk'_right {X Y P Q : T} {f : X ⟶ Y} {g : P ⟶ Q} {u : X ⟶ P} {v : Y ⟶ Q}
  (h : u ≫ g = f ≫ v) [has_lift $ arrow.hom_mk' h] : lift (arrow.hom_mk' h) ≫ g = v :=
by simp only [←arrow.mk_hom g, lift.fac_right, arrow.hom_mk'_right]

section

instance subsingleton_lift_struct_of_epi {f g : arrow T} (sq : f ⟶ g) [epi f.hom] :
  subsingleton (lift_struct sq) :=
subsingleton.intro $ λ a b, lift_struct.ext a b $ (cancel_epi f.hom).1 $ by simp

instance subsingleton_lift_struct_of_mono {f g : arrow T} (sq : f ⟶ g) [mono g.hom] :
  subsingleton (lift_struct sq) :=
subsingleton.intro $ λ a b, lift_struct.ext a b $ (cancel_mono g.hom).1 $ by simp

end

variables {C : Type u} [category.{v} C]
/-- A helper construction: given a square between `i` and `f ≫ g`, produce a square between
`i` and `g`, whose top leg uses `f`:
A  → X
     ↓f
↓i   Y             --> A → Y
     ↓g                ↓i  ↓g
B  → Z                 B → Z
 -/
@[simps] def square_to_snd {X Y Z: C} {i : arrow C} {f : X ⟶ Y} {g : Y ⟶ Z}
  (sq : i ⟶ arrow.mk (f ≫ g)) :
  i ⟶ arrow.mk g :=
{ left := sq.left ≫ f,
  right := sq.right }

/-- The functor sending an arrow to its source. -/
@[simps] def left_func : arrow C ⥤ C := comma.fst _ _

/-- The functor sending an arrow to its target. -/
@[simps] def right_func : arrow C ⥤ C := comma.snd _ _

/-- The natural transformation from `left_func` to `right_func`, given by the arrow itself. -/
@[simps]
def left_to_right : (left_func : arrow C ⥤ C) ⟶ right_func :=
{ app := λ f, f.hom }

end arrow

namespace functor

universes v₁ v₂ u₁ u₂

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

/-- A functor `C ⥤ D` induces a functor between the corresponding arrow categories. -/
@[simps]
def map_arrow (F : C ⥤ D) : arrow C ⥤ arrow D :=
{ obj := λ a,
  { left := F.obj a.left,
    right := F.obj a.right,
    hom := F.map a.hom, },
  map := λ a b f,
  { left := F.map f.left,
    right := F.map f.right,
    w' := by { have w := f.w, simp only [id_map] at w, dsimp, simp only [←F.map_comp, w], } } }

end functor

end category_theory


/- -----------------------------------------------------------------------
Basic properties of LeanCat.
----------------------------------------------------------------------- -/

import ..c1_basic
import ..c2_limits
import ..c3_wtypes
import ..c4_topoi

namespace qp

open stdaux

universe variables ℓ' ℓ ℓobj ℓhom

/- -----------------------------------------------------------------------
Constant homs.
----------------------------------------------------------------------- -/

/-! #brief A constant hom in LeanCat.
-/
definition LeanCat.const_hom
    {X Y : LeanCat.{ℓ}^.obj}
    (y : Y)
    : LeanCat^.hom X Y
| x := y

/- -----------------------------------------------------------------------
Limits and colimits.
----------------------------------------------------------------------- -/

/-! #brief LeanCat has all limits.
-/
instance LeanCat.HasAllLimits : HasAllLimits.{ℓobj ℓhom} LeanCat.{max ℓ ℓobj}
:= { has_limit
      := λ X L
         , HasLimit.show
            { g : ∀ (x : X^.obj), L^.obj x
               // ∀ {x₁ x₂ : X^.obj} (f : X^.hom x₁ x₂)
                  , g x₂ = L^.hom f (g x₁)
            }
            (λ x g, g^.val x)
            (λ x₁ x₂ f, funext (λ g, g^.property f))
            (λ C hom ωhom c
             , { val := λ x, hom x c
               , property := λ x₁ x₂ f, begin rw ωhom f, trivial end
               })
            (λ C hom ωhom x, rfl)
            (λ C hom ωhom f ωf
             , funext (λ c, subtype.eq (funext (λ x, eq.symm (by apply congr_fun (ωf x) c)))))
   }

/-! #brief The equivalence relation underlying colimits in LeanCat.
-/
definition LeanCat.HasAllCoLimits.prop {X : Cat.{ℓobj ℓhom}}
    (L : Fun X LeanCat.{max ℓ ℓobj})
    (a b : (Σ (x : X^.obj), L^.obj x))
    : Prop
:= ∃ (f : X^.hom a^.fst b^.fst), b^.snd = L^.hom f a^.snd

/-! #brief LeanCat has all co-limits.
-/
instance LeanCat.HasAllCoLimits : HasAllCoLimits.{ℓobj ℓhom} LeanCat.{max ℓ ℓobj}
:= { has_colimit
      := λ X L
         , HasCoLimit.show
            (quot (LeanCat.HasAllCoLimits.prop L))
            (λ x Lx, quot.mk _ {fst := x, snd := Lx})
            (λ x₁ x₂ f, funext (λ Lx, quot.sound (exists.intro f rfl)))
            (λ C hom ωhom
             , let f : (Σ (x : X^.obj), L^.obj x) → C
                      := λ Lx, hom Lx^.fst Lx^.snd in
               let ωf : ∀ (a b : Σ (x : ⟦X⟧), L^.obj x)
                        , LeanCat.HasAllCoLimits.prop L a b
                        → f a = f b
                     := λ a b ωab
                        , begin
                            dsimp,
                            cases ωab with g ωg,
                            rw [ωg, ωhom g],
                            trivial
                          end
               in quot.lift f ωf)
            (λ C hom ωhom x, rfl)
            (λ C hom ωhom f ωf
             , funext (quot.ind (begin
                                   intro Lx,
                                   cases Lx with x Lx,
                                   apply eq.symm (congr_fun (ωf x) Lx)
                                 end)))
   }

/- -----------------------------------------------------------------------
Limits and colimits in over/under categories.
----------------------------------------------------------------------- -/

/-! #brief Structure hom for colimits in OverCat LeanCat.
-/
definition LeanCat.Over.HasCoLimit.colim_hom
    (B : LeanCat.{max ℓ ℓobj}^.obj)
    {X : Cat.{ℓobj ℓhom}}
    (L : Fun X (OverCat LeanCat B))
    : LeanCat^.hom (colimit (OverFun.out LeanCat B □□ L)) B
:= let f : (Σ (x : X^.obj), (L^.obj x)^.obj) → B
        := λ x, (L^.obj x^.fst)^.hom x^.snd
in quot.lift f
    begin
      intros a b,
      cases a with xa a,
      cases b with xb b,
      intro ω, cases ω with h ωb,
      dsimp at h,
      dsimp at ωb, subst ωb,
      apply congr_fun (L^.hom h)^.triangle a
    end

/-! #brief OverCat LeanCat has all co-limits.
-/
instance LeanCat.Over.HasCoLimit
    (B : LeanCat.{max ℓ ℓobj}^.obj)
    {X : Cat.{ℓobj ℓhom}} (L : Fun X (OverCat LeanCat B))
    : HasCoLimit L
:= HasCoLimit.show
    { obj := colimit (OverFun.out LeanCat B □□ L)
    , hom := LeanCat.Over.HasCoLimit.colim_hom B L
    }
    (λ x, { hom := λ Lx, quot.mk _ { fst := x, snd := Lx }
          , triangle := sorry
          })
    (λ x₁ x₂ f, begin
                  apply OverHom.eq,
                  apply funext, intro Lx,
                  apply quot.sound,
                  apply exists.intro f,
                  trivial
                end)
    sorry
    sorry
    sorry

instance LeanCat.Over.HasAllCoLimits
    (B : LeanCat.{max ℓ ℓobj}^.obj)
    : HasAllCoLimits.{ℓobj ℓhom}
        (OverCat LeanCat.{max ℓ ℓobj} B)
:= { has_colimit := @LeanCat.Over.HasCoLimit B
   }

/-! #brief Handy simplifier.
-/
theorem LeanCat.Over.HasCoLimit.obj
    (B : LeanCat.{max ℓ ℓobj}^.obj)
    {X : Cat.{ℓobj ℓhom}} (L : Fun X (OverCat LeanCat B))
    : (colimit L)^.obj = colimit (OverFun.out LeanCat B □□ L)
:= rfl

/- -----------------------------------------------------------------------
Products.
----------------------------------------------------------------------- -/

/-! #brief LeanCat has all products.
-/
instance LeanCat.HasProduct
    {A : Type ℓ'} (factor : A → LeanCat.{max ℓ ℓ'}^.obj)
    : HasProduct LeanCat.{max ℓ ℓ'} factor
:= HasProduct.show LeanCat factor
    (∀ (a : A), factor a)
    (λ a fa, fa a)
    (λ T f t a, f a t)
    (λ T f a, rfl)
    (λ T f h ωh
      , begin
          apply funext, intro t,
          apply funext, intro a,
          rw ωh,
          trivial
        end)

/-! #brief LeanCat has all products.
-/
instance LeanCat.HasAllProducts
    : HasAllProducts.{ℓ'} LeanCat.{max ℓ ℓ'}
:= { has_product := @LeanCat.HasProduct
   }

/-! #brief Finite product type in LeanCat.
-/
definition ListProd
    : ∀ (TT : list LeanCat.{ℓ}^.obj)
      , LeanCat.{ℓ}^.obj
| [] := punit
| [T] := T
| (T :: TT) := T × ListProd TT

/-! #brief A fancy way of mapping through a ListProd.
-/
definition {ℓb ℓx ℓy} ListProd.map
    {Ba : Type ℓb} {Tx : Ba → Type ℓx} {Ty : Ba → Type ℓy}
    (f : ∀ (b : Ba), Tx b → Ty b)
    : ∀ (BB : list Ba)
      , ListProd (list.map Tx BB)
      → ListProd (list.map Ty BB)
| [] _ := punit.star
| [Ba] x := f Ba x
| (Ba :: Ba₀ :: BB) (prod.mk x xx) := (f Ba x, @ListProd.map (Ba₀ :: BB) xx)

/-! #brief Projection from finite product type in LeanCat.
-/
definition ListProd.π
    : ∀ (TT : list LeanCat.{ℓ}^.obj)
        (n : fin (list.length TT))
        (x : ListProd TT)
      , list.get TT n
| [] n x := fin.zero_elim n
| [T] (fin.mk 0 ω0) X := X
| [T] (fin.mk (nat.succ n) ωn) X := false.rec _ begin cases ωn, cases a end
| (T :: T₁ :: TT) (fin.mk 0 ω0) X := X^.fst
| (T :: T₁ :: TT) (fin.mk (nat.succ n) ωn) X := ListProd.π (T₁ :: TT) { val := n, is_lt := nat.lt_of_succ_lt_succ ωn } X^.snd

/-! #brief Enumerating a map into a finite product.
-/
definition ListProd.univ
    : ∀ (TT : list LeanCat.{ℓ}^.obj)
        (S : LeanCat.{ℓ}^.obj)
        (f : ∀ (n : ℕ)
               (ωn : n < list.length TT)
             , S → list.get TT { val := n, is_lt := ωn })
      , S → ListProd TT
| [] S f s := punit.star
| [T] S f s := f 0 (fin_of 0)^.is_lt s
| (T :: T₁ :: TT) S f s
:= ( f 0 (fin_of 0)^.is_lt s
   , ListProd.univ (T₁ :: TT) S (λ n ωn s', f (nat.succ n) (nat.succ_lt_succ ωn) s') s
   )

/-! #brief Factoring property of the universal map.
-/
definition ListProd.univ.factor
    : ∀ {TT : list LeanCat.{ℓ}^.obj}
        {S : LeanCat.{ℓ}^.obj}
        {f : ∀ (n : ℕ)
               (ωn : n < list.length TT)
             , S → list.get TT { val := n, is_lt := ωn }}
        {n : ℕ} {ωn : n < list.length TT}
        {s : S}
      , f n ωn s = ListProd.π TT
                    { val := n, is_lt := ωn }
                    (ListProd.univ TT S f s)
| [] S f n ωn s := by cases ωn
| [T] S f 0 ω0 s := rfl
| [T] S f (nat.succ n) ωn s := false.rec _ begin cases ωn, cases a end
| (T :: T₁ :: TT) S f 0 ω0 s := rfl
| (T :: T₁ :: TT) S f (nat.succ n) ωn s
:= begin
     refine eq.trans _ (@ListProd.univ.factor (T₁ :: TT) S _ n _ s),
     trivial
   end

/-! #brief LeanCat has all finite products.
-/
instance LeanCat.HasFinProduct (factor : list LeanCat.{ℓ}^.obj)
    : HasFinProduct LeanCat factor
:= HasProduct.show LeanCat (list.get factor)
    (ListProd factor)
    (ListProd.π factor)
    (λ T f, ListProd.univ factor T (λ n ωn, f { val := n, is_lt := ωn }))
    (λ T f n
      , begin
          apply funext, intro t,
          cases n with n ωn,
          refine eq.trans _ (ListProd.univ.factor),
          trivial
        end)
    (λ T f h ωh
      , begin
          assert ωf : f = λ n t, ListProd.π factor n (h t),
          { apply funext @ωh },
          subst ωf,
          apply funext, intro t,
          induction factor with T factor rec,
          { apply punit.uniq },
          cases factor with T₁ factor,
          { trivial },
          { apply prod.eq,
            { trivial },
            { refine eq.trans _ (rec (λ t, (h t)^.snd) _),
              { trivial },
              { intro n, trivial }
            }
          }
        end)

/-! #brief LeanCat has all finite products.
-/
instance LeanCat.HasAllFinProducts
    : HasAllFinProducts LeanCat.{ℓ}
:= { has_product := LeanCat.HasFinProduct
   }

/- -----------------------------------------------------------------------
Co-products.
----------------------------------------------------------------------- -/

/-! #brief LeanCat has all co-products.
-/
instance LeanCat.HasCoProduct
    {A : Type ℓ'} (factor : A → LeanCat.{max ℓ ℓ'}^.obj)
    : HasCoProduct LeanCat.{max ℓ ℓ'} factor
:= HasCoProduct.show LeanCat factor
    (Σ (a : A), factor a)
    (sigma.mk)
    (λ T f af, f af^.fst af^.snd)
    (λ T f a, rfl)
    (λ T f h ωh
      , begin
          apply funext, intro af,
          cases af with a f,
          rw ωh,
          trivial
        end)

/-! #brief LeanCat has all co-products.
-/
instance LeanCat.HasAllCoProducts
    : HasAllCoProducts.{ℓ'} LeanCat.{max ℓ ℓ'}
:= { has_coproduct := @LeanCat.HasCoProduct
   }

/-! #brief Finite sum type in LeanCat.
-/
definition ListSum
    : ∀ (TT : list LeanCat.{ℓ}^.obj)
      , LeanCat.{ℓ}^.obj
| [] := pempty
| [T] := T
| (T :: TT) := sum T (ListSum TT)

/-! #brief A fancy way of mapping through a ListSum.
-/
definition {ℓb ℓx ℓy} ListSum.map
    {Ba : Type ℓb} {Tx : Ba → Type ℓx} {Ty : Ba → Type ℓy}
    : ∀ (BB : list Ba)
        (f : ∀ (n : ℕ) (ωn : n < list.length BB)
             , Tx (list.get BB {val := n, is_lt := ωn}) → Ty (list.get BB {val := n, is_lt := ωn}))
      , ListSum (list.map Tx BB)
      → ListSum (list.map Ty BB)
| [] f e := by cases e
| [Ba] f x := f 0 fin.zero^.is_lt x
| (Ba :: Ba₀ :: BB) f (sum.inl x) := sum.inl (f 0 fin.zero^.is_lt x)
| (Ba :: Ba₀ :: BB) f (sum.inr xx)
:= sum.inr (ListSum.map (Ba₀ :: BB)
             (λ n ωn, f (nat.succ n) (nat.succ_le_succ ωn))
            xx)

/-! #brief Inclusion into finite sum type in LeanCat.
-/
definition ListSum.ι
    : ∀ (TT : list LeanCat.{ℓ}^.obj)
        (n : fin (list.length TT))
        (x : list.get TT n)
      , ListSum TT
| [] n x := fin.zero_elim n
| [T] (fin.mk 0 ω0) x := x
| [T] (fin.mk (nat.succ n) ωn) x := false.rec _ begin cases ωn, cases a end
| (T :: T₁ :: TT) (fin.mk 0 ω0) x := sum.inl x
| (T :: T₁ :: TT) (fin.mk (nat.succ n) ωn) x
:= sum.inr (ListSum.ι (T₁ :: TT) { val := n, is_lt := nat.lt_of_succ_lt_succ ωn } x)

/-! #brief Enumerating a map out of a finite sum.
-/
definition ListSum.univ
    : ∀ (TT : list LeanCat.{ℓ}^.obj)
        (S : LeanCat.{ℓ}^.obj)
        (f : ∀ (n : ℕ)
               (ωn : n < list.length TT)
             , list.get TT { val := n, is_lt := ωn } → S)
      , ListSum TT → S
| [] S f e := by cases e
| [T] S f s := f 0 (fin_of 0)^.is_lt s
| (T :: T₁ :: TT) S f (sum.inl s)
:= f 0 (fin_of 0)^.is_lt s
| (T :: T₁ :: TT) S f (sum.inr s)
:= ListSum.univ (T₁ :: TT) S (λ n ωn s', f (nat.succ n) (nat.succ_lt_succ ωn) s') s

/-! #brief Factoring property of the universal map.
-/
definition ListSum.univ.factor
    : ∀ {TT : list LeanCat.{ℓ}^.obj}
        {S : LeanCat.{ℓ}^.obj}
        {f : ∀ (n : ℕ)
               (ωn : n < list.length TT)
             , list.get TT { val := n, is_lt := ωn } → S}
        {n : ℕ} {ωn : n < list.length TT}
        {s : list.get TT { val := n, is_lt := ωn }}
      , f n ωn s = ListSum.univ TT S f
                     (ListSum.ι TT { val := n, is_lt := ωn } s)
| [] S f n ωn s := by cases ωn
| [T] S f 0 ω0 s := rfl
| [T] S f (nat.succ n) ωn s := false.rec _ begin cases ωn, cases a end
| (T :: T₁ :: TT) S f 0 ω0 s := rfl
| (T :: T₁ :: TT) S f (nat.succ n) ωn s
:= begin
     refine eq.trans _ (@ListSum.univ.factor (T₁ :: TT) S _ n _ s),
     trivial
   end

/-! #brief LeanCat has all finite products.
-/
instance LeanCat.HasFinCoProduct (factor : list LeanCat.{ℓ}^.obj)
    : HasFinCoProduct LeanCat factor
:= HasCoProduct.show LeanCat (list.get factor)
    (ListSum factor)
    (ListSum.ι factor)
    (λ T f, ListSum.univ factor T (λ n ωn, f { val := n, is_lt := ωn }))
    (λ T f n
      , begin
          apply funext, intro t,
          cases n with n ωn,
          refine eq.trans _ (ListSum.univ.factor),
          trivial
        end)
    (λ T f h ωh
      , begin
          assert ωf : f = λ n t, h (ListSum.ι factor n t),
          { apply funext @ωh },
          subst ωf,
          apply funext, intro t,
          induction factor with T factor rec,
          { cases t },
          cases factor with T₁ factor,
          { trivial },
          { cases t,
            { trivial },
            { refine eq.trans _ (rec (λ a, (h (sum.inr a))) _ _),
              { trivial },
              { intro n, trivial }
            }
          }
        end)

/-! #brief LeanCat has all finite products.
-/
instance LeanCat.HasAllFinCoProducts
    : HasAllFinCoProducts LeanCat.{ℓ}
:= { has_coproduct := LeanCat.HasFinCoProduct
   }

/- -----------------------------------------------------------------------
Pullbacks.
----------------------------------------------------------------------- -/

/-! #brief LeanCat has all pullbacks.
-/
instance LeanCat.HasPullback
    {base : LeanCat.{ℓ}^.obj} {factor : list LeanCat.{ℓ}^.obj}
    {T : LeanCat.{ℓ}^.obj}
    (maps : @HomsIn LeanCat (base :: factor) T)
    : HasPullback LeanCat maps
:= HasPullback.show LeanCat.{ℓ} maps
    { p : finproduct LeanCat (base :: factor)
      // ∀ (n : fin (list.length (base :: factor)))
         , HomsIn.get maps (fin_of 0) (finproduct.π LeanCat (base :: factor) (fin_of 0) p)
            = HomsIn.get maps n (finproduct.π LeanCat (base :: factor) n p)
    }
    (λ p, HomsIn.get maps (fin_of 0) (finproduct.π LeanCat (base :: factor) (fin_of 0) p^.val))
    (HomsOut.comp (finproduct.cone LeanCat (base :: factor))^.Proj (λ p, p^.val))
    begin
      cases maps with _ m_base _ maps,
      -- apply HomsList.eq,
      -- { trivial },
      -- induction maps with _ m₁ _ maps rec,
      -- { trivial },
      exact sorry
    end
    sorry
    sorry
    sorry

instance LeanCat.HasAllPullbacks
    : HasAllPullbacks LeanCat.{ℓ}
:= { has_pullback
      := λ base factor T maps
         , LeanCat.HasPullback maps
   }

/-! #brief A handy wrapper.
-/
definition LeanCat.BaseChangeFun
    {X Y : LeanCat.{ℓ}^.obj}
    (f : LeanCat.{ℓ}^.hom X Y)
    : Fun (OverCat LeanCat Y) (OverCat LeanCat X)
:= @BaseChangeFun LeanCat X Y f
     (HasAllPullbacks.HasPullbacksAlong LeanCat f)

/- -----------------------------------------------------------------------
Products in OverCat LeanCat.
----------------------------------------------------------------------- -/

/-! #brief OverCat LeanCat has finite products.
-/
instance LeanCat.Over.HasFinProduct
    (T₀ : LeanCat.{ℓ}^.obj)
    (factor : list (OverCat LeanCat T₀)^.obj)
    : HasFinProduct (OverCat LeanCat T₀) factor
:= OverCat.HasFinProduct LeanCat.{ℓ} T₀ factor

/- -----------------------------------------------------------------------
Exponentials.
----------------------------------------------------------------------- -/

/-! #brief LeanCat has exponential objects.
-/
instance LeanCat.HasExp (X Y : LeanCat.{ℓ}^.obj)
    : @HasExp LeanCat X Y
:= { exp := Y → X
   , ev
      := λ exp_Y_HasFinProduct p
         , let f := @finproduct.π _ _ exp_Y_HasFinProduct (@fin_of 1 0)
        in let y := @finproduct.π _ _ exp_Y_HasFinProduct (@fin_of 0 1)
        in f p (y p)
   , univ
      := λ Z Z_Y_HasFinProduct e z y
         , e (finproduct.iso (LeanCat.HasFinProduct [Z, Y]) Z_Y_HasFinProduct (z, y))
   , factor := λ exp_Y_HasFinProduct Z Z_Y_HasFinProduct e
               , begin
                   apply funext, intro zy,
                   rw LeanCat.simp_circ,
                   dsimp,
                   exact sorry
                 end
   , uniq := λ exp_Y_HasFinProduct Z Z_Y_HasFinProduct e u ωu
             , begin
                 apply funext, intro z,
                 apply funext, intro y,
                 rw ωu,
                 exact sorry
               end
   }

/- -----------------------------------------------------------------------
Exponentials in OverCat LeanCat.
----------------------------------------------------------------------- -/

/-! #brief LeanCat has exponential objects.
-/
definition LeanCat.Over.exp
      (T₀ : LeanCat.{ℓ}^.obj)
      (T S : (OverCat LeanCat T₀)^.obj)
      : OverObj LeanCat.{ℓ} T₀
:= { obj := Σ (t₀ : T₀)
            , {s : S^.dom // S^.hom s = t₀}
              → {t : T^.obj // T^.hom t = t₀}
   , hom := sigma.fst
   }

/-! #brief LeanCat has exponential objects.
-/
instance LeanCat.Over.HasExp
      (T₀ : LeanCat.{ℓ}^.obj)
      (X Y : (OverCat LeanCat T₀)^.obj)
    : @HasExp (OverCat LeanCat T₀) X Y
:= { exp := LeanCat.Over.exp T₀ X Y
   , ev
      := λ p_HasProd
         , { hom := λ p, let f := (@finproduct.π (OverCat LeanCat T₀) [LeanCat.Over.exp T₀ X Y, Y] p_HasProd (@fin_of 1 0))^.hom p
                      in let y := (@finproduct.π (OverCat LeanCat T₀) [LeanCat.Over.exp T₀ X Y, Y] p_HasProd (@fin_of 0 1))^.hom p
                      in (f^.snd { val := y, property := sorry })^.val
           , triangle := sorry
           }
   , univ
      := λ A A_HasProd f
         , let a_y : ∀ (a : A^.obj)
                       (y : {s // Y^.hom s = A^.hom a})
                     , OverObj.dom (finproduct (OverCat LeanCat T₀) [A, Y])
                   := λ a y
                      , { val := (a, y^.val)
                        , property
                           := begin
                                intro nωn, cases nωn with n ωn,
                                cases n with n, { trivial },
                                cases n with n, { apply eq.symm y^.property },
                                apply nat.not_lt_add_right n 2 ωn
                              end
                        }
        in let a_y' := λ a y, ((finproduct.iso (LeanCat.Over.HasFinProduct T₀ [A, Y]) A_HasProd)^.hom (a_y a y))
        in { hom
              := λ a
                 , ⟨ A^.hom a
                   , λ y, { val := f^.hom (a_y' a y)
                          , property := begin
                                          refine eq.trans (congr_fun (eq.symm f^.triangle) (a_y' a y)) _,
                                          exact sorry
                                        end
                          }
                   ⟩
         , triangle := sorry
         }
   , factor := λ A p_HasProd A_HasProd e
               , sorry
   , uniq := λ exp_Y_HasFinProduct Z Z_Y_HasFinProduct e u ωu
             , sorry
   }

/-! #brief OverCat LeanCat has all exponentials.
-/
instance LeanCat.Over.HasAllExp
    (T₀ : LeanCat.{ℓ}^.obj)
    : @HasAllExp (OverCat LeanCat T₀)
:= { has_exp := LeanCat.Over.HasExp T₀
   }

/-! #brief LeanCat has exponentials in all slices.
-/
instance LeanCat.HasAllLocalExp
    : HasAllLocalExp LeanCat.{ℓ}
:= { has_exp := LeanCat.Over.HasExp
   }

/- -----------------------------------------------------------------------
Subobject classifiers.
----------------------------------------------------------------------- -/

/-! #brief Axiom of choice gives LeanCat a subobject classifier.
-/
noncomputable instance LeanCat.HasSubobjClass
    : HasSubobjClass LeanCat.{ℓ}
:= HasSubobjClass.show
    (λ LeanCat_HasFinal, Lean.LevelMax Prop)
    (λ LeanCat_HasFinal, λ u, Lean.LevelMax.lift true)
    (λ LeanCat_HasFinal U X m m_Monic, λ x, Lean.LevelMax.lift (∃ (u : U), m u = x))
    (λ LeanCat_HasFinal U X V m m_Monic h ωh x
     , let u₀ : ∃ (u : U), m u = h x
             := begin
                  apply of_iff_true,
                  apply eq.to_iff,
                  apply Lean.LevelMax.lift.inj,
                  apply congr_fun ωh
                end in
       let u : ∃! (u : U), h x = m u
            := exists.elim u₀
                (λ u ωu
                 , exists_unique.intro u (eq.symm ωu)
                    (λ u' ωu', LeanCat.Monic.inj m_Monic
                                (eq.symm (eq.trans ωu ωu'))))
       in unique_choice u)
    (λ LeanCat_HasFinal U X m m_Monic
     , begin
         apply funext, intro u,
         apply congr_arg Lean.LevelMax.lift,
         apply iff.to_eq,
         apply iff_true_intro,
         apply exists.intro u,
         trivial
       end)
    (λ LeanCat_HasFinal U V X m m_Monic h ωh
     , begin
         apply funext, intro v,
         dsimp, unfold LeanCat SortCat, dsimp,
         generalize (of_iff_true (eq.to_iff (Lean.LevelMax.lift.inj (congr_fun ωh v)))) ω,
         intro ω, cases ω with u ωu,
         refine eq.trans (eq.symm _) (eq.symm (congr_arg m unique_choice.simp)),
         exact ωu
       end)
    (λ LeanCat_HasFinal U V X m m_Monic h ωh
     , begin
         apply funext, intro v,
         generalize (of_iff_true (eq.to_iff (Lean.LevelMax.lift.inj (congr_fun ωh v)))) ω,
         intro ω, cases ω with u ωu,
         refine eq.trans _ (eq.symm unique_choice.simp),
         apply LeanCat.Monic.inj m_Monic,
         exact eq.symm ωu
       end)
    (λ LeanCat_HasFinal U X m m_Monic char' char'_IsPullback
     , sorry)

--    , char_uniq
--       := λ LeanCat_HasFinal U X m m_Monic char' ωchar'
--          , let char'' : X → Prop
--                      := λ x, Lean.LevelMax.cases_on (char' x) (λ P, P)
--         in begin
--              apply funext, intro x,
--              assert ωchar'' : char' x = Lean.LevelMax.lift (Lean.LevelMax.cases_on (char' x) (λ P, P)),
--              { generalize (char' x) char'_x,
--                intro char'_x, cases char'_x,
--                trivial,
--              },
--              refine eq.trans ωchar'' (congr_arg Lean.LevelMax.lift _),
--              apply iff.to_eq,
--              apply iff.intro,
--              { intro ωP_x, exact sorry
--              },
--              { intro ωu, cases ωu with u ωu,
--                subst ωu,
--                -- true because ωchar' implies char' (m u) = Lean.LevelMax.lift true.
--                exact sorry
--              }
--            end
--    }

/- -----------------------------------------------------------------------
Natural numbers object.
----------------------------------------------------------------------- -/

/-! #brief LeanCat has an NNO.
-/
instance LeanCat.HasNNO
    : @HasNNO LeanCat.{ℓ} LeanCat.HasFinal
:= { nn := Lean.LevelMax ℕ
   , zero := λ u, Lean.LevelMax.lift 0
   , succ := Lean.LevelMax.map nat.succ
   , univ := λ A z s n, nat.rec_on (Lean.LevelMax.unlift n)
                         (z punit.star)
                         (λ n' a, s a)
   , comm_zero
      := λ A z s
         , begin
             apply funext, intro u, cases u,
             trivial
           end
   , comm_succ
      := λ A z s
         , begin
             apply funext, intro n, cases n with n,
             induction n with n rec,
             { trivial },
             { apply congr_arg s,
               apply rec
             }
           end
   , uniq
      := λ A z s u' ωzero ωsucc
         , begin
             apply funext, intro n, cases n with n,
             induction n with n rec,
             { rw ωzero, trivial },
             { refine eq.trans (eq.symm (congr_fun ωsucc (Lean.LevelMax.lift n))) _,
               apply congr_arg s rec
             }
           end
   }

end qp


import tactic.transport
import order.bounded_order
import algebra.lie.basic

-- We verify that `transport` can move a `semiring` across an equivalence.
-- Note that we've never even mentioned the idea of addition or multiplication to `transport`.
def semiring.map {α : Type} [semiring α] {β : Type} (e : α ≃ β) : semiring β :=
by transport using e

-- Indeed, it can equally well move a `semilattice_sup`.
def sup.map {α : Type} [semilattice_sup α] {β : Type} (e : α ≃ β) : semilattice_sup β :=
by transport using e

-- Verify definitional equality of the new structure data.
example {α : Type} [semilattice_sup α] {β : Type} (e : α ≃ β) (x y : β) :
begin
  haveI := sup.map e,
  exact (x ≤ y) = (e.symm x ≤ e.symm y),
end :=
rfl

-- Below we verify in more detail that the transported structure for `semiring`
-- is definitionally what you would hope for.

inductive mynat : Type
| zero : mynat
| succ : mynat → mynat

def mynat_equiv : ℕ ≃ mynat :=
{ to_fun := λ n, nat.rec_on n mynat.zero (λ n, mynat.succ),
  inv_fun := λ n, mynat.rec_on n nat.zero (λ n, nat.succ),
  left_inv := λ n, begin induction n, refl, exact congr_arg nat.succ n_ih, end,
  right_inv := λ n, begin induction n, refl, exact congr_arg mynat.succ n_ih, end }

@[simp] lemma mynat_equiv_apply_zero : mynat_equiv 0 = mynat.zero := rfl
@[simp] lemma mynat_equiv_apply_succ (n : ℕ) :
  mynat_equiv (n + 1) = mynat.succ (mynat_equiv n) := rfl
@[simp] lemma mynat_equiv_symm_apply_zero : mynat_equiv.symm mynat.zero = 0:= rfl
@[simp] lemma mynat_equiv_symm_apply_succ (n : mynat) :
  mynat_equiv.symm (mynat.succ n) = (mynat_equiv.symm n) + 1 := rfl

instance semiring_mynat : semiring mynat :=
semiring.map mynat_equiv

lemma mynat_add_def (a b : mynat) : a + b = mynat_equiv (mynat_equiv.symm a + mynat_equiv.symm b) :=
rfl

-- Verify that we can do computations with the transported structure.
example :
  (mynat.succ (mynat.succ mynat.zero)) + (mynat.succ mynat.zero) =
    (mynat.succ (mynat.succ (mynat.succ mynat.zero))) :=
rfl

lemma mynat_zero_def : (0 : mynat) = mynat_equiv 0 :=
rfl

lemma mynat_one_def : (1 : mynat) = mynat_equiv 1 :=
rfl

lemma mynat_mul_def (a b : mynat) : a * b = mynat_equiv (mynat_equiv.symm a * mynat_equiv.symm b) :=
rfl

example : (3 : mynat) + (7 : mynat) = (10 : mynat) :=
rfl

example : (2 : mynat) * (2 : mynat) = (4 : mynat) :=
rfl

example : (3 : mynat) + (7 : mynat) * (2 : mynat) = (17 : mynat) :=
rfl

example : (2 : ℕ) • (3 : mynat) = (6 : mynat) :=
rfl

example : (3 : mynat) ^ 2 = (9 : mynat) :=
rfl


example (P Q R S T U: Type)
(p : P)
(h : P → Q)
(i : Q → R)
(j : Q → T)
(k : S → T)
(l : T → U)
: U :=
begin
apply l,
apply j,
apply h,
exact p,
end


variable {α : Type*}

def is_prefix (l₁ : list α) (l₂ : list α) : Prop :=
  ∃ t, l₁ ++ t = l₂

def list_has_le : has_le (list α) := ⟨is_prefix⟩

section
  local attribute [instance] list_has_le

  theorem list.is_prefix_refl (l : list α) : l ≤ l :=
    ⟨[], by simp⟩
end

-- error:
-- theorem bar (l : list α) : l ≤ l :=
--   ⟨[], by simp⟩