{-# OPTIONS --cubical --safe #-}
module Cubical.HITs.Everything where

open import Cubical.HITs.Cylinder public
open import Cubical.HITs.Hopf public
open import Cubical.HITs.Interval public
open import Cubical.HITs.Ints.BiInvInt public hiding ( pred ; suc-pred ; pred-suc )
open import Cubical.HITs.Ints.DeltaInt public hiding ( pred ; succ ; zero )
open import Cubical.HITs.Ints.HAEquivInt public hiding ( suc-haequiv )
open import Cubical.HITs.Ints.IsoInt public
open import Cubical.HITs.Ints.QuoInt public
open import Cubical.HITs.Join public
open import Cubical.HITs.ListedFiniteSet public
open import Cubical.HITs.Pushout public
open import Cubical.HITs.Modulo public
open import Cubical.HITs.S1 public
open import Cubical.HITs.S2 public
open import Cubical.HITs.S3 public
open import Cubical.HITs.Rational public
open import Cubical.HITs.Susp public
open import Cubical.HITs.SmashProduct public renaming (comm to Smash-comm)
open import Cubical.HITs.Torus public
open import Cubical.HITs.PropositionalTruncation public
open import Cubical.HITs.SetTruncation public
open import Cubical.HITs.GroupoidTruncation public
open import Cubical.HITs.2GroupoidTruncation public
open import Cubical.HITs.SetQuotients public
open import Cubical.HITs.FiniteMultiset public hiding ( _++_ ; [_] ; assoc-++ )
open import Cubical.HITs.Colimit


------------------------------------------------------------------------
-- The Agda standard library
--
-- This module is DEPRECATED.
------------------------------------------------------------------------

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

-- Disabled to prevent warnings from deprecated monoid solver
{-# OPTIONS --warn=noUserWarning #-}

module Data.List.Solver where

{-# WARNING_ON_IMPORT
"Data.List.Solver was deprecated in v1.3.
Use the new reflective Tactic.MonoidSolver instead."
#-}

import Algebra.Solver.Monoid as Solver
open import Data.List.Properties using (++-monoid)

------------------------------------------------------------------------
-- A module for automatically solving propositional equivalences
-- containing _++_

module ++-Solver {a} {A : Set a} =
  Solver (++-monoid A) renaming (id to nil)


module Control.Monad.Transformer where

open import Prelude

record Transformer {a b} (T : (Set a → Set b) → (Set a → Set b)) : Set (lsuc a ⊔ lsuc b) where
  field
    lift : {M : Set a → Set b} {{_ : Monad M}} {A : Set a} → M A → T M A

open Transformer {{...}} public


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

open import HoTT
open import cw.CW
open import cw.DegreeByProjection
open import cohomology.ChainComplex

module cw.cohomology.cellular.ChainComplex {i : ULevel} where

  chain-template : ∀ {n} (skel : Skeleton {i} n) {m}
    → Dec (m ≤ n) → AbGroup i
  chain-template skel (inl m≤n) = FreeAbGroup (cells-nth m≤n skel)
  chain-template skel (inr _) = Lift-abgroup {j = i} Unit-abgroup

  abstract
    boundary-nth-template : ∀ {n} (skel : Skeleton {i} n) dec
      → has-degrees-with-finite-support skel dec
      → {m : ℕ} (m≤n : m ≤ n) (Sm≤n : S m ≤ n)
      → cw-init (cw-take Sm≤n skel) == cw-take (≤-trans lteS Sm≤n) skel
      → cw-take (≤-trans lteS Sm≤n) skel == cw-take m≤n skel
      →  FreeAbGroup.grp (cells-nth Sm≤n skel)
      →ᴳ FreeAbGroup.grp (cells-nth m≤n skel)
    boundary-nth-template skel dec fin-sup m≤n Sm≤n path₀ path₁ =
         transportᴳ (λ lower-skel → FreeAbGroup.grp (cells-last lower-skel)) (path₀ ∙ path₁)
      ∘ᴳ boundary-nth Sm≤n skel dec fin-sup

  boundary-template : ∀ {n} (skel : Skeleton {i} n) dec
    → has-degrees-with-finite-support skel dec
    → {m : ℕ} (m≤n? : Dec (m ≤ n)) (Sm≤n? : Dec (S m ≤ n))
    →  AbGroup.grp (chain-template skel Sm≤n?)
    →ᴳ AbGroup.grp (chain-template skel m≤n?)
  boundary-template skel dec fin-sup _ (inr _) = cst-hom
  boundary-template skel dec fin-sup (inr m≰n) (inl Sm≤n) = ⊥-rec $ m≰n (≤-trans lteS Sm≤n)
  boundary-template skel dec fin-sup (inl m≤n) (inl Sm≤n) =
    boundary-nth-template skel dec fin-sup m≤n Sm≤n (cw-init-take Sm≤n skel)
      (ap (λ m≤n → cw-take m≤n skel) (≤-has-all-paths (≤-trans lteS Sm≤n) m≤n))

  chain-complex : ∀ {n} (skel : Skeleton {i} n) dec
    → has-degrees-with-finite-support skel dec
    → ChainComplex i
  chain-complex {n} skel dec fin-sup = record {M} where
    module M where
      head : AbGroup i
      head = Lift-abgroup {j = i} ℤ-abgroup

      chain : ℕ → AbGroup i
      chain m = chain-template skel (≤-dec m n)

      augment : AbGroup.grp (chain 0) →ᴳ AbGroup.grp head
      augment = FreeAbGroup-extend head λ _ → lift 1

      boundary : ∀ m → (AbGroup.grp (chain (S m)) →ᴳ AbGroup.grp (chain m))
      boundary m = boundary-template skel dec fin-sup (≤-dec m n) (≤-dec (S m) n)

  cochain-complex : ∀ {j} {n} (skel : Skeleton {i} n) dec
    → has-degrees-with-finite-support skel dec
    → AbGroup j → CochainComplex (lmax i j)
  cochain-complex skel dec fin-sup G = complex-dualize
    (chain-complex skel dec fin-sup) G

  {- properties of coboundaries -}

  abstract
    private
      path-lemma₀ : ∀ {n} (skel : Skeleton {i} (S n)) {m} (m<n : m < n) (Sm<n : S m < n)
        →  ap (λ m≤Sn → cw-take m≤Sn skel) (≤-has-all-paths (≤-trans lteS (lteSR (inr Sm<n))) (lteSR (inr m<n)))
        == ap (λ m≤n → cw-take m≤n (cw-init skel)) (≤-has-all-paths (≤-trans lteS (inr Sm<n)) (inr m<n))
      path-lemma₀ skel m<n Sm<n =
        ap (λ m≤Sn → cw-take m≤Sn skel) (≤-has-all-paths (≤-trans lteS (lteSR (inr Sm<n))) (lteSR (inr m<n)))
          =⟨ ap (ap (λ m≤Sn → cw-take m≤Sn skel)) (contr-has-all-paths _ _) ⟩
        ap (λ m≤Sn → cw-take m≤Sn skel) (ap (lteSR ∘ inr) (<-has-all-paths (<-trans ltS Sm<n) m<n))
          =⟨ ∘-ap (λ m≤Sn → cw-take m≤Sn skel) (lteSR ∘ inr) _ ⟩
        ap (λ Sm<n → cw-take (lteSR (inr Sm<n)) skel) (<-has-all-paths (<-trans ltS Sm<n) m<n)
          =⟨ ap-∘ (λ m≤n → cw-take m≤n (cw-init skel)) inr _ ⟩
        ap (λ m≤n → cw-take m≤n (cw-init skel)) (ap inr (<-has-all-paths (<-trans ltS Sm<n) m<n))
          =⟨ ap (ap (λ m≤n → cw-take m≤n (cw-init skel))) (contr-has-all-paths _ _) ⟩
        ap (λ m≤n → cw-take m≤n (cw-init skel)) (≤-has-all-paths (≤-trans lteS (inr Sm<n)) (inr m<n))
          =∎

      path-lemma₁ : ∀ {n} (skel : Skeleton {i} (S (S n)))
        →  ap (λ n≤SSn → cw-take n≤SSn skel) (≤-has-all-paths (lteSR lteS) (lteSR lteS))
        == ap (λ n≤Sn → cw-take n≤Sn (cw-init skel)) (≤-has-all-paths lteS lteS)
      path-lemma₁ skel =
        ap (λ n≤SSn → cw-take n≤SSn skel) (≤-has-all-paths (lteSR lteS) (lteSR lteS))
          =⟨ ap (ap (λ n≤SSn → cw-take n≤SSn skel)) (contr-has-all-paths _ _) ⟩
        idp
          =⟨ ap (ap (λ n≤Sn → cw-take n≤Sn (cw-init skel))) (contr-has-all-paths _ _) ⟩
        ap (λ n≤Sn → cw-take n≤Sn (cw-init skel)) (≤-has-all-paths lteS lteS)
          =∎

      path-lemma₂ : ∀ {n} (skel : Skeleton {i} (S n))
        → ap (λ n≤Sn → cw-take n≤Sn skel) (≤-has-all-paths lteS lteS) == idp
      path-lemma₂ skel =
        ap (λ n≤Sn → cw-take n≤Sn skel) (≤-has-all-paths lteS lteS)
          =⟨ ap (ap (λ n≤Sn → cw-take n≤Sn skel)) (contr-has-all-paths _ _) ⟩
        idp
          =∎

  abstract
    boundary-template-descend-from-far : ∀ {n} (skel : Skeleton {i} (S n)) dec fin-sup {m} m<n Sm<n
      → boundary-template {n = S n} skel dec fin-sup {m} (inl (lteSR (inr m<n))) (inl (lteSR (inr Sm<n)))
        == boundary-template {n = n} (cw-init skel)
          (init-has-cells-with-dec-eq skel dec)
          (init-has-degrees-with-finite-support skel dec fin-sup)
          (inl (inr m<n)) (inl (inr Sm<n))
    boundary-template-descend-from-far skel dec fin-sup m<n Sm<n =
      ap (boundary-nth-template skel dec fin-sup (lteSR (inr m<n)) (lteSR (inr Sm<n)) (cw-init-take (lteSR (inr Sm<n)) skel))
        (path-lemma₀ skel m<n Sm<n)

    boundary-template-descend-from-two-above : ∀ {n} (skel : Skeleton {i} (S (S n))) dec fin-sup
      → boundary-template {n = S (S n)} skel dec fin-sup (inl (lteSR lteS)) (inl lteS)
        == boundary-template {n = (S n)} (cw-init skel)
          (init-has-cells-with-dec-eq skel dec)
          (init-has-degrees-with-finite-support skel dec fin-sup)
          (inl lteS) (inl lteE)
    boundary-template-descend-from-two-above skel dec fin-sup =
      ap (boundary-nth-template skel dec fin-sup (lteSR lteS) lteS idp) (path-lemma₁ skel)

    boundary-template-β : ∀ {n} (skel : Skeleton {i} (S n)) dec fin-sup
      →  boundary-template {n = S n} skel dec fin-sup (inl lteS) (inl lteE)
      == FreeAbGroup-extend
            (FreeAbGroup (cells-last (cw-init skel)))
            (boundary'-last skel dec fin-sup)
    boundary-template-β skel dec fin-sup = group-hom= $
      ap (GroupHom.f ∘ boundary-nth-template skel dec fin-sup lteS lteE idp) (path-lemma₂ skel)


open import Oscar.Prelude
open import Oscar.Data.¶
open import Oscar.Data.Fin
open import Oscar.Data.Substitunction
open import Oscar.Data.Term
open import Oscar.Data.Maybe
open import Oscar.Data.Proposequality
open import Oscar.Data.Vec
open import Oscar.Class.Congruity
open import Oscar.Class.Thickandthin
open import Oscar.Class.Injectivity
open import Oscar.Class.Smap
open import Oscar.Class.Pure
open import Oscar.Class.Apply
import Oscar.Property.Monad.Maybe
import Oscar.Property.Thickandthin.FinFinProposequalityMaybeProposequality
import Oscar.Class.Surjection.⋆
import Oscar.Class.Congruity.Proposequality
import Oscar.Class.Injectivity.Vec
import Oscar.Class.Smap.ExtensionFinExtensionTerm

module Oscar.Property.Thickandthin.FinTermProposequalityMaybeProposequality where

module _ {𝔭} {𝔓 : Ø 𝔭} where

  open Substitunction 𝔓
  open Term 𝔓

  instance

    [𝓣hick]FinTerm : [𝓣hick] Fin Term
    [𝓣hick]FinTerm = ∁

    𝓣hickFinTerm : 𝓣hick Fin Term
    𝓣hickFinTerm .𝓣hick.thick x t = thick x ◃ t

    [𝓣hick]FinTerms : ∀ {N} → [𝓣hick] Fin (Terms N)
    [𝓣hick]FinTerms = ∁

    𝓣hickFinTerms : ∀ {N} → 𝓣hick Fin (Terms N)
    𝓣hickFinTerms .𝓣hick.thick x t = thick x ◃ t

    [𝓣hin]FinTerm : [𝓣hin] Fin Term
    [𝓣hin]FinTerm = ∁

    𝓣hinFinTerm : 𝓣hin Fin Term
    𝓣hinFinTerm .𝓣hin.thin = smap ∘ thin

    [𝓣hin]FinTerms : ∀ {N} → [𝓣hin] Fin (Terms N)
    [𝓣hin]FinTerms = ∁

    𝓣hinFinTerms : ∀ {N} → 𝓣hin Fin (Terms N)
    𝓣hinFinTerms .𝓣hin.thin = smap ∘ thin

    [𝓘njectivity₂,₁]FinTerm : ∀ {m} → [𝓘njectivity₂,₁] (𝔱hin Fin Term m) Proposequality Proposequality
    [𝓘njectivity₂,₁]FinTerm = ∁

    𝓘njection₂FinTerm : ∀ {m} → 𝓘njection₂ (λ (_ : ¶⟨< ↑ m ⟩) (_ : Term m) → Term (↑ m))
    𝓘njection₂FinTerm {m} .𝓘njection₂.injection₂ = thin

    [𝓘njectivity₂,₁]FinTerms : ∀ {N m} → [𝓘njectivity₂,₁] (𝔱hin Fin (Terms N) m) Proposequality Proposequality
    [𝓘njectivity₂,₁]FinTerms = ∁

    𝓘njection₂FinTerms : ∀ {N m} → 𝓘njection₂ (λ (_ : ¶⟨< ↑ m ⟩) (_ : Terms N m) → Terms N (↑ m))
    𝓘njection₂FinTerms {m} .𝓘njection₂.injection₂ = thin

    𝓘njection₁-TermI : ∀ {n} → 𝓘njection₁ (λ (_ : ¶⟨< n ⟩) → Term n)
    𝓘njection₁-TermI .𝓘njection₁.injection₁ = i

    [𝓘njectivity₁]TermI : ∀ {n} → [𝓘njectivity₁] (λ (_ : ¶⟨< n ⟩) → Term n) Proposequality Proposequality
    [𝓘njectivity₁]TermI = ∁

    𝓘njectivity₁TermI : ∀ {n} → 𝓘njectivity₁ (λ (_ : ¶⟨< n ⟩) → Term n) Proposequality Proposequality
    𝓘njectivity₁TermI {n} .𝓘njectivity₁.injectivity₁ ∅ = ∅

    𝓘njection₂-TermFork : ∀ {n} → 𝓘njection₂ (λ (_ : Term n) (_ : Term n) → Term n)
    𝓘njection₂-TermFork .𝓘njection₂.injection₂ = _fork_

    [𝓘njection₂,₀,₁]-TermFork : ∀ {n} → [𝓘njectivity₂,₀,₁] (λ (_ : Term n) (_ : Term n) → Term n) Proposequality Proposequality
    [𝓘njection₂,₀,₁]-TermFork = ∁

    𝓘njection₂,₀,₁-TermFork : ∀ {n} → 𝓘njectivity₂,₀,₁ (λ (_ : Term n) (_ : Term n) → Term n) Proposequality Proposequality
    𝓘njection₂,₀,₁-TermFork .𝓘njectivity₂,₀,₁.injectivity₂,₀,₁ ∅ = ∅

    [𝓘njection₂,₀,₂]-TermFork : ∀ {n} → [𝓘njectivity₂,₀,₂] (λ (_ : Term n) (_ : Term n) → Term n) Proposequality Proposequality
    [𝓘njection₂,₀,₂]-TermFork = ∁

    𝓘njection₂,₀,₂-TermFork : ∀ {n} → 𝓘njectivity₂,₀,₂ (λ (_ : Term n) (_ : Term n) → Term n) Proposequality Proposequality
    𝓘njection₂,₀,₂-TermFork .𝓘njectivity₂,₀,₂.injectivity₂,₀,₂ ∅ = ∅

    𝓘njection₃TermFunction : ∀ {n} → 𝓘njection₃ (λ (_ : 𝔓) (N : ¶) (_ : Terms N n) → Term n)
    𝓘njection₃TermFunction {n} .𝓘njection₃.injection₃ p N ts = function p ts

    [𝓘njectivity₃,₀,₁]TermFunction : ∀ {n} → [𝓘njectivity₃,₀,₁] (λ (_ : 𝔓) (N : ¶) (_ : Terms N n) → Term n) Proposequality Proposequality
    [𝓘njectivity₃,₀,₁]TermFunction = ∁

    𝓘njectivity₃,₀,₁TermFunction : ∀ {n} → 𝓘njectivity₃,₀,₁ (λ (_ : 𝔓) (N : ¶) (_ : Terms N n) → Term n) Proposequality Proposequality
    𝓘njectivity₃,₀,₁TermFunction .𝓘njectivity₃,₀,₁.injectivity₃,₀,₁ ∅ = ∅

    [𝓘njectivity₃,₀,₂]TermFunction : ∀ {n} → [𝓘njectivity₃,₀,₂] (λ (_ : 𝔓) (N : ¶) (_ : Terms N n) → Term n) Proposequality Proposequality
    [𝓘njectivity₃,₀,₂]TermFunction = ∁

    𝓘njectivity₃,₀,₂TermFunction : ∀ {n} → 𝓘njectivity₃,₀,₂ (λ (_ : 𝔓) (N : ¶) (_ : Terms N n) → Term n) Proposequality Proposequality
    𝓘njectivity₃,₀,₂TermFunction .𝓘njectivity₃,₀,₂.injectivity₃,₀,₂ ∅ = ∅

    𝓘njection₂TermFunction : ∀ {N n} → 𝓘njection₂ (λ (_ : 𝔓) (_ : Terms N n) → Term n)
    𝓘njection₂TermFunction {N} {n} .𝓘njection₂.injection₂ p ts = function p ts

    [𝓘njectivity₂,₀,₂]TermFunction : ∀ {N n} → [𝓘njectivity₂,₀,₂] (λ (_ : 𝔓) (_ : Terms N n) → Term n) Proposequality Proposequality
    [𝓘njectivity₂,₀,₂]TermFunction = ∁

    𝓘njectivity₂,₀,₂TermFunction : ∀ {N n} → 𝓘njectivity₂,₀,₂ (λ (_ : 𝔓) (_ : Terms N n) → Term n) Proposequality Proposequality
    𝓘njectivity₂,₀,₂TermFunction .𝓘njectivity₂,₀,₂.injectivity₂,₀,₂ ∅ = ∅

  mutual

    instance

      𝓘njectivity₂,₁FinTerm : ∀ {m} → 𝓘njectivity₂,₁ (𝔱hin Fin Term m) Proposequality Proposequality
      𝓘njectivity₂,₁FinTerm .𝓘njectivity₂,₁.injectivity₂,₁ x {i _} {i _} eq = congruity i (injectivity₂,₁ x (injectivity₁[ Proposequality ] eq))
      𝓘njectivity₂,₁FinTerm .𝓘njectivity₂,₁.injectivity₂,₁ _ {i _} {leaf} ()
      𝓘njectivity₂,₁FinTerm .𝓘njectivity₂,₁.injectivity₂,₁ _ {i _} {_ fork _} ()
      𝓘njectivity₂,₁FinTerm .𝓘njectivity₂,₁.injectivity₂,₁ _ {i _} {function _ _} ()
      𝓘njectivity₂,₁FinTerm .𝓘njectivity₂,₁.injectivity₂,₁ _ {leaf} {i _} ()
      𝓘njectivity₂,₁FinTerm .𝓘njectivity₂,₁.injectivity₂,₁ _ {leaf} {leaf} _ = ∅
      𝓘njectivity₂,₁FinTerm .𝓘njectivity₂,₁.injectivity₂,₁ _ {leaf} {_ fork _} ()
      𝓘njectivity₂,₁FinTerm .𝓘njectivity₂,₁.injectivity₂,₁ _ {leaf} {function _ _} ()
      𝓘njectivity₂,₁FinTerm .𝓘njectivity₂,₁.injectivity₂,₁ _ {_ fork _} {i _} ()
      𝓘njectivity₂,₁FinTerm .𝓘njectivity₂,₁.injectivity₂,₁ _ {_ fork _} {leaf} ()
      𝓘njectivity₂,₁FinTerm .𝓘njectivity₂,₁.injectivity₂,₁ x {y₁ fork y₂} {y₃ fork y₄} eq
        rewrite injectivity₂,₁ {_∼₂_ = Proposequality} x {y₁ = y₁} (injectivity₂,₀,₁[ Proposequality ] eq)
              | injectivity₂,₁ {_∼₂_ = Proposequality} x {y₁ = y₂} (injectivity₂,₀,₂[ Proposequality ] eq)
        = ∅
      𝓘njectivity₂,₁FinTerm .𝓘njectivity₂,₁.injectivity₂,₁ _ {y₁ fork y₂} {function x₁ x₂} ()
      𝓘njectivity₂,₁FinTerm .𝓘njectivity₂,₁.injectivity₂,₁ _ {function _ _} {i x₃} ()
      𝓘njectivity₂,₁FinTerm .𝓘njectivity₂,₁.injectivity₂,₁ _ {function _ _} {leaf} ()
      𝓘njectivity₂,₁FinTerm .𝓘njectivity₂,₁.injectivity₂,₁ _ {function _ _} {y₂ fork y₃} ()
      𝓘njectivity₂,₁FinTerm .𝓘njectivity₂,₁.injectivity₂,₁ x {function p1 {N1} ts1} {function p2 {N2} ts2} t₁≡t₂
        rewrite injectivity₃,₀,₁[ Proposequality ] {x₂ = p2} t₁≡t₂
        with injectivity₃,₀,₂[ Proposequality ] {y₂ = N2} t₁≡t₂
      … | ∅
        with injectivity₂,₀,₂[ Proposequality ] {y₂ = thin x ts2} t₁≡t₂
      … | ts₁≡ts₂ = congruity (function p2) (injectivity₂,₁ x ts₁≡ts₂)

      𝓘njectivity₂,₁FinTerms : ∀ {N m} → 𝓘njectivity₂,₁ (𝔱hin Fin (Terms N) m) Proposequality Proposequality
      𝓘njectivity₂,₁FinTerms .𝓘njectivity₂,₁.injectivity₂,₁ x {∅} {∅} x₁ = ∅
      𝓘njectivity₂,₁FinTerms .𝓘njectivity₂,₁.injectivity₂,₁ x {_ , _} {t₂ , ts₂} eq
        rewrite injectivity₂,₁ {_∼₂_ = Proposequality} x {y₂ = t₂} (injectivity₂,₀,₁[ Proposequality ] eq)
              | injectivity₂,₁ {_∼₂_ = Proposequality} x {y₂ = ts₂} (injectivity₂,₀,₂[ Proposequality ] eq)
        = ∅

  instance

    [𝓒heck]FinTermMaybe : [𝓒heck] Fin Term Maybe
    [𝓒heck]FinTermMaybe = ∁

    [𝓒heck]FinTermsMaybe : ∀ {N} → [𝓒heck] Fin (Terms N) Maybe
    [𝓒heck]FinTermsMaybe = ∁

  open import Oscar.Class.Smap
  open import Oscar.Class.Fmap

  mutual

    instance

      𝓒heckFinTermMaybe : 𝓒heck Fin Term Maybe
      𝓒heckFinTermMaybe .𝓒heck.check x (i y) = ⦇ i (check x y) ⦈
      𝓒heckFinTermMaybe .𝓒heck.check x leaf = ⦇ leaf ⦈
      𝓒heckFinTermMaybe .𝓒heck.check x (y₁ fork y₂) = ⦇ _fork_ (check x y₁) (check x y₂) ⦈
      𝓒heckFinTermMaybe .𝓒heck.check x (function p ts) = ⦇ (function p) (check x ts) ⦈

      𝓒heckFinTermsMaybe : ∀ {N} → 𝓒heck Fin (Terms N) Maybe
      𝓒heckFinTermsMaybe .𝓒heck.check _ ∅ = ⦇ ∅ ⦈
      𝓒heckFinTermsMaybe .𝓒heck.check x (t , ts) = ⦇ check x t , check x ts ⦈

  instance

    [𝓣hick/thin=1]FinTermProposequality : [𝓣hick/thin=1] Fin Term Proposequality
    [𝓣hick/thin=1]FinTermProposequality = ∁

    [𝓣hick/thin=1]FinTermsProposequality : ∀ {N} → [𝓣hick/thin=1] Fin (Terms N) Proposequality
    [𝓣hick/thin=1]FinTermsProposequality = ∁

  mutual

    instance

      𝓣hick/thin=1FinTermProposequality : 𝓣hick/thin=1 Fin Term Proposequality
      𝓣hick/thin=1FinTermProposequality .𝓣hick/thin=1.thick/thin=1 x (i y) rewrite thick/thin=1 {_≈_ = Proposequality} x y = ∅ -- congruity i $ thick/thin=1 x y
      𝓣hick/thin=1FinTermProposequality .𝓣hick/thin=1.thick/thin=1 x leaf = ∅
      𝓣hick/thin=1FinTermProposequality .𝓣hick/thin=1.thick/thin=1 x (y₁ fork y₂) = congruity₂ _fork_ (thick/thin=1 x y₁) (thick/thin=1 x y₂)
      𝓣hick/thin=1FinTermProposequality .𝓣hick/thin=1.thick/thin=1 x (function p ts) = congruity (function p) (thick/thin=1 x ts)

      𝓣hick/thin=1FinTermsProposequality : ∀ {N} → 𝓣hick/thin=1 Fin (Terms N) Proposequality
      𝓣hick/thin=1FinTermsProposequality .𝓣hick/thin=1.thick/thin=1 x ∅ = ∅
      𝓣hick/thin=1FinTermsProposequality .𝓣hick/thin=1.thick/thin=1 x (t , ts) = congruity₂ _,_ (thick/thin=1 x t) (thick/thin=1 x ts)

  instance

    [𝓒heck/thin=1]FinTermMaybe : [𝓒heck/thin=1] Fin Term Maybe Proposequality
    [𝓒heck/thin=1]FinTermMaybe = ∁

    [𝓒heck/thin=1]FinTermsMaybe : ∀ {N} → [𝓒heck/thin=1] Fin (Terms N) Maybe Proposequality
    [𝓒heck/thin=1]FinTermsMaybe = ∁

  mutual

    instance

      𝓒heck/thin=1FinTermMaybe : 𝓒heck/thin=1 Fin Term Maybe Proposequality
      𝓒heck/thin=1FinTermMaybe .𝓒heck/thin=1.check/thin=1 x (i y) rewrite check/thin=1 {_≈_ = Proposequality⟦ Maybe _ ⟧} x y = ∅
      𝓒heck/thin=1FinTermMaybe .𝓒heck/thin=1.check/thin=1 x leaf = ∅
      𝓒heck/thin=1FinTermMaybe .𝓒heck/thin=1.check/thin=1 x (y₁ fork y₂)
        rewrite check/thin=1 {_≈_ = Proposequality⟦ Maybe _ ⟧} x y₁
              | check/thin=1 {_≈_ = Proposequality⟦ Maybe _ ⟧} x y₂
        = ∅
      𝓒heck/thin=1FinTermMaybe .𝓒heck/thin=1.check/thin=1 x (function p ys) rewrite check/thin=1 {_≈_ = Proposequality⟦ Maybe _ ⟧} x ys = ∅

      𝓒heck/thin=1FinTermsMaybe : ∀ {N} → 𝓒heck/thin=1 Fin (Terms N) Maybe Proposequality
      𝓒heck/thin=1FinTermsMaybe .𝓒heck/thin=1.check/thin=1 x ∅ = ∅
      𝓒heck/thin=1FinTermsMaybe .𝓒heck/thin=1.check/thin=1 x (y , ys)
        rewrite check/thin=1 {_≈_ = Proposequality⟦ Maybe _ ⟧} x y
              | check/thin=1 {_≈_ = Proposequality⟦ Maybe _ ⟧} x ys
        = ∅

  instance

    IsThickandthinFinTerm : IsThickandthin Fin Term Proposequality Maybe Proposequality
    IsThickandthinFinTerm = ∁

    IsThickandthinFinTerms : ∀ {N} → IsThickandthin Fin (Terms N) Proposequality Maybe Proposequality
    IsThickandthinFinTerms = ∁

module _ {𝔭} (𝔓 : Ø 𝔭) where

  open Substitunction 𝔓
  open Term 𝔓

  ThickandthinFinTerm : Thickandthin _ _ _ _ _ _
  ThickandthinFinTerm = ∁ Fin Term Proposequality Maybe Proposequality

  ThickandthinFinTerms : ∀ N → Thickandthin _ _ _ _ _ _
  ThickandthinFinTerms N = ∁ Fin (Terms N) Proposequality Maybe Proposequality


{-# OPTIONS --rewriting #-}

open import Agda.Builtin.Equality

postulate f : Set₁ → Set₁

module _ (A : Set) where
  postulate rew : f Set ≡ Set

{-# BUILTIN REWRITE _≡_ #-}
{-# REWRITE rew #-}


{-# OPTIONS --cubical --safe #-}
module Cubical.HITs.Nullification.Properties where

open import Cubical.Foundations.Everything
open isPathSplitEquiv
open import Cubical.Modalities.Everything
open Modality
open import Cubical.HITs.Localization renaming (rec to Localize-rec)
open import Cubical.Data.Unit

open import Cubical.HITs.Nullification.Base

rec : ∀ {ℓ ℓ' ℓ''} {S : Type ℓ} {A : Type ℓ'} {B : Type ℓ''}
      → (nB : isNull S B) → (A → B) → Null S A → B
rec nB g ∣ x ∣ = g x
rec nB g (hub f) = fst (sec nB) (λ s → rec nB g (f s))
rec nB g (spoke f s i) = snd (sec nB) (λ s → rec nB g (f s)) i s
rec nB g (≡hub {x} {y} p i) = fst (secCong nB (rec nB g x) (rec nB g y)) (λ i s → rec nB g (p s i)) i
rec nB g (≡spoke {x} {y} p s i j) = snd (secCong nB (rec nB g x) (rec nB g y)) (λ i s → rec nB g (p s i)) i j s

toPathP⁻ : ∀ {ℓ} (A : I → Type ℓ) {x : A i0} {y : A i1} → x ≡ transport⁻ (λ i → A i) y → PathP A x y
toPathP⁻ A p i = toPathP {A = λ i → A (~ i)} (sym p) (~ i)

toPathP⁻-sq : ∀ {ℓ} {A : Type ℓ} (x : A) → Square (toPathP⁻ (λ _ → A) (λ _ → transport refl x)) refl
                                                  (transportRefl x) refl
toPathP⁻-sq x j i = hcomp (λ l → λ { (i = i0) → transportRefl x j
                                   ; (i = i1) → x ; (j = i1) → x })
                          (transportRefl x (i ∨ j))

module _ {ℓ ℓ' ℓ''} {S : Type ℓ} {A : Type ℓ'} {B : Null S A → Type ℓ''} where

  private
    secCongDep' : ∀ (nB : (x : Null S A) → isNull S (B x)) {x y : Null S A} (p : x ≡ y)
                  → (∀ (bx : B x) (by : B y) → hasSection (cong₂ (λ x (b : B x) (_ : S) → b) p))
    secCongDep' nB p = secCongDep (λ _ → const) p (λ a → secCong (nB a))

  elim : (nB : (x : Null S A) → isNull S (B x)) → ((a : A) → B ∣ a ∣) → (x : Null S A) → B x
  elim nB g ∣ x ∣ = g x
  elim nB g (hub f)
    = fst (sec (nB (hub f)))
          (λ s → transport (λ i → B (spoke f s (~ i))) (elim nB g (f s)))

  elim nB g (spoke f s i)
    = toPathP⁻ (λ i → B (spoke f s i))
               (funExt⁻ ( snd (sec (nB (hub f)))
                              (λ s → transport (λ i → B (spoke f s (~ i))) (elim nB g (f s))) ) s) i

  elim nB g (≡hub {x} {y} p i)
    = hcomp (λ k → λ { (i = i0) → transportRefl (elim nB g x) k
                     ; (i = i1) → transportRefl (elim nB g y) k })
            (fst (secCongDep' nB (≡hub p) (transport refl (elim nB g x)) (transport refl (elim nB g y)))
                 (λ i s → transport (λ j → B (≡spoke p s (~ j) i)) (elim nB g (p s i))) i)

  elim nB g (≡spoke {x} {y} p s j i)
    = hcomp (λ k → λ { (i = i0) → toPathP⁻-sq (elim nB g x) k j
                     ; (i = i1) → toPathP⁻-sq (elim nB g y) k j
                     ; (j = i1) → elim nB g (p s i) })
            (q₂ j i)

    where q₁ : Path (PathP (λ i → B (≡hub p i)) (transport refl (elim nB g x)) (transport refl (elim nB g y)))
                    (fst (secCongDep' nB (≡hub p) (transport refl (elim nB g x)) (transport refl (elim nB g y)))
                         (λ i s → transport (λ j → B (≡spoke p s (~ j) i)) (elim nB g (p s i))))
                    (λ i → transport (λ j → B (≡spoke p s (~ j) i)) (elim nB g (p s i)))
          q₁ j i = snd (secCongDep' nB (≡hub p) (transport refl (elim nB g x)) (transport refl (elim nB g y)))
                       (λ i s → transport (λ j → B (≡spoke p s (~ j) i)) (elim nB g (p s i))) j i s

          q₂ : PathP (λ j → PathP (λ i → B (≡spoke p s j i)) (toPathP⁻ (λ _ → B x) (λ _ → transport refl (elim nB g x)) j)
                                                             (toPathP⁻ (λ _ → B y) (λ _ → transport refl (elim nB g y)) j))
                     (fst (secCongDep' nB (≡hub p) (transport refl (elim nB g x)) (transport refl (elim nB g y)))
                        (λ i s → transport (λ j → B (≡spoke p s (~ j) i)) (elim nB g (p s i))))
                     (λ i → elim nB g (p s i))
          q₂ j i = toPathP⁻ (λ j → B (≡spoke p s j i)) (λ j → q₁ j i) j

-- nullification is a modality

NullModality : ∀ {ℓ} (S : Type ℓ) → Modality ℓ
isModal       (NullModality S) = isNull S
isModalIsProp (NullModality S) = isPropIsPathSplitEquiv _
◯             (NullModality S) = Null S
◯-isModal     (NullModality S) = isNull-Null
η             (NullModality S) = ∣_∣
◯-elim        (NullModality S) = elim
◯-elim-β      (NullModality S) = λ _ _ _ → refl
◯-=-isModal   (NullModality S) x y = fromIsEquiv _ e
  where e : isEquiv (λ (p : x ≡ y) → const {B = S} p)
        e = transport (λ i → isEquiv {B = funExtPath {A = S} {f = const x} {g = const y} (~ i)}
                                     (λ p → ua-gluePath funExtEquiv {x = const p} {y = cong const p} refl (~ i)))
                      (isEquivCong (_ , toIsEquiv _ isNull-Null))

idemNull : ∀ {ℓ} (S A : Type ℓ) → isNull S A → A ≃ Null S A
idemNull S A nA = ∣_∣ , isModalToIsEquiv (NullModality S) nA

-- nullification is localization at a map (S → 1)

module Null-iso-Localize {ℓ ℓ'} (S : Type ℓ) (A : Type ℓ') where

  to : Null S A → Localize {A = Unit} (λ _ → const {B = S} tt) A
  to ∣ x ∣ = ∣ x ∣
  to (hub f) = ext tt (to ∘ f) tt
  to (spoke f s i) = isExt tt (to ∘ f) s i
  to (≡hub {x} {y} p i) = ≡ext tt (const (to x)) (const (to y)) (cong to ∘ p) tt i
  to (≡spoke {x} {y} p s i j) = ≡isExt tt (const (to x)) (const (to y)) (cong to ∘ p) s i j

  from : Localize {A = Unit} (λ _ → const {B = S} tt) A → Null S A
  from ∣ x ∣ = ∣ x ∣
  from (ext tt f tt) = hub (from ∘ f)
  from (isExt tt f s i) = spoke (from ∘ f) s i
  from (≡ext tt g h p tt i) = ≡hub {x = from (g tt)} {from (h tt)} (cong from ∘ p) i
  from (≡isExt tt g h p s i j) = ≡spoke {x = from (g tt)} {from (h tt)} (cong from ∘ p) s i j

  to-from : ∀ (x : Localize {A = Unit} (λ _ → const {B = S} tt) A) → to (from x) ≡ x
  to-from ∣ x ∣ k = ∣ x ∣
  to-from (ext tt f tt) k = ext tt (λ s → to-from (f s) k) tt
  to-from (isExt tt f s i) k = isExt tt (λ s → to-from (f s) k) s i
  to-from (≡ext tt g h p tt i) k = ≡ext tt (λ _ → to-from (g tt) k) (λ _ → to-from (h tt) k) (λ s j → to-from (p s j) k) tt i
  to-from (≡isExt tt g h p s i j) k = ≡isExt tt (λ _ → to-from (g tt) k) (λ _ → to-from (h tt) k) (λ s j → to-from (p s j) k) s i j

  from-to : ∀ (x : Null S A) → from (to x) ≡ x
  from-to ∣ x ∣ k = ∣ x ∣
  from-to (hub f) k = hub (λ s → from-to (f s) k)
  from-to (spoke f s i) k = spoke (λ s → from-to (f s) k) s i
  from-to (≡hub {x} {y} p i) k = ≡hub {x = from-to x k} {from-to y k} (λ s j → from-to (p s j) k) i
  from-to (≡spoke {x} {y} p s i j) k = ≡spoke {x = from-to x k} {from-to y k} (λ s j → from-to (p s j) k) s i j

  isom : Iso (Null S A) (Localize {A = Unit} (λ _ → const {B = S} tt) A)
  isom = iso to from to-from from-to

Null≃Localize : ∀ {ℓ ℓ'} (S : Type ℓ) (A : Type ℓ') → Null S A ≃ Localize (λ _ → const tt) A
Null≃Localize S A = isoToEquiv (Null-iso-Localize.isom S A)


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

open import Prelude
open import GSeTT.Syntax
open import GSeTT.Rules
open import GSeTT.Uniqueness-Derivations
open import Sets ℕ eqdecℕ
open import GSeTT.Dec-Type-Checking
open import CaTT.Ps-contexts

{- PS-contexts -}
module CaTT.Relation where

  -- The relation ◃ generating cases
  data _,_◃₀_ Γ x y : Set₁ where
    ◃∂⁻ : ∀{A z} → Γ ⊢t (Var y) # (⇒ A (Var x) (Var z)) → Γ , x ◃₀ y
    ◃∂⁺ : ∀{A z} → Γ ⊢t (Var x) # (⇒ A (Var z) (Var y)) → Γ , x ◃₀ y

  -- Transitive closure : we associate on the right
  data _,_◃_ Γ x y : Set₁ where
    gen : Γ , x ◃₀ y → Γ , x ◃ y
    ◃T : ∀{z} → Γ , x ◃ z → Γ , z ◃₀ y → Γ , x ◃ y

  rel : ∀ Γ x y → Set₁
  rel Γ x y = Γ , x ◃ y

  W◃₀ : ∀ {Γ x y z A} → (Γ :: (z , A)) ⊢C → Γ , x ◃₀ y → (Γ :: (z , A)) , x ◃₀ y
  W◃₀ Γ+⊢ (◃∂⁻ Γ⊢x) = ◃∂⁻ (wkt Γ⊢x Γ+⊢)
  W◃₀ Γ+⊢ (◃∂⁺ Γ⊢x) = ◃∂⁺ (wkt Γ⊢x Γ+⊢)

  W◃ : ∀ {Γ x y z A} → (Γ :: (z , A)) ⊢C → Γ , x ◃ y → (Γ :: (z , A)) , x ◃ y
  W◃ Γ+⊢ (gen x◃₀y) = gen (W◃₀ Γ+⊢ x◃₀y)
  W◃ Γ+⊢ (◃T x◃y y◃₀z) = ◃T (W◃ Γ+⊢ x◃y) (W◃₀ Γ+⊢ y◃₀z)

  WW◃ : ∀ {Γ x y z f A B} → ((Γ :: (z , A)) :: (f , B)) ⊢C → Γ , x ◃ y → ((Γ :: (z , A)) :: (f , B)) , x ◃ y
  WW◃ Γ+⊢@(cc Γ⊢ _ idp) x◃y = W◃ Γ+⊢ (W◃ Γ⊢ x◃y)

  ◃-trans : ∀ {Γ x y z} → Γ , x ◃ y → Γ , y ◃ z → Γ , x ◃ z
  ◃-trans x◃y (gen y◃₀z) = ◃T x◃y y◃₀z
  ◃-trans x◃y (◃T y◃z z◃₀w) = ◃T (◃-trans x◃y y◃z) z◃₀w

  -- TODO : Move at the right place
  x#A∈Γ→x∈Γ : ∀ {Γ x A} → x # A ∈ Γ → x ∈ Γ
  x#A∈Γ→x∈Γ {Γ :: (y , _)} (inl x#A∈Γ) = inl (x#A∈Γ→x∈Γ x#A∈Γ)
  x#A∈Γ→x∈Γ {Γ :: (y , _)} (inr (idp , idp)) = inr idp

  Γ⊢x:A→x∈Γ : ∀ {Γ x A} → Γ ⊢t (Var x) # A → x ∈ Γ
  Γ⊢x:A→x∈Γ (var _ x#A∈Γ) = x#A∈Γ→x∈Γ x#A∈Γ

  data _,_⟿_ : Pre-Ctx → ℕ → ℕ → Set₁ where -- y is an iterated target of x in Γ
    ∂⁺⟿ : ∀{Γ x a y A} → Γ ⊢t (Var x) # (⇒ A (Var a) (Var y)) → Γ , x ⟿ y
    x⟿∂⁺ : ∀{Γ x a y z A} → Γ ⊢t (Var x) # (⇒ A (Var a) (Var y)) → Γ , y ⟿ z → Γ , x ⟿ z

  W⟿ : ∀ {Γ x y z A} → (Γ :: (z , A)) ⊢C → Γ , x ⟿ y → (Γ :: (z , A)) , x ⟿ y
  W⟿ Γ+⊢ (∂⁺⟿ Γ⊢x) = ∂⁺⟿ (wkt Γ⊢x Γ+⊢)
  W⟿ Γ+⊢ (x⟿∂⁺ Γ⊢x x⟿y) = x⟿∂⁺ (wkt Γ⊢x Γ+⊢) (W⟿ Γ+⊢ x⟿y)

  WW⟿ : ∀ {Γ x y z w A B} → ((Γ :: (z , A)) :: (w , B)) ⊢C → Γ , x ⟿ y → ((Γ :: (z , A)) :: (w , B)) , x ⟿ y
  WW⟿ Γ++⊢@(cc Γ+⊢ _ idp) x⟿y = W⟿ Γ++⊢ (W⟿ Γ+⊢ x⟿y)

  ⟿→◃ : ∀ {Γ x y} → Γ , x ⟿ y → Γ , x ◃ y
  ⟿→◃ (∂⁺⟿ Γ⊢x) = gen (◃∂⁺ Γ⊢x)
  ⟿→◃ (x⟿∂⁺ Γ⊢x x⟿y) = ◃-trans (gen (◃∂⁺ Γ⊢x)) (⟿→◃ x⟿y)

  Γ++ : ∀ {Γ x A} → Γ ⊢ps x # A → Pre-Ctx
  Γ++ {Γ} {x} {A} _ = (Γ :: (length Γ , A)) :: (S (length Γ) , ⇒ A (Var x) (Var (length Γ)))

  //⟿ : ∀ {Γ Δ x y A a} → Γ ⊢t (Var x) # A → Δ ⊢t (Var y) # A → Γ , x ⟿ a → Δ , y ⟿ a
  //⟿ Γ⊢x Δ⊢y (∂⁺⟿ Γ⊢x') with unique-type Γ⊢x Γ⊢x' idp
  ... | idp = ∂⁺⟿ Δ⊢y
  //⟿ Γ⊢x Δ⊢y (x⟿∂⁺ Γ⊢x' x⟿a) with unique-type Γ⊢x Γ⊢x' idp
  ... | idp = x⟿∂⁺ Δ⊢y (//⟿ (Γ⊢tgt (Γ⊢t:A→Γ⊢A Γ⊢x)) (Γ⊢tgt (Γ⊢t:A→Γ⊢A Δ⊢y)) x⟿a)

  T⟿ : ∀ {Γ x y z} → Γ , x ⟿ y → Γ , y ⟿ z → Γ , x ⟿ z
  T⟿ (∂⁺⟿ Γ⊢x) y⟿z = x⟿∂⁺ Γ⊢x y⟿z
  T⟿ (x⟿∂⁺ Γ⊢x x⟿y) y⟿z = x⟿∂⁺ Γ⊢x (T⟿ x⟿y y⟿z)

  ⟿dim : ∀ {Γ x y A B} → Γ ⊢t Var x # A → Γ ⊢t Var y # B → Γ , x ⟿ y → dim B < dim A
  ⟿dim Γ⊢x:A Γ⊢y:B (∂⁺⟿ Γ⊢x) with unique-type Γ⊢x:A Γ⊢x idp | unique-type Γ⊢y:B (Γ⊢tgt(Γ⊢t:A→Γ⊢A Γ⊢x)) idp
  ... | idp | idp = n≤n _
  ⟿dim Γ⊢x:A Γ⊢y:B (x⟿∂⁺ Γ⊢x z⟿y) with unique-type Γ⊢x:A Γ⊢x idp
  ... | idp = n≤m→n≤Sm (⟿dim (Γ⊢tgt(Γ⊢t:A→Γ⊢A Γ⊢x)) Γ⊢y:B z⟿y)

  𝔻0-◃ : ∀ z → ¬ ((nil :: (0 , ∗)) , 0 ◃ z)
  𝔻0-◃ z (gen (◃∂⁻ (var _ (inl ()))))
  𝔻0-◃ z (gen (◃∂⁻ (var _ (inr ()))))
  𝔻0-◃ z (gen (◃∂⁺ (var _ (inl ()))))
  𝔻0-◃ z (gen (◃∂⁺ (var _ (inr ()))))
  𝔻0-◃ z (◃T 0◃x _) = 𝔻0-◃ _ 0◃x

  𝔻0-⟿ : ∀ z → ¬ ((nil :: (0 , ∗)) , 0 ⟿ z)
  𝔻0-⟿ z (∂⁺⟿ (var _ (inl ())))
  𝔻0-⟿ z (∂⁺⟿ (var _ (inr ())))
  𝔻0-⟿ z (x⟿∂⁺ (var _ (inl ())) _)
  𝔻0-⟿ z (x⟿∂⁺ (var _ (inr ())) _)

  n≮n : ∀ n → ¬ (n < n)
  n≮n n n<n = Sn≰n _ n<n

  ⟿-is-tgt : ∀ {Γ x y z A} → Γ ⊢t Var x # ⇒ A (Var y) (Var z) → Γ , x ⟿ y → y == z
  ⟿-is-tgt Γ⊢x (∂⁺⟿ Γ⊢'x) with unique-type Γ⊢x Γ⊢'x idp
  ... | idp = idp
  ⟿-is-tgt Γ⊢x (x⟿∂⁺ Γ⊢'x y'⟿y) with unique-type Γ⊢x Γ⊢'x idp
  ... | idp = ⊥-elim (Sn≰n _ (⟿dim (Γ⊢tgt (Γ⊢t:A→Γ⊢A Γ⊢'x)) (Γ⊢src (Γ⊢t:A→Γ⊢A Γ⊢x)) y'⟿y))

  no-loop : ∀{Γ x y z T a A} → Γ ⊢ps a # A → Γ ⊢t (Var x) # ⇒ T (Var y) (Var z) → y ≠ z
  no-loop pss (var _ (inl ())) idp
  no-loop pss (var _ (inr ())) idp
  no-loop (psd Γ⊢psf) Γ⊢x idp = no-loop Γ⊢psf Γ⊢x idp
  no-loop (pse Γ⊢psb idp idp idp idp idp) (var _ (inl (inl x∈Γ))) idp = no-loop Γ⊢psb (var (Γ⊢psx:A→Γ⊢ Γ⊢psb) x∈Γ) idp
  no-loop (pse Γ⊢psb idp idp idp idp idp) (var _ (inl (inr (idp , idp)))) idp = no-loop Γ⊢psb (Γ⊢psx:A→Γ⊢x:A Γ⊢psb) idp
  no-loop (pse Γ⊢psb idp idp idp idp idp) (var _ (inr (idp , idp))) idp = x∉ (Γ⊢psx:A→Γ⊢ Γ⊢psb) (n≤n _) (Γ⊢psx:A→Γ⊢x:A Γ⊢psb)

  dangling-is-not-a-source : ∀ {Γ x A} → Γ ⊢ps x # A → (∀ f z {B} →  ¬ (Γ ⊢t Var f # ⇒ B (Var x) (Var z)))
  post-dangling-is-not-a-source : ∀ {Γ x A} → Γ ⊢ps x # A → (∀ {y B} f z → Γ , x ⟿ y →  ¬ (Γ ⊢t (Var f) # ⇒ B (Var y) (Var z)))

  dangling-is-not-a-source pss _ _ (var _ (inl ()))
  dangling-is-not-a-source pss _ _ (var _ (inr ()))
  dangling-is-not-a-source {x = x} (psd Γ⊢ps) t u Γ⊢t = post-dangling-is-not-a-source Γ⊢ps t u  (∂⁺⟿ (psvar Γ⊢ps)) Γ⊢t
  dangling-is-not-a-source (pse Γ⊢ps idp idp idp idp idp) _ _ (var _ (inl (inl x∈Γ))) = x∉ (psv Γ⊢ps) (n≤Sn _) (Γ⊢src (Γ⊢t:A→Γ⊢A (var (psv Γ⊢ps) x∈Γ)))
  dangling-is-not-a-source (pse Γ⊢ps idp idp idp idp idp) _ _ (var _ (inl (inr (idp , idp)))) = x∉ (psv Γ⊢ps) (n≤Sn _) (Γ⊢src (Γ⊢t:A→Γ⊢A (psvar Γ⊢ps)))
  dangling-is-not-a-source (pse Γ⊢ps idp idp idp idp idp) _ _ (var _ (inr (idp , idp))) = x∉ (psv Γ⊢ps) (n≤Sn _) (psvar Γ⊢ps)
  post-dangling-is-not-a-source pss t u x⟿y Γ⊢t = 𝔻0-⟿ _ x⟿y
  post-dangling-is-not-a-source (psd Γ⊢ps) t u x⟿y Γ⊢t = post-dangling-is-not-a-source Γ⊢ps t u (T⟿ (∂⁺⟿ (psvar Γ⊢ps)) x⟿y) Γ⊢t
  post-dangling-is-not-a-source Γ+⊢@(pse Γ⊢ps idp idp idp idp idp) t u (∂⁺⟿ Γ⊢Sl) Γ⊢t with unique-type Γ⊢Sl (psvar Γ+⊢) idp
  post-dangling-is-not-a-source (pse Γ⊢ps idp idp idp idp idp) _ _ (∂⁺⟿ Γ⊢Sl) (var _ (inl (inl t∈Γ))) | idp = x∉ (psv Γ⊢ps) (n≤n _) (Γ⊢src (Γ⊢t:A→Γ⊢A (var (psv Γ⊢ps) t∈Γ)))
  post-dangling-is-not-a-source (pse Γ⊢ps idp idp idp idp idp) _ _ (∂⁺⟿ Γ⊢Sl) (var _ (inl (inr (idp , idp)))) | idp = x∉ (psv Γ⊢ps) (n≤n _) (Γ⊢src (Γ⊢t:A→Γ⊢A (psvar Γ⊢ps)))
  post-dangling-is-not-a-source (pse Γ⊢ps idp idp idp idp idp) _ _ (∂⁺⟿ Γ⊢Sl) (var _ (inr (idp , idp))) | idp = x∉ (psv Γ⊢ps) (n≤n _) (psvar Γ⊢ps)
  post-dangling-is-not-a-source Γ+⊢@(pse Γ⊢ps idp idp idp idp idp) t u (x⟿∂⁺ Γ⊢Sl x⟿y) Γ⊢t with unique-type Γ⊢Sl (psvar Γ+⊢) idp
  post-dangling-is-not-a-source (pse Γ⊢ps idp idp idp idp idp) _ _ (x⟿∂⁺ Γ⊢Sl x⟿y) (var Γ+⊢ (inl (inl t∈Γ))) | idp =
         post-dangling-is-not-a-source Γ⊢ps _ _ (//⟿ (var Γ+⊢ (inl (inr (idp , idp)))) (psvar Γ⊢ps) x⟿y) (var (psv Γ⊢ps) t∈Γ)
  post-dangling-is-not-a-source (pse Γ⊢ps  idp idp idp idp idp)  _ _ (x⟿∂⁺ Γ⊢Sl x⟿y) (var Γ+⊢ (inl (inr (idp , idp)))) | idp with ⟿-is-tgt (var Γ+⊢ (inl (inr (idp , idp)))) x⟿y
  ... | idp = no-loop Γ⊢ps (psvar Γ⊢ps) idp
  post-dangling-is-not-a-source (pse Γ⊢ps idp idp idp idp idp) _ _ (x⟿∂⁺ Γ⊢Sl x⟿y) (var Γ++⊢@(cc Γ+⊢ _ p) (inr (idp , idp))) | idp = n≮n _ (⟿dim (var Γ++⊢ (inl (inr (idp , idp)))) (wkt (wkt (psvar Γ⊢ps) Γ+⊢) Γ++⊢) x⟿y)

  ⊢psx-◃₀→⟿ : ∀ {Γ x a A} → Γ ⊢ps x # A → Γ , x ◃₀ a → Γ , x ⟿ a
  ⊢psx-◃₀→⟿ Γ⊢psx (◃∂⁻ Γ⊢a) = ⊥-elim (dangling-is-not-a-source Γ⊢psx _ _ Γ⊢a)
  ⊢psx-◃₀→⟿ Γ⊢psx (◃∂⁺ Γ⊢x) = ∂⁺⟿ Γ⊢x

  ⊢psx-◃₀→⟿+ : ∀ {Γ x y a A} → Γ ⊢ps x # A → Γ , x ⟿ y → Γ , y ◃₀ a → Γ , y ⟿ a
  ⊢psx-◃₀→⟿+ Γ⊢psx x⟿y (◃∂⁻ Γ⊢a) = ⊥-elim (post-dangling-is-not-a-source Γ⊢psx _ _ x⟿y Γ⊢a)
  ⊢psx-◃₀→⟿+ Γ⊢psx x⟿y (◃∂⁺ Γ⊢y) = ∂⁺⟿ Γ⊢y

  ⊢psx-◃→⟿ : ∀ {Γ x a A} → Γ ⊢ps x # A → Γ , x ◃ a → Γ , x ⟿ a
  ⊢psx-◃→⟿+ : ∀ {Γ x a b A} → Γ ⊢ps x # A → Γ , x ⟿ a → Γ , a ◃ b → Γ , a ⟿ b

  ⊢psx-◃→⟿ Γ⊢psx (gen x◃₀a) = ⊢psx-◃₀→⟿ Γ⊢psx x◃₀a
  ⊢psx-◃→⟿ Γ⊢psx (◃T x◃z z◃₀a) = T⟿ (⊢psx-◃→⟿ Γ⊢psx x◃z) (⊢psx-◃₀→⟿+ Γ⊢psx (⊢psx-◃→⟿ Γ⊢psx x◃z) z◃₀a)
  ⊢psx-◃→⟿+ Γ⊢psx x⟿y (gen y◃₀a) = ⊢psx-◃₀→⟿+ Γ⊢psx x⟿y y◃₀a
  ⊢psx-◃→⟿+ Γ⊢psx x⟿y (◃T y◃z z◃₀a) = T⟿ (⊢psx-◃→⟿+ Γ⊢psx x⟿y y◃z) (⊢psx-◃₀→⟿+ Γ⊢psx (T⟿ x⟿y (⊢psx-◃→⟿+ Γ⊢psx x⟿y y◃z)) z◃₀a)

  -- easy to finish, and follows the paper proof
  psx-◃-linear→ : ∀ {Γ x A} → Γ ⊢ps x # A → (∀ a b → a ∈ Γ → b ∈ Γ → (((Γ , a ◃ b) + (Γ , b ◃ a)) + (a == b)))
  psx-◃-linear→ pss .0 .0 (inr idp) (inr idp) = inr idp
  psx-◃-linear→ (psd Γ⊢psx) a b a∈Γ b∈Γ = psx-◃-linear→ Γ⊢psx a b a∈Γ b∈Γ
  psx-◃-linear→ Γ++⊢ps@(pse Γ⊢psx idp idp idp idp idp) a b (inl (inl a∈Γ)) (inl (inl b∈Γ)) with psx-◃-linear→ Γ⊢psx a b a∈Γ b∈Γ
  ... | inl (inl a◃b) = inl (inl (WW◃ (psv Γ++⊢ps) a◃b))
  ... | inl (inr b◃a) = inl (inr (WW◃ (psv Γ++⊢ps) b◃a))
  ... | inr idp = inr idp
  psx-◃-linear→ Γ++⊢ps@(pse {x = x} Γ⊢psx idp idp idp idp idp) a .(length _) (inl (inl a∈Γ)) (inl (inr idp)) with psx-◃-linear→ Γ⊢psx a x a∈Γ (Γ⊢x:A→x∈Γ (psvar Γ⊢psx)) -- a ∈ Γ , b = y
  ... | inl (inl a◃x) = inl (inl (◃-trans (WW◃ (psv Γ++⊢ps) a◃x) (◃T (gen (◃∂⁻ (psvar Γ++⊢ps))) ((◃∂⁺ (psvar Γ++⊢ps)))))) -- a ◃ x
  ... | inl (inr x◃a) = inl (inr (⟿→◃ (//⟿ (psvar Γ⊢psx) (var (psv Γ++⊢ps) (inl (inr (idp , idp)))) (⊢psx-◃→⟿ Γ⊢psx x◃a)))) -- x ◃ a
  ... | inr idp = inl (inl (◃T (gen (◃∂⁻ (psvar Γ++⊢ps))) (◃∂⁺ (psvar Γ++⊢ps)))) -- a = x
  psx-◃-linear→ Γ++⊢ps@(pse {x = x} Γ⊢psx idp idp idp idp idp) a .(S (length _)) (inl (inl a∈Γ)) (inr idp) with psx-◃-linear→ Γ⊢psx a x a∈Γ (Γ⊢x:A→x∈Γ (psvar Γ⊢psx)) -- a ∈ Γ , b = f (**)
  ... | inl (inl a◃x) = inl (inl (◃T (WW◃ (psv Γ++⊢ps) a◃x) (◃∂⁻ (psvar Γ++⊢ps)))) -- a ◃ x
  ... | inl (inr x◃a) = inl (inr (⟿→◃ (x⟿∂⁺ (psvar Γ++⊢ps) (//⟿ (psvar Γ⊢psx) (var (psv Γ++⊢ps) (inl (inr (idp , idp)))) (⊢psx-◃→⟿ Γ⊢psx x◃a))))) -- x ◃ a
  ... | inr idp = inl (inl (gen (◃∂⁻ (psvar Γ++⊢ps)))) -- a = x
  psx-◃-linear→ Γ++⊢ps@(pse {x = x} Γ⊢psx idp idp idp idp idp) .(length _) b (inl (inr idp)) (inl (inl b∈Γ)) with psx-◃-linear→ Γ⊢psx b x b∈Γ (Γ⊢x:A→x∈Γ (psvar Γ⊢psx)) -- a = y, b ∈ Γ
  ... | inl (inl b◃x) = inl (inr (◃-trans (WW◃ (psv Γ++⊢ps) b◃x) (◃T (gen (◃∂⁻ (psvar Γ++⊢ps))) (◃∂⁺ (psvar Γ++⊢ps))))) -- b ◃ x
  ... | inl (inr x◃b) = inl (inl (⟿→◃ (//⟿ (psvar Γ⊢psx) (var (psv Γ++⊢ps) (inl (inr (idp , idp)))) (⊢psx-◃→⟿ Γ⊢psx x◃b)))) -- x ◃ b
  ... | inr idp = inl (inr (◃T (gen (◃∂⁻ (psvar Γ++⊢ps))) (◃∂⁺ (psvar Γ++⊢ps)))) -- b = x
  psx-◃-linear→ (pse Γ⊢psx idp idp idp idp idp) .(length _) .(length _) (inl (inr idp)) (inl (inr idp)) = inr idp
  psx-◃-linear→ Γ++⊢ps@(pse Γ⊢psx idp idp idp idp idp) .(length _) .(S (length _)) (inl (inr idp)) (inr idp) = inl (inr (gen (◃∂⁺ (psvar Γ++⊢ps)))) -- a = y, b = f
  psx-◃-linear→ Γ++⊢ps@(pse {x = x} Γ⊢psx  idp idp idp idp idp) .(S (length _)) b (inr idp) (inl (inl b∈Γ)) with psx-◃-linear→ Γ⊢psx b x b∈Γ (Γ⊢x:A→x∈Γ (psvar Γ⊢psx)) -- a = f b ∈ Γ
  ... | inl (inl b◃x) = inl (inr (◃T (WW◃ (psv Γ++⊢ps) b◃x) (◃∂⁻ (psvar Γ++⊢ps)))) -- b ◃ x
  ... | inl (inr x◃b) = inl (inl (⟿→◃ (x⟿∂⁺ (psvar Γ++⊢ps) (//⟿ (psvar Γ⊢psx) (var (psv Γ++⊢ps) (inl (inr (idp , idp)))) (⊢psx-◃→⟿ Γ⊢psx x◃b)))))  -- x ◃ b
  ... | inr idp = inl (inr (gen (◃∂⁻ (psvar Γ++⊢ps)))) -- b = x
  psx-◃-linear→ Γ++⊢ps@(pse Γ⊢psx idp idp idp idp idp) .(S (length _)) .(length _) (inr idp) (inl (inr idp)) = inl (inl (gen (◃∂⁺ (psvar Γ++⊢ps)))) -- a = f, b = y
  psx-◃-linear→ (pse Γ⊢psx idp idp idp idp idp) .(S (length _)) .(S (length _)) (inr idp) (inr idp) = inr idp

  strengthen : ∀ {Γ x A y B} → (Γ :: (y , B)) ⊢t Var x # A → x ∈ Γ → Γ ⊢t Var x # A
  strengthen (var (cc Γ⊢ _ idp) (inl x#A∈Γ)) x∈Γ = var Γ⊢ x#A∈Γ
  strengthen (var (cc Γ⊢ _ idp) (inr (idp , idp))) x∈Γ = ⊥-elim (l∉ Γ⊢ (n≤n _) x∈Γ)

  strengthen+ : ∀ {Γ x A y B z C} → ((Γ :: (y , B)) :: (z , C)) ⊢t Var x # A → x ∈ Γ → Γ ⊢t Var x # A
  strengthen+ Γ++⊢x x∈Γ = strengthen (strengthen Γ++⊢x (inl x∈Γ)) x∈Γ

  ◃₀∈ : ∀ {Γ x a} → Γ , x ◃₀ a → a ∈ Γ
  ◃₀∈ (◃∂⁻ Γ⊢a) = Γ⊢x:A→x∈Γ Γ⊢a
  ◃₀∈ (◃∂⁺ Γ⊢x) = Γ⊢x:A→x∈Γ (Γ⊢tgt (Γ⊢t:A→Γ⊢A Γ⊢x))

  ◃∈ : ∀ {Γ x a} → Γ , x ◃ a → a ∈ Γ
  ◃∈ (gen x◃₀a) = ◃₀∈ x◃₀a
  ◃∈ (◃T _ z◃₀x) = ◃₀∈ z◃₀x

  ∈◃₀ : ∀ {Γ x a} → Γ , x ◃₀ a → x ∈ Γ
  ∈◃₀ (◃∂⁻ Γ⊢a) = Γ⊢x:A→x∈Γ (Γ⊢src (Γ⊢t:A→Γ⊢A Γ⊢a))
  ∈◃₀ (◃∂⁺ Γ⊢x) = Γ⊢x:A→x∈Γ Γ⊢x

  ∈◃ : ∀ {Γ x a} → Γ , x ◃ a → x ∈ Γ
  ∈◃ (gen x◃₀a) = ∈◃₀ x◃₀a
  ∈◃ (◃T x◃z _) = ∈◃ x◃z

  WWpsx : ∀ {Γ x A} → (Γ⊢ps : Γ ⊢ps x # A) → Γ++ Γ⊢ps ⊢t (Var x) # A
  WWpsx Γ⊢ps = wkt (wkt (psvar Γ⊢ps) (cc (psv Γ⊢ps) (Γ⊢t:A→Γ⊢A (psvar Γ⊢ps)) idp)) (psv (pse Γ⊢ps idp idp idp idp idp))

  dangling-◃₀ : ∀ {Γ x A a} → (Γ⊢ps : Γ ⊢ps x # A) → Γ++ Γ⊢ps , S (length Γ) ◃₀ a → a == length Γ
  dangling-◃₀ Γ⊢ps (◃∂⁻ Γ⊢a) = ⊥-elim (dangling-is-not-a-source (pse Γ⊢ps idp idp idp idp idp) _ _ Γ⊢a)
  dangling-◃₀ Γ⊢ps (◃∂⁺ (var _ (inl (inl Sl∈Γ)))) = ⊥-elim (l∉ (psv Γ⊢ps) (n≤Sn _) (x#A∈Γ→x∈Γ Sl∈Γ))
  dangling-◃₀ Γ⊢ps (◃∂⁺ (var _ (inl (inr (Sl=l , idp))))) = ⊥-elim (Sn≠n _ Sl=l)
  dangling-◃₀ Γ⊢ps (◃∂⁺ (var _ (inr (_ , idp)))) = idp

  ◃₀-dangling : ∀ {Γ x A a} → (Γ⊢ps : Γ ⊢ps x # A) → Γ++ Γ⊢ps , a ◃₀ S (length Γ)  → a == x
  ◃₀-dangling Γ⊢ps (◃∂⁻ Γ+⊢Sl) with unique-type Γ+⊢Sl (psvar (pse Γ⊢ps idp idp idp idp idp)) idp
  ... | idp = idp
  ◃₀-dangling Γ⊢ps (◃∂⁺ (var x (inl (inl a∈Γ)))) = ⊥-elim (x∉ (psv Γ⊢ps) (n≤Sn _) (Γ⊢tgt (Γ⊢t:A→Γ⊢A (var (psv Γ⊢ps) a∈Γ))))
  ◃₀-dangling Γ⊢ps (◃∂⁺ (var x (inl (inr (idp , idp))))) = ⊥-elim (x∉ (psv Γ⊢ps) (n≤Sn _) (Γ⊢tgt (Γ⊢t:A→Γ⊢A (psvar Γ⊢ps))))
  ◃₀-dangling Γ⊢ps (◃∂⁺ (var x (inr (idp , abs)))) = ⊥-elim (Sn≠n _ (=Var (snd (=⇒ abs))))

  ◃₀-dangling-tgt : ∀ {Γ x A a} → (Γ⊢ps : Γ ⊢ps x # A) → Γ++ Γ⊢ps , a ◃₀ length Γ  → (a == S (length Γ)) + (Γ++ Γ⊢ps , a ◃₀ x)
  ◃₀-dangling-tgt Γ⊢ps (◃∂⁻ Γ+⊢l) with unique-type Γ+⊢l (var (psv (pse Γ⊢ps idp idp idp idp idp)) (inl (inr (idp , idp)))) idp
  ... | idp = inr (◃∂⁻ (WWpsx Γ⊢ps))
  ◃₀-dangling-tgt Γ⊢ps (◃∂⁺ (var x (inl (inl a∈Γ)))) = ⊥-elim (x∉ (psv Γ⊢ps) (n≤n _) (Γ⊢tgt (Γ⊢t:A→Γ⊢A (var (psv Γ⊢ps) a∈Γ))))
  ◃₀-dangling-tgt Γ⊢ps (◃∂⁺ (var x (inl (inr (idp , idp))))) = ⊥-elim (x∉ (psv Γ⊢ps) (n≤n _) (Γ⊢tgt (Γ⊢t:A→Γ⊢A (psvar Γ⊢ps))))
  ◃₀-dangling-tgt Γ⊢ps (◃∂⁺ (var x (inr (p , _)))) = inl p

  ◃-dangling : ∀ {Γ x A a} → (Γ⊢ps : Γ ⊢ps x # A) → Γ++ Γ⊢ps , a ◃ S (length Γ)  → (a == x) + (Γ++ Γ⊢ps , a ◃ x)
  ◃-dangling Γ⊢ps (gen x◃₀Sl) with ◃₀-dangling Γ⊢ps x◃₀Sl
  ... | idp = inl idp
  ◃-dangling Γ⊢ps (◃T a◃x x◃₀Sl) with ◃₀-dangling Γ⊢ps x◃₀Sl
  ... | idp = inr a◃x

  ◃-dangling-tgt : ∀ {Γ x A a} → (Γ⊢ps : Γ ⊢ps x # A) → Γ++ Γ⊢ps , a ◃ length Γ  → (a == S (length Γ) + (a == x)) + (Γ++ Γ⊢ps , a ◃ x)
  ◃-dangling-tgt Γ⊢ps (gen a◃₀l) with ◃₀-dangling-tgt Γ⊢ps a◃₀l
  ... | inl idp = inl (inl idp)
  ... | inr a◃₀x = inr (gen a◃₀x)
  ◃-dangling-tgt Γ⊢ps (◃T a◃z z◃₀l) with ◃₀-dangling-tgt Γ⊢ps z◃₀l
  ... | inl idp with ◃-dangling Γ⊢ps a◃z
  ... | inl idp = inl (inr idp)
  ... | inr a◃x = inr a◃x
  ◃-dangling-tgt Γ⊢ps (◃T a◃z z◃₀l) | inr z◃₀x = inr (◃T a◃z z◃₀x)

  strengthen-◃₀ : ∀ {Γ x A a b} → (Γ⊢ps : Γ ⊢ps x # A) → a ∈ Γ → b ∈ Γ → Γ++ Γ⊢ps , a ◃₀ b → Γ , a ◃₀ b
  strengthen-◃₀ Γ⊢ps a∈Γ b∈Γ (◃∂⁻ Γ⊢b) = ◃∂⁻ (strengthen+ Γ⊢b b∈Γ)
  strengthen-◃₀ Γ⊢ps a∈Γ b∈Γ (◃∂⁺ Γ⊢a) = ◃∂⁺ (strengthen+ Γ⊢a a∈Γ)

  -- useful particular case
  strengthen-◃₀-dangling : ∀ {Γ x A a} → (Γ⊢ps : Γ ⊢ps x # A) → Γ++ Γ⊢ps , length Γ ◃₀ a → Γ , x ◃₀ a
  strengthen-◃₀-dangling Γ⊢ps (◃∂⁻ Γ⊢a) = ⊥-elim (post-dangling-is-not-a-source (pse Γ⊢ps idp idp idp idp idp) _ _ (∂⁺⟿ (psvar (pse Γ⊢ps idp idp idp idp idp))) Γ⊢a)
  strengthen-◃₀-dangling Γ⊢ps (◃∂⁺ (var _ (inl (inl l∈Γ)))) = ⊥-elim (l∉ (psv Γ⊢ps) (n≤n _) (x#A∈Γ→x∈Γ l∈Γ))
  strengthen-◃₀-dangling Γ⊢ps (◃∂⁺ (var _ (inl (inr (_ , idp))))) = ◃∂⁺ (psvar Γ⊢ps)
  strengthen-◃₀-dangling Γ⊢ps (◃∂⁺ (var _ (inr (l=Sl , _)))) = ⊥-elim (Sn≠n _ (l=Sl ^))

  ∈-dangling : ∀ {Γ x A} → Γ ⊢ps x # A → x ∈ Γ
  ∈-dangling Γ⊢ps = Γ⊢x:A→x∈Γ (psvar Γ⊢ps)

  ∈-dangling-◃₀ : ∀ {Γ x A a} → (Γ⊢ps : Γ ⊢ps x # A) → Γ++ Γ⊢ps , a ◃₀ x → a ∈ Γ
  ∈-dangling-◃₀ Γ⊢ps (◃∂⁻ Γ+⊢x) with unique-type Γ+⊢x  (WWpsx Γ⊢ps) idp
  ... | idp = Γ⊢x:A→x∈Γ (Γ⊢src (Γ⊢t:A→Γ⊢A (psvar Γ⊢ps)))
  ∈-dangling-◃₀ Γ⊢ps (◃∂⁺ (var _ (inl (inl a∈Γ)))) = x#A∈Γ→x∈Γ a∈Γ
  ∈-dangling-◃₀ Γ⊢ps (◃∂⁺ (var _ (inl (inr (idp , idp))))) with unique-type (psvar Γ⊢ps) (Γ⊢tgt (Γ⊢t:A→Γ⊢A (psvar Γ⊢ps))) idp
  ... | ()
  ∈-dangling-◃₀ Γ⊢ps (◃∂⁺ (var _ (inr (idp , idp)))) = ⊥-elim (x∉ (psv Γ⊢ps) (n≤n _) (psvar Γ⊢ps))

  strengthen-dangling-◃₀ : ∀ {Γ x A a} → (Γ⊢ps : Γ ⊢ps x # A) → Γ++ Γ⊢ps , a ◃₀ x → Γ , a ◃₀ x
  strengthen-dangling-◃₀ Γ⊢ps a◃₀x = strengthen-◃₀ Γ⊢ps (∈-dangling-◃₀ Γ⊢ps a◃₀x) (∈-dangling Γ⊢ps) a◃₀x

  -- Not easy to find a way to express in a terminating way
  pse-◃-elim : ∀ {Γ x A a b} → (Γ⊢ps : Γ ⊢ps x # A) → a ∈ Γ → b ∈ Γ → Γ++ Γ⊢ps , a ◃ b → Γ , a ◃ b
  pse-◃-elim Γ⊢ps a∈Γ b∈Γ (gen a◃₀b) = gen (strengthen-◃₀ Γ⊢ps a∈Γ b∈Γ a◃₀b)
  pse-◃-elim Γ⊢ps a∈Γ b∈Γ (◃T a◃z z◃₀b) with ◃∈ a◃z
  pse-◃-elim Γ⊢ps a∈Γ b∈Γ (◃T a◃z z◃₀b) | inl (inl z∈Γ) = ◃T (pse-◃-elim Γ⊢ps a∈Γ z∈Γ a◃z) (strengthen-◃₀ Γ⊢ps z∈Γ b∈Γ z◃₀b)
  pse-◃-elim Γ⊢ps a∈Γ b∈Γ (◃T (gen a◃₀l) l◃₀b) | inl (inr idp) with ◃₀-dangling-tgt Γ⊢ps a◃₀l
  ... | inl idp = ⊥-elim (l∉ (psv Γ⊢ps) (n≤Sn _) a∈Γ)
  ... | inr a◃₀x = ◃T (gen (strengthen-◃₀ Γ⊢ps a∈Γ (∈-dangling Γ⊢ps) a◃₀x)) (strengthen-◃₀-dangling Γ⊢ps l◃₀b)
  pse-◃-elim Γ⊢ps a∈Γ b∈Γ (◃T (◃T a◃z z◃₀l) l◃₀b) | inl (inr idp) with ◃₀-dangling-tgt Γ⊢ps z◃₀l
  ... | inr z◃₀x = ◃T (◃T (pse-◃-elim Γ⊢ps a∈Γ (∈-dangling-◃₀ Γ⊢ps z◃₀x) a◃z) (strengthen-dangling-◃₀ Γ⊢ps z◃₀x)) (strengthen-◃₀-dangling Γ⊢ps l◃₀b)
  pse-◃-elim Γ⊢ps a∈Γ b∈Γ (◃T (◃T (gen a◃₀Sl) Sl◃₀l) l◃₀b) | inl (inr idp) | inl idp with ◃₀-dangling Γ⊢ps a◃₀Sl
  ... | idp = gen (strengthen-◃₀-dangling Γ⊢ps l◃₀b)
  pse-◃-elim Γ⊢ps a∈Γ b∈Γ (◃T (◃T (◃T a◃z z◃₀Sl) Sl◃₀l) l◃₀b) | inl (inr idp) | inl idp with ◃₀-dangling Γ⊢ps z◃₀Sl
  ... | idp = ◃T (pse-◃-elim Γ⊢ps a∈Γ (∈-dangling Γ⊢ps) a◃z) (strengthen-◃₀-dangling Γ⊢ps l◃₀b)
  pse-◃-elim Γ⊢ps a∈Γ b∈Γ (◃T a◃z z◃₀b) | inr idp with dangling-◃₀ Γ⊢ps z◃₀b
  ... | idp = ⊥-elim (l∉ (psv Γ⊢ps) (n≤n _) b∈Γ)

  psx-◃-linear← : ∀ {Γ z A} → Γ ⊢ps z # A → (∀ x → x ∈ Γ →  ¬ (Γ , x ◃ x))
  psx-◃-linear← pss .0 (inr idp) x◃x = 𝔻0-◃ 0 x◃x
  psx-◃-linear← (psd Γ⊢psz) x x∈Γ x◃x = psx-◃-linear← Γ⊢psz x x∈Γ x◃x
  psx-◃-linear← (pse Γ⊢psz idp idp idp idp idp) x (inl (inl x∈Γ)) x◃x = psx-◃-linear← Γ⊢psz x x∈Γ (pse-◃-elim Γ⊢psz x∈Γ x∈Γ x◃x)
  psx-◃-linear← Γ+⊢ps@(pse Γ⊢psz idp idp idp idp idp) x (inl (inr idp)) x◃x = ⊥-elim (Sn≰n _ (⟿dim (var (psv Γ+⊢ps) (inl (inr (idp , idp)))) (var (psv Γ+⊢ps) (inl (inr (idp , idp)))) (⊢psx-◃→⟿+ Γ+⊢ps (∂⁺⟿ (psvar Γ+⊢ps)) x◃x)))
  psx-◃-linear← Γ+⊢ps@(pse Γ⊢psz idp idp idp idp idp) x (inr idp) x◃x = ⊥-elim (Sn≰n _ (⟿dim (psvar Γ+⊢ps) (psvar Γ+⊢ps) (⊢psx-◃→⟿ Γ+⊢ps x◃x)))

  ◃-linear : Pre-Ctx → Set₁
  ◃-linear Γ = ∀ x y → x ∈ Γ → y ∈ Γ → (x ≠ y) ↔ ((Γ , x ◃ y) + (Γ , y ◃ x))

  ps-◃-linear : ∀ Γ → Γ ⊢ps → ◃-linear Γ
  fst (ps-◃-linear Γ (ps Γ⊢psz) x y x∈Γ y∈Γ) x≠y with psx-◃-linear→ Γ⊢psz x y x∈Γ y∈Γ
  ... | inl H = H
  ... | inr x=y = ⊥-elim (x≠y x=y)
  snd (ps-◃-linear Γ (ps Γ⊢psz) x .x x∈Γ y∈Γ) (inl x◃x) idp = psx-◃-linear← Γ⊢psz x x∈Γ x◃x
  snd (ps-◃-linear Γ (ps Γ⊢psz) x .x x∈Γ y∈Γ) (inr x◃x) idp = psx-◃-linear← Γ⊢psz x x∈Γ x◃x


open import Relation.Unary using ( ∅ ; _∪_ )
open import Web.Semantic.DL.Concept using ( Concept )
open import Web.Semantic.DL.Role using ( Role )
open import Web.Semantic.DL.Signature using ( Signature )
open import Web.Semantic.Util using ( Subset ; ⁅_⁆ )

module Web.Semantic.DL.TBox where

infixl 5 _⊑₁_ _⊑₂_
infixr 4 _,_

{- a Terminology Box on a Signature (Concept and Role Names)
  is constructed by specifying
   - ε the empty TBox
   - Combination of TBoxes (_,_) - ie. a Union
   - subsumption relations ⊑ between roles and between concepts
   - properties of Roles (Reflexivity, Irreflexivity, Transitivity)
   - disjointness relation between Roles -}
data TBox (Σ : Signature) : Set where
  ε : TBox Σ
  _,_ : (T U : TBox Σ) → TBox Σ
  _⊑₁_ : (C D : Concept Σ) → TBox Σ
  _⊑₂_ : (Q R : Role Σ) → TBox Σ
  Ref : (R : Role Σ) → TBox Σ
  Irr : (R : Role Σ) → TBox Σ
  Tra : (R : Role Σ) → TBox Σ
  Dis : (Q R : Role Σ) → TBox Σ

Axioms : ∀ {Σ} → TBox Σ → Subset (TBox Σ)
Axioms ε         = ∅
Axioms (T , U)   = (Axioms T) ∪ (Axioms U)
Axioms (C ⊑₁ D)  = ⁅ C ⊑₁ D ⁆
Axioms (Q ⊑₂ R)  = ⁅ Q ⊑₂ R ⁆
Axioms (Ref R)   = ⁅ Ref R ⁆
Axioms (Irr R)   = ⁅ Irr R ⁆
Axioms (Tra R)   = ⁅ Tra R ⁆
Axioms (Dis Q R) = ⁅ Dis Q R ⁆


module Categories.Equalizer where


-- Andreas, 2016-06-26, issue #2059 reported by IanOrton

-- An irrelevant parameter in a rewrite rule should still
-- be bound by the lhs.

{-# OPTIONS --rewriting #-}

-- {-# OPTIONS -v tc.pos:10 #-}
-- {-# OPTIONS -v tc.polarity:10 #-}

open import Common.Equality
open import Common.Bool

data ⊥ : Set where

⊥-elim : ∀{a}{A : Set a} → .⊥ → A
⊥-elim ()

_∧_ : (a b : Bool) → Bool
true  ∧ b = b
false ∧ _ = false

obvious : (b b' : Bool) .(p : b ≡ b' → ⊥) → (b ∧ b') ≡ false
obvious false b'    notEq = refl
obvious true  false notEq = refl
obvious true  true  notEq = ⊥-elim (notEq refl)

{-# BUILTIN REWRITE _≡_ #-}
{-# REWRITE obvious   #-}

-- Should give error:

-- obvious  is not a legal rewrite rule,
-- since the following variables are not bound by the left hand side:  p
-- when checking the pragma REWRITE obvious

oops : (b : Bool) → b ∧ b ≡ false
oops b = refl

true≢false : true ≡ false → ⊥
true≢false ()

bot : ⊥
bot = true≢false (oops true)


------------------------------------------------------------------------
-- Functional semantics for an untyped λ-calculus with constants
------------------------------------------------------------------------

{-# OPTIONS --no-termination-check #-}

module Lambda.Closure.Functional.No-workarounds where

open import Category.Monad
open import Category.Monad.Partiality as Partiality
  using (_⊥; never; OtherKind; other; steps)
open import Codata.Musical.Notation
open import Data.Empty using (⊥-elim)
open import Data.List hiding (lookup)
open import Data.Maybe hiding (_>>=_)
import Data.Maybe.Categorical as Maybe
open import Data.Nat
open import Data.Product
open import Data.Sum
open import Data.Vec using (Vec; []; _∷_; lookup)
open import Function
import Level
open import Relation.Binary using (module Preorder)
open import Relation.Binary.PropositionalEquality as P using (_≡_)
open import Relation.Nullary
open import Relation.Nullary.Negation

open Partiality._⊥
private
  open module E {A : Set} = Partiality.Equality (_≡_ {A = A})
  open module R {A : Set} =
    Partiality.Reasoning (P.isEquivalence {A = A})

open import Lambda.Syntax
open Closure Tm
open import Lambda.VirtualMachine
open Functional
private
  module VM = Closure Code

------------------------------------------------------------------------
-- A monad with partiality and failure

PF : RawMonad {f = Level.zero} (_⊥ ∘ Maybe)
PF = Maybe.monadT Partiality.monad

module PF where
  open RawMonad PF public

  fail : {A : Set} → Maybe A ⊥
  fail = now nothing

  _>>=-cong_ :
    ∀ {k} {A B : Set} {x₁ x₂ : Maybe A ⊥} {f₁ f₂ : A → Maybe B ⊥} →
    Rel k x₁ x₂ → (∀ x → Rel k (f₁ x) (f₂ x)) →
    Rel k (x₁ >>= f₁) (x₂ >>= f₂)
  _>>=-cong_ {k} {f₁ = f₁} {f₂} x₁≈x₂ f₁≈f₂ =
    Partiality._>>=-cong_ x₁≈x₂ helper
    where
    helper : ∀ {x y} → x ≡ y →
             Rel k (maybe f₁ fail x) (maybe f₂ fail y)
    helper {x = nothing} P.refl = fail ∎
    helper {x = just x}  P.refl = f₁≈f₂ x

  associative :
    {A B C : Set}
    (x : Maybe A ⊥) (f : A → Maybe B ⊥) (g : B → Maybe C ⊥) →
    (x >>= f >>= g) ≅ (x >>= λ y → f y >>= g)
  associative x f g =
    (x >>= f >>= g)                      ≅⟨ Partiality.associative P.refl x _ _ ⟩
    (x >>=′ λ y → maybe f fail y >>= g)  ≅⟨ Partiality._>>=-cong_ (x ∎) helper ⟩
    (x >>= λ y → f y >>= g)              ∎
    where
    open RawMonad Partiality.monad renaming (_>>=_ to _>>=′_)

    helper : ∀ {y₁ y₂} → y₁ ≡ y₂ →
             (maybe f fail y₁ >>= g) ≅ maybe (λ z → f z >>= g) fail y₂
    helper {y₁ = nothing} P.refl = fail ∎
    helper {y₁ = just y}  P.refl = (f y >>= g) ∎

  >>=-inversion-⇓ :
    ∀ {k} {A B : Set} x {f : A → Maybe B ⊥} {y} →
    (x>>=f⇓ : (x >>= f) ⇓[ k ] just y) →
    ∃ λ z → ∃₂ λ (x⇓ : x ⇓[ k ] just z)
                 (fz⇓ : f z ⇓[ k ] just y) →
                 steps x⇓ + steps fz⇓ ≡ steps x>>=f⇓
  >>=-inversion-⇓ x {f} x>>=f⇓
    with Partiality.>>=-inversion-⇓ {_∼A_ = _≡_} P.refl x x>>=f⇓
  ... | (nothing , x↯ , now ()  , _)
  ... | (just z  , x⇓ , fz⇓     , eq) = (z , x⇓ , fz⇓ , eq)

  >>=-inversion-⇑ :
    ∀ {k} {A B : Set} x {f : A → Maybe B ⊥} →
    (x >>= f) ⇑[ other k ] →
    ¬ ¬ (x ⇑[ other k ] ⊎
         ∃ λ y → x ⇓[ other k ] just y × f y ⇑[ other k ])
  >>=-inversion-⇑ {k} x {f} x>>=f⇑ =
    helper ⟨$⟩ Partiality.>>=-inversion-⇑ P.isEquivalence x x>>=f⇑
    where
    open RawMonad ¬¬-Monad renaming (_<$>_ to _⟨$⟩_)

    helper : (_ ⊎ ∃ λ (y : Maybe _) → _) → _
    helper (inj₁ x⇑                      ) = inj₁ x⇑
    helper (inj₂ (just y  , x⇓,fy⇑)      ) = inj₂ (y , x⇓,fy⇑)
    helper (inj₂ (nothing , x↯,now∼never)) =
      ⊥-elim (Partiality.now≉never (proj₂ x↯,now∼never))

open PF

------------------------------------------------------------------------
-- Semantics

infix 5 _∙_

-- Note that this definition gives us determinism "for free".

mutual

  ⟦_⟧ : ∀ {n} → Tm n → Env n → Maybe Value ⊥
  ⟦ con i ⟧   ρ = return (con i)
  ⟦ var x ⟧   ρ = return (lookup ρ x)
  ⟦ ƛ t ⟧     ρ = return (ƛ t ρ)
  ⟦ t₁ · t₂ ⟧ ρ = ⟦ t₁ ⟧ ρ >>= λ v₁ →
                  ⟦ t₂ ⟧ ρ >>= λ v₂ →
                  v₁ ∙ v₂

  _∙_ : Value → Value → Maybe Value ⊥
  con i  ∙ v₂ = fail
  ƛ t₁ ρ ∙ v₂ = later (♯ (⟦ t₁ ⟧ (v₂ ∷ ρ)))

------------------------------------------------------------------------
-- Example

Ω-loops : ⟦ Ω ⟧ [] ≈ never
Ω-loops = later (♯ Ω-loops)

------------------------------------------------------------------------
-- Some lemmas

-- An abbreviation.

infix 5 _⟦·⟧_

_⟦·⟧_ : Maybe Value ⊥ → Maybe Value ⊥ → Maybe Value ⊥
v₁ ⟦·⟧ v₂ = v₁ >>= λ v₁ → v₂ >>= λ v₂ → v₁ ∙ v₂

-- _⟦·⟧_ preserves equality.

_⟦·⟧-cong_ : ∀ {k v₁₁ v₁₂ v₂₁ v₂₂} →
             Rel k v₁₁ v₂₁ → Rel k v₁₂ v₂₂ →
             Rel k (v₁₁ ⟦·⟧ v₁₂) (v₂₁ ⟦·⟧ v₂₂)
v₁₁≈v₂₁ ⟦·⟧-cong v₁₂≈v₂₂ =
  v₁₁≈v₂₁ >>=-cong λ v₁ →
  v₁₂≈v₂₂ >>=-cong λ v₂ →
  v₁ ∙ v₂ ∎

-- The semantics of application is compositional (with respect to the
-- syntactic equality which is used).

·-comp : ∀ {n} (t₁ t₂ : Tm n) {ρ} →
         ⟦ t₁ · t₂ ⟧ ρ ≅ ⟦ t₁ ⟧ ρ ⟦·⟧ ⟦ t₂ ⟧ ρ
·-comp t₁ t₂ = _ ∎

------------------------------------------------------------------------
-- Compiler correctness

module Correctness where

  -- The relation _≈_ does not admit unrestricted use of transitivity
  -- in corecursive proofs, so I have formulated the correctness proof
  -- using a continuation. Note that the proof would perhaps be easier
  -- if the semantics was also formulated in continuation-passing
  -- style.

  mutual

    correct :
      ∀ {n} t {ρ : Env n} {c s} {k : Value → Maybe VM.Value ⊥} →
      (∀ v → exec ⟨ c , val (comp-val v) ∷ s , comp-env ρ ⟩ ≈ k v) →
      exec ⟨ comp t c , s , comp-env ρ ⟩ ≈ (⟦ t ⟧ ρ >>= k)
    correct (con i) {ρ} {c} {s} {k} hyp = laterˡ (
      exec ⟨ c , val (Lambda.Syntax.Closure.con i) ∷ s , comp-env ρ ⟩  ≈⟨ hyp (con i) ⟩
      k (con i)                                                    ∎)
    correct (var x) {ρ} {c} {s} {k} hyp = laterˡ (
      exec ⟨ c , val (lookup (comp-env ρ) x) ∷ s , comp-env ρ ⟩  ≡⟨ P.cong (λ v → exec ⟨ c , val v ∷ s , comp-env ρ ⟩) (lookup-hom x ρ) ⟩
      exec ⟨ c , val (comp-val (lookup ρ x)) ∷ s , comp-env ρ ⟩  ≈⟨ hyp (lookup ρ x) ⟩
      k (lookup ρ x)                                             ∎)
    correct (ƛ t) {ρ} {c} {s} {k} hyp = laterˡ (
      exec ⟨ c , val (comp-val (ƛ t ρ)) ∷ s , comp-env ρ ⟩  ≈⟨ hyp (ƛ t ρ) ⟩
      k (ƛ t ρ)                                             ∎)
    correct (t₁ · t₂) {ρ} {c} {s} {k} hyp =
      exec ⟨ comp t₁ (comp t₂ (app ∷ c)) , s , comp-env ρ ⟩      ≈⟨ correct t₁ (λ v₁ → correct t₂ (λ v₂ → ∙-correct v₁ v₂ hyp)) ⟩
      (⟦ t₁ ⟧ ρ >>= λ v₁ →  ⟦ t₂ ⟧ ρ >>= λ v₂ → v₁ ∙ v₂  >>= k)  ≅⟨ ((⟦ t₁ ⟧ ρ ∎) >>=-cong λ _ → sym $ associative (⟦ t₂ ⟧ ρ) _ _) ⟩
      (⟦ t₁ ⟧ ρ >>= λ v₁ → (⟦ t₂ ⟧ ρ >>= λ v₂ → v₁ ∙ v₂) >>= k)  ≅⟨ sym $ associative (⟦ t₁ ⟧ ρ) _ _ ⟩
      (⟦ t₁ ⟧ ρ ⟦·⟧ ⟦ t₂ ⟧ ρ >>= k)                              ≅⟨ _ ∎ ⟩
      (⟦ t₁ · t₂ ⟧ ρ >>= k)                                      ∎

    ∙-correct :
      ∀ {n} v₁ v₂ {ρ : Env n} {c s} {k : Value → Maybe VM.Value ⊥} →
      (∀ v → exec ⟨ c , val (comp-val v) ∷ s , comp-env ρ ⟩ ≈ k v) →
      exec ⟨ app ∷ c , val (comp-val v₂) ∷ val (comp-val v₁) ∷ s , comp-env ρ ⟩ ≈
      (v₁ ∙ v₂ >>= k)
    ∙-correct (con i)   v₂                 _   = fail ∎
    ∙-correct (ƛ t₁ ρ₁) v₂ {ρ} {c} {s} {k} hyp =
      exec ⟨ app ∷ c , val (comp-val v₂) ∷ val (comp-val (ƛ t₁ ρ₁)) ∷ s , comp-env ρ ⟩  ≈⟨ later (♯ (

        exec ⟨ comp t₁ [ ret ] , ret c (comp-env ρ) ∷ s , comp-env (v₂ ∷ ρ₁) ⟩               ≈⟨ correct t₁ (λ v → laterˡ (hyp v)) ⟩
        (⟦ t₁ ⟧ (v₂ ∷ ρ₁) >>= k)                                                             ∎)) ⟩

      (ƛ t₁ ρ₁ ∙ v₂ >>= k)                                                              ∎

-- Note that the equality that is used here is syntactic.

correct : ∀ t →
          exec ⟨ comp t [] , [] , [] ⟩ ≈
          (⟦ t ⟧ [] >>= λ v → PF.return (comp-val v))
correct t = Correctness.correct t (λ v → return (comp-val v) ∎)


open import Agda.Primitive public using (lzero)

{-# BUILTIN LEVELZERO lzero #-}


{-

https://github.com/mietek/hilbert-gentzen

An Agda formalisation of IPC, IS4, ICML, and ILP.  Work in progress.

Made by Miëtek Bak.  Published under the MIT X11 license.

-}

module Everything where

import Common
import Common.Context
import Common.ContextPair
import Common.Predicate
import Common.PredicateBasedContext
import Common.Semantics
import Common.UntypedContext

-- Basic intuitionistic propositional calculus, without ∨ or ⊥.

-- Common syntax.
import BasicIPC.Syntax.Common

-- Hilbert-style formalisation of closed syntax.
import BasicIPC.Syntax.ClosedHilbertSequential  -- Sequences of terms.
import BasicIPC.Syntax.ClosedHilbert            -- Nested terms.

-- Hilbert-style formalisation of syntax.
import BasicIPC.Syntax.HilbertSequential        -- Sequences of terms.
import BasicIPC.Syntax.Hilbert                  -- Nested terms.

-- Gentzen-style formalisation of syntax.
import BasicIPC.Syntax.Gentzen                  -- Simple terms.
import BasicIPC.Syntax.GentzenNormalForm        -- Normal forms and neutrals.
import BasicIPC.Syntax.GentzenSpinalNormalForm  -- Normal forms, neutrals, and spines.

-- Translation between different formalisations of syntax.
import BasicIPC.Syntax.Translation

-- Basic Tarski-style semantics, for soundness only.
import BasicIPC.Semantics.BasicTarski

-- Tarski-style semantics with glueing for α and ▻, after Coquand-Dybjer.
import BasicIPC.Semantics.TarskiGluedClosedImplicit    -- Implicit closed syntax.
import BasicIPC.Semantics.TarskiGluedClosedHilbert     -- Hilbert-style closed syntax.

-- Tarski-style semantics with contexts as concrete worlds, and glueing for α and ▻.
import BasicIPC.Semantics.TarskiConcreteGluedImplicit  -- Implicit syntax.
import BasicIPC.Semantics.TarskiConcreteGluedHilbert   -- Hilbert-style syntax.
import BasicIPC.Semantics.TarskiConcreteGluedGentzen   -- Gentzen-style syntax.

-- Kripke-style semantics with contexts as concrete worlds, and glueing for α and ▻.
import BasicIPC.Semantics.KripkeConcreteGluedImplicit  -- Implicit syntax.
import BasicIPC.Semantics.KripkeConcreteGluedHilbert   -- Hilbert-style syntax.
import BasicIPC.Semantics.KripkeConcreteGluedGentzen   -- Gentzen-style syntax.

-- Kripke-style semantics with contexts as concrete worlds.
import BasicIPC.Semantics.KripkeConcrete

-- Kripke-style semantics with abstract worlds.
import BasicIPC.Semantics.KripkeMcKinseyTarski         -- McKinsey-Tarski embedding.
import BasicIPC.Semantics.KripkeGodel                  -- Gödel embedding.

-- Available metatheory for basic IPC.
--
--       ┌─────┬─────┬─────┬─────┬─────┐
--       │ CH  │ H   │ G   │ Gⁿᶠ │ Gˢⁿᶠ│
-- ┌─────┼─────┼─────┼─────┼─────┼─────┤
-- │ BT  │ e₀  │ e   │ e   │     │     │
-- ├─────┼─────┼─────┼─────┼─────┼─────┤
-- │ TGCI│ e₀q₀│ eq₀ │ eq₀ │     │     │
-- ├─────┼─────┼─────┼─────┼─────┼─────┤
-- │ TGCH│ e₀q₀│ eq₀ │     │     │     │
-- ├─────┼─────┼─────┼─────┼─────┼─────┤
-- │ TCGI│     │ eq  │ eq  │     │     │
-- ├─────┼─────┼─────┼─────┼─────┼─────┤
-- │ TCGH│     │ eq  │ eq  │     │     │
-- ├─────┼─────┼─────┼─────┼─────┼─────┤
-- │ TCGG│     │ eq  │ eq  │     │     │
-- ├─────┼─────┼─────┼─────┼─────┼─────┤
-- │ KCGI│     │ eq  │ eq  │     │     │
-- ├─────┼─────┼─────┼─────┼─────┼─────┤
-- │ KCGH│     │ eq  │ eq  │     │     │
-- ├─────┼─────┼─────┼─────┼─────┼─────┤
-- │ KCGG│     │ eq  │ eq  │     │     │
-- ├─────┼─────┼─────┼─────┼─────┼─────┤
-- │ KC  │     │ eq  │ eq  │ eq  │     │
-- ├─────┼─────┼─────┼─────┼─────┼─────┤
-- │ KMT │     │ eq  │ eq  │ eq  │     │
-- ├─────┼─────┼─────┼─────┼─────┼─────┤
-- │ KG  │     │ eq  │ eq  │ eq  │     │
-- ├─────┼─────┼─────┼─────┼─────┼─────┤
-- │ HS  │     │     │     │     │ n   │
-- └─────┴─────┴─────┴─────┴─────┴─────┘
--
-- e₀   : Soundness only, for closed terms only.
-- e₀q₀ : Soundness and completeness, for closed terms only.
-- e    : Soundness only.
-- eq₀  : Soundness, for all terms; completeness, for closed terms only.
-- eq   : Soundness and completeness, or normalisation by evaluation.
-- n    : Normalisation by other means.

import BasicIPC.Metatheory.ClosedHilbert-BasicTarski
import BasicIPC.Metatheory.ClosedHilbert-TarskiGluedClosedImplicit
import BasicIPC.Metatheory.ClosedHilbert-TarskiGluedClosedHilbert

import BasicIPC.Metatheory.Hilbert-BasicTarski
import BasicIPC.Metatheory.Hilbert-TarskiGluedClosedImplicit
import BasicIPC.Metatheory.Hilbert-TarskiGluedClosedHilbert
import BasicIPC.Metatheory.Hilbert-TarskiConcreteGluedImplicit
import BasicIPC.Metatheory.Hilbert-TarskiConcreteGluedHilbert
import BasicIPC.Metatheory.Hilbert-TarskiConcreteGluedGentzen
import BasicIPC.Metatheory.Hilbert-KripkeConcreteGluedImplicit
import BasicIPC.Metatheory.Hilbert-KripkeConcreteGluedHilbert
import BasicIPC.Metatheory.Hilbert-KripkeConcreteGluedGentzen
import BasicIPC.Metatheory.Hilbert-KripkeConcrete
import BasicIPC.Metatheory.Hilbert-KripkeMcKinseyTarski
import BasicIPC.Metatheory.Hilbert-KripkeGodel

import BasicIPC.Metatheory.Gentzen-BasicTarski
import BasicIPC.Metatheory.Gentzen-TarskiGluedClosedImplicit
import BasicIPC.Metatheory.Gentzen-TarskiConcreteGluedImplicit
import BasicIPC.Metatheory.Gentzen-TarskiConcreteGluedHilbert
import BasicIPC.Metatheory.Gentzen-TarskiConcreteGluedGentzen
import BasicIPC.Metatheory.Gentzen-KripkeConcreteGluedImplicit
import BasicIPC.Metatheory.Gentzen-KripkeConcreteGluedHilbert
import BasicIPC.Metatheory.Gentzen-KripkeConcreteGluedGentzen
import BasicIPC.Metatheory.Gentzen-KripkeConcrete
import BasicIPC.Metatheory.Gentzen-KripkeMcKinseyTarski
import BasicIPC.Metatheory.Gentzen-KripkeGodel

import BasicIPC.Metatheory.GentzenNormalForm-KripkeConcrete
import BasicIPC.Metatheory.GentzenNormalForm-KripkeMcKinseyTarski
import BasicIPC.Metatheory.GentzenNormalForm-KripkeGodel

import BasicIPC.Metatheory.GentzenSpinalNormalForm-HereditarySubstitution

-- TODO

-- Common syntax.
import BasicT.Syntax.Common

-- Gentzen-style formalisation of syntax.
import BasicT.Syntax.Gentzen
import BasicT.Syntax.GentzenNormalForm

-- Basic Tarski-style semantics, for soundness only.
import BasicT.Semantics.BasicTarski

-- Available metatheory.

import BasicT.Metatheory.Gentzen-BasicTarski

import BasicT.Metatheory.GentzenNormalForm-Unknown

-- Intuitionistic propositional calculus.

-- Common syntax.
import IPC.Syntax.Common

-- Hilbert-style formalisation of closed syntax.
import IPC.Syntax.ClosedHilbertSequential  -- Sequences of terms.
import IPC.Syntax.ClosedHilbert            -- Nested terms.

-- Hilbert-style formalisation of syntax.
import IPC.Syntax.HilbertSequential        -- Sequences of terms.
import IPC.Syntax.Hilbert                  -- Nested terms.

-- Gentzen-style formalisation of syntax.
import IPC.Syntax.Gentzen                  -- Simple terms.
import IPC.Syntax.GentzenNormalForm        -- Normal forms and neutrals.
import IPC.Syntax.GentzenSpinalNormalForm  -- Normal forms, neutrals, and spines.

-- Translation between different formalisations of syntax.
import IPC.Syntax.Translation

-- Basic Tarski-style semantics, for soundness only.
import IPC.Semantics.BasicTarski

-- Kripke-style semantics with exploding abstract worlds.
import IPC.Semantics.KripkeExploding

-- Available metatheory for IPC.
--
--       ┌─────┬─────┬─────┬─────┬─────┐
--       │ CH  │ H   │ G   │ Gⁿᶠ │ Gˢⁿᶠ│
-- ┌─────┼─────┼─────┼─────┼─────┼─────┤
-- │ BT  │ e₀  │ e   │ e   │     │     │
-- ├─────┼─────┼─────┼─────┼─────┼─────┤
-- │ KE  │     │     │ eq  │ eq  │     │
-- ├─────┼─────┼─────┼─────┼─────┼─────┤
-- │ HS  │     │     │     │     │ n   │
-- └─────┴─────┴─────┴─────┴─────┴─────┘
--
-- e₀   : Soundness only, for closed terms only.
-- e₀q₀ : Soundness and completeness, for closed terms only.
-- e    : Soundness only.
-- eq₀  : Soundness, for all terms; completeness, for closed terms only.
-- eq   : Soundness and completeness, or normalisation by evaluation.
-- n    : Normalisation by other means.

import IPC.Metatheory.ClosedHilbert-BasicTarski

import IPC.Metatheory.Hilbert-BasicTarski

import IPC.Metatheory.Gentzen-BasicTarski
import IPC.Metatheory.Gentzen-KripkeExploding

import IPC.Metatheory.GentzenNormalForm-KripkeExploding

import IPC.Metatheory.GentzenSpinalNormalForm-HereditarySubstitution

-- Basic intuitionistic modal logic S4, without ∨, ⊥, or ◇.

-- Common syntax.
import BasicIS4.Syntax.Common

-- Hilbert-style formalisation of closed syntax.
import BasicIS4.Syntax.ClosedHilbertSequential        -- Sequences of terms.
import BasicIS4.Syntax.ClosedHilbert                  -- Nested terms.

-- Hilbert-style formalisation of syntax.
import BasicIS4.Syntax.HilbertSequential              -- Sequences of terms.
import BasicIS4.Syntax.Hilbert                        -- Nested terms.

-- Gentzen-style formalisation of syntax, after Bierman-de Paiva.
import BasicIS4.Syntax.Gentzen

-- Hilbert-style formalisation of syntax with context pairs.
import BasicIS4.Syntax.DyadicHilbertSequential        -- Sequences of terms.
import BasicIS4.Syntax.DyadicHilbert                  -- Nested terms.

-- Gentzen-style formalisation of syntax with context pairs, after Pfenning-Davies.
import BasicIS4.Syntax.DyadicGentzen                  -- Simple terms.
import BasicIS4.Syntax.DyadicGentzenNormalForm        -- Normal forms and neutrals.
import BasicIS4.Syntax.DyadicGentzenSpinalNormalForm  -- Normal forms, neutrals, and spines.

-- Gentzen-style formalisation of labelled syntax, after Basin-Matthews-Viganò.
import BasicIS4.Syntax.LabelledGentzen

-- Translation between different formalisations of syntax.
import BasicIS4.Syntax.Translation

-- Basic Kripke-style semantics with abstract worlds, for soundness only.
import BasicIS4.Semantics.BasicKripkeOno                 -- Ono-style conditions.
import BasicIS4.Semantics.BasicKripkeBozicDosen          -- Božić-Došen-style conditions.
import BasicIS4.Semantics.BasicKripkeEwald               -- Ewald-style conditions.
import BasicIS4.Semantics.BasicKripkeAlechina            -- Alechina-style conditions.

-- Tarski-style semantics with glueing for α, ▻, and □, after Gabbay-Nanevski.
import BasicIS4.Semantics.TarskiClosedOvergluedImplicit  -- Implicit closed syntax.
import BasicIS4.Semantics.TarskiClosedOvergluedHilbert   -- Hilbert-style closed syntax.

-- Tarski-style semantics with contexts as concrete worlds, and glueing for α, ▻, and □.
import BasicIS4.Semantics.TarskiOvergluedImplicit        -- Implicit syntax.
import BasicIS4.Semantics.TarskiOvergluedHilbert         -- Hilbert-style syntax.
import BasicIS4.Semantics.TarskiOvergluedGentzen         -- Gentzen-style syntax.

-- Tarski-style semantics with contexts as concrete worlds, and glueing for □ only.
import BasicIS4.Semantics.TarskiGluedImplicit            -- Implicit syntax.
import BasicIS4.Semantics.TarskiGluedHilbert             -- Hilbert-style syntax.
import BasicIS4.Semantics.TarskiGluedGentzen             -- Gentzen-style syntax.

-- Tarski-style semantics with context pairs as concrete worlds, and glueing for α, ▻, and □.
import BasicIS4.Semantics.TarskiOvergluedDyadicImplicit  -- Implicit syntax.
import BasicIS4.Semantics.TarskiOvergluedDyadicHilbert   -- Hilbert-style syntax.
import BasicIS4.Semantics.TarskiOvergluedDyadicGentzen   -- Gentzen-style syntax.

-- Tarski-style semantics with context pairs as concrete worlds, and glueing for □ only.
import BasicIS4.Semantics.TarskiGluedDyadicImplicit      -- Implicit syntax.

-- TODO
import BasicIS4.Semantics.TarskiGluedDyadicHilbert       -- Hilbert-style syntax.

import BasicIS4.Semantics.TarskiGluedDyadicGentzen       -- Gentzen-style syntax.

-- Canonical model equipment for Kripke-style semantics with contexts as concrete worlds.
import BasicIS4.Equipment.KripkeCanonical
import BasicIS4.Equipment.KripkeNonCanonical

-- Canonical model equipment for Kripke-style semantics with context pairs as concrete worlds.
import BasicIS4.Equipment.KripkeDyadicCanonical
import BasicIS4.Equipment.KripkeDyadicNonCanonical

-- Available metatheory for basic IS4.
--
--       ┌─────┬─────┬─────┬─────┬─────┐
--       │ CH  │ H   │ G   │ DH  │ DG  │
-- ┌─────┼─────┼─────┼─────┼─────┼─────┤
-- │ BKO │     │ e   │ e   │ e   │ e   │
-- ├─────┼─────┼─────┼─────┼─────┼─────┤
-- │ BKBD│     │ e   │ e   │ e   │ e   │
-- ├─────┼─────┼─────┼─────┼─────┼─────┤
-- │ BKE │     │ e   │ e   │ e   │ e   │
-- ├─────┼─────┼─────┼─────┼─────┼─────┤
-- │ BKA&│     │ e   │ e   │ e   │ e   │
-- ├─────┼─────┼─────┼─────┼─────┼─────┤
-- │ TCOI│ e₀q₀│ eq₀ │ eq₀ │     │     │
-- ├─────┼─────┼─────┼─────┼─────┼─────┤
-- │ TCOH│ e₀q₀│ eq₀ │     │     │     │
-- ├─────┼─────┼─────┼─────┼─────┼─────┤
-- │ TOI │     │ eq  │ eq  │     │     │
-- ├─────┼─────┼─────┼─────┼─────┼─────┤
-- │ TOH │     │ eq  │     │     │     │
-- ├─────┼─────┼─────┼─────┼─────┼─────┤
-- │ TOG │     │ eq  │ eq  │     │     │
-- ├─────┼─────┼─────┼─────┼─────┼─────┤
-- │ TGI │     │ eq  │ WIP │     │     │
-- ├─────┼─────┼─────┼─────┼─────┼─────┤
-- │ TGH │     │ eq  │     │     │     │
-- ├─────┼─────┼─────┼─────┼─────┼─────┤
-- │ TGG │     │     │ WIP │     │     │
-- ├─────┼─────┼─────┼─────┼─────┼─────┤
-- │ TODI│     │     │     │ eq  │ eq  │
-- ├─────┼─────┼─────┼─────┼─────┼─────┤
-- │ TODH│     │     │     │ eq  │     │
-- ├─────┼─────┼─────┼─────┼─────┼─────┤
-- │ TODG│     │     │     │ eq  │ eq  │
-- ├─────┼─────┼─────┼─────┼─────┼─────┤
-- │ TGDI│     │     │     │ WIP │ WIP │
-- ├─────┼─────┼─────┼─────┼─────┼─────┤
-- │ TGDH│     │     │     │ WIP │     │
-- ├─────┼─────┼─────┼─────┼─────┼─────┤
-- │ TGDG│     │     │     │     │ WIP │
-- └─────┴─────┴─────┴─────┴─────┴─────┘
--
-- e₀   : Soundness only, for closed terms only.
-- e₀q₀ : Soundness and completeness, for closed terms only.
-- e    : Soundness only.
-- eq₀  : Soundness, for all terms; completeness, for closed terms only.
-- eq   : Soundness and completeness, or normalisation by evaluation.
-- WIP  : Work in progress.

import BasicIS4.Metatheory.ClosedHilbert-TarskiClosedOvergluedImplicit
import BasicIS4.Metatheory.ClosedHilbert-TarskiClosedOvergluedHilbert

import BasicIS4.Metatheory.Hilbert-BasicKripkeOno
import BasicIS4.Metatheory.Hilbert-BasicKripkeBozicDosen
import BasicIS4.Metatheory.Hilbert-BasicKripkeEwald
import BasicIS4.Metatheory.Hilbert-BasicKripkeAlechina
import BasicIS4.Metatheory.Hilbert-TarskiClosedOvergluedImplicit
import BasicIS4.Metatheory.Hilbert-TarskiClosedOvergluedHilbert
import BasicIS4.Metatheory.Hilbert-TarskiOvergluedImplicit
import BasicIS4.Metatheory.Hilbert-TarskiOvergluedHilbert
import BasicIS4.Metatheory.Hilbert-TarskiOvergluedGentzen
import BasicIS4.Metatheory.Hilbert-TarskiGluedImplicit
import BasicIS4.Metatheory.Hilbert-TarskiGluedHilbert

import BasicIS4.Metatheory.Gentzen-BasicKripkeOno
import BasicIS4.Metatheory.Gentzen-BasicKripkeBozicDosen
import BasicIS4.Metatheory.Gentzen-BasicKripkeEwald
import BasicIS4.Metatheory.Gentzen-BasicKripkeAlechina
import BasicIS4.Metatheory.Gentzen-TarskiClosedOvergluedImplicit
import BasicIS4.Metatheory.Gentzen-TarskiOvergluedImplicit
import BasicIS4.Metatheory.Gentzen-TarskiOvergluedGentzen
import BasicIS4.Metatheory.Gentzen-TarskiGluedImplicit -- FIXME
import BasicIS4.Metatheory.Gentzen-TarskiGluedGentzen -- FIXME

import BasicIS4.Metatheory.DyadicHilbert-BasicKripkeOno
import BasicIS4.Metatheory.DyadicHilbert-BasicKripkeBozicDosen
import BasicIS4.Metatheory.DyadicHilbert-BasicKripkeEwald
import BasicIS4.Metatheory.DyadicHilbert-BasicKripkeAlechina
import BasicIS4.Metatheory.DyadicHilbert-TarskiOvergluedDyadicImplicit
import BasicIS4.Metatheory.DyadicHilbert-TarskiOvergluedDyadicHilbert
import BasicIS4.Metatheory.DyadicHilbert-TarskiOvergluedDyadicGentzen
import BasicIS4.Metatheory.DyadicHilbert-TarskiGluedDyadicImplicit -- FIXME
import BasicIS4.Metatheory.DyadicHilbert-TarskiGluedDyadicHilbert

import BasicIS4.Metatheory.DyadicGentzen-BasicKripkeOno
import BasicIS4.Metatheory.DyadicGentzen-BasicKripkeBozicDosen
import BasicIS4.Metatheory.DyadicGentzen-BasicKripkeEwald
import BasicIS4.Metatheory.DyadicGentzen-BasicKripkeAlechina
import BasicIS4.Metatheory.DyadicGentzen-TarskiOvergluedDyadicImplicit
import BasicIS4.Metatheory.DyadicGentzen-TarskiOvergluedDyadicGentzen
import BasicIS4.Metatheory.DyadicGentzen-TarskiGluedDyadicImplicit -- FIXME
import BasicIS4.Metatheory.DyadicGentzen-TarskiGluedDyadicGentzen -- FIXME

import BasicIS4.Metatheory.DyadicGentzenSpinalNormalForm-HereditarySubstitution

-- Basic intuitionistic contextual modal logic, without ∨ or ⊥.

-- Common syntax.
import BasicICML.Syntax.Common

-- Gentzen-style formalisation of syntax with context pairs, after Nanevski-Pfenning-Pientka.
import BasicICML.Syntax.DyadicGentzen
import BasicICML.Syntax.DyadicGentzenNormalForm
import BasicICML.Syntax.DyadicGentzenSpinalNormalForm

-- Available metatheory for basic ICML.
import BasicICML.Metatheory.DyadicGentzenSpinalNormalForm-HereditarySubstitution

-- Basic intuitionistic logic of proofs, without ∨, ⊥, or +.

-- Common syntax.
import BasicILP.Syntax.Common

-- Gentzen-style formalisation of syntax with context pairs.
import BasicILP.Syntax.DyadicGentzen
import BasicILP.Syntax.DyadicGentzenNormalForm

-- (To be rewritten.)

-- Common syntax, with types parametrised by a closed, untyped representation of syntax.
import OldBasicILP.UntypedSyntax.Common

-- Hilbert-style formalisation of closed syntax.
import OldBasicILP.UntypedSyntax.ClosedHilbertSequential  -- Sequences of terms.
import OldBasicILP.UntypedSyntax.ClosedHilbert            -- Nested terms.

-- Translation between different formalisations of syntax.
import OldBasicILP.UntypedSyntax.Translation -- FIXME

-- Common syntax, with types parametrised by closed syntax.
import OldBasicILP.Syntax.Common

-- Hilbert-style formalisation of closed syntax.
import OldBasicILP.Syntax.ClosedHilbertSequential  -- Sequences of terms.
import OldBasicILP.Syntax.ClosedHilbert            -- Nested terms.

-- Translation between different formalisations of syntax.
import OldBasicILP.Syntax.Translation -- FIXME
-- import OldBasicILP.Syntax.Projection -- FIXME

-- (To be rewritten.)

import OlderBasicILP.Indirect
import OlderBasicILP.Indirect.Hilbert.Sequential
import OlderBasicILP.Indirect.Hilbert.Nested
import OlderBasicILP.Indirect.Gentzen
-- import OlderBasicILP.Indirect.Translation
import OlderBasicILP.Direct.Hilbert.Nested
import OlderBasicILP.Direct.Gentzen
-- import OlderBasicILP.Direct.Translation


module Productivity (char : Set) where

  open import Common.Coinduction

  infix  50 _⋆ _+
  infixl 40 _⊛_
  infixl 30 _∣_

  data P : Set where
    ε   : P
    sym : char -> P
    _⊛_ : ∞ P -> ∞ P -> P
    _∣_ : ∞ P -> ∞ P -> P

  mutual

    _⋆ : P -> P
    p ⋆ = ♯ ε ∣ ♯ (p +)

    _+ : P -> P
    p + = ♯ p ⊛ ♯ (p ⋆)

  _sepBy_ : P -> P -> P
  p sepBy sep = ♯ p ⊛ ♯ ((♯ sep ⊛ ♯ p) ⋆)

  postulate
    addOp  : P
    mulOp  : P
    number : P
    openP  : char
    closeP : char

  -- Not guarded:

  mutual
    expr   = term sepBy addOp
    term   = factor sepBy mulOp
    factor = ♯ number ∣ ♯ (♯ (♯ sym openP ⊛ ♯ expr) ⊛ ♯ sym closeP)

  -- Guarded and incomprehensible:

  mutual
    expr₁ = ♯ term₁ ⊛ ♯ expr₂
    expr₂ = ♯ ε ∣ ♯ expr₃
    expr₃ = ♯ (♯ addOp ⊛ ♯ term₁) ⊛ ♯ expr₂

    term₁ = ♯ factor₁ ⊛ ♯ term₂
    term₂ = ♯ ε ∣ ♯ term₃
    term₃ = ♯ (♯ mulOp ⊛ ♯ factor₁) ⊛ ♯ term₂

    factor₁ = ♯ number ∣ ♯ (♯ (♯ sym openP ⊛ ♯ expr₁) ⊛ ♯ sym closeP)


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

open import HoTT
open import cohomology.CofiberSequence
open import cohomology.Exactness
open import cohomology.ExactPairIso
open import cohomology.FunctionOver
open import cohomology.MayerVietoris
open import cohomology.SplitExactRight
open import cohomology.Theory

module cohomology.Coproduct {i} (OT : OrdinaryTheory i) where

open OrdinaryTheory OT
open import cohomology.ConstantFunction cohomology-theory
open import cohomology.Functor cohomology-theory
open import cohomology.Sn OT

{- Cⁿ(X ⊔ Y) == Cⁿ(X ∨ Y) × Cⁿ(S⁰). The proof is by constructing a
 - splitting exact sequence

         0 → Cⁿ(X ∨ Y) → Cⁿ(X ⊔ Y) → C(S⁰)

 - by defining a map [select : S⁰ → X ⊔ Y] such that
   [Cofiber select == X ∨ Y] and [select] has a left inverse. -}

module CofSelect (X Y : Ptd i) where

  select : Sphere {i} 0 → fst (X ⊙⊔ Y)
  select (lift true) = inl (snd X)
  select (lift false) = inr (snd Y)

  ⊙select : fst (⊙Sphere {i} 0 ⊙→ X ⊙⊔ Y)
  ⊙select = (select , idp)

  module Into = CofiberRec select {C = X ∨ Y}
    (winl (snd X))
    add-wglue
    (λ {(lift true) → idp; (lift false) → wglue})

  module Out = WedgeRec {X = X} {Y = Y} {C = Cofiber select}
    (λ x → cfcod _ (inl x))
    (λ y → cfcod _ (inr y))
    (! (cfglue _ (lift true)) ∙ cfglue _ (lift false))

  into = Into.f
  out = Out.f

  into-out : ∀ w → into (out w) == w
  into-out = Wedge-elim
    (λ x → idp)
    (λ y → idp)
    (↓-∘=idf-in into out $
      ap into (ap out wglue)
        =⟨ ap (ap into) Out.glue-β ⟩
      ap into (! (cfglue _ (lift true)) ∙ cfglue _ (lift false))
        =⟨ ap-∙ into (! (cfglue _ (lift true))) (cfglue _ (lift false)) ⟩
      ap into (! (cfglue _ (lift true))) ∙ ap into (cfglue _ (lift false))
        =⟨ ap-! into (cfglue _ (lift true)) ∙ ap ! (Into.glue-β (lift true))
           |in-ctx (λ w → w ∙ ap into (cfglue _ (lift false))) ⟩
      ap into (cfglue _ (lift false))
        =⟨ Into.glue-β (lift false) ⟩
      wglue ∎)

  out-into : ∀ κ → out (into κ) == κ
  out-into = Cofiber-elim _
    (! (cfglue _ (lift true)))
    (λ {(inl x) → idp; (inr y) → idp})
    (λ {(lift true) → ↓-∘=idf-from-square out into $
          ap (ap out) (Into.glue-β (lift true)) ∙v⊡ bl-square _;
        (lift false) → ↓-∘=idf-from-square out into $
          (ap (ap out) (Into.glue-β (lift false)) ∙ Out.glue-β)
          ∙v⊡ lt-square (! (cfglue _ (lift true))) ⊡h vid-square})

  eq : Cofiber select ≃ X ∨ Y
  eq = equiv into out into-out out-into

  ⊙path : ⊙Cof ⊙select == X ⊙∨ Y
  ⊙path = ⊙ua eq idp

  cfcod-over : ⊙cfcod ⊙select == ⊙add-wglue
               [ (λ U → fst (X ⊙⊔ Y ⊙→ U)) ↓ ⊙path ]
  cfcod-over = codomain-over-⊙equiv _ _ _ ▹ pair= idp lemma
    where
    lemma : ap into (! (cfglue _ (lift true))) ∙ idp == idp
    lemma = ∙-unit-r _ ∙ ap-! into (cfglue _ (lift true))
            ∙ ap ! (Into.glue-β (lift true))

  ext-glue-cst :
    ⊙ext-glue == ⊙cst {X = ⊙Cof ⊙select} {Y = ⊙Sphere 1}
  ext-glue-cst = ⊙λ=
    (Cofiber-elim _
      idp
      (λ {(inl _) → ! (merid _ (lift true));
          (inr _) → ! (merid _ (lift false))})
      (λ {(lift true) → ↓-='-from-square $
            ExtGlue.glue-β (lift true)
            ∙v⊡ tr-square (merid _ (lift true))
            ⊡v∙ ! (ap-cst (north _) (glue (lift true)));
          (lift false) → ↓-='-from-square $
            ExtGlue.glue-β (lift false)
            ∙v⊡ tr-square (merid _ (lift false))
            ⊡v∙ ! (ap-cst (north _) (glue (lift false)))}))
    idp

  ext-over : ⊙ext-glue == ⊙cst
             [ (λ U → fst (U ⊙→ ⊙Sphere 1)) ↓ ⊙path ]
  ext-over = ext-glue-cst ◃ domain-over-⊙equiv _ _ _

module C⊔ (n : ℤ) (m : ℕ) (X Y : Ptd i) where

  open CofSelect X Y

  ed : {G : Group i} (φ : GroupHom (C n (⊙Susp^ m (X ⊙⊔ Y))) G)
    → ExactDiag _ _
  ed {G} φ =
    C n (⊙Susp^ m (⊙Sphere 1))
      ⟨ cst-hom ⟩→
    C n (⊙Susp^ m (X ⊙∨ Y))
      ⟨ CF-hom n (⊙susp^-fmap m ⊙add-wglue) ⟩→
    C n (⊙Susp^ m (X ⊙⊔ Y))
      ⟨ φ ⟩→ -- CF-hom n (⊙susp^-fmap m ⊙select)
    G ⊣| -- C n (⊙Susp^ m (⊙Sphere 0))

  es : ExactSeq (ed (CF-hom n (⊙susp^-fmap m ⊙select)))
  es = exact-build (ed (CF-hom n (⊙susp^-fmap m ⊙select)))
    (transport
      (λ g → is-exact g (CF n (⊙susp^-fmap m ⊙add-wglue)))
      (ap (CF n) (⊙susp^-fmap-cst m) ∙ ap GroupHom.⊙f (CF-cst n))
      (transport
        (λ {(_ , g , h) → is-exact (CF n (⊙susp^-fmap m h))
                                   (CF n (⊙susp^-fmap m g))})
        (pair= ⊙path (↓-×-in cfcod-over ext-over))
        (transport
          (λ {(_ , g , h) → is-exact (CF n h) (CF n g)})
          (suspend^-cof= m (⊙cfcod ⊙select) (⊙ext-glue)
            (pair= (Cof².space-path ⊙select) (Cof².cfcod²-over ⊙select)))
          (C-exact n (⊙susp^-fmap m (⊙cfcod ⊙select))))))
    (transport
      (λ {(_ , g) → is-exact (CF n (⊙susp^-fmap m g))
                             (CF n (⊙susp^-fmap m ⊙select))})
      (pair= ⊙path cfcod-over)
      (transport
        (λ {(_ , g , h) → is-exact (CF n h) (CF n g)})
        (suspend^-cof= m ⊙select _ idp)
        (C-exact n (⊙susp^-fmap m ⊙select))))

  module Nonzero (neq : n ≠ ℕ-to-ℤ m) where

    iso : C n (⊙Susp^ m (X ⊙∨ Y)) == C n (⊙Susp^ m (X ⊙⊔ Y))
    iso = exact-pair-iso $
      transport (λ {(G , φ) → ExactSeq (ed {G} φ)})
        (pair= (ap (C n) (⊙Susp^-+ m O
                          ∙ ap (λ k → ⊙Susp^ k (⊙Sphere 0)) (+-unit-r m))
                ∙ C-Sphere-≠ n m neq)
               (prop-has-all-paths-↓
                  {B = λ G → GroupHom (C n (⊙Susp^ m (X ⊙⊔ Y))) G}
                  (contr-is-prop 0ᴳ-hom-in-level)))
        es

    add-wglue-over :
      idhom _ == CF-hom n (⊙susp^-fmap m ⊙add-wglue)
      [ (λ G → GroupHom (C n (⊙Susp^ m (X ⊙∨ Y))) G) ↓ iso ]
    add-wglue-over = codomain-over-iso _ _ _ _ $ codomain-over-equiv _ _

  module Any where

    deselect : fst (X ⊙⊔ Y) → Sphere {i} 0
    deselect (inl _) = lift true
    deselect (inr _) = lift false

    ⊙deselect : fst (X ⊙⊔ Y ⊙→ ⊙Sphere {i} 0)
    ⊙deselect = (deselect , idp)

    deselect-select : ⊙deselect ⊙∘ ⊙select == ⊙idf _
    deselect-select = ⊙λ= (λ {(lift true) → idp; (lift false) → idp}) idp

    module SER = SplitExactRight (C-abelian n _)
      (CF-hom n (⊙susp^-fmap m ⊙add-wglue))
      (CF-hom n (⊙susp^-fmap m ⊙select))
      es
      (CF-hom n (⊙susp^-fmap m ⊙deselect))
      (app= $ ap GroupHom.f $ CF-inverse n
        (⊙susp^-fmap m ⊙select)
        (⊙susp^-fmap m ⊙deselect)
        (! (⊙susp^-fmap-∘ m ⊙deselect ⊙select)
         ∙ ap (⊙susp^-fmap m) deselect-select
         ∙ ⊙susp^-fmap-idf m _))

    iso : C n (⊙Susp^ m (X ⊙⊔ Y))
       == C n (⊙Susp^ m (X ⊙∨ Y)) ×ᴳ C n (⊙Susp^ m (⊙Sphere 0))
    iso = SER.iso

    add-wglue-over :
      CF-hom n (⊙susp^-fmap m ⊙add-wglue) == ×ᴳ-inl
      [ (λ G → GroupHom (C n (⊙Susp^ m (X ⊙∨ Y))) G) ↓ iso ]
    add-wglue-over = SER.φ-over-iso


------------------------------------------------------------------------
-- The Agda standard library
--
-- Simple combinators working solely on and with functions
------------------------------------------------------------------------

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

module Function where

open import Level
open import Strict

infixr 9 _∘_ _∘′_
infixl 8 _ˢ_
infixl 1 _on_
infixl 1 _⟨_⟩_
infixr -1 _$_ _$′_ _$!_ _$!′_
infixr 0 _-[_]-_
infixl 0 _|>_ _|>′_ _∋_

------------------------------------------------------------------------
-- Types

-- Unary functions on a given set.

Fun₁ : ∀ {i} → Set i → Set i
Fun₁ A = A → A

-- Binary functions on a given set.

Fun₂ : ∀ {i} → Set i → Set i
Fun₂ A = A → A → A

------------------------------------------------------------------------
-- Functions

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

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

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

const : ∀ {a b} {A : Set a} {B : Set b} → A → B → A
const x = λ _ → x

-- The S combinator. (Written infix as in Conor McBride's paper
-- "Outrageous but Meaningful Coincidences: Dependent type-safe syntax
-- and evaluation".)

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

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

-- Note that _$_ is right associative, like in Haskell. If you want a
-- left associative infix application operator, use
-- Category.Functor._<$>_, available from
-- Category.Monad.Identity.IdentityMonad.

_$_ : ∀ {a b} {A : Set a} {B : A → Set b} →
      ((x : A) → B x) → ((x : A) → B x)
f $ x = f x

_$′_ : ∀ {a b} {A : Set a} {B : Set b} →
       (A → B) → (A → B)
_$′_ = _$_

-- Strict (call-by-value) application

_$!_ : ∀ {a b} {A : Set a} {B : A → Set b} →
       ((x : A) → B x) → ((x : A) → B x)
_$!_ = flip force

_$!′_ : ∀ {a b} {A : Set a} {B : Set b} →
        (A → B) → (A → B)
_$!′_ = _$!_

-- flipped application aka pipe-forward

_|>_ : ∀ {a b} {A : Set a} {B : A → Set b} →
       (a : A) → (∀ a → B a) → B a
_|>_ = flip _$_

_|>′_ : ∀ {a b} {A : Set a} {B : Set b} →
        A → (A → B) → B
_|>′_ = _|>_

_⟨_⟩_ : ∀ {a b c} {A : Set a} {B : Set b} {C : Set c} →
        A → (A → B → C) → B → C
x ⟨ f ⟩ y = f x y

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

_-[_]-_ : ∀ {a b c d e} {A : Set a} {B : Set b} {C : Set c}
            {D : Set d} {E : Set e} →
          (A → B → C) → (C → D → E) → (A → B → D) → (A → B → E)
f -[ _*_ ]- g = λ x y → f x y * g x y

-- In Agda you cannot annotate every subexpression with a type
-- signature. This function can be used instead.

_∋_ : ∀ {a} (A : Set a) → A → A
A ∋ x = x

-- Conversely it is sometimes useful to be able to extract the
-- type of a given expression:

typeOf : ∀ {a} {A : Set a} → A → Set a
typeOf {A = A} _ = A

-- Case expressions (to be used with pattern-matching lambdas, see
-- README.Case).

infix 0 case_return_of_ case_of_

case_return_of_ :
  ∀ {a b} {A : Set a}
  (x : A) (B : A → Set b) → ((x : A) → B x) → B x
case x return B of f = f x

case_of_ : ∀ {a b} {A : Set a} {B : Set b} → A → (A → B) → B
case x of f = case x return _ of f


module Categories.Coequalizer where


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

open import HoTT

{-
Various lemmas that will be used in cohomology.DisjointlyPointedSet.
Many of them, for example the choice lemma about coproducts, should be
put into core/.
-}

module homotopy.DisjointlyPointedSet where

module _ {i} where

  is-separable : (X : Ptd i) → Type i
  is-separable X = has-dec-onesided-eq (pt X)

  abstract
    is-separable-is-prop : {X : Ptd i}
      → is-prop (is-separable X)
    is-separable-is-prop = has-dec-onesided-eq-is-prop

  MinusPoint : (X : Ptd i) → Type i
  MinusPoint X = Σ (de⊙ X) (pt X ≠_)

  unite-pt : (X : Ptd i) → (⊤ ⊔ MinusPoint X → de⊙ X)
  unite-pt X (inl _) = pt X
  unite-pt X (inr (x , _)) = x

  has-disjoint-pt : (X : Ptd i) → Type i
  has-disjoint-pt X = is-equiv (unite-pt X)

  abstract
    separable-has-disjoint-pt : {X : Ptd i}
      → is-separable X → has-disjoint-pt X
    separable-has-disjoint-pt {X} dec =
      is-eq _ sep unite-sep sep-unite where
        sep : de⊙ X → ⊤ ⊔ (Σ (de⊙ X) (pt X ≠_))
        sep x with dec x
        sep x | inl _  = inl unit
        sep x | inr ¬p = inr (x , ¬p)

        abstract
          sep-unite : ∀ x → sep (unite-pt X x) == x
          sep-unite (inl _) with dec (pt X)
          sep-unite (inl _) | inl _  = idp
          sep-unite (inl _) | inr ¬p = ⊥-rec (¬p idp)
          sep-unite (inr (x , ¬p)) with dec x
          sep-unite (inr (x , ¬p)) | inl p   = ⊥-rec (¬p p)
          sep-unite (inr (x , ¬p)) | inr ¬p' = ap inr $ pair= idp (prop-has-all-paths ¬-is-prop ¬p' ¬p)

          unite-sep : ∀ x → unite-pt X (sep x) == x
          unite-sep x with dec x
          unite-sep x | inl p = p
          unite-sep x | inr ¬p = idp

    disjoint-pt-is-separable : {X : Ptd i}
      → has-disjoint-pt X → is-separable X
    disjoint-pt-is-separable unite-ise x with unite.g x | unite.f-g x
      where module unite = is-equiv unite-ise
    disjoint-pt-is-separable unite-ise x | inl unit       | p   = inl p
    disjoint-pt-is-separable unite-ise x | inr (y , pt≠y) | y=x = inr λ pt=x → pt≠y (pt=x ∙ ! y=x)

  separable-unite-equiv : ∀ {X}
    → is-separable X
    → (⊤ ⊔ MinusPoint X ≃ de⊙ X)
  separable-unite-equiv dX = _ , separable-has-disjoint-pt dX

module _ {i j k} n (A : Type i) (B : Type j) where
  abstract
    ⊔-has-choice-implies-inr-has-choice : has-choice n (A ⊔ B) k → has-choice n B k
    ⊔-has-choice-implies-inr-has-choice ⊔-ac W =
      transport is-equiv (λ= lemma₃)
        (snd lemma₂ ∘ise ⊔-ac W' ∘ise is-equiv-inverse (snd (Trunc-emap n lemma₁))) where
          W' : A ⊔ B → Type k
          W' (inl _) = Lift {j = k} ⊤
          W' (inr b) = W b

          lemma₁ : Π (A ⊔ B) W' ≃ Π B W
          lemma₁ = equiv to from to-from from-to where
            to : Π (A ⊔ B) W' → Π B W
            to f b = f (inr b)

            from : Π B W → Π (A ⊔ B) W'
            from f (inl a) = lift tt
            from f (inr b) = f b

            abstract
              to-from : ∀ f → to (from f) == f
              to-from f = λ= λ b → idp

              from-to : ∀ f → from (to f) == f
              from-to f = λ= λ{(inl a) → idp; (inr b) → idp}

          lemma₂ : Π (A ⊔ B) (Trunc n ∘ W') ≃ Π B (Trunc n ∘ W)
          lemma₂ = equiv to from to-from from-to where
            to : Π (A ⊔ B) (Trunc n ∘ W') → Π B (Trunc n ∘ W)
            to f b = f (inr b)

            from : Π B (Trunc n ∘ W) → Π (A ⊔ B) (Trunc n ∘ W')
            from f (inl a) = [ lift tt ]
            from f (inr b) = f b

            abstract
              to-from : ∀ f → to (from f) == f
              to-from f = λ= λ b → idp

              from-to : ∀ f → from (to f) == f
              from-to f = λ= λ{
                (inl a) → Trunc-elim
                  {P = λ t → [ lift tt ] == t}
                  (λ _ → =-preserves-level Trunc-level)
                  (λ _ → idp) (f (inl a));
                (inr b) → idp}

          lemma₃ : ∀ f → –> lemma₂ (unchoose (<– (Trunc-emap n lemma₁) f)) == unchoose f
          lemma₃ = Trunc-elim
            {P = λ f → –> lemma₂ (unchoose (<– (Trunc-emap n lemma₁) f)) == unchoose f}
            (λ _ → =-preserves-level (Π-level λ _ → Trunc-level))
            (λ f → λ= λ b → idp)

module _ {i j} n {X : Ptd i} (X-sep : has-disjoint-pt X) where
  abstract
    MinusPoint-has-choice : has-choice n (de⊙ X) j → has-choice n (MinusPoint X) j
    MinusPoint-has-choice X-ac =
      ⊔-has-choice-implies-inr-has-choice n ⊤ (MinusPoint X) $
        transport! (λ A → has-choice n A j) (ua (_ , X-sep)) X-ac


-- Andreas, 2016-10-11, AIM XXIV, issue #2248
-- COMPILED_TYPE should only work on postulates

data Unit : Set where
  unit : Unit

postulate
  IO : Set → Set

{-# BUILTIN IO IO #-}
{-# COMPILE GHC IO = type IO #-}

abstract
  IO' : Set → Set
  IO' A = A

  doNothing : IO' Unit
  doNothing = unit

{-# COMPILE GHC IO' = type IO #-}

postulate
  toIO : {A : Set} → IO' A → IO A

{-# COMPILE GHC toIO = \ _ x -> x #-}

main : IO Unit
main = toIO doNothing


module PrintNat where

import PreludeShow
open PreludeShow

mainS = showNat 42


module Functional.Dependent where

import      Lvl
open import Type

private variable ℓ ℓ₁ ℓ₂ : Lvl.Level

-- Function type as a function
_→ᶠ_ : (X : Type{ℓ₁}) → (Type{ℓ₁} → Type{ℓ₂}) → Type{ℓ₁ Lvl.⊔ ℓ₂}
X →ᶠ Y = X → Y(X)
infixl 30 _→ᶠ_

module _ where
  private variable X : Type{ℓ}
  private variable Y : X → Type{ℓ}
  private variable Z : ∀{x : X} → Y(x) → Type{ℓ}

  apply : (x : X) → ((x : X) → Y(x)) → Y(x)
  apply(x)(f) = f(x)
  {-# INLINE apply #-}

  const : (∀{x : X} → Y(x)) → ((x : X) → Y(x))
  const y _ = y
  {-# INLINE const #-}

  _$_ : ((x : X) → Y(x)) → (x : X) → Y(x)
  f $ x = f(x)
  {-# INLINE _$_ #-}
  infixr 0 _$_

  _⩺_ : (x : X) → ((x : X) → Y(x)) → Y(x)
  x ⩺ f = f(x)
  {-# INLINE _⩺_ #-}
  infixl 10000 _⩺_

  _⩹_ : ((x : X) → Y(x)) → (x : X) → Y(x)
  f ⩹ x = f(x)
  {-# INLINE _⩹_ #-}
  infixl 10000 _⩹_

  _∘ᵢₘₚₗ_ : (∀{x : X}{y : Y(x)} → Z{x}(y)) → (g : ∀{x : X} → Y(x)) → (∀{x : X} → Z(g{x}))
  (f ∘ᵢₘₚₗ g){x} = f{x}{g{x}}
  infixl 10000 _∘ᵢₘₚₗ_

  _∘ᵢₙₛₜ_ : (⦃ x : X ⦄ ⦃ y : Y(x) ⦄ → Z{x}(y)) → (g : ⦃ x : X ⦄ → Y(x)) → (⦃ x : X ⦄ → Z(g ⦃ x ⦄))
  (f ∘ᵢₙₛₜ g) ⦃ x ⦄ = f ⦃ x ⦄ ⦃ g ⦃ x ⦄ ⦄
  infixl 10000 _∘ᵢₙₛₜ_

  _∘ₛ_ : ((x : X) → (y : Y(x)) → Z{x}(y)) → (g : (x : X) → Y(x)) → ((x : X) → Z(g(x)))
  (f ∘ₛ g)(x) = f(x)(g(x))
  {-# INLINE _∘ₛ_ #-}
  infixl 10000 _∘ₛ_

  _∘_ : (∀{x : X} → (y : Y(x)) → Z{x}(y)) → (g : (x : X) → Y(x)) → ((x : X) → Z(g(x)))
  _∘_ f = (const f) ∘ₛ_
  {-# INLINE _∘_ #-}
  infixl 10000 _∘_

module _ where
  private variable X : Type{ℓ}
  private variable Y : X → Type{ℓ}
  private variable Z : ∀{x₁ x₂ : X} → Y(x₁) → Y(x₂) → Type{ℓ}

  _on₂_ : (f : ∀{x₁ x₂ : X} → (y₁ : Y(x₁)) → (y₂ : Y(x₂)) → Z{x₁}{x₂}(y₁)(y₂)) → (g : (x : X) → Y(x)) → ((x₁ : X) → (x₂ : X) → Z(g(x₁))(g(x₂)))
  ((_▫_) on₂ f)(y₁)(y₂) = f(y₁) ▫ f(y₂)

module _ where
  private variable X Y : Type{ℓ}
  private variable Z : X → Y → Type{ℓ}

  swap : ((x : X) → (y : Y) → Z(x)(y)) → ((y : Y) → (x : X) → Z(x)(y))
  swap f(y)(x) = f(x)(y)
  {-# INLINE swap #-}

{- TODO: Agda errors
module _ where
  private variable X₁ : Type{ℓ}
  private variable X₂ : X₁ → Type{ℓ}
  private variable Y₁ : ∀{x₁ : X₁} → X₂(x₁) → Type{ℓ}
  private variable Y₂ : ∀{x₁ : X₁}{x₂ : X₂(x₁)} → Y₁{x₁}(x₂) → Type{ℓ}
  private variable Z : ∀{x₁ : X₁}{x₂ : X₂(x₁)}{y₁ : Y₁{x₁}(x₂)} → (Y₂{x₁}{x₂}(y₁)) → Type{ℓ}

  pointwise₂,₁' : (∀{x₁ : X₁} → (x₂ : X₂(x₁)) → {y₁ : Y₁(x₂)} → (y₂ : Y₂(y₁)) → Z{x₁}{x₂}{y₁}(y₂)) → (f : (x₁ : X₁) → X₂(x₁)) → (g : ∀{x₁}{x₂} → (y₁ : Y₁{x₁}(x₂)) → Y₂{x₁}{x₂}(y₁)) → ((x₁ : X₁) → (y₁ : Y₁{x₁}(f(x₁))) → Z{x₁}{f(x₁)}{y₁}(g(y₁)))
-}
{-
module _ where
  private variable X₁ : Type{ℓ}
  private variable X₂ : X₁ → Type{ℓ}
  private variable Y₁ : ∀{x₁ : X₁} → X₂(x₁) → Type{ℓ}
  private variable Y₂ : ∀{x₁ : X₁}{x₂ : X₂(x₁)} → Y₁{x₁}(x₂) → Type{ℓ}
  private variable Z : ∀{x₁ : X₁}{x₂ : X₂(x₁)}{y₁ : Y₁{x₁}(x₂)} → Type{ℓ}

  pointwise₂,₁' : ∀{x₁ : X₁} → (x₂ : X₂(x₁)) → {y₁ : Y₁(x₂)} → (y₂ : Y₂(y₁)) → Z{x₁}{x₂}{y₁}
-}

module _ where
  private variable A : Type{ℓ}
  private variable B : A → Type{ℓ}
  private variable C : ∀{a : A} → B(a) → Type{ℓ}
  private variable D : ∀{a : A}{b : B(a)} → (C{a}(b)) → Type{ℓ}
  private variable E : ∀{a : A}{b : B(a)}{c : C{a}(b)} → D{a}{b}(c) → Type{ℓ}
  private variable F : ∀{a : A}{b : B(a)}{c : C{a}(b)}{d : D{a}{b}(c)} → E{a}{b}{c}(d) → Type{ℓ}

  -- Alternative definition: (f ∘₂ g) a b = f(g a b)
  _∘₂_ : (∀{a : A}{b : B(a)} → (c : C{a}(b)) → D{a}{b}(c)) → (g : ∀(a)(b) → C{a}(b)) → (∀(a)(b) → D(g a b))
  _∘₂_ f = (f ∘_) ∘_
  {-# INLINE _∘₂_ #-}

  -- Alternative definition: (f ∘₂ₛ g) x y = f a b (g a b)
  _∘₂ₛ_ : ((a : A) → (b : B(a)) → (c : C{a}(b)) → D{a}{b}(c)) → (g : ∀(a)(b) → C{a}(b)) → (∀(a)(b) → D(g a b))
  _∘₂ₛ_ f = ((_∘ₛ_) ∘ f) ∘ₛ_
  {-# INLINE _∘₂ₛ_ #-}

  -- Alternative definition: (f ∘₂ g) a b c = f(g a b c)
  _∘₃_ : (∀{a : A}{b : B(a)}{c : C{a}(b)} → (d : D{a}{b}(c)) → E{a}{b}{c}(d)) → (g : ∀(a)(b)(c) → D{a}{b}(c)) → (∀(a)(b)(c) → E(g a b c))
  _∘₃_ f = (f ∘₂_) ∘_
  {-# INLINE _∘₃_ #-}

  -- Alternative definition: (f ∘₃ₛ g) a b c = f a b c (g a b c)
  _∘₃ₛ_ : (∀(a : A)(b : B(a))(c : C{a}(b)) → (d : D{a}{b}(c)) → E{a}{b}{c}(d)) → (g : ∀(a)(b)(c) → D{a}{b}(c)) → (∀(a)(b)(c) → E(g a b c))
  _∘₃ₛ_ f = ((_∘₂ₛ_) ∘ f) ∘ₛ_
  {-# INLINE _∘₃ₛ_ #-}

  -- Alternative definition: (f ∘₄ g) a b c d = f(g a b c d)
  _∘₄_ : (∀{a : A}{b : B(a)}{c : C{a}(b)}{d : D{a}{b}(c)} → (e : E{a}{b}{c}(d)) → F{a}{b}{c}{d}(e)) → (g : ∀(a)(b)(c)(d) → E{a}{b}{c}(d)) → (∀(a)(b)(c)(d) → F(g a b c d))
  _∘₄_ f = (f ∘₃_) ∘_
  {-# INLINE _∘₄_ #-}

  -- Alternative definition: (f ∘₄ₛ g) a b c d = f a b c d (g a b c d)
  _∘₄ₛ_ : (∀(a : A)(b : B(a))(c : C{a}(b))(d : D{a}{b}(c)) → (e : E{a}{b}{c}(d)) → F{a}{b}{c}{d}(e)) → (g : ∀(a)(b)(c)(d) → E{a}{b}{c}(d)) → (∀(a)(b)(c)(d) → F(g a b c d))
  _∘₄ₛ_ f = ((_∘₃ₛ_) ∘ f) ∘ₛ_
  {-# INLINE _∘₄ₛ_ #-}

  -- Alternative definition: pointwise₂,₁(_▫_) f g a = f(a) ▫ g(a)
  pointwise₂,₁ : (∀{a : A} → (b : B(a)) → (c : C{a}(b)) → D{a}{b}(c)) → (f : (a : A) → B(a)) → (g : (a : A) → C{a}(f(a))) → (a : A) → D{a}{f(a)}(g(a))
  pointwise₂,₁(_▫_) = ((_∘ₛ_) ∘ ((_▫_) ∘_))
  {-# INLINE pointwise₂,₁ #-}

  -- Alternative definition: pointwise₂,₂(_▫_) f g a b = (f a b) ▫ (g a b)
  pointwise₂,₂ : (∀{a : A}{b : B(a)} → (c : C{a}(b)) → (d : D{a}{b}(c)) → E{a}{b}{c}(d)) → (f : (a : A) → (b : B(a)) → C{a}(b)) → (g : (a : A) → (b : B(a)) → D{a}{b}(f a b)) → (a : A) → (b : B(a)) → E{a}{b}{f a b}(g a b)
  pointwise₂,₂(_▫_) = pointwise₂,₁(pointwise₂,₁(_▫_))
  {-# INLINE pointwise₂,₂ #-}

  -- Alternative definition: pointwise₂,₃(_▫_) f g a b c = (f a b c) ▫ (g a b c)
  pointwise₂,₃ : (∀{a : A}{b : B(a)}{c : C{a}(b)} → (d : D{a}{b}(c)) → (e : E{a}{b}{c}(d)) → F{a}{b}{c}{d}(e)) → (f : (a : A) → (b : B(a)) → (c : C{a}(b)) → D{a}{b}(c)) → (g : (a : A) → (b : B(a)) → (c : C{a}(b)) → E{a}{b}(f a b c)) → (a : A) → (b : B(a)) → (c : C{a}(b)) → F{a}{b}{c}{f a b c}(g a b c)
  pointwise₂,₃(_▫_) = pointwise₂,₁(pointwise₂,₂(_▫_))
  {-# INLINE pointwise₂,₃ #-}


module Base.Prelude.Unit where

open import Data.Unit using (tt)         renaming (⊤ to ⊤ᵖ) public
open import Base.Free using (Free; pure)

⊤ : (S : Set) (P : S → Set) → Set
⊤ _ _ = ⊤ᵖ

pattern Tt = pure tt


{-# OPTIONS --cubical-compatible #-}

data D : Set → Set₁ where
  c : (@0 A : Set) → D A


module examplesPaperJFP.SpaceShipSimpleVar where

open import SizedIO.Base
open import StateSizedIO.GUI.BaseStateDependent

open import Data.Bool.Base
open import Data.List.Base
open import Data.Integer

open import Data.Product hiding (map)
open import SizedIO.Object
open import SizedIO.IOObject

open import NativeIO

open import StateSizedIO.GUI.WxBindingsFFI
open import StateSizedIO.GUI.VariableList

open import StateSizedIO.GUI.WxGraphicsLib

open import StateSized.GUI.BitMaps

VarType = ℤ

varInit : VarType
varInit = (+ 150)

onPaint : ∀{i} → VarType → DC → Rect → IO GuiLev1Interface i VarType
onPaint z dc rect      =  exec (drawBitmap dc ship (z , (+ 150)) true) λ _ →
                          return z

moveSpaceShip  : ∀{i} → Frame → VarType → IO GuiLev1Interface i VarType
moveSpaceShip  fra z   =  return (z + (+ 20))

callRepaint    : ∀{i} → Frame → VarType → IO GuiLev1Interface i VarType
callRepaint    fra z   =  exec (repaint fra) λ _ → return z

buttonHandler : ∀{i} → Frame → List (VarType  → IO GuiLev1Interface i VarType)
buttonHandler fra = moveSpaceShip fra ∷ [ callRepaint fra ]

program : ∀{i} → IOˢ GuiLev2Interface i (λ _ → Unit) []
program =  execˢ (level1C makeFrame)           λ fra →
           execˢ (level1C (makeButton fra))    λ bt →
           execˢ (level1C (addButton fra bt))  λ _ →
           execˢ (createVar varInit)           λ _ →
           execˢ (setButtonHandler bt (moveSpaceShip fra
                                     ∷ [ callRepaint fra ])) λ _ →
           execˢ (setOnPaint       fra [ onPaint  ])
           returnˢ

main : NativeIO Unit
main = start (translateLev2 program)


-- Record projections should be positive in their argument
module Issue602-2 where

record A : Set₁ where
  constructor mkA
  field
    f : Set

unA : A → Set
unA (mkA x) = x

data B (a : A) : Set where
  mkB : unA a → B a

data D : Set where
  d : B (mkA D) → D