------------------------------------------------------------------------------
-- Test the consistency of PA.Axiomatic.Standard.Base
------------------------------------------------------------------------------

{-# OPTIONS --exact-split              #-}
{-# OPTIONS --no-sized-types           #-}
{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --without-K                #-}

-- In the module PA.Axiomatic.Standard.Base we declare Agda postulates
-- as first-order logic axioms. We test if it is possible to prove an
-- unprovable theorem from these axioms.

module PA.Axiomatic.Standard.Base.Consistency.Axioms where

open import PA.Axiomatic.Standard.Base

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

postulate impossible : (m n : ℕ) → m ≡ n
{-# ATP prove impossible #-}


------------------------------------------------------------------------
-- Parallel substitutions (defined as functions)
------------------------------------------------------------------------

open import Data.Universe.Indexed

module deBruijn.Substitution.Function.Basics
  {i u e} {Uni : IndexedUniverse i u e} where

import Axiom.Extensionality.Propositional as E
import deBruijn.Context; open deBruijn.Context Uni
open import Function using (id; _∘_; _$_)
open import Level using (_⊔_)
open import Relation.Binary.PropositionalEquality as P using (_≡_)

open P.≡-Reasoning

-- Substitutions, represented as functions from variables to terms.

Sub : ∀ {t} (T : Term-like t) {Γ Δ : Ctxt} → Γ ⇨̂ Δ → Set _
Sub T = [ Var ⟶ T ]

private
 module Dummy {t} {T : Term-like t} where

  open Term-like T

  -- Interpretation of substitutions: context morphisms.

  ⟦_⟧⇨ : ∀ {Γ Δ} {ρ̂ : Γ ⇨̂ Δ} → Sub T ρ̂ → Γ ⇨̂ Δ
  ⟦_⟧⇨ {ρ̂ = ρ̂} _ = ρ̂

  -- Application of substitutions to types.

  infixl 8 _/I_ _/_

  _/I_ : ∀ {Γ Δ i} {ρ̂ : Γ ⇨̂ Δ} → IType Γ i → Sub T ρ̂ → IType Δ i
  σ /I ρ = σ /̂I ⟦ ρ ⟧⇨

  _/_ : ∀ {Γ Δ} {ρ̂ : Γ ⇨̂ Δ} → Type Γ → Sub T ρ̂ → Type Δ
  σ / ρ = σ /̂ ⟦ ρ ⟧⇨

  -- Application of substitutions to values.

  infixl 8 _/Val_

  _/Val_ : ∀ {Γ Δ σ} {ρ̂ : Γ ⇨̂ Δ} →
           Value Γ σ → Sub T ρ̂ → Value Δ (σ /̂ ρ̂)
  v /Val ρ = v /̂Val ⟦ ρ ⟧⇨

  -- Application of substitutions to context extensions.

  infixl 8 _/⁺_ _/₊_

  _/⁺_ : ∀ {Γ Δ} {ρ̂ : Γ ⇨̂ Δ} → Ctxt⁺ Γ → Sub T ρ̂ → Ctxt⁺ Δ
  Γ⁺ /⁺ ρ = Γ⁺ /̂⁺ ⟦ ρ ⟧⇨

  _/₊_ : ∀ {Γ Δ} {ρ̂ : Γ ⇨̂ Δ} → Ctxt₊ Γ → Sub T ρ̂ → Ctxt₊ Δ
  Γ₊ /₊ ρ = Γ₊ /̂₊ ⟦ ρ ⟧⇨

  -- Application of substitutions to variables.

  infixl 8 _/∋_ _/∋-lemma_

  _/∋_ : ∀ {Γ Δ σ} {ρ̂ : Γ ⇨̂ Δ} → Γ ∋ σ → (ρ : Sub T ρ̂) → Δ ⊢ σ / ρ
  x /∋ ρ = ρ · x

  _/∋-lemma_ : ∀ {Γ Δ σ} {ρ̂ : Γ ⇨̂ Δ} (x : Γ ∋ σ) (ρ : Sub T ρ̂) →
               x /̂∋ ⟦ ρ ⟧⇨ ≅-Value ⟦ x /∋ ρ ⟧
  x /∋-lemma ρ = corresponds ρ x

  app∋ : ∀ {Γ Δ} {ρ̂ : Γ ⇨̂ Δ} → Sub T ρ̂ → [ Var ⟶ T ] ρ̂
  app∋ ρ = record
    { function    = λ _ x → x /∋       ρ
    ; corresponds = λ _ x → x /∋-lemma ρ
    }

  -- Empty substitution.

  ε⇨ : ∀ {Δ} → Sub T ε̂[ Δ ]
  ε⇨ = record { function = λ _ (); corresponds = λ _ () }

  ε⇨[_] : ∀ Δ → Sub T ε̂[ Δ ]
  ε⇨[ _ ] = ε⇨

  -- Extends a substitution with another term.

  private

    -- This function is not local to _▻⇨[_]_ because a proof below
    -- fails to type check if the function depends on the proof
    -- component of the substitution.

    fun : ∀ {Γ Δ σ} {ρ̂ : Γ ⇨̂ Δ} →
          (∀ {τ} → Γ ∋ τ → Δ ⊢ τ /̂ ρ̂) →
          (t : Δ ⊢ σ /̂ ρ̂) →
          ∀ {τ} → Γ ▻ σ ∋ τ → Δ ⊢ τ /̂ (ρ̂ ▻̂ ⟦ t ⟧)
    fun f t zero    = t
    fun f t (suc x) = f x

  infixl 5 _▻⇨_ _▻⇨[_]_

  _▻⇨[_]_ : ∀ {Γ Δ} {ρ̂ : Γ ⇨̂ Δ}
            (ρ : Sub T ρ̂) σ (t : Δ ⊢ σ / ρ) → Sub T (ρ̂ ▻̂[ σ ] ⟦ t ⟧)
  _▻⇨[_]_ {Γ} {Δ} {ρ̂} ρ σ t =
    record { function = λ _ → fun (_·_ ρ) t; corresponds = λ _ → corr }
    where
    abstract
      corr : ∀ {τ} (x : Γ ▻ σ ∋ τ) →
             x /̂∋ (ρ̂ ▻̂ ⟦ t ⟧) ≅-Value ⟦ fun (_·_ ρ) t x ⟧
      corr zero    = P.refl
      corr (suc x) = x /∋-lemma ρ

  _▻⇨_ : ∀ {Γ Δ σ} {ρ̂ : Γ ⇨̂ Δ}
         (ρ : Sub T ρ̂) (t : Δ ⊢ σ / ρ) → Sub T (ρ̂ ▻̂[ σ ] ⟦ t ⟧)
  ρ ▻⇨ t = ρ ▻⇨[ _ ] t

  -- The tail of a nonempty substitution.

  tail : ∀ {Γ Δ σ} {ρ̂ : Γ ▻ σ ⇨̂ Δ} → Sub T ρ̂ → Sub T (t̂ail ρ̂)
  tail ρ = ρ [∘] weaken∋

  -- The head of a nonempty substitution.

  head : ∀ {Γ Δ σ} {ρ̂ : Γ ▻ σ ⇨̂ Δ} (ρ : Sub T ρ̂) → Δ ⊢ σ / tail ρ
  head ρ = zero /∋ ρ

  head-lemma : ∀ {Γ Δ σ} {ρ̂ : Γ ▻ σ ⇨̂ Δ} (ρ : Sub T ρ̂) →
               ĥead ⟦ ρ ⟧⇨ ≅-Value ⟦ head ρ ⟧
  head-lemma ρ = zero /∋-lemma ρ

  -- Equality of substitutions.

  infix 4 _≅-⇨_

  _≅-⇨_ : ∀ {Γ₁ Δ₁} {ρ̂₁ : Γ₁ ⇨̂ Δ₁} (ρ₁ : Sub T ρ̂₁)
            {Γ₂ Δ₂} {ρ̂₂ : Γ₂ ⇨̂ Δ₂} (ρ₂ : Sub T ρ̂₂) → Set _
  _≅-⇨_ = _≅-⟶_

  -- Certain uses of substitutivity can be removed.

  drop-subst-Sub :
    ∀ {a} {A : Set a} {x₁ x₂ : A} {Γ Δ}
    (f : A → Γ ⇨̂ Δ) {ρ} (eq : x₁ ≡ x₂) →
    P.subst (λ x → Sub T (f x)) eq ρ ≅-⇨ ρ
  drop-subst-Sub f P.refl = [ P.refl ]

  -- Some congruence lemmas.

  ε⇨-cong : ∀ {Δ₁ Δ₂} → Δ₁ ≅-Ctxt Δ₂ → ε⇨[ Δ₁ ] ≅-⇨ ε⇨[ Δ₂ ]
  ε⇨-cong P.refl = [ P.refl ]

  ▻⇨-cong :
    ∀ {Γ₁ Δ₁ σ₁} {ρ̂₁ : Γ₁ ⇨̂ Δ₁} {ρ₁ : Sub T ρ̂₁} {t₁ : Δ₁ ⊢ σ₁ / ρ₁}
      {Γ₂ Δ₂ σ₂} {ρ̂₂ : Γ₂ ⇨̂ Δ₂} {ρ₂ : Sub T ρ̂₂} {t₂ : Δ₂ ⊢ σ₂ / ρ₂} →
    σ₁ ≅-Type σ₂ → ρ₁ ≅-⇨ ρ₂ → t₁ ≅-⊢ t₂ →
    ρ₁ ▻⇨[ σ₁ ] t₁ ≅-⇨ ρ₂ ▻⇨[ σ₂ ] t₂
  ▻⇨-cong {ρ₁ = _ , _} {ρ₂ = ._ , _} P.refl [ P.refl ] P.refl =
    [ P.refl ]

  ⟦⟧⇨-cong : ∀ {Γ₁ Δ₁} {ρ̂₁ : Γ₁ ⇨̂ Δ₁} {ρ₁ : Sub T ρ̂₁}
               {Γ₂ Δ₂} {ρ̂₂ : Γ₂ ⇨̂ Δ₂} {ρ₂ : Sub T ρ̂₂} →
             ρ₁ ≅-⇨ ρ₂ → ⟦ ρ₁ ⟧⇨ ≅-⇨̂ ⟦ ρ₂ ⟧⇨
  ⟦⟧⇨-cong {ρ₁ = _ , _} {ρ₂ = ._ , _} [ P.refl ] = P.refl

  /I-cong :
    ∀ {i}
      {Γ₁ Δ₁} {ρ̂₁ : Γ₁ ⇨̂ Δ₁} {σ₁ : IType Γ₁ i} {ρ₁ : Sub T ρ̂₁}
      {Γ₂ Δ₂} {ρ̂₂ : Γ₂ ⇨̂ Δ₂} {σ₂ : IType Γ₂ i} {ρ₂ : Sub T ρ̂₂} →
    σ₁ ≅-IType σ₂ → ρ₁ ≅-⇨ ρ₂ → σ₁ /I ρ₁ ≅-IType σ₂ /I ρ₂
  /I-cong {ρ₁ = _ , _} {ρ₂ = ._ , _} P.refl [ P.refl ] = P.refl

  /-cong : ∀ {Γ₁ Δ₁ σ₁} {ρ̂₁ : Γ₁ ⇨̂ Δ₁} {ρ₁ : Sub T ρ̂₁}
             {Γ₂ Δ₂ σ₂} {ρ̂₂ : Γ₂ ⇨̂ Δ₂} {ρ₂ : Sub T ρ̂₂} →
           σ₁ ≅-Type σ₂ → ρ₁ ≅-⇨ ρ₂ → σ₁ / ρ₁ ≅-Type σ₂ / ρ₂
  /-cong {ρ₁ = _ , _} {ρ₂ = ._ , _} P.refl [ P.refl ] = P.refl

  /⁺-cong : ∀ {Γ₁ Δ₁ Γ⁺₁} {ρ̂₁ : Γ₁ ⇨̂ Δ₁} {ρ₁ : Sub T ρ̂₁}
              {Γ₂ Δ₂ Γ⁺₂} {ρ̂₂ : Γ₂ ⇨̂ Δ₂} {ρ₂ : Sub T ρ̂₂} →
            Γ⁺₁ ≅-Ctxt⁺ Γ⁺₂ → ρ₁ ≅-⇨ ρ₂ → Γ⁺₁ /⁺ ρ₁ ≅-Ctxt⁺ Γ⁺₂ /⁺ ρ₂
  /⁺-cong {ρ₁ = _ , _} {ρ₂ = ._ , _} P.refl [ P.refl ] = P.refl

  /₊-cong : ∀ {Γ₁ Δ₁ Γ₊₁} {ρ̂₁ : Γ₁ ⇨̂ Δ₁} {ρ₁ : Sub T ρ̂₁}
              {Γ₂ Δ₂ Γ₊₂} {ρ̂₂ : Γ₂ ⇨̂ Δ₂} {ρ₂ : Sub T ρ̂₂} →
            Γ₊₁ ≅-Ctxt₊ Γ₊₂ → ρ₁ ≅-⇨ ρ₂ → Γ₊₁ /₊ ρ₁ ≅-Ctxt₊ Γ₊₂ /₊ ρ₂
  /₊-cong {ρ₁ = _ , _} {ρ₂ = ._ , _} P.refl [ P.refl ] = P.refl

  /∋-cong : ∀ {Γ₁ Δ₁ σ₁} {x₁ : Γ₁ ∋ σ₁} {ρ̂₁ : Γ₁ ⇨̂ Δ₁} {ρ₁ : Sub T ρ̂₁}
              {Γ₂ Δ₂ σ₂} {x₂ : Γ₂ ∋ σ₂} {ρ̂₂ : Γ₂ ⇨̂ Δ₂} {ρ₂ : Sub T ρ̂₂} →
            x₁ ≅-∋ x₂ → ρ₁ ≅-⇨ ρ₂ → x₁ /∋ ρ₁ ≅-⊢ x₂ /∋ ρ₂
  /∋-cong {ρ₁ = _ , _} {ρ₂ = ._ , _} P.refl [ P.refl ] = P.refl

  tail-cong : ∀ {Γ₁ Δ₁ σ₁} {ρ̂₁ : Γ₁ ▻ σ₁ ⇨̂ Δ₁} {ρ₁ : Sub T ρ̂₁}
                {Γ₂ Δ₂ σ₂} {ρ̂₂ : Γ₂ ▻ σ₂ ⇨̂ Δ₂} {ρ₂ : Sub T ρ̂₂} →
              ρ₁ ≅-⇨ ρ₂ → tail ρ₁ ≅-⇨ tail ρ₂
  tail-cong {ρ₁ = _ , _} {ρ₂ = ._ , _} [ P.refl ] = [ P.refl ]

  head-cong : ∀ {Γ₁ Δ₁ σ₁} {ρ̂₁ : Γ₁ ▻ σ₁ ⇨̂ Δ₁} {ρ₁ : Sub T ρ̂₁}
                {Γ₂ Δ₂ σ₂} {ρ̂₂ : Γ₂ ▻ σ₂ ⇨̂ Δ₂} {ρ₂ : Sub T ρ̂₂} →
              ρ₁ ≅-⇨ ρ₂ → head ρ₁ ≅-⊢ head ρ₂
  head-cong {ρ₁ = _ , _} {ρ₂ = ._ , _} [ P.refl ] = P.refl

  abstract

    -- Some eta-laws, based on the assumption of extensionality.

    -- Eta in empty contexts.

    ηε : E.Extensionality (i ⊔ u ⊔ e) (i ⊔ u ⊔ e ⊔ t) →
         ∀ {Δ} {ρ̂ : ε ⇨̂ Δ} (ρ : Sub T ρ̂) → ρ ≅-⇨ ε⇨[ Δ ]
    ηε ext ρ = extensional-equality₁ ext P.refl (λ ())

    -- Eta in non-empty contexts.

    η▻ : E.Extensionality (i ⊔ u ⊔ e) (i ⊔ u ⊔ e ⊔ t) →
         ∀ {Γ Δ σ} {ρ̂ : Γ ▻ σ ⇨̂ Δ} (ρ : Sub T ρ̂) →
         ρ ≅-⇨ tail ρ ▻⇨[ σ ] head ρ
    η▻ ext {Γ} {σ = σ} {ρ̂} ρ = extensional-equality₂ ext lemma₁ lemma₂
      where
      open Term-like Var using () renaming (_≅-⊢_ to _≅-∋′_)

      lemma₁ : ρ̂ ≅-⇨̂ t̂ail ρ̂ ▻̂[ σ ] ⟦ head ρ ⟧
      lemma₁ = begin
        [ ρ̂                   ]  ≡⟨ P.refl ⟩
        [ t̂ail ρ̂ ▻̂ ĥead ρ̂     ]  ≡⟨ ▻̂-cong P.refl P.refl (head-lemma ρ) ⟩
        [ t̂ail ρ̂ ▻̂ ⟦ head ρ ⟧ ]  ∎

      lemma₂′ : ∀ {τ} (x : Γ ▻ σ ∋ τ) →
                x /∋ ρ ≅-⊢ x /∋ (tail ρ ▻⇨[ σ ] head ρ)
      lemma₂′ zero    = P.refl
      lemma₂′ (suc x) = P.refl

      lemma₂ : ∀ {τ₁} {x₁ : Γ ▻ σ ∋ τ₁}
                 {τ₂} {x₂ : Γ ▻ σ ∋ τ₂} →
               x₁ ≅-∋′ x₂ → x₁ /∋ ρ ≅-⊢ x₂ /∋ (tail ρ ▻⇨[ σ ] head ρ)
      lemma₂ {x₁ = x} P.refl = lemma₂′ x

    -- Two substitutions are equal if their indices are equal and
    -- their projections are pairwise equal (assuming extensionality).

    extensionality :
      E.Extensionality (i ⊔ u ⊔ e) (i ⊔ u ⊔ e ⊔ t) →
      ∀ {Γ Δ₁} {ρ̂₁ : Γ ⇨̂ Δ₁} {ρ₁ : Sub T ρ̂₁}
          {Δ₂} {ρ̂₂ : Γ ⇨̂ Δ₂} {ρ₂ : Sub T ρ̂₂} →
      Δ₁ ≅-Ctxt Δ₂ → (∀ {σ} (x : Γ ∋ σ) → x /∋ ρ₁ ≅-⊢ x /∋ ρ₂) →
      ρ₁ ≅-⇨ ρ₂
    extensionality ext {ε} {ρ₁ = ρ₁} {ρ₂ = ρ₂} P.refl hyp =
      ρ₁  ≅-⟶⟨ ηε ext ρ₁ ⟩
      ε⇨  ≅-⟶⟨ sym-⟶ $ ηε ext ρ₂ ⟩
      ρ₂  ∎-⟶
    extensionality ext {Γ ▻ σ} {ρ₁ = ρ₁} {ρ₂ = ρ₂} P.refl hyp =
      ρ₁                  ≅-⟶⟨ η▻ ext ρ₁ ⟩
      tail ρ₁ ▻⇨ head ρ₁  ≅-⟶⟨ ▻⇨-cong P.refl
                                       (extensionality ext P.refl (hyp ∘ suc))
                                       (hyp zero) ⟩
      tail ρ₂ ▻⇨ head ρ₂  ≅-⟶⟨ sym-⟶ $ η▻ ext ρ₂ ⟩
      ρ₂                  ∎-⟶

open Dummy public


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

open import lib.Basics
open import lib.cubical.Square
open import lib.types.Bool
open import lib.types.Coproduct
open import lib.types.FunctionSeq
open import lib.types.Paths
open import lib.types.Pointed
open import lib.types.Span
open import lib.types.Pushout
open import lib.types.Sigma

module lib.types.Smash where

module _ {i j} (X : Ptd i) (Y : Ptd j) where

  ⊙∧-span : ⊙Span
  ⊙∧-span = ⊙span (X ⊙× Y) ⊙Bool (X ⊙⊔ Y)
    (⊔-rec (_, pt Y) (pt X ,_) , idp)
    (⊙⊔-fmap {Y = Y} ⊙cst ⊙cst)

  ∧-span : Span
  ∧-span = ⊙Span-to-Span ⊙∧-span

  abstract
    _∧_ : Type (lmax i j)
    _∧_ = Pushout ∧-span
  Smash = _∧_

module _ {i j} {X : Ptd i} {Y : Ptd j} where

  abstract
    smin : de⊙ X → de⊙ Y → Smash X Y
    smin x y = left (x , y)

module _ {i j} (X : Ptd i) (Y : Ptd j) where

  _⊙∧_ = ptd (X ∧ Y) (smin (pt X) (pt Y))
  ⊙Smash = _⊙∧_

module _ {i j} {X : Ptd i} {Y : Ptd j} where

  abstract

    smbasel : Smash X Y
    smbasel = right true

    smbaser : Smash X Y
    smbaser = right false

    smgluel : (x : de⊙ X) → smin x (pt Y) == smbasel
    smgluel x = glue (inl x)

    smgluer : (y : de⊙ Y) → smin (pt X) y == smbaser
    smgluer y = glue (inr y)

  ∧-norm-l-seq : (x : de⊙ X) → smin x (pt Y) =-= smin (pt X) (pt Y)
  ∧-norm-l-seq x = smgluel x ◃∙ ! (smgluel (pt X)) ◃∎

  ∧-norm-l : (x : de⊙ X) → smin x (pt Y) == smin (pt X) (pt Y)
  ∧-norm-l x = ↯ (∧-norm-l-seq x)

  ∧-norm-r-seq : (y : de⊙ Y) → smin (pt X) y =-= smin (pt X) (pt Y)
  ∧-norm-r-seq y = smgluer y ◃∙ ! (smgluer (pt Y)) ◃∎

  ∧-norm-r : (y : de⊙ Y) → smin (pt X) y == smin (pt X) (pt Y)
  ∧-norm-r y = ↯ (∧-norm-r-seq y)

  ∧-⊙inl : de⊙ Y → X ⊙→ ⊙Smash X Y
  ∧-⊙inl y = (λ x → smin x y) , smgluer y ∙ ! (smgluer (pt Y))

  ∧-⊙inr : de⊙ X → Y ⊙→ ⊙Smash X Y
  ∧-⊙inr x = (λ y → smin x y) , smgluel x ∙ ! (smgluel (pt X))

  ∧-glue-lr : smbasel == smbaser
  ∧-glue-lr = ! (smgluel (pt X)) ∙ smgluer (pt Y)

  ap-smin-l : {a b : de⊙ X} (p : a == b)
    → ap (λ x → smin x (pt Y)) p == smgluel a ∙ ! (smgluel b)
  ap-smin-l = ap-null-homotopic (λ x → smin x (pt Y)) smgluel

  ap-smin-r : {a b : de⊙ Y} (p : a == b)
    → ap (smin (pt X)) p == smgluer a ∙ ! (smgluer b)
  ap-smin-r = ap-null-homotopic (λ y → smin (pt X) y) smgluer

module _ {i j} {X : Ptd i} {Y : Ptd j} where

  module SmashElim {k} {P : Smash X Y → Type k}
    (smin* : (x : de⊙ X) (y : de⊙ Y) → P (smin x y))
    (smbasel* : P smbasel) (smbaser* : P smbaser)
    (smgluel* : (x : de⊙ X) → smin* x (pt Y) == smbasel* [ P ↓ smgluel x ])
    (smgluer* : (y : de⊙ Y) → smin* (pt X) y == smbaser* [ P ↓ smgluer y ]) where

    -- It would be better to encapsulate the repetition in the following definitions in a
    -- private module as follows. Unfortunately, this is not possible when the smash
    -- datatype is declared abstract.
    {-private
      module M = PushoutElim
        (uncurry smin*)
        (Coprod-elim (λ _ → smbasel*) (λ _ → smbaser*))
        (Coprod-elim smgluel* smgluer*)-}

    abstract
      f : (s : X ∧ Y) → P s
      f = PushoutElim.f (uncurry smin*) (Coprod-elim (λ _ → smbasel*) (λ _ → smbaser*)) (Coprod-elim smgluel* smgluer*)

      smin-β : ∀ x y → f (smin x y) ↦ smin* x y
      smin-β x y = PushoutElim.left-β (uncurry smin*) (Coprod-elim (λ _ → smbasel*) (λ _ → smbaser*)) (Coprod-elim smgluel* smgluer*) (x , y)
      {-# REWRITE smin-β #-}

      smbasel-β : f smbasel ↦ smbasel*
      smbasel-β = PushoutElim.right-β (uncurry smin*) (Coprod-elim (λ _ → smbasel*) (λ _ → smbaser*)) (Coprod-elim smgluel* smgluer*) true
      {-# REWRITE smbasel-β #-}

      smbaser-β : f smbaser ↦ smbaser*
      smbaser-β = PushoutElim.right-β (uncurry smin*) (Coprod-elim (λ _ → smbasel*) (λ _ → smbaser*)) (Coprod-elim smgluel* smgluer*) false
      {-# REWRITE smbaser-β #-}

      smgluel-β : ∀ (x : de⊙ X) → apd f (smgluel x) == smgluel* x
      smgluel-β = PushoutElim.glue-β (uncurry smin*) (Coprod-elim (λ _ → smbasel*) (λ _ → smbaser*)) (Coprod-elim smgluel* smgluer*) ∘ inl

      smgluer-β : ∀ (y : de⊙ Y) → apd f (smgluer y) == smgluer* y
      smgluer-β = PushoutElim.glue-β (uncurry smin*) (Coprod-elim (λ _ → smbasel*) (λ _ → smbaser*)) (Coprod-elim smgluel* smgluer*) ∘ inr

  Smash-elim = SmashElim.f

  module SmashRec {k} {C : Type k}
    (smin* : (x : de⊙ X) (y : de⊙ Y) → C)
    (smbasel* smbaser* : C)
    (smgluel* : (x : de⊙ X) → smin* x (pt Y) == smbasel*)
    (smgluer* : (y : de⊙ Y) → smin* (pt X) y == smbaser*) where

    -- It would be better to encapsulate the repetition in the following definitions in a
    -- private module as follows. Unfortunately, this is not possible when the smash
    -- datatype is declared abstract.
    {-private
      module M = PushoutRec {d = ∧-span X Y}
        (uncurry smin*)
        (Coprod-rec (λ _ → smbasel*) (λ _ → smbaser*))
        (Coprod-elim smgluel* smgluer*)-}

    abstract
      f : X ∧ Y → C
      f = PushoutRec.f (uncurry smin*) (Coprod-elim (λ _ → smbasel*) (λ _ → smbaser*)) (Coprod-elim smgluel* smgluer*)

      smin-β : ∀ x y → f (smin x y) ↦ smin* x y
      smin-β x y = PushoutRec.left-β {d = ∧-span X Y} (uncurry smin*) (Coprod-rec (λ _ → smbasel*) (λ _ → smbaser*)) (Coprod-elim smgluel* smgluer*) (x , y)
      {-# REWRITE smin-β #-}

      smbasel-β : f smbasel ↦ smbasel*
      smbasel-β = PushoutRec.right-β {d = ∧-span X Y} (uncurry smin*) (Coprod-rec (λ _ → smbasel*) (λ _ → smbaser*)) (Coprod-elim smgluel* smgluer*) true
      {-# REWRITE smbasel-β #-}

      smbaser-β : f smbaser ↦ smbaser*
      smbaser-β = PushoutRec.right-β {d = ∧-span X Y} (uncurry smin*) (Coprod-rec (λ _ → smbasel*) (λ _ → smbaser*)) (Coprod-elim smgluel* smgluer*) false
      {-# REWRITE smbaser-β #-}

      smgluel-β : ∀ (x : de⊙ X) → ap f (smgluel x) == smgluel* x
      smgluel-β = PushoutRec.glue-β (uncurry smin*) (Coprod-rec (λ _ → smbasel*) (λ _ → smbaser*)) (Coprod-elim smgluel* smgluer*) ∘ inl

      smgluer-β : ∀ (y : de⊙ Y) → ap f (smgluer y) == smgluer* y
      smgluer-β = PushoutRec.glue-β (uncurry smin*) (Coprod-rec (λ _ → smbasel*) (λ _ → smbaser*)) (Coprod-elim smgluel* smgluer*) ∘ inr

      ∧-norm-l-β : ∀ (x : de⊙ X) → ap f (∧-norm-l x) == smgluel* x ∙ ! (smgluel* (pt X))
      ∧-norm-l-β x =
        ap f (∧-norm-l x)
          =⟨ ap-∙ f (smgluel x) (! (smgluel (pt X))) ⟩
        ap f (smgluel x) ∙ ap f (! (smgluel (pt X)))
          =⟨ ap2 _∙_ (smgluel-β x)
                     (ap-! f (smgluel (pt X)) ∙
                      ap ! (smgluel-β (pt X))) ⟩
        smgluel* x ∙ ! (smgluel* (pt X)) =∎

      ∧-norm-r-β : ∀ (y : de⊙ Y) → ap f (∧-norm-r y) == smgluer* y ∙ ! (smgluer* (pt Y))
      ∧-norm-r-β y =
        ap f (∧-norm-r y)
          =⟨ ap-∙ f (smgluer y) (! (smgluer (pt Y))) ⟩
        ap f (smgluer y) ∙ ap f (! (smgluer (pt Y)))
          =⟨ ap2 _∙_ (smgluer-β y)
                     (ap-! f (smgluer (pt Y)) ∙
                      ap ! (smgluer-β (pt Y))) ⟩
        smgluer* y ∙ ! (smgluer* (pt Y)) =∎

  Smash-rec = SmashRec.f

  module SmashPathOverElim {k} {P : Smash X Y → Type k}
    (g₁ g₂ : (xy : Smash X Y) → P xy)
    (smin* : (x : de⊙ X) (y : de⊙ Y) → g₁ (smin x y) == g₂ (smin x y))
    (smbasel* : g₁ smbasel == g₂ smbasel)
    (smbaser* : g₁ smbaser == g₂ smbaser)
    (smgluel* : (x : de⊙ X) →
      smin* x (pt Y) ◃ apd g₂ (smgluel x) ==
      apd g₁ (smgluel x) ▹ smbasel*)
    (smgluer* : (y : de⊙ Y) →
      smin* (pt X) y ◃ apd g₂ (smgluer y) ==
      apd g₁ (smgluer y) ▹ smbaser*)
    where

    f : g₁ ∼ g₂
    f =
      Smash-elim
        {P = λ xy → g₁ xy == g₂ xy}
        smin*
        smbasel*
        smbaser*
        (λ x → ↓-=-in (smgluel* x))
        (λ y → ↓-=-in (smgluer* y))

  Smash-PathOver-elim = SmashPathOverElim.f

  module SmashPathElim {k} {C : Type k}
    (g₁ g₂ : Smash X Y → C)
    (smin* : (x : de⊙ X) (y : de⊙ Y) → g₁ (smin x y) == g₂ (smin x y))
    (smbasel* : g₁ smbasel == g₂ smbasel)
    (smbaser* : g₁ smbaser == g₂ smbaser)
    (smgluel* : (x : de⊙ X) →
      Square (smin* x (pt Y)) (ap g₁ (smgluel x))
             (ap g₂ (smgluel x)) smbasel*)
    (smgluer* : (y : de⊙ Y) →
      Square (smin* (pt X) y) (ap g₁ (smgluer y))
             (ap g₂ (smgluer y)) smbaser*)
    where

    f : g₁ ∼ g₂
    f =
      Smash-elim
        {P = λ xy → g₁ xy == g₂ xy}
        smin*
        smbasel*
        smbaser*
        (λ x → ↓-='-from-square (smgluel* x))
        (λ y → ↓-='-from-square (smgluer* y))

  Smash-Path-elim = SmashPathElim.f

module _ {i j k l} {X : Ptd i} {Y : Ptd j} {X' : Ptd k} {Y' : Ptd l} (f : X ⊙→ X') (g : Y ⊙→ Y') where

  private
    module M = SmashRec
      {C = X' ∧ Y'}
      (λ x y → smin (fst f x) (fst g y))
      (smin (pt X') (pt Y'))
      (smin (pt X') (pt Y'))
      (λ x → ap (λ y' → smin (fst f x) y') (snd g) ∙ ∧-norm-l (fst f x))
      (λ y → ap (λ x' → smin x' (fst g y)) (snd f) ∙ ∧-norm-r (fst g y))

  abstract
    ∧-fmap : X ∧ Y → X' ∧ Y'
    ∧-fmap = M.f

    ∧-fmap-smin-β : ∀ x y → ∧-fmap (smin x y) ↦ smin (fst f x) (fst g y)
    ∧-fmap-smin-β = M.smin-β
    {-# REWRITE ∧-fmap-smin-β #-}

    ∧-fmap-smbasel-β : ∧-fmap smbasel ↦ smin (pt X') (pt Y')
    ∧-fmap-smbasel-β = M.smbasel-β
    {-# REWRITE ∧-fmap-smbasel-β #-}

    ∧-fmap-smbaser-β : ∧-fmap smbaser ↦ smin (pt X') (pt Y')
    ∧-fmap-smbaser-β = M.smbaser-β
    {-# REWRITE ∧-fmap-smbaser-β #-}

    ∧-fmap-smgluel-β' : ∀ x →
      ap ∧-fmap (smgluel x)
      ==
      ap (λ y' → smin (fst f x) y') (snd g) ∙
      ∧-norm-l (fst f x)
    ∧-fmap-smgluel-β' x = M.smgluel-β x

    ∧-fmap-smgluer-β' : ∀ y →
      ap ∧-fmap (smgluer y)
      ==
      ap (λ x' → smin x' (fst g y)) (snd f) ∙
      ∧-norm-r (fst g y)
    ∧-fmap-smgluer-β' = M.smgluer-β

  ∧-fmap-smgluel-β : ∀ x →
    ap ∧-fmap (smgluel x) ◃∎
    =ₛ
    ap (λ y' → smin (fst f x) y') (snd g) ◃∙
    ∧-norm-l (fst f x) ◃∎
  ∧-fmap-smgluel-β x = =ₛ-in (∧-fmap-smgluel-β' x)

  ∧-fmap-smgluer-β : ∀ y →
    ap ∧-fmap (smgluer y) ◃∎
    =ₛ
    ap (λ x' → smin x' (fst g y)) (snd f) ◃∙
    ∧-norm-r (fst g y) ◃∎
  ∧-fmap-smgluer-β y = =ₛ-in (∧-fmap-smgluer-β' y)

  ⊙∧-fmap : X ⊙∧ Y ⊙→ X' ⊙∧ Y'
  ⊙∧-fmap = ∧-fmap , ap2 smin (snd f) (snd g)

  ∧-fmap-norm-l : ∀ x →
    ap ∧-fmap (∧-norm-l x) ◃∎
    =ₛ
    ap (λ y' → smin (fst f x) y') (snd g) ◃∙
    smgluel (fst f x) ◃∙
    ! (smgluel (fst f (pt X))) ◃∙
    ! (ap (smin (fst f (pt X))) (snd g)) ◃∎
  ∧-fmap-norm-l x =
    ap ∧-fmap (∧-norm-l x) ◃∎
      =ₛ⟨ ap-seq-∙ ∧-fmap (∧-norm-l-seq x) ⟩
    ap ∧-fmap (smgluel x) ◃∙
    ap ∧-fmap (! (smgluel (pt X))) ◃∎
      =ₛ₁⟨ 1 & 1 & ap-! ∧-fmap (smgluel (pt X)) ⟩
    ap ∧-fmap (smgluel x) ◃∙
    ! (ap ∧-fmap (smgluel (pt X))) ◃∎
      =ₛ⟨ 0 & 1 & ∧-fmap-smgluel-β x ⟩
    ap (smin (fst f x)) (snd g) ◃∙
    ∧-norm-l (fst f x) ◃∙
    ! (ap ∧-fmap (smgluel (pt X))) ◃∎
      =ₛ⟨ 2 & 1 & !-=ₛ (∧-fmap-smgluel-β (pt X)) ⟩
    ap (smin (fst f x)) (snd g) ◃∙
    ∧-norm-l (fst f x) ◃∙
    ! (∧-norm-l (fst f (pt X))) ◃∙
    ! (ap (smin (fst f (pt X))) (snd g)) ◃∎
      =ₛ⟨ 2 & 1 & !-=ₛ (expand (∧-norm-l-seq (fst f (pt X)))) ⟩
    ap (smin (fst f x)) (snd g) ◃∙
    ∧-norm-l (fst f x) ◃∙
    ! (! (smgluel (pt X'))) ◃∙
    ! (smgluel (fst f (pt X))) ◃∙
    ! (ap (smin (fst f (pt X))) (snd g)) ◃∎
      =ₛ⟨ 1 & 1 & expand (∧-norm-l-seq (fst f x)) ⟩
    ap (smin (fst f x)) (snd g) ◃∙
    smgluel (fst f x) ◃∙
    ! (smgluel (pt X')) ◃∙
    ! (! (smgluel (pt X'))) ◃∙
    ! (smgluel (fst f (pt X))) ◃∙
    ! (ap (smin (fst f (pt X))) (snd g)) ◃∎
      =ₛ⟨ 2 & 2 & seq-!-inv-r (! (smgluel (pt X')) ◃∎) ⟩
    ap (smin (fst f x)) (snd g) ◃∙
    smgluel (fst f x) ◃∙
    ! (smgluel (fst f (pt X))) ◃∙
    ! (ap (smin (fst f (pt X))) (snd g)) ◃∎ ∎ₛ

  ∧-fmap-norm-r : ∀ y →
    ap ∧-fmap (∧-norm-r y) ◃∎
    =ₛ
    ap (λ x' → smin x' (fst g y)) (snd f) ◃∙
    smgluer (fst g y) ◃∙
    ! (smgluer (fst g (pt Y))) ◃∙
    ! (ap (λ x' → smin x' (fst g (pt Y))) (snd f)) ◃∎
  ∧-fmap-norm-r y =
    ap ∧-fmap (∧-norm-r y) ◃∎
      =ₛ⟨ ap-seq-∙ ∧-fmap (∧-norm-r-seq y) ⟩
    ap ∧-fmap (smgluer y) ◃∙
    ap ∧-fmap (! (smgluer (pt Y))) ◃∎
      =ₛ₁⟨ 1 & 1 & ap-! ∧-fmap (smgluer (pt Y)) ⟩
    ap ∧-fmap (smgluer y) ◃∙
    ! (ap ∧-fmap (smgluer (pt Y))) ◃∎
      =ₛ⟨ 0 & 1 & ∧-fmap-smgluer-β y ⟩
    ap (λ x' → smin x' (fst g y)) (snd f) ◃∙
    ∧-norm-r (fst g y) ◃∙
    ! (ap ∧-fmap (smgluer (pt Y))) ◃∎
      =ₛ⟨ 2 & 1 & !-=ₛ (∧-fmap-smgluer-β (pt Y)) ⟩
    ap (λ x' → smin x' (fst g y)) (snd f) ◃∙
    ∧-norm-r (fst g y) ◃∙
    ! (∧-norm-r (fst g (pt Y))) ◃∙
    ! (ap (λ x' → smin x' (fst g (pt Y))) (snd f)) ◃∎
      =ₛ⟨ 2 & 1 & !-=ₛ (expand (∧-norm-r-seq (fst g (pt Y)))) ⟩
    ap (λ x' → smin x' (fst g y)) (snd f) ◃∙
    ∧-norm-r (fst g y) ◃∙
    ! (! (smgluer (pt Y'))) ◃∙
    ! (smgluer (fst g (pt Y))) ◃∙
    ! (ap (λ x' → smin x' (fst g (pt Y))) (snd f)) ◃∎
      =ₛ⟨ 1 & 1 & expand (∧-norm-r-seq (fst g y)) ⟩
    ap (λ x' → smin x' (fst g y)) (snd f) ◃∙
    smgluer (fst g y) ◃∙
    ! (smgluer (pt Y')) ◃∙
    ! (! (smgluer (pt Y'))) ◃∙
    ! (smgluer (fst g (pt Y))) ◃∙
    ! (ap (λ x → smin x (fst g (pt Y))) (snd f)) ◃∎
      =ₛ⟨ 2 & 2 & seq-!-inv-r (! (smgluer (pt Y')) ◃∎) ⟩
    ap (λ x' → smin x' (fst g y)) (snd f) ◃∙
    smgluer (fst g y) ◃∙
    ! (smgluer (fst g (pt Y))) ◃∙
    ! (ap (λ x' → smin x' (fst g (pt Y))) (snd f)) ◃∎ ∎ₛ

module _ {i i' i'' j j' j''}
         {X : Ptd i} {X' : Ptd i'} {X'' : Ptd i''} (f : X ⊙→ X') (f' : X' ⊙→ X'')
         {Y : Ptd j} {Y' : Ptd j'} {Y'' : Ptd j''} (g : Y ⊙→ Y') (g' : Y' ⊙→ Y'') where

  ∧-fmap-comp : ∀ xy →
    ∧-fmap (f' ⊙∘ f) (g' ⊙∘ g) xy == ∧-fmap f' g' (∧-fmap f g xy)
  ∧-fmap-comp =
    Smash-elim {X = X} {Y = Y}
      {P = λ xy → ∧-fmap (f' ⊙∘ f) (g' ⊙∘ g) xy == ∧-fmap f' g' (∧-fmap f g xy)}
      (λ x y → idp)
      (! (ap2 smin (snd f') (snd g')))
      (! (ap2 smin (snd f') (snd g')))
      (λ x → ↓-='-in-=ₛ $
        idp ◃∙
        ap (∧-fmap f' g' ∘ ∧-fmap f g) (smgluel x) ◃∎
          =ₛ⟨ 0 & 1 & expand [] ⟩
        ap (∧-fmap f' g' ∘ ∧-fmap f g) (smgluel x) ◃∎
          =ₛ₁⟨ ap-∘ (∧-fmap f' g') (∧-fmap f g) (smgluel x) ⟩
        ap (∧-fmap f' g') (ap (∧-fmap f g) (smgluel x)) ◃∎
          =ₛ⟨ ap-seq-=ₛ (∧-fmap f' g') (∧-fmap-smgluel-β f g x) ⟩
        ap (∧-fmap f' g') (ap (smin (fst f x)) (snd g)) ◃∙
        ap (∧-fmap f' g') (∧-norm-l (fst f x)) ◃∎
          =ₛ₁⟨ 0 & 1 & ∘-ap (∧-fmap f' g') (smin (fst f x)) (snd g) ⟩
        ap (smin (fst (f' ⊙∘ f) x) ∘ fst g') (snd g) ◃∙
        ap (∧-fmap f' g') (∧-norm-l (fst f x)) ◃∎
          =ₛ⟨ 1 & 1 & ∧-fmap-norm-l f' g' (fst f x) ⟩
        ap (smin (fst (f' ⊙∘ f) x) ∘ fst g') (snd g) ◃∙
        ap (smin (fst (f' ⊙∘ f) x)) (snd g') ◃∙
        smgluel (fst (f' ⊙∘ f) x) ◃∙
        ! (smgluel (fst f' (pt X'))) ◃∙
        ! (ap (smin (fst f' (pt X'))) (snd g')) ◃∎
          =ₛ₁⟨ 0 & 1 & ap-∘ (smin (fst (f' ⊙∘ f) x)) (fst g') (snd g) ⟩
        ap (smin (fst (f' ⊙∘ f) x)) (ap (fst g') (snd g)) ◃∙
        ap (smin (fst (f' ⊙∘ f) x)) (snd g') ◃∙
        smgluel (fst (f' ⊙∘ f) x) ◃∙
        ! (smgluel (fst f' (pt X'))) ◃∙
        ! (ap (smin (fst f' (pt X'))) (snd g')) ◃∎
          =ₛ⟨ 0 & 2 & ∙-ap-seq (smin (fst (f' ⊙∘ f) x)) (ap (fst g') (snd g) ◃∙ snd g' ◃∎) ⟩
        ap (smin (fst f' (fst f x))) (snd (g' ⊙∘ g)) ◃∙
        smgluel (fst (f' ⊙∘ f) x) ◃∙
        ! (smgluel (fst f' (pt X'))) ◃∙
        ! (ap (smin (fst f' (pt X'))) (snd g')) ◃∎
          =ₛ⟨ 3 & 0 & !ₛ (seq-!-inv-r (ap (λ x'' → smin x'' (pt Y'')) (snd f') ◃∎)) ⟩
        ap (smin (fst f' (fst f x))) (snd (g' ⊙∘ g)) ◃∙
        smgluel (fst (f' ⊙∘ f) x) ◃∙
        ! (smgluel (fst f' (pt X'))) ◃∙
        ap (λ x'' → smin x'' (pt Y'')) (snd f') ◃∙
        ! (ap (λ x'' → smin x'' (pt Y'')) (snd f')) ◃∙
        ! (ap (smin (fst f' (pt X'))) (snd g')) ◃∎
          =ₛ⟨ 4 & 2 & !ₛ $ !-=ₛ $ ap2-out' smin (snd f') (snd g') ⟩
        ap (smin (fst f' (fst f x))) (snd (g' ⊙∘ g)) ◃∙
        smgluel (fst (f' ⊙∘ f) x) ◃∙
        ! (smgluel (fst f' (pt X'))) ◃∙
        ap (λ x'' → smin x'' (pt Y'')) (snd f') ◃∙
        ! (ap2 smin (snd f') (snd g')) ◃∎
          =ₛ⟨ 3 & 1 &
              =ₛ-in {t = smgluel (fst f' (pt X')) ◃∙ ! (smgluel (pt X'')) ◃∎} $
              ap-null-homotopic (λ x'' → smin x'' (pt Y'')) smgluel (snd f') ⟩
        ap (smin (fst f' (fst f x))) (snd (g' ⊙∘ g)) ◃∙
        smgluel (fst (f' ⊙∘ f) x) ◃∙
        ! (smgluel (fst f' (pt X'))) ◃∙
        smgluel (fst f' (pt X')) ◃∙
        ! (smgluel (pt X'')) ◃∙
        ! (ap2 smin (snd f') (snd g')) ◃∎
          =ₛ⟨ 2 & 2 & seq-!-inv-l (smgluel (fst f' (pt X')) ◃∎) ⟩
        ap (smin (fst f' (fst f x))) (snd (g' ⊙∘ g)) ◃∙
        smgluel (fst (f' ⊙∘ f) x) ◃∙
        ! (smgluel (pt X'')) ◃∙
        ! (ap2 smin (snd f') (snd g')) ◃∎
          =ₛ⟨ 1 & 2 & contract ⟩
        ap (smin (fst f' (fst f x))) (snd (g' ⊙∘ g)) ◃∙
        ∧-norm-l (fst (f' ⊙∘ f) x) ◃∙
        ! (ap2 smin (snd f') (snd g')) ◃∎
          =ₛ⟨ 0 & 2 & !ₛ (∧-fmap-smgluel-β (f' ⊙∘ f) (g' ⊙∘ g) x) ⟩
        ap (∧-fmap (f' ⊙∘ f) (g' ⊙∘ g)) (smgluel x) ◃∙
        ! (ap2 smin (snd f') (snd g')) ◃∎ ∎ₛ)
      (λ y → ↓-='-in-=ₛ $
        idp ◃∙
        ap (∧-fmap f' g' ∘ ∧-fmap f g) (smgluer y) ◃∎
          =ₛ⟨ 0 & 1 & expand [] ⟩
        ap (∧-fmap f' g' ∘ ∧-fmap f g) (smgluer y) ◃∎
          =ₛ₁⟨ ap-∘ (∧-fmap f' g') (∧-fmap f g) (smgluer y) ⟩
        ap (∧-fmap f' g') (ap (∧-fmap f g) (smgluer y)) ◃∎
          =ₛ⟨ ap-seq-=ₛ (∧-fmap f' g') (∧-fmap-smgluer-β f g y) ⟩
        ap (∧-fmap f' g') (ap (λ x' → smin x' (fst g y)) (snd f)) ◃∙
        ap (∧-fmap f' g') (∧-norm-r (fst g y)) ◃∎
          =ₛ₁⟨ 0 & 1 & ∘-ap (∧-fmap f' g') (λ x' → smin x' (fst g y)) (snd f) ⟩
        ap (λ x' → smin (fst f' x') (fst (g' ⊙∘ g) y)) (snd f) ◃∙
        ap (∧-fmap f' g') (∧-norm-r (fst g y)) ◃∎
          =ₛ⟨ 1 & 1 & ∧-fmap-norm-r f' g' (fst g y) ⟩
        ap (λ x' → smin (fst f' x') (fst (g' ⊙∘ g) y)) (snd f) ◃∙
        ap (λ x'' → smin x'' (fst (g' ⊙∘ g) y)) (snd f') ◃∙
        smgluer (fst (g' ⊙∘ g) y) ◃∙
        ! (smgluer (fst g' (pt Y'))) ◃∙
        ! (ap (λ x' → smin x' (fst g' (pt Y'))) (snd f')) ◃∎
          =ₛ₁⟨ 0 & 1 & ap-∘ (λ x'' → smin x'' (fst (g' ⊙∘ g) y)) (fst f') (snd f) ⟩
        ap (λ x'' → smin x'' (fst (g' ⊙∘ g) y)) (ap (fst f') (snd f)) ◃∙
        ap (λ x'' → smin x'' (fst (g' ⊙∘ g) y)) (snd f') ◃∙
        smgluer (fst (g' ⊙∘ g) y) ◃∙
        ! (smgluer (fst g' (pt Y'))) ◃∙
        ! (ap (λ x' → smin x' (fst g' (pt Y'))) (snd f')) ◃∎
          =ₛ⟨ 0 & 2 & ∙-ap-seq (λ x'' → smin x'' (fst (g' ⊙∘ g) y))
                               (ap (fst f') (snd f) ◃∙ snd f' ◃∎) ⟩
        ap (λ x'' → smin x'' (fst (g' ⊙∘ g) y)) (snd (f' ⊙∘ f)) ◃∙
        smgluer (fst (g' ⊙∘ g) y) ◃∙
        ! (smgluer (fst g' (pt Y'))) ◃∙
        ! (ap (λ x' → smin x' (fst g' (pt Y'))) (snd f')) ◃∎
          =ₛ⟨ 3 & 0 & !ₛ (seq-!-inv-r (ap (smin (pt X'')) (snd g') ◃∎)) ⟩
        ap (λ x'' → smin x'' (fst (g' ⊙∘ g) y)) (snd (f' ⊙∘ f)) ◃∙
        smgluer (fst (g' ⊙∘ g) y) ◃∙
        ! (smgluer (fst g' (pt Y'))) ◃∙
        ap (smin (pt X'')) (snd g') ◃∙
        ! (ap (smin (pt X'')) (snd g')) ◃∙
        ! (ap (λ x' → smin x' (fst g' (pt Y'))) (snd f')) ◃∎
          =ₛ⟨ 4 & 2 & !ₛ $ !-=ₛ $ ap2-out smin (snd f') (snd g') ⟩
        ap (λ x'' → smin x'' (fst (g' ⊙∘ g) y)) (snd (f' ⊙∘ f)) ◃∙
        smgluer (fst (g' ⊙∘ g) y) ◃∙
        ! (smgluer (fst g' (pt Y'))) ◃∙
        ap (smin (pt X'')) (snd g') ◃∙
        ! (ap2 smin (snd f') (snd g')) ◃∎
          =ₛ⟨ 3 & 1 &
              =ₛ-in {t = smgluer (fst g' (pt Y')) ◃∙ ! (smgluer (pt Y'')) ◃∎} $
              ap-null-homotopic (smin (pt X'')) smgluer (snd g') ⟩
        ap (λ x'' → smin x'' (fst (g' ⊙∘ g) y)) (snd (f' ⊙∘ f)) ◃∙
        smgluer (fst (g' ⊙∘ g) y) ◃∙
        ! (smgluer (fst g' (pt Y'))) ◃∙
        smgluer (fst g' (pt Y')) ◃∙
        ! (smgluer (pt Y'')) ◃∙
        ! (ap2 smin (snd f') (snd g')) ◃∎
          =ₛ⟨ 2 & 2 & seq-!-inv-l (smgluer (fst g' (pt Y')) ◃∎) ⟩
        ap (λ x'' → smin x'' (fst (g' ⊙∘ g) y)) (snd (f' ⊙∘ f)) ◃∙
        smgluer (fst (g' ⊙∘ g) y) ◃∙
        ! (smgluer (pt Y'')) ◃∙
        ! (ap2 smin (snd f') (snd g')) ◃∎
          =ₛ⟨ 1 & 2 & contract ⟩
        ap (λ x'' → smin x'' (fst (g' ⊙∘ g) y)) (snd (f' ⊙∘ f)) ◃∙
        ∧-norm-r (fst (g' ⊙∘ g) y) ◃∙
        ! (ap2 smin (snd f') (snd g')) ◃∎
          =ₛ⟨ 0 & 2 & !ₛ (∧-fmap-smgluer-β (f' ⊙∘ f) (g' ⊙∘ g) y) ⟩
        ap (∧-fmap (f' ⊙∘ f) (g' ⊙∘ g)) (smgluer y) ◃∙
        ! (ap2 smin (snd f') (snd g')) ◃∎ ∎ₛ)

module _ {i j} {X : Ptd i} {Y : Ptd j} where

  ×-to-∧ : de⊙ X × de⊙ Y → X ∧ Y
  ×-to-∧ (x , y) = smin x y

  ×-⊙to-∧ : X ⊙× Y ⊙→ X ⊙∧ Y
  ×-⊙to-∧ = ×-to-∧ , idp

module _ {i j} (X : Ptd i) (Y : Ptd j) where

  module SmashSwap =
    SmashRec {X = X} {Y = Y}
      {C = Y ∧ X}
      (λ x y → smin y x)
      (smin (pt Y) (pt X))
      (smin (pt Y) (pt X))
      ∧-norm-r
      ∧-norm-l

  ∧-swap : X ∧ Y → Y ∧ X
  ∧-swap = SmashSwap.f

  ⊙∧-swap : X ⊙∧ Y ⊙→ Y ⊙∧ X
  ⊙∧-swap = ∧-swap , idp

  ∧-swap-norm-l-β : ∀ x →
    ap ∧-swap (∧-norm-l x) == ∧-norm-r x
  ∧-swap-norm-l-β x =
    ap ∧-swap (∧-norm-l x)
      =⟨ SmashSwap.∧-norm-l-β x ⟩
    ∧-norm-r x ∙ ! (∧-norm-r (pt X))
      =⟨ ap (λ u → ∧-norm-r x ∙ ! u) (!-inv-r (smgluer (pt X))) ⟩
    ∧-norm-r x ∙ idp
      =⟨ ∙-unit-r (∧-norm-r x) ⟩
    ∧-norm-r x =∎

  ∧-swap-norm-r-β : ∀ y →
    ap ∧-swap (∧-norm-r y) == ∧-norm-l y
  ∧-swap-norm-r-β y =
    ap ∧-swap (∧-norm-r y)
      =⟨ SmashSwap.∧-norm-r-β y ⟩
    ∧-norm-l y ∙ ! (∧-norm-l (pt Y))
      =⟨ ap (λ u → ∧-norm-l y ∙ ! u) (!-inv-r (smgluel (pt Y))) ⟩
    ∧-norm-l y ∙ idp
      =⟨ ∙-unit-r (∧-norm-l y) ⟩
    ∧-norm-l y =∎

  ×-to-∧-swap : ∧-swap ∘ ×-to-∧ ∼ ×-to-∧ ∘ ×-swap
  ×-to-∧-swap (x , y) = idp

  ×-⊙to-∧-swap :
    ⊙∧-swap ◃⊙∘ ×-⊙to-∧ ◃⊙idf
    =⊙∘
    ×-⊙to-∧ ◃⊙∘ ⊙×-swap ◃⊙idf
  ×-⊙to-∧-swap = =⊙∘-in $
    ⊙λ=' ×-to-∧-swap idp

module _ {i j} (X : Ptd i) (Y : Ptd j) where

  module SmashSwapInvolutive =
    SmashElim {X = X} {Y = Y}
      {P = λ xy → ∧-swap Y X (∧-swap X Y xy) == xy}
      (λ x y → idp)
      (smgluel (pt X))
      (smgluer (pt Y))
      (λ x → ↓-app=idf-in $ ! $
        ap (∧-swap Y X ∘ ∧-swap X Y) (smgluel x) ∙ smgluel (pt X)
          =⟨ ap (_∙ smgluel (pt X)) $
             ap-∘ (∧-swap Y X) (∧-swap X Y) (smgluel x) ⟩
        ap (∧-swap Y X) (ap (∧-swap X Y) (smgluel x)) ∙ smgluel (pt X)
          =⟨ ap (λ p → ap (∧-swap Y X) p ∙ smgluel (pt X)) $
             SmashSwap.smgluel-β X Y x ⟩
        ap (∧-swap Y X) (∧-norm-r x) ∙ smgluel (pt X)
          =⟨ ap (_∙ smgluel (pt X)) (∧-swap-norm-r-β Y X x) ⟩
        ∧-norm-l x ∙ smgluel (pt X)
          =⟨ ∙-assoc (smgluel x) (! (smgluel (pt X))) (smgluel (pt X))⟩
        smgluel x ∙ ! (smgluel (pt X)) ∙ smgluel (pt X)
          =⟨ ap (smgluel x ∙_) (!-inv-l (smgluel (pt X))) ⟩
        smgluel x ∙ idp
          =⟨ ∙-unit-r (smgluel x) ⟩
        smgluel x
          =⟨ ! (∙'-unit-l (smgluel x)) ⟩
        idp ∙' smgluel x =∎)
      (λ y → ↓-app=idf-in $ ! $
        ap (∧-swap Y X ∘ ∧-swap X Y) (smgluer y) ∙ smgluer (pt Y)
          =⟨ ap (_∙ smgluer (pt Y)) $
             ap-∘ (∧-swap Y X) (∧-swap X Y) (smgluer y) ⟩
        ap (∧-swap Y X) (ap (∧-swap X Y) (smgluer y)) ∙ smgluer (pt Y)
          =⟨ ap (λ p → ap (∧-swap Y X) p ∙ smgluer (pt Y)) $
             SmashSwap.smgluer-β X Y y ⟩
        ap (∧-swap Y X) (∧-norm-l y) ∙ smgluer (pt Y)
          =⟨ ap (_∙ smgluer (pt Y)) (∧-swap-norm-l-β Y X y) ⟩
        ∧-norm-r y ∙ smgluer (pt Y)
          =⟨ ∙-assoc (smgluer y) (! (smgluer (pt Y))) (smgluer (pt Y)) ⟩
        smgluer y ∙ ! (smgluer (pt Y)) ∙ smgluer (pt Y)
          =⟨ ap (smgluer y ∙_) (!-inv-l (smgluer (pt Y))) ⟩
        smgluer y ∙ idp
          =⟨ ∙-unit-r (smgluer y) ⟩
        smgluer y
          =⟨ ! (∙'-unit-l (smgluer y)) ⟩
        idp ∙' smgluer y =∎)

  ∧-swap-inv : ∀ xy → ∧-swap Y X (∧-swap X Y xy) == xy
  ∧-swap-inv = SmashSwapInvolutive.f

  ⊙∧-swap-inv : ⊙∧-swap Y X ◃⊙∘ ⊙∧-swap X Y ◃⊙idf =⊙∘ ⊙idf-seq
  ⊙∧-swap-inv = =⊙∘-in (⊙λ=' ∧-swap-inv idp)

module _ {i j} (X : Ptd i) (Y : Ptd j) where

  ∧-swap-is-equiv : is-equiv (∧-swap X Y)
  ∧-swap-is-equiv = is-eq _ (∧-swap Y X) (∧-swap-inv Y X) (∧-swap-inv X Y)

  ∧-swap-equiv : (X ∧ Y) ≃ (Y ∧ X)
  ∧-swap-equiv = ∧-swap X Y , ∧-swap-is-equiv

module _ {i i' j j'} {X : Ptd i} {X' : Ptd i'} {Y : Ptd j} {Y' : Ptd j'}
         (f : X ⊙→ X') (g : Y ⊙→ Y') where

  ∧-swap-naturality : ∀ xy →
    ∧-fmap g f (∧-swap X Y xy) == ∧-swap X' Y' (∧-fmap f g xy)
  ∧-swap-naturality =
    Smash-elim {X = X} {Y = Y}
      {P = λ xy → ∧-fmap g f (∧-swap X Y xy) == ∧-swap X' Y' (∧-fmap f g xy)}
      (λ x y → idp)
      (ap2 smin (snd g) (snd f))
      (ap2 smin (snd g) (snd f))
      (λ x → ↓-='-in-=ₛ $
        idp ◃∙
        ap (∧-swap X' Y' ∘ ∧-fmap f g) (smgluel x) ◃∎
          =ₛ⟨ 0 & 1 & expand [] ⟩
        ap (∧-swap X' Y' ∘ ∧-fmap f g) (smgluel x) ◃∎
          =ₛ₁⟨ ap-∘ (∧-swap X' Y') (∧-fmap f g) (smgluel x) ⟩
        ap (∧-swap X' Y') (ap (∧-fmap f g) (smgluel x)) ◃∎
          =ₛ⟨ ap-seq-=ₛ (∧-swap X' Y') (∧-fmap-smgluel-β f g x) ⟩
        ap (∧-swap X' Y') (ap (smin (fst f x)) (snd g)) ◃∙
        ap (∧-swap X' Y') (∧-norm-l (fst f x)) ◃∎
          =ₛ₁⟨ 0 & 1 & ∘-ap (∧-swap X' Y') (smin (fst f x)) (snd g) ⟩
        ap (λ y' → smin y' (fst f x)) (snd g) ◃∙
        ap (∧-swap X' Y') (∧-norm-l (fst f x)) ◃∎
          =ₛ₁⟨ 1 & 1 & ∧-swap-norm-l-β X' Y' (fst f x) ⟩
        ap (λ y' → smin y' (fst f x)) (snd g) ◃∙
        ∧-norm-r (fst f x) ◃∎
          =ₛ⟨ 1 & 1 & expand (∧-norm-r-seq (fst f x)) ⟩
        ap (λ y' → smin y' (fst f x)) (snd g) ◃∙
        smgluer (fst f x) ◃∙
        ! (smgluer (pt X')) ◃∎
          =ₛ⟨ 2 & 0 & !ₛ (seq-!-inv-l (smgluer (fst f (pt X)) ◃∎)) ⟩
        ap (λ y' → smin y' (fst f x)) (snd g) ◃∙
        smgluer (fst f x) ◃∙
        ! (smgluer (fst f (pt X))) ◃∙
        smgluer (fst f (pt X)) ◃∙
        ! (smgluer (pt X')) ◃∎
          =ₛ₁⟨ 3 & 2 & ! (ap-null-homotopic (smin (pt Y')) smgluer (snd f)) ⟩
        ap (λ y' → smin y' (fst f x)) (snd g) ◃∙
        smgluer (fst f x) ◃∙
        ! (smgluer (fst f (pt X))) ◃∙
        ap (smin (pt Y')) (snd f) ◃∎
          =ₛ⟨ 3 & 0 & !ₛ (seq-!-inv-l (ap (λ y' → smin y' (fst f (pt X))) (snd g) ◃∎)) ⟩
        ap (λ y' → smin y' (fst f x)) (snd g) ◃∙
        smgluer (fst f x) ◃∙
        ! (smgluer (fst f (pt X))) ◃∙
        ! (ap (λ y' → smin y' (fst f (pt X))) (snd g)) ◃∙
        ap (λ y' → smin y' (fst f (pt X))) (snd g) ◃∙
        ap (smin (pt Y')) (snd f) ◃∎
          =ₛ⟨ 4 & 2 & !ₛ (ap2-out smin (snd g) (snd f)) ⟩
        ap (λ y' → smin y' (fst f x)) (snd g) ◃∙
        smgluer (fst f x) ◃∙
        ! (smgluer (fst f (pt X))) ◃∙
        ! (ap (λ y' → smin y' (fst f (pt X))) (snd g)) ◃∙
        ap2 smin (snd g) (snd f) ◃∎
          =ₛ⟨ 0 & 4 & !ₛ (∧-fmap-norm-r g f x) ⟩
        ap (∧-fmap g f) (∧-norm-r x) ◃∙
        ap2 smin (snd g) (snd f) ◃∎
          =ₛ₁⟨ 0 & 1 & ! (ap (ap (∧-fmap g f)) (SmashSwap.smgluel-β X Y x)) ⟩
        ap (∧-fmap g f) (ap (∧-swap X Y) (smgluel x)) ◃∙
        ap2 smin (snd g) (snd f) ◃∎
          =ₛ₁⟨ 0 & 1 & ∘-ap (∧-fmap g f) (∧-swap X Y) (smgluel x) ⟩
        ap (∧-fmap g f ∘ ∧-swap X Y) (smgluel x) ◃∙
        ap2 smin (snd g) (snd f) ◃∎ ∎ₛ)
      (λ y → ↓-='-in-=ₛ $
        idp ◃∙
        ap (∧-swap X' Y' ∘ ∧-fmap f g) (smgluer y) ◃∎
          =ₛ⟨ 0 & 1 & expand [] ⟩
        ap (∧-swap X' Y' ∘ ∧-fmap f g) (smgluer y) ◃∎
          =ₛ₁⟨ ap-∘ (∧-swap X' Y') (∧-fmap f g) (smgluer y) ⟩
        ap (∧-swap X' Y') (ap (∧-fmap f g) (smgluer y)) ◃∎
          =ₛ⟨ ap-seq-=ₛ (∧-swap X' Y') (∧-fmap-smgluer-β f g y) ⟩
        ap (∧-swap X' Y') (ap (λ x' → smin x' (fst g y)) (snd f)) ◃∙
        ap (∧-swap X' Y') (∧-norm-r (fst g y)) ◃∎
          =ₛ₁⟨ 0 & 1 & ∘-ap (∧-swap X' Y') (λ x' → smin x' (fst g y)) (snd f) ⟩
        ap (smin (fst g y)) (snd f) ◃∙
        ap (∧-swap X' Y') (∧-norm-r (fst g y)) ◃∎
          =ₛ₁⟨ 1 & 1 & ∧-swap-norm-r-β X' Y' (fst g y) ⟩
        ap (smin (fst g y)) (snd f) ◃∙
        ∧-norm-l (fst g y) ◃∎
          =ₛ⟨ 1 & 1 & expand (∧-norm-l-seq (fst g y)) ⟩
        ap (smin (fst g y)) (snd f) ◃∙
        smgluel (fst g y) ◃∙
        ! (smgluel (pt Y')) ◃∎
          =ₛ⟨ 2 & 0 & !ₛ (seq-!-inv-l (smgluel (fst g (pt Y)) ◃∎)) ⟩
        ap (smin (fst g y)) (snd f) ◃∙
        smgluel (fst g y) ◃∙
        ! (smgluel (fst g (pt Y))) ◃∙
        smgluel (fst g (pt Y)) ◃∙
        ! (smgluel (pt Y')) ◃∎
          =ₛ₁⟨ 3 & 2 & ! (ap-null-homotopic (λ y' → smin y' (pt X')) smgluel (snd g)) ⟩
        ap (smin (fst g y)) (snd f) ◃∙
        smgluel (fst g y) ◃∙
        ! (smgluel (fst g (pt Y))) ◃∙
        ap (λ y' → smin y' (pt X')) (snd g) ◃∎
          =ₛ⟨ 3 & 0 & !ₛ (seq-!-inv-l (ap (smin (fst g (pt Y))) (snd f) ◃∎)) ⟩
        ap (smin (fst g y)) (snd f) ◃∙
        smgluel (fst g y) ◃∙
        ! (smgluel (fst g (pt Y))) ◃∙
        ! (ap (smin (fst g (pt Y))) (snd f)) ◃∙
        ap (smin (fst g (pt Y))) (snd f) ◃∙
        ap (λ y' → smin y' (pt X')) (snd g) ◃∎
          =ₛ⟨ 4 & 2 & !ₛ (ap2-out' smin (snd g) (snd f)) ⟩
        ap (smin (fst g y)) (snd f) ◃∙
        smgluel (fst g y) ◃∙
        ! (smgluel (fst g (pt Y))) ◃∙
        ! (ap (smin (fst g (pt Y))) (snd f)) ◃∙
        ap2 smin (snd g) (snd f) ◃∎
          =ₛ⟨ 0 & 4 & !ₛ (∧-fmap-norm-l g f y) ⟩
        ap (∧-fmap g f) (∧-norm-l y) ◃∙
        ap2 smin (snd g) (snd f) ◃∎
          =ₛ₁⟨ 0 & 1 & ! (ap (ap (∧-fmap g f)) (SmashSwap.smgluer-β X Y y)) ⟩
        ap (∧-fmap g f) (ap (∧-swap X Y) (smgluer y)) ◃∙
        ap2 smin (snd g) (snd f) ◃∎
          =ₛ₁⟨ 0 & 1 & ∘-ap (∧-fmap g f) (∧-swap X Y) (smgluer y) ⟩
        ap (∧-fmap g f ∘ ∧-swap X Y) (smgluer y) ◃∙
        ap2 smin (snd g) (snd f) ◃∎ ∎ₛ)

  ⊙∧-swap-naturality : ⊙∧-fmap g f ⊙∘ ⊙∧-swap X Y ==
                       ⊙∧-swap X' Y' ⊙∘ ⊙∧-fmap f g
  ⊙∧-swap-naturality =
    ⊙λ=' ∧-swap-naturality $ =ₛ-out $
    ap2 smin (snd g) (snd f) ◃∎
      =ₛ⟨ ap2-out smin (snd g) (snd f) ⟩
    ap (λ u → smin u (fst f (pt X))) (snd g) ◃∙
    ap (smin (pt Y')) (snd f) ◃∎
      =ₛ⟨ !ₛ $ ap2-out' (λ x y → smin y x) (snd f) (snd g) ⟩
    ap2 (λ x y → smin y x) (snd f) (snd g) ◃∎
      =ₛ₁⟨ ! $ ap-ap2 (∧-swap X' Y') smin (snd f) (snd g) ⟩
    ap (∧-swap X' Y') (ap2 smin (snd f) (snd g)) ◃∎
      =ₛ⟨ 1 & 0 & contract ⟩
    ap (∧-swap X' Y') (ap2 smin (snd f) (snd g)) ◃∙ idp ◃∎ ∎ₛ

  ∧-swap-fmap : ∀ xy →
    ∧-swap Y' X' (∧-fmap g f (∧-swap X Y xy)) == ∧-fmap f g xy
  ∧-swap-fmap xy =
    ∧-swap Y' X' (∧-fmap g f (∧-swap X Y xy))
      =⟨ ap (∧-swap Y' X') (∧-swap-naturality xy) ⟩
    ∧-swap Y' X' (∧-swap X' Y' (∧-fmap f g xy))
      =⟨ ∧-swap-inv X' Y' (∧-fmap f g xy) ⟩
    ∧-fmap f g xy =∎


module Dimension.PartialWeakening.Soundness where

  open import Exception -- using (Except; left; right; _<$>_; _>>=_)
  open import Injective

  -- Semantics given by application to a name in Fin n

  apply : ∀ {n m} (f : PWeak n m) (i : Fin n) → Except E (Fin m)
  apply []       ()
  apply (e ∷ f)  zero    = left e
  apply (e ∷ f)  (suc i) = apply f i
  apply (lift f) zero    = right zero
  apply (lift f) (suc i) = suc <$> apply f i
  apply (weak f) i       = suc <$> apply f i

  -- Proof of injectivity wrt. semantics

  injective : ∀ {n m} (f : PWeak n m) (i j : Fin n) →
    let k = apply f i in
    let l = apply f j in
    IsDefined k → k ≡ l → i ≡ j
  injective []       ()
  injective (e ∷ f) zero    j        () p
  injective (e ∷ f) (suc i) zero     fi p with apply f i
  injective (e ∷ f) (suc i) zero     () p  | left _
  injective (e ∷ f) (suc i) zero     fi () | right a
  injective (e ∷ f) (suc i) (suc j)  fi p = cong suc (injective f i j fi p)
  injective (lift f) zero   zero     fi p = refl
  injective (lift f) zero   (suc j)  fi p with apply f j
  injective (lift f) zero   (suc j)  fi p | left  _ = ⊥-elim (right≢left p)
  injective (lift f) zero   (suc j)  fi p | right l = ⊥-elim (zero≢suc (right-injective _ _ p))
  injective (lift f) (suc i) zero    fi p with apply f i
  injective (lift f) (suc i) zero    fi p | left  e = ⊥-elim (left≢right p)
  injective (lift f) (suc i) zero    fi p | right k = ⊥-elim (suc≢zero (right-injective _ _ p))
  injective (lift f) (suc i) (suc j) fi p = cong suc (injective f i j (map-def-inv _ fi) (map-injective suc-injective _ _ p))
  injective (weak f) i       j       fi p = injective f i j (map-def-inv _ fi) (map-injective suc-injective _ _ p)

  -- Soundness of id

  apply-id : ∀ n (i : Fin n) → apply id i ≡ return i
  apply-id 0       ()
  apply-id (suc n) zero    = refl
  apply-id (suc n) (suc i) with (apply id i) | (apply-id n i)
  apply-id (suc n) (suc i) | .(right i) | refl = refl

  -- Lemma: one inductive step

  lift-lift-suc : ∀ {n m l} (f : PWeak n m) {g : PWeak m l} {i : Fin n} →

    (ih : apply (comp f g) i ≡ apply f i >>= apply g) →

    apply (comp (lift f) (lift g)) (suc i)  ≡
    apply (lift f) (suc i) >>= apply (lift g)

  lift-lift-suc f {g = g} {i = i} ih = begin

      apply (comp (lift f) (lift g)) (suc i)

    ≡⟨⟩                                      -- definition of comp

      apply (lift (comp f g)) (suc i)

    ≡⟨⟩                                      -- definition of apply

      suc <$> apply (comp f g) i

    ≡⟨ cong (_<$>_ suc) ih ⟩                 -- induction hypothesis

      suc <$> (apply f i >>= apply g)

    ≡⟨ map-after-bind (apply f i) ⟩          -- map commutes with bind I

      (apply f i >>= λ j → suc <$> apply g j)

    ≡⟨⟩                                      -- definition of apply

      (apply f i >>= λ j → apply (lift g) (suc j))

    ≡⟨ sym (bind-after-map (apply f i)) ⟩    -- map commutes with bind II

      (suc <$> apply f i) >>= apply (lift g)

    ≡⟨⟩                                      -- definition of apply

      apply (lift f) (suc i) >>= apply (lift g)
    ∎

  -- Soundness of comp

  apply-comp : ∀ {n m l} (f : PWeak n m) (g : PWeak m l) (i : Fin n) →
    apply (comp f g) i ≡ apply f i >>= apply g
  apply-comp [] g ()
  apply-comp (e ∷ f) g zero = refl
  apply-comp (e ∷ f) g (suc i) = apply-comp f g i
--  apply-comp (lift f) (e ∷ g) i = {!!}
  apply-comp (lift f) (e ∷ g) zero = refl
  apply-comp (lift f) (e ∷ g) (suc i) with apply f i
  apply-comp (lift f) (e ∷ g) (suc i) | left e′ = {!!}
  apply-comp (lift f) (e ∷ g) (suc i) | right a = {!!}
  apply-comp (lift f) (lift g) zero = refl
  apply-comp (lift f) (lift g) (suc i) = lift-lift-suc f (apply-comp f g i)
  apply-comp (lift f) (weak g) i = begin

      suc <$> apply (comp (lift f) g) i

    ≡⟨ cong (_<$>_ suc) (apply-comp (lift f) g i) ⟩  -- ind. hyp.

      suc <$> (apply (lift f) i >>= apply g)

    ≡⟨ map-after-bind (apply (lift f) i) ⟩           -- move map

      apply (lift f) i >>= (λ j → suc <$> apply g j)
    ∎
  apply-comp (weak f) g i = {!!}


open import MJ.Types
import MJ.Classtable.Core as Core
import MJ.Classtable.Code as Code

import MJ.Syntax as Syntax
import MJ.Semantics.Values as Values

module MJ.Semantics {c}(Ct : Core.Classtable c)(ℂ : Code.Code Ct) where

-- functional big-step definitional interpreter
-- open import MJ.Semantics.Functional Σ ℂ
open import MJ.Semantics.Monadic Ct ℂ public


{-# OPTIONS --cubical-compatible --rewriting --confluence-check #-}

module Issue1719.Spans where

open import Issue1719.Common

record Span : Set₁ where
  constructor span
  field
    A B C : Set
    f : C → A
    g : C → B
open Span public


∙_ : Set₁ → Set₁
∙ X = X

Foo : Set
Foo = ∙ Set


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

module Cham.Agent where

open import Cham.Context
open import Cham.Label
open import Cham.Name
open import Data.Nat
open import Data.Product

data Agent : Context → Set where
  Nil  : Agent ∅

  _∙_  : ∀ {Γ}
       → (Valence : Label)
       → Agent Γ
       → Agent (Γ ⊢ Valence)

  _∣_  : ∀ {Γ₁ Γ₂}
       → Agent Γ₁
       → Agent Γ₂
       → Agent (Γ₁ , Γ₂)

  _/_  : ∀ {Γ}
       → (Ion : Name)
       → Agent Γ
       → Agent (Γ ⊢ Ion ⁻)

  _[]_ : ∀ {Γ₁ Γ₂}
       → Agent Γ₁
       → Agent Γ₂
       → Agent (Γ₁ , Γ₂)

Reaction : ∀ {Γ₁ Γ₂ Ion}
         → Agent (Γ₁ ⊢ Ion ⁺)
         → Agent (Γ₂ ⊢ Ion ⁻)
         → Agent Γ₁ × Agent Γ₂
Reaction (.(_   ⁺) ∙ a₁) (.(_ ⁻) ∙ a₂) = a₁ , a₂
Reaction (.(Ion ⁺) ∙ a₁) (Ion    / a₂) = a₁ , a₂


-- Private signatures
module Issue476d where

module M where
  private
    record R : Set₁

  record R where
    field X : Set

Q : Set₁
Q = M.R


{-# OPTIONS --cubical --safe --postfix-projections #-}

module Algebra.Construct.Free.Semilattice.Direct where

open import Algebra
open import Prelude
open import Path.Reasoning
infixl 6 _∪_

data 𝒦 (A : Type a) : Type a where
  η : A → 𝒦 A
  _∪_ : 𝒦 A → 𝒦 A → 𝒦 A
  ∅ : 𝒦 A
  ∪-assoc : ∀ xs ys zs → (xs ∪ ys) ∪ zs ≡ xs ∪ (ys ∪ zs)
  ∪-commutative : ∀ xs ys → xs ∪ ys ≡ ys ∪ xs
  ∪-idempotent : ∀ xs → xs ∪ xs ≡ xs
  ∪-identity : ∀ xs → xs ∪ ∅ ≡ xs
  trunc : isSet (𝒦 A)

module _ (semiLattice : Semilattice b) where
  open Semilattice semiLattice
  module _ (sIsSet : isSet 𝑆) (h : A → 𝑆) where
    μ : 𝒦 A → 𝑆
    μ (η x) = h x
    μ (xs ∪ ys) = μ xs ∙ μ ys
    μ ∅ = ε
    μ (∪-assoc xs ys zs i) = assoc (μ xs) (μ ys) (μ zs) i
    μ (∪-commutative xs ys i) = comm (μ xs) (μ ys) i
    μ (∪-idempotent xs i) = idem (μ xs) i
    μ (∪-identity xs i) = ∙ε (μ xs) i
    μ (trunc xs ys x y i j) = sIsSet (μ xs) (μ ys) (cong μ x) (cong μ y) i j

module Eliminators where
  record _⇘_ {a p} (A : Type a) (P : 𝒦 A → Type p) : Type (a ℓ⊔ p) where
    constructor elim
    field
      ⟦_⟧-set : ∀ {xs} → isSet (P xs)
      ⟦_⟧∅ : P ∅
      ⟦_⟧_∪_⟨_∪_⟩ : ∀ xs ys → P xs → P ys → P (xs ∪ ys)
      ⟦_⟧η : ∀ x → P (η x)
    private z = ⟦_⟧∅; f = ⟦_⟧_∪_⟨_∪_⟩
    field
      ⟦_⟧-assoc : ∀ xs ys zs pxs pys pzs →
        f (xs ∪ ys) zs (f xs ys pxs pys) pzs ≡[ i ≔ P (∪-assoc xs ys zs i ) ]≡
        f xs (ys ∪ zs) pxs (f ys zs pys pzs)
      ⟦_⟧-commutative : ∀ xs ys pxs pys →
        f xs ys pxs pys ≡[ i ≔ P (∪-commutative xs ys i) ]≡ f ys xs pys pxs
      ⟦_⟧-idempotent : ∀ xs pxs →
        f xs xs pxs pxs ≡[ i ≔ P (∪-idempotent xs i) ]≡ pxs
      ⟦_⟧-identity : ∀ xs pxs → f xs ∅ pxs z ≡[ i ≔ P (∪-identity xs i) ]≡ pxs
    ⟦_⟧⇓ : ∀ xs → P xs
    ⟦ η x ⟧⇓ = ⟦_⟧η x
    ⟦ xs ∪ ys ⟧⇓ = f xs ys ⟦ xs ⟧⇓ ⟦ ys ⟧⇓
    ⟦ ∅ ⟧⇓ = z
    ⟦ ∪-assoc xs ys zs i ⟧⇓ = ⟦_⟧-assoc xs ys zs ⟦ xs ⟧⇓ ⟦ ys ⟧⇓ ⟦ zs ⟧⇓ i
    ⟦ ∪-commutative xs ys i ⟧⇓ = ⟦_⟧-commutative xs ys ⟦ xs ⟧⇓ ⟦ ys ⟧⇓ i
    ⟦ ∪-idempotent xs i ⟧⇓ = ⟦_⟧-idempotent xs ⟦ xs ⟧⇓ i
    ⟦ ∪-identity xs i ⟧⇓ = ⟦_⟧-identity xs ⟦ xs ⟧⇓ i
    ⟦ trunc xs ys x y i j ⟧⇓ =
        isOfHLevel→isOfHLevelDep 2
          (λ xs → ⟦_⟧-set {xs})
          ⟦ xs ⟧⇓ ⟦ ys ⟧⇓
          (cong ⟦_⟧⇓ x) (cong ⟦_⟧⇓ y)
          (trunc xs ys x y)
          i j
  open _⇘_ public

  infixr 0 ⇘-syntax
  ⇘-syntax = _⇘_
  syntax ⇘-syntax A (λ xs → Pxs) = xs ∈𝒦 A ⇒ Pxs

  record _⇲_ {a p} (A : Type a) (P : 𝒦 A  → Type p) : Type (a ℓ⊔ p) where
    constructor elim-prop
    field
      ∥_∥-prop : ∀ {xs} → isProp (P xs)
      ∥_∥∅ : P ∅
      ∥_∥_∪_⟨_∪_⟩ : ∀ xs ys → P xs → P ys → P (xs ∪ ys)
      ∥_∥η : ∀ x → P (η x)
    private z = ∥_∥∅; f = ∥_∥_∪_⟨_∪_⟩
    ∥_∥⇑ = elim
            (λ {xs} → isProp→isSet (∥_∥-prop {xs}))
            z f ∥_∥η
            (λ xs ys zs pxs pys pzs → toPathP (∥_∥-prop (transp (λ i → P (∪-assoc xs ys zs i)) i0 (f (xs ∪ ys) zs (f xs ys pxs pys) pzs)) (f xs (ys ∪ zs) pxs (f ys zs pys pzs) )))
            (λ xs ys pxs pys → toPathP (∥_∥-prop (transp (λ i → P (∪-commutative xs ys i)) i0 (f xs ys pxs pys)) (f ys xs pys pxs) ))
            (λ xs pxs → toPathP (∥_∥-prop (transp (λ i → P (∪-idempotent xs i)) i0 (f xs xs pxs pxs)) pxs))
            (λ xs pxs → toPathP (∥_∥-prop (transp (λ i → P (∪-identity xs i)) i0 (f xs ∅ pxs z)) pxs))
    ∥_∥⇓ = ⟦ ∥_∥⇑ ⟧⇓

  open _⇲_ public
  elim-prop-syntax : ∀ {a p} → (A : Type a) → (𝒦 A → Type p) → Type (a ℓ⊔ p)
  elim-prop-syntax = _⇲_

  syntax elim-prop-syntax A (λ xs → Pxs) = xs ∈𝒦 A ⇒∥ Pxs ∥

module _ {a} {A : Type a} where
  open Semilattice
  open CommutativeMonoid
  open Monoid
  𝒦-semilattice : Semilattice a
  𝒦-semilattice .commutativeMonoid .monoid .𝑆 = 𝒦 A
  𝒦-semilattice .commutativeMonoid .monoid ._∙_ = _∪_
  𝒦-semilattice .commutativeMonoid .monoid .ε = ∅
  𝒦-semilattice .commutativeMonoid .monoid .assoc = ∪-assoc
  𝒦-semilattice .commutativeMonoid .monoid .ε∙ x = ∪-commutative ∅ x ; ∪-identity x
  𝒦-semilattice .commutativeMonoid .monoid .∙ε = ∪-identity
  𝒦-semilattice .commutativeMonoid .comm = ∪-commutative
  𝒦-semilattice .idem = ∪-idempotent

import Algebra.Construct.Free.Semilattice as Listed

Listed→Direct : Listed.𝒦 A → 𝒦 A
Listed→Direct = Listed.μ 𝒦-semilattice trunc η

Direct→Listed : 𝒦 A → Listed.𝒦 A
Direct→Listed = μ Listed.𝒦-semilattice Listed.trunc (Listed._∷ Listed.[])

Listed→Direct→Listed : (xs : Listed.𝒦 A) → Direct→Listed (Listed→Direct xs) ≡ xs
Listed→Direct→Listed = ∥ ldl ∥⇓
  where
  open Listed using (_⇲_; elim-prop-syntax)
  open _⇲_

  ldl : xs ∈𝒦 A ⇒∥ Direct→Listed (Listed→Direct xs) ≡ xs ∥
  ∥ ldl ∥-prop = Listed.trunc _ _
  ∥ ldl ∥[] = refl
  ∥ ldl ∥ x ∷ xs ⟨ Pxs ⟩ = cong (x Listed.∷_) Pxs

open Eliminators

Direct→Listed→Direct : (xs : 𝒦 A) → Listed→Direct (Direct→Listed xs) ≡ xs
Direct→Listed→Direct = ∥ dld ∥⇓
  where
  dld : xs ∈𝒦 A ⇒∥ Listed→Direct (Direct→Listed xs) ≡ xs ∥
  ∥ dld ∥-prop = trunc _ _
  ∥ dld ∥∅ = refl
  ∥ dld ∥η x = ∪-identity (η x)
  ∥ dld ∥ xs ∪ ys ⟨ Pxs ∪ Pys ⟩ =
    sym (Listed.∙-hom 𝒦-semilattice trunc η (Direct→Listed xs) (Direct→Listed ys)) ;
    cong₂ _∪_ Pxs Pys

Direct⇔Listed : 𝒦 A ⇔ Listed.𝒦 A
Direct⇔Listed .fun = Direct→Listed
Direct⇔Listed .inv = Listed→Direct
Direct⇔Listed .rightInv = Listed→Direct→Listed
Direct⇔Listed .leftInv = Direct→Listed→Direct


-- An example of something where normalization is surprisingly slow
{-# OPTIONS --cubical --safe #-}
module Cubical.Experiments.Problem where

open import Cubical.Core.Everything

open import Cubical.Foundations.Prelude

open import Cubical.Data.Int

open import Cubical.HITs.S1
open import Cubical.HITs.S2
open import Cubical.HITs.S3
open import Cubical.HITs.Join
open import Cubical.HITs.Hopf

ptType : Type _
ptType = Σ Type₀ \ A → A

pt : (A : ptType) → A .fst
pt A = A .snd

S¹pt : ptType
S¹pt = (S¹ , base)
S²pt : ptType
S²pt = (S² , base)
S³pt : ptType
S³pt = (S³ , base)
joinpt : ptType
joinpt = (join S¹ S¹ , inl base)

Ω : (A : ptType) → ptType
Ω A = Path _ (pt A) (pt A) , refl
Ω² : (A : ptType) → ptType
Ω² A = Ω (Ω A)
Ω³ : (A : ptType) → ptType
Ω³ A = Ω² (Ω A)

α : join S¹ S¹ → S²
α (inl _) = base
α (inr _) = base
α (push x y i) = (merid y ∙ merid x) i
  where
  merid : S¹ → Path S² base base
  merid base = refl
  merid (loop i) = λ j → surf i j

-- The tests

test0To2 : Ω³ S³pt .fst
test0To2 i j k = surf i j k

f3 : Ω³ S³pt .fst → Ω³ joinpt .fst
f3 p i j k = S³→joinS¹S¹ (p i j k)

test0To3 : Ω³ joinpt .fst
test0To3 = f3 test0To2

f4 : Ω³ joinpt .fst → Ω³ S²pt .fst
f4 p i j k = α (p i j k)

test0To4 : Ω³ S²pt .fst
test0To4 = f4 test0To3

innerpath : ∀ i j → HopfS² (test0To4 i j i1)
innerpath i j = transp (λ k → HopfS² (test0To4 i j k)) i0 base

-- C-c C-n problem uses a lot of memory
problem : pos 0 ≡ pos 0
problem i = transp (λ j → helix (innerpath i j)) i0 (pos 0)

-- Lots of tests: (thanks Evan!)

winding2 : Path (Path S² base base) refl refl → Int
winding2 p = winding (λ j → transp (λ i → HopfS² (p i j)) i0 base)

test0 : Int
test0 = winding2 (λ i j → surf i j)

test1 : Int
test1 = winding2 (λ i j → surf j i)

test2 : Int
test2 = winding2 (λ i j → hcomp (λ _ → λ { (i = i0) → base ; (i = i1) → base ; (j = i0) → base ; (j = i1) → base}) (surf i j))

test3 : Int
test3 = winding2 (λ i j → hcomp (λ k → λ { (i = i0) → surf j k ; (i = i1) → base ; (j = i0) → base ; (j = i1) → base}) base)

test4 : Int
test4 = winding2 (λ i j → hcomp (λ k → λ { (i = i0) → surf j k ; (i = i1) → base ; (j = i0) → base ; (j = i1) → base}) base)

test5 : Int
test5 = winding2 (λ i j → hcomp (λ k → λ { (i = i0) → base ; (i = i1) → base ; (j = i0) → surf k i ; (j = i1) → base}) base)

test6 : Int
test6 = winding2 (λ i j → hcomp (λ k → λ { (i = i0) → base ; (i = i1) → base ; (j = i0) → base ; (j = i1) → surf k i}) base)

test7 : Int
test7 = winding2 (λ i j → hcomp (λ k → λ { (i = i0) → base ; (i = i1) → surf j k ; (j = i0) → base ; (j = i1) → base}) (surf i j))

test8 : Int
test8 = winding2 (λ i j → hcomp (λ k → λ { (i = i0) → base ; (i = i1) → base ; (j = i0) → surf k i ; (j = i1) → base}) (surf i j))

test9 : Int
test9 = winding2 (λ i j → hcomp (λ k → λ { (i = i0) → base ; (i = i1) → base ; (j = i0) → base ; (j = i1) → surf k i}) (surf i j))

test10 : Int
test10 = winding2 (λ i j → hcomp (λ k → λ { (i = i0) → surf j k ; (i = i1) → base ; (j = i0) → base ; (j = i1) → base}) (surf i j))

-- Tests using HopfS²'

winding2' : Path (Path S² base base) refl refl → Int
winding2' p = winding (λ j → transp (λ i → HopfS²' (p i j)) i0 base)

test0' : Int
test0' = winding2' (λ i j → surf i j)

test1' : Int
test1' = winding2' (λ i j → surf j i)

test2' : Int
test2' = winding2' (λ i j → hcomp (λ _ → λ { (i = i0) → base ; (i = i1) → base ; (j = i0) → base ; (j = i1) → base}) (surf i j))

test3' : Int
test3' = winding2' (λ i j → hcomp (λ k → λ { (i = i0) → surf j k ; (i = i1) → base ; (j = i0) → base ; (j = i1) → base}) base)

test4' : Int
test4' = winding2' (λ i j → hcomp (λ k → λ { (i = i0) → surf j k ; (i = i1) → base ; (j = i0) → base ; (j = i1) → base}) base)

test5' : Int
test5' = winding2' (λ i j → hcomp (λ k → λ { (i = i0) → base ; (i = i1) → base ; (j = i0) → surf k i ; (j = i1) → base}) base)

test6' : Int
test6' = winding2' (λ i j → hcomp (λ k → λ { (i = i0) → base ; (i = i1) → base ; (j = i0) → base ; (j = i1) → surf k i}) base)

test7' : Int
test7' = winding2' (λ i j → hcomp (λ k → λ { (i = i0) → base ; (i = i1) → surf j k ; (j = i0) → base ; (j = i1) → base}) (surf i j))

test8' : Int
test8' = winding2' (λ i j → hcomp (λ k → λ { (i = i0) → base ; (i = i1) → base ; (j = i0) → surf k i ; (j = i1) → base}) (surf i j))

test9' : Int
test9' = winding2' (λ i j → hcomp (λ k → λ { (i = i0) → base ; (i = i1) → base ; (j = i0) → base ; (j = i1) → surf k i}) (surf i j))

test10' : Int
test10' = winding2' (λ i j → hcomp (λ k → λ { (i = i0) → surf j k ; (i = i1) → base ; (j = i0) → base ; (j = i1) → base}) (surf i j))


module Issue1494.Helper where

record Record : Set₁ where
  field _≡_ : {A : Set} → A → A → Set

module Module (r : Record) where

  open Record r public


open import Prelude

module Implicits.Improved.Stack.Expressiveness where

open import Coinduction
open import Data.Fin.Substitution
open import Implicits.Oliveira.Types
open import Implicits.Oliveira.Terms
open import Implicits.Oliveira.Contexts
open import Implicits.Oliveira.Substitutions
open import Implicits.Oliveira.Deterministic.Resolution as D
open import Implicits.Oliveira.Ambiguous.Resolution as A
open import Implicits.Improved.Stack.Resolution as F
open import Implicits.Improved.Infinite.Resolution as ∞

module Finite⊆Infinite where

  p : ∀ {ν} {a} {Δ : ICtx ν} {s} → Δ F.& s ⊢ᵣ a → Δ ∞.⊢ᵣ a
  p (r-simp a a↓τ) = r-simp a (lem a↓τ)
    where
      lem : ∀ {ν} {a τ r} {Δ : ICtx ν} {r∈Δ : r List.∈ Δ} {s : Stack Δ} →
            Δ F.& s , r∈Δ ⊢ a ↓ τ → Δ ∞.⊢ a ↓ τ
      lem (i-simp τ) = i-simp τ
      lem (i-iabs _ ⊢ᵣa b↓τ) = i-iabs (♯ (p ⊢ᵣa)) (lem b↓τ)
      lem (i-tabs b a[/b]↓τ) = i-tabs b (lem a[/b]↓τ)
  p (r-iabs x) = r-iabs (p x)
  p (r-tabs x) = r-tabs (p x)

module Finite⊆OliveiraAmbiguous where

  p : ∀ {ν} {a} {Δ : ICtx ν} {s} → Δ F.& s ⊢ᵣ a → Δ A.⊢ᵣ a
  p (r-simp a a↓τ) = lem a↓τ (r-ivar a)
    where
      lem : ∀ {ν} {a r τ} {Δ : ICtx ν} {r∈Δ : r List.∈ Δ} {s} →
            Δ F.& s , r∈Δ ⊢ a ↓ τ → Δ A.⊢ᵣ a → Δ A.⊢ᵣ simpl τ
      lem (i-simp τ) K⊢ᵣτ = K⊢ᵣτ
      lem (i-iabs _ ⊢ᵣa b↓τ) K⊢ᵣa⇒b = lem b↓τ (r-iapp K⊢ᵣa⇒b (p ⊢ᵣa))
      lem (i-tabs b a[/b]↓τ) K⊢ᵣ∀a = lem a[/b]↓τ (r-tapp b K⊢ᵣ∀a)
  p (r-iabs x) = r-iabs (p x)
  p (r-tabs x) = r-tabs (p x)

module OliveiraDeterministic⊆Finite where

  open FirstLemmas

  -- Oliveira's termination condition is part of the well-formdness of types
  -- So we assume here that ⊢term x holds for all types x
  p : ∀ {ν} {a : Type ν} {Δ : ICtx ν} s →
      (∀ {μ} (x : Type μ) → ⊢term x) → Δ D.⊢ᵣ a → Δ F.& s ⊢ᵣ a
  p s term (r-simp {ρ = r} x r↓a) =
    r-simp (proj₁ $ FirstLemmas.first⟶∈ x) (lem (proj₁ $ first⟶∈ x) s r↓a)
    where
      lem : ∀ {ν r'} {Δ : ICtx ν} (r∈Δ : r' List.∈ Δ) {a r} s → Δ D.⊢ r ↓ a → Δ F.& s , r∈Δ ⊢ r ↓ a
      lem r∈Δ s (i-simp a) = i-simp a
      lem r∈Δ s (i-iabs {ρ₁ = ρ₁} ⊢ᵣρ₁ ρ₂↓τ) =
        i-iabs (push< s r∈Δ {!!}) (p (s push ρ₁ for r∈Δ) term ⊢ᵣρ₁) (lem r∈Δ s ρ₂↓τ)
      lem r∈Δ s (i-tabs b x₁) = i-tabs b (lem r∈Δ s x₁)
  p s term (r-iabs ρ₁ {ρ₂ = ρ₂} x) = r-iabs (p (s prepend ρ₂) term x)
  p s term (r-tabs x) = r-tabs (p (stack-weaken s) term x)


{-# OPTIONS --cubical --save-metas #-}

module Erased-cubical-Pattern-matching-Cubical where

data D : Set where
  c₁ c₂ : D


module Issue2756 where

module M where

  postulate A : Set

module M′ = M

B : Set
B = M′.A


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

open import HoTT
open import homotopy.PtdAdjoint
open import homotopy.SuspAdjointLoop
open import cohomology.Exactness
open import cohomology.FunctionOver
open import cohomology.MayerVietoris
open import cohomology.Theory

{- Standard Mayer-Vietoris exact sequence (algebraic) derived from
 - the result in cohomology.MayerVietoris (topological).
 - This is a whole bunch of algebra which is not very interesting.
 -}

module cohomology.MayerVietorisExact {i} (CT : CohomologyTheory i)
  (n : ℤ) (ps : ⊙Span {i} {i} {i}) where

open MayerVietorisFunctions ps
module MV = MayerVietoris ps
open ⊙Span ps

open CohomologyTheory CT
open import cohomology.BaseIndependence CT
open import cohomology.Functor CT
open import cohomology.InverseInSusp CT
open import cohomology.LongExactSequence CT n ⊙reglue
open import cohomology.Wedge CT

mayer-vietoris-seq : HomSequence _ _
mayer-vietoris-seq =
  C n (⊙Pushout ps)
    ⟨ ×ᴳ-hom-in (CF-hom n (⊙left ps)) (CF-hom n (⊙right ps)) ⟩→
  C n X ×ᴳ C n Y
    ⟨ ×ᴳ-sum-hom (C-abelian _ _) (CF-hom n f)
                 (inv-hom _ (C-abelian _ _) ∘ᴳ (CF-hom n g)) ⟩→
  C n Z
    ⟨ CF-hom (succ n) ⊙ext-glue ∘ᴳ fst ((C-Susp n Z)⁻¹ᴳ) ⟩→
  C (succ n) (⊙Pushout ps)
    ⟨ ×ᴳ-hom-in (CF-hom _ (⊙left ps)) (CF-hom _ (⊙right ps)) ⟩→
  C (succ n) X ×ᴳ C (succ n) Y ⊣|

mayer-vietoris-exact : is-exact-seq mayer-vietoris-seq
mayer-vietoris-exact =
  transport (λ {(r , s) → is-exact-seq s})
    (pair= _ $ sequence= _ _ $
      idp
        ∥⟨ ↓-over-×-in _→ᴳ_ idp (CWedge.⊙wedge-rec-over n X Y _ _) ⟩∥
      CWedge.path n X Y
        ∥⟨ ↓-over-×-in' _→ᴳ_
             (ap↓ (λ φ → φ ∘ᴳ fst (C-Susp n (X ⊙∨ Y) ⁻¹ᴳ))
                  (CF-↓cod= (succ n) MV.ext-over)
              ∙ᵈ codomain-over-iso {χ = diff'} (codomain-over-equiv _ _))
             (CWedge.wedge-hom-η n X Y _
              ▹ ap2 (×ᴳ-sum-hom (C-abelian n Z)) inl-lemma inr-lemma) ⟩∥
      ap (C (succ n)) MV.⊙path ∙ group-ua (C-Susp n Z)
        ∥⟨ ↓-over-×-in _→ᴳ_
            (CF-↓dom= (succ n) MV.cfcod-over
             ∙ᵈ domain-over-iso
                  (! (ap (λ h → CF _ ⊙ext-glue ∘ h)
                     (λ= (is-equiv.g-f (snd (C-Susp n Z)))))
                   ◃ domain-over-equiv _ _))
            idp                                              ⟩∥
      idp
        ∥⟨ ↓-over-×-in _→ᴳ_ idp (CWedge.⊙wedge-rec-over (succ n) X Y _ _) ⟩∥
      CWedge.path (succ n) X Y ∥⊣|)
    long-cofiber-exact
  where
  {- shorthand -}
  diff' = fst (C-Susp n Z) ∘ᴳ CF-hom (succ n) MV.⊙mv-diff
                           ∘ᴳ fst (C-Susp n (X ⊙∨ Y) ⁻¹ᴳ)

  {- Variations on suspension axiom naturality -}
  natural-lemma₁ : {X Y : Ptd i} (n : ℤ) (f : fst (X ⊙→ Y))
    → (fst (C-Susp n X) ∘ᴳ CF-hom _ (⊙susp-fmap f)) ∘ᴳ fst (C-Susp n Y ⁻¹ᴳ)
      == CF-hom n f
  natural-lemma₁ {X} {Y} n f =
    ap (λ φ → φ ∘ᴳ fst (C-Susp n Y ⁻¹ᴳ)) (C-SuspF n f)
    ∙ hom= _ _ (λ= (ap (CF n f) ∘ is-equiv.f-g (snd (C-Susp n Y))))

  natural-lemma₂ : {X Y : Ptd i} (n : ℤ) (f : fst (X ⊙→ Y))
    → CF-hom _ (⊙susp-fmap f) ∘ᴳ fst (C-Susp n Y ⁻¹ᴳ)
      == fst (C-Susp n X ⁻¹ᴳ) ∘ᴳ CF-hom n f
  natural-lemma₂ {X} {Y} n f =
    hom= _ _ (λ= (! ∘ is-equiv.g-f (snd (C-Susp n X))
                    ∘ CF _ (⊙susp-fmap f)
                    ∘ GroupHom.f (fst (C-Susp n Y ⁻¹ᴳ))))
    ∙ ap (λ φ → fst (C-Susp n X ⁻¹ᴳ) ∘ᴳ φ) (natural-lemma₁ n f)

  {- Associativity lemmas -}
  assoc-lemma : ∀ {i} {G H K L J : Group i}
    (φ : L →ᴳ J) (ψ : K →ᴳ L) (χ : H →ᴳ K) (ξ : G →ᴳ H)
    → (φ ∘ᴳ ψ) ∘ᴳ χ ∘ᴳ ξ == φ ∘ᴳ ((ψ ∘ᴳ χ) ∘ᴳ ξ)
  assoc-lemma _ _ _ _ = hom= _ _ idp

  assoc-lemma₂ : ∀ {i} {G H K L J : Group i}
    (φ : L →ᴳ J) (ψ : K →ᴳ L) (χ : H →ᴳ K) (ξ : G →ᴳ H)
    → (φ ∘ᴳ ψ ∘ᴳ χ) ∘ᴳ ξ == φ ∘ᴳ ψ ∘ᴳ χ ∘ᴳ ξ
  assoc-lemma₂ _ _ _ _ = hom= _ _ idp

  inl-lemma : diff' ∘ᴳ CF-hom n (⊙projl X Y) == CF-hom n f
  inl-lemma =
    assoc-lemma₂
      (fst (C-Susp n Z)) (CF-hom (succ n) MV.⊙mv-diff)
      (fst (C-Susp n (X ⊙∨ Y) ⁻¹ᴳ)) (CF-hom n (⊙projl X Y))
    ∙ ap (λ φ → fst (C-Susp n Z) ∘ᴳ CF-hom (succ n) MV.⊙mv-diff ∘ᴳ φ)
         (! (natural-lemma₂ n (⊙projl X Y)))
    ∙ ! (assoc-lemma₂
           (fst (C-Susp n Z)) (CF-hom _ MV.⊙mv-diff)
           (CF-hom _ (⊙susp-fmap (⊙projl X Y)))
           (fst (C-Susp n X ⁻¹ᴳ)))
    ∙ ap (λ φ → (fst (C-Susp n Z) ∘ᴳ φ) ∘ᴳ fst (C-Susp n X ⁻¹ᴳ))
         (! (CF-comp _ (⊙susp-fmap (⊙projl X Y)) MV.⊙mv-diff))
    ∙ ap (λ φ → (fst (C-Susp n Z) ∘ᴳ φ) ∘ᴳ fst (C-Susp n X ⁻¹ᴳ))
         (CF-λ= (succ n) projl-mv-diff)
    ∙ natural-lemma₁ n f
    where
    {- Compute the left projection of mv-diff -}
    projl-mv-diff : (σz : fst (⊙Susp Z))
      → susp-fmap (projl X Y) (MV.mv-diff σz)
        == susp-fmap (fst f) σz
    projl-mv-diff = Suspension-elim _ idp (merid _ (snd X)) $
      ↓-='-from-square ∘ λ z →
        (ap-∘ (susp-fmap (projl X Y)) MV.mv-diff (merid _ z)
         ∙ ap (ap (susp-fmap (projl X Y))) (MV.MVDiff.glue-β z)
         ∙ ap-∙ (susp-fmap (projl X Y))
                (merid _ (winl (fst f z))) (! (merid _ (winr (fst g z))))
         ∙ (SuspFmap.glue-β (projl X Y) (winl (fst f z))
            ∙2 (ap-! (susp-fmap _) (merid _ (winr (fst g z)))
                ∙ ap ! (SuspFmap.glue-β (projl X Y) (winr (fst g z))))))
        ∙v⊡ (vid-square {p = merid _ (fst f z)}
             ⊡h rt-square (merid _ (snd X)))
        ⊡v∙ (∙-unit-r _ ∙ ! (SuspFmap.glue-β (fst f) z))

  inr-lemma : diff' ∘ᴳ CF-hom n (⊙projr X Y)
                           == inv-hom _ (C-abelian n Z) ∘ᴳ CF-hom n g
  inr-lemma =
    assoc-lemma₂
      (fst (C-Susp n Z)) (CF-hom (succ n) MV.⊙mv-diff)
      (fst (C-Susp n (X ⊙∨ Y) ⁻¹ᴳ)) (CF-hom n (⊙projr X Y))
    ∙ ap (λ φ → fst (C-Susp n Z) ∘ᴳ CF-hom (succ n) MV.⊙mv-diff ∘ᴳ φ)
         (! (natural-lemma₂ n (⊙projr X Y)))
    ∙ ! (assoc-lemma₂
           (fst (C-Susp n Z)) (CF-hom _ MV.⊙mv-diff)
           (CF-hom _ (⊙susp-fmap (⊙projr X Y)))
           (fst (C-Susp n Y ⁻¹ᴳ)))
    ∙ ap (λ φ → (fst (C-Susp n Z) ∘ᴳ φ) ∘ᴳ fst (C-Susp n Y ⁻¹ᴳ))
         (! (CF-comp _ (⊙susp-fmap (⊙projr X Y)) MV.⊙mv-diff))
    ∙ ∘ᴳ-assoc (fst (C-Susp n Z))
        (CF-hom _ (⊙susp-fmap (⊙projr X Y) ⊙∘ MV.⊙mv-diff))
        (fst (C-Susp n Y ⁻¹ᴳ))
    ∙ ap (λ φ → fst (C-Susp n Z) ∘ᴳ φ ∘ᴳ fst (C-Susp n Y ⁻¹ᴳ))
         (CF-λ= (succ n) projr-mv-diff)
    ∙ ap (λ φ → fst (C-Susp n Z) ∘ᴳ φ ∘ᴳ fst (C-Susp n Y ⁻¹ᴳ))
         (CF-comp _ (⊙susp-fmap g) (⊙flip-susp Z))
    ∙ ! (assoc-lemma (fst (C-Susp n Z)) (CF-hom _ (⊙flip-susp Z))
                     (CF-hom _ (⊙susp-fmap g)) (fst (C-Susp n Y ⁻¹ᴳ)))
    ∙ ap (λ φ → (fst (C-Susp n Z) ∘ᴳ φ)
                ∘ᴳ CF-hom _ (⊙susp-fmap g) ∘ᴳ fst (C-Susp n Y ⁻¹ᴳ))
         (C-flip-susp-is-inv (succ n))
    ∙ ap (λ φ → φ ∘ᴳ CF-hom _ (⊙susp-fmap g) ∘ᴳ fst (C-Susp n Y ⁻¹ᴳ))
         (inv-hom-natural (C-abelian _ _) (C-abelian _ _)
           (fst (C-Susp n Z)))
    ∙ assoc-lemma (inv-hom _ (C-abelian n Z)) (fst (C-Susp n Z))
                  (CF-hom _ (⊙susp-fmap g)) (fst (C-Susp n Y ⁻¹ᴳ))
    ∙ ap (λ φ → inv-hom _ (C-abelian n Z) ∘ᴳ φ) (natural-lemma₁ n g)
    where
    {- Compute the right projection of mv-diff -}
    projr-mv-diff : (σz : fst (⊙Susp Z))
      → susp-fmap (projr X Y) (MV.mv-diff σz)
        == susp-fmap (fst g) (flip-susp σz)
    projr-mv-diff = Suspension-elim _ (merid _ (snd Y)) idp $
      ↓-='-from-square ∘ λ z →
        (ap-∘ (susp-fmap (projr X Y)) MV.mv-diff (merid _ z)
         ∙ ap (ap (susp-fmap (projr X Y))) (MV.MVDiff.glue-β z)
         ∙ ap-∙ (susp-fmap (projr X Y))
             (merid _ (winl (fst f z))) (! (merid _ (winr (fst g z))))
         ∙ (SuspFmap.glue-β (projr X Y) (winl (fst f z))
            ∙2 (ap-! (susp-fmap (projr X Y))
                  (merid _ (winr (fst g z)))
                ∙ ap ! (SuspFmap.glue-β (projr X Y) (winr (fst g z))))))
        ∙v⊡ ((lt-square (merid _ (snd Y))
             ⊡h vid-square {p = ! (merid _ (fst g z))}))
        ⊡v∙ ! (ap-∘ (susp-fmap (fst g)) flip-susp (merid _ z)
               ∙ ap (ap (susp-fmap (fst g))) (FlipSusp.glue-β z)
               ∙ ap-! (susp-fmap (fst g)) (merid _ z)
               ∙ ap ! (SuspFmap.glue-β (fst g) z))


postulate
  @0 A : Set

_ : @0 Set → (Set → Set) → Set
_ = λ @0 where
  A G → G A


module Plain.Models where

open import Data.Nat
open import Plain.Terms

-- The (complete) Herbrand universe for Σ
U' : {n : ℕ} → (Signature n) → Set
U' Σ = GTerm Σ

open import Relation.Unary as U
open import Level

-- a (complete) Herbrand interpretation
record Interp {n : ℕ} (Σ : Signature n) : Set₁ where
  field
    Carrier : Pred (U' Σ) Level.zero
open Interp

_∩ᵢ_ : {n : ℕ} → {Σ : Signature n} → Interp Σ → Interp Σ
  → Interp Σ
i₁ ∩ᵢ i₂ = record { Carrier = (Carrier i₁) U.∩ Carrier i₂ }

_∪ᵢ_ : {n : ℕ} → {Σ : Signature n} → Interp Σ → Interp Σ
  → Interp Σ
i₁ ∪ᵢ i₂ = record { Carrier = (Carrier i₁) U.∪ Carrier i₂ }

open import Data.List as L
open import Data.List.All as LAl
open import Data.List.Any as LAn
open import Relation.Binary.Core

open Program

-- | Inductive model property
record IsIndModel {n : ℕ}
  {Σ : Signature n} (i : Interp Σ) (P : Program Σ) : Set₂ where
  field
    forwClosed :
      (bs' : List (GTerm Σ))
      → All (λ b → b ∈ Carrier i) bs'
      → (σ : GSubst Σ)
      → (a : Term Σ Var)
      → (bs : List (Term Σ Var))
      → Any (λ cl → cl ≡ (a :- bs)) (prg P)
      → (L.map (app σ) bs) ≡ bs'
      → (app σ a ∈ Carrier i)
open IsIndModel

-- | Ind Model
record IndModel {n : ℕ}
  {Σ : Signature n} (P : Program Σ) : Set₂ where
  field
    iInterp : Interp Σ
    isIndModel : IsIndModel iInterp P

open IndModel

open import Data.Product
open import Data.List.All.Properties -- using (All-map)

{-
-- | Model intersection
_∩m_ : {n : ℕ} → {Σ : Signature n} → {P : Program Σ}
  → (m₁ : IndModel P) → (m₂ : IndModel P)
  → IndModel P
_∩m_ {n} {Σ} {P} m₁ m₂ = record
  { interp = interp m₁ ∩ᵢ interp m₂
  ; isIndModel = prop-model-intersection-pair P m₁ m₂ }
-}

⋂ᵢ : {n : ℕ} → {Σ : Signature n} →
  (I : Set) → (I → Interp Σ)
  → Interp Σ
⋂ᵢ I f = record { Carrier = ⋂ I (λ i t → t ∈ Carrier (f i)) }

open import Function

prop-model-intersection : {n : ℕ} → {Σ : Signature n} →
  (P : Program Σ)
  → (I : Set) -- ^ is non-empty by what argument?
  → (mps : I → IndModel P)
  → IsIndModel ( ⋂ᵢ I (iInterp ∘ mps)) P
prop-model-intersection P I mps =
  record { forwClosed = λ bs' pbs' σ a bs pcl pbs i →
    forwClosed (isIndModel (mps i)) bs'
      (LAl.map (λ k → k i) pbs')
      σ a bs pcl pbs
    }

-- | Coinductive model
record IsCoiModel {n : ℕ}
  {Σ : Signature n} (i : Interp Σ) (P : Program Σ) : Set₂ where
  field
    backClosed :
      {a : Term Σ Var} → {bs : List (Term Σ Var)}
      → (a' : GTerm Σ)
      → a' ∈ Carrier i
      → ∃ (λ (σclsp : GSubst Σ ×
        Any (λ c → a :- bs ≡ c) (prg P))
      → app (proj₁ σclsp) a ≡ a'
      → All (λ c → c ∈ Carrier i) (L.map (app (proj₁ σclsp)) bs))
open IsCoiModel

-- | Coi Model
record CoiModel {n : ℕ}
  {Σ : Signature n} (P : Program Σ) : Set₂ where
  field
    cInterp : Interp Σ
    isCoiModel : IsCoiModel cInterp P

open CoiModel

⋃ᵢ : {n : ℕ} → {Σ : Signature n} →
  (I : Set) → (I → Interp Σ)
  → Interp Σ
⋃ᵢ I f = record { Carrier = λ x → ⋃ I (λ i t → t ∈ Carrier (f i)) x }

open import Data.Product as DP

-- | model union property
prop-model-union : {n : ℕ} → {Σ : Signature n} →
  (P : Program Σ)
  → (I : Set) -- ^ is non-empty by what argument?
  → (mps : I → CoiModel P)
  → IsCoiModel ( ⋃ᵢ I (cInterp ∘ mps)) P
prop-model-union P I mps =
  record { backClosed = λ a' x →
    DP.map (λ id → id)
           (λ x₂ x₃ → LAl.map (λ x₄ → proj₁ x , x₄) (x₂ x₃))
           (backClosed (isCoiModel (mps (proj₁ x))) a' (proj₂ x)) }

open import Data.Unit

prop-ex-ind-model : {n : ℕ} → {Σ : Signature n}
  → (P : Program Σ)
  → IndModel P
prop-ex-ind-model P = record
  { iInterp = record { Carrier = U }
  ; isIndModel = record { forwClosed = λ bs' x σ a bs x₁ x₂ → tt }
  }

open import Data.Empty

prop-ex-coi-model : {n : ℕ} → {Σ : Signature n}
  → (P : Program Σ)
  → CoiModel P
prop-ex-coi-model P = record
  { cInterp = record { Carrier = ∅ }
  ; isCoiModel = record { backClosed = λ a' () }
  }


open import Algebra
open import Data.Nat as ℕ using (ℕ; suc; zero)
open import Data.Pos as ℕ⁺
open import Data.List as L using (List; []; _∷_; _++_)
open import Data.List.Any as LA using (Any; here; there)
open import Data.List.Any.BagAndSetEquality as B
open import Data.Product as PR using (∃; _×_; _,_; proj₁; proj₂)
open import Data.Sum using (_⊎_; inj₁; inj₂)
open import Function using (_$_; flip)
open import Function.Equality using (_⟨$⟩_)
open import Function.Inverse as I using ()
open import Relation.Binary.PropositionalEquality as P using (_≡_; _≢_)

open import Data.Environment
open import nodcap.Base
open import nodcap.NF.Typing

module nodcap.NF.Expand where

open I.Inverse using (to; from)
private module ++ {a} {A : Set a} = Monoid (L.monoid A)

{-# TERMINATING #-}
-- Lemma:
--   We can expand an instance of ?[ n ] A into n repetitions of A,
--   by induction on n.
--
-- Problematic calls:
--   * in the recursive call under cont, the index n is split as
--     n₁ + n₂, for which we have n₁, n₂ < n, but not definitionally.
mutual
  expand : {Γ : Environment} {A : Type} {n : ℕ⁺} →

    ⊢ⁿᶠ ?[ n ] A ∷ Γ →
    --------------------
    ⊢ⁿᶠ replicate⁺ n A ++ Γ

  expand (mk?₁ x) = x
  expand (cont {Γ} {A} {m} {n} x)
    = P.subst (λ Δ → ⊢ⁿᶠ Δ ++ Γ) (replicate⁺-++-commute m n)
    $ P.subst ⊢ⁿᶠ_ (P.sym (++.assoc (replicate⁺ m A) (replicate⁺ n A) Γ))
    $ exch (swp [] (replicate⁺ m A) (replicate⁺ n A))
    $ expand {n = n}
    $ exch (fwd [] (replicate⁺ m A))
    $ expand {n = m} x
  expand {Γ} {A} {n} (exch b x)
    = exch (B.++-cong {xs₁ = replicate⁺ n A} I.id (del-from b (here P.refl)))
    $ expandIn (from b ⟨$⟩ here P.refl) x

  expandIn : {Γ : Environment} {A : Type} {n : ℕ⁺} (i : ?[ n ] A ∈ Γ) →

    ⊢ⁿᶠ Γ →
    ----------------------------
    ⊢ⁿᶠ replicate⁺ n A ++ Γ - i

  expandIn (here P.refl) x = expand x
  expandIn {_} {A} {n} (there i) (send {Γ} {Δ} x h)
    with split Γ i
  ... | inj₁ (j , p) rewrite p
      = exch (swp [] (replicate⁺ n A) (_ ∷ []))
      $ P.subst ⊢ⁿᶠ_ (++.assoc (_ ∷ replicate⁺ n A) (Γ - j) Δ)
      $ flip send h
      $ exch (swp [] (_ ∷ []) (replicate⁺ n A))
      $ expandIn (there j) x
  ... | inj₂ (j , p) rewrite p
      = exch (swp [] (replicate⁺ n A) (_ ∷ Γ))
      $ send x
      $ exch (swp [] (_ ∷ []) (replicate⁺ n A))
      $ expandIn (there j) h
  expandIn {Γ} {A} {n} (there i) (recv x)
    = exch (swp [] (replicate⁺ n A) (_ ∷ []))
    $ recv
    $ exch (swp [] (_ ∷ _ ∷ []) (replicate⁺ n A))
    $ expandIn (there (there i)) x
  expandIn {Γ} {A} {n} (there i) (sel₁ x)
    = exch (swp [] (replicate⁺ n A) (_ ∷ []))
    $ sel₁
    $ exch (swp [] (_ ∷ []) (replicate⁺ n A))
    $ expandIn (there i) x
  expandIn {Γ} {A} {n} (there i) (sel₂ x)
    = exch (swp [] (replicate⁺ n A) (_ ∷ []))
    $ sel₂
    $ exch (swp [] (_ ∷ []) (replicate⁺ n A))
    $ expandIn (there i) x
  expandIn {Γ} {A} {n} (there i) (case x h)
    = exch (swp [] (replicate⁺ n A) (_ ∷ []))
    $ case
      ( exch (swp [] (_ ∷ []) (replicate⁺ n A))
      $ expandIn (there i) x )
      ( exch (swp [] (_ ∷ []) (replicate⁺ n A))
      $ expandIn (there i) h )
  expandIn (there ()) halt
  expandIn {Γ} {A} {n} (there i) (wait x)
    = exch (swp [] (replicate⁺ n A) (_ ∷ []))
    $ wait
    $ expandIn i x
  expandIn {Γ} {A} {n} (there i)  loop
    = exch (swp [] (replicate⁺ n A) (_ ∷ []))
    $ loop
  expandIn {Γ} {A} {n} (there i) (mk?₁ x)
    = exch (swp [] (replicate⁺ n A) (_ ∷ []))
    $ mk?₁
    $ exch (swp [] (_ ∷ []) (replicate⁺ n A))
    $ expandIn (there i) x
  expandIn {Γ} {A} {n} (there i) (mk!₁ x)
    = exch (swp [] (replicate⁺ n A) (_ ∷ []))
    $ mk!₁
    $ exch (swp [] (_ ∷ []) (replicate⁺ n A))
    $ expandIn (there i) x
  expandIn {Γ} {A} {n} (there i) (cont x)
    = exch (swp [] (replicate⁺ n A) (_ ∷ []))
    $ cont
    $ exch (swp [] (_ ∷ _ ∷ []) (replicate⁺ n A))
    $ expandIn (there (there i)) x
  expandIn {_} {A} {n} (there i) (pool {Γ} {Δ} x y)
    with split Γ i
  ... | inj₁ (j , p) rewrite p
      = exch (swp [] (replicate⁺ n A) (_ ∷ []))
      $ P.subst ⊢ⁿᶠ_ (++.assoc (_ ∷ replicate⁺ n A) (Γ - j) Δ)
      $ flip pool y
      $ exch (swp [] (_ ∷ []) (replicate⁺ n A))
      $ expandIn (there j) x
  ... | inj₂ (j , p) rewrite p
      = exch (swp [] (replicate⁺ n A) (_ ∷ Γ))
      $ pool x
      $ exch (swp [] (_ ∷ []) (replicate⁺ n A))
      $ expandIn (there j) y
  expandIn {Γ} {A} {n} i (exch b x)
    = exch (B.++-cong {xs₁ = replicate⁺ n A} I.id (del-from b i))
    $ expandIn (from b ⟨$⟩ i) x


------------------------------------------------------------------------
-- Fixpoint combinators
------------------------------------------------------------------------

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

open import Partiality-algebra as PA hiding (id; _∘_)

module Partiality-algebra.Fixpoints where

open import Equality.Propositional.Cubical
open import Logical-equivalence using (_⇔_)
open import Prelude hiding (T; ⊥)

open import Bijection equality-with-J using (_↔_)
import Equivalence equality-with-J as Eq
open import Function-universe equality-with-J hiding (id; _∘_)
open import H-level equality-with-J
open import H-level.Closure equality-with-J
open import Monad equality-with-J
open import Univalence-axiom equality-with-J

open import Partiality-algebra.Monotone
open import Partiality-algebra.Omega-continuous
import Partiality-algebra.Properties as PAP

open [_⟶_]⊑

-- The development below, up to fix-is-least, is (very similar to)
-- Kleene's fixed-point theorem.

private
 module Fix₀ {a p q} {A : Type a} {P : Partiality-algebra p q A} where

  open Partiality-algebra P
  open PAP P

  -- Repeated composition of a monotone function with itself.

  comp : [ P ⟶ P ]⊑ → ℕ → [ P ⟶ P ]⊑
  comp f zero    = id⊑
  comp f (suc n) = f ∘⊑ comp f n

  -- Pre-composition with the function is equal to post-composition
  -- with the function.

  pre≡post : ∀ f n → comp f n ∘⊑ f ≡ f ∘⊑ comp f n
  pre≡post f zero    = f  ∎
  pre≡post f (suc n) =
    (f ∘⊑ comp f n) ∘⊑ f  ≡⟨ ∘⊑-assoc f (comp f n) ⟩
    f ∘⊑ (comp f n ∘⊑ f)  ≡⟨ cong (f ∘⊑_) $ pre≡post f n ⟩∎
    f ∘⊑ (f ∘⊑ comp f n)  ∎

  -- Repeated application of a monotone function to never.

  app : [ P ⟶ P ]⊑ → ℕ → T
  app f n = function (comp f n) never

  -- An increasing sequence consisting of repeated applications of the
  -- given monotone function to never.

  fix-sequence : [ P ⟶ P ]⊑ → Increasing-sequence
  fix-sequence f = app f , fix-sequence-increasing
    where
    abstract
      fix-sequence-increasing :
        ∀ n → function (comp f n) never ⊑ function (f ∘⊑ comp f n) never
      fix-sequence-increasing n =
        function (comp f n) never               ⊑⟨ monotone (comp f n) (never⊑ (function f never)) ⟩
        function (comp f n) (function f never)  ⊑⟨⟩
        function (comp f n ∘⊑ f) never          ≡⟨ cong (λ g → function g never) $ pre≡post f n ⟩⊑
        function (f ∘⊑ comp f n) never          ■

  -- Taking the tail of this sequence amounts to the same thing as
  -- applying the function to each element in the sequence.

  tailˢ-fix-sequence :
    (f : [ P ⟶ P ]⊑) →
    tailˢ (fix-sequence f) ≡ [ f $ fix-sequence f ]-inc
  tailˢ-fix-sequence f =
    _↔_.to equality-characterisation-increasing λ _ → refl

  -- The sequence has the same least upper bound as the sequence you get
  -- if you apply the function to each element of the sequence.

  ⨆-fix-sequence :
    (f : [ P ⟶ P ]⊑) →
    ⨆ (fix-sequence f) ≡ ⨆ [ f $ fix-sequence f ]-inc
  ⨆-fix-sequence f =
    ⨆ (fix-sequence f)            ≡⟨ sym $ ⨆tail≡⨆ _ ⟩
    ⨆ (tailˢ (fix-sequence f))    ≡⟨ cong ⨆ (tailˢ-fix-sequence f) ⟩∎
    ⨆ [ f $ fix-sequence f ]-inc  ∎

  -- A fixpoint combinator.

  fix : [ P ⟶ P ]⊑ → T
  fix f = ⨆ (fix-sequence f)

  -- The fixpoint combinator produces fixpoints for ω-continuous
  -- arguments.

  fix-is-fixpoint-combinator :
    (fω : [ P ⟶ P ]) →
    let f : [ P ⟶ P ]⊑
        f = [_⟶_].monotone-function fω
    in fix f ≡ function f (fix f)
  fix-is-fixpoint-combinator fω =
    fix f                            ≡⟨⟩
    ⨆ (fix-sequence f)               ≡⟨ ⨆-fix-sequence f ⟩
    ⨆ [ f $ fix-sequence f ]-inc     ≡⟨ sym $ [_⟶_].ω-continuous fω _ ⟩
    function f (⨆ (fix-sequence f))  ≡⟨⟩
    function f (fix f)               ∎
    where
    f : [ P ⟶ P ]⊑
    f = [_⟶_].monotone-function fω

  -- The result of the fixpoint combinator is smaller than or equal to
  -- every post-fixpoint.

  fix-is-least :
    (f : [ P ⟶ P ]⊑) →
    ∀ x → function f x ⊑ x → fix f ⊑ x
  fix-is-least f x fx⊑x = least-upper-bound _ _ lemma
    where
    lemma : ∀ n → function (comp f n) never ⊑ x
    lemma zero    = never⊑ x
    lemma (suc n) =
      function (f ∘⊑ comp f n) never          ⊑⟨⟩
      function f (function (comp f n) never)  ⊑⟨ monotone f (lemma n) ⟩
      function f x                            ⊑⟨ fx⊑x ⟩■
      x                                       ■

  -- A restricted homomorphism property.

  comp-∘ : ∀ f n → comp (f ∘⊑ f) n ≡ comp f n ∘⊑ comp f n
  comp-∘ f zero    = id⊑  ∎
  comp-∘ f (suc n) =
    (f ∘⊑ f) ∘⊑ comp (f ∘⊑ f) n         ≡⟨ cong ((f ∘⊑ f) ∘⊑_) (comp-∘ f n) ⟩
    (f ∘⊑ f) ∘⊑ (comp f n ∘⊑ comp f n)  ≡⟨ lemma f f (comp f n) _ ⟩
    f ∘⊑ ((f ∘⊑ comp f n) ∘⊑ comp f n)  ≡⟨ cong ((_∘⊑ comp f n) ∘ (f ∘⊑_)) $ sym $ pre≡post f n ⟩
    f ∘⊑ ((comp f n ∘⊑ f) ∘⊑ comp f n)  ≡⟨ sym $ lemma f (comp f n) f _ ⟩∎
    (f ∘⊑ comp f n) ∘⊑ (f ∘⊑ comp f n)  ∎
    where
    lemma : (f g h k : [ P ⟶ P ]⊑) →
            (f ∘⊑ g) ∘⊑ (h ∘⊑ k) ≡ f ∘⊑ ((g ∘⊑ h) ∘⊑ k)
    lemma f g h k =
      (f ∘⊑ g) ∘⊑ (h ∘⊑ k)  ≡⟨ ∘⊑-assoc f g ⟩
      f ∘⊑ (g ∘⊑ (h ∘⊑ k))  ≡⟨ cong (f ∘⊑_) $ ∘⊑-assoc g h ⟩∎
      f ∘⊑ ((g ∘⊑ h) ∘⊑ k)  ∎

  -- The function comp f is homomorphic with respect to _+_/_∘⊑_.

  comp-+∘ : ∀ f m {n} → comp f (m + n) ≡ comp f m ∘⊑ comp f n
  comp-+∘ f zero    {n} = comp f n  ∎
  comp-+∘ f (suc m) {n} =
    f ∘⊑ comp f (m + n)          ≡⟨ cong (f ∘⊑_) $ comp-+∘ f m ⟩
    f ∘⊑ (comp f m ∘⊑ comp f n)  ≡⟨ ∘⊑-assoc f (comp f m) ⟩∎
    (f ∘⊑ comp f m) ∘⊑ comp f n  ∎

  -- Taking steps that are "twice as large" does not affect the end
  -- result.

  fix-∘ : (f : [ P ⟶ P ]⊑) → fix (f ∘⊑ f) ≡ fix f
  fix-∘ f = antisymmetry
    (least-upper-bound _ _ λ n →
       function (comp (f ∘⊑ f) n) never       ≡⟨ cong (λ f → function f never) $ comp-∘ f n ⟩⊑
       function (comp f n ∘⊑ comp f n) never  ≡⟨ cong (λ f → function f never) $ sym $ comp-+∘ f n ⟩⊑
       function (comp f (n + n)) never        ⊑⟨ upper-bound (fix-sequence f) (n + n) ⟩■
       ⨆ (fix-sequence f)                     ■)
    (⨆-mono λ n →
       function (comp f n) never                        ⊑⟨ monotone (comp f n) (never⊑ _) ⟩
       function (comp f n) (function (comp f n) never)  ⊑⟨⟩
       function (comp f n ∘⊑ comp f n) never            ≡⟨ cong (λ f → function f never) $ sym $ comp-∘ f n ⟩⊑
       function (comp (f ∘⊑ f) n) never                 ■)

open Fix₀

-- N-ary Scott induction.

module N-ary
  (open Partiality-algebra)
  {a p q r} n
  (As : Fin n → Type a)
  (Ps : ∀ i → Partiality-algebra p q (As i))
  (P : (∀ i → T (Ps i)) → Type r)
  (P⊥ : P (λ i → never (Ps i)))
  (P⨆ : (ss : ∀ i → Increasing-sequence (Ps i)) →
        (∀ n → P (λ i → _[_] (Ps i) (ss i) n)) →
        P (λ i → ⨆ (Ps i) (ss i)))
  (fs : ∀ i → [ Ps i ⟶ Ps i ]⊑)
  where

  -- Generalised.

  fix-induction′ :
    (∀ n → P (λ i → app (fs i) n) → P (λ i → app (fs i) (suc n))) →
    P (fix ∘ fs)
  fix-induction′ step =                       $⟨ lemma ⟩
    (∀ n → P (λ i → app (fs i) n))            ↝⟨ P⨆ _ ⟩
    P (λ i → ⨆ (Ps i) (fix-sequence (fs i)))  ↝⟨ id ⟩□
    P (fix ∘ fs)                              □
    where
    lemma : ∀ n → P (λ i → function (comp (fs i) n) (never (Ps i)))
    lemma zero    = P⊥
    lemma (suc n) =                             $⟨ lemma n ⟩
      P (λ i → app (fs i) n)                    ↝⟨ step n ⟩□
      P (λ i → function (fs i) (app (fs i) n))  □

  -- Basic.

  fix-induction :
    (∀ xs → P xs → P (λ i → function (fs i) (xs i))) →
    P (fix ∘ fs)
  fix-induction step =
    fix-induction′ (λ n → step (λ i → app (fs i) n))

open N-ary public

module Fix {a p q} {A : Type a} {P : Partiality-algebra p q A} where

  open Partiality-algebra P

  -- Unary Scott induction.

  fix-induction₁ :
    ∀ {r}
    (Q : T → Type r) →
    Q never →
    (∀ s → (∀ n → Q (s [ n ])) → Q (⨆ s)) →
    (f : [ P ⟶ P ]⊑) →
    (∀ x → Q x → Q (function f x)) →
    Q (fix f)
  fix-induction₁ Q Q⊥ Q⨆ f step =
    fix-induction
      1
      [ const A ,        ⊥-elim    ]
      [ const P , (λ i → ⊥-elim i) ]
      (Q ∘ (_$ fzero))
      Q⊥
      (Q⨆ ∘ (_$ fzero))
      [ const f , (λ x → ⊥-elim x) ]
      (step ∘ (_$ fzero))

  open Fix₀ {P = P} public

open Fix public


{-# OPTIONS --type-in-type
            --no-termination-check
            --no-positivity-check #-}

module IMDesc where

--********************************************
-- Prelude
--********************************************

-- Some preliminary stuffs, to avoid relying on the stdlib

--****************
-- Sigma and friends
--****************

data Sigma (A : Set)(B : A -> Set) : Set where
  _,_ : (x : A)(y : B x) -> Sigma A B

_*_ : (A B : Set) -> Set
A * B = Sigma A \_ -> B

fst : {A : Set}{B : A -> Set} -> Sigma A B -> A
fst (a , _) = a

snd : {A : Set}{B : A -> Set} (p : Sigma A B) -> B (fst p)
snd (a , b) = b

data Zero : Set where
record One : Set where

--****************
-- Sum and friends
--****************

data _+_ (A B : Set) : Set where
  l : A -> A + B
  r : B -> A + B

--****************
-- Prop
--****************

data EProp : Set where
  Trivial : EProp

Prf : EProp -> Set
Prf _ = {! !}

--****************
-- Enum
--****************

data EnumU : Set where

data EnumT (E : EnumU) : Set where

Branches : (E : EnumU) -> (P : EnumT E -> Set) -> Set
Branches  _ _ = {! !}

switch : (E : EnumU) -> (e : EnumT E) -> (P : EnumT E -> Set) -> Branches E P -> P e
switch = {! !}

--********************************************
-- IMDesc
--********************************************

--****************
-- Code
--****************

data IDesc (I : Set) : Set where
  iat      : (i : I) -> IDesc I
  ipi      : (S : Set)(T : S -> IDesc I) -> IDesc I
  isigma   : (S : Set)(T : S -> IDesc I) -> IDesc I
  iprf     : (Q : EProp) -> IDesc I
  iprod    : (D : IDesc I)(D : IDesc I) -> IDesc I
  ifsigma  : (E : EnumU)(f : Branches E (\ _ -> IDesc I)) -> IDesc I

--****************
-- Interpretation
--****************

desc : (I : Set)(D : IDesc I)(P : I -> Set) -> Set
desc I (iat i)        P = P i
desc I (ipi S T)      P = (s : S) -> desc I (T s) P
desc I (isigma S T)   P = Sigma S (\ s -> desc I (T s) P)
desc I (iprf q)       P = Prf q
desc I (iprod D D')   P = Sigma (desc I D P) (\ _ -> desc I D' P)
desc I (ifsigma E B)  P = Sigma (EnumT E) (\ e -> desc I (switch E e (\ _ -> IDesc I) B) P)

--****************
-- Curried and uncurried interpretations
--****************

curryD : (I : Set)(D : IDesc I)(P : I -> Set)(R : desc I D P -> Set) -> Set
curryD I (iat i) P R = (x : P i) -> R x
curryD I (ipi S T) P R = (f : (s : S) -> desc I (T s) P) -> R f
curryD I (isigma S T) P R = (s : S) -> curryD I (T s) P (\ d -> R (s , d))
curryD I (iprf Q) P R = (x : Prf Q) -> R x
curryD I (iprod D D') P R = curryD I D P (\ d ->
                             curryD I D' P (\ d' -> R (d , d')))
curryD I (ifsigma E B) P R = Branches E (\e -> curryD I (switch E e (\_ -> IDesc I) B) P (\d -> R (e , d)))

uncurryD : (I : Set)(D : IDesc I)(P : I -> Set)(R : desc I D P -> Set) ->
           curryD I D P R -> (xs : desc I D P) -> R xs
uncurryD I (iat i) P R f xs = f xs
uncurryD I (ipi S T) P R F f = F f
uncurryD I (isigma S T) P R f (s , d) =  uncurryD I (T s) P (\d -> R (s , d)) (f s) d
uncurryD I (iprf Q) P R f q = f q
uncurryD I (iprod D D') P R f (d , d') =  uncurryD I D' P ((\ d' → R (d , d')))
                                           (uncurryD I D P ((\ x → curryD I D' P (\ d0 → R (x , d0)))) f d) d'
uncurryD I (ifsigma E B) P R br (e , d) =  uncurryD I (switch E e (\ _ -> IDesc I) B) P
                                                      (\ d -> R ( e , d ))
                                                      (switch E e ( \ e -> R ( e , d)) br) d

--****************
-- Everywhere
--****************

box : (I : Set)(D : IDesc I)(P : I -> Set) -> desc I D P -> IDesc (Sigma I P)
box I (iat i)        P x         = iat (i , x)
box I (ipi S T)      P f         = ipi S (\ s -> box I (T s) P (f s))
box I (isigma S T)   P (s , d)   = box I (T s) P d
box I (iprf Q)       P q         = iprf Trivial
box I (iprod D D')   P (d , d')  = iprod (box I D P d) (box I D' P d')
box I (ifsigma E B)  P (e , d)   = box I (switch E e (\ _ -> IDesc I) B) P d

mapbox : (I : Set)(D : IDesc I)(Z : I -> Set)(P : Sigma I Z -> Set) ->
         ((x : Sigma I Z) -> P x) ->
         ( d : desc I D Z) -> desc (Sigma I Z) (box I D Z d) P
mapbox = {!!}

--****************
-- Fix-point
--****************

data IMu (I : Set)(D : I -> IDesc I)(i : I) : Set where
  Con : desc I (D i) (\ j -> IMu I D j) -> IMu I D i

--****************
-- Induction, curried
--****************

inductionC : (I : Set)(D : I -> IDesc I)(i : I)(v : IMu I D i)
             (P : Sigma I (IMu I D) -> Set)
             (m : (i : I) ->
                  curryD I (D i) (IMu I D) (\xs ->
                    curryD (Sigma I (IMu I D))
                           (box I (D i) (IMu I D) xs)
                           P
                           (\ _ -> P (i , Con xs)))) ->
             P ( i , v )
inductionC I D i (Con x) P m =
  let t = uncurryD  I
                    (D i)
                    (IMu I D)
                    (\xs ->
                    curryD (Sigma I (IMu I D))
                           (box I (D i) (IMu I D) xs)
                           P
                           (\ _ -> P (i , Con xs)))
                    (m i)
                    x
  in
  uncurryD (Sigma I (IMu I D))
           ( box I (D i) (IMu I D) x)
           P
           (\ _ -> P ( i , Con x))
           t
           (mapbox I ( D i) ( IMu I D) P ind x)
           where ind : (x' : Sigma I (IMu I D)) -> P x'
                 ind ( i , x) = inductionC I D i x P m