-- Andreas, 2012-03-09, example by Ulf
{-# OPTIONS -v tc.conv.irr:50 -v tc.decl.ax:10 -v tc.decl.mutual:20 #-}
module Issue351-5 where

open import Common.Prelude
open import Common.Equality
open import Common.Irrelevance

postulate
  foo : (x : Squash Nat) → ((r : Squash Nat) → r ≡ squash (suc (unsquash x))) → Set
  bar : foo (squash _) (λ r → refl)


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

{-
  Adapted from Ulrik's work in Lean (released under Apache License 2.0)
  https://github.com/leanprover/lean/blob/master/hott/homotopy/cellcomplex.hlean
-}

open import HoTT renaming (pt to pt⊙)
open import homotopy.DisjointlyPointedSet

module cw.CW {i} where

open import cw.Attached public

{-
  Naming convention: most of them have the "cw-" prefix
-}

-- skeleton
{-
  Disadvantages of alternative definitions:

  [Skeleton] as a data type: No η. ([Skeleton (S n)] does not expand.)
  [Skeleton] as a recursive record type: No η.
  [Skeleton] as a recursive fuction giving recursive Σ types:
    the current Agda sees that [Skeleton 0] and [Skeleton (S n)]
    have the same head symbol [Σ] and will not invert [Skeleton]
    during unification.

  The following is combines a recursive funcition and a non-recursive
  record type which should strike a good balance.
-}

record AttachedSkeleton n (Skel : Type (lsucc i)) (Real : Skel → Type i)
  : Type (lsucc i) where
  constructor attached-skeleton
  field
    skel : Skel
    cells : hSet i
    attaching : Attaching (Real skel) (fst cells) (Sphere n)

Skeleton : ℕ → Type (lsucc i)
Realizer : {n : ℕ} → Skeleton n → Type i

Skeleton O = hSet i
Skeleton (S n) = AttachedSkeleton n (Skeleton n) Realizer

Realizer {n = O} A = fst A
Realizer {n = S n} (attached-skeleton _ _ α) = Attached α

⟦_⟧ = Realizer

-- Pointedness

-- this function is needed for pointedness
cw-head : ∀ {n : ℕ} → Skeleton n → Type i
cw-head {n = O} cells = fst cells
cw-head {n = S n} (attached-skeleton skel _ _) = cw-head skel

-- this function is needed for pointedness
incl^ : ∀ {n : ℕ} (skel : Skeleton n)
  → cw-head skel → ⟦ skel ⟧
incl^ {n = O} cells a = a
incl^ {n = S n} (attached-skeleton skel _ _) a = incl (incl^ skel a)

-- disjointly pointed skeletons
record ⊙Skeleton (n : ℕ) : Type (lsucc i) where
  constructor ⊙skeleton
  field
    skel : Skeleton n
    pt : cw-head skel
    pt-dec : is-separable ⊙[ cw-head skel , pt ]

⊙Realizer : {n : ℕ} → ⊙Skeleton n → Ptd i
⊙Realizer (⊙skeleton skel pt _) = ⊙[ ⟦ skel ⟧ , incl^ skel pt ]

⊙⟦_⟧ = ⊙Realizer

-- Take a prefix of a skeleton

cw-init : ∀ {n} → Skeleton (S n) → Skeleton n
cw-init (attached-skeleton skel _ _) = skel

⊙cw-init : ∀ {n} → ⊙Skeleton (S n) → ⊙Skeleton n
⊙cw-init (⊙skeleton skel pt dec) = ⊙skeleton (cw-init skel) pt dec

cw-take : ∀ {m n : ℕ} (m≤n : m ≤ n) → Skeleton n → Skeleton m
cw-take (inl idp)        skel = skel
cw-take (inr ltS)        skel = cw-init skel
cw-take (inr (ltSR m<n)) skel = cw-take (inr m<n) (cw-init skel)

cw-init-take : ∀ {m n : ℕ} (Sm≤n : S m ≤ n) skel
  → cw-init (cw-take Sm≤n skel) == cw-take (≤-trans lteS Sm≤n) skel
cw-init-take (inl idp) skel = idp
cw-init-take (inr ltS) skel = idp
cw-init-take (inr (ltSR lt)) skel = cw-init-take (inr lt) (cw-init skel)

⊙cw-take : ∀ {m n : ℕ} (m≤n : m ≤ n) → ⊙Skeleton n → ⊙Skeleton m
⊙cw-take (inl idp)        ⊙skel = ⊙skel
⊙cw-take (inr ltS)        ⊙skel = ⊙cw-init ⊙skel
⊙cw-take (inr (ltSR m<n)) ⊙skel = ⊙cw-take (inr m<n) (⊙cw-init ⊙skel)

⊙cw-head : ∀ {n : ℕ} → ⊙Skeleton n → Ptd i
⊙cw-head (⊙skeleton skel pt _) = ⊙[ cw-head skel , pt ]

⊙cw-init-take : ∀ {m n : ℕ} (Sm≤n : S m ≤ n) ⊙skel
  → ⊙cw-init (⊙cw-take Sm≤n ⊙skel) == ⊙cw-take (≤-trans lteS Sm≤n) ⊙skel
⊙cw-init-take (inl idp) ⊙skel = idp
⊙cw-init-take (inr ltS) ⊙skel = idp
⊙cw-init-take (inr (ltSR lt)) ⊙skel = ⊙cw-init-take (inr lt) (⊙cw-init ⊙skel)

-- Access the [m]th cells

cells-last : ∀ {n : ℕ} → Skeleton n → Type i
cells-last {n = O} cells = fst cells
cells-last {n = S n} (attached-skeleton _ cells _) = fst cells

⊙cells-last : ∀ {n : ℕ} → ⊙Skeleton n → Type i
⊙cells-last (⊙skeleton skel _ _) = cells-last skel

cells-nth : ∀ {m n : ℕ} (m≤n : m ≤ n) → Skeleton n → Type i
cells-nth m≤n = cells-last ∘ cw-take m≤n

⊙cells-nth : ∀ {m n : ℕ} (m≤n : m ≤ n) → ⊙Skeleton n → Type i
⊙cells-nth m≤n = ⊙cells-last ∘ ⊙cw-take m≤n

-- Access the [m]th dimensional attaching map

Realizer₋₁ : ∀ {n : ℕ} → Skeleton (S n) → Type i
Realizer₋₁ = ⟦_⟧ ∘ cw-init

⟦_⟧₋₁ = Realizer₋₁

⊙Realizer₋₁ : ∀ {n : ℕ} → ⊙Skeleton (S n) → Ptd i
⊙Realizer₋₁ = ⊙⟦_⟧ ∘ ⊙cw-init

⊙⟦_⟧₋₁ = ⊙Realizer₋₁

attaching-last : ∀ {n : ℕ} (skel : Skeleton (S n))
  → cells-last skel → (Sphere n → ⟦ skel ⟧₋₁)
attaching-last (attached-skeleton _ _ attaching) = attaching

⊙attaching-last : ∀ {n : ℕ} (⊙skel : ⊙Skeleton (S n))
  → ⊙cells-last ⊙skel → (Sphere n → de⊙ ⊙⟦ ⊙skel ⟧₋₁)
⊙attaching-last = attaching-last ∘ ⊙Skeleton.skel

attaching-nth : ∀ {m n : ℕ} (Sm≤n : S m ≤ n) (skel : Skeleton n)
  → cells-nth Sm≤n skel → (Sphere m → ⟦ cw-take Sm≤n skel ⟧₋₁)
attaching-nth Sm≤n = attaching-last ∘ cw-take Sm≤n

⊙attaching-nth : ∀ {m n : ℕ} (Sm≤n : S m ≤ n) (⊙skel : ⊙Skeleton n)
  → ⊙cells-nth Sm≤n ⊙skel → Sphere m → de⊙ ⊙⟦ ⊙cw-take Sm≤n ⊙skel ⟧₋₁
⊙attaching-nth Sm≤n = ⊙attaching-last ∘ ⊙cw-take Sm≤n

-- Access the [m]th dimensional inclusion map

cw-incl-last : ∀ {n} (skel : Skeleton (S n))
  → (⟦ skel ⟧₋₁ → ⟦ skel ⟧)
cw-incl-last _ = incl

⊙cw-incl-last : ∀ {n} (⊙skel : ⊙Skeleton (S n))
  → (⊙⟦ ⊙skel ⟧₋₁ ⊙→ ⊙⟦ ⊙skel ⟧)
⊙cw-incl-last _ = incl , idp

cw-incl-nth : ∀ {m n : ℕ} (Sm≤n : S m ≤ n) (skel : Skeleton n)
  → ⟦ cw-take Sm≤n skel ⟧₋₁ → ⟦ cw-take Sm≤n skel ⟧
cw-incl-nth Sm≤n = cw-incl-last ∘ cw-take Sm≤n

⊙cw-incl-nth : ∀ {m n : ℕ} (Sm≤n : S m ≤ n) (⊙skel : ⊙Skeleton n)
  → (⊙⟦ ⊙cw-take Sm≤n ⊙skel ⟧₋₁ ⊙→ ⊙⟦ ⊙cw-take Sm≤n ⊙skel ⟧)
⊙cw-incl-nth Sm≤n = ⊙cw-incl-last ∘ ⊙cw-take Sm≤n

cw-incl-tail : ∀ {m n : ℕ} (m≤n : m ≤ n) (skel : Skeleton n)
  → (⟦ cw-take m≤n skel ⟧ → ⟦ skel ⟧)
cw-incl-tail (inl idp) skel = idf ⟦ skel ⟧
cw-incl-tail (inr ltS) skel = cw-incl-last skel
cw-incl-tail (inr (ltSR lt)) skel =
  cw-incl-last skel ∘ cw-incl-tail (inr lt) (cw-init skel)

⊙cw-incl-tail : ∀ {m n : ℕ} (m≤n : m ≤ n) (⊙skel : ⊙Skeleton n)
  → (⊙⟦ ⊙cw-take m≤n ⊙skel ⟧ ⊙→ ⊙⟦ ⊙skel ⟧)
⊙cw-incl-tail (inl idp) ⊙skel = ⊙idf ⊙⟦ ⊙skel ⟧
⊙cw-incl-tail (inr ltS) ⊙skel = ⊙cw-incl-last ⊙skel
⊙cw-incl-tail (inr (ltSR lt)) ⊙skel =
  ⊙cw-incl-last ⊙skel ⊙∘ ⊙cw-incl-tail (inr lt) (⊙cw-init ⊙skel)

-- Extra conditions on CW complexes

-- 1. decidable equalities
has-cells-with-dec-eq : ∀ {n} → Skeleton n → Type i
has-cells-with-dec-eq {n = O} skel = has-dec-eq (cells-last skel)
has-cells-with-dec-eq {n = S n} skel =
  has-cells-with-dec-eq (cw-init skel) × has-dec-eq (cells-last skel)

⊙has-cells-with-dec-eq : ∀ {n} → ⊙Skeleton n → Type i
⊙has-cells-with-dec-eq = has-cells-with-dec-eq ∘ ⊙Skeleton.skel

cells-last-has-dec-eq : ∀ {n} (skel : Skeleton n)
  → has-cells-with-dec-eq skel → has-dec-eq (cells-last skel)
cells-last-has-dec-eq {n = O} skel dec = dec
cells-last-has-dec-eq {n = S n} skel dec = snd dec

init-has-cells-with-dec-eq : ∀ {n} (skel : Skeleton (S n))
  → has-cells-with-dec-eq skel
  → has-cells-with-dec-eq (cw-init skel)
init-has-cells-with-dec-eq skel dec = fst dec

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

cells-nth-has-dec-eq : ∀ {m n} (m≤n : m ≤ n) (skel : Skeleton n)
  → has-cells-with-dec-eq skel → has-dec-eq (cells-nth m≤n skel)
cells-nth-has-dec-eq m≤n skel dec =
  cells-last-has-dec-eq (cw-take m≤n skel)
    (take-has-cells-with-dec-eq m≤n skel dec)

has-cells-with-dec-eq-is-prop : ∀ {n} {skel : Skeleton n}
  → is-prop (has-cells-with-dec-eq skel)
has-cells-with-dec-eq-is-prop {n = O} = has-dec-eq-is-prop
has-cells-with-dec-eq-is-prop {n = S n} =
  ×-level has-cells-with-dec-eq-is-prop has-dec-eq-is-prop

-- 2. choice
has-cells-with-choice : TLevel → {n : ℕ} → Skeleton n → (j : ULevel) → Type (lmax i (lsucc j))
has-cells-with-choice t {n = O} skel j = has-choice t (cells-last skel) j
has-cells-with-choice t {n = S n} skel j =
  has-cells-with-choice t (cw-init skel) j × has-choice t (cells-last skel) j

⊙has-cells-with-choice : TLevel → {n : ℕ} → ⊙Skeleton n → (j : ULevel) → Type (lmax i (lsucc j))
⊙has-cells-with-choice t ⊙skel j = has-cells-with-choice t (⊙Skeleton.skel ⊙skel) j

⊙cells-last-has-choice : {t : TLevel} {n : ℕ} (⊙skel : ⊙Skeleton n) {j : ULevel}
  → ⊙has-cells-with-choice t ⊙skel j
  → has-choice t (⊙cells-last ⊙skel) j
⊙cells-last-has-choice {n = O} ⊙skel ac = ac
⊙cells-last-has-choice {n = S n} ⊙skel ac = snd ac

⊙init-has-cells-with-choice : {t : TLevel} {n : ℕ} (⊙skel : ⊙Skeleton (S n)) {j : ULevel}
  → ⊙has-cells-with-choice t ⊙skel j
  → ⊙has-cells-with-choice t (⊙cw-init ⊙skel) j
⊙init-has-cells-with-choice ⊙skel ac = fst ac

⊙take-has-cells-with-choice : {t : TLevel} {m n : ℕ} (m≤n : m ≤ n) (⊙skel : ⊙Skeleton n) {j : ULevel}
  → ⊙has-cells-with-choice t ⊙skel j
  → ⊙has-cells-with-choice t (⊙cw-take m≤n ⊙skel) j
⊙take-has-cells-with-choice (inl idp) ⊙skel ac = ac
⊙take-has-cells-with-choice (inr ltS) ⊙skel ac = ⊙init-has-cells-with-choice ⊙skel ac
⊙take-has-cells-with-choice (inr (ltSR lt)) ⊙skel ac
  = ⊙take-has-cells-with-choice (inr lt) (⊙cw-init ⊙skel) (⊙init-has-cells-with-choice ⊙skel ac)

⊙cells-nth-has-choice : {t : TLevel} {m n : ℕ} (m≤n : m ≤ n) (⊙skel : ⊙Skeleton n) {j : ULevel}
  → ⊙has-cells-with-choice t ⊙skel j
  → has-choice t (⊙cells-nth m≤n ⊙skel) j
⊙cells-nth-has-choice m≤n ⊙skel ac = ⊙cells-last-has-choice (⊙cw-take m≤n ⊙skel)
  (⊙take-has-cells-with-choice m≤n ⊙skel ac)

{-
The following are not needed.

-- Dimensional lifting

cw-lift₁ : ∀ {n : ℕ} → Skeleton n → Skeleton (S n)
cw-lift₁ skel = attached-skeleton skel
  (Lift Empty , Lift-level Empty-is-set)
  λ{(lift ()) _}

-- This slightly stretches the naming convension
-- to two skeletons being extensionally equal.
cw-lift₁-equiv : ∀ {n} (skel : Skeleton n)
  → ⟦ cw-lift₁ skel ⟧ ≃ ⟦ skel ⟧
cw-lift₁-equiv skel = equiv to incl to-incl incl-to
  where
    to : ⟦ cw-lift₁ skel ⟧ → ⟦ skel ⟧
    to = Attached-rec (idf ⟦ skel ⟧) (λ{(lift ())}) (λ{(lift ()) _})

    to-incl : ∀ x → to (incl x) == x
    to-incl _ = idp

    incl-to : ∀ x → incl (to x) == x
    incl-to = Attached-elim (λ _ → idp) (λ{(lift ())}) (λ{(lift ()) _})

cw-lift : ∀ {n m : ℕ} → n < m → Skeleton n → Skeleton m
cw-lift ltS = cw-lift₁
cw-lift (ltSR lt) = cw-lift₁ ∘ cw-lift lt
-}


------------------------------------------------------------------------
-- The Agda standard library
--
-- This module is DEPRECATED. Please use
-- Data.Vec.Relation.Binary.Equality.DecPropositional directly.
------------------------------------------------------------------------

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

open import Relation.Binary
open import Relation.Binary.PropositionalEquality

module Data.Vec.Relation.Equality.DecPropositional
  {a} {A : Set a} (_≟_ : Decidable {A = A} _≡_) where

open import Data.Vec.Relation.Binary.Equality.DecPropositional _≟_ public


{-# OPTIONS --safe #-}
module Cubical.Algebra.CommMonoid.Base where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.SIP

open import Cubical.Data.Sigma

open import Cubical.Algebra.Monoid

open import Cubical.Displayed.Base
open import Cubical.Displayed.Auto
open import Cubical.Displayed.Record
open import Cubical.Displayed.Universe

open import Cubical.Reflection.RecordEquiv

open Iso

private
  variable
    ℓ ℓ' : Level

record IsCommMonoid {M : Type ℓ}
                    (ε : M) (_·_ : M → M → M) : Type ℓ where
  constructor iscommmonoid

  field
    isMonoid : IsMonoid ε _·_
    ·Comm     : (x y : M) → x · y ≡ y · x

  open IsMonoid isMonoid public

unquoteDecl IsCommMonoidIsoΣ = declareRecordIsoΣ IsCommMonoidIsoΣ (quote IsCommMonoid)

record CommMonoidStr (M : Type ℓ) : Type ℓ where
  constructor commmonoidstr

  field
    ε            : M
    _·_          : M → M → M
    isCommMonoid : IsCommMonoid ε _·_

  infixl 7 _·_

  open IsCommMonoid isCommMonoid public

CommMonoid : ∀ ℓ → Type (ℓ-suc ℓ)
CommMonoid ℓ = TypeWithStr ℓ CommMonoidStr

makeIsCommMonoid : {M : Type ℓ} {ε : M} {_·_ : M → M → M}
                 (is-setM : isSet M)
                 (·Assoc   : (x y z : M) → x · (y · z) ≡ (x · y) · z)
                 (·IdR     : (x : M) → x · ε ≡ x)
                 (·Comm    : (x y : M) → x · y ≡ y · x)
               → IsCommMonoid ε _·_
IsCommMonoid.isMonoid (makeIsCommMonoid is-setM ·Assoc ·IdR ·Comm) =
  makeIsMonoid is-setM ·Assoc ·IdR (λ x → ·Comm _ _ ∙ ·IdR x)
IsCommMonoid.·Comm (makeIsCommMonoid is-setM ·Assoc ·IdR ·Comm) = ·Comm

makeCommMonoid : {M : Type ℓ} (ε : M) (_·_ : M → M → M)
               (is-setM : isSet M)
               (·Assoc : (x y z : M) → x · (y · z) ≡ (x · y) · z)
               (·IdR : (x : M) → x · ε ≡ x)
               (·Comm    : (x y : M) → x · y ≡ y · x)
             → CommMonoid ℓ
fst (makeCommMonoid ε _·_ is-setM ·Assoc ·IdR ·Comm) = _
CommMonoidStr.ε (snd (makeCommMonoid ε _·_ is-setM ·Assoc ·IdR ·Comm)) = ε
CommMonoidStr._·_ (snd (makeCommMonoid ε _·_ is-setM ·Assoc ·IdR ·Comm)) = _·_
CommMonoidStr.isCommMonoid (snd (makeCommMonoid ε _·_ is-setM ·Assoc ·IdR ·Comm)) =
  makeIsCommMonoid is-setM ·Assoc ·IdR ·Comm

CommMonoidStr→MonoidStr : {A : Type ℓ} → CommMonoidStr A → MonoidStr A
CommMonoidStr→MonoidStr (commmonoidstr _ _ H) = monoidstr _ _ (IsCommMonoid.isMonoid H)

CommMonoid→Monoid : CommMonoid ℓ → Monoid ℓ
CommMonoid→Monoid (_ , commmonoidstr  _ _ M) = _ , monoidstr _ _ (IsCommMonoid.isMonoid M)

isSetFromIsCommMonoid :
  {M : Type ℓ} {ε : M} {_·_ : M → M → M}
  (isCommMonoid : IsCommMonoid ε _·_)
  → isSet M
isSetFromIsCommMonoid isCommMonoid =
  let open IsCommMonoid isCommMonoid
  in is-set

isSetCommMonoid : (M : CommMonoid ℓ) → isSet ⟨ M ⟩
isSetCommMonoid M =
  let open CommMonoidStr (snd M)
  in isSetFromIsCommMonoid isCommMonoid

CommMonoidHom : (L : CommMonoid ℓ) (M : CommMonoid ℓ') → Type (ℓ-max ℓ ℓ')
CommMonoidHom L M = MonoidHom (CommMonoid→Monoid L) (CommMonoid→Monoid M)

IsCommMonoidEquiv : {A : Type ℓ} {B : Type ℓ'}
  (M : CommMonoidStr A) (e : A ≃ B) (N : CommMonoidStr B) → Type (ℓ-max ℓ ℓ')
IsCommMonoidEquiv M e N = IsMonoidHom (CommMonoidStr→MonoidStr M) (e .fst) (CommMonoidStr→MonoidStr N)

CommMonoidEquiv : (M : CommMonoid ℓ) (N : CommMonoid ℓ') → Type (ℓ-max ℓ ℓ')
CommMonoidEquiv M N = Σ[ e ∈ (M .fst ≃ N .fst) ] IsCommMonoidEquiv (M .snd) e (N .snd)

isPropIsCommMonoid : {M : Type ℓ} (ε : M) (_·_ : M → M → M)
             → isProp (IsCommMonoid ε _·_)
isPropIsCommMonoid ε _·_  =
  isOfHLevelRetractFromIso 1 IsCommMonoidIsoΣ
    (isPropΣ (isPropIsMonoid ε _·_)
             λ mon → isPropΠ2 (λ _ _ → mon .is-set _ _))
  where
  open IsMonoid

𝒮ᴰ-CommMonoid : DUARel (𝒮-Univ ℓ) CommMonoidStr ℓ
𝒮ᴰ-CommMonoid =
  𝒮ᴰ-Record (𝒮-Univ _) IsCommMonoidEquiv
    (fields:
      data[ ε ∣ autoDUARel _ _ ∣ presε ]
      data[ _·_ ∣ autoDUARel _ _ ∣ pres· ]
      prop[ isCommMonoid ∣ (λ _ _ → isPropIsCommMonoid _ _) ])
  where
  open CommMonoidStr
  open IsMonoidHom

CommMonoidPath : (M N : CommMonoid ℓ) → CommMonoidEquiv M N ≃ (M ≡ N)
CommMonoidPath = ∫ 𝒮ᴰ-CommMonoid .UARel.ua


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

open import Agda.Builtin.List
open import Agda.Builtin.Nat

infixl 6 _∷ʳ_

_∷ʳ_ : {A : Set} → List A → A → List A
[]        ∷ʳ x = x ∷ []
(hd ∷ tl) ∷ʳ x = hd ∷ tl ∷ʳ x

infixl 5 _∷ʳ′_

data InitLast {A : Set} : List A → Set where
  []    : InitLast []
  _∷ʳ′_ : (xs : List A) (x : A) → InitLast (xs ∷ʳ x)

initLast : {A : Set} (xs : List A) → InitLast xs
initLast []               = []
initLast (x ∷ xs)         with initLast xs
... | []       = [] ∷ʳ′ x
... | ys ∷ʳ′ y = (x ∷ ys) ∷ʳ′ y

f : (xs : List Nat) → Set
f xs with initLast xs
... | [] = {!!}
... | xs ∷ʳ′ x = {!!}

-- ^ Shadowing a variable that is bound implicitly in the `...` is allowed


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

open import lib.Basics
open import lib.types.TLevel
open import lib.types.Pi
open import lib.types.Sigma
open import lib.NType2

module lib.types.Truncation where

module _ {i} where

  postulate  -- HIT
    Trunc : (n : ℕ₋₂) (A : Type i) → Type i
    [_] : {n : ℕ₋₂} {A : Type i} → A → Trunc n A
    instance Trunc-level : {n : ℕ₋₂} {A : Type i} → has-level n (Trunc n A)

  module TruncElim {n : ℕ₋₂} {A : Type i} {j} {P : Trunc n A → Type j}
    {{p : (x : Trunc n A) → has-level n (P x)}} (d : (a : A) → P [ a ]) where

    postulate  -- HIT
      f : Π (Trunc n A) P
      [_]-β : ∀ a → f [ a ] ↦ d a
    {-# REWRITE [_]-β #-}

open TruncElim public renaming (f to Trunc-elim)

module TruncRec {i j} {n : ℕ₋₂} {A : Type i} {B : Type j} {{p : has-level n B}}
  (d : A → B) where

  private
    module M = TruncElim {{λ x → p}} d

  f : Trunc n A → B
  f = M.f

open TruncRec public renaming (f to Trunc-rec)

module TruncRecType {i j} {n : ℕ₋₂} {A : Type i} (d : A → n -Type j) where

  open TruncRec {{n -Type-level j}} d public

  flattening-Trunc : Σ (Trunc (S n) A) (fst ∘ f) ≃ Trunc (S n) (Σ A (fst ∘ d))
  flattening-Trunc = equiv to from to-from from-to where

    to-aux : (x : Trunc (S n) A) → (fst (f x) → Trunc (S n) (Σ A (fst ∘ d)))
    to-aux = Trunc-elim (λ a b → [ (a , b) ])

    to : Σ (Trunc (S n) A) (fst ∘ f) → Trunc (S n) (Σ A (fst ∘ d))
    to (x , y) = to-aux x y

    from-aux : Σ A (fst ∘ d) → Σ (Trunc (S n) A) (fst ∘ f)
    from-aux (a , b) = ([ a ] , b)

    from : Trunc (S n) (Σ A (fst ∘ d)) → Σ (Trunc (S n) A) (fst ∘ f)
    from = Trunc-rec {{Σ-level ⟨⟩ (λ x → raise-level _ (snd (f x)))}}
                     from-aux  where

    to-from : (x : Trunc (S n) (Σ A (fst ∘ d))) → to (from x) == x
    to-from = Trunc-elim (λ _ → idp)

    from-to-aux : (a : Trunc (S n) A) (b : fst (f a)) → from (to-aux a b) == (a , b)
    from-to-aux = Trunc-elim {{λ _ → Π-level (λ _ → =-preserves-level (Σ-level ⟨⟩ (λ x → raise-level _ (snd (f x)))))}}
                             (λ a b → idp)

    from-to : (x : Σ (Trunc (S n) A) (fst ∘ f)) → from (to x) == x
    from-to (a , b) = from-to-aux a b

⊙Trunc : ∀ {i} → ℕ₋₂ → Ptd i → Ptd i
⊙Trunc n ⊙[ A , a ] = ⊙[ Trunc n A , [ a ] ]

module _ {i} {n : ℕ₋₂} {A : Type i} where

  Trunc= : (a b : Trunc (S n) A) → n -Type i
  Trunc= = Trunc-elim (λ a → Trunc-elim ((λ b → (Trunc n (a == b) , Trunc-level))))

  Trunc=-equiv : (a b : Trunc (S n) A) → (a == b) ≃ fst (Trunc= a b)
  Trunc=-equiv a b = equiv (to a b) (from a b) (to-from a b) (from-to a b) where

    to-aux : (a : Trunc (S n) A) → fst (Trunc= a a)
    to-aux = Trunc-elim {{λ x → raise-level _ (snd (Trunc= x x))}}
                        (λ a → [ idp ])

    to : (a b : Trunc (S n) A) → (a == b → fst (Trunc= a b))
    to a .a idp = to-aux a

    from-aux : (a b : A) → a == b → [ a ] == [ b ] :> Trunc (S n) A
    from-aux a .a idp = idp

    from : (a b : Trunc (S n) A) → (fst (Trunc= a b) → a == b)
    from = Trunc-elim (λ a → Trunc-elim (λ b → Trunc-rec (from-aux a b)))

    to-from-aux : (a b : A) → (p : a == b) → to _ _ (from-aux a b p) == [ p ]
    to-from-aux a .a idp = idp

    to-from : (a b : Trunc (S n) A) (x : fst (Trunc= a b)) → to a b (from a b x) == x
    to-from = Trunc-elim {{λ x → Π-level (λ y → Π-level (λ _ → =-preserves-level (raise-level _ (snd (Trunc= x y)))))}}
              (λ a → Trunc-elim {{λ x → Π-level (λ _ → =-preserves-level (raise-level _ (snd (Trunc= [ a ] x))))}}
              (λ b → Trunc-elim
              (to-from-aux a b)))

    from-to-aux : (a : Trunc (S n) A) → from a a (to-aux a) == idp
    from-to-aux = Trunc-elim (λ _ → idp)

    from-to : (a b : Trunc (S n) A) (p : a == b) → from a b (to a b p) == p
    from-to a .a idp = from-to-aux a
  Trunc=-path : (a b : Trunc (S n) A) → (a == b) == fst (Trunc= a b)
  Trunc=-path a b = ua (Trunc=-equiv a b)

{- Universal property -}

abstract
  Trunc-rec-is-equiv : ∀ {i j} (n : ℕ₋₂) (A : Type i) (B : Type j)
    {{p : has-level n B}} → is-equiv (Trunc-rec {{p}} :> ((A → B) → (Trunc n A → B)))
  Trunc-rec-is-equiv n A B {{p}} = is-eq _ (λ f → f ∘ [_])
    (λ f → λ= (Trunc-elim (λ a → idp))) (λ f → idp)

Trunc-preserves-level : ∀ {i} {A : Type i} {n : ℕ₋₂} (m : ℕ₋₂)
 → has-level n A → has-level n (Trunc m A)
Trunc-preserves-level {n = ⟨-2⟩} _ p = has-level-in
  ([ contr-center p ] , Trunc-elim (λ a → ap [_] (contr-path p a)))
Trunc-preserves-level ⟨-2⟩ _ = contr-has-level Trunc-level
Trunc-preserves-level {n = (S n)} (S m) c = has-level-in (λ t₁ t₂ →
  Trunc-elim
    {{λ s₁ → prop-has-level-S {A = has-level n (s₁ == t₂)} has-level-is-prop}}
    (λ a₁ → Trunc-elim
      {{λ s₂ → prop-has-level-S {A = has-level n ([ a₁ ] == s₂)} has-level-is-prop}}
      (λ a₂ → equiv-preserves-level
      ((Trunc=-equiv [ a₁ ] [ a₂ ])⁻¹)
               {{Trunc-preserves-level {n = n} m (has-level-apply c a₁ a₂)}})
              t₂)
    t₁)

{- an n-type is equivalent to its n-truncation -}
unTrunc-equiv : ∀ {i} {n : ℕ₋₂} (A : Type i)
  {{_ : has-level n A}} → Trunc n A ≃ A
unTrunc-equiv A = equiv f [_] (λ _ → idp) g-f where
  f = Trunc-rec (idf _)
  g-f = Trunc-elim (λ _ → idp)

⊙unTrunc-equiv : ∀ {i} {n : ℕ₋₂} (X : Ptd i)
  {{_ : has-level n (de⊙ X)}} → ⊙Trunc n X ⊙≃ X
⊙unTrunc-equiv {n = n} X = ≃-to-⊙≃ (unTrunc-equiv (de⊙ X)) idp

-- Equivalence associated to the universal property
Trunc-extend-equiv : ∀ {i j} (n : ℕ₋₂) (A : Type i) (B : Type j)
  {{p : has-level n B}} → (A → B) ≃ (Trunc n A → B)
Trunc-extend-equiv n A B = (Trunc-rec , Trunc-rec-is-equiv n A B)

Trunc-fmap : ∀ {i j} {n : ℕ₋₂} {A : Type i} {B : Type j} → ((A → B) → (Trunc n A → Trunc n B))
Trunc-fmap f = Trunc-rec ([_] ∘ f)

⊙Trunc-fmap : ∀ {i j} {n : ℕ₋₂} {X : Ptd i} {Y : Ptd j} → ((X ⊙→ Y) → (⊙Trunc n X ⊙→ ⊙Trunc n Y))
⊙Trunc-fmap F = Trunc-fmap (fst F) , ap [_] (snd F)

Trunc-fmap2 : ∀ {i j k} {n : ℕ₋₂} {A : Type i} {B : Type j} {C : Type k}
  → ((A → B → C) → (Trunc n A → Trunc n B → Trunc n C))
Trunc-fmap2 f = Trunc-rec (λ a → Trunc-fmap (f a))

-- XXX What is the naming convention?
Trunc-fpmap : ∀ {i j} {n : ℕ₋₂} {A : Type i} {B : Type j} {f g : A → B}
  → f ∼ g → Trunc-fmap {n = n} f ∼ Trunc-fmap g
Trunc-fpmap h = Trunc-elim (ap [_] ∘ h)

Trunc-fmap-idf : ∀ {i} {n : ℕ₋₂} {A : Type i}
  → ∀ x → Trunc-fmap {n = n} (idf A) x == x
Trunc-fmap-idf =
  Trunc-elim (λ _ → idp)

Trunc-fmap-∘ : ∀ {i j k} {n : ℕ₋₂} {A : Type i} {B : Type j} {C : Type k}
  → (g : B → C) → (f : A → B)
  → ∀ x → Trunc-fmap {n = n} g (Trunc-fmap f x) == Trunc-fmap (g ∘ f) x
Trunc-fmap-∘ g f =
  Trunc-elim (λ _ → idp)

Trunc-csmap : ∀ {i₀ i₁ j₀ j₁} {n : ℕ₋₂}
  {A₀ : Type i₀} {A₁ : Type i₁} {B₀ : Type j₀} {B₁ : Type j₁}
  {f : A₀ → B₀} {g : A₁ → B₁} {hA : A₀ → A₁} {hB : B₀ → B₁}
  → CommSquare f g hA hB
  → CommSquare (Trunc-fmap {n = n} f) (Trunc-fmap g) (Trunc-fmap hA) (Trunc-fmap hB)
Trunc-csmap (comm-sqr cs) = comm-sqr $ Trunc-elim (ap [_] ∘ cs)

{- Pushing concatentation through Trunc= -}
module _ {i} {n : ℕ₋₂} {A : Type i} where

  {- concatenation in Trunc= -}
  Trunc=-∙ : {ta tb tc : Trunc (S n) A}
    → fst (Trunc= ta tb) → fst (Trunc= tb tc) → fst (Trunc= ta tc)
  Trunc=-∙ {ta = ta} {tb = tb} {tc = tc} =
    Trunc-elim {P = λ ta → C ta tb tc}
      {{λ ta → level ta tb tc}}
      (λ a → Trunc-elim {P = λ tb → C [ a ] tb tc}
         {{λ tb → level [ a ] tb tc}}
         (λ b → Trunc-elim {P = λ tc → C [ a ] [ b ] tc}
                  {{λ tc → level [ a ] [ b ] tc}}
                  (λ c → Trunc-fmap2 _∙_)
                  tc)
         tb)
      ta
    where
    C : (ta tb tc : Trunc (S n) A) → Type i
    C ta tb tc = fst (Trunc= ta tb) → fst (Trunc= tb tc) → fst (Trunc= ta tc)

    level : (ta tb tc : Trunc (S n) A) → has-level (S n) (C ta tb tc)
    level ta tb tc = raise-level _ $
              Π-level (λ _ → Π-level (λ _ → snd (Trunc= ta tc)))

  {- XXX naming convention -}
  Trunc=-∙-comm : {x y z : Trunc (S n) A }
    (p : x == y) (q : y == z)
    →  –> (Trunc=-equiv x z) (p ∙ q)
    == Trunc=-∙ {ta = x} (–> (Trunc=-equiv x y) p) (–> (Trunc=-equiv y z) q)
  Trunc=-∙-comm {x = x} idp idp =
    Trunc-elim
       {P = λ x → –> (Trunc=-equiv x x) idp
               == Trunc=-∙ {ta = x} (–> (Trunc=-equiv x x) idp)
                                    (–> (Trunc=-equiv x x) idp)}
       {{λ x → raise-level _ $ =-preserves-level (snd (Trunc= x x))}}
       (λ a → idp)
       x

{- naturality of Trunc=-equiv -}

module _ {i j} {n : ℕ₋₂} {A : Type i} {B : Type j} (f : A → B) where
  Trunc=-fmap : ∀ (a₀ a₁ : Trunc (S n) A)
    → (fst (Trunc= {n = n} a₀ a₁) → fst (Trunc= {n = n} (Trunc-fmap f a₀) (Trunc-fmap f a₁)))
  Trunc=-fmap = Trunc-elim
    {P = λ a₀ → ∀ a₁ → (fst (Trunc= a₀ a₁) → fst (Trunc= (Trunc-fmap f a₀) (Trunc-fmap f a₁)))}
    {{λ a₀ → Π-level λ a₁ → Π-level λ _ → raise-level _ $ snd (Trunc= (Trunc-fmap f a₀) (Trunc-fmap f a₁))}}
    (λ a₀ → Trunc-elim
      {P = λ a₁ → (fst (Trunc= [ a₀ ] a₁) → fst (Trunc= [ f a₀ ] (Trunc-fmap f a₁)))}
      {{λ a₁ → Π-level λ _ → raise-level _ $ snd (Trunc= [ f a₀ ] (Trunc-fmap f a₁))}}
      (λ a₁ → Trunc-fmap (ap f)))

module _ {i j} {n : ℕ₋₂} {A : Type i} {B : Type j} (f : A → B) where
  Trunc=-equiv-nat : ∀ (a₀ a₁ : Trunc (S n) A) (p : a₀ == a₁)
     →  –> (Trunc=-equiv (Trunc-fmap f a₀) (Trunc-fmap f a₁)) (ap (Trunc-fmap f) p)
     == Trunc=-fmap f a₀ a₁ (–> (Trunc=-equiv a₀ a₁) p)
  Trunc=-equiv-nat a₀ .a₀ idp =
    Trunc-elim
      {P = λ a
        →  –> (Trunc=-equiv (Trunc-fmap f a) (Trunc-fmap f a)) idp
        == Trunc=-fmap f a a (–> (Trunc=-equiv a a) idp)}
      {{λ a → raise-level _ $ =-preserves-level $ snd ((Trunc= (Trunc-fmap f a) (Trunc-fmap f a)))}}
      (λ _ → idp)
      a₀

{- Truncation preserves equivalences - more convenient than univalence+ap
 - when we need to know the forward or backward function explicitly -}
module _ {i j} {n : ℕ₋₂} {A : Type i} {B : Type j} where

  Trunc-isemap : {f : A → B} → is-equiv f → is-equiv (Trunc-fmap {n = n} f)
  Trunc-isemap {f-orig} ie = is-eq f g f-g g-f where
    f = Trunc-fmap f-orig
    g = Trunc-fmap (is-equiv.g ie)

    f-g : ∀ tb → f (g tb) == tb
    f-g = Trunc-elim (ap [_] ∘ is-equiv.f-g ie)

    g-f : ∀ ta → g (f ta) == ta
    g-f = Trunc-elim (ap [_] ∘ is-equiv.g-f ie)

  Trunc-emap : A ≃ B → Trunc n A ≃ Trunc n B
  Trunc-emap (f , f-ie) = Trunc-fmap f , Trunc-isemap f-ie

Trunc-csemap : ∀ {i₀ i₁ j₀ j₁} {n : ℕ₋₂}
  {A₀ : Type i₀} {A₁ : Type i₁} {B₀ : Type j₀} {B₁ : Type j₁}
  {f : A₀ → B₀} {g : A₁ → B₁} {hA : A₀ → A₁} {hB : B₀ → B₁}
  → CommSquareEquiv f g hA hB
  → CommSquareEquiv (Trunc-fmap {n = n} f) (Trunc-fmap g) (Trunc-fmap hA) (Trunc-fmap hB)
Trunc-csemap (cs , hA-ise , hB-ise) = Trunc-csmap cs , Trunc-isemap hA-ise , Trunc-isemap hB-ise

transport-Trunc : ∀ {i j} {A : Type i} {n : ℕ₋₂} (P : A → Type j)
  {x y : A} (p : x == y) (b : P x)
  → transport (Trunc n ∘ P) p [ b ] == [ transport P p b ]
transport-Trunc _ idp _ = idp

Trunc-fuse : ∀ {i} (A : Type i) (m n : ℕ₋₂)
  → Trunc m (Trunc n A) ≃ Trunc (minT m n) A
Trunc-fuse A m n = equiv
  (Trunc-rec {{raise-level-≤T (minT≤l m n) Trunc-level}}
    (Trunc-rec {{raise-level-≤T (minT≤r m n) Trunc-level}}
      [_]))
  (Trunc-rec ([_] ∘ [_]))
  (Trunc-elim (λ _ → idp))
  (Trunc-elim (Trunc-elim
       {{λ _ → =-preserves-level (Trunc-preserves-level _ Trunc-level)}}
       (λ _ → idp)))
  where
      instance
        l : has-level (minT m n) (Trunc m (Trunc n A))
        l with (minT-out m n)
        l | inl p = transport (λ k → has-level k (Trunc m (Trunc n A)))
                              (! p) Trunc-level
        l | inr q = Trunc-preserves-level _
                      (transport (λ k → has-level k (Trunc n A))
                                 (! q) Trunc-level)

Trunc-fuse-≤ : ∀ {i} (A : Type i) {m n : ℕ₋₂} (m≤n : m ≤T n)
  → Trunc m (Trunc n A) ≃ Trunc m A
Trunc-fuse-≤ A m≤n = equiv
  (Trunc-rec (Trunc-rec {{raise-level-≤T m≤n Trunc-level}}
      [_]))
  (Trunc-rec ([_] ∘ [_]))
  (Trunc-elim (λ _ → idp))
  (Trunc-elim (Trunc-elim
       {{λ _ → =-preserves-level (Trunc-preserves-level _ Trunc-level)}}
       (λ _ → idp)))

{- Truncating a binary product is equivalent to truncating its components -}
Trunc-×-econv : ∀ {i} {j} (n : ℕ₋₂) (A : Type i) (B : Type j)
  → Trunc n (A × B) ≃ Trunc n A × Trunc n B
Trunc-×-econv n A B = equiv f g f-g g-f
  where
  f : Trunc n (A × B) → Trunc n A × Trunc n B
  f = Trunc-rec (λ {(a , b) → [ a ] , [ b ]})

  g : Trunc n A × Trunc n B → Trunc n (A × B)
  g (ta , tb) = Trunc-rec (λ a → Trunc-rec (λ b → [ a , b ]) tb) ta

  f-g : ∀ p → f (g p) == p
  f-g (ta , tb) = Trunc-elim
    {P = λ ta → f (g (ta , tb)) == (ta , tb)}
    (λ a → Trunc-elim
      {P = λ tb → f (g ([ a ] , tb)) == ([ a ] , tb)}
      (λ b → idp)
      tb)
    ta

  g-f : ∀ tab → g (f tab) == tab
  g-f = Trunc-elim
    {P = λ tab → g (f tab) == tab}
    (λ ab → idp)

Trunc-×-conv : ∀ {i} {j} (n : ℕ₋₂) (A : Type i) (B : Type j)
  → Trunc n (A × B) == Trunc n A × Trunc n B
Trunc-×-conv n A B = ua (Trunc-×-econv n A B)


------------------------------------------------------------------------
-- The Agda standard library
--
-- Properties of Rational numbers
------------------------------------------------------------------------

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

module Data.Rational.Properties where

open import Function using (_∘_ ; _$_)
open import Data.Integer as ℤ using (ℤ; ∣_∣; +_; -[1+_])
open import Data.Integer.Coprimality using (coprime-divisor)
import Data.Integer.Properties as ℤ
open import Data.Rational.Base
open import Data.Nat as ℕ using (ℕ; zero; suc)
import Data.Nat.Properties as ℕ
open import Data.Nat.Coprimality as C using (Coprime; coprime?)
open import Data.Nat.Divisibility hiding (/-cong)
open import Data.Product using (_,_)
open import Data.Sum
open import Relation.Binary
open import Relation.Binary.PropositionalEquality
open import Relation.Nullary using (Dec; yes; no; recompute)
open import Relation.Nullary.Decidable as Dec′ using (True; fromWitness)

open import Algebra.FunctionProperties {A = ℚ} _≡_
open import Algebra.FunctionProperties.Consequences.Propositional

------------------------------------------------------------------------
-- Helper lemmas

private
  recomputeCP : ∀ {n d} → .(Coprime n (suc d)) → Coprime n (suc d)
  recomputeCP {n} {d-1} c = recompute (coprime? n (suc d-1)) c

------------------------------------------------------------------------
-- Equality

≡⇒≃ : _≡_ ⇒ _≃_
≡⇒≃ refl = refl

≃⇒≡ : _≃_ ⇒ _≡_
≃⇒≡ {i = mkℚ n₁ d₁ c₁} {j = mkℚ n₂ d₂ c₂} eq = helper
  where
  open ≡-Reasoning

  1+d₁∣1+d₂ : suc d₁ ∣ suc d₂
  1+d₁∣1+d₂ = coprime-divisor (+ suc d₁) n₁ (+ suc d₂)
    (C.sym (recomputeCP c₁)) $
    divides ∣ n₂ ∣ $ begin
      ∣ n₁ ℤ.* + suc d₂ ∣  ≡⟨ cong ∣_∣ eq ⟩
      ∣ n₂ ℤ.* + suc d₁ ∣  ≡⟨ ℤ.abs-*-commute n₂ (+ suc d₁) ⟩
      ∣ n₂ ∣ ℕ.* suc d₁    ∎

  1+d₂∣1+d₁ : suc d₂ ∣ suc d₁
  1+d₂∣1+d₁ = coprime-divisor (+ suc d₂) n₂ (+ suc d₁)
    (C.sym (recomputeCP c₂)) $
    divides ∣ n₁ ∣ (begin
      ∣ n₂ ℤ.* + suc d₁ ∣  ≡⟨ cong ∣_∣ (sym eq) ⟩
      ∣ n₁ ℤ.* + suc d₂ ∣  ≡⟨ ℤ.abs-*-commute n₁ (+ suc d₂) ⟩
      ∣ n₁ ∣ ℕ.* suc d₂    ∎)

  helper : mkℚ n₁ d₁ c₁ ≡ mkℚ n₂ d₂ c₂
  helper with ∣-antisym 1+d₁∣1+d₂ 1+d₂∣1+d₁
  ... | refl with ℤ.*-cancelʳ-≡ n₁ n₂ (+ suc d₁) (λ ()) eq
  ...   | refl = refl

infix 4 _≟_

_≟_ : Decidable {A = ℚ} _≡_
p ≟ q with (↥ p ℤ.* ↧ q) ℤ.≟ (↥ q ℤ.* ↧ p)
... | yes pq≃qp = yes (≃⇒≡ pq≃qp)
... | no ¬pq≃qp = no (¬pq≃qp ∘ ≡⇒≃)

------------------------------------------------------------------------
-- _≤_

infix 4 _≤?_

drop-*≤* : ∀ {p q} → p ≤ q → (↥ p ℤ.* ↧ q) ℤ.≤ (↥ q ℤ.* ↧ p)
drop-*≤* (*≤* pq≤qp) = pq≤qp

≤-reflexive : _≡_ ⇒ _≤_
≤-reflexive refl = *≤* ℤ.≤-refl

≤-refl : Reflexive _≤_
≤-refl = ≤-reflexive refl

≤-trans : Transitive _≤_
≤-trans {i = p@(mkℚ n₁ d₁ c₁)} {j = q@(mkℚ n₂ d₂ c₂)} {k = r@(mkℚ n₃ d₃ c₃)} (*≤* eq₁) (*≤* eq₂)
  = *≤* $ ℤ.*-cancelʳ-≤-pos (n₁ ℤ.* ℤ.+ suc d₃) (n₃ ℤ.* ℤ.+ suc d₁) d₂ $ begin
  let sd₁ = ↧ p; sd₂ = ↧ q; sd₃ = ↧ r in
  (n₁  ℤ.* sd₃) ℤ.* sd₂  ≡⟨ ℤ.*-assoc n₁ sd₃ sd₂ ⟩
  n₁   ℤ.* (sd₃ ℤ.* sd₂) ≡⟨ cong (n₁ ℤ.*_) (ℤ.*-comm sd₃ sd₂) ⟩
  n₁   ℤ.* (sd₂ ℤ.* sd₃) ≡⟨ sym (ℤ.*-assoc n₁ sd₂ sd₃) ⟩
  (n₁  ℤ.* sd₂) ℤ.* sd₃  ≤⟨ ℤ.*-monoʳ-≤-pos d₃ eq₁ ⟩
  (n₂  ℤ.* sd₁) ℤ.* sd₃  ≡⟨ cong (ℤ._* sd₃) (ℤ.*-comm n₂ sd₁) ⟩
  (sd₁ ℤ.* n₂)  ℤ.* sd₃  ≡⟨ ℤ.*-assoc sd₁ n₂ sd₃ ⟩
  sd₁  ℤ.* (n₂  ℤ.* sd₃) ≤⟨ ℤ.*-monoˡ-≤-pos d₁ eq₂ ⟩
  sd₁  ℤ.* (n₃  ℤ.* sd₂) ≡⟨ sym (ℤ.*-assoc sd₁ n₃ sd₂) ⟩
  (sd₁ ℤ.* n₃)  ℤ.* sd₂  ≡⟨ cong (ℤ._* sd₂) (ℤ.*-comm sd₁ n₃) ⟩
  (n₃  ℤ.* sd₁) ℤ.* sd₂  ∎
  where open ℤ.≤-Reasoning

≤-antisym : Antisymmetric _≡_ _≤_
≤-antisym (*≤* le₁) (*≤* le₂) = ≃⇒≡ (ℤ.≤-antisym le₁ le₂)

≤-total : Total _≤_
≤-total p q = [ inj₁ ∘ *≤* , inj₂ ∘ *≤* ]′ (ℤ.≤-total
  (↥ p ℤ.* ↧ q)
  (↥ q ℤ.* ↧ p))

_≤?_ : Decidable _≤_
p ≤? q = Dec′.map′ *≤* drop-*≤* ((↥ p ℤ.* ↧ q) ℤ.≤? (↥ q ℤ.* ↧ p))

≤-isPreorder : IsPreorder _≡_ _≤_
≤-isPreorder = record
  { isEquivalence = isEquivalence
  ; reflexive     = ≤-reflexive
  ; trans         = ≤-trans
  }

≤-isPartialOrder : IsPartialOrder _≡_ _≤_
≤-isPartialOrder = record
  { isPreorder = ≤-isPreorder
  ; antisym    = ≤-antisym
  }

≤-isTotalOrder : IsTotalOrder _≡_ _≤_
≤-isTotalOrder = record
  { isPartialOrder = ≤-isPartialOrder
  ; total          = ≤-total
  }

≤-isDecTotalOrder : IsDecTotalOrder _≡_ _≤_
≤-isDecTotalOrder = record
  { isTotalOrder = ≤-isTotalOrder
  ; _≟_          = _≟_
  ; _≤?_         = _≤?_
  }

≤-decTotalOrder : DecTotalOrder _ _ _
≤-decTotalOrder = record
  { Carrier         = ℚ
  ; _≈_             = _≡_
  ; _≤_             = _≤_
  ; isDecTotalOrder = ≤-isDecTotalOrder
  }

≤-irrelevant : Irrelevant _≤_
≤-irrelevant (*≤* x₁) (*≤* x₂) = cong *≤* (ℤ.≤-irrelevant x₁ x₂)

------------------------------------------------------------------------
-- DEPRECATED NAMES
------------------------------------------------------------------------
-- Please use the new names as continuing support for the old names is
-- not guaranteed.

-- Version 1.0

≤-irrelevance = ≤-irrelevant
{-# WARNING_ON_USAGE ≤-irrelevance
"Warning: ≤-irrelevance was deprecated in v1.0.
Please use ≤-irrelevant instead."
#-}


{-# OPTIONS --guardedness #-}
module Builtin.Coinduction where

open import Agda.Builtin.Coinduction public


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

-- This file contains an implementation of the stack-based compiler for Hutton's
-- razor, as from:
--
--   P. Bahr and G. Hutton, “Calculating correct compilers,” Journal of
--   Functional Programming, vol. 25, no. e14, Sep. 2015,
--   doi: 10.1017/S0956796815000180.
--
-- The compiler is total and the evaluator is stack-safe, and furthermore we have
-- proven a full isomorphism between the code representation and the AST.

module Data.Dyck.Except where

open import Prelude
open import Data.Nat using (_+_)
open import Data.Vec.Iterated using (Vec; _∷_; []; foldlN; head)

private
  variable
    n : ℕ

--------------------------------------------------------------------------------
-- Language for Arithmetic Expressions
--------------------------------------------------------------------------------

data Expr (A : Type a) : Type a where
  [_] : A → Expr A
  _⊕_ : Expr A → Expr A → Expr A

  throw : Expr A
  catch : Expr A → Expr A → Expr A

--------------------------------------------------------------------------------
-- Code for the virtual stack machine.
--------------------------------------------------------------------------------

data Code (A : Type a) : ℕ → Type a where
  HALT : Code A 1

  PUSH : A → Code A (1 + n) → Code A n
  ADD  : Code A (1 + n) → Code A (2 + n)

  RAISE : Code A (1 + n) → Code A n
  CATCH : Code A (1 + n) → Code A (2 + n)

--------------------------------------------------------------------------------
-- Conversion from a Code to a Expr (evaluation / execution)
--------------------------------------------------------------------------------

code→expr⊙ : Code A n → Vec (Expr A) n → Expr A
code→expr⊙ HALT        (v ∷ [])       = v
code→expr⊙ (PUSH v is) st             = code→expr⊙ is ([ v ] ∷ st)
code→expr⊙ (ADD    is) (t₁ ∷ t₂ ∷ st) = code→expr⊙ is (t₂ ⊕ t₁ ∷ st)
code→expr⊙ (RAISE  is) st             = code→expr⊙ is (throw ∷ st)
code→expr⊙ (CATCH  is) (t₁ ∷ t₂ ∷ st) = code→expr⊙ is (catch t₂ t₁ ∷ st)

code→expr : Code A zero → Expr A
code→expr ds = code→expr⊙ ds []

--------------------------------------------------------------------------------
-- Conversion from a Expr to a Code (compilation)
--------------------------------------------------------------------------------

expr→code⊙ : Expr A → Code A (1 + n) → Code A n
expr→code⊙ [ x ]         = PUSH x
expr→code⊙ (xs ⊕ ys)     = expr→code⊙ xs ∘ expr→code⊙ ys ∘ ADD
expr→code⊙ throw         = RAISE
expr→code⊙ (catch xs ys) = expr→code⊙ xs ∘ expr→code⊙ ys ∘ CATCH

expr→code : Expr A → Code A 0
expr→code tr = expr→code⊙ tr HALT

--------------------------------------------------------------------------------
-- Execution
--------------------------------------------------------------------------------

Func : Type a → ℕ → Type _
Func A zero    = Maybe A
Func A (suc n) = Maybe A → Func A n

open import Data.Maybe.Sugar

exec : Code ℕ n → Func ℕ n
exec HALT        = λ x → x
exec (PUSH x xs) = exec xs (just x)
exec (ADD    xs) = λ x₂ x₁ → exec xs ⦇ x₁ + x₂ ⦈
exec (RAISE  xs) = exec xs nothing
exec (CATCH  xs) = λ x₂ x₁ → exec xs (x₁ <|> x₂)

_ : exec (expr→code (catch ([ 3 ] ⊕ throw) ([ 10 ] ⊕ [ 2 ]))) ≡ just 12
_ = refl

--------------------------------------------------------------------------------
-- Proof of isomorphism
--------------------------------------------------------------------------------

expr→code→expr⊙ : {is : Code A (1 + n)} {st : Vec (Expr A) n} (e : Expr A) →
  code→expr⊙ (expr→code⊙ e is) st ≡ code→expr⊙ is (e ∷ st)
expr→code→expr⊙ [ x ]         = refl
expr→code→expr⊙ (xs ⊕ ys)     = expr→code→expr⊙ xs ; expr→code→expr⊙ ys
expr→code→expr⊙ throw         = refl
expr→code→expr⊙ (catch xs ys) = expr→code→expr⊙ xs ; expr→code→expr⊙ ys

code→expr→code⊙ : {st : Vec (Expr A) n} (is : Code A n) →
 expr→code (code→expr⊙ is st) ≡ foldlN (Code A) expr→code⊙ is st
code→expr→code⊙  HALT       = refl
code→expr→code⊙ (PUSH i is) = code→expr→code⊙ is
code→expr→code⊙ (ADD    is) = code→expr→code⊙ is
code→expr→code⊙ (RAISE  is) = code→expr→code⊙ is
code→expr→code⊙ (CATCH  is) = code→expr→code⊙ is

prog-iso : Code A 0 ⇔ Expr A
prog-iso .fun = code→expr
prog-iso .inv = expr→code
prog-iso .rightInv = expr→code→expr⊙
prog-iso .leftInv  = code→expr→code⊙


{-# OPTIONS --universe-polymorphism #-}
open import Categories.Category
open import Categories.Object.Products

module Categories.Object.Products.N-ary {o ℓ e}
  (C : Category o ℓ e)
  (P : Products C)
  where

open Category C
open Products P
open Equiv

import Categories.Object.Product
open Categories.Object.Product C

import Categories.Object.BinaryProducts
open Categories.Object.BinaryProducts C

import Categories.Object.BinaryProducts.N-ary

import Categories.Object.Terminal
open Categories.Object.Terminal C

open import Data.Nat
open import Data.Vec
open import Data.Vec.Properties
open import Data.Product.N-ary hiding ([])

import Level

open import Relation.Binary.PropositionalEquality as PropEq
  using ()
  renaming (_≡_ to _≣_
           ; refl to ≣-refl
           ; sym  to ≣-sym
           ; cong to ≣-cong
           )

open BinaryProducts binary
module NonEmpty = Categories.Object.BinaryProducts.N-ary C binary
open Terminal terminal

Prod : {n : ℕ} → Vec Obj n → Obj
Prod { zero} [] = ⊤
Prod {suc n} As = NonEmpty.Prod As

-- This whole module is made a great deal more heinous than it should be
-- by the fact that "xs ++ [] ≣ xs" is ill-typed, so I have to repeatedly
-- prove trivial corrolaries of that fact without using it directly.
-- I don't really know how to deal with that in a sane way.

πˡ : {n m : ℕ}
  → (As : Vec Obj n)
  → (Bs : Vec Obj m)
  → Prod (As ++ Bs) ⇒ Prod As
πˡ {       zero}      []       Bs  = !
πˡ {      suc n} (A ∷ As) (B ∷ Bs) = NonEmpty.πˡ (A ∷ As) (B ∷ Bs)
πˡ {   suc zero} (A ∷ [])      []  = id
πˡ {suc (suc n)} (A ∷ As)      []  = ⟨ π₁ , πˡ As [] ∘ π₂ ⟩

πʳ : {n m : ℕ}
  → (As : Vec Obj n)
  → (Bs : Vec Obj m)
  → Prod (As ++ Bs) ⇒ Prod Bs
πʳ [] Bs = id
πʳ (A ∷ As) (B ∷ Bs) = NonEmpty.πʳ (A ∷ As) (B ∷ Bs)
πʳ As [] = !

glue : {n m : ℕ}{X : Obj}
  → (As : Vec Obj n)
  → (Bs : Vec Obj m)
  → (f : X ⇒ Prod As)
  → (g : X ⇒ Prod Bs)
  → X ⇒ Prod (As ++ Bs)
glue {       zero}      []       Bs  f g = g
glue {      suc n} (A ∷ As) (B ∷ Bs) f g = NonEmpty.glue (A ∷ As) (B ∷ Bs) f g
glue {   suc zero} (A ∷ [])      []  f g = f
glue {suc (suc n)} (A ∷ As)      []  f g = ⟨ π₁ ∘ f , glue As [] (π₂ ∘ f) g ⟩

open HomReasoning

.commuteˡ : {n m : ℕ}{X : Obj}
  → (As : Vec Obj n)
  → (Bs : Vec Obj m)
  → {f : X ⇒ Prod As}
  → {g : X ⇒ Prod Bs}
  → πˡ As Bs ∘ glue As Bs f g ≡ f
commuteˡ {       zero}      []       Bs  {f}{g} = !-unique₂ (! ∘ g) f
commuteˡ {      suc n} (A ∷ As) (B ∷ Bs) {f}{g} = NonEmpty.commuteˡ (A ∷ As) (B ∷ Bs)
commuteˡ {   suc zero} (A ∷ [])      []  {f}{g} = identityˡ
commuteˡ {suc (suc n)} (A ∷ As)      []  {f}{g} =
  begin
    ⟨ π₁ , πˡ As [] ∘ π₂ ⟩ ∘ ⟨ π₁ ∘ f , glue As [] (π₂ ∘ f) g ⟩
  ↓⟨ ⟨⟩∘ ⟩
    ⟨ π₁              ∘ ⟨ π₁ ∘ f , glue As [] (π₂ ∘ f) g ⟩
    , (πˡ As [] ∘ π₂) ∘ ⟨ π₁ ∘ f , glue As [] (π₂ ∘ f) g ⟩
    ⟩
  ↓⟨ ⟨⟩-congʳ assoc ⟩
    ⟨ π₁            ∘ ⟨ π₁ ∘ f , glue As [] (π₂ ∘ f) g ⟩
    , πˡ As [] ∘ π₂ ∘ ⟨ π₁ ∘ f , glue As [] (π₂ ∘ f) g ⟩
    ⟩
  ↓⟨ ⟨⟩-cong₂ commute₁ (∘-resp-≡ʳ commute₂) ⟩
    ⟨ π₁ ∘ f , πˡ As [] ∘ glue As [] (π₂ ∘ f) g ⟩
  ↓⟨ ⟨⟩-congʳ (commuteˡ As []) ⟩
    ⟨ π₁ ∘ f , π₂ ∘ f ⟩
  ↓⟨ g-η ⟩
      f
  ∎

.commuteʳ : {n m : ℕ}{X : Obj}
  → (As : Vec Obj n)
  → (Bs : Vec Obj m)
  → {f : X ⇒ Prod As}
  → {g : X ⇒ Prod Bs}
  → πʳ As Bs ∘ glue As Bs f g ≡ g
commuteʳ {       zero}      []       Bs  {f}{g} = identityˡ
commuteʳ {      suc n} (A ∷ As) (B ∷ Bs) {f}{g} = NonEmpty.commuteʳ (A ∷ As) (B ∷ Bs)
commuteʳ {   suc zero} (A ∷ [])      []  {f}{g} = !-unique₂ (! ∘ f) g
commuteʳ {suc (suc n)} (A ∷ As)      []  {f}{g} = !-unique₂ (! ∘ glue (A ∷ As) [] f g) g

.N-universal : {n m : ℕ}{X : Obj}
  → (As : Vec Obj n)
  → (Bs : Vec Obj m)
  → {f : X ⇒ Prod As}
  → {g : X ⇒ Prod Bs}
  → {h : X ⇒ Prod (As ++ Bs) }
  → πˡ As Bs ∘ h ≡ f
  → πʳ As Bs ∘ h ≡ g
  → glue As Bs f g ≡ h
N-universal {       zero}      []       Bs  {f}{g}{h} h-commuteˡ h-commuteʳ = trans (sym h-commuteʳ) identityˡ
N-universal {      suc n} (A ∷ As) (B ∷ Bs) {f}{g}{h} h-commuteˡ h-commuteʳ = NonEmpty.N-universal (A ∷ As) (B ∷ Bs) h-commuteˡ h-commuteʳ
N-universal {   suc zero} (A ∷ [])      []  {f}{g}{h} h-commuteˡ h-commuteʳ = trans (sym h-commuteˡ) identityˡ
N-universal {suc (suc n)} (A ∷ As)      []  {f}{g}{h} h-commuteˡ h-commuteʳ =
  begin
    ⟨ π₁ ∘ f , glue As [] (π₂ ∘ f) g ⟩
  ↓⟨ ⟨⟩-congʳ (N-universal As [] π₂∘h-commuteˡ π₂∘h-commuteʳ) ⟩
    ⟨ π₁ ∘ f , π₂ ∘ h ⟩
  ↑⟨ ⟨⟩-congˡ π₁∘h-commuteˡ ⟩
    ⟨ π₁ ∘ h , π₂ ∘ h ⟩
  ↓⟨ g-η ⟩
    h
  ∎

  where
    -- h-commuteˡ : ⟨ π₁ , πˡ As [] ∘ π₂ ⟩ ∘ h ≡ f
    -- h-commuteʳ : (πʳ As [] ∘ π₂) ∘ h ≡ g

    π₁∘h-commuteˡ : π₁ ∘ h ≡ π₁ ∘ f
    π₁∘h-commuteˡ =
      begin
        π₁ ∘ h
      ↑⟨ commute₁ ⟩∘⟨ refl ⟩
        (π₁ ∘ ⟨ π₁ , πˡ As [] ∘ π₂ ⟩) ∘ h
      ↓⟨ assoc ⟩
        π₁ ∘ ⟨ π₁ , πˡ As [] ∘ π₂ ⟩ ∘ h
      ↓⟨ refl ⟩∘⟨ h-commuteˡ ⟩
        π₁ ∘ f
      ∎

    π₂∘h-commuteˡ :  πˡ As [] ∘ π₂ ∘ h ≡ π₂ ∘ f
    π₂∘h-commuteˡ =
      begin
        πˡ As [] ∘ π₂ ∘ h
      ↑⟨ assoc ⟩
        (πˡ As [] ∘ π₂) ∘ h
      ↑⟨ commute₂ ⟩∘⟨ refl ⟩
        (π₂ ∘ ⟨ π₁ , πˡ As [] ∘ π₂ ⟩) ∘ h
      ↓⟨ assoc ⟩
        π₂ ∘ ⟨ π₁ , πˡ As [] ∘ π₂ ⟩ ∘ h
      ↓⟨ refl ⟩∘⟨ h-commuteˡ ⟩
        π₂ ∘ f
      ∎

    π₂∘h-commuteʳ : πʳ As [] ∘ π₂ ∘ h ≡ g
    π₂∘h-commuteʳ = !-unique₂ (πʳ As [] ∘ π₂ ∘ h) g

isProduct : {n m : ℕ}
  → (As : Vec Obj n)
  → (Bs : Vec Obj m)
  → Product (Prod As) (Prod Bs)
isProduct {n}{m} As Bs = record
  { A×B   = Prod (As ++ Bs)
  ; π₁    = πˡ As Bs
  ; π₂    = πʳ As Bs
  ; ⟨_,_⟩ = glue As Bs
  ; commute₁ = commuteˡ As Bs
  ; commute₂ = commuteʳ As Bs
  ; universal = N-universal As Bs
  }


------------------------------------------------------------------------
-- Half adjoint equivalences
------------------------------------------------------------------------

-- This development is partly based on the presentation of half
-- adjoint equivalences in the HoTT book, and partly based on
-- Voevodsky's work on univalent foundations.

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

open import Equality

module Equivalence.Half-adjoint
  {e⁺} (eq : ∀ {a p} → Equality-with-J a p e⁺) where

open Derived-definitions-and-properties eq

open import Logical-equivalence using (_⇔_)
open import Prelude

open import Bijection eq as B using (_↔_)
import Equivalence.Contractible-preimages eq as CP
open import H-level eq as H-level
open import H-level.Closure eq
open import Preimage eq as Preimage using (_⁻¹_)
open import Surjection eq as S hiding (id; _∘_)

private
  variable
    a b p q : Level
    A B C   : Type a
    P       : A → Type p
    Q       : (x : A) → P x → Type q
    f g     : A → B
    A↔B     : A ↔ B

------------------------------------------------------------------------
-- The definition of Is-equivalence

mutual

  -- Is-equivalence f means that f is a half adjoint equivalence.

  Is-equivalence :
    {A : Type a} {B : Type b} →
    (A → B) → Type (a ⊔ b)
  Is-equivalence {A = A} {B = B} f =
    ∃ λ (f⁻¹ : B → A) → Proofs f f⁻¹

  -- The "proofs" contained in Is-equivalence f.

  Proofs :
    {A : Type a} {B : Type b} →
    (A → B) → (B → A) → Type (a ⊔ b)
  Proofs f f⁻¹ =
    ∃ λ (f-f⁻¹ : ∀ x → f (f⁻¹ x) ≡ x) →
    ∃ λ (f⁻¹-f : ∀ x → f⁻¹ (f x) ≡ x) →
      ∀ x → cong f (f⁻¹-f x) ≡ f-f⁻¹ (f x)

-- Some projections.

inverse :
  {@0 A : Type a} {@0 B : Type b} {@0 f : A → B} →
  Is-equivalence f → B → A
inverse = proj₁

right-inverse-of :
  {@0 A : Type a} {@0 B : Type b} {@0 f : A → B} →
  (eq : Is-equivalence f) →
  ∀ x → f (inverse eq x) ≡ x
right-inverse-of = proj₁ ∘ proj₂

left-inverse-of :
  {@0 A : Type a} {@0 B : Type b} {@0 f : A → B} →
  (eq : Is-equivalence f) →
  ∀ x → inverse eq (f x) ≡ x
left-inverse-of = proj₁ ∘ proj₂ ∘ proj₂

------------------------------------------------------------------------
-- Identity, inverse, composition

-- The identity function is an equivalence.

id-equivalence : Is-equivalence (id {A = A})
id-equivalence =
    id
  , refl
  , refl
  , (λ x →
       cong id (refl x)  ≡⟨ sym $ cong-id _ ⟩∎
       refl x            ∎)

-- If f is an equivalence, then its inverse is also an equivalence.

inverse-equivalence :
  (eq : Is-equivalence f) → Is-equivalence (inverse eq)
inverse-equivalence {f = f} (f⁻¹ , f-f⁻¹ , f⁻¹-f , f-f⁻¹-f) =
  f , f⁻¹-f , f-f⁻¹ , f⁻¹-f-f⁻¹
  where

  abstract

    f⁻¹-f-f⁻¹ : ∀ x → cong f⁻¹ (f-f⁻¹ x) ≡ f⁻¹-f (f⁻¹ x)
    f⁻¹-f-f⁻¹ x = subst
      (λ x → cong f⁻¹ (f-f⁻¹ x) ≡ f⁻¹-f (f⁻¹ x))
      (f-f⁻¹ x)
      (cong f⁻¹ (f-f⁻¹ (f (f⁻¹ x)))       ≡⟨ cong (cong f⁻¹) $ sym $ f-f⁻¹-f _ ⟩

       cong f⁻¹ (cong f (f⁻¹-f (f⁻¹ x)))  ≡⟨ cong-∘ f⁻¹ f _ ⟩

       cong (f⁻¹ ∘ f) (f⁻¹-f (f⁻¹ x))     ≡⟨ cong-≡id-≡-≡id f⁻¹-f ⟩∎

       f⁻¹-f (f⁻¹ (f (f⁻¹ x)))            ∎)

-- If f and g are inverses, then f ∘ g is an equivalence.

composition-equivalence :
  Is-equivalence f → Is-equivalence g → Is-equivalence (f ∘ g)
composition-equivalence
  {f = f} {g = g}
  (f⁻¹ , f-f⁻¹ , f⁻¹-f , f-f⁻¹-f)
  (g⁻¹ , g-g⁻¹ , g⁻¹-g , g-g⁻¹-g) =
    [f-g]⁻¹
  , [f-g]-[f-g]⁻¹
  , [f-g]⁻¹-[f-g]
  , [f-g]-[f-g]⁻¹-[f-g]
  where
  [f-g] = f ∘ g

  [f-g]⁻¹ = g⁻¹ ∘ f⁻¹

  [f-g]-[f-g]⁻¹ = λ x →
    f (g (g⁻¹ (f⁻¹ x)))  ≡⟨ cong f $ g-g⁻¹ _ ⟩
    f (f⁻¹ x)            ≡⟨ f-f⁻¹ _ ⟩∎
    x                    ∎

  [f-g]⁻¹-[f-g] = λ x →
    g⁻¹ (f⁻¹ (f (g x)))  ≡⟨ cong g⁻¹ $ f⁻¹-f _ ⟩
    g⁻¹ (g x)            ≡⟨ g⁻¹-g _ ⟩∎
    x                    ∎

  abstract

    [f-g]-[f-g]⁻¹-[f-g] :
      ∀ x → cong [f-g] ([f-g]⁻¹-[f-g] x) ≡ [f-g]-[f-g]⁻¹ ([f-g] x)
    [f-g]-[f-g]⁻¹-[f-g] x =
      cong (f ∘ g) (trans (cong g⁻¹ (f⁻¹-f (g x))) (g⁻¹-g x))           ≡⟨ trans (sym $ cong-∘ _ _ _) $
                                                                           cong (cong _) $
                                                                           trans (cong-trans _ _ _) $
                                                                           cong (flip trans _) $
                                                                           cong-∘ _ _ _ ⟩
      cong f (trans (cong (g ∘ g⁻¹) (f⁻¹-f (g x))) (cong g (g⁻¹-g x)))  ≡⟨ cong (cong _) $ cong (trans _) $ g-g⁻¹-g _ ⟩
      cong f (trans (cong (g ∘ g⁻¹) (f⁻¹-f (g x))) (g-g⁻¹ (g x)))       ≡⟨ cong (cong f) $ naturality g-g⁻¹ ⟩
      cong f (trans (g-g⁻¹ (f⁻¹ (f (g x)))) (cong id (f⁻¹-f (g x))))    ≡⟨ cong (cong _) $ cong (trans _) $ sym $ cong-id _ ⟩
      cong f (trans (g-g⁻¹ (f⁻¹ (f (g x)))) (f⁻¹-f (g x)))              ≡⟨ cong-trans _ _ _ ⟩
      trans (cong f (g-g⁻¹ (f⁻¹ (f (g x))))) (cong f (f⁻¹-f (g x)))     ≡⟨ cong (trans _) $ f-f⁻¹-f _ ⟩∎
      trans (cong f (g-g⁻¹ (f⁻¹ (f (g x))))) (f-f⁻¹ (f (g x)))          ∎

------------------------------------------------------------------------
-- Conversions to and from bijections

-- Equivalences are bijections (functions with quasi-inverses).

Is-equivalence→↔ :
  {@0 A : Type a} {@0 B : Type b} {f : A → B} →
  Is-equivalence f → A ↔ B
Is-equivalence→↔ {f = f} (f⁻¹ , f-f⁻¹ , f⁻¹-f , _) = record
  { surjection = record
    { logical-equivalence = record
      { to   = f
      ; from = f⁻¹
      }
    ; right-inverse-of = f-f⁻¹
    }
  ; left-inverse-of = f⁻¹-f
  }

-- Functions with quasi-inverses are equivalences.
--
-- Note that the left inverse proof is preserved unchanged.

↔→Is-equivalenceˡ :
  (A↔B : A ↔ B) → Is-equivalence (_↔_.to A↔B)
↔→Is-equivalenceˡ A↔B =
    from
  , right-inverse-of′
  , A↔B.left-inverse-of
  , left-right
  where
  open module A↔B = _↔_ A↔B using (to; from)

  abstract

    right-inverse-of′ : ∀ x → to (from x) ≡ x
    right-inverse-of′ x =
      to (from x)              ≡⟨ sym (A↔B.right-inverse-of _) ⟩
      to (from (to (from x)))  ≡⟨ cong to (A↔B.left-inverse-of _) ⟩
      to (from x)              ≡⟨ A↔B.right-inverse-of _ ⟩∎
      x                        ∎

    left-right :
      ∀ x → cong to (A↔B.left-inverse-of x) ≡ right-inverse-of′ (to x)
    left-right x =
      let lemma =
            trans (A↔B.right-inverse-of _)
              (cong to (A↔B.left-inverse-of _))                         ≡⟨ cong (trans _) $
                                                                           cong-id _ ⟩
            trans (A↔B.right-inverse-of _)
              (cong id (cong to (A↔B.left-inverse-of _)))               ≡⟨ sym $ naturality A↔B.right-inverse-of ⟩

            trans (cong (to ∘ from) (cong to (A↔B.left-inverse-of _)))
              (A↔B.right-inverse-of _)                                  ≡⟨ cong (flip trans _) $
                                                                           cong-∘ _ _ _ ⟩
            trans (cong (to ∘ from ∘ to) (A↔B.left-inverse-of _))
              (A↔B.right-inverse-of _)                                  ≡⟨ cong (flip trans _) $ sym $
                                                                           cong-∘ _ _ _ ⟩
            trans (cong to (cong (from ∘ to) (A↔B.left-inverse-of _)))
              (A↔B.right-inverse-of _)                                  ≡⟨ cong (flip trans _ ∘ cong to) $
                                                                           cong-≡id-≡-≡id A↔B.left-inverse-of ⟩∎
            trans (cong to (A↔B.left-inverse-of _))
              (A↔B.right-inverse-of _)                                  ∎
      in
      cong to (A↔B.left-inverse-of x)             ≡⟨ sym $ trans-sym-[trans] _ _ ⟩

      trans (sym (A↔B.right-inverse-of _))
        (trans (A↔B.right-inverse-of _)
           (cong to (A↔B.left-inverse-of _)))     ≡⟨ cong (trans _) lemma ⟩∎

      trans (sym (A↔B.right-inverse-of _))
        (trans (cong to (A↔B.left-inverse-of _))
           (A↔B.right-inverse-of _))              ∎

_ : proj₁ (↔→Is-equivalenceˡ A↔B) ≡ _↔_.from A↔B
_ = refl _

_ :
  proj₁ (proj₂ (proj₂ (↔→Is-equivalenceˡ A↔B))) ≡
  _↔_.left-inverse-of A↔B
_ = refl _

-- Functions with quasi-inverses are equivalences.
--
-- Note that the right inverse proof is preserved unchanged.

↔→Is-equivalenceʳ :
  (A↔B : A ↔ B) → Is-equivalence (_↔_.to A↔B)
↔→Is-equivalenceʳ =
  inverse-equivalence ∘
  ↔→Is-equivalenceˡ ∘
  B.inverse

_ : proj₁ (↔→Is-equivalenceʳ A↔B) ≡ _↔_.from A↔B
_ = refl _

_ : proj₁ (proj₂ (↔→Is-equivalenceʳ A↔B)) ≡ _↔_.right-inverse-of A↔B
_ = refl _

------------------------------------------------------------------------
-- Is-equivalence is related to CP.Is-equivalence (part one)

-- Is-equivalence f and CP.Is-equivalence f are logically equivalent.

Is-equivalence⇔Is-equivalence-CP :
  Is-equivalence f ⇔ CP.Is-equivalence f
Is-equivalence⇔Is-equivalence-CP = record
  { to   = to
  ; from = from
  }
  where
  to : Is-equivalence f → CP.Is-equivalence f
  to {f = f} (f⁻¹ , f-f⁻¹ , f⁻¹-f , f-f⁻¹-f) y =
      (f⁻¹ y , f-f⁻¹ y)
    , λ (x , f-f⁻¹′) →
      Σ-≡,≡→≡
        (f⁻¹ y      ≡⟨ sym $ cong f⁻¹ f-f⁻¹′ ⟩
         f⁻¹ (f x)  ≡⟨ f⁻¹-f x ⟩∎
         x          ∎)
        (elim¹
           (λ {y} f-f⁻¹′ →
              subst (λ x → f x ≡ y)
                (trans (sym (cong f⁻¹ f-f⁻¹′)) (f⁻¹-f x))
                (f-f⁻¹ y) ≡
              f-f⁻¹′)
           (subst (λ x′ → f x′ ≡ f x)
              (trans (sym (cong f⁻¹ (refl _))) (f⁻¹-f x))
              (f-f⁻¹ (f x))                                    ≡⟨ cong (flip (subst _) _) $
                                                                  trans (cong (flip trans _) $
                                                                         trans (cong sym $ cong-refl _) $
                                                                         sym-refl) $
                                                                  trans-reflˡ _ ⟩

            subst (λ x′ → f x′ ≡ f x) (f⁻¹-f x) (f-f⁻¹ (f x))  ≡⟨ subst-∘ _ _ _ ⟩

            subst (_≡ f x) (cong f (f⁻¹-f x)) (f-f⁻¹ (f x))    ≡⟨ subst-trans-sym ⟩

            trans (sym (cong f (f⁻¹-f x))) (f-f⁻¹ (f x))       ≡⟨ cong (flip trans _ ∘ sym) $
                                                                  f-f⁻¹-f _ ⟩

            trans (sym (f-f⁻¹ (f x))) (f-f⁻¹ (f x))            ≡⟨ trans-symˡ _ ⟩∎

            refl _                                             ∎)
           f-f⁻¹′)

  from : CP.Is-equivalence f → Is-equivalence f
  from eq =
      CP.inverse eq
    , CP.right-inverse-of eq
    , CP.left-inverse-of eq
    , CP.left-right-lemma eq

-- All fibres of an equivalence over a given point are equal to a
-- given fibre.

irrelevance :
  (eq : Is-equivalence f) →
  ∀ y (p : f ⁻¹ y) → (inverse eq y , right-inverse-of eq y) ≡ p
irrelevance =
  CP.irrelevance ∘
  _⇔_.to Is-equivalence⇔Is-equivalence-CP

-- When proving that a function is an equivalence one can assume that
-- the codomain is inhabited.

[inhabited→Is-equivalence]→Is-equivalence :
  {f : A → B} →
  (B → Is-equivalence f) → Is-equivalence f
[inhabited→Is-equivalence]→Is-equivalence hyp =
  _⇔_.from Is-equivalence⇔Is-equivalence-CP $ λ x →
  _⇔_.to Is-equivalence⇔Is-equivalence-CP (hyp x) x

------------------------------------------------------------------------
-- The "inverse of extensionality" is an equivalence (assuming
-- extensionality)

-- Is-equivalence respects extensional equality.

respects-extensional-equality :
  (∀ x → f x ≡ g x) →
  Is-equivalence f → Is-equivalence g
respects-extensional-equality
  {f = f} {g = g} f≡g (f⁻¹ , f-f⁻¹ , f⁻¹-f , f-f⁻¹-f) =
  ↔→Is-equivalenceʳ (record
    { surjection = record
      { logical-equivalence = record
        { to   = g
        ; from = f⁻¹
        }
      ; right-inverse-of = λ x →
          g (f⁻¹ x)  ≡⟨ sym $ f≡g _ ⟩
          f (f⁻¹ x)  ≡⟨ f-f⁻¹ _ ⟩∎
          x          ∎
      }
    ; left-inverse-of = λ x →
        f⁻¹ (g x)  ≡⟨ cong f⁻¹ $ sym $ f≡g _ ⟩
        f⁻¹ (f x)  ≡⟨ f⁻¹-f _ ⟩∎
        x          ∎
    })

-- Functions between contractible types are equivalences.

function-between-contractible-types-is-equivalence :
  ∀ {a b} {A : Type a} {B : Type b} (f : A → B) →
  Contractible A → Contractible B → Is-equivalence f
function-between-contractible-types-is-equivalence f A-contr B-contr =
  ↔→Is-equivalenceˡ (record
    { surjection = record
      { logical-equivalence = record
        { from = λ _ → proj₁ A-contr
        }
      ; right-inverse-of = λ x →
          f (proj₁ A-contr)  ≡⟨ sym $ proj₂ B-contr _ ⟩
          proj₁ B-contr      ≡⟨ proj₂ B-contr _ ⟩∎
          x                  ∎
      }
    ; left-inverse-of = proj₂ A-contr
    })

abstract

  -- If Σ-map id f is an equivalence, then f is also an equivalence.

  drop-Σ-map-id :
    {A : Type a} {P : A → Type p} {Q : A → Type q}
    (f : ∀ {x} → P x → Q x) →
    Is-equivalence {A = Σ A P} {B = Σ A Q} (Σ-map id f) →
    ∀ x → Is-equivalence (f {x = x})
  drop-Σ-map-id f eq x =
    _⇔_.from Is-equivalence⇔Is-equivalence-CP $
    CP.drop-Σ-map-id f
      (_⇔_.to Is-equivalence⇔Is-equivalence-CP eq)
      x

  -- A "computation" rule for drop-Σ-map-id.

  inverse-drop-Σ-map-id :
    {A : Type a} {P : A → Type p} {Q : A → Type q}
    {f : ∀ {x} → P x → Q x} {x : A} {y : Q x}
    {eq : Is-equivalence {A = Σ A P} {B = Σ A Q} (Σ-map id f)} →
    inverse (drop-Σ-map-id f eq x) y ≡
    subst P (cong proj₁ (right-inverse-of eq (x , y)))
      (proj₂ (inverse eq (x , y)))
  inverse-drop-Σ-map-id = CP.inverse-drop-Σ-map-id

  -- The function ext⁻¹ is an equivalence (assuming extensionality).

  ext⁻¹-is-equivalence :
    ({P : A → Type b} → Extensionality′ A P) →
    {P : A → Type b} {f g : (x : A) → P x} →
    Is-equivalence (ext⁻¹ {f = f} {g = g})
  ext⁻¹-is-equivalence {A = A} ext {P = P} {f = f} {g = g} =
    drop-Σ-map-id ext⁻¹ lemma₂ f
    where
    surj :
      (∀ x → Singleton (g x)) ↠
      (∃ λ (f : (x : A) → P x) → ∀ x → f x ≡ g x)
    surj = record
      { logical-equivalence = record
        { to   = λ f → proj₁ ∘ f , proj₂ ∘ f
        ; from = λ p x → proj₁ p x , proj₂ p x
        }
      ; right-inverse-of = refl
      }

    lemma₁ : Contractible (∃ λ (f : (x : A) → P x) → ∀ x → f x ≡ g x)
    lemma₁ =
      H-level.respects-surjection surj 0 $
        _⇔_.from Π-closure-contractible⇔extensionality
          ext (singleton-contractible ∘ g)

    lemma₂ :
      Is-equivalence
        {A = ∃ λ f → f ≡ g}
        {B = ∃ λ f → ∀ x → f x ≡ g x}
        (Σ-map id ext⁻¹)
    lemma₂ = function-between-contractible-types-is-equivalence
               _ (singleton-contractible g) lemma₁

------------------------------------------------------------------------
-- Results related to h-levels

abstract

  -- Is-equivalence f is a proposition (assuming extensionality).

  propositional :
    {A : Type a} {B : Type b} →
    Extensionality (a ⊔ b) (a ⊔ b) →
    (f : A → B) → Is-proposition (Is-equivalence f)
  propositional {a = a} {b = b} {A = A} {B = B} ext f =
    [inhabited⇒+]⇒+ 0 λ eq →
    mono₁ 0 $
    H-level.respects-surjection
      ((∃ λ ((f⁻¹ , f-f⁻¹) : ∃ λ f⁻¹ → ∀ x → f (f⁻¹ x) ≡ x) →
        ∃ λ (f⁻¹-f : ∀ x → f⁻¹ (f x) ≡ x) →
            ∀ x → cong f (f⁻¹-f x) ≡ f-f⁻¹ (f x))              ↠⟨ _↔_.surjection $ B.inverse B.Σ-assoc ⟩□

       Is-equivalence f                                        □)
      0 $
    Σ-closure 0 (lemma₁ eq) (uncurry $ lemma₂ eq)
    where
    ext₁ : Extensionality b b
    ext₁ = lower-extensionality a a ext

    ext₁′ : Extensionality b a
    ext₁′ = lower-extensionality a b ext

    ext-↠ :
      {A B : Type b} {f g : A → B} →
      f ≡ g ↠ (∀ x → f x ≡ g x)
    ext-↠ =
      _↔_.surjection $
      Is-equivalence→↔ $
      ext⁻¹-is-equivalence (apply-ext ext₁)

    lemma₁ :
      Is-equivalence f →
      Contractible (∃ λ (f⁻¹ : B → A) → ∀ x → f (f⁻¹ x) ≡ x)
    lemma₁ (f⁻¹ , f-f⁻¹ , f⁻¹-f , f-f⁻¹-f) =
      H-level.respects-surjection
        ((∃ λ f⁻¹ → f ∘ f⁻¹ ≡ id)         ↠⟨ (∃-cong λ _ → ext-↠) ⟩□
         (∃ λ f⁻¹ → ∀ x → f (f⁻¹ x) ≡ x)  □)
        0 $
      Preimage.bijection⁻¹-contractible
        (record
           { surjection = record
             { logical-equivalence = record
               { to   = f   ∘_
               ; from = f⁻¹ ∘_
               }
             ; right-inverse-of = λ g → apply-ext ext₁ λ x →
                 f (f⁻¹ (g x))  ≡⟨ f-f⁻¹ (g x) ⟩∎
                 g x            ∎
             }
           ; left-inverse-of = λ g → apply-ext ext₁′ λ x →
               f⁻¹ (f (g x))  ≡⟨ f⁻¹-f (g x) ⟩∎
               g x            ∎
           })
        id

    ext₂ : Extensionality a (a ⊔ b)
    ext₂ = lower-extensionality b lzero ext

    lemma₂ :
      Is-equivalence f →
      (f⁻¹ : B → A) (f-f⁻¹ : ∀ x → f (f⁻¹ x) ≡ x) →
      Contractible
        (∃ λ (f⁻¹-f : ∀ x → f⁻¹ (f x) ≡ x) →
           ∀ x → cong f (f⁻¹-f x) ≡ f-f⁻¹ (f x))
    lemma₂ eq f⁻¹ f-f⁻¹ =
      H-level.respects-surjection
        ((∀ x → (f⁻¹ (f x) , f-f⁻¹ (f x)) ≡ (x , refl (f x)))             ↠⟨ (∀-cong ext₂ λ _ → _↔_.surjection $ B.inverse B.Σ-≡,≡↔≡) ⟩

         (∀ x → ∃ λ f⁻¹-f →
                  subst (λ y → f y ≡ f x) f⁻¹-f (f-f⁻¹ (f x)) ≡
                  refl (f x))                                             ↠⟨ (∀-cong ext₂ λ x → ∃-cong λ f⁻¹-f →
                                                                              elim (λ {A B} _ → A ↠ B) (λ _ → S.id) (

             subst (λ y → f y ≡ f x) f⁻¹-f (f-f⁻¹ (f x)) ≡ refl (f x)           ≡⟨ cong (_≡ _) $ subst-∘ _ _ _ ⟩
             subst (_≡ f x) (cong f f⁻¹-f) (f-f⁻¹ (f x)) ≡ refl (f x)           ≡⟨ cong (_≡ _) subst-trans-sym ⟩
             trans (sym (cong f f⁻¹-f)) (f-f⁻¹ (f x)) ≡ refl (f x)              ≡⟨ [trans≡]≡[≡trans-symˡ] _ _ _ ⟩
             f-f⁻¹ (f x) ≡ trans (sym (sym (cong f f⁻¹-f))) (refl (f x))        ≡⟨ cong (_ ≡_) $ trans-reflʳ _ ⟩
             f-f⁻¹ (f x) ≡ sym (sym (cong f f⁻¹-f))                             ≡⟨ cong (_ ≡_) $ sym-sym _ ⟩∎
             f-f⁻¹ (f x) ≡ cong f f⁻¹-f                                         ∎)) ⟩

         (∀ x → ∃ λ f⁻¹-f → f-f⁻¹ (f x) ≡ cong f f⁻¹-f)                   ↠⟨ (∀-cong ext₂ λ _ → ∃-cong λ _ →
                                                                              _↔_.surjection B.≡-comm) ⟩

         (∀ x → ∃ λ f⁻¹-f → cong f f⁻¹-f ≡ f-f⁻¹ (f x))                   ↠⟨ _↔_.surjection B.ΠΣ-comm ⟩□

         (∃ λ f⁻¹-f → ∀ x → cong f (f⁻¹-f x) ≡ f-f⁻¹ (f x))               □)
        0 $
      Π-closure ext₂ 0 λ x →
      H-level.⇒≡ 0 $
      _⇔_.to Is-equivalence⇔Is-equivalence-CP eq (f x)

-- If the domain of f is contractible and the codomain is
-- propositional, then Is-equivalence f is contractible (assuming
-- extensionality).

sometimes-contractible :
  Extensionality (a ⊔ b) (a ⊔ b) →
  {A : Type a} {B : Type b} {f : A → B} →
  Contractible A → Is-proposition B →
  Contractible (Is-equivalence f)
sometimes-contractible {a = a} {b = b} ext A-contr B-prop =
  Σ-closure 0 (Π-closure ext-b-a 0 λ _ → A-contr)              λ _ →
  Σ-closure 0 (Π-closure ext-b-b 0 λ _ → H-level.+⇒≡ B-prop)   λ _ →
  Σ-closure 0 (Π-closure ext-a-a 0 λ _ → H-level.⇒≡ 0 A-contr) λ _ →
  Π-closure ext-a-b 0 λ _ → H-level.⇒≡ 0 $ H-level.+⇒≡ B-prop
  where
  ext-a-a : Extensionality a a
  ext-a-a = lower-extensionality b b ext

  ext-a-b : Extensionality a b
  ext-a-b = lower-extensionality b a ext

  ext-b-a : Extensionality b a
  ext-b-a = lower-extensionality a b ext

  ext-b-b : Extensionality b b
  ext-b-b = lower-extensionality a a ext

------------------------------------------------------------------------
-- Is-equivalence is related to CP.Is-equivalence (part two)

-- Is-equivalence f and CP.Is-equivalence f are isomorphic (assuming
-- extensionality).

Is-equivalence↔Is-equivalence-CP :
  {A : Type a} {B : Type b} {f : A → B} →
  Extensionality (a ⊔ b) (a ⊔ b) →
  Is-equivalence f ↔ CP.Is-equivalence f
Is-equivalence↔Is-equivalence-CP ext = record
  { surjection = record
    { logical-equivalence = Is-equivalence⇔Is-equivalence-CP
    ; right-inverse-of    = λ _ → CP.propositional ext _ _ _
    }
  ; left-inverse-of = λ _ → propositional ext _ _ _
  }


-- A simple word counter

open import Coinduction using ( ♯_ )
open import Data.Char.Classifier using ( isSpace )
open import Data.Bool using ( Bool ; true ; false )
open import Data.Natural using ( Natural ; show )
open import System.IO using ( Command )
open import System.IO.Transducers.Lazy using ( _⇒_ ; inp ; out ; done ; _⟫_ ; _⟨&⟩_ )
open import System.IO.Transducers.List using ( length )
open import System.IO.Transducers.Bytes using ( bytes )
open import System.IO.Transducers.IO using ( run )
open import System.IO.Transducers.UTF8 using ( split ; encode )
open import System.IO.Transducers.Session using ( ⟨_⟩ ; _&_ ; Bytes ; Strings )

module System.IO.Examples.WC where

words : Bytes ⇒ ⟨ Natural ⟩
words = split isSpace ⟫ inp (♯ length { Bytes })

-- TODO: this isn't exactly lovely user syntax.

report : ⟨ Natural ⟩ & ⟨ Natural ⟩ ⇒ Strings
report =
  (inp (♯ λ #bytes →
  (out true
  (out (show #bytes)
  (out true
  (out " "
  (inp (♯ λ #words →
  (out true
  (out (show #words)
  (out true
  (out "\n"
  (out false done)))))))))))))

wc : Bytes ⇒ Bytes
wc = bytes ⟨&⟩ words ⟫ report ⟫ inp (♯ encode)

main : Command
main = run wc


------------------------------------------------------------------------
-- The Agda standard library
--
-- Homomorphism proofs for exponentiation over polynomials
------------------------------------------------------------------------

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

open import Tactic.RingSolver.Core.Polynomial.Parameters

module Tactic.RingSolver.Core.Polynomial.Homomorphism.Exponentiation
  {r₁ r₂ r₃ r₄}
  (homo : Homomorphism r₁ r₂ r₃ r₄)
  where

open import Function

open import Data.Nat.Base as ℕ using (ℕ; suc; zero; compare)
open import Data.Product  using (_,_; _×_; proj₁; proj₂)
open import Data.List.Kleene
open import Data.Vec      using (Vec)

import Data.Nat.Properties as ℕ-Prop
import Relation.Binary.PropositionalEquality as ≡

open Homomorphism homo
open import Tactic.RingSolver.Core.Polynomial.Homomorphism.Lemmas homo
open import Tactic.RingSolver.Core.Polynomial.Base from
open import Tactic.RingSolver.Core.Polynomial.Reasoning to
open import Tactic.RingSolver.Core.Polynomial.Homomorphism.Multiplication homo
open import Tactic.RingSolver.Core.Polynomial.Semantics homo

import Algebra.Operations.Ring rawRing as RawPow
import Algebra.Operations.Ring (RawCoeff.rawRing from) as CoPow

pow-eval-hom : ∀ x i → ⟦ x CoPow.^ i +1 ⟧ᵣ ≈ ⟦ x ⟧ᵣ RawPow.^ i +1
pow-eval-hom x ℕ.zero = refl
pow-eval-hom x (suc i) = (*-homo _ x) ⟨ trans ⟩ (≪* pow-eval-hom x i)

⊡-mult-hom : ∀ {n} i (xs : Poly n) ρ → ⟦ ⊡-mult i xs ⟧ ρ ≈ ⟦ xs ⟧ ρ RawPow.^ i +1
⊡-mult-hom ℕ.zero xs ρ = refl
⊡-mult-hom (suc i) xs ρ =  ⊠-hom (⊡-mult i xs) xs ρ ⟨ trans ⟩ (≪* ⊡-mult-hom i xs ρ)

⊡-+1-hom : ∀ {n} → (xs : Poly n) → (i : ℕ) → ∀ ρ → ⟦ xs ⊡ i +1 ⟧ ρ ≈ ⟦ xs ⟧ ρ RawPow.^ i +1
⊡-+1-hom (Κ x  ⊐ i≤n) i ρ = pow-eval-hom x i
⊡-+1-hom xs@(⅀ (_ & ∹ _) ⊐ i≤n) i ρ = ⊡-mult-hom i xs ρ
⊡-+1-hom (⅀ (x ≠0 Δ j & []) ⊐ i≤n) i ρ =
  begin
    ⟦ x ⊡ i +1 Δ (j ℕ.+ i ℕ.* j) ∷↓ [] ⊐↓ i≤n ⟧ ρ
  ≈⟨ ⊐↓-hom (x ⊡ i +1 Δ (j ℕ.+ i ℕ.* j) ∷↓ []) i≤n ρ ⟩
    ⅀?⟦ x ⊡ i +1 Δ (j ℕ.+ i ℕ.* j) ∷↓ [] ⟧ (drop-1 i≤n ρ)
  ≈⟨ ∷↓-hom (x ⊡ i +1) (j ℕ.+ i ℕ.* j) [] ρ′ Ρ ⟩
    (ρ′ RawPow.^ (j ℕ.+ i ℕ.* j)) * (⟦ x ⊡ i +1 ⟧ Ρ)
  ≈⟨ *≫ (( ⊡-+1-hom x i Ρ) ) ⟩
    (ρ′ RawPow.^ (j ℕ.+ i ℕ.* j)) * (⟦ x ⟧ Ρ RawPow.^ i +1)
  ≈⟨ rearrange j ⟩
    (( ⟦ x ⟧ Ρ) *⟨ ρ′ ⟩^ j) RawPow.^ i +1
  ∎
  where
  ρ′,Ρ = drop-1 i≤n ρ
  ρ′ = proj₁ ρ′,Ρ
  Ρ = proj₂ ρ′,Ρ
  rearrange : ∀ j → (ρ′ RawPow.^ (j ℕ.+ i ℕ.* j)) * (⟦ x ⟧ Ρ RawPow.^ i +1)≈ (( ⟦ x ⟧ Ρ) *⟨ ρ′ ⟩^ j) RawPow.^ i +1
  rearrange zero =
    begin
      (ρ′ RawPow.^ (i ℕ.* 0)) * (⟦ x ⟧ Ρ RawPow.^ i +1)
    ≡⟨ ≡.cong (λ k →  (ρ′ RawPow.^ k) * (⟦ x ⟧ Ρ RawPow.^ i +1)) (ℕ-Prop.*-zeroʳ i) ⟩
      1# * (⟦ x ⟧ Ρ RawPow.^ i +1)
    ≈⟨ *-identityˡ _ ⟩
      ⟦ x ⟧ Ρ RawPow.^ i +1
    ∎
  rearrange j@(suc j′) =
    begin
      (ρ′ RawPow.^ (j ℕ.+ i ℕ.* j)) * (⟦ x ⟧ Ρ RawPow.^ i +1)
    ≈⟨ ≪* sym ( pow-mult-+1 ρ′ j′ i) ⟩
      ((ρ′ RawPow.^ j′ +1) RawPow.^ i +1) * (⟦ x ⟧ Ρ RawPow.^ i +1)
    ≈⟨ sym (pow-distrib-+1 _ (⟦ x ⟧ Ρ) i) ⟩
      ((ρ′ RawPow.^ j′ +1) * ⟦ x ⟧ Ρ) RawPow.^ i +1
    ∎

⊡-hom : ∀ {n} → (xs : Poly n) → (i : ℕ) → ∀ ρ → ⟦ xs ⊡ i ⟧ ρ ≈ ⟦ xs ⟧ ρ RawPow.^ i
⊡-hom xs ℕ.zero ρ = 1-homo
⊡-hom xs (suc i) ρ = ⊡-+1-hom xs i ρ


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

module Categories.Category.Construction.Properties.Presheaves.CartesianClosed where

open import Level
open import Data.Unit
open import Data.Product using (_,_)
open import Data.Product.Relation.Binary.Pointwise.NonDependent
open import Function.Equality using (Π) renaming (_∘_ to _∙_)
open import Relation.Binary

open import Categories.Category
open import Categories.Category.Cartesian
open import Categories.Category.CartesianClosed
open import Categories.Category.CartesianClosed.Canonical renaming (CartesianClosed to CCartesianClosed)
open import Categories.Category.Construction.Presheaves
open import Categories.Category.Instance.Setoids
open import Categories.Functor
open import Categories.Functor.Hom
open import Categories.Functor.Properties
open import Categories.Functor.Presheaf
open import Categories.NaturalTransformation

import Categories.Category.Construction.Properties.Presheaves.Cartesian as Preₚ
import Categories.Object.Product as Prod
import Categories.Object.Exponential as Exp
import Categories.Morphism.Reasoning as MR
import Relation.Binary.Reasoning.Setoid as SetoidR

open Π using (_⟨$⟩_)

module HasClosedStructure o′ ℓ′ {o ℓ e} {C : Category o ℓ e} (Car : Cartesian C) where
  private
    module C = Category C
    open Preₚ C
    open C
    P = Presheaves′ o′ ℓ′ C
    module P = Category P
    S = Setoids o′ ℓ′
    module S = Category S
    open Prod C
    open Cartesian Car

  Pres-exp : (F : Presheaf C (Setoids o′ ℓ′)) (X : Obj) → Presheaf C (Setoids o′ ℓ′)
  Pres-exp F X = record
    { F₀           = λ Y → F.₀ (X × Y)
    ; F₁           = λ f → F.₁ (second f)
    ; identity     = λ {A} {x y} eq →
      let open Setoid  (F.₀ (X × A))
          open SetoidR (F.₀ (X × A))
      in begin
        F.₁ (second C.id) ⟨$⟩ x ≈⟨ F.F-resp-≈ (id×id (product {X} {A})) refl ⟩
        F.F₁ C.id ⟨$⟩ x         ≈⟨ F.identity eq ⟩
        y                       ∎
    ; homomorphism = λ {Y Z W} {f} {g} {x y} eq →
      let open Setoid  (F.₀ (X × Y))
          open SetoidR (F.₀ (X × W))
      in begin
        F.₁ (second (f ∘ g)) ⟨$⟩ x                ≈˘⟨ [ F ]-resp-∘ second∘second (sym eq) ⟩
        F.₁ (second g) ⟨$⟩ (F.₁ (second f) ⟨$⟩ y) ∎
    ; F-resp-≈     = λ {Y Z} {f g} eq → F.F-resp-≈ (⁂-cong₂ Equiv.refl eq)
    }
    where module F = Functor F

  ExpF : (F : Presheaf C (Setoids o′ ℓ′)) → Functor C.op P
  ExpF F = record
    { F₀           = Pres-exp F
    ; F₁           = λ {A B} f → ntHelper record
      { η       = λ X → F₁ (first f)
      ; commute = λ {X Y} g {x y} eq →
        [ F ]-resp-square (Equiv.sym first↔second) eq
      }
    ; identity     = λ {A B} {x y} eq →
      let open Setoid  (F₀ (A × B))
          open SetoidR (F₀ (A × B))
      in begin
        F₁ (first C.id) ⟨$⟩ x ≈⟨ F-resp-≈ (id×id product) eq ⟩
        F₁ C.id ⟨$⟩ y         ≈⟨ identity refl ⟩
        y                     ∎
    ; homomorphism = λ {X Y Z} {f g} {W} {x y} eq →
      let open Setoid  (F₀ (X × W))
          open SetoidR (F₀ (Z × W))
      in begin
        F₁ (first (f ∘ g)) ⟨$⟩ x              ≈˘⟨ [ F ]-resp-∘ first∘first (sym eq) ⟩
        F₁ (first g) ⟨$⟩ (F₁ (first f) ⟨$⟩ y) ∎
    ; F-resp-≈     = λ {A B} {f g} eq → F-resp-≈ (⁂-cong₂ eq Equiv.refl)
    }
    where open Functor F

  module _ (F G : Presheaf C (Setoids o′ ℓ′)) where
    private
      module F = Functor F
      module G = Functor G

    Presheaf^ : Presheaf C (Setoids (o′ ⊔ ℓ′ ⊔ o ⊔ ℓ) (o′ ⊔ ℓ′ ⊔ o))
    Presheaf^ = record
      { F₀           = λ X → Hom[ Presheaves C ][ G , Pres-exp F X ]
      ; F₁           = λ {A B} f → record
        { _⟨$⟩_ = λ α →
          let module α = NaturalTransformation α
          in ntHelper record
          { η       = λ X → F.₁ (first f) ∙ α.η X
          ; commute = λ {X Y} g  {x y} eq →
            let open SetoidR (F.₀ (B × Y))
            in begin
              F.₁ (first f) ⟨$⟩ (α.η Y ⟨$⟩ (G.₁ g ⟨$⟩ x))          ≈⟨ Π.cong (F.₁ (first f)) (α.commute g eq) ⟩
              F.₁ (first f) ⟨$⟩ (F.₁ (second g) ⟨$⟩ (α.η X ⟨$⟩ y)) ≈˘⟨ [ F ]-resp-square first↔second (Setoid.refl (F.₀ (A × X))) ⟩
              F.₁ (second g) ⟨$⟩ (F.₁ (first f) ⟨$⟩ (α.η X ⟨$⟩ y)) ∎
          }
        ; cong  = λ eq eq′ → Π.cong (F.₁ (first f)) (eq eq′)
        }
      ; identity     = λ {X} {α β} eq {Y} {x y} eq′ →
        let module α = NaturalTransformation α
            module β = NaturalTransformation β
            open SetoidR (F.₀ (X × Y))
        in begin
          F.₁ (first C.id) ⟨$⟩ (α.η Y ⟨$⟩ x) ≈⟨ F.F-resp-≈ (id×id product) (eq eq′) ⟩
          F.₁ C.id ⟨$⟩ (β.η Y ⟨$⟩ y)         ≈⟨ F.identity (Setoid.refl (F.₀ (X × Y))) ⟩
          β.η Y ⟨$⟩ y                        ∎
      ; homomorphism = λ {X Y Z} eq {W} eq′ →
        let open Setoid  (F.₀ (X × W))
        in Setoid.sym (F.₀ (Z × W)) ([ F ]-resp-∘ first∘first (sym (eq eq′)))
      ; F-resp-≈     = λ eq eq′ eq″ → F.F-resp-≈ (⁂-cong₂ eq Equiv.refl) (eq′ eq″)
      }

module IsCCC {o} {C : Category o o o} (Car : Cartesian C) where
  private
    module C  = Category C
    module CH = C.HomReasoning
    open Preₚ C
    open C
    open Prod C
    P = Presheaves′ o o C
    module P = Category P
    open Cartesian Car
    open IsCartesian o o
    open HasClosedStructure o o Car

  CanonicalCCC : CCartesianClosed P
  CanonicalCCC = record
    { ⊤            = PC.terminal.⊤
    ; _×_          = PC._×_
    ; !            = PC.!
    ; π₁           = PC.π₁
    ; π₂           = PC.π₂
    ; ⟨_,_⟩        = PC.⟨_,_⟩
    ; !-unique     = PC.!-unique
    ; π₁-comp      = λ {_ _ f} {_ g} → PC.project₁ {h = f} {g}
    ; π₂-comp      = λ {_ _ f} {_ g} → PC.project₂ {h = f} {g}
    ; ⟨,⟩-unique   = λ {_ _ _ f g h} → PC.unique {h = h} {i = f} {j = g}
    ; _^_          = Presheaf^
    ; eval         = λ {F G} →
      let module F = Functor F
          module G = Functor G
      in ntHelper record
        { η       = λ X → record
          { _⟨$⟩_ = λ { (α , x) →
            let module α = NaturalTransformation α
            in F.₁ Δ ⟨$⟩ (α.η X ⟨$⟩ x) }
          ; cong  = λ { (eq , eq′) → Π.cong (F.₁ Δ) (eq eq′) }
          }
        ; commute = λ {X Y} f → λ { {α , x} {β , y} (eq , eq′) →
          let module α = NaturalTransformation α
              module β = NaturalTransformation β
              open Setoid  (F.₀ (X × X))
              open SetoidR (F.₀ Y)
          in begin
            F.₁ Δ ⟨$⟩ (F.₁ (first f) ⟨$⟩ (α.η Y ⟨$⟩ (G.₁ f ⟨$⟩ x)))
              ≈⟨ Π.cong (F.₁ Δ ∙ F.₁ (first f)) (α.commute f eq′) ⟩
            F.₁ Δ ∙ F.₁ (first f) ∙ F.₁ (second f) ⟨$⟩ (α.η X ⟨$⟩ y)
              ≈⟨ Π.cong (F.₁ Δ) ([ F ]-resp-∘ second∘first refl) ⟩
            F.₁ Δ ⟨$⟩ (F.F₁ (f ⁂ f) ⟨$⟩ (α.η X ⟨$⟩ y))
              ≈⟨ [ F ]-resp-∘ ⁂∘Δ refl ⟩
            F.F₁ ⟨ f , f ⟩ ⟨$⟩ (α.η X ⟨$⟩ y)
              ≈˘⟨ [ F ]-resp-∘ Δ∘ (sym (eq (Setoid.refl (G.₀ X)))) ⟩
            F.₁ f ⟨$⟩ (F.₁ Δ ⟨$⟩ (β.η X ⟨$⟩ y))
              ∎ }
        }
    ; curry        = λ {F G H} α →
      let module F = Functor F
          module G = Functor G
          module H = Functor H
          module α = NaturalTransformation α
      in ntHelper record
        { η       = λ X → record
          { _⟨$⟩_ = λ x → ntHelper record
            { η       = λ Y → record
              { _⟨$⟩_ = λ y → α.η (X × Y) ⟨$⟩ (F.₁ π₁ ⟨$⟩ x , G.₁ π₂ ⟨$⟩ y)
              ; cong  = λ eq → Π.cong (α.η (X × Y)) (Setoid.refl (F.₀ (X × Y)) , Π.cong (G.₁ π₂) eq)
              }
            ; commute = λ {Y Z} f {y z} eq →
              let open SetoidR (H.₀ (X × Z))
              in begin
                α.η (X × Z) ⟨$⟩ (F.₁ π₁ ⟨$⟩ x , G.₁ π₂ ⟨$⟩ (G.₁ f ⟨$⟩ y))
                  ≈˘⟨ Π.cong (α.η (X × Z)) ( [ F ]-resp-∘ (π₁∘⁂ CH.○ identityˡ) (Setoid.refl (F.₀ X))
                                           , [ G ]-resp-square π₂∘⁂ (Setoid.refl (G.₀ Y))) ⟩
                α.η (X × Z) ⟨$⟩ (F.₁ (second f) ∙ F.₁ π₁ ⟨$⟩ x , G.₁ (second f) ⟨$⟩ (G.₁ π₂ ⟨$⟩ y))
                  ≈⟨ α.commute (second f) (Setoid.refl (F.₀ (X × Y)) , Π.cong (G.₁ π₂) eq) ⟩
                H.₁ (second f) ⟨$⟩ (α.η (X × Y) ⟨$⟩ (F.₁ π₁ ⟨$⟩ x , G.₁ π₂ ⟨$⟩ z))
                  ∎
            }
          ; cong  = λ eq₁ eq₂ → Π.cong (α.η _) (Π.cong (F.F₁ π₁) eq₁ , Π.cong (G.₁ π₂) eq₂)
          }
        ; commute = λ {X Y} f {x y} eq₁ {Z} {z w} eq₂ →
          let open SetoidR (H.₀ (Y × Z))
          in begin
            α.η (Y × Z) ⟨$⟩ (F.₁ π₁ ⟨$⟩ (F.₁ f ⟨$⟩ x) , G.₁ π₂ ⟨$⟩ z)
              ≈˘⟨ Π.cong (α.η _) ( [ F ]-resp-square π₁∘⁂ (Setoid.refl (F.₀ X))
                                 , [ G ]-resp-∘ (π₂∘⁂ CH.○ identityˡ) (Setoid.refl (G.₀ Z))) ⟩
            α.η (Y × Z) ⟨$⟩ (F.₁ (first f) ⟨$⟩ (F.₁ π₁ ⟨$⟩ x) , G.₁ (first f) ⟨$⟩ (G.₁ π₂ ⟨$⟩ z))
              ≈⟨ α.commute (first f) (Π.cong (F.₁ π₁) eq₁ , Π.cong (G.₁ π₂) eq₂) ⟩
            H.₁ (first f) ⟨$⟩ (α.η (X × Z) ⟨$⟩ (F.₁ π₁ ⟨$⟩ y , G.₁ π₂ ⟨$⟩ w))
              ∎
        }
    ; eval-comp    = λ {F G H} {α} → λ { {X} {x , y} {z , w} (eq₁ , eq₂) →
      let module F = Functor F
          module G = Functor G
          module H = Functor H
          module α = NaturalTransformation α
          module HX = Setoid (H.₀ X)
          module GX = Setoid (G.₀ X)
          open SetoidR (F.₀ X)
      in begin
        F.₁ Δ ⟨$⟩ (α.η (X × X) ⟨$⟩ (H.₁ π₁ ⟨$⟩ x , G.₁ π₂ ⟨$⟩ y))
          ≈⟨ α.sym-commute Δ (Π.cong (H.₁ π₁) eq₁ , Π.cong (G.₁ π₂) eq₂) ⟩
        α.η X ⟨$⟩ (H.₁ Δ ⟨$⟩ (H.F₁ π₁ ⟨$⟩ z) , G.₁ Δ ⟨$⟩ (G.₁ π₂ ⟨$⟩ w))
          ≈⟨ Π.cong (α.η X) ([ H ]-resp-∘ project₁ HX.refl , [ G ]-resp-∘ project₂ GX.refl) ⟩
        α.η X ⟨$⟩ (H.F₁ C.id ⟨$⟩ z , G.F₁ C.id ⟨$⟩ w)
          ≈⟨ Π.cong (α.η X) (H.identity HX.refl , G.identity GX.refl) ⟩
        α.η X ⟨$⟩ (z , w)
          ∎ }
    ; curry-resp-≈ = λ {F G H} eq eq₁ eq₂ →
      let module G = Functor G
          module H = Functor H
      in eq (Π.cong (G.₁ π₁) eq₁ , Π.cong (H.₁ π₂) eq₂)
    ; curry-unique = λ {F G H} {α β} eq {X} {x y} eq₁ {Y} {z w} eq₂ →
      let module F   = Functor F
          module G   = Functor G
          module H   = Functor H
          module α   = NaturalTransformation α
          module β   = NaturalTransformation β
          module GXY = Setoid (G.₀ (X × Y))
          module αXx = NaturalTransformation (α.η X ⟨$⟩ x)
          open SetoidR (G.₀ (X × Y))
      in begin
        αXx.η Y ⟨$⟩ z
          ≈˘⟨ G.identity GXY.refl ⟩
        G.₁ C.id ⟨$⟩ (αXx.η Y ⟨$⟩ z)
          ≈˘⟨ [ G ]-resp-∘ (⁂∘Δ CH.○ η) GXY.refl ⟩
        G.₁ Δ ⟨$⟩ (G.F₁ (π₁ ⁂ π₂) ⟨$⟩ (αXx.η Y ⟨$⟩ z))
          ≈˘⟨ Π.cong (G.₁ Δ) ([ G ]-resp-∘ second∘first GXY.refl) ⟩
        G.₁ Δ ⟨$⟩ (G.₁ (first π₁) ⟨$⟩ (G.₁ (second π₂) ⟨$⟩ (αXx.η Y ⟨$⟩ z)))
          ≈⟨ Π.cong (G.₁ Δ ∙ G.₁ (first π₁)) (αXx.sym-commute π₂ (Setoid.refl (H.₀ Y))) ⟩
        G.₁ Δ ⟨$⟩ (G.₁ (first π₁) ⟨$⟩ (αXx.η (X × Y) ⟨$⟩ (H.₁ π₂ ⟨$⟩ z)))
          ≈⟨ Π.cong (G.₁ Δ) (α.sym-commute π₁ (Setoid.refl (F.₀ X)) (Setoid.refl (H.₀ (X × Y)))) ⟩
        G.₁ Δ ⟨$⟩ (NaturalTransformation.η (α.η (X × Y) ⟨$⟩ (F.₁ π₁ ⟨$⟩ x)) (X × Y) ⟨$⟩ (H.₁ π₂ ⟨$⟩ z))
          ≈⟨ eq (Π.cong (F.₁ π₁) eq₁ , Π.cong (H.₁ π₂) eq₂) ⟩
        β.η (X × Y) ⟨$⟩ (F.₁ π₁ ⟨$⟩ y , H.₁ π₂ ⟨$⟩ w)
          ∎
    }
    where module PC = Presheaves-Cartesian

  Presheaves-CartesianClosed : CartesianClosed P
  Presheaves-CartesianClosed = Equivalence.fromCanonical P CanonicalCCC

  module Presheaves-CartesianClosed = CartesianClosed Presheaves-CartesianClosed


open import Agda.Builtin.Equality

cong : ∀{a b} {A : Set a} {B : Set b} (f : A → B) {x y : A} (eq : x ≡ y) → f x ≡ f y
cong f refl = refl

record Category : Set₂ where
  field
    Ob  : Set₁
    _⇒_ : Ob → Ob → Set
    _∘_ : ∀ {O P Q} → P ⇒ Q → O ⇒ P → O ⇒ Q

  -- Moving this out of the record fixes the problem.
  idem : {X : Ob} → X ⇒ X → Set₁
  idem {X} f = f ∘ f ≡ f → Set

Sets : Category
Sets = record
    { Ob = Set
    ; _⇒_ = {!!}
    ; _∘_ = λ f g x → f (g x)
    }
open Category Sets

postulate
  Y : Ob
  f : Y ⇒ Y

idem-f : idem {X = _} f  -- Solving the _ fixes the problem
idem-f ff≡f
  with ffx≡fx ← cong {!!} ff≡f
  = Y


module Oscar.Data.Term.internal.SubstituteAndSubstitution {𝔣} (FunctionName : Set 𝔣) where

open import Oscar.Category.Action
open import Oscar.Category.Category
open import Oscar.Category.CategoryAction
open import Oscar.Category.Functor
open import Oscar.Category.Morphism
open import Oscar.Category.Semifunctor
open import Oscar.Category.Semigroupoid
open import Oscar.Category.Setoid
open import Oscar.Category.SemigroupoidAction
open import Oscar.Data.Equality
open import Oscar.Data.Equality.properties
open import Oscar.Data.Fin
open import Oscar.Data.Nat
open import Oscar.Data.Term FunctionName
open import Oscar.Data.Vec
open import Oscar.Function
open import Oscar.Level
open import Oscar.Relation

𝕞₁ : Morphism _ _ _
𝕞₁ = Fin ⇨ Term

𝕞₂ : Morphism _ _ _
𝕞₂ = Term ⇨ Term

𝕞₂ₛ : Nat → Morphism _ _ _
𝕞₂ₛ N = Terms N ⇨ Terms N

module 𝔐₁ = Morphism 𝕞₁
module 𝔐₂ = Morphism 𝕞₂
module 𝔐₂ₛ (N : Nat) where open Morphism (𝕞₂ₛ N) public using () renaming (_↦_ to _[_↦_])

private

  infix 19 _◂_ _◂s_

  mutual

    _◂_ : ∀ {m n} → m 𝔐₁.↦ n → m 𝔐₂.↦ n
    σ̇ ◂ i 𝑥 = σ̇ 𝑥
    _ ◂ leaf = leaf
    σ̇ ◂ (τl fork τr) = (σ̇ ◂ τl) fork (σ̇ ◂ τr)
    σ̇ ◂ (function fn τs) = function fn (σ̇ ◂s τs) where

    _◂s_ : ∀ {m n} → m ⊸ n → ∀ {N} → N 𝔐₂ₛ.[ m ↦ n ] -- Vec (Term m) N → Vec (Term n) N
    f ◂s [] = []
    f ◂s (t ∷ ts) = f ◂ t ∷ f ◂s ts

  _∙_ : ∀ {m n} → m ⊸ n → ∀ {l} → l ⊸ m → l ⊸ n
  _∙_ f g = (f ◂_) ∘ g

  mutual

    ◂-extensionality : ∀ {m n} {f g : m ⊸ n} → f ≡̇ g → f ◂_ ≡̇ g ◂_
    ◂-extensionality p (i x) = p x
    ◂-extensionality p leaf = refl
    ◂-extensionality p (s fork t) = cong₂ _fork_ (◂-extensionality p s) (◂-extensionality p t)
    ◂-extensionality p (function fn ts) = cong (function fn) (◂s-extensionality p ts)

    ◂s-extensionality : ∀ {m n} {f g : m ⊸ n} → f ≡̇ g → ∀ {N} → _◂s_ f {N} ≡̇ _◂s_ g
    ◂s-extensionality p [] = refl
    ◂s-extensionality p (t ∷ ts) = cong₂ _∷_ (◂-extensionality p t) (◂s-extensionality p ts)

  mutual

    ◂-associativity : ∀ {l m} (f : l ⊸ m) {n} (g : m ⊸ n) → (g ∙ f) ◂_ ≡̇ (g ◂_) ∘ (f ◂_)
    ◂-associativity _ _ (i _) = refl
    ◂-associativity _ _ leaf = refl
    ◂-associativity _ _ (τ₁ fork τ₂) = cong₂ _fork_ (◂-associativity _ _ τ₁) (◂-associativity _ _ τ₂)
    ◂-associativity f g (function fn ts) = cong (function fn) (◂s-associativity f g ts)

    ◂s-associativity : ∀ {l m n} (f : l ⊸ m) (g : m ⊸ n) → ∀ {N} → (_◂s_ (g ∙ f) {N}) ≡̇ (g ◂s_) ∘ (f ◂s_)
    ◂s-associativity _ _ [] = refl
    ◂s-associativity _ _ (τ ∷ τs) = cong₂ _∷_ (◂-associativity _ _ τ) (◂s-associativity _ _ τs)

  ∙-associativity : ∀ {k l} (f : k ⊸ l) {m} (g : l ⊸ m) {n} (h : m ⊸ n) → (h ∙ g) ∙ f ≡̇ h ∙ (g ∙ f)
  ∙-associativity f g h x rewrite ◂-associativity g h (f x) = refl

  ∙-extensionality : ∀ {l m} {f₁ f₂ : l ⊸ m} → f₁ ≡̇ f₂ → ∀ {n} {g₁ g₂ : m ⊸ n} → g₁ ≡̇ g₂ → g₁ ∙ f₁ ≡̇ g₂ ∙ f₂
  ∙-extensionality {f₂ = f₂} f₁≡̇f₂ g₁≡̇g₂ x rewrite f₁≡̇f₂ x = ◂-extensionality g₁≡̇g₂ (f₂ x)

instance

  IsSemigroupoid𝕞₁∙ : IsSemigroupoid 𝕞₁ _∙_
  IsSemigroupoid.extensionality IsSemigroupoid𝕞₁∙ = ∙-extensionality
  IsSemigroupoid.associativity IsSemigroupoid𝕞₁∙ = ∙-associativity

𝕘₁ : Semigroupoid _ _ _
𝕘₁ = 𝕞₁ , _∙_

𝕘₂ : Semigroupoid _ _ _
𝕘₂ = 𝕞₂ , (λ ‵ → _∘_ ‵)

𝕘₂ₛ : Nat → Semigroupoid _ _ _
𝕘₂ₛ N = 𝕞₂ₛ N , (λ ‵ → _∘_ ‵)

𝕘₁,₂ : Semigroupoids _ _ _ _ _ _
𝕘₁,₂ = 𝕘₁ , 𝕘₂

instance

  IsSemifunctor𝕘₁₂◂ : IsSemifunctor 𝕘₁,₂ _◂_
  IsSemifunctor.extensionality IsSemifunctor𝕘₁₂◂ = ◂-extensionality
  IsSemifunctor.distributivity IsSemifunctor𝕘₁₂◂ = ◂-associativity

𝕗◂ : Semifunctor _ _ _ _ _ _
𝕗◂ = 𝕘₁,₂ , _◂_

𝕘₁,₂ₛ : Nat → Semigroupoids _ _ _ _ _ _
𝕘₁,₂ₛ N = 𝕘₁ , 𝕘₂ₛ N

instance

  IsSemifunctor𝕘₁,₂ₛ◂s : ∀ {N} → IsSemifunctor (𝕘₁,₂ₛ N) (λ ‵ → _◂s_ ‵)
  IsSemifunctor.extensionality IsSemifunctor𝕘₁,₂ₛ◂s f≡̇g τs = ◂s-extensionality f≡̇g τs
  IsSemifunctor.distributivity IsSemifunctor𝕘₁,₂ₛ◂s f g x = ◂s-associativity f g x

𝕗◂s : Nat → Semifunctor _ _ _ _ _ _
𝕗◂s N = 𝕘₁,₂ₛ N , (λ ‵ → _◂s_ ‵)

𝕒₂ : Action _ _ _
𝕒₂ = actionΣ Term

𝕒₂ₛ : Nat → Action _ _ _
𝕒₂ₛ N = actionΣ (Terms N)

instance

  IsSemigroupoidAction𝕘₁𝕒₂◂ : IsSemigroupoidAction 𝕘₁ 𝕒₂ _◂_
  IsSemigroupoidAction.extensionality IsSemigroupoidAction𝕘₁𝕒₂◂ {s₁ = s₁} refl f₁≡̇f₂ = ◂-extensionality f₁≡̇f₂ s₁
  IsSemigroupoidAction.associativity IsSemigroupoidAction𝕘₁𝕒₂◂ s f g = ◂-associativity f g s

  IsSemigroupoidAction𝕘₁𝕒₂ₛ◂s : ∀ {N} → IsSemigroupoidAction 𝕘₁ (𝕒₂ₛ N) (λ ‵ → _◂s_ ‵)
  IsSemigroupoidAction.extensionality IsSemigroupoidAction𝕘₁𝕒₂ₛ◂s {s₁ = s₁} refl f₁≡̇f₂ = ◂s-extensionality f₁≡̇f₂ s₁
  IsSemigroupoidAction.associativity IsSemigroupoidAction𝕘₁𝕒₂ₛ◂s s f g = ◂s-associativity f g s

𝕟◂ : SemigroupoidAction _ _ _ _ _
𝕟◂ = [ 𝕘₁ / 𝕒₂ ] _◂_

𝕟◂s : Nat → SemigroupoidAction _ _ _ _ _
𝕟◂s N = [ 𝕘₁ / 𝕒₂ₛ N ] (λ ‵ → _◂s_ ‵)

private

  ε : ∀ {m} → m ⊸ m
  ε = i

  mutual

    ◂-identity : ∀ {m} (t : Term m) → ε ◂ t ≡ t
    ◂-identity (i x) = refl
    ◂-identity leaf = refl
    ◂-identity (s fork t) = cong₂ _fork_ (◂-identity s) (◂-identity t)
    ◂-identity (function fn ts) = cong (function fn) (◂s-identity ts)

    ◂s-identity : ∀ {N m} (t : Vec (Term m) N) → ε ◂s t ≡ t
    ◂s-identity [] = refl
    ◂s-identity (t ∷ ts) = cong₂ _∷_ (◂-identity t) (◂s-identity ts)

  ∙-left-identity : ∀ {m n} (f : m ⊸ n) → ε ∙ f ≡̇ f
  ∙-left-identity f = ◂-identity ∘ f

  ∙-right-identity : ∀ {m n} (f : m ⊸ n) → f ∙ ε ≡̇ f
  ∙-right-identity _ _ = refl

instance

  IsCategory𝕘₁ε : IsCategory 𝕘₁ ε
  IsCategory.left-identity IsCategory𝕘₁ε = ∙-left-identity
  IsCategory.right-identity IsCategory𝕘₁ε = ∙-right-identity

𝔾₁ : Category _ _ _
𝔾₁ = 𝕘₁ , ε

𝔾₂ : Category _ _ _
𝔾₂ = 𝕘₂ , id

𝔾₂ₛ : Nat → Category _ _ _
𝔾₂ₛ N = 𝕘₂ₛ N , id

𝔾₁,₂ : Categories _ _ _ _ _ _
𝔾₁,₂ = 𝔾₁ , 𝔾₂

𝔾₁,₂ₛ : Nat → Categories _ _ _ _ _ _
𝔾₁,₂ₛ N = 𝔾₁ , 𝔾₂ₛ N

instance

  IsFunctor𝔾₁,₂◂ : IsFunctor 𝔾₁,₂ _◂_
  IsFunctor.identity IsFunctor𝔾₁,₂◂ _ = ◂-identity

𝔽◂ : Functor _ _ _ _ _ _
𝔽◂ = 𝔾₁,₂ , _◂_

instance

  IsFunctor𝔾₁,₂ₛ◂ : ∀ {N} → IsFunctor (𝔾₁,₂ₛ N) (λ ‵ → _◂s_ ‵)
  IsFunctor.identity IsFunctor𝔾₁,₂ₛ◂ _ = ◂s-identity -- ◂-identity

𝔽s : Nat → Functor _ _ _ _ _ _
𝔽s N = 𝔾₁,₂ₛ N , (λ ‵ → _◂s_ ‵)

instance

  IsCategoryAction𝔾₁𝕒₂◂ : IsCategoryAction 𝔾₁ 𝕒₂ _◂_
  IsCategoryAction.identity IsCategoryAction𝔾₁𝕒₂◂ = ◂-identity

  IsCategoryAction𝔾₁𝕒₂ₛ◂s : ∀ {N} → IsCategoryAction 𝔾₁ (𝕒₂ₛ N) (λ ‵ → _◂s_ ‵)
  IsCategoryAction.identity IsCategoryAction𝔾₁𝕒₂ₛ◂s = ◂s-identity

ℕ◂ : CategoryAction _ _ _ _ _
ℕ◂ = [ 𝔾₁ / 𝕒₂ ] _◂_

ℕ◂s : Nat → CategoryAction _ _ _ _ _
ℕ◂s N = [ 𝔾₁ / 𝕒₂ₛ N ] (λ ‵ → _◂s_ ‵)