open import Relation.Nullary using (Dec; yes; no; ¬_)
open import Relation.Nullary.Decidable using (from-yes)
open import Relation.Nullary.Negation using (contradiction)
open import Relation.Binary using (Tri)
open Tri
open import Relation.Binary.PropositionalEquality using (_≡_; _≢_; refl; sym; trans)

open import Data.Empty using (⊥)
open import Data.Sum using (inj₁; inj₂)

module AKS.Primality.Properties where

open import AKS.Nat using (ℕ; _+_; _≟_; _<_; _>_; _<?_; _≤_)
open import AKS.Nat using (<-cmp; <-irrefl; <-trans; 0<1+n; ≤-antisym; 0≤n; suc-injective-≤; <⇒≤; ≢⇒¬≟; <⇒≱; n≤m⇒n<m⊎n≡m; ≤-refl; n<1+n)
open import AKS.Nat using (Acc; acc; <-well-founded; _⊂_; Interval; [_,_∣_]; ⊂-well-founded; upward)
open import AKS.Nat.GCD
  using (_∣_; _∤_; _∣?_; gcd; bézout; lemma; Identity; gcd[a,b]∣a; gcd[a,b]∣b; 0∣n⇒n≈0; ∣-respˡ; ∣⇒≤; ∣-trans)
  renaming (_⊥_ to _coprime_)

open import AKS.Primality.Base

prime≢0 : ∀ {p} → IsPrime p → p ≢ 0
prime≢0 (IsPrime✓ 1<p _) p≡0 = <-irrefl (sym p≡0) (<-trans 0<1+n 1<p)

¬prime<2 : ∀ p → p < 2 → ¬ (IsPrime p)
¬prime<2 p p<2 (IsPrime✓ 1<p ∀i∣p[i≡p]) = contradiction 1<p (<⇒≱ p<2)

exclusive : ∀ {n} → IsPrime n → IsComposite n → ⊥
exclusive {n} (IsPrime✓ 1<n ∀i∣n[i≡n]) (IsComposite✓ p p<n (IsPrime✓ 1<p _) p∣n)
  = contradiction p<n (<-irrefl (∀i∣n[i≡n] 1<p p∣n))

n<1⇒n≡0 : ∀ {n} → n < 1 → n ≡ 0
n<1⇒n≡0 {n} n<1 = ≤-antisym (suc-injective-≤ n<1) 0≤n

n⊥prime : ∀ {p} n {n≢0 : n ≢ 0} → n < p → IsPrime p → n coprime p
n⊥prime {p} n {n≢0} n<p (IsPrime✓ 1<p ∀i∣p[i≡p]) with <-cmp 1 (gcd n p)
... | tri> _ _ 1>gcd[n,p] = contradiction (0∣n⇒n≈0 (∣-respˡ (n<1⇒n≡0 1>gcd[n,p]) (gcd[a,b]∣a n p))) n≢0
... | tri≈ _ 1≡gcd[n,p] _ = sym 1≡gcd[n,p]
... | tri< 1<gcd[n,p] _ _ = contradiction p≤n (<⇒≱ n<p)
  where
  gcd[n,p]≡p : gcd n p ≡ p
  gcd[n,p]≡p = ∀i∣p[i≡p] 1<gcd[n,p] (gcd[a,b]∣b n p)
  p∣n : p ∣ n
  p∣n = ∣-respˡ gcd[n,p]≡p (gcd[a,b]∣a n p)
  p≤n : p ≤ n
  p≤n = ∣⇒≤ {n≢0 = ≢⇒¬≟ n≢0} p∣n

bézout-prime : ∀ x p → x ≢ 0 → x < p → IsPrime p → Identity 1 x p
bézout-prime x p x≢0 x<p p-isPrime with bézout x p | n⊥prime x {x≢0} x<p p-isPrime
bézout-prime x p x≢0 x<p p-isPrime | lemma d gcd[x,p]≡d ident | gcd[x,p]≡1 with trans (sym gcd[x,p]≡d) gcd[x,p]≡1
bézout-prime x p x≢0 x<p p-isPrime | lemma .1 gcd[x,p]≡d ident | gcd[x,p]≡1 | refl = ident

compositionalityⁱ : ∀ n → 1 < n → Acc _<_ n → Compositionality n
primalityⁱ : ∀ n → 1 < n → Acc _<_ n → Primality n

compositionalityⁱ n 1<n (acc downward)
  = loop 2 (from-yes (1 <? 2)) 1<n ⊂-well-founded ¬p<2[p∤n]
  where
  ¬p<2[p∤n] : ∀ {p} → p < 2 → IsPrime p → p ∤ n
  ¬p<2[p∤n] {p} p<2 p-isPrime _ = contradiction p-isPrime (¬prime<2 p p<2)
  cons
    : ∀ {x}
    → (IsPrime x → x ∤ n)
    → (∀ {p} → p < x → IsPrime p → p ∤ n)
    → (∀ {p} → p < 1 + x → IsPrime p → p ∤ n)
  cons {x} x-isPrime⇒x∤n ∀p<x[p∤n] {p} p<1+x p-isPrime p∣n with <-cmp p x
  ... | tri< p<x _ _ = contradiction p∣n (∀p<x[p∤n] p<x p-isPrime)
  ... | tri≈ _ refl _ = contradiction p∣n (x-isPrime⇒x∤n p-isPrime)
  ... | tri> _ _ x<p = contradiction (suc-injective-≤ p<1+x) (<⇒≱ x<p)
  loop
    : ∀ x → 1 < x → (x≤n : x ≤ n) → Acc _⊂_ [ x , n ∣ x≤n ]
    → (∀ {p} → p < x → IsPrime p → p ∤ n)
    → Compositionality n
  loop x 1<x x≤n (acc next) ∀p<x⇒p∤n with n≤m⇒n<m⊎n≡m x≤n
  ... | inj₂ refl = Prime✓ ∀p<x⇒p∤n
  ... | inj₁ x<n with primalityⁱ x 1<x (downward x<n)
  ...   | Composite✓ x-isComposite = loop (1 + x) (<-trans 1<x n<1+n) x<n (next [1+x,n]⊂[x,n]) ∀p<1+x⇒p∤n
          where
          [1+x,n]⊂[x,n] : [ 1 + x , n ∣ x<n ] ⊂ [ x , n ∣ x≤n ]
          [1+x,n]⊂[x,n] = upward n<1+n ≤-refl
          ∀p<1+x⇒p∤n = cons (λ x-isPrime _ → exclusive x-isPrime x-isComposite) ∀p<x⇒p∤n
  ...   | Prime✓ x-isPrime with x ∣? n
  ...     | yes x∣n = Composite✓ (IsComposite✓ x x<n x-isPrime x∣n)
  ...     | no ¬x∣n = loop (1 + x) (<-trans 1<x n<1+n) x<n (next [1+x,n]⊂[x,n]) ∀p<1+x[p∤n]
          where
          [1+x,n]⊂[x,n] : [ 1 + x , n ∣ x<n ] ⊂ [ x , n ∣ x≤n ]
          [1+x,n]⊂[x,n] = upward n<1+n ≤-refl
          ∀p<1+x[p∤n] = cons (λ _ x∣n → ¬x∣n x∣n) ∀p<x⇒p∤n

primalityⁱ n 1<n wf@(acc downward) with compositionalityⁱ n 1<n wf
... | Composite✓ isComposite = Composite✓ isComposite
  -- n is a composite so just return the proof of compositionality
