open import Agda.Primitive using (lzero; lsuc; _⊔_ ;Level)
open import Relation.Binary.PropositionalEquality using (_≡_; refl; sym; setoid; cong; trans)
import Function.Equality
open import Relation.Binary using (Setoid)

import Categories.Category
import Categories.Functor
import Categories.Category.Instance.Setoids
import Categories.Monad.Relative
import Categories.Category.Equivalence
import Categories.Category.Cocartesian
import Categories.Category.Construction.Functors
import Categories.NaturalTransformation.Equivalence
import Relation.Binary.Core

import SecondOrder.Arity
import SecondOrder.Signature
import SecondOrder.Metavariable
import SecondOrder.VRenaming
import SecondOrder.MRenaming
import SecondOrder.Term
import SecondOrder.IndexedCategory
import SecondOrder.RelativeKleisli
import SecondOrder.Substitution

module SecondOrder.VRelativeMonad
  {ℓ}
  {𝔸 : SecondOrder.Arity.Arity}
  (Σ : SecondOrder.Signature.Signature ℓ 𝔸)
  where

  open SecondOrder.Signature.Signature Σ
  open SecondOrder.Metavariable Σ
  open SecondOrder.Term Σ
  open SecondOrder.VRenaming Σ
  open SecondOrder.MRenaming Σ
  open SecondOrder.Substitution Σ

  -- TERMS FORM A RELATIVE MONAD
  -- (FOR A FUNCTOR WHOSE DOMAIN IS THE
  -- CATEGORY OF VARIABLE CONTEXTS AND RENAMINGS)

  module _ where
    open Categories.Category
    open Categories.Functor using (Functor)
    open Categories.Category.Instance.Setoids
    open Categories.Monad.Relative
    open Function.Equality using () renaming (setoid to Π-setoid)
    open Categories.Category.Equivalence using (StrongEquivalence)
    open import SecondOrder.IndexedCategory
    open import SecondOrder.RelativeKleisli
    open Categories.Category.Construction.Functors
    open Categories.NaturalTransformation.Equivalence
    open Relation.Binary.Core hiding (_⇒_)

    -- The carrier of the codomain of Jⱽ (morally ∀ Γ → A ∈ Δ ,, Γ)

    record Codomain-Jⱽ-Elt : Set ((lsuc ℓ)) where
      open Category (Setoids ℓ ℓ)
      open Setoid
      field
        F₀ :  VContext → MContext → Obj
        F₁ : ∀ {Θ ψ Δ Ξ} (ρ : Δ ⇒ᵛ Ξ) (ι : Θ ⇒ᵐ ψ)
             → (F₀ Δ Θ) ⇒ (F₀ Ξ ψ)
        identity : ∀ {Θ Δ}
                   → Category._≈_ (Setoids ℓ ℓ) (F₁ (idᵛ {Δ}) (idᵐ {Θ})) (id {F₀ Δ Θ})
        homomorphism : ∀ {Θ ψ Ω Γ Δ Ξ} {ρ : Γ ⇒ᵛ Δ} {ι : Θ ⇒ᵐ ψ} {τ : Δ ⇒ᵛ Ξ} {μ : ψ ⇒ᵐ Ω}
                       → Category._≈_ (Setoids ℓ ℓ) (F₁ (τ ∘ᵛ ρ) (μ ∘ᵐ ι)) ((F₁ τ μ) ∘ (F₁ ρ ι))
        F-resp-≈ : ∀ {Θ ψ Γ Δ} {ρ τ : Γ ⇒ᵛ Δ} {ι μ : Θ ⇒ᵐ ψ}
                   → (ρ ≡ᵛ τ) → (ι ≡ᵐ μ) → (Category._≈_ (Setoids ℓ ℓ) (F₁ ρ ι) (F₁ τ μ))

    -- Transformation for Codomain-Jⱽ (analogue to natural transformations)

    record NaturalTransformation-Jⱽ (Fⱽ Gⱽ : Codomain-Jⱽ-Elt) : Set (lsuc ℓ)
      where
        private
          module Fⱽ = Codomain-Jⱽ-Elt Fⱽ
          module Gⱽ = Codomain-Jⱽ-Elt Gⱽ
        open Fⱽ using (F₀; F₁)
        open Category (Setoids ℓ ℓ)
        field
          η : ∀ Θ Γ → (F₀ Γ Θ) ⇒ (Gⱽ.F₀ Γ Θ)
          commute : ∀ {Θ ψ Γ Δ} (ρ : Γ ⇒ᵛ Δ) (ι : Θ ⇒ᵐ ψ)
                    → Category._≈_ (Setoids ℓ ℓ) ((η ψ Δ) ∘ (F₁ ρ ι)) ((Gⱽ.F₁ ρ ι) ∘ (η Θ Γ))
          -- ignore-MCtx : ∀ Θ Ω Γ → (∀ (x : F₀ Γ Θ))

    open NaturalTransformation-Jⱽ

    -- Equivalence of NaturalTransformation-Jⱽ (analogue to the one
    -- of the natural transformations)

    infix 4 _≃Jⱽ_

    _≃Jⱽ_ : ∀ {Fⱽ Gⱽ : Codomain-Jⱽ-Elt} → Rel (NaturalTransformation-Jⱽ Fⱽ Gⱽ) ℓ
    𝒩 ≃Jⱽ ℳ  = ∀ {Θ Γ} → Category._≈_ (Setoids ℓ ℓ)
                            (η 𝒩 Θ Γ)
                            (η ℳ Θ Γ)

    -- Identity transformation analogue to the one
    -- of the natural transformations, for NaturalTransformation-Jⱽ

    idN-Jⱽ : ∀ {Fⱽ : Codomain-Jⱽ-Elt} → NaturalTransformation-Jⱽ Fⱽ Fⱽ
    idN-Jⱽ {Fⱽ} =
           record
             { η = λ Θ Γ →
               record
                 { _⟨$⟩_ = λ x → x
                 ; cong = λ x → x }
             ; commute = λ {Θ} {ψ} {Γ} {Δ} ρ ι ξ
                         → Codomain-Jⱽ-Elt.F-resp-≈  Fⱽ {Θ} {ψ} {Γ} {Δ} {ρ} {ρ} {ι} {ι}
                                                (λ x₁ → refl) (λ M → refl) ξ }

    -- Composition of NaturalTransformation-Jⱽ (analogue to the one
    -- of the natural transformations)

    _∘-Jⱽ_ : ∀ {Fⱽ Gⱽ Hⱽ : Codomain-Jⱽ-Elt} (𝒩 : NaturalTransformation-Jⱽ Gⱽ Hⱽ) (ℳ : NaturalTransformation-Jⱽ Fⱽ Gⱽ) → NaturalTransformation-Jⱽ Fⱽ Hⱽ
    _∘-Jⱽ_ {Fⱽ} {Gⱽ} {Hⱽ} 𝒩 ℳ =
             let open Category (Setoids ℓ ℓ) in
             let open NaturalTransformation-Jⱽ in
             let open Codomain-Jⱽ-Elt in
             record
                 { η = λ Θ Γ → η 𝒩 Θ Γ ∘ η ℳ Θ Γ
                 ; commute = λ {Θ} {ψ} {Γ} {Δ} ρ ι →
                             let open HomReasoning {F₀ Fⱽ Γ Θ} {F₀ Hⱽ Δ ψ} in
                             begin
                             (Category._∘_ (Setoids ℓ ℓ) (η {Gⱽ} {Hⱽ} 𝒩 ψ Δ) ((η {Fⱽ} {Gⱽ} ℳ ψ Δ) ∘ (F₁ Fⱽ ρ ι))) ≈⟨ assoc {f = F₁ Fⱽ ρ ι} {g = η ℳ ψ Δ} {h = η 𝒩 ψ Δ} ⟩
                             (η 𝒩 ψ Δ ∘ (η ℳ ψ Δ) ∘ (F₁ Fⱽ ρ ι)) ≈⟨ refl⟩∘⟨_
                                                                      {f = η 𝒩 ψ Δ} {g = (η ℳ ψ Δ) ∘ (F₁ Fⱽ ρ ι)}
                                                                      {i = (F₁ Gⱽ ρ ι) ∘ (η ℳ Θ Γ)}
                                                                      (commute ℳ ρ ι) ⟩
                             (η 𝒩 ψ Δ ∘ ((F₁ Gⱽ ρ ι) ∘ (η ℳ Θ Γ))) ≈⟨ sym-assoc {f = η ℳ Θ Γ} {g = F₁ Gⱽ ρ ι} {h = η 𝒩 ψ Δ}⟩
                             ((η 𝒩 ψ Δ) ∘ (F₁ Gⱽ ρ ι)) ∘ (η ℳ Θ Γ) ≈⟨ _⟩∘⟨refl
                                                                      {f = (η 𝒩 ψ Δ) ∘ (F₁ Gⱽ ρ ι)} {h = (F₁ Hⱽ ρ ι) ∘ (η 𝒩 Θ Γ)}
                                                                      {g = η ℳ Θ Γ}
                                                                      (commute 𝒩 ρ ι) ⟩
                             (((F₁ Hⱽ ρ ι) ∘ (η 𝒩 Θ Γ)) ∘ (η ℳ Θ Γ)) ≈⟨ assoc {f = η ℳ Θ Γ} {g = η 𝒩 Θ Γ} {h = F₁ Hⱽ ρ ι} ⟩
                             (((F₁ Hⱽ ρ ι) ∘ (η 𝒩 Θ Γ)) ∘ (η ℳ Θ Γ)) ∎}

    -- Proof that the category of Codomain-Jⱽ and NaturalTransformation-Jⱽ is indeed a category

    -- associativity of composition
    -- (surprisingly enough, the proof of "sym-assoc-Jⱽ" is exactly the same :
    -- Is there a problem in the definitions ?)
    assoc-Jⱽ : {A B C D : Codomain-Jⱽ-Elt}
               {ℒ : NaturalTransformation-Jⱽ A B}
               {ℳ : NaturalTransformation-Jⱽ B C}
               {𝒩 : NaturalTransformation-Jⱽ C D}
               → ((𝒩 ∘-Jⱽ ℳ) ∘-Jⱽ ℒ) ≃Jⱽ (𝒩 ∘-Jⱽ (ℳ ∘-Jⱽ ℒ))
    assoc-Jⱽ  {A} {B} {C} {D} {ℒ} {ℳ} {𝒩} {Θ} {Γ} ξ = Function.Equality.Π.cong (η 𝒩 Θ Γ)
                                                          (Function.Equality.Π.cong (η ℳ Θ Γ)
                                                            (Function.Equality.cong (η ℒ Θ Γ) ξ))

    -- identity is identity
    identityˡ-Jⱽ : {A B : Codomain-Jⱽ-Elt}
                  {𝒩 : NaturalTransformation-Jⱽ A B}
                  → (idN-Jⱽ ∘-Jⱽ 𝒩) ≃Jⱽ 𝒩
    identityˡ-Jⱽ  {𝒩 = 𝒩} {Θ = Θ} {Γ = Γ} ξ = Function.Equality.cong (η 𝒩 Θ Γ) ξ

    -- Codomain of Jⱽ (the category with Codomain-Jⱽ-Elt as objects and NaturalTransformation-Jⱽ as maps)
    Codomain-Jⱽ : Category (lsuc ℓ) (lsuc ℓ)  ℓ
    Codomain-Jⱽ = record
                    { Obj = Codomain-Jⱽ-Elt
                    ; _⇒_ = NaturalTransformation-Jⱽ
                    ; _≈_ = _≃Jⱽ_
                    ; id = idN-Jⱽ
                    ; _∘_ = _∘-Jⱽ_
                    ; assoc = λ {Fⱽ} {Gⱽ} {Hⱽ} {Kⱽ} {𝒩} {ℳ} {ℒ} → assoc-Jⱽ  {ℒ = 𝒩} {ℳ = ℳ} {𝒩 = ℒ}
                    ; sym-assoc = λ {Fⱽ} {Gⱽ} {Hⱽ} {Kⱽ} {𝒩} {ℳ} {ℒ} → assoc-Jⱽ  {ℒ = 𝒩} {ℳ = ℳ} {𝒩 = ℒ}
                    ; identityˡ = λ {Fⱽ} {Gⱽ} {𝒩} → identityˡ-Jⱽ {𝒩 = 𝒩}
                    ; identityʳ = λ {Fⱽ} {Gⱽ} {𝒩} → identityˡ-Jⱽ {𝒩 = 𝒩}
                    ; identity² = λ {Fⱽ} ξ → ξ
                    ; equiv = λ {Fⱽ} {Gⱽ}
                              → record
                                  { refl = λ {𝒩 = 𝒩} {Θ = Θ} {Γ = Γ} {x} {y} ξ
                                           → Function.Equality.cong (η 𝒩 Θ Γ) ξ
                                  ; sym = λ {𝒩} {ℳ} ξᴺ {Θ} {Γ} ξ
                                          → Category.Equiv.sym (Setoids ℓ ℓ)
                                          {_} {_} {η 𝒩 Θ Γ} {η ℳ Θ Γ} ξᴺ ξ
                                  ; trans =  λ {𝒩} {ℳ} {ℒ} ξᴺ₂ ξᴺ₁ {Θ} {Γ} ξ
                                             → Category.Equiv.trans (Setoids ℓ ℓ)
                                             {_} {_} {η 𝒩 Θ Γ} {η ℳ Θ Γ} {η ℒ Θ Γ} ξᴺ₂ ξᴺ₁ ξ}
                    ; ∘-resp-≈ = λ {Fⱽ} {Gⱽ} {Hⱽ} {𝒩} {ℳ} {ℒ} {𝒦} ξᴺ₁ ξᴺ₂ {Θ} {Γ} ξ
                                 → Category.∘-resp-≈ (Setoids ℓ ℓ)
                                   {_} {_}  {_}
                                   {η 𝒩 Θ Γ} {η ℳ Θ Γ} {η ℒ Θ Γ} {η 𝒦 Θ Γ}
                                   ξᴺ₁ ξᴺ₂ ξ
                    }

    -- The embedding of contexts into setoids indexed by sorts, metavariable telescope and variable telescope

    Jⱽ : Functor VContexts (IndexedCategory sort Codomain-Jⱽ)
    Jⱽ = record
              { F₀ = λ Γ A →
                       record
                         { F₀ = λ Δ Θ → setoid (A ∈ (Γ ,, Δ))
                         ; F₁ = λ ρ ι → record
                                            { _⟨$⟩_ = [ inlᵛ , inrᵛ ∘ᵛ ρ ]ᵛ
                                            ; cong = λ {x} {y} ξ →  ρ-resp-≡ {ρ = [ var-inl , var-inr ∘ᵛ ρ ]ᵛ} ξ}
                         ; identity = λ {Θ} {Δ} {x} ξ → trans (idᵛ+idᵛ x) ξ
                         ; homomorphism = λ {Θ} {ψ} {Ω} {Δ} {Ξ} {Λ} {ρ} {ι} {τ} {μ} {x} {y} ξ
                                          → trans
                                            (ʳ⇑ᵛ-resp-∘ᵛ x)
                                            (ρ-resp-≡ {ρ = [ var-inl , (λ x₁ → var-inr (τ x₁)) ]ᵛ}
                                              (ρ-resp-≡ {ρ = [ var-inl , (λ x₁ → var-inr (ρ x₁)) ]ᵛ} ξ))
                         ; F-resp-≈ = λ {Θ} {ψ} {Δ} {Ξ} {ρ} {τ} {ι} {μ} ξᵛ ξᵐ {x} {y} ξ
                                      → trans
                                        ([,]ᵛ-resp-≡ᵛ (λ x₁ → refl) (∘ᵛ-resp-≡ᵛ {τ₁ = λ x₁ → var-inr x₁} (λ x₁ → refl) λ x₁ → ξᵛ x₁) x)
                                        (ρ-resp-≡ {ρ = [ var-inl , (λ x₁ → var-inr (τ x₁)) ]ᵛ} ξ)
                         }

              ; F₁ = λ ρ A → record
                               { η = λ Θ Γ → record { _⟨$⟩_ = ⇑ᵛ ρ ; cong = cong (⇑ᵛ ρ) }
                               ; commute = λ τ ι {x} ξ
                                           → trans
                                             (uniqueᵛ²
                                               {τ = [ (λ x₁ → var-inl (ρ x₁)) , (λ x₁ → var-inr x₁) ]ᵛ ∘ᵛ [ var-inl , (λ x₁ → var-inr (τ x₁)) ]ᵛ}
                                               {σ = [ var-inl , (λ x₁ → var-inr (τ x₁)) ]ᵛ ∘ᵛ [ (λ x₁ → var-inl (ρ x₁)) , (λ x₁ → var-inr x₁) ]ᵛ} (λ x₁ → refl) (λ x₁ → refl) x)
                                               (ρ-resp-≡
                                                 {ρ = [ var-inl , (λ x₁ → var-inr (τ x₁)) ]ᵛ ∘ᵛ [ (λ x₁ → var-inl (ρ x₁)) , (λ x₁ → var-inr x₁) ]ᵛ} ξ)}

              ; identity =  λ A {Θ} {Γ} {x} ξ → trans (idᵛ+idᵛ x) ξ
              ; homomorphism = λ {Δ} {Ξ} {Λ} {ρ} {τ} A {_} {_} {x} ξ
                               → trans
                                 (uniqueᵛ²
                                   {τ = [ (λ x₁ → var-inl (τ (ρ x₁))) , (λ x₁ → var-inr x₁) ]ᵛ}
                                   {σ = [ (λ x₁ → var-inl (τ x₁)) , (λ x₁ → var-inr x₁) ]ᵛ ∘ᵛ [ (λ x₁ → var-inl (ρ x₁)) , (λ x₁ → var-inr x₁) ]ᵛ}
                                   (λ x₁ → refl) (λ x₁ → refl) x)
                                 (ρ-resp-≡
                                   {ρ = [ (λ x₁ → var-inl (τ x₁)) , (λ x₁ → var-inr x₁) ]ᵛ ∘ᵛ [ (λ x₁ → var-inl (ρ x₁)) , (λ x₁ → var-inr x₁) ]ᵛ } ξ)
              ; F-resp-≈ = λ {_} {_} {ρ} {τ} ξρ A {_} {_} {x} {y} ξ
                           → trans
                             (([,]ᵛ-resp-≡ᵛ {ρ₁ = λ x₁ → var-inl (ρ x₁)} {τ₁ = var-inr} (λ x₁ → ∘ᵛ-resp-≡ᵛ {τ₁ = var-inl} (λ x₃ → refl) ξρ x₁) (λ x₁ → refl) x))
                             (ρ-resp-≡ {ρ = ⇑ᵛ τ} ξ)
              }

  factor-empty-ctx : ∀ {Θ Ω Γ Δ A} (x : Setoid.Carrier ((Codomain-Jⱽ-Elt.F₀((Categories.Functor.Functor.F₀ Jⱽ) Γ A)) Δ Θ)) → x ≡ ( Function.Equality._⟨$⟩_ ((NaturalTransformation-Jⱽ.η ((Categories.Functor.Functor.F₁ Jⱽ) idᵛ A)) Ω Δ) x)
  factor-empty-ctx (var-inl x) = refl
  factor-empty-ctx (var-inr x) = refl

  -- The relative monad over Jⱽ

  module _ {Θ : MContext} where
    open Categories.Category
    open Categories.Functor using (Functor)
    open Categories.Category.Instance.Setoids
    open Categories.Category.Category (Setoids ℓ ℓ)
    open Categories.Monad.Relative
    open Function.Equality using () renaming (setoid to Π-setoid)
    open Categories.Category.Equivalence using (StrongEquivalence)
    open import SecondOrder.IndexedCategory
    open import SecondOrder.RelativeKleisli
    open NaturalTransformation-Jⱽ
    open Function.Equality using (_⟨$⟩_) renaming (cong to func-cong)
    open import Relation.Binary.Reasoning.MultiSetoid

    -- Setoids≈-⟨$⟩ : ∀ {From To} (f g : From Function.Equality.⟶ To) → (Category._≈_ (Setoids ℓ ℓ) f g) → (∀ (x : Setoid.Carrier From) → Setoid._≈_ To (f ⟨$⟩ x) (g ⟨$⟩ x))
    -- Setoids≈-⟨$⟩ = {!!}

    VMonad : Monad Jⱽ
    Codomain-Jⱽ-Elt.F₀ (Monad.F₀ VMonad Γ A) Δ ψ = Term-setoid Θ (Γ ,, Δ) A
    _⟨$⟩_      (Codomain-Jⱽ-Elt.F₁ (Monad.F₀ VMonad Γ A) ρ ι) = [ ʳ⇑ᵛ ρ ]ᵛ_
    func-cong (Codomain-Jⱽ-Elt.F₁ (Monad.F₀ VMonad Γ A) ρ ι) ξ = []ᵛ-resp-≈ ξ
    Codomain-Jⱽ-Elt.identity     (Monad.F₀ VMonad Γ A) ξ = ≈-trans ([]ᵛ-resp-≡ᵛ idᵛ+idᵛ) (≈-trans [idᵛ] ξ)
    Codomain-Jⱽ-Elt.homomorphism (Monad.F₀ VMonad Γ A) {ρ = ρ} {ι = ι} {τ = τ} {μ = μ} {x = x} {y = y} ξ
      = begin⟨ Term-setoid Θ _ _ ⟩
          [ ʳ⇑ᵛ (τ ∘ᵛ ρ) ]ᵛ x ≈⟨ []ᵛ-resp-≈ ξ ⟩
          [ ʳ⇑ᵛ (τ ∘ᵛ ρ) ]ᵛ y ≈⟨ []ᵛ-resp-≡ᵛ (λ x₁ →
              uniqueᵛ² {τ = [ (λ x₂ → var-inl x₂) , (λ x₂ → var-inr (τ (ρ x₂))) ]ᵛ}
                       {σ = σ' }
                       (λ x₂ → refl) (λ x₂ → refl) x₁) ⟩
          [ σ' ]ᵛ y ≈⟨ [∘ᵛ] ⟩
         ((Codomain-Jⱽ-Elt.F₁ (Monad.F₀ VMonad Γ A) τ μ ∘
           Codomain-Jⱽ-Elt.F₁ (Monad.F₀ VMonad Γ A) ρ ι) ⟨$⟩ y)
         ∎
         where
           σ' : (Γ ,, _) ⇒ᵛ Γ ,, _
           σ' = [ var-inl
                , (λ x₁ → var-inr (τ x₁))
                ]ᵛ ∘ᵛ [ var-inl
                      , (λ x₁ → var-inr (ρ x₁))
                      ]ᵛ
    Codomain-Jⱽ-Elt.F-resp-≈  (Monad.F₀ VMonad Γ A) {ψ} {Ω} {Δ} {Ξ} {ρ} {τ} {ι} {μ} ξᵛ ξᵐ {t} {u} ξ  =
                                                          begin⟨ Term-setoid Θ _ _ ⟩
                                                          ([ [ (λ x₁ → var-inl x₁) , (λ x₁ → var-inr (ρ x₁)) ]ᵛ ]ᵛ t) ≈⟨ []ᵛ-resp-≈ ξ ⟩
                                                          ([ [ (λ x₁ → var-inl x₁) , (λ x₁ → var-inr (ρ x₁)) ]ᵛ ]ᵛ u)
                                                                                ≈⟨ []ᵛ-resp-≡ᵛ ([,]ᵛ-resp-≡ᵛ (λ x → refl) λ x → ρ-resp-≡ {ρ = var-inr} (ξᵛ x)) ⟩
                                                          ([ [ (λ x₁ → var-inl x₁) , (λ x₁ → var-inr (τ x₁)) ]ᵛ ]ᵛ u) ∎

    _⟨$⟩_ (η (Monad.unit VMonad A) ψ Γ) = tm-var
    func-cong (η (Monad.unit VMonad A) ψ Γ) ξ = congˢ-var {σ = tm-var} ξ
    commute (Monad.unit VMonad A) ρ ι ξ =  congˢ-var {σ = tm-var} (ρ-resp-≡ {ρ = [ var-inl , (λ x₁ → var-inr (ρ x₁)) ]ᵛ} ξ)

    _⟨$⟩_ (η (Monad.extend VMonad {Δ} {Ξ} σ A) ψ Γ) t =  [ (λ {B} x →  η (σ B) ψ  Γ  ⟨$⟩ x) ]ˢ t
    func-cong (η (Monad.extend VMonad σ A) ψ Γ) = []ˢ-resp-≈ ((λ {B} x → η (σ B) ψ Γ ⟨$⟩ x) )
    commute (Monad.extend VMonad {Υ} {Ω} σ A) {Ξ} {Ψ} {Γ} {Δ} ρ ι {x} {y} x≈y
      = begin⟨ Term-setoid Θ _ _ ⟩
               ([ (λ {B} → _⟨$⟩_ (η (σ B) Ψ Δ)) ]ˢ ([ [ (λ x₁ → var-inl x₁) , (λ x₁ → var-inr (ρ x₁)) ]ᵛ ]ᵛ x)) ≈⟨  ≈-sym ([ˢ∘ᵛ] x) ⟩
               ([(λ {B} → _⟨$⟩_ (η (σ B) Ψ Δ)) ˢ∘ᵛ [ (λ x₁ → var-inl x₁) , (λ x₁ → var-inr (ρ x₁)) ]ᵛ ]ˢ x) ≈⟨ {!!} ⟩
               {!!} ≈⟨ {!!} ⟩
               ([ [ (λ x₁ → var-inl x₁) , (λ x₁ → var-inr (ρ x₁)) ]ᵛ ]ᵛ ([ (λ {B} → _⟨$⟩_ (η (σ B) Ξ Γ)) ]ˢ y)) ∎

      --   where
      --     is-subst : ∀ (𝒩 : NaturalTransformation-Jⱽ (Jⱽ Γ A) (Monad.F₀ VMonad Ω i)) → Σ
      -- begin⟨ Term-setoid Θ _ _ ⟩
      --   (η (Monad.extend VMonad σ A) Ψ Δ ∘
      --     Codomain-Jⱽ-Elt.F₁ (Monad.F₀ VMonad Υ A) ρ ι
      --     ⟨$⟩ x)
      --     ≈⟨ ≈-sym ([ˢ∘ᵛ] x) ⟩
      --   ([ (λ {B} x₁ → η (σ B) Θ Δ ⟨$⟩ x₁) ˢ∘ᵛ (ʳ⇑ᵛ ρ) ]ˢ x) ≈⟨ []ˢ-resp-≈ ((λ {B} → _⟨$⟩_ (η (σ B) Θ Δ)) ˢ∘ᵛ(ʳ⇑ᵛ ρ)) x≈y ⟩
      --   ([ (λ {B} → _⟨$⟩_ (η (σ B) Θ Δ)) ˢ∘ᵛ (ʳ⇑ᵛ ρ) ]ˢ y) ≈⟨ []ˢ-resp-≈ˢ y (η-ˢ∘ᵛ ρ ι) ⟩
      --   ([ ʳ⇑ᵛ ρ ᵛ∘ˢ (λ {B} x₁ → η (σ B) Θ Γ ⟨$⟩ x₁) ]ˢ y) ≈⟨ [ᵛ∘ˢ] y ⟩
      --   (Codomain-Jⱽ-Elt.F₁ (Monad.F₀ VMonad Ω A) ρ ι ∘
      --     η (Monad.extend VMonad σ A) Ξ Γ
      --     ⟨$⟩ y)
      --     ∎
      where
        𝒩-to-subst : ∀  {Γ Δ Ξ} (𝒩 : ∀ A → NaturalTransformation-Jⱽ (Categories.Functor.Functor.F₀ Jⱽ Γ A) (Monad.F₀ VMonad Ξ A)) → (Θ ⊕ (Γ ,, Δ) ⇒ˢ (Ξ ,, Δ))
        𝒩-to-subst 𝒩 {A} (var-inl z) = η (𝒩 A) _ _ ⟨$⟩ (var-inl z)
        𝒩-to-subst 𝒩 {A} (var-inr z) = tm-var (var-inr z)

        𝒩-is-subst : ∀ {Ω Γ Ξ} (𝒩 : ∀ A → NaturalTransformation-Jⱽ (Categories.Functor.Functor.F₀ Jⱽ Γ A) (Monad.F₀ VMonad Ξ A)) x → SecondOrder.Term._≈_ Σ ((NaturalTransformation-Jⱽ.η (𝒩 A) Ω Γ) ⟨$⟩ x) (𝒩-to-subst 𝒩 x)
        𝒩-is-subst 𝒩 (var-inl z) = {!!}
        𝒩-is-subst 𝒩 (var-inr z) = {!!}

        η-ˢ∘ᵛ : ∀ {Ξ} {ψ} {Γ} {Δ} (ρ : Γ ⇒ᵛ Δ) (ι : Ξ ⇒ᵐ ψ)
               → (λ {B} → _⟨$⟩_ (η (σ B) ψ Δ)) ˢ∘ᵛ (ʳ⇑ᵛ ρ)
                 ≈ˢ ʳ⇑ᵛ ρ ᵛ∘ˢ (λ {B} x₁ → η (σ B) Ψ Γ ⟨$⟩ x₁)
        η-ˢ∘ᵛ {Ξ = Ξ′} {ψ = ψ} {Γ = Γ′} {Δ′} ρ ι (var-inl x) =
                   begin⟨ Term-setoid Θ _ _ ⟩
                     ((λ {B} → _⟨$⟩_ (η (σ B) ψ Δ′)) ˢ∘ᵛ (ʳ⇑ᵛ ρ)) (var-inl x) ≈⟨ {!!} ⟩
                     {![]!} ≈⟨ {!!} ⟩
                     {!!} ≈⟨ {! ˢ∘ᵛ-η (σ A₁) Θ Γ₁η (σ A₁) Θ Γ₁ᵛ∘ˢ-disjoint ˢ∘ᵛ-ᵛ∘uˢ-disjoint!} ⟩
                     (ʳ⇑ᵛ ρ ᵛ∘ˢ (λ {B} → _⟨$⟩_ (η (σ B) Ψ _))) (var-inl x) ∎
               where
                 ˢ∘ᵛ-ᵛ∘ˢ-disjoint : ∀ {ψ} {Γ Ξ Δ Λ} (σ : ψ ⊕ Ξ ⇒ˢ Λ) (ρ : Γ ⇒ᵛ Δ)
                                      →  ⇑ˢ σ ˢ∘ᵛ ʳ⇑ᵛ ρ  ≈ˢ ʳ⇑ᵛ ρ ᵛ∘ˢ ⇑ˢ σ
                 ˢ∘ᵛ-ᵛ∘ˢ-disjoint σ τ (var-inl x) =
                                        begin⟨ Term-setoid _ _ _ ⟩
                                          ([ var-inl ]ᵛ σ x) ≈⟨ []ᵛ-resp-≡ᵛ (λ x₃ → refl) ⟩
                                          ([ [ (λ x₃ → var-inl x₃) , (λ x₃ → var-inr (τ x₃)) ]ᵛ ∘ᵛ var-inl ]ᵛ σ x) ≈⟨ [∘ᵛ] ⟩
                                          ([ [ (λ x₃ → var-inl x₃) , (λ x₃ → var-inr (τ x₃)) ]ᵛ ]ᵛ ([ var-inl ]ᵛ σ x)) ∎
                 ˢ∘ᵛ-ᵛ∘ˢ-disjoint σ τ (var-inr x) = ≈-refl
        η-ˢ∘ᵛ ρ ι (var-inr x) = begin⟨ Term-setoid Θ _ _ ⟩ {!!}
    Monad.identityʳ VMonad {_} {_} {𝒩s} =
                           λ i {k = Ω} {Γ = Γ} {x = x} {y = y} x≈y → (func-cong (η (𝒩s i) Ω Γ) (x≈y))
    Monad.identityˡ VMonad = λ i x≈y →  ≈-trans [idˢ] x≈y
    Monad.assoc VMonad  {Γ} {Δ} {Ξ} {k} {l} = λ A {ψ} {Λ} {x} {y} ξ
                         → begin⟨ Term-setoid Θ _ _ ⟩
                             ([ (λ {B} x₁ → [ (λ {B = B₁} → _⟨$⟩_ (η (l B₁) ψ Λ)) ]ˢ (η (k B) ψ Λ ⟨$⟩ x₁)) ]ˢ x)
                                ≈⟨ []ˢ-resp-≈ (λ {B} x₁ → [ (λ {B = B₁} → _⟨$⟩_ (η (l B₁) ψ Λ)) ]ˢ (η (k B) ψ Λ ⟨$⟩ x₁)) ξ ⟩
                             ([ (λ {B} x₁ → [ (λ {B = B₁} → _⟨$⟩_ (η (l B₁) ψ Λ)) ]ˢ (η (k B) ψ Λ ⟨$⟩ x₁)) ]ˢ y) ≈⟨ [∘ˢ] y ⟩
                             ([ (λ {B} → _⟨$⟩_ (η (l B) ψ Λ)) ]ˢ ([ (λ {B} → _⟨$⟩_ (η (k B) ψ Λ)) ]ˢ y)) ∎
    Monad.extend-≈ VMonad {Γ} {Δ} {k} {h} = λ ξ A {ψ} {Λ} {t} {u} ξᵗ
                                            → begin⟨ Term-setoid Θ _ _ ⟩
                                              ([ (λ {B} → _⟨$⟩_ (η (k B) ψ Λ)) ]ˢ t) ≈⟨ []ˢ-resp-≈ (λ {B} → _⟨$⟩_ (η (k B) ψ Λ)) ξᵗ ⟩
                                              ([ (λ {B} → _⟨$⟩_ (η (k B) ψ Λ)) ]ˢ u) ≈⟨ []ˢ-resp-≈ˢ u (λ {A = C} x → ξ C refl) ⟩
                                              ([ (λ {B} → _⟨$⟩_ (η (h B) ψ Λ)) ]ˢ u) ∎

-- *************************************************************************************

-- open import Agda.Primitive using (lzero; lsuc; _⊔_ ;Level)
-- open import Relation.Binary.PropositionalEquality using (_≡_; refl; sym; setoid; cong; trans)
-- import Function.Equality
-- open import Relation.Binary using (Setoid)

-- import Categories.Category
-- import Categories.Functor
-- import Categories.Category.Instance.Setoids
-- import Categories.Monad.Relative
-- import Categories.Category.Equivalence
-- import Categories.Category.Cocartesian
-- import Categories.Category.Construction.Functors
-- import Categories.NaturalTransformation.Equivalence
-- import Relation.Binary.Core

-- import SecondOrder.Arity
-- import SecondOrder.Signature
-- import SecondOrder.Metavariable
-- import SecondOrder.VRenaming
-- import SecondOrder.MRenaming
-- import SecondOrder.Term
-- import SecondOrder.IndexedCategory
-- import SecondOrder.RelativeKleisli
-- import SecondOrder.Substitution

-- module SecondOrder.VRelMon
--   {ℓ}
--   {𝔸 : SecondOrder.Arity.Arity}
--   (Σ : SecondOrder.Signature.Signature ℓ 𝔸)
--   where

--   open SecondOrder.Signature.Signature Σ
--   open SecondOrder.Metavariable Σ
--   open SecondOrder.Term Σ
--   open SecondOrder.VRenaming Σ
--   open SecondOrder.MRenaming Σ
--   open SecondOrder.Substitution Σ

--   -- TERMS FORM A RELATIVE MONAD
--   -- (FOR A FUNCTOR WHOSE DOMAIN IS THE
--   -- CATEGORY OF VARIABLE CONTEXTS AND RENAMINGS)

--   module _ where
--     open Categories.Category
--     open Categories.Functor using (Functor)
--     open Categories.Category.Instance.Setoids
--     open Categories.Monad.Relative
--     open Function.Equality using () renaming (setoid to Π-setoid)
--     open Categories.Category.Equivalence using (StrongEquivalence)
--     open import SecondOrder.IndexedCategory
--     open import SecondOrder.RelativeKleisli
--     open Categories.Category.Construction.Functors
--     open Categories.NaturalTransformation.Equivalence
--     open Relation.Binary.Core hiding (_⇒_)

--     -- The carrier of the codomain of Jⱽ (morally ∀ Γ → A ∈ Δ ,, Γ)
--     record Codomain-Jⱽ-Elt : Set ((lsuc ℓ)) where
--       open Category (Setoids ℓ ℓ)
--       open Setoid
--       field
--         F₀ :  VContext → MContext → Obj
--         F₁ : ∀ {Θ ψ Δ Ξ} (ρ : Δ ⇒ᵛ Ξ) (ι : Θ ⇒ᵐ ψ)
--              → (F₀ Δ Θ) ⇒ (F₀ Ξ ψ)
--         identity : ∀ {Θ Δ}
--                    → Category._≈_ (Setoids ℓ ℓ) (F₁ (idᵛ {Δ}) (idᵐ {Θ})) (id {F₀ Δ Θ})
--         homomorphism : ∀ {Θ ψ Ω Γ Δ Ξ} {ρ : Γ ⇒ᵛ Δ} {ι : Θ ⇒ᵐ ψ} {τ : Δ ⇒ᵛ Ξ} {μ : ψ ⇒ᵐ Ω}
--                        → Category._≈_ (Setoids ℓ ℓ) (F₁ (τ ∘ᵛ ρ) (μ ∘ᵐ ι)) ((F₁ τ μ) ∘ (F₁ ρ ι))
--         F-resp-≈ : ∀ {Θ ψ Γ Δ} {ρ τ : Γ ⇒ᵛ Δ} {ι μ : Θ ⇒ᵐ ψ}
--                    → (ρ ≡ᵛ τ) → (ι ≡ᵐ μ) → (Category._≈_ (Setoids ℓ ℓ) (F₁ ρ ι) (F₁ τ μ))

--     -- Transformation for Codomain-Jⱽ (analogue to natural transformations)

--     record NaturalTransformation-Jⱽ (Fⱽ Gⱽ : Codomain-Jⱽ-Elt) : Set (lsuc ℓ)
--       where
--         private
--           module Fⱽ = Codomain-Jⱽ-Elt Fⱽ
--           module Gⱽ = Codomain-Jⱽ-Elt Gⱽ
--         open Fⱽ using (F₀; F₁)
--         open Category (Setoids ℓ ℓ)
--         field
--           η : ∀ Θ Γ → (F₀ Γ Θ) ⇒ (Gⱽ.F₀ Γ Θ)
--           commute : ∀ {Θ ψ Γ Δ} (ρ : Γ ⇒ᵛ Δ) (ι : Θ ⇒ᵐ ψ)
--                     → Category._≈_ (Setoids ℓ ℓ) ((η ψ Δ) ∘ (F₁ ρ ι)) ((Gⱽ.F₁ ρ ι) ∘ (η Θ Γ))

--     open NaturalTransformation-Jⱽ

--     -- Equivalence of NaturalTransformation-Jⱽ (analogue to the one
--     -- of the natural transformations)

--     infix 4 _≃Jⱽ_

--     _≃Jⱽ_ : ∀ {Fⱽ Gⱽ : Codomain-Jⱽ-Elt} → Rel (NaturalTransformation-Jⱽ Fⱽ Gⱽ) ℓ
--     𝒩 ≃Jⱽ ℳ  = ∀ {Θ Γ} → Category._≈_ (Setoids ℓ ℓ)
--                             (η 𝒩 Θ Γ)
--                             (η ℳ Θ Γ)

--     -- Identity transformation analogue to the one
--     -- of the natural transformations, for NaturalTransformation-Jⱽ

--     idN-Jⱽ : ∀ {Fⱽ : Codomain-Jⱽ-Elt} → NaturalTransformation-Jⱽ Fⱽ Fⱽ
--     idN-Jⱽ {Fⱽ} =
--            record
--              { η = λ Θ Γ →
--                record
--                  { _⟨$⟩_ = λ x → x
--                  ; cong = λ x → x }
--              ; commute = λ {Θ} {ψ} {Γ} {Δ} ρ ι ξ
--                          → Codomain-Jⱽ-Elt.F-resp-≈  Fⱽ {Θ} {ψ} {Γ} {Δ} {ρ} {ρ} {ι} {ι}
--                                                 (λ x₁ → refl) (λ M → refl) ξ }

--     -- Composition of NaturalTransformation-Jⱽ (analogue to the one
--     -- of the natural transformations)

--     _∘-Jⱽ_ : ∀ {Fⱽ Gⱽ Hⱽ : Codomain-Jⱽ-Elt} (𝒩 : NaturalTransformation-Jⱽ Gⱽ Hⱽ) (ℳ : NaturalTransformation-Jⱽ Fⱽ Gⱽ) → NaturalTransformation-Jⱽ Fⱽ Hⱽ
--     _∘-Jⱽ_ {Fⱽ} {Gⱽ} {Hⱽ} 𝒩 ℳ =
--              let open Category (Setoids ℓ ℓ) in
--              let open NaturalTransformation-Jⱽ in
--              let open Codomain-Jⱽ-Elt in
--              record
--                  { η = λ Θ Γ → η 𝒩 Θ Γ ∘ η ℳ Θ Γ
--                  ; commute = λ {Θ} {ψ} {Γ} {Δ} ρ ι →
--                              let open HomReasoning {F₀ Fⱽ Γ Θ} {F₀ Hⱽ Δ ψ} in
--                              begin
--                              (Category._∘_ (Setoids ℓ ℓ) (η {Gⱽ} {Hⱽ} 𝒩 ψ Δ) ((η {Fⱽ} {Gⱽ} ℳ ψ Δ) ∘ (F₁ Fⱽ ρ ι))) ≈⟨ assoc {f = F₁ Fⱽ ρ ι} {g = η ℳ ψ Δ} {h = η 𝒩 ψ Δ} ⟩
--                              (η 𝒩 ψ Δ ∘ (η ℳ ψ Δ) ∘ (F₁ Fⱽ ρ ι)) ≈⟨ refl⟩∘⟨_
--                                                                       {f = η 𝒩 ψ Δ} {g = (η ℳ ψ Δ) ∘ (F₁ Fⱽ ρ ι)}
--                                                                       {i = (F₁ Gⱽ ρ ι) ∘ (η ℳ Θ Γ)}
--                                                                       (commute ℳ ρ ι) ⟩
--                              (η 𝒩 ψ Δ ∘ ((F₁ Gⱽ ρ ι) ∘ (η ℳ Θ Γ))) ≈⟨ sym-assoc {f = η ℳ Θ Γ} {g = F₁ Gⱽ ρ ι} {h = η 𝒩 ψ Δ}⟩
--                              ((η 𝒩 ψ Δ) ∘ (F₁ Gⱽ ρ ι)) ∘ (η ℳ Θ Γ) ≈⟨ _⟩∘⟨refl
--                                                                       {f = (η 𝒩 ψ Δ) ∘ (F₁ Gⱽ ρ ι)} {h = (F₁ Hⱽ ρ ι) ∘ (η 𝒩 Θ Γ)}
--                                                                       {g = η ℳ Θ Γ}
--                                                                       (commute 𝒩 ρ ι) ⟩
--                              (((F₁ Hⱽ ρ ι) ∘ (η 𝒩 Θ Γ)) ∘ (η ℳ Θ Γ)) ≈⟨ assoc {f = η ℳ Θ Γ} {g = η 𝒩 Θ Γ} {h = F₁ Hⱽ ρ ι} ⟩
--                              (((F₁ Hⱽ ρ ι) ∘ (η 𝒩 Θ Γ)) ∘ (η ℳ Θ Γ)) ∎}

--     -- Proof that the category of Codomain-Jⱽ and NaturalTransformation-Jⱽ is indeed a category

--     -- associativity of composition
--     -- (surprisingly enough, the proof of "sym-assoc-Jⱽ" is exactly the same :
--     -- Is there a problem in the definitions ?)
--     assoc-Jⱽ : {A B C D : Codomain-Jⱽ-Elt}
--                {ℒ : NaturalTransformation-Jⱽ A B}
--                {ℳ : NaturalTransformation-Jⱽ B C}
--                {𝒩 : NaturalTransformation-Jⱽ C D}
--                → ((𝒩 ∘-Jⱽ ℳ) ∘-Jⱽ ℒ) ≃Jⱽ (𝒩 ∘-Jⱽ (ℳ ∘-Jⱽ ℒ))
--     assoc-Jⱽ  {A} {B} {C} {D} {ℒ} {ℳ} {𝒩} {Θ} {Γ} ξ = Function.Equality.Π.cong (η 𝒩 Θ Γ)
--                                                           (Function.Equality.Π.cong (η ℳ Θ Γ)
--                                                             (Function.Equality.cong (η ℒ Θ Γ) ξ))

--     -- identity is identity
--     identityˡ-Jⱽ : {A B : Codomain-Jⱽ-Elt}
--                   {𝒩 : NaturalTransformation-Jⱽ A B}
--                   → (idN-Jⱽ ∘-Jⱽ 𝒩) ≃Jⱽ 𝒩
--     identityˡ-Jⱽ  {𝒩 = 𝒩} {Θ = Θ} {Γ = Γ} ξ = Function.Equality.cong (η 𝒩 Θ Γ) ξ

--     -- Codomain of Jⱽ (the category with Codomain-Jⱽ-Elt as objects and NaturalTransformation-Jⱽ as maps)
--     Codomain-Jⱽ : Category (lsuc ℓ) (lsuc ℓ)  ℓ
--     Codomain-Jⱽ = record
--                     { Obj = Codomain-Jⱽ-Elt
--                     ; _⇒_ = NaturalTransformation-Jⱽ
--                     ; _≈_ = _≃Jⱽ_
--                     ; id = idN-Jⱽ
--                     ; _∘_ = _∘-Jⱽ_
--                     ; assoc = λ {Fⱽ} {Gⱽ} {Hⱽ} {Kⱽ} {𝒩} {ℳ} {ℒ} → assoc-Jⱽ  {ℒ = 𝒩} {ℳ = ℳ} {𝒩 = ℒ}
--                     ; sym-assoc = λ {Fⱽ} {Gⱽ} {Hⱽ} {Kⱽ} {𝒩} {ℳ} {ℒ} → assoc-Jⱽ  {ℒ = 𝒩} {ℳ = ℳ} {𝒩 = ℒ}
--                     ; identityˡ = λ {Fⱽ} {Gⱽ} {𝒩} → identityˡ-Jⱽ {𝒩 = 𝒩}
--                     ; identityʳ = λ {Fⱽ} {Gⱽ} {𝒩} → identityˡ-Jⱽ {𝒩 = 𝒩}
--                     ; identity² = λ {Fⱽ} ξ → ξ
--                     ; equiv = λ {Fⱽ} {Gⱽ}
--                               → record
--                                   { refl = λ {𝒩 = 𝒩} {Θ = Θ} {Γ = Γ} {x} {y} ξ
--                                            → Function.Equality.cong (η 𝒩 Θ Γ) ξ
--                                   ; sym = λ {𝒩} {ℳ} ξᴺ {Θ} {Γ} ξ
--                                           → Category.Equiv.sym (Setoids ℓ ℓ)
--                                           {_} {_} {η 𝒩 Θ Γ} {η ℳ Θ Γ} ξᴺ ξ
--                                   ; trans =  λ {𝒩} {ℳ} {ℒ} ξᴺ₂ ξᴺ₁ {Θ} {Γ} ξ
--                                              → Category.Equiv.trans (Setoids ℓ ℓ)
--                                              {_} {_} {η 𝒩 Θ Γ} {η ℳ Θ Γ} {η ℒ Θ Γ} ξᴺ₂ ξᴺ₁ ξ}
--                     ; ∘-resp-≈ = λ {Fⱽ} {Gⱽ} {Hⱽ} {𝒩} {ℳ} {ℒ} {𝒦} ξᴺ₁ ξᴺ₂ {Θ} {Γ} ξ
--                                  → Category.∘-resp-≈ (Setoids ℓ ℓ)
--                                    {_} {_}  {_}
--                                    {η 𝒩 Θ Γ} {η ℳ Θ Γ} {η ℒ Θ Γ} {η 𝒦 Θ Γ}
--                                    ξᴺ₁ ξᴺ₂ ξ
--                     }

--     -- The embedding of contexts into setoids indexed by sorts, metavariable telescope and variable telescope

--     Jⱽ : Functor VContexts (IndexedCategory sort Codomain-Jⱽ)
--     Jⱽ = record
--               { F₀ = λ Γ A →
--                        record
--                          { F₀ = λ Δ Θ → setoid (A ∈ (Γ ,, Δ))
--                          ; F₁ = λ ρ ι → record
--                                             { _⟨$⟩_ = [ inlᵛ , inrᵛ ∘ᵛ ρ ]ᵛ
--                                             ; cong = λ {x} {y} ξ →  ρ-resp-≡ {ρ = [ var-inl , var-inr ∘ᵛ ρ ]ᵛ} ξ}
--                          ; identity = λ {Θ} {Δ} {x} ξ → trans (idᵛ+idᵛ x) ξ
--                          ; homomorphism = λ {Θ} {ψ} {Ω} {Δ} {Ξ} {Λ} {ρ} {ι} {τ} {μ} {x} {y} ξ
--                                           → trans
--                                             (ʳ⇑ᵛ-resp-∘ᵛ x)
--                                             (ρ-resp-≡ {ρ = [ var-inl , (λ x₁ → var-inr (τ x₁)) ]ᵛ}
--                                               (ρ-resp-≡ {ρ = [ var-inl , (λ x₁ → var-inr (ρ x₁)) ]ᵛ} ξ))
--                          ; F-resp-≈ = λ {Θ} {ψ} {Δ} {Ξ} {ρ} {τ} {ι} {μ} ξᵛ ξᵐ {x} {y} ξ
--                                       → trans
--                                         ([,]ᵛ-resp-≡ᵛ (λ x₁ → refl) (∘ᵛ-resp-≡ᵛ {τ₁ = λ x₁ → var-inr x₁} (λ x₁ → refl) λ x₁ → ξᵛ x₁) x)
--                                         (ρ-resp-≡ {ρ = [ var-inl , (λ x₁ → var-inr (τ x₁)) ]ᵛ} ξ)
--                          }

--               ; F₁ = λ ρ A → record
--                                { η = λ Θ Γ → record { _⟨$⟩_ = ⇑ᵛ ρ ; cong = cong (⇑ᵛ ρ) }
--                                ; commute = λ τ ι {x} ξ
--                                            → trans
--                                              (uniqueᵛ²
--                                                {τ = [ (λ x₁ → var-inl (ρ x₁)) , (λ x₁ → var-inr x₁) ]ᵛ ∘ᵛ [ var-inl , (λ x₁ → var-inr (τ x₁)) ]ᵛ}
--                                                {σ = [ var-inl , (λ x₁ → var-inr (τ x₁)) ]ᵛ ∘ᵛ [ (λ x₁ → var-inl (ρ x₁)) , (λ x₁ → var-inr x₁) ]ᵛ} (λ x₁ → refl) (λ x₁ → refl) x)
--                                                (ρ-resp-≡
--                                                  {ρ = [ var-inl , (λ x₁ → var-inr (τ x₁)) ]ᵛ ∘ᵛ [ (λ x₁ → var-inl (ρ x₁)) , (λ x₁ → var-inr x₁) ]ᵛ} ξ)}

--               ; identity =  λ A {Θ} {Γ} {x} ξ → trans (idᵛ+idᵛ x) ξ
--               ; homomorphism = λ {Δ} {Ξ} {Λ} {ρ} {τ} A {_} {_} {x} ξ
--                                → trans
--                                  (uniqueᵛ²
--                                    {τ = [ (λ x₁ → var-inl (τ (ρ x₁))) , (λ x₁ → var-inr x₁) ]ᵛ}
--                                    {σ = [ (λ x₁ → var-inl (τ x₁)) , (λ x₁ → var-inr x₁) ]ᵛ ∘ᵛ [ (λ x₁ → var-inl (ρ x₁)) , (λ x₁ → var-inr x₁) ]ᵛ}
--                                    (λ x₁ → refl) (λ x₁ → refl) x)
--                                  (ρ-resp-≡
--                                    {ρ = [ (λ x₁ → var-inl (τ x₁)) , (λ x₁ → var-inr x₁) ]ᵛ ∘ᵛ [ (λ x₁ → var-inl (ρ x₁)) , (λ x₁ → var-inr x₁) ]ᵛ } ξ)
--               ; F-resp-≈ = λ {_} {_} {ρ} {τ} ξρ A {_} {_} {x} {y} ξ
--                            → trans
--                              (([,]ᵛ-resp-≡ᵛ {ρ₁ = λ x₁ → var-inl (ρ x₁)} {τ₁ = var-inr} (λ x₁ → ∘ᵛ-resp-≡ᵛ {τ₁ = var-inl} (λ x₃ → refl) ξρ x₁) (λ x₁ → refl) x))
--                              (ρ-resp-≡ {ρ = ⇑ᵛ τ} ξ)
--               }

--   -- The relative monad over Jⱽ

--   module _ {Θ : MContext} where
--     open Categories.Category
--     open Categories.Functor using (Functor)
--     open Categories.Category.Instance.Setoids
--     open Categories.Monad.Relative
--     open Function.Equality using () renaming (setoid to Π-setoid)
--     open Categories.Category.Equivalence using (StrongEquivalence)
--     open import SecondOrder.IndexedCategory
--     open import SecondOrder.RelativeKleisli
--     open NaturalTransformation-Jⱽ

--     VMonad : Monad Jⱽ
--     VMonad =
--       let open Function.Equality using (_⟨$⟩_) renaming (cong to func-cong) in
--       record
--         { F₀ = λ Γ A → record
--                          { F₀ = λ Δ ψ → Term-setoid Θ (Γ ,, Δ) A
--                          ; F₁ = λ ρ ι → record { _⟨$⟩_ = [_]ᵛ_ (ʳ⇑ᵛ ρ) ; cong = λ ξ → []ᵛ-resp-≈ ξ }
--                          ; identity = λ ξ → ≈-trans ([]ᵛ-resp-≡ᵛ idᵛ+idᵛ) (≈-trans [idᵛ] ξ)
--                          ; homomorphism = λ {_} {_} {_} {_} {_} {_} {ρ} {_} {τ} ξ
--                                           → ≈-trans
--                                           ([]ᵛ-resp-≈ ξ)
--                                           (≈-trans
--                                             ([]ᵛ-resp-≡ᵛ λ x₁
--                                               → uniqueᵛ²
--                                                 {τ = [ (λ x₂ → var-inl x₂) , (λ x₂ → var-inr (τ (ρ x₂))) ]ᵛ}
--                                                 {σ = [ (λ x₁ → var-inl x₁) , (λ x₁ → var-inr (τ x₁)) ]ᵛ  ∘ᵛ [ (λ x₁ → var-inl x₁) , (λ x₁ → var-inr (ρ x₁)) ]ᵛ }
--                                                 (λ x₂ → refl) (λ x₂ → refl) x₁)
--                                             [∘ᵛ])

--                          ; F-resp-≈ = λ ξᵛ ξᵐ ξ → ≈-trans ([]ᵛ-resp-≈ ξ) ([]ᵛ-resp-≡ᵛ λ x → [,]ᵛ-resp-≡ᵛ (λ x₁ → refl) (λ x₁ → ρ-resp-≡ {ρ = var-inr} (ξᵛ x₁)) x )
--                          }
--         ; unit = λ A
--                    → record
--                      { η = λ ψ Γ
--                        → record
--                          { _⟨$⟩_ = λ x → tm-var x
--                          ; cong = λ ξ → congˢ-var {σ = tm-var} ξ }
--                        ; commute = λ ρ ι ξ → congˢ-var {σ = tm-var} (ρ-resp-≡ {ρ = [ var-inl , (λ x₁ → var-inr (ρ x₁)) ]ᵛ} ξ) }
--         ; extend = {!!}
--         ; identityʳ = λ A ξ → {!!}
--         ; identityˡ = {!!}
--         ; assoc = {!!}
--         ; extend-≈ = {!!}
--         }

--     -- Other possibility, if the above doesn't work :

--     -- Jⱽ′ : Functor VContexts (Functors MContexts (Functors VContexts (IndexedCategory sort (Setoids ℓ ℓ))))
--     -- Jⱽ′ = record
--     --           { F₀ = {!!} -- λ Γ A → setoid (A ∈ Γ)
--     --           ; F₁ = {!!} -- λ ρ A → record { _⟨$⟩_ = ρ ; cong = cong ρ }
--     --           ; identity = {!!} -- λ A ξ → ξ
--     --           ; homomorphism = {!!} -- λ {_} {_} {_} {ρ} {σ} A {_} {_} ξ → cong σ (cong ρ ξ)
--     --           ; F-resp-≈ = {!!} -- λ ξ A ζ → trans (ξ _) (cong _ ζ)
--     --           }


open import Agda.Builtin.Nat

data V : (n : Nat) → Set where
  cons : (n : Nat) → V (suc n)
       -- ^ this n is forced

    -- v and this n is marked shape irrelevant
g : ..(n : Nat) → V n → Nat
g _ (cons n) = n
--             ^ so we can't return n here, since we're really
--               returning the shape irrelevant one.


module negation where

open import level
open import empty

----------------------------------------------------------------------
-- syntax
----------------------------------------------------------------------

infix 7 ¬

----------------------------------------------------------------------
-- defined types
----------------------------------------------------------------------

¬ : ∀{ℓ}(x : Set ℓ) → Set ℓ
¬ {ℓ} x = x → (⊥ {ℓ})


module NF.Product where

open import NF
open import Data.Product
open import Relation.Binary.PropositionalEquality

instance
  nf, : {A : Set}{B : A -> Set}{a : A}{b : B a}{{nfa : NF a}}{{nfb : NF b}} -> NF {Σ A B} (a , b)
  Sing.unpack (NF.!! (nf, {B = B} {a = a} {b = b} {{nfa}})) = nf a , subst B (sym nf≡) (nf b)
  Sing.eq (NF.!! (nf, {{nfa}} {{nfb}})) rewrite nf≡ {{nfa}} | nf≡ {{nfb}} = refl

  {-# INLINE nf, #-}


-- Andreas, 2016-08-04, issue #964
-- Allow open metas and interaction points in imported files

-- {-# OPTIONS -v import:100 #-}
-- {-# OPTIONS -v meta.postulate:20 #-}
-- {-# OPTIONS -v tc.conv.level:50 #-}

open import Common.Level
open import Common.Equality

postulate something : Set₁

open import Common.Issue964.UnsolvedMetas something

test =  M.N.meta3

shouldFail : _≡_ {A = Level} meta (lsuc (lsuc lzero))
shouldFail = refl

-- WAS: WEIRD ERROR:
-- Set (Set .Issue964.UnsolvedMetas.1) != Set₂
-- when checking that the expression refl has type
-- meta ≡ lsuc (lsuc lzero)

-- NOW:
-- Set (.Issue964.UnsolvedMetas.unsolved#meta.1 something) != Set₂
-- when checking that the expression refl has type
-- meta ≡ lsuc (lsuc lzero)


{-# OPTIONS --without-K #-}
module sets.nat.struct where

open import sum
open import equality
open import function
open import container.core
open import container.w
open import sets.empty
open import sets.unit
open import sets.nat.core
open import sets.fin
open import sets.vec.dependent
open import hott.level

ℕ-c : Container _ _ _
ℕ-c = record
  { I = ⊤
  ; A = λ _ → Fin 2
  ; B = ⊥ ∷∷ ⊤ ∷∷ ⟦⟧
  ; r = λ _ → tt }

open Container ℕ-c

ℕ-algebra-iso : (⊤ ⊎ ℕ) ≅ ℕ
ℕ-algebra-iso = record
  { to = λ { (inj₁ _) → zero ; (inj₂ n) → suc n }
  ; from = λ { zero → inj₁ tt ; (suc n) → inj₂ n }
  ; iso₁ = λ { (inj₁ _) → refl ; (inj₂ n) → refl }
  ; iso₂ = λ { zero → refl ; (suc n) → refl } }

private
  inℕ : F (λ _ → ℕ) tt → ℕ
  inℕ (zero , u) = 0
  inℕ (suc zero , u) = suc (u tt)
  inℕ (suc (suc ()) , u)

ℕ-struct-iso : ℕ ≅ W ℕ-c tt
ℕ-struct-iso = iso f g α β
  where
    f : ℕ → W ℕ-c tt
    f 0 = sup (zero) (λ ())
    f (suc n) = sup (suc zero) (λ _ → f n)

    g : W ℕ-c tt → ℕ
    g = fold ℕ-c (λ i → inℕ) tt

    α : (n : ℕ) → g (f n) ≡ n
    α zero = refl
    α (suc n) = ap suc (α n)

    β : (n : W ℕ-c tt) → f (g n) ≡ n
    β (sup zero u) = ap (sup zero) (funext λ ())
    β (sup (suc zero) u) = ap (sup (suc zero)) (funext (λ x → β (u tt)))
    β (sup (suc (suc ())) u)

private
  F-struct-iso : ∀ {i}(X : ⊤ → Set i) → F X tt ≅ (⊤ ⊎ X tt)
  F-struct-iso X = begin
      ( Σ (A tt) λ a → B a → X tt )
    ≅⟨ sym≅ (⊎-Σ-iso (λ a → B a → X tt)) ⟩
      ( (⊥ → X tt) ⊎ (⊤ → X tt) )
    ≅⟨ ⊎-ap-iso (contr-⊤-iso ⊥-initial) Π-left-unit ⟩
      ( ⊤ ⊎ X tt )
    ∎
    where open ≅-Reasoning

ℕ-initial : ∀ {i} (X : ℕ → Set i)
          → (x₀ : X 0)(f : ∀ n → X n → X (suc n))
          → contr ( Σ ((n : ℕ) → X n) λ x
                  → (x₀ ≡ x 0)
                  × (∀ n → f n (x n) ≡ x (suc n)) )
ℕ-initial X x₀ f = iso-level ℕ-alg-iso (W-section-contr ℕ-c 𝓧)
  where
    ψ : ∀ x → ((b : B (proj₁ x)) → X (proj₂ x b)) → X (inℕ x)
    ψ (zero , u) v = x₀
    ψ (suc zero , u) v = f (u tt) (v tt)
    ψ (suc (suc ()) , u) v

    P : ∀ i (n : W ℕ-c i) → Set _
    P i n = X (invert ℕ-struct-iso n)

    θ : ∀ i x → ((b : B (proj₁ x)) → P tt (proj₂ x b)) → P i (inW ℕ-c i x)
    θ i (a , u) v = ψ (a , invert ℕ-struct-iso ∘' u) v

    𝓧 : AlgFib ℕ-c _
    𝓧 = P , θ

    ℕ-alg-iso : AlgSection ℕ-c 𝓧 ≅
              ( Σ ((n : ℕ) → X n) λ x
              → (x₀ ≡ x 0)
              × (∀ n → f n (x n) ≡ x (suc n)) )
    ℕ-alg-iso = begin
        AlgSection ℕ-c 𝓧
      ≅⟨ ( Σ-ap-iso Π-left-unit λ g → iso≡ Π-left-unit) ⟩
        ( Σ ((w : W ℕ-c tt) → P tt w) λ g
        → ( _≡_ {A = (x : F (W ℕ-c) tt) → P tt (inW ℕ-c tt x)}
            (λ x → θ tt x (λ b → g (proj₂ x b)))
            (λ x → g (inW ℕ-c tt x)) ) )
      ≅⟨ sym≅ ( Σ-ap-iso (Π-ap-iso ℕ-struct-iso λ _ → refl≅) λ g
         → iso≡ (Π-ap-iso (sym≅ (F-ap-iso (λ i → sym≅ ℕ-struct-iso) tt)) λ x
                → refl≅ ) ) ⟩
        ( Σ ((n : ℕ) → X n) λ g
        → ( _≡_ {A = (x : F (λ _ → ℕ) tt) → X (inℕ x)}
            (λ x → ψ x (λ b → g (proj₂ x b)))
            (λ x → g (inℕ x)) ) )
      ≅⟨ ( Σ-ap-iso refl≅ λ g
         → iso≡ (Π-ap-iso (F-struct-iso (λ _ → ℕ)) λ _ → refl≅) ) ⟩
        ( let φ = invert (F-struct-iso (λ _ → ℕ))
        in Σ ((n : ℕ) → X n) λ g
        → ( _≡_ {A = (x : ⊤ ⊎ ℕ) → X (inℕ (φ x))}
            (λ x → ψ (φ x) (λ b → g (proj₂ (φ x) b)))
            (λ x → g (inℕ (φ x))) ) )
      ≅⟨ ( Σ-ap-iso refl≅ λ x → iso≡ ⊎-universal ) ⟩
        ( Σ ((n : ℕ) → X n) λ x
        → ( _≡_ {A = (⊤ → X 0) × ((n : ℕ) → X (suc n))}
            ((λ _ → x₀) , (λ n → f n (x n)))
            ((λ _ → x 0) , (λ n → x (suc n))) ) )
      ≅⟨ ( Σ-ap-iso refl≅ λ x → sym≅ ×-split-iso ) ⟩
        ( Σ ((n : ℕ) → X n) λ x
        → (_≡_ {A = ⊤ → X 0} (λ _ → x₀) (λ _ → x 0))
        × (_≡_ {A = (n : ℕ) → X (suc n)} (λ n → f n (x n)) (λ n → x (suc n))) )
      ≅⟨ ( Σ-ap-iso refl≅ λ x → ×-ap-iso (iso≡ Π-left-unit) (sym≅ strong-funext-iso) ) ⟩
        ( Σ ((n : ℕ) → X n) λ x
        → (x₀ ≡ x 0)
        × (∀ n → f n (x n) ≡ x (suc n)) )
      ∎
      where
        open ≅-Reasoning

ℕ-initial-simple : ∀ {i} {X : Set i} (x₀ : X)
                 → contr ( Σ (ℕ → X) λ x
                         → (x₀ ≡ x 0)
                         × (∀ n → x n ≡ x (suc n)) )
ℕ-initial-simple {X = X} x₀
  = ((λ _ → x₀) , refl , λ _ → refl)
  , (λ u → contr⇒prop (ℕ-initial (λ _ → X) x₀ (λ _ x → x)) _ u)

ℕ-elim-shift : ∀ {i}{X : ℕ → Set i}
             → ((n : ℕ) → X n)
             ≅ ( (X 0) × ((n : ℕ) → X (suc n)) )
ℕ-elim-shift {i}{X} = begin
    ((n : ℕ) → X n)
  ≅⟨ (Π-ap-iso (sym≅ ℕ-algebra-iso) λ _ → refl≅) ⟩
    ((n : ⊤ ⊎ ℕ) → X (apply ℕ-algebra-iso n))
  ≅⟨ ⊎-universal ⟩
    ((⊤ → X 0) × ((n : ℕ) → X (suc n)))
  ≅⟨ ×-ap-iso Π-left-unit refl≅ ⟩
    (X 0 × ((n : ℕ) → X (suc n)))
  ∎
  where
    open ≅-Reasoning


module container.w where

open import container.w.core public
open import container.w.algebra public
open import container.w.fibration public


module Issue363 where

infixl 0 _>>=_

postulate
  A     : Set
  x     : A
  _>>=_ : A → (A → A) → A
  P     : A → Set

lemma : P ((x >>= λ x → x) >>= λ x → x)
lemma = {!!}

-- The type of the goal above was printed as follows:
--
--   P (x >>= λ x' → x' >>= λ x' → x')
--
-- This is not correct.


open import Prelude

module Implicits.Syntax.MetaType where

open import Implicits.Syntax.Type

mutual
  data MetaSimpleType (m ν : ℕ) : Set where
    tvar : Fin ν → MetaSimpleType m ν
    mvar : Fin m → MetaSimpleType m ν
    _→'_ : (a b : MetaType m ν) → MetaSimpleType m ν
    tc   : ℕ → MetaSimpleType m ν

  data MetaType (m ν : ℕ) : Set where
    _⇒_ : (a b : MetaType m ν) → MetaType m ν
    ∀'  : MetaType m (suc ν) → MetaType m ν
    simpl : MetaSimpleType m ν → MetaType m ν

s-tvar : ∀ {ν m} → Fin ν → MetaType m ν
s-tvar n = simpl (tvar n)

s-mvar : ∀ {ν m} → Fin m → MetaType m ν
s-mvar n = simpl (mvar n)

s-tc : ∀ {ν m} → ℕ → MetaType m ν
s-tc c = simpl (tc c)

mutual
  to-smeta : ∀ {m ν} → SimpleType ν → MetaSimpleType m ν
  to-smeta (tc x) = (tc x)
  to-smeta (tvar n) = (tvar n)
  to-smeta (a →' b) = (to-meta a) →' (to-meta b)

  to-meta : ∀ {m ν} → Type ν → MetaType m ν
  to-meta (simpl x) = simpl (to-smeta x)
  to-meta (a ⇒ b) = (to-meta a) ⇒ (to-meta b)
  to-meta (∀' a) = ∀' (to-meta a)

mutual
  from-smeta : ∀ {ν} → MetaSimpleType zero ν → SimpleType ν
  from-smeta (tvar x) = tvar x
  from-smeta (mvar ())
  from-smeta (tc c) = tc c
  from-smeta (a →' b) = from-meta a →' from-meta b

  from-meta : ∀ {ν} → MetaType zero ν → Type ν
  from-meta (simpl τ) = simpl (from-smeta τ)
  from-meta (a ⇒ b) = from-meta a ⇒ from-meta b
  from-meta (∀' x) = ∀' (from-meta x)

is-m∀' : ∀ {m ν} → MetaType m ν → Set
is-m∀' (simpl x) = ⊥
is-m∀' (a ⇒ b) = ⊥
is-m∀' (∀' x) = ⊤


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

module Lens where

open import Lens.Definition public
open import Lens.Operators public
open import Lens.Composition public
open import Lens.Pair public


{-# OPTIONS --no-positivity-check #-}
module IIRDg where

import LF
import DefinitionalEquality
import IIRD

open LF
open DefinitionalEquality
open IIRD

mutual

  data Ug {I : Set}{D : I -> Set1}(γ : OPg I D) : I -> Set where
    introg : (a : Gu γ (Ug γ) (Tg γ)) -> Ug γ (Gi γ (Ug γ) (Tg γ) a)

  Tg : {I : Set}{D : I -> Set1}(γ : OPg I D)(i : I) -> Ug γ i -> D i
  Tg γ .(Gi γ (Ug γ) (Tg γ) a) (introg a) = Gt γ (Ug γ) (Tg γ) a

Arg : {I : Set}{D : I -> Set1}(γ : OPg I D) -> Set
Arg γ = Gu γ (Ug γ) (Tg γ)

index : {I : Set}{D : I -> Set1}(γ : OPg I D) -> Arg γ -> I
index γ a = Gi γ (Ug γ) (Tg γ) a

IH : {I : Set}{D : I -> Set1}(γ : OPg I D)(F : (i : I) -> Ug γ i -> Set1) -> Arg γ -> Set1
IH γ = KIH γ (Ug γ) (Tg γ)

-- Elimination rule
Rg : {I : Set}{D : I -> Set1}(γ : OPg I D)(F : (i : I) -> Ug γ i -> Set1) ->
     (h : (a : Arg γ) -> IH γ F a -> F (index γ a) (introg a)) ->
     (i : I)(u : Ug γ i) -> F i u
Rg γ F h .(index γ a) (introg a) = h a (Kmap γ (Ug γ) (Tg γ) F (Rg γ F h) a)

{-
-- We don't have general IIRDs so we have to postulate Ug/Tg

postulate
  Ug : {I : Set}{D : I -> Set1} -> OPg I D -> I -> Set
  Tg : {I : Set}{D : I -> Set1}(γ : OPg I D)(i : I) -> Ug γ i -> D i

  introg : {I : Set}{D : I -> Set1}(γ : OPg I D)(a : Gu γ (Ug γ) (Tg γ)) ->
           Ug γ (Gi γ (Ug γ) (Tg γ) a)

  Tg-equality : {I : Set}{D : I -> Set1}(γ : OPg I D)(a : Gu γ (Ug γ) (Tg γ)) ->
                Tg γ (Gi γ (Ug γ) (Tg γ) a) (introg γ a) ≡₁ Gt γ (Ug γ) (Tg γ) a

  Rg : {I : Set}{D : I -> Set1}(γ : OPg I D)(F : (i : I) -> Ug γ i -> Set1)
       (h : (a : Gu γ (Ug γ) (Tg γ)) -> KIH γ (Ug γ) (Tg γ) F a -> F (Gi γ (Ug γ) (Tg γ) a) (introg γ a))
       (i : I)(u : Ug γ i) -> F i u

  Rg-equality : {I : Set}{D : I -> Set1}(γ : OPg I D)(F : (i : I) -> Ug γ i -> Set1)
                (h : (a : Gu γ (Ug γ) (Tg γ)) -> KIH γ (Ug γ) (Tg γ) F a -> F (Gi γ (Ug γ) (Tg γ) a) (introg γ a))
                (a : Gu γ (Ug γ) (Tg γ)) ->
                Rg γ F h (Gi γ (Ug γ) (Tg γ) a) (introg γ a)
                ≡₁ h a (Kmap γ (Ug γ) (Tg γ) F (Rg γ F h) a)

-- Helpers

ι★g : {I : Set}(i : I) -> OPg I (\_ -> One')
ι★g i = ι < i | ★' >'

-- Examples

module Martin-Löf-Identity where

  IdOP : {A : Set} -> OPg (A * A) (\_ -> One')
  IdOP {A} = σ A \a -> ι★g < a | a >

  _==_ : {A : Set}(x y : A) -> Set
  x == y = Ug IdOP < x | y >

  refl : {A : Set}(x : A) -> x == x
  refl x = introg IdOP < x | ★ >

  -- We have to work slightly harder than desired since we don't have η for × and One.
  private
    -- F C is just uncurry C but dependent and at high universes.
    F : {A : Set}(C : (x y : A) -> x == y -> Set1)(i : A * A) -> Ug IdOP i -> Set1
    F C < x | y > p = C x y p

    h' : {A : Set}(C : (x y : A) -> x == y -> Set1)
         (h : (x : A) -> C x x (refl x))
         (a : Gu IdOP (Ug IdOP) (Tg IdOP)) -> KIH IdOP (Ug IdOP) (Tg IdOP) (F C) a ->
         F C (Gi IdOP (Ug IdOP) (Tg IdOP) a) (introg IdOP a)
    h' C h < x | ★ > _ = h x

  J : {A : Set}(C : (x y : A) -> x == y -> Set1)
      (h : (x : A) -> C x x (refl x))
      (x y : A)(p : x == y) -> C x y p
  J {A} C h x y p = Rg IdOP (F C) (h' C h) < x | y > p

  J-equality : {A : Set}(C : (x y : A) -> x == y -> Set1)
               (h : (x : A) -> C x x (refl x))(x : A) ->
               J C h x x (refl x) ≡₁ h x
  J-equality {A} C h x = Rg-equality IdOP (F C) (h' C h) < x | ★ >

module Christine-Identity where

  IdOP : {A : Set}(a : A) -> OPg A (\_ -> One')
  IdOP {A} a = ι★g a

  _==_ : {A : Set}(x y : A) -> Set
  x == y = Ug (IdOP x) y

  refl : {A : Set}(x : A) -> x == x
  refl x = introg (IdOP x) ★

  private
    h' : {A : Set}(x : A)(C : (y : A) -> x == y -> Set1)
         (h : C x (refl x))(a : Gu (IdOP x) (Ug (IdOP x)) (Tg (IdOP x))) ->
         KIH (IdOP x) (Ug (IdOP x)) (Tg (IdOP x)) C a ->
         C (Gi (IdOP x) (Ug (IdOP x)) (Tg (IdOP x)) a) (introg (IdOP x) a)
    h' x C h ★ _ = h

  H : {A : Set}(x : A)(C : (y : A) -> x == y -> Set1)
      (h : C x (refl x))
      (y : A)(p : x == y) -> C y p
  H x C h y p = Rg (IdOP x) C (h' x C h) y p

  H-equality : {A : Set}(x : A)(C : (y : A) -> x == y -> Set1)
               (h : C x (refl x)) ->
               H x C h x (refl x) ≡₁ h
  H-equality x C h = Rg-equality (IdOP x) C (h' x C h) ★

open Christine-Identity
-}


{-

Please do not move this file. Changes should only be made if
necessary.

This file contains pointers to the code examples and main results from
the paper:

Synthetic Cohomology Theory in Cubical Agda

-}

-- The "--safe" flag ensures that there are no postulates or
-- unfinished goals
{-# OPTIONS --safe #-}
module Cubical.Papers.ZCohomology where

-- Misc.
open import Cubical.Data.Int hiding (_+_)
open import Cubical.Data.Nat
open import Cubical.Foundations.Everything
open import Cubical.HITs.S1
open import Cubical.Data.Sum
open import Cubical.Data.Sigma

-- 2
open import Cubical.Core.Glue                                as Glue
import Cubical.Foundations.Prelude                           as Prelude
import Cubical.Foundations.GroupoidLaws                      as GroupoidLaws
import Cubical.Foundations.Path                              as Path
import Cubical.Foundations.Pointed                           as Pointed
  renaming (Pointed to Type∙)
open import Cubical.HITs.S1                                  as S1
open import Cubical.HITs.Susp                                as Suspension
open import Cubical.HITs.Sn                                  as Sn
open import Cubical.Homotopy.Loopspace                       as Loop
open import Cubical.Foundations.HLevels                      as n-types
open import Cubical.HITs.Truncation                          as Trunc
open import Cubical.Homotopy.Connected                       as Connected
import Cubical.HITs.Pushout                                  as Push
import Cubical.HITs.Wedge                                    as ⋁
import Cubical.Foundations.Univalence                        as Unival
import Cubical.Foundations.SIP                               as StructIdPrinc
import Cubical.Algebra.Group                                 as Gr
import Cubical.Algebra.Group.GroupPath                       as GrPath

-- 3
import Cubical.ZCohomology.Base                              as coHom
  renaming (coHomK to K ; coHomK-ptd to K∙)
import Cubical.HITs.Sn.Properties                            as S
import Cubical.ZCohomology.GroupStructure                    as GroupStructure
import Cubical.ZCohomology.Properties                        as Properties
  renaming (Kn→ΩKn+1 to σ ; ΩKn+1→Kn to σ⁻¹)
import Cubical.Experiments.ZCohomologyOld.Properties as oldCohom

-- 4
import Cubical.ZCohomology.RingStructure.CupProduct          as Cup
import Cubical.ZCohomology.RingStructure.RingLaws            as ⌣Ring
import Cubical.ZCohomology.RingStructure.GradedCommutativity as ⌣Comm
import Cubical.Foundations.Pointed.Homogeneous               as Homogen

-- 5
import Cubical.HITs.Torus                                    as 𝕋²
  renaming (Torus to 𝕋²)
import Cubical.HITs.KleinBottle                              as 𝕂²
  renaming (KleinBottle to 𝕂²)
import Cubical.HITs.RPn                                      as ℝP
  renaming (RP² to ℝP²)
import Cubical.ZCohomology.Groups.Sn                         as HⁿSⁿ
  renaming (Hⁿ-Sᵐ≅0 to Hⁿ-Sᵐ≅1)
import Cubical.ZCohomology.Groups.Torus                      as HⁿT²
import Cubical.ZCohomology.Groups.Wedge                      as Hⁿ-wedge
import Cubical.ZCohomology.Groups.KleinBottle                as Hⁿ𝕂²
import Cubical.ZCohomology.Groups.RP2                        as HⁿℝP²
  renaming (H¹-RP²≅0 to H¹-RP²≅1)
import Cubical.ZCohomology.Groups.CP2                        as HⁿℂP²
  renaming (CP² to ℂP² ; ℤ→HⁿCP²→ℤ to g)
  {- Remark: ℂP² is defined as the pushout S² ← TotalHopf → 1 in
  the formalisation. TotalHopf is just the total space from the Hopf
  fibration. We have TotalHopf ≃ S³, and the map TotalHopf → S²
  is given by taking the first projection. This is equivalent to the
  description given in the paper, since h : S³ → S² is given by
  S³ ≃ TotalHopf → S² -}

-- Appendix
import Cubical.Homotopy.EilenbergSteenrod                    as ES-axioms
import Cubical.ZCohomology.EilenbergSteenrodZ                as satisfies-ES-axioms
  renaming (coHomFunctor to H^~ ; coHomFunctor' to Ĥ)
import Cubical.ZCohomology.MayerVietorisUnreduced            as MayerVietoris

----- 2. HOMOTOPY TYPE THEORY IN CUBICAL AGDA -----

-- 2.1 Important notions in Cubical Agda
open Prelude using ( PathP
                   ; _≡_
                   ; refl
                   ; cong
                   ; cong₂
                   ; funExt)

open GroupoidLaws using (_⁻¹)

open Prelude using ( transport
                   ; subst
                   ; hcomp)

--- 2.2 Important concepts from HoTT/UF in Cubical Agda

-- Pointed Types
open Pointed using (Type∙)

-- The circle, 𝕊¹
open S1 using (S¹)

-- Suspensions
open Suspension using (Susp)

-- (Pointed) n-spheres, 𝕊ⁿ
open Sn using (S₊∙)

-- Loop spaces
open Loop using (Ω^_)

-- Eckmann-Hilton argument
open Loop using (Eckmann-Hilton)

-- n-types Note that we start indexing from 0 in the Cubical Library
-- (so (-2)-types as referred to as 0-types, (-1) as 1-types, and so
-- on)
open n-types using (isOfHLevel)

-- truncations
open Trunc using (hLevelTrunc)

-- elimination principle
open Trunc using (elim)

-- elimination principle for paths
truncPathElim : ∀ {ℓ ℓ'} {A : Type ℓ} {x y : A} (n : ℕ)
              → {B : Path (hLevelTrunc (suc n) A) ∣ x ∣ ∣ y ∣ → Type ℓ'}
              → ((q : _) → isOfHLevel n (B q))
              → ((p : x ≡ y) → B (cong ∣_∣ p))
              → (q : _) → B q
truncPathElim zero hlev ind q = hlev q .fst
truncPathElim (suc n) {B = B} hlev ind q =
  subst B (Iso.leftInv (Trunc.PathIdTruncIso _) q)
    (help (ΩTrunc.encode-fun ∣ _ ∣ ∣ _ ∣ q))
  where
  help : (q : _) → B (ΩTrunc.decode-fun ∣ _ ∣ ∣ _ ∣ q)
  help = Trunc.elim (λ _ → hlev _) ind

-- Connectedness
open Connected using (isConnected)

-- Pushouts
open Push using (Pushout)

-- Wedge sum
open ⋁ using (_⋁_)

-- 2.3 Univalence

-- Univalence and the ua function respectively
open Unival using (univalence ; ua)

-- Glue types
open Glue using (Glue)

-- The structure identity principle and the sip function
-- respectively
open StructIdPrinc using (SIP ; sip)

-- Groups
open Gr using (Group)

-- Isomorphic groups are path equal
open GrPath using (GroupPath)

----- 3. ℤ-COHOMOLOGY IN CUBICAL AGDA -----

-- 3.1 Eilenberg-MacLane spaces

-- Eilenberg-MacLane spaces Kₙ (unpointed and pointed respectively)
open coHom using (K ; K∙)

-- Proposition 7
open S using (sphereConnected)

-- Lemma 8
open S using (wedgeconFun; wedgeconLeft ; wedgeconRight)

-- restated to match the formulation in the paper
wedgeConSn' : ∀ {ℓ} (n m : ℕ) {A : (S₊ (suc n)) → (S₊ (suc m)) → Type ℓ}
            → ((x : S₊ (suc n)) (y : S₊ (suc m)) → isOfHLevel ((suc n) + (suc m)) (A x y))
            → (fₗ : (x : _) → A x (ptSn (suc m)))
            → (fᵣ : (x : _) → A (ptSn (suc n)) x)
            → (p : fₗ (ptSn (suc n)) ≡ fᵣ (ptSn (suc m)))
            → Σ[ F ∈ ((x : S₊ (suc n)) (y : S₊ (suc m)) → A x y) ]
                (Σ[ (left , right) ∈ ((x : S₊ (suc n)) → fₗ x ≡ F x (ptSn (suc m)))
                                   × ((x : S₊ (suc m)) → fᵣ x ≡ F (ptSn (suc n)) x) ]
                  p ≡ left (ptSn (suc n)) ∙ (right (ptSn (suc m))) ⁻¹)
wedgeConSn' zero zero hlev fₗ fᵣ p =
  (wedgeconFun 0 0 hlev fᵣ fₗ p)
   , ((λ x → sym (wedgeconRight 0 0 hlev fᵣ fₗ p x))
   , λ _ → refl) -- right holds by refl
   , rUnit _
wedgeConSn' zero (suc m) hlev fₗ fᵣ p =
  (wedgeconFun 0 (suc m) hlev fᵣ fₗ p)
  , ((λ _ → refl) -- left holds by refl
  , (λ x → sym (wedgeconLeft 0 (suc m) hlev fᵣ fₗ p x)))
  , lUnit _
wedgeConSn' (suc n) m hlev fₗ fᵣ p =
  (wedgeconFun (suc n) m hlev fᵣ fₗ p)
   , ((λ x → sym (wedgeconRight (suc n) m hlev fᵣ fₗ p x))
   , λ _ → refl) -- right holds by refl
   , rUnit _

-- +ₖ (addition) and 0ₖ
open GroupStructure using (_+ₖ_ ; 0ₖ)

-- The function σ : Kₙ → ΩKₙ₊₁
open Properties using (σ)

-- -ₖ (subtraction)
open GroupStructure using (-ₖ_)

-- Group laws for +ₖ
open GroupStructure using ( rUnitₖ ; lUnitₖ
                          ; rCancelₖ ; lCancelₖ
                          ; commₖ
                          ; assocₖ)

-- All group laws are equal to refl at 0ₖ
-- rUnitₖ (definitional)
0-rUnit≡refl : rUnitₖ 0 (0ₖ 0) ≡ refl
1-rUnit≡refl : rUnitₖ 1 (0ₖ 1) ≡ refl
0-rUnit≡refl = refl
1-rUnit≡refl = refl
n≥2-rUnit≡refl : {n : ℕ} → rUnitₖ (2 + n) (0ₖ (2 + n)) ≡ refl
n≥2-rUnit≡refl = refl

-- lUnitₖ (definitional)
0-lUnit≡refl : lUnitₖ 0 (0ₖ 0) ≡ refl
1-lUnit≡refl : lUnitₖ 1 (0ₖ 1) ≡ refl
n≥2-lUnit≡refl : {n : ℕ} → lUnitₖ (2 + n) (0ₖ (2 + n)) ≡ refl
0-lUnit≡refl = refl
1-lUnit≡refl = refl
n≥2-lUnit≡refl = refl

-- assocₖ (definitional)
0-assoc≡refl : assocₖ 0 (0ₖ 0) (0ₖ 0) (0ₖ 0) ≡ refl
1-assoc≡refl : assocₖ 1 (0ₖ 1) (0ₖ 1) (0ₖ 1) ≡ refl
n≥2-assoc≡refl : {n : ℕ} → assocₖ (2 + n) (0ₖ (2 + n)) (0ₖ (2 + n)) (0ₖ (2 + n)) ≡ refl
0-assoc≡refl = refl
1-assoc≡refl = refl
n≥2-assoc≡refl = refl

-- commₖ (≡ refl ∙ refl for n ≥ 2)
0-comm≡refl : commₖ 0 (0ₖ 0) (0ₖ 0) ≡ refl
1-comm≡refl : commₖ 1 (0ₖ 1) (0ₖ 1) ≡ refl
n≥2-comm≡refl : {n : ℕ} → commₖ (2 + n) (0ₖ (2 + n)) (0ₖ (2 + n)) ≡ refl
0-comm≡refl = refl
1-comm≡refl = refl
n≥2-comm≡refl = sym (rUnit refl)

-- lCancelₖ (definitional)
0-lCancel≡refl : lCancelₖ 0 (0ₖ 0) ≡ refl
1-lCancel≡refl : lCancelₖ 1 (0ₖ 1) ≡ refl
n≥2-lCancel≡refl : {n : ℕ} → lCancelₖ (2 + n) (0ₖ (2 + n)) ≡ refl
0-lCancel≡refl = refl
1-lCancel≡refl = refl
n≥2-lCancel≡refl = refl

-- rCancelₖ (≡ (refl ∙ refl) ∙ refl for n ≥ 1)
0-rCancel≡refl : rCancelₖ 0 (0ₖ 0) ≡ refl
1-rCancel≡refl : rCancelₖ 1 (0ₖ 1) ≡ refl
n≥2-rCancel≡refl : {n : ℕ} → rCancelₖ (2 + n) (0ₖ (2 + n)) ≡ refl
0-rCancel≡refl = refl
1-rCancel≡refl = refl
n≥2-rCancel≡refl i = rUnit (rUnit refl (~ i)) (~ i)

-- Proof that there is a unique h-structure on Kₙ
-- +ₖ defines an h-Structure on Kₙ
open GroupStructure using (_+ₖ_ ; 0ₖ ; rUnitₖ ; lUnitₖ ; lUnitₖ≡rUnitₖ)

-- and so does Brunerie's addition
open oldCohom using (_+ₖ_ ; 0ₖ ; rUnitₖ ; lUnitₖ ; rUnitlUnit0)

-- consequently both additions agree
open GroupStructure using (+ₖ-unique)
open oldCohom using (addLemma)
additionsAgree : (n : ℕ) → GroupStructure._+ₖ_ {n = n} ≡ oldCohom._+ₖ_ {n = n}
additionsAgree zero i x y = oldCohom.addLemma x y (~ i)
additionsAgree (suc n) i x y =
  +ₖ-unique n (GroupStructure._+ₖ_) (oldCohom._+ₖ_)
              (GroupStructure.rUnitₖ (suc n)) (GroupStructure.lUnitₖ (suc n))
              (oldCohom.rUnitₖ (suc n)) (oldCohom.lUnitₖ (suc n))
              (sym (lUnitₖ≡rUnitₖ (suc n)))
              (rUnitlUnit0 (suc n)) x y i

-- Theorem 9 (Kₙ ≃ ΩKₙ₊₁)
open Properties using (Kn≃ΩKn+1)

-- σ and σ⁻¹ are morphisms
-- (for σ⁻¹ this is proved directly without using the fact that σ is a morphism)
open Properties using (Kn→ΩKn+1-hom ; ΩKn+1→Kn-hom)

-- Lemma 10 (p ∙ q ≡ cong²₊(p,q)) for n = 1 and n ≥ 2 respectively
open GroupStructure using (∙≡+₁ ; ∙≡+₂)

-- Lemma 11 (cong²₊ is commutative) and Theorem 12 respectively
open GroupStructure using (cong+ₖ-comm ; isCommΩK)

-- 3.2 Group structure on Hⁿ(A)

-- +ₕ (addition), -ₕ and 0ₕ
open GroupStructure using (_+ₕ_ ; -ₕ_ ; 0ₕ)

-- Cohomology group structure
open GroupStructure using ( rUnitₕ ; lUnitₕ
                          ; rCancelₕ ; lCancelₕ
                          ; commₕ
                          ; assocₕ)

-------------------------------------------------------------------- MOVE?
-- Reduced cohomology, group structure
open GroupStructure using (coHomRedGroupDir)

-- Equality of unreduced and reduced cohmology
open Properties using (coHomGroup≡coHomRedGroup)
--------------------------------------------------------------------

----- 4. The Cup Product and Cohomology Ring -----
-- 4.1
-- Lemma 13
open Properties using (isOfHLevel↑∙)

-- ⌣ₖ
open Cup using (_⌣ₖ_)

-- ⌣ₖ is pointed in both arguments
open ⌣Ring using (0ₖ-⌣ₖ ; ⌣ₖ-0ₖ)

-- The cup product
open Cup using (_⌣_)

-- 4.2
-- Lemma 14
Lem14 : ∀ {ℓ} {A : Type∙ ℓ} (n : ℕ) (f g : A →∙ K∙ n) → fst f ≡ fst g → f ≡ g
Lem14 n f g p = Homogen.→∙Homogeneous≡ (Properties.isHomogeneousKn n) p

-- Proposition 15
open ⌣Ring using (leftDistr-⌣ₖ ; rightDistr-⌣ₖ)

-- Lemma 16
open ⌣Ring using (assocer-helpFun≡)

-- Proposition 17
open ⌣Ring using (assoc-⌣ₖ)

-- Proposition 18
open ⌣Comm using (gradedComm-⌣ₖ)

-- Ring structure on ⌣
open ⌣Ring using (leftDistr-⌣ ; rightDistr-⌣
                ; assoc-⌣ ; 1⌣
                ; rUnit⌣ ; lUnit⌣
                ; ⌣0 ; 0⌣)
open ⌣Comm using (gradedComm-⌣)

----- 5. CHARACTERIZING ℤ-COHOMOLOGY GROUPS -----

-- 5.1
-- Proposition 19
open HⁿSⁿ using (Hⁿ-Sⁿ≅ℤ)

-- 5.2
-- The torus
open 𝕋² using (𝕋²)

-- Propositions 20 and 21 respectively
open HⁿT² using (H¹-T²≅ℤ×ℤ ; H²-T²≅ℤ)

-- 5.3
-- The Klein bottle
open 𝕂² using (𝕂²)

-- The real projective plane
open ℝP using (ℝP²)

-- Proposition 22 and 23 respectively
-- ℤ/2ℤ is represented by Bool with the unique group structure
-- Lemma 23 is used implicitly in H²-𝕂²≅Bool
open Hⁿ𝕂² using (H¹-𝕂²≅ℤ ; H²-𝕂²≅Bool)

-- First and second cohomology groups of ℝP² respectively
open HⁿℝP² using (H¹-RP²≅1 ; H²-RP²≅Bool)

-- 5.4
-- The complex projective plane
open HⁿℂP² using (ℂP²)

-- Second and fourth cohomology groups ℂP² respectively
open HⁿℂP² using (H²CP²≅ℤ ;  H⁴CP²≅ℤ)

-- 6 Proving by computations in Cubical Agda
-- Proof of m = n = 1 case of graded commutativity (post truncation elimination):
-- Uncomment and give it a minute. The proof is currently not running very fast.

{-
open ⌣Comm using (-ₖ^_·_ )
n=m=1 : (a b : S¹)
    → _⌣ₖ_ {n = 1} {m = 1} ∣ a ∣ ∣ b ∣
     ≡ (-ₖ (_⌣ₖ_ {n = 1} {m = 1} ∣ b ∣ ∣ a ∣))
n=m=1 base base = refl
n=m=1 base (loop i) k = -ₖ (Properties.Kn→ΩKn+10ₖ _ (~ k) i)
n=m=1 (loop i) base k = Properties.Kn→ΩKn+10ₖ _ k i
n=m=1 (loop i) (loop j) k = -- This hcomp is just a simple rewriting to get paths in Ω²K₂
  hcomp (λ r → λ { (i = i0) → -ₖ Properties.Kn→ΩKn+10ₖ _ (~ k ∨ ~ r) j
                  ; (i = i1) → -ₖ Properties.Kn→ΩKn+10ₖ _ (~ k ∨ ~ r) j
                  ; (j = i0) → Properties.Kn→ΩKn+10ₖ _ (k ∨ ~ r) i
                  ; (j = i1) → Properties.Kn→ΩKn+10ₖ _ (k ∨ ~ r) i
                  ; (k = i0) →
                    doubleCompPath-filler
                      (sym (Properties.Kn→ΩKn+10ₖ _))
                      (λ j i →  _⌣ₖ_ {n = 1} {m = 1} ∣ loop i ∣ ∣ loop j ∣)
                      (Properties.Kn→ΩKn+10ₖ _)
                      (~ r) j i
                  ; (k = i1) →
                    -ₖ doubleCompPath-filler
                      (sym (Properties.Kn→ΩKn+10ₖ _))
                      (λ j i →  _⌣ₖ_ {n = 1} {m = 1} ∣ loop i ∣ ∣ loop j ∣)
                      (Properties.Kn→ΩKn+10ₖ _)
                      (~ r) i j})
        ((main
       ∙ sym (cong-∙∙ (cong (-ₖ_)) (sym (Properties.Kn→ΩKn+10ₖ _))
             (λ j i →  (_⌣ₖ_ {n = 1} {m = 1} ∣ loop i ∣ ∣ loop j ∣))
             (Properties.Kn→ΩKn+10ₖ _))) k i j)
  where
  open import Cubical.Foundations.Equiv.HalfAdjoint
  t : Iso (typ ((Ω^ 2) (K∙ 2))) ℤ
  t = compIso (congIso (invIso (Properties.Iso-Kn-ΩKn+1 1)))
       (invIso (Properties.Iso-Kn-ΩKn+1 0))

  p₁ = flipSquare ((sym (Properties.Kn→ΩKn+10ₖ _))
                      ∙∙ (λ j i →  _⌣ₖ_ {n = 1} {m = 1} ∣ loop i ∣ ∣ loop j ∣)
                      ∙∙ (Properties.Kn→ΩKn+10ₖ _))
  p₂ = (cong (cong (-ₖ_))
            ((sym (Properties.Kn→ΩKn+10ₖ _))))
                      ∙∙ (λ j i →  -ₖ (_⌣ₖ_ {n = 1} {m = 1} ∣ loop i ∣ ∣ loop j ∣))
                      ∙∙ (cong (cong (-ₖ_)) (Properties.Kn→ΩKn+10ₖ _))

  computation : Iso.fun t p₁ ≡ Iso.fun t p₂
  computation = refl

  main : p₁ ≡ p₂
  main = p₁                         ≡⟨ sym (Iso.leftInv t p₁) ⟩
        (Iso.inv t (Iso.fun t p₁))  ≡⟨ cong (Iso.inv t) computation ⟩
        Iso.inv t (Iso.fun t p₂)    ≡⟨ Iso.leftInv t p₂ ⟩
        p₂ ∎
-}

-- 𝕋² ≠ S² ∨ S¹ ∨ S¹
open HⁿT² using (T²≠S²⋁S¹⋁S¹)

-- Second "Brunerie number"
open HⁿℂP² using (g)
brunerie2 : ℤ
brunerie2 = g 1

----- A. Proofs -----

-- A.2 Proofs for Section 4

-- Lemma 27
open Homogen using (→∙Homogeneous≡)

-- Lemma 28
open Homogen using (isHomogeneous→∙)

-- Lemma 29
open Properties using (isHomogeneousKn)

-- Lemma 30, parts 1-3 respectively
open Path using (sym≡flipSquare ; sym-cong-sym≡id ; sym≡cong-sym)

-- Lemma 31
open ⌣Comm using (cong-ₖ-gen-inr)

-- A.3 Proofs for Section 5

-- Proposition 32
open HⁿSⁿ using (Hⁿ-Sᵐ≅1)

----- B. THE EILENBERG-STEENROD AXIOMS -----

-- B.1 The axioms in HoTT/UF

-- The axioms are defined as a record type
open ES-axioms.coHomTheory

-- Proof of the claim that the alternative reduced cohomology functor
-- Ĥ is the same as the usual reduced cohomology functor
_ : ∀ {ℓ} → satisfies-ES-axioms.H^~ {ℓ} ≡ satisfies-ES-axioms.Ĥ
_ = satisfies-ES-axioms.coHomFunctor≡coHomFunctor'

-- B.2 Verifying the axioms

-- Propositions 35 and 36.
_ : ∀ {ℓ} → ES-axioms.coHomTheory {ℓ} satisfies-ES-axioms.H^~
_ = satisfies-ES-axioms.isCohomTheoryZ

-- B.3 Characterizing Z-cohomology groups using the axioms

-- Theorem 37
open MayerVietoris.MV using ( Ker-i⊂Im-d ; Im-d⊂Ker-i
                            ; Ker-Δ⊂Im-i ; Im-i⊂Ker-Δ
                            ; Ker-d⊂Im-Δ ; Im-Δ⊂Ker-d)

----- C. BENCHMARKING COMPUTATIONS WITH THE COHOMOLOGY GROUPS -----

import Cubical.Experiments.ZCohomology.Benchmarks


module Issue604 where

f : (y : Set1) → (x : Set) → Set1
f x = ?


module Text.Parse (Tok : Set) where

open import Prelude

private
  data P′ (A : Set) : Set where
    symbolBind : (Tok → P′ A) → P′ A
    fail′ : P′ A
    returnPlus : A → P′ A → P′ A

  _+++′_ : ∀ {A} → P′ A → P′ A → P′ A
  symbolBind f +++′ symbolBind g = symbolBind λ x → f x +++′ g x
  fail′ +++′ q = q
  p +++′ fail′ = p
  returnPlus x p +++′ q = returnPlus x (p +++′ q)
  p +++′ returnPlus x q = returnPlus x (p +++′ q)

  parse′ : ∀ {A} → P′ A → List Tok → List (A × List Tok)
  parse′ (symbolBind _) [] = []
  parse′ (symbolBind f) (c ∷ s) = parse′ (f c) s
  parse′ (returnPlus x p) s = (x , s) ∷ parse′ p s
  parse′ fail′ xs = []

record P (A : Set) : Set₁ where
  constructor mkP
  field
    unP : ∀ {B} → (A → P′ B) → P′ B

open P

symbol : P Tok
symbol = mkP symbolBind

fail : ∀ {A} → P A
fail = mkP λ _ → fail′

infixr 2 _+++_
_+++_ : ∀ {A} → P A → P A → P A
p +++ q = mkP λ k → unP p k +++′ unP q k

private
  ret : ∀ {A} → A → P A
  ret x = mkP λ k → k x

  bind : ∀ {A B} → P A → (A → P B) → P B
  bind p f = mkP λ k → unP p (λ x → unP (f x) k)

parse : ∀ {A} → P A → List Tok → List (A × List Tok)
parse p = parse′ (unP p (λ x → returnPlus x fail′))

parse! : ∀ {A} → P A → List Tok → Maybe A
parse! p s with filter (null ∘ snd) (parse p s)
... | []          = nothing
... | (x , _) ∷ _ = just x

--- Instances ---

instance
  FunctorP : Functor P
  fmap {{FunctorP}} f m = bind m λ x → ret (f x)

  ApplicativeP : Applicative P
  pure {{ApplicativeP}} = ret
  _<*>_ {{ApplicativeP}} = monadAp bind

  MonadP : Monad P
  _>>=_  {{MonadP}} = bind

  MonoidP : ∀ {A} → Monoid (P A)
  mempty {{MonoidP}} = fail
  _<>_   {{MonoidP}} = _+++_

--- Derived combinators ---

sat : (p : Tok → Bool) → P (Σ Tok (IsTrue ∘ p))
sat p = symbol >>= match
  where
    -- Inlining 'match' gives internal error!
    match : Tok → P (Σ Tok (IsTrue ∘ p))
    match t = if′ p t then return (t , it) else fail

sat! : (Tok → Bool) → P Tok
sat! p = fst <$> sat p

token : {{EqTok : Eq Tok}} → Tok → P ⊤
token t = _ <$ sat (isYes ∘ _==_ t)

{-# NON_TERMINATING #-}
many many₁ : ∀ {A} → P A → P (List A)
many p = return [] +++ many₁ p
many₁ p = _∷_ <$> p <*> many p


-- The category of contexts and renamings
module SOAS.ContextMaps.CategoryOfRenamings {T : Set} where

open import SOAS.Common
open import SOAS.Context {T}
open import SOAS.Variable
open import SOAS.ContextMaps.Combinators (ℐ {T})

open import Categories.Functor.Bifunctor
open import Categories.Object.Initial
open import Categories.Object.Coproduct
open import Categories.Category.Cocartesian

import Categories.Morphism

-- The category of contexts and renamings, defined as the Lawvere theory
-- associated with the clone of variables. In elementary terms it has
-- contexts Γ, Δ as objects, and renamings Γ ↝ Δ ≜ Γ ~[ ℐ → ℐ ]↝ Δ as arrows.
𝔽 : Category 0ℓ 0ℓ 0ℓ
𝔽 = categoryHelper (record
  { Obj = Ctx
  ; _⇒_ = _↝_
  ; _≈_ = λ {Γ} ρ₁ ρ₂ → ∀{α : T}{v : ℐ α Γ} → ρ₁ v ≡ ρ₂ v
  ; id = λ x → x
  ; _∘_ = λ ϱ ρ v → ϱ (ρ v)
  ; assoc = refl
  ; identityˡ = refl
  ; identityʳ = refl
  ; equiv = record { refl = refl ; sym = λ p → sym p ; trans = λ p q → trans p q }
  ; ∘-resp-≈ = λ{ {f = ρ₁} p₁ p₂ → trans (cong ρ₁ p₂) p₁ }
  })

module 𝔽 = Category 𝔽 using (op) renaming ( _∘_      to _∘ᵣ_
                                          ; _≈_      to _≈ᵣ_
                                          ; id       to idᵣ
                                          ; ∘-resp-≈ to ∘-resp-≈ᵣ )
open 𝔽 public

id′ᵣ : (Γ : Ctx) → Γ ↝ Γ
id′ᵣ Γ = idᵣ {Γ}

-- Category of context is co-Cartesian, given by the empty initial context and
-- context concatenation as the monoidal product.
𝔽:Cocartesian : Cocartesian 𝔽
𝔽:Cocartesian = record
  { initial = record
    { ⊥ = ∅
    ; ⊥-is-initial = record { ! = λ{()} ; !-unique = λ{ f {_} {()}} }
    }
  ; coproducts = record { coproduct = λ {Γ}{Δ} → record
    { A+B = Γ ∔ Δ
    ; i₁ = expandʳ Δ
    ; i₂ = expandˡ Γ
    ; [_,_] = copair
    ; inject₁ = λ{ {Θ}{ρ}{ϱ} → i₁-commute ρ ϱ _ }
    ; inject₂ = λ{ {Θ}{ρ}{ϱ} → i₂-commute ρ ϱ _ }
    ; unique = λ{ p₁ p₂ → unique {Γ}{Δ} _ _ _ p₁ p₂ _ }
    } }
  }
  where

  in₁ : (Γ Δ : Ctx) → Γ ↝ Γ ∔ Δ
  in₁ (α ∙ Γ) Δ new     = new
  in₁ (α ∙ Γ) Δ (old v) = old (in₁ Γ Δ v)

  in₂ : (Γ Δ : Ctx) → Δ ↝ Γ ∔ Δ
  in₂ ∅       Δ v = v
  in₂ (α ∙ Γ) Δ v = old (in₂ Γ Δ v)

  i₁-commute : {Γ Δ Θ : Ctx}{α : T}(ρ : Γ ↝ Θ)(ϱ : Δ ↝ Θ)(v : ℐ α Γ)
             → copair ρ ϱ (expandʳ Δ v) ≡ ρ v
  i₁-commute ρ ϱ new = refl
  i₁-commute ρ ϱ (old v) = i₁-commute (ρ ∘ old) ϱ v

  i₂-commute : {Γ Δ Θ : Ctx}{α : T}(ρ : Γ ↝ Θ)(ϱ : Δ ↝ Θ)(v : ℐ α Δ)
             → copair ρ ϱ (expandˡ Γ v) ≡ ϱ v
  i₂-commute {∅} ρ ϱ v = refl
  i₂-commute {α ∙ Γ} ρ ϱ v = i₂-commute (ρ ∘ old) ϱ v

  unique : {Γ Δ Θ : Ctx}{α : T}(ρ : Γ ↝ Θ)(ϱ : Δ ↝ Θ)(π : Γ ∔ Δ ↝ Θ)
         → (π ∘ᵣ expandʳ Δ ≈ᵣ ρ)
         → (π ∘ᵣ expandˡ Γ ≈ᵣ ϱ)
         → (v : ℐ α (Γ ∔ Δ)) → copair ρ ϱ v ≡ π v
  unique {∅} ρ ϱ π p₁ p₂ v = sym p₂
  unique {α ∙ Γ} ρ ϱ π p₁ p₂ new = sym p₁
  unique {α ∙ Γ} ρ ϱ π p₁ p₂ (old v) = unique (ρ ∘ old) ϱ (π ∘ old) p₁ p₂ v

module 𝔽:Co = Cocartesian 𝔽:Cocartesian
module ∔ = BinaryCoproducts (Cocartesian.coproducts 𝔽:Cocartesian)

-- | Special operations coming from the coproduct structure

-- Concatenation is a bifunctor
∔:Bifunctor : Bifunctor 𝔽 𝔽 𝔽
∔:Bifunctor = 𝔽:Co.-+-

-- Left context concatenation functor Γ ∔ (-) : 𝔽 ⟶ 𝔽, for any context Γ
_∔F- : Ctx → Functor 𝔽 𝔽
Γ ∔F- = Γ ∔.+-

-- Right context concatenation functor (-) ∔ Δ : 𝔽 ⟶ 𝔽, for any context Δ
-∔F_ : Ctx → Functor 𝔽 𝔽
-∔F Δ  = ∔.-+ Δ

-- Functorial mapping and injections
_∣∔∣_ : {Γ₁ Γ₂ Δ₁ Δ₂ : Ctx}(ρ : Γ₁ ↝ Γ₂)(ϱ : Δ₁ ↝ Δ₂) → (Γ₁ ∔ Δ₁) ↝ (Γ₂ ∔ Δ₂)
_∣∔∣_ = ∔._+₁_

_∣∔_ : {Γ₁ Γ₂ : Ctx}(ρ : Γ₁ ↝ Γ₂)(Δ : Ctx) → (Γ₁ ∔ Δ) ↝ (Γ₂ ∔ Δ)
ρ ∣∔ Δ = ρ ∣∔∣ id′ᵣ Δ

_∔∣_ : {Δ₁ Δ₂ : Ctx}(Γ : Ctx)(ϱ : Δ₁ ↝ Δ₂) → (Γ ∔ Δ₁) ↝ (Γ ∔ Δ₂)
Γ ∔∣ ϱ =  id′ᵣ Γ ∣∔∣ ϱ

inl  : (Γ {Δ} : Ctx) → Γ ↝ Γ ∔ Δ
inl Γ {Δ} v = ∔.i₁ {Γ}{Δ} v

inr  : (Γ {Δ} : Ctx) → Δ ↝ Γ ∔ Δ
inr Γ {Δ} v = ∔.i₂ {Γ}{Δ} v

-- Left context concatenation represents weakening a variable in Γ by an
-- arbitrary new context Θ to get a variable in context (Θ ∔ Γ).
module Concatˡ Γ = Functor (Γ ∔F-)
    using () renaming ( F₁           to _∔ᵣ_
                      ; identity     to ∔identity
                      ; homomorphism to ∔homomorphism
                      ; F-resp-≈     to ∔F-resp-≈)
open Concatˡ public

-- Context extension represents weakening by a single type, and it's a special
-- case of context concatenation with a singleton context.
module Ext τ = Functor (⌊ τ ⌋ ∔F-)
    using () renaming ( F₁           to _∙ᵣ_
                      ; identity     to ∙identity
                      ; homomorphism to ∙homomorphism
                      ; F-resp-≈     to ∙F-resp-≈)
open Ext public

-- The two coincide (since add is a special case of copair)
-- but not definitionally: ∙ᵣ is the parallel sum of id : ⌊ τ ⌋ ↝ ⌊ τ ⌋ and ρ : Γ ↝ Δ
-- (i.e. the copairing of expandʳ ⌊ τ ⌋ Δ  : ⌊ τ ⌋ ↝ τ ∙ Δ and old ∘ ρ :  Γ ↝ τ ∙ Δ)
-- while liftᵣ is the copairing of new : ⌊ τ ⌋ ↝ τ ∙ Δ and old ∘ ρ :  Γ ↝ τ ∙ Δ
∙ᵣ-as-add : {α τ : T}{Γ Δ : Ctx} → (ρ : Γ ↝ Δ)(v : ℐ α (τ ∙ Γ))
        → add new (old ∘ ρ) v ≡ (τ ∙ᵣ ρ) v
∙ᵣ-as-add ρ new = refl
∙ᵣ-as-add ρ (old v) = refl

-- Making this a definitional equality simplifies things significantly

-- Right context concatenation is possible but rarely needed.
module Concatʳ Δ =  Functor (-∔F Δ )


{-# OPTIONS --cubical --no-import-sorts --safe #-}
{-
  This is inspired by/copied from:
  https://github.com/agda/agda-stdlib/blob/master/src/Tactic/MonoidSolver.agda
-}
module Cubical.Algebra.RingSolver.ReflectionSolving where

open import Cubical.Foundations.Prelude hiding (Type)
open import Cubical.Functions.Logic

open import Agda.Builtin.Reflection hiding (Type)
open import Agda.Builtin.String

open import Cubical.Reflection.Base

open import Cubical.Data.Maybe
open import Cubical.Data.Sigma
open import Cubical.Data.List
open import Cubical.Data.Nat.Literals public
open import Cubical.Data.Int using (fromNegInt; fromNatInt) public
open import Cubical.Data.Nat using (ℕ) renaming (_+_ to _+ℕ_)
open import Cubical.Data.FinData using () renaming (zero to fzero; suc to fsuc) public
open import Cubical.Data.Bool
open import Cubical.Data.Bool.SwitchStatement
open import Cubical.Data.Vec using (Vec) renaming ([] to emptyVec; _∷_ to _∷vec_) public

open import Cubical.Algebra.RingSolver.AlgebraExpression public
open import Cubical.Algebra.CommRing
open import Cubical.Algebra.RingSolver.RawAlgebra
open import Cubical.Algebra.RingSolver.IntAsRawRing
open import Cubical.Algebra.RingSolver.CommRingSolver renaming (solve to ringSolve)

private
  variable
    ℓ : Level

  _==_ = primQNameEquality
  {-# INLINE _==_ #-}

  record VarInfo : Type ℓ-zero where
    field
      varName : String
      varType : Arg Term
      index : ℕ

  getArgs : Term → Maybe (Term × Term)
  getArgs (def n xs) =
    if n == (quote PathP)
    then go xs
    else nothing
      where
      go : List (Arg Term) → Maybe (Term × Term)
      go (varg x ∷ varg y ∷ []) = just (x , y)
      go (x ∷ xs)               = go xs
      go _                      = nothing
  getArgs _ = nothing

  constructSolution : ℕ → List VarInfo → Term → Term → Term → Term
  constructSolution n varInfos R lhs rhs =
    encloseWithIteratedLambda (map VarInfo.varName varInfos) solverCall
    where
      encloseWithIteratedLambda : List String → Term → Term
      encloseWithIteratedLambda (varName ∷ xs) t = lam visible (abs varName (encloseWithIteratedLambda xs t))
      encloseWithIteratedLambda [] t = t

      variableList : List VarInfo → Arg Term
      variableList [] = varg (con (quote emptyVec) [])
      variableList (varInfo ∷ varInfos)
        = varg (con (quote _∷vec_) (varg (var (VarInfo.index varInfo) []) ∷ (variableList varInfos) ∷ []))

      solverCall = def
         (quote ringSolve)
         (varg R ∷ varg lhs ∷ varg rhs
           ∷ variableList (rev varInfos)
           ∷ varg (def (quote refl) []) ∷ [])

module pr (R : CommRing {ℓ}) {n : ℕ} where
  private
    νR = CommRing→RawℤAlgebra R

  open CommRingStr (snd R)

  0' : Expr ℤAsRawRing (fst R) n
  0' = K 0

  1' : Expr ℤAsRawRing (fst R) n
  1' = K 1

module _ (cring : Term) where
  private
    νR = def (quote CommRing→RawℤAlgebra) (varg cring ∷ [])

  open pr

  mutual
    `0` : List (Arg Term) → Term
    `0` [] = def (quote 0') (varg cring ∷ [])
    `0` (varg fstcring ∷ xs) = `0` xs
    `0` (harg _ ∷ xs) = `0` xs
    `0` _ = unknown

    `1` : List (Arg Term) → Term
    `1` [] = def (quote 1') (varg cring ∷ [])
    `1` (varg fstcring ∷ xs) = `1` xs
    `1` (harg _ ∷ xs) = `1` xs
    `1` _ = unknown

    `_·_` : List (Arg Term) → Term
    `_·_` (harg _ ∷ xs) = `_·_` xs
    `_·_` (varg _ ∷ varg x ∷ varg y ∷ []) =
      con
        (quote _·'_) (varg (buildExpression x) ∷ varg (buildExpression y) ∷ [])
    `_·_` _ = unknown

    `_+_` : List (Arg Term) → Term
    `_+_` (harg _ ∷ xs) = `_+_` xs
    `_+_` (varg _ ∷ varg x ∷ varg y ∷ []) =
      con
        (quote _+'_) (varg (buildExpression x) ∷ varg (buildExpression y) ∷ [])
    `_+_` _ = unknown

    `-_` : List (Arg Term) → Term
    `-_` (harg _ ∷ xs) = `-_` xs
    `-_` (varg _ ∷ varg x ∷ []) =
      con
        (quote -'_) (varg (buildExpression x) ∷ [])
    `-_` _ = unknown

    K' : List (Arg Term) → Term
    K' xs = con (quote K) xs

    finiteNumberAsTerm : ℕ → Term
    finiteNumberAsTerm ℕ.zero = con (quote fzero) []
    finiteNumberAsTerm (ℕ.suc n) = con (quote fsuc) (varg (finiteNumberAsTerm n) ∷ [])

    buildExpression : Term → Term
    buildExpression (var index _) = con (quote ∣) (varg (finiteNumberAsTerm index) ∷ [])
    buildExpression t@(def n xs) =
      switch (n ==_) cases
        case (quote CommRingStr.0r)  ⇒ `0` xs     break
        case (quote CommRingStr.1r)  ⇒ `1` xs     break
        case (quote CommRingStr._·_) ⇒ `_·_` xs   break
        case (quote CommRingStr._+_) ⇒ `_+_` xs   break
        case (quote (CommRingStr.-_))  ⇒ `-_` xs    break
        default⇒ (K' xs)
    buildExpression t@(con n xs) =
      switch (n ==_) cases
        case (quote CommRingStr.0r)  ⇒ `0` xs     break
        case (quote CommRingStr.1r)  ⇒ `1` xs     break
        case (quote CommRingStr._·_) ⇒ `_·_` xs   break
        case (quote CommRingStr._+_) ⇒ `_+_` xs   break
        case (quote (CommRingStr.-_))  ⇒ `-_` xs    break
        default⇒ (K' xs)
    buildExpression t = unknown

  toAlgebraExpression : Maybe (Term × Term) → Maybe (Term × Term)
  toAlgebraExpression nothing = nothing
  toAlgebraExpression (just (lhs , rhs)) = just (buildExpression lhs , buildExpression rhs)

private
  adjustDeBruijnIndex : (n : ℕ) → Term → Term
  adjustDeBruijnIndex n (var k args) = var (k +ℕ n) args
  adjustDeBruijnIndex n _ = unknown

  getVarsAndEquation : Term → Maybe (List VarInfo × Term)
  getVarsAndEquation t =
    let
      (rawVars , equationTerm) = extractVars t
      maybeVars = addIndices (length rawVars) rawVars
    in map-Maybe (_, equationTerm) maybeVars
    where
          extractVars : Term → List (String × Arg Term) × Term
          extractVars (pi argType (abs varName t)) with extractVars t
          ...                                         | xs , equation = (varName , argType) ∷ xs , equation
          extractVars equation = [] , equation

          addIndices : ℕ → List (String × Arg Term) → Maybe (List VarInfo)
          addIndices ℕ.zero         []        = just []
          addIndices (ℕ.suc countVar) ((varName , argType) ∷ list) =
            map-Maybe (λ varList → record { varName = varName ; varType = argType ; index = countVar }
                                   ∷ varList)
                      (addIndices countVar list)
          addIndices _ _ = nothing

  solve-macro : Term → Term → TC Unit
  solve-macro cring hole = do
    hole′ ← inferType hole >>= normalise
    just (varInfos , equation) ← returnTC (getVarsAndEquation hole′)
      where
        nothing
          → typeError (strErr "Something went wrong when getting the variable names in "
                         ∷ termErr hole′ ∷ [])
    adjustedCring ← returnTC (adjustDeBruijnIndex (length varInfos) cring)
    just (lhs , rhs) ← returnTC (toAlgebraExpression adjustedCring (getArgs equation))
      where
        nothing
          → typeError(
              strErr "Error while trying to buils ASTs for the equation " ∷
              termErr equation ∷ [])
    let solution = constructSolution (length varInfos) varInfos adjustedCring lhs rhs
    unify hole solution

macro
  solve : Term → Term → TC _
  solve = solve-macro

fromℤ : (R : CommRing {ℓ}) → ℤ → fst R
fromℤ = scalar


module Issue2935 where

data ℕ : Set where
  zero : ℕ
  suc  : ℕ → ℕ

bad : ℕ → ℕ
bad zero = zero
bad suc  = zero


module Sessions.Syntax.Types where

open import Level
open import Function

open import Data.Bool
open import Data.List
open import Data.List.All
open import Data.List.Membership.Propositional
open import Data.List.Relation.Binary.Permutation.Inductive
open import Data.List.Relation.Ternary.Interleaving.Propositional as I
open import Data.List.Relation.Ternary.Interleaving.Properties
open import Data.List.Relation.Binary.Equality.Propositional
open import Data.Product
open import Data.Product.Relation.Binary.Pointwise.NonDependent
open import Codata.Thunk as Thunk

open import Algebra
open import Algebra.FunctionProperties

open import Relation.Unary hiding (_∈_; _⊢_)
open import Relation.Nullary
open import Relation.Nullary.Decidable as DecM
open import Relation.Nullary.Product
open import Relation.Binary.PropositionalEquality as P hiding ([_])

open import Relation.Ternary.Separation
open import Relation.Ternary.Separation.Construct.Product
open import Relation.Ternary.Separation.Construct.List

{- Unrestricted-, Session- and Expression types-}
module _ where
  mutual
    -- crefnel types
    infixr 10 _¿_
    data SType : Set where
      _!_ _¿_ : Type → SType → SType
      end     : SType

    data Type : Set where
      unit  : Type
      cref  : SType → Type
      prod  : Type → Type → Type
      _⊸_   : Type → Type → Type

  LCtx = List Type   -- linear contexts
  variable
    Γ Γ' Γ₁ Γ₂ Γ₃ Γ₄ : LCtx

{- Some conventions -}
variable
  a b c   : Type
  α β γ   : SType

{- Duality -}
module _ where

  infixl 1000 _⁻¹
  _⁻¹  : SType → SType
  (a ! β) ⁻¹ = a ¿ β ⁻¹
  (a ¿ β) ⁻¹ = a ! β ⁻¹
  end ⁻¹     = end

  dual-end : ∀ {α} → α ⁻¹ ≡ end → α ≡ end
  dual-end {x ! α} ()
  dual-end {x ¿ α} ()
  dual-end {end} refl = refl

  dual-involutive : ∀ {α} → α ⁻¹ ⁻¹ ≡ α
  dual-involutive {x ! α} = cong (_!_ _) dual-involutive
  dual-involutive {x ¿ α} = cong (_¿_ _) dual-involutive
  dual-involutive {end} = refl


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

module Data.List.Sugar where

open import Data.List.Base
open import Prelude

[_] : A → List A
[ x ] = x ∷ []

pure : A → List A
pure = [_]

_>>=_ : List A → (A → List B) → List B
_>>=_ = flip concatMap

_>>_ : List A → List B → List B
xs >> ys = xs >>= const ys

_<*>_ : List (A → B) → List A → List B
fs <*> xs = do
  f ← fs
  x ← xs
  [ f x ]

guard : Bool → List ⊤
guard false = []
guard true  = [ tt ]


-- Andreas, 2017-04-11, Issue 2543
-- Printing of second non-trivial with-pattern

-- {-# OPTIONS -v interaction.case:100 #-}

data D : Set where
  c : D → D

f : D → D
f y with c y
... | c z with c y
... | q = {!q!}  -- C-c C-c q

-- Was:
-- f y | c z | (c q) = ?

-- Expected:
-- f y | c z | c q = ?


{-# OPTIONS --without-K #-}
module semisimplicial where
  open import Agda.Primitive
  open import Data.Nat
  open import big-endian

  -- N-truncated, augmented semisimplicial types.
  -- Universe polymorphism has not been added yet
  -- (should be very easy, at the cost of even more bloat of type signatures).
  -- There is a canonical bijection between natural numbers (thought of in big-endian encoding) and
  -- simplices of Δ^∞. An *ideal* is a downward-closed set of simplices in this ordering.
  -- Each nontrivial ideal is principal, so the ideals are well-ordered by inclusion,
  -- or equivalently by looking at their last face (the generator of the ideal) and ordering as a natural number.
  -- Not every simplicial subset of a simplex is an ideal, but among the ideals are the simplices themselves
  -- (in binary, a simplex is 11...11), as well as the boundaries of simplices (11...10).
  -- The definition here defines an N-truncated, augmented semismplicial type X by starting with
  -- an N-1 -truncated, augmented semisimplicial type XUnd, and then inductively defining the set of maps
  -- into X from each ideal in turn, until we reach the boundary of the N-simplex.
  -- Then we supply a set of fillers for these boundaries, i.e. the set of N-simplices.
  -- Along the way we keep track of face relationships to know how to glue to get from one ideal to the next.

  -- A truncated augmented simplicial set which has simplices of augmented dimension =< N
  data sSet : ∀ (N : ℕ) → Set₁
  -- Filling data for spheres of augmented dimension N required to promote from sSet N to sSet (suc N)
  record FillData {N : ℕ} (XUnd : sSet N) : Set₁

  -- Build by induction on dimension.
  data sSet where
    Aug : Set → sSet 0
    reedy : ∀ {N : ℕ} → ∀ (XUnd : sSet N) →
            ∀ (XFill : FillData XUnd) →
            sSet (suc N)

  -- Given X and F, tells you the set of ideals in X of the shape "weakly preceeding F"
  -- Note that "a face with N+1 digits" is a sneaky equivalent to "a simplex with at most N+1 digits"
  IdealIn : ∀ {N : ℕ} → ∀ (X : sSet N) →
            ∀ {d : ℕ} → ∀ (F : Face N d) →
            Set
  -- Given X G, x, x', tells you whether x' is the G-shaped face of x.
  -- F' will be the pullback of F by G, but padded out with zeros to have N bits.
  -- (It is not explicitly enforced that F' is the pullback, but the constructors will be such
  -- that no "isFaceOf" relation ever gets built when that is not the case)
  isFaceOf : ∀ {N : ℕ} → ∀ (X : sSet N) →
             ∀ {d : ℕ} → {F : Face N d} → ∀ (x : IdealIn X F ) →
             ∀ {d' : ℕ} → ∀ {F' : Face N d'} → ∀ (x' : IdealIn X F') →
             ∀ {n' : ℕ} → ∀ (G : Face N n') →
             Set

  -- The filling data just needs to tell you how to fill spheres.
  record FillData {N} XUnd where
    constructor fillData
    field
      FillX : IdealIn XUnd (PreDelta+ N) →
                          Set

  -- The following type deals with wrapping issues.
  -- When building an N-truncated semisimplicial type X, we will need to know
  -- when one ideal x in X was constructed from another ideal y in X
  -- via particular constructors. But this constructor could have been applied at *any*
  -- earlier stage k, and so x and y will be wrapped N-k times in the passage from a
  -- k-truncated semisimplicial set to an N-truncated one. Thus we won't be able to
  -- directly look at the constructors used to form y from x.
  -- The type isBuildOf keeps track of this information for us as we wrap things to increasing depth.
  --
  -- Let sx be of shape one bigger than x, let y be the last face of x,
  -- and let sy be of shape one bigger than y.
  -- Then isBuildOf x sx y sy will tell you if sx was built from x by attaching sy at y.
  isBuildOf : ∀ {N : ℕ} → ∀ (X : sSet N) →
              ∀ {d : ℕ} → ∀ {F : Face N d} → ∀ (x : IdealIn X F) →
              ∀ {sd : ℕ} → ∀ {sF : Face N sd} →
              -- ∀ (fsf : isSucF F sF) →
              ∀ (sx : IdealIn X sF) →
              ∀ {e : ℕ} → ∀ {G : Face N e} → ∀ (y : IdealIn X G) →
              ∀ {se : ℕ} → ∀ {sG : Face N se} →
              -- ∀ (gsg : isSucF G sG) →
              ∀ (sy : IdealIn X sG) →
              Set

  --These things will be defined inductively, with special cases for N = 0.
  data IdealIn0 (X0 : Set) :
                ∀ {d : ℕ} → ∀ (F : Face zero d) →
                Set where
    taut0 : ∀ (x : X0) → IdealIn0 X0 (inc emp)

  data isFaceOf0 (X0 : Set) :
                ∀ {d : ℕ} → ∀ {F : Face zero d} → IdealIn0 X0 F →
                ∀ {d' : ℕ} → ∀ {F' : Face zero d'} → IdealIn0 X0 F' →
                ∀ {n' : ℕ} → ∀ (G : Face zero n') →
                Set where
    refl0 : ∀ (x : X0) → isFaceOf0 X0 (taut0 x) (taut0 x) (inc emp)

  data isBuildOf0 (X0 : Set) :
              ∀ {d : ℕ} → ∀ {F : Face 0 d} → ∀ (x : IdealIn0 X0 F) →
              ∀ {sd : ℕ} → ∀ {sF : Face 0 sd} →
              -- ∀ (fsf : isSucF F sF) →
              ∀ (sx : IdealIn0 X0 sF) →
              ∀ {e : ℕ} → ∀ {G : Face 0 e} → ∀ (y : IdealIn0 X0 G) →
              ∀ {se : ℕ} → ∀ {sG : Face 0 se} →
              -- ∀ (gsg : isSucF G sG) →
              ∀ (sy : IdealIn0 X0 sG) →
              Set where

  -- In dimension N+1, the definitions will be more complicated.
  data IdealInN {N : ℕ} (XUnd : sSet N) (XFill : FillData XUnd) :
                ∀ {d : ℕ} → ∀ (F : Face (suc N) d) →
                Set
  data isFaceOfN {N : ℕ} (XUnd : sSet N) (XFill : FillData XUnd) :
                  ∀ {d : ℕ} → ∀ {F : Face (suc N) d} → IdealInN XUnd XFill F →
                  ∀ {d' : ℕ} → ∀ {F' : Face (suc N) d'} → IdealInN XUnd XFill F' →
                  ∀ {n' : ℕ} → ∀ (G : Face (suc N) n') →
                  Set

  data isBuildOfN {N : ℕ} (XUnd : sSet N) (XFill : FillData XUnd) :
              ∀ {d : ℕ} → ∀ {F : Face (suc N) d} → ∀ (x : IdealInN XUnd XFill F) →
              ∀ {sd : ℕ} → ∀ {sF : Face (suc N) sd} →
              -- ∀ (fsf : isSucF F sF) →
              ∀ (sx : IdealInN XUnd XFill sF) →
              ∀ {e : ℕ} → ∀ {G : Face (suc N) e} → ∀ (y : IdealInN XUnd XFill G) →
              ∀ {se : ℕ} → ∀ {sG : Face (suc N) se} →
              -- ∀ (gsg : isSucF G sG) →
              ∀ (sy : IdealInN XUnd XFill sG) →
              Set

  --Inductive definitions of all of this data.
  IdealIn (Aug X0) = IdealIn0 X0
  IdealIn (reedy XUnd XFill) = IdealInN XUnd XFill

  isFaceOf (Aug X0) = isFaceOf0 X0
  isFaceOf (reedy XUnd XFill) = isFaceOfN XUnd XFill

  -- isBuildOf (reedy XUnd XFill) = isBuildOfN XUnd XFill
  isBuildOf (Aug X0) = isBuildOf0 X0
  isBuildOf (reedy XUnd XFill) = isBuildOfN XUnd XFill

  data IdealInN {N} XUnd XFill where
    --Inherit ideals from the previous dimension. Need to tack on a leading zero.
    oldN : ∀ {d : ℕ} → ∀ {F : Face N d} → ∀ (x : IdealIn XUnd F) →
            IdealInN XUnd XFill (0x F)
    -- Promote the ideal given by filling a sphere from the previous dimension.
    fillN : ∀ {x : IdealIn XUnd (PreDelta+ N)} → ∀ (z : FillData.FillX XFill x) →
             IdealInN XUnd XFill (0x (inc (Delta+ N)))

    --Build a new closed ideal from an open ideal and some previously-constructed filling data.
    -- sF is required to be a simplex, so that it is a *new* thing to build and not already previously constructed.
    -- x is of shape "strictly below sF".
    -- y is the sF-face of x, i.e. the boundary of the next simplex to be added to complete to "weakly below sF".
    -- so y ought to be of shape "boundary of a simplex", but this is not enforced explicitly.
    -- sy is an ideal (so should be in fact a simplex) filling y.
    -- We obtain buildN z xy of shape "weakly below S" by gluing z onto x along y.
    buildN :  ∀ {d : ℕ} → ∀ {F : Face (suc N) d} → ∀ (x : IdealInN XUnd XFill F) →
              ∀ {sd : ℕ} → ∀ {sF : Simp (suc N) (suc sd)} → ∀ (fsf : isSucF F (inc sF)) →
              ∀ {e : ℕ} → ∀ {G : Face (suc N) e} → ∀ {y : IdealInN XUnd XFill G} →  ∀ (xy : isFaceOfN XUnd XFill x y (inc sF)) →
              ∀ {se : ℕ} → ∀ {sG : Face (suc N) (suc se)} → ∀ (gsg : isSucF G sG) →
              ∀ (sy : IdealInN XUnd XFill sG) →
              ∀ (ysy : isBuildOfN XUnd XFill y sy y sy) →
              IdealInN XUnd XFill (inc sF)

  data isFaceOfN {N} XUnd XFill where
    --Inherit face relations from the previous dimension. Need to tack on a leading zero.
    -- If x' is a G - face of x in the previous dimension,
    -- then oldN x' is a 0x G - face of oldN x, and also a 1x G -face of oldN x.
    oldOld0N : ∀ {d : ℕ} → ∀ {F : Face N d} → ∀ {d' : ℕ} → ∀ {F' : Face N d'} → ∀ {n' : ℕ} → ∀ {G : Face N n'} →
                          ∀ {x : IdealIn XUnd F} → ∀ {x' : IdealIn XUnd F'} → ∀ (xx' : isFaceOf XUnd x x' G) →
              isFaceOfN XUnd XFill (oldN x) (oldN x') (0x G)
    oldOld1N : ∀ {d : ℕ} → ∀ {F : Face N d} → ∀ {d' : ℕ} → ∀ {F' : Face N d'} → ∀ {n' : ℕ} → ∀ {G : Face N n'} →
                          ∀ {x : IdealIn XUnd F} → ∀ {x' : IdealIn XUnd F'} → ∀ (xx' : isFaceOf XUnd x x' G) →
              isFaceOfN XUnd XFill (oldN x) (oldN x') (inc (1x G))

    -- When filling a top-dimensional sphere from the previous dimension, need to inherit faces from the boundary being filled.
    -- If x is an N-sphere filled by z, and x' is an old G-face of x,
    -- then oldN x' is a 0x G - face of fillN z, and also a 1x G - face of fillN z.
    oldFill0N : ∀ {x : IdealIn XUnd (PreDelta+ N)} → ∀ (z : FillData.FillX XFill x) →
               ∀ {d : ℕ} → ∀ {F : Face N d} → ∀ {x' : IdealIn XUnd F} → ∀ {n' : ℕ} → ∀ {G : Face N n'} → ∀ (xx' : isFaceOf XUnd x x' G) →
               isFaceOfN XUnd XFill (fillN z)  (oldN x') (0x G)
    oldFill1N : ∀ {x : IdealIn XUnd (PreDelta+ N)} → ∀ (z : FillData.FillX XFill x) →
               ∀ {d : ℕ} → ∀ {F : Face N d} → ∀ {x' : IdealIn XUnd F} → ∀ {n' : ℕ} → ∀ {G : Face N n'} → ∀ (xx' : isFaceOf XUnd x x' G) →
               isFaceOfN XUnd XFill (fillN z)  (oldN x') (inc (1x G))

    -- When filling a top-dimensional sphere from the previous dimension, need to put in a reflexivity face relation.
    -- There are actually two -- one for the face 111111 and one for the face 011111
    reflFill0N : ∀ {x : IdealIn XUnd (PreDelta+ N)} → ∀ (z : FillData.FillX XFill x) →
                isFaceOfN XUnd XFill (fillN z) (fillN z) (0x (inc (Delta+ N)))
    reflFill1N : ∀ {x : IdealIn XUnd (PreDelta+ N)} → ∀ (z : FillData.FillX XFill x) →
                isFaceOfN XUnd XFill (fillN z) (fillN z) (inc (1x (inc (Delta+ N))))

    -- When building a new ideal, need to inherit faces from the open ideal being filled.
    -- This function takes 21 arguments, 7 of them explicit. I believe it is the second-longest type signature in the file.
    -- sF is required to be a simplex, so that it is a *new* thing to build and not already previously constructed.
    -- x is of shape "strictly below sF".
    -- y is the sF-face of x, i.e. the boundary of the next simplex to be added to complete to "weakly below sF".
    -- so y ought to be of shape "boundary of a simplex", but this is not enforced explicitly.
    -- sy is an ideal (so should be in fact a simplex) filling y.
    -- x' is a face of x.
    -- conclude that, when you glue sy to x along y, you have x' as a face.
    oldBuildN : ∀ {d : ℕ} → ∀ {F : Face (suc N) d} → ∀ (x : IdealInN XUnd XFill F) →
              ∀ {sd : ℕ} → ∀ {sF : Simp (suc N) (suc sd)} → ∀ (fsf : isSucF F (inc sF)) →
              ∀ {e : ℕ} → ∀ {G : Face (suc N) e} → ∀ {y : IdealInN XUnd XFill G} →  ∀ (xy : isFaceOfN XUnd XFill x y (inc sF)) →
              ∀ {se : ℕ} → ∀ {sG : Face (suc N) (suc se)} → ∀ (gsg : isSucF G sG) →
              ∀ (sy : IdealInN XUnd XFill sG) →
              ∀ (ysy : isBuildOfN XUnd XFill y sy y sy) →
              ∀ {d' : ℕ} → ∀ {F' : Face (suc N) d'} →  ∀ {x' : IdealInN XUnd XFill F'} →
                             ∀ {n' : ℕ} → ∀ {H : Face (suc N) n'} → ∀ (xx' : isFaceOfN XUnd XFill x x' H) →
              isFaceOfN XUnd XFill (buildN x fsf xy gsg sy ysy) x' H

    -- When building a new ideal, need to put in "mixed" faces, built from faces of the open ideal being filled and the filling data.
    -- This constructor takes 32 arguments, 13 of them explicit. I believe that's the longest in the file.
    -- sF is required to be a simplex, so that it is a *new* thing to build and not already previously constructed.
    -- x is of shape "strictly below sF".
    -- y is the sF-face of x, i.e. the boundary of the next simplex to be added to complete to "weakly below sF".
    -- so y ought to be of shape "boundary of a simplex", but this is not enforced explicitly.
    -- sy is an ideal (so should be in fact a simplex) filling y.
    -- x' is a face of x.
    -- conclude that when you glue sy to x along y, then sx' is a face.
    mixBuildN : ∀ {d : ℕ} → ∀ {F : Face (suc N) d} → ∀ (x : IdealInN XUnd XFill F) →
              ∀ {sd : ℕ} → ∀ {sF : Simp (suc N) (suc sd)} → ∀ (fsf : isSucF F (inc sF)) →
              ∀ {e : ℕ} → ∀ {G : Face (suc N) e} → ∀ {y : IdealInN XUnd XFill G} →  ∀ (xy : isFaceOfN XUnd XFill x y (inc sF)) →
              ∀ {se : ℕ} → ∀ {sG : Face (suc N) (suc se)} → ∀ (gsg : isSucF G sG) →
              ∀ (sy : IdealInN XUnd XFill sG) →
              ∀ (ysy : isBuildOfN XUnd XFill y sy y sy) →
              ∀ {d' : ℕ} → ∀ {F' : Face (suc N) d'} →  ∀ {x' : IdealInN XUnd XFill F'} →
                             ∀ {n' : ℕ} → ∀ {H : Face (suc N) n'} → ∀ (xx' : isFaceOfN XUnd XFill x x' H) →
              ∀ {sd' : ℕ} → ∀ {sF' : Simp (suc N) (suc sd)} → ∀ (f'sf' : isSucF F' (inc sF')) →
              ∀ (x'y : isFaceOfN XUnd XFill x' y (inc sF')) →
              ∀ {sx' : IdealInN XUnd XFill (inc sF')} → ∀ (x'sx'ysy : isBuildOfN XUnd XFill x' sx' y sy) →
              ∀ {n'' : ℕ} → ∀ {F'' : Face n' n''} → ∀ (shf'' : isPB (inc sF) H F'') →
              ∀ {00F'' : Face (suc N) n''} → ∀ (00f'' : isPadOf F'' 00F'') →
              isFaceOfN XUnd XFill (buildN x fsf xy gsg sy ysy) sx' 00F''

  data isBuildOfN {N} XUnd XFill where
    -- Carry forward the old build relations from XUnd.
    oldIsBuildN : ∀ {d : ℕ} → ∀ {F : Face N d} → ∀ (x : IdealIn XUnd F) →
              ∀ {sd : ℕ} → ∀ {sF : Face N (suc sd)} → ∀ (fsf : isSucF F sF) →
              ∀ (sx : IdealIn XUnd sF) →
              ∀ {e : ℕ} → ∀ {G : Face N e} → ∀ (y : IdealIn XUnd G) →
              ∀ {se : ℕ} → ∀ {sG : Face N (suc se)} → ∀ (gsg : isSucF G sG) →
              ∀ (sy : IdealIn XUnd sG) →
              isBuildOf XUnd x sx y sy →
              isBuildOfN XUnd XFill (oldN x) (oldN sx) (oldN y) (oldN sy)
    -- When filling an N-boundary, we have a reflexive build relationship.
    fillIsBuildN : ∀ {x : IdealIn XUnd (PreDelta+ N)} → ∀ (z : FillData.FillX XFill x) →
                 isBuildOfN XUnd XFill (oldN x) (fillN z) (oldN x) (fillN z)
    -- When we build a new ideal, record it here.
    buildIsBuildN : ∀ {d : ℕ} → ∀ {F : Face (suc N) d} → ∀ (x : IdealInN XUnd XFill F) →
              ∀ {sd : ℕ} → ∀ {sF : Simp (suc N) (suc sd)} → ∀ (fsf : isSucF F (inc sF)) →
              ∀ {e : ℕ} → ∀ {G : Face (suc N) e} → ∀ {y : IdealInN XUnd XFill G} →  ∀ (xy : isFaceOfN XUnd XFill x y (inc sF)) →
              ∀ {se : ℕ} → ∀ {sG : Face (suc N) (suc se)} → ∀ (gsg : isSucF G sG) →
              ∀ (sy : IdealInN XUnd XFill sG) →
              ∀ (ysy : isBuildOfN XUnd XFill y sy y sy) →
              isBuildOfN XUnd XFill x (buildN x fsf xy gsg sy ysy) y sy