import SciLean.Prelude
import SciLean.Mathlib.Data.Enumtype
-- import SciLean.Algebra
import SciLean.Core

def List.bubblesort [LT α] [DecidableRel (. < . : α → α → Prop)] (l : List α) : {l' : List α // l.length = l'.length} :=
  match l with
  | [] => ⟨[], rfl⟩
  | x :: xs =>
    match xs.bubblesort with
    | ⟨[], h⟩ => ⟨[x], by simp[h]⟩
    | ⟨y :: ys, h⟩ =>
      if y < x then
        have : Nat.succ (length ys) < Nat.succ (length xs) := by rw [h, List.length_cons]; apply Nat.lt_succ_self
        let ⟨zs, he⟩ := bubblesort (x :: ys)
        ⟨y :: zs, by simp[h, ← he]⟩
      else
        ⟨x :: y :: ys, by simp[h]⟩
decreasing_by sorry_proof
-- termination_by _ => l.length  -- clashes with Mathlib.Data.List.Basic

namespace SciLean

/-- Prism

  A prism is anything that can be created from a point and two operations: cone and product. This way we can basic geometric primitives like triangles, squares, pyramids, n-simplices, n-cubes etc.

```
    *   = point

    *
   / \  = cone *--*
  *---*

  *--*          *
  |  |  = prod  |   *--*
  *--*          *
```

  segment  = cone point
  triangle = cone segment
  square   = prod segment segment
  cube     = prod segment square
  tet      = cone triangle
  pyramid  = cone square

  n-simples = coneⁿ point
  n-cube    = (prod segment)ⁿ⁻¹ segment

  Non-uniqueness
  --------------

  TODO: This definition needs to be factored

  Cartain prisms have multiple different representations. For example `cube = prod segment square ≈ prod square segment`. This is the reason this inductive type is only a representation and not the final prism.

-/
inductive PrismRepr where
  | point : PrismRepr
  | cone (P : PrismRepr) : PrismRepr
  | prod (P Q : PrismRepr) : PrismRepr
with
  /-- Dimension of a prism -/
  @[computed_field]
  dim : (P : PrismRepr) → Nat
  | .point => 0
  | .cone P' => P'.dim + 1
  | .prod P' Q' => P'.dim + Q'.dim
deriving DecidableEq, Inhabited

section PrismExamples
  open PrismRepr

  private def segment  := cone point
  private def triangle := cone segment
  private def square   := prod segment segment
  private def tet      := cone triangle
  private def cube     := prod segment square
  private def pyramid  := cone square
  private def prism    := prod segment triangle

  private def ncube : (dim : Nat) → PrismRepr
  | 0 => point
  | 1 => segment
  | (n+1) => prod segment (ncube n)

  private def ntet : (dim : Nat) → PrismRepr
  | 0 => point
  | (n+1) => cone (ntet n)

end PrismExamples

namespace PrismRepr

  /-- Number of `n`-dimensional faces of prism `P` -/
  def faceCount (n : Nat) (P : PrismRepr) : Nat :=
    match P with
    | point => if n == 0 then 1 else 0
    | cone P =>
      match n with
      | 0   => (P.faceCount 0) + 1
      | n+1 => P.faceCount n + P.faceCount (n+1)
    | prod P Q => ∑ i : Fin (n+1), (P.faceCount i.1) * (Q.faceCount (n-i.1))

  abbrev pointCount (P : PrismRepr) : Nat := P.faceCount 0
  abbrev edgeCount  (P : PrismRepr) : Nat := P.faceCount 1

  instance : Mul PrismRepr := ⟨λ P Q => P.prod Q⟩

  -- TODO: Clean this up, it is a bit of a mess
  def toString : PrismRepr → String
  | point => "•"
  -- | cone point => "—"
  -- | cone (cone point) => "⃤"
  -- | prod (cone point) (cone point) => "⃞"
  | cone (prod P Q) => s!"• ∧ ({(prod P Q).toString})"
  | cone P => s!"• ∧ {P.toString}"
  | prod (cone P) (cone Q) => s!"({(cone P).toString}) × ({(cone Q).toString})"
  | prod (cone P) Q => s!"({(cone P).toString}) × {Q.toString}"
  | prod (prod P₁ P₂) Q => s!"({(prod P₁ P₂).toString}) × {Q.toString}"
  | prod P (cone Q) => s!"{P.toString} × ({(cone Q).toString})"
  | prod P Q => s!"{P.toString} × {Q.toString}"

  instance : ToString PrismRepr := ⟨λ P => P.toString⟩

/-- Ordering of prism representations

  1. Prism representations are ordered by their dimensions.

  2. When the dimensions are the same:
    2a. `cone P` is always smaller then `prod Q₁ Q₂`.
    2b. For `prod P₁ P₂` and `prod Q₁ Q₂` we use lexicographical
      ordering of (P₁, P₂) and (Q₁, Q₂)
      i.e. we want: segment * square < square * segment

-/
  def ord (P Q : PrismRepr) : Ordering :=
    match P, Q with
    | point, point => .eq
    | point, _ => .lt
    | cone _, point => .gt
    | cone P, cone Q => ord P Q
    | cone P, prod _ _ =>
      if (cone P).dim ≤ Q.dim
      then .lt
      else .gt
    | prod _ _, point => .gt
    | prod P₁ P₂, cone Q =>
      if P₁.dim + P₂.dim < (cone Q).dim
      then .lt
      else .gt
    | prod P₁ P₂, prod Q₁ Q₂ =>
      match compare P.dim Q.dim with
      | .lt => .lt
      | .gt => .gt
      | .eq =>
        match ord P₁ Q₁ with
        | .lt => .lt
        | .gt => .gt
        | .eq => ord P₂ Q₂

  instance : LT PrismRepr := ⟨λ P Q => ord P Q = .lt⟩
  instance : LE PrismRepr := ⟨λ P Q => ord P Q ≠ .gt⟩

  instance : DecidableEq Ordering :=
    λ x y =>
    match x, y with
    | .lt, .lt => isTrue (by rfl)
    | .gt, .gt => isTrue (by rfl)
    | .eq, .eq => isTrue (by rfl)
    | _, _ => isFalse (by sorry_proof)

  instance (P Q : PrismRepr) : Decidable (P < Q) :=
    if h : ord P Q = .lt then
      isTrue h
    else
      isFalse h

  instance (P Q : PrismRepr) : Decidable (P ≤ Q) :=
    if h : ord P Q = .gt then
      isFalse (by simp[LE.le]; assumption)
    else
      isTrue (by simp[LE.le]; assumption)

/-- PrismRepr is in canonical form iff
  1. it is a point
  2. it is a cone of a prism in canonical form
  3. is is a product of cone prisms
     (c P₁) × ... × (c Pₙ)
     the product is right associated, non-increasing and every prism is in canonical form
-/
  inductive IsCanonical : PrismRepr → Prop where
  | point : IsCanonical point
  | cone (P) (h : IsCanonical P) : IsCanonical (cone P)
  | cone_prod {P Q : PrismRepr} -- Product of two cones
      (hP : IsCanonical P) (hQ : IsCanonical Q) (hOrd : P ≤ Q)
      : IsCanonical (prod (cone P) (cone Q))
  | ord_prod {P Q S : PrismRepr} -- product has to be ordered and right associated
      (hP : IsCanonical P)
      (hCan : IsCanonical (prod (cone Q) S))
      (hOrd : P ≤ Q)
      : IsCanonical (prod (cone P) (prod (cone Q) S))

  instance isCanonical (P : PrismRepr) : Decidable (IsCanonical P) :=
    match P with
    | point => isTrue (.point)
    | cone P =>
      match isCanonical P with
      | isTrue h => isTrue (.cone P h)
      | isFalse h => isFalse (by intro q; cases q; rename_i q; apply (h q))
    | prod point Q => isFalse (by intro h; cases h)
    | prod (cone P) point => isFalse (by intro h; cases h)
    | prod (cone P) (cone Q) =>
      match isCanonical P, isCanonical Q with
      | isTrue hP, isTrue hQ =>
        if hOrd : P ≤ Q
        then isTrue (.cone_prod hP hQ hOrd)
        else isFalse (by intro h; cases h; rename_i h; apply (hOrd h))
      | isFalse hP, _ => isFalse (by intro h; cases h; rename_i h _ _; apply (hP h))
      | _, isFalse hQ => isFalse (by intro h; cases h; rename_i _ h _; apply (hQ h))
    | prod (cone P) (prod point S) => isFalse (by intro h; cases h)
    | prod (cone P) (prod (cone Q) S) =>
      match isCanonical P with
      | isTrue hP  =>
        if hOrd : P ≤ Q then
          match isCanonical (prod (cone Q) S) with
          | isTrue hCan => isTrue (.ord_prod hP hCan hOrd)
          | isFalse hCan => isFalse (by intro h; cases h; rename_i h; apply (hCan h))
        else
          isFalse (by intro h; cases h; rename_i _ h _; apply (hOrd h))
      | isFalse hP => isFalse (by intro h; cases h; rename_i h _ _ ; apply (hP h))
    | prod (cone P) (prod (prod Q₁ Q₂) S) => isFalse (by intro h; cases h)
    | prod (prod _ _) _ => isFalse (by intro h; cases h)

  -- TODO: Prove termination
  -- This should be a bubble sort, for termination have a look at:
  -- https://leanprover.zulipchat.com/#narrow/stream/270676-lean4/topic/Termination.20of.20bubble.20sort
  def toCanonical : PrismRepr → PrismRepr
  | point => point
  | cone P => cone P.toCanonical
  | prod point P => P.toCanonical
  | prod (cone P) Q =>
    match Q.toCanonical with
    | point => cone P.toCanonical
    | cone Q =>
      let P := P.toCanonical
      if P ≤ Q
      then prod (cone P) (cone Q)
      else prod (cone Q) (cone P)
    | prod (cone Q₁) Q₂ =>
      if P ≤ Q₁
      then prod (cone P) (prod (cone Q₁) Q₂)
      else prod (cone Q₁) (prod (cone P) Q₂).toCanonical
    | prod _ _ => unreachable!
  | prod P Q =>
    match P.toCanonical with
    | point => Q.toCanonical
    | cone P => (prod (cone P) Q).toCanonical
    -- | prod (cone P₁) P₂ => (prod (cone P₁) (prod P₂ Q)) -- .toCanonical
    | prod P₁ P₂ => (prod P₁ (prod P₂ Q)).toCanonical
    -- | prod _ _ => unreachable!
  decreasing_by sorry_proof

  example : ((segment * segment) * segment |>.toCanonical )
            =
            (segment * (segment * segment ))
            := by native_decide -- by  rfl -- TODO: Make this provable by rfl!!!

  /-- toCanonical truly producees prism in canonical form -/
  @[simp]
  theorem toCanonical_IsCanonical (P : PrismRepr) : P.toCanonical.IsCanonical := sorry_proof
  /-- toCanonical preserves dimension -/
  @[simp]
  theorem toCanonical_dim (P : PrismRepr) : P.toCanonical.dim = P.dim := sorry_proof

  @[simp]
  theorem IsCanonical_point : point.IsCanonical := IsCanonical.point
  @[simp]
  theorem IsCanonical_base_of_cone (P : PrismRepr) (h : P.cone.IsCanonical) : P.IsCanonical := sorry_proof
  @[simp]
  theorem IsCanonical_cone (P : PrismRepr) (h : P.IsCanonical) : P.cone.IsCanonical := IsCanonical.cone P h
  @[simp]
  theorem IsCanonical_prod_fst (P Q : PrismRepr) (h : (P.prod Q).IsCanonical) : P.IsCanonical := sorry_proof
  @[simp]
  theorem IsCanonical_prod_snd (P Q : PrismRepr) (h : (P.prod Q).IsCanonical) : Q.IsCanonical := sorry_proof

  section ToCanonicalTests

    example : IsCanonical square := by native_decide
    example : ¬(prod point square).IsCanonical := by native_decide
    example : (prod point square).toCanonical = square := by native_decide

    example : ¬(prod triangle segment).IsCanonical := by native_decide
    example : (prod triangle segment).toCanonical = prism := by native_decide

    example : (prod (cone square) (cone triangle)).toCanonical
              =
              (prod (cone triangle) (cone square)) := by native_decide

  end ToCanonicalTests