... | Prime✓ ∀p<n[p∤n] = Prime✓ (IsPrime✓ 1<n ∀i∣n[i≡n])
  -- All prime divisors less then n do not divide n therefore n is prime (#1)
  where
  n≢0 : n ≢ 0
  n≢0 n≡0 = <-irrefl (sym n≡0) (<-trans 0<1+n 1<n)
  ∀i∣n[i≡n] : ∀ {i} → 1 < i → i ∣ n → i ≡ n
  ∀i∣n[i≡n] {i} 1<i i∣n with <-cmp i n
  ... | tri> _ _ n<i = contradiction (∣⇒≤ {n≢0 = ≢⇒¬≟ n≢0} i∣n) (<⇒≱ n<i)
      -- i is larger than n so i divides n so i is less then or equal to n ⇒⇐
  ... | tri≈ _ i≡n _ = i≡n
  ... | tri< i<n _ _ with primalityⁱ i 1<i (downward i<n)
  ...   | Prime✓ i-isPrime
        = contradiction i∣n (∀p<n[p∤n] i<n i-isPrime)
        -- i is a prime divisor of n (#1) ⇒⇐
  ...   | Composite✓ (IsComposite✓ p p<i p-isPrime p∣i)
        = contradiction (∣-trans p∣i i∣n) (∀p<n[p∤n] (<-trans p<i i<n) p-isPrime)
        -- i is a composite number with a prime divisor therefore there exists a prime divisor of n (#1) ⇒⇐

primality : ∀ n → 1 < n → Primality n
primality n 1<n = primalityⁱ n 1<n <-well-founded

prime? : ∀ n → Dec (IsPrime n)
prime? n with 1 <? n
... | no ¬1<n = no λ { (IsPrime✓ 1<n _) → ¬1<n 1<n }
... | yes 1<n with primality n 1<n
... | Prime✓ isPrime = yes isPrime
... | Composite✓ isComposite = no λ { isPrime → exclusive isPrime isComposite }

composite? : ∀ n → Dec (IsComposite n)
composite? n with 1 <? n
... | no ¬1<n = no λ { (IsComposite✓ p p<n (IsPrime✓ 1<p _) _) → ¬1<n (<-trans 1<p p<n) }
... | yes 1<n with primality n 1<n
... | Prime✓ isPrime = no λ { isComposite → exclusive isPrime isComposite }
... | Composite✓ isComposite = yes isComposite

-- 13-isPrime : IsPrime 13
-- 13-isPrime = from-yes (prime? 13)

-- 24-isComposite : IsComposite 24
-- 24-isComposite = from-yes (composite? 24)


{-# OPTIONS --cubical-compatible #-}
module Common.Integer where

open import Agda.Builtin.Int public renaming (Int to Integer)


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

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

module cohomology.Sigma {i} (CT : CohomologyTheory i) where

open CohomologyTheory CT
open import cohomology.Functor CT
open import cohomology.BaseIndependence CT

{- Cⁿ(Σx:X.Y) = Cⁿ(⋁x:X.Y) × Cⁿ(X). The proof is by constructing a
 - splitting exact sequence

       0 → Cⁿ(⋁x:X.Y) → Cⁿ(Σx:X.Y) → Cⁿ(X)

 - by observing that the map [select : x ↦ (x, snd Yₓ)] has a left inverse
 - and satisfies [Cofiber select == ⋁x:X.Y. -}

module CofSelect (X : Ptd i) (Y : fst X → Ptd i) where

  select : fst X → fst (⊙Σ X Y)
  select x = (x , snd (Y x))

  ⊙select : fst (X ⊙→ ⊙Σ X Y)
  ⊙select = (select , idp)

  ⊙Σbwin : fst (⊙Σ X Y ⊙→ ⊙BigWedge Y)
  ⊙Σbwin = (uncurry bwin , ! (bwglue (snd X)))

  eq : Cofiber select ≃ BigWedge Y
  eq = equiv Into.f Out.f into-out out-into
    where
    module Into = CofiberRec select {C = BigWedge Y}
      bwbase (uncurry bwin) bwglue

    module Out = BigWedgeRec {X = Y} {C = Cofiber select}
      (cfbase _) (curry (cfcod _)) (cfglue _)

    into-out : ∀ w → Into.f (Out.f w) == w
    into-out = BigWedge-elim
      idp (λ _ _ → idp)
      (↓-∘=idf-in Into.f Out.f ∘ λ x →
        ap (ap Into.f) (Out.glue-β x) ∙ Into.glue-β x)

    out-into : ∀ c → Out.f (Into.f c) == c
    out-into = Cofiber-elim select
      idp (λ _ → idp)
      (↓-∘=idf-in Out.f Into.f ∘ λ x →
        ap (ap Out.f) (Into.glue-β x) ∙ Out.glue-β x)

  ⊙path : ⊙Cof ⊙select == ⊙BigWedge Y
  ⊙path = ⊙ua eq idp

  cfcod-over : cfcod _ == uncurry bwin [ (λ U → fst (⊙Σ X Y) → fst U) ↓ ⊙path ]
  cfcod-over = ↓-cst2-in _ _ $ codomain-over-equiv _ _

  ext-glue-cst : ext-glue {s = cofiber-span select} == cst (north _)
  ext-glue-cst = λ= $ Cofiber-elim _
    idp
    (λ {(x , y) → ! (merid _ x)})
    (↓-='-from-square ∘ λ x →
      ExtGlue.glue-β x ∙v⊡
        tr-square (merid _ x)
      ⊡v∙ ! (ap-cst (north _) (cfglue _ x)))

  ext-over : ext-glue == cst (north _)
             [ (λ U → fst U → fst (⊙Susp X)) ↓ ⊙path ]
  ext-over = ↓-cst2-in _ _ $ ext-glue-cst ◃ domain-over-equiv _ _

module CΣ (n : ℤ) (X : Ptd i) (Y : fst X → Ptd i) where

  open CofSelect X Y

  private
    seq : HomSequence _ _
    seq =
      C n (⊙Susp X)     ⟨ cst-hom ⟩→
      C n (⊙BigWedge Y) ⟨ CF-hom n ⊙Σbwin ⟩→
      C n (⊙Σ X Y)      ⟨ CF-hom n ⊙select ⟩→
      C n X             ⊣|

    eseq : is-exact-seq seq
    eseq = exact-build seq
      (transport (λ {(φ , ψ) → is-exact ψ φ})
        (pair×= (CF-base-indep n _ _ _) (CF-base-indep n _ _ _ ∙ CF-cst n))
        (transport {A = Σ _ (λ {(U , g , h) → (g (snd (⊙Σ X Y)) == snd U)
                                            × (h (snd U) == north _)})}
          (λ {((_ , g , h) , (p , q)) →
            is-exact (CF-hom n (h , q)) (CF-hom n (g , p))})
          (pair= (pair= ⊙path (↓-×-in cfcod-over ext-over))
                 (↓-×-in (from-transp _ _ idp) (from-transp _ _ idp)))
          (transport {A = Σ _ (λ {(U , g) → g (cfbase _) == snd U})}
            (λ {((_ , g) , p) →
              is-exact (CF-hom n (g , p)) (CF-hom n (⊙cfcod ⊙select))})
            (pair= (pair= (Cof².space-path ⊙select) (Cof².cfcod²-over ⊙select))
                   (from-transp _ _ idp))
            (C-exact n (⊙cfcod ⊙select)))))
      (transport (λ φ → is-exact φ (CF-hom n ⊙select))
        (CF-base-indep n _ _ _)
        (transport {A = Σ _ (λ {(U , g) → g (snd (⊙Σ X Y)) == snd U})}
          (λ {((_ , g) , p) → is-exact (CF-hom n (g , p)) (CF-hom n ⊙select)})
          (pair= (pair= ⊙path cfcod-over) (from-transp _ _ idp))
          (C-exact n ⊙select)))

    module SER = SplitExactRight (C-abelian n _)
      (CF-hom n ⊙Σbwin) (CF-hom n ⊙select)
      eseq
      (CF-hom n (⊙dfst Y))
      (app= $ ap GroupHom.f $ CF-inverse n ⊙select (⊙dfst Y) (λ _ → idp))

  path : C n (⊙Σ X Y) == C n (⊙BigWedge Y) ×ᴳ C n X
  path = SER.iso

  ⊙Σbwin-over : CF-hom n ⊙Σbwin == ×ᴳ-inl
                [ (λ G → GroupHom (C n (⊙BigWedge Y)) G) ↓ path ]
  ⊙Σbwin-over = SER.φ-over-iso

  ⊙select-over : CF-hom n ⊙select == ×ᴳ-snd {G = C n (⊙BigWedge Y)}
                 [ (λ G → GroupHom G (C n X)) ↓ path ]
  ⊙select-over = SER.ψ-over-iso

  open CofSelect public using (select; ⊙select; ⊙Σbwin)

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

  private
    T : Sphere {i} 0 → Ptd i
    T (lift true) = X
    T (lift false) = Y

  path : C n (X ⊙⊔ Y) == C n (X ⊙∨ Y) ×ᴳ C n (⊙Sphere 0)
  path = ap (C n) (! (⊙ua (ΣBool-equiv-⊔ (fst ∘ T)) idp))
         ∙ CΣ.path n (⊙Sphere 0) T
         ∙ ap (λ Z → C n Z ×ᴳ C n (⊙Sphere 0)) (BigWedge-Bool-⊙path T)


-- Reported by matteo.acerbi, AIMXX, 2014-10-21

-- The following is accepted.

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

-- {-# OPTIONS -v term:30 #-}

record X : Set where
  coinductive
  constructor ↑_
  field       ↓_ : X
open X

record Y (x1 x2 : X) : Set where
  coinductive
  field       ]_[ : Y (↑ x1) (↑ x2)
open Y

trivial-Y : ∀ {x1 x2} → Y x1 x2
] trivial-Y [ = trivial-Y

-- Should termination check.


{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.HITs.Sn where

open import Cubical.HITs.Sn.Base public
open import Cubical.HITs.Sn.Properties public


------------------------------------------------------------------------
-- The Agda standard library
--
-- The universe polymorphic unit type and the total relation on unit
------------------------------------------------------------------------

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

module Data.Unit.Polymorphic where

------------------------------------------------------------------------
-- Re-export contents of Base module

open import Data.Unit.Polymorphic.Base public

------------------------------------------------------------------------
-- Re-export query operations

open import Data.Unit.Polymorphic.Properties public using (_≟_)


-- A Beth model of normal forms

open import Library

module NfModelCaseTreeConv (Base : Set) where

import Formulas   ; open module Form = Formulas    Base
import Derivations; open module Der  = Derivations Base

-- Beth model

data Cover (P : Cxt → Set) (Γ : Cxt) : Set where
  returnC : (p : P Γ) → Cover P Γ
  falseC  : (t : Ne Γ False) → Cover P Γ
  orC     : ∀{C D} (t : Ne Γ (C ∨ D))
              (c : Cover P (Γ ∙ C))
              (d : Cover P (Γ ∙ D)) → Cover P Γ

-- Syntactic paste

pasteNf : ∀{A} → Cover (Nf' A) →̇ Nf' A
pasteNf (returnC p) = p
pasteNf (falseC t)  = falseE t
pasteNf (orC t c d) = orE t (pasteNf c) (pasteNf d)

-- Weakening covers:  A case tree in Γ can be transported to a thinning Δ
-- by weakening all the scrutinees.

monC : ∀{P} → (monP : Mon P) → Mon (Cover P)
monC monP τ (returnC p) = returnC (monP τ p)
monC monP τ (falseC t)  = falseC (monNe τ t)
monC monP τ (orC t c d) = orC (monNe τ t) (monC monP (lift τ) c)
                                          (monC monP (lift τ) d)

-- Monad

mapC : ∀{P Q} → (P →̇ Q) → (Cover P →̇ Cover Q)
mapC f (returnC p) = returnC (f p)
mapC f (falseC t)  = falseC t
mapC f (orC t c d) = orC t (mapC f c) (mapC f d)

joinC : ∀{P} → Cover (Cover P) →̇ Cover P
joinC (returnC p) = p
joinC (falseC t)  = falseC t
joinC (orC t c d) = orC t (joinC c) (joinC d)

-- Version of mapC with f relativized to subcontexts of Γ

mapC' : ∀{P Q Γ} → KFun P Q Γ → Cover P Γ → Cover Q Γ
mapC' f (returnC p) = returnC (f id≤ p)
mapC' f (falseC t)  = falseC t
mapC' f (orC t c d) = orC t (mapC' (λ τ → f (τ • weak id≤)) c)
                            (mapC' (λ τ → f (τ • weak id≤)) d)

Conv : (Δ₀ : Cxt) (P Q : Cxt → Set) → Set
Conv Δ₀ P Q = ∀{Γ Δ} (δ : Δ ≤ Δ₀) (τ : Δ ≤ Γ) → P Γ → Q Δ

convC : ∀{Δ₀} {P Q}
  → Conv Δ₀ P Q
  → Conv Δ₀ (Cover P) (Cover Q)
convC {Δ₀} {P} {Q} f {Γ} {Δ} δ τ (returnC p) = returnC (f δ τ p)
convC {Δ₀} {P} {Q} f {Γ} {Δ} δ τ (falseC t) = falseC (monNe τ t)
convC {Δ₀} {P} {Q} f {Γ} {Δ} δ τ (orC t c d) = orC (monNe τ t)
  (convC {Δ₀} f (weak δ) (lift τ) c)
  (convC {Δ₀} f (weak δ) (lift τ) d)

-- The syntactic Beth model.

-- We interpret base propositions  Atom P  by their normal deriviations.
-- ("Normal" is important; "neutral is not sufficient since we need case trees here.)

-- The negative connectives True, ∧, and ⇒ are explained as usual by η-expansion
-- and the meta-level connective.

-- The positive connectives False and ∨ are inhabited by case trees.
-- In case False, the tree has no leaves.
-- In case A ∨ B, each leaf must be in the semantics of either A or B.

T⟦_⟧ : (A : Form) (Γ : Cxt) → Set
T⟦ Atom P ⟧ = Nf' (Atom P)
T⟦ True   ⟧ Γ = ⊤
T⟦ False  ⟧ = Cover λ Δ → ⊥
T⟦ A ∨ B  ⟧ = Cover λ Δ → T⟦ A ⟧ Δ ⊎ T⟦ B ⟧ Δ
T⟦ A ∧ B  ⟧ Γ = T⟦ A ⟧ Γ × T⟦ B ⟧ Γ
T⟦ A ⇒ B  ⟧ Γ = ∀{Δ} (τ : Δ ≤ Γ) → T⟦ A ⟧ Δ → T⟦ B ⟧ Δ

-- Monotonicity of the model is proven by induction on the proposition,
-- using monotonicity of covers and the built-in monotonicity at implication.

-- monT : ∀ A {Γ Δ} (τ : Δ ≤ Γ) → T⟦ A ⟧ Γ → T⟦ A ⟧ Δ

monT : ∀ A → Mon T⟦ A ⟧
monT (Atom P) = monNf
monT True     = _
monT False    = monC λ τ ()
monT (A ∨ B)  = monC λ τ → map-⊎ (monT A τ) (monT B τ)
monT (A ∧ B) τ (a , b) = monT A τ a , monT B τ b
monT (A ⇒ B) τ f σ = f (σ • τ)

-- Reflection / reification, proven simultaneously by induction on the proposition.

-- Reflection is η-expansion (and recursively reflection);
-- at positive connections we build a case tree with a single scrutinee: the neutral
-- we are reflecting.

-- At implication, we need reification, which produces introductions
-- and reifies the stored case trees.

mutual

  fresh : ∀ {Γ} A → T⟦ A ⟧ (Γ ∙ A)
  fresh A = reflect A (hyp top)

  reflect : ∀ A → Ne' A →̇ T⟦ A ⟧
  reflect (Atom P) t = ne t
  reflect True     t = _
  reflect False    t = falseC t
  reflect (A ∨ B)  t = orC t (returnC (inj₁ (fresh A)))
                             (returnC (inj₂ (fresh B)))
  reflect (A ∧ B)  t = reflect A (andE₁ t) , reflect B (andE₂ t)
  reflect (A ⇒ B)  t τ a = reflect B (impE (monNe τ t) (reify A a))

  reify : ∀ A → T⟦ A ⟧ →̇ Nf' A
  reify (Atom P) t      = t
  reify True _          = trueI
  reify False           = pasteNf ∘  mapC ⊥-elim
  reify (A ∨ B)         = pasteNf ∘  mapC [ orI₁ ∘ reify A , orI₂ ∘ reify B ]
  reify (A ∧ B) (a , b) = andI (reify A a) (reify B b)
  reify (A ⇒ B) ⟦f⟧     = impI (reify B (⟦f⟧ (weak id≤) (fresh A)))

-- Semantic paste.

paste : ∀ A → Cover T⟦ A ⟧ →̇ T⟦ A ⟧
paste (Atom P) = pasteNf
paste True     = _
paste False    = joinC
paste (A ∨ B)  = joinC
paste (A ∧ B)  = < paste A ∘ mapC proj₁ , paste B ∘ mapC proj₂  >
paste (A ⇒ B) c τ a = paste B (convC (λ δ τ' f → f τ' (monT A δ a)) id≤ τ c)

-- Fundamental theorem
-- Extension of T⟦_⟧ to contexts

G⟦_⟧ : ∀ (Γ Δ : Cxt) → Set
G⟦ ε     ⟧ Δ = ⊤
G⟦ Γ ∙ A ⟧ Δ = G⟦ Γ ⟧ Δ × T⟦ A ⟧ Δ

-- monG : ∀{Γ Δ Φ} (τ : Φ ≤ Δ) → G⟦ Γ ⟧ Δ → G⟦ Γ ⟧ Φ

monG : ∀{Γ} → Mon G⟦ Γ ⟧
monG {ε} τ _ = _
monG {Γ ∙ A} τ (γ , a) = monG τ γ , monT A τ a

-- Variable case.

lookup : ∀{Γ A} (x : Hyp A Γ) → G⟦ Γ ⟧ →̇ T⟦ A ⟧
lookup top     = proj₂
lookup (pop x) = lookup x ∘ proj₁

-- A lemma for the orE case.

orElim : ∀ A B C {Γ} → T⟦ A ∨ B ⟧ Γ → T⟦ A ⇒ C ⟧ Γ → T⟦ B ⇒ C ⟧ Γ → T⟦ C ⟧ Γ
orElim A B C c g h = paste C (mapC' (λ τ → [ g τ , h τ ]) c)

-- A lemma for the falseE case.

-- Casts an empty cover into any semantic value (by contradiction).

falseElim : ∀ C → T⟦ False ⟧ →̇ T⟦ C ⟧
falseElim C = paste C ∘ mapC ⊥-elim

-- The fundamental theorem

eval :  ∀{A Γ} (t : Γ ⊢ A) → G⟦ Γ ⟧ →̇ T⟦ A ⟧
eval (hyp x)           = lookup x
eval (impI t)    γ τ a = eval t (monG τ γ , a)
eval (impE t u)  γ     = eval t γ id≤ (eval u γ)
eval (andI t u)  γ     = eval t γ , eval u γ
eval (andE₁ t)         = proj₁ ∘ eval t
eval (andE₂ t)         = proj₂ ∘ eval t
eval (orI₁ t)    γ     = returnC (inj₁ (eval t γ))
eval (orI₂ t)    γ     = returnC (inj₂ (eval t γ))
eval (orE {A = A} {B} {C} t u v) γ = orElim A B C (eval t γ)
  (λ τ a → eval u (monG τ γ , a))
  (λ τ b → eval v (monG τ γ , b))
eval {C} (falseE t) γ  = falseElim C (eval t γ)
eval trueI       γ     = _

-- Identity environment

ide : ∀ Γ → G⟦ Γ ⟧ Γ
ide ε = _
ide (Γ ∙ A) = monG (weak id≤) (ide Γ) , reflect A (hyp top)

-- Normalization

norm : ∀{A} → Tm A →̇ Nf' A
norm t = reify _ (eval t (ide _))

-- Q.E.D. -}


-- Andreas, 2011-10-06
module Issue483b where

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

postulate
  A : Set
  f : .A → A

test : let X : .A → A
           X = _
       in .(x : A) → X (f x) ≡ f x
test x = refl
-- this gave an internal error before because X _ = f x
-- was solved by X = λ _ → f __IMPOSSIBLE__
--
-- Now one should get an unsolved meta


------------------------------------------------------------------------
-- Functors and natural transformations (for 1-categories)
------------------------------------------------------------------------

-- The code is based on the presentation in the HoTT book (but might
-- not follow it exactly).

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

open import Equality

module Functor
  {reflexive} (eq : ∀ {a p} → Equality-with-J a p reflexive) where

import Surjection

open import Bijection eq hiding (id; _∘_; inverse; step-↔; finally-↔)
open import Category eq
open Derived-definitions-and-properties eq
open import Equivalence eq as Eq using (_≃_; module _≃_; ↔⇒≃)
open import Function-universe eq hiding (id; _∘_)
open import H-level eq
open import H-level.Closure eq
open import Logical-equivalence using (_⇔_; module _⇔_)
open import Prelude as P hiding (id; _^_)

------------------------------------------------------------------------
-- Functors

Functor : ∀ {ℓ₁ ℓ₂ ℓ₃ ℓ₄} →
          Precategory ℓ₁ ℓ₂ → Precategory ℓ₃ ℓ₄ → Type _
Functor C D =
  -- Object map.
  ∃ λ (F₀ : Obj C → Obj D) →

  -- Morphism map.
  ∃ λ (F : ∀ {X Y} → Hom C X Y → Hom D (F₀ X) (F₀ Y)) →

  -- F should be homomorphic with respect to identity and composition.
  (∀ {X} → F (id C {X = X}) ≡ id D) ×
  (∀ {X Y Z} {f : Hom C X Y} {g : Hom C Y Z} →
     F (_∙_ C g f) ≡ _∙_ D (F g) (F f))

  where open Precategory

-- A wrapper.

infix 4 _⇨_

record _⇨_ {ℓ₁ ℓ₂ ℓ₃ ℓ₄}
           (C : Precategory ℓ₁ ℓ₂) (D : Precategory ℓ₃ ℓ₄) :
           Type (ℓ₁ ⊔ ℓ₂ ⊔ ℓ₃ ⊔ ℓ₄) where
  field
    functor : Functor C D

  open Precategory

  infixr 10 _⊚_ _⊙_

  -- Object map.

  _⊚_ : Obj C → Obj D
  _⊚_ = proj₁ functor

  -- Morphism map.

  _⊙_ : ∀ {X Y} → Hom C X Y → Hom D (_⊚_ X) (_⊚_ Y)
  _⊙_ = proj₁ (proj₂ functor)

  -- The morphism map is homomorphic with respect to identity.

  ⊙-id : ∀ {X} → _⊙_ (id C {X = X}) ≡ id D
  ⊙-id = proj₁ (proj₂ (proj₂ functor))

  -- The morphism map is homomorphic with respect to composition.

  ⊙-∙ : ∀ {X Y Z} {f : Hom C X Y} {g : Hom C Y Z} →
        _⊙_ (_∙_ C g f) ≡ _∙_ D (_⊙_ g) (_⊙_ f)
  ⊙-∙ = proj₂ (proj₂ (proj₂ functor))

open _⇨_ public

private
 module Dummy₁ where
  abstract

   -- The homomorphism properties are propositional (assuming
   -- extensionality).

   functor-properties-propositional :
     ∀ {ℓ₁ ℓ₂ ℓ₃ ℓ₄} →
     Extensionality (ℓ₁ ⊔ ℓ₂) (ℓ₁ ⊔ ℓ₂ ⊔ ℓ₄) →
     {C : Precategory ℓ₁ ℓ₂} {D : Precategory ℓ₃ ℓ₄}
     (F : C ⇨ D) → let open Precategory in

     Is-proposition ((∀ {X} → F ⊙ id C {X = X} ≡ id D) ×
                     (∀ {X Y Z} {f : Hom C X Y} {g : Hom C Y Z} →
                      F ⊙ (_∙_ C g f) ≡ _∙_ D (F ⊙ g) (F ⊙ f)))

   functor-properties-propositional {ℓ₁} {ℓ₂} ext {D = D} _ = ×-closure 1
     (implicit-Π-closure (lower-extensionality ℓ₂ (ℓ₁ ⊔ ℓ₂) ext) 1 λ _ →
      Precategory.Hom-is-set D)
     (implicit-Π-closure (lower-extensionality ℓ₂ lzero     ext) 1 λ _ →
      implicit-Π-closure (lower-extensionality ℓ₂ lzero     ext) 1 λ _ →
      implicit-Π-closure (lower-extensionality ℓ₂ ℓ₁        ext) 1 λ _ →
      implicit-Π-closure (lower-extensionality ℓ₁ ℓ₁        ext) 1 λ _ →
      implicit-Π-closure (lower-extensionality ℓ₁ (ℓ₁ ⊔ ℓ₂) ext) 1 λ _ →
      Precategory.Hom-is-set D)

open Dummy₁ public

private
 module Dummy₂ where
  abstract

   -- Functor equality is equivalent to equality of the corresponding
   -- maps, suitably transported (assuming extensionality).

   equality-characterisation⇨ :
     ∀ {ℓ₁ ℓ₂ ℓ₃ ℓ₄} →
     Extensionality (ℓ₁ ⊔ ℓ₂) (ℓ₁ ⊔ ℓ₂ ⊔ ℓ₄) →
     {C : Precategory ℓ₁ ℓ₂} {D : Precategory ℓ₃ ℓ₄} {F G : C ⇨ D} →
     let open Precategory in

     (F ≡ G)

       ≃

     ∃ λ (⊚F≡⊚G : _⊚_ F ≡ _⊚_ G) →
         _≡_ {A = ∀ {X Y} → Hom C X Y → Hom D (G ⊚ X) (G ⊚ Y)}
             (subst (λ F → ∀ {X Y} → Hom C X Y → Hom D (F X) (F Y))
                    ⊚F≡⊚G (_⊙_ F))
             (_⊙_ G)

   equality-characterisation⇨ ext {C} {D} {F} {G} =
     let P : (Obj C → Obj D) → Type _
         P = λ F₀ → ∀ {X Y} → Hom C X Y → Hom D (F₀ X) (F₀ Y)

         Q : ∃ P → Type _
         Q = λ { (F₀ , F) → (∀ {X} → F (id C {X = X}) ≡ id D) ×
                            (∀ {X Y Z} {f : Hom C X Y} {g : Hom C Y Z} →
                               F (_∙_ C g f) ≡ _∙_ D (F g) (F f)) }
     in

     (F ≡ G)                                                              ↝⟨ ↔⇒≃ record
                                                                               { surjection = record
                                                                                { logical-equivalence = record
                                                                                { to   = cong functor
                                                                                ; from = cong λ f → record { functor = f }
                                                                                }
                                                                                ; right-inverse-of = λ _ → trans (cong-∘ _ _ _) (sym $ cong-id _)
                                                                                }
                                                                               ; left-inverse-of = λ _ → trans (cong-∘ _ _ _) (sym $ cong-id _)
                                                                               } ⟩
     (functor F ≡ functor G)                                              ↔⟨ inverse Σ-≡,≡↔≡ ⟩

     (∃ λ (⊚F≡⊚G : _⊚_ F ≡ _⊚_ G) →
          subst (λ F₀ → ∃ λ (F : P F₀) → Q (F₀ , F)) ⊚F≡⊚G
                (proj₂ $ functor F) ≡ proj₂ (functor G))                  ↝⟨ ∃-cong (λ ⊚F≡⊚G → ≡⇒↝ _ $ cong (λ x → x ≡ proj₂ (functor G)) $
                                                                               push-subst-pair P Q) ⟩
     (∃ λ (⊚F≡⊚G : _⊚_ F ≡ _⊚_ G) →
          _≡_ {A = ∃ λ (H : P (_⊚_ G)) → Q (_⊚_ G , H)}
          ( subst P ⊚F≡⊚G (_⊙_ F)
          , subst Q (Σ-≡,≡→≡ ⊚F≡⊚G (refl _)) (proj₂ $ proj₂ $ functor F)
          )
          (proj₂ (functor G)))                                            ↔⟨ ∃-cong (λ ⊚F≡⊚G → inverse $
                                                                               ignore-propositional-component
                                                                                (functor-properties-propositional ext G)) ⟩□
     (∃ λ (⊚F≡⊚G : _⊚_ F ≡ _⊚_ G) →
          (λ {_ _} → subst P ⊚F≡⊚G (_⊙_ F)) ≡ _⊙_ G)                      □

     where open Precategory

   -- Some simplification lemmas.

   proj₁-to-equality-characterisation⇨ :
     ∀ {ℓ₁ ℓ₂ ℓ₃ ℓ₄}
     (ext : Extensionality (ℓ₁ ⊔ ℓ₂) (ℓ₁ ⊔ ℓ₂ ⊔ ℓ₄))
     {C : Precategory ℓ₁ ℓ₂} {D : Precategory ℓ₃ ℓ₄} {F G : C ⇨ D} →
     let open Precategory in
     (F≡G : F ≡ G) →

     proj₁ (_≃_.to (equality-characterisation⇨ ext {F = F} {G = G}) F≡G)
       ≡
     cong _⊚_ F≡G

   proj₁-to-equality-characterisation⇨ ext F≡G =
     proj₁ (_≃_.to (equality-characterisation⇨ ext) F≡G)  ≡⟨ proj₁-Σ-≡,≡←≡ _ ⟩
     cong proj₁ (cong functor F≡G)                        ≡⟨ cong-∘ _ _ _ ⟩∎
     cong _⊚_ F≡G                                         ∎

   cong-⊚-from-equality-characterisation⇨ :
     ∀ {ℓ₁ ℓ₂ ℓ₃ ℓ₄}
     (ext : Extensionality (ℓ₁ ⊔ ℓ₂) (ℓ₁ ⊔ ℓ₂ ⊔ ℓ₄))
     {C : Precategory ℓ₁ ℓ₂} {D : Precategory ℓ₃ ℓ₄} {F G : C ⇨ D} →
     let open Precategory in
     (⊚F≡⊚G : _⊚_ F ≡ _⊚_ G) →
     (⊙F≡⊙G : _≡_ {A = ∀ {X Y} → Hom C X Y → Hom D (G ⊚ X) (G ⊚ Y)}
                  (subst (λ F → ∀ {X Y} → Hom C X Y → Hom D (F X) (F Y))
                         ⊚F≡⊚G (_⊙_ F))
                  (_⊙_ G)) →

     cong _⊚_ (_≃_.from (equality-characterisation⇨ ext {F = F} {G = G})
                        (⊚F≡⊚G , ⊙F≡⊙G))
       ≡
     ⊚F≡⊚G

   cong-⊚-from-equality-characterisation⇨ ext {F = F} {G} ⊚F≡⊚G ⊙F≡⊙G =
     cong _⊚_ (_≃_.from (equality-characterisation⇨ ext {F = F} {G = G})
                        (⊚F≡⊚G , ⊙F≡⊙G))                                  ≡⟨ cong-∘ _ _ _ ⟩

     cong proj₁ (Σ-≡,≡→≡ ⊚F≡⊚G _)                                         ≡⟨ proj₁-Σ-≡,≡→≡ _ _ ⟩∎

     ⊚F≡⊚G                                                                ∎

open Dummy₂ public

private
 module Dummy₃ where
  abstract

   -- Another equality characterisation lemma.

   equality-characterisation≡⇨ :
     ∀ {ℓ₁ ℓ₂ ℓ₃ ℓ₄} →
     Extensionality (ℓ₁ ⊔ ℓ₂) (ℓ₁ ⊔ ℓ₂ ⊔ ℓ₄) →
     {C : Precategory ℓ₁ ℓ₂} {D : Precategory ℓ₃ ℓ₄} {F G : C ⇨ D}
     {eq₁ eq₂ : F ≡ G} →
     (eq₁ ≡ eq₂) ≃ (cong _⊚_ eq₁ ≡ cong _⊚_ eq₂)
   equality-characterisation≡⇨ {ℓ₁} {ℓ₂} ext {D = D} {eq₁ = eq₁} {eq₂} =
     eq₁ ≡ eq₂                                              ↝⟨ inverse $ Eq.≃-≡ (equality-characterisation⇨ ext) ⟩

     _≃_.to (equality-characterisation⇨ ext) eq₁ ≡
     _≃_.to (equality-characterisation⇨ ext) eq₂            ↔⟨ inverse $ ignore-propositional-component
                                                                 (implicit-Π-closure (lower-extensionality ℓ₂ lzero     ext) 2 λ _ →
                                                                  implicit-Π-closure (lower-extensionality ℓ₂ ℓ₁        ext) 2 λ _ →
                                                                  Π-closure          (lower-extensionality ℓ₁ (ℓ₁ ⊔ ℓ₂) ext) 2 λ _ →
                                                                  Precategory.Hom-is-set D) ⟩
     proj₁ (_≃_.to (equality-characterisation⇨ ext) eq₁) ≡
     proj₁ (_≃_.to (equality-characterisation⇨ ext) eq₂)    ↝⟨ ≡⇒↝ _ (cong₂ _≡_ (proj₁-to-equality-characterisation⇨ _ _)
                                                                                (proj₁-to-equality-characterisation⇨ _ _)) ⟩□
     cong _⊚_ eq₁ ≡ cong _⊚_ eq₂                            □

open Dummy₃ public

-- Identity functor.

id⇨ : ∀ {ℓ₁ ℓ₂} {C : Precategory ℓ₁ ℓ₂} → C ⇨ C
functor id⇨ = P.id , P.id , refl _ , refl _

-- Composition of functors.

infixr 10 _∙⇨_

_∙⇨_ : ∀ {ℓ₁ ℓ₂} {C : Precategory ℓ₁ ℓ₂}
         {ℓ₃ ℓ₄} {D : Precategory ℓ₃ ℓ₄}
         {ℓ₅ ℓ₆} {E : Precategory ℓ₅ ℓ₆} →
       D ⇨ E → C ⇨ D → C ⇨ E
functor (_∙⇨_ {C = C} {D = D} {E = E} G F) =
  (G ⊚_) ∘ (F ⊚_) ,
  (G ⊙_) ∘ (F ⊙_) ,
  (G ⊙ F ⊙ id C              ≡⟨ cong (G ⊙_) $ ⊙-id F ⟩
   G ⊙ id D                  ≡⟨ ⊙-id G ⟩∎
   id E                      ∎) ,
  (λ {_ _ _ f g} →
     G ⊙ F ⊙ _∙_ C g f              ≡⟨ cong (G ⊙_) $ ⊙-∙ F ⟩
     G ⊙ _∙_ D (F ⊙ g) (F ⊙ f)      ≡⟨ ⊙-∙ G ⟩∎
     _∙_ E (G ⊙ F ⊙ g) (G ⊙ F ⊙ f)  ∎)
  where
  open Precategory

-- id⇨ is a left identity (assuming extensionality).

id⇨∙⇨ :
  ∀ {ℓ₁ ℓ₂} {C : Precategory ℓ₁ ℓ₂}
    {ℓ₃ ℓ₄} {D : Precategory ℓ₃ ℓ₄} →
  Extensionality (ℓ₁ ⊔ ℓ₂) (ℓ₁ ⊔ ℓ₂ ⊔ ℓ₄) →
  {F : C ⇨ D} → id⇨ ∙⇨ F ≡ F
id⇨∙⇨ ext {F} = _≃_.from (equality-characterisation⇨ ext)
  ( refl (F ⊚_)
  , (subst _ (refl (F ⊚_)) (λ {_ _} → F ⊙_)  ≡⟨ subst-refl _ _ ⟩∎
     (λ {_ _} → F ⊙_)                        ∎)
  )

-- id⇨ is a right identity (assuming extensionality).

∙⇨id⇨ :
  ∀ {ℓ₁ ℓ₂} {C : Precategory ℓ₁ ℓ₂}
    {ℓ₃ ℓ₄} {D : Precategory ℓ₃ ℓ₄} →
  Extensionality (ℓ₁ ⊔ ℓ₂) (ℓ₁ ⊔ ℓ₂ ⊔ ℓ₄) →
  {F : C ⇨ D} → F ∙⇨ id⇨ ≡ F
∙⇨id⇨ ext {F} = _≃_.from (equality-characterisation⇨ ext)
  ( refl (F ⊚_)
  , (subst _ (refl (F ⊚_)) (λ {_ _} → F ⊙_)  ≡⟨ subst-refl _ _ ⟩∎
     (λ {_ _} → F ⊙_)                        ∎)
  )

-- _∙⇨_ is associative (assuming extensionality).

∙⇨-assoc :
  ∀ {ℓ₁ ℓ₂} {C₁ : Precategory ℓ₁ ℓ₂}
    {ℓ₃ ℓ₄} {C₂ : Precategory ℓ₃ ℓ₄}
    {ℓ₅ ℓ₆} {C₃ : Precategory ℓ₅ ℓ₆}
    {ℓ₇ ℓ₈} {C₄ : Precategory ℓ₇ ℓ₈} →
  Extensionality (ℓ₁ ⊔ ℓ₂) (ℓ₁ ⊔ ℓ₂ ⊔ ℓ₈) →
  (F : C₃ ⇨ C₄) (G : C₂ ⇨ C₃) {H : C₁ ⇨ C₂} →
  F ∙⇨ (G ∙⇨ H) ≡ (F ∙⇨ G) ∙⇨ H
∙⇨-assoc ext F G {H} = _≃_.from (equality-characterisation⇨ ext)
  ( refl _
  , (subst _ (refl _) (λ {_ _} → (F ∙⇨ G ∙⇨ H) ⊙_)  ≡⟨ subst-refl _ _ ⟩
     (λ {_ _} → (F ∙⇨ G ∙⇨ H) ⊙_)                   ∎)
  )

------------------------------------------------------------------------
-- Natural transformations

Natural-transformation :
  ∀ {ℓ₁ ℓ₂} {C : Precategory ℓ₁ ℓ₂}
    {ℓ₃ ℓ₄} {D : Precategory ℓ₃ ℓ₄} →
  C ⇨ D → C ⇨ D → Type _
Natural-transformation {C = C} {D = D} F G =
  -- Morphisms.
  ∃ λ (γ : ∀ {X} → Hom D (F ⊚ X) (G ⊚ X)) →

  -- Naturality.
  ∀ {X Y} {f : Hom C X Y} → (G ⊙ f) ∙ γ ≡ γ ∙ (F ⊙ f)

  where
  open Precategory hiding (_∙_)
  open Precategory D using (_∙_)

-- A wrapper.

infix 4 _⇾_

record _⇾_ {ℓ₁ ℓ₂} {C : Precategory ℓ₁ ℓ₂}
           {ℓ₃ ℓ₄} {D : Precategory ℓ₃ ℓ₄}
           (F G : C ⇨ D) : Type (ℓ₁ ⊔ ℓ₂ ⊔ ℓ₃ ⊔ ℓ₄) where
  field
    natural-transformation : Natural-transformation F G

  open Precategory hiding (_∙_)
  open Precategory D using (_∙_)

  -- Morphisms.

  transformation : ∀ {X} → Hom D (F ⊚ X) (G ⊚ X)
  transformation = proj₁ natural-transformation

  -- Naturality.

  natural : ∀ {X Y} {f : Hom C X Y} →
            (G ⊙ f) ∙ transformation ≡ transformation ∙ (F ⊙ f)
  natural = proj₂ natural-transformation

private
 module Dummy₄ where
  abstract

   -- The naturality property is a proposition (assuming
   -- extensionality).

   naturality-propositional :
     ∀ {ℓ₁ ℓ₂ ℓ₃ ℓ₄} →
     Extensionality (ℓ₁ ⊔ ℓ₂) (ℓ₁ ⊔ ℓ₂ ⊔ ℓ₄) →
     {C : Precategory ℓ₁ ℓ₂} {D : Precategory ℓ₃ ℓ₄}
     (F G : C ⇨ D) →
     let open Precategory hiding (_∙_); open Precategory D using (_∙_) in
     {transformation : ∀ {X} → Hom D (F ⊚ X) (G ⊚ X)} →

     Is-proposition (∀ {X Y} {f : Hom C X Y} →
                     (G ⊙ f) ∙ transformation ≡
                     transformation ∙ (F ⊙ f))

   naturality-propositional {ℓ₁} {ℓ₂} ext {D = D} _ _ =
     implicit-Π-closure (lower-extensionality ℓ₂ lzero     ext) 1 λ _ →
     implicit-Π-closure (lower-extensionality ℓ₂ ℓ₁        ext) 1 λ _ →
     implicit-Π-closure (lower-extensionality ℓ₁ (ℓ₁ ⊔ ℓ₂) ext) 1 λ _ →
     Precategory.Hom-is-set D

   -- Natural transformation equality is equivalent to pointwise
   -- equality of the corresponding "transformations" (assuming
   -- extensionality).

   equality-characterisation⇾ :
     ∀ {ℓ₁ ℓ₂ ℓ₃ ℓ₄} →
     Extensionality (ℓ₁ ⊔ ℓ₂) (ℓ₁ ⊔ ℓ₂ ⊔ ℓ₄) →
     {C : Precategory ℓ₁ ℓ₂} {D : Precategory ℓ₃ ℓ₄}
     {F G : C ⇨ D} {γ δ : F ⇾ G} →

     (γ ≡ δ)
       ≃
     (∀ {X} → _⇾_.transformation γ {X = X} ≡
              _⇾_.transformation δ {X = X})

   equality-characterisation⇾ {ℓ₁} {ℓ₂} ext {F = F} {G} {γ} {δ} =
     γ ≡ δ                                                          ↝⟨ inverse $ Eq.≃-≡ $ ↔⇒≃ record
                                                                         { surjection = record
                                                                           { logical-equivalence = record
                                                                             { to   = _⇾_.natural-transformation
                                                                             ; from = λ γ → record { natural-transformation = γ }
                                                                             }
                                                                           ; right-inverse-of = refl
                                                                           }
                                                                         ; left-inverse-of = refl
                                                                         } ⟩
     _⇾_.natural-transformation γ ≡ _⇾_.natural-transformation δ    ↔⟨ inverse $ ignore-propositional-component
                                                                                (naturality-propositional ext F G) ⟩
     (λ {X} → _⇾_.transformation γ {X = X}) ≡ _⇾_.transformation δ  ↝⟨ inverse $ Eq.≃-≡ (Eq.↔⇒≃ implicit-Π↔Π) ⟩

     (λ X → _⇾_.transformation γ {X = X}) ≡
     (λ X → _⇾_.transformation δ {X = X})                           ↝⟨ inverse $ Eq.extensionality-isomorphism
                                                                                (lower-extensionality ℓ₂ (ℓ₁ ⊔ ℓ₂) ext) ⟩
     (∀ X → _⇾_.transformation γ {X = X} ≡
            _⇾_.transformation δ {X = X})                           ↔⟨ inverse implicit-Π↔Π ⟩□

     (∀ {X} → _⇾_.transformation γ {X = X} ≡
              _⇾_.transformation δ {X = X})                         □

   -- Natural transformations form sets (assuming extensionality).

   ⇾-set :
     ∀ {ℓ₁ ℓ₂ ℓ₃ ℓ₄} →
     Extensionality (ℓ₁ ⊔ ℓ₂) (ℓ₁ ⊔ ℓ₂ ⊔ ℓ₄) →
     {C : Precategory ℓ₁ ℓ₂} {D : Precategory ℓ₃ ℓ₄} {F G : C ⇨ D} →
     Is-set (F ⇾ G)
   ⇾-set {ℓ₁} {ℓ₂} ext {D = D} {F = F} {G = G} =
     let surj = record
           { logical-equivalence = record
             { to   = λ γ → record { natural-transformation = γ }
             ; from = _⇾_.natural-transformation
             }
           ; right-inverse-of = refl
           } in

     respects-surjection surj 2 $
       Σ-closure 2
         (implicit-Π-closure
            (lower-extensionality ℓ₂ (ℓ₁ ⊔ ℓ₂) ext) 2 λ _ →
          Precategory.Hom-is-set D)
         (λ _ → mono₁ 1 $ naturality-propositional ext F G)

open Dummy₄ public

-- Identity natural transformation.

id⇾ : ∀ {ℓ₁ ℓ₂} {C : Precategory ℓ₁ ℓ₂}
        {ℓ₃ ℓ₄} {D : Precategory ℓ₃ ℓ₄}
      (F : C ⇨ D) → F ⇾ F
id⇾ {C = C} {D = D} F =
  record { natural-transformation = id , Dummy₅.nat }
  where
  open Precategory D

  module Dummy₅ where
   abstract

    nat : ∀ {X Y} {f : Precategory.Hom C X Y} →
          (F ⊙ f) ∙ id ≡ id ∙ (F ⊙ f)
    nat {f = f} =
      (F ⊙ f) ∙ id  ≡⟨ right-identity ⟩
      F ⊙ f         ≡⟨ sym $ left-identity ⟩∎
      id ∙ (F ⊙ f)  ∎

-- Composition of natural transformations.

infixr 10 _∙⇾_

_∙⇾_ : ∀ {ℓ₁ ℓ₂} {C : Precategory ℓ₁ ℓ₂}
         {ℓ₃ ℓ₄} {D : Precategory ℓ₃ ℓ₄}
         {F G H : C ⇨ D} →
       G ⇾ H → F ⇾ G → F ⇾ H
_∙⇾_ {C = C} {D = D} {F} {G} {H} γ δ =
  record { natural-transformation = ε , Dummy₅.nat }
  where
  open Precategory D
  open _⇾_

  ε : ∀ {X} → Hom (F ⊚ X) (H ⊚ X)
  ε = transformation γ ∙ transformation δ

  module Dummy₅ where
   abstract

    nat : ∀ {X Y} {f : Precategory.Hom C X Y} →
          (H ⊙ f) ∙ ε ≡ ε ∙ (F ⊙ f)
    nat {f = f} =
      (H ⊙ f) ∙ (transformation γ ∙ transformation δ)  ≡⟨ assoc ⟩
      ((H ⊙ f) ∙ transformation γ) ∙ transformation δ  ≡⟨ cong (λ f → f ∙ _) $ natural γ ⟩
      (transformation γ ∙ (G ⊙ f)) ∙ transformation δ  ≡⟨ sym assoc ⟩
      transformation γ ∙ ((G ⊙ f) ∙ transformation δ)  ≡⟨ cong (_∙_ _) $ natural δ ⟩
      transformation γ ∙ (transformation δ ∙ (F ⊙ f))  ≡⟨ assoc ⟩∎
      (transformation γ ∙ transformation δ) ∙ (F ⊙ f)  ∎

-- Composition of functors and natural transformations.

infixr 10 _⇾∙⇨_ _⇨∙⇾_

_⇾∙⇨_ : ∀ {ℓ₁ ℓ₂} {C : Precategory ℓ₁ ℓ₂}
          {ℓ₃ ℓ₄} {D : Precategory ℓ₃ ℓ₄}
          {ℓ₅ ℓ₆} {E : Precategory ℓ₅ ℓ₆}
          {G H : D ⇨ E} →
        G ⇾ H → (F : C ⇨ D) → (G ∙⇨ F) ⇾ (H ∙⇨ F)
_⇾_.natural-transformation (γ ⇾∙⇨ _) = transformation , natural
  where
  open _⇾_ γ

_⇨∙⇾_ : ∀ {ℓ₁ ℓ₂} {C : Precategory ℓ₁ ℓ₂}
          {ℓ₃ ℓ₄} {D : Precategory ℓ₃ ℓ₄}
          {ℓ₅ ℓ₆} {E : Precategory ℓ₅ ℓ₆}
          {G H : C ⇨ D} →
        (F : D ⇨ E) → G ⇾ H → (F ∙⇨ G) ⇾ (F ∙⇨ H)
_⇾_.natural-transformation (_⇨∙⇾_ {C = C} {D = D} {E = E} {G} {H} F γ) =
  ε , Dummy₅.nat
  where
  open Precategory
  open _⇾_ γ

  ε : ∀ {X} → Hom E (F ⊚ G ⊚ X) (F ⊚ H ⊚ X)
  ε = F ⊙ transformation

  module Dummy₅ where
   abstract

    nat : ∀ {X Y} {f : Hom C X Y} →
          _∙_ E (F ⊙ H ⊙ f) ε ≡ _∙_ E ε (F ⊙ G ⊙ f)
    nat {f = f} =
      _∙_ E (F ⊙ H ⊙ f) (F ⊙ transformation)  ≡⟨ sym $ ⊙-∙ F ⟩
      F ⊙ _∙_ D (H ⊙ f) transformation        ≡⟨ cong (F ⊙_) natural ⟩
      F ⊙ _∙_ D transformation (G ⊙ f)        ≡⟨ ⊙-∙ F ⟩∎
      _∙_ E (F ⊙ transformation) (F ⊙ G ⊙ f)  ∎

------------------------------------------------------------------------
-- Functor precategories

-- Functor precategories are defined using extensionality.

infix 10 _^_

_^_ : ∀ {ℓ₁ ℓ₂ ℓ₃ ℓ₄} →
      Precategory ℓ₁ ℓ₂ → Precategory ℓ₃ ℓ₄ →
      Extensionality (ℓ₃ ⊔ ℓ₄) (ℓ₂ ⊔ ℓ₃ ⊔ ℓ₄) →
      Precategory _ _
(D ^ C) ext = record
  { precategory =
        (C ⇨ D)
      , (λ F G → (F ⇾ G) , ⇾-set ext)
      , id⇾ _
      , _∙⇾_
      , _≃_.from (equality-characterisation⇾ ext) left-identity
      , _≃_.from (equality-characterisation⇾ ext) right-identity
      , _≃_.from (equality-characterisation⇾ ext) assoc
  }
  where
  open Precategory D

private
 module Dummy₅ where
  abstract

   -- The natural transformation γ is an isomorphism in (D ^ C) ext iff
   -- _⇾_.transformation γ {X = X} is an isomorphism in D for every X.

   natural-isomorphism-lemma :
     ∀ {ℓ₁ ℓ₂ ℓ₃ ℓ₄}
     (ext : Extensionality (ℓ₁ ⊔ ℓ₂) (ℓ₁ ⊔ ℓ₂ ⊔ ℓ₄)) →
     {C : Precategory ℓ₁ ℓ₂} {D : Precategory ℓ₃ ℓ₄}
     {F G : C ⇨ D} {γ : F ⇾ G} → let open Precategory in

     Is-isomorphism ((D ^ C) ext) γ ⇔
     (∀ {X} → Is-isomorphism D (_⇾_.transformation γ {X = X}))

   natural-isomorphism-lemma ext {D = D} {F} {G} {γ} = record
     { to = λ { (δ , γδ , δγ) →
         transformation δ ,
         (transformation γ ∙ transformation δ  ≡⟨⟩
          transformation (γ ∙⇾ δ)              ≡⟨ cong (λ ε → transformation ε) γδ ⟩
          transformation (id⇾ G)               ≡⟨⟩
          id                                   ∎) ,
         (transformation δ ∙ transformation γ  ≡⟨⟩
          transformation (δ ∙⇾ γ)              ≡⟨ cong (λ ε → transformation ε) δγ ⟩
          transformation (id⇾ F)               ≡⟨⟩
          id                                   ∎) }
     ; from = λ iso →
         record { natural-transformation =
           proj₁ iso ,
           (λ {_ _ f} →
                (F ⊙ f) ∙ proj₁ iso                                     ≡⟨ sym left-identity ⟩
                id ∙ (F ⊙ f) ∙ proj₁ iso                                ≡⟨ cong (λ g → g ∙ (F ⊙ f) ∙ proj₁ iso) $ sym $ proj₂ (proj₂ iso) ⟩
                (proj₁ iso ∙ transformation γ) ∙ (F ⊙ f) ∙ proj₁ iso    ≡⟨ sym assoc ⟩
                proj₁ iso ∙ (transformation γ ∙ (F ⊙ f) ∙ proj₁ iso)    ≡⟨ cong (_ ∙_) assoc ⟩
                proj₁ iso ∙ ((transformation γ ∙ (F ⊙ f)) ∙ proj₁ iso)  ≡⟨ cong (λ g → _ ∙ (g ∙ _)) $ sym $ natural γ ⟩
                proj₁ iso ∙ (((G ⊙ f) ∙ transformation γ) ∙ proj₁ iso)  ≡⟨ cong (_ ∙_) $ sym assoc ⟩
                proj₁ iso ∙ (G ⊙ f) ∙ (transformation γ ∙ proj₁ iso)    ≡⟨ cong ((_ ∙_) ∘ ((G ⊙ f) ∙_)) $ proj₁ (proj₂ iso) ⟩
                proj₁ iso ∙ (G ⊙ f) ∙ id                                ≡⟨ assoc ⟩
                (proj₁ iso ∙ (G ⊙ f)) ∙ id                              ≡⟨ right-identity ⟩∎
                proj₁ iso ∙ (G ⊙ f)                                     ∎) } ,
         _≃_.from (equality-characterisation⇾ ext) (proj₁ (proj₂ iso)) ,
         _≃_.from (equality-characterisation⇾ ext) (proj₂ (proj₂ iso))
     }
     where
     open Precategory D
     open _⇾_

open Dummy₅ public

abstract

  -- If D is a category, then (D ^ C) ext is also a category.

  infix 10 _↑_

  _↑_ : ∀ {ℓ₁ ℓ₂ ℓ₃ ℓ₄} →
        Category ℓ₁ ℓ₂ → Precategory ℓ₃ ℓ₄ →
        Extensionality (ℓ₃ ⊔ ℓ₄) (ℓ₁ ⊔ ℓ₂ ⊔ ℓ₃ ⊔ ℓ₄) →
        Category (ℓ₁ ⊔ ℓ₂ ⊔ ℓ₃ ⊔ ℓ₄) (ℓ₁ ⊔ ℓ₂ ⊔ ℓ₃ ⊔ ℓ₄)
  _↑_ {ℓ₁} {ℓ₂} {ℓ₃} {ℓ₄} D C ext = record { category =
    D^C ,

    (λ {F G} → _≃_.is-equivalence $ ↔⇒≃ $ record
       { surjection = record
         { logical-equivalence = record
           { to   = Precategory.≡→≅ D^C
           ; from = λ { (F⇾G , F⇾G-iso) →

               let γ : ∀ X → F ⊚ X ≅ G ⊚ X
                   γ _ = _⇾_.transformation F⇾G ,
                         _⇔_.to (natural-isomorphism-lemma ext₁) F⇾G-iso

                   ⊚F≡⊚G : _⊚_ F ≡ _⊚_ G
                   ⊚F≡⊚G = apply-ext (Eq.good-ext ext₂) λ X →
                     F ⊚ X  ≡⟨ ≅→≡ (γ X) ⟩∎
                     G ⊚ X  ∎

                   cong-⊚F≡⊚G : ∀ {X} → cong (λ H → H X) ⊚F≡⊚G ≡ ≅→≡ (γ X)
                   cong-⊚F≡⊚G = Eq.cong-good-ext ext₂ (≅→≡ ∘ γ)

                   ⊙F≡⊙G : _≡_ {A = ∀ {X Y} → HomC X Y → Hom (G ⊚ X) (G ⊚ Y)}
                               (subst (λ F → ∀ {X Y} → HomC X Y → Hom (F X) (F Y))
                                      ⊚F≡⊚G
                                      (_⊙_ F))
                               (_⊙_ G)
                   ⊙F≡⊙G =
                     implicit-extensionality (lower-extensionality ℓ₄ ℓ₁        ext) λ X →
                     implicit-extensionality (lower-extensionality ℓ₄ (ℓ₁ ⊔ ℓ₃) ext) λ Y →
                     apply-ext (lower-extensionality ℓ₃ (ℓ₁ ⊔ ℓ₃ ⊔ ℓ₄) ext) λ f →

                     subst (λ F → ∀ {X Y} → HomC X Y → Hom (F X) (F Y))
                           ⊚F≡⊚G (_⊙_ F) f                               ≡⟨ cong (λ H → H f) $ sym $
                                                                                push-subst-implicit-application ⊚F≡⊚G
                                                                                (λ F X → ∀ {Y} → HomC X Y → Hom (F X) (F Y)) ⟩
                     subst (λ F → ∀ {Y} → HomC X Y → Hom (F X) (F Y))
                           ⊚F≡⊚G (_⊙_ F) f                               ≡⟨ cong (λ H → H f) $ sym $
                                                                                push-subst-implicit-application ⊚F≡⊚G
                                                                                (λ F Y → HomC X Y → Hom (F X) (F Y)) ⟩
                     subst (λ F → HomC X Y → Hom (F X) (F Y))
                           ⊚F≡⊚G (_⊙_ F) f                               ≡⟨ sym $ push-subst-application ⊚F≡⊚G
                                                                                (λ F _ → Hom (F X) (F Y)) ⟩
                     subst (λ F → Hom (F X) (F Y)) ⊚F≡⊚G (F ⊙ f)         ≡⟨ subst-∘ (uncurry Hom) (λ H → (H X , H Y)) ⊚F≡⊚G ⟩

                     subst (uncurry Hom)
                           (cong (λ H → (H X , H Y)) ⊚F≡⊚G) (F ⊙ f)      ≡⟨ cong (λ p → subst (uncurry Hom) p (F ⊙ f)) $ sym $
                                                                                cong₂-cong-cong {eq = ⊚F≡⊚G} (λ H → H X) (λ H → H Y) _,_ ⟩
                     subst (uncurry Hom)
                           (cong₂ _,_ (cong (λ H → H X) ⊚F≡⊚G)
                                      (cong (λ H → H Y) ⊚F≡⊚G)) (F ⊙ f)  ≡⟨ cong₂ (λ p q → subst (uncurry Hom) (cong₂ _,_ p q) (F ⊙ f))
                                                                                cong-⊚F≡⊚G cong-⊚F≡⊚G ⟩
                     subst (uncurry Hom)
                           (cong₂ _,_ (≅→≡ (γ X)) (≅→≡ (γ Y))) (F ⊙ f)   ≡⟨ Hom-, (≅→≡ (γ X)) (≅→≡ (γ Y)) ⟩

                     ≡→≅ (≅→≡ (γ Y)) ¹ ∙ (F ⊙ f) ∙ ≡→≅ (≅→≡ (γ X)) ⁻¹    ≡⟨ cong₂ (λ p q → p ¹ ∙ (F ⊙ f) ∙ q ⁻¹)
                                                                                (_≃_.right-inverse-of ≡≃≅ _)
                                                                                (_≃_.right-inverse-of ≡≃≅ _) ⟩
                     γ Y ¹ ∙ (F ⊙ f) ∙ γ X ⁻¹                            ≡⟨ assoc ⟩

                     (γ Y ¹ ∙ (F ⊙ f)) ∙ γ X ⁻¹                          ≡⟨ cong (_∙ γ X ⁻¹) $ sym $ _⇾_.natural F⇾G ⟩

                     ((G ⊙ f) ∙ γ X ¹) ∙ γ X ⁻¹                          ≡⟨ sym assoc ⟩

                     (G ⊙ f) ∙ γ X ¹ ∙ γ X ⁻¹                            ≡⟨ cong (_ ∙_) $ γ X ¹⁻¹ ⟩

                     (G ⊙ f) ∙ id                                        ≡⟨ right-identity ⟩∎

                     G ⊙ f                                               ∎

               in _≃_.from (equality-characterisation⇨ ext₁)
                           (⊚F≡⊚G , ⊙F≡⊙G) }
           }
         ; right-inverse-of = λ { (F⇾G , F⇾G-iso) →
             _≃_.from (Precategory.≡≃≡¹ D^C) $
             _≃_.from (equality-characterisation⇾ ext₁) λ {X} →
               _⇾_.transformation (proj₁ (Precategory.≡→≅ D^C _))         ≡⟨⟩

               _⇾_.transformation
                 (proj₁ (elim (λ {F G} _ → Precategory._≅_ D^C F G)
                              (λ _ → Precategory.id≅ D^C) _))             ≡⟨ elim (λ {F G} F≡G →
                                                                                _⇾_.transformation (proj₁ (Precategory.≡→≅ D^C F≡G)) ≡
                                                                                elim (λ {F G} _ → Hom (F X) (G X)) (λ _ → id) (cong _⊚_ F≡G))
                                                                                (λ F →
                   _⇾_.transformation
                     (proj₁ (elim (λ {F G} _ → Precategory._≅_ D^C F G)
                                  (λ _ → Precategory.id≅ D^C) (refl F)))             ≡⟨ cong (λ f → _⇾_.transformation (proj₁ f) {X = X}) $
                                                                                elim-refl (λ {X Y} _ → Precategory._≅_ D^C X Y) _ ⟩
                   _⇾_.transformation {F = F}
                     (proj₁ (Precategory.id≅ D^C))                                   ≡⟨⟩

                   id                                                                ≡⟨ sym $ elim-refl (λ {F G} _ → Hom (F X) (G X)) _ ⟩

                   elim (λ {F G} _ → Hom (F X) (G X))
                        (λ _ → id) (refl (_⊚_ F))                                    ≡⟨ cong (elim (λ {F G} _ → Hom (F X) (G X)) _) $
                                                                                sym $ cong-refl _⊚_ ⟩∎
                   elim (λ {F G} _ → Hom (F X) (G X))
                        (λ _ → id) (cong _⊚_ (refl F))                               ∎)
                                                                                _ ⟩
               elim (λ {F G} _ → Hom (F X) (G X))
                    (λ _ → id) (cong _⊚_ _)                               ≡⟨ cong (elim (λ {F G} _ → Hom (F X) (G X)) (λ _ → id)) $
                                                                               cong-⊚-from-equality-characterisation⇨ _ _ _ ⟩
               elim (λ {F G} _ → Hom (F X) (G X)) (λ _ → id)
                    (apply-ext (Eq.good-ext ext₂) λ Y →
                       ≅→≡ (_⇾_.transformation F⇾G {X = Y} , _))          ≡⟨ Eq.elim-good-ext ext₂ _ _ _ ⟩

               elim (λ {X Y} _ → Hom X Y) (λ _ → id)
                    (≅→≡ (_⇾_.transformation F⇾G {X = X} , _))            ≡⟨ elim (λ {X Y} X≡Y → elim (λ {X Y} _ → Hom X Y) (λ _ → id) X≡Y ≡
                                                                                proj₁ (≡→≅ X≡Y))
                                                                                (λ X →
                   elim (λ {X Y} _ → Hom X Y) (λ _ → id) (refl X)                    ≡⟨ elim-refl (λ {X Y} _ → Hom X Y) _ ⟩
                   id                                                                ≡⟨⟩
                   proj₁ id≅                                                         ≡⟨ cong proj₁ (sym ≡→≅-refl) ⟩∎
                   proj₁ (≡→≅ (refl X))                                              ∎ )
                                                                                _ ⟩
               proj₁ (≡→≅ (≅→≡ (_⇾_.transformation F⇾G {X = X} , _)))     ≡⟨ cong proj₁ (_≃_.right-inverse-of ≡≃≅ _) ⟩∎

               _⇾_.transformation F⇾G {X = X}                             ∎ }
           }
       ; left-inverse-of = λ F≡G →
           _≃_.from (equality-characterisation≡⇨ ext₁) (
              cong _⊚_ _                                           ≡⟨ cong-⊚-from-equality-characterisation⇨ _ _ _ ⟩

              apply-ext (Eq.good-ext ext₂) (λ X →
                ≅→≡ ( _⇾_.transformation
                        (proj₁ $ Precategory.≡→≅ D^C F≡G) {X = X}
                    , _
                    ))                                             ≡⟨ elim
                                                                        (λ {F G} F≡G → (f : (X : _) → _) →
                                                                           apply-ext (Eq.good-ext ext₂) (λ X →
                                                                             ≅→≡ (_⇾_.transformation (proj₁ $ Precategory.≡→≅ D^C F≡G) , f X)) ≡
                                                                           cong _⊚_ F≡G)
                                                                        (λ F _ →
                  apply-ext (Eq.good-ext ext₂) (λ _ →
                    ≅→≡ ( _⇾_.transformation
                            (proj₁ $ Precategory.≡→≅ D^C (refl F))
                        , _
                        ))                                                  ≡⟨ cong (apply-ext (Eq.good-ext ext₂)) (apply-ext ext₂ λ X → cong ≅→≡ $
                                                                                Σ-≡,≡→≡ (cong (λ f → _⇾_.transformation (proj₁ f) {X = X}) $
                                                                                Precategory.≡→≅-refl D^C)
                                                                                (refl _)) ⟩
                  apply-ext (Eq.good-ext ext₂) (λ _ →
                    ≅→≡ ( _⇾_.transformation {F = F}
                            (proj₁ $ Precategory.id≅ D^C)
                        , _
                        ))                                                  ≡⟨⟩

                  apply-ext (Eq.good-ext ext₂) (λ _ → ≅→≡ (id , _))         ≡⟨ cong (apply-ext (Eq.good-ext ext₂)) (apply-ext ext₂ λ _ →
                                                                                cong ≅→≡ $ _≃_.from ≡≃≡¹ $ refl _) ⟩
                  apply-ext (Eq.good-ext ext₂) (λ _ → ≅→≡ id≅)              ≡⟨ cong (apply-ext (Eq.good-ext ext₂)) (apply-ext ext₂ λ _ →
                                                                                ≅→≡-refl) ⟩
                  apply-ext (Eq.good-ext ext₂) (λ X → refl (F ⊚ X))         ≡⟨ Eq.good-ext-refl ext₂ _ ⟩

                  refl (_⊚_ F)                                              ≡⟨ sym $ cong-refl _ ⟩∎

                  cong _⊚_ (refl F)                                         ∎)
                                                                        F≡G _ ⟩∎
              cong _⊚_ F≡G                                         ∎)
       }) }
    where
    open Category D
    open Precategory C using () renaming (Hom to HomC)

    ext₁ : Extensionality (ℓ₃ ⊔ ℓ₄) (ℓ₂ ⊔ ℓ₃ ⊔ ℓ₄)
    ext₁ = lower-extensionality lzero ℓ₁ ext

    ext₂ : Extensionality ℓ₃ ℓ₁
    ext₂ = lower-extensionality ℓ₄ (ℓ₂ ⊔ ℓ₃ ⊔ ℓ₄) ext

    D^C : Precategory (ℓ₁ ⊔ ℓ₂ ⊔ ℓ₃ ⊔ ℓ₄) (ℓ₁ ⊔ ℓ₂ ⊔ ℓ₃ ⊔ ℓ₄)
    D^C = (precategory ^ C) ext₁


open import Nat
open import Prelude
open import dynamics-core
open import contexts
open import lemmas-consistency
open import lemmas-disjointness
open import lemmas-matching
open import weakening

module typed-elaboration where
  mutual
    typed-elaboration-synth : {Γ : tctx} {e : hexp} {τ : htyp} {d : ihexp} {Δ : hctx} →
                            Γ ⊢ e ⇒ τ ~> d ⊣ Δ →
                            Δ , Γ ⊢ d :: τ
    typed-elaboration-synth ESNum = TANum
    typed-elaboration-synth (ESPlus dis apt x₁ x₂)
      with typed-elaboration-ana x₁ | typed-elaboration-ana x₂
    ... | con1 , ih1 | con2 , ih2 = TAPlus (TACast (weaken-ta-Δ1 apt ih1) con1) (TACast (weaken-ta-Δ2 apt ih2) con2)
    typed-elaboration-synth (ESVar x₁) = TAVar x₁
    typed-elaboration-synth (ESLam x₁ ex) = TALam x₁ (typed-elaboration-synth ex)
    typed-elaboration-synth (ESAp {Δ1 = Δ1} _ d x₁ x₂ x₃ x₄)
      with typed-elaboration-ana x₃ | typed-elaboration-ana x₄
    ... | con1 , ih1 | con2 , ih2  = TAAp (TACast (weaken-ta-Δ1 d ih1) con1) (TACast (weaken-ta-Δ2 {Δ1 = Δ1} d ih2) con2)
    typed-elaboration-synth (ESEHole {Γ = Γ} {u = u}) with natEQ u u
    ... | Inr u≠u = abort (u≠u refl)
    ... | Inl refl = TAEHole (x∈■ u (Γ , ⦇-⦈)) (STAId (λ x τ z → z))
    typed-elaboration-synth (ESNEHole {Γ = Γ} {τ = τ} {u = u} {Δ = Δ} (d1 , d2) ex)
                            with typed-elaboration-synth ex
    ... | ih1 = TANEHole {Δ = Δ ,, (u , Γ , ⦇-⦈)} (ctx-top Δ u (Γ , ⦇-⦈) (d2 u (lem-domsingle _ _))) (weaken-ta-Δ2 (d2 , d1) ih1) (STAId (λ x τ₁ z → z))
    typed-elaboration-synth (ESAsc x)
      with typed-elaboration-ana x
    ... | con , ih = TACast ih con
    typed-elaboration-synth (ESPair x x₁ x₂ x₃)
      with typed-elaboration-synth x₂ | typed-elaboration-synth x₃
    ... | ih1 | ih2 = TAPair (weaken-ta-Δ1 x₁ ih1) (weaken-ta-Δ2 x₁ ih2)
    typed-elaboration-synth (ESFst x x₁ x₂)
      with typed-elaboration-ana x₂
    ... | con , ih = TAFst (TACast ih con)
    typed-elaboration-synth (ESSnd x x₁ x₂)
      with typed-elaboration-ana x₂
    ... | con , ih = TASnd (TACast ih con)

    typed-elaboration-ana : {Γ : tctx} {e : hexp} {τ τ' : htyp} {d : ihexp} {Δ : hctx} →
                            Γ ⊢ e ⇐ τ ~> d :: τ' ⊣ Δ →
                            (τ' ~ τ) × (Δ , Γ ⊢ d :: τ')
    typed-elaboration-ana (EALam x₁ MAHole ex)
      with typed-elaboration-ana ex
    ... | con , D = TCHole1 , TALam x₁ D
    typed-elaboration-ana (EALam x₁ MAArr ex)
      with typed-elaboration-ana ex
    ... | con , D = TCArr TCRefl con , TALam x₁ D
    typed-elaboration-ana (EASubsume x x₁ x₂ x₃) = ~sym x₃ , typed-elaboration-synth x₂
    typed-elaboration-ana (EAEHole {Γ = Γ} {u = u}) = TCRefl , TAEHole (x∈■ u (Γ , _)) (STAId (λ x τ z → z))
    typed-elaboration-ana (EANEHole {Γ = Γ} {u = u} {τ = τ} {Δ = Δ} (d1 , d2) x)
      with typed-elaboration-synth x
    ... | ih1 = TCRefl , TANEHole {Δ = Δ ,, (u , Γ , τ)} (ctx-top Δ u (Γ , τ) (d2 u (lem-domsingle _ _)) ) (weaken-ta-Δ2 (d2 , d1) ih1) (STAId (λ x₁ τ₁ z → z))
    typed-elaboration-ana (EAInl MSHole x₁)
      with typed-elaboration-ana x₁
    ... | con , D = TCHole1 , TAInl D
    typed-elaboration-ana (EAInl MSSum x₁)
      with typed-elaboration-ana x₁
    ... | con , D = TCSum con TCRefl , TAInl D
    typed-elaboration-ana (EAInr MSHole x₁)
      with typed-elaboration-ana x₁
    ... | con , D = TCHole1 , TAInr D
    typed-elaboration-ana (EAInr MSSum x₁)
      with typed-elaboration-ana x₁
    ... | con , D = TCSum TCRefl con , TAInr D
    typed-elaboration-ana (EACase x x₁ x₂ x₃ x₄ x₅ x₆ x₇ x₈ x₉ x₁₀ x₁₁)
      with typed-elaboration-synth x₈ |
           typed-elaboration-ana x₁₀ | typed-elaboration-ana x₁₁
    ... | D | con1 , D1 | con2 , D2 =
      let Δ##Δ1∪Δ2 = ##-comm (disjoint-parts (##-comm x₃) (##-comm x₄))
      in let wtd   = TACast (weaken-ta-Δ1 Δ##Δ1∪Δ2 D) (▸sum-consist x₉)
      in let wtd1  = TACast (weaken-ta-Δ2 Δ##Δ1∪Δ2 (weaken-ta-Δ1 x₅ D1)) con1
      in let wtd2  = TACast (weaken-ta-Δ2 Δ##Δ1∪Δ2 (weaken-ta-Δ2 x₅ D2)) con2
      in let wt    = TACase wtd x₆ wtd1 x₇ wtd2
      in TCRefl , wt


module SizedIO.Console where

open import Level using () renaming (zero to lzero)
open import Size

open import NativeIO
open import SizedIO.Base

data ConsoleCommand : Set where
  putStrLn : String → ConsoleCommand
  getLine  : ConsoleCommand

ConsoleResponse : ConsoleCommand → Set
ConsoleResponse (putStrLn s) = Unit
ConsoleResponse  getLine     = String

consoleI : IOInterface
Command  consoleI  = ConsoleCommand
Response consoleI  = ConsoleResponse

IOConsole : Size → Set → Set
IOConsole i = IO consoleI i

IOConsole+ : Size → Set → Set
IOConsole+ i = IO+ consoleI i

translateIOConsoleLocal : (c : ConsoleCommand) → NativeIO (ConsoleResponse c)
translateIOConsoleLocal (putStrLn s) = nativePutStrLn s
translateIOConsoleLocal getLine      = nativeGetLine

translateIOConsole : {A : Set} → IOConsole ∞ A → NativeIO A
translateIOConsole = translateIO translateIOConsoleLocal

main : NativeIO Unit
main = nativePutStrLn "Console"


mutual
  data D : Set where
    c : R → D

  record R : Set where
    inductive
    field
      out : D
open R

f : D → {A : Set} → A
f (c x) = f (out x)
-- should termination check


open import Nat
open import Prelude
open import List

open import contexts
open import core

open import lemmas-env

module lemmas-progress where
  typ-inhabitance-pres : ∀{Δ Σ' Γ E e τ} →
                           Δ , Σ' , Γ ⊢ E →
                           Δ , Σ' , Γ ⊢ e :: τ →
                           Σ[ r ∈ result ] (Δ , Σ' ⊢ r ·: τ)

  typ-inhabitance-pres Γ⊢E ta@(TAFix e-ta) = _ , (TAFix Γ⊢E ta)
  typ-inhabitance-pres Γ⊢E (TAVar x∈Γ)
    with env-all-Γ Γ⊢E x∈Γ
  ... | _ , x∈E , r-ta = _ , r-ta
  typ-inhabitance-pres Γ⊢E (TAApp _ f-ta arg-ta)
    with typ-inhabitance-pres Γ⊢E f-ta | typ-inhabitance-pres Γ⊢E arg-ta
  ... | _ , rf-ta | _ , rarg-ta = _ , TAApp rf-ta rarg-ta
  typ-inhabitance-pres Γ⊢E TAUnit = _ , TAUnit
  typ-inhabitance-pres Γ⊢E (TAPair _ ta1 ta2)
    with typ-inhabitance-pres Γ⊢E ta1 | typ-inhabitance-pres Γ⊢E ta2
  ... | _ , r-ta1 | _ , r-ta2 = _ , TAPair r-ta1 r-ta2
  typ-inhabitance-pres Γ⊢E (TAFst ta)
    with typ-inhabitance-pres Γ⊢E ta
  ... | _ , r-ta = _ , TAFst r-ta
  typ-inhabitance-pres Γ⊢E (TASnd ta)
    with typ-inhabitance-pres Γ⊢E ta
  ... | _ , r-ta = _ , TASnd r-ta
  typ-inhabitance-pres Γ⊢E (TACtor d∈Σ' c∈d e-ta)
    with typ-inhabitance-pres Γ⊢E e-ta
  ... | _ , r-ta = _ , TACtor d∈Σ' c∈d r-ta
  typ-inhabitance-pres Γ⊢E (TACase d∈Σ' e-ta h1 h2)
    with typ-inhabitance-pres Γ⊢E e-ta
  ... | _ , r-ta = _ , TACase d∈Σ' Γ⊢E r-ta h1 λ form →
                       let _ , _ , _ , h5 , h6 = h2 form in
                       _ , h5 , h6
  typ-inhabitance-pres Γ⊢E (TAHole u∈Δ) = _ , TAHole u∈Δ Γ⊢E
  typ-inhabitance-pres Γ⊢E (TAAsrt _ e-ta1 e-ta2) = _ , TAUnit


------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Connecting Nehemiah.Change.Term and Nehemiah.Change.Value.
------------------------------------------------------------------------

module Nehemiah.Change.Evaluation where

open import Nehemiah.Syntax.Type
open import Nehemiah.Syntax.Term
open import Nehemiah.Change.Type
open import Nehemiah.Change.Term
open import Nehemiah.Change.Value
open import Nehemiah.Denotation.Value
open import Nehemiah.Denotation.Evaluation

open import Relation.Binary.PropositionalEquality
open import Base.Denotation.Notation

import Parametric.Change.Evaluation
    ⟦_⟧Base ⟦_⟧Const ΔBase apply-base diff-base nil-base ⟦apply-base⟧ ⟦diff-base⟧ ⟦nil-base⟧
  as ChangeEvaluation

meaning-⊕-base : ChangeEvaluation.ApplyStructure
meaning-⊕-base base-int = refl
meaning-⊕-base base-bag = refl

meaning-⊝-base : ChangeEvaluation.DiffStructure
meaning-⊝-base base-int = refl
meaning-⊝-base base-bag = refl

meaning-onil-base : ChangeEvaluation.NilStructure
meaning-onil-base base-int = refl
meaning-onil-base base-bag = refl

open ChangeEvaluation.Structure meaning-⊕-base meaning-⊝-base meaning-onil-base public


module prelude where

open import level public
open import product public
open import product-thms public
open import sum public
open import empty public
open import unit public
open import functions renaming (id to id-set) public
open import eq public
open import list public
open import list-thms public
open import bool public
open import nat public
open import nat-thms public

-- Extensionality will be used when proving equivalences of morphisms.
postulate ext-set : ∀{l1 l2 : level} → extensionality {l1} {l2}
-- These are isomorphisms, but Agda has no way to prove these as
-- equivalences.  They are consistent to adopt as equivalences by
-- univalence:
postulate ∧-unit : ∀{ℓ}{A : Set ℓ} → A ≡ (⊤ {ℓ} ∧ A)
postulate ∧-assoc : ∀{ℓ}{A B C : Set ℓ} →  (A ∧ (B ∧ C)) ≡ ((A ∧ B) ∧ C)
postulate ∧-twist : ∀{ℓ}{A B : Set ℓ} →  (A ∧ B) ≡ (B ∧ A)
-- Provable from the above axioms:
postulate assoc-twist₁ : {A B C D : Set} → ((A × C) × (B × D)) ≡ ((A × B) × (C × D))

-- The following defines a commutative monoid as lists:
_* = 𝕃

postulate *-comm : ∀{A : Set}{l₁ l₂ : A *} → l₁ ++ l₂ ≡ l₂ ++ l₁


module Issue213 where

postulate
  Prod : Set → Set → Set
  A    : Set

Foo : Set
Foo = let infixr 3 _×_
          _×_ : Set → Set → Set
          _×_ = Prod
      in A × A × A


{-# OPTIONS --cubical --safe --no-sized-types --no-guardedness #-}
module Agda.Builtin.Cubical.Glue where

open import Agda.Primitive
open import Agda.Builtin.Sigma
open import Agda.Primitive.Cubical renaming (primINeg to ~_; primIMax to _∨_; primIMin to _∧_;
                                             primHComp to hcomp; primTransp to transp; primComp to comp;
                                             itIsOne to 1=1)
open import Agda.Builtin.Cubical.Path
open import Agda.Builtin.Cubical.Sub renaming (Sub to _[_↦_]; primSubOut to ouc)

module Helpers where
    -- Homogeneous filling
    hfill : ∀ {ℓ} {A : Set ℓ} {φ : I}
              (u : ∀ i → Partial φ A)
              (u0 : A [ φ ↦ u i0 ]) (i : I) → A
    hfill {φ = φ} u u0 i =
      hcomp (λ j → \ { (φ = i1) → u (i ∧ j) 1=1
                     ; (i = i0) → ouc u0 })
            (ouc u0)

    -- Heterogeneous filling defined using comp
    fill : ∀ {ℓ : I → Level} (A : ∀ i → Set (ℓ i)) {φ : I}
             (u : ∀ i → Partial φ (A i))
             (u0 : A i0 [ φ ↦ u i0 ]) →
             ∀ i →  A i
    fill A {φ = φ} u u0 i =
      comp (λ j → A (i ∧ j)) _
           (λ j → \ { (φ = i1) → u (i ∧ j) 1=1
                    ; (i = i0) → ouc u0 })
           (ouc {φ = φ} u0)

    module _ {ℓ} {A : Set ℓ} where
      refl : {x : A} → x ≡ x
      refl {x = x} = λ _ → x

      sym : {x y : A} → x ≡ y → y ≡ x
      sym p = λ i → p (~ i)

      cong : ∀ {ℓ'} {B : A → Set ℓ'} {x y : A}
             (f : (a : A) → B a) (p : x ≡ y)
           → PathP (λ i → B (p i)) (f x) (f y)
      cong f p = λ i → f (p i)

    isContr : ∀ {ℓ} → Set ℓ → Set ℓ
    isContr A = Σ A \ x → (∀ y → x ≡ y)

    fiber : ∀ {ℓ ℓ'} {A : Set ℓ} {B : Set ℓ'} (f : A → B) (y : B) → Set (ℓ ⊔ ℓ')
    fiber {A = A} f y = Σ A \ x → f x ≡ y

open Helpers

-- We make this a record so that isEquiv can be proved using
-- copatterns. This is good because copatterns don't get unfolded
-- unless a projection is applied so it should be more efficient.
record isEquiv {ℓ ℓ'} {A : Set ℓ} {B : Set ℓ'} (f : A → B) : Set (ℓ ⊔ ℓ') where
  field
    equiv-proof : (y : B) → isContr (fiber f y)

open isEquiv public

infix 4 _≃_

_≃_ : ∀ {ℓ ℓ'} (A : Set ℓ) (B : Set ℓ') → Set (ℓ ⊔ ℓ')
A ≃ B = Σ (A → B) \ f → (isEquiv f)

equivFun : ∀ {ℓ ℓ'} {A : Set ℓ} {B : Set ℓ'} → A ≃ B → A → B
equivFun e = fst e

-- Improved version of equivProof compared to Lemma 5 in CCHM. We put
-- the (φ = i0) face in contr' making it be definitionally c in this
-- case. This makes the computational behavior better, in particular
-- for transp in Glue.
equivProof : ∀ {la lt} (T : Set la) (A : Set lt) → (w : T ≃ A) → (a : A)
           → ∀ ψ → (Partial ψ (fiber (w .fst) a)) → fiber (w .fst) a
equivProof A B w a ψ fb = contr' {A = fiber (w .fst) a} (w .snd .equiv-proof a) ψ fb
  where
    contr' : ∀ {ℓ} {A : Set ℓ} → isContr A → (φ : I) → (u : Partial φ A) → A
    contr' {A = A} (c , p) φ u = hcomp (λ i → λ { (φ = i1) → p (u 1=1) i
                                                ; (φ = i0) → c }) c

{-# BUILTIN EQUIV      _≃_        #-}
{-# BUILTIN EQUIVFUN   equivFun   #-}
{-# BUILTIN EQUIVPROOF equivProof #-}

primitive
    primGlue    : ∀ {ℓ ℓ'} (A : Set ℓ) {φ : I}
      → (T : Partial φ (Set ℓ')) → (e : PartialP φ (λ o → T o ≃ A))
      → Set ℓ'
    prim^glue   : ∀ {ℓ ℓ'} {A : Set ℓ} {φ : I}
      → {T : Partial φ (Set ℓ')} → {e : PartialP φ (λ o → T o ≃ A)}
      → PartialP φ T → A → primGlue A T e
    prim^unglue : ∀ {ℓ ℓ'} {A : Set ℓ} {φ : I}
      → {T : Partial φ (Set ℓ')} → {e : PartialP φ (λ o → T o ≃ A)}
      → primGlue A T e → A

    -- Needed for transp in Glue.
    primFaceForall : (I → I) → I

module _ {ℓ : I → Level} (P : (i : I) → Set (ℓ i)) where
  private
    E : (i : I) → Set (ℓ i)
    E  = λ i → P i
    ~E : (i : I) → Set (ℓ (~ i))
    ~E = λ i → P (~ i)

    A = P i0
    B = P i1

    f : A → B
    f x = transp E i0 x

    g : B → A
    g y = transp ~E i0 y

    u : ∀ i → A → E i
    u i x = transp (λ j → E (i ∧ j)) (~ i) x

    v : ∀ i → B → E i
    v i y = transp (λ j → ~E ( ~ i ∧ j)) i y

    fiberPath : (y : B) → (xβ0 xβ1 : fiber f y) → xβ0 ≡ xβ1
    fiberPath y (x0 , β0) (x1 , β1) k = ω , λ j → δ (~ j) where
      module _ (j : I) where
        private
          sys : A → ∀ i → PartialP (~ j ∨ j) (λ _ → E (~ i))
          sys x i (j = i0) = v (~ i) y
          sys x i (j = i1) = u (~ i) x
        ω0 = comp ~E _ (sys x0) ((β0 (~ j)))
        ω1 = comp ~E _ (sys x1) ((β1 (~ j)))
        θ0 = fill ~E (sys x0) (inc (β0 (~ j)))
        θ1 = fill ~E (sys x1) (inc (β1 (~ j)))
      sys = λ {j (k = i0) → ω0 j ; j (k = i1) → ω1 j}
      ω = hcomp sys (g y)
      θ = hfill sys (inc (g y))
      δ = λ (j : I) → comp E _
            (λ i → λ { (j = i0) → v i y ; (k = i0) → θ0 j (~ i)
                     ; (j = i1) → u i ω ; (k = i1) → θ1 j (~ i) })
             (θ j)

    γ : (y : B) → y ≡ f (g y)
    γ y j = comp E _ (λ i → λ { (j = i0) → v i y
                            ; (j = i1) → u i (g y) }) (g y)

  pathToisEquiv : isEquiv f
  pathToisEquiv .equiv-proof y .fst .fst = g y
  pathToisEquiv .equiv-proof y .fst .snd = sym (γ y)
  pathToisEquiv .equiv-proof y .snd = fiberPath y _

  pathToEquiv : A ≃ B
  pathToEquiv .fst = f
  pathToEquiv .snd = pathToisEquiv

{-# BUILTIN PATHTOEQUIV pathToEquiv #-}


{-# OPTIONS --prop --rewriting #-}

open import Calf.CostMonoid

module Calf.Types.BoundedFunction (costMonoid : CostMonoid) where

open CostMonoid costMonoid

open import Calf.Prelude
open import Calf.Metalanguage
open import Calf.Step costMonoid
open import Calf.Types.Bounded costMonoid

open import Level using (_⊔_)
open import Relation.Binary
open import Data.Product

bounded : (A : tp pos) → cmp cost → tp neg
bounded A n = Σ+- (U (F A)) λ u → IsBounded⁻ A u n

Ψ : (A : tp pos) → (B : val A → tp pos) → (val A → ℂ) → tp neg
Ψ A B p =
  Σ+- (U(Π A (λ a → F (B a)))) λ f →
    Π A λ a → IsBounded⁻ (B a) (f a) (p a)

dom : ∀ {ℓ} {a} {A : Set a} {B : Set a} → Rel B ℓ → Rel (A → B) (a ⊔ ℓ)
dom {A = A} r f1 f2 = ∀ (a : A) → r (f1 a) (f2 a)

Ψ/relax : ∀ A B {p p'} → dom _≤_ p p' →
                 (f : cmp (Ψ A B p)) →
                 cmp (Ψ A B p')
Ψ/relax A B h (func , prf) = func ,
  λ a → bound/relax (λ _ → h a) (prf a)


{-# OPTIONS --without-K --safe #-}
-- https://www.cs.bham.ac.uk/~mhe/papers/omniscient-journal-revised.pdf

module Constructive.Omniscience where

open import Level renaming (zero to lzero; suc to lsuc)
import Data.Bool as 𝔹 using (_≤_)
open import Data.Bool as 𝔹 using (Bool; true; false; T; f≤t; b≤b; _∧_; not; _∨_)
import Data.Bool.Properties as 𝔹ₚ
open import Data.Empty
open import Data.Unit using (tt)
open import Data.Nat
open import Data.Nat.Properties
open import Data.Product as Prod
open import Data.Sum as Sum
open import Function.Base
open import Relation.Binary as B
open import Relation.Binary.PropositionalEquality
open import Relation.Nullary
open import Relation.Nullary.Decidable
import Relation.Unary as U

-- agda-misc
open import Constructive.Axiom
open import Constructive.Axiom.Properties
open import Constructive.Axiom.Properties.Base.Lemma
open import Constructive.Common
open import Constructive.Combinators

ℕ∞ : Set
ℕ∞ = Σ (ℕ → Bool) λ x → ∀ i → T (x (suc i)) → T (x i)

⟦_⟧C : ℕ → ℕ → Bool
⟦ n ⟧C = λ m → isYes (m <? n)

⟦_⟧C-con : ∀ n i → T (⟦ n ⟧C (suc i)) → T (⟦ n ⟧C i)
⟦ n ⟧C-con i True[si<n] = fromWitness (m+n≤o⇒n≤o 1 $ toWitness True[si<n])

⟦_⟧ : ℕ → ℕ∞
⟦ n ⟧ = ⟦ n ⟧C , ⟦ n ⟧C-con

∞ : ℕ∞
∞ = (λ _ → true) , (λ i _ → tt)

_≈_ : Rel (ℕ → Bool) lzero
α ≈ β = ∀ i → α i ≡ β i

_≉_ : Rel (ℕ → Bool) lzero
α ≉ β = ¬ (α ≈ β)

_#_ : Rel (ℕ → Bool) lzero
α # β = ∃ λ i → α i ≢ β i

#⇒≉  : {α β : ℕ → Bool} → α # β → α ≉ β
#⇒≉ {α} {β} (i , αi≢βi) α≈β = αi≢βi (α≈β i)

≈-refl : {α : ℕ → Bool} → α ≈ α
≈-refl _ = refl

≈-sym : {α β : ℕ → Bool} → α ≈ β → β ≈ α
≈-sym α≈β i = sym (α≈β i)

≈-trans : {α β γ : ℕ → Bool} → α ≈ β → β ≈ γ → α ≈ γ
≈-trans α≈β β≈γ i = trans (α≈β i) (β≈γ i)

_≈∞_ : Rel ℕ∞ lzero
x ≈∞ y = proj₁ x ≈ proj₁ y

_≉∞_ : Rel ℕ∞ lzero
x ≉∞ y = proj₁ x ≉ proj₁ y

_#∞_ : Rel ℕ∞ lzero
x #∞ y = proj₁ x # proj₁ y

⟦⟧-cong : ∀ {m n} → m ≡ n → ⟦ m ⟧ ≈∞ ⟦ n ⟧
⟦⟧-cong {m} {n} m≡n i = cong (λ x → ⟦ x ⟧C i) m≡n

-- Proposition 3.1
-- r = ≤-all
≤-all : (ℕ → Bool) → (ℕ → Bool)
≤-all α zero    = α 0
≤-all α (suc n) = α (suc n) ∧ ≤-all α n

≤-all-idem : ∀ α → ≤-all (≤-all α) ≈ ≤-all α
≤-all-idem α zero    = refl
≤-all-idem α (suc n) = begin
  (α (suc n) ∧ ≤-all α n) ∧ ≤-all (≤-all α) n
    ≡⟨ cong ((α (suc n) ∧ ≤-all α n) ∧_) $ ≤-all-idem α n ⟩
  (α (suc n) ∧ ≤-all α n) ∧ ≤-all α n
    ≡⟨ 𝔹ₚ.∧-assoc (α (suc n)) (≤-all α n) (≤-all α n) ⟩
  α (suc n) ∧ (≤-all α n ∧ ≤-all α n)
    ≡⟨ cong (α (suc n) ∧_) $ 𝔹ₚ.∧-idem (≤-all α n) ⟩
  α (suc n) ∧ ≤-all α n
    ∎
  where open ≡-Reasoning

private
  T-∧-× : ∀ {x y} → T (x ∧ y) → (T x × T y)
  T-∧-× {true} {true} t = tt , tt

  T-×-∧ : ∀ {x y} → (T x × T y) → T (x ∧ y)
  T-×-∧ {true} {true} (tt , tt) = tt

  ≤⇒≡∨< : ∀ {m n} → m ≤ n → (m ≡ n) ⊎ (m < n)
  ≤⇒≡∨< {m} {n} m≤n with m ≟ n
  ... | yes m≡n = inj₁ m≡n
  ... | no  m≢n = inj₂ (≤∧≢⇒< m≤n m≢n)

≤-all-convergent : ∀ α i → T (≤-all α (suc i)) → T (≤-all α i)
≤-all-convergent α n t = proj₂ (T-∧-× t)

≤-all-ℕ∞ : (ℕ → Bool) → ℕ∞
≤-all-ℕ∞ α = ≤-all α , ≤-all-convergent α

≤-all-extract-by-≤ : ∀ α {n k} → k ≤ n → T (≤-all α n) → T (α k)
≤-all-extract-by-≤ α {zero}  {.0}    z≤n       t = t
≤-all-extract-by-≤ α {suc n} {zero}  z≤n       t =
  ≤-all-extract-by-≤ α {n} {0} z≤n (proj₂ (T-∧-× t))
≤-all-extract-by-≤ α {suc n} {suc k} (s≤s k≤n) t with ≤⇒≡∨< k≤n
... | inj₁ k≡n    = subst (T ∘′ α ∘′ suc) (sym k≡n) (proj₁ (T-∧-× t))
... | inj₂ suck≤n = ≤-all-extract-by-≤ α suck≤n (proj₂ (T-∧-× t))

≤-all-extract : ∀ α n → T (≤-all α n) → T (α n)
≤-all-extract α n = ≤-all-extract-by-≤ α ≤-refl

≤-all-construct : ∀ α n → (∀ k → k ≤ n → T (α k)) → T (≤-all α n)
≤-all-construct α zero    f = f zero ≤-refl
≤-all-construct α (suc n) f =
  T-×-∧ ((f (suc n) ≤-refl) , ≤-all-construct α n λ k k≤n → f k (≤-step k≤n))

private
  not-injective : ∀ {x y} → not x ≡ not y → x ≡ y
  not-injective {false} {false} refl = refl
  not-injective {true}  {true}  refl = refl

  x≢y⇒not[x]≡y : ∀ {x y} → x ≢ y → not x ≡ y
  x≢y⇒not[x]≡y {false} {false} x≢y = contradiction refl x≢y
  x≢y⇒not[x]≡y {false} {true}  x≢y = refl
  x≢y⇒not[x]≡y {true}  {false} x≢y = refl
  x≢y⇒not[x]≡y {true}  {true}  x≢y = contradiction refl x≢y

  x≡y⇒not[x]≢y : ∀ {x y} → x ≡ y → not x ≢ y
  x≡y⇒not[x]≢y {false} {false} p ()
  x≡y⇒not[x]≢y {false} {true}  () q
  x≡y⇒not[x]≢y {true}  {false} () q
  x≡y⇒not[x]≢y {true}  {true}  p ()

  not[x]≢y⇒x≡y : ∀ {x y} → not x ≢ y → x ≡ y
  not[x]≢y⇒x≡y {x} {y} not[x]≢y =
    subst (_≡ y) (𝔹ₚ.not-involutive x) $ x≢y⇒not[x]≡y not[x]≢y

  not[x]≡y⇒x≢y : ∀ {x y} → not x ≡ y → x ≢ y
  not[x]≡y⇒x≢y not[x]≡y x≡y = x≡y⇒not[x]≢y x≡y not[x]≡y

-- LPO-Bool <=> ∀ x → (x #∞ ∞) ⊎ (x ≈∞ ∞)
lpo-Bool⇒∀x→x#∞⊎x≈∞ : LPO-Bool ℕ → ∀ x → (x #∞ ∞) ⊎ (x ≈∞ ∞)
lpo-Bool⇒∀x→x#∞⊎x≈∞ lpo-Bool (α , con) with lpo-Bool λ n → not (α n)
... | inj₁ (x , not[αx]≡true) = inj₁ (x , not[x]≡y⇒x≢y not[αx]≡true)
... | inj₂ ¬∃x→not[αx]≡true   =
  inj₂ λ i → not[x]≢y⇒x≡y $′ ¬∃P→∀¬P ¬∃x→not[αx]≡true i

private
  T-to-≡ : ∀ {x} → T x → x ≡ true
  T-to-≡ {true} tx = refl

  ≡-to-T : ∀ {x} → x ≡ true → T x
  ≡-to-T {true} x≡true = tt

  T-¬-not : ∀ {x} → ¬ (T x) → T (not x)
  T-¬-not {false} n = tt
  T-¬-not {true}  n = n tt

  T-not-¬ : ∀ {x} → T (not x) → ¬ (T x)
  T-not-¬ {false} tt ()
  T-not-¬ {true}  () y

  ¬-T-not-to-T : ∀ {x} → ¬ T (not x) → T x
  ¬-T-not-to-T {x} ¬Tnotx = subst T (𝔹ₚ.not-involutive x) $ T-¬-not ¬Tnotx

  ≤-to-→ : ∀ {x y} → x 𝔹.≤ y → T x → T y
  ≤-to-→ {true} {true} x≤y _ = tt

  →-to-≤ : ∀ {x y} → (T x → T y) → x 𝔹.≤ y
  →-to-≤ {false} {false} Tx→Ty = b≤b
  →-to-≤ {false} {true}  Tx→Ty = f≤t
  →-to-≤ {true}  {false} Tx→Ty = ⊥-elim (Tx→Ty tt)
  →-to-≤ {true}  {true}  Tx→Ty = b≤b

  T-≡ : ∀ {x y} → (T x → T y) → (T y → T x) → x ≡ y
  T-≡ Tx→Ty Ty→Tx = 𝔹ₚ.≤-antisym (→-to-≤ Tx→Ty) (→-to-≤ Ty→Tx)

¬T-≤-all-to-≤ : ∀ α n → ¬ T (≤-all α n) → ∃ λ k → k ≤ n × ¬ T (α k)
¬T-≤-all-to-≤ α zero    ¬T with 𝔹ₚ.T? (α 0)
... | yes Tα0 = contradiction Tα0 ¬T
... | no ¬Tα0 = 0 , (z≤n , ¬Tα0)
¬T-≤-all-to-≤ α (suc n) ¬T with 𝔹ₚ.T? (α (suc n))
... | yes Tαsn =
 Prod.map₂ (Prod.map₁ ≤-step) $
   ¬T-≤-all-to-≤ α n (contraposition (λ T≤-allαn → T-×-∧ (Tαsn , T≤-allαn)) ¬T)
... | no ¬Tαsn = suc n , ≤-refl , ¬Tαsn

¬T-≤-all-to-≤′ : ∀ α n → ¬ T (≤-all (not ∘′ α) n) → ∃ λ k → k ≤ n × T (α k)
¬T-≤-all-to-≤′ α n ¬T with ¬T-≤-all-to-≤ (not ∘ α) n ¬T
... | (k , k≤n , ¬Tnotαn) = k , (k≤n , ¬-T-not-to-T ¬Tnotαn)

¬T-≤-all-to-∃ : ∀ α n → ¬ T (≤-all α n) → ∃ λ k → ¬ T (α k)
¬T-≤-all-to-∃ α n ¬T = Prod.map₂ proj₂ (¬T-≤-all-to-≤ α n ¬T)

¬T-≤-all-to-∃′ : ∀ α n → ¬ T (≤-all (not ∘′ α) n) → ∃ λ k → T (α k)
¬T-≤-all-to-∃′ α n ¬T = Prod.map₂ proj₂ (¬T-≤-all-to-≤′ α n ¬T)

≤-to-¬T-≤-all : ∀ α n → ∃ (λ k → k ≤ n × ¬ T (α k)) → ¬ T (≤-all α n)
≤-to-¬T-≤-all α n (k , k≤n  , ¬Tαk) ttt = ¬Tαk (≤-all-extract-by-≤ α k≤n ttt)

∀x→x#∞⊎x≈∞⇒lpo-Bool : (∀ x → (x #∞ ∞) ⊎ (x ≈∞ ∞)) → LPO-Bool ℕ
∀x→x#∞⊎x≈∞⇒lpo-Bool ≈∞? P with ≈∞? (≤-all-ℕ∞ (λ n → not (P n)))
... | inj₁ (x , ≤-all[not∘P,x]≢true) =
  inj₁ (Prod.map₂ T-to-≡ (¬T-≤-all-to-∃′ P x
    (contraposition T-to-≡ ≤-all[not∘P,x]≢true)))
... | inj₂ ∀i→≤-all[not∘P,i]≡true =
  inj₂ (∀¬P→¬∃P λ i → not[x]≡y⇒x≢y (T-to-≡ $ ≤-all-extract (not ∘ P) i $
    ≡-to-T (∀i→≤-all[not∘P,i]≡true i)))

-- Theorem 3.5
ε : (ℕ∞ → Bool) → ℕ∞
ε p = ≤-all-ℕ∞ λ n → p ⟦ n ⟧

T-⟦⟧C-to-< : ∀ {n i} → T (⟦ n ⟧C i) → i < n
T-⟦⟧C-to-< t = toWitness t

<-to-T-⟦⟧C : ∀ {n i} → i < n → T (⟦ n ⟧C i)
<-to-T-⟦⟧C i<n = fromWitness i<n

lemma-1-forward : ∀ (p : ℕ∞ → Bool) n →
                  ε p ≈∞ ⟦ n ⟧ → ¬ T (p ⟦ n ⟧) × (∀ k → k < n → T (p ⟦ k ⟧))
lemma-1-forward p n εp≈∞⟦n⟧ = ¬T[p⟦n⟧] , i<n⇒Tp⟦i⟧
  where
  ∀i→≤-all[p∘⟦⟧,i]≡⟦n⟧Ci : ∀ i → ≤-all (λ m → p ⟦ m ⟧) i ≡ ⟦ n ⟧C i
  ∀i→≤-all[p∘⟦⟧,i]≡⟦n⟧Ci = εp≈∞⟦n⟧

  i<n⇒Tp⟦i⟧ : ∀ i → i < n → T (p ⟦ i ⟧)
  i<n⇒Tp⟦i⟧ i i<n = ≤-all-extract (p ∘′ ⟦_⟧) i T[≤-all[p∘⟦⟧,i]]
    where
    ⟦n⟧Ci≡true : ⟦ n ⟧C i ≡ true
    ⟦n⟧Ci≡true = T-to-≡ (<-to-T-⟦⟧C i<n)

    ≤-all[p∘⟦⟧,i]≡true : ≤-all (λ m → p ⟦ m ⟧) i ≡ true
    ≤-all[p∘⟦⟧,i]≡true = trans (∀i→≤-all[p∘⟦⟧,i]≡⟦n⟧Ci i) ⟦n⟧Ci≡true

    T[≤-all[p∘⟦⟧,i]] : T (≤-all (λ m → p ⟦ m ⟧) i)
    T[≤-all[p∘⟦⟧,i]] = ≡-to-T ≤-all[p∘⟦⟧,i]≡true

  ¬T[p⟦n⟧] : ¬ T (p ⟦ n ⟧)
  ¬T[p⟦n⟧] = contraposition (subst (T ∘′ p ∘′ ⟦_⟧) (sym m≡n)) ¬T[p⟦m⟧]
    where
    ⟦n⟧Cn≡false : ⟦ n ⟧C n ≡ false
    ⟦n⟧Cn≡false = not-injective (T-to-≡ (T-¬-not (contraposition T-⟦⟧C-to-< (n≮n n))))

    ≤-all[p∘⟦⟧,n]≡false : ≤-all (λ m → p ⟦ m ⟧) n ≡ false
    ≤-all[p∘⟦⟧,n]≡false = trans (∀i→≤-all[p∘⟦⟧,i]≡⟦n⟧Ci n) ⟦n⟧Cn≡false

    ¬T-≤-all[p∘⟦⟧,n] : ¬ T (≤-all (λ m → p ⟦ m ⟧) n)
    ¬T-≤-all[p∘⟦⟧,n] = T-not-¬ (≡-to-T (cong not ≤-all[p∘⟦⟧,n]≡false))

    ∃m→m≤n×¬T[p⟦m⟧] : ∃ λ m → m ≤ n × ¬ T (p ⟦ m ⟧)
    ∃m→m≤n×¬T[p⟦m⟧] = ¬T-≤-all-to-≤ (p ∘′ ⟦_⟧) n ¬T-≤-all[p∘⟦⟧,n]

    m : ℕ
    m = proj₁ ∃m→m≤n×¬T[p⟦m⟧]

    m≤n : m ≤ n
    m≤n = proj₁ (proj₂ ∃m→m≤n×¬T[p⟦m⟧])

    ¬T[p⟦m⟧] : ¬ T (p ⟦ m ⟧)
    ¬T[p⟦m⟧] = proj₂ (proj₂ ∃m→m≤n×¬T[p⟦m⟧])

    m≮n : m ≮ n
    m≮n m<n = ¬T[p⟦m⟧] (i<n⇒Tp⟦i⟧ m m<n)

    m≡n : m ≡ n
    m≡n = ≤-antisym m≤n (≮⇒≥ m≮n)

lemma-1-backwards : ∀ (p : ℕ∞ → Bool) n →
                    ¬ T (p ⟦ n ⟧) × (∀ k → k < n → T (p ⟦ k ⟧)) →
                    ε p ≈∞ ⟦ n ⟧
lemma-1-backwards p n (¬Tp⟦n⟧ , ∀k→k<n→Tp⟦k⟧) = ∀i→≤-all[p∘⟦⟧,i]≡⟦n⟧Ci
  where
  open ≡-Reasoning

  ∀i→≤-all[p∘⟦⟧,i]≡⟦n⟧Ci : ∀ i → ≤-all (λ m → p ⟦ m ⟧) i ≡ ⟦ n ⟧C i
  ∀i→≤-all[p∘⟦⟧,i]≡⟦n⟧Ci i with n ≤? i
  ... | yes n≤i = trans (not-injective (T-to-≡ (T-¬-not ¬T≤-all[p∘⟦⟧,i])))
                        (sym ⟦n⟧Ci≡false)
    where
    ⟦n⟧Ci≡false : ⟦ n ⟧C i ≡ false
    ⟦n⟧Ci≡false = not-injective (T-to-≡ (T-¬-not (contraposition T-⟦⟧C-to-< (≤⇒≯ n≤i))))

    ¬T≤-all[p∘⟦⟧,i] : ¬ T (≤-all (λ m → p ⟦ m ⟧) i)
    ¬T≤-all[p∘⟦⟧,i] t = ¬Tp⟦n⟧ (≤-all-extract-by-≤ (p ∘′ ⟦_⟧) n≤i t)
  ... | no  n≰i = begin
    ≤-all (λ m → p ⟦ m ⟧) i
      ≡⟨ T-to-≡ (≤-all-construct (p ∘ ⟦_⟧) i
                λ k k≤i → ∀k→k<n→Tp⟦k⟧ k (<-transʳ k≤i i<n)) ⟩
    true
     ≡⟨ sym $ T-to-≡ (<-to-T-⟦⟧C i<n) ⟩
    ⟦ n ⟧C i
     ∎
    where i<n = ≰⇒> n≰i

{-
pp : ℕ∞ → Bool
pp (x , _) = not (x 0) ∨ (x 0 ∧ not (x 1))
-}

ε-correct : (P : ℕ∞ → Bool) → P (ε P) ≡ true → ∀ x → P x ≡ true
ε-correct P P[εP]≡true x = {!   !}

searchable-Bool : Searchable-Bool ℕ∞
searchable-Bool = ε , ε-correct


module MLib.Algebra.PropertyCode where

open import MLib.Prelude
open import MLib.Finite

open import MLib.Algebra.PropertyCode.RawStruct public
open import MLib.Algebra.PropertyCode.Core as Core public
  using (Property; Properties; Code; IsSubcode; _∈ₚ_; _⇒ₚ_; ⟦_⟧P)
  renaming (⇒ₚ-weaken to weaken)

open Core.PropKind public
open Core.PropertyC using (_on_; _is_for_; _⟨_⟩ₚ_) public

import Relation.Unary as U using (Decidable)
open import Relation.Binary as B using (Setoid)

open import Data.List.All as All using (All; _∷_; []) public
open import Data.List.Any using (Any; here; there)
open import Data.Bool using (_∨_)

open import Category.Applicative

record Struct {k} (code : Code k) c ℓ : Set (sucˡ (c ⊔ˡ ℓ ⊔ˡ k)) where
  open Code code public

  field
    rawStruct : RawStruct K c ℓ
    Π : Properties code

  open RawStruct rawStruct public

  open Properties Π public

  field
    reify : ∀ {π} → π ∈ₚ Π → ⟦ π ⟧P rawStruct

  Hasₚ : (Π′ : Properties code) → Set
  Hasₚ Π′ = Π′ ⇒ₚ Π

  Has : List (Property K) → Set
  Has = Hasₚ ∘ Core.fromList

  Has₁ : Property K → Set
  Has₁ π = Hasₚ (Core.singleton π)

  use : ∀ π ⦃ hasπ : π ∈ₚ Π ⦄ → ⟦ π ⟧P rawStruct
  use _ ⦃ hasπ ⦄ = reify hasπ

  from : ∀ {Π′} (hasΠ′ : Hasₚ Π′) π ⦃ hasπ : π ∈ₚ Π′ ⦄ → ⟦ π ⟧P rawStruct
  from hasΠ′ _ ⦃ hasπ ⦄ = use _ ⦃ Core.⇒ₚ-MP hasπ hasΠ′ ⦄

  substruct : ∀ {k′} {code′ : Code k′} → IsSubcode code′ code → Struct code′ c ℓ
  substruct isSub = record
    { rawStruct = record
      { Carrier = Carrier
      ; _≈_ = _≈_
      ; appOp = appOp ∘ Core.subK→supK isSub
      ; isRawStruct = isRawStruct′
      }
    ; Π = Core.subcodeProperties isSub Π
    ; reify = Core.reinterpret isSub rawStruct isRawStruct′ _ ∘ reify ∘ Core.fromSubcode isSub
    }
    where
    isRawStruct′ = record
      { isEquivalence = isEquivalence
      ; congⁿ = congⁿ ∘ Core.subK→supK isSub
      }

  toSubstruct :
    ∀ {k′} {code′ : Code k′} (isSub : IsSubcode code′ code) →
    ∀ {Π′ : Properties code′} (hasΠ′ : Hasₚ (Core.supcodeProperties isSub Π′)) →
    Π′ ⇒ₚ Core.subcodeProperties isSub Π
  toSubstruct isSub hasΠ′ = Core.→ₚ-⇒ₚ λ π hasπ →
    Core.fromSupcode isSub
      (Core.⇒ₚ-→ₚ hasΠ′
        (Core.mapProperty (Core.subK→supK isSub) π)
        (Core.fromSupcode′ isSub hasπ))


{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.ZCohomology.KcompPrelims where

open import Cubical.ZCohomology.Base
open import Cubical.Homotopy.Connected
open import Cubical.HITs.Hopf
open import Cubical.Homotopy.Freudenthal hiding (encode)
open import Cubical.HITs.Sn
open import Cubical.HITs.S1
open import Cubical.HITs.Truncation renaming (elim to trElim ; rec to trRec ; map to trMap)

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Transport
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.GroupoidLaws
open import Cubical.Foundations.Univalence
open import Cubical.Foundations.Equiv.HalfAdjoint

open import Cubical.Data.Int renaming (_+_ to +Int)
open import Cubical.Data.Nat hiding (_·_)
open import Cubical.Data.Unit

open import Cubical.HITs.Susp
open import Cubical.HITs.Nullification
open import Cubical.Data.Prod.Base
open import Cubical.Homotopy.Loopspace
open import Cubical.Data.Bool
open import Cubical.Data.Sum.Base
open import Cubical.Data.Sigma hiding (_×_)
open import Cubical.Foundations.Function
open import Cubical.Foundations.Pointed
open import Cubical.HITs.S3

private
  variable
    ℓ : Level
    A : Type ℓ

{- We want to prove that Kn≃ΩKn+1. For this we use the map ϕ-}

ϕ : (pt a : A) → typ (Ω (Susp A , north))
ϕ pt a = (merid a) ∙ sym (merid pt)

private
  Kn→ΩKn+1 : (n : ℕ) → coHomK n → typ (Ω (coHomK-ptd (suc n)))
  Kn→ΩKn+1 zero x i = ∣ intLoop x i ∣
  Kn→ΩKn+1 (suc zero) = trRec (isOfHLevelTrunc 4 ∣ north ∣ ∣ north ∣)
                               λ a i → ∣ ϕ base a i ∣
  Kn→ΩKn+1 (suc (suc n)) = trRec (isOfHLevelTrunc (2 + (3 + n)) ∣ north ∣ ∣ north ∣)
                                  λ a i → ∣ ϕ north a i ∣

  d-map : typ (Ω ((Susp S¹) , north)) → S¹
  d-map p = subst HopfSuspS¹ p base

  d-mapId : (r : S¹) → d-map (ϕ base r) ≡ r
  d-mapId r = substComposite HopfSuspS¹ (merid r) (sym (merid base)) base ∙
              rotLemma r
    where
    rotLemma : (r : S¹) → r · base ≡ r
    rotLemma base = refl
    rotLemma (loop i) = refl

sphereConnectedSpecCase : isConnected 4 (Susp (Susp S¹))
sphereConnectedSpecCase = sphereConnected 3

d-mapComp : Iso (fiber d-map base) (Path (S₊ 3) north north)
d-mapComp = compIso (IsoΣPathTransportPathΣ {B = HopfSuspS¹} _ _)
                     (congIso (invIso IsoS³TotalHopf))

is1Connected-dmap : isConnectedFun 3 d-map
is1Connected-dmap = toPropElim (λ _ → isPropIsOfHLevel 0)
                               (isConnectedRetractFromIso 3 d-mapComp
                                 (isOfHLevelRetractFromIso 0 (invIso (PathIdTruncIso 3))
                                              contrHelper))
  where
  contrHelper : isContr (Path (∥ Susp (Susp S¹) ∥ 4) ∣ north ∣ ∣ north ∣)
  fst contrHelper = refl
  snd contrHelper = isOfHLevelPlus {n = 0} 2 (sphereConnected 3) ∣ north ∣ ∣ north ∣ refl

d-Iso : Iso (∥ Path (S₊ 2) north north ∥ 3) (coHomK 1)
d-Iso = connectedTruncIso _ d-map is1Connected-dmap

d-mapId2 : Iso.fun d-Iso ∘ trMap (ϕ base) ≡ idfun (coHomK 1)
d-mapId2 = funExt (trElim (λ _ → isOfHLevelPath 3 (isOfHLevelTrunc 3) _ _) λ a i → ∣ d-mapId a i ∣)

Iso∥ϕ₁∥ : Iso (coHomK 1) (∥ Path (S₊ 2) north north ∥ 3)
Iso∥ϕ₁∥ = composesToId→Iso d-Iso (trMap (ϕ base)) d-mapId2

Iso-Kn-ΩKn+1 : (n : HLevel) → Iso (coHomK n) (typ (Ω (coHomK-ptd (suc n))))
Iso-Kn-ΩKn+1 zero = invIso (compIso (congIso (truncIdempotentIso _ isGroupoidS¹)) ΩS¹IsoInt)
Iso-Kn-ΩKn+1 (suc zero) = compIso Iso∥ϕ₁∥ (invIso (PathIdTruncIso 3))
Iso-Kn-ΩKn+1 (suc (suc n)) = compIso (stabSpheres-n≥2 n)
                                     (invIso (PathIdTruncIso (4 + n)))
 where
  helper : n + (4 + n) ≡ 2 + (n + (2 + n))
  helper = +-suc n (3 + n) ∙ (λ i → suc (+-suc n (2 + n) i))