{-# OPTIONS --allow-unsolved-metas #-}

-- Andreas, 2014-12-06
-- Reported by sanzhiyan, Dec 4 2014

open import Data.Vec
open import Data.Fin
open import Data.Nat renaming (_+_ to _+N_)
open import Data.Nat.Solver
open import Relation.Binary.PropositionalEquality hiding ([_])
open +-*-Solver using (prove; solve; _:=_; con; var; _:+_; _:*_; :-_; _:-_)

data prop : Set where
  F T   : prop
  _∧_ _∨_ : prop → prop → prop

infixl 4 _∧_ _∨_

Γ : (n : ℕ) → Set
Γ n = Vec prop n

infix 1 _⊢_

data _⊢_ : ∀ {n} → Γ n → prop → Set  where
  hyp     : ∀ {n}(C : Γ n)(v : Fin n) → C ⊢ (lookup v C)
  andI    : ∀ {n}{C : Γ n}{p p' : prop} → C ⊢ p → C ⊢ p' → C ⊢ p ∧ p'
  andEL   : ∀ {n}{C : Γ n}{p p' : prop} → C ⊢ p ∧ p' → C ⊢ p
  andER   : ∀ {n}{C : Γ n}{p p' : prop} → C ⊢ p ∧ p' → C ⊢ p'
  orIL    : ∀ {n}{C : Γ n}{p : prop}(p' : prop) → C ⊢ p → C ⊢ p ∨ p'
  orIR    : ∀ {n}{C : Γ n}{p' : prop}(p : prop) → C ⊢ p' → C ⊢ p ∨ p'
  orE     : ∀ {n}{C : Γ n}{p p' c : prop} → C ⊢ p ∨ p' → p ∷ C ⊢ c → p' ∷ C ⊢ c →  C ⊢ c

-- WAS:
-- The first two _ could not be solved before today's (2014-12-06) improvement of pruning.
-- Except for variables, they were applied to a huge neutral proof term coming from the ring solver.
-- Agda could not prune before the improved neutrality check implemented by Andrea(s) 2014-12-05/06.
--
-- As a consequence, Agda would often reattempt solving, each time doing the expensive
-- occurs check.  This would extremely slow down Agda.

weakening : ∀ {n m p p'}(C : Γ n)(C' : Γ m) → C ++ C' ⊢ p → C ++ [ p' ] ++ C' ⊢ p
weakening {n} {m} {p' = p'} C C' (hyp .(C ++ C') v) = subst (λ R → C ++ (_ ∷ C') ⊢ R) {!!}
          (hyp (C ++ (_ ∷ C')) (subst (λ x → Fin x) proof (inject₁ v))) where
        proof : suc (n +N m) ≡ n +N suc m
        proof = (solve 2 (λ n₁ m₁ → con 1 :+ (n₁ :+ m₁) := n₁ :+ (con 1 :+ m₁)) refl n m)
weakening C C' (andI prf prf') = andI (weakening C C' prf) (weakening C C' prf')
weakening C C' (andEL prf) = andEL (weakening C C' prf)
weakening C C' (andER prf) = andER (weakening C C' prf)
weakening C C' (orIL p'' prf) = orIL p'' (weakening C C' prf)
weakening C C' (orIR p prf) = orIR p (weakening C C' prf)
weakening C C' (orE prf prf₁ prf₂) = orE (weakening C C' prf) (weakening (_ ∷ C) C' prf₁) (weakening (_ ∷ C) C' prf₂)

-- Should check fast now and report the ? as unsolved meta.


{-# OPTIONS --without-K --safe #-}

module Categories.Diagram.Limit.Ran where

open import Level
open import Data.Product using (Σ)

open import Categories.Category
open import Categories.Category.Complete
import Categories.Category.Construction.Cones as ConesCat
open import Categories.Category.Construction.Comma
open import Categories.Category.Construction.Properties.Comma
open import Categories.Category.Instance.One using (One)
open import Categories.Diagram.Cone using (Cone; Cone⇒)
open import Categories.Diagram.Cone.Properties
open import Categories.Diagram.Limit
open import Categories.Diagram.Limit.Properties
open import Categories.Functor
open import Categories.Functor.Properties
open import Categories.Functor.Construction.Constant
open import Categories.Kan
open import Categories.NaturalTransformation
open import Categories.NaturalTransformation.Equivalence using () renaming (_≃_ to _≊_)
open import Categories.NaturalTransformation.NaturalIsomorphism using (NaturalIsomorphism; _≃_; module ≃; _ⓘˡ_)
open import Categories.Object.Terminal using (Terminal)

import Categories.Morphism as Mor
import Categories.Morphism.Reasoning as MR

-- construct a Ran from a limit
module _ {o ℓ e o′ ℓ′ e′ o″ ℓ″ e″} {C : Category o′ ℓ′ e′} {D : Category o ℓ e} {E : Category o″ ℓ″ e″}
         (F : Functor C D) (X : Functor C E) (Com : Complete (o′ ⊔ ℓ) (ℓ′ ⊔ e) e′ E) where
  private
    module C = Category C
    module D = Category D
    module E = Category E
    module F = Functor F
    module X = Functor X
    open Limit using (limit; proj; apex; module terminal)
    open Cone using () renaming (commute to K-commute)
    open ConesCat.Cone⇒ using (arr) renaming (commute to ⇒-commute)
    open Mor E using (_≅_)

    G   : (d : D.Obj) → Functor (d ↙ F) E
    G d = X ∘F Cod {A = One} {B = C} {C = D} (const! d) F

    ⊤Gd : (d : D.Obj) → Limit (G d)
    ⊤Gd d = Com (G d)
    module ⊤Gd d = Limit (⊤Gd d) using (proj; limit; rep; rep-cone; apex; module terminal)

    f↙F : {Y Z : D.Obj} (f : Y D.⇒ Z) → Functor (Z ↙ F) (Y ↙ F)
    f↙F   =  along-natˡ′ F

    Gf≃ : {Y Z : D.Obj} (f : Y D.⇒ Z) → G Z ≃ G Y ∘F f↙F f
    Gf≃ f = record
      { F⇒G = record
        { η           = λ z/F →  let j = CommaObj.β z/F in X.₁ {j} C.id -- help inference a bit
        ; commute     = λ _ → [ X ]-resp-square id-comm-sym
        ; sym-commute = λ _ → [ X ]-resp-square id-comm
        }
      ; F⇐G = record
        { η       = λ _ → X.₁ C.id
        ; commute = λ _ → [ X ]-resp-square id-comm-sym
        ; sym-commute = λ _ → [ X ]-resp-square id-comm
        }
      ; iso = λ _ → record
        { isoˡ = [ X ]-resp-∘ C.identity² ○ X.identity
        ; isoʳ = [ X ]-resp-∘ C.identity² ○ X.identity
        }
      }
      where open MR C using (id-comm-sym; id-comm)
            open E.HomReasoning using (_○_)

    Compl : {Y Z : D.Obj} (f : Y D.⇒ Z) → Limit (G Y ∘F f↙F f)
    Compl {Y} f = Com (G Y ∘F f↙F f)

    limY⇒limZ∘ : {Y Z : D.Obj} (f : Y D.⇒ Z) →
        ConesCat.Cones (G Y ∘F f↙F f) [ F-map-Coneʳ (f↙F f) (limit (Com (G Y))) , limit (Compl f) ]
    limY⇒limZ∘ {Y} f = F⇒arr Com (f↙F f) (G Y)

    limZ∘≅limZ : {Y Z : D.Obj} (f : Y D.⇒ Z) → ⊤Gd.apex Z ≅ apex (Compl f)
    limZ∘≅limZ {Y} {Z} f = ≃⇒lim≅ (Gf≃ f) (⊤Gd Z) (Compl f)

  limit-is-ran : Ran F X
  limit-is-ran = record
    { R        = R
    ; ε        = ε
    ; δ        = δ
    ; δ-unique = λ {M γ} δ′ eq → δ-unique {M} {γ} δ′ eq
    ; commutes = commutes
    }
    where
    open MR E
    open E.HomReasoning
    module DH = D.HomReasoning

    R₀ : D.Obj → E.Obj
    R₀ = ⊤Gd.apex
    R₁ : ∀ {A B} → D [ A , B ] → E [ R₀ A , R₀ B ]
    R₁ {A} f = _≅_.to (limZ∘≅limZ f) E.∘ arr (limY⇒limZ∘ f)

    ↙⇒ : {Y Z : D.Obj} (K : CommaObj {A = One} {C} {D} (const Z) F) (f : Y D.⇒ Z) → CommaObj {A = One} {C} {D} (const Y) F
    ↙⇒ K f = record { β = CommaObj.β K; f = D.id D.∘ CommaObj.f K D.∘ f }

    proj-red : {Y Z : D.Obj} (K : CommaObj (const Z) F) (f : Y D.⇒ Z) → ⊤Gd.proj Z K E.∘ R₁ f E.≈ ⊤Gd.proj Y (↙⇒ K f)
    proj-red {Y} {Z} K f = begin
      ⊤Gd.proj Z K E.∘ R₁ f                                  ≈⟨ pullˡ (⇒-commute (≃⇒Cone⇒ (≃.sym (Gf≃ f)) (Compl f) (⊤Gd Z))) ⟩
      (X.₁ C.id E.∘ proj (Compl f) K) E.∘ arr (limY⇒limZ∘ f) ≈⟨ pullʳ (⇒-commute (limY⇒limZ∘ f)) ⟩
      X.₁ C.id E.∘ ⊤Gd.proj Y f/K                            ≈⟨ elimˡ X.identity ⟩
      ⊤Gd.proj Y f/K                                         ∎
      where
      f/K : CommaObj {A = One} {C} {D} (const Y) F
      f/K = ↙⇒ K f

    commaF : {d : D.Obj} {c : C.Obj} (f : d D.⇒ F.₀ c) → CommaObj {A = One} {C} {D} (const d) F
    commaF f = record { f = f }

    proj≈ : {d : D.Obj} {b : C.Obj} {f g : d D.⇒ F.₀ b} → f D.≈ g → ⊤Gd.proj d (commaF f) E.≈ ⊤Gd.proj d (commaF g)
    proj≈ {d} {b} {f} {g} eq = begin
      ⊤Gd.proj d (commaF f)              ≈⟨ introˡ X.identity ⟩
      X.₁ C.id E.∘ ⊤Gd.proj d (commaF f) ≈⟨ K-commute (⊤Gd.limit d) C⇒ ⟩
      ⊤Gd.proj d (commaF g)               ∎
      where
      C⇒ : Comma⇒ (commaF f) (commaF g)
      C⇒ = record
             { h = C.id
             ; commute = DH.begin
               F.₁ C.id D.∘ f   DH.≈⟨ D.∘-resp-≈ F.identity eq ⟩
               D.id D.∘ g       DH.≈⟨ MR.id-comm-sym D  ⟩
               g D.∘ D.id       DH.∎
              }

    ConesGd : {d : D.Obj} → Functor (Comma {A = One} (const d) F) E
    ConesGd {d} = X ∘F Cod {A = One} {B = C} {C = D} (const d) F

    R-identity : {d : D.Obj} → R₁ {d} D.id E.≈ E.id
    R-identity {d} = G.terminal.⊤-id ConeArr
        where
        open E
        module G = Limit (Com (G d))
        ConeArr : Cone⇒ (ConesGd {d}) G.limit G.limit
        ConeArr = record
          { arr = R₁ D.id
          ; commute = λ {Z} → begin
            G.proj Z ∘ R₁ D.id  ≈⟨ proj-red Z D.id ⟩
            G.proj (↙⇒ Z D.id) ≈⟨ proj≈ (D.Equiv.trans D.identityˡ D.identityʳ) ⟩
            G.proj Z            ∎
          }

    R-hom : {Y Z W : D.Obj} {f : D [ Y , Z ]} {g : D [ Z , W ]} → E [ R₁ (D [ g ∘ f ]) ≈ E [ R₁ g ∘ R₁ f ] ]
    R-hom {Y} {Z} {W} {f} {g} = terminal.!-unique₂ (⊤Gd W) {A = cc} {f = f⇒} {g = g⇒}
      where
      module ⊤GY = Cone (⊤Gd.limit Y)
      module H   = Functor (f↙F (g D.∘ f)) using (₀; ₁)
      open E
      cc : Cone (X ∘F Cod (const W) F)
      cc = record { N = ⊤GY.N; apex = record
        { ψ      =  λ K → ⊤GY.ψ (H.₀ K)
        ; commute = λ h → ⊤GY.commute (H.₁ h)
        } }
      f⇒ : Cone⇒ (ConesGd {W}) cc (⊤Gd.terminal.⊤ W)
      f⇒ = record
        { arr = R₁ (g D.∘ f)
        ; commute = λ {K} → proj-red K (g D.∘ f)
        }
      g⇒ : Cone⇒ (ConesGd {W}) cc (⊤Gd.terminal.⊤ W)
      g⇒ = record
        { arr = R₁ g ∘ R₁ f
        ; commute = λ {K} → begin
          ⊤Gd.proj W K ∘ R₁ g ∘ R₁ f        ≈⟨ pullˡ (proj-red K g) ⟩
          ⊤Gd.proj Z (↙⇒ K g) ∘ R₁ f       ≈⟨ proj-red (↙⇒ K g) f ⟩
          ⊤Gd.proj Y (↙⇒ (↙⇒ K g) f)     ≈⟨ proj≈ (D.Equiv.trans D.identityˡ (MR.assoc²' D)) ⟩
          ⊤Gd.proj Y (↙⇒ K (g D.∘ f))      ∎
        }

    R-resp-≈ : {Y Z : D.Obj} {f g : D [ Y , Z ]} → D [ f ≈ g ] → E [ R₁ f ≈ R₁ g ]
    R-resp-≈ {Y} {Z} {f} {g} f≈g = terminal.!-unique₂ (⊤Gd Z) {A = cc} {f = fc} {g = gc}
      where
      open E
      module ⊤GY = Cone (⊤Gd.limit Y)
      module H = Functor (f↙F f)
      cc : Cone (X ∘F Cod (const Z) F)
      cc = record { apex = record
            { ψ       = λ K → ⊤GY.ψ (H.F₀ K)
            ; commute = λ h → ⊤GY.commute (H.F₁ h)
            } }
      F-resp-≈-commute : ∀ {Y Z} {K : Category.Obj (Z ↙ F)} {f g : Y D.⇒ Z} → f D.≈ g →
                           ⊤Gd.proj Z K ∘ R₁ f ≈ ⊤Gd.proj Y (↙⇒ K g)
      F-resp-≈-commute {Y} {Z} {K} {f} {g} eq = begin
        ⊤Gd.proj Z K ∘ R₁ f   ≈⟨ proj-red K f ⟩
        ⊤Gd.proj Y (↙⇒ K f) ≈⟨ proj≈ (D.∘-resp-≈ʳ (D.∘-resp-≈ʳ eq)) ⟩
        ⊤Gd.proj Y (↙⇒ K g) ∎
      fc : Cone⇒ (ConesGd {Z}) cc (⊤Gd.terminal.⊤ Z)
      fc = record
        { arr     = R₁ f
        ; commute = λ {X} → F-resp-≈-commute {Y} {Z} {X} {f} {f} D.Equiv.refl
        }
      gc : Cone⇒ (ConesGd {Z}) cc (⊤Gd.terminal.⊤ Z)
      gc = record
        { arr = R₁ g
        ; commute = λ {X} → F-resp-≈-commute {Y} {Z} {X} {g} {f} (D.Equiv.sym f≈g)
        }

    R : Functor D E
    R = record
      { F₀           = R₀
      ; F₁           = R₁
      ; identity     = λ {d} → R-identity {d}
      ; homomorphism = λ {A B C} {f g} → R-hom {A} {B} {C} {f} {g}
      ; F-resp-≈     = λ {A B} {f g} → R-resp-≈ {A} {B} {f} {g}
      }

    ,Fc : (c : C.Obj) → CommaObj {A = One} {B = C} {C = D} (const (F.₀ c)) F
    ,Fc c = record { β = c ; f = D.id }

    ε : NaturalTransformation (R ∘F F) X
    ε = ntHelper record
      { η       = λ c → ⊤Gd.proj (F.F₀ c) record { f = D.id }
      ; commute = λ {Y Z} f → begin
        ⊤Gd.proj (F.F₀ Z) _ ∘ Functor.F₁ (R ∘F F) f ≈⟨ proj-red _ (F.F₁ f) ⟩
        ⊤Gd.proj (F.F₀ Y) _                         ≈˘⟨ K-commute {C = E} (⊤Gd.limit (F.F₀ Y)) record { h = f ; commute = D.Equiv.sym (D.Equiv.trans (D.∘-resp-≈ˡ D.identityˡ) (D.∘-resp-≈ˡ D.identityˡ)) } ⟩
        X.F₁ f ∘ ⊤Gd.proj (F.F₀ Y) _                ∎
      }
      where open E

{-
    ε : NaturalTransformation (R ∘F F) X
    ε = ntHelper record
      { η       = λ c → ⊤Gd.proj (F.₀ c) (,Fc c)
      ; commute = λ {Y Z} f → let module G = Limit (Com (G (F.₀ Y))) in begin
        ⊤Gd.proj (F.₀ Z) (,Fc Z) E.∘ Functor.F₁ (R ∘F F) f ≈⟨ proj-red (,Fc Z) (F.₁ f) ⟩
        G.proj (↙⇒ (,Fc Z) (F.₁ f))                       ≈˘⟨ K-commute {C = E} {J = Comma (const (F.₀ Y)) F} {F = ConesGd {F.₀ Y}}
                                                                         G.limit (,⇒ f) ⟩
        X.₁ f E.∘ G.proj (,Fc Y)                           ∎
      }
        where
        ,⇒ : {Y Z : C.Obj} (f : Y C.⇒ Z) → Comma⇒ (,Fc Y) (↙⇒ (,Fc Z) (F.₁ f))
        ,⇒ f = record
               { g = _
               ; h = f
               ; commute = DH.begin
                   F.₁ f D.∘ D.id                      DH.≈˘⟨ D.identityˡ DH.⟩∘⟨refl ⟩
                   ((D.id D.∘ F.₁ f) D.∘ D.id)         DH.≈˘⟨ D.identityˡ DH.⟩∘⟨refl ⟩
                    (D.id D.∘ D.id D.∘ F.₁ f) D.∘ D.id DH.∎
               }
-}
    δ-Cone : ∀ d (M : Functor D E) → NaturalTransformation (M ∘F F) X → Cone (G d)
    δ-Cone d M γ = record
      { apex = record
        { ψ       = λ K → γ.η (β K) E.∘ M.₁ (f K)
        ; commute = λ {Y Z} g → begin
          X.₁ (h g) E.∘ γ.η (β Y) E.∘ M.₁ (f Y)          ≈˘⟨ pushˡ (γ.commute (h g)) ⟩
          (γ.η (β Z) E.∘ M.₁ (F.₁ (h g))) E.∘ M.₁ (f Y)  ≈⟨  pullʳ ([ M ]-resp-∘ (D.Equiv.trans (commute g) D.identityʳ))  ⟩
          γ.η (β Z) E.∘ M.₁ (f Z)
            ∎
        }
      }
      where module M = Functor M
            module γ = NaturalTransformation γ
            open CommaObj
            open Comma⇒

    δ : (M : Functor D E) → NaturalTransformation (M ∘F F) X → NaturalTransformation M R
    δ M γ = record
      { η           = λ d → ⊤Gd.rep d (δ-Cone d M γ)
      ; commute     = λ {Y Z} f → terminal.!-unique₂ (⊤Gd Z) {cc f} {q⇒ f} {w⇒ f}
      ; sym-commute = λ {Y Z} f → terminal.!-unique₂ (⊤Gd Z) {cc f} {w⇒ f} {q⇒ f}
      }
      where module M        = Functor M
            module γ        = NaturalTransformation γ
            module δ-Cone d = Cone (δ-Cone d M γ)
            open CommaObj
            cc : {Y Z : D.Obj} → Y D.⇒ Z → Cone (X ∘F Cod (const Z) F)
            cc {_} {Z} f = record
                 { apex = record
                   { ψ       = λ W → δ-Cone.ψ Z W E.∘ M.F₁ f
                   ; commute = λ g → pullˡ (δ-Cone.commute Z g)
                   }
                 }
            q⇒ : {Y Z : D.Obj} → (f : Y D.⇒ Z) → Cone⇒ (ConesGd {Z}) (cc f) (⊤Gd.terminal.⊤ Z)
            q⇒ {Y} {Z} f = record
              { arr     = ⊤Gd.rep Z (δ-Cone Z M γ) E.∘ M.F₁ f
              ; commute = pullˡ (⇒-commute (⊤Gd.rep-cone Z (δ-Cone Z M γ)))
              }
            w⇒ : {Y Z : D.Obj} → (g : Y D.⇒ Z) → Cone⇒ (ConesGd {Z}) (cc g) (⊤Gd.terminal.⊤ Z)
            w⇒ {Y} {Z} g = record
              { arr     = R₁ g E.∘ ⊤Gd.rep Y (δ-Cone Y M γ)
              ; commute = λ {W} → begin
                ⊤Gd.proj Z W E.∘ R₁ g E.∘ ⊤Gd.rep Y (δ-Cone Y M γ)  ≈⟨ pullˡ (proj-red W g) ⟩
                ⊤Gd.proj Y (↙⇒ W g) E.∘ ⊤Gd.rep Y (δ-Cone Y M γ)  ≈⟨ ⇒-commute (⊤Gd.rep-cone Y (δ-Cone Y M γ)) ⟩
                γ.η (β W) E.∘ M.F₁ (D.id D.∘ f W D.∘ g)             ≈˘⟨ refl⟩∘⟨ [ M ]-resp-∘ ( D.Equiv.sym D.identityˡ ) ⟩
                γ.η (β W) E.∘ M.F₁ (f W) E.∘ M.F₁ g                 ≈⟨ E.sym-assoc ⟩
                (γ.η (β W) E.∘ M.F₁ (f W)) E.∘ M.F₁ g               ∎
              }

    δ-unique : ∀ {M : Functor D E} {γ : NaturalTransformation (M ∘F F) X}
                 (δ′ : NaturalTransformation M R) → γ ≊ ε ∘ᵥ δ′ ∘ʳ F → δ′ ≊ δ M γ
    δ-unique {M} {γ} δ′ eq {d} = ⟺ (⊤Gd.terminal.!-unique d C⇒)
      where
      module M = Functor M using (₁)
      module γ = NaturalTransformation γ using (η)
      module δ = NaturalTransformation δ′ using (η; commute)
      open CommaObj
      C⇒ : Cone⇒ (X ∘F Cod (const d) F) (δ-Cone d M γ) (terminal.⊤ (⊤Gd d))
      C⇒ = record
        { arr     = δ.η d
        ; commute = λ {W} → begin
          ⊤Gd.proj d W E.∘ δ.η d                                                   ≈˘⟨ proj≈ (D.Equiv.trans D.identityˡ D.identityˡ)  ⟩∘⟨refl ⟩
          ⊤Gd.proj d (↙⇒ (commaF D.id) (f W)) E.∘ δ.η d                          ≈˘⟨ pullˡ (proj-red (commaF D.id) (f W)) ⟩
          ⊤Gd.proj (F.₀ (β W)) (commaF D.id) E.∘ R₁ (f W) E.∘ δ.η d                ≈˘⟨ pullʳ (δ.commute (f W)) ⟩
          (⊤Gd.proj (F.₀ (β W)) (commaF D.id) E.∘ δ.η (F.₀ (β W))) E.∘ M.₁ (f W)   ≈˘⟨ eq ⟩∘⟨refl ⟩
          γ.η (β W) E.∘ M.₁ (f W)
            ∎
        }

    commutes : (M : Functor D E) (γ : NaturalTransformation (M ∘F F) X) → γ ≊ ε ∘ᵥ δ M γ ∘ʳ F
    commutes M γ {c} = begin
        η γ c                 ≈˘⟨ elimʳ M.identity ⟩
        η γ c E.∘ M.₁ D.id    ≈˘⟨ ⇒-commute (⊤Gd.rep-cone (F.₀ c) (δ-Cone (F.₀ c) M γ)) {,Fc c} ⟩
        η (ε ∘ᵥ δ M γ ∘ʳ F) c ∎
      where
      open NaturalTransformation
      module M  = Functor M using (₁; identity)


{-# OPTIONS --cubical --safe #-}

module Cubical.Homotopy.PointedFibration where

open import Cubical.Core.Everything

open import Cubical.Data.Nat

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Pointed
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.GroupoidLaws
open import Cubical.Foundations.Function
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.HLevels
open import Cubical.Homotopy.Base
open import Cubical.Homotopy.Connected
open import Cubical.Homotopy.Loopspace
open import Cubical.Data.Nat
open import Cubical.Data.Nat.Order
open LowerBoundedInduction
open import Cubical.Data.Sigma
open import Cubical.Data.Unit
open import Cubical.Foundations.HLevels'
open import Cubical.Foundations.Structure

private
  variable
    ℓ ℓ' : Level

-- Different versions of Theorem 9. We abstract ℓ' again here
-- to avoid some issues with implicit arguments.
module _ {ℓ' : Level} (X : Pointed ℓ) where
  -- block of private stuff to reduce redundancy in the proof of the theorem
  private
    module _ (n k : ℕ) where
      -- A, together with its paramenters/context, is just the statement of the theorem.
      A : Type (ℓ-max ℓ (ℓ-suc ℓ'))
      A = (isConnX : isConnected (k + 1) (typ X))
          → (Y : typ X → Σ[ Yx ∈ Pointed ℓ' ] (isOfHLevel (n + k) (typ Yx)))
          → isOfHLevel (n) (Π∙ X (λ x → typ (fst (Y x))) (pt (fst (Y (pt X)))))

    module PointSec (n k : ℕ)
                    (isConnX : isConnected (k + 1) (typ X))
                    (Y : typ X → Σ[ Yx ∈ Pointed ℓ' ] (isOfHLevel (n + k) (typ Yx))) where
      -- The type of pointed sections (x : X) →ₚₜ Y x
      sec∙ : Type (ℓ-max ℓ ℓ')
      sec∙ = Π∙ X (λ x → typ (fst (Y x))) (pt (fst (Y (pt X))))

      -- Note that if isOfHLevel had a uniform interface for n ≥ 1 then this should be a part of the where
      -- clause in the theorem.
      module PointSecProps where
        -- Given s, the type of pointed sections (x : X) →ₚₜ Ω(Y x, s x)
        sec∙' : (s : sec∙) → Type (ℓ-max ℓ ℓ')
        sec∙' s = Π∙ X (λ x → s .fst x ≡ s .fst x) refl

        -- towards sec∙' s ≃ (s ≡ s)
        secIso : (s : sec∙) → Iso (sec∙' s) (s ∙∼ s)
        secIso (_ , s₂) = iso (λ (H , p) → H , p ∙ sym (rCancel s₂))
                        (λ (H , p) → H , p ∙ rCancel s₂)
                        (λ (H , p) → ΣPathP (refl ,
                                            sym (assoc p (rCancel s₂) (sym (rCancel s₂))) ∙∙
                                            cong (p ∙_) (rCancel (rCancel s₂)) ∙∙
                                            sym (rUnit p)))
                        (λ (H , p) → ΣPathP (refl ,
                                            sym (assoc p
                                                       (sym (rCancel s₂))
                                                       (rCancel s₂)) ∙∙
                                            cong (p ∙_) (lCancel (rCancel s₂)) ∙∙
                                            sym (rUnit p)))

        -- compose the equivalences
        sec≃ : (s : sec∙) → sec∙' s ≃ (s ≡ s)
        sec≃ = λ (s : sec∙) → compEquiv (isoToEquiv (secIso s)) (funExt∙≃ s s)

  -- p.9 Theorem 3 of Higher Types in HoTT
  sec∙Trunc : {n k : ℕ} → A (n + 1) (k)
  sec∙Trunc {n = 0} {k} isConnX Y = isContr→isProp (s₀ , λ s → funExt∙ (s₀∙∼s s))
    where
      sec∙ : Type (ℓ-max ℓ ℓ')
      sec∙ = Π∙ X (λ x → typ (fst (Y x))) (pt (fst (Y (pt X))))

      module _ where
        -- trivial section
        s₀ : sec∙
        s₀ = (λ a → pt (fst (Y a))) , refl

        -- abbreviations
        s₀₁ = fst s₀
        ⋆ = pt X

        -- the k-connected map 𝟙 → X
        f : Unit → typ X
        f tt = ⋆

        -- proof that f is k-connected
        fkconn : isConnectedFun k f
        fkconn = UnitConnectedFunElim isConnX f

        -- notation
        module _ (s : sec∙) where
          s₁ = fst s
          s₂ = snd s

          -- the regular homotopies between the trivial section and s coincide with the
          -- identity type s₀₁ ⋆ ≡ s₁ ⋆
          -- the Unit type will be eliminated in the next step
          IsoHtpy𝟙Idpt : Iso (s₀₁ ∼ s₁) (Unit → s₀₁ ⋆ ≡ s₁ ⋆)
          IsoHtpy𝟙Idpt = elim.isIsoPrecompose f k (λ (x : typ X) → (s₀₁ x ≡ s₁ x) , HL← (HL→ (snd (Y x)) (s₀₁ x) (s₁ x))) fkconn

          IsoHtpyIdpt : Iso (s₀₁ ∼ s₁) (s₀₁ ⋆ ≡ s₁ ⋆)
          IsoHtpyIdpt = compIso IsoHtpy𝟙Idpt (𝟙-universal (s₀₁ ⋆ ≡ s₁ ⋆))

          -- judgementally,
          -- (s₀ ∙∼ s) ≡ (Σ[ h ∈ (s₀₁ ∼ s₁) ] (h ⋆ ≡ (snd s₀) ∙ s₂ ⁻¹))
          -- The right inverse of IsoHtpyIdpt gives such a pointed homotopy
          s₀∙∼s : s₀ ∙∼ s
          fst s₀∙∼s = Iso.inv IsoHtpyIdpt (refl ∙ s₂ ⁻¹)
          snd s₀∙∼s =
            Iso.inv IsoHtpyIdpt (refl ∙ s₂ ⁻¹) ⋆
              ≡⟨ refl ⟩
            Iso.fun IsoHtpyIdpt (Iso.inv IsoHtpyIdpt (refl ∙ s₂ ⁻¹))
              ≡⟨ Iso.rightInv IsoHtpyIdpt (refl ∙ s₂ ⁻¹) ⟩
            refl ∙ s₂ ⁻¹ ∎

  sec∙Trunc {n = 1} {k} isConnX Y = truncSelfId→truncId {n = 0} (λ s → EquivPresHLevel {n = 1} (sec≃ s) (sec∙Trunc {n = 0} {k} isConnX λ x → ((s .fst x ≡ s .fst x) , refl) , (snd (Y x) (s .fst x) (s .fst x))))
    where
      open PointSec 2 k isConnX Y
      open PointSecProps

  sec∙Trunc {n = suc (suc m)} {k} isConnX Y =
    -- suffices to show that loop spaces are truncated
    truncSelfId→truncId
      -- each self-identity type of a section s is equivalent to a type of sections
      λ s → EquivPresHLevel (sec≃ s)
        -- that the induction hypothesis can be applied to
        (sec∙Trunc {n = suc m} isConnX λ x → ((s .fst x ≡ s .fst x) , refl) , snd (Y x) (s .fst x) (s .fst x))
    where
      open PointSec (suc (suc m) + 1) k isConnX Y
      open PointSecProps

  -- alternate version of sec∙Trunc with bound on n instead of adding a bound
  sec∙Trunc' : {n k : ℕ} (1≤n : 1 ≤ n) → A n k
  sec∙Trunc' {n = n} {k = k} 1≤n
    = +Type→≤Type 1 (λ n → A n k) (λ r isConnX Y → sec∙Trunc {n = r} {k = k} isConnX Y) n 1≤n

module _ (X : Pointed ℓ) (Y : Pointed ℓ') where
  pointed-maps-truncated : {n k : ℕ}
                           → 1 ≤ n
                           → isConnected (k + 1) (typ X)
                           → isOfHLevel (n + k) (typ Y)
                           → isOfHLevel (n) (X →∙ Y)
  pointed-maps-truncated {n = n} 1≤n connX truncY =
    sec∙Trunc' X 1≤n connX λ _ → Y , truncY


{-# OPTIONS --without-K #-}
module Cat where

import Level as L
open import Data.Fin hiding (fromℕ; toℕ)
open import Data.Nat
open import Data.Product
open import Data.List
open import Function renaming (_∘_ to _○_)

open import HoTT
open import FT
open import FT-Nat
import Equivalences as E
open import Path2Equiv

{--
1. postulate path2equiv
2. show that (FT, path) is equivalent to (FinSet, bijections) as categories
3. show that [[ ]]: (B, <->) -> (Set, function) is a functor
   [where (Set is Agda's Set)].
--}

{--
Categories, functors, etc. adapted from:
http://wiki.portal.chalmers.se/agda/uploads/Main.Libraries/20110915Category.agda

Consider using:
https://github.com/tomprince/agda-categories
https://github.com/tomprince/agda-categories/blob/master/Categories/Category.agda
--}

------------------------------------------------------------------
-- Categories

record Setoid (a b : L.Level) : Set (L.suc (a L.⊔ b)) where
  infix 2 _∼_
  field
    object : Set a
    _∼_ : object → object → Set b
    refl∼ : {x : object} → x ∼ x
    sym∼ : {x y : object} → x ∼ y → y ∼ x
    trans∼ : {x y z : object} → y ∼ z → x ∼ y → x ∼ z

strictSetoid : ∀ {a} → Set a → Setoid a a
strictSetoid A = record
  { object = A
  ; _∼_ = _≡_
  ; refl∼ = λ {x} → refl x
  ; sym∼ = !
  ; trans∼ = λ q p → p ∘ q
  }

∥_∥ : ∀ {a b c} {X : Set a} → (h : X → X → Setoid b c) → (x y : X) → Set b
∥ h ∥ x y = Setoid.object (h x y)

record Cat (a b c : L.Level) : Set (L.suc (a L.⊔ b L.⊔ c)) where
  field
    object : Set a
    hom : object → object → Setoid b c
    identity : (x : object) → ∥ hom ∥ x x
    comp : {x y z : object} → ∥ hom ∥ y z → ∥ hom ∥ x y → ∥ hom ∥ x z
    comp∼ : {x y z : object} →
             {g0 g1 : ∥ hom ∥ y z} → {f0 f1 : ∥ hom ∥ x y} →
             (g0∼g1 : let open Setoid (hom y z) in g0 ∼ g1) →
             (f0∼f1 : let open Setoid (hom x y) in f0 ∼ f1) →
             let open Setoid (hom x z) in comp g0 f0 ∼ comp g1 f1
    associativity∼ : {w x y z : object} →
      (f : ∥ hom ∥ y z) → (g : ∥ hom ∥ x y) → (h : ∥ hom ∥ w x) →
      let open Setoid (hom w z) in comp (comp f g) h ∼ comp f (comp g h)
    left-identity∼ : {x y : object} → (f : ∥ hom ∥ x y) →
      let open Setoid (hom x y) in comp (identity y) f ∼ f
    right-identity∼ : {x y : object} → (f : ∥ hom ∥ x y) →
      let open Setoid (hom x y) in comp f (identity x) ∼ f

-- the type of objects in category C
ob : ∀ {a b c} → Cat a b c → Set a
ob C = Cat.object C

-- the type of morphisms between two given objects in C
_〈_,_〉 : ∀ {a b c} → (C : Cat a b c) → ob C → ob C → Set b
C 〈 X , Y 〉 = ∥ Cat.hom C ∥ X Y

-- the type of identities of morphisms
_∣_∼_ : ∀ {a b c} → (C : Cat a b c) → {X Y : ob C} →
        C 〈 X , Y 〉 → C 〈 X , Y 〉 → Set c
_∣_∼_ C {X} {Y} f g = Setoid._∼_ (Cat.hom C X Y) f g

-- convenient abbreviation for identity morphism
idC : ∀ {a b c} → (C : Cat a b c) → (x : ob C) → C 〈 x , x 〉
idC C x = Cat.identity C x

-- convenient abbreviation for composition of morphisms
_∣_∘_ : ∀ {a b c} → (C : Cat a b c) → {x y z : ob C } →
        C 〈 y , z 〉 → C 〈 x , y 〉 → C 〈 x , z 〉
C ∣ g ∘ f = Cat.comp C g f

------------------------------------------------------------------
-- Functors
record _=>_ {a b c a' b' c'} (C : Cat a b c) (D : Cat a' b' c') :
  Set (a L.⊔ a' L.⊔ b L.⊔ b' L.⊔ c L.⊔ c') where
  field
    object : ob C  → ob D
    hom : {X Y : ob C} →
      C 〈 X , Y 〉 → D 〈 object X , object Y 〉
    hom∼ : {X Y : ob C} → (f g : C 〈 X , Y 〉) →
      (f∼g : C ∣ f ∼ g) → D ∣ hom f ∼ hom g
    identity∼ : {X : ob C} →
      D ∣ hom (idC C X) ∼ idC D (object X)
    comp∼ : {X Y Z : ob C} → (f : C 〈 Y , Z 〉) → (g : C 〈 X , Y 〉) →
      D ∣ hom (C ∣ f ∘ g) ∼ (D ∣ hom f ∘ hom g)

-- Applying the functor to objects
_`_ : ∀ {a b c a' b' c'} {X : Cat a b c} → {Y : Cat a' b' c'} →
  X => Y → ob X → ob Y
F ` x = _=>_.object F x

-- Applying the functor to morphisms
_``_ : ∀ {a b c a' b' c'} {X : Cat a b c} → {Y : Cat a' b' c'} →
  {x0 x1 : ob X} → (F : X => Y) → X 〈 x0 , x1 〉 → Y 〈 F ` x0 , F ` x1 〉
F `` f = _=>_.hom F f

------------------------------------------------------------------
-- The category (FinSet,bijections)
-- M, N, L are finite sets witnessed by their sizes m, n, l
-- F, G, H are bijections

-- bijections between two sets M and N
record Bijection (m n : ℕ) : Set where
  field
    f : Fin m → Fin n
    g : Fin n → Fin m
    injective  : {x y : Fin m} → f x ≡ f y → x ≡ y
    surjective : {x : Fin n} → f (g x) ≡ x

-- there is a bijection from each set to itself
idBijection : (m : ℕ) → Bijection m m
idBijection m = record {
    f = id ;
    g = id ;
    injective = id ;
    surjective = λ {x} → refl x
  }

-- composition of bijections
∘Bijection : {m n l : ℕ} → Bijection n l → Bijection m n → Bijection m l
∘Bijection G F = record {
    f = Bijection.f G ○ Bijection.f F ;
    g = Bijection.g F ○ Bijection.g G ;
    injective = λ α → Bijection.injective F (Bijection.injective G α) ;
    surjective = λ {x} →
      Bijection.f G (Bijection.f F (Bijection.g F (Bijection.g G x)))
        ≡⟨ ap (λ x → Bijection.f G x) (Bijection.surjective F) ⟩
      Bijection.f G (Bijection.g G x)
        ≡⟨ Bijection.surjective G ⟩
      x ∎
  }

-- two bijections are the "same" if they agree modulo ≡
∼Bijection : {m n : ℕ} → Bijection m n → Bijection m n → Set
∼Bijection F G = (Bijection.f F) E.∼ (Bijection.f G)

-- the set of all bijections between two sets M and N taken modulo ≡
BijectionSetoid : (m n : ℕ) → Setoid L.zero L.zero
BijectionSetoid m n = record {
    object = Bijection m n ;
    _∼_ = ∼Bijection ;
    refl∼ = λ {F} → E.refl∼ {f = Bijection.f F} ;
    sym∼ = λ {F} {G} →
             E.sym∼ {f = Bijection.f F} {g = Bijection.f G} ;
    trans∼ = λ {F} {G} {H} P Q →
               E.trans∼ {f = Bijection.f F}
                        {g = Bijection.f G}
                        {h = Bijection.f H}
                        Q P
    }

-- the category of finite sets and bijections
FinCat : Cat L.zero L.zero L.zero
FinCat = record {
          object = ℕ ;
          hom = BijectionSetoid ;
          identity = idBijection ;
          comp = λ G F → ∘Bijection G F ;
          comp∼ = λ {m} {n} {l} {G₀} {G₁} {F₀} {F₁} Q P x →
                    Bijection.f (∘Bijection G₀ F₀) x
                      ≡⟨ bydef ⟩
                    Bijection.f G₀ (Bijection.f F₀ x)
                      ≡⟨ ap (λ z → Bijection.f G₀ z) (P x) ⟩
                    Bijection.f G₀ (Bijection.f F₁ x)
                      ≡⟨ Q (Bijection.f F₁ x) ⟩
                    Bijection.f (∘Bijection G₁ F₁) x ∎ ;
          associativity∼  = λ F G H x →
            Bijection.f (∘Bijection F G) (Bijection.f H x)
              ≡⟨ bydef ⟩
            Bijection.f F (Bijection.f G (Bijection.f H x)) ∎ ;
          left-identity∼  = λ {m} {n} F x →
            Bijection.f (idBijection n) (Bijection.f F x)
              ≡⟨ bydef ⟩
            Bijection.f F x ∎ ;
          right-identity∼ = λ {m} {n} F x →
            Bijection.f F (Bijection.f (idBijection m) x)
              ≡⟨ bydef ⟩
            Bijection.f F x ∎
      }

------------------------------------------------------------------
-- The category (FinSet,HoTT-equivalence)
-- M, N, L are finite sets witnessed by their sizes m, n, l
-- F, G, H are equivalences

-- an equivalence (A ≃ B) consists of a function f : A → B
-- and a proof that it is an equivalence; the proof consists of
-- two functions g and h : B → A together with two proofs that
-- (f ○ g) ∼ id and (h ○ f) ∼ id
-- for now, I am suggesting that two such equivalences are the same
-- if the forward functions f are the same
∼Equiv : {m n : ℕ} → (Fin m E.≃ Fin n) → (Fin m E.≃ Fin n) → Set
∼Equiv F G = (proj₁ F) E.∼ (proj₁ G)

-- the set of all equivalences between two sets M and N taken modulo ≡
EquivSetoid : (m n : ℕ) → Setoid L.zero L.zero
EquivSetoid m n = record {
    object = (Fin m) E.≃ (Fin n) ;
    _∼_ = ∼Equiv ;
    refl∼ = λ {F} → E.refl∼ {f = proj₁ F} ;
    sym∼ = λ {F} {G} → E.sym∼ {f = proj₁ F} {g = proj₁ G} ;
    trans∼ = λ {F} {G} {H} P Q →
                E.trans∼ {f = proj₁ F} {g = proj₁ G} {h = proj₁ H} Q P
    }

FinCat' : Cat L.zero L.zero L.zero
FinCat' = record {
          object = ℕ ;
          hom = EquivSetoid ;
          identity = λ m → E.id≃ {A = Fin m} ;
          comp = λ q p → E.trans≃ p q ;
          comp∼ = λ {m} {n} {l} {G₀} {G₁} {F₀} {F₁} Q P x →
                    proj₁ (E.trans≃ F₀ G₀) x
                      ≡⟨ bydef ⟩
                    proj₁ G₀ (proj₁ F₀ x)
                      ≡⟨ ap (λ z → proj₁ G₀ z) (P x) ⟩
                    proj₁ G₀ (proj₁ F₁ x)
                      ≡⟨ Q (proj₁ F₁ x) ⟩
                    proj₁ (E.trans≃ F₁ G₁) x ∎ ;
          associativity∼  = λ F G H x → refl (proj₁ F (proj₁ G (proj₁ H x))) ;
          left-identity∼  = λ {m} {n} F x → refl (proj₁ F x) ;
          right-identity∼ = λ {m} {n} F x → refl (proj₁ F x)
      }

------------------------------------------------------------------
-- The category (FT,path)

-- evaluation
evalF : {b₁ b₂ : FT} → (b₁ ⇛ b₂) → ⟦ b₁ ⟧ → ⟦ b₂ ⟧
evalF p = proj₁ (path2equiv p)

-- could equivalently use sym≃ on the result of path2equiv p
evalB : {b₁ b₂ : FT} → (b₁ ⇛ b₂) → ⟦ b₂ ⟧ → ⟦ b₁ ⟧
evalB p = proj₁ (path2equiv (sym⇛ p))

-- equivalence of combinators
_∼c_ : {b₁ b₂ : FT} → (c₁ c₂ : b₁ ⇛ b₂) → Set
_∼c_ {b₁} {b₂} c₁ c₂ = (v : ⟦ b₁ ⟧) → evalF c₁ v ≡ evalF c₂ v

-- equivalence class of paths between two types
paths : FT → FT → Setoid L.zero L.zero
paths b₁ b₂ = record {
               object = b₁ ⇛ b₂ ;
               _∼_ = _∼c_ ;
               refl∼  = λ {c} v → refl (evalF c v) ;
               sym∼ = λ p v → ! (p v) ;
               trans∼ = λ q p v → (p v) ∘ (q v)
             }

-- the category of finite types and paths
FTCat : Cat L.zero L.zero L.zero
FTCat = record {
          object = FT ;
          hom = paths ;
          identity = λ b → id⇛ {b}  ;
          comp = λ c₂ c₁ → c₁ ◎ c₂ ;
          comp∼ = λ {b₀} {b₁} {b₂} {c₂} {c₂'} {c₁} {c₁'} q p v →
                    evalF (c₁ ◎ c₂) v
                      ≡⟨ bydef  ⟩
                    evalF c₂ (evalF c₁ v)
                      ≡⟨ ap (λ z → evalF c₂ z) (p v) ⟩
                    evalF c₂ (evalF c₁' v)
                      ≡⟨ q (evalF c₁' v) ⟩
                    evalF (c₁' ◎ c₂') v ∎ ;
          associativity∼  = λ r q p v →
            evalF (p ◎ (q ◎ r)) v
              ≡⟨ bydef ⟩
            evalF r (evalF q (evalF p v))
              ≡⟨ bydef ⟩
            evalF ((p ◎ q) ◎ r) v ∎ ;
          left-identity∼  = λ p v →
            evalF id⇛ (evalF p v)
              ≡⟨ bydef ⟩
             evalF p v ∎ ;
          right-identity∼ = λ p v →
            evalF p (evalF id⇛ v)
              ≡⟨ bydef ⟩
            evalF p v ∎
      }

------------------------------------------------------------------
{--
Two categories C and D are equivalent if we have:
- a functor F : C -> D
- a functor G : D -> C
- two natural isomorphisms ε : F ∘ G -> I_D and η : G ∘ F -> I_C

--}

ff : {m n : ℕ} → (Fin m E.≃ Fin n) → (fromℕ m ⇛ fromℕ n)
ff = {!!}

gg : {b₀ b₁ : FT} → (b₀ ⇛ b₁) → (Fin (suc (toℕ b₀)) E.≃ Fin (suc (toℕ b₁)))
gg = {!!}

-- functor from FinCat' to FTCat
fin2ft : FinCat' => FTCat
fin2ft = record {
    object = fromℕ ; -- (Fin 1) should map to ZERO
    hom = ff ;  --
    hom∼ = {!!} ;
    identity∼ = {!!} ;
    comp∼ = {!!}
  }

-- functor from FTCat to FinCat'
ft2fin : FTCat => FinCat'
ft2fin = record {
    object = λ b → suc (toℕ b) ; -- ZERO maps to (Fin 1)
    hom = gg ;
    hom∼ = {!!} ;
    identity∼ = {!!} ;
    comp∼ = {!!}
  }

------------------------------------------------------------------


{-# OPTIONS --irrelevant-projections #-}

data _≡_ {A : Set} : A → A → Set where
  refl : (x : A) → x ≡ x

module Erased where

  record Erased (A : Set) : Set where
    constructor [_]
    field
      @0 erased : A

  open Erased

  record _↔_ (A B : Set) : Set where
    field
      to      : A → B
      from    : B → A
      to∘from : ∀ x → to (from x) ≡ x
      from∘to : ∀ x → from (to x) ≡ x

  postulate
    A : Set
    P : (B : Set) → (Erased A → B) → Set
    p : (B : Set) (f : Erased A ↔ B) → P B (_↔_.to f)

  fails : P (Erased (Erased A)) (λ (x : Erased A) → [ x ])
  fails =
    p _ (record
           { from    = λ ([ x ]) → [ erased x ]
           ; to∘from = refl
           ; from∘to = λ _ → refl _
           })

module Irrelevant where

  record Irrelevant (A : Set) : Set where
    constructor [_]
    field
      .irr : A

  open Irrelevant

  record _↔_ (A B : Set) : Set where
    field
      to      : A → B
      from    : B → A
      to∘from : ∀ x → to (from x) ≡ x
      from∘to : ∀ x → from (to x) ≡ x

  postulate
    A : Set
    P : (B : Set) → (Irrelevant A → B) → Set
    p : (B : Set) (f : Irrelevant A ↔ B) → P B (_↔_.to f)

  fails : P (Irrelevant (Irrelevant A)) (λ (x : Irrelevant A) → [ x ])
  fails =
    p _ (record
           { from    = λ ([ x ]) → [ irr x ]
           ; to∘from = refl
           ; from∘to = λ _ → refl _
           })


{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.DStructures.Structures.Higher where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Function
open import Cubical.Foundations.Pointed
open import Cubical.Foundations.Univalence

open import Cubical.Functions.FunExtEquiv

open import Cubical.Homotopy.Base
open import Cubical.Homotopy.Connected

open import Cubical.Data.Sigma
open import Cubical.Data.Nat

open import Cubical.Relation.Binary

open import Cubical.Algebra.Group
open import Cubical.Algebra.Group.Higher
open import Cubical.Algebra.Group.EilenbergMacLane1

open import Cubical.HITs.EilenbergMacLane1

open import Cubical.DStructures.Base
open import Cubical.DStructures.Meta.Properties

open import Cubical.DStructures.Meta.Isomorphism
open import Cubical.DStructures.Structures.Universe
open import Cubical.DStructures.Structures.Type
open import Cubical.DStructures.Structures.Group
open import Cubical.DStructures.Structures.Constant

private
  variable
    ℓ ℓ' : Level

𝒮ᴰ-connected : {ℓ : Level} (k : ℕ) → URGStrᴰ (𝒮-universe {ℓ}) (isConnected k) ℓ-zero
𝒮ᴰ-connected k =
  Subtype→Sub-𝒮ᴰ (λ A → isConnected k A , isPropIsContr)
                 𝒮-universe

𝒮ᴰ-truncated : {ℓ : Level} (n : ℕ) → URGStrᴰ (𝒮-universe {ℓ}) (isOfHLevel n) ℓ-zero
𝒮ᴰ-truncated n =
  Subtype→Sub-𝒮ᴰ (λ A → isOfHLevel n A , isPropIsOfHLevel n)
                 𝒮-universe

𝒮ᴰ-BGroup : (n k : ℕ)
            → URGStrᴰ (𝒮-universe {ℓ})
                      (λ A → A × (isConnected (k + 1) A) × (isOfHLevel (n + k + 2) A))
                      ℓ
𝒮ᴰ-BGroup n k =
  combine-𝒮ᴰ 𝒮ᴰ-pointed
             (combine-𝒮ᴰ (𝒮ᴰ-connected (k + 1))
                         (𝒮ᴰ-truncated (n + k + 2)))

𝒮-BGroup : (n k : ℕ) → URGStr (Σ[ A ∈ Type ℓ ] A × (isConnected (k + 1) A) × (isOfHLevel (n + k + 2) A)) ℓ
𝒮-BGroup n k = ∫⟨ 𝒮-universe ⟩ 𝒮ᴰ-BGroup n k

𝒮-1BGroup : URGStr 1BGroupΣ ℓ
𝒮-1BGroup = 𝒮-BGroup 0 1

𝒮-Iso-BGroup-Group : {ℓ : Level} → 𝒮-PIso (𝒮-group ℓ) 𝒮-1BGroup
RelIso.fun 𝒮-Iso-BGroup-Group G = EM₁ G , embase , EM₁Connected G , EM₁Groupoid G
RelIso.inv 𝒮-Iso-BGroup-Group = π₁-1BGroupΣ
RelIso.leftInv 𝒮-Iso-BGroup-Group = π₁EM₁≃
RelIso.rightInv 𝒮-Iso-BGroup-Group BG = basetype-≅ , basepoint-≅ , tt , tt
  where
    -- notation
    type = fst BG
    * = fst (snd BG)
    conn = fst (snd (snd BG))
    trunc = snd (snd (snd BG))
    BG' = (bgroup (type , *) conn trunc)

    π₁BG : Group
    π₁BG = π₁-1BGroupΣ BG

    EM₁π₁BG : 1BGroupΣ
    EM₁π₁BG = EM₁ π₁BG , embase , EM₁Connected π₁BG , EM₁Groupoid π₁BG

    -- equivalences
    basetype-≅ : EM₁ π₁BG ≃ type
    fst basetype-≅ = EM₁-functor-lInv-function π₁BG BG' (GroupEquiv.hom (π₁EM₁≃ π₁BG))
    snd basetype-≅ = EM₁-functor-lInv-onIso-isEquiv π₁BG BG' (π₁EM₁≃ π₁BG)

    basepoint-≅ : * ≡ *
    basepoint-≅ = refl

𝒮ᴰ-BGroupHom : (n k : ℕ) → URGStrᴰ (𝒮-BGroup {ℓ} n k ×𝒮 𝒮-BGroup {ℓ'} n k)
                                  (λ (BG , BH) → BGroupHomΣ BG BH)
                                  (ℓ-max ℓ ℓ')
𝒮ᴰ-BGroupHom n k =
  make-𝒮ᴰ
    (λ {(BG , BH)} {(BG' , BH')} f (((eᴳ , _) , eᴳ-pt , _), ((eᴴ , _) , eᴴ-pt , _)) f'
       → ((eᴴ , eᴴ-pt) ∘∙ f) ∙∼ (f' ∘∙ (eᴳ , eᴳ-pt)))
    (λ {(BG , BH)} f → q {(BG , BH)} f)
    contrSingl
    where
      module _ {(BG , BH) : BGroupΣ n k × BGroupΣ n k} (f : BGroupHomΣ BG BH) where
        q : (id∙ (baseΣ BH) ∘∙ f) ∙∼ (f ∘∙ id∙ (baseΣ BG))
        q = funExt∙⁻ (id∙ (baseΣ BH) ∘∙ f
                       ≡⟨ ∘∙-idʳ f ⟩
                     f
                       ≡⟨ sym (∘∙-idˡ f) ⟩
                     (f ∘∙ id∙ (baseΣ BG)) ∎)

      module _ ((BG , BH) : BGroupΣ n k × BGroupΣ n k) (f : BGroupHomΣ BG BH) where
        contrSingl : isContr (Σ[ f' ∈ BGroupHomΣ BG BH ] ((id∙ (baseΣ BH) ∘∙ f) ∙∼ (f' ∘∙ id∙ (baseΣ BG))))
        contrSingl =
                isContrRespectEquiv (Σ-cong-equiv-snd (λ f' → f ≡ f'
                                                                ≃⟨ invEquiv (funExt∙≃ f f') ⟩
                                                               f ∙∼ f'
                                                                ≃⟨ pathToEquiv (cong (_∙∼ f')
                                                                                (sym (∘∙-idʳ f))
                                                                               ∙ cong ((id∙ (baseΣ BH) ∘∙ f) ∙∼_)
                                                                                (sym (∘∙-idˡ f'))) ⟩
                                                              (id∙ (baseΣ BH) ∘∙ f) ∙∼ (f' ∘∙ id∙ (baseΣ BG)) ■))

                                    (isContrSingl f)


{-# OPTIONS --allow-unsolved-metas #-}
module LiteralFormula where

open import OscarPrelude

open import IsLiteralFormula
open import HasNegation
open import Formula

record LiteralFormula : Set
 where
  constructor ⟨_⟩
  field
    {formula} : Formula
    isLiteralFormula : IsLiteralFormula formula

open LiteralFormula public

instance EqLiteralFormula : Eq LiteralFormula
Eq._==_ EqLiteralFormula (⟨_⟩ {φ₁} lf₁) (⟨_⟩ {φ₂} lf₂)
 with φ₁ ≟ φ₂
… | no φ₁≢φ₂ = no (λ {refl → φ₁≢φ₂ refl})
Eq._==_ EqLiteralFormula (⟨_⟩ {φ₁} lf₁) (⟨_⟩ {φ₂} lf₂) | yes refl = case (eqIsLiteralFormula lf₁ lf₂) of λ {refl → yes refl}

instance HasNegationLiteralFormula : HasNegation LiteralFormula
HasNegation.~ HasNegationLiteralFormula ⟨ atomic 𝑃 τs ⟩ = ⟨ logical 𝑃 τs ⟩
HasNegation.~ HasNegationLiteralFormula ⟨ logical 𝑃 τs ⟩ = ⟨ atomic 𝑃 τs ⟩

open import Interpretation
open import Vector
open import Term
open import Elements
open import TruthValue

module _ where

  open import HasSatisfaction

  instance HasSatisfactionLiteralFormula : HasSatisfaction LiteralFormula
  HasSatisfaction._⊨_ HasSatisfactionLiteralFormula I ⟨ atomic 𝑃 τs ⟩ = 𝑃⟦ I ⟧ 𝑃 ⟨ ⟨ τ⟦ I ⟧ <$> vector (terms τs) ⟩ ⟩ ≡ ⟨ true ⟩
  HasSatisfaction._⊨_ HasSatisfactionLiteralFormula I ⟨ logical 𝑃 τs ⟩ = 𝑃⟦ I ⟧ 𝑃 ⟨ ⟨ τ⟦ I ⟧ <$> vector (terms τs) ⟩ ⟩ ≡ ⟨ false ⟩

  instance HasDecidableSatisfactionLiteralFormula : HasDecidableSatisfaction LiteralFormula
  HasDecidableSatisfaction._⊨?_ HasDecidableSatisfactionLiteralFormula
    I ⟨ atomic 𝑃 τs ⟩
   with 𝑃⟦ I ⟧ 𝑃 ⟨ ⟨ τ⟦ I ⟧ <$> vector (terms τs) ⟩ ⟩
  … | ⟨ true ⟩ = yes refl
  … | ⟨ false ⟩ = no λ ()
  HasDecidableSatisfaction._⊨?_ HasDecidableSatisfactionLiteralFormula
    I ⟨ logical 𝑃 τs ⟩
    with 𝑃⟦ I ⟧ 𝑃 ⟨ ⟨ τ⟦ I ⟧ <$> vector (terms τs) ⟩ ⟩
  … | ⟨ true ⟩ = no λ ()
  … | ⟨ false ⟩ = yes refl

  instance HasDecidableValidationLiteralFormula : HasDecidableValidation LiteralFormula
  HasDecidableValidation.⊨? HasDecidableValidationLiteralFormula = {!!}

module _ where

  open import HasSubstantiveDischarge

  postulate
    instance cs' : CanonicalSubstitution LiteralFormula
    instance hpu' : HasPairUnification LiteralFormula (CanonicalSubstitution.S cs')

  instance HasSubstantiveDischargeLiteralFormula : HasSubstantiveDischarge LiteralFormula
  --HasSubstantiveDischarge._o≽o_ HasSubstantiveDischargeLiteralFormula φ₁ φ₂ = φ₁ ≡ φ₂
  HasSubstantiveDischarge.hasNegation HasSubstantiveDischargeLiteralFormula = it
  HasSubstantiveDischarge.≽-reflexive HasSubstantiveDischargeLiteralFormula = {!!}
  HasSubstantiveDischarge.≽-consistent HasSubstantiveDischargeLiteralFormula = {!!}
  HasSubstantiveDischarge.≽-contrapositive HasSubstantiveDischargeLiteralFormula = {!!}

  instance HasDecidableSubstantiveDischargeLiteralFormula : HasDecidableSubstantiveDischarge LiteralFormula
  HasDecidableSubstantiveDischarge.hasSubstantiveDischarge HasDecidableSubstantiveDischargeLiteralFormula = it
  HasDecidableSubstantiveDischarge._≽?_ HasDecidableSubstantiveDischargeLiteralFormula φ+ φ- = {!!} -- φ+ ≟ φ-


{-# OPTIONS --without-K --exact-split #-}

module localizations-rings where

import subrings
open subrings public

is-invertible-Ring :
  {l1 : Level} (R : Ring l1) (x : type-Ring R) → UU l1
is-invertible-Ring R =
  is-invertible-Monoid (multiplicative-monoid-Ring R)

is-prop-is-invertible-Ring :
  {l1 : Level} (R : Ring l1) (x : type-Ring R) →
  is-prop (is-invertible-Ring R x)
is-prop-is-invertible-Ring R =
  is-prop-is-invertible-Monoid (multiplicative-monoid-Ring R)

--------------------------------------------------------------------------------

{- We introduce homomorphism that invert specific elements -}

inverts-element-hom-Ring :
  {l1 l2 : Level} (R1 : Ring l1) (R2 : Ring l2) (x : type-Ring R1) →
  (f : hom-Ring R1 R2) → UU l2
inverts-element-hom-Ring R1 R2 x f =
  is-invertible-Ring R2 (map-hom-Ring R1 R2 f x)

is-prop-inverts-element-hom-Ring :
  {l1 l2 : Level} (R : Ring l1) (S : Ring l2) (x : type-Ring R)
  (f : hom-Ring R S) → is-prop (inverts-element-hom-Ring R S x f)
is-prop-inverts-element-hom-Ring R S x f =
  is-prop-is-invertible-Ring S (map-hom-Ring R S f x)

inv-inverts-element-hom-Ring :
  {l1 l2 : Level} (R : Ring l1) (S : Ring l2) (x : type-Ring R)
  (f : hom-Ring R S) → inverts-element-hom-Ring R S x f → type-Ring S
inv-inverts-element-hom-Ring R S x f H = pr1 H

is-left-inverse-inv-inverts-element-hom-Ring :
  {l1 l2 : Level} (R : Ring l1) (S : Ring l2) (x : type-Ring R)
  (f : hom-Ring R S) (H : inverts-element-hom-Ring R S x f) →
  Id ( mul-Ring S
       ( inv-inverts-element-hom-Ring R S x f H)
       ( map-hom-Ring R S f x))
     ( unit-Ring S)
is-left-inverse-inv-inverts-element-hom-Ring R S x f H = pr1 (pr2 H)

is-right-inverse-inv-inverts-element-hom-Ring :
  {l1 l2 : Level} (R : Ring l1) (S : Ring l2) (x : type-Ring R)
  (f : hom-Ring R S) (H : inverts-element-hom-Ring R S x f) →
  Id ( mul-Ring S
       ( map-hom-Ring R S f x)
       ( inv-inverts-element-hom-Ring R S x f H))
     ( unit-Ring S)
is-right-inverse-inv-inverts-element-hom-Ring R S x f H = pr2 (pr2 H)

inverts-element-comp-hom-Ring :
  {l1 l2 l3 : Level} (R : Ring l1) (S : Ring l2) (T : Ring l3) (x : type-Ring R)
  (g : hom-Ring S T) (f : hom-Ring R S) → inverts-element-hom-Ring R S x f →
  inverts-element-hom-Ring R T x (comp-hom-Ring R S T g f)
inverts-element-comp-hom-Ring R S T x g f H =
  pair
    ( map-hom-Ring S T g (inv-inverts-element-hom-Ring R S x f H))
    ( pair
      ( ( inv
          ( preserves-mul-hom-Ring S T g
            ( inv-inverts-element-hom-Ring R S x f H)
            ( map-hom-Ring R S f x))) ∙
        ( ( ap
            ( map-hom-Ring S T g)
            ( is-left-inverse-inv-inverts-element-hom-Ring R S x f H)) ∙
          ( preserves-unit-hom-Ring S T g)))
      ( ( inv
          ( preserves-mul-hom-Ring S T g
            ( map-hom-Ring R S f x)
            ( inv-inverts-element-hom-Ring R S x f H))) ∙
        ( ( ap
            ( map-hom-Ring S T g)
            ( is-right-inverse-inv-inverts-element-hom-Ring R S x f H)) ∙
          ( preserves-unit-hom-Ring S T g))))

{- We state the universal property of the localization of a Ring at a single
   element x ∈ R. -}

precomp-universal-property-localization-Ring :
  {l1 l2 l3 : Level} (R : Ring l1) (S : Ring l2) (T : Ring l3) (x : type-Ring R)
  (f : hom-Ring R S) (H : inverts-element-hom-Ring R S x f) →
  hom-Ring S T → Σ (hom-Ring R T) (inverts-element-hom-Ring R T x)
precomp-universal-property-localization-Ring R S T x f H g =
  pair (comp-hom-Ring R S T g f) (inverts-element-comp-hom-Ring R S T x g f H)

universal-property-localization-Ring :
  (l : Level) {l1 l2 : Level} (R : Ring l1) (S : Ring l2) (x : type-Ring R)
  (f : hom-Ring R S) → inverts-element-hom-Ring R S x f → UU (lsuc l ⊔ l1 ⊔ l2)
universal-property-localization-Ring l R S x f H =
  (T : Ring l) →
  is-equiv (precomp-universal-property-localization-Ring R S T x f H)

unique-extension-universal-property-localization-Ring :
  {l1 l2 l3 : Level} (R : Ring l1) (S : Ring l2) (T : Ring l3) (x : type-Ring R)
  (f : hom-Ring R S) (H : inverts-element-hom-Ring R S x f) →
  universal-property-localization-Ring l3 R S x f H →
  (h : hom-Ring R T) (K : inverts-element-hom-Ring R T x h) →
  is-contr
    (Σ (hom-Ring S T) (λ g → htpy-hom-Ring R T (comp-hom-Ring R S T g f) h))
unique-extension-universal-property-localization-Ring R S T x f H up-f h K =
  is-contr-equiv'
    ( fib (precomp-universal-property-localization-Ring R S T x f H) (pair h K))
    ( equiv-tot ( λ g →
      ( equiv-htpy-hom-Ring-eq R T (comp-hom-Ring R S T g f) h) ∘e
      ( equiv-Eq-total-subtype-eq
        ( is-prop-inverts-element-hom-Ring R T x)
        ( precomp-universal-property-localization-Ring R S T x f H g)
        ( pair h K))))
    ( is-contr-map-is-equiv (up-f T) (pair h K))

center-unique-extension-universal-property-localization-Ring :
  {l1 l2 l3 : Level} (R : Ring l1) (S : Ring l2) (T : Ring l3) (x : type-Ring R)
  (f : hom-Ring R S) (H : inverts-element-hom-Ring R S x f) →
  universal-property-localization-Ring l3 R S x f H →
  (h : hom-Ring R T) (K : inverts-element-hom-Ring R T x h) →
  Σ (hom-Ring S T) (λ g → htpy-hom-Ring R T (comp-hom-Ring R S T g f) h)
center-unique-extension-universal-property-localization-Ring R S T x f H up-f h K =
  center
    ( unique-extension-universal-property-localization-Ring
      R S T x f H up-f h K)

map-universal-property-localization-Ring :
  {l1 l2 l3 : Level} (R : Ring l1) (S : Ring l2) (T : Ring l3) (x : type-Ring R)
  (f : hom-Ring R S) (H : inverts-element-hom-Ring R S x f) →
  universal-property-localization-Ring l3 R S x f H →
  (h : hom-Ring R T) (K : inverts-element-hom-Ring R T x h) → hom-Ring S T
map-universal-property-localization-Ring R S T x f H up-f h K =
  pr1 ( center-unique-extension-universal-property-localization-Ring
        R S T x f H up-f h K)

htpy-universal-property-localization-Ring :
  {l1 l2 l3 : Level} (R : Ring l1) (S : Ring l2) (T : Ring l3) (x : type-Ring R)
  (f : hom-Ring R S) (H : inverts-element-hom-Ring R S x f) →
  (up-f : universal-property-localization-Ring l3 R S x f H) →
  (h : hom-Ring R T) (K : inverts-element-hom-Ring R T x h) →
  htpy-hom-Ring R T (comp-hom-Ring R S T (map-universal-property-localization-Ring R S T x f H up-f h K) f) h
htpy-universal-property-localization-Ring R S T x f H up-f h K =
  pr2 ( center-unique-extension-universal-property-localization-Ring
        R S T x f H up-f h K)

{- We show that the type of localizations of a ring R at an element x is
   contractible. -}

is-equiv-up-localization-up-localization-Ring :
  {l1 l2 l3 : Level} (R : Ring l1) (S : Ring l2) (T : Ring l3) (x : type-Ring R)
  (f : hom-Ring R S) (inverts-f : inverts-element-hom-Ring R S x f) →
  (g : hom-Ring R T) (inverts-g : inverts-element-hom-Ring R T x g) →
  (h : hom-Ring S T) (H : htpy-hom-Ring R T (comp-hom-Ring R S T h f) g) →
  ({l : Level} → universal-property-localization-Ring l R S x f inverts-f) →
  ({l : Level} → universal-property-localization-Ring l R T x g inverts-g) →
  is-iso-hom-Ring S T h
is-equiv-up-localization-up-localization-Ring R S T x f inverts-f g inverts-g h H up-f up-g = {!is-iso-is-equiv-hom-Ring!}

--------------------------------------------------------------------------------

{- We introduce homomorphisms that invert all elements of a subset of a ring -}

inverts-subset-hom-Ring :
  {l1 l2 l3 : Level} (R : Ring l1) (S : Ring l2) (P : subset-Ring l3 R) →
  (f : hom-Ring R S) → UU (l1 ⊔ l2 ⊔ l3)
inverts-subset-hom-Ring R S P f =
  (x : type-Ring R) (p : type-Prop (P x)) → inverts-element-hom-Ring R S x f

is-prop-inverts-subset-hom-Ring :
  {l1 l2 l3 : Level} (R : Ring l1) (S : Ring l2) (P : subset-Ring l3 R) →
  (f : hom-Ring R S) → is-prop (inverts-subset-hom-Ring R S P f)
is-prop-inverts-subset-hom-Ring R S P f =
  is-prop-Π (λ x → is-prop-Π (λ p → is-prop-inverts-element-hom-Ring R S x f))

inv-inverts-subset-hom-Ring :
  {l1 l2 l3 : Level} (R : Ring l1) (S : Ring l2) (P : subset-Ring l3 R)
  (f : hom-Ring R S) (H : inverts-subset-hom-Ring R S P f)
  (x : type-Ring R) (p : type-Prop (P x)) → type-Ring S
inv-inverts-subset-hom-Ring R S P f H x p =
  inv-inverts-element-hom-Ring R S x f (H x p)

is-left-inverse-inv-inverts-subset-hom-Ring :
  {l1 l2 l3 : Level} (R : Ring l1) (S : Ring l2) (P : subset-Ring l3 R)
  (f : hom-Ring R S) (H : inverts-subset-hom-Ring R S P f)
  (x : type-Ring R) (p : type-Prop (P x)) →
  Id (mul-Ring S (inv-inverts-subset-hom-Ring R S P f H x p) (map-hom-Ring R S f x)) (unit-Ring S)
is-left-inverse-inv-inverts-subset-hom-Ring R S P f H x p =
  is-left-inverse-inv-inverts-element-hom-Ring R S x f (H x p)

is-right-inverse-inv-inverts-subset-hom-Ring :
  {l1 l2 l3 : Level} (R : Ring l1) (S : Ring l2) (P : subset-Ring l3 R)
  (f : hom-Ring R S) (H : inverts-subset-hom-Ring R S P f)
  (x : type-Ring R) (p : type-Prop (P x)) →
  Id (mul-Ring S (map-hom-Ring R S f x) (inv-inverts-subset-hom-Ring R S P f H x p)) (unit-Ring S)
is-right-inverse-inv-inverts-subset-hom-Ring R S P f H x p =
  is-right-inverse-inv-inverts-element-hom-Ring R S x f (H x p)

inverts-subset-comp-hom-Ring :
  {l1 l2 l3 l4 : Level} (R : Ring l1) (S : Ring l2) (T : Ring l3)
  (P : subset-Ring l4 R) (g : hom-Ring S T) (f : hom-Ring R S) →
  inverts-subset-hom-Ring R S P f →
  inverts-subset-hom-Ring R T P (comp-hom-Ring R S T g f)
inverts-subset-comp-hom-Ring R S T P g f H x p =
  inverts-element-comp-hom-Ring R S T x g f (H x p)

{- We state the universal property of the localization of a Ring at a subset
   of R. -}

precomp-universal-property-localization-subset-Ring :
  {l1 l2 l3 l4 : Level} (R : Ring l1) (S : Ring l2) (T : Ring l3)
  (P : subset-Ring l4 R) →
  (f : hom-Ring R S) (H : inverts-subset-hom-Ring R S P f) →
  hom-Ring S T → Σ (hom-Ring R T) (inverts-subset-hom-Ring R T P)
precomp-universal-property-localization-subset-Ring R S T P f H g =
  pair (comp-hom-Ring R S T g f) (inverts-subset-comp-hom-Ring R S T P g f H)

universal-property-localization-subset-Ring :
  (l : Level) {l1 l2 l3 : Level} (R : Ring l1) (S : Ring l2)
  (P : subset-Ring l3 R) (f : hom-Ring R S) →
  inverts-subset-hom-Ring R S P f → UU (lsuc l ⊔ l1 ⊔ l2 ⊔ l3)
universal-property-localization-subset-Ring l R S P f H =
  (T : Ring l) →
  is-equiv (precomp-universal-property-localization-subset-Ring R S T P f H)


open import Agda.Builtin.Equality using (_≡_; refl)

record ⊤ : Set where
  no-eta-equality
  constructor tt

data Box (A : Set) : Set where
  [_] : A → Box A

Unit : Set
Unit = Box ⊤

F : Unit → Set → Set
F [ _ ] x = x

G : {P : Unit → Set} → ((x : ⊤) → P [ x ]) → ((x : Unit) → P x)
G f [ x ] = f x

record R : Set₁ where
  no-eta-equality
  field
    f : (x : Unit) → Box (F x ⊤)

  data ⊥ : Set where

r : R
r = record { f = G [_] }

open R r

H : ⊥ → Set₁
H _ rewrite refl {x = tt} = Set


-- WARNING: This file was generated automatically by Vehicle
-- and should not be modified manually!
-- Metadata
--  - Agda version: 2.6.2
--  - AISEC version: 0.1.0.1
--  - Time generated: ???

{-# OPTIONS --allow-exec #-}

open import Vehicle
open import Vehicle.Data.Tensor
open import Data.Nat as ℕ using (ℕ)
open import Data.Fin as Fin using (Fin; #_)
open import Data.List

module simple-tensor-temp-output where

zeroD : Tensor ℕ []
zeroD = 2

oneD : Tensor ℕ (2 ∷ [])
oneD = zeroD ∷ (1 ∷ [])

twoD : Tensor ℕ (2 ∷ (2 ∷ []))
twoD = oneD ∷ ((2 ∷ (3 ∷ [])) ∷ [])

lookup2D : ℕ
lookup2D = twoD (# 0) (# 1)


------------------------------------------------------------------------
-- The Agda standard library
--
-- Signs
------------------------------------------------------------------------

{-# OPTIONS --without-K --safe #-}

module Data.Sign where

------------------------------------------------------------------------
-- Definition

open import Data.Sign.Base public
open import Data.Sign.Properties public
  using (_≟_)


{-# OPTIONS --safe #-}
module CF.Syntax.Hoisted where

open import Level
open import Data.List

open import Relation.Unary hiding (_⊢_)
open import Relation.Ternary.Core
open import Relation.Ternary.Structures
open import Relation.Ternary.Structures.Syntax

open import CF.Types
open import CF.Contexts.Lexical
open import CF.Syntax using (module Statements)
open import CF.Syntax using (Exp) public

mutual
  Stmt = Statements.Statement Block

  {- This is Bigstar, but Agda cannot termination check that -}
  data Block (r : Ty) : Pred Ctx 0ℓ where
    nil  : ε[ Block r ]
    cons : ∀[ Stmt r ✴ Block r ⇒ Block r ]

open import Relation.Unary.PredicateTransformer hiding (_⍮_)
open import Data.Product

-- make constructors visible
open Exp public
open Statements Block public
open CoDeBruijn public
open import CF.Contexts.Lexical using (_⊢_) public


open import Agda.Builtin.Nat

[_] :  (Nat → Set) → Set
[ T ] = ∀ {i} → T i

data D : Nat → Nat → Set where
  c : ∀ {i} → [ D i ]


------------------------------------------------------------------------
-- A variant of Nat.Wrapper.Cubical, defined using --erased-cubical
------------------------------------------------------------------------

{-# OPTIONS --erased-cubical --safe #-}

open import Equality.Path as P
open import Prelude hiding (zero; suc; _+_)

open import Bijection equality-with-J using (_↔_)

module Nat.Wrapper.Cubical.Erased
  -- The underlying representation of natural numbers.
  (Nat′ : Type)
  -- A bijection between this representation and the unary natural
  -- numbers.
  (Nat′↔ℕ : Nat′ ↔ ℕ)
  where

open import Equality.Path.Univalence
open import Logical-equivalence using (_⇔_)

import Equivalence equality-with-J as Eq
open import Equivalence.Erased.Cubical equality-with-paths as EEq
  using (_≃ᴱ_)
import Equivalence.Erased.Contractible-preimages.Cubical
         equality-with-paths
  as ECP
open import Erased.Cubical equality-with-paths
open import Function-universe equality-with-J as F hiding (_∘_)
open import H-level equality-with-J
open import H-level.Closure equality-with-J
open import H-level.Truncation.Propositional.Erased equality-with-paths
  as Trunc
import Nat equality-with-J as Nat
import Univalence-axiom equality-with-J as U

open import Nat.Wrapper equality-with-J Nat′ Nat′↔ℕ as NW
open NW.[]-cong instance-of-[]-cong-axiomatisation

private
  variable
    A   : Type
    m n : A

------------------------------------------------------------------------
-- Could Nat have been defined using the propositional truncation
-- operator (with an erased higher constructor) instead of Erased?

-- Could Nat have been defined using ∥_∥ᴱ instead of Erased? Let us
-- try.

-- Given a truncated natural number we can kind of apply Nat-[_] to
-- it, because Nat-[_] is a family of contractible types. (The code
-- uses erased univalence.)

Nat-[]′ : ∥ ℕ ∥ᴱ → ∃ λ (A : Type) → Contractible A
Nat-[]′ = Trunc.rec λ where
  .truncation-is-propositionʳ →
    U.∃-H-level-H-level-1+ ext univ 0
  .∣∣ʳ n →
      Nat-[ n ]
    , propositional⇒inhabited⇒contractible
        Nat-[]-propositional
        ( _↔_.from Nat′↔ℕ n
        , [ _↔_.right-inverse-of Nat′↔ℕ n ]
        )

Nat-[_]′ : ∥ ℕ ∥ᴱ → Type
Nat-[ n ]′ = proj₁ (Nat-[]′ n)

-- Thus we can form a variant of Nat.

Nat-with-∥∥ᴱ : Type
Nat-with-∥∥ᴱ = Σ ∥ ℕ ∥ᴱ Nat-[_]′

-- However, this variant is equivalent (with erased proofs) to the
-- unit type.

Nat-with-∥∥ᴱ≃ᴱ⊤ : Nat-with-∥∥ᴱ ≃ᴱ ⊤
Nat-with-∥∥ᴱ≃ᴱ⊤ =
  _⇔_.to EEq.Contractibleᴱ⇔≃ᴱ⊤ $
  ECP.Contractibleᴱ-Σ
    (ECP.inhabited→Is-proposition→Contractibleᴱ
       ∣ 0 ∣ truncation-is-proposition)
    (ECP.Contractible→Contractibleᴱ ∘ proj₂ ∘ Nat-[]′)

-- And thus it is not isomorphic to the natural numbers.

¬-Nat-with-∥∥ᴱ↔ℕ : ¬ (Nat-with-∥∥ᴱ ↔ ℕ)
¬-Nat-with-∥∥ᴱ↔ℕ =
  Stable-¬
    [ Nat-with-∥∥ᴱ ↔ ℕ  ↝⟨ F._∘ inverse (from-equivalence (EEq.≃ᴱ→≃ Nat-with-∥∥ᴱ≃ᴱ⊤)) ⟩
      ⊤ ↔ ℕ             ↝⟨ (λ hyp → _↔_.injective (inverse hyp) refl) ⟩
      0 ≡ 1             ↝⟨ Nat.0≢+ ⟩□
      ⊥                 □
    ]

------------------------------------------------------------------------
-- Addition of "wrapped" numbers is commutative and associative

module _ (o : Operations) where

  open Operations-for-Nat o
  open Operations-for-Nat-correct o

  private

    -- A lemma used several times below.

    from[to+to]≡+ :
      ∀ m →
      _↔_.from Nat↔ℕ (_↔_.to Nat↔ℕ m Prelude.+ _↔_.to Nat↔ℕ n) ≡ m + n
    from[to+to]≡+ {n = n} m =
      _↔_.from Nat↔ℕ (_↔_.to Nat↔ℕ m Prelude.+ _↔_.to Nat↔ℕ n)  ≡⟨ cong (_↔_.from Nat↔ℕ) $ sym $ to-ℕ-+ m n ⟩
      _↔_.from Nat↔ℕ (_↔_.to Nat↔ℕ (m + n))                     ≡⟨ _↔_.left-inverse-of Nat↔ℕ _ ⟩∎
      m + n                                                     ∎

  -- First two "traditional" proofs.

  -- Addition is commutative.

  +-comm-traditional : ∀ m {n} → m + n ≡ n + m
  +-comm-traditional m {n = n} =
    m + n                                                     ≡⟨ sym $ from[to+to]≡+ m ⟩
    _↔_.from Nat↔ℕ (_↔_.to Nat↔ℕ m Prelude.+ _↔_.to Nat↔ℕ n)  ≡⟨ cong (_↔_.from Nat↔ℕ) $ Nat.+-comm (_↔_.to Nat↔ℕ m) ⟩
    _↔_.from Nat↔ℕ (_↔_.to Nat↔ℕ n Prelude.+ _↔_.to Nat↔ℕ m)  ≡⟨ from[to+to]≡+ n ⟩∎
    n + m                                                     ∎

  -- Addition is associative.

  +-assoc-traditional : ∀ m {n o} → m + (n + o) ≡ (m + n) + o
  +-assoc-traditional m {n = n} {o = o} =
    m + (n + o)                                                     ≡⟨ cong (m +_) $ sym $ from[to+to]≡+ n ⟩

    m + (_↔_.from Nat↔ℕ (_↔_.to Nat↔ℕ n Prelude.+ _↔_.to Nat↔ℕ o))  ≡⟨ sym $ from[to+to]≡+ m ⟩

    _↔_.from Nat↔ℕ (_↔_.to Nat↔ℕ m
                      Prelude.+
                    _↔_.to Nat↔ℕ (_↔_.from Nat↔ℕ
                      (_↔_.to Nat↔ℕ n Prelude.+ _↔_.to Nat↔ℕ o)))   ≡⟨ cong (λ n → _↔_.from Nat↔ℕ (_↔_.to Nat↔ℕ m Prelude.+ n)) $
                                                                       _↔_.right-inverse-of Nat↔ℕ _ ⟩
    _↔_.from Nat↔ℕ
      (_↔_.to Nat↔ℕ m
         Prelude.+
       (_↔_.to Nat↔ℕ n Prelude.+ _↔_.to Nat↔ℕ o))                   ≡⟨ cong (_↔_.from Nat↔ℕ) $ Nat.+-assoc (_↔_.to Nat↔ℕ m) ⟩

    _↔_.from Nat↔ℕ
      ((_↔_.to Nat↔ℕ m Prelude.+ _↔_.to Nat↔ℕ n)
         Prelude.+
       _↔_.to Nat↔ℕ o)                                              ≡⟨ cong (λ n → _↔_.from Nat↔ℕ (n Prelude.+ _↔_.to Nat↔ℕ o)) $ sym $
                                                                       _↔_.right-inverse-of Nat↔ℕ _ ⟩
    _↔_.from Nat↔ℕ
      (_↔_.to Nat↔ℕ (_↔_.from Nat↔ℕ
         (_↔_.to Nat↔ℕ m Prelude.+ _↔_.to Nat↔ℕ n))
         Prelude.+
       _↔_.to Nat↔ℕ o)                                              ≡⟨ from[to+to]≡+ (_↔_.from Nat↔ℕ (_↔_.to Nat↔ℕ m Prelude.+ _↔_.to Nat↔ℕ n)) ⟩

    (_↔_.from Nat↔ℕ (_↔_.to Nat↔ℕ m Prelude.+ _↔_.to Nat↔ℕ n)) + o  ≡⟨ cong (_+ o) $ from[to+to]≡+ {n = n} m ⟩∎

    (m + n) + o                                                     ∎

  -- The following proofs are instead based on a technique used by
  -- Vezzosi, Mörtberg and Abel in "Cubical Agda: A Dependently Typed
  -- Programming Language with Univalence and Higher Inductive Types".

  -- The type of unary natural numbers is equal to the type of wrapped
  -- natural numbers (in erased contexts).

  @0 ℕ≡Nat : ℕ ≡ Nat
  ℕ≡Nat = sym (≃⇒≡ (Eq.↔⇒≃ Nat↔ℕ))

  -- Addition of unary natural numbers is, in a certain sense, equal
  -- to addition of wrapped natural numbers (in erased contexts).

  @0 +≡+ : P.[ (λ i → ℕ≡Nat i → ℕ≡Nat i → ℕ≡Nat i) ] Prelude._+_ ≡ _+_
  +≡+ =
    Prelude._+_                                                         ≡⟨ (λ i → transport
                                                                                (λ j → ℕ≡Nat (min i j) → ℕ≡Nat (min i j) → ℕ≡Nat (min i j))
                                                                                (- i) Prelude._+_) ⟩h
    transport (λ i → ℕ≡Nat i → ℕ≡Nat i → ℕ≡Nat i) 0̲ Prelude._+_         ≡⟨⟩
    (λ m n → _↔_.from Nat↔ℕ (_↔_.to Nat↔ℕ m Prelude.+ _↔_.to Nat↔ℕ n))  ≡⟨ (⟨ext⟩ λ m → ⟨ext⟩ λ _ → from[to+to]≡+ m) ⟩∎
    _+_                                                                 ∎

  -- Addition is commutative (in erased contexts).

  @0 +-comm-cubical : ∀ m {n} → m + n ≡ n + m
  +-comm-cubical =
    transport
      (λ i → (m {n} : ℕ≡Nat i) → +≡+ i m n ≡ +≡+ i n m)
      0̲
      Nat.+-comm

  -- Addition is associative (in erased contexts).

  @0 +-assoc-cubical : ∀ m {n o} → m + (n + o) ≡ (m + n) + o
  +-assoc-cubical =
    transport
      (λ i → (m {n o} : ℕ≡Nat i) →
             +≡+ i m (+≡+ i n o) ≡ +≡+ i (+≡+ i m n) o)
      0̲
      Nat.+-assoc

  -- This proof technique seems to scale better than the one used
  -- above, at least for examples of the kind used here. However, when
  -- --erased-cubical is used it only works in erased contexts.


mutual

  record R (A : Set) : Set where
    inductive
    field
      f₁ : A
      f₂ : R′ A

  record R′ (A : Set) : Set where
    inductive
    field
      f : R A


------------------------------------------------------------------------
-- The Agda standard library
--
-- Some properties imply others
------------------------------------------------------------------------

-- This file contains some core definitions which are reexported by
-- Relation.Binary.Consequences.

module Relation.Binary.Consequences.Core where

open import Relation.Binary.Core
open import Data.Product

subst⟶resp₂ : ∀ {a ℓ p} {A : Set a} {∼ : Rel A ℓ}
              (P : Rel A p) → Substitutive ∼ p → P Respects₂ ∼
subst⟶resp₂ {∼ = ∼} P subst =
  (λ {x _ _} y'∼y Pxy' → subst (P x)         y'∼y Pxy') ,
  (λ {y _ _} x'∼x Px'y → subst (λ x → P x y) x'∼x Px'y)


module Structure.Category.Monoidal where

import      Lvl
open import Data.Tuple as Tuple using (_,_ ; _⨯_)
open import Data.Tuple.Category
open import Data.Tuple.Equivalence
import      Functional as Fn
open import Logic.Predicate
open import Structure.Setoid
open import Structure.Category
open import Structure.Category.Functor
import      Structure.Category.Functor.Functors as Functors
open import Structure.Category.NaturalTransformation
open import Syntax.Function
open import Type

private variable ℓ ℓₒ ℓₘ ℓₑ ℓₒ₁ ℓₘ₁ ℓₑ₁ ℓₒ₂ ℓₘ₂ ℓₑ₂ : Lvl.Level
private variable Obj : Type{ℓ}
private variable Morphism : Obj → Obj → Type{ℓ}

open Functors.Wrapped

module _
  {C : CategoryObject{ℓₒ}{ℓₘ}{ℓₑ}}
  (product@([∃]-intro _) : (C ⨯ᶜᵃᵗ C) →ᶠᵘⁿᶜᵗᵒʳ C)
  (𝟏 : CategoryObject.Object(C))
  where

  open CategoryObject(C)
  open Category.ArrowNotation(category)
  open Category(category)
  open Functor

  record MonoidalCategory : Type{Lvl.of(Type.of C)} where
    constructor intro

    field
      associator : (((product ∘ᶠᵘⁿᶜᵗᵒʳ (Tupleᶜᵃᵗ.mapLeft product))) ∘ᶠᵘⁿᶜᵗᵒʳ Tupleᶜᵃᵗ.associateLeft) ↔ᴺᵀ (product ∘ᶠᵘⁿᶜᵗᵒʳ (Tupleᶜᵃᵗ.mapRight product))
      unitorₗ : (product ∘ᶠᵘⁿᶜᵗᵒʳ Tupleᶜᵃᵗ.constₗ 𝟏) ↔ᴺᵀ idᶠᵘⁿᶜᵗᵒʳ
      unitorᵣ : (product ∘ᶠᵘⁿᶜᵗᵒʳ Tupleᶜᵃᵗ.constᵣ 𝟏) ↔ᴺᵀ idᶠᵘⁿᶜᵗᵒʳ

    _⊗_ : Object → Object → Object
    _⊗_ = Tuple.curry([∃]-witness product)

    _<⊗>_ : ∀{x₁ x₂ y₁ y₂} → (x₁ ⟶ x₂) → (y₁ ⟶ y₂) → ((x₁ ⊗ y₁) ⟶ (x₂ ⊗ y₂))
    _<⊗>_ = Tuple.curry(map([∃]-proof product))

    α : ∀(x)(y)(z) → (((x ⊗ y) ⊗ z) ⟶ (x ⊗ (y ⊗ z)))
    α x y z = [∃]-witness associator (x , (y , z))

    υₗ : ∀(x) → ((𝟏 ⊗ x) ⟶ x)
    υₗ = [∃]-witness unitorₗ

    υᵣ : ∀(x) → ((x ⊗ 𝟏) ⟶ x)
    υᵣ = [∃]-witness unitorᵣ

    α⁻¹ : ∀(x)(y)(z) → ((x ⊗ (y ⊗ z)) ⟶ ((x ⊗ y) ⊗ z))
    α⁻¹ x y z = [∃]-witness (invᴺᵀ associator) (x , (y , z))

    υₗ⁻¹ : ∀(x) → (x ⟶ (𝟏 ⊗ x))
    υₗ⁻¹ = [∃]-witness (invᴺᵀ unitorₗ)

    υᵣ⁻¹ : ∀(x) → (x ⟶ (x ⊗ 𝟏))
    υᵣ⁻¹ = [∃]-witness (invᴺᵀ unitorᵣ)

    α-natural : ∀{(x₁ , (x₂ , x₃)) (y₁ , (y₂ , y₃)) : Object ⨯ (Object ⨯ Object)}
                 {(f₁ , f₂ , f₃) : ((x₁ ⟶ y₁) ⨯ ((x₂ ⟶ y₂) ⨯ (x₃ ⟶ y₃)))} →
                 ((α y₁ y₂ y₃) ∘ ((f₁ <⊗> f₂) <⊗> f₃) ≡ (f₁ <⊗> (f₂ <⊗> f₃)) ∘ (α x₁ x₂ x₃))
    α-natural = NaturalTransformation.natural(NaturalIsomorphism.naturalTransformation([∃]-proof associator))

    υₗ-natural : ∀{x y}{f : x ⟶ y} → (υₗ(y) ∘ (id <⊗> f) ≡ f ∘ υₗ(x))
    υₗ-natural = NaturalTransformation.natural(NaturalIsomorphism.naturalTransformation([∃]-proof unitorₗ))

    υᵣ-natural : ∀{x y}{f : x ⟶ y} → (υᵣ(y) ∘ (f <⊗> id) ≡ f ∘ υᵣ(x))
    υᵣ-natural = NaturalTransformation.natural(NaturalIsomorphism.naturalTransformation([∃]-proof unitorᵣ))

    α⁻¹-natural : ∀{((x₁ , x₂) , x₃) ((y₁ , y₂) , y₃) : (Object ⨯ Object) ⨯ Object}
                   {(f₁ , f₂ , f₃) : ((x₁ ⟶ y₁) ⨯ ((x₂ ⟶ y₂) ⨯ (x₃ ⟶ y₃)))} →
                   ((α⁻¹ y₁ y₂ y₃) ∘ (f₁ <⊗> (f₂ <⊗> f₃)) ≡ ((f₁ <⊗> f₂) <⊗> f₃) ∘ (α⁻¹ x₁ x₂ x₃))
    α⁻¹-natural = NaturalTransformation.natural(NaturalIsomorphism.naturalTransformation([∃]-proof (invᴺᵀ associator)))

    υₗ⁻¹-natural : ∀{x y}{f : x ⟶ y} → (υₗ⁻¹(y) ∘ f ≡ (id <⊗> f) ∘ υₗ⁻¹(x))
    υₗ⁻¹-natural = NaturalTransformation.natural(NaturalIsomorphism.naturalTransformation([∃]-proof (invᴺᵀ unitorₗ)))

    υᵣ⁻¹-natural : ∀{x y}{f : x ⟶ y} → (υᵣ⁻¹(y) ∘ f ≡ (f <⊗> id) ∘ υᵣ⁻¹(x))
    υᵣ⁻¹-natural = NaturalTransformation.natural(NaturalIsomorphism.naturalTransformation([∃]-proof (invᴺᵀ unitorᵣ)))

    -- TODO: And the coherence conditions?

record Monoidalᶜᵃᵗ{ℓₒ}{ℓₘ}{ℓₑ} (C : CategoryObject{ℓₒ}{ℓₘ}{ℓₑ}) : Type{Lvl.𝐒(ℓₒ Lvl.⊔ ℓₘ Lvl.⊔ ℓₑ)} where
  constructor intro
  field
    productFunctor : (C ⨯ᶜᵃᵗ C) →ᶠᵘⁿᶜᵗᵒʳ C
    unitObject : CategoryObject.Object(C)
    ⦃ monoidalCategory ⦄ : MonoidalCategory(productFunctor)(unitObject)

module _
  {C₁ : CategoryObject{ℓₒ}{ℓₘ}{ℓₑ}} ⦃ (intro product₁ 𝟏₁) : Monoidalᶜᵃᵗ(C₁) ⦄
  {C₂ : CategoryObject{ℓₒ}{ℓₘ}{ℓₑ}} ⦃ (intro product₂ 𝟏₂) : Monoidalᶜᵃᵗ(C₂) ⦄
  (functor@([∃]-intro F) : (C₁ →ᶠᵘⁿᶜᵗᵒʳ C₂))
  where

  instance _ = C₁
  instance _ = C₂

  open CategoryObject ⦃ … ⦄
  open Category ⦃ … ⦄
  open Category.ArrowNotation ⦃ … ⦄
  open Functor ⦃ … ⦄
  open MonoidalCategory ⦃ … ⦄

  -- Also called: Lax monoidal functor, applicative functor, idiom.
  record MonoidalFunctor : Type{Lvl.of(Type.of C₁)} where
    constructor intro
    field
      ε : 𝟏₂ ⟶ F(𝟏₁)
      Μ : (product₂ ∘ᶠᵘⁿᶜᵗᵒʳ Tupleᶜᵃᵗ.map functor functor) →ᴺᵀ (functor ∘ᶠᵘⁿᶜᵗᵒʳ product₁)

    μ : ∀{x y} → ((F(x) ⊗ F(y)) ⟶ F(x ⊗ y))
    μ{x}{y} = [∃]-witness Μ (x , y)

    μ-natural : ∀{(x₁ , x₂) (y₁ , y₂) : Object ⦃ C₁ ⦄ ⨯ Object ⦃ C₁ ⦄}
                 {(f₁ , f₂) : ((x₁ ⟶ y₁) ⨯ (x₂ ⟶ y₂))} →
                 (μ ∘ (map(f₁) <⊗> map(f₂)) ≡ map(f₁ <⊗> f₂) ∘ μ)
    μ-natural = NaturalTransformation.natural([∃]-proof Μ)

    -- TODO: Coherence conditions

module _
  {C : CategoryObject{ℓₒ}{ℓₘ}{ℓₑ}} ⦃ (intro product 𝟏) : Monoidalᶜᵃᵗ(C) ⦄
  (functor@([∃]-intro F) : (⟲ᶠᵘⁿᶜᵗᵒʳ C))
  where

  instance _ = C

  open CategoryObject ⦃ … ⦄
  open Category ⦃ … ⦄
  open Category.ArrowNotation ⦃ … ⦄
  open Functor ⦃ … ⦄
  open MonoidalCategory ⦃ … ⦄

  record TensorialStrength : Type{Lvl.of(Type.of C)} where
    constructor intro
    field
      Β : (product ∘ᶠᵘⁿᶜᵗᵒʳ Tupleᶜᵃᵗ.mapRight functor) →ᴺᵀ (functor ∘ᶠᵘⁿᶜᵗᵒʳ product)

    β : ∀{x y} → ((x ⊗ F(y)) ⟶ F(x ⊗ y))
    β{x}{y} = [∃]-witness Β (x , y)

    β-natural : ∀{(x₁ , x₂) (y₁ , y₂) : Object ⦃ C ⦄ ⨯ Object ⦃ C ⦄}
                 {(f₁ , f₂) : ((x₁ ⟶ y₁) ⨯ (x₂ ⟶ y₂))} →
                 (β ∘ (f₁ <⊗> map(f₂)) ≡ map(f₁ <⊗> f₂) ∘ β)
    β-natural = NaturalTransformation.natural([∃]-proof Β)

  module TensorialStrengthenedMonoidalEndofunctor ⦃ monoidal : MonoidalFunctor(functor) ⦄ ⦃ strength : TensorialStrength ⦄ where
    open MonoidalFunctor(monoidal)
    open TensorialStrength(strength)

    Ι : idᶠᵘⁿᶜᵗᵒʳ →ᴺᵀ functor
    ∃.witness Ι x = {!!} ∘ μ{x}{𝟏} ∘ {!!}
    ∃.proof Ι = {!!}

    ι : ∀{x} → (x ⟶ F(x))
    ι{x} = [∃]-witness Ι x


{-# OPTIONS --without-K --safe #-}

open import Categories.Category
open import Categories.Category.Monoidal
open import Categories.Category.Monoidal.Closed

module Categories.Category.Monoidal.Closed.IsClosed.Diagonal
  {o ℓ e} {C : Category o ℓ e} {M : Monoidal C} (Cl : Closed M) where

open import Data.Product using (Σ; _,_)
open import Function using (_$_) renaming (_∘_ to _∙_)
open import Function.Equality as Π using (Π)

open import Categories.Category.Product
open import Categories.Category.Monoidal.Properties M
open import Categories.Morphism C
open import Categories.Morphism.Properties C
open import Categories.Morphism.Reasoning C
open import Categories.Functor renaming (id to idF)
open import Categories.Functor.Bifunctor
open import Categories.Functor.Bifunctor.Properties
open import Categories.NaturalTransformation hiding (id)
open import Categories.NaturalTransformation.Dinatural hiding (_∘ʳ_)
open import Categories.NaturalTransformation.NaturalIsomorphism as NI hiding (refl)
import Categories.Category.Closed as Cls

open Closed Cl

private
  open Category C
  module ℱ = Functor
  module ⊗ = Functor ⊗
  α⇒ = associator.from
  α⇐ = associator.to
  λ⇒ = unitorˡ.from
  λ⇐ = unitorˡ.to
  ρ⇒ = unitorʳ.from
  ρ⇐ = unitorʳ.to

open HomReasoning
open Π.Π
open adjoint renaming (unit to η; counit to ε; Ladjunct to 𝕃; Ladjunct-comm′ to 𝕃-comm′;
 Ladjunct-resp-≈ to 𝕃-resp-≈)

open import Categories.Category.Monoidal.Closed.IsClosed.Identity Cl  -- defines diagonal
open import Categories.Category.Monoidal.Closed.IsClosed.L Cl

Lj≈j : ∀ {X Y} → L X Y Y ∘ diagonal.α Y ≈ diagonal.α [ X , Y ]₀
Lj≈j {X} {Y} = begin
  L X Y Y ∘ 𝕃 λ⇒                                            ≈˘⟨ 𝕃-comm′ ⟩
  𝕃 (𝕃 (ε.η Y ∘ id ⊗₁ ε.η Y ∘ α⇒) ∘ 𝕃 λ⇒ ⊗₁ id)            ≈˘⟨ 𝕃-resp-≈ 𝕃-comm′ ⟩
  𝕃 (𝕃 $ (ε.η Y ∘ id ⊗₁ ε.η Y ∘ α⇒) ∘ (𝕃 λ⇒ ⊗₁ id) ⊗₁ id) ≈⟨ 𝕃-resp-≈ $ 𝕃-resp-≈ $ absorb-λ⇒ ⟩
  𝕃 (𝕃 (Radjunct λ⇒))                                       ≈⟨ 𝕃-resp-≈ LRadjunct≈id ⟩
  diagonal.α [ X , Y ]₀                                     ∎
  where
  absorb-λ⇒ : (ε.η Y ∘ id ⊗₁ ε.η {X} Y ∘ α⇒) ∘ (𝕃 λ⇒ ⊗₁ id) ⊗₁ id ≈ Radjunct λ⇒
  absorb-λ⇒ = begin
    (ε.η Y ∘ id ⊗₁ ε.η Y ∘ α⇒) ∘ (𝕃 λ⇒ ⊗₁ id) ⊗₁ id ≈⟨ pull-last assoc-commute-from ⟩
    ε.η Y ∘ id ⊗₁ ε.η Y ∘ 𝕃 λ⇒ ⊗₁ id ⊗₁ id ∘ α⇒     ≈˘⟨ assoc ⟩
    (ε.η Y ∘ id ⊗₁ ε.η Y) ∘ 𝕃 λ⇒ ⊗₁ id ⊗₁ id ∘ α⇒   ≈⟨ refl⟩∘⟨ ⊗.F-resp-≈ (refl , ⊗.identity) ⟩∘⟨refl ⟩
    (ε.η Y ∘ id ⊗₁ ε.η Y) ∘ 𝕃 λ⇒ ⊗₁ id ∘ α⇒         ≈⟨ center [ ⊗ ]-commute ⟩
    ε.η Y ∘ (𝕃 λ⇒ ⊗₁ id ∘ id ⊗₁ ε.η Y) ∘ α⇒         ≈⟨ pull-first RLadjunct≈id ⟩
    λ⇒ ∘ id ⊗₁ ε.η Y ∘ α⇒                           ≈⟨ pullˡ unitorˡ-commute-from ⟩
    (ε.η Y ∘ λ⇒) ∘ α⇒                                ≈⟨ pullʳ coherence₁ ⟩
    Radjunct λ⇒ ∎

jL≈i : {X Y : Obj} → [ diagonal.α X , id ]₁ ∘ L X X Y ≈ identity.⇒.η [ X , Y ]₀
jL≈i {X} {Y} = begin
  [ Δ X , id ]₁ ∘ L X X Y                             ≈˘⟨ pushˡ [ [-,-] ]-commute ⟩
  ([ id , 𝕃 inner ]₁ ∘ [ Δ X , id ]₁) ∘ η.η XY        ≈˘⟨ pushʳ (mate.commute₁ (diagonal.α X)) ⟩
  [ id , 𝕃 inner ]₁ ∘ [ id , id ⊗₁ Δ X ]₁ ∘ η.η XY    ≈˘⟨ pushˡ (ℱ.homomorphism [ unit ,-]) ⟩
  𝕃 (𝕃 inner ∘ id ⊗₁ Δ X)                             ≈˘⟨ 𝕃-resp-≈ $ 𝕃-comm′ ⟩
  𝕃 (𝕃 $ inner ∘ (id ⊗₁ Δ X) ⊗₁ id)                  ≈⟨ 𝕃-resp-≈ $ 𝕃-resp-≈ inner∘diag⇒ℝρ ⟩
  𝕃 (𝕃 $ Radjunct ρ⇒)                                 ≈⟨ 𝕃-resp-≈ $ LRadjunct≈id ⟩
  𝕃 ρ⇒                                                ≈˘⟨ identityˡ ⟩
  id ∘ 𝕃 ρ⇒    ∎
  where
  XY = [ X , Y ]₀
  inner = ε.η Y ∘ id ⊗₁ ε.η X ∘ α⇒
  Δ = diagonal.α
  inner∘diag⇒ℝρ : inner ∘ (id ⊗₁ Δ X) ⊗₁ id ≈ Radjunct ρ⇒
  inner∘diag⇒ℝρ = begin
    inner ∘ (id ⊗₁ Δ X) ⊗₁ id                      ≈⟨ pull-last assoc-commute-from ○ ⟺ assoc ⟩
    (ε.η Y ∘ id ⊗₁ ε.η X) ∘ id ⊗₁ Δ X ⊗₁ id ∘ α⇒   ≈⟨ center (⟺ (ℱ.homomorphism (XY ⊗-))) ⟩
    ε.η Y ∘ id ⊗₁ (ε.η X ∘ 𝕃 λ⇒ ⊗₁ id) ∘ α⇒        ≈⟨ refl⟩∘⟨ ℱ.F-resp-≈ (XY ⊗-) RLadjunct≈id ⟩∘⟨refl ⟩
    ε.η Y ∘ id ⊗₁ λ⇒ ∘ α⇒                          ≈⟨ refl⟩∘⟨ triangle ⟩
    Radjunct ρ⇒ ∎

private
  i-η = identity.⇒.η

-- Not about diagonal, but it feels like a waste to start another file just for this
iL≈i : {Y Z : Obj} → [ i-η Y , id ]₁ ∘ L unit Y Z ≈ [ id , i-η Z ]₁
iL≈i {Y} {Z} = begin
  [ i-η Y , id ]₁ ∘ L unit Y Z                       ≈˘⟨ pushˡ [ [-,-] ]-commute ⟩
  ([ id , 𝕃 inner ]₁ ∘ [ i-η Y , id ]₁) ∘ η.η YZ     ≈⟨ ( refl⟩∘⟨ (ℱ.F-resp-≈ [-, YZ ⊗₀ [ unit , Y ]₀ ] identityˡ)) ⟩∘⟨refl ⟩
  ([ id , 𝕃 inner ]₁ ∘ [ 𝕃 ρ⇒ , id ]₁) ∘ η.η YZ      ≈˘⟨ pushʳ (mate.commute₁ (𝕃 ρ⇒)) ⟩
  [ id , 𝕃 inner ]₁ ∘ [ id , id ⊗₁ 𝕃 ρ⇒ ]₁ ∘ η.η YZ  ≈˘⟨ pushˡ (ℱ.homomorphism [ Y ,-]) ⟩
  𝕃 (𝕃 inner ∘ id ⊗₁ 𝕃 ρ⇒)                           ≈˘⟨ 𝕃-resp-≈ 𝕃-comm′ ⟩
  𝕃 (𝕃 $ inner ∘ (id ⊗₁ 𝕃 ρ⇒) ⊗₁ id)                ≈⟨ 𝕃-resp-≈ $ 𝕃-resp-≈ absorb ⟩
  𝕃 (𝕃 $ ε.η Z ∘ ρ⇒)                                ≈⟨ 𝕃-resp-≈ $ ∘-resp-≈ˡ (ℱ.homomorphism [ unit ,-])
                                                                  ○ (assoc ○ ∘-resp-≈ʳ (⟺ identityˡ)) ⟩
  𝕃 ([ id , ε.η Z ]₁ ∘ i-η (YZ ⊗₀ Y))               ≈˘⟨ 𝕃-resp-≈ $ identity.⇒.commute (ε.η Z) ⟩
  𝕃 (i-η Z ∘ ε.η Z)                                  ≈˘⟨ 𝕃-resp-≈ $ ε.commute (i-η Z) ⟩
  𝕃 (Radjunct [ id , i-η Z ]₁)                       ≈⟨ LRadjunct≈id ⟩
  [ id , i-η Z ]₁   ∎
  where
  YZ = [ Y , Z ]₀
  inner = ε.η Z ∘ id ⊗₁ ε.η Y ∘ α⇒
  absorb : inner ∘ (id ⊗₁ 𝕃 ρ⇒) ⊗₁ id ≈ ε.η Z ∘ ρ⇒
  absorb = begin
    inner ∘ (id ⊗₁ 𝕃 ρ⇒) ⊗₁ id                      ≈⟨ pull-last assoc-commute-from ○ ⟺ assoc ⟩
    (ε.η Z ∘ id ⊗₁ ε.η Y) ∘ id ⊗₁ 𝕃 ρ⇒ ⊗₁ id ∘ α⇒   ≈⟨ center (⟺ (ℱ.homomorphism (YZ ⊗-))) ⟩
    ε.η Z ∘ id ⊗₁ (ε.η Y ∘ 𝕃 ρ⇒ ⊗₁ id) ∘ α⇒         ≈⟨ refl⟩∘⟨ ℱ.F-resp-≈ (YZ ⊗-) RLadjunct≈id ⟩∘⟨refl ⟩
    ε.η Z ∘ id ⊗₁ ρ⇒ ∘ α⇒                           ≈⟨ refl⟩∘⟨ coherence₂ ⟩
    ε.η Z ∘ ρ⇒  ∎


-- Giving /lift \phi/ the the first hole TWICE (the first time you get an type error), causes the following internal error:

--   An internal error has occurred. Please report this as a bug.
--   Location of the error:
--   src/full/Agda/TypeChecking/Reduce/Monad.hs:118

------------------------------------------------------------------------
-- Library

infixr 9 _∘_

_∘_ : ∀ {a b c}
        {A : Set a} {B : A → Set b} {C : {x : A} → B x → Set c} →
        (∀ {x} (y : B x) → C y) → (g : (x : A) → B x) →
        ((x : A) → C (g x))
f ∘ g = λ x → f (g x)

data ⊥ : Set where

data _⊎_ (A : Set) (B : Set) : Set where
  inj₁ : (x : A) → A ⊎ B
  inj₂ : (y : B) → A ⊎ B

[_,_] : ∀ {A : Set} {B : Set} {C : A ⊎ B → Set} →
        ((x : A) → C (inj₁ x)) → ((x : B) → C (inj₂ x)) →
        ((x : A ⊎ B) → C x)
[ f , g ] (inj₁ x) = f x
[ f , g ] (inj₂ y) = g y

[_,_]₁ : ∀ {A : Set} {B : Set} {C : A ⊎ B → Set₁} →
        ((x : A) → C (inj₁ x)) → ((x : B) → C (inj₂ x)) →
        ((x : A ⊎ B) → C x)
[ f , g ]₁ (inj₁ x) = f x
[ f , g ]₁ (inj₂ y) = g y

record Σ (X : Set) (Y : X → Set) : Set where
  constructor _,_
  field
    proj₁ : X
    proj₂ : Y proj₁

open Σ public

_×_ : Set → Set → Set
X × Y = Σ X λ _ → Y

data _≡_ {X : Set} (x : X) : X → Set where
  refl : x ≡ x

subst : ∀ {A} (P : A → Set) {x y} → x ≡ y → P x → P y
subst P refl p = p

Pow : Set → Set₁
Pow X = X → Set

_∈_ : ∀ {X} → X → Pow X → Set
x ∈ P = P x

infix 4 _⊆_
_⊆_ : ∀ {X} → Pow X → Pow X → Set
P ⊆ Q = ∀ {x} → x ∈ P → x ∈ Q

_∪_ : ∀ {X} → Pow X → Pow X → Pow X
P ∪ Q = λ x → P x ⊎ Q x

_⇒_ : ∀ {X} → Pow X → Pow X → Pow X
P ⇒ Q = λ x → x ∈ P → x ∈ Q

record _▷_ (I O : Set) : Set₁ where
  constructor _◃_/_
  field
    Parameter  : (o : O) → Set
    Arity      : ∀ {o} (p : Parameter o) → Set
    input      : ∀ {o} (p : Parameter o) (a : Arity p) → I

open _▷_ public

Sig = λ I → I ▷ I

⟦_⟧ : ∀ {I O} → I ▷ O → (Pow I → Pow O)
⟦ P ◃ A / s ⟧ X o = Σ (P o) λ p → ((a : A p) → X (s p a))

data μ {I} (Ω : Sig I) : Pow I where
  sup : ⟦ Ω ⟧ (μ Ω) ⊆ μ Ω

const^C : ∀ {I O} → Pow O → I ▷ O
const^C X = X ◃ (λ _ → ⊥) / λ x ()

_⊎^C_ : ∀ {I O} → I ▷ O → I ▷ O → I ▷ O
(P₁ ◃ A₁ / s₁) ⊎^C (P₂ ◃ A₂ / s₂) = (P₁ ∪ P₂) ◃ [ A₁ , A₂ ]₁ / [ s₁ , s₂ ]

_⊙^C_ : ∀ {I J} → I ▷ I → J ▷ J → (I × J) ▷ (I × J)
(P₁ ◃ A₁ / s₁) ⊙^C (P₂ ◃ A₂ / s₂) = (λ { (i , j) → P₁ i ⊎ P₂ j })
  ◃ [ A₁ , A₂ ]₁
  / (λ  { {_ , j} (inj₁ p₁) a₁ → s₁ p₁ a₁ , j
        ; {i , _} (inj₂ p₂) a₂ → i , s₂ p₂ a₂
        })

_⋆^C_ : ∀ {O} → O ▷ O → Pow O → O ▷ O
Σ ⋆^C X = const^C X ⊎^C Σ

_⋆_ : ∀ {O} → O ▷ O → Pow O → Pow O
Σ ⋆ X = μ (Σ ⋆^C X)

Alg : ∀ {I} → Sig I → Pow I → Set
Alg Ω X = ⟦ Ω ⟧ X ⊆ X

do : ∀ {O} {Σ : O ▷ O} {X} → Alg Σ (Σ ⋆ X)
do (p , k) = sup (inj₂ p , k)

Hom : ∀ {I J} → Sig (I × J) → Pow (I × J) → Pow I → Sig J → Pow J → Set
Hom Ω U V Ψ W = Alg  (const^C U ⊎^C Ω)
                     ((V ∘ proj₁) ⇒ ((Ψ ⋆ W) ∘ proj₂))

_⋊_ : ∀ {I O} (C : I ▷ O) Z → (I × Z) ▷ (O × Z)
(P ◃ A / s) ⋊ Z = (P ∘ proj₁) ◃ A / λ {oz} p a → s p a , proj₂ oz

record ContainerMorphism
    {I₁ I₂ O₁ O₂}
    (C₁ : I₁ ▷ O₁) (C₂ : I₂ ▷ O₂)
    (f : I₁ → I₂) (g : O₁ → O₂)
    (_∼_ : I₂ → I₂ → Set) (_≈_ : Set → Set → Set)
    (_·_ : ∀ {A B} → A ≈ B → A → B) : Set where
  field
    parameter  : Parameter C₁ ⊆ Parameter C₂ ∘ g
    arity      : ∀ {o} {p₁ : Parameter C₁ o} →
                 Arity C₂ (parameter p₁) ≈ Arity C₁ p₁
    coherent   : ∀ {o} {p₁ : Parameter C₁ o} {a₂ : Arity C₂ (parameter p₁)} →
                 f (input C₁ p₁ (arity · a₂)) ∼ input C₂ (parameter p₁) a₂

open ContainerMorphism public

_⇛[_/_]_ : ∀ {I₁ I₂ O₁ O₂} → I₁ ▷ O₁ → (I₁ → I₂) → (O₁ → O₂) →
           I₂ ▷ O₂ → Set
C₁ ⇛[ f / g ] C₂ = ContainerMorphism C₁ C₂ f g _≡_  (λ R₂ R₁ → R₂ → R₁)
                                                    (λ f x → f x)

_⇛[_]_ : ∀ {I J} → I ▷ I → (I → J) → J ▷ J → Set
C₁ ⇛[ f ] C₂ = C₁ ⇛[ f / f ] C₂

⟪_⟫ : ∀ {I J} {C₁ : I ▷ I} {C₂ : J ▷ J} {f : I → J} →
      C₁ ⇛[ f ] C₂ → (X : Pow J) → ⟦ C₁ ⟧ (X ∘ f) ⊆ ⟦ C₂ ⟧ X ∘ f
⟪ m ⟫ X (c , k) = parameter m c , λ a₂ →
  subst X (coherent m) (k (arity m a₂))

------------------------------------------------------------------------

weaken : ∀ {I J} {Ω : Sig I} {Ψ : Sig J} {X : Pow J} {f : I → J} →
         Alg Ψ X → Ω ⇛[ f ] Ψ → Alg Ω (X ∘ f)
weaken {X = X} φ m (p , k) = φ (⟪ m ⟫ X (p , k))

lift : ∀ {I J} {Ω : Sig I} {U : Pow (I × J)} {V : Pow I} {Ψ : Sig J} {W : Pow J} →
       Hom (Ω ⋊ J)    U V Ψ W →
       Hom (Ω ⊙^C Ψ)  U V Ψ W
lift φ (inj₁ u , _)         = φ (inj₁ u , λ ())
lift φ (inj₂ (inj₁ p) , k)  = φ (inj₂ p , k)
lift φ (inj₂ (inj₂ p) , k)  = λ v → do (p , λ a → k a v)

handle : ∀ {I J K} {Ω : Sig I} {Ω′ : Sig J} {Ω″ : Sig K}
         {U : Pow (J × K)} {V : Pow J} {W : Pow K} {f : I → J × K} →
         Hom (Ω′ ⋊ K) U V Ω″ W → Ω ⇛[ f ] (Ω′ ⊙^C Ω″) →
         ∀ {i} → i ∈ (Ω ⋆ (U ∘ f)) → let (j , k) = f i in
         j ∈ V → k ∈ (Ω″ ⋆ W)
handle φ m (sup (inj₁ u  , _))  v = φ (inj₁ u , λ ()) v
handle φ m (sup (inj₂ p  , k))  v = weaken {!lift φ!} {!!} {!!}

-- Expected outcome:
-- giving "lift φ" twice should give the same error twice.


{-# OPTIONS --without-K --rewriting #-}

open import HoTT
open import cw.CW
open import homotopy.SphereEndomorphism
open import homotopy.PinSn
open import groups.CoefficientExtensionality

module cw.DegreeBySquashing {i} where

  module DegreeAboveOne {n : ℕ} (skel : Skeleton {i} (S (S n)))
    (dec : has-cells-with-dec-eq skel)
    -- the cells at the upper and lower dimensions
    (upper : cells-last skel)
    (lower : cells-last (cw-init skel))
    where

    private
      lower-skel = cw-init skel
      lower-dec = init-has-cells-with-dec-eq skel dec
      lower-cells = cells-last lower-skel
      lower-cells-has-dec-eq = cells-last-has-dec-eq lower-skel lower-dec

    -- squash the lower CW complex except one of its cells [lower]
    cw-squash-lower-to-Sphere : ⟦ lower-skel ⟧ → Sphere (S n)
    cw-squash-lower-to-Sphere = Attached-rec (λ _ → north) squash-hubs squash-spokes where
      -- squash cells except [lower]
      squash-hubs : lower-cells → Sphere (S n)
      squash-hubs c with lower-cells-has-dec-eq c lower
      ... | (inl _) = south
      ... | (inr _) = north
      -- squash cells except [lower]
      squash-spokes : (c : lower-cells) → Sphere n
        → north == squash-hubs c
      squash-spokes c s with lower-cells-has-dec-eq c lower
      ... | (inl _) = merid s
      ... | (inr _) = idp

    degree-map : Sphere (S n) → Sphere (S n)
    degree-map = cw-squash-lower-to-Sphere ∘ attaching-last skel upper

    degree-map' : ℤ-group →ᴳ ℤ-group
    degree-map' = –>ᴳ (πS-SphereS-iso-ℤ n)
               ∘ᴳ Trunc-rec →ᴳ-level (πS-fmap n)
                    (⊙SphereS-endo-in n [ degree-map ])
               ∘ᴳ <–ᴳ (πS-SphereS-iso-ℤ n)

    degree' : ℤ → ℤ
    degree' = GroupHom.f degree-map'

    degree : ℤ
    degree = degree' 1

  module DegreeAtOne (skel : Skeleton {i} 1)
    (dec : has-cells-with-dec-eq skel)
    -- the cells at the upper and lower dimensions
    (line : cells-last skel)
    (point : cells-last (cw-init skel)) where

    private
      points-dec-eq = cells-nth-has-dec-eq (inr ltS) skel dec
      endpoint = attaching-last skel

    -- Maybe [true] can or should be mapped to [-1]. Not sure.
    degree : ℤ
    degree with points-dec-eq (endpoint line true) point
    degree | inl _ = 1
    degree | inr _ with points-dec-eq (endpoint line false) point
    degree | inr _ | inl _ = -1
    degree | inr _ | inr _ = 0

  degree-last : ∀ {n} (skel : Skeleton {i} (S n))
    → has-cells-with-dec-eq skel
    → cells-last skel → cells-last (cw-init skel) → ℤ
  degree-last {n = O} = DegreeAtOne.degree
  degree-last {n = S _} = DegreeAboveOne.degree

  degree-nth : ∀ {m n} (Sm≤n : S m ≤ n) (skel : Skeleton {i} n)
    → has-cells-with-dec-eq skel
    → cells-nth Sm≤n skel → cells-last (cw-init (cw-take Sm≤n skel)) → ℤ
  degree-nth Sm≤n skel dec = degree-last (cw-take Sm≤n skel) (take-has-cells-with-dec-eq Sm≤n skel dec)

  has-degrees-with-finite-support : ∀ {n} (skel : Skeleton {i} n)
    → has-cells-with-dec-eq skel → Type i
  has-degrees-with-finite-support {n = O} _ _ = Lift ⊤
  has-degrees-with-finite-support {n = S n} skel dec =
    has-degrees-with-finite-support (cw-init skel) (init-has-cells-with-dec-eq skel dec) ×
    ∀ upper → has-finite-support (cells-nth-has-dec-eq (inr ltS) skel dec) (degree-last skel dec upper)

  init-has-degrees-with-finite-support : ∀ {n} (skel : Skeleton {i} (S n)) dec
    → has-degrees-with-finite-support skel dec
    → has-degrees-with-finite-support (cw-init skel) (init-has-cells-with-dec-eq skel dec)
  init-has-degrees-with-finite-support skel dec fin-sup = fst fin-sup

  take-has-degrees-with-finite-support : ∀ {m n} (m≤n : m ≤ n) (skel : Skeleton {i} n) dec
    → has-degrees-with-finite-support skel dec
    → has-degrees-with-finite-support (cw-take m≤n skel) (take-has-cells-with-dec-eq m≤n skel dec)
  take-has-degrees-with-finite-support (inl idp) skel dec fin-sup = fin-sup
  take-has-degrees-with-finite-support (inr ltS) skel dec fin-sup =
    init-has-degrees-with-finite-support skel dec fin-sup
  take-has-degrees-with-finite-support (inr (ltSR lt)) skel dec fin-sup =
    take-has-degrees-with-finite-support (inr lt) (cw-init skel)
      (init-has-cells-with-dec-eq skel dec)
      (init-has-degrees-with-finite-support skel dec fin-sup)

  degree-last-has-finite-support : ∀ {n} (skel : Skeleton {i} (S n)) dec
    → has-degrees-with-finite-support skel dec
    → ∀ upper → has-finite-support
        (cells-last-has-dec-eq (cw-init skel) (init-has-cells-with-dec-eq skel dec))
        (degree-last skel dec upper)
  degree-last-has-finite-support skel dec fin-sup = snd fin-sup

  degree-nth-has-finite-support : ∀ {m n} (Sm≤n : S m ≤ n) (skel : Skeleton {i} n) dec
    → has-degrees-with-finite-support skel dec
    → ∀ upper → has-finite-support
        (cells-last-has-dec-eq
          (cw-init (cw-take Sm≤n skel))
          (init-has-cells-with-dec-eq (cw-take Sm≤n skel) (take-has-cells-with-dec-eq Sm≤n skel dec)))
        (degree-nth Sm≤n skel dec upper)
  degree-nth-has-finite-support Sm≤n skel dec fin-sup =
    degree-last-has-finite-support (cw-take Sm≤n skel)
      (take-has-cells-with-dec-eq Sm≤n skel dec)
      (take-has-degrees-with-finite-support Sm≤n skel dec fin-sup)

  -- the following are named [boundary'] because it is not extended to the free groups

  boundary'-last : ∀ {n} (skel : Skeleton {i} (S n)) dec
    → has-degrees-with-finite-support skel dec
    → cells-last skel → FreeAbGroup.El (cells-last (cw-init skel))
  boundary'-last skel dec fin-sup upper = fst ((snd fin-sup) upper)

  boundary'-nth : ∀ {m n} (Sm≤n : S m ≤ n) (skel : Skeleton {i} n) dec
    → has-degrees-with-finite-support skel dec
    → cells-nth Sm≤n skel → FreeAbGroup.El (cells-last (cw-init (cw-take Sm≤n skel)))
  boundary'-nth Sm≤n skel dec fin-sup =
    boundary'-last (cw-take Sm≤n skel)
      (take-has-cells-with-dec-eq Sm≤n skel dec)
      (take-has-degrees-with-finite-support Sm≤n skel dec fin-sup)


module Basics where

id : ∀ {a}{A : Set a} → A → A
id x = x

_∘_ : ∀ {a b c}{A : Set a}{B : Set b}{C : Set c} → (f : B → C) → (g : A → B) → (A → C)
f ∘ g = λ x → f (g x)


module Control.Monad.Zero where

open import Prelude

record MonadZero {a b} (M : Set a → Set b) : Set (lsuc a ⊔ b) where
  instance constructor mkMonadZero
  field overlap {{super-zero}}  : FunctorZero M
        overlap {{super-monad}} : Monad M

open MonadZero public


{-

This file contains a summary of what remains for π₄(S³) ≡ ℤ/2ℤ to be proved.

See the module π₄S³ at the end of this file.

-}

{-# OPTIONS --safe #-}
module Cubical.Homotopy.Group.Pi4S3.Summary where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Pointed

open import Cubical.Data.Nat.Base
open import Cubical.Data.Sigma.Base
open import Cubical.Data.Int renaming (ℤ to Int) hiding (_+_)

open import Cubical.HITs.Sn
open import Cubical.HITs.SetTruncation

open import Cubical.Homotopy.Group.Base hiding (π)
open import Cubical.Homotopy.HopfInvariant.Base
open import Cubical.Homotopy.HopfInvariant.Homomorphism
open import Cubical.Homotopy.HopfInvariant.HopfMap
open import Cubical.Homotopy.Whitehead
open import Cubical.Homotopy.Group.Pi3S2

open import Cubical.Algebra.Group.Base
open import Cubical.Algebra.Group.Morphisms
open import Cubical.Algebra.Group.MorphismProperties
open import Cubical.Algebra.Group.Instances.Int
open import Cubical.Algebra.Group.Instances.IntMod
open import Cubical.Algebra.Group.ZAction

private
  variable
    ℓ : Level

-- TODO: ideally this would not be off by one in the definition of π'Gr
π : ℕ → Pointed ℓ → Group ℓ
π n X = π'Gr (predℕ n) X

-- Nicer notation for the spheres (as pointed types)
𝕊² 𝕊³ : Pointed₀
𝕊² = S₊∙ 2
𝕊³ = S₊∙ 3

-- Whitehead product
[_]× : {X : Pointed ℓ} {n m : ℕ} → π' (suc n) X × π' (suc m) X → π' (suc (n + m)) X
[_]× (f , g) = [ f ∣ g ]π'

-- Some type abbreviations (unproved results)
π₄S³≡ℤ/something : GroupEquiv (π 3 𝕊²) ℤ → Type₁
π₄S³≡ℤ/something eq =
  π 4 𝕊³ ≡ ℤ/ abs (eq .fst .fst [ ∣ idfun∙ _ ∣₂ , ∣ idfun∙ _ ∣₂ ]×)

-- Summary of the last steps of the proof
module π₄S³
  (π₃S²≃ℤ           : GroupEquiv (π 3 𝕊²) ℤ)
  (gen-by-HopfMap   : gen₁-by (π 3 𝕊²) ∣ HopfMap ∣₂)
  (π₄S³≡ℤ/whitehead : π₄S³≡ℤ/something π₃S²≃ℤ)
  (hopfWhitehead    : abs (HopfInvariant-π' 0 ([ (∣ idfun∙ _ ∣₂ , ∣ idfun∙ _ ∣₂) ]×)) ≡ 2)
  where

  -- Package the Hopf invariant up into a group equivalence
  hopfInvariantEquiv : GroupEquiv (π 3 𝕊²) ℤ
  fst (fst hopfInvariantEquiv) = HopfInvariant-π' 0
  snd (fst hopfInvariantEquiv) =
    GroupEquivℤ-isEquiv (invGroupEquiv π₃S²≃ℤ) ∣ HopfMap ∣₂
                        gen-by-HopfMap (GroupHom-HopfInvariant-π' 0)
                        (abs→⊎ _ _ HopfInvariant-HopfMap)
  snd hopfInvariantEquiv = snd (GroupHom-HopfInvariant-π' 0)

  -- The two equivalences map [ (∣ idfun∙ _ ∣₂ , ∣ idfun∙ _ ∣₂) ]× to
  -- the same number, modulo the sign
  remAbs : abs (groupEquivFun π₃S²≃ℤ [ (∣ idfun∙ _ ∣₂ , ∣ idfun∙ _ ∣₂) ]×)
         ≡ abs (groupEquivFun hopfInvariantEquiv [ (∣ idfun∙ _ ∣₂ , ∣ idfun∙ _ ∣₂) ]×)
  remAbs = absGroupEquivℤGroup (invGroupEquiv π₃S²≃ℤ) (invGroupEquiv hopfInvariantEquiv) _

  -- So the image of [ (∣ idfun∙ _ ∣₂ , ∣ idfun∙ _ ∣₂) ]× under π₃S²≃ℤ
  -- is 2 (modulo the sign)
  remAbs₂ : abs (groupEquivFun π₃S²≃ℤ [ (∣ idfun∙ _ ∣₂ , ∣ idfun∙ _ ∣₂) ]×) ≡ 2
  remAbs₂ = remAbs ∙ hopfWhitehead

  -- The final result then follows
  π₄S³≡ℤ : π 4 𝕊³ ≡ ℤ/ 2
  π₄S³≡ℤ = π₄S³≡ℤ/whitehead ∙ cong (ℤ/_) remAbs₂

-- In order to instantiate the module, we need the four following lemmas:
-- Proved: 2/4

{- Lemma 1 -}
Lemma₁ : GroupEquiv ℤ (π'Gr 2 (S₊∙ 2))
Lemma₁ = invGroupEquiv π₃S²≅ℤ

{- Lemma 2 -}
Lemma₂ : gen₁-by (π 3 𝕊²) ∣ HopfMap ∣₂
Lemma₂ = π₂S³-gen-by-HopfMap

{- Lemma 3 (WIP) -}
{-
Lemma₃ : π₄S³≡ℤ/something (invGroupEquiv π₃S²≅ℤ)
Lemma₃ = ?
-}

{- Lemma 4 (WIP) -}
{-
Lemma₄ : abs (HopfInvariant-π' 0 ([ (∣ idfun∙ _ ∣₂ , ∣ idfun∙ _ ∣₂) ]×)) ≡ 2)
Lemma₄ = ?
-}


-- {-# OPTIONS -v tc.meta:30 #-}
{-# OPTIONS --show-implicit --show-irrelevant #-}
module Issue629a where

record ∃ {A : Set} (B : A → Set) : Set where
  constructor _,_
  field
    proj₁ : A
    proj₂ : B proj₁

uncurry : {A : Set} {B : A → Set} {C : ∃ B → Set} →
          ((x : A) (y : B x) → C (x , y)) →
          ((p : ∃ B) → C p)
uncurry f (x , y) = f x y

foo : {A : Set} {B : A → Set} → ∃ B → ∃ B
foo = uncurry λ x y → (x , y)


-- ----------------------------------------------------------------------
-- The Agda Descriptor Library
--
-- (Open) Descriptors
-- ----------------------------------------------------------------------

module Data.Desc where

open import Data.List using (List; []; _∷_)
open import Data.List.Relation.Unary.All using (All; []; _∷_)
open import Data.List.Relation.Unary.Any using (here; there)
open import Data.List.Membership.Propositional using (_∈_)
open import Data.Product using (Σ; _,_)
open import Data.Var using (_-Scoped[_]; Var; get; zero; suc; tabulate)
open import Data.Unit.Polymorphic using (⊤; tt)

open import Level using (Level; 0ℓ; _⊔_)

open import Relation.Unary using (IUniversal; _⇒_)

private
  variable
    A : Set

1ℓ : Level
1ℓ = Level.suc 0ℓ

-- ----------------------------------------------------------------------
-- Definition
--
-- An open description is a open dependent type theory.
-- Our theoretic model is described by:
--
-- Metatheoretic terms:
--
-- Agda sets          A, B ∷= ...
-- Agda values        x, y ∷= ...
--
-- Open object terms:
--
-- kinds              κ ∷= Set | Π A κ
-- types              T ∷= a | T x | Π A T | T ⟶ T
--
-- A descriptor is a set of well-kinded constructor types.

data Kind : Set₁ where
  `Set₀ : Kind
  `Π : (A : Set) → (A → Kind) → Kind

private
  variable
    κ κ′ : Kind
    Γ : List Kind
    B : A → Kind

infixr 6 _⟶_

data Type : Kind -Scoped[ 1ℓ ] where
  `_ : ∀[ Var κ ⇒ Type κ ]
  _·_ : Type (`Π A B) Γ → (a : A) → Type (B a) Γ
  `Π : (A : Set) → (A → Type `Set₀ Γ) → Type `Set₀ Γ
  _⟶_ : Type `Set₀ Γ → Type `Set₀ Γ → Type `Set₀ Γ

mutual

  data Pos : Type κ Γ → Set where

    `_ : ∀ (x : Var κ Γ)
      -- ----------------
      → Pos (` x)

    _·_ : ∀ {T : Type (`Π A B) Γ}
      → Pos T
      → (a : A)
      -- ------------------------
      → Pos (T · a)

    `Π : (A : Set) {T : A → Type `Set₀ Γ}
      → ((a : A) → Pos (T a))
      -- --------------------------------
      → Pos (`Π A T)

    _⟶_ : ∀ {T T′ : Type `Set₀ Γ}
      → Neg T
      → Pos T′
      -- --------------------------
      → Pos (T ⟶ T′)

  data Neg : Type κ Γ → Set where

    _·_ : ∀ {T : Type (`Π A B) Γ}
      → Neg T
      → (a : A)
      -- ------------------------
      → Neg (T · a)

    `Π : (A : Set) {T : A → Type `Set₀ Γ}
      → ((a : A) → Neg (T a))
      -- --------------------------------
      → Neg (`Π A T)

    _⟶_ : ∀ {T T′ : Type `Set₀ Γ}
      → Pos T
      → Neg T′
      -- --------------------------
      → Neg (T ⟶ T′)

data StrictPos : Type κ Γ → Set where

  `_ : ∀ (x : Var κ Γ)
    -- ----------------
    → StrictPos (` x)

  _·_ : ∀ {T : Type (`Π A B) Γ}
    → StrictPos T
    → (a : A)
    -- ------------------------
    → StrictPos (T · a)

  `Π : (A : Set) {T : A → Type `Set₀ Γ}
    → ((a : A) → StrictPos (T a))
    -- --------------------------------
    → StrictPos (`Π A T)

data Con : Type κ Γ → Set where

  `_ : ∀ (x : Var κ Γ)
  -- ----------------
    → Con (` x)

  _·_ : ∀ {T : Type (`Π A B) Γ}
    → Con T
    → (a : A)
    -- ------------------------
    → Con (T · a)

  `Π : (A : Set) {T : A → Type `Set₀ Γ}
    → ((a : A) → Con (T a))
    -- --------------------------------
    → Con (`Π A T)

  _⟶_ : ∀ {T T′ : Type `Set₀ Γ}
    → StrictPos T
    → Con T′
    -- --------------------------
    → Con (T ⟶ T′)

data Constr : Kind -Scoped[ 1ℓ ] where
  ! : {T : Type κ Γ} → Con T → Constr κ Γ

++⇒C : ∀{T : Type κ Γ} → StrictPos T → Con T
++⇒C (` x) = ` x
++⇒C (P · a) = ++⇒C P · a
++⇒C (`Π A P) = `Π A (λ a → ++⇒C (P a))

Desc : List Kind → Set₁
Desc Γ = List (Constr `Set₀ Γ)

-- ----------------------------------------------------------------------
-- Interpretation

lift⟦_⟧ᴷ : Kind → (ℓ : Level) → Set (Level.suc ℓ)
lift⟦ `Set₀ ⟧ᴷ ℓ = Set ℓ
lift⟦ `Π A κ ⟧ᴷ ℓ = (a : A) → lift⟦ κ a ⟧ᴷ ℓ

-- Lifting of lift⟦_⟧ᴷ to a context
lift⟪_⟫ᴷ : List Kind → (ℓ : Level) → Set (Level.suc ℓ)
lift⟪ Γ ⟫ᴷ ℓ = All (λ κ → lift⟦ κ ⟧ᴷ ℓ) Γ

⟦_⟧ᴷ : Kind → Set₁
⟦ `Set₀ ⟧ᴷ = Set
⟦ `Π A κ ⟧ᴷ = (a : A) → ⟦ κ a ⟧ᴷ

⟪_⟫ᴷ : List Kind → Set₁
⟪ Γ ⟫ᴷ = All ⟦_⟧ᴷ Γ

-- ----------------------------------------------------------------------
-- Fixpoint
--

-- To define the fixed point, we're looking for a fixpoint of the form:
--  μ : Desc Γ → ⟪ Γ ⟫ᴷ
--
-- To consider the interpretation of constructors and type formers,
-- we first describe the terms formed by constructors and
-- positive types:
--
-- constructor terms    c ∷= Constrᵢ | c · a | c · p

private
  variable
    C : Constr `Set₀ Γ
    D : Desc Γ

data Term : Constr `Set₀ Γ -Scoped[ 1ℓ ] where
  `Constr : ∀[ Var C ⇒ Term C ]
  _·_ : ∀ {A} {T : A → Type `Set₀ Γ} {C : (a : A) → Con (T a)}
    → Term (! (`Π A C)) D → (a : A) → Term (! (C a)) D
  _•_ :  ∀ {T T′ : Type `Set₀ Γ} {P : StrictPos T} {C : Con T′}
    → Term (! (P ⟶ C)) D → Term (! (++⇒C P)) D → Term (! C) D

μᵏ : Constr κ Γ → Desc Γ → lift⟦ κ ⟧ᴷ 1ℓ
μᵏ {κ = `Set₀} C D = Term C D
μᵏ {κ = `Π _ _} (! C) D = λ a → μᵏ (! (C · a)) D

μᴰ : Desc Γ → lift⟪ Γ ⟫ᴷ 1ℓ
μᴰ D = tabulate λ x → μᵏ (! (` x)) D

-- ----------------------------------------------------------------------
-- Examples

ℕᴰ : Desc (`Set₀ ∷ [])
ℕᴰ = ! (` zero) ∷ ! ((` zero) ⟶ (` zero)) ∷ []

`ℕ : Set₁
`ℕ = get zero (μᴰ ℕᴰ)

pattern `zero = `Constr zero
pattern `suc n = `Constr (suc zero) • n

_ : `ℕ
_ = `suc (`suc `zero)


-- Andreas, 2017-11-01, issue #2824
-- allow built-in pragmas in parametrized modules

{-# OPTIONS --rewriting #-}

open import Agda.Builtin.Equality

module _ (A : Set) where  -- This is the top-level module header.

{-# BUILTIN REWRITE _≡_ #-}

postulate
  P : A → Set
  a b : A
  a→b : a ≡ b

{-# REWRITE a→b #-}

test : P a → P b
test x = x

-- Should succeed.