end PrismRepr

/--
  The type `Face P` represends faces of a prism `P`

  Point prism can have only one face, the point itself.

  Cone prisms have three types of faces.
    1. the tip
    2. sides of the code
    3. faces of the base prism

  Product prisms have faces are created by products of

  Categorical perspective
  -----------------------

  A face is a inclusion of a prism `F` into a prism `P`. For a face `f : Face P`, we can obtain `F` by `f.toPrism`.

  Then we can thin about `f` as a morphism `F → P` in the `Prism` category.

  Retation to Semi-Semplicial sets
  --------------------------------

  This represents strictly increasing mapping from one Prism to another.

  TODO: expand on this
-/
inductive FaceRepr : Type where
  | point : FaceRepr
  | tip (P : PrismRepr) : FaceRepr
  | cone (f : FaceRepr) : FaceRepr
  | base (f : FaceRepr) : FaceRepr
  | prod (f g : FaceRepr)  : FaceRepr
with

  /-- Converts Face to Prism -/
  @[computed_field]
  toPrism : FaceRepr → PrismRepr
  | .point => .point
  | .tip _ => .point
  | .cone f => f.toPrism.cone
  | .base f => f.toPrism
  | .prod f g => f.toPrism.prod g.toPrism

  /-- Face `f` is a face of the prism `f.ofPrism` -/
  @[computed_field]
  ofPrism : FaceRepr → PrismRepr
  | .point => .point
  | .tip P => P.cone
  | .cone f => f.ofPrism.cone
  | .base f => f.ofPrism.cone
  | .prod f g => f.ofPrism.prod g.ofPrism
deriving DecidableEq, Inhabited

namespace FaceRepr

  def toString : FaceRepr → String
    | point => "•"
    | tip P => s!"(tip ({P}))"
    | cone f => s!"(cone {f.toString})"
    | base f => s!"(base {f.toString})"
    | prod f g => s!"({f.toString} × {g.toString})"

  instance : ToString FaceRepr := ⟨FaceRepr.toString⟩

  /-- Dimension of a face -/
  def dim (f : FaceRepr) : Nat := f.toPrism.dim

  /-- Isomorphism between faces of `P` and `P.toCanonical`. -/
  def toCanonical (f : FaceRepr) : FaceRepr :=
  match f with
  | .point => .point
  | .tip P => .tip P.toCanonical
  | .cone f => .cone f.toCanonical
  | .base f => .base f.toCanonical
  | .prod f g =>
    let f' := f.toCanonical
    match f' with
    | .point => g.toCanonical
    | .tip _ | .cone _ | .base _ =>
      let g' := g.toCanonical
      match g' with
      | .point => f'
      | .tip _ | .cone _ | .base _ =>
        if f'.ofPrism ≤ g'.ofPrism then .prod f' g' else .prod g' f'
      | .prod g₁' g₂' =>
        if f'.ofPrism ≤ g₁'.ofPrism
        then .prod f' (.prod g₁' g₂')
        else .prod g₁' (.prod f' g₂')
    | .prod f₁' f₂' =>
      let g' := (FaceRepr.prod f₂' g).toCanonical
      match g' with
      | .point => unreachable!
      | .tip _ | .cone _ | .base _ =>
        if f₁'.ofPrism ≤ g'.ofPrism then .prod f₁' g' else .prod g' f₁'
      | .prod g₁' g₂' =>
        if f₁'.ofPrism ≤ g₁'.ofPrism then .prod f₁' (.prod g₁' g₂') else .prod g₁' (.prod f₁' g₂')
  decreasing_by sorry_proof

  theorem toCanonical_ofPrism_IsCanonical (f : FaceRepr) : f.toCanonical.ofPrism.IsCanonical := sorry_proof
  theorem toCanonical_ofPrism (f : FaceRepr) : f.toCanonical.ofPrism = f.ofPrism.toCanonical := sorry_proof
  theorem toCanonical_dim (f : FaceRepr) : f.toCanonical.dim = f.dim := sorry_proof

  /-- Isomorphism between faces of `P.toCanonical` and `P`. -/
  def fromCanonical (f : FaceRepr) (P : PrismRepr) (_ : f.ofPrism = P.toCanonical) : FaceRepr :=
  match P, f with
  | .point, .point => .point
  | .point, _ => unreachable!

  | .cone P, .tip _ => .tip P
  | .cone P, .cone f' => .cone (f'.fromCanonical P sorry_proof)
  | .cone P, .base f' => .base (f'.fromCanonical P sorry_proof)
  | .cone _, _ => unreachable!

  | .prod .point P', f' =>
    FaceRepr.prod .point (f'.fromCanonical P' sorry_proof)

  | .prod (.cone P) Q, f' =>
    let Q' := Q.toCanonical
    match Q' with
    | .point =>
      .prod (f'.fromCanonical (.cone P) sorry_proof)
            (FaceRepr.point.fromCanonical Q sorry_proof)

    | .cone Q' =>
      match f' with
      | .prod f' g' =>
        let P' := P.toCanonical
        if P' ≤ Q' then
          .prod (f'.fromCanonical (.cone P) sorry_proof) (g'.fromCanonical Q sorry_proof)
        else
          .prod (g'.fromCanonical (.cone P) sorry_proof) (f'.fromCanonical Q sorry_proof)
      | _ => unreachable!

    | .prod (.cone Q₁') Q₂' =>
      match f' with
      | .prod f' g' =>
        let P' := P.toCanonical
        if P' ≤ Q₁' then
          .prod (f'.fromCanonical P.cone sorry_proof) (g'.fromCanonical Q sorry_proof)
        else
          let f'' := (f'.fromCanonical Q₁'.cone sorry_proof)
          let g'' := (g'.fromCanonical (.prod P.cone Q₂') sorry_proof)
          match g'' with
          | .prod g₁''' g₂''' =>
            .prod g₁''' ((FaceRepr.prod f'' g₂''').fromCanonical Q sorry_proof)
          | _ => unreachable!
      | _ => unreachable!
    | _ => unreachable!
  | .prod P Q, fg =>
    let P' := P.toCanonical
    match P' with
    | .point =>
      .prod (FaceRepr.point.fromCanonical P sorry_proof) (fg.fromCanonical Q sorry_proof)
    | .cone P' =>
      let fg' := fg.fromCanonical (.prod P'.cone Q) sorry_proof
      match fg' with
      | .prod f' g' => .prod (f'.fromCanonical P sorry_proof) g'
      | _ => unreachable!
    | .prod (.cone P₁') P₂' =>
        let fg' := fg.fromCanonical (.prod P₁'.cone (.prod P₂' Q)) sorry_proof
        match fg' with
        | .prod f₁' (.prod f₂' g') =>
          .prod ((FaceRepr.prod f₁' f₂').fromCanonical P sorry_proof) g'
        | _ => unreachable!
    | _ => unreachable!
  decreasing_by sorry_proof

  @[simp]
  theorem fromCanonical_ofPrism (f : FaceRepr) (P : PrismRepr) (h : f.ofPrism = P.toCanonical)
    : (fromCanonical f P h).ofPrism = P
  := sorry_proof

  @[simp]
  theorem fromCanonical_toPrism (f : FaceRepr) (P : PrismRepr) (h : f.ofPrism = P.toCanonical)
    : (fromCanonical f P h).toPrism.toCanonical = f.toPrism.toCanonical
  := sorry_proof

  @[simp]
  theorem fromCanonical_dim (f : FaceRepr) (P : PrismRepr) (h : f.ofPrism = P.toCanonical)
    : (fromCanonical f P h).dim = f.dim
  := sorry_proof

  @[simp]
  theorem ofPrism_toCanonical_toCanonical_ofPrism (f : FaceRepr)
    : f.toCanonical.ofPrism = f.ofPrism.toCanonical
  := sorry_proof

  @[simp]
  theorem toPrism_toCanonical_toCanonical_toPrism (f : FaceRepr)
    : f.toCanonical.toPrism.toCanonical = f.toPrism.toCanonical
  := sorry_proof

/--
Face of a face is a face. If we have a face `f` of prism `P` and a face `g` of prism `f.toPrism` then `g` is also a face of `P`.

It is a called "comp" because we can think of `f` and `g` as inclusions of a prism to a larger prism. Reinterpreting `g` as a face of `P` is just a composition of these inclusions.

---

Categorical perspective
-----------------------
This is morphism composition. The face `f` is a morphism `Q → P` and `g` is a morphism `S → Q` in `Prism` category, `comp f g : Face P` is just their composition.
-/

  def comp (f g : FaceRepr)
    (h : f.toPrism = g.ofPrism := by (first | rfl |simp))
    : FaceRepr
    :=
      match f, g, h with
      |   point,   point, _ => point
      |  tip P',   point, _ => tip P'
      | cone f',   tip _, _ => tip f'.ofPrism
      | cone f', cone g', _ =>
        cone (f'.comp g' (sorry_proof))
      | cone f', base g', _ =>
        base (f'.comp g' (sorry_proof))
      | base f',      g', _ =>
        base (f'.comp g' (sorry_proof))
      | prod f' f'', prod g' g'', _ =>
        prod (f'.comp g'   (sorry_proof))
             (f''.comp g'' (sorry_proof))

    /-- The prism type of a face does not depend on the larger prism. -/
    @[simp]
    theorem comp_toPrism (f g : FaceRepr) (h)
      : (f.comp g h).toPrism = g.toPrism
      := sorry_proof

    /--  -/
    @[simp]
    theorem comp_ofPrism (f g : FaceRepr) (h)
      : (f.comp g h).ofPrism = f.ofPrism
      := sorry_proof

    /-- The dimension of a face does not depend on the larger prism. -/
    @[simp]
    theorem comp_dim (f g : FaceRepr) (h)
      : (f.comp g h).dim = g.dim
      := sorry_proof

end FaceRepr

-- structure FaceRepr' (P : Option PrismRepr := none) (dim : Option ℕ := none) where
--   f : FaceRepr
--   hp : match P with
--        | some P => f.ofPrism = P
--        | none => True
--   hd : match dim with
--        | some dim => f.dim = dim
--        | none => True

-- namespace FaceRepr'

--   instance : DecidableEq (FaceRepr' P dim) :=
--     λ f g =>
--       if f.1=g.1
--       then isTrue sorry_proof
--       else isFalse sorry_proof

--   def toPrism {P n} (f : FaceRepr' P n) : PrismRepr := f.1.toPrism
--   def ofPrism {P n} (f : FaceRepr' P n) : PrismRepr := f.1.ofPrism
--   def dim {P n} (f : FaceRepr' P n) : Nat := f.1.dim

--   @[simp]
--   theorem ofPrism_simp {P n} (f : FaceRepr' (some P) n)
--     : f.ofPrism = P := by simp[ofPrism, f.2]; done

--   @[simp]
--   theorem dim_simp {P n} (f : FaceRepr' P (some n))
--     : f.dim = n := by simp[dim, f.3]; done

--   /-- Remove dimension information of a face -/
--   def anyDim {P n} (f : FaceRepr' P n) : FaceRepr' P := ⟨f.1, f.2, True.intro⟩
--   /-- Remove Prism information of a face -/
--   def anyPrism {P n} (f : FaceRepr' P n) : FaceRepr' none n := ⟨f.1, True.intro, f.3⟩

--   instance : Coe (FaceRepr' P n) FaceRepr := ⟨λ f => f.1⟩

--   def comp (f : FaceRepr' P n) (g : FaceRepr' (some Q) m)
--     (h : f.1.toPrism = Q := by first | rfl | simp)
--     : FaceRepr' P m
--     :=
--       ⟨f.1.comp g.1 (by rw[h,g.2]; done),
--        by cases P; simp; simp[f.2]; done,
--        by cases m; simp; simp[g.3]; done⟩

--   def toCanonical (f : FaceRepr' (some P) n) : FaceRepr' (some P.toCanonical) n :=
--     ⟨f.1.toCanonical,
--      by simp[f.1.toCanonical_ofPrism,f.2] done,
--      by simp[f.1.toCanonical_dim, f.3] done⟩

--   def fromCanonical (f : FaceRepr' (some P.toCanonical) n) : FaceRepr' (some P) n :=
--     ⟨f.1.fromCanonical P (by simp[f.2] done),
--      by simp[f.1.fromCanonical_ofPrism,f.2] done,
--      by simp[f.1.fromCanonical_dim, f.3] done⟩

-- end FaceRepr'

namespace PrismRepr

  def topFace : PrismRepr → FaceRepr
  | .point => .point
  | .cone P => .cone P.topFace
  | .prod P Q => .prod P.topFace Q.topFace

  @[simp]
  theorem topFace_ofPrism (P : PrismRepr) : P.topFace.ofPrism = P := sorry_proof
  @[simp]
  theorem topFace_toPrism (P : PrismRepr) : P.topFace.toPrism = P := sorry_proof

  /-- The first `n`-face of `P` -/
  def first (P : PrismRepr) (n : Nat) : Option FaceRepr:=
    match P, n with
    | .point, 0 => some .point
    | .point, _ => none
    | .cone P', 0 => some $ .tip P'
    | .cone P', n'+1 =>
      match P'.first n' with
      | some f => some $ .cone f
      | none => none
    | .prod P' Q', n =>
      Id.run do
      for i in [0:n+1] do
        match P'.first i, Q'.first (n-i) with
        | some f', some g' =>
          return some $ .prod f' g'
        | _, _ => continue
      none

  theorem first_ofPrism (P : PrismRepr) (n : Nat)
    : match P.first n with
      | some f => f.ofPrism = P
      | none => True
    := sorry_proof

  theorem first_dim (P : PrismRepr) (n : Nat)
    : match P.first n with
      | some f => f.dim = n
      | none => True
    := sorry_proof

  def prodSplit (P : PrismRepr) : List PrismRepr :=
  match P with
  | .point  => [.point]
  | .cone Q => [.cone Q]
  | .prod Q₁ Q₂ => Q₁ :: Q₂.prodSplit

  def prodHead (P : PrismRepr) : PrismRepr :=
  match P with
  | .point  => .point
  | .cone Q => .cone Q
  | .prod Q₁ _ => Q₁

  def prodTail (P : PrismRepr) : PrismRepr :=
  match P with
  | .point  => .point
  | .cone _ => .point
  | .prod _ Q₂ => Q₂

  -- def first' (P : PrismRepr) (n : Option Nat := none) : Option (FaceRepr' P n) :=
  --   match n with
  --   | some n => P.first n |>.map (⟨·, sorry_proof, sorry_proof⟩)
  --   | none     => P.first 0   |>.map (⟨·, sorry_proof, sorry_proof⟩)

end PrismRepr

namespace FaceRepr

  /-- Next face of the same Prism and dimension -/
  def next (f : FaceRepr) : Option FaceRepr :=
    match f.ofPrism, f.dim, f with
    | .point, 0, point => none
    | .cone P', 0, tip _ =>
      match P'.first 0 with
      | some f' => some $ base f'
      | none => none
    | .cone P', n'+1, cone f' =>
      match next f' with
      | some f'' => some $ cone f''
      | none =>
        match P'.first (n'+1) with
        | some f'' => some $ base f''
        | none => none
    | .cone _, _, base f' =>
      match next f' with
      | some f'' => some $ base f''
      | none => none
    | _, _, prod f' g' =>
      let P' := f'.ofPrism
      let Q' := g'.ofPrism
      match next f' with
      | some f'' => some $ prod f'' g'
      | none =>
        match P'.first f'.dim, next g' with
        | some f'', some g'' => some $ .prod f'' g''
        | _, _ =>
          match g'.dim with
          | 0 => none
          | m''+1 =>
            match P'.first (f'.dim+1), Q'.first m'' with
            | some f'', some g'' => some $ .prod f'' g''
            | _, _ => none
    | _, _, _ => panic! "Unreachable code in Face.next. This is a bug!"

  theorem next_ofPrism (f : FaceRepr)
    : match f.next with
      | some f' => f'.ofPrism = f.ofPrism
      | none => True
    := sorry_proof

  theorem next_dim (f : FaceRepr)
    : match f.next with
      | some f' => f'.dim = f.dim
      | none => True
    := sorry_proof

end FaceRepr

-- Next face of the same prism and if dimension is specified then of the
--   same dimension as well
-- def FaceRepr'.next {P : PrismRepr} {n : Option Nat}  -- Note that `P` is not Option!
--   (f : FaceRepr' (some P) n) : Option (FaceRepr' P n) :=
--   match f.1.next, f.1.next_ofPrism, f.1.next_dim with
--   | some f', h, q => some ⟨f', by rw [f.2] at h; assumption; done,
--                                by cases n; simp; rename_i n; rw [f.3] at q; assumption; done⟩
--   | none, _, _ => -- Out of faces of the same prism and dimension
--     match n with
--     | some _ => none
--     | none =>  -- if dimension is not specified get a face of higher dimension
--       match f.1.ofPrism.first (f.1.dim+1) with
--       | some f => some ⟨f, sorry_proof, sorry_proof⟩
--       | none => none

-- instance (P : PrismRepr) (n : Option Nat)
--   : Iterable (FaceRepr' P n) :=
-- {
--   first := P.first' n
--   next := λ f => f.next
--   decEq := by infer_instance
-- }

-- /-- All faces of a prism, optionaly all faces with of specified dimension -/
-- def PrismRepr.faces (P : PrismRepr) (n : Option Nat := none) := Iterable.fullRange (FaceRepr' P n)
-- /-- All faces of a face, optionaly all faces with of specified dimension -/
-- def FaceRepr.faces  (f : FaceRepr)  (n : Option Nat := none) := Iterable.fullRange (FaceRepr' f.toPrism n)
-- /-- All faces of a face, optionaly all faces with of specified dimension -/
-- def FaceRepr'.faces (f : FaceRepr' P n') (n : Option Nat := none)  := f.1.faces n

-- abbrev PrismRepr.Point (P : PrismRepr) : Type := FaceRepr' P (some 0)
-- abbrev PrismRepr.Edge  (P : PrismRepr) : Type := FaceRepr' P (some 0)

-- /-- All points of a prism -/
-- abbrev PrismRepr.points (P : PrismRepr) := Iterable.fullRange (FaceRepr' P (some 0))
-- /-- All edges of a prism -/
-- abbrev PrismRepr.edges (P : PrismRepr) := Iterable.fullRange (FaceRepr' P (some 1))

-- /-- All points of a face -/
-- abbrev FaceRepr.points (f : FaceRepr) := Iterable.fullRange (FaceRepr' f.toPrism (some 0))
-- /-- All edges of a face -/
-- abbrev FaceRepr.edges (f : FaceRepr) := Iterable.fullRange (FaceRepr' f.toPrism (some 1))

-- /-- All points of a face -/
-- abbrev FaceRepr'.points (f : FaceRepr' P n') := f.1.faces (some 0)
-- /-- All edges of a face -/
-- abbrev FaceRepr'.edges (f : FaceRepr' P n') := f.1.faces (some 1)

/-- Index of a face among all faces of the same prism and dimension -/
-- def FaceRepr.index (f : FaceRepr) : Nat :=
--   match f.dim, f with
--   | _, point => 0
--   | _, tip _ => 0
--   | _, cone f' => f'.index
--   | 0, base f' => f'.index + 1
--   | n'+1, base f' => f'.ofPrism.faceCount n' + f'.index
--   | _, prod f' g' =>
--     let P' := f'.ofPrism
--     let Q' := g'.ofPrism
--     (∑ i : Fin f'.dim, (P'.faceCount i)*(Q'.faceCount (f.dim-i)))
--     + g'.index * (P'.faceCount f'.dim)
--     + f'.index

def FaceRepr.index (f : FaceRepr) : Nat :=
  match f with
  | point => 0
  | tip P => P.faceCount 0
  | base f' => f'.index
  | cone f' => (f'.ofPrism.faceCount f.dim) + f'.index
  | prod f' g' =>
    let P' := f'.ofPrism
    let Q' := g'.ofPrism
    (∑ i : Fin f'.dim, (P'.faceCount i)*(Q'.faceCount (f.dim-i)))
    + g'.index * (P'.faceCount f'.dim)
    + f'.index

def FaceRepr.fromIndex (P : PrismRepr) (dim : Nat) (i : Fin (P.faceCount dim)) : FaceRepr :=
  match P, dim with
  | .point, 0 => point
  | .cone P', 0 =>
    let n' := P'.faceCount 0
    if h : i.1 < n' then
      .base (fromIndex P' 0 ⟨i.1, h⟩)
    else
      .tip P'
  | .cone P', dim'+1 =>
    let n' := P'.faceCount (dim'+1)
    if h : i.1 < n' then
      .base (fromIndex P' (dim'+1) ⟨i.1, h⟩)
    else
      .cone (fromIndex P' dim' ⟨i.1 - n', sorry_proof⟩)
  | .prod P' Q', _ => Id.run do
    let mut n := 0
    for d' in [0:dim+1] do
      let Δn := (P'.faceCount d') * (Q'.faceCount (dim-d'))
      if h : i.1 < n + Δn then
        let iP := (i-n) % (P'.faceCount d')
        let iQ := (i-n) / (P'.faceCount d')
        return (fromIndex P' d' ⟨iP,sorry_proof⟩).prod (fromIndex Q' (dim-d') ⟨iQ,sorry_proof⟩)
      else
        n := n + Δn

    panic! s!"Invalid index {i} in FaceRepr.fromIndex!"

/-- Index of a face is smaller then the number of faces of the same dimesnsion and of the same Prism -/
def FaceRepr.index_numberOfFaces (f : FaceRepr)
  : f.index < f.ofPrism.faceCount f.dim
  := sorry_proof

/-- Face is uniquelly determined by its parent prism, dimension and index -/
def FaceRepr.index_ext (f g : FaceRepr)
  : f.ofPrism = g.ofPrism → f.dim = g.dim → f.index = g.index → f = g
  := sorry_proof

abbrev PrismRepr.Space : PrismRepr → Type
| .point => Unit
| .cone P => ℝ × P.Space
| .prod P Q => P.Space × Q.Space

instance PrismRepr.instVecSpace (P : PrismRepr) : Vec P.Space :=
  match P with
  | point =>    by simp[Space]; infer_instance; done
  | cone P =>   by simp[Space]; apply (@instVecProd _ _ (by infer_instance) (instVecSpace P)); done
  | prod P Q => by simp[Space]; apply (@instVecProd _ _ (instVecSpace P) (instVecSpace Q)); done

def FaceRepr.embed (f : FaceRepr) (x : f.toPrism.Space) : f.ofPrism.Space :=
match f, x with
| .point, _ => ()
| .tip _x, _ => (1,0)
| .cone P', x'' =>
  let (t', x') := x''
  (t', (1-t')*(P'.embed x'))
| .base P', x'' =>
  (0, (P'.embed x''))
| .prod P' Q', x'' =>
  let (x', y') := x''
  (P'.embed x', Q'.embed y')

-- def FaceRepr'.embed (f : FaceRepr' (some P) n) (x : f.toPrism.Space) : P.Space := f.2 ▸ (f.1.embed x)

def PrismRepr.barycenter (P : PrismRepr) : P.Space :=
  match P with
  | point => 0
  | cone P' =>
    let w := (1.0 : ℝ)/(P.pointCount : ℝ)
    (w, (1-w)*P'.barycenter)
  | prod P Q =>
    (P.barycenter, Q.barycenter)

  -- def toRn : {P : Prism} → P.E → ℝ^P.dim := sorry_proof
  -- def fromRn : {P : Prism} → ℝ^P.dim → P.E := sorry_proof

/-- Barycentric coordinates of a prism

    This implementation has bad numerical properties and it is thus serves mostly as a specification -/
def PrismRepr.barycentricCoordSpec {P : PrismRepr} (p : FaceRepr) (_ : p.ofPrism = P ∧ p.dim = 0 /- `p` is a point of P -/) (x : P.Space) : ℝ :=
  match P, p, x with
  | .point, _, _ => 0
  | .cone _, .tip _, (t, _) => t
  | .cone _, .base p', (t, x') =>
    (1-t) * (barycentricCoordSpec p' sorry_proof (1/(1-t) * x'))
  | .prod _ _, .prod p q, (x, y) =>
    (barycentricCoordSpec p sorry_proof x) *
    (barycentricCoordSpec q sorry_proof y)
  | .cone _, .cone _, _ => unreachable!

-- Most likely this has bad numerics!!!
-- What type of barycentric coordinates are these? They are not harmonic, maybe Wachspress?
-- Can we define different set of coordinates inductively?
def PrismRepr.barycentricCoord {P : PrismRepr} (p : FaceRepr) (h : p.ofPrism = P ∧ p.dim = 0 /- `p` is a point of P -/) (x : P.Space) : ℝ :=
  match P, p, x, h.1 with
  | .point, _, _, _ => 0
  | .cone .point, .base _, (t, ()), _ => 1-t
  | .cone _, .tip _, (t, (_)), _ => t
  | .cone (.cone _), .base (.tip _), (_, (s, _)), _ => s
  | .cone (.cone P), .base (.base p), (t, (s, x)), _ =>
    -- let p' : FaceRepr' (some $ .cone P) (0 : Nat) := ⟨.base p, sorry_proof, sorry_proof⟩
    barycentricCoord (P := P.cone) (.base p) sorry_proof (t+s, x)
  | .cone (.prod P Q), .base (.prod p q), (t, (x, y)),_ =>
    -- let p' : FaceRepr' (some $ .cone P) (0 : Nat) := ⟨.base p, sorry_proof, sorry_proof⟩
    (barycentricCoord (P := P.cone) (.base p) sorry_proof (t,x)) *
    (barycentricCoord q sorry_proof (1/(1-t) * y))
  | .prod _ _, .prod p q, (x, y), _ =>
    (barycentricCoord p sorry_proof x) *
    (barycentricCoord q sorry_proof y)
  -- In all these cases `p` is not a point
  -- Can we modify the original match statement to eliminate these?
  -- | .cone (.prod _ _), .cone _, _ => unreachable!
  -- | .cone (.cone _),  .base (.cone _), _ => unreachable!
  -- | .cone (.cone _),  .cone _, _ => unreachable!
  -- | .cone .point, .cone _, _ => unreachable!

theorem PrismRepr.barycentricCoord_sound {P : PrismRepr} (p : FaceRepr) (h : p.ofPrism = P ∧ p.dim = 0 /- `p` is a point of P -/) (x : P.Space)
  : P.barycentricCoord p h x = P.barycentricCoordSpec p h x := sorry_proof

namespace PrismRepr

end PrismRepr

  #eval triangle < square
  #eval triangle * triangle
  #eval segment * pyramid |>.dim

  -- Ordering of 4D prisms
  -- cone of 3D
  #eval tet.cone < pyramid.cone
  #eval pyramid.cone < prism.cone
  #eval prism.cone < cube.cone
  #eval cube.cone < segment * tet
  -- 1D × 3D
  #eval segment * tet < segment * pyramid
  #eval segment * pyramid < segment * prism
  -- 1D × 1D × 2D
  #eval segment * prism < segment * cube
  -- 1D × 1D × 1D × 1D
  #eval segment * cube < triangle * triangle

-- order preserving map from one prism to another prism
-- Should include pure inclusions like Face but also collapses
--
-- There is some non-uniqueness, doing `shift` if the same as `cone ∘ base`
-- inductive Morph : Prism → Type
--   | point : Morph point
--   | tip (P : Prism) : Morph (cone P)
--   | cone {P : Prism} (f : Morph P) : Morph (cone P)
--   | base {P : Prism} (f : Morph P) : Morph (cone P)
--   | collapse {P : Prism} (m : Morph (cone P)) : Morph (cone (cone P))
--   | shift    {P : Prism} (m : Morph (cone P)) : Morph (cone (cone P))
--   | prod {P Q : Prism} (f : Morph P) (g : Morph Q) : Morph (prod P Q)

-- Face if Morph not containing collapses and shifts

#exit
-- structure Inclusion (Q P : Prism) where
--   f  : Face P
--   hq : f.toPrism = Q

-- instance (Q P) : CoeFun (Inclusion Q P) (λ a => Face Q → Face P) := sorry

-- variable (ι : Inclusion Q P) (f : Face Q)

-- #check (ι f)

  -- For finite element spaces look at:
  --
  -- Construction of scalar and vector finite element families on polygonal and polyhedral meshes
  --   https://arxiv.org/abs/1405.6978
  --
  -- Minimal degree H(curl) And H(div) conforming finite elements on polytopal meshes
  --   https://arxiv.org/abs/1502.01553

private def testBarycentricCoord (P : PrismRepr) : IO Unit := do
  IO.println s!"Testing barycentric coordinates of {P}"

  for pi in P.points do
    for pj in P.points do
      IO.print s!"{P.coord pi (pj.embed 0)} "

    IO.println ""
  IO.println ""

#eval testBarycentricCoord segment
#eval testBarycentricCoord cube.cone
#eval testBarycentricCoord pyramid.cone

def analyzePrism (P : PrismRepr) : IO Unit := do
  IO.println s!"Analyzing {P}"

  for d in [0:P.dim+1] do
    IO.println s!"  Looking at {d}-faces"

    for f in P.faces d do
      IO.println s!"     dim: {f.1.dim} | id: {f.1.index} | {f.1} | {f.1.toPrism} | {f.1.toPrism.toCanonical} | {f.toCanonical.fromCanonical == f} "
      IO.print   s!"       "
      for g in f.faces do
        IO.print s!"| {g.1.ofPrism} "
      IO.println ""

      -- IO.print s!"       "
      -- for g in f.1.faces do
      --   IO.print s!"| {g.toPrism.toCanonical} "
      -- IO.println s!""

      -- let mut f := Face.first P d |>.getD default
      -- for i in [0:P.faceCount d] do

      --   IO.println s!"    face {i}: id:{f.toFin} | {f.toPrism} | {f.toPrism.toCanonical} | canonical: {f == f}"

      --   f.toPrism.forFacesM
      --     λ g => IO.println s!"     {g.toPrism == (f.comp g |>.toPrism)}"-- g.toPrism.forFacesM

      --   f.toCanonical.toPrism.forFacesM
      --     λ g => IO.println s!"     {g.toCanonical.fromCanonical == g}"-- g.toPrism.forFacesM

      --   --     λ h =>
      --   --       let h'  := Face.ofFace h
      --   --       let h'' := Face.ofFace h'
      --   --       IO.println s!"{h''}"
      --   -- -- IO.println ""
      --   f := f.next.getD default

#eval analyzePrism triangle
#eval analyzePrism (PrismRepr.point.prod (square.prod .point))
#eval analyzePrism pyramid
#eval analyzePrism (triangle.prod segment)
#eval ((cube).cone.prod triangle).dim


import tactic.basic

/-
dependent equality / dependent path / "pathover" from HoTT/cubical type theory
-/

inductive deq {α : Sort*} {C : α → Sort*} :
  Π {a a' : α} (e : a = a') (x : C a) (x' : C a'), Prop
| refl {a : α} (x : C a) : deq (eq.refl a) x x

attribute [refl] deq.refl

notation x ` =[`:50 e:50 `] `:50 x':50 := deq e x x'

variables {α : Sort*} {C : α → Sort*}

@[symm] lemma deq.symm {a a' : α} (e : a = a') (x : C a) (x' : C a') :
  x =[e] x' → x' =[e.symm] x :=
begin
  rintro ⟨⟩,
  refl
end

@[trans] lemma deq.trans {a a' a'' : α} (e : a = a') (e' : a' = a'')
  (x : C a) (x' : C a') (x'' : C a'') :
  x =[e] x' → x' =[e'] x'' → x =[e.trans e'] x'' :=
begin
  rintros ⟨⟩ ⟨⟩,
  refl
end

lemma deq_iff_eq {a : α} {x y : C a} : x =[eq.refl a] y ↔ x = y :=
by split; rintro ⟨⟩; refl


/-
Copyright (c) 2021 Andrew Yang. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Andrew Yang
-/
import category_theory.sites.dense_subsite

/-!
# Induced Topology

We say that a functor `G : C ⥤ (D, K)` is locally dense if for each covering sieve `T` in `D` of
some `X : C`, `T ∩ mor(C)` generates a covering sieve of `X` in `D`. A locally dense fully faithful
functor then induces a topology on `C` via `{ T ∩ mor(C) | T ∈ K }`. Note that this is equal to
the collection of sieves on `C` whose image generates a covering sieve. This construction would
make `C` both cover-lifting and cover-preserving.

Some typical examples are full and cover-dense functors (for example the functor from a basis of a
topological space `X` into `opens X`). The functor `over X ⥤ C` is also locally dense, and the
induced topology can then be used to construct the big sites associated to a scheme.

Given a fully faithful cover-dense functor `G : C ⥤ (D, K)` between small sites, we then have
`Sheaf (H.induced_topology) A ≌ Sheaf K A`. This is known as the comparison lemma.

## References

* [Elephant]: *Sketches of an Elephant*, P. T. Johnstone: C2.2.
* https://ncatlab.org/nlab/show/dense+sub-site
* https://ncatlab.org/nlab/show/comparison+lemma

-/

namespace category_theory

universes v u

open limits opposite presieve

section

variables {C : Type*} [category C] {D : Type*} [category D] {G : C ⥤ D}
variables {J : grothendieck_topology C} {K : grothendieck_topology D}
variables (A : Type v) [category.{u} A]

-- variables (A) [full G] [faithful G]

/--
We say that a functor `C ⥤ D` into a site is "locally dense" if
for each covering sieve `T` in `D`, `T ∩ mor(C)` generates a covering sieve in `D`.
-/
def locally_cover_dense (K : grothendieck_topology D) (G : C ⥤ D) : Prop :=
∀ ⦃X⦄ (T : K (G.obj X)), (T.val.functor_pullback G).functor_pushforward G ∈ K (G.obj X)

namespace locally_cover_dense

variables [full G] [faithful G] (Hld : locally_cover_dense K G)

include Hld

lemma pushforward_cover_iff_cover_pullback {X : C} (S : sieve X) :
  K _ (S.functor_pushforward G) ↔ ∃ (T : K (G.obj X)), T.val.functor_pullback G = S :=
begin
  split,
  { intros hS,
    exact ⟨⟨_, hS⟩, (sieve.fully_faithful_functor_galois_coinsertion G X).u_l_eq S⟩ },
  { rintros ⟨T, rfl⟩,
    exact Hld T }
end

/--
If a functor `G : C ⥤ (D, K)` is fully faithful and locally dense,
then the set `{ T ∩ mor(C) | T ∈ K }` is a grothendieck topology of `C`.
-/
@[simps]
def induced_topology :
  grothendieck_topology C :=
{ sieves := λ X S, K _ (S.functor_pushforward G),
  top_mem' := λ X, by { change K _ _, rw sieve.functor_pushforward_top, exact K.top_mem _ },
  pullback_stable' := λ X Y S f hS,
  begin
    have : S.pullback f = ((S.functor_pushforward G).pullback (G.map f)).functor_pullback G,
    { conv_lhs { rw ← (sieve.fully_faithful_functor_galois_coinsertion G X).u_l_eq S },
      ext,
      change (S.functor_pushforward G) _ ↔ (S.functor_pushforward G) _,
      rw G.map_comp },
    rw this,
    change K _ _,
    apply Hld ⟨_, K.pullback_stable (G.map f) hS⟩
  end,
  transitive' := λ X S hS S' H',
  begin
    apply K.transitive hS,
    rintros Y _ ⟨Z, g, i, hg, rfl⟩,
    rw sieve.pullback_comp,
    apply K.pullback_stable i,
    refine K.superset_covering _ (H' hg),
    rintros W _ ⟨Z', g', i', hg, rfl⟩,
    use ⟨Z', g' ≫ g, i', hg, by simp⟩
  end }

/-- `G` is cover-lifting wrt the induced topology. -/
lemma induced_topology_cover_lifting :
  cover_lifting Hld.induced_topology K G := ⟨λ _ S hS, Hld ⟨S, hS⟩⟩

/-- `G` is cover-preserving wrt the induced topology. -/
lemma induced_topology_cover_preserving :
  cover_preserving Hld.induced_topology K G := ⟨λ _ S hS, hS⟩

end locally_cover_dense

lemma cover_dense.locally_cover_dense [full G] (H : cover_dense K G) : locally_cover_dense K G :=
begin
  intros X T,
  refine K.superset_covering _ (K.bind_covering T.property (λ Y f Hf, H.is_cover Y)),
  rintros Y _ ⟨Z, _, f, hf, ⟨W, g, f', (rfl : _ = _)⟩, rfl⟩,
  use W, use G.preimage (f' ≫ f), use g,
  split,
  simpa using T.val.downward_closed hf f',
  simp,
end

/--
Given a fully faithful cover-dense functor `G : C ⥤ (D, K)`, we may induce a topology on `C`.
-/
abbreviation cover_dense.induced_topology [full G] [faithful G] (H : cover_dense K G) :
  grothendieck_topology C := H.locally_cover_dense.induced_topology

variable (J)

lemma over_forget_locally_cover_dense (X : C) : locally_cover_dense J (over.forget X) :=
begin
  intros Y T,
  convert T.property,
  ext Z f,
  split,
  { rintros ⟨_, _, g', hg, rfl⟩,
    exact T.val.downward_closed hg g' },
  { intros hf,
    exact ⟨over.mk (f ≫ Y.hom), over.hom_mk f, 𝟙 _, hf, (category.id_comp _).symm⟩ }
end

end

section small_site

variables {C : Type v} [small_category C] {D : Type v} [small_category D] {G : C ⥤ D}
variables {J : grothendieck_topology C} {K : grothendieck_topology D}
variables (A : Type u) [category.{v} A]

/--
Cover-dense functors induces an equivalence of categories of sheaves.

This is known as the comparison lemma. It requires that the sites are small and the value category
is complete.
-/
noncomputable
def cover_dense.Sheaf_equiv [full G] [faithful G] (H : cover_dense K G) [has_limits A] :
  Sheaf H.induced_topology A ≌ Sheaf K A :=
H.Sheaf_equiv_of_cover_preserving_cover_lifting
  H.locally_cover_dense.induced_topology_cover_preserving
  H.locally_cover_dense.induced_topology_cover_lifting

end small_site

end category_theory


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

Basic machinery for defining general coinductive types

Work in progress
-/
import data.pfun tactic.interactive ..for_mathlib .basic

universes u v w

open nat function list (hiding head')

variables (F : pfunctor.{u})

local prefix `♯`:0 := cast (by simp [*] <|> cc <|> solve_by_elim)

namespace pfunctor
namespace approx

inductive cofix_a : ℕ → Type u
| continue : cofix_a 0
| intro {n} : ∀ a, (F.B a → cofix_a n) → cofix_a (succ n)

@[extensionality]
lemma cofix_a_eq_zero : ∀ x y : cofix_a F 0, x = y
| (cofix_a.continue _) (cofix_a.continue _) := rfl

variables {F}

def head' : Π {n}, cofix_a F (succ n) → F.A
 | n (cofix_a.intro i _) := i

def children' : Π {n} (x : cofix_a F (succ n)), F.B (head' x) → cofix_a F n
 | n (cofix_a.intro a f) := f

lemma approx_eta  {n : ℕ} (x : cofix_a F (n+1)) :
  x = cofix_a.intro (head' x) (children' x) :=
by cases x; refl

inductive agree
: ∀ {n : ℕ}, cofix_a F n → cofix_a F (n+1) → Prop
 | continue (x : cofix_a F 0) (y : cofix_a F 1) : agree x y
 | intro {n} {a} (x : F.B a → cofix_a F n) (x' : F.B a → cofix_a F (n+1)) :
   (∀ i : F.B a, agree (x i) (x' i)) →
   agree (cofix_a.intro a x) (cofix_a.intro a x')

def all_agree (x : Π n, cofix_a F n) :=
∀ n, agree (x n) (x (succ n))

@[simp]
lemma agree_trival {x : cofix_a F 0} {y : cofix_a F 1}
: agree x y :=
by { constructor }

lemma agree_children {n : ℕ} (x : cofix_a F (succ n)) (y : cofix_a F (succ n+1))
  {i j}
  (h₀ : i == j)
  (h₁ : agree x y)
: agree (children' x i) (children' y j) :=
begin
  cases h₁, cases h₀,
  apply h₁_a_1,
end

def truncate
: ∀ {n : ℕ}, cofix_a F (n+1) → cofix_a F n
 | 0 (cofix_a.intro _ _) := cofix_a.continue _
 | (succ n) (cofix_a.intro i f) := cofix_a.intro i $ truncate ∘ f

lemma truncate_eq_of_agree {n : ℕ}
  (x : cofix_a F n)
  (y : cofix_a F (succ n))
  (h : agree x y)
: truncate y = x :=
begin
  induction n generalizing x y
  ; cases x ; cases y,
  { refl },
  { cases h with _ _ _ _ _ h₀ h₁,
    cases h,
    simp [truncate,exists_imp_distrib,(∘)],
    ext y, apply n_ih,
    apply h₁ }
end

variables {X : Type w}
variables (f : X → F.apply X)

def s_corec : Π (i : X) n, cofix_a F n
 | _ 0 := cofix_a.continue _
 | j (succ n) :=
   let ⟨y,g⟩ := f j in
   cofix_a.intro y (λ i, s_corec (g i) _)

lemma P_corec (i : X) (n : ℕ) : agree (s_corec f i n) (s_corec f i (succ n)) :=
begin
  induction n with n generalizing i,
  constructor,
  cases h : f i with y g,
  simp [s_corec,h,s_corec._match_1] at ⊢ n_ih,
  constructor,
  introv,
  apply n_ih,
end

def path (F : pfunctor.{u}) := list F.Idx

open list

instance : subsingleton (cofix_a F 0) :=
⟨ by { intros, casesm* cofix_a F 0, refl } ⟩

open list nat
lemma head_succ' (n m : ℕ) (x : Π n, cofix_a F n)
  (Hconsistent : all_agree x)
: head' (x (succ n)) = head' (x (succ m)) :=
begin
  suffices : ∀ n, head' (x (succ n)) = head' (x 1),
  { simp [this] },
  clear m n, intro,
  cases h₀ : x (succ n) with _ i₀ f₀,
  cases h₁ : x 1 with _ i₁ f₁,
  simp [head'],
  induction n with n,
  { 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,
    congr, funext j, dsimp [comp],
    rw truncate_eq_of_agree,
    apply H_a_1 }
end

end approx
open approx

structure M_intl :=
  (approx : ∀ n, cofix_a F n)
  (consistent : all_agree approx)

def M := M_intl

namespace M

lemma ext' (x y : M F)
  (H : ∀ i : ℕ, x.approx i = y.approx i)
: x = y :=
begin
  cases x, cases y,
  congr, ext, apply H,
end

variables {X : Type*}
variables (f : X → F.apply X)
variables {F}

protected def corec (i : X) : M F :=
{ approx := s_corec f i
, consistent := P_corec _ _ }

variables {F}

def head : M F → F.A
 | x := head' (x.1 1)

def children : Π (x : M F), F.B (head x) → M F
| x i :=
   let H := λ n : ℕ, @head_succ' _ n 0 x.1 x.2 in
   { approx := λ n, children' (x.1 _) (cast (congr_arg _ $ by simp [head,H]; refl) i)
   , consistent :=
     begin
       intro,
       have P' := x.2 (succ n),
       apply agree_children _ _ _ P',
       transitivity i,
       apply cast_heq,
       symmetry,
       apply cast_heq,
     end }

def ichildren [inhabited (M F)] [decidable_eq F.A] : F.Idx → M F → M F
 | i x :=
if H' : i.1 = head x
  then children x (cast (congr_arg _ $ by simp [head,H']; refl) i.2)
  else default _

lemma head_succ (n m : ℕ) (x : M F)
: head' (x.approx (succ n)) = head' (x.approx (succ m)) :=
head_succ' n m _ x.consistent

lemma head_eq_head' : Π (x : M F) (n : ℕ),
  head x = head' (x.approx $ n+1)
| ⟨x,h⟩ n := head_succ' _ _ _ h

lemma head'_eq_head : Π (x : M F) (n : ℕ),
  head' (x.approx $ n+1) = head x
| ⟨x,h⟩ n := head_succ' _ _ _ h

lemma truncate_approx (x : M F) (n : ℕ) :
  truncate (x.approx $ n+1) = x.approx n :=
truncate_eq_of_agree _ _ (x.consistent _)

def from_cofix : M F → F.apply (M F)
 | x := ⟨head x,λ i, children x i ⟩

namespace approx

protected def s_mk (x : F.apply $ M F) : Π n, cofix_a F n
 | 0 :=  cofix_a.continue _
 | (succ n) := cofix_a.intro x.1 (λ i, (x.2 i).approx n)

protected def P_mk  (x : F.apply $ M F)
: all_agree (approx.s_mk x)
 | 0 := by { constructor }
 | (succ n) := by { constructor, introv,
                    apply (x.2 i).consistent }

end approx

protected def mk (x : F.apply $ M F) : M F :=
{ approx := approx.s_mk x
, consistent := approx.P_mk x }

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'

@[simp]
lemma from_cofix_mk (x : F.apply $ M F)
: from_cofix (M.mk x) = x :=
begin
  funext i,
  dsimp [M.mk,from_cofix],
  cases x with x ch, congr, ext i,
  cases h : ch i,
  simp [children,M.approx.s_mk,children',cast_eq],
  dsimp [M.approx.s_mk,children'],
  congr, rw h,
end

lemma mk_from_cofix (x : M F)
: M.mk (from_cofix x) = x :=
begin
  apply ext', intro n,
  dsimp [M.mk],
  induction n with n,
  { dsimp [head], ext },
  dsimp [approx.s_mk,from_cofix,head],
  cases h : x.approx (succ n) with _ hd ch,
  have h' : hd = head' (x.approx 1),
  { rw [← head_succ' n,h,head'], apply x.consistent },
  revert ch, rw h', intros, congr,
  { ext a, dsimp [children],
    h_generalize! hh : a == a'',
    rw h, intros, cases hh, refl },
end

lemma mk_inj {x y : F.apply $ M F}
  (h : M.mk x = M.mk y) : x = y :=
by rw [← from_cofix_mk x,h,from_cofix_mk]

protected def cases {r : M F → Sort w}
  (f : ∀ (x : F.apply $ M F), r (M.mk x)) (x : M F) : r x :=
suffices r (M.mk (from_cofix x)),
  by { haveI := classical.prop_decidable,
       haveI := inhabited.mk x,
       rw [← mk_from_cofix x], exact this },
f _

protected def cases_on {r : M F → Sort w}
  (x : M F) (f : ∀ (x : F.apply $ M F), r (M.mk x)) : r x :=
M.cases f x

protected def cases_on' {r : M F → Sort w}
  (x : M F) (f : ∀ a f, r (M.mk ⟨a,f⟩)) : r x :=
M.cases_on x (λ ⟨a,g⟩, f a _)

lemma approx_mk (a : F.A) (f : F.B a → M F) (i : ℕ) :
  (M.mk ⟨a, f⟩).approx (succ i) = cofix_a.intro a (λ j, (f j).approx i) :=
by refl

lemma agree'_refl [inhabited (M F)] [decidable_eq F.A] {n : ℕ} (x : M F) :
  agree' n x x :=
by { induction n generalizing x; induction x using pfunctor.M.cases_on'; constructor; try { refl }, intros, apply n_ih }

lemma agree_iff_agree' [inhabited (M F)] [decidable_eq F.A] {n : ℕ} (x y : M F) :
  agree (x.approx n) (y.approx $ n+1) ↔ agree' n x y :=
begin
  split; intros h,
  { induction n generalizing x y, constructor,
    { induction x using pfunctor.M.cases_on',
      induction y using pfunctor.M.cases_on',
      simp only [approx_mk] at h, cases h,
      constructor; try { refl },
      intro i, apply n_ih, apply h_a_1 } },
  { induction n generalizing x y, constructor,
    { cases h,
      induction x using pfunctor.M.cases_on',
      induction y using pfunctor.M.cases_on',
      simp only [approx_mk],
      replace h_a_1 := mk_inj h_a_1, cases h_a_1,
      replace h_a_2 := mk_inj h_a_2, cases h_a_2,
      constructor, intro i, apply n_ih, apply h_a_3 } },
end

@[simp]
lemma cases_mk {r : M F → Sort*} (x : F.apply $ M F) (f : Π (x : F.apply $ M F), r (M.mk x))
: pfunctor.M.cases f (M.mk x) = f x :=
begin
  dsimp [M.mk,pfunctor.M.cases,from_cofix,head,approx.s_mk,head'],
  cases x, dsimp [approx.s_mk],
  apply eq_of_heq,
  apply rec_heq_of_heq, congr,
  ext, dsimp [children,approx.s_mk,children'],
  cases h : x_snd x, dsimp [head],
  congr, ext,
  change (x_snd (x)).approx x_1 = _,
  rw h
end

@[simp]
lemma cases_on_mk {r : M F → Sort*} (x : F.apply $ M F) (f : Π x : F.apply $ M F, r (M.mk x))
: pfunctor.M.cases_on (M.mk x) f = f x :=
cases_mk x f

@[simp]
lemma cases_on_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.cases_on' (M.mk ⟨a,x⟩) f = f a x :=
cases_mk ⟨_,x⟩ _

inductive is_path  : path F → M F → Prop
| nil (x : M F) : is_path [] x
| cons (xs : path F) {a} (x : M F) (f : F.B a → M F) (i : F.B a) :
  x = M.mk ⟨a,f⟩ →
  is_path xs (f i) →
  is_path (⟨a,i⟩ :: xs) x

lemma is_path_cons {xs : path F} {a a'} {f : F.B a → M F} {i : F.B a'}
  (h : is_path (⟨a',i⟩ :: xs) (M.mk ⟨a,f⟩)) :
  a = a' :=
begin
  revert h, generalize h : (M.mk ⟨a,f⟩) = x,
  intros h', cases h', subst x,
  cases mk_inj h'_a_1, refl,
end

lemma is_path_cons' {xs : path F} {a} {f : F.B a → M F} {i : F.B a}
  (h : is_path (⟨a,i⟩ :: xs) (M.mk ⟨a,f⟩)) :
  is_path xs (f i) :=
begin
  revert h, generalize h : (M.mk ⟨a,f⟩) = x,
  intros h', cases h', subst x,
  cases mk_inj h'_a_1, exact h'_a_2,
end

def isubtree [decidable_eq F.A] [inhabited (M F)] : path F → M F → M F
 | [] x := x
 | (⟨a, i⟩ :: ps) x :=
pfunctor.M.cases_on' x (λ a' f,
(if h : a = a' then isubtree ps (f $ cast (by rw h) i)
 else default (M F) : (λ x, M F) (M.mk ⟨a',f⟩)))

def iselect [decidable_eq F.A] [inhabited (M F)] (ps : path F) : M F → F.A :=
λ (x : M F), head $ isubtree ps x

lemma iselect_eq_default [decidable_eq F.A] [inhabited (M F)] (ps : path F) (x : M F)
  (h : ¬ is_path ps x) :
  iselect ps x = head (default $ M F) :=
begin
  induction ps generalizing x,
  { exfalso, apply h, constructor },
  { cases ps_hd with a i,
    induction x using pfunctor.M.cases_on',
    simp [iselect,isubtree] at ps_ih ⊢,
    by_cases h'' : a = x_a, subst x_a,
    { simp *, rw ps_ih, intro h', apply h,
      constructor; try { refl }, apply h' },
    { simp * } }
end

lemma head_mk (x : F.apply (M F)) :
  head (M.mk x) = x.1 :=
eq.symm $
calc  x.1
    = (from_cofix (M.mk x)).1 : by rw from_cofix_mk
... = head (M.mk x)           : by refl

lemma 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; refl

lemma ichildren_mk [decidable_eq F.A] [inhabited (M F)] (x : F.apply (M F)) (i : F.Idx)
: ichildren i (M.mk x) = x.iget i :=
by { dsimp [ichildren,pfunctor.apply.iget],
     congr, ext, apply ext',
     dsimp [children',M.mk,approx.s_mk],
     intros, refl }

lemma isubtree_cons [decidable_eq 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.apply.iget,dif_pos,isubtree,M.cases_on_mk']; refl

lemma iselect_nil [decidable_eq F.A] [inhabited (M F)] {a} (f : F.B a → M F) :
  iselect nil (M.mk ⟨a,f⟩) = a :=
by refl

lemma iselect_cons [decidable_eq 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]

lemma corec_def {X} (f : X → F.apply X) (x₀ : X) :
  M.corec f x₀ = M.mk (M.corec f <$> f x₀)  :=
begin
  dsimp [M.corec,M.mk],
  congr, ext n,
  cases n with n,
  { dsimp [s_corec,approx.s_mk], refl, },
  { dsimp [s_corec,approx.s_mk], cases h : (f x₀),
    dsimp [s_corec._match_1,(<$>),pfunctor.map],
    congr, }
end

lemma ext_aux [inhabited (M F)] [decidable_eq 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) :=
begin
  induction n with n generalizing x y z,
  { specialize hrec [] rfl,
    induction x using pfunctor.M.cases_on', induction y using pfunctor.M.cases_on',
    simp only [iselect_nil] at hrec, subst hrec,
    simp only [approx_mk, true_and, eq_self_iff_true, heq_iff_eq],
    ext, },
  { cases hx, cases hy,
    induction x using pfunctor.M.cases_on', induction y using pfunctor.M.cases_on',
    subst z,
    replace hx_a_2 := mk_inj hx_a_2, cases hx_a_2,
    replace hy_a_1 := mk_inj hy_a_1, cases hy_a_1,
    replace hy_a_2 := mk_inj hy_a_2, cases hy_a_2,
    simp [approx_mk], ext i, apply n_ih,
    { apply hx_a_3 }, { apply hy_a_3 },
    introv h, specialize hrec (⟨_,i⟩ :: ps) (congr_arg _ h),
    simp [iselect_cons] at hrec, exact hrec }
end

open pfunctor.approx

-- variables (F : pfunctor.{v})
variables {F}

local prefix `♯`:0 := cast (by simp [*] <|> cc <|> solve_by_elim)

local attribute [instance, priority 0] classical.prop_decidable

lemma ext [inhabited (M F)] [decidable_eq F.A]
  (x y : M F)
  (H : ∀ (ps : path F), iselect ps x = iselect ps y)
: x = y :=
begin
  apply ext', intro i,
  induction i with i,
  { 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',
    simp [iselect] at H,
    cases H',
    apply H ps }
end

section bisim
  variable (R : M F → M F → Prop)
  local infix ~ := R

  structure is_bisimulation :=
  (head : ∀ {a a'} {f f'}, M.mk ⟨a,f⟩ ~ M.mk ⟨a',f'⟩ → a = a')
  (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) )

  variables [inhabited (M F)] [decidable_eq F.A]
  theorem nth_of_bisim (bisim : is_bisimulation R) (s₁ s₂) (ps : path F) :
       s₁ ~ s₂ →
         is_path ps s₁ ∨ is_path 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 :=
  begin
    intros h₀ hh,
    induction s₁ using pfunctor.M.cases_on' with a f,
      induction s₂ using pfunctor.M.cases_on' with a' f',
      have : a = a' := bisim.head h₀, subst a',
      induction ps with i ps generalizing a f f',
      { existsi [rfl,a,f,f',rfl,rfl],
        apply bisim.tail h₀ },
      cases i with a' i,
      have : a = a',
      { cases hh; cases is_path_cons hh; refl },
      subst a', dsimp [iselect] at ps_ih ⊢,
      have h₁ := bisim.tail h₀ i,
      induction h : (f i) using pfunctor.M.cases_on' with a₀ f₀,
      induction h' : (f' i) using pfunctor.M.cases_on' with a₁ f₁,
      simp only [h,h',isubtree_cons] at ps_ih ⊢,
      rw [h,h'] at h₁,
      have : a₀ = a₁ := bisim.head h₁, subst a₁,
      apply (ps_ih _ _ _ h₁),
      rw [← h,← h'], apply or_of_or_of_imp_of_imp hh is_path_cons' is_path_cons'
  end

  theorem eq_of_bisim (bisim : is_bisimulation R) : ∀ s₁ s₂, s₁ ~ s₂ → s₁ = s₂ :=
  begin
    introv Hr, apply ext,
    introv,
    by_cases h : is_path ps s₁ ∨ is_path ps s₂,
    { have H := nth_of_bisim R bisim _ _ ps Hr h,
      exact H.left },
    { rw not_or_distrib at h, cases h with h₀ h₁,
      simp only [iselect_eq_default,*,not_false_iff] }
  end
end bisim

section coinduction

variables F

coinductive R : Π (s₁ s₂ : M F), Prop
| intro {a} (s₁ s₂ : F.B a → M F) :
   (∀ i, R (s₁ i) (s₂ i)) →
   R (M.mk ⟨_,s₁⟩) (M.mk ⟨_,s₂⟩)

section
variables [decidable_eq F.A] [inhabited $ M F]

open ulift
lemma R_is_bisimulation : is_bisimulation (R F) :=
begin
  constructor; introv hr,
  { suffices : (λ a b, head a = head b) (M.mk ⟨a, f⟩) (M.mk ⟨a', f'⟩),
    { simp only [head_mk] at this, exact this },
    refine R.cases_on _ hr _,
    intros, simp only [head_mk] },
  { suffices : (λ a b, ∀ i j, i == j → R F (children a i) (children b j)) (M.mk ⟨a, f⟩) (M.mk ⟨a, f'⟩),
    { specialize this (cast (by rw head_mk) i) (cast (by rw head_mk) i) heq.rfl,
      simp only [children_mk] at this, exact this, },
    refine R.cases_on _ hr _,
    introv h₂ h₃,
    let k := cast (by rw head_mk) i_1,
    have h₀ : (children (M.mk ⟨a_1, s₁⟩) i_1) = s₁ k := children_mk _ _,
    have h₁ : (children (M.mk ⟨a_1, s₂⟩) j) = s₂ k,
    { rw children_mk, congr, symmetry, apply eq_of_heq h₃ },
    rw [h₀,h₁], apply h₂ },
end

end
variables {F}

lemma coinduction {s₁ s₂ : M F}
  (hh : R _ s₁ s₂)
: s₁ = s₂ :=
begin
  haveI := inhabited.mk s₁,
  exact eq_of_bisim
    (R F) (R_is_bisimulation F) _ _
    hh
end

lemma coinduction' {s₁ s₂ : M F}
  (hh : R _ s₁ s₂)
: s₁ = s₂ :=
begin
  have hh' := hh, revert hh',
  apply R.cases_on F hh, clear hh s₁ s₂,
  introv h₀ h₁,
  rw coinduction h₁
end

end coinduction

universes u' v'

def corec_on {X : Type*} (x₀ : X) (f : X → F.apply X) : M F :=
M.corec f x₀

end M

end pfunctor

namespace tactic.interactive
open tactic (hiding coinduction) lean.parser interactive

meta def bisim (g : parse $ optional (tk "generalizing" *> many ident)) : tactic unit :=
do applyc ``pfunctor.M.coinduction,
   coinduction ``pfunctor.M.R.corec_on g

end tactic.interactive

namespace pfunctor

open M

variables {P : pfunctor.{u}} {α : Type u}

def M_dest : M P → P.apply (M P) := from_cofix

def M_corec : (α → P.apply α) → (α → M P) := M.corec

lemma M_dest_corec (g : α → P.apply α) (x : α) :
  M_dest (M_corec g x) = M_corec g <$> g x :=
by rw [M_corec,M_dest,corec_def,from_cofix_mk]

lemma M_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 :=
begin
  intros,
  bisim generalizing x y, rename w x; rename h_1_w y; rename h_1_h_left ih,
  rcases h _ _ ih with ⟨ a', f, f', h₀, h₁, h₂ ⟩, clear h, dsimp [M_dest] at h₀ h₁,
  existsi [a',f,f'], split,
  { intro, existsi [f i,f' i,h₂ _,rfl], refl },
  split,
  { rw [← h₀,mk_from_cofix] },
  { rw [← h₁,mk_from_cofix] },
end

theorem M_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 :=
λ x Qx,
let R := λ w z : M P, ∃ x', Q x' ∧ w = u x' ∧ z = v x' in
@M_bisim P R
  (λ x y ⟨x', Qx', xeq, yeq⟩,
    let ⟨a, f, f', ux'eq, vx'eq, h'⟩ := h x' Qx' in
      ⟨a, f, f', xeq.symm ▸ ux'eq, yeq.symm ▸ vx'eq, h'⟩)
  _ _ ⟨x, Qx, rfl, rfl⟩

-- for the record, show M_bisim follows from M_bisim'
theorem M_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 :=
λ x y Rxy,
let Q : M P × M P → Prop := λ p, R p.fst p.snd in
M_bisim' Q prod.fst prod.snd
  (λ p Qp,
    let ⟨a, f, f', hx, hy, h'⟩ := h p.fst p.snd Qp in
    ⟨a, f, f', hx, hy, λ i, ⟨⟨f i, f' i⟩, h' i, rfl, rfl⟩⟩)
  ⟨x, y⟩ Rxy

theorem M_corec_unique (g : α → P.apply α) (f : α → M P)
    (hyp : ∀ x, M_dest (f x) = f <$> (g x)) :
  f = M_corec g :=
begin
  ext x,
  apply M_bisim' (λ x, true) _ _ _ _ trivial,
  clear x,
  intros x _,
  cases gxeq : g x with a f',
  have h₀ : M_dest (f x) = ⟨a, f ∘ f'⟩,
  { rw [hyp, gxeq, pfunctor.map_eq] },
  have h₁ : M_dest (M_corec g x) = ⟨a, M_corec g ∘ f'⟩,
  { rw [M_dest_corec, gxeq, pfunctor.map_eq], },
  refine ⟨_, _, _, h₀, h₁, _⟩,
  intro i,
  exact ⟨f' i, trivial, rfl, rfl⟩
end

def M_mk : P.apply (M P) → M P := M_corec (λ x, M_dest <$> x)

theorem M_mk_M_dest (x : M P) : M_mk (M_dest x) = x :=
begin
  apply M_bisim' (λ x, true) (M_mk ∘ M_dest) _ _ _ trivial,
  clear x,
  intros x _,
  cases Mxeq : M_dest x with a f',
  have : M_dest (M_mk (M_dest x)) = ⟨a, _⟩,
  { rw [M_mk, M_dest_corec, Mxeq, pfunctor.map_eq, pfunctor.map_eq] },
  refine ⟨_, _, _, this, rfl, _⟩,
  intro i,
  exact ⟨f' i, trivial, rfl, rfl⟩
end

theorem M_dest_M_mk (x : P.apply (M P)) : M_dest (M_mk x) = x :=
begin
  have : M_mk ∘ M_dest = id := funext M_mk_M_dest,
  rw [M_mk, M_dest_corec, ←comp_map, ←M_mk, this, id_map, id]
end

def corec₁ {α : Type u} (F : Π X, (α → X) → α → P.apply X) : α → M P :=
M_corec (F _ id)

def M_corec' {α : Type u} (F : Π {X : Type u}, (α → X) → α → M P ⊕ P.apply X) (x : α) : M P :=
corec₁
(λ X rec (a : M P ⊕ α),
     let y := a >>= F (rec ∘ sum.inr) in
     match y with
     | sum.inr y := y
     | sum.inl y := (rec ∘ sum.inl) <$> M_dest y
     end )
(@sum.inr (M P) _ x)

end pfunctor


/-
Copyright (c) 2021 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin
-/

import category_theory.preadditive.default

/-!
# Preadditive structure on functor categories

If `C` and `D` are categories and `D` is preadditive,
then `C ⥤ D` is also preadditive.

-/

open_locale big_operators

namespace category_theory
open category_theory.limits preadditive

variables {C D : Type*} [category C] [category D] [preadditive D]

instance : preadditive (C ⥤ D) :=
{ hom_group := λ F G,
  { add := λ α β,
    { app := λ X, α.app X + β.app X,
      naturality' := by { intros, rw [comp_add, add_comp, α.naturality, β.naturality] } },
    zero := { app := λ X, 0, naturality' := by { intros, rw [zero_comp, comp_zero] } },
    neg := λ α,
    { app := λ X, -α.app X,
      naturality' := by { intros, rw [comp_neg, neg_comp, α.naturality] } },
    sub := λ α β,
    { app := λ X, α.app X - β.app X,
      naturality' := by { intros, rw [comp_sub, sub_comp, α.naturality, β.naturality] } },
    add_assoc := by { intros, ext, apply add_assoc },
    zero_add := by { intros, ext, apply zero_add },
    add_zero := by { intros, ext, apply add_zero },
    sub_eq_add_neg := by { intros, ext, apply sub_eq_add_neg },
    add_left_neg := by { intros, ext, apply add_left_neg },
    add_comm := by { intros, ext, apply add_comm } },
  add_comp' := by { intros, ext, apply add_comp },
  comp_add' := by { intros, ext, apply comp_add } }

namespace nat_trans

variables {F G : C ⥤ D}

/-- Application of a natural transformation at a fixed object,
as group homomorphism -/
@[simps] def app_hom (X : C) : (F ⟶ G) →+ (F.obj X ⟶ G.obj X) :=
{ to_fun := λ α, α.app X,
  map_zero' := rfl,
  map_add' := λ _ _, rfl }

@[simp] lemma app_zero (X : C) : (0 : F ⟶ G).app X = 0 := rfl

@[simp]

@[simp] lemma app_sub (X : C) (α β : F ⟶ G) : (α - β).app X = α.app X - β.app X := rfl

@[simp] lemma app_neg (X : C) (α : F ⟶ G) : (-α).app X = -α.app X := rfl

@[simp] lemma app_nsmul (X : C) (α : F ⟶ G) (n : ℕ) : (n • α).app X = n • α.app X :=
(app_hom X).map_nsmul α n

@[simp] lemma app_zsmul (X : C) (α : F ⟶ G) (n : ℤ) : (n • α).app X = n • α.app X :=
(app_hom X).map_zsmul α n

@[simp] lemma app_sum {ι : Type*} (s : finset ι) (X : C) (α : ι → (F ⟶ G)) :
  (∑ i in s, α i).app X = ∑ i in s, ((α i).app X) :=
by { rw [← app_hom_apply, add_monoid_hom.map_sum], refl }

end nat_trans

end category_theory


lemma and_symm (P Q : Prop) : P ∧ Q → Q ∧ P :=
begin
    intro h,
    cases h with p q,
    split,
    exact q,
    exact p,
end