open import Oscar.Prelude
open import Oscar.Class

module Oscar.Class.Leftstar where

module Leftstar
  {𝔞 𝔟 𝔣 𝔞̇ 𝔟̇}
  {𝔄 : Ø 𝔞}
  {𝔅 : Ø 𝔟}
  {𝔉 : Ø 𝔣}
  (𝔄̇ : 𝔄 → Ø 𝔞̇)
  (𝔅̇ : 𝔅 → Ø 𝔟̇)
  (_◂_ : 𝔉 → 𝔄 → 𝔅)
  = ℭLASS (_◂_ , 𝔅̇) (∀ {x} f → 𝔄̇ x → 𝔅̇ (f ◂ x))

module _
  {𝔞 𝔟 𝔣 𝔞̇ 𝔟̇}
  {𝔄 : Ø 𝔞}
  {𝔅 : Ø 𝔟}
  {𝔉 : Ø 𝔣}
  {𝔄̇ : 𝔄 → Ø 𝔞̇}
  {𝔅̇ : 𝔅 → Ø 𝔟̇}
  {_◂_ : 𝔉 → 𝔄 → 𝔅}
  where
  leftstar = Leftstar.method 𝔄̇ 𝔅̇ _◂_

open import Oscar.Class.Surjection
open import Oscar.Class.Smap

module Leftstar,smaparrow
  {𝔵₁ 𝔵₂} {𝔛₁ : Ø 𝔵₁} {𝔛₂ : Ø 𝔵₂}
  (surjection : Surjection.type 𝔛₁ 𝔛₂)
  {𝔭₁ 𝔭₂} (𝔓₁ : 𝔛₂ → Ø 𝔭₁) (𝔓₂ : 𝔛₂ → Ø 𝔭₂)
  {𝔯} (ℜ : 𝔛₁ → 𝔛₁ → Ø 𝔯)
  {𝔭̇₁} (𝔓̇₁ : ∀ {a} → 𝔓₁ (surjection a) → Ø 𝔭̇₁)
  {𝔭̇₂} (𝔓̇₂ : ∀ {a} → 𝔓₂ (surjection a) → Ø 𝔭̇₂)
  (smaparrow : Smaparrow.type ℜ 𝔓₁ 𝔓₂ surjection surjection)
  where
  class = ∀ {a₁ a₂} → Leftstar.class (𝔓̇₁ {a₁}) (𝔓̇₂ {a₂}) smaparrow
  type = ∀ {a₁ a₂} → Leftstar.type (𝔓̇₁ {a₁}) (𝔓̇₂ {a₂}) smaparrow

module Leftstar,smaparrow!
  {𝔵₁ 𝔵₂} {𝔛₁ : Ø 𝔵₁} {𝔛₂ : Ø 𝔵₂}
  ⦃ _ : Surjection.class 𝔛₁ 𝔛₂ ⦄
  {𝔭₁ 𝔭₂} (𝔓₁ : 𝔛₂ → Ø 𝔭₁) (𝔓₂ : 𝔛₂ → Ø 𝔭₂)
  {𝔯} (ℜ : 𝔛₁ → 𝔛₁ → Ø 𝔯)
  {𝔭̇₁} (𝔓̇₁ : ∀ {a} → 𝔓₁ (surjection a) → Ø 𝔭̇₁)
  {𝔭̇₂} (𝔓̇₂ : ∀ {a} → 𝔓₂ (surjection a) → Ø 𝔭̇₂)
  ⦃ _ : Smaparrow!.class ℜ 𝔓₁ 𝔓₂ ⦄
  = Leftstar,smaparrow surjection 𝔓₁ 𝔓₂ ℜ 𝔓̇₁ 𝔓̇₂ smaparrow

module Leftstar,smaphomarrow
  {𝔵₁ 𝔵₂} {𝔛₁ : Ø 𝔵₁} {𝔛₂ : Ø 𝔵₂}
  (surjection : Surjection.type 𝔛₁ 𝔛₂)
  {𝔭} (𝔓 : 𝔛₂ → Ø 𝔭)
  {𝔯} (ℜ : 𝔛₁ → 𝔛₁ → Ø 𝔯)
  {𝔭̇} (𝔓̇ : ∀ {a} → 𝔓 (surjection a) → Ø 𝔭̇)
  (smaparrow : Smaphomarrow.type ℜ 𝔓 surjection)
  = Leftstar,smaparrow surjection 𝔓 𝔓 ℜ 𝔓̇ 𝔓̇ smaparrow

module Leftstar,smaphomarrow!
  {𝔵₁ 𝔵₂} {𝔛₁ : Ø 𝔵₁} {𝔛₂ : Ø 𝔵₂}
  ⦃ _ : Surjection.class 𝔛₁ 𝔛₂ ⦄
  {𝔭} (𝔓 : 𝔛₂ → Ø 𝔭)
  {𝔯} (ℜ : 𝔛₁ → 𝔛₁ → Ø 𝔯)
  {𝔭̇} (𝔓̇ : ∀ {a} → 𝔓 (surjection a) → Ø 𝔭̇)
  ⦃ _ : Smaphomarrow!.class ℜ 𝔓 ⦄
  = Leftstar,smaphomarrow surjection 𝔓 ℜ 𝔓̇ smaparrow


-- Coalgebraic strength over an endofunctor
module SOAS.Coalgebraic.Strength {T : Set} where

open import SOAS.Common
open import SOAS.Context
open import SOAS.Variable
open import SOAS.Families.Core {T}
open import SOAS.Abstract.Hom {T}
import SOAS.Abstract.Coalgebra {T} as →□ ; open →□.Sorted

open import SOAS.Coalgebraic.Map

private
  variable
    Γ Δ Θ : Ctx
    α : T

-- Pointed coalgebraic strength for a family endofunctor
record Strength (Fᶠ : Functor 𝔽amiliesₛ 𝔽amiliesₛ) : Set₁ where
  open Functor Fᶠ
  open Coalgₚ

  field
    -- Strength transformation that lifts a 𝒫-substitution over an endofunctor F₀
    str : {𝒫 : Familyₛ}(𝒫ᴮ : Coalgₚ 𝒫)(𝒳 : Familyₛ)
        → F₀ 〖 𝒫 , 𝒳 〗 ⇾̣ 〖 𝒫 , F₀ 𝒳 〗

    -- Naturality conditions for the two components
    str-nat₁ : {𝒫 𝒬 𝒳 : Familyₛ}{𝒫ᴮ : Coalgₚ 𝒫}{𝒬ᴮ : Coalgₚ 𝒬}
             → {f : 𝒬 ⇾̣ 𝒫} (fᴮ⇒ : Coalgₚ⇒ 𝒬ᴮ 𝒫ᴮ f)
             → (h : F₀ 〖 𝒫 , 𝒳 〗 α Γ) (σ : Γ ~[ 𝒬 ]↝ Δ)
      → str 𝒫ᴮ 𝒳 h (f ∘ σ)
      ≡ str 𝒬ᴮ 𝒳 (F₁ (λ{ h′ ς → h′ (λ v → f (ς v))}) h) σ

    str-nat₂ : {𝒫 𝒳 𝒴 : Familyₛ}{𝒫ᴮ : Coalgₚ 𝒫}
             → (f : 𝒳 ⇾̣ 𝒴)(h : F₀ 〖 𝒫 , 𝒳 〗 α Γ)(σ : Γ ~[ 𝒫 ]↝ Δ)
      → str 𝒫ᴮ 𝒴 (F₁ (λ{ h′ ς → f (h′ ς)}) h) σ
      ≡ F₁ f (str 𝒫ᴮ 𝒳 h σ)

    -- Unit law
    str-unit : (𝒳 : Familyₛ)(h : F₀ 〖 ℐ , 𝒳 〗 α Γ)
      → str ℐᴮ 𝒳 h id
      ≡ F₁ (i 𝒳) h

    -- Associativity law for a particular pointed coalgebraic map f
    str-assoc  : (𝒳 : Familyₛ){𝒫 𝒬 ℛ : Familyₛ}
                 {𝒫ᴮ : Coalgₚ 𝒫} {𝒬ᴮ : Coalgₚ 𝒬} {ℛᴮ : Coalgₚ ℛ}
                 {f : 𝒫 ⇾̣ 〖 𝒬 , ℛ 〗}
                 (fᶜ : Coalgebraic 𝒫ᴮ 𝒬ᴮ ℛᴮ f) (open Coalgebraic fᶜ)
                 (h : F₀ 〖 ℛ , 𝒳 〗 α Γ)(σ : Γ ~[ 𝒫 ]↝ Δ)(ς : Δ ~[ 𝒬 ]↝ Θ)
      → str ℛᴮ 𝒳 h (λ v → f (σ v) ς)
      ≡ str 𝒬ᴮ 𝒳 (str 〖𝒫,𝒴〗ᴮ 〖 𝒬 , 𝒳 〗 (F₁ (L 𝒬 ℛ 𝒳) h) (f ∘ σ)) ς

  module _ (𝒳 {𝒫 𝒬 ℛ} : Familyₛ) where

    -- Precompose an internal hom by a parametrised map
    precomp : (f : 𝒫 ⇾̣ 〖 𝒬 , ℛ 〗) → 〖 ℛ , 𝒳 〗 ⇾̣ 〖 𝒫 , 〖 𝒬 , 𝒳 〗 〗
    precomp f h σ ς = h (λ v → f (σ v) ς)

    -- Corollary: strength distributes over pointed coalgebraic maps
    str-dist : {𝒫ᴮ : Coalgₚ 𝒫} {𝒬ᴮ : Coalgₚ 𝒬} {ℛᴮ : Coalgₚ ℛ}
               {f : 𝒫 ⇾̣ 〖 𝒬 , ℛ 〗}
               (fᶜ : Coalgebraic 𝒫ᴮ 𝒬ᴮ ℛᴮ f)
               (h : F₀ 〖 ℛ , 𝒳 〗 α Γ)(σ : Γ ~[ 𝒫 ]↝ Δ)(ς : Δ ~[ 𝒬 ]↝ Θ)
      → str ℛᴮ 𝒳 h (λ v → f (σ v) ς)
      ≡ str 𝒬ᴮ 𝒳 (str 𝒫ᴮ 〖 𝒬 , 𝒳 〗 (F₁ (precomp f) h) σ) ς
    str-dist {𝒫ᴮ = 𝒫ᴮ} {𝒬ᴮ} {ℛᴮ} {f} fᶜ h σ ς =
      begin
          str ℛᴮ 𝒳 h (λ v → f (σ v) ς)
      ≡⟨ str-assoc 𝒳 fᶜ h σ ς ⟩
          str 𝒬ᴮ 𝒳 (str 〖𝒫,𝒴〗ᴮ 〖 𝒬 , 𝒳 〗 (F₁ (L 𝒬 ℛ 𝒳) h) (f ∘ σ)) ς
      ≡⟨ cong (λ - → str 𝒬ᴮ 𝒳 - ς) (str-nat₁ fᴮ⇒ (F₁ (L 𝒬 ℛ 𝒳) h) σ) ⟩
          str 𝒬ᴮ 𝒳 (str 𝒫ᴮ 〖 𝒬 , 𝒳 〗 (F₁ 〖 f , 〖 𝒬 , 𝒳 〗 〗ₗ
                                        (F₁ (L 𝒬 ℛ 𝒳) h)) σ) ς
      ≡˘⟨ cong (λ - → str 𝒬ᴮ 𝒳 (str 𝒫ᴮ 〖 𝒬 , 𝒳 〗 - σ) ς) homomorphism ⟩
          str 𝒬ᴮ 𝒳 (str 𝒫ᴮ 〖 𝒬 , 𝒳 〗 (F₁ (precomp f) h) σ) ς
      ∎
      where
      open ≡-Reasoning
      open Coalgebraic fᶜ renaming (ᴮ⇒ to fᴮ⇒)


{-# OPTIONS --universe-polymorphism #-}

module Issue464 where

open import Common.Level

data _×_ {a b}(A : Set a)(B : Set b) : Set (a ⊔ b) where
  _,_ : A → B → A × B

data ⊥ : Set where
record ⊤ : Set where

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

data nonSP : Set1 where
  ι : nonSP
  δ : (A : Set) -> nonSP -> nonSP

⟦_⟧ : nonSP -> (Set × ⊤) -> Set
⟦ ι ⟧ UT = ⊤
⟦ (δ A γ) ⟧ (U , T) = (U -> A) × ⟦ γ ⟧ (U , T)

data U (γ : nonSP) : Set where
  intro : ⟦ γ ⟧ (U γ , _) -> U γ
-- the positivity checker objects (as it should) if "(Set × ⊤)" is changed to "Set"
-- in the type of ⟦_⟧ and "(U γ , _)" is changed accordingly to "U γ".

bad : Set
bad = U (δ ⊥ ι) -- constructor in : (bad -> ⊥) -> bad

p : bad -> ⊥
p (intro (x , _)) = x (intro (x , _))

absurd : ⊥
absurd = p (intro (p , _))


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

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

open import Cubical.Data.Bool
open import Cubical.HITs.Join
open import Cubical.HITs.Susp.Base

open Iso

Susp-iso-joinBool : ∀ {ℓ} {A : Type ℓ} → Iso (Susp A) (join A Bool)
fun Susp-iso-joinBool north = inr true
fun Susp-iso-joinBool south = inr false
fun Susp-iso-joinBool (merid a i) = (sym (push a true) ∙ push a false) i
inv Susp-iso-joinBool (inr true ) = north
inv Susp-iso-joinBool (inr false) = south
inv Susp-iso-joinBool (inl _) = north
inv Susp-iso-joinBool (push a true  i) = north
inv Susp-iso-joinBool (push a false i) = merid a i
rightInv Susp-iso-joinBool (inr true ) = refl
rightInv Susp-iso-joinBool (inr false) = refl
rightInv Susp-iso-joinBool (inl a) = sym (push a true)
rightInv Susp-iso-joinBool (push a true  i) j = push a true (i ∨ ~ j)
rightInv Susp-iso-joinBool (push a false i) j
  = hcomp (λ k → λ { (i = i0) → push a true (~ j)
                   ; (i = i1) → push a false k
                   ; (j = i1) → push a false (i ∧ k) })
          (push a true (~ i ∧ ~ j))
leftInv Susp-iso-joinBool north = refl
leftInv Susp-iso-joinBool south = refl
leftInv (Susp-iso-joinBool {A = A}) (merid a i) j
  = hcomp (λ k → λ { (i = i0) → transp (λ _ → Susp A) (k ∨ j) north
                   ; (i = i1) → transp (λ _ → Susp A) (k ∨ j) (merid a k)
                   ; (j = i1) → merid a (i ∧ k) })
          (transp (λ _ → Susp A) j north)

Susp≃joinBool : ∀ {ℓ} {A : Type ℓ} → Susp A ≃ join A Bool
Susp≃joinBool = isoToEquiv Susp-iso-joinBool

Susp≡joinBool : ∀ {ℓ} {A : Type ℓ} → Susp A ≡ join A Bool
Susp≡joinBool = isoToPath Susp-iso-joinBool

congSuspEquiv : ∀ {ℓ} {A B : Type ℓ} → A ≃ B → Susp A ≃ Susp B
congSuspEquiv {ℓ} {A} {B} h = isoToEquiv isom
  where isom : Iso (Susp A) (Susp B)
        Iso.fun isom north = north
        Iso.fun isom south = south
        Iso.fun isom (merid a i) = merid (fst h a) i
        Iso.inv isom north = north
        Iso.inv isom south = south
        Iso.inv isom (merid a i) = merid (invEq h a) i
        Iso.rightInv isom north = refl
        Iso.rightInv isom south = refl
        Iso.rightInv isom (merid a i) j = merid (retEq h a j) i
        Iso.leftInv isom north = refl
        Iso.leftInv isom south = refl
        Iso.leftInv isom (merid a i) j = merid (secEq h a j) i

suspToPropElim : ∀ {ℓ ℓ'} {A : Type ℓ} {B : Susp A → Type ℓ'} (a : A)
                 → ((x : Susp A) → isProp (B x))
                 → B north
                 → (x : Susp A) → B x
suspToPropElim a isProp Bnorth north = Bnorth
suspToPropElim {B = B} a isProp Bnorth south = subst B (merid a) Bnorth
suspToPropElim {B = B} a isProp Bnorth (merid a₁ i) =
  isOfHLevel→isOfHLevelDep 1 isProp Bnorth (subst B (merid a) Bnorth) (merid a₁) i

suspToPropElim2 : ∀ {ℓ ℓ'} {A : Type ℓ} {B : Susp A → Susp A → Type ℓ'} (a : A)
                 → ((x y : Susp A) → isProp (B x y))
                 → B north north
                 → (x y : Susp A) → B x y
suspToPropElim2 _ _ Bnorth north north = Bnorth
suspToPropElim2 {B = B} a _ Bnorth north south = subst (B north) (merid a) Bnorth
suspToPropElim2 {B = B} a isprop Bnorth north (merid x i) =
  isProp→PathP (λ i → isprop north (merid x i))
               Bnorth (subst (B north) (merid a) Bnorth) i
suspToPropElim2 {B = B} a _ Bnorth south north = subst (λ x → B x north) (merid a) Bnorth
suspToPropElim2 {B = B} a _ Bnorth south south = subst (λ x → B x x) (merid a) Bnorth
suspToPropElim2 {B = B} a isprop Bnorth south (merid x i) =
  isProp→PathP (λ i → isprop south (merid x i))
               (subst (λ x → B x north) (merid a) Bnorth)
               (subst (λ x → B x x) (merid a) Bnorth) i
suspToPropElim2 {B = B} a isprop Bnorth (merid x i) north =
  isProp→PathP (λ i → isprop (merid x i) north)
               Bnorth (subst (λ x → B x north) (merid a) Bnorth) i
suspToPropElim2 {B = B} a isprop Bnorth (merid x i) south =
  isProp→PathP (λ i → isprop (merid x i) south)
               (subst (B north) (merid a) Bnorth)
               (subst (λ x → B x x) (merid a) Bnorth) i
suspToPropElim2 {B = B} a isprop Bnorth (merid x i) (merid y j) =
  isSet→SquareP (λ i j → isOfHLevelSuc 1 (isprop _ _))
     (isProp→PathP (λ i₁ → isprop north (merid y i₁)) Bnorth
                   (subst (B north) (merid a) Bnorth))
     (isProp→PathP (λ i₁ → isprop south (merid y i₁))
                   (subst (λ x₁ → B x₁ north) (merid a) Bnorth)
                   (subst (λ x₁ → B x₁ x₁) (merid a) Bnorth))
     (isProp→PathP (λ i₁ → isprop (merid x i₁) north) Bnorth
                   (subst (λ x₁ → B x₁ north) (merid a) Bnorth))
     (isProp→PathP (λ i₁ → isprop (merid x i₁) south)
                   (subst (B north) (merid a) Bnorth)
                   (subst (λ x₁ → B x₁ x₁) (merid a) Bnorth)) i j
{- Clever proof:
suspToPropElim2 a isProp Bnorth =
  suspToPropElim a (λ x → isOfHLevelΠ 1 λ y → isProp x y)
                   (suspToPropElim a (λ x → isProp north x) Bnorth)
-}


module Structure.Signature where

open import Data.Tuple.Raise
open import Data.Tuple.Raiseᵣ.Functions
import      Lvl
open import Numeral.Natural
open import Structure.Function
open import Structure.Setoid
open import Structure.Relator
open import Type

private variable ℓ ℓᵢ ℓᵢ₁ ℓᵢ₂ ℓᵢ₃ ℓd ℓd₁ ℓd₂ ℓᵣ ℓᵣ₁ ℓᵣ₂ ℓₑ ℓₑ₁ ℓₑ₂ : Lvl.Level
private variable n : ℕ

-- A signature consists of a countable family of sets of function and relation symbols.
-- `functions(n)` and `relations(n)` should be interpreted as the indices for functions/relations of arity `n`.
record Signature : Type{Lvl.𝐒(ℓᵢ₁ Lvl.⊔ ℓᵢ₂)} where
  field
    functions : ℕ → Type{ℓᵢ₁}
    relations : ℕ → Type{ℓᵢ₂}

private variable s : Signature{ℓᵢ₁}{ℓᵢ₂}

import      Data.Tuple.Equiv as Tuple

-- A structure with a signature `s` consists of a domain and interpretations of the function/relation symbols in `s`.
record Structure (s : Signature{ℓᵢ₁}{ℓᵢ₂}) : Type{Lvl.𝐒(ℓₑ Lvl.⊔ ℓd Lvl.⊔ ℓᵣ) Lvl.⊔ ℓᵢ₁ Lvl.⊔ ℓᵢ₂} where
  open Signature(s)
  field
    domain : Type{ℓd}
    ⦃ equiv ⦄ : ∀{n} → Equiv{ℓₑ}(domain ^ n)
    ⦃ ext ⦄ : ∀{n} → Tuple.Extensionality(equiv{𝐒(𝐒 n)})
    function : functions(n) → ((domain ^ n) → domain)
    ⦃ function-func ⦄ : ∀{fi} → Function(function{n} fi)
    relation : relations(n) → ((domain ^ n) → Type{ℓᵣ})
    ⦃ relation-func ⦄ : ∀{ri} → UnaryRelator(relation{n} ri)

open Structure public using() renaming (domain to dom ; function to fn ; relation to rel)

open import Logic.Predicate

module _ {s : Signature{ℓᵢ₁}{ℓᵢ₂}} where
  private variable A B C S : Structure{ℓd = ℓd}{ℓᵣ = ℓᵣ}(s)
  private variable fi : Signature.functions s n
  private variable ri : Signature.relations s n
  private variable xs : dom(S) ^ n

  record Homomorphism
    (A : Structure{ℓₑ = ℓₑ₁}{ℓd = ℓd₁}{ℓᵣ = ℓᵣ₁}(s))
    (B : Structure{ℓₑ = ℓₑ₂}{ℓd = ℓd₂}{ℓᵣ = ℓᵣ₂}(s))
    (f : dom(A) → dom(B))
    : Type{ℓₑ₁ Lvl.⊔ ℓₑ₂ Lvl.⊔ ℓd₁ Lvl.⊔ ℓd₂ Lvl.⊔ ℓᵣ₁ Lvl.⊔ ℓᵣ₂ Lvl.⊔ Lvl.ofType(Type.of s)}
    where

    field
      ⦃ function ⦄ : Function(f)
      preserve-functions : ∀{xs : dom(A) ^ n} → (f(fn(A) fi xs) ≡ fn(B) fi (map f xs))
      preserve-relations : ∀{xs : dom(A) ^ n} → (rel(A) ri xs) → (rel(B) ri (map f xs))

  _→ₛₜᵣᵤ_ : Structure{ℓₑ = ℓₑ₁}{ℓd = ℓd₁}{ℓᵣ = ℓᵣ₁}(s) → Structure{ℓₑ = ℓₑ₂}{ℓd = ℓd₂}{ℓᵣ = ℓᵣ₂}(s) → Type
  A →ₛₜᵣᵤ B = ∃(Homomorphism A B)

  open import Data
  open import Data.Tuple as Tuple using (_,_)
  open import Data.Tuple.Raiseᵣ.Proofs
  open import Functional
  open import Function.Proofs
  open import Lang.Instance
  open import Structure.Operator
  open import Structure.Relator.Properties
  open import Syntax.Transitivity

  idₛₜᵣᵤ : A →ₛₜᵣᵤ A
  ∃.witness idₛₜᵣᵤ = id
  Homomorphism.preserve-functions (∃.proof (idₛₜᵣᵤ {A = A})) {n} {fi} {xs} = congruence₁(fn A fi) (symmetry(Equiv._≡_ (Structure.equiv A)) ⦃ Equiv.symmetry infer ⦄ map-id)
  Homomorphism.preserve-relations (∃.proof (idₛₜᵣᵤ {A = A})) {n} {ri} {xs} = substitute₁ₗ(rel A ri) map-id

  _∘ₛₜᵣᵤ_ : let _ = A , B , C in (B →ₛₜᵣᵤ C) → (A →ₛₜᵣᵤ B) → (A →ₛₜᵣᵤ C)
  ∃.witness (([∃]-intro f) ∘ₛₜᵣᵤ ([∃]-intro g)) = f ∘ g
  Homomorphism.function (∃.proof ([∃]-intro f ∘ₛₜᵣᵤ [∃]-intro g)) = [∘]-function {f = f}{g = g}
  Homomorphism.preserve-functions (∃.proof (_∘ₛₜᵣᵤ_ {A = A} {B = B} {C = C} ([∃]-intro f ⦃ hom-f ⦄) ([∃]-intro g ⦃ hom-g ⦄))) {fi = fi} = transitivity(_≡_) ⦃ Equiv.transitivity infer ⦄ (transitivity(_≡_) ⦃ Equiv.transitivity infer ⦄ (congruence₁(f) (Homomorphism.preserve-functions hom-g)) (Homomorphism.preserve-functions hom-f)) (congruence₁(fn C fi) (symmetry(Equiv._≡_ (Structure.equiv C)) ⦃ Equiv.symmetry infer ⦄ (map-[∘] {f = f}{g = g})))
  Homomorphism.preserve-relations (∃.proof (_∘ₛₜᵣᵤ_ {A = A} {B = B} {C = C} ([∃]-intro f ⦃ hom-f ⦄) ([∃]-intro g ⦃ hom-g ⦄))) {ri = ri} = substitute₁ₗ (rel C ri) map-[∘] ∘ Homomorphism.preserve-relations hom-f ∘ Homomorphism.preserve-relations hom-g

  open import Function.Equals
  open import Function.Equals.Proofs
  open import Logic.Predicate.Equiv
  open import Structure.Category
  open import Structure.Categorical.Properties

  Structure-Homomorphism-category : Category(_→ₛₜᵣᵤ_ {ℓₑ}{ℓd}{ℓᵣ})
  Category._∘_ Structure-Homomorphism-category = _∘ₛₜᵣᵤ_
  Category.id  Structure-Homomorphism-category = idₛₜᵣᵤ
  BinaryOperator.congruence (Category.binaryOperator Structure-Homomorphism-category) = [⊜][∘]-binaryOperator-raw
  _⊜_.proof (Morphism.Associativity.proof (Category.associativity Structure-Homomorphism-category) {_} {_} {_} {_} {[∃]-intro f} {[∃]-intro g} {[∃]-intro h}) {x} = reflexivity(_≡_) ⦃ Equiv.reflexivity infer ⦄ {f(g(h(x)))}
  _⊜_.proof (Morphism.Identityₗ.proof (Tuple.left (Category.identity Structure-Homomorphism-category)) {f = [∃]-intro f}) {x} = reflexivity(_≡_) ⦃ Equiv.reflexivity infer ⦄ {f(x)}
  _⊜_.proof (Morphism.Identityᵣ.proof (Tuple.right (Category.identity Structure-Homomorphism-category)) {f = [∃]-intro f}) {x} = reflexivity(_≡_) ⦃ Equiv.reflexivity infer ⦄ {f(x)}

module _ (s : Signature{ℓᵢ₁}{ℓᵢ₂}) where
  data Term : Type{ℓᵢ₁} where
    var  : ℕ → Term
    func : (Signature.functions s n) → (Term ^ n) → Term


module Data.Fin.Instance where

open import Class.Equality
open import Class.Traversable
open import Data.Fin renaming (_≟_ to _≟F_)
open import Data.Fin.Map

instance
  Eq-Fin : ∀ {n} -> Eq (Fin n)
  Eq-Fin = record { _≟_ = _≟F_ }

  Traversable-Fin-Map : ∀ {a} {n} -> Traversable {a} (FinMap n)
  Traversable-Fin-Map = record { sequence = sequenceDepFinMap }


------------------------------------------------------------------------
-- Localisation
------------------------------------------------------------------------

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

-- Following "Modalities in Homotopy Type Theory" by Rijke, Shulman
-- and Spitters.

-- The module is parametrised by a notion of equality. The higher
-- constructors of the HIT defining localisation use path equality,
-- but the supplied notion of equality is used for many other things.

import Equality.Path as P

module Localisation
  {e⁺} (eq : ∀ {a p} → P.Equality-with-paths a p e⁺) where

open P.Derived-definitions-and-properties eq hiding (elim)

open import Prelude as P

open import Bijection equality-with-J using (_↔_)
open import Equality.Path.Isomorphisms eq hiding (ext)
open import Pushout eq as Pushout using (Pushout)

private
  variable
    a b c p q r : Level
    A B C       : Type a
    P Q R       : A → Type p
    e f g x y   : A

------------------------------------------------------------------------
-- Localisation

-- A first approximation to localisation.
--
-- This is a slight generalisation of the HIT that Rijke et al. call
-- 𝓙: they require all types to live in the same universe.

data Localisation′
       {A : Type a} {P : A → Type p} {Q : A → Type q}
       (f : ∀ x → P x → Q x) (B : Type b) :
       Type (a ⊔ b ⊔ p ⊔ q) where
  [_]   : B → Localisation′ f B
  ext   : (P x → Localisation′ f B) →
          (Q x → Localisation′ f B)
  ext≡ᴾ : ext g (f x y) P.≡ g y

-- A variant of ext≡ᴾ.

ext≡ :
  {f : (x : A) → P x → Q x} {g : P x → Localisation′ f B} →
  ext g (f x y) ≡ g y
ext≡ = _↔_.from ≡↔≡ ext≡ᴾ

-- Localisation.

Localisation :
  {A : Type a} {P : A → Type p} {Q : A → Type q} →
  (∀ x → P x → Q x) →
  Type b → Type (a ⊔ b ⊔ p ⊔ q)
Localisation {p = p} {q = q} {A = A} {P = P} {Q = Q} f =
  Localisation′ f̂
  where
  P̂ : A ⊎ A → Type (p ⊔ q)
  P̂ = P.[ ↑ q ∘ P
        , (λ x → Pushout (record { left = f x; right = f x }))
        ]

  Q̂ : A ⊎ A → Type q
  Q̂ = P.[ Q , Q ]

  f̂ : (x : A ⊎ A) → P̂ x → Q̂ x
  f̂ = P.[ (λ x → f x ∘ lower)
        , (λ x → Pushout.rec id id (refl ∘ f x))
        ]

------------------------------------------------------------------------
-- Some eliminators for Localisation′

-- A dependent eliminator, expressed using paths.

record Elimᴾ
         {A : Type a} {P : A → Type p} {Q : A → Type q}
         (f : ∀ x → P x → Q x) (B : Type b)
         (R : Localisation′ f B → Type r) :
         Type (a ⊔ b ⊔ p ⊔ q ⊔ r) where
  no-eta-equality
  field
    []ʳ   : ∀ x → R [ x ]
    extʳ  : (∀ y → R (g y)) → ∀ y → R (ext {x = x} g y)
    ext≡ʳ : (h : (y : P x) → R (g y)) →
            P.[ (λ i → R (ext≡ᴾ {g = g} {y = y} i)) ] extʳ h (f x y) ≡
            h y

open Elimᴾ public

elimᴾ : Elimᴾ f B R → (x : Localisation′ f B) → R x
elimᴾ {f = f} {B = B} {R = R} e = helper
  where
  module E = Elimᴾ e

  helper : (x : Localisation′ f B) → R x
  helper [ x ]             = E.[]ʳ x
  helper (ext g y)         = E.extʳ (λ y → helper (g y)) y
  helper (ext≡ᴾ {g = g} i) = E.ext≡ʳ (λ y → helper (g y)) i

-- A non-dependent eliminator, expressed using paths.

record Recᴾ
         {A : Type a} {P : A → Type p} {Q : A → Type q}
         (f : ∀ x → P x → Q x) (B : Type b)
         (C : Type c) :
         Type (a ⊔ b ⊔ p ⊔ q ⊔ c) where
  no-eta-equality
  field
    []ʳ   : B → C
    extʳ  : (P x → C) → Q x → C
    ext≡ʳ : (g : P x → C) → extʳ g (f x y) P.≡ g y

open Recᴾ public

recᴾ : Recᴾ f B C → Localisation′ f B → C
recᴾ r = elimᴾ λ where
    .[]ʳ   → R.[]ʳ
    .extʳ  → R.extʳ
    .ext≡ʳ → R.ext≡ʳ
  where
  module R = Recᴾ r

-- A dependent eliminator.

record Elim
         {A : Type a} {P : A → Type p} {Q : A → Type q}
         (f : ∀ x → P x → Q x) (B : Type b)
         (R : Localisation′ f B → Type r) :
         Type (a ⊔ b ⊔ p ⊔ q ⊔ r) where
  no-eta-equality
  field
    []ʳ   : ∀ x → R [ x ]
    extʳ  : (∀ y → R (g y)) → ∀ y → R (ext {x = x} g y)
    ext≡ʳ : (h : (y : P x) → R (g y)) →
            subst R (ext≡ {y = y} {g = g}) (extʳ h (f x y)) ≡ h y

open Elim public

elim : Elim f B R → (x : Localisation′ f B) → R x
elim e = elimᴾ λ where
    .[]ʳ   → E.[]ʳ
    .extʳ  → E.extʳ
    .ext≡ʳ → subst≡→[]≡ ∘ E.ext≡ʳ
  where
  module E = Elim e

-- A "computation" rule.

elim-ext≡ :
  dcong (elim e) (ext≡ {y = y} {g = g}) ≡
  Elim.ext≡ʳ e (elim e ∘ g)
elim-ext≡ = dcong-subst≡→[]≡ (refl _)

-- A non-dependent eliminator.

record Rec
         {A : Type a} {P : A → Type p} {Q : A → Type q}
         (f : ∀ x → P x → Q x) (B : Type b)
         (C : Type c) :
         Type (a ⊔ b ⊔ p ⊔ q ⊔ c) where
  no-eta-equality
  field
    []ʳ   : B → C
    extʳ  : (P x → C) → Q x → C
    ext≡ʳ : (g : P x → C) → extʳ g (f x y) ≡ g y

open Rec public

rec : Rec f B C → Localisation′ f B → C
rec r = recᴾ λ where
    .[]ʳ   → R.[]ʳ
    .extʳ  → R.extʳ
    .ext≡ʳ → _↔_.to ≡↔≡ ∘ R.ext≡ʳ
  where
  module R = Rec r

-- A "computation" rule.

rec-ext≡ :
  {f : ∀ x → P x → Q x}
  {r : Rec f B C}
  {g : P x → Localisation′ f B} →
  cong (rec r) (ext≡ {y = y} {g = g}) ≡
  Rec.ext≡ʳ r (rec r ∘ g)
rec-ext≡ = cong-≡↔≡ (refl _)


postulate
  A B : Set
  f : @0 {{A}} → B

g : @0 {{A}} → B
g = f


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

module Class where

open import Cubical.Core.Everything
open import Function.Base using (id; _$_)

private
  variable
    A B C : Set
    ℓ ℓ′ ℓ″ : Level

-- Custom non-dependent definition, since the one in the prelude is too general
_∘_ : {A : Set ℓ} {B : Set ℓ′} {C : Set ℓ″} → (B → C) → (A → B) → A → C
(f ∘ g) x = f (g x)

infixr 9 _∘_

record Functor (F : Set → Set₁) : Set₂ where
  field
    fmap : (A → B) → F A → F B
    fmap-id-legit : (m : F A) → fmap id m ≡ m
    fmap-compose-legit
      : (m : F A)
      → (f : B → C)
      → (g : A → B)
      → fmap (f ∘ g) m ≡ fmap f (fmap g m)
  _<$>_ : (A → B) → F A → F B
  f <$> x = fmap f x

open Functor

record Applicative (F : Set → Set₁) : Set₂ where
  infixl 4 _<*>_

  field
    functor : Functor F
    pure : A → F A
    _<*>_ : F (A → B) → F A → F B
    app-identity : (v : F A) → (pure id <*> v) ≡ v
    app-compose
      : (u : F (B → C))
      → (v : F (A → B))
      → (w : F A)
      → (pure _∘_ <*> u <*> v <*> w) ≡ (u <*> (v <*> w))
    app-homo
      : (f : A → B)
      → (x : A)
      → (pure f <*> pure x) ≡ pure (f x)
    app-intchg
      : (u : F (A → B))
      → (y : A)
      → (u <*> pure y) ≡ (pure (_$ y) <*> u)

  open Functor functor public

record Monad (M : Set → Set₁) : Set₂ where
  infixl 1 _>>=_

  field
    applicative : Applicative M
    _>>=_ : M A → (A → M B) → M B

  open Applicative applicative public

  return : A → M A
  return = pure

  field
    monad-left-id
      : (a : A)
      → (f : A → M B)
      → (return a >>= f) ≡ f a
    monad-right-id
      : (m : M A)
      → (m >>= return) ≡ m
    monad-assoc
      : (m : M A)
      → (f : A → M B)
      → (g : B → M C)
      → (m >>= f >>= g) ≡ (m >>= (λ x → f x >>= g))


{-# OPTIONS --universe-polymorphism #-}
module Data.BitVector.Properties where

open import Algebra using (CommutativeRing)
open import Data.Bool using (_∧_; _∨_; _xor_)
                   renaming (Bool to Bit; false to 0#; true to 1#)
open import Data.Nat using (ℕ) renaming (zero to Nzero; suc to Nsuc)
open import Data.Product using (_,_)
open import Data.Vec hiding (last)
open import Relation.Binary
open import Relation.Binary.PropositionalEquality

open import Data.BitVector

last-cons : ∀ {n} x (xs : BitVector (Nsuc n)) → last (x ∷ xs) ≡ last xs
last-cons _ (x ∷ xs) = refl

last-snoc : ∀ {n} (xs : BitVector n) x → last (snoc xs x) ≡ x
last-snoc []            _                                  = refl
last-snoc (y ∷ [])      _                                  = refl
last-snoc (y ∷ y′ ∷ ys) x rewrite last-cons y′ (snoc ys x) = last-snoc ys x

droplast-snoc : ∀ {n} (xs : BitVector n) x → droplast (snoc xs x) ≡ xs
droplast-snoc []       _                            = refl
droplast-snoc (y ∷ ys) x rewrite droplast-snoc ys x = refl

droplast-snoc-last : ∀ {n} (x : BitVector (Nsuc n)) → snoc (droplast x) (last x) ≡ x
droplast-snoc-last (x ∷ [])                                           = refl
droplast-snoc-last (x ∷ x′ ∷ xs) rewrite droplast-snoc-last (x′ ∷ xs) = refl

rotate∘unrotate≡id : ∀ {n} (x : BitVector n) → rotate (unrotate x) ≡ x
rotate∘unrotate≡id [] = refl
rotate∘unrotate≡id (x ∷ []) = refl
rotate∘unrotate≡id (x ∷ x′ ∷ xs) rewrite last-cons x′ (snoc xs x)
                                      | last-snoc xs x
                                      | droplast-snoc xs x = refl

unrotate∘rotate≡id : ∀ {n} (x : BitVector n) → unrotate (rotate x) ≡ x
unrotate∘rotate≡id [] = refl
unrotate∘rotate≡id (x ∷ xs) = droplast-snoc-last (x ∷ xs)

private
  module P {n : ℕ} where
    import Algebra.FunctionProperties as FP; open FP (_≡_ {A = BitVector n}) public
  open P

  +-identityˡ : ∀ {n} → LeftIdentity (zero n) _+_
  +-identityˡ []                               = refl
  +-identityˡ (1# ∷ xs) rewrite +-identityˡ xs = refl
  +-identityˡ (0# ∷ xs) rewrite +-identityˡ xs = refl

  +-identityʳ : ∀ {n} → RightIdentity (zero n) _+_
  +-identityʳ []                               = refl
  +-identityʳ (1# ∷ xs) rewrite +-identityʳ xs = refl
  +-identityʳ (0# ∷ xs) rewrite +-identityʳ xs = refl

  add-carry : ∀ {n} c₁ c₂ (x y z : BitVector n) → add′ c₁ x (add′ c₂ y z) ≡ add′ c₂ x (add′ c₁ y z)
  add-carry c₁ c₂ []        []        []                                         = refl
  add-carry 0# 0# (0# ∷ xs) (y  ∷ ys) (z  ∷ zs)                                  = refl
  add-carry 0# 0# (1# ∷ xs) (0# ∷ ys) (0# ∷ zs)                                  = refl
  add-carry 0# 0# (1# ∷ xs) (0# ∷ ys) (1# ∷ zs)                                  = refl
  add-carry 0# 0# (1# ∷ xs) (1# ∷ ys) (0# ∷ zs)                                  = refl
  add-carry 0# 0# (1# ∷ xs) (1# ∷ ys) (1# ∷ zs)                                  = refl
  add-carry 0# 1# (0# ∷ xs) (0# ∷ ys) (0# ∷ zs)                                  = refl
  add-carry 0# 1# (0# ∷ xs) (0# ∷ ys) (1# ∷ zs) rewrite add-carry 0# 1# xs ys zs = refl
  add-carry 0# 1# (0# ∷ xs) (1# ∷ ys) (0# ∷ zs) rewrite add-carry 0# 1# xs ys zs = refl
  add-carry 0# 1# (0# ∷ xs) (1# ∷ ys) (1# ∷ zs)                                  = refl
  add-carry 0# 1# (1# ∷ xs) (0# ∷ ys) (0# ∷ zs)                                  = refl
  add-carry 0# 1# (1# ∷ xs) (0# ∷ ys) (1# ∷ zs) rewrite add-carry 0# 1# xs ys zs = refl
  add-carry 0# 1# (1# ∷ xs) (1# ∷ ys) (0# ∷ zs) rewrite add-carry 0# 1# xs ys zs = refl
  add-carry 0# 1# (1# ∷ xs) (1# ∷ ys) (1# ∷ zs)                                  = refl
  add-carry 1# 0# (0# ∷ xs) (0# ∷ ys) (0# ∷ zs)                                  = refl
  add-carry 1# 0# (0# ∷ xs) (0# ∷ ys) (1# ∷ zs) rewrite add-carry 1# 0# xs ys zs = refl
  add-carry 1# 0# (0# ∷ xs) (1# ∷ ys) (0# ∷ zs) rewrite add-carry 1# 0# xs ys zs = refl
  add-carry 1# 0# (0# ∷ xs) (1# ∷ ys) (1# ∷ zs)                                  = refl
  add-carry 1# 0# (1# ∷ xs) (0# ∷ ys) (0# ∷ zs)                                  = refl
  add-carry 1# 0# (1# ∷ xs) (0# ∷ ys) (1# ∷ zs) rewrite add-carry 1# 0# xs ys zs = refl
  add-carry 1# 0# (1# ∷ xs) (1# ∷ ys) (0# ∷ zs) rewrite add-carry 1# 0# xs ys zs = refl
  add-carry 1# 0# (1# ∷ xs) (1# ∷ ys) (1# ∷ zs)                                  = refl
  add-carry 1# 1# (0# ∷ xs) (y  ∷ ys) (z  ∷ zs)                                  = refl
  add-carry 1# 1# (1# ∷ xs) (0# ∷ ys) (0# ∷ zs)                                  = refl
  add-carry 1# 1# (1# ∷ xs) (0# ∷ ys) (1# ∷ zs)                                  = refl
  add-carry 1# 1# (1# ∷ xs) (1# ∷ ys) (0# ∷ zs)                                  = refl
  add-carry 1# 1# (1# ∷ xs) (1# ∷ ys) (1# ∷ zs)                                  = refl

  add-assoc : ∀ {n} c₁ c₂ (x y z : BitVector n) → add′ c₁ (add′ c₂ x y) z ≡ add′ c₁ x (add′ c₂ y z)
  add-assoc c₁ c₂ []        []        []                                         = refl
  add-assoc c₁ 1# (1# ∷ xs) (1# ∷ ys) (1# ∷ zs) rewrite add-assoc 1# 1# xs ys zs = refl
  add-assoc c₁ 1# (1# ∷ xs) (1# ∷ ys) (0# ∷ zs) rewrite add-assoc c₁ 1# xs ys zs = refl
  add-assoc c₁ 1# (1# ∷ xs) (0# ∷ ys) (1# ∷ zs) rewrite add-assoc c₁ 1# xs ys zs = refl
  add-assoc c₁ 1# (1# ∷ xs) (0# ∷ ys) (0# ∷ zs) rewrite add-assoc 0# 1# xs ys zs
                                                      | add-carry 0# 1# xs ys zs = refl
  add-assoc c₁ 1# (0# ∷ xs) (1# ∷ ys) (1# ∷ zs) rewrite add-assoc c₁ 1# xs ys zs = refl
  add-assoc c₁ 1# (0# ∷ xs) (1# ∷ ys) (0# ∷ zs) rewrite add-assoc 0# 1# xs ys zs = refl
  add-assoc c₁ 1# (0# ∷ xs) (0# ∷ ys) (1# ∷ zs) rewrite add-assoc 1# 0# xs ys zs
                                                      | add-carry 1# 0# xs ys zs = refl
  add-assoc c₁ 1# (0# ∷ xs) (0# ∷ ys) (0# ∷ zs) rewrite add-assoc c₁ 0# xs ys zs = refl
  add-assoc c₁ 0# (1# ∷ xs) (1# ∷ ys) (1# ∷ zs) rewrite add-assoc c₁ 1# xs ys zs = refl
  add-assoc c₁ 0# (1# ∷ xs) (1# ∷ ys) (0# ∷ zs) rewrite add-assoc 0# 1# xs ys zs
                                                      | add-carry 0# 1# xs ys zs = refl
  add-assoc c₁ 0# (1# ∷ xs) (0# ∷ ys) (1# ∷ zs) rewrite add-assoc 1# 0# xs ys zs = refl
  add-assoc c₁ 0# (1# ∷ xs) (0# ∷ ys) (0# ∷ zs) rewrite add-assoc c₁ 0# xs ys zs = refl
  add-assoc c₁ 0# (0# ∷ xs) (1# ∷ ys) (1# ∷ zs) rewrite add-assoc 1# 0# xs ys zs
                                                      | add-carry 1# 0# xs ys zs = refl
  add-assoc c₁ 0# (0# ∷ xs) (1# ∷ ys) (0# ∷ zs) rewrite add-assoc c₁ 0# xs ys zs = refl
  add-assoc c₁ 0# (0# ∷ xs) (0# ∷ ys) (1# ∷ zs) rewrite add-assoc c₁ 0# xs ys zs = refl
  add-assoc c₁ 0# (0# ∷ xs) (0# ∷ ys) (0# ∷ zs) rewrite add-assoc 0# 0# xs ys zs = refl

  +-assoc : ∀ {n} → Associative {n} _+_
  +-assoc []        []        []                                         = refl
  +-assoc (1# ∷ xs) (1# ∷ ys) (1# ∷ zs) rewrite add-assoc 0# 1# xs ys zs = refl
  +-assoc (1# ∷ xs) (1# ∷ ys) (0# ∷ zs) rewrite add-assoc 0# 1# xs ys zs
                                              | add-carry 0# 1# xs ys zs = refl
  +-assoc (1# ∷ xs) (0# ∷ ys) (1# ∷ zs) rewrite add-assoc 1# 0# xs ys zs = refl
  +-assoc (1# ∷ xs) (0# ∷ ys) (0# ∷ zs) rewrite add-assoc 0# 0# xs ys zs = refl
  +-assoc (0# ∷ xs) (1# ∷ ys) (1# ∷ zs) rewrite add-assoc 1# 0# xs ys zs
                                              | add-carry 1# 0# xs ys zs = refl
  +-assoc (0# ∷ xs) (1# ∷ ys) (0# ∷ zs) rewrite add-assoc 0# 0# xs ys zs = refl
  +-assoc (0# ∷ xs) (0# ∷ ys) (1# ∷ zs) rewrite add-assoc 0# 0# xs ys zs = refl
  +-assoc (0# ∷ xs) (0# ∷ ys) (0# ∷ zs) rewrite add-assoc 0# 0# xs ys zs = refl

  add-comm : ∀ {n} c (x y : BitVector n) → add′ c x y ≡ add′ c y x
  add-comm c []        []                                  = refl
  add-comm c (1# ∷ xs) (1# ∷ ys) rewrite add-comm 1# xs ys = refl
  add-comm c (1# ∷ xs) (0# ∷ ys) rewrite add-comm c  xs ys = refl
  add-comm c (0# ∷ xs) (1# ∷ ys) rewrite add-comm c  xs ys = refl
  add-comm c (0# ∷ xs) (0# ∷ ys) rewrite add-comm 0# xs ys = refl

  +-comm : ∀ {n} → Commutative {n} _+_
  +-comm = add-comm 0#

  add-inverse : ∀ {n} xs → add′ 1# (zero n + bitwise-negation xs) xs ≡ zero n
  add-inverse []                               = refl
  add-inverse (1# ∷ xs) rewrite add-inverse xs = refl
  add-inverse (0# ∷ xs) rewrite add-inverse xs = refl

  inverseˡ : ∀ {n} → LeftInverse (zero n) -_ _+_
  inverseˡ [] = refl
  inverseˡ (1# ∷ xs) rewrite add-inverse xs = refl
  inverseˡ (0# ∷ xs) rewrite      add-assoc 0# 1# (zero _) (bitwise-negation xs) xs
                           |      add-carry 0# 1# (zero _) (bitwise-negation xs) xs
                           | sym (add-assoc 1# 0# (zero _) (bitwise-negation xs) xs)
                           | add-inverse xs = refl

  inverseʳ : ∀ {n} → RightInverse (zero n) -_ _+_
  inverseʳ x = trans (+-comm x (- x)) (inverseˡ x)

  *-zeroˡ : ∀ {n} → LeftZero (zero n) _*_
  *-zeroˡ []                                      = refl
  *-zeroˡ {Nsuc n} x rewrite *-zeroˡ (droplast x) = refl

  2*_ : ∀ {n} → Op₁ {0} (BitVector n)
  2* x = droplast (0# ∷ x)

  1+2*_ : ∀ {n} → Op₁ {0} (BitVector n)
  1+2* x = droplast (1# ∷ x)

  _+2*_ : ∀ {n} → Bit → BitVector n → BitVector n
  b +2* x = droplast (b ∷ x)

  *-identityˡ : ∀ {n} → LeftIdentity (one n) _*_
  *-identityˡ []                                                   = refl
  *-identityˡ (0# ∷ xs) rewrite *-zeroˡ (  2* xs) | +-identityʳ xs = refl
  *-identityˡ (1# ∷ xs) rewrite *-zeroˡ (1+2* xs) | +-identityʳ xs = refl

  *-comm : ∀ {n} → Commutative {n} _*_
  *-comm          [] [] = refl
  *-comm {Nsuc n} x  y  = *-comm1 x y
   where
   *-comm1 : ∀ {n} → Commutative {Nsuc n} _*_
   *-comm1          (0# ∷ []) (0# ∷ [])                                            = refl
   *-comm1          (0# ∷ []) (1# ∷ [])                                            = refl
   *-comm1          (1# ∷ []) (0# ∷ [])                                            = refl
   *-comm1          (1# ∷ []) (1# ∷ [])                                            = refl
   *-comm1 {Nsuc _} (0# ∷ xs) (0# ∷ ys) rewrite *-comm1 xs (2* ys)
                                              | *-comm1 ys (2* xs)
                                              | *-comm (droplast ys) (droplast xs) = refl
   *-comm1 {Nsuc _} (0# ∷ xs) (1# ∷ ys) rewrite *-comm1 xs (1+2* ys)
                                              | *-comm1 ys (2* xs)
                                              | *-comm (droplast ys) (droplast xs) = refl
   *-comm1 {Nsuc _} (1# ∷ xs) (0# ∷ ys) rewrite *-comm1 xs (2* ys)
                                              | *-comm1 ys (1+2* xs)
                                              | *-comm (droplast ys) (droplast xs) = refl
   *-comm1 {Nsuc _} (1# ∷ xs) (1# ∷ ys) rewrite *-comm1 xs (1+2* ys)
                                              | *-comm1 ys (1+2* xs)
                                              | *-comm (droplast ys) (droplast xs)
                                              | sym (+-assoc ys xs (0# ∷ droplast xs * droplast ys))
                                              | +-comm ys xs
                                              | +-assoc xs ys (0# ∷ droplast xs * droplast ys) = refl

  droplast-distrib-+ : ∀ {n} (x y : BitVector (Nsuc n))
                     → droplast (x + y) ≡ droplast x + droplast y
  droplast-distrib-+ {Nzero}  _         _                                          = refl
  droplast-distrib-+ {Nsuc _} (0# ∷ xs) (0# ∷ ys) rewrite droplast-distrib-+ xs ys = refl
  droplast-distrib-+ {Nsuc _} (0# ∷ xs) (1# ∷ ys) rewrite droplast-distrib-+ xs ys = refl
  droplast-distrib-+ {Nsuc _} (1# ∷ xs) (0# ∷ ys) rewrite droplast-distrib-+ xs ys = refl
  droplast-distrib-+ {Nsuc _} (1# ∷ xs) (1# ∷ ys) rewrite droplast-distrib-+ xs ys
                                                        = cong (_∷_ 0#) (lemma xs ys)
   where
   lemma : ∀ {n} (xs ys : BitVector (Nsuc n))
         → droplast (add′ 1# xs ys) ≡ add′ 1# (droplast xs) (droplast ys)
   lemma {Nzero}  _         _                                          = refl
   lemma {Nsuc _} (0# ∷ xs) (0# ∷ ys) rewrite droplast-distrib-+ xs ys = refl
   lemma {Nsuc _} (0# ∷ xs) (1# ∷ ys) rewrite lemma xs ys              = refl
   lemma {Nsuc _} (1# ∷ xs) (0# ∷ ys) rewrite lemma xs ys              = refl
   lemma {Nsuc _} (1# ∷ xs) (1# ∷ ys) rewrite lemma xs ys              = refl

  droplast-distrib-* : ∀ {n} (x y : BitVector (Nsuc n))
                     → droplast (x * y) ≡ droplast x * droplast y
  droplast-distrib-* {Nzero}  _         _ = refl
  droplast-distrib-* {Nsuc _} (0# ∷ xs) (y  ∷ ys)
    rewrite droplast-distrib-* xs (y +2* ys) = refl
  droplast-distrib-* {Nsuc _} (1# ∷ xs) (0# ∷ ys)
    rewrite droplast-distrib-+ ys (xs * (2* ys))
          | droplast-distrib-* xs (2* ys) = refl
  droplast-distrib-* {Nsuc _} (1# ∷ xs) (1# ∷ ys)
    rewrite droplast-distrib-+ ys (xs * (1+2* ys))
          | droplast-distrib-* xs (1+2* ys) = refl

  extract-carry : ∀ {n} (xs ys : BitVector n) → add′ 1# xs ys ≡ one _ + (xs + ys)
  extract-carry []        []                                            = refl
  extract-carry (0# ∷ xs) (0# ∷ ys) rewrite +-identityˡ (xs + ys)       = refl
  extract-carry (0# ∷ xs) (1# ∷ ys) rewrite add-carry 1# 0# (zero _) xs ys
                                          | +-identityˡ (add′ 1# xs ys) = refl
  extract-carry (1# ∷ xs) (0# ∷ ys) rewrite add-carry 1# 0# (zero _) xs ys
                                          | +-identityˡ (add′ 1# xs ys) = refl
  extract-carry (1# ∷ xs) (1# ∷ ys) rewrite +-identityˡ (add′ 1# xs ys) = refl

  shift-to-add : ∀ c {n} (x : BitVector n) → c +2* x ≡ add′ c x x
  shift-to-add _ []                                   = refl
  shift-to-add c (0# ∷ xs) rewrite shift-to-add 0# xs = refl
  shift-to-add c (1# ∷ xs) rewrite shift-to-add 1# xs = refl

  *-distribʳ : ∀ {n} → (_*_ {n}) DistributesOverʳ _+_
  *-distribʳ          [] [] [] = refl
  *-distribʳ {Nsuc n} xs ys zs = *-distribʳ1 xs ys zs

    where
    lemma : ∀ {n} c (xs ys zs : BitVector n)
          → add′ 1# ys zs * c +2* xs
          ≡ add′ c (xs + (ys * c +2* xs)) (xs + (zs * c +2* xs))
    lemma c xs ys zs rewrite
         extract-carry ys zs
       | *-distribʳ (c +2* xs) (one _) (ys + zs)
       | *-identityˡ (c +2* xs)
       | *-distribʳ (c +2* xs) ys zs
       | shift-to-add c xs
       | *-comm ys (add′ c xs xs)
       | *-comm zs (add′ c xs xs)
       | +-comm (add′ c xs xs) (add′ c xs xs * ys + add′ c xs xs * zs)
       | add-carry 0# c (add′ c xs xs * ys + add′ c xs xs * zs) xs xs
       | add-assoc c 0# (add′ c xs xs * ys) (add′ c xs xs * zs) (xs + xs)
       | sym (+-assoc (add′ c xs xs * zs) xs xs)
       | +-comm (add′ c xs xs * zs) xs
       | +-comm (xs + add′ c xs xs * zs) xs
       | sym (add-assoc c 0# (add′ c xs xs * ys) xs (xs + add′ c xs xs * zs))
       | +-comm  (add′ c xs xs * ys) xs
       = refl

    *-distribʳ1 : ∀ {n} → (_*_ {Nsuc n}) DistributesOverʳ _+_
    *-distribʳ1 xs (0# ∷ ys) (0# ∷ zs) rewrite *-distribʳ (droplast xs) ys zs = refl
    *-distribʳ1 (0# ∷ xs) (0# ∷ ys) (1# ∷ zs)
             rewrite *-distribʳ (2* xs) ys zs
                   | sym (+-assoc xs (ys * 2* xs) (zs * 2* xs))
                   | +-comm xs (ys * 2* xs)
                   | +-assoc (ys * 2* xs) xs (zs * 2* xs) = refl
    *-distribʳ1 (1# ∷ xs) (0# ∷ ys) (1# ∷ zs)
             rewrite *-distribʳ (1+2* xs) ys zs
                   | sym (+-assoc xs (ys * 1+2* xs) (zs * 1+2* xs))
                   | +-comm xs (ys * 1+2* xs)
                   | +-assoc (ys * 1+2* xs) xs (zs * 1+2* xs) = refl
    *-distribʳ1 (0# ∷ xs) (1# ∷ ys) (0# ∷ zs)
             rewrite *-distribʳ (2* xs) ys zs
                   | +-assoc xs (ys * 2* xs) (zs * 2* xs) = refl
    *-distribʳ1 (1# ∷ xs) (1# ∷ ys) (0# ∷ zs)
             rewrite *-distribʳ (1+2* xs) ys zs
                   | +-assoc xs (ys * 1+2* xs) (zs * 1+2* xs) = refl
    *-distribʳ1 (0# ∷ xs) (1# ∷ ys) (1# ∷ zs) rewrite lemma 0# xs ys zs = refl
    *-distribʳ1 (1# ∷ xs) (1# ∷ ys) (1# ∷ zs) rewrite lemma 1# xs ys zs = refl

  *-assoc : ∀ {n} → Associative {n} _*_
  *-assoc          [] [] [] = refl
  *-assoc {Nsuc n} x  y  z  = *-assoc1 x y z

   where
   *-assoc1 : ∀ {n} → Associative {Nsuc n} _*_
   *-assoc1 (0# ∷ xs) ys zs rewrite *-assoc xs (droplast ys) (droplast zs)
                                  | droplast-distrib-* ys zs = refl
   *-assoc1 (1# ∷ xs) ys zs rewrite *-distribʳ zs ys (0# ∷ xs * droplast ys)
                                  | *-assoc xs (droplast ys) (droplast zs)
                                  | droplast-distrib-* ys zs = refl

  *-identityʳ : ∀ {n} → RightIdentity (one n) _*_
  *-identityʳ x rewrite *-comm x (one _) = *-identityˡ x

  *-distribˡ : ∀ {n} → (_*_ {n}) DistributesOverˡ _+_
  *-distribˡ x y z rewrite *-comm x (y + z)
                         | *-distribʳ x y z
                         | *-comm x y
                         | *-comm x z = refl

  module Properties (n : ℕ) where
    open import Algebra.Structures

    +-isSemigroup : IsSemigroup {A = BitVector n} _≡_ _+_
    +-isSemigroup = record
       { isEquivalence = isEquivalence; assoc = +-assoc; ∙-cong = cong₂ _+_ }

    +-isMonoid : IsMonoid _≡_ _+_ (zero n)
    +-isMonoid = record
       { isSemigroup = +-isSemigroup; identity = +-identityˡ , +-identityʳ }

    +-isGroup : IsGroup _≡_ _+_ (zero n) -_
    +-isGroup = record
       { isMonoid = +-isMonoid; inverse = inverseˡ , inverseʳ; ⁻¹-cong = cong -_ }

    +-isAbelianGroup : IsAbelianGroup _≡_ _+_ (zero n) -_
    +-isAbelianGroup = record { isGroup = +-isGroup; comm = +-comm }

    *-isSemigroup : IsSemigroup {A = BitVector n} _≡_ _*_
    *-isSemigroup = record
       { isEquivalence = isEquivalence; assoc = *-assoc; ∙-cong = cong₂ _*_ }

    *-isMonoid : IsMonoid _≡_ _*_ (one n)
    *-isMonoid = record
       { isSemigroup = *-isSemigroup; identity = *-identityˡ , *-identityʳ }

    isRing : IsRing _≡_ _+_ _*_ -_ (zero n) (one n)
    isRing = record { +-isAbelianGroup = +-isAbelianGroup;
                      *-isMonoid = *-isMonoid;
                      distrib = *-distribˡ , *-distribʳ }

    isCommutativeRing : IsCommutativeRing _≡_ _+_ _*_ -_ (zero n) (one n)
    isCommutativeRing = record { isRing = isRing; *-comm = *-comm }

commutativeRing : ∀ n → CommutativeRing _ _
commutativeRing n = record
  { Carrier = BitVector n;
    _≈_ = _≡_; _+_ = _+_; _*_ = _*_; -_ = -_;
    0# = zero n; 1# = one n;
    isCommutativeRing = Properties.isCommutativeRing n }


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

module Cubical.Structures.Ring where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.HLevels
open import Cubical.Data.Sigma

open import Cubical.Foundations.SIP renaming (SNS-PathP to SNS)

open import Cubical.Structures.NAryOp
open import Cubical.Structures.Monoid hiding (⟨_⟩)
open import Cubical.Structures.AbGroup hiding (⟨_⟩)
open import Cubical.Structures.Pointed

private
  variable
    ℓ ℓ' : Level

raw-ring-structure : Type ℓ → Type ℓ
raw-ring-structure X = (X → X → X) × X × (X → X → X)

-- Maybe this is not the best way? (Suggestions welcome, maybe having raw-monoid-iso defined?)
raw-ring-is-SNS : SNS {ℓ} raw-ring-structure _
raw-ring-is-SNS = join-SNS (nAryFunIso 2) (nAryFunSNS 2)
                           (join-iso pointed-iso (nAryFunIso 2))
                           (join-SNS pointed-iso pointed-is-SNS (nAryFunIso 2) (nAryFunSNS 2))

ring-axioms : (X : Type ℓ) (s : raw-ring-structure X) → Type ℓ
ring-axioms X (_+_ , ₁ , _·_) = abelian-group-axioms X _+_ ×
                                monoid-axioms X (₁ , _·_) ×
                                ((x y z : X) → x · (y + z) ≡ (x · y) + (x · z)) ×
                                ((x y z : X) → (x + y) · z ≡ (x · z) + (y · z))

ring-structure : Type ℓ → Type ℓ
ring-structure = add-to-structure raw-ring-structure ring-axioms

Ring : Type (ℓ-suc ℓ)
Ring {ℓ} = TypeWithStr ℓ ring-structure

ring-iso : StrIso ring-structure ℓ
ring-iso = add-to-iso (join-iso (nAryFunIso 2) (join-iso pointed-iso (nAryFunIso 2))) ring-axioms

ring-axioms-isProp : (X : Type ℓ) (s : raw-ring-structure X) → isProp (ring-axioms X s)
ring-axioms-isProp X (_+_ , ₁ , _·_) = isPropΣ (abelian-group-axioms-isProp X _+_)
                                      λ _ → isPropΣ (monoid-axioms-are-Props X (₁ , _·_))
                                      λ { (isSetX , _) → isPropΣ (isPropΠ3 (λ _ _ _ → isSetX _ _))
                                      λ _ → isPropΠ3 (λ _ _ _ → isSetX _ _)}

ring-is-SNS : SNS {ℓ} ring-structure ring-iso
ring-is-SNS = add-axioms-SNS _ ring-axioms-isProp raw-ring-is-SNS

RingPath : (M N : Ring {ℓ}) → (M ≃[ ring-iso ] N) ≃ (M ≡ N)
RingPath = SIP ring-is-SNS

-- Rings have an abelian group

Ring→AbGroup : Ring {ℓ} → AbGroup {ℓ}
Ring→AbGroup (R , (_+_ , _) , +AbGroup , _) = R , _+_ , +AbGroup

-- Rings have a monoid

Ring→Monoid : Ring {ℓ} → Monoid {ℓ}
Ring→Monoid (R , (_ , ₁ , _·_) , _ , ·Monoid , _) = R , (₁ , _·_) , ·Monoid

-- Ring extractors

⟨_⟩ : Ring {ℓ} → Type ℓ
⟨ R , _ ⟩ = R

module _ (R : Ring {ℓ}) where
  ring+-operation = abgroup-operation (Ring→AbGroup R)

  ring-is-set = abgroup-is-set (Ring→AbGroup R)

  ring+-assoc = abgroup-assoc (Ring→AbGroup R)

  ring+-id = abgroup-id (Ring→AbGroup R)

  ring+-rid = abgroup-rid (Ring→AbGroup R)

  ring+-lid = abgroup-lid (Ring→AbGroup R)

  ring+-inv = abgroup-inv (Ring→AbGroup R)

  ring+-rinv = abgroup-rinv (Ring→AbGroup R)

  ring+-linv = abgroup-linv (Ring→AbGroup R)

  ring+-comm = abgroup-comm (Ring→AbGroup R)

  ring·-operation = monoid-operation (Ring→Monoid R)

  ring·-assoc = monoid-assoc (Ring→Monoid R)

  ring·-id = monoid-id (Ring→Monoid R)

  ring·-rid = monoid-rid (Ring→Monoid R)

  ring·-lid = monoid-lid (Ring→Monoid R)

module ring-syntax where

  ring+-operation-syntax : (R : Ring {ℓ}) → ⟨ R ⟩ → ⟨ R ⟩ → ⟨ R ⟩
  ring+-operation-syntax R = ring+-operation R

  infixr 14 ring+-operation-syntax
  syntax ring+-operation-syntax R x y = x +⟨ R ⟩ y

  ring·-operation-syntax : (R : Ring {ℓ}) → ⟨ R ⟩ → ⟨ R ⟩ → ⟨ R ⟩
  ring·-operation-syntax R = ring·-operation R

  infixr 18 ring·-operation-syntax
  syntax ring·-operation-syntax R x y = x ·⟨ R ⟩ y

open ring-syntax

ring-rdist : (R : Ring {ℓ}) (x y z : ⟨ R ⟩) → x ·⟨ R ⟩ (y +⟨ R ⟩ z) ≡ (x ·⟨ R ⟩ y) +⟨ R ⟩ (x ·⟨ R ⟩ z)
ring-rdist (_ , _ , _ , _ , P , _) = P

ring-ldist : (R : Ring {ℓ}) (x y z : ⟨ R ⟩) → (x +⟨ R ⟩ y) ·⟨ R ⟩ z ≡ (x ·⟨ R ⟩ z) +⟨ R ⟩ (y ·⟨ R ⟩ z)
ring-ldist (_ , _ , _ , _ , _ , P) = P

-- Ring ·syntax

module ring-·syntax (R : Ring {ℓ}) where

  infixr 14 _+_
  infixr 18 _·_
  infix  15 -_

  _+_ = ring+-operation R

  _·_ = ring·-operation R

  ₀ = ring+-id R

  ₁ = ring·-id R

  -_ = ring+-inv R


{-# OPTIONS --no-syntactic-equality #-}

open import Agda.Primitive

variable
  ℓ : Level
  A : Set ℓ
  P : A → Set ℓ


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

open import lib.Basics
open import lib.NType2
open import lib.types.Empty
open import lib.types.Group
open import lib.types.LoopSpace
open import lib.types.Nat
open import lib.types.Pi
open import lib.types.Pointed
open import lib.types.Sigma
open import lib.types.TLevel
open import lib.types.Truncation
open import lib.groups.GroupProduct
open import lib.groups.Homomorphism
open import lib.groups.Isomorphism
open import lib.groups.LoopSpace
open import lib.groups.TruncationGroup
open import lib.groups.Unit

module lib.groups.HomotopyGroup where

{- Higher homotopy groups -}
module _ {i} where

  πS : (n : ℕ) (X : Ptd i) → Group i
  πS n X = Trunc-group (Ω^S-group-structure n X)

  π'S : (n : ℕ) (X : Ptd i) → Group i
  π'S n X = Trunc-group (Ω^'S-group-structure n X)

  fundamental-group : (X : Ptd i) → Group i
  fundamental-group X = πS 0 X

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

  πS-fmap : X ⊙→ Y → (πS n X →ᴳ πS n Y)
  πS-fmap F = Trunc-group-fmap (Ω^S-group-structure-fmap n F)

  π'S-fmap : X ⊙→ Y → (π'S n X →ᴳ π'S n Y)
  π'S-fmap F = Trunc-group-fmap (Ω^'S-group-structure-fmap n F)

  πS-emap : (X ⊙≃ Y) → (πS n X ≃ᴳ πS n Y)
  πS-emap e = Trunc-group-emap (Ω^S-group-structure-emap n e)

  π'S-emap : (X ⊙≃ Y) → (π'S n X ≃ᴳ π'S n Y)
  π'S-emap e = Trunc-group-emap (Ω^'S-group-structure-emap n e)

{- π_(n+1) of a space is π_n of its loop space -}
abstract
  πS-Ω-split-iso : ∀ {i} (n : ℕ) (X : Ptd i)
    → πS (S n) X ≃ᴳ πS n (⊙Ω X)
  πS-Ω-split-iso n X =
    group-hom
      (Trunc-fmap (Ω^-Ω-split (S n) X))
      (Trunc-elim
        (λ p → Trunc-elim
          (λ q → ap [_] (Ω^S-Ω-split-∙ n X p q)))) ,
    Trunc-isemap {n = 0} (Ω^-Ω-split-is-equiv (S n) X)

{- We can shift the truncation inside the loop in the definition of π -}
module _ {i} where

  private
    record Ω^STruncPreIso (n : ℕ) (m : ℕ₋₂) (k : ℕ₋₂) (X : Ptd i)
      : Type i where
      field
        F : ⊙Ω^ (S n) (⊙Trunc k X) ⊙→ ⊙Trunc m (⊙Ω^ (S n) X)
        pres-comp : ∀ (p q : Ω^ (S n) (⊙Trunc k X))
          → fst F (Ω^S-∙ n p q) == Trunc-fmap2 (Ω^S-∙ n) (fst F p) (fst F q)
        e : is-equiv (fst F)

    Ω^S-Trunc-preiso : (n : ℕ) (m : ℕ₋₂) (X : Ptd i)
      → Ω^STruncPreIso n m (⟨ S n ⟩₋₂ +2+ m) X
    Ω^S-Trunc-preiso O m X =
      record { F = (–> (Trunc=-equiv [ pt X ] [ pt X ]) , idp);
               pres-comp = Trunc=-∙-comm;
               e = snd (Trunc=-equiv [ pt X ] [ pt X ]) }
    Ω^S-Trunc-preiso (S n) m X =
      let
        r : Ω^STruncPreIso n (S m) (⟨ S n ⟩₋₂ +2+ S m) X
        r = Ω^S-Trunc-preiso n (S m) X

        H = (–> (Trunc=-equiv [ idp^ (S n) ] [ idp^ (S n) ]) , idp)
        G = ⊙Ω-fmap (Ω^STruncPreIso.F r)
      in
      transport (λ k → Ω^STruncPreIso (S n) m k X)
        (+2+-βr ⟨ S n ⟩₋₂ m)
        (record {
           F = H ⊙∘ G;
           pres-comp = λ p q →
             ap (fst H) (Ω^S-fmap-∙ 0 (Ω^STruncPreIso.F r) p q)
             ∙ (Trunc=-∙-comm (fst G p) (fst G q));
           e = snd (Trunc=-equiv [ idp^ (S n) ] [ idp^ (S n) ]
                    ∘e Ω^-emap 1 (Ω^STruncPreIso.F r , Ω^STruncPreIso.e r))})

  Ω^S-group-Trunc-fuse-diag-iso : (n : ℕ) (X : Ptd i)
    → Ω^S-group n (⊙Trunc ⟨ S n ⟩ X) ≃ᴳ πS n X
  Ω^S-group-Trunc-fuse-diag-iso n X = group-hom (fst F) pres-comp , e
    where
    r = transport (λ k → Ω^STruncPreIso n 0 k X)
                  (+2+0 ⟨ S n ⟩₋₂) (Ω^S-Trunc-preiso n 0 X)
    open Ω^STruncPreIso r

{- favonia: the same lemma for the alternative homotopy groups is trivial. -}

  Ω^'S-group-Trunc-fuse-diag-iso : (n : ℕ) (X : Ptd i)
    → Ω^'S-group n (⊙Trunc ⟨ S n ⟩ X) ≃ᴳ π'S n X
  Ω^'S-group-Trunc-fuse-diag-iso O X =
    ≃-to-≃ᴳ (Trunc=-equiv [ pt X ] [ pt X ]) Trunc=-∙-comm
  Ω^'S-group-Trunc-fuse-diag-iso (S n) X =
        Ω^'S-group-Trunc-fuse-diag-iso n (⊙Ω X)
    ∘eᴳ Ω^'S-group-emap n {X = ⊙Ω (⊙Trunc ⟨ S (S n) ⟩ X)} (≃-to-⊙≃ (Trunc=-equiv [ pt X ] [ pt X ]) idp)

abstract
  πS-Trunc-fuse-≤-iso : ∀ {i} (n : ℕ) (m : ℕ₋₂) (X : Ptd i)
    → (⟨ S n ⟩ ≤T m) → πS n (⊙Trunc m X) ≃ᴳ πS n X
  πS-Trunc-fuse-≤-iso n m X Sn≤m =
    πS n (⊙Trunc m X)
      ≃ᴳ⟨ Ω^S-group-Trunc-fuse-diag-iso n (⊙Trunc m X) ⁻¹ᴳ ⟩
    Ω^S-group n (⊙Trunc ⟨ S n ⟩ (⊙Trunc m X))
      ≃ᴳ⟨ Ω^S-group-emap n (≃-to-⊙≃ (Trunc-fuse-≤ (de⊙ X) Sn≤m) idp) ⟩
    Ω^S-group n (⊙Trunc ⟨ S n ⟩ X)
      ≃ᴳ⟨ Ω^S-group-Trunc-fuse-diag-iso n X ⟩
    πS n X
      ≃ᴳ∎

  π'S-Trunc-fuse-≤-iso : ∀ {i} (n : ℕ) (m : ℕ₋₂) (X : Ptd i)
    → (⟨ S n ⟩ ≤T m) → π'S n (⊙Trunc m X) ≃ᴳ π'S n X
  π'S-Trunc-fuse-≤-iso n m X Sn≤m =
    π'S n (⊙Trunc m X)
      ≃ᴳ⟨ Ω^'S-group-Trunc-fuse-diag-iso n (⊙Trunc m X) ⁻¹ᴳ ⟩
    Ω^'S-group n (⊙Trunc ⟨ S n ⟩ (⊙Trunc m X))
      ≃ᴳ⟨ Ω^'S-group-emap n (≃-to-⊙≃ (Trunc-fuse-≤ (de⊙ X) Sn≤m) idp) ⟩
    Ω^'S-group n (⊙Trunc ⟨ S n ⟩ X)
      ≃ᴳ⟨ Ω^'S-group-Trunc-fuse-diag-iso n X ⟩
    π'S n X
      ≃ᴳ∎

  πS-Trunc-fuse->-iso : ∀ {i} (n : ℕ) (m : ℕ₋₂) (X : Ptd i)
    → (m <T ⟨ S n ⟩) → πS n (⊙Trunc m X) ≃ᴳ 0ᴳ
  πS-Trunc-fuse->-iso n m X m<n =
    πS n (⊙Trunc m X)
      ≃ᴳ⟨ Ω^S-group-Trunc-fuse-diag-iso n (⊙Trunc m X) ⁻¹ᴳ ⟩
    Ω^S-group n (⊙Trunc ⟨ S n ⟩ (⊙Trunc m X))
      ≃ᴳ⟨ contr-iso-0ᴳ _ $ inhab-prop-is-contr
           (Group.ident (Ω^S-group n (⊙Trunc ⟨ S n ⟩ (⊙Trunc m X))))
           {{Ω^-level -1 (S n) _ $ Trunc-preserves-level ⟨ S n ⟩ $
             raise-level-≤T
               (transport (λ k → m ≤T k) (+2+-comm -1 ⟨ S n ⟩₋₂) (<T-to-≤T m<n))
               (Trunc-level {n = m})}} ⟩
    0ᴳ ≃ᴳ∎

  π'S-Trunc-fuse->-iso : ∀ {i} (n : ℕ) (m : ℕ₋₂) (X : Ptd i)
    → (m <T ⟨ S n ⟩) → π'S n (⊙Trunc m X) ≃ᴳ 0ᴳ
  π'S-Trunc-fuse->-iso n m X m<n =
    π'S n (⊙Trunc m X)
      ≃ᴳ⟨ Ω^'S-group-Trunc-fuse-diag-iso n (⊙Trunc m X) ⁻¹ᴳ ⟩
    Ω^'S-group n (⊙Trunc ⟨ S n ⟩ (⊙Trunc m X))
      ≃ᴳ⟨ contr-iso-0ᴳ _ $ inhab-prop-is-contr
           (Group.ident (Ω^'S-group n (⊙Trunc ⟨ S n ⟩ (⊙Trunc m X))))
           {{Ω^'-is-prop (S n) _ $ Trunc-preserves-level ⟨ S n ⟩ $
             raise-level-≤T (<T-to-≤T m<n) (Trunc-level {n = m})}} ⟩
    0ᴳ ≃ᴳ∎

  -- XXX Naming conventions?
  πS->level-econv : ∀ {i} (n : ℕ) (m : ℕ₋₂) (X : Ptd i)
    → (m <T ⟨ S n ⟩) → {{_ : has-level m (de⊙ X)}}
    → πS n X ≃ᴳ 0ᴳ
  πS->level-econv n m X lt =
    πS n X
      ≃ᴳ⟨ πS-emap n (⊙unTrunc-equiv X ⊙⁻¹) ⟩
    πS n (⊙Trunc m X)
      ≃ᴳ⟨ πS-Trunc-fuse->-iso n m X lt ⟩
    0ᴳ
      ≃ᴳ∎

  π'S->level-econv : ∀ {i} (n : ℕ) (m : ℕ₋₂) (X : Ptd i)
    → (m <T ⟨ S n ⟩) → {{_ : has-level m (de⊙ X)}}
    → π'S n X ≃ᴳ 0ᴳ
  π'S->level-econv n m X lt =
    π'S n X
      ≃ᴳ⟨ π'S-emap n (⊙unTrunc-equiv X ⊙⁻¹) ⟩
    π'S n (⊙Trunc m X)
      ≃ᴳ⟨ π'S-Trunc-fuse->-iso n m X lt ⟩
    0ᴳ
      ≃ᴳ∎

{- πₙ(X × Y) == πₙ(X) × πₙ(Y) -}
module _ {i j} (n : ℕ) (X : Ptd i) (Y : Ptd  j) where

  πS-× : πS n (X ⊙× Y) ≃ᴳ πS n X ×ᴳ πS n Y
  πS-× = Trunc-group-× _ _ ∘eᴳ Trunc-group-emap (Ω^S-group-structure-× n X Y)

  π'S-× : π'S n (X ⊙× Y) ≃ᴳ π'S n X ×ᴳ π'S n Y
  π'S-× = Trunc-group-× _ _ ∘eᴳ Trunc-group-emap (Ω^'S-group-structure-× n X Y)


open import Agda.Primitive

variable
  A : Set _

levelOf : A → Level
levelOf {a} _ = a


-- Jesper, 2019-09-12: The fix of #3541 introduced a regression: the
-- index of the equality type is treated as a positive argument.

data _≡_ (A : Set) : Set → Set where
  refl : A ≡ A

postulate X : Set

data D : Set where
  c : X ≡ D → D


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

open import lib.Basics
open import lib.types.Paths

module lib.types.Unit where

pattern tt = unit

⊙Unit : Ptd₀
⊙Unit = ⊙[ Unit , unit ]

-- Unit is contractible
instance
  Unit-level : {n : ℕ₋₂} → has-level n Unit
  Unit-level {n = ⟨-2⟩} = has-level-in (unit , λ y → idp)
  Unit-level {n = S n} = raise-level n Unit-level


open import Nat
open import Prelude
open import dynamics-core
open import contexts
open import typed-elaboration
open import lemmas-gcomplete
open import lemmas-complete
open import progress-checks
open import finality

module cast-inert where
  -- if a term is compelete and well typed, then the casts inside are all
  -- identity casts and there are no failed casts
  cast-inert : ∀{Δ Γ d τ} →
               d dcomplete →
               Δ , Γ ⊢ d :: τ →
               cast-id d
  cast-inert dc TANum = CINum
  cast-inert (DCPlus dc dc₁) (TAPlus wt wt₁) = CIPlus (cast-inert dc wt) (cast-inert dc₁ wt₁)
  cast-inert dc (TAVar x₁) = CIVar
  cast-inert (DCLam dc x₁) (TALam x₂ wt) = CILam (cast-inert dc wt)
  cast-inert (DCAp dc dc₁) (TAAp wt wt₁) = CIAp (cast-inert dc wt) (cast-inert dc₁ wt₁)
  cast-inert (DCInl x dc) (TAInl wt) = CIInl (cast-inert dc wt)
  cast-inert (DCInr x dc) (TAInr wt) = CIInr (cast-inert dc wt)
  cast-inert (DCCase dc dc₁ dc₂) (TACase wt x wt₁ x₁ wt₂) =
    CICase (cast-inert dc wt) (cast-inert dc₁ wt₁) (cast-inert dc₂ wt₂)
  cast-inert (DCPair dc dc₁) (TAPair wt wt₁) = CIPair (cast-inert dc wt) (cast-inert dc₁ wt₁)
  cast-inert (DCFst dc) (TAFst wt) = CIFst (cast-inert dc wt)
  cast-inert (DCSnd dc) (TASnd wt) = CISnd (cast-inert dc wt)
  cast-inert () (TAEHole x x₁)
  cast-inert () (TANEHole x wt x₁)
  cast-inert (DCCast dc x x₁) (TACast wt x₂)
    with complete-consistency x₂ x x₁
  ... | refl = CICast (cast-inert dc wt)
  cast-inert () (TAFailedCast wt x x₁ x₂)

  -- in a well typed complete internal expression, every cast is the
  -- identity cast.
  complete-casts : ∀{Γ Δ d τ1 τ2} →
                   Γ , Δ ⊢ d ⟨ τ1 ⇒ τ2 ⟩ :: τ2 →
                   d ⟨ τ1 ⇒ τ2 ⟩ dcomplete →
                   τ1 == τ2
  complete-casts wt comp with cast-inert comp wt
  complete-casts wt comp | CICast qq = refl

  -- relates expressions to the same thing with all identity casts
  -- removed. note that this is a syntactic rewrite and it goes under
  -- binders.
  data no-id-casts : ihexp → ihexp → Set where
    NICNum    : ∀{n} →
                no-id-casts (N n) (N n)
    NICPlus   : ∀{d1 d2 d1' d2'} →
                no-id-casts d1 d1' →
                no-id-casts d2 d2' →
                no-id-casts (d1 ·+ d2) (d1' ·+ d2')
    NICVar    : ∀{x} →
                no-id-casts (X x) (X x)
    NICLam    : ∀{x τ d d'} →
                no-id-casts d d' →
                no-id-casts (·λ x ·[ τ ] d) (·λ x ·[ τ ] d')
    NICAp     : ∀{d1 d2 d1' d2'} →
                no-id-casts d1 d1' →
                no-id-casts d2 d2' →
                no-id-casts (d1 ∘ d2) (d1' ∘ d2')
    NICInl    : ∀{d τ d'} →
                no-id-casts d d' →
                no-id-casts (inl τ d) (inl τ d')
    NICInr    : ∀{d τ d'} →
                no-id-casts d d' →
                no-id-casts (inr τ d) (inr τ d')
    NICCase   : ∀{d x d1 y d2 d' d1' d2'} →
                no-id-casts d d' →
                no-id-casts d1 d1' →
                no-id-casts d2 d2' →
                no-id-casts (case d x d1 y d2) (case d' x d1' y d2')
    NICPair   : ∀{d1 d2 d1' d2'} →
                no-id-casts d1 d1' →
                no-id-casts d2 d2' →
                no-id-casts ⟨ d1 , d2 ⟩ ⟨ d1' , d2' ⟩
    NICFst    : ∀{d d'} →
                no-id-casts d d' →
                no-id-casts (fst d) (fst d')
    NICSnd    : ∀{d d'} →
                no-id-casts d d' →
                no-id-casts (snd d) (snd d')
    NICHole   : ∀{u} →
                no-id-casts (⦇-⦈⟨ u ⟩) (⦇-⦈⟨ u ⟩)
    NICNEHole : ∀{d d' u} →
                no-id-casts d d' →
                no-id-casts (⦇⌜ d ⌟⦈⟨ u ⟩) (⦇⌜ d' ⌟⦈⟨ u ⟩)
    NICCast   : ∀{d d' τ} →
                no-id-casts d d' →
                no-id-casts (d ⟨ τ ⇒ τ ⟩) d'
    NICFailed : ∀{d d' τ1 τ2} →
                no-id-casts d d' →
                no-id-casts (d ⟨ τ1 ⇒⦇-⦈⇏ τ2 ⟩) (d' ⟨ τ1 ⇒⦇-⦈⇏ τ2 ⟩)

  -- removing identity casts doesn't change the type
  no-id-casts-type : ∀{Γ Δ d τ d' } → Δ , Γ ⊢ d :: τ →
                                      no-id-casts d d' →
                                      Δ , Γ ⊢ d' :: τ
  no-id-casts-type TANum NICNum = TANum
  no-id-casts-type (TAPlus wt wt₁) (NICPlus nic nic₁) = TAPlus (no-id-casts-type wt nic) (no-id-casts-type wt₁ nic₁)
  no-id-casts-type (TAVar x₁) NICVar = TAVar x₁
  no-id-casts-type (TALam x₁ wt) (NICLam nic) = TALam x₁ (no-id-casts-type wt nic)
  no-id-casts-type (TAAp wt wt₁) (NICAp nic nic₁) = TAAp (no-id-casts-type wt nic) (no-id-casts-type wt₁ nic₁)
  no-id-casts-type (TAInl wt) (NICInl nic) = TAInl (no-id-casts-type wt nic)
  no-id-casts-type (TAInr wt) (NICInr nic) = TAInr (no-id-casts-type wt nic)
  no-id-casts-type (TACase wt x wt₁ x₁ wt₂) (NICCase nic nic₁ nic₂) = TACase (no-id-casts-type wt nic) x (no-id-casts-type wt₁ nic₁) x₁ (no-id-casts-type wt₂ nic₂)
  no-id-casts-type (TAPair wt wt₁) (NICPair nic nic₁) = TAPair (no-id-casts-type wt nic) (no-id-casts-type wt₁ nic₁)
  no-id-casts-type (TAFst wt) (NICFst nic) = TAFst (no-id-casts-type wt nic)
  no-id-casts-type (TASnd wt) (NICSnd nic) = TASnd (no-id-casts-type wt nic)
  no-id-casts-type (TAEHole x x₁) NICHole = TAEHole x x₁
  no-id-casts-type (TANEHole x wt x₁) (NICNEHole nic) = TANEHole x (no-id-casts-type wt nic) x₁
  no-id-casts-type (TACast wt x) (NICCast nic) = no-id-casts-type wt nic
  no-id-casts-type (TAFailedCast wt x x₁ x₂) (NICFailed nic) = TAFailedCast (no-id-casts-type wt nic) x x₁ x₂


{-# OPTIONS --cubical #-}

module Properties where

open import Data.Fin renaming (zero to Fzero; suc to Fsuc) hiding (_+_; _≟_)
open import Data.Nat
open import Data.Nat.DivMod using (_mod_; _div_; m≡m%n+[m/n]*n)
open import Data.Nat.Properties using (+-comm)
open import Data.Product
open import Function using (_∘_)
open import Relation.Binary.PropositionalEquality
open import Relation.Nullary.Decidable using (False)
open ≡-Reasoning

open import Pitch

RelAbs : (n : Pitch) → (relativeToAbsolute ∘ absoluteToRelative) n ≡ n
RelAbs (pitch zero) = refl
RelAbs (pitch (suc n)) =
  begin
    (relativeToAbsolute ∘ absoluteToRelative) (pitch (suc n))
  ≡⟨ refl ⟩
    relativeToAbsolute (pitchClass ((suc n) mod chromaticScaleSize) ,
                        octave ((suc n) div chromaticScaleSize))
  ≡⟨ refl ⟩
    pitch (((suc n) div chromaticScaleSize) * chromaticScaleSize +
           (toℕ ((suc n) mod chromaticScaleSize)))
  ≡⟨ cong pitch
          (+-comm (((suc n) div chromaticScaleSize) * chromaticScaleSize)
                  (toℕ ((suc n) mod chromaticScaleSize))) ⟩
    pitch ((toℕ ((suc n) mod chromaticScaleSize)) +
           (((suc n) div chromaticScaleSize) * chromaticScaleSize))
  ≡⟨ cong pitch (sym {!!}) ⟩
  -- ≡⟨ cong pitch (sym (m≡m%n+[m/n]*n n chromaticScaleSize)) ⟩
    pitch (suc n)
  ∎

{-
absRelAbs (pitch (+_     zero))    = refl
absRelAbs (pitch (+_     (suc n))) = let x = absRelAbs (pitch (+ n)) in {!!}
absRelAbs (pitch (-[1+_] zero))    = refl
absRelAbs (pitch (-[1+_] (suc n))) = {!!}
-}

AbsRel : (n : PitchOctave) → (absoluteToRelative ∘ relativeToAbsolute) n ≡ n
AbsRel (pitchClass p , octave o) =
  begin
    (absoluteToRelative ∘ relativeToAbsolute) (pitchClass p , octave o)
  ≡⟨ refl ⟩
    absoluteToRelative (pitch (o * chromaticScaleSize + (toℕ p)))
  ≡⟨ refl ⟩
    (pitchClass ((o * chromaticScaleSize + (toℕ p)) mod chromaticScaleSize) ,
                 octave ((o * chromaticScaleSize + (toℕ p)) div chromaticScaleSize))
  ≡⟨ {!!} ⟩
    (pitchClass p , octave o)
  ∎

{-
relAbsRel (relativePitch zero    , octave (+_     zero))    = refl
relAbsRel (relativePitch zero    , octave (+_     (suc n))) = {!!}
relAbsRel (relativePitch zero    , octave (-[1+_] zero))    = refl
relAbsRel (relativePitch zero    , octave (-[1+_] (suc n))) = {!!}
relAbsRel (relativePitch (suc n) , octave (+_     zero))    = {!!}
relAbsRel (relativePitch (suc n) , octave (+_     (suc o))) = {!!}
relAbsRel (relativePitch (suc n) , octave (-[1+_] zero))    = {!!}
relAbsRel (relativePitch (suc n) , octave (-[1+_] (suc o))) = {!!}
-}


module Issue49 where

module Dummy {A : Set1} where
  postulate D : Set

T : Set
T = Dummy.D {Set}

T' : Set
T' = Dummy.D {A = Set}


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

open import Base
open import Homotopy.PushoutDef
open import Homotopy.PushoutUP as PushoutUP
open import Homotopy.Truncation
open import Homotopy.PullbackDef
open import Homotopy.PullbackInvariantEquiv

module Homotopy.TruncationRightExact {i} (n : ℕ₋₂) (d : pushout-diag i) where

open pushout-diag d
open import Homotopy.PushoutIsPushout d

τd : pushout-diag i
τd = diag (τ n A), (τ n B), (τ n C), (τ-fmap f), (τ-fmap g)

module H  = PushoutUP d  (cst unit)
module τH = PushoutUP τd (is-truncated n)

-- I want to prove that [τ n d.pushout] is a pushout in [is-truncated n]. It
-- first needs to be equipped with a cocone

cocone-τpushout : τH.cocone (τ n (pushout d))
cocone-τpushout = (τ-fmap left , τ-fmap right ,
                     τ-extend ⦃ λ _ → ≡-is-truncated _ (τ-is-truncated _ _) ⦄
                       (ap proj ◯ glue))

-- We have a map [(τ n (pushout d) → E) → τH.cocone E] with [E] in [P] given by
-- [τH.compose-cocone-map] and we want to prove that it’s an equivalence

-- The idea is that it’s the composite of five equivalences:

-- [equiv1 : τ n (pushout d) → E ≃ (pushout d) → E]
--    by the universal property of truncations
-- [equiv2 : (pushout d) → E ≃ H.cocone E]
--    by the universal property of pushout in Type
-- [equiv3 : H.cocone E ≃ pullback … (without truncations)]
--    via [cocone-is-pullback]
-- [equiv4 : pullback … (without truncations) ≃ pullback … (with truncations)]
--    by the universal property of truncations and invariance of pullback wrt
--    equivalence of diagrams
-- [equiv5 : pullback … (with truncations) ≃ τH.cocone E]
--    via [cocone-is-pullback]

module _ (E : Set i) ⦃ P-E : is-truncated n E ⦄ where

  private
    ≡E-is-truncated#instance : {x y : E} → is-truncated n (x ≡ y)
    ≡E-is-truncated#instance = ≡-is-truncated n P-E

    λ-≡E-is-truncated#instance : {A : Set i} {u v : A → E}
      → ((x : A) → is-truncated n (u x ≡ v x))
    λ-≡E-is-truncated#instance = λ _ → ≡E-is-truncated#instance

    ≡≡E-is-truncated#instance : {x y : E} {p q : x ≡ y} → is-truncated n (p ≡ q)
    ≡≡E-is-truncated#instance = ≡-is-truncated n (≡-is-truncated n P-E)

    λ-≡≡E-is-truncated#instance : {A : Set i} {x y : A → E}
      {p q : (a : A) → x a ≡ y a} → ((a : A) → is-truncated n (p a ≡ q a))
    λ-≡≡E-is-truncated#instance = λ _ → ≡≡E-is-truncated#instance

    equiv1 : (τ n (pushout d) → E) ≃ (pushout d → E)
    equiv1 = ((λ u → u ◯ proj) , τ-up n _ _)

    equiv2 : (pushout d → E) ≃ H.cocone E
    equiv2 = ((λ f → ((f ◯ left) , (f ◯ right) , (ap f ◯ glue)))
             , pushout-is-pushout E)

    -- (could be defined more generally somewhere else)
    diag-hom : pullback-diag i
    diag-hom = diag (A → E), (B → E), (C → E), (λ u → u ◯ f), (λ u → u ◯ g)

    τdiag-hom : pullback-diag i
    τdiag-hom = diag (τ n A → E), (τ n B → E), (τ n C → E),
                     (λ u → u ◯ τ-fmap f) , (λ u → u ◯ τ-fmap g)

    equiv3 : H.cocone E ≃ pullback diag-hom
    equiv3 = H.cocone-equiv-pullback E

    p₀ : (a : A → E) (x : τ n C)
      → τ-extend-nondep a (τ-fmap f x) ≡ τ-extend-nondep (a ◯ f) x
    p₀ a = τ-extend (λ x → refl)

    p : (a : A → E) → (τ-extend-nondep a) ◯ τ-fmap f ≡ τ-extend-nondep (a ◯ f)
    p a = funext (p₀ a)

    q₀ : (b : B → E) (x : τ n C)
      → τ-extend-nondep (b ◯ g) x ≡ τ-extend-nondep b (τ-fmap g x)
    q₀ b = τ-extend (λ x → refl)

    q : (b : B → E) → τ-extend-nondep (b ◯ g) ≡ (τ-extend-nondep b) ◯ τ-fmap g
    q b = funext (q₀ b)

    equiv4 : pullback diag-hom ≃ pullback τdiag-hom
    equiv4 = pullback-invariant-equiv diag-hom τdiag-hom
               (τ-extend-equiv n A E) (τ-extend-equiv n B E)
               (τ-extend-equiv n C E) p q

    equiv5 : pullback τdiag-hom ≃ τH.cocone E
    equiv5 = τH.pullback-equiv-cocone E

    -- We have defined the five equivalences, now we want to prove that the
    -- composite is what we want. We start by computing the composite of the
    -- equivalences 3, 4 and 5.

    map-543 : H.cocone E → τH.cocone E
    map-543 (a , b , e) = (τ-extend-nondep a , τ-extend-nondep b , τ-extend e)

    map-543-correct : (x : H.cocone E)
      → equiv5 ☆ (equiv4 ☆ (equiv3 ☆ x)) ≡ map-543 x
    map-543-correct (a , b , h) =
      ap (λ u → _ , _ , u)
        (funext (τ-extend
          (λ x →
            ap-concat (λ u → u (proj x)) (p a)
              (ap τ-extend-nondep (funext h) ∘ q b)
            ∘ (whisker-right _ (happly (happly-funext (p₀ a)) (proj x))
            ∘ (ap-concat (λ u → u (proj x))
                (ap τ-extend-nondep (funext h)) (q b)
            ∘ (whisker-right _
                (compose-ap (λ u → u (proj x)) τ-extend-nondep (funext h))
            ∘ (whisker-right _ (happly (happly-funext h) x)
            ∘ (whisker-left (h x)
                (happly (happly-funext (q₀ b)) (proj x))
            ∘ refl-right-unit (h x)))))))))

    -- We now study the full composite

    map-54321 : (τ n (pushout d) → E) → τH.cocone E
    map-54321 = τH.compose-cocone-map _ _ cocone-τpushout

    map-21-A₀ : (f : τ n (pushout d) → E) (u : τ n A)
      → τH.A→top (map-543 (equiv2 ☆ (equiv1 ☆ f))) u ≡ τH.A→top (map-54321 f) u
    map-21-A₀ f = τ-extend (λ x → refl)

    map-21-A : (f : τ n (pushout d) → E)
      → τH.A→top (map-543 (equiv2 ☆ (equiv1 ☆ f))) ≡ τH.A→top (map-54321 f)
    map-21-A f = funext (map-21-A₀ f)

    map-21-B₀ : (f : τ n (pushout d) → E) (u : τ n B)
      → τH.B→top (map-543 (equiv2 ☆ (equiv1 ☆ f))) u ≡ τH.B→top (map-54321 f) u
    map-21-B₀ f = τ-extend (λ x → refl)

    map-21-B : (f : τ n (pushout d) → E)
      → τH.B→top (map-543 (equiv2 ☆ (equiv1 ☆ f))) ≡ τH.B→top (map-54321 f)
    map-21-B f = funext (map-21-B₀ f)

    map-21-correct : (h : τ n (pushout d) → E)
      → map-543 (equiv2 ☆ (equiv1 ☆ h)) ≡ map-54321 h
    map-21-correct h = τH.cocone-eq _ (map-21-A h) (map-21-B h)
      (τ-extend
        (λ x →
          whisker-right _ (happly (happly-funext (map-21-A₀ h)) (proj (f x)))
          ∘ (compose-ap h proj _
          ∘ (! (refl-right-unit (ap (h ◯ proj) (glue x)))
          ∘ whisker-left (ap (h ◯ proj) (glue x))
          (! (happly (happly-funext (map-21-B₀ h)) (proj (g x))))))))

    map-54321-correct : (f : τ n (pushout d) → E)
      → equiv5 ☆ (equiv4 ☆ (equiv3 ☆ (equiv2 ☆ (equiv1 ☆ f)))) ≡ map-54321 f
    map-54321-correct f = map-543-correct (equiv2 ☆ (equiv1 ☆ f))
                          ∘ map-21-correct f

  map-54321-is-equiv : is-equiv map-54321
  map-54321-is-equiv =
    transport is-equiv (funext map-54321-correct)
      (compose-is-equiv
        ((λ f₁ → equiv4 ☆ (equiv3 ☆ (equiv2 ☆ (equiv1 ☆ f₁))))
        , compose-is-equiv
          ((λ f₁ → equiv3 ☆ (equiv2 ☆ (equiv1 ☆ f₁)))
            , compose-is-equiv
              ((λ f₁ → equiv2 ☆ (equiv1 ☆ f₁))
                , compose-is-equiv equiv1 equiv2)
              equiv3)
          equiv4)
      equiv5)

abstract
  τpushout-is-pushout : τH.is-pushout (τ n (pushout d)) cocone-τpushout
  τpushout-is-pushout E = map-54321-is-equiv E


------------------------------------------------------------------------------
-- The FOTC co-inductive lists type
------------------------------------------------------------------------------

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

-- N.B. This module is re-exported by FOTC.Data.Colist.

module FOTC.Data.Colist.Type where

open import FOTC.Base
open import FOTC.Base.List

------------------------------------------------------------------------------
-- The FOTC co-lists type (co-inductive predicate for total list).

-- Functional for the Colist predicate.
-- ColistF : (D → Set) → D → Set
-- ColistF A xs = xs ≡ [] ∨ ∃[ x' ] ∃[ xs' ] xs ≡ x' ∷ xs' ∧ A xs'

-- Colist is the greatest fixed-point of ColistF (by Colist-out and
-- Colist-coind).

postulate
  Colist : D → Set

postulate
-- Colist is a post-fixed point of ColistF, i.e.
--
-- Colist ≤ ColistF Colist.
  Colist-out : ∀ {xs} → Colist xs →
               xs ≡ [] ∨ (∃[ x' ] ∃[ xs' ] xs ≡ x' ∷ xs' ∧ Colist xs')
{-# ATP axiom Colist-out #-}

-- Colist is the greatest post-fixed point of ColistF, i.e.
--
-- ∀ A. A ≤ ColistF A ⇒ A ≤ Colist.
--
-- N.B. This is an axiom schema. Because in the automatic proofs we
-- *must* use an instance, we do not add this postulate as an ATP
-- axiom.
postulate
  Colist-coind :
    (A : D → Set) →
    -- A is post-fixed point of ColistF.
    (∀ {xs} → A xs → xs ≡ [] ∨ (∃[ x' ] ∃[ xs' ] xs ≡ x' ∷ xs' ∧ A xs')) →
    -- Colist is greater than A.
    ∀ {xs} → A xs → Colist xs


{-# OPTIONS --no-flat-split #-}
module _ where

postulate
  A : Set

data Id (A : Set) : Set where
  id : A → Id A

-- --no-flat-split disables matching on the @♭ x agument.
test2 : (@♭ x : Id A) → A
test2 (id x) = x


------------------------------------------------------------------------
-- The Agda standard library
--
-- Intersection of two binary relations
------------------------------------------------------------------------

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

module Relation.Binary.Construct.Intersection where

open import Data.Product
open import Data.Sum using (_⊎_; inj₁; inj₂; [_,_])
open import Function using (_∘_)
open import Level using (_⊔_)
open import Relation.Binary
open import Relation.Nullary using (yes; no)

------------------------------------------------------------------------
-- Definition

_∩_ : ∀ {a b ℓ₁ ℓ₂} {A : Set a} {B : Set b} →
      REL A B ℓ₁ → REL A B ℓ₂ → REL A B (ℓ₁ ⊔ ℓ₂)
L ∩ R = λ i j → L i j × R i j

------------------------------------------------------------------------
-- Properties

module _ {a ℓ₁ ℓ₂} {A : Set a} (L : Rel A ℓ₁) (R : Rel A ℓ₂) where

  reflexive : Reflexive L → Reflexive R → Reflexive (L ∩ R)
  reflexive L-refl R-refl = L-refl , R-refl

  symmetric : Symmetric L → Symmetric R → Symmetric (L ∩ R)
  symmetric L-sym R-sym = map L-sym R-sym

  transitive : Transitive L → Transitive R → Transitive (L ∩ R)
  transitive L-trans R-trans = zip L-trans R-trans

  respects : ∀ {p} (P : A → Set p) →
             P Respects L ⊎ P Respects R → P Respects (L ∩ R)
  respects P resp (Lxy , Rxy) = [ (λ x → x Lxy) , (λ x → x Rxy) ] resp

  min : ∀ {⊤} → Minimum L ⊤ → Minimum R ⊤ → Minimum (L ∩ R) ⊤
  min L-min R-min = < L-min , R-min >

  max : ∀ {⊥} → Maximum L ⊥ → Maximum R ⊥ → Maximum (L ∩ R) ⊥
  max L-max R-max = < L-max , R-max >

module _ {a b ℓ₁ ℓ₂ ℓ₃} {A : Set a} {B : Set b}
         (≈ : REL A B ℓ₁) {L : REL A B ℓ₂} {R : REL A B ℓ₃} where

  implies : (≈ ⇒ L) → (≈ ⇒ R) → ≈ ⇒ (L ∩ R)
  implies ≈⇒L ≈⇒R = < ≈⇒L , ≈⇒R >

module _ {a b ℓ₁ ℓ₂ ℓ₃} {A : Set a} {B : Set b}
         (≈ : REL A B ℓ₁) (L : REL A B ℓ₂) (R : REL A B ℓ₃) where

  irreflexive : Irreflexive ≈ L ⊎ Irreflexive ≈ R → Irreflexive ≈ (L ∩ R)
  irreflexive irrefl x≈y (Lxy , Rxy) = [ (λ x → x x≈y Lxy) , (λ x → x x≈y Rxy) ] irrefl

module _ {a ℓ₁ ℓ₂ ℓ₃} {A : Set a}
         (≈ : Rel A ℓ₁) (L : Rel A ℓ₂) (R : Rel A ℓ₃) where

  respectsˡ : L Respectsˡ ≈ → R Respectsˡ ≈ → (L ∩ R) Respectsˡ ≈
  respectsˡ L-resp R-resp x≈y = map (L-resp x≈y) (R-resp x≈y)

  respectsʳ : L Respectsʳ ≈ → R Respectsʳ ≈ → (L ∩ R) Respectsʳ ≈
  respectsʳ L-resp R-resp x≈y = map (L-resp x≈y) (R-resp x≈y)

  respects₂ : L Respects₂ ≈ → R Respects₂ ≈ → (L ∩ R) Respects₂ ≈
  respects₂ (Lʳ , Lˡ) (Rʳ , Rˡ) = respectsʳ Lʳ Rʳ , respectsˡ Lˡ Rˡ

  antisymmetric : Antisymmetric ≈ L ⊎ Antisymmetric ≈ R → Antisymmetric ≈ (L ∩ R)
  antisymmetric (inj₁ L-antisym) (Lxy , _) (Lyx , _) = L-antisym Lxy Lyx
  antisymmetric (inj₂ R-antisym) (_ , Rxy) (_ , Ryx) = R-antisym Rxy Ryx

module _ {a b ℓ₁ ℓ₂} {A : Set a} {B : Set b} {L : REL A B ℓ₁} {R : REL A B ℓ₂} where

  decidable : Decidable L → Decidable R → Decidable (L ∩ R)
  decidable L? R? x y with L? x y | R? x y
  ... | no ¬Lxy | _       = no (¬Lxy ∘ proj₁)
  ... | yes _   | no ¬Rxy = no (¬Rxy ∘ proj₂)
  ... | yes Lxy | yes Rxy = yes (Lxy , Rxy)

------------------------------------------------------------------------
-- Structures

module _ {a ℓ₁ ℓ₂} {A : Set a} {L : Rel A ℓ₁} {R : Rel A ℓ₂} where

  isEquivalence : IsEquivalence L → IsEquivalence R → IsEquivalence (L ∩ R)
  isEquivalence eqₗ eqᵣ = record
    { refl  = reflexive  L R Eqₗ.refl  Eqᵣ.refl
    ; sym   = symmetric  L R Eqₗ.sym   Eqᵣ.sym
    ; trans = transitive L R Eqₗ.trans Eqᵣ.trans
    }
    where module Eqₗ = IsEquivalence eqₗ; module Eqᵣ = IsEquivalence eqᵣ

  isDecEquivalence : IsDecEquivalence L → IsDecEquivalence R → IsDecEquivalence (L ∩ R)
  isDecEquivalence eqₗ eqᵣ = record
    { isEquivalence = isEquivalence Eqₗ.isEquivalence Eqᵣ.isEquivalence
    ; _≟_           = decidable Eqₗ._≟_ Eqᵣ._≟_
    }
    where module Eqₗ = IsDecEquivalence eqₗ; module Eqᵣ = IsDecEquivalence eqᵣ

module _ {a ℓ₁ ℓ₂ ℓ₃} {A : Set a} {≈ : Rel A ℓ₁} {L : Rel A ℓ₂} {R : Rel A ℓ₃} where

  isPreorder : IsPreorder ≈ L → IsPreorder ≈ R → IsPreorder ≈ (L ∩ R)
  isPreorder Oₗ Oᵣ = record
    { isEquivalence = Oₗ.isEquivalence
    ; reflexive     = implies ≈ Oₗ.reflexive Oᵣ.reflexive
    ; trans         = transitive L R Oₗ.trans Oᵣ.trans
    }
    where module Oₗ = IsPreorder Oₗ; module Oᵣ = IsPreorder Oᵣ

  isPartialOrderˡ : IsPartialOrder ≈ L → IsPreorder ≈ R → IsPartialOrder ≈ (L ∩ R)
  isPartialOrderˡ Oₗ Oᵣ = record
    { isPreorder = isPreorder Oₗ.isPreorder Oᵣ
    ; antisym    = antisymmetric ≈ L R (inj₁ Oₗ.antisym)
    }
    where module Oₗ = IsPartialOrder Oₗ; module Oᵣ = IsPreorder Oᵣ

  isPartialOrderʳ : IsPreorder ≈ L → IsPartialOrder ≈ R → IsPartialOrder ≈ (L ∩ R)
  isPartialOrderʳ Oₗ Oᵣ = record
    { isPreorder = isPreorder Oₗ Oᵣ.isPreorder
    ; antisym    = antisymmetric ≈ L R (inj₂ Oᵣ.antisym)
    }
    where module Oₗ = IsPreorder Oₗ; module Oᵣ = IsPartialOrder Oᵣ

  isStrictPartialOrderˡ : IsStrictPartialOrder ≈ L →
                          Transitive R → R Respects₂ ≈ →
                          IsStrictPartialOrder ≈ (L ∩ R)
  isStrictPartialOrderˡ Oₗ transᵣ respᵣ = record
    { isEquivalence = Oₗ.isEquivalence
    ; irrefl        = irreflexive ≈ L R (inj₁ Oₗ.irrefl)
    ; trans         = transitive L R Oₗ.trans transᵣ
    ; <-resp-≈      = respects₂ ≈ L R Oₗ.<-resp-≈ respᵣ
    }
    where module Oₗ = IsStrictPartialOrder Oₗ

  isStrictPartialOrderʳ : Transitive L → L Respects₂ ≈ →
                          IsStrictPartialOrder ≈ R →
                          IsStrictPartialOrder ≈ (L ∩ R)
  isStrictPartialOrderʳ transₗ respₗ Oᵣ = record
    { isEquivalence = Oᵣ.isEquivalence
    ; irrefl        = irreflexive ≈ L R (inj₂ Oᵣ.irrefl)
    ; trans         = transitive L R transₗ Oᵣ.trans
    ; <-resp-≈      = respects₂ ≈ L R respₗ Oᵣ.<-resp-≈
    }
    where module Oᵣ = IsStrictPartialOrder Oᵣ


------------------------------------------------------------------------------
-- Properties of the alter list
------------------------------------------------------------------------------

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

module FOT.FOTC.UnguardedCorecursion.Alter.PropertiesATP where

open import FOT.FOTC.UnguardedCorecursion.Alter.Alter

open import FOTC.Base
open import FOTC.Base.List
open import FOTC.Data.Stream.Type
open import FOTC.Relation.Binary.Bisimilarity.Type

------------------------------------------------------------------------------
-- TODO (23 December 2013).
-- alter-Stream : Stream alter
-- alter-Stream = Stream-coind A h refl
--   where
--   A : D → Set
--   A xs = xs ≡ xs
--   {-# ATP definition A #-}

--   postulate h : A alter → ∃[ x' ] ∃[ xs' ] alter ≡ x' ∷ xs' ∧ A xs'
--   {-# ATP prove h #-}

-- TODO (23 December 2013).
-- alter'-Stream : Stream alter'
-- alter'-Stream = Stream-coind A h refl
--   where
--   A : D → Set
--   A xs = xs ≡ xs
--   {-# ATP definition A #-}

--   postulate h : A alter' → ∃[ x' ] ∃[ xs' ] alter' ≡ x' ∷ xs' ∧ A xs'
--   {-# ATP prove h #-}

-- TODO (23 December 2013).
-- alter≈alter' : alter ≈ alter'
-- alter≈alter' = ≈-coind B h₁ h₂
--   where
--   B : D → D → Set
--   B xs ys = xs ≡ xs
--   {-# ATP definition B #-}

--   postulate h₁ : B alter alter' → ∃[ x' ] ∃[ xs' ] ∃[ ys' ]
--                    alter ≡ x' ∷ xs' ∧ alter' ≡ x' ∷ ys' ∧ B xs' ys'
--   {-# ATP prove h₁ #-}

--   postulate h₂ : B alter alter'
--   {-# ATP prove h₂ #-}


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

open import HoTT
open import cohomology.FunctionOver

module cohomology.TwoPushouts where

--        g     h
--     B --> C --> D    K = A ⊔^B C / (f,g)        d₁ = A <- B -> C
--    f|     |     |    L = K ⊔^C D / (left,h)     d₂ = K <- C -> D
--     v     v     v                               d  = A <- B -> D
--     A --> K --> L
--
module TwoPushoutsEquiv {i j k l} {A : Type i} {B : Type j} {C : Type k}
  {D : Type l} (f : B → A) (g : B → C) (h : C → D) where

  private
    d₁ : Span
    d₁ = span A C B f g

    d₂ : Span
    d₂ = span (Pushout d₁) D C right h

    d : Span
    d = span A D B f (h ∘ g)

  module Inner = PushoutRec {d = d₁} {D = Pushout d}
    left
    (right ∘ h)
    glue

  module Into = PushoutRec {d = d} {D = Pushout d₂}
    (left ∘ left)
    right
    (λ b → ap left (glue b) ∙ glue (g b))

  into : Pushout d -> Pushout d₂
  into = Into.f

  module Out = PushoutRec {d = d₂} {D = Pushout d}
    Inner.f
    right
    (λ _ → idp)

  out : Pushout d₂ → Pushout d
  out = Out.f

  private
    square-extend-tr : ∀ {i} {A : Type i} {a₀₀ a₀₁ a₁₀ a₁₁ b : A}
      {p₀₋ : a₀₀ == a₀₁} {p₋₀ : a₀₀ == a₁₀}
      {p₋₁ : a₀₁ == a₁₁} {p₁₋ : a₁₀ == a₁₁} (q : a₁₀ == b)
      → Square p₀₋ p₋₀ p₋₁ p₁₋
      → Square p₀₋ (p₋₀ ∙ q) p₋₁ (! q ∙' p₁₋)
    square-extend-tr idp ids = ids

    square-corner-bl : ∀ {i} {A : Type i} {a₀ a₁ : A} (q : a₀ == a₁)
      → Square (! q) idp q idp
    square-corner-bl idp = ids

  into-inner : (k : Pushout d₁) → into (Inner.f k) == left k
  into-inner = Pushout-elim
    (λ a → idp)
    (λ c → ! (glue c))
    (λ b → ↓-='-from-square $
      (ap-∘ into Inner.f (glue b)
       ∙ ap (ap into) (Inner.glue-β b) ∙ Into.glue-β b)
      ∙v⊡ square-extend-tr (glue (g b)) vid-square)

  abstract
    into-out : (l : Pushout d₂) → into (out l) == l
    into-out = Pushout-elim
      into-inner
      (λ d → idp)
      (λ c → ↓-∘=idf-from-square into out $
        ap (ap into) (Out.glue-β c) ∙v⊡ square-corner-bl (glue c))

    out-into : (l : Pushout d) → out (into l) == l
    out-into = Pushout-elim
      (λ a → idp)
      (λ d → idp)
      (λ b → ↓-∘=idf-from-square out into $ vert-degen-square $
        ap out (ap into (glue b))
          =⟨ ap (ap out) (Into.glue-β b) ⟩
        ap out (ap left (glue b) ∙ glue (g b))
          =⟨ ap-∙ out (ap left (glue b)) (glue (g b)) ⟩
        ap out (ap left (glue b)) ∙ ap out (glue (g b))
          =⟨ ∘-ap out left (glue b) |in-ctx (λ w → w ∙ ap out (glue (g b))) ⟩
        ap Inner.f (glue b) ∙ ap out (glue (g b))
          =⟨ Out.glue-β (g b) |in-ctx (λ w → ap Inner.f (glue b) ∙ w) ⟩
        ap Inner.f (glue b) ∙ idp
          =⟨ ∙-unit-r _ ⟩
        ap Inner.f (glue b)
          =⟨ Inner.glue-β b ⟩
        glue b ∎)

  two-pushouts-equiv : Pushout d ≃ Pushout d₂
  two-pushouts-equiv = equiv into out into-out out-into

  two-pushouts : Lift {j = lmax l (lmax k (lmax j i))} (Pushout d) == Pushout d₂
  two-pushouts = ua (two-pushouts-equiv ∘e lift-equiv)

  two-pushouts-left : lift ∘ left == left ∘ left
                      [ (λ E → (A → E)) ↓ two-pushouts ]
  two-pushouts-left = codomain-over-equiv _ _

  two-pushouts-right : lift ∘ right == right [ (λ E → (D → E)) ↓ two-pushouts ]
  two-pushouts-right = codomain-over-equiv _ _

  two-pushouts-inner : lift ∘ Inner.f == left
                       [ (λ E → (Pushout d₁ → E)) ↓ two-pushouts ]
  two-pushouts-inner = codomain-over-equiv _ _ ▹ λ= into-inner

--        g     h
--     Y --> Z --> W    K = X ⊔^Y Y / (f,g)        ps₁ = X <- Y -> Z
--    f|     |     |    L = Z ⊔^Z W / (left,h)     ps₂ = K <- Z -> W
--     v     v     v                               ps = X <- Y -> W
--     X --> K --> L
--
module TwoPushoutsPtd {i j k l} {X : Ptd i} {Y : Ptd j} {Z : Ptd k} {W : Ptd l}
  (f : fst (Y ⊙→ X)) (g : fst (Y ⊙→ Z)) (h : fst (Z ⊙→ W)) where

  private
    ps₁ = ⊙span X Z Y f g
    ps₂ = ⊙span (⊙Pushout ps₁) W Z (⊙right ps₁) h
    ps = ⊙span X W Y f (h ⊙∘ g)

  open TwoPushoutsEquiv (fst f) (fst g) (fst h) public

  two-pushouts-ptd :
    ⊙Lift {j = lmax l (lmax k (lmax j i))} (⊙Pushout ps)
    == ⊙Pushout ps₂
  two-pushouts-ptd = ⊙ua (two-pushouts-equiv ∘e lift-equiv) idp

  two-pushouts-⊙left :
    ⊙lift ⊙∘ ⊙left ps == ⊙left ps₂ ⊙∘ ⊙left ps₁
    [ (λ V → fst (X ⊙→ V)) ↓ two-pushouts-ptd ]
  two-pushouts-⊙left = codomain-over-⊙equiv _ _ _

  two-pushouts-⊙right :
    ⊙lift ⊙∘ ⊙right ps == ⊙right ps₂
    [ (λ V → fst (W ⊙→ V)) ↓ two-pushouts-ptd ]
  two-pushouts-⊙right =
    codomain-over-⊙equiv _ _ _ ▹ pair= idp (lemma f g h)
    where
    lemma : {X : Ptd i} {Y : Ptd j} {Z : Ptd k} {W : Ptd l}
      (f : fst (Y ⊙→ X)) (g : fst (Y ⊙→ Z)) (h : fst (Z ⊙→ W))
      → ap (TwoPushoutsEquiv.into (fst f) (fst g) (fst h)
               ∘ lower {j = lmax l (lmax k (lmax j i))})
              (snd (⊙lift ⊙∘ ⊙right (⊙span X W Y f (h ⊙∘ g))))
        ∙ idp
        ==  ap right (! (snd h)) ∙ ! (glue (snd Z))
            ∙' ap left (snd (⊙right (⊙span X Z Y f g)))
    lemma {Y = Y} (f , idp) (g , idp) (h , idp) =
      ap (2P.into ∘ lower) (ap lift (! (glue (snd Y))) ∙ idp) ∙ idp
        =⟨ ∙-unit-r _ ⟩
      ap (2P.into ∘ lower) (ap lift (! (glue (snd Y))) ∙ idp)
        =⟨ ∙-unit-r _ |in-ctx (ap (2P.into ∘ lower)) ⟩
      ap (2P.into ∘ lower) (ap lift (! (glue (snd Y))))
        =⟨ ∘-ap (2P.into ∘ lower) lift _ ⟩
      ap 2P.into (! (glue (snd Y)))
        =⟨ ap-! 2P.into (glue (snd Y)) ⟩
      ! (ap 2P.into (glue (snd Y)))
        =⟨ 2P.Into.glue-β (snd Y) |in-ctx ! ⟩
      ! (ap left (glue (snd Y)) ∙ glue (g (snd Y)))
        =⟨ !-∙ (ap left (glue (snd Y))) (glue (g (snd Y))) ⟩
      ! (glue (g (snd Y))) ∙ ! (ap left (glue (snd Y)))
        =⟨ !-ap left (glue (snd Y)) |in-ctx (λ w → ! (glue (g (snd Y))) ∙ w) ⟩
      ! (glue (g (snd Y))) ∙ ap left (! (glue (snd Y)))
        =⟨ ∙=∙' (! (glue (g (snd Y)))) (ap left (! (glue (snd Y)))) ⟩
      ! (glue (g (snd Y))) ∙' ap left (! (glue (snd Y))) ∎
      where
      module 2P = TwoPushoutsEquiv f g h

  two-pushouts-⊙inner : ⊙lift ⊙∘ (Inner.f , idp) == ⊙left ps₂
    [ (λ V → fst (⊙Pushout ps₁ ⊙→ V)) ↓ two-pushouts-ptd ]
  two-pushouts-⊙inner =
    codomain-over-⊙equiv _ _ _ ▹ ⊙λ= into-inner idp

open TwoPushoutsEquiv
  using (two-pushouts-equiv; two-pushouts; two-pushouts-left;
         two-pushouts-right; two-pushouts-inner)

open TwoPushoutsPtd
  using (two-pushouts-ptd; two-pushouts-⊙left; two-pushouts-⊙right;
         two-pushouts-⊙inner)


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

module Data.Integer.Literals where

open import Data.Integer
open import Literals.Number
open import Data.Unit

instance
  numberNat : Number ℤ
  numberNat = record
    { Constraint = λ _ → ⊤
    ; fromNat    = λ n → ⁺ n
    }


------------------------------------------------------------------------
-- An example: A function that, given a stream, tries to find an
-- element satisfying a predicate
------------------------------------------------------------------------

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

module Search where

open import Equality.Propositional.Cubical
open import Prelude hiding (⊥)

open import Monad equality-with-J
open import Univalence-axiom equality-with-J

open import Partiality-algebra.Monotone
open import Partiality-monad.Inductive
open import Partiality-monad.Inductive.Fixpoints
open import Partiality-monad.Inductive.Monad

-- Streams.

infixr 5 _∷_

record Stream {a} (A : Type a) : Type a where
  coinductive
  constructor _∷_
  field
    head : A
    tail : Stream A

open Stream

-- A direct implementation of the function.

module Direct {a} {A : Type a} (q : A → Bool) where

  Φ : Trans (Stream A) (λ _ → A)
  Φ f xs = if q (head xs) then return (head xs) else f (tail xs)

  Φ-monotone :
    ∀ {f₁ f₂} → (∀ xs → f₁ xs ⊑ f₂ xs) → ∀ xs → Φ f₁ xs ⊑ Φ f₂ xs
  Φ-monotone f₁⊑f₂ xs with q (head xs)
  ... | true  = return (head xs)  ■
  ... | false = f₁⊑f₂ (tail xs)

  Φ-⊑ : Trans-⊑ (Stream A) (λ _ → A)
  Φ-⊑ = record { function = Φ; monotone = Φ-monotone }

  search : Stream A → A ⊥
  search = fix→ Φ-⊑

  search-least :
    ∀ f → (∀ xs → Φ f xs ⊑ f xs) →
    ∀ xs → search xs ⊑ f xs
  search-least = fix→-is-least Φ-⊑

  Φ-ω-continuous :
    (s : ∃ λ (f : ℕ → Stream A → A ⊥) →
           ∀ n xs → f n xs ⊑ f (suc n) xs) →
    Φ (⨆ ∘ at s) ≡ ⨆ ∘ at [ Φ-⊑ $ s ]-inc
  Φ-ω-continuous s = ⟨ext⟩ helper
    where
    helper : ∀ xs → Φ (⨆ ∘ at s) xs ≡ ⨆ (at [ Φ-⊑ $ s ]-inc xs)
    helper xs with q (head xs)
    ... | true  = return (head xs)               ≡⟨ sym ⨆-const ⟩∎
                  ⨆ (constˢ (return (head xs)))  ∎
    ... | false = ⨆ (at s (tail xs))             ∎

  Φ-ω : Trans-ω (Stream A) (λ _ → A)
  Φ-ω = record
    { monotone-function = Φ-⊑
    ; ω-continuous      = Φ-ω-continuous
    }

  search-fixpoint : search ≡ Φ search
  search-fixpoint = fix→-is-fixpoint-combinator Φ-ω

-- An arguably more convenient implementation.

module Indirect {a} {A : Type a} (q : A → Bool) where

  ΦP : Stream A → Partial (Stream A) (λ _ → A) A
  ΦP xs =
    if q (head xs) then
      return (head xs)
    else
      rec (tail xs)

  Φ : Trans (Stream A) (λ _ → A)
  Φ = Trans-⊑.function (transformer ΦP)

  search : Stream A → A ⊥
  search = fixP ΦP

  search-least :
    ∀ f → (∀ xs → Φ f xs ⊑ f xs) →
    ∀ xs → search xs ⊑ f xs
  search-least = fixP-is-least ΦP

  search-fixpoint : search ≡ Φ search
  search-fixpoint = fixP-is-fixpoint-combinator ΦP


open import Nat
open import Prelude
open import core
open import contexts
open import lemmas-consistency
open import type-assignment-unicity
open import lemmas-progress-checks

-- taken together, the theorems in this file argue that for any expression
-- d, at most one summand of the labeled sum that results from progress may
-- be true at any time: that boxed values, indeterminates, and expressions
-- that step are pairwise disjoint.
--
-- note that as a consequence of currying and comutativity of products,
-- this means that there are three theorems to prove. in addition to those,
-- we also prove several convenince forms that combine theorems about
-- indeterminate and boxed value forms into the same statement about final
-- forms, which mirrors the mutual definition of indeterminate and final
-- and saves some redundant argumentation.
module progress-checks where
  -- boxed values are not indeterminates
  boxedval-not-indet : ∀{d} → d boxedval → d indet → ⊥
  boxedval-not-indet (BVVal VConst) ()
  boxedval-not-indet (BVVal VLam) ()
  boxedval-not-indet (BVArrCast x bv) (ICastArr x₁ ind) = boxedval-not-indet bv ind
  boxedval-not-indet (BVHoleCast x bv) (ICastGroundHole x₁ ind) = boxedval-not-indet bv ind
  boxedval-not-indet (BVHoleCast x bv) (ICastHoleGround x₁ ind x₂) = boxedval-not-indet bv ind

  -- boxed values don't step
  boxedval-not-step : ∀{d} → d boxedval → (Σ[ d' ∈ ihexp ] (d ↦ d')) → ⊥
  boxedval-not-step (BVVal VConst) (d' , Step FHOuter () x₃)
  boxedval-not-step (BVVal VLam) (d' , Step FHOuter () x₃)
  boxedval-not-step (BVArrCast x bv) (d0' , Step FHOuter (ITCastID) FHOuter) = x refl
  boxedval-not-step (BVArrCast x bv) (_ , Step (FHCast x₁) x₂ (FHCast x₃)) = boxedval-not-step bv (_ , Step x₁ x₂ x₃)
  boxedval-not-step (BVHoleCast () bv) (d' , Step FHOuter (ITCastID) FHOuter)
  boxedval-not-step (BVHoleCast x bv) (d' , Step FHOuter (ITCastSucceed ()) FHOuter)
  boxedval-not-step (BVHoleCast GHole bv) (_ , Step FHOuter (ITGround (MGArr x)) FHOuter) = x refl
  boxedval-not-step (BVHoleCast x bv) (_ , Step (FHCast x₁) x₂ (FHCast x₃)) = boxedval-not-step bv (_ , Step x₁ x₂ x₃)
  boxedval-not-step (BVHoleCast x x₁) (_ , Step FHOuter (ITExpand ()) FHOuter)
  boxedval-not-step (BVHoleCast x x₁) (_ , Step FHOuter (ITCastFail x₂ () x₄) FHOuter)

  mutual
    -- indeterminates don't step
    indet-not-step : ∀{d} → d indet → (Σ[ d' ∈ ihexp ] (d ↦ d')) → ⊥
    indet-not-step IEHole (d' , Step FHOuter () FHOuter)
    indet-not-step (INEHole x) (d' , Step FHOuter () FHOuter)
    indet-not-step (INEHole x) (_ , Step (FHNEHole x₁) x₂ (FHNEHole x₃)) = final-sub-not-trans x x₁ x₂
    indet-not-step (IAp x₁ () x₂) (_ , Step FHOuter (ITLam) FHOuter)
    indet-not-step (IAp x (ICastArr x₁ ind) x₂) (_ , Step FHOuter (ITApCast) FHOuter) = x _ _ _ _ _  refl
    indet-not-step (IAp x ind _) (_ , Step (FHAp1 x₂) x₃ (FHAp1 x₄)) = indet-not-step ind (_ , Step x₂ x₃ x₄)
    indet-not-step (IAp x ind f) (_ , Step (FHAp2 x₃) x₄ (FHAp2 x₆)) = final-not-step f (_ , Step x₃ x₄ x₆)
    indet-not-step (ICastArr x ind) (d0' , Step FHOuter (ITCastID) FHOuter) = x refl
    indet-not-step (ICastArr x ind) (_ , Step (FHCast x₁) x₂ (FHCast x₃)) = indet-not-step ind (_ , Step x₁ x₂ x₃)
    indet-not-step (ICastGroundHole () ind) (d' , Step FHOuter (ITCastID) FHOuter)
    indet-not-step (ICastGroundHole x ind) (d' , Step FHOuter (ITCastSucceed ()) FHOuter)
    indet-not-step (ICastGroundHole GHole ind) (_ , Step FHOuter (ITGround (MGArr x₁)) FHOuter) = x₁ refl
    indet-not-step (ICastGroundHole x ind) (_ , Step (FHCast x₁) x₂ (FHCast x₃)) = indet-not-step ind (_ , Step x₁ x₂ x₃)
    indet-not-step (ICastHoleGround x ind ()) (d' , Step FHOuter (ITCastID ) FHOuter)
    indet-not-step (ICastHoleGround x ind g) (d' , Step FHOuter (ITCastSucceed  x₂) FHOuter) = x _ _ refl
    indet-not-step (ICastHoleGround x ind GHole) (_ , Step FHOuter (ITExpand (MGArr x₂)) FHOuter) = x₂ refl
    indet-not-step (ICastHoleGround x ind g) (_ , Step (FHCast x₁) x₂ (FHCast x₃)) = indet-not-step ind (_ , Step x₁ x₂ x₃)
    indet-not-step (ICastGroundHole x x₁) (_ , Step FHOuter (ITExpand ()) FHOuter)
    indet-not-step (ICastHoleGround x x₁ x₂) (_ , Step FHOuter (ITGround ()) FHOuter)
    indet-not-step (ICastGroundHole x x₁) (_ , Step FHOuter (ITCastFail x₂ () x₄) FHOuter)
    indet-not-step (ICastHoleGround x x₁ x₂) (_ , Step FHOuter (ITCastFail x₃ x₄ x₅) FHOuter) = x _ _ refl
    indet-not-step (IFailedCast x x₁ x₂ x₃) (d' , Step FHOuter () FHOuter)
    indet-not-step (IFailedCast x x₁ x₂ x₃) (_ , Step (FHFailedCast x₄) x₅ (FHFailedCast x₆)) = final-not-step x (_ , Step x₄ x₅ x₆)

    -- final expressions don't step
    final-not-step : ∀{d} → d final → Σ[ d' ∈ ihexp ] (d ↦ d') → ⊥
    final-not-step (FBoxedVal x) stp = boxedval-not-step x stp
    final-not-step (FIndet x) stp = indet-not-step x stp


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

module Light.Variable.Sets where

open import Light.Variable.Levels

variable
      𝕒 𝕒₀ 𝕒₁ 𝕒₂ 𝕒₃ 𝕒₄ 𝕒₅ : Set aℓ
      𝕓 𝕓₀ 𝕓₁ 𝕓₂ 𝕓₃ 𝕓₄ 𝕓₅ : Set bℓ
      𝕔 𝕔₀ 𝕔₁ 𝕔₂ 𝕔₃ 𝕔₄ 𝕔₅ : Set cℓ
      𝕕 𝕕₀ 𝕕₁ 𝕕₂ 𝕕₃ 𝕕₄ 𝕕₅ : Set dℓ
      𝕖 𝕖₀ 𝕖₁ 𝕖₂ 𝕖₃ 𝕖₄ 𝕖₅ : Set eℓ
      𝕗 𝕗₀ 𝕗₁ 𝕗₂ 𝕗₃ 𝕗₄ 𝕗₅ : Set fℓ
      𝕘 𝕘₀ 𝕘₁ 𝕘₂ 𝕘₃ 𝕘₄ 𝕘₅ : Set gℓ
      𝕙 𝕙₀ 𝕙₁ 𝕙₂ 𝕙₃ 𝕙₄ 𝕙₅ : Set hℓ