diff --git a/docs/Cubical.Displayed.Auto.html b/docs/Cubical.Displayed.Auto.html index 4e5f8fa..e7fc52b 100644 --- a/docs/Cubical.Displayed.Auto.html +++ b/docs/Cubical.Displayed.Auto.html @@ -35,158 +35,158 @@ -- Descriptor language mutual - data UARelDesc : ∀ {ℓA ℓ≅A} {A : Type ℓA} (𝒮-A : UARel A ℓ≅A) → Typeω where + data UARelDesc : ∀ {ℓA ℓ≅A} {A : Type ℓA} (𝒮-A : UARel A ℓ≅A) → Typeω where - generic : ∀ {ℓA} {A : Type ℓA} → UARelDesc (𝒮-generic A) + generic : ∀ {ℓA} {A : Type ℓA} → UARelDesc (𝒮-generic A) univ : ∀ ℓU → UARelDesc (𝒮-Univ ℓU) -- Having a special descriptor for non-dependent × helps to avoid -- combinatorial explosion. Automation will try to apply this first. prod : ∀ {ℓA ℓ≅A ℓB ℓ≅B} - {A : Type ℓA} {𝒮-A : UARel A ℓ≅A} (dA : UARelDesc 𝒮-A) - {B : Type ℓB} {𝒮-B : UARel B ℓ≅B} (dB : UARelDesc 𝒮-B) + {A : Type ℓA} {𝒮-A : UARel A ℓ≅A} (dA : UARelDesc 𝒮-A) + {B : Type ℓB} {𝒮-B : UARel B ℓ≅B} (dB : UARelDesc 𝒮-B) → UARelDesc (𝒮-A ×𝒮 𝒮-B) sigma : ∀ {ℓA ℓ≅A ℓB ℓ≅B} - {A : Type ℓA} {𝒮-A : UARel A ℓ≅A} (dA : UARelDesc 𝒮-A) - {B : A → Type ℓB} {𝒮ᴰ-B : DUARel 𝒮-A B ℓ≅B} (dB : DUARelDesc 𝒮-A 𝒮ᴰ-B) + {A : Type ℓA} {𝒮-A : UARel A ℓ≅A} (dA : UARelDesc 𝒮-A) + {B : A → Type ℓB} {𝒮ᴰ-B : DUARel 𝒮-A B ℓ≅B} (dB : DUARelDesc 𝒮-A 𝒮ᴰ-B) → UARelDesc (∫ 𝒮ᴰ-B) - param : ∀ {ℓA ℓB ℓ≅B} (A : Type ℓA) - {B : Type ℓB} {𝒮-B : UARel B ℓ≅B} (dB : UARelDesc 𝒮-B) + param : ∀ {ℓA ℓB ℓ≅B} (A : Type ℓA) + {B : Type ℓB} {𝒮-B : UARel B ℓ≅B} (dB : UARelDesc 𝒮-B) → UARelDesc (A →𝒮 𝒮-B) pi : ∀ {ℓA ℓ≅A ℓB ℓ≅B} - {A : Type ℓA} {𝒮-A : UARel A ℓ≅A} (dA : UARelDesc 𝒮-A) - {B : A → Type ℓB} {𝒮ᴰ-B : DUARel 𝒮-A B ℓ≅B} (dB : DUARelDesc 𝒮-A 𝒮ᴰ-B) + {A : Type ℓA} {𝒮-A : UARel A ℓ≅A} (dA : UARelDesc 𝒮-A) + {B : A → Type ℓB} {𝒮ᴰ-B : DUARel 𝒮-A B ℓ≅B} (dB : DUARelDesc 𝒮-A 𝒮ᴰ-B) → UARelDesc (𝒮-Π 𝒮-A 𝒮ᴰ-B) unit : UARelDesc 𝒮-Unit -- Projections from one UARel to another data UARelReindex : ∀ {ℓA ℓ≅A ℓC ℓ≅C} - {A : Type ℓA} {𝒮-A : UARel A ℓ≅A} - {C : Type ℓC} {𝒮-C : UARel C ℓ≅C} + {A : Type ℓA} {𝒮-A : UARel A ℓ≅A} + {C : Type ℓC} {𝒮-C : UARel C ℓ≅C} (f : UARelHom 𝒮-A 𝒮-C) - → Typeω + → Typeω where - id : ∀ {ℓA ℓ≅A} {A : Type ℓA} {𝒮-A : UARel A ℓ≅A} + id : ∀ {ℓA ℓ≅A} {A : Type ℓA} {𝒮-A : UARel A ℓ≅A} → UARelReindex (𝒮-id 𝒮-A) ∘fst : ∀ {ℓA ℓ≅A ℓB ℓ≅B ℓC ℓ≅C} - {A : Type ℓA} {𝒮-A : UARel A ℓ≅A} - {B : A → Type ℓB} {𝒮ᴰ-B : DUARel 𝒮-A B ℓ≅B} - {C : Type ℓC} {𝒮-C : UARel C ℓ≅C} + {A : Type ℓA} {𝒮-A : UARel A ℓ≅A} + {B : A → Type ℓB} {𝒮ᴰ-B : DUARel 𝒮-A B ℓ≅B} + {C : Type ℓC} {𝒮-C : UARel C ℓ≅C} {f : UARelHom 𝒮-A 𝒮-C} → UARelReindex f → UARelReindex (𝒮-∘ f (𝒮-fst {𝒮ᴰ-B = 𝒮ᴰ-B})) ∘snd : ∀ {ℓA ℓ≅A ℓB ℓ≅B ℓC ℓ≅C} - {A : Type ℓA} {𝒮-A : UARel A ℓ≅A} - {B : Type ℓB} {𝒮-B : UARel B ℓ≅B} - {C : Type ℓC} {𝒮-C : UARel C ℓ≅C} + {A : Type ℓA} {𝒮-A : UARel A ℓ≅A} + {B : Type ℓB} {𝒮-B : UARel B ℓ≅B} + {C : Type ℓC} {𝒮-C : UARel C ℓ≅C} {f : UARelHom 𝒮-B 𝒮-C} → UARelReindex f → UARelReindex (𝒮-∘ f (𝒮-snd {𝒮-A = 𝒮-A})) ∘app : ∀ {ℓA ℓB ℓ≅B ℓC ℓ≅C} - {A : Type ℓA} - {B : Type ℓB} {𝒮-B : UARel B ℓ≅B} - {C : Type ℓC} {𝒮-C : UARel C ℓ≅C} + {A : Type ℓA} + {B : Type ℓB} {𝒮-B : UARel B ℓ≅B} + {C : Type ℓC} {𝒮-C : UARel C ℓ≅C} {f : UARelHom 𝒮-B 𝒮-C} → UARelReindex f → (a : A) → UARelReindex (𝒮-∘ f (𝒮-app a)) data SubstRelDesc : ∀ {ℓA ℓ≅A ℓB} - {A : Type ℓA} (𝒮-A : UARel A ℓ≅A) - {B : A → Type ℓB} (𝒮ˢ-B : SubstRel 𝒮-A B) → Typeω + {A : Type ℓA} (𝒮-A : UARel A ℓ≅A) + {B : A → Type ℓB} (𝒮ˢ-B : SubstRel 𝒮-A B) → Typeω where - generic : ∀ {ℓA ℓ≅A ℓB} {A : Type ℓA} {𝒮-A : UARel A ℓ≅A} {B : A → Type ℓB} + generic : ∀ {ℓA ℓ≅A ℓB} {A : Type ℓA} {𝒮-A : UARel A ℓ≅A} {B : A → Type ℓB} → SubstRelDesc 𝒮-A (𝒮ˢ-generic 𝒮-A B) constant : ∀ {ℓA ℓ≅A ℓB} - {A : Type ℓA} {𝒮-A : UARel A ℓ≅A} {B : Type ℓB} + {A : Type ℓA} {𝒮-A : UARel A ℓ≅A} {B : Type ℓB} → SubstRelDesc 𝒮-A (𝒮ˢ-const 𝒮-A B) -- We have an element DUARel over any 𝒮-A with a proejction to a universe -- that can be described with UARelReindex - el : ∀ {ℓA ℓ≅A ℓU} {A : Type ℓA} {𝒮-A : UARel A ℓ≅A} + el : ∀ {ℓA ℓ≅A ℓU} {A : Type ℓA} {𝒮-A : UARel A ℓ≅A} {f : UARelHom 𝒮-A (𝒮-Univ ℓU)} → UARelReindex f → SubstRelDesc 𝒮-A (𝒮ˢ-reindex f (𝒮ˢ-El ℓU)) prod : ∀ {ℓA ℓ≅A ℓB ℓC} - {A : Type ℓA} {𝒮-A : UARel A ℓ≅A} - {B : A → Type ℓB} {𝒮ˢ-B : SubstRel 𝒮-A B} (dB : SubstRelDesc 𝒮-A 𝒮ˢ-B) - {C : A → Type ℓC} {𝒮ˢ-C : SubstRel 𝒮-A C} (dC : SubstRelDesc 𝒮-A 𝒮ˢ-C) + {A : Type ℓA} {𝒮-A : UARel A ℓ≅A} + {B : A → Type ℓB} {𝒮ˢ-B : SubstRel 𝒮-A B} (dB : SubstRelDesc 𝒮-A 𝒮ˢ-B) + {C : A → Type ℓC} {𝒮ˢ-C : SubstRel 𝒮-A C} (dC : SubstRelDesc 𝒮-A 𝒮ˢ-C) → SubstRelDesc 𝒮-A (𝒮ˢ-B ×𝒮ˢ 𝒮ˢ-C) sigma : ∀ {ℓA ℓ≅A ℓB ℓC} - {A : Type ℓA} {𝒮-A : UARel A ℓ≅A} - {B : A → Type ℓB} {𝒮ˢ-B : SubstRel 𝒮-A B} (dB : SubstRelDesc 𝒮-A 𝒮ˢ-B) - {C : Σ A B → Type ℓC} {𝒮ˢ-C : SubstRel (∫ˢ 𝒮ˢ-B) C} (dC : SubstRelDesc (∫ˢ 𝒮ˢ-B) 𝒮ˢ-C) + {A : Type ℓA} {𝒮-A : UARel A ℓ≅A} + {B : A → Type ℓB} {𝒮ˢ-B : SubstRel 𝒮-A B} (dB : SubstRelDesc 𝒮-A 𝒮ˢ-B) + {C : Σ A B → Type ℓC} {𝒮ˢ-C : SubstRel (∫ˢ 𝒮ˢ-B) C} (dC : SubstRelDesc (∫ˢ 𝒮ˢ-B) 𝒮ˢ-C) → SubstRelDesc 𝒮-A (𝒮ˢ-Σ 𝒮ˢ-B 𝒮ˢ-C) pi : ∀ {ℓA ℓ≅A ℓB ℓC} - {A : Type ℓA} {𝒮-A : UARel A ℓ≅A} - {B : A → Type ℓB} {𝒮ˢ-B : SubstRel 𝒮-A B} (dB : SubstRelDesc 𝒮-A 𝒮ˢ-B) - {C : Σ A B → Type ℓC} {𝒮ˢ-C : SubstRel (∫ˢ 𝒮ˢ-B) C} (dC : SubstRelDesc (∫ˢ 𝒮ˢ-B) 𝒮ˢ-C) + {A : Type ℓA} {𝒮-A : UARel A ℓ≅A} + {B : A → Type ℓB} {𝒮ˢ-B : SubstRel 𝒮-A B} (dB : SubstRelDesc 𝒮-A 𝒮ˢ-B) + {C : Σ A B → Type ℓC} {𝒮ˢ-C : SubstRel (∫ˢ 𝒮ˢ-B) C} (dC : SubstRelDesc (∫ˢ 𝒮ˢ-B) 𝒮ˢ-C) → SubstRelDesc 𝒮-A (𝒮ˢ-Π 𝒮ˢ-B 𝒮ˢ-C) data DUARelDesc : ∀ {ℓA ℓ≅A ℓB ℓ≅B} - {A : Type ℓA} (𝒮-A : UARel A ℓ≅A) - {B : A → Type ℓB} (𝒮ᴰ-B : DUARel 𝒮-A B ℓ≅B) → Typeω + {A : Type ℓA} (𝒮-A : UARel A ℓ≅A) + {B : A → Type ℓB} (𝒮ᴰ-B : DUARel 𝒮-A B ℓ≅B) → Typeω where - generic : ∀ {ℓA ℓ≅A ℓB} {A : Type ℓA} {𝒮-A : UARel A ℓ≅A} {B : A → Type ℓB} + generic : ∀ {ℓA ℓ≅A ℓB} {A : Type ℓA} {𝒮-A : UARel A ℓ≅A} {B : A → Type ℓB} → DUARelDesc 𝒮-A (𝒮ᴰ-generic 𝒮-A B) constant : ∀ {ℓA ℓ≅A ℓB ℓ≅B} - {A : Type ℓA} {𝒮-A : UARel A ℓ≅A} - {B : Type ℓB} {𝒮-B : UARel B ℓ≅B} + {A : Type ℓA} {𝒮-A : UARel A ℓ≅A} + {B : Type ℓB} {𝒮-B : UARel B ℓ≅B} → UARelDesc 𝒮-B → DUARelDesc 𝒮-A (𝒮ᴰ-const 𝒮-A 𝒮-B) - el : ∀ {ℓA ℓ≅A ℓU} {A : Type ℓA} {𝒮-A : UARel A ℓ≅A} + el : ∀ {ℓA ℓ≅A ℓU} {A : Type ℓA} {𝒮-A : UARel A ℓ≅A} {f : UARelHom 𝒮-A (𝒮-Univ ℓU)} → UARelReindex f → DUARelDesc 𝒮-A (𝒮ᴰ-reindex f (𝒮ᴰ-El ℓU)) prod : ∀ {ℓA ℓ≅A ℓB ℓ≅B ℓC ℓ≅C} - {A : Type ℓA} {𝒮-A : UARel A ℓ≅A} - {B : A → Type ℓB} {𝒮ᴰ-B : DUARel 𝒮-A B ℓ≅B} (dB : DUARelDesc 𝒮-A 𝒮ᴰ-B) - {C : A → Type ℓC} {𝒮ᴰ-C : DUARel 𝒮-A C ℓ≅C} (dC : DUARelDesc 𝒮-A 𝒮ᴰ-C) + {A : Type ℓA} {𝒮-A : UARel A ℓ≅A} + {B : A → Type ℓB} {𝒮ᴰ-B : DUARel 𝒮-A B ℓ≅B} (dB : DUARelDesc 𝒮-A 𝒮ᴰ-B) + {C : A → Type ℓC} {𝒮ᴰ-C : DUARel 𝒮-A C ℓ≅C} (dC : DUARelDesc 𝒮-A 𝒮ᴰ-C) → DUARelDesc 𝒮-A (𝒮ᴰ-B ×𝒮ᴰ 𝒮ᴰ-C) sigma : ∀ {ℓA ℓ≅A ℓB ℓ≅B ℓC ℓ≅C} - {A : Type ℓA} {𝒮-A : UARel A ℓ≅A} - {B : A → Type ℓB} {𝒮ᴰ-B : DUARel 𝒮-A B ℓ≅B} (dB : DUARelDesc 𝒮-A 𝒮ᴰ-B) - {C : Σ A B → Type ℓC} {𝒮ᴰ-C : DUARel (∫ 𝒮ᴰ-B) C ℓ≅C} (dC : DUARelDesc (∫ 𝒮ᴰ-B) 𝒮ᴰ-C) + {A : Type ℓA} {𝒮-A : UARel A ℓ≅A} + {B : A → Type ℓB} {𝒮ᴰ-B : DUARel 𝒮-A B ℓ≅B} (dB : DUARelDesc 𝒮-A 𝒮ᴰ-B) + {C : Σ A B → Type ℓC} {𝒮ᴰ-C : DUARel (∫ 𝒮ᴰ-B) C ℓ≅C} (dC : DUARelDesc (∫ 𝒮ᴰ-B) 𝒮ᴰ-C) → DUARelDesc 𝒮-A (𝒮ᴰ-Σ 𝒮ᴰ-B 𝒮ᴰ-C) pi : ∀ {ℓA ℓ≅A ℓB ℓ≅B ℓC ℓ≅C} - {A : Type ℓA} {𝒮-A : UARel A ℓ≅A} - {B : A → Type ℓB} {𝒮ᴰ-B : DUARel 𝒮-A B ℓ≅B} (dB : DUARelDesc 𝒮-A 𝒮ᴰ-B) - {C : Σ A B → Type ℓC} {𝒮ᴰ-C : DUARel (∫ 𝒮ᴰ-B) C ℓ≅C} (dC : DUARelDesc (∫ 𝒮ᴰ-B) 𝒮ᴰ-C) + {A : Type ℓA} {𝒮-A : UARel A ℓ≅A} + {B : A → Type ℓB} {𝒮ᴰ-B : DUARel 𝒮-A B ℓ≅B} (dB : DUARelDesc 𝒮-A 𝒮ᴰ-B) + {C : Σ A B → Type ℓC} {𝒮ᴰ-C : DUARel (∫ 𝒮ᴰ-B) C ℓ≅C} (dC : DUARelDesc (∫ 𝒮ᴰ-B) 𝒮ᴰ-C) → DUARelDesc 𝒮-A (𝒮ᴰ-Π 𝒮ᴰ-B 𝒮ᴰ-C) piˢ : ∀ {ℓA ℓ≅A ℓB ℓC ℓ≅C} - {A : Type ℓA} {𝒮-A : UARel A ℓ≅A} - {B : A → Type ℓB} {𝒮ˢ-B : SubstRel 𝒮-A B} (dB : SubstRelDesc 𝒮-A 𝒮ˢ-B) - {C : Σ A B → Type ℓC} {𝒮ᴰ-C : DUARel (∫ˢ 𝒮ˢ-B) C ℓ≅C} (dC : DUARelDesc (∫ˢ 𝒮ˢ-B) 𝒮ᴰ-C) + {A : Type ℓA} {𝒮-A : UARel A ℓ≅A} + {B : A → Type ℓB} {𝒮ˢ-B : SubstRel 𝒮-A B} (dB : SubstRelDesc 𝒮-A 𝒮ˢ-B) + {C : Σ A B → Type ℓC} {𝒮ᴰ-C : DUARel (∫ˢ 𝒮ˢ-B) C ℓ≅C} (dC : DUARelDesc (∫ˢ 𝒮ˢ-B) 𝒮ᴰ-C) → DUARelDesc 𝒮-A (𝒮ᴰ-Πˢ 𝒮ˢ-B 𝒮ᴰ-C) private - getUARel : ∀ {ℓA ℓ≅A} {A : Type ℓA} {𝒮-A : UARel A ℓ≅A} + getUARel : ∀ {ℓA ℓ≅A} {A : Type ℓA} {𝒮-A : UARel A ℓ≅A} → UARelDesc 𝒮-A → UARel A ℓ≅A getUARel {𝒮-A = 𝒮-A} _ = 𝒮-A getDUARel : ∀ {ℓA ℓ≅A ℓB ℓ≅B} - {A : Type ℓA} {𝒮-A : UARel A ℓ≅A} - {B : A → Type ℓB} {𝒮ᴰ-B : DUARel 𝒮-A B ℓ≅B} + {A : Type ℓA} {𝒮-A : UARel A ℓ≅A} + {B : A → Type ℓB} {𝒮ᴰ-B : DUARel 𝒮-A B ℓ≅B} → DUARelDesc 𝒮-A 𝒮ᴰ-B → DUARel 𝒮-A B ℓ≅B getDUARel {𝒮ᴰ-B = 𝒮ᴰ-B} _ = 𝒮ᴰ-B @@ -195,83 +195,83 @@ FUEL = 10000 mutual - autoUARelDesc : ℕ → R.Term → R.TC Unit - autoUARelDesc zero hole = R.typeError [ R.strErr "Out of fuel" ] - autoUARelDesc (suc n) hole = + autoUARelDesc : ℕ → R.Term → R.TC Unit + autoUARelDesc zero hole = R.typeError [ R.strErr "Out of fuel" ] + autoUARelDesc (suc n) hole = tryUniv <|> tryProd <|> trySigma <|> tryParam <|> tryPi <|> tryUnit <|> useGeneric where - tryUniv : R.TC Unit - tryUniv = R.unify (R.con (quote UARelDesc.univ) [ varg R.unknown ]) hole + tryUniv : R.TC Unit + tryUniv = R.unify (R.con (quote UARelDesc.univ) [ varg R.unknown ]) hole - tryBinary : R.Name → R.TC Unit + tryBinary : R.Name → R.TC Unit tryBinary name = - newMeta R.unknown >>= λ hole₁ → - newMeta R.unknown >>= λ hole₂ → - R.unify (R.con name (hole₁ v∷ hole₂ v∷ [])) hole >> + newMeta R.unknown >>= λ hole₁ → + newMeta R.unknown >>= λ hole₂ → + R.unify (R.con name (hole₁ v∷ hole₂ v∷ [])) hole >> autoUARelDesc n hole₁ >> autoDUARelDesc n hole₂ - tryParam : R.TC Unit + tryParam : R.TC Unit tryParam = - newMeta R.unknown >>= λ paramTy → - newMeta R.unknown >>= λ hole₁ → - R.unify (R.con (quote UARelDesc.param) (paramTy v∷ hole₁ v∷ [])) hole >> + newMeta R.unknown >>= λ paramTy → + newMeta R.unknown >>= λ hole₁ → + R.unify (R.con (quote UARelDesc.param) (paramTy v∷ hole₁ v∷ [])) hole >> autoUARelDesc n hole₁ tryProd = tryBinary (quote UARelDesc.prod) trySigma = tryBinary (quote UARelDesc.sigma) tryPi = tryBinary (quote UARelDesc.pi) - tryUnit : R.TC Unit - tryUnit = R.unify (R.con (quote UARelDesc.unit) []) hole + tryUnit : R.TC Unit + tryUnit = R.unify (R.con (quote UARelDesc.unit) []) hole - useGeneric : R.TC Unit - useGeneric = R.unify (R.con (quote UARelDesc.generic) []) hole + useGeneric : R.TC Unit + useGeneric = R.unify (R.con (quote UARelDesc.generic) []) hole - autoUARelReindex : ℕ → R.Term → R.TC Unit - autoUARelReindex zero hole = R.typeError [ R.strErr "Out of fuel" ] - autoUARelReindex (suc n) hole = + autoUARelReindex : ℕ → R.Term → R.TC Unit + autoUARelReindex zero hole = R.typeError [ R.strErr "Out of fuel" ] + autoUARelReindex (suc n) hole = tryId <|> tryFst <|> trySnd <|> tryApp where - tryId : R.TC Unit - tryId = R.unify (R.con (quote UARelReindex.id) []) hole + tryId : R.TC Unit + tryId = R.unify (R.con (quote UARelReindex.id) []) hole - tryUnary : R.Name → R.TC Unit + tryUnary : R.Name → R.TC Unit tryUnary name = - newMeta R.unknown >>= λ hole₁ → - R.unify (R.con name [ varg hole₁ ]) hole >> + newMeta R.unknown >>= λ hole₁ → + R.unify (R.con name [ varg hole₁ ]) hole >> autoUARelReindex n hole₁ tryFst = tryUnary (quote UARelReindex.∘fst) trySnd = tryUnary (quote UARelReindex.∘snd) - tryApp : R.TC Unit + tryApp : R.TC Unit tryApp = - newMeta R.unknown >>= λ hole₁ → - newMeta R.unknown >>= λ param → - R.unify (R.con (quote UARelReindex.∘app) (hole₁ v∷ param v∷ [])) hole >> + newMeta R.unknown >>= λ hole₁ → + newMeta R.unknown >>= λ param → + R.unify (R.con (quote UARelReindex.∘app) (hole₁ v∷ param v∷ [])) hole >> autoUARelReindex n hole₁ - autoSubstRelDesc : ℕ → R.Term → R.TC Unit - autoSubstRelDesc zero hole = R.typeError [ R.strErr "Out of fuel" ] - autoSubstRelDesc (suc n) hole = + autoSubstRelDesc : ℕ → R.Term → R.TC Unit + autoSubstRelDesc zero hole = R.typeError [ R.strErr "Out of fuel" ] + autoSubstRelDesc (suc n) hole = tryConstant <|> tryEl <|> tryProd <|> trySigma <|> tryPi <|> useGeneric where - tryConstant : R.TC Unit + tryConstant : R.TC Unit tryConstant = - R.unify (R.con (quote SubstRelDesc.constant) []) hole + R.unify (R.con (quote SubstRelDesc.constant) []) hole - tryEl : R.TC Unit + tryEl : R.TC Unit tryEl = - newMeta R.unknown >>= λ hole₁ → - R.unify (R.con (quote SubstRelDesc.el) [ varg hole₁ ]) hole >> + newMeta R.unknown >>= λ hole₁ → + R.unify (R.con (quote SubstRelDesc.el) [ varg hole₁ ]) hole >> autoUARelReindex n hole₁ - tryBinary : R.Name → R.TC Unit + tryBinary : R.Name → R.TC Unit tryBinary name = - newMeta R.unknown >>= λ hole₁ → - newMeta R.unknown >>= λ hole₂ → - R.unify (R.con name (hole₁ v∷ hole₂ v∷ [])) hole >> + newMeta R.unknown >>= λ hole₁ → + newMeta R.unknown >>= λ hole₂ → + R.unify (R.con name (hole₁ v∷ hole₂ v∷ [])) hole >> autoSubstRelDesc n hole₁ >> autoSubstRelDesc n hole₂ @@ -279,31 +279,31 @@ trySigma = tryBinary (quote SubstRelDesc.sigma) tryPi = tryBinary (quote SubstRelDesc.pi) - useGeneric : R.TC Unit - useGeneric = R.unify (R.con (quote SubstRelDesc.generic) []) hole + useGeneric : R.TC Unit + useGeneric = R.unify (R.con (quote SubstRelDesc.generic) []) hole - autoDUARelDesc : ℕ → R.Term → R.TC Unit - autoDUARelDesc zero hole = R.typeError [ R.strErr "Out of fuel" ] - autoDUARelDesc (suc n) hole = + autoDUARelDesc : ℕ → R.Term → R.TC Unit + autoDUARelDesc zero hole = R.typeError [ R.strErr "Out of fuel" ] + autoDUARelDesc (suc n) hole = tryConstant <|> tryEl <|> tryProd <|> trySigma <|> tryPiˢ <|> tryPi <|> useGeneric where - tryConstant : R.TC Unit + tryConstant : R.TC Unit tryConstant = - newMeta R.unknown >>= λ hole₁ → - R.unify (R.con (quote DUARelDesc.constant) [ varg hole₁ ]) hole >> + newMeta R.unknown >>= λ hole₁ → + R.unify (R.con (quote DUARelDesc.constant) [ varg hole₁ ]) hole >> autoUARelDesc n hole₁ - tryEl : R.TC Unit + tryEl : R.TC Unit tryEl = - newMeta R.unknown >>= λ hole₁ → - R.unify (R.con (quote DUARelDesc.el) [ varg hole₁ ]) hole >> + newMeta R.unknown >>= λ hole₁ → + R.unify (R.con (quote DUARelDesc.el) [ varg hole₁ ]) hole >> autoUARelReindex n hole₁ - tryBinary : R.Name → R.TC Unit + tryBinary : R.Name → R.TC Unit tryBinary name = - newMeta R.unknown >>= λ hole₁ → - newMeta R.unknown >>= λ hole₂ → - R.unify (R.con name (hole₁ v∷ hole₂ v∷ [])) hole >> + newMeta R.unknown >>= λ hole₁ → + newMeta R.unknown >>= λ hole₂ → + R.unify (R.con name (hole₁ v∷ hole₂ v∷ [])) hole >> autoDUARelDesc n hole₁ >> autoDUARelDesc n hole₂ @@ -311,81 +311,81 @@ trySigma = tryBinary (quote DUARelDesc.sigma) tryPi = tryBinary (quote DUARelDesc.pi) - tryPiˢ : R.TC Unit + tryPiˢ : R.TC Unit tryPiˢ = - newMeta R.unknown >>= λ hole₁ → - newMeta R.unknown >>= λ hole₂ → - R.unify (R.con (quote DUARelDesc.piˢ) (hole₁ v∷ hole₂ v∷ [])) hole >> + newMeta R.unknown >>= λ hole₁ → + newMeta R.unknown >>= λ hole₂ → + R.unify (R.con (quote DUARelDesc.piˢ) (hole₁ v∷ hole₂ v∷ [])) hole >> autoSubstRelDesc n hole₁ >> autoDUARelDesc n hole₂ - useGeneric : R.TC Unit - useGeneric = R.unify (R.con (quote DUARelDesc.generic) []) hole + useGeneric : R.TC Unit + useGeneric = R.unify (R.con (quote DUARelDesc.generic) []) hole module DisplayedAutoMacro where - autoUARel : ∀ {ℓA} (A : Type ℓA) → ℕ → R.Term → R.TC Unit + autoUARel : ∀ {ℓA} (A : Type ℓA) → ℕ → R.Term → R.TC Unit autoUARel A n hole = - R.quoteTC A >>= λ `A` → - newMeta R.unknown >>= λ desc → + R.quoteTC A >>= λ `A` → + newMeta R.unknown >>= λ desc → makeAuxiliaryDef "autoUA" - (R.def (quote UARel) (`A` v∷ R.unknown v∷ [])) - (R.def (quote getUARel) [ varg desc ]) + (R.def (quote UARel) (`A` v∷ R.unknown v∷ [])) + (R.def (quote getUARel) [ varg desc ]) >>= λ uaTerm → - R.unify hole uaTerm >> + R.unify hole uaTerm >> autoUARelDesc n desc - autoDUARel : ∀ {ℓA ℓ≅A ℓB} {A : Type ℓA} (𝒮-A : UARel A ℓ≅A) (B : A → Type ℓB) - → ℕ → R.Term → R.TC Unit + autoDUARel : ∀ {ℓA ℓ≅A ℓB} {A : Type ℓA} (𝒮-A : UARel A ℓ≅A) (B : A → Type ℓB) + → ℕ → R.Term → R.TC Unit autoDUARel 𝒮-A B n hole = - R.quoteTC 𝒮-A >>= λ `𝒮-A` → - R.quoteTC B >>= λ `B` → - newMeta R.unknown >>= λ desc → + R.quoteTC 𝒮-A >>= λ `𝒮-A` → + R.quoteTC B >>= λ `B` → + newMeta R.unknown >>= λ desc → makeAuxiliaryDef "autoDUA" - (R.def (quote DUARel) (`𝒮-A` v∷ `B` v∷ R.unknown v∷ [])) - (R.def (quote getDUARel) [ varg desc ]) + (R.def (quote DUARel) (`𝒮-A` v∷ `B` v∷ R.unknown v∷ [])) + (R.def (quote getDUARel) [ varg desc ]) >>= λ duaTerm → - R.unify hole duaTerm >> + R.unify hole duaTerm >> autoDUARelDesc n desc macro - autoUARel : ∀ {ℓA} (A : Type ℓA) → R.Term → R.TC Unit + autoUARel : ∀ {ℓA} (A : Type ℓA) → R.Term → R.TC Unit autoUARel A = DisplayedAutoMacro.autoUARel A FUEL - autoDUARel : ∀ {ℓA ℓ≅A ℓB} {A : Type ℓA} (𝒮-A : UARel A ℓ≅A) (B : A → Type ℓB) - → R.Term → R.TC Unit + autoDUARel : ∀ {ℓA ℓ≅A ℓB} {A : Type ℓA} (𝒮-A : UARel A ℓ≅A) (B : A → Type ℓB) + → R.Term → R.TC Unit autoDUARel 𝒮-A B = DisplayedAutoMacro.autoDUARel 𝒮-A B FUEL private - module Example (A : Type) (a₀ : A) where + module Example (A : Type) (a₀ : A) where - example0 : DUARel (autoUARel Type) (λ X → X → A × X) ℓ-zero + example0 : DUARel (autoUARel Type) (λ X → X → A × X) ℓ-zero example0 = autoDUARel _ _ - example0' : {X Y : Type} (e : X ≃ Y) + example0' : {X Y : Type} (e : X ≃ Y) (f : X → A × X) (g : Y → A × Y) - → (∀ x → (f x .fst ≡ g (e .fst x) .fst) × (e .fst (f x .snd) ≡ g (e .fst x) .snd)) + → (∀ x → (f x .fst ≡ g (e .fst x) .fst) × (e .fst (f x .snd) ≡ g (e .fst x) .snd)) → PathP (λ i → ua e i → A × ua e i) f g - example0' e f g = example0 .DUARel.uaᴰ f e g .fst + example0' e f g = example0 .DUARel.uaᴰ f e g .fst -- An example where a DUARel is parameterized over a pair of types - example1 : DUARel (autoUARel (Type × Type)) (λ (X , Z) → X → Z) ℓ-zero + example1 : DUARel (autoUARel (Type × Type)) (λ (X , Z) → X → Z) ℓ-zero example1 = autoDUARel _ _ - example1' : {X Y : Type} (e : X ≃ Y) {Z W : Type} (h : Z ≃ W) + example1' : {X Y : Type} (e : X ≃ Y) {Z W : Type} (h : Z ≃ W) (f : X → Z) (g : Y → W) - → (∀ x → h .fst (f x) ≡ g (e .fst x)) + → (∀ x → h .fst (f x) ≡ g (e .fst x)) → PathP (λ i → ua e i → ua h i) f g - example1' e h f g = example1 .DUARel.uaᴰ f (e , h) g .fst + example1' e h f g = example1 .DUARel.uaᴰ f (e , h) g .fst -- An example where a DUARel is parameterized over a family of types - example2 : DUARel (autoUARel (A → Type)) (λ B → B a₀) ℓ-zero + example2 : DUARel (autoUARel (A → Type)) (λ B → B a₀) ℓ-zero example2 = autoDUARel _ _ - example2' : {B C : A → Type} (e : (a : A) → B a ≃ C a) + example2' : {B C : A → Type} (e : (a : A) → B a ≃ C a) (b : B a₀) (c : C a₀) - → e a₀ .fst b ≡ c + → e a₀ .fst b ≡ c → PathP (λ i → ua (e a₀) i) b c - example2' e b c = example2 .DUARel.uaᴰ b e c .fst + example2' e b c = example2 .DUARel.uaᴰ b e c .fst \ No newline at end of file diff --git a/docs/Cubical.Displayed.Base.html b/docs/Cubical.Displayed.Base.html index 097185c..403e9ba 100644 --- a/docs/Cubical.Displayed.Base.html +++ b/docs/Cubical.Displayed.Base.html @@ -18,14 +18,14 @@ private variable - ℓ ℓA ℓA' ℓ≅A ℓB ℓB' ℓ≅B ℓC ℓ≅C : Level + ℓ ℓA ℓA' ℓ≅A ℓB ℓB' ℓ≅B ℓC ℓ≅C : Level -record UARel (A : Type ℓA) (ℓ≅A : Level) : Type (ℓ-max ℓA (ℓ-suc ℓ≅A)) where +record UARel (A : Type ℓA) (ℓ≅A : Level) : Type (ℓ-max ℓA (ℓ-suc ℓ≅A)) where no-eta-equality constructor uarel field - _≅_ : A → A → Type ℓ≅A - ua : (a a' : A) → (a ≅ a') ≃ (a ≡ a') + _≅_ : A → A → Type ℓ≅A + ua : (a a' : A) → (a ≅ a') ≃ (a ≡ a') uaIso : (a a' : A) → Iso (a ≅ a') (a ≡ a') uaIso a a' = equivToIso (ua a a') @@ -38,32 +38,32 @@ ρ : (a : A) → a ≅ a ρ a = ≡→≅ refl -open BinaryRelation +open BinaryRelation -- another constructor for UARel using contractibility of relational singletons -make-𝒮 : {A : Type ℓA} {_≅_ : A → A → Type ℓ≅A} - (ρ : isRefl _≅_) (contrTotal : contrRelSingl _≅_) → UARel A ℓ≅A +make-𝒮 : {A : Type ℓA} {_≅_ : A → A → Type ℓ≅A} + (ρ : isRefl _≅_) (contrTotal : contrRelSingl _≅_) → UARel A ℓ≅A UARel._≅_ (make-𝒮 {_≅_ = _≅_} _ _) = _≅_ -UARel.ua (make-𝒮 {_≅_ = _≅_} ρ c) = contrRelSingl→isUnivalent _≅_ ρ c +UARel.ua (make-𝒮 {_≅_ = _≅_} ρ c) = contrRelSingl→isUnivalent _≅_ ρ c -record DUARel {A : Type ℓA} (𝒮-A : UARel A ℓ≅A) - (B : A → Type ℓB) (ℓ≅B : Level) : Type (ℓ-max (ℓ-max ℓA ℓB) (ℓ-max ℓ≅A (ℓ-suc ℓ≅B))) where +record DUARel {A : Type ℓA} (𝒮-A : UARel A ℓ≅A) + (B : A → Type ℓB) (ℓ≅B : Level) : Type (ℓ-max (ℓ-max ℓA ℓB) (ℓ-max ℓ≅A (ℓ-suc ℓ≅B))) where no-eta-equality constructor duarel open UARel 𝒮-A field - _≅ᴰ⟨_⟩_ : {a a' : A} → B a → a ≅ a' → B a' → Type ℓ≅B - uaᴰ : {a a' : A} (b : B a) (p : a ≅ a') (b' : B a') → (b ≅ᴰ⟨ p ⟩ b') ≃ PathP (λ i → B (≅→≡ p i)) b b' + _≅ᴰ⟨_⟩_ : {a a' : A} → B a → a ≅ a' → B a' → Type ℓ≅B + uaᴰ : {a a' : A} (b : B a) (p : a ≅ a') (b' : B a') → (b ≅ᴰ⟨ p ⟩ b') ≃ PathP (λ i → B (≅→≡ p i)) b b' - fiberRel : (a : A) → Rel (B a) (B a) ℓ≅B + fiberRel : (a : A) → Rel (B a) (B a) ℓ≅B fiberRel a = _≅ᴰ⟨ ρ a ⟩_ - uaᴰρ : {a : A} (b b' : B a) → b ≅ᴰ⟨ ρ a ⟩ b' ≃ (b ≡ b') + uaᴰρ : {a : A} (b b' : B a) → b ≅ᴰ⟨ ρ a ⟩ b' ≃ (b ≡ b') uaᴰρ {a} b b' = compEquiv (uaᴰ b (ρ _) b') - (substEquiv (λ q → PathP (λ i → B (q i)) b b') (secEq (ua a a) refl)) + (substEquiv (λ q → PathP (λ i → B (q i)) b b') (secEq (ua a a) refl)) ρᴰ : {a : A} → (b : B a) → b ≅ᴰ⟨ ρ a ⟩ b ρᴰ {a} b = invEq (uaᴰρ b b) refl @@ -71,19 +71,19 @@ -- total UARel induced by a DUARel -module _ {A : Type ℓA} {𝒮-A : UARel A ℓ≅A} - {B : A → Type ℓB} {ℓ≅B : Level} +module _ {A : Type ℓA} {𝒮-A : UARel A ℓ≅A} + {B : A → Type ℓB} {ℓ≅B : Level} (𝒮ᴰ-B : DUARel 𝒮-A B ℓ≅B) where open UARel 𝒮-A open DUARel 𝒮ᴰ-B - ∫ : UARel (Σ A B) (ℓ-max ℓ≅A ℓ≅B) - UARel._≅_ ∫ (a , b) (a' , b') = Σ[ p ∈ a ≅ a' ] (b ≅ᴰ⟨ p ⟩ b') - UARel.ua ∫ (a , b) (a' , b') = + ∫ : UARel (Σ A B) (ℓ-max ℓ≅A ℓ≅B) + UARel._≅_ ∫ (a , b) (a' , b') = Σ[ p ∈ a ≅ a' ] (b ≅ᴰ⟨ p ⟩ b') + UARel.ua ∫ (a , b) (a' , b') = compEquiv - (Σ-cong-equiv (ua a a') (λ p → uaᴰ b p b')) + (Σ-cong-equiv (ua a a') (λ p → uaᴰ b p b')) ΣPath≃PathΣ \ No newline at end of file diff --git a/docs/Cubical.Displayed.Constant.html b/docs/Cubical.Displayed.Constant.html index b3877e5..35fe12c 100644 --- a/docs/Cubical.Displayed.Constant.html +++ b/docs/Cubical.Displayed.Constant.html @@ -15,12 +15,12 @@ private variable - ℓ ℓA ℓA' ℓP ℓ≅A ℓ≅A' ℓB ℓB' ℓ≅B ℓ≅B' ℓC ℓ≅C : Level + ℓ ℓA ℓA' ℓP ℓ≅A ℓ≅A' ℓB ℓB' ℓ≅B ℓ≅B' ℓC ℓ≅C : Level -- constant DUARel -module _ {A : Type ℓA} (𝒮-A : UARel A ℓ≅A) - {B : Type ℓB} (𝒮-B : UARel B ℓ≅B) where +module _ {A : Type ℓA} (𝒮-A : UARel A ℓ≅A) + {B : Type ℓB} (𝒮-B : UARel B ℓ≅B) where open UARel 𝒮-B open DUARel @@ -31,11 +31,11 @@ -- SubstRel for an arbitrary constant family -module _ {A : Type ℓA} (𝒮-A : UARel A ℓ≅A) (B : Type ℓB) where +module _ {A : Type ℓA} (𝒮-A : UARel A ℓ≅A) (B : Type ℓB) where open SubstRel 𝒮ˢ-const : SubstRel 𝒮-A (λ _ → B) 𝒮ˢ-const .SubstRel.act _ = idEquiv B - 𝒮ˢ-const .SubstRel.uaˢ p b = transportRefl b + 𝒮ˢ-const .SubstRel.uaˢ p b = transportRefl b \ No newline at end of file diff --git a/docs/Cubical.Displayed.Function.html b/docs/Cubical.Displayed.Function.html index 8108c99..bde1c04 100644 --- a/docs/Cubical.Displayed.Function.html +++ b/docs/Cubical.Displayed.Function.html @@ -24,17 +24,17 @@ private variable - ℓA ℓ≅A ℓB ℓ≅B ℓC ℓ≅C : Level + ℓA ℓ≅A ℓB ℓ≅B ℓC ℓ≅C : Level -- UARel on dependent function type -- from UARel on domain and DUARel on codomain -module _ {A : Type ℓA} (𝒮-A : UARel A ℓ≅A) {B : A → Type ℓB} (𝒮ᴰ-B : DUARel 𝒮-A B ℓ≅B) where +module _ {A : Type ℓA} (𝒮-A : UARel A ℓ≅A) {B : A → Type ℓB} (𝒮ᴰ-B : DUARel 𝒮-A B ℓ≅B) where open UARel 𝒮-A open DUARel 𝒮ᴰ-B - 𝒮-Π : UARel ((a : A) → B a) (ℓ-max ℓA ℓ≅B) + 𝒮-Π : UARel ((a : A) → B a) (ℓ-max ℓA ℓ≅B) UARel._≅_ 𝒮-Π f f' = ∀ a → f a ≅ᴰ⟨ ρ a ⟩ f' a UARel.ua 𝒮-Π f f' = compEquiv @@ -43,14 +43,14 @@ -- Parameterize UARel by type -_→𝒮_ : (A : Type ℓA) {B : Type ℓB} (𝒮-B : UARel B ℓ≅B) → UARel (A → B) (ℓ-max ℓA ℓ≅B) +_→𝒮_ : (A : Type ℓA) {B : Type ℓB} (𝒮-B : UARel B ℓ≅B) → UARel (A → B) (ℓ-max ℓA ℓ≅B) (A →𝒮 𝒮-B) .UARel._≅_ f f' = ∀ a → 𝒮-B .UARel._≅_ (f a) (f' a) (A →𝒮 𝒮-B) .UARel.ua f f' = compEquiv (equivΠCod λ a → 𝒮-B .UARel.ua (f a) (f' a)) funExtEquiv -𝒮-app : {A : Type ℓA} {B : Type ℓB} {𝒮-B : UARel B ℓ≅B} +𝒮-app : {A : Type ℓA} {B : Type ℓB} {𝒮-B : UARel B ℓ≅B} → A → UARelHom (A →𝒮 𝒮-B) 𝒮-B 𝒮-app a .UARelHom.fun f = f a 𝒮-app a .UARelHom.rel h = h a @@ -59,9 +59,9 @@ -- DUARel on dependent function type -- from DUARels on domain and codomain -module _ {A : Type ℓA} {𝒮-A : UARel A ℓ≅A} - {B : A → Type ℓB} (𝒮ᴰ-B : DUARel 𝒮-A B ℓ≅B) - {C : (a : A) → B a → Type ℓC} (𝒮ᴰ-C : DUARel (∫ 𝒮ᴰ-B) (uncurry C) ℓ≅C) +module _ {A : Type ℓA} {𝒮-A : UARel A ℓ≅A} + {B : A → Type ℓB} (𝒮ᴰ-B : DUARel 𝒮-A B ℓ≅B) + {C : (a : A) → B a → Type ℓC} (𝒮ᴰ-C : DUARel (∫ 𝒮ᴰ-B) (uncurry C) ℓ≅C) where open UARel 𝒮-A @@ -69,51 +69,51 @@ module B = DUARel 𝒮ᴰ-B module C = DUARel 𝒮ᴰ-C - 𝒮ᴰ-Π : DUARel 𝒮-A (λ a → (b : B a) → C a b) (ℓ-max (ℓ-max ℓB ℓ≅B) ℓ≅C) + 𝒮ᴰ-Π : DUARel 𝒮-A (λ a → (b : B a) → C a b) (ℓ-max (ℓ-max ℓB ℓ≅B) ℓ≅C) DUARel._≅ᴰ⟨_⟩_ 𝒮ᴰ-Π f p f' = - ∀ {b b'} (q : b B.≅ᴰ⟨ p ⟩ b') → f b C.≅ᴰ⟨ p , q ⟩ f' b' + ∀ {b b'} (q : b B.≅ᴰ⟨ p ⟩ b') → f b C.≅ᴰ⟨ p , q ⟩ f' b' DUARel.uaᴰ 𝒮ᴰ-Π f p f' = compEquiv (equivImplicitΠCod λ {b} → (equivImplicitΠCod λ {b'} → - (equivΠ (B.uaᴰ b p b') (λ q → C.uaᴰ (f b) (p , q) (f' b'))))) + (equivΠ (B.uaᴰ b p b') (λ q → C.uaᴰ (f b) (p , q) (f' b'))))) funExtDepEquiv -_→𝒮ᴰ_ : {A : Type ℓA} {𝒮-A : UARel A ℓ≅A} - {B : A → Type ℓB} (𝒮ᴰ-B : DUARel 𝒮-A B ℓ≅B) - {C : A → Type ℓC} (𝒮ᴰ-C : DUARel 𝒮-A C ℓ≅C) - → DUARel 𝒮-A (λ a → B a → C a) (ℓ-max (ℓ-max ℓB ℓ≅B) ℓ≅C) +_→𝒮ᴰ_ : {A : Type ℓA} {𝒮-A : UARel A ℓ≅A} + {B : A → Type ℓB} (𝒮ᴰ-B : DUARel 𝒮-A B ℓ≅B) + {C : A → Type ℓC} (𝒮ᴰ-C : DUARel 𝒮-A C ℓ≅C) + → DUARel 𝒮-A (λ a → B a → C a) (ℓ-max (ℓ-max ℓB ℓ≅B) ℓ≅C) 𝒮ᴰ-B →𝒮ᴰ 𝒮ᴰ-C = 𝒮ᴰ-Π 𝒮ᴰ-B (𝒮ᴰ-Lift _ 𝒮ᴰ-C 𝒮ᴰ-B) -- DUARel on dependent function type -- from a SubstRel on the domain and DUARel on the codomain -module _ {A : Type ℓA} {𝒮-A : UARel A ℓ≅A} - {B : A → Type ℓB} (𝒮ˢ-B : SubstRel 𝒮-A B) - {C : (a : A) → B a → Type ℓC} (𝒮ᴰ-C : DUARel (∫ˢ 𝒮ˢ-B) (uncurry C) ℓ≅C) +module _ {A : Type ℓA} {𝒮-A : UARel A ℓ≅A} + {B : A → Type ℓB} (𝒮ˢ-B : SubstRel 𝒮-A B) + {C : (a : A) → B a → Type ℓC} (𝒮ᴰ-C : DUARel (∫ˢ 𝒮ˢ-B) (uncurry C) ℓ≅C) where open UARel 𝒮-A open SubstRel 𝒮ˢ-B open DUARel 𝒮ᴰ-C - 𝒮ᴰ-Πˢ : DUARel 𝒮-A (λ a → (b : B a) → C a b) (ℓ-max ℓB ℓ≅C) + 𝒮ᴰ-Πˢ : DUARel 𝒮-A (λ a → (b : B a) → C a b) (ℓ-max ℓB ℓ≅C) DUARel._≅ᴰ⟨_⟩_ 𝒮ᴰ-Πˢ f p f' = - (b : B _) → f b ≅ᴰ⟨ p , refl ⟩ f' (act p .fst b) + (b : B _) → f b ≅ᴰ⟨ p , refl ⟩ f' (act p .fst b) DUARel.uaᴰ 𝒮ᴰ-Πˢ f p f' = compEquiv (compEquiv - (equivΠCod λ b → Jequiv (λ b' q → f b ≅ᴰ⟨ p , q ⟩ f' b')) + (equivΠCod λ b → Jequiv (λ b' q → f b ≅ᴰ⟨ p , q ⟩ f' b')) (invEquiv implicit≃Explicit)) (DUARel.uaᴰ (𝒮ᴰ-Π (Subst→DUA 𝒮ˢ-B) 𝒮ᴰ-C) f p f') -- SubstRel on a dependent function type -- from a SubstRel on the domain and SubstRel on the codomain -module _ {A : Type ℓA} {𝒮-A : UARel A ℓ≅A} - {B : A → Type ℓB} (𝒮ˢ-B : SubstRel 𝒮-A B) - {C : Σ A B → Type ℓC} (𝒮ˢ-C : SubstRel (∫ˢ 𝒮ˢ-B) C) +module _ {A : Type ℓA} {𝒮-A : UARel A ℓ≅A} + {B : A → Type ℓB} (𝒮ˢ-B : SubstRel 𝒮-A B) + {C : Σ A B → Type ℓC} (𝒮ˢ-C : SubstRel (∫ˢ 𝒮ˢ-B) C) where open UARel 𝒮-A @@ -122,16 +122,16 @@ module B = SubstRel 𝒮ˢ-B module C = SubstRel 𝒮ˢ-C - 𝒮ˢ-Π : SubstRel 𝒮-A (λ a → (b : B a) → C (a , b)) - 𝒮ˢ-Π .act p = equivΠ' (B.act p) (λ q → C.act (p , q)) + 𝒮ˢ-Π : SubstRel 𝒮-A (λ a → (b : B a) → C (a , b)) + 𝒮ˢ-Π .act p = equivΠ' (B.act p) (λ q → C.act (p , q)) 𝒮ˢ-Π .uaˢ p f = - fromPathP - (DUARel.uaᴰ (𝒮ᴰ-Π (Subst→DUA 𝒮ˢ-B) (Subst→DUA 𝒮ˢ-C)) f p (equivFun (𝒮ˢ-Π .act p) f) .fst + fromPathP + (DUARel.uaᴰ (𝒮ᴰ-Π (Subst→DUA 𝒮ˢ-B) (Subst→DUA 𝒮ˢ-C)) f p (equivFun (𝒮ˢ-Π .act p) f) .fst (λ {b} → - J (λ b' q → - equivFun (C.act (p , q)) (f b) - ≡ equivFun (equivΠ' (𝒮ˢ-B .act p) (λ q → C.act (p , q))) f b') + J (λ b' q → + equivFun (C.act (p , q)) (f b) + ≡ equivFun (equivΠ' (𝒮ˢ-B .act p) (λ q → C.act (p , q))) f b') (λ i → - C.act (p , λ j → commSqIsEq (𝒮ˢ-B .act p .snd) b (~ i) j) .fst + C.act (p , λ j → commSqIsEq (𝒮ˢ-B .act p .snd) b (~ i) j) .fst (f (retEq (𝒮ˢ-B .act p) b (~ i)))))) \ No newline at end of file diff --git a/docs/Cubical.Displayed.Generic.html b/docs/Cubical.Displayed.Generic.html index e97d248..a159aa1 100644 --- a/docs/Cubical.Displayed.Generic.html +++ b/docs/Cubical.Displayed.Generic.html @@ -16,23 +16,23 @@ private variable - ℓ ℓA ℓA' ℓP ℓ≅A ℓ≅A' ℓB ℓB' ℓ≅B ℓ≅B' ℓC ℓ≅C : Level + ℓ ℓA ℓA' ℓP ℓ≅A ℓ≅A' ℓB ℓB' ℓ≅B ℓ≅B' ℓC ℓ≅C : Level -- UARel for an arbitrary type -𝒮-generic : (A : Type ℓA) → UARel A ℓA +𝒮-generic : (A : Type ℓA) → UARel A ℓA UARel._≅_ (𝒮-generic A) = _≡_ UARel.ua (𝒮-generic A) a a' = idEquiv (a ≡ a') -- DUARel for an arbitrary family -𝒮ᴰ-generic : {A : Type ℓA} (𝒮-A : UARel A ℓ≅A) (B : A → Type ℓB) → DUARel 𝒮-A B ℓB +𝒮ᴰ-generic : {A : Type ℓA} (𝒮-A : UARel A ℓ≅A) (B : A → Type ℓB) → DUARel 𝒮-A B ℓB 𝒮ᴰ-generic 𝒮-A B .DUARel._≅ᴰ⟨_⟩_ b p b' = PathP (λ i → B (UARel.≅→≡ 𝒮-A p i)) b b' 𝒮ᴰ-generic 𝒮-A B .DUARel.uaᴰ b p b' = idEquiv _ -- SubstRel for an arbitrary family -𝒮ˢ-generic : {A : Type ℓA} (𝒮-A : UARel A ℓ≅A) (B : A → Type ℓB) → SubstRel 𝒮-A B -𝒮ˢ-generic 𝒮-A B .SubstRel.act p = substEquiv B (UARel.≅→≡ 𝒮-A p) +𝒮ˢ-generic : {A : Type ℓA} (𝒮-A : UARel A ℓ≅A) (B : A → Type ℓB) → SubstRel 𝒮-A B +𝒮ˢ-generic 𝒮-A B .SubstRel.act p = substEquiv B (UARel.≅→≡ 𝒮-A p) 𝒮ˢ-generic 𝒮-A B .SubstRel.uaˢ p b = refl \ No newline at end of file diff --git a/docs/Cubical.Displayed.Morphism.html b/docs/Cubical.Displayed.Morphism.html index a9edb37..e6a8453 100644 --- a/docs/Cubical.Displayed.Morphism.html +++ b/docs/Cubical.Displayed.Morphism.html @@ -19,10 +19,10 @@ private variable - ℓ ℓA ℓA' ℓ≅A ℓB ℓB' ℓ≅B ℓC ℓ≅C : Level + ℓ ℓA ℓA' ℓ≅A ℓB ℓB' ℓ≅B ℓC ℓ≅C : Level -record UARelHom {A : Type ℓA} {B : Type ℓB} (𝒮-A : UARel A ℓ≅A) (𝒮-B : UARel B ℓ≅B) - : Type (ℓ-max (ℓ-max ℓA ℓ≅A) (ℓ-max ℓB ℓ≅B)) where +record UARelHom {A : Type ℓA} {B : Type ℓB} (𝒮-A : UARel A ℓ≅A) (𝒮-B : UARel B ℓ≅B) + : Type (ℓ-max (ℓ-max ℓA ℓ≅A) (ℓ-max ℓB ℓ≅B)) where no-eta-equality constructor uarelhom field @@ -33,22 +33,22 @@ open UARelHom -𝒮-id : {A : Type ℓA} (𝒮-A : UARel A ℓ≅A) → UARelHom 𝒮-A 𝒮-A +𝒮-id : {A : Type ℓA} (𝒮-A : UARel A ℓ≅A) → UARelHom 𝒮-A 𝒮-A 𝒮-id 𝒮-A .fun = idfun _ 𝒮-id 𝒮-A .rel = idfun _ 𝒮-id 𝒮-A .ua _ = refl -𝒮-∘ : {A : Type ℓA} {𝒮-A : UARel A ℓ≅A} {B : Type ℓB} {𝒮-B : UARel B ℓ≅B} - {C : Type ℓC} {𝒮-C : UARel C ℓ≅C} +𝒮-∘ : {A : Type ℓA} {𝒮-A : UARel A ℓ≅A} {B : Type ℓB} {𝒮-B : UARel B ℓ≅B} + {C : Type ℓC} {𝒮-C : UARel C ℓ≅C} → UARelHom 𝒮-B 𝒮-C → UARelHom 𝒮-A 𝒮-B → UARelHom 𝒮-A 𝒮-C 𝒮-∘ g f .fun = g .fun ∘ f .fun 𝒮-∘ g f .rel = g .rel ∘ f .rel 𝒮-∘ {𝒮-A = 𝒮-A} {𝒮-B = 𝒮-B} {𝒮-C = 𝒮-C} g f .ua p = - cong (cong (g .fun)) (f .ua p) ∙ g .ua (f .rel p) + cong (cong (g .fun)) (f .ua p) ∙ g .ua (f .rel p) -𝒮ᴰ-reindex : {A : Type ℓA} {𝒮-A : UARel A ℓ≅A} {B : Type ℓB} {𝒮-B : UARel B ℓ≅B} {C : B → Type ℓC} +𝒮ᴰ-reindex : {A : Type ℓA} {𝒮-A : UARel A ℓ≅A} {B : Type ℓB} {𝒮-B : UARel B ℓ≅B} {C : B → Type ℓC} (f : UARelHom 𝒮-A 𝒮-B) → DUARel 𝒮-B C ℓ≅C → DUARel 𝒮-A (C ∘ fun f) ℓ≅C @@ -56,14 +56,14 @@ 𝒮ᴰ-reindex {C = C} f 𝒮ᴰ-C .DUARel.uaᴰ c p c' = compEquiv (𝒮ᴰ-C .DUARel.uaᴰ c (f .rel p) c') - (substEquiv (λ q → PathP (λ i → C (q i)) c c') (sym (f .ua p))) + (substEquiv (λ q → PathP (λ i → C (q i)) c c') (sym (f .ua p))) -𝒮ˢ-reindex : {A : Type ℓA} {𝒮-A : UARel A ℓ≅A} {B : Type ℓB} {𝒮-B : UARel B ℓ≅B} {C : B → Type ℓC} +𝒮ˢ-reindex : {A : Type ℓA} {𝒮-A : UARel A ℓ≅A} {B : Type ℓB} {𝒮-B : UARel B ℓ≅B} {C : B → Type ℓC} (f : UARelHom 𝒮-A 𝒮-B) → SubstRel 𝒮-B C → SubstRel 𝒮-A (C ∘ fun f) 𝒮ˢ-reindex f 𝒮ˢ-C .SubstRel.act p = 𝒮ˢ-C .SubstRel.act (f .rel p) 𝒮ˢ-reindex {C = C} f 𝒮ˢ-C .SubstRel.uaˢ p c = - cong (λ q → subst C q c) (f .ua p) - ∙ 𝒮ˢ-C .SubstRel.uaˢ (f .rel p) c + cong (λ q → subst C q c) (f .ua p) + ∙ 𝒮ˢ-C .SubstRel.uaˢ (f .rel p) c \ No newline at end of file diff --git a/docs/Cubical.Displayed.Prop.html b/docs/Cubical.Displayed.Prop.html index ce1c124..4240431 100644 --- a/docs/Cubical.Displayed.Prop.html +++ b/docs/Cubical.Displayed.Prop.html @@ -19,36 +19,36 @@ private variable - ℓA ℓ≅A ℓB ℓ≅B ℓP : Level + ℓA ℓ≅A ℓB ℓ≅B ℓP : Level -𝒮-prop : (P : hProp ℓP) → UARel (P .fst) ℓ-zero +𝒮-prop : (P : hProp ℓP) → UARel (P .fst) ℓ-zero 𝒮-prop P .UARel._≅_ _ _ = Unit 𝒮-prop P .UARel.ua _ _ = - invEquiv (isContr→≃Unit (isOfHLevelPath' 0 (P .snd) _ _)) + invEquiv (isContr→≃Unit (isOfHLevelPath' 0 (P .snd) _ _)) -𝒮ᴰ-prop : {A : Type ℓA} (𝒮-A : UARel A ℓ≅A) (P : A → hProp ℓP) - → DUARel 𝒮-A (λ a → P a .fst) ℓ-zero +𝒮ᴰ-prop : {A : Type ℓA} (𝒮-A : UARel A ℓ≅A) (P : A → hProp ℓP) + → DUARel 𝒮-A (λ a → P a .fst) ℓ-zero 𝒮ᴰ-prop 𝒮-A P .DUARel._≅ᴰ⟨_⟩_ _ _ _ = Unit 𝒮ᴰ-prop 𝒮-A P .DUARel.uaᴰ _ _ _ = - invEquiv (isContr→≃Unit (isOfHLevelPathP' 0 (P _ .snd) _ _)) - -𝒮-subtype : {A : Type ℓA} (𝒮-A : UARel A ℓ≅A) {P : A → Type ℓP} - → (∀ a → isProp (P a)) - → UARel (Σ A P) ℓ≅A -𝒮-subtype 𝒮-A propP .UARel._≅_ (a , _) (a' , _) = 𝒮-A .UARel._≅_ a a' -𝒮-subtype 𝒮-A propP .UARel.ua (a , _) (a' , _) = - compEquiv (𝒮-A .UARel.ua a a') (Σ≡PropEquiv propP) - -𝒮ᴰ-subtype : {A : Type ℓA} {𝒮-A : UARel A ℓ≅A} - {B : A → Type ℓB} (𝒮ᴰ-B : DUARel 𝒮-A B ℓ≅B) - {P : (a : A) → B a → Type ℓP} - → (∀ a b → isProp (P a b)) + invEquiv (isContr→≃Unit (isOfHLevelPathP' 0 (P _ .snd) _ _)) + +𝒮-subtype : {A : Type ℓA} (𝒮-A : UARel A ℓ≅A) {P : A → Type ℓP} + → (∀ a → isProp (P a)) + → UARel (Σ A P) ℓ≅A +𝒮-subtype 𝒮-A propP .UARel._≅_ (a , _) (a' , _) = 𝒮-A .UARel._≅_ a a' +𝒮-subtype 𝒮-A propP .UARel.ua (a , _) (a' , _) = + compEquiv (𝒮-A .UARel.ua a a') (Σ≡PropEquiv propP) + +𝒮ᴰ-subtype : {A : Type ℓA} {𝒮-A : UARel A ℓ≅A} + {B : A → Type ℓB} (𝒮ᴰ-B : DUARel 𝒮-A B ℓ≅B) + {P : (a : A) → B a → Type ℓP} + → (∀ a b → isProp (P a b)) → DUARel 𝒮-A (λ a → Σ[ b ∈ B a ] (P a b)) ℓ≅B -𝒮ᴰ-subtype 𝒮ᴰ-B propP .DUARel._≅ᴰ⟨_⟩_ (b , _) p (b' , _) = 𝒮ᴰ-B .DUARel._≅ᴰ⟨_⟩_ b p b' -𝒮ᴰ-subtype 𝒮ᴰ-B propP .DUARel.uaᴰ (b , _) p (b' , _) = +𝒮ᴰ-subtype 𝒮ᴰ-B propP .DUARel._≅ᴰ⟨_⟩_ (b , _) p (b' , _) = 𝒮ᴰ-B .DUARel._≅ᴰ⟨_⟩_ b p b' +𝒮ᴰ-subtype 𝒮ᴰ-B propP .DUARel.uaᴰ (b , _) p (b' , _) = compEquiv (𝒮ᴰ-B .DUARel.uaᴰ b p b') (compEquiv - (invEquiv (Σ-contractSnd λ _ → isOfHLevelPathP' 0 (propP _ b') _ _)) + (invEquiv (Σ-contractSnd λ _ → isOfHLevelPathP' 0 (propP _ b') _ _)) ΣPath≃PathΣ) \ No newline at end of file diff --git a/docs/Cubical.Displayed.Properties.html b/docs/Cubical.Displayed.Properties.html index fe2a6b6..e1059bf 100644 --- a/docs/Cubical.Displayed.Properties.html +++ b/docs/Cubical.Displayed.Properties.html @@ -6,43 +6,43 @@ open import Cubical.Foundations.HLevels open import Cubical.Foundations.Isomorphism open import Cubical.Foundations.Equiv -open import Cubical.Foundations.Univalence using (pathToEquiv; univalence; ua-ungluePath-Equiv) +open import Cubical.Foundations.Univalence using (pathToEquiv; univalence; ua-ungluePath-Equiv) open import Cubical.Data.Unit open import Cubical.Data.Sigma open import Cubical.Relation.Binary -open BinaryRelation +open BinaryRelation open import Cubical.Displayed.Base private variable - ℓ ℓA ℓA' ℓP ℓ≅A ℓ≅A' ℓB ℓB' ℓ≅B ℓ≅B' ℓC ℓ≅C : Level + ℓ ℓA ℓA' ℓP ℓ≅A ℓ≅A' ℓB ℓB' ℓ≅B ℓ≅B' ℓC ℓ≅C : Level -- induction principles -module _ {A : Type ℓA} (𝒮-A : UARel A ℓ≅A) where +module _ {A : Type ℓA} (𝒮-A : UARel A ℓ≅A) where open UARel 𝒮-A 𝒮-J : {a : A} - (P : (a' : A) → (p : a ≡ a') → Type ℓ) + (P : (a' : A) → (p : a ≡ a') → Type ℓ) (d : P a refl) {a' : A} (p : a ≅ a') → P a' (≅→≡ p) 𝒮-J {a} P d {a'} p - = J (λ y q → P y q) + = J (λ y q → P y q) d (≅→≡ p) 𝒮-J-2 : {a : A} - (P : (a' : A) → (p : a ≅ a') → Type ℓ) + (P : (a' : A) → (p : a ≅ a') → Type ℓ) (d : P a (ρ a)) {a' : A} (p : a ≅ a') → P a' p 𝒮-J-2 {a = a} P d {a'} p - = subst (λ r → P a' r) (Iso.leftInv (uaIso a a') p) g + = subst (λ r → P a' r) (Iso.leftInv (uaIso a a') p) g where g : P a' (≡→≅ (≅→≡ p)) g = 𝒮-J (λ y q → P y (≡→≅ q)) d p @@ -50,50 +50,50 @@ -- constructors -module _ {A : Type ℓA} {𝒮-A : UARel A ℓ≅A} - {B : A → Type ℓB} - (_≅ᴰ⟨_⟩_ : {a a' : A} → B a → UARel._≅_ 𝒮-A a a' → B a' → Type ℓ≅B) +module _ {A : Type ℓA} {𝒮-A : UARel A ℓ≅A} + {B : A → Type ℓB} + (_≅ᴰ⟨_⟩_ : {a a' : A} → B a → UARel._≅_ 𝒮-A a a' → B a' → Type ℓ≅B) where open UARel 𝒮-A -- constructor that reduces ua to the case where p = ρ a by induction on p private - 𝒮ᴰ-make-aux : (uni : {a : A} (b b' : B a) → b ≅ᴰ⟨ ρ a ⟩ b' ≃ (b ≡ b')) - → ({a a' : A} (b : B a) (p : a ≅ a') (b' : B a') → (b ≅ᴰ⟨ p ⟩ b') ≃ PathP (λ i → B (≅→≡ p i)) b b') + 𝒮ᴰ-make-aux : (uni : {a : A} (b b' : B a) → b ≅ᴰ⟨ ρ a ⟩ b' ≃ (b ≡ b')) + → ({a a' : A} (b : B a) (p : a ≅ a') (b' : B a') → (b ≅ᴰ⟨ p ⟩ b') ≃ PathP (λ i → B (≅→≡ p i)) b b') 𝒮ᴰ-make-aux uni {a} {a'} b p = 𝒮-J-2 𝒮-A - (λ y q → (b' : B y) → (b ≅ᴰ⟨ q ⟩ b') ≃ PathP (λ i → B (≅→≡ q i)) b b') + (λ y q → (b' : B y) → (b ≅ᴰ⟨ q ⟩ b') ≃ PathP (λ i → B (≅→≡ q i)) b b') (λ b' → uni' b') p where g : (b' : B a) → (b ≡ b') ≡ PathP (λ i → B (≅→≡ (ρ a) i)) b b' - g b' = subst (λ r → (b ≡ b') ≡ PathP (λ i → B (r i)) b b') + g b' = subst (λ r → (b ≡ b') ≡ PathP (λ i → B (r i)) b b') (sym (Iso.rightInv (uaIso a a) refl)) refl - uni' : (b' : B a) → b ≅ᴰ⟨ ρ a ⟩ b' ≃ PathP (λ i → B (≅→≡ (ρ a) i)) b b' - uni' b' = compEquiv (uni b b') (pathToEquiv (g b')) + uni' : (b' : B a) → b ≅ᴰ⟨ ρ a ⟩ b' ≃ PathP (λ i → B (≅→≡ (ρ a) i)) b b' + uni' b' = compEquiv (uni b b') (pathToEquiv (g b')) - 𝒮ᴰ-make-1 : (uni : {a : A} (b b' : B a) → b ≅ᴰ⟨ ρ a ⟩ b' ≃ (b ≡ b')) + 𝒮ᴰ-make-1 : (uni : {a : A} (b b' : B a) → b ≅ᴰ⟨ ρ a ⟩ b' ≃ (b ≡ b')) → DUARel 𝒮-A B ℓ≅B DUARel._≅ᴰ⟨_⟩_ (𝒮ᴰ-make-1 uni) = _≅ᴰ⟨_⟩_ DUARel.uaᴰ (𝒮ᴰ-make-1 uni) = 𝒮ᴰ-make-aux uni -- constructor that reduces univalence further to contractibility of relational singletons - 𝒮ᴰ-make-2 : (ρᴰ : {a : A} → isRefl _≅ᴰ⟨ ρ a ⟩_) - (contrTotal : (a : A) → contrRelSingl _≅ᴰ⟨ ρ a ⟩_) + 𝒮ᴰ-make-2 : (ρᴰ : {a : A} → isRefl _≅ᴰ⟨ ρ a ⟩_) + (contrTotal : (a : A) → contrRelSingl _≅ᴰ⟨ ρ a ⟩_) → DUARel 𝒮-A B ℓ≅B - 𝒮ᴰ-make-2 ρᴰ contrTotal = 𝒮ᴰ-make-1 (contrRelSingl→isUnivalent _ ρᴰ (contrTotal _)) + 𝒮ᴰ-make-2 ρᴰ contrTotal = 𝒮ᴰ-make-1 (contrRelSingl→isUnivalent _ ρᴰ (contrTotal _)) -- relational isomorphisms -𝒮-iso→iso : {A : Type ℓA} (𝒮-A : UARel A ℓ≅A) - {B : Type ℓB} (𝒮-B : UARel B ℓ≅B) - (F : RelIso (UARel._≅_ 𝒮-A) (UARel._≅_ 𝒮-B)) +𝒮-iso→iso : {A : Type ℓA} (𝒮-A : UARel A ℓ≅A) + {B : Type ℓB} (𝒮-B : UARel B ℓ≅B) + (F : RelIso (UARel._≅_ 𝒮-A) (UARel._≅_ 𝒮-B)) → Iso A B 𝒮-iso→iso 𝒮-A 𝒮-B F - = RelIso→Iso (UARel._≅_ 𝒮-A) + = RelIso→Iso (UARel._≅_ 𝒮-A) (UARel._≅_ 𝒮-B) (UARel.≅→≡ 𝒮-A) (UARel.≅→≡ 𝒮-B) @@ -101,11 +101,11 @@ -- fiberwise relational isomorphisms -module _ {A : Type ℓA} {𝒮-A : UARel A ℓ≅A} - {A' : Type ℓA'} {𝒮-A' : UARel A' ℓ≅A'} +module _ {A : Type ℓA} {𝒮-A : UARel A ℓ≅A} + {A' : Type ℓA'} {𝒮-A' : UARel A' ℓ≅A'} (F : Iso A A') - {B : A → Type ℓB} (𝒮ᴰ-B : DUARel 𝒮-A B ℓ≅B) - {B' : A' → Type ℓB'} (𝒮ᴰ-B' : DUARel 𝒮-A' B' ℓ≅B') where + {B : A → Type ℓB} (𝒮ᴰ-B : DUARel 𝒮-A B ℓ≅B) + {B' : A' → Type ℓB'} (𝒮ᴰ-B' : DUARel 𝒮-A' B' ℓ≅B') where open UARel 𝒮-A open DUARel 𝒮ᴰ-B renaming (_≅ᴰ⟨_⟩_ to _≅B⟨_⟩_ @@ -123,21 +123,21 @@ -- the following can of course be done slightly more generally -- for fiberwise binary relations - F*fiberRelB' : (a : A) → Rel (B' (f a)) (B' (f a)) ℓ≅B' + F*fiberRelB' : (a : A) → Rel (B' (f a)) (B' (f a)) ℓ≅B' F*fiberRelB' a = fiberRelB' (f a) - module _ (G : (a : A) → RelIso (fiberRelB a) (F*fiberRelB' a)) where + module _ (G : (a : A) → RelIso (fiberRelB a) (F*fiberRelB' a)) where private fiberIsoOver : (a : A) → Iso (B a) (B' (f a)) fiberIsoOver a - = RelIso→Iso (fiberRelB a) + = RelIso→Iso (fiberRelB a) (F*fiberRelB' a) - (equivFun (uaᴰρB _ _)) - (equivFun (uaᴰρB' _ _)) + (equivFun (uaᴰρB _ _)) + (equivFun (uaᴰρB' _ _)) (G a) -- DUARelFiberIsoOver→TotalIso produces an isomorphism of total spaces -- from a relational isomorphism between B a and (F * B) a - 𝒮ᴰ-fiberIsoOver→totalIso : Iso (Σ A B) (Σ A' B') - 𝒮ᴰ-fiberIsoOver→totalIso = Σ-cong-iso F fiberIsoOver + 𝒮ᴰ-fiberIsoOver→totalIso : Iso (Σ A B) (Σ A' B') + 𝒮ᴰ-fiberIsoOver→totalIso = Σ-cong-iso F fiberIsoOver \ No newline at end of file diff --git a/docs/Cubical.Displayed.Record.html b/docs/Cubical.Displayed.Record.html index 721875d..60d6a1b 100644 --- a/docs/Cubical.Displayed.Record.html +++ b/docs/Cubical.Displayed.Record.html @@ -55,48 +55,48 @@ `πS` and `πS≅` are equivalences---see `𝒮ᴰ-Record` below. -} -data DUAFields {ℓA ℓ≅A ℓR ℓ≅R} {A : Type ℓA} (𝒮-A : UARel A ℓ≅A) - (R : A → Type ℓR) (_≅R⟨_⟩_ : {a a' : A} → R a → UARel._≅_ 𝒮-A a a' → R a' → Type ℓ≅R) - : ∀ {ℓS ℓ≅S} {S : A → Type ℓS} +data DUAFields {ℓA ℓ≅A ℓR ℓ≅R} {A : Type ℓA} (𝒮-A : UARel A ℓ≅A) + (R : A → Type ℓR) (_≅R⟨_⟩_ : {a a' : A} → R a → UARel._≅_ 𝒮-A a a' → R a' → Type ℓ≅R) + : ∀ {ℓS ℓ≅S} {S : A → Type ℓS} (πS : ∀ {a} → R a → S a) (𝒮ᴰ-S : DUARel 𝒮-A S ℓ≅S) (πS≅ : ∀ {a} {r : R a} {e} {r' : R a} → r ≅R⟨ e ⟩ r' → DUARel._≅ᴰ⟨_⟩_ 𝒮ᴰ-S (πS r) e (πS r')) - → Typeω + → Typeω where -- `fields:` -- Base case, no fields yet recorded in `𝒮ᴰ-S`. - fields: : DUAFields 𝒮-A R _≅R⟨_⟩_ (λ _ → tt) (𝒮ᴰ-Unit 𝒮-A) (λ _ → tt) + fields: : DUAFields 𝒮-A R _≅R⟨_⟩_ (λ _ → tt) (𝒮ᴰ-Unit 𝒮-A) (λ _ → tt) -- `… data[ πF ∣ 𝒮ᴰ-F ∣ πF≅ ]` -- Add a new field with a DURG. `πF` should be the name of the field in the structure record `R` and `πF≅` -- the name of the corresponding field in the equivalence record `_≅R⟨_⟩_`, while `𝒮ᴰ-F` is a DURG for the -- field's type over `𝒮-A`. Data fields that depend on previous fields of the record are not currently -- supported. - _data[_∣_∣_] : ∀ {ℓS ℓ≅S} {S : A → Type ℓS} + _data[_∣_∣_] : ∀ {ℓS ℓ≅S} {S : A → Type ℓS} {πS : ∀ {a} → R a → S a} {𝒮ᴰ-S : DUARel 𝒮-A S ℓ≅S} {πS≅ : ∀ {a} {r : R a} {e} {r' : R a} → r ≅R⟨ e ⟩ r' → DUARel._≅ᴰ⟨_⟩_ 𝒮ᴰ-S (πS r) e (πS r')} → DUAFields 𝒮-A R _≅R⟨_⟩_ πS 𝒮ᴰ-S πS≅ - → ∀ {ℓF ℓ≅F} {F : A → Type ℓF} + → ∀ {ℓF ℓ≅F} {F : A → Type ℓF} (πF : ∀ {a} → (r : R a) → F a) (𝒮ᴰ-F : DUARel 𝒮-A F ℓ≅F) (πF≅ : ∀ {a} {r : R a} {e} {r' : R a} (p : r ≅R⟨ e ⟩ r') → DUARel._≅ᴰ⟨_⟩_ 𝒮ᴰ-F (πF r) e (πF r')) - → DUAFields 𝒮-A R _≅R⟨_⟩_ (λ r → πS r , πF r) (𝒮ᴰ-S ×𝒮ᴰ 𝒮ᴰ-F) (λ p → πS≅ p , πF≅ p) + → DUAFields 𝒮-A R _≅R⟨_⟩_ (λ r → πS r , πF r) (𝒮ᴰ-S ×𝒮ᴰ 𝒮ᴰ-F) (λ p → πS≅ p , πF≅ p) -- `… prop[ πF ∣ propF ]` -- Add a new propositional field. `πF` should be the name of the field in the structure record `R`, while -- propF is a proof that this field is a proposition. - _prop[_∣_] : ∀ {ℓS ℓ≅S} {S : A → Type ℓS} + _prop[_∣_] : ∀ {ℓS ℓ≅S} {S : A → Type ℓS} {πS : ∀ {a} → R a → S a} {𝒮ᴰ-S : DUARel 𝒮-A S ℓ≅S} {πS≅ : ∀ {a} {r : R a} {e} {r' : R a} → r ≅R⟨ e ⟩ r' → DUARel._≅ᴰ⟨_⟩_ 𝒮ᴰ-S (πS r) e (πS r')} → DUAFields 𝒮-A R _≅R⟨_⟩_ πS 𝒮ᴰ-S πS≅ - → ∀ {ℓF} {F : (a : A) → S a → Type ℓF} + → ∀ {ℓF} {F : (a : A) → S a → Type ℓF} (πF : ∀ {a} → (r : R a) → F a (πS r)) - (propF : ∀ a s → isProp (F a s)) - → DUAFields 𝒮-A R _≅R⟨_⟩_ (λ r → πS r , πF r) (𝒮ᴰ-subtype 𝒮ᴰ-S propF) (λ p → πS≅ p) + (propF : ∀ a s → isProp (F a s)) + → DUAFields 𝒮-A R _≅R⟨_⟩_ (λ r → πS r , πF r) (𝒮ᴰ-subtype 𝒮ᴰ-S propF) (λ p → πS≅ p) -module _ {ℓA ℓ≅A} {A : Type ℓA} {𝒮-A : UARel A ℓ≅A} - {ℓR ℓ≅R} {R : A → Type ℓR} (_≅R⟨_⟩_ : {a a' : A} → R a → UARel._≅_ 𝒮-A a a' → R a' → Type ℓ≅R) - {ℓS ℓ≅S} {S : A → Type ℓS} +module _ {ℓA ℓ≅A} {A : Type ℓA} {𝒮-A : UARel A ℓ≅A} + {ℓR ℓ≅R} {R : A → Type ℓR} (_≅R⟨_⟩_ : {a a' : A} → R a → UARel._≅_ 𝒮-A a a' → R a' → Type ℓ≅R) + {ℓS ℓ≅S} {S : A → Type ℓS} {πS : ∀ {a} → R a → S a} {𝒮ᴰ-S : DUARel 𝒮-A S ℓ≅S} {πS≅ : ∀ {a} {r : R a} {e} {r' : R a} → r ≅R⟨ e ⟩ r' → DUARel._≅ᴰ⟨_⟩_ 𝒮ᴰ-S (πS r) e (πS r')} (fs : DUAFields 𝒮-A R _≅R⟨_⟩_ πS 𝒮ᴰ-S πS≅) @@ -116,22 +116,22 @@ (e≅ _ _ r p r') (compIso (equivToIso (uaᴰ (e _ .Iso.fun r) p (e _ .Iso.fun r'))) - (invIso (congPathIso λ i → isoToEquiv (e _))))) + (invIso (congPathIso λ i → isoToEquiv (e _))))) module DisplayedRecordMacro where -- Extract a name from a term - findName : R.Term → R.TC R.Name + findName : R.Term → R.TC R.Name findName t = Maybe.rec - (R.typeError (R.strErr "Not a name: " ∷ R.termErr t ∷ [])) + (R.typeError (R.strErr "Not a name: " ∷ R.termErr t ∷ [])) (λ s → s) (go t) where - go : R.Term → Maybe (R.TC R.Name) - go (R.meta x _) = just (R.blockOnMeta x) - go (R.def name _) = just (R.returnTC name) - go (R.lam _ (R.abs _ t)) = go t + go : R.Term → Maybe (R.TC R.Name) + go (R.meta x _) = just (R.blockOnMeta x) + go (R.def name _) = just (R.returnTC name) + go (R.lam _ (R.abs _ t)) = go t go t = nothing -- ℓA ℓ≅A ℓR ℓ≅R A 𝒮-A R _≅R⟨_⟩_ @@ -144,32 +144,32 @@ Takes a reflected DUAFields term as input and collects lists of structure field names and equivalence field names. (These are returned in reverse order. -} - parseFields : R.Term → R.TC (List R.Name × List R.Name) - parseFields (R.con (quote fields:) _) = R.returnTC ([] , []) - parseFields (R.con (quote _data[_∣_∣_]) (family∷ (indices∷ (fs v∷ ℓF h∷ ℓ≅F h∷ F h∷ πF v∷ 𝒮ᴰ-F v∷ πF≅ v∷ _)))) = - parseFields fs >>= λ (fs , f≅s) → + parseFields : R.Term → R.TC (List R.Name × List R.Name) + parseFields (R.con (quote fields:) _) = R.returnTC ([] , []) + parseFields (R.con (quote _data[_∣_∣_]) (family∷ (indices∷ (fs v∷ ℓF h∷ ℓ≅F h∷ F h∷ πF v∷ 𝒮ᴰ-F v∷ πF≅ v∷ _)))) = + parseFields fs >>= λ (fs , f≅s) → findName πF >>= λ f → findName πF≅ >>= λ f≅ → - R.returnTC (f ∷ fs , f≅ ∷ f≅s) - parseFields (R.con (quote _prop[_∣_]) (family∷ (indices∷ (fs v∷ ℓF h∷ F h∷ πF v∷ _)))) = - parseFields fs >>= λ (fs , f≅s) → + R.returnTC (f ∷ fs , f≅ ∷ f≅s) + parseFields (R.con (quote _prop[_∣_]) (family∷ (indices∷ (fs v∷ ℓF h∷ F h∷ πF v∷ _)))) = + parseFields fs >>= λ (fs , f≅s) → findName πF >>= λ f → - R.returnTC (f ∷ fs , f≅s) - parseFields (R.meta x _) = R.blockOnMeta x - parseFields t = R.typeError (R.strErr "Malformed specification: " ∷ R.termErr t ∷ []) + R.returnTC (f ∷ fs , f≅s) + parseFields (R.meta x _) = R.blockOnMeta x + parseFields t = R.typeError (R.strErr "Malformed specification: " ∷ R.termErr t ∷ []) {- Given a list of record field names (in reverse order), generates a ΣFormat (in the sense of Cubical.Reflection.RecordEquiv) associating the record fields with the fields of a left-associated iterated Σ-type -} - List→LeftAssoc : List R.Name → RE.ΣFormat - List→LeftAssoc [] = RE.unit - List→LeftAssoc (x ∷ xs) = List→LeftAssoc xs RE., RE.leaf x + List→LeftAssoc : List R.Name → RE.ΣFormat + List→LeftAssoc [] = RE.unit + List→LeftAssoc (x ∷ xs) = List→LeftAssoc xs RE., RE.leaf x - module _ {ℓA ℓ≅A} {A : Type ℓA} (𝒮-A : UARel A ℓ≅A) - {ℓR ℓ≅R} {R : A → Type ℓR} (≅R : {a a' : A} → R a → UARel._≅_ 𝒮-A a a' → R a' → Type ℓ≅R) - {ℓS ℓ≅S} {S : A → Type ℓS} + module _ {ℓA ℓ≅A} {A : Type ℓA} (𝒮-A : UARel A ℓ≅A) + {ℓR ℓ≅R} {R : A → Type ℓR} (≅R : {a a' : A} → R a → UARel._≅_ 𝒮-A a a' → R a' → Type ℓ≅R) + {ℓS ℓ≅S} {S : A → Type ℓS} {πS : ∀ {a} → R a → S a} {𝒮ᴰ-S : DUARel 𝒮-A S ℓ≅S} {πS≅ : ∀ {a} {r : R a} {e} {r' : R a} → ≅R r e r' → DUARel._≅ᴰ⟨_⟩_ 𝒮ᴰ-S (πS r) e (πS r')} where @@ -180,23 +180,23 @@ The proofs of equivalence are generated using Cubical.Reflection.RecordEquiv and then `𝒮ᴰ-Fields` is applied. -} - 𝒮ᴰ-Record : DUAFields 𝒮-A R ≅R πS 𝒮ᴰ-S πS≅ → R.Term → R.TC Unit + 𝒮ᴰ-Record : DUAFields 𝒮-A R ≅R πS 𝒮ᴰ-S πS≅ → R.Term → R.TC Unit 𝒮ᴰ-Record fs hole = - R.quoteTC (DUARel 𝒮-A R ℓ≅R) >>= R.checkType hole >>= λ hole → - R.quoteωTC fs >>= λ `fs` → - parseFields `fs` >>= λ (fields , ≅fields) → - R.freshName "fieldsIso" >>= λ fieldsIso → - R.freshName "≅fieldsIso" >>= λ ≅fieldsIso → - R.quoteTC R >>= R.normalise >>= λ `R` → - R.quoteTC {A = {a a' : A} → R a → UARel._≅_ 𝒮-A a a' → R a' → Type ℓ≅R} ≅R >>= R.normalise >>= λ `≅R` → + R.quoteTC (DUARel 𝒮-A R ℓ≅R) >>= R.checkType hole >>= λ hole → + R.quoteωTC fs >>= λ `fs` → + parseFields `fs` >>= λ (fields , ≅fields) → + R.freshName "fieldsIso" >>= λ fieldsIso → + R.freshName "≅fieldsIso" >>= λ ≅fieldsIso → + R.quoteTC R >>= R.normalise >>= λ `R` → + R.quoteTC {A = {a a' : A} → R a → UARel._≅_ 𝒮-A a a' → R a' → Type ℓ≅R} ≅R >>= R.normalise >>= λ `≅R` → findName `R` >>= RE.declareRecordIsoΣ' fieldsIso (List→LeftAssoc fields) >> findName `≅R` >>= RE.declareRecordIsoΣ' ≅fieldsIso (List→LeftAssoc ≅fields) >> - R.unify hole - (R.def (quote 𝒮ᴰ-Fields) + R.unify hole + (R.def (quote 𝒮ᴰ-Fields) (`≅R` v∷ `fs` v∷ - vlam "_" (R.def fieldsIso []) v∷ - vlam "a" (vlam "a'" (vlam "r" (vlam "p" (vlam "r'" (R.def ≅fieldsIso []))))) v∷ - [])) + vlam "_" (R.def fieldsIso []) v∷ + vlam "a" (vlam "a'" (vlam "r" (vlam "p" (vlam "r'" (R.def ≅fieldsIso []))))) v∷ + [])) macro 𝒮ᴰ-Record = DisplayedRecordMacro.𝒮ᴰ-Record @@ -206,7 +206,7 @@ private module Example where - record Example (A : Type) : Type where + record Example (A : Type) : Type where no-eta-equality -- works with or without eta equality field dog : A → A → A @@ -215,17 +215,17 @@ open Example - record ExampleEquiv {A B : Type} (x : Example A) (e : A ≃ B) (y : Example B) : Type where + record ExampleEquiv {A B : Type} (x : Example A) (e : A ≃ B) (y : Example B) : Type where no-eta-equality -- works with or without eta equality field - dogEq : ∀ a a' → e .fst (x .dog a a') ≡ y .dog (e .fst a) (e .fst a') - catEq : ∀ a a' → e .fst (x .cat a a') ≡ y .cat (e .fst a) (e .fst a') + dogEq : ∀ a a' → e .fst (x .dog a a') ≡ y .dog (e .fst a) (e .fst a') + catEq : ∀ a a' → e .fst (x .cat a a') ≡ y .cat (e .fst a) (e .fst a') open ExampleEquiv - example : DUARel (𝒮-Univ ℓ-zero) Example ℓ-zero + example : DUARel (𝒮-Univ ℓ-zero) Example ℓ-zero example = - 𝒮ᴰ-Record (𝒮-Univ ℓ-zero) ExampleEquiv + 𝒮ᴰ-Record (𝒮-Univ ℓ-zero) ExampleEquiv (fields: data[ dog ∣ autoDUARel _ _ ∣ dogEq ] data[ cat ∣ autoDUARel _ _ ∣ catEq ] diff --git a/docs/Cubical.Displayed.Sigma.html b/docs/Cubical.Displayed.Sigma.html index 2f170e2..285a520 100644 --- a/docs/Cubical.Displayed.Sigma.html +++ b/docs/Cubical.Displayed.Sigma.html @@ -19,44 +19,44 @@ private variable - ℓ ℓA ℓA' ℓP ℓ≅A ℓ≅A' ℓB ℓB' ℓ≅B ℓ≅B' ℓC ℓ≅C : Level + ℓ ℓA ℓA' ℓP ℓ≅A ℓ≅A' ℓB ℓB' ℓ≅B ℓ≅B' ℓC ℓ≅C : Level -- UARel on a Σ-type -∫ˢ : {A : Type ℓA} {𝒮-A : UARel A ℓ≅A} {B : A → Type ℓB} (𝒮ˢ-B : SubstRel 𝒮-A B) - → UARel (Σ A B) (ℓ-max ℓ≅A ℓB) +∫ˢ : {A : Type ℓA} {𝒮-A : UARel A ℓ≅A} {B : A → Type ℓB} (𝒮ˢ-B : SubstRel 𝒮-A B) + → UARel (Σ A B) (ℓ-max ℓ≅A ℓB) ∫ˢ 𝒮ˢ-B = ∫ (Subst→DUA 𝒮ˢ-B) -_×𝒮_ : {A : Type ℓA} (𝒮-A : UARel A ℓ≅A) {B : Type ℓB} (𝒮-B : UARel B ℓ≅B) - → UARel (A × B) (ℓ-max ℓ≅A ℓ≅B) +_×𝒮_ : {A : Type ℓA} (𝒮-A : UARel A ℓ≅A) {B : Type ℓB} (𝒮-B : UARel B ℓ≅B) + → UARel (A × B) (ℓ-max ℓ≅A ℓ≅B) 𝒮-A ×𝒮 𝒮-B = ∫ (𝒮ᴰ-const 𝒮-A 𝒮-B) -- Projection UARel morphisms -𝒮-fst : {A : Type ℓA} {𝒮-A : UARel A ℓ≅A} {B : A → Type ℓB} {𝒮ᴰ-B : DUARel 𝒮-A B ℓ≅B} +𝒮-fst : {A : Type ℓA} {𝒮-A : UARel A ℓ≅A} {B : A → Type ℓB} {𝒮ᴰ-B : DUARel 𝒮-A B ℓ≅B} → UARelHom (∫ 𝒮ᴰ-B) 𝒮-A -𝒮-fst .UARelHom.fun = fst -𝒮-fst .UARelHom.rel = fst +𝒮-fst .UARelHom.fun = fst +𝒮-fst .UARelHom.rel = fst 𝒮-fst .UARelHom.ua p = refl -𝒮-snd : {A : Type ℓA} {𝒮-A : UARel A ℓ≅A} {B : Type ℓB} {𝒮-B : UARel B ℓ≅B} +𝒮-snd : {A : Type ℓA} {𝒮-A : UARel A ℓ≅A} {B : Type ℓB} {𝒮-B : UARel B ℓ≅B} → UARelHom (𝒮-A ×𝒮 𝒮-B) 𝒮-B -𝒮-snd .UARelHom.fun = snd -𝒮-snd .UARelHom.rel = snd +𝒮-snd .UARelHom.fun = snd +𝒮-snd .UARelHom.rel = snd 𝒮-snd .UARelHom.ua p = refl -- Lift a DUARel to live over a Σ-type -𝒮ᴰ-Lift : {A : Type ℓA} (𝒮-A : UARel A ℓ≅A) {B : A → Type ℓB} (𝒮ᴰ-B : DUARel 𝒮-A B ℓ≅B) - {C : A → Type ℓC} (𝒮ᴰ-C : DUARel 𝒮-A C ℓ≅C) - → DUARel (∫ 𝒮ᴰ-C) (λ (a , _) → B a) ℓ≅B +𝒮ᴰ-Lift : {A : Type ℓA} (𝒮-A : UARel A ℓ≅A) {B : A → Type ℓB} (𝒮ᴰ-B : DUARel 𝒮-A B ℓ≅B) + {C : A → Type ℓC} (𝒮ᴰ-C : DUARel 𝒮-A C ℓ≅C) + → DUARel (∫ 𝒮ᴰ-C) (λ (a , _) → B a) ℓ≅B 𝒮ᴰ-Lift _ 𝒮ᴰ-B _ = 𝒮ᴰ-reindex 𝒮-fst 𝒮ᴰ-B -- DUARel on a Σ-type -module _ {A : Type ℓA} {𝒮-A : UARel A ℓ≅A} - {B : A → Type ℓB} {ℓ≅B : Level} (𝒮ᴰ-B : DUARel 𝒮-A B ℓ≅B) - {C : Σ A B → Type ℓC} {ℓ≅C : Level} (𝒮ᴰ-C : DUARel (∫ 𝒮ᴰ-B) C ℓ≅C) +module _ {A : Type ℓA} {𝒮-A : UARel A ℓ≅A} + {B : A → Type ℓB} {ℓ≅B : Level} (𝒮ᴰ-B : DUARel 𝒮-A B ℓ≅B) + {C : Σ A B → Type ℓC} {ℓ≅C : Level} (𝒮ᴰ-C : DUARel (∫ 𝒮ᴰ-B) C ℓ≅C) where open UARel 𝒮-A @@ -64,29 +64,29 @@ module B = DUARel 𝒮ᴰ-B module C = DUARel 𝒮ᴰ-C - 𝒮ᴰ-Σ : DUARel 𝒮-A (λ a → Σ[ b ∈ B a ] C (a , b)) (ℓ-max ℓ≅B ℓ≅C) - DUARel._≅ᴰ⟨_⟩_ 𝒮ᴰ-Σ (b , c) p (b' , c') = - Σ[ q ∈ b B.≅ᴰ⟨ p ⟩ b' ] (c C.≅ᴰ⟨ p , q ⟩ c') - DUARel.uaᴰ 𝒮ᴰ-Σ (b , c) p (b' , c') = + 𝒮ᴰ-Σ : DUARel 𝒮-A (λ a → Σ[ b ∈ B a ] C (a , b)) (ℓ-max ℓ≅B ℓ≅C) + DUARel._≅ᴰ⟨_⟩_ 𝒮ᴰ-Σ (b , c) p (b' , c') = + Σ[ q ∈ b B.≅ᴰ⟨ p ⟩ b' ] (c C.≅ᴰ⟨ p , q ⟩ c') + DUARel.uaᴰ 𝒮ᴰ-Σ (b , c) p (b' , c') = compEquiv - (Σ-cong-equiv (B.uaᴰ b p b') (λ q → C.uaᴰ c (p , q) c')) + (Σ-cong-equiv (B.uaᴰ b p b') (λ q → C.uaᴰ c (p , q) c')) ΣPath≃PathΣ -- DUARel on a non-dependent Σ-type -module _ {A : Type ℓA} {𝒮-A : UARel A ℓ≅A} - {B : A → Type ℓB} {ℓ≅B : Level} (𝒮ᴰ-B : DUARel 𝒮-A B ℓ≅B) - {C : A → Type ℓC} {ℓ≅C : Level} (𝒮ᴰ-C : DUARel 𝒮-A C ℓ≅C) +module _ {A : Type ℓA} {𝒮-A : UARel A ℓ≅A} + {B : A → Type ℓB} {ℓ≅B : Level} (𝒮ᴰ-B : DUARel 𝒮-A B ℓ≅B) + {C : A → Type ℓC} {ℓ≅C : Level} (𝒮ᴰ-C : DUARel 𝒮-A C ℓ≅C) where - _×𝒮ᴰ_ : DUARel 𝒮-A (λ a → B a × C a) (ℓ-max ℓ≅B ℓ≅C) + _×𝒮ᴰ_ : DUARel 𝒮-A (λ a → B a × C a) (ℓ-max ℓ≅B ℓ≅C) _×𝒮ᴰ_ = 𝒮ᴰ-Σ 𝒮ᴰ-B (𝒮ᴰ-Lift 𝒮-A 𝒮ᴰ-C 𝒮ᴰ-B) -- SubstRel on a Σ-type -module _ {A : Type ℓA} {𝒮-A : UARel A ℓ≅A} - {B : A → Type ℓB} (𝒮ˢ-B : SubstRel 𝒮-A B) - {C : Σ A B → Type ℓC} (𝒮ˢ-C : SubstRel (∫ˢ 𝒮ˢ-B) C) +module _ {A : Type ℓA} {𝒮-A : UARel A ℓ≅A} + {B : A → Type ℓB} (𝒮ˢ-B : SubstRel 𝒮-A B) + {C : Σ A B → Type ℓC} (𝒮ˢ-C : SubstRel (∫ˢ 𝒮ˢ-B) C) where open UARel 𝒮-A @@ -95,17 +95,17 @@ module B = SubstRel 𝒮ˢ-B module C = SubstRel 𝒮ˢ-C - 𝒮ˢ-Σ : SubstRel 𝒮-A (λ a → Σ[ b ∈ B a ] C (a , b)) - 𝒮ˢ-Σ .act p = Σ-cong-equiv (B.act p) (λ b → C.act (p , refl)) + 𝒮ˢ-Σ : SubstRel 𝒮-A (λ a → Σ[ b ∈ B a ] C (a , b)) + 𝒮ˢ-Σ .act p = Σ-cong-equiv (B.act p) (λ b → C.act (p , refl)) 𝒮ˢ-Σ .uaˢ p _ = - fromPathP - (DUARel.uaᴰ (𝒮ᴰ-Σ (Subst→DUA 𝒮ˢ-B) (Subst→DUA 𝒮ˢ-C)) _ p _ .fst (refl , refl)) + fromPathP + (DUARel.uaᴰ (𝒮ᴰ-Σ (Subst→DUA 𝒮ˢ-B) (Subst→DUA 𝒮ˢ-C)) _ p _ .fst (refl , refl)) -- SubstRel on a non-dependent product -module _ {A : Type ℓA} {𝒮-A : UARel A ℓ≅A} - {B : A → Type ℓB} (𝒮ˢ-B : SubstRel 𝒮-A B) - {C : A → Type ℓC} (𝒮ˢ-C : SubstRel 𝒮-A C) +module _ {A : Type ℓA} {𝒮-A : UARel A ℓ≅A} + {B : A → Type ℓB} (𝒮ˢ-B : SubstRel 𝒮-A B) + {C : A → Type ℓC} (𝒮ˢ-C : SubstRel 𝒮-A C) where open UARel 𝒮-A @@ -115,6 +115,6 @@ module C = SubstRel 𝒮ˢ-C _×𝒮ˢ_ : SubstRel 𝒮-A (λ a → B a × C a) - _×𝒮ˢ_ .act p = ≃-× (B.act p) (C.act p) - _×𝒮ˢ_ .uaˢ p (b , c) = ΣPathP (B.uaˢ p b , C.uaˢ p c) + _×𝒮ˢ_ .act p = ≃-× (B.act p) (C.act p) + _×𝒮ˢ_ .uaˢ p (b , c) = ΣPathP (B.uaˢ p b , C.uaˢ p c) \ No newline at end of file diff --git a/docs/Cubical.Displayed.Subst.html b/docs/Cubical.Displayed.Subst.html index 71a2d2f..3792aa8 100644 --- a/docs/Cubical.Displayed.Subst.html +++ b/docs/Cubical.Displayed.Subst.html @@ -21,10 +21,10 @@ private variable - ℓA ℓ≅A ℓB : Level + ℓA ℓ≅A ℓB : Level -record SubstRel {A : Type ℓA} {ℓ≅A : Level} (𝒮-A : UARel A ℓ≅A) (B : A → Type ℓB) - : Type (ℓ-max (ℓ-max ℓA ℓB) ℓ≅A) +record SubstRel {A : Type ℓA} {ℓ≅A : Level} (𝒮-A : UARel A ℓ≅A) (B : A → Type ℓB) + : Type (ℓ-max (ℓ-max ℓA ℓB) ℓ≅A) where no-eta-equality @@ -32,28 +32,28 @@ open UARel 𝒮-A field - act : {a a' : A} → a ≅ a' → B a ≃ B a' - uaˢ : {a a' : A} (p : a ≅ a') (b : B a) → subst B (≅→≡ p) b ≡ equivFun (act p) b + act : {a a' : A} → a ≅ a' → B a ≃ B a' + uaˢ : {a a' : A} (p : a ≅ a') (b : B a) → subst B (≅→≡ p) b ≡ equivFun (act p) b - uaˢ⁻ : {a a' : A} (p : a ≅ a') (b : B a') → subst B (sym (≅→≡ p)) b ≡ invEq (act p) b + uaˢ⁻ : {a a' : A} (p : a ≅ a') (b : B a') → subst B (sym (≅→≡ p)) b ≡ invEq (act p) b uaˢ⁻ p b = - subst B (sym (≅→≡ p)) b - ≡⟨ cong (subst B (sym (≅→≡ p))) (sym (secEq (act p) b)) ⟩ - subst B (sym (≅→≡ p)) (equivFun (act p) (invEq (act p) b)) - ≡⟨ cong (subst B (sym (≅→≡ p))) (sym (uaˢ p (invEq (act p) b))) ⟩ - subst B (sym (≅→≡ p)) (subst B (≅→≡ p) (invEq (act p) b)) - ≡⟨ pathToIso (cong B (≅→≡ p)) .Iso.leftInv (invEq (act p) b) ⟩ + subst B (sym (≅→≡ p)) b + ≡⟨ cong (subst B (sym (≅→≡ p))) (sym (secEq (act p) b)) ⟩ + subst B (sym (≅→≡ p)) (equivFun (act p) (invEq (act p) b)) + ≡⟨ cong (subst B (sym (≅→≡ p))) (sym (uaˢ p (invEq (act p) b))) ⟩ + subst B (sym (≅→≡ p)) (subst B (≅→≡ p) (invEq (act p) b)) + ≡⟨ pathToIso (cong B (≅→≡ p)) .Iso.leftInv (invEq (act p) b) ⟩ invEq (act p) b - ∎ + ∎ -Subst→DUA : {A : Type ℓA} {ℓ≅A : Level} {𝒮-A : UARel A ℓ≅A} {B : A → Type ℓB} +Subst→DUA : {A : Type ℓA} {ℓ≅A : Level} {𝒮-A : UARel A ℓ≅A} {B : A → Type ℓB} → SubstRel 𝒮-A B → DUARel 𝒮-A B ℓB DUARel._≅ᴰ⟨_⟩_ (Subst→DUA 𝒮ˢ-B) b p b' = - equivFun (SubstRel.act 𝒮ˢ-B p) b ≡ b' + equivFun (SubstRel.act 𝒮ˢ-B p) b ≡ b' DUARel.uaᴰ (Subst→DUA {𝒮-A = 𝒮-A} {B = B} 𝒮ˢ-B) b p b' = - equivFun (SubstRel.act 𝒮ˢ-B p) b ≡ b' + equivFun (SubstRel.act 𝒮ˢ-B p) b ≡ b' ≃⟨ invEquiv (compPathlEquiv (sym (SubstRel.uaˢ 𝒮ˢ-B p b))) ⟩ - subst B (≅→≡ p) b ≡ b' + subst B (≅→≡ p) b ≡ b' ≃⟨ invEquiv (PathP≃Path (λ i → B (≅→≡ p i)) b b') ⟩ PathP (λ i → B (≅→≡ p i)) b b' ■ diff --git a/docs/Cubical.Displayed.Unit.html b/docs/Cubical.Displayed.Unit.html index 3ee0b6a..7b7e7a0 100644 --- a/docs/Cubical.Displayed.Unit.html +++ b/docs/Cubical.Displayed.Unit.html @@ -18,12 +18,12 @@ private variable - ℓA ℓ≅A : Level + ℓA ℓ≅A : Level -𝒮-Unit : UARel Unit ℓ-zero +𝒮-Unit : UARel Unit ℓ-zero 𝒮-Unit .UARel._≅_ _ _ = Unit 𝒮-Unit .UARel.ua _ _ = invEquiv (isContr→≃Unit (isProp→isContrPath isPropUnit _ _)) -𝒮ᴰ-Unit : {A : Type ℓA} (𝒮-A : UARel A ℓ≅A) → DUARel 𝒮-A (λ _ → Unit) ℓ-zero +𝒮ᴰ-Unit : {A : Type ℓA} (𝒮-A : UARel A ℓ≅A) → DUARel 𝒮-A (λ _ → Unit) ℓ-zero 𝒮ᴰ-Unit 𝒮-A = 𝒮ᴰ-const 𝒮-A 𝒮-Unit \ No newline at end of file diff --git a/docs/Cubical.Displayed.Universe.html b/docs/Cubical.Displayed.Universe.html index a476853..6823ab9 100644 --- a/docs/Cubical.Displayed.Universe.html +++ b/docs/Cubical.Displayed.Universe.html @@ -18,17 +18,17 @@ private variable - ℓA ℓ≅A ℓB ℓ≅B ℓP : Level + ℓA ℓ≅A ℓB ℓ≅B ℓP : Level -𝒮-Univ : ∀ ℓ → UARel (Type ℓ) ℓ -𝒮-Univ ℓ .UARel._≅_ = _≃_ -𝒮-Univ ℓ .UARel.ua _ _ = isoToEquiv (invIso univalenceIso) +𝒮-Univ : ∀ ℓ → UARel (Type ℓ) ℓ +𝒮-Univ ℓ .UARel._≅_ = _≃_ +𝒮-Univ ℓ .UARel.ua _ _ = isoToEquiv (invIso univalenceIso) 𝒮ˢ-El : ∀ ℓ → SubstRel (𝒮-Univ ℓ) (λ X → X) 𝒮ˢ-El ℓ .SubstRel.act e = e -𝒮ˢ-El ℓ .SubstRel.uaˢ e a = uaβ e a +𝒮ˢ-El ℓ .SubstRel.uaˢ e a = uaβ e a 𝒮ᴰ-El : ∀ ℓ → DUARel (𝒮-Univ ℓ) (λ X → X) ℓ -𝒮ᴰ-El ℓ .DUARel._≅ᴰ⟨_⟩_ a e a' = e .fst a ≡ a' +𝒮ᴰ-El ℓ .DUARel._≅ᴰ⟨_⟩_ a e a' = e .fst a ≡ a' 𝒮ᴰ-El ℓ .DUARel.uaᴰ a e a' = invEquiv (ua-ungluePath-Equiv e) \ No newline at end of file diff --git a/docs/Cubical.Functions.Implicit.html b/docs/Cubical.Functions.Implicit.html index 23a7113..ee0fb7f 100644 --- a/docs/Cubical.Functions.Implicit.html +++ b/docs/Cubical.Functions.Implicit.html @@ -6,14 +6,14 @@ open import Cubical.Foundations.Equiv open import Cubical.Foundations.Isomorphism -implicit≃Explicit : ∀ {ℓ ℓ'} {A : Type ℓ} {B : A → Type ℓ'} - → ({a : A} → B a) ≃ ((a : A) → B a) +implicit≃Explicit : ∀ {ℓ ℓ'} {A : Type ℓ} {B : A → Type ℓ'} + → ({a : A} → B a) ≃ ((a : A) → B a) implicit≃Explicit = isoToEquiv isom where isom : Iso _ _ Iso.fun isom f a = f Iso.inv isom f = f _ - Iso.rightInv isom f = funExt λ _ → refl - Iso.leftInv isom f = implicitFunExt refl + Iso.rightInv isom f = funExt λ _ → refl + Iso.leftInv isom f = implicitFunExt refl \ No newline at end of file diff --git a/docs/Cubical.HITs.SetQuotients.Base.html b/docs/Cubical.HITs.SetQuotients.Base.html index 32b1c9d..8cc3f4c 100644 --- a/docs/Cubical.HITs.SetQuotients.Base.html +++ b/docs/Cubical.HITs.SetQuotients.Base.html @@ -12,7 +12,7 @@ open import Cubical.Core.Primitives -- Set quotients as a higher inductive type: -data _/_ {ℓ ℓ'} (A : Type ℓ) (R : A → A → Type ℓ') : Type (ℓ-max ℓ ℓ') where +data _/_ {ℓ ℓ'} (A : Type ℓ) (R : A → A → Type ℓ') : Type (ℓ-max ℓ ℓ') where [_] : (a : A) → A / R eq/ : (a b : A) → (r : R a b) → [ a ] ≡ [ b ] squash/ : (x y : A / R) → (p q : x ≡ y) → p ≡ q diff --git a/docs/Cubical.Relation.Binary.Base.html b/docs/Cubical.Relation.Binary.Base.html index 1b30501..3a9046b 100644 --- a/docs/Cubical.Relation.Binary.Base.html +++ b/docs/Cubical.Relation.Binary.Base.html @@ -22,78 +22,78 @@ private variable - ℓA ℓ≅A ℓA' ℓ≅A' : Level + ℓA ℓ≅A ℓA' ℓ≅A' : Level -Rel : ∀ {ℓ} (A B : Type ℓ) (ℓ' : Level) → Type (ℓ-max ℓ (ℓ-suc ℓ')) -Rel A B ℓ' = A → B → Type ℓ' +Rel : ∀ {ℓ} (A B : Type ℓ) (ℓ' : Level) → Type (ℓ-max ℓ (ℓ-suc ℓ')) +Rel A B ℓ' = A → B → Type ℓ' -PropRel : ∀ {ℓ} (A B : Type ℓ) (ℓ' : Level) → Type (ℓ-max ℓ (ℓ-suc ℓ')) +PropRel : ∀ {ℓ} (A B : Type ℓ) (ℓ' : Level) → Type (ℓ-max ℓ (ℓ-suc ℓ')) PropRel A B ℓ' = Σ[ R ∈ Rel A B ℓ' ] ∀ a b → isProp (R a b) -idPropRel : ∀ {ℓ} (A : Type ℓ) → PropRel A A ℓ -idPropRel A .fst a a' = ∥ a ≡ a' ∥₁ -idPropRel A .snd _ _ = squash₁ +idPropRel : ∀ {ℓ} (A : Type ℓ) → PropRel A A ℓ +idPropRel A .fst a a' = ∥ a ≡ a' ∥₁ +idPropRel A .snd _ _ = squash₁ -invPropRel : ∀ {ℓ ℓ'} {A B : Type ℓ} +invPropRel : ∀ {ℓ ℓ'} {A B : Type ℓ} → PropRel A B ℓ' → PropRel B A ℓ' -invPropRel R .fst b a = R .fst a b -invPropRel R .snd b a = R .snd a b +invPropRel R .fst b a = R .fst a b +invPropRel R .snd b a = R .snd a b -compPropRel : ∀ {ℓ ℓ' ℓ''} {A B C : Type ℓ} - → PropRel A B ℓ' → PropRel B C ℓ'' → PropRel A C (ℓ-max ℓ (ℓ-max ℓ' ℓ'')) -compPropRel R S .fst a c = ∥ Σ[ b ∈ _ ] (R .fst a b × S .fst b c) ∥₁ -compPropRel R S .snd _ _ = squash₁ +compPropRel : ∀ {ℓ ℓ' ℓ''} {A B C : Type ℓ} + → PropRel A B ℓ' → PropRel B C ℓ'' → PropRel A C (ℓ-max ℓ (ℓ-max ℓ' ℓ'')) +compPropRel R S .fst a c = ∥ Σ[ b ∈ _ ] (R .fst a b × S .fst b c) ∥₁ +compPropRel R S .snd _ _ = squash₁ -graphRel : ∀ {ℓ} {A B : Type ℓ} → (A → B) → Rel A B ℓ +graphRel : ∀ {ℓ} {A B : Type ℓ} → (A → B) → Rel A B ℓ graphRel f a b = f a ≡ b -module HeterogenousRelation {ℓ ℓ' : Level} {A B : Type ℓ} (R : Rel A B ℓ') where - isUniversalRel : Type (ℓ-max ℓ ℓ') +module HeterogenousRelation {ℓ ℓ' : Level} {A B : Type ℓ} (R : Rel A B ℓ') where + isUniversalRel : Type (ℓ-max ℓ ℓ') isUniversalRel = (a : A) (b : B) → R a b -module BinaryRelation {ℓ ℓ' : Level} {A : Type ℓ} (R : Rel A A ℓ') where - isRefl : Type (ℓ-max ℓ ℓ') +module BinaryRelation {ℓ ℓ' : Level} {A : Type ℓ} (R : Rel A A ℓ') where + isRefl : Type (ℓ-max ℓ ℓ') isRefl = (a : A) → R a a - isIrrefl : Type (ℓ-max ℓ ℓ') + isIrrefl : Type (ℓ-max ℓ ℓ') isIrrefl = (a : A) → ¬ R a a - isSym : Type (ℓ-max ℓ ℓ') + isSym : Type (ℓ-max ℓ ℓ') isSym = (a b : A) → R a b → R b a - isAsym : Type (ℓ-max ℓ ℓ') + isAsym : Type (ℓ-max ℓ ℓ') isAsym = (a b : A) → R a b → ¬ R b a - isAntisym : Type (ℓ-max ℓ ℓ') + isAntisym : Type (ℓ-max ℓ ℓ') isAntisym = (a b : A) → R a b → R b a → a ≡ b - isTrans : Type (ℓ-max ℓ ℓ') + isTrans : Type (ℓ-max ℓ ℓ') isTrans = (a b c : A) → R a b → R b c → R a c -- Sum types don't play nicely with props, so we truncate - isCotrans : Type (ℓ-max ℓ ℓ') + isCotrans : Type (ℓ-max ℓ ℓ') isCotrans = (a b c : A) → R a b → (R a c ⊔′ R b c) - isWeaklyLinear : Type (ℓ-max ℓ ℓ') + isWeaklyLinear : Type (ℓ-max ℓ ℓ') isWeaklyLinear = (a b c : A) → R a b → R a c ⊔′ R c b - isConnected : Type (ℓ-max ℓ ℓ') + isConnected : Type (ℓ-max ℓ ℓ') isConnected = (a b : A) → ¬ (a ≡ b) → R a b ⊔′ R b a - isStronglyConnected : Type (ℓ-max ℓ ℓ') + isStronglyConnected : Type (ℓ-max ℓ ℓ') isStronglyConnected = (a b : A) → R a b ⊔′ R b a isStronglyConnected→isConnected : isStronglyConnected → isConnected isStronglyConnected→isConnected strong a b _ = strong a b isIrrefl×isTrans→isAsym : isIrrefl × isTrans → isAsym - isIrrefl×isTrans→isAsym (irrefl , trans) a₀ a₁ Ra₀a₁ Ra₁a₀ + isIrrefl×isTrans→isAsym (irrefl , trans) a₀ a₁ Ra₀a₁ Ra₁a₀ = irrefl a₀ (trans a₀ a₁ a₀ Ra₀a₁ Ra₁a₀) - IrreflKernel : Rel A A (ℓ-max ℓ ℓ') + IrreflKernel : Rel A A (ℓ-max ℓ ℓ') IrreflKernel a b = R a b × (¬ a ≡ b) - ReflClosure : Rel A A (ℓ-max ℓ ℓ') + ReflClosure : Rel A A (ℓ-max ℓ ℓ') ReflClosure a b = R a b ⊎ (a ≡ b) SymKernel : Rel A A ℓ' @@ -109,22 +109,22 @@ NegationRel a b = ¬ (R a b) module _ - {ℓ'' : Level} + {ℓ'' : Level} (P : Embedding A ℓ'') where private - subtype : Type ℓ'' - subtype = (fst P) + subtype : Type ℓ'' + subtype = (fst P) toA : subtype → A - toA = fst (snd P) + toA = fst (snd P) InducedRelation : Rel subtype subtype ℓ' InducedRelation a b = R (toA a) (toA b) - record isEquivRel : Type (ℓ-max ℓ ℓ') where + record isEquivRel : Type (ℓ-max ℓ ℓ') where constructor equivRel field reflexive : isRefl @@ -136,33 +136,33 @@ isUniversalRel→isEquivRel u .isEquivRel.symmetric a b _ = u b a isUniversalRel→isEquivRel u .isEquivRel.transitive a _ c _ _ = u a c - isPropValued : Type (ℓ-max ℓ ℓ') + isPropValued : Type (ℓ-max ℓ ℓ') isPropValued = (a b : A) → isProp (R a b) - isSetValued : Type (ℓ-max ℓ ℓ') + isSetValued : Type (ℓ-max ℓ ℓ') isSetValued = (a b : A) → isSet (R a b) - isEffective : Type (ℓ-max ℓ ℓ') + isEffective : Type (ℓ-max ℓ ℓ') isEffective = - (a b : A) → isEquiv (eq/ {R = R} a b) + (a b : A) → isEquiv (eq/ {R = R} a b) - impliesIdentity : Type _ + impliesIdentity : Type _ impliesIdentity = {a a' : A} → (R a a') → (a ≡ a') - inequalityImplies : Type _ + inequalityImplies : Type _ inequalityImplies = (a b : A) → ¬ a ≡ b → R a b -- the total space corresponding to the binary relation w.r.t. a - relSinglAt : (a : A) → Type (ℓ-max ℓ ℓ') + relSinglAt : (a : A) → Type (ℓ-max ℓ ℓ') relSinglAt a = Σ[ a' ∈ A ] (R a a') -- the statement that the total space is contractible at any a - contrRelSingl : Type (ℓ-max ℓ ℓ') + contrRelSingl : Type (ℓ-max ℓ ℓ') contrRelSingl = (a : A) → isContr (relSinglAt a) - isUnivalent : Type (ℓ-max ℓ ℓ') - isUnivalent = (a a' : A) → (R a a') ≃ (a ≡ a') + isUnivalent : Type (ℓ-max ℓ ℓ') + isUnivalent = (a a' : A) → (R a a') ≃ (a ≡ a') contrRelSingl→isUnivalent : isRefl → contrRelSingl → isUnivalent contrRelSingl→isUnivalent ρ c a a' = isoToEquiv i @@ -170,19 +170,19 @@ h : isProp (relSinglAt a) h = isContr→isProp (c a) aρa : relSinglAt a - aρa = a , ρ a + aρa = a , ρ a Q : (y : A) → a ≡ y → _ Q y _ = R a y i : Iso (R a a') (a ≡ a') - Iso.fun i r = cong fst (h aρa (a' , r)) + Iso.fun i r = cong fst (h aρa (a' , r)) Iso.inv i = J Q (ρ a) - Iso.rightInv i = J (λ y p → cong fst (h aρa (y , J Q (ρ a) p)) ≡ p) - (J (λ q _ → cong fst (h aρa (a , q)) ≡ refl) - (J (λ α _ → cong fst α ≡ refl) refl + Iso.rightInv i = J (λ y p → cong fst (h aρa (y , J Q (ρ a) p)) ≡ p) + (J (λ q _ → cong fst (h aρa (a , q)) ≡ refl) + (J (λ α _ → cong fst α ≡ refl) refl (isProp→isSet h _ _ refl (h _ _))) (sym (JRefl Q (ρ a)))) - Iso.leftInv i r = J (λ w β → J Q (ρ a) (cong fst β) ≡ snd w) - (JRefl Q (ρ a)) (h aρa (a' , r)) + Iso.leftInv i r = J (λ w β → J Q (ρ a) (cong fst β) ≡ snd w) + (JRefl Q (ρ a)) (h aρa (a' , r)) isUnivalent→contrRelSingl : isUnivalent → contrRelSingl isUnivalent→contrRelSingl u a = q @@ -192,20 +192,20 @@ f x p = invEq (u a x) p t : singl a → relSinglAt a - t (x , p) = x , f x p + t (x , p) = x , f x p q : isContr (relSinglAt a) - q = isOfHLevelRespectEquiv 0 (t , totalEquiv _ _ f λ x → invEquiv (u a x) .snd) + q = isOfHLevelRespectEquiv 0 (t , totalEquiv _ _ f λ x → invEquiv (u a x) .snd) (isContrSingl a) -EquivRel : ∀ {ℓ} (A : Type ℓ) (ℓ' : Level) → Type (ℓ-max ℓ (ℓ-suc ℓ')) +EquivRel : ∀ {ℓ} (A : Type ℓ) (ℓ' : Level) → Type (ℓ-max ℓ (ℓ-suc ℓ')) EquivRel A ℓ' = Σ[ R ∈ Rel A A ℓ' ] BinaryRelation.isEquivRel R -EquivPropRel : ∀ {ℓ} (A : Type ℓ) (ℓ' : Level) → Type (ℓ-max ℓ (ℓ-suc ℓ')) -EquivPropRel A ℓ' = Σ[ R ∈ PropRel A A ℓ' ] BinaryRelation.isEquivRel (R .fst) +EquivPropRel : ∀ {ℓ} (A : Type ℓ) (ℓ' : Level) → Type (ℓ-max ℓ (ℓ-suc ℓ')) +EquivPropRel A ℓ' = Σ[ R ∈ PropRel A A ℓ' ] BinaryRelation.isEquivRel (R .fst) -record RelIso {A : Type ℓA} (_≅_ : Rel A A ℓ≅A) - {A' : Type ℓA'} (_≅'_ : Rel A' A' ℓ≅A') : Type (ℓ-max (ℓ-max ℓA ℓA') (ℓ-max ℓ≅A ℓ≅A')) where +record RelIso {A : Type ℓA} (_≅_ : Rel A A ℓ≅A) + {A' : Type ℓA'} (_≅'_ : Rel A' A' ℓ≅A') : Type (ℓ-max (ℓ-max ℓA ℓA') (ℓ-max ℓ≅A ℓ≅A')) where constructor reliso field fun : A → A' @@ -215,7 +215,7 @@ open BinaryRelation -RelIso→Iso : {A : Type ℓA} {A' : Type ℓA'} +RelIso→Iso : {A : Type ℓA} {A' : Type ℓA'} (_≅_ : Rel A A ℓ≅A) (_≅'_ : Rel A' A' ℓ≅A') (uni : impliesIdentity _≅_) (uni' : impliesIdentity _≅'_) (f : RelIso _≅_ _≅'_) @@ -227,27 +227,27 @@ Iso.leftInv (RelIso→Iso _ _ uni uni' f) a = uni (RelIso.leftInv f a) -isIrreflIrreflKernel : ∀{ℓ ℓ'} {A : Type ℓ} (R : Rel A A ℓ') → isIrrefl (IrreflKernel R) -isIrreflIrreflKernel _ _ (_ , ¬a≡a) = ¬a≡a refl +isIrreflIrreflKernel : ∀{ℓ ℓ'} {A : Type ℓ} (R : Rel A A ℓ') → isIrrefl (IrreflKernel R) +isIrreflIrreflKernel _ _ (_ , ¬a≡a) = ¬a≡a refl -isReflReflClosure : ∀{ℓ ℓ'} {A : Type ℓ} (R : Rel A A ℓ') → isRefl (ReflClosure R) +isReflReflClosure : ∀{ℓ ℓ'} {A : Type ℓ} (R : Rel A A ℓ') → isRefl (ReflClosure R) isReflReflClosure _ _ = inr refl -isConnectedStronglyConnectedIrreflKernel : ∀{ℓ ℓ'} {A : Type ℓ} (R : Rel A A ℓ') +isConnectedStronglyConnectedIrreflKernel : ∀{ℓ ℓ'} {A : Type ℓ} (R : Rel A A ℓ') → isStronglyConnected R → isConnected (IrreflKernel R) isConnectedStronglyConnectedIrreflKernel R strong a b ¬a≡b - = ∥₁.map (λ x → ⊎.rec (λ Rab → inl (Rab , ¬a≡b)) - (λ Rba → inr (Rba , (λ b≡a → ¬a≡b (sym b≡a)))) x) + = ∥₁.map (λ x → ⊎.rec (λ Rab → inl (Rab , ¬a≡b)) + (λ Rba → inr (Rba , (λ b≡a → ¬a≡b (sym b≡a)))) x) (strong a b) -isSymSymKernel : ∀{ℓ ℓ'} {A : Type ℓ} (R : Rel A A ℓ') → isSym (SymKernel R) -isSymSymKernel _ _ _ (Rab , Rba) = Rba , Rab +isSymSymKernel : ∀{ℓ ℓ'} {A : Type ℓ} (R : Rel A A ℓ') → isSym (SymKernel R) +isSymSymKernel _ _ _ (Rab , Rba) = Rba , Rab -isSymSymClosure : ∀{ℓ ℓ'} {A : Type ℓ} (R : Rel A A ℓ') → isSym (SymClosure R) +isSymSymClosure : ∀{ℓ ℓ'} {A : Type ℓ} (R : Rel A A ℓ') → isSym (SymClosure R) isSymSymClosure _ _ _ (inl Rab) = inr Rab isSymSymClosure _ _ _ (inr Rba) = inl Rba -isAsymAsymKernel : ∀ {ℓ ℓ'} {A : Type ℓ} (R : Rel A A ℓ') → isAsym (AsymKernel R) -isAsymAsymKernel _ _ _ (Rab , _) (_ , ¬Rab) = ¬Rab Rab +isAsymAsymKernel : ∀ {ℓ ℓ'} {A : Type ℓ} (R : Rel A A ℓ') → isAsym (AsymKernel R) +isAsymAsymKernel _ _ _ (Rab , _) (_ , ¬Rab) = ¬Rab Rab \ No newline at end of file diff --git a/docs/Cubical.Relation.Binary.Order.Apartness.Base.html b/docs/Cubical.Relation.Binary.Order.Apartness.Base.html new file mode 100644 index 0000000..0d5a592 --- /dev/null +++ b/docs/Cubical.Relation.Binary.Order.Apartness.Base.html @@ -0,0 +1,132 @@ + +Cubical.Relation.Binary.Order.Apartness.Base
{-# OPTIONS --safe #-}
+{-
+  An apartness relation is a relation that distinguishes
+  elements which are different from each other
+-}
+module Cubical.Relation.Binary.Order.Apartness.Base where
+
+open import Cubical.Foundations.Prelude
+open import Cubical.Foundations.Equiv
+open import Cubical.Foundations.HLevels
+open import Cubical.Foundations.Isomorphism
+open import Cubical.Foundations.Univalence
+open import Cubical.Foundations.Transport
+open import Cubical.Foundations.SIP
+
+open import Cubical.Data.Sigma
+open import Cubical.Data.Sum
+
+open import Cubical.Reflection.RecordEquiv
+open import Cubical.Reflection.StrictEquiv
+
+open import Cubical.Displayed.Base
+open import Cubical.Displayed.Auto
+open import Cubical.Displayed.Record
+open import Cubical.Displayed.Universe
+
+open import Cubical.Relation.Binary.Base
+open import Cubical.Relation.Nullary
+
+open import Cubical.HITs.PropositionalTruncation
+
+open Iso
+open BinaryRelation
+
+
+private
+  variable
+    ℓ ℓ' ℓ'' ℓ₀ ℓ₀' ℓ₁ ℓ₁' : Level
+
+record IsApartness {A : Type ℓ} (_#_ : A → A → Type ℓ') : Type (ℓ-max ℓ ℓ') where
+  no-eta-equality
+  constructor isapartness
+
+  field
+    is-set : isSet A
+    is-prop-valued : isPropValued _#_
+    is-irrefl : isIrrefl _#_
+    is-cotrans : isCotrans _#_
+    is-sym : isSym _#_
+
+unquoteDecl IsApartnessIsoΣ = declareRecordIsoΣ IsApartnessIsoΣ (quote IsApartness)
+
+
+record ApartnessStr (ℓ' : Level) (A : Type ℓ) : Type (ℓ-max ℓ (ℓ-suc ℓ')) where
+
+  constructor apartnessstr
+
+  field
+    _#_     : A → A → Type ℓ'
+    isApartness : IsApartness _#_
+
+  infixl 7 _#_
+
+  open IsApartness isApartness public
+
+Apartness : ∀ ℓ ℓ' → Type (ℓ-max (ℓ-suc ℓ) (ℓ-suc ℓ'))
+Apartness ℓ ℓ' = TypeWithStr ℓ (ApartnessStr ℓ')
+
+apartness : (A : Type ℓ) (_#_ : A → A → Type ℓ') (h : IsApartness _#_) → Apartness ℓ ℓ'
+apartness A _#_ h = A , apartnessstr _#_ h
+
+record IsApartnessEquiv {A : Type ℓ₀} {B : Type ℓ₁}
+  (M : ApartnessStr ℓ₀' A) (e : A ≃ B) (N : ApartnessStr ℓ₁' B)
+  : Type (ℓ-max (ℓ-max ℓ₀ ℓ₀') ℓ₁')
+  where
+  constructor
+   isapartnessequiv
+  -- Shorter qualified names
+  private
+    module M = ApartnessStr M
+    module N = ApartnessStr N
+
+  field
+    pres# : (x y : A) → x M.# y ≃ equivFun e x N.# equivFun e y
+
+
+ApartnessEquiv : (M : Apartness ℓ₀ ℓ₀') (M : Apartness ℓ₁ ℓ₁') → Type (ℓ-max (ℓ-max ℓ₀ ℓ₀') (ℓ-max ℓ₁ ℓ₁'))
+ApartnessEquiv M N = Σ[ e ∈ ⟨ M ⟩ ≃ ⟨ N ⟩ ] IsApartnessEquiv (M .snd) e (N .snd)
+
+isPropIsApartness : {A : Type ℓ} (_#_ : A → A → Type ℓ') → isProp (IsApartness _#_)
+isPropIsApartness _#_ = isOfHLevelRetractFromIso 1 IsApartnessIsoΣ
+  (isPropΣ isPropIsSet
+    λ isSetA → isPropΣ (isPropΠ2 (λ _ _ → isPropIsProp))
+      λ isPropValued# → isProp×2
+                        (isPropΠ λ _ → isProp¬ _)
+                        (isPropΠ4 λ _ _ _ _ → squash₁)
+                        (isPropΠ3 λ _ _ _ → isPropValued# _ _))
+
+𝒮ᴰ-Apartness : DUARel (𝒮-Univ ℓ) (ApartnessStr ℓ') (ℓ-max ℓ ℓ')
+𝒮ᴰ-Apartness =
+  𝒮ᴰ-Record (𝒮-Univ _) IsApartnessEquiv
+    (fields:
+      data[ _#_ ∣ autoDUARel _ _ ∣ pres# ]
+      prop[ isApartness ∣ (λ _ _ → isPropIsApartness _) ])
+    where
+    open ApartnessStr
+    open IsApartness
+    open IsApartnessEquiv
+
+ApartnessPath : (M N : Apartness ℓ ℓ') → ApartnessEquiv M N ≃ (M ≡ N)
+ApartnessPath = ∫ 𝒮ᴰ-Apartness .UARel.ua
+
+-- an easier way of establishing an equivalence of apartness relations
+module _ {P : Apartness ℓ₀ ℓ₀'} {S : Apartness ℓ₁ ℓ₁'} (e : ⟨ P ⟩ ≃ ⟨ S ⟩) where
+  private
+    module P = ApartnessStr (P .snd)
+    module S = ApartnessStr (S .snd)
+
+  module _ (isMon : ∀ x y → x P.# y → equivFun e x S.# equivFun e y)
+           (isMonInv : ∀ x y → x S.# y → invEq e x P.# invEq e y) where
+    open IsApartnessEquiv
+    open IsApartness
+
+    makeIsApartnessEquiv : IsApartnessEquiv (P .snd) e (S .snd)
+    pres# makeIsApartnessEquiv x y = propBiimpl→Equiv (P.isApartness .is-prop-valued _ _)
+                                                      (S.isApartness .is-prop-valued _ _)
+                                                      (isMon _ _) (isMonInv' _ _)
+      where
+      isMonInv' : ∀ x y → equivFun e x S.# equivFun e y → x P.# y
+      isMonInv' x y ex#ey = transport (λ i → retEq e x i P.# retEq e y i) (isMonInv _ _ ex#ey)
+
\ No newline at end of file diff --git a/docs/Cubical.Relation.Binary.Order.Apartness.Properties.html b/docs/Cubical.Relation.Binary.Order.Apartness.Properties.html new file mode 100644 index 0000000..e20f37c --- /dev/null +++ b/docs/Cubical.Relation.Binary.Order.Apartness.Properties.html @@ -0,0 +1,55 @@ + +Cubical.Relation.Binary.Order.Apartness.Properties
{-# OPTIONS --safe #-}
+module Cubical.Relation.Binary.Order.Apartness.Properties where
+
+open import Cubical.Foundations.Prelude
+
+open import Cubical.Functions.Embedding
+
+open import Cubical.Data.Empty as ⊥
+open import Cubical.Data.Sum as ⊎
+
+open import Cubical.Relation.Binary.Base
+open import Cubical.Relation.Binary.Order.Apartness.Base
+
+open import Cubical.HITs.PropositionalTruncation as ∥₁
+
+open import Cubical.Relation.Nullary
+
+private
+  variable
+    ℓ ℓ' ℓ'' : Level
+
+open BinaryRelation
+
+isApartness→ImpliesInequality : {A : Type ℓ} {_#_ : Rel A A ℓ'}
+                              → IsApartness _#_ → ∀ x y → x # y → ¬ (x ≡ y)
+isApartness→ImpliesInequality {_#_ = _#_} apart x y x#y x≡y
+  = IsApartness.is-irrefl apart y (subst (λ a → a # y) x≡y x#y)
+
+isApartness→isEquivRelNegationRel : {A : Type ℓ} {_#_ : Rel A A ℓ'}
+                                  → IsApartness _#_ → isEquivRel (NegationRel _#_)
+isApartness→isEquivRelNegationRel apart
+  = equivRel (λ a a#a → IsApartness.is-irrefl apart a a#a)
+                        (λ a b ¬a#b b#a → ¬a#b (IsApartness.is-sym apart b a b#a))
+                         λ a b c ¬a#b ¬b#c a#c
+                           → ∥₁.rec isProp⊥ (⊎.rec ¬a#b
+                                    (λ c#b → ¬b#c (IsApartness.is-sym apart c b c#b)))
+                                    (IsApartness.is-cotrans apart a c b a#c)
+
+module _
+  {A : Type ℓ}
+  {R : Rel A A ℓ'}
+  where
+
+  open BinaryRelation
+
+  isApartnessInduced : IsApartness R → (B : Type ℓ'') → (f : B ↪ A)
+                     → IsApartness (InducedRelation R (B , f))
+  isApartnessInduced apa B (f , emb)
+    = isapartness (Embedding-into-isSet→isSet (f , emb) (IsApartness.is-set apa))
+                  (λ a b → IsApartness.is-prop-valued apa (f a) (f b))
+                  (λ a → IsApartness.is-irrefl apa (f a))
+                  (λ a b c → IsApartness.is-cotrans apa (f a) (f b) (f c))
+                  λ a b → IsApartness.is-sym apa (f a) (f b)
+
\ No newline at end of file diff --git a/docs/Cubical.Relation.Binary.Order.Apartness.html b/docs/Cubical.Relation.Binary.Order.Apartness.html new file mode 100644 index 0000000..6534ae1 --- /dev/null +++ b/docs/Cubical.Relation.Binary.Order.Apartness.html @@ -0,0 +1,7 @@ + +Cubical.Relation.Binary.Order.Apartness
{-# OPTIONS --safe #-}
+module Cubical.Relation.Binary.Order.Apartness where
+
+open import Cubical.Relation.Binary.Order.Apartness.Base public
+open import Cubical.Relation.Binary.Order.Apartness.Properties public
+
\ No newline at end of file diff --git a/docs/Cubical.Relation.Binary.Order.Loset.Base.html b/docs/Cubical.Relation.Binary.Order.Loset.Base.html new file mode 100644 index 0000000..cf281ce --- /dev/null +++ b/docs/Cubical.Relation.Binary.Order.Loset.Base.html @@ -0,0 +1,136 @@ + +Cubical.Relation.Binary.Order.Loset.Base
{-# OPTIONS --safe #-}
+{-
+  Losets are linearly-ordered sets,
+  i.e. strict posets that are also weakly linear
+  and connected, or more plainly a strict poset
+  where every element can be compared
+-}
+module Cubical.Relation.Binary.Order.Loset.Base where
+
+open import Cubical.Foundations.Prelude
+open import Cubical.Foundations.Equiv
+open import Cubical.Foundations.HLevels
+open import Cubical.Foundations.Isomorphism
+open import Cubical.Foundations.Univalence
+open import Cubical.Foundations.Transport
+open import Cubical.Foundations.SIP
+
+open import Cubical.Data.Sigma
+
+open import Cubical.HITs.PropositionalTruncation
+
+open import Cubical.Reflection.RecordEquiv
+open import Cubical.Reflection.StrictEquiv
+
+open import Cubical.Displayed.Base
+open import Cubical.Displayed.Auto
+open import Cubical.Displayed.Record
+open import Cubical.Displayed.Universe
+
+open import Cubical.Relation.Binary.Base
+open import Cubical.Relation.Nullary.Properties
+
+open Iso
+open BinaryRelation
+
+
+private
+  variable
+    ℓ ℓ' ℓ'' ℓ₀ ℓ₀' ℓ₁ ℓ₁' : Level
+
+record IsLoset {A : Type ℓ} (_<_ : A → A → Type ℓ') : Type (ℓ-max ℓ ℓ') where
+  no-eta-equality
+  constructor isloset
+
+  field
+    is-set : isSet A
+    is-prop-valued : isPropValued _<_
+    is-irrefl : isIrrefl _<_
+    is-trans : isTrans _<_
+    is-asym : isAsym _<_
+    is-weakly-linear : isWeaklyLinear _<_
+    is-connected : isConnected _<_
+
+unquoteDecl IsLosetIsoΣ = declareRecordIsoΣ IsLosetIsoΣ (quote IsLoset)
+
+
+record LosetStr (ℓ' : Level) (A : Type ℓ) : Type (ℓ-max ℓ (ℓ-suc ℓ')) where
+
+  constructor losetstr
+
+  field
+    _<_     : A → A → Type ℓ'
+    isLoset : IsLoset _<_
+
+  infixl 7 _<_
+
+  open IsLoset isLoset public
+
+Loset : ∀ ℓ ℓ' → Type (ℓ-max (ℓ-suc ℓ) (ℓ-suc ℓ'))
+Loset ℓ ℓ' = TypeWithStr ℓ (LosetStr ℓ')
+
+loset : (A : Type ℓ) (_<_ : A → A → Type ℓ') (h : IsLoset _<_) → Loset ℓ ℓ'
+loset A _<_ h = A , losetstr _<_ h
+
+record IsLosetEquiv {A : Type ℓ₀} {B : Type ℓ₁}
+  (M : LosetStr ℓ₀' A) (e : A ≃ B) (N : LosetStr ℓ₁' B)
+  : Type (ℓ-max (ℓ-max ℓ₀ ℓ₀') ℓ₁')
+  where
+  constructor
+   islosetequiv
+  -- Shorter qualified names
+  private
+    module M = LosetStr M
+    module N = LosetStr N
+
+  field
+    pres< : (x y : A) → x M.< y ≃ equivFun e x N.< equivFun e y
+
+
+LosetEquiv : (M : Loset ℓ₀ ℓ₀') (M : Loset ℓ₁ ℓ₁') → Type (ℓ-max (ℓ-max ℓ₀ ℓ₀') (ℓ-max ℓ₁ ℓ₁'))
+LosetEquiv M N = Σ[ e ∈ ⟨ M ⟩ ≃ ⟨ N ⟩ ] IsLosetEquiv (M .snd) e (N .snd)
+
+isPropIsLoset : {A : Type ℓ} (_<_ : A → A → Type ℓ') → isProp (IsLoset _<_)
+isPropIsLoset _<_ = isOfHLevelRetractFromIso 1 IsLosetIsoΣ
+  (isPropΣ isPropIsSet
+    λ isSetA → isPropΣ (isPropΠ2 (λ _ _ → isPropIsProp))
+      λ isPropValued< → isProp×4 (isPropΠ (λ x → isProp¬ (x < x)))
+                                 (isPropΠ5 (λ _ _ _ _ _ → isPropValued< _ _))
+                                 (isPropΠ3 (λ x y _ → isProp¬ (y < x)))
+                                 (isPropΠ4 λ _ _ _ _ → squash₁)
+                                 (isPropΠ3 λ _ _ _ → squash₁))
+
+𝒮ᴰ-Loset : DUARel (𝒮-Univ ℓ) (LosetStr ℓ') (ℓ-max ℓ ℓ')
+𝒮ᴰ-Loset =
+  𝒮ᴰ-Record (𝒮-Univ _) IsLosetEquiv
+    (fields:
+      data[ _<_ ∣ autoDUARel _ _ ∣ pres< ]
+      prop[ isLoset ∣ (λ _ _ → isPropIsLoset _) ])
+    where
+    open LosetStr
+    open IsLoset
+    open IsLosetEquiv
+
+LosetPath : (M N : Loset ℓ ℓ') → LosetEquiv M N ≃ (M ≡ N)
+LosetPath = ∫ 𝒮ᴰ-Loset .UARel.ua
+
+-- an easier way of establishing an equivalence of losets
+module _ {P : Loset ℓ₀ ℓ₀'} {S : Loset ℓ₁ ℓ₁'} (e : ⟨ P ⟩ ≃ ⟨ S ⟩) where
+  private
+    module P = LosetStr (P .snd)
+    module S = LosetStr (S .snd)
+
+  module _ (isMon : ∀ x y → x P.< y → equivFun e x S.< equivFun e y)
+           (isMonInv : ∀ x y → x S.< y → invEq e x P.< invEq e y) where
+    open IsLosetEquiv
+    open IsLoset
+
+    makeIsLosetEquiv : IsLosetEquiv (P .snd) e (S .snd)
+    pres< makeIsLosetEquiv x y = propBiimpl→Equiv (P.isLoset .is-prop-valued _ _)
+                                                  (S.isLoset .is-prop-valued _ _)
+                                                  (isMon _ _) (isMonInv' _ _)
+      where
+      isMonInv' : ∀ x y → equivFun e x S.< equivFun e y → x P.< y
+      isMonInv' x y ex<ey = transport (λ i → retEq e x i P.< retEq e y i) (isMonInv _ _ ex<ey)
+
\ No newline at end of file diff --git a/docs/Cubical.Relation.Binary.Order.Loset.Properties.html b/docs/Cubical.Relation.Binary.Order.Loset.Properties.html new file mode 100644 index 0000000..2316884 --- /dev/null +++ b/docs/Cubical.Relation.Binary.Order.Loset.Properties.html @@ -0,0 +1,93 @@ + +Cubical.Relation.Binary.Order.Loset.Properties
{-# OPTIONS --safe #-}
+module Cubical.Relation.Binary.Order.Loset.Properties where
+
+open import Cubical.Data.Sum as ⊎
+open import Cubical.Data.Empty as ⊥
+
+open import Cubical.Foundations.Prelude
+
+open import Cubical.Functions.Embedding
+
+open import Cubical.HITs.PropositionalTruncation as ∥₁
+
+open import Cubical.Relation.Binary.Base
+open import Cubical.Relation.Binary.Order.Apartness.Base
+open import Cubical.Relation.Binary.Order.Toset.Base
+open import Cubical.Relation.Binary.Order.StrictPoset.Base
+open import Cubical.Relation.Binary.Order.Loset.Base
+
+open import Cubical.Relation.Nullary
+
+private
+  variable
+    ℓ ℓ' ℓ'' : Level
+
+module _
+  {A : Type ℓ}
+  {R : Rel A A ℓ'}
+  where
+
+  open BinaryRelation
+
+  isLoset→isStrictPoset : IsLoset R → IsStrictPoset R
+  isLoset→isStrictPoset loset = isstrictposet
+                                (IsLoset.is-set loset)
+                                (IsLoset.is-prop-valued loset)
+                                (IsLoset.is-irrefl loset)
+                                (IsLoset.is-trans loset)
+                                (IsLoset.is-asym loset)
+
+  private
+    transrefl : isTrans R → isTrans (ReflClosure R)
+    transrefl trans a b c (inl Rab) (inl Rbc) = inl (trans a b c Rab Rbc)
+    transrefl trans a b c (inl Rab) (inr b≡c) = inl (subst (R a) b≡c Rab)
+    transrefl trans a b c (inr a≡b) (inl Rbc) = inl (subst (λ z → R z c) (sym a≡b) Rbc)
+    transrefl trans a b c (inr a≡b) (inr b≡c) = inr (a≡b ∙ b≡c)
+
+    antisym : isIrrefl R → isTrans R → isAntisym (ReflClosure R)
+    antisym irr trans a b (inl Rab) (inl Rba) = ⊥.rec (irr a (trans a b a Rab Rba))
+    antisym irr trans a b (inl _) (inr b≡a) = sym b≡a
+    antisym irr trans a b (inr a≡b) _ = a≡b
+
+  isLoset→isTosetReflClosure : Discrete A → IsLoset R → IsToset (ReflClosure R)
+  isLoset→isTosetReflClosure disc loset
+    = istoset (IsLoset.is-set loset)
+              (λ a b → isProp⊎ (IsLoset.is-prop-valued loset a b)
+                               (IsLoset.is-set loset a b)
+                               λ Rab a≡b
+                                 → IsLoset.is-irrefl loset a (subst (R a)
+                                                             (sym a≡b) Rab))
+              (isReflReflClosure R)
+              (transrefl (IsLoset.is-trans loset))
+              (antisym (IsLoset.is-irrefl loset)
+                       (IsLoset.is-trans loset))
+              λ a b → decRec (λ a≡b → ∣ inl (inr a≡b) ∣₁)
+                             (λ ¬a≡b → ∥₁.map (⊎.map (λ Rab → inl Rab) λ Rba → inl Rba)
+                             (IsLoset.is-connected loset a b ¬a≡b)) (disc a b)
+
+  isLosetInduced : IsLoset R → (B : Type ℓ'') → (f : B ↪ A)
+                 → IsLoset (InducedRelation R (B , f))
+  isLosetInduced los B (f , emb)
+    = isloset (Embedding-into-isSet→isSet (f , emb) (IsLoset.is-set los))
+              (λ a b → IsLoset.is-prop-valued los (f a) (f b))
+              (λ a → IsLoset.is-irrefl los (f a))
+              (λ a b c → IsLoset.is-trans los (f a) (f b) (f c))
+              (λ a b → IsLoset.is-asym los (f a) (f b))
+              (λ a b c → IsLoset.is-weakly-linear los (f a) (f b) (f c))
+              λ a b ¬a≡b → IsLoset.is-connected los (f a) (f b)
+                λ fa≡fb → ¬a≡b (isEmbedding→Inj emb a b fa≡fb)
+
+Loset→StrictPoset : Loset ℓ ℓ' → StrictPoset ℓ ℓ'
+Loset→StrictPoset (_ , los)
+  = _ , strictposetstr (LosetStr._<_ los)
+                       (isLoset→isStrictPoset (LosetStr.isLoset los))
+
+Loset→Toset : (los : Loset ℓ ℓ')
+            → Discrete (fst los)
+            → Toset ℓ (ℓ-max ℓ ℓ')
+Loset→Toset (_ , los) disc
+  = _ , tosetstr (BinaryRelation.ReflClosure (LosetStr._<_ los))
+                 (isLoset→isTosetReflClosure disc
+                                             (LosetStr.isLoset los))
+
\ No newline at end of file diff --git a/docs/Cubical.Relation.Binary.Order.Loset.html b/docs/Cubical.Relation.Binary.Order.Loset.html new file mode 100644 index 0000000..7ed5961 --- /dev/null +++ b/docs/Cubical.Relation.Binary.Order.Loset.html @@ -0,0 +1,7 @@ + +Cubical.Relation.Binary.Order.Loset
{-# OPTIONS --safe #-}
+module Cubical.Relation.Binary.Order.Loset where
+
+open import Cubical.Relation.Binary.Order.Loset.Base public
+open import Cubical.Relation.Binary.Order.Loset.Properties public
+
\ No newline at end of file diff --git a/docs/Cubical.Relation.Binary.Order.Poset.Base.html b/docs/Cubical.Relation.Binary.Order.Poset.Base.html new file mode 100644 index 0000000..d7261af --- /dev/null +++ b/docs/Cubical.Relation.Binary.Order.Poset.Base.html @@ -0,0 +1,140 @@ + +Cubical.Relation.Binary.Order.Poset.Base
{-# OPTIONS --safe #-}
+module Cubical.Relation.Binary.Order.Poset.Base where
+
+open import Cubical.Foundations.Prelude
+open import Cubical.Foundations.Equiv
+open import Cubical.Foundations.Equiv.HalfAdjoint
+open import Cubical.Foundations.HLevels
+open import Cubical.Foundations.Isomorphism
+open import Cubical.Foundations.Univalence
+open import Cubical.Foundations.Transport
+open import Cubical.Foundations.SIP
+
+open import Cubical.Data.Sigma
+
+open import Cubical.Reflection.RecordEquiv
+open import Cubical.Reflection.StrictEquiv
+
+open import Cubical.Displayed.Base
+open import Cubical.Displayed.Auto
+open import Cubical.Displayed.Record
+open import Cubical.Displayed.Universe
+
+open import Cubical.Relation.Binary.Base
+
+open Iso
+open BinaryRelation
+
+
+private
+  variable
+    ℓ ℓ' ℓ'' ℓ₀ ℓ₀' ℓ₁ ℓ₁' : Level
+
+record IsPoset {A : Type ℓ} (_≤_ : A → A → Type ℓ') : Type (ℓ-max ℓ ℓ') where
+  no-eta-equality
+  constructor isposet
+
+  field
+    is-set : isSet A
+    is-prop-valued : isPropValued _≤_
+    is-refl : isRefl _≤_
+    is-trans : isTrans _≤_
+    is-antisym : isAntisym _≤_
+
+unquoteDecl IsPosetIsoΣ = declareRecordIsoΣ IsPosetIsoΣ (quote IsPoset)
+
+
+record PosetStr (ℓ' : Level) (A : Type ℓ) : Type (ℓ-max ℓ (ℓ-suc ℓ')) where
+
+  constructor posetstr
+
+  field
+    _≤_     : A → A → Type ℓ'
+    isPoset : IsPoset _≤_
+
+  infixl 7 _≤_
+
+  open IsPoset isPoset public
+
+Poset : ∀ ℓ ℓ' → Type (ℓ-max (ℓ-suc ℓ) (ℓ-suc ℓ'))
+Poset ℓ ℓ' = TypeWithStr ℓ (PosetStr ℓ')
+
+poset : (A : Type ℓ) (_≤_ : A → A → Type ℓ') (h : IsPoset _≤_) → Poset ℓ ℓ'
+poset A _≤_ h = A , posetstr _≤_ h
+
+record IsPosetEquiv {A : Type ℓ₀} {B : Type ℓ₁}
+  (M : PosetStr ℓ₀' A) (e : A ≃ B) (N : PosetStr ℓ₁' B)
+  : Type (ℓ-max (ℓ-max ℓ₀ ℓ₀') ℓ₁')
+  where
+  constructor
+   isposetequiv
+  -- Shorter qualified names
+  private
+    module M = PosetStr M
+    module N = PosetStr N
+
+  field
+    pres≤ : (x y : A) → x M.≤ y ≃ equivFun e x N.≤ equivFun e y
+
+
+PosetEquiv : (M : Poset ℓ₀ ℓ₀') (M : Poset ℓ₁ ℓ₁') → Type (ℓ-max (ℓ-max ℓ₀ ℓ₀') (ℓ-max ℓ₁ ℓ₁'))
+PosetEquiv M N = Σ[ e ∈ ⟨ M ⟩ ≃ ⟨ N ⟩ ] IsPosetEquiv (M .snd) e (N .snd)
+
+isPropIsPoset : {A : Type ℓ} (_≤_ : A → A → Type ℓ') → isProp (IsPoset _≤_)
+isPropIsPoset _≤_ = isOfHLevelRetractFromIso 1 IsPosetIsoΣ
+  (isPropΣ isPropIsSet
+    λ isSetA → isPropΣ (isPropΠ2 (λ _ _ → isPropIsProp))
+      λ isPropValued≤ → isProp×2
+                         (isPropΠ (λ _ → isPropValued≤ _ _))
+                           (isPropΠ5 λ _ _ _ _ _ → isPropValued≤ _ _)
+                             (isPropΠ4 λ _ _ _ _ → isSetA _ _))
+
+𝒮ᴰ-Poset : DUARel (𝒮-Univ ℓ) (PosetStr ℓ') (ℓ-max ℓ ℓ')
+𝒮ᴰ-Poset =
+  𝒮ᴰ-Record (𝒮-Univ _) IsPosetEquiv
+    (fields:
+      data[ _≤_ ∣ autoDUARel _ _ ∣ pres≤ ]
+      prop[ isPoset ∣ (λ _ _ → isPropIsPoset _) ])
+    where
+    open PosetStr
+    open IsPoset
+    open IsPosetEquiv
+
+PosetPath : (M N : Poset ℓ ℓ') → PosetEquiv M N ≃ (M ≡ N)
+PosetPath = ∫ 𝒮ᴰ-Poset .UARel.ua
+
+-- an easier way of establishing an equivalence of posets
+module _ {P : Poset ℓ₀ ℓ₀'} {S : Poset ℓ₁ ℓ₁'} (e : ⟨ P ⟩ ≃ ⟨ S ⟩) where
+  private
+    module P = PosetStr (P .snd)
+    module S = PosetStr (S .snd)
+
+  module _ (isMon : ∀ x y → x P.≤ y → equivFun e x S.≤ equivFun e y)
+           (isMonInv : ∀ x y → x S.≤ y → invEq e x P.≤ invEq e y) where
+    open IsPosetEquiv
+    open IsPoset
+
+    makeIsPosetEquiv : IsPosetEquiv (P .snd) e (S .snd)
+    pres≤ makeIsPosetEquiv x y = propBiimpl→Equiv (P.isPoset .is-prop-valued _ _)
+                                                  (S.isPoset .is-prop-valued _ _)
+                                                  (isMon _ _) (isMonInv' _ _)
+      where
+      isMonInv' : ∀ x y → equivFun e x S.≤ equivFun e y → x P.≤ y
+      isMonInv' x y ex≤ey = transport (λ i → retEq e x i P.≤ retEq e y i) (isMonInv _ _ ex≤ey)
+
+
+module PosetReasoning (P' : Poset ℓ ℓ') where
+ private P = fst P'
+ open PosetStr (snd P')
+ open IsPoset
+
+ _≤⟨_⟩_ : (x : P) {y z : P} → x ≤ y → y ≤ z → x ≤ z
+ x ≤⟨ p ⟩ q = isPoset .is-trans x _ _ p q
+
+ _◾ : (x : P) → x ≤ x
+ x ◾ = isPoset .is-refl x
+
+ infixr 0 _≤⟨_⟩_
+ infix  1 _◾
+
\ No newline at end of file diff --git a/docs/Cubical.Relation.Binary.Order.Poset.Properties.html b/docs/Cubical.Relation.Binary.Order.Poset.Properties.html new file mode 100644 index 0000000..2d5b173 --- /dev/null +++ b/docs/Cubical.Relation.Binary.Order.Poset.Properties.html @@ -0,0 +1,73 @@ + +Cubical.Relation.Binary.Order.Poset.Properties
{-# OPTIONS --safe #-}
+module Cubical.Relation.Binary.Order.Poset.Properties where
+
+open import Cubical.Foundations.Prelude
+open import Cubical.Foundations.HLevels
+
+open import Cubical.Functions.Embedding
+
+open import Cubical.HITs.PropositionalTruncation as ∥₁
+
+open import Cubical.Relation.Binary.Base
+open import Cubical.Relation.Binary.Order.Poset.Base
+open import Cubical.Relation.Binary.Order.Preorder.Base
+open import Cubical.Relation.Binary.Order.StrictPoset.Base
+
+open import Cubical.Relation.Nullary
+
+private
+  variable
+    ℓ ℓ' ℓ'' : Level
+
+module _
+  {A : Type ℓ}
+  {R : Rel A A ℓ'}
+  where
+
+  open BinaryRelation
+
+  isPoset→isPreorder : IsPoset R → IsPreorder R
+  isPoset→isPreorder poset = ispreorder
+                             (IsPoset.is-set poset)
+                             (IsPoset.is-prop-valued poset)
+                             (IsPoset.is-refl poset)
+                             (IsPoset.is-trans poset)
+
+  private
+    transirrefl : isTrans R → isAntisym R → isTrans (IrreflKernel R)
+    transirrefl trans anti a b c (Rab , ¬a≡b) (Rbc , ¬b≡c)
+      = trans a b c Rab Rbc
+      , λ a≡c → ¬a≡b (anti a b Rab (subst (R b) (sym a≡c) Rbc))
+
+  isPoset→isStrictPosetIrreflKernel : IsPoset R → IsStrictPoset (IrreflKernel R)
+  isPoset→isStrictPosetIrreflKernel poset
+    = isstrictposet (IsPoset.is-set poset)
+                    (λ a b → isProp× (IsPoset.is-prop-valued poset a b)
+                                     (isProp¬ (a ≡ b)))
+                    (isIrreflIrreflKernel R)
+                    (transirrefl (IsPoset.is-trans poset)
+                                 (IsPoset.is-antisym poset))
+                    (isIrrefl×isTrans→isAsym (IrreflKernel R)
+                                             (isIrreflIrreflKernel R
+                                             , transirrefl (IsPoset.is-trans poset)
+                                                           (IsPoset.is-antisym poset)))
+
+  isPosetInduced : IsPoset R → (B : Type ℓ'') → (f : B ↪ A) → IsPoset (InducedRelation R (B , f))
+  isPosetInduced pos B (f , emb)
+    = isposet (Embedding-into-isSet→isSet (f , emb) (IsPoset.is-set pos))
+              (λ a b → IsPoset.is-prop-valued pos (f a) (f b))
+              (λ a → IsPoset.is-refl pos (f a))
+              (λ a b c → IsPoset.is-trans pos (f a) (f b) (f c))
+              λ a b a≤b b≤a → isEmbedding→Inj emb a b
+                (IsPoset.is-antisym pos (f a) (f b) a≤b b≤a)
+
+Poset→Preorder : Poset ℓ ℓ' → Preorder ℓ ℓ'
+Poset→Preorder (_ , pos) = _ , preorderstr (PosetStr._≤_ pos)
+                                           (isPoset→isPreorder (PosetStr.isPoset pos))
+
+Poset→StrictPoset : Poset ℓ ℓ' → StrictPoset ℓ (ℓ-max ℓ ℓ')
+Poset→StrictPoset (_ , pos)
+  = _ , strictposetstr (BinaryRelation.IrreflKernel (PosetStr._≤_ pos))
+                       (isPoset→isStrictPosetIrreflKernel (PosetStr.isPoset pos))
+
\ No newline at end of file diff --git a/docs/Cubical.Relation.Binary.Order.Poset.html b/docs/Cubical.Relation.Binary.Order.Poset.html new file mode 100644 index 0000000..d6a6430 --- /dev/null +++ b/docs/Cubical.Relation.Binary.Order.Poset.html @@ -0,0 +1,7 @@ + +Cubical.Relation.Binary.Order.Poset
{-# OPTIONS --safe #-}
+module Cubical.Relation.Binary.Order.Poset where
+
+open import Cubical.Relation.Binary.Order.Poset.Base public
+open import Cubical.Relation.Binary.Order.Poset.Properties public
+
\ No newline at end of file diff --git a/docs/Cubical.Relation.Binary.Order.Preorder.Base.html b/docs/Cubical.Relation.Binary.Order.Preorder.Base.html new file mode 100644 index 0000000..acb6986 --- /dev/null +++ b/docs/Cubical.Relation.Binary.Order.Preorder.Base.html @@ -0,0 +1,137 @@ + +Cubical.Relation.Binary.Order.Preorder.Base
{-# OPTIONS --safe #-}
+module Cubical.Relation.Binary.Order.Preorder.Base where
+
+open import Cubical.Foundations.Prelude
+open import Cubical.Foundations.Equiv
+open import Cubical.Foundations.HLevels
+open import Cubical.Foundations.Isomorphism
+open import Cubical.Foundations.Univalence
+open import Cubical.Foundations.Transport
+open import Cubical.Foundations.SIP
+
+open import Cubical.Data.Sigma
+
+open import Cubical.Reflection.RecordEquiv
+open import Cubical.Reflection.StrictEquiv
+
+open import Cubical.Displayed.Base
+open import Cubical.Displayed.Auto
+open import Cubical.Displayed.Record
+open import Cubical.Displayed.Universe
+
+open import Cubical.Relation.Binary.Base
+
+open Iso
+open BinaryRelation
+
+
+private
+  variable
+    ℓ ℓ' ℓ'' ℓ₀ ℓ₀' ℓ₁ ℓ₁' : Level
+
+record IsPreorder {A : Type ℓ} (_≲_ : A → A → Type ℓ') : Type (ℓ-max ℓ ℓ') where
+  no-eta-equality
+  constructor ispreorder
+
+  field
+    is-set : isSet A
+    is-prop-valued : isPropValued _≲_
+    is-refl : isRefl _≲_
+    is-trans : isTrans _≲_
+
+unquoteDecl IsPreorderIsoΣ = declareRecordIsoΣ IsPreorderIsoΣ (quote IsPreorder)
+
+
+record PreorderStr (ℓ' : Level) (A : Type ℓ) : Type (ℓ-max ℓ (ℓ-suc ℓ')) where
+
+  constructor preorderstr
+
+  field
+    _≲_     : A → A → Type ℓ'
+    isPreorder : IsPreorder _≲_
+
+  infixl 7 _≲_
+
+  open IsPreorder isPreorder public
+
+Preorder : ∀ ℓ ℓ' → Type (ℓ-max (ℓ-suc ℓ) (ℓ-suc ℓ'))
+Preorder ℓ ℓ' = TypeWithStr ℓ (PreorderStr ℓ')
+
+preorder : (A : Type ℓ) (_≲_ : A → A → Type ℓ') (h : IsPreorder _≲_) → Preorder ℓ ℓ'
+preorder A _≲_ h = A , preorderstr _≲_ h
+
+record IsPreorderEquiv {A : Type ℓ₀} {B : Type ℓ₁}
+  (M : PreorderStr ℓ₀' A) (e : A ≃ B) (N : PreorderStr ℓ₁' B)
+  : Type (ℓ-max (ℓ-max ℓ₀ ℓ₀') ℓ₁')
+  where
+  constructor
+   ispreorderequiv
+  -- Shorter qualified names
+  private
+    module M = PreorderStr M
+    module N = PreorderStr N
+
+  field
+    pres≲ : (x y : A) → x M.≲ y ≃ equivFun e x N.≲ equivFun e y
+
+
+PreorderEquiv : (M : Preorder ℓ₀ ℓ₀') (M : Preorder ℓ₁ ℓ₁') → Type (ℓ-max (ℓ-max ℓ₀ ℓ₀') (ℓ-max ℓ₁ ℓ₁'))
+PreorderEquiv M N = Σ[ e ∈ ⟨ M ⟩ ≃ ⟨ N ⟩ ] IsPreorderEquiv (M .snd) e (N .snd)
+
+isPropIsPreorder : {A : Type ℓ} (_≲_ : A → A → Type ℓ') → isProp (IsPreorder _≲_)
+isPropIsPreorder _≲_ = isOfHLevelRetractFromIso 1 IsPreorderIsoΣ
+  (isPropΣ isPropIsSet
+    λ isSetA → isPropΣ (isPropΠ2 (λ _ _ → isPropIsProp))
+      λ isPropValued≲ → isProp×
+                        (isPropΠ (λ _ → isPropValued≲ _ _))
+                        (isPropΠ4 λ _ _ _ _ → isPropΠ λ _ → isPropValued≲ _ _))
+
+𝒮ᴰ-Preorder : DUARel (𝒮-Univ ℓ) (PreorderStr ℓ') (ℓ-max ℓ ℓ')
+𝒮ᴰ-Preorder =
+  𝒮ᴰ-Record (𝒮-Univ _) IsPreorderEquiv
+    (fields:
+      data[ _≲_ ∣ autoDUARel _ _ ∣ pres≲ ]
+      prop[ isPreorder ∣ (λ _ _ → isPropIsPreorder _) ])
+    where
+    open PreorderStr
+    open IsPreorder
+    open IsPreorderEquiv
+
+PreorderPath : (M N : Preorder ℓ ℓ') → PreorderEquiv M N ≃ (M ≡ N)
+PreorderPath = ∫ 𝒮ᴰ-Preorder .UARel.ua
+
+-- an easier way of establishing an equivalence of preorders
+module _ {P : Preorder ℓ₀ ℓ₀'} {S : Preorder ℓ₁ ℓ₁'} (e : ⟨ P ⟩ ≃ ⟨ S ⟩) where
+  private
+    module P = PreorderStr (P .snd)
+    module S = PreorderStr (S .snd)
+
+  module _ (isMon : ∀ x y → x P.≲ y → equivFun e x S.≲ equivFun e y)
+           (isMonInv : ∀ x y → x S.≲ y → invEq e x P.≲ invEq e y) where
+    open IsPreorderEquiv
+    open IsPreorder
+
+    makeIsPreorderEquiv : IsPreorderEquiv (P .snd) e (S .snd)
+    pres≲ makeIsPreorderEquiv x y = propBiimpl→Equiv (P.isPreorder .is-prop-valued _ _)
+                                                  (S.isPreorder .is-prop-valued _ _)
+                                                  (isMon _ _) (isMonInv' _ _)
+      where
+      isMonInv' : ∀ x y → equivFun e x S.≲ equivFun e y → x P.≲ y
+      isMonInv' x y ex≲ey = transport (λ i → retEq e x i P.≲ retEq e y i) (isMonInv _ _ ex≲ey)
+
+
+module PreorderReasoning (P' : Preorder ℓ ℓ') where
+ private P = fst P'
+ open PreorderStr (snd P')
+ open IsPreorder
+
+ _≲⟨_⟩_ : (x : P) {y z : P} → x ≲ y → y ≲ z → x ≲ z
+ x ≲⟨ p ⟩ q = isPreorder .is-trans x _ _ p q
+
+ _◾ : (x : P) → x ≲ x
+ x ◾ = isPreorder .is-refl x
+
+ infixr 0 _≲⟨_⟩_
+ infix  1 _◾
+
\ No newline at end of file diff --git a/docs/Cubical.Relation.Binary.Order.Preorder.Properties.html b/docs/Cubical.Relation.Binary.Order.Preorder.Properties.html new file mode 100644 index 0000000..8f4d35a --- /dev/null +++ b/docs/Cubical.Relation.Binary.Order.Preorder.Properties.html @@ -0,0 +1,59 @@ + +Cubical.Relation.Binary.Order.Preorder.Properties
{-# OPTIONS --safe #-}
+module Cubical.Relation.Binary.Order.Preorder.Properties where
+
+open import Cubical.Foundations.Prelude
+open import Cubical.Foundations.HLevels
+
+open import Cubical.Functions.Embedding
+
+open import Cubical.HITs.PropositionalTruncation as ∥₁
+
+open import Cubical.Relation.Binary.Base
+open import Cubical.Relation.Binary.Order.Preorder.Base
+open import Cubical.Relation.Binary.Order.StrictPoset.Base
+
+open import Cubical.Relation.Nullary
+
+private
+  variable
+    ℓ ℓ' ℓ'' : Level
+
+module _
+  {A : Type ℓ}
+  {R : Rel A A ℓ'}
+  where
+
+  open BinaryRelation
+
+  isPreorder→isEquivRelSymKernel : IsPreorder R → isEquivRel (SymKernel R)
+  isPreorder→isEquivRelSymKernel preorder
+    = equivRel (λ a → (IsPreorder.is-refl preorder a)
+                    , (IsPreorder.is-refl preorder a))
+               (isSymSymKernel R)
+               (λ a b c (Rab , Rba) (Rbc , Rcb)
+                 → IsPreorder.is-trans preorder a b c Rab Rbc
+                 , IsPreorder.is-trans preorder c b a Rcb Rba)
+
+  isPreorder→isStrictPosetAsymKernel : IsPreorder R → IsStrictPoset (AsymKernel R)
+  isPreorder→isStrictPosetAsymKernel preorder
+    = isstrictposet (IsPreorder.is-set preorder)
+                    (λ a b → isProp× (IsPreorder.is-prop-valued preorder a b) (isProp¬ (R b a)))
+                    (λ a (Raa , ¬Raa) → ¬Raa (IsPreorder.is-refl preorder a))
+                    (λ a b c (Rab , ¬Rba) (Rbc , ¬Rcb)
+                      → IsPreorder.is-trans preorder a b c Rab Rbc
+                      , λ Rca → ¬Rcb (IsPreorder.is-trans preorder c a b Rca Rab))
+                    (isAsymAsymKernel R)
+
+  isPreorderInduced : IsPreorder R → (B : Type ℓ'') → (f : B ↪ A) → IsPreorder (InducedRelation R (B , f))
+  isPreorderInduced pre B (f , emb)
+    = ispreorder (Embedding-into-isSet→isSet (f , emb) (IsPreorder.is-set pre))
+                 (λ a b → IsPreorder.is-prop-valued pre (f a) (f b))
+                 (λ a → IsPreorder.is-refl pre (f a))
+                 λ a b c → IsPreorder.is-trans pre (f a) (f b) (f c)
+
+Preorder→StrictPoset : Preorder ℓ ℓ' → StrictPoset ℓ ℓ'
+Preorder→StrictPoset (_ , pre)
+  = _ , strictposetstr (BinaryRelation.AsymKernel (PreorderStr._≲_ pre))
+                       (isPreorder→isStrictPosetAsymKernel (PreorderStr.isPreorder pre))
+
\ No newline at end of file diff --git a/docs/Cubical.Relation.Binary.Order.Preorder.html b/docs/Cubical.Relation.Binary.Order.Preorder.html new file mode 100644 index 0000000..3f15a32 --- /dev/null +++ b/docs/Cubical.Relation.Binary.Order.Preorder.html @@ -0,0 +1,7 @@ + +Cubical.Relation.Binary.Order.Preorder
{-# OPTIONS --safe #-}
+module Cubical.Relation.Binary.Order.Preorder where
+
+open import Cubical.Relation.Binary.Order.Preorder.Base public
+open import Cubical.Relation.Binary.Order.Preorder.Properties public
+
\ No newline at end of file diff --git a/docs/Cubical.Relation.Binary.Order.Properties.html b/docs/Cubical.Relation.Binary.Order.Properties.html new file mode 100644 index 0000000..4d1f18d --- /dev/null +++ b/docs/Cubical.Relation.Binary.Order.Properties.html @@ -0,0 +1,304 @@ + +Cubical.Relation.Binary.Order.Properties
{-# OPTIONS --safe #-}
+module Cubical.Relation.Binary.Order.Properties where
+
+open import Cubical.Data.Sigma
+open import Cubical.Data.Sum as ⊎
+
+open import Cubical.Foundations.Prelude
+open import Cubical.Foundations.HLevels
+
+open import Cubical.Functions.Embedding
+
+open import Cubical.HITs.PropositionalTruncation as ∥₁
+
+open import Cubical.Relation.Binary.Base
+open import Cubical.Relation.Binary.Order.Poset
+open import Cubical.Relation.Binary.Order.Toset
+open import Cubical.Relation.Binary.Order.Preorder.Base
+
+private
+  variable
+    ℓ ℓ' ℓ'' : Level
+
+module _
+  {A : Type ℓ}
+  {_≲_ : Rel A A ℓ'}
+  (pre : IsPreorder _≲_)
+  where
+
+  private
+      prop : ∀ a b → isProp (a ≲ b)
+      prop = IsPreorder.is-prop-valued pre
+
+  module _
+    (P : Embedding A ℓ'')
+    where
+
+    private
+      subtype : Type ℓ''
+      subtype = fst P
+
+      toA : subtype → A
+      toA = fst (snd P)
+
+    isMinimal : (n : subtype) → Type (ℓ-max ℓ' ℓ'')
+    isMinimal n = (x : subtype) → toA x ≲ toA n → toA n ≲ toA x
+
+    isPropIsMinimal : ∀ n → isProp (isMinimal n)
+    isPropIsMinimal n = isPropΠ2 λ x _ → prop (toA n) (toA x)
+
+    Minimal : Type (ℓ-max ℓ' ℓ'')
+    Minimal = Σ[ n ∈ subtype ] isMinimal n
+
+    isMaximal : (n : subtype) → Type (ℓ-max ℓ' ℓ'')
+    isMaximal n = (x : subtype) → toA n ≲ toA x → toA x ≲ toA n
+
+    isPropIsMaximal : ∀ n → isProp (isMaximal n)
+    isPropIsMaximal n = isPropΠ2 λ x _ → prop (toA x) (toA n)
+
+    Maximal : Type (ℓ-max ℓ' ℓ'')
+    Maximal = Σ[ n ∈ subtype ] isMaximal n
+
+    isLeast : (n : subtype) → Type (ℓ-max ℓ' ℓ'')
+    isLeast n = (x : subtype) → toA n ≲ toA x
+
+    isPropIsLeast : ∀ n → isProp (isLeast n)
+    isPropIsLeast n = isPropΠ λ x → prop (toA n) (toA x)
+
+    Least : Type (ℓ-max ℓ' ℓ'')
+    Least = Σ[ n ∈ subtype ] isLeast n
+
+    isGreatest : (n : subtype) → Type (ℓ-max ℓ' ℓ'')
+    isGreatest n = (x : subtype) → toA x ≲ toA n
+
+    isPropIsGreatest : ∀ n → isProp (isGreatest n)
+    isPropIsGreatest n = isPropΠ λ x → prop (toA x) (toA n)
+
+    Greatest : Type (ℓ-max ℓ' ℓ'')
+    Greatest = Σ[ n ∈ subtype ] isGreatest n
+
+  module _
+    {B : Type ℓ''}
+    (P : B → A)
+    where
+
+    isLowerBound : (n : A) → Type (ℓ-max ℓ' ℓ'')
+    isLowerBound n = (x : B) → n ≲ P x
+
+    isPropIsLowerBound : ∀ n → isProp (isLowerBound n)
+    isPropIsLowerBound n = isPropΠ λ x → prop n (P x)
+
+    LowerBound : Type (ℓ-max (ℓ-max ℓ ℓ') ℓ'')
+    LowerBound = Σ[ n ∈ A ] isLowerBound n
+
+    isUpperBound : (n : A) → Type (ℓ-max ℓ' ℓ'')
+    isUpperBound n = (x : B) → P x ≲ n
+
+    isPropIsUpperBound : ∀ n → isProp (isUpperBound n)
+    isPropIsUpperBound n = isPropΠ λ x → prop (P x) n
+
+    UpperBound : Type (ℓ-max (ℓ-max ℓ ℓ') ℓ'')
+    UpperBound = Σ[ n ∈ A ] isUpperBound n
+
+  module _
+    {B : Type ℓ''}
+    (P : B → A)
+    where
+
+    isMaximalLowerBound : (n : A) → Type (ℓ-max (ℓ-max ℓ ℓ') ℓ'')
+    isMaximalLowerBound n
+      = Σ[ islb ∈ isLowerBound P n ]
+        isMaximal (LowerBound P
+                  , (EmbeddingΣProp (isPropIsLowerBound P))) (n , islb)
+
+    isPropIsMaximalLowerBound : ∀ n → isProp (isMaximalLowerBound n)
+    isPropIsMaximalLowerBound n
+      = isPropΣ (isPropIsLowerBound P n)
+                λ islb → isPropIsMaximal (LowerBound P
+                       , EmbeddingΣProp (isPropIsLowerBound P)) (n , islb)
+
+    MaximalLowerBound : Type (ℓ-max (ℓ-max ℓ ℓ') ℓ'')
+    MaximalLowerBound = Σ[ n ∈ A ] isMaximalLowerBound n
+
+    isMinimalUpperBound : (n : A) → Type (ℓ-max (ℓ-max ℓ ℓ') ℓ'')
+    isMinimalUpperBound n
+      = Σ[ isub ∈ isUpperBound P n ]
+        isMinimal (UpperBound P
+                  , EmbeddingΣProp (isPropIsUpperBound P)) (n , isub)
+
+    isPropIsMinimalUpperBound : ∀ n → isProp (isMinimalUpperBound n)
+    isPropIsMinimalUpperBound n
+      = isPropΣ (isPropIsUpperBound P n)
+                λ isub → isPropIsMinimal (UpperBound P
+                       , EmbeddingΣProp (isPropIsUpperBound P)) (n , isub)
+
+    MinimalUpperBound : Type (ℓ-max (ℓ-max ℓ ℓ') ℓ'')
+    MinimalUpperBound = Σ[ n ∈ A ] isMinimalUpperBound n
+
+    isInfimum : (n : A) → Type (ℓ-max (ℓ-max ℓ ℓ') ℓ'')
+    isInfimum n
+      = Σ[ islb ∈ isLowerBound P n ]
+        isGreatest (LowerBound P
+                   , EmbeddingΣProp (isPropIsLowerBound P)) (n , islb)
+
+    isPropIsInfimum : ∀ n → isProp (isInfimum n)
+    isPropIsInfimum n
+      = isPropΣ (isPropIsLowerBound P n)
+                λ islb → isPropIsGreatest (LowerBound P
+                       , EmbeddingΣProp (isPropIsLowerBound P)) (n , islb)
+
+    Infimum : Type (ℓ-max (ℓ-max ℓ ℓ') ℓ'')
+    Infimum = Σ[ n ∈ A ] isInfimum n
+
+    isSupremum : (n : A) → Type (ℓ-max (ℓ-max ℓ ℓ') ℓ'')
+    isSupremum n
+      = Σ[ isub ∈ isUpperBound P n ]
+        isLeast (UpperBound P
+                , EmbeddingΣProp (isPropIsUpperBound P)) (n , isub)
+
+    isPropIsSupremum : ∀ n → isProp (isSupremum n)
+    isPropIsSupremum n
+      = isPropΣ (isPropIsUpperBound P n)
+                λ isub → isPropIsLeast (UpperBound P
+                       , EmbeddingΣProp (isPropIsUpperBound P)) (n , isub)
+
+    Supremum : Type (ℓ-max (ℓ-max ℓ ℓ') ℓ'')
+    Supremum = Σ[ n ∈ A ] isSupremum n
+
+module _
+  {A : Type ℓ}
+  {_≲_ : Rel A A ℓ'}
+  (pre : IsPreorder _≲_)
+  where
+
+  module _
+    {P : Embedding A ℓ''}
+    where
+
+    private
+      toA : (fst P) → A
+      toA = fst (snd P)
+
+    isLeast→isMinimal : ∀ n → isLeast pre P n → isMinimal pre P n
+    isLeast→isMinimal _ isl x _ = isl x
+
+    isGreatest→isMaximal : ∀ n → isGreatest pre P n → isMaximal pre P n
+    isGreatest→isMaximal _ isg x _ = isg x
+
+    isLeast→isLowerBound : ∀ n → isLeast pre P n → isLowerBound pre toA (toA n)
+    isLeast→isLowerBound _ isl = isl
+
+    isGreatest→isUpperBound : ∀ n → isGreatest pre P n → isUpperBound pre toA (toA n)
+    isGreatest→isUpperBound _ isg = isg
+
+    isLeast→isInfimum : ∀ n → isLeast pre P n → isInfimum pre toA (toA n)
+    isLeast→isInfimum n isl = (isLeast→isLowerBound n isl) , (λ x → snd x n)
+
+    isGreatest→isSupremum : ∀ n → isGreatest pre P n → isSupremum pre toA (toA n)
+    isGreatest→isSupremum n isg = (isGreatest→isUpperBound n isg) , (λ x → snd x n)
+
+  module _
+    {B : Type ℓ''}
+    {P : B → A}
+    where
+
+    isInfimum→isLowerBound : ∀ n → isInfimum pre P n → isLowerBound pre P n
+    isInfimum→isLowerBound _ = fst
+
+    isSupremum→isUpperBound : ∀ n → isSupremum pre P n → isUpperBound pre P n
+    isSupremum→isUpperBound _ = fst
+
+module _
+  {A : Type ℓ}
+  {_≤_ : Rel A A ℓ'}
+  (pos : IsPoset _≤_)
+  where
+
+  private
+    pre : IsPreorder _≤_
+    pre = isPoset→isPreorder pos
+
+    anti : BinaryRelation.isAntisym _≤_
+    anti = IsPoset.is-antisym pos
+
+  module _
+    {P : Embedding A ℓ''}
+    where
+
+    private
+      toA : (fst P) → A
+      toA = fst (snd P)
+
+      emb : isEmbedding toA
+      emb = snd (snd P)
+
+    isLeast→ContrMinimal : ∀ n → isLeast pre P n  → ∀ m → isMinimal pre P m → n ≡ m
+    isLeast→ContrMinimal n isln m ismm
+      = isEmbedding→Inj emb n m (anti (toA n) (toA m) (isln m) (ismm n (isln m)))
+
+    isGreatest→ContrMaximal : ∀ n → isGreatest pre P n → ∀ m → isMaximal pre P m → n ≡ m
+    isGreatest→ContrMaximal n isgn m ismm
+      = isEmbedding→Inj emb n m (anti (toA n) (toA m) (ismm n (isgn m)) (isgn m))
+
+    isLeastUnique : ∀ n m → isLeast pre P n → isLeast pre P m → n ≡ m
+    isLeastUnique n m isln islm
+      = isEmbedding→Inj emb n m (anti (toA n) (toA m) (isln m) (islm n))
+
+    isGreatestUnique : ∀ n m → isGreatest pre P n → isGreatest pre P m → n ≡ m
+    isGreatestUnique n m isgn isgm
+      = isEmbedding→Inj emb n m (anti (toA n) (toA m) (isgm n) (isgn m))
+
+  module _
+    {B : Type ℓ''}
+    {P : B → A}
+    where
+
+    isInfimum→ContrMaximalLowerBound : ∀ n → isInfimum pre P n
+                                     → ∀ m → isMaximalLowerBound pre P m
+                                     → n ≡ m
+    isInfimum→ContrMaximalLowerBound n (isln , isglbn) m (islm , ismlbm)
+      = anti n m (ismlbm (n , isln) (isglbn (m , islm))) (isglbn (m , islm))
+
+    isSupremum→ContrMinimalUpperBound : ∀ n → isSupremum pre P n
+                                      → ∀ m → isMinimalUpperBound pre P m
+                                      → n ≡ m
+    isSupremum→ContrMinimalUpperBound n (isun , islubn) m (isum , ismubm)
+      = anti n m (islubn (m , isum)) (ismubm (n , isun) (islubn (m , isum)))
+
+    isInfimumUnique : ∀ n m → isInfimum pre P n → isInfimum pre P m → n ≡ m
+    isInfimumUnique n m (isln , infn) (islm , infm)
+      = anti n m (infm (n , isln)) (infn (m , islm))
+
+    isSupremumUnique : ∀ n m → isSupremum pre P n → isSupremum pre P m → n ≡ m
+    isSupremumUnique n m (isun , supn) (isum , supm)
+      = anti n m (supn (m , isum)) (supm (n , isun))
+
+module _
+  {A : Type ℓ}
+  {P : Embedding A ℓ''}
+  {_≤_ : Rel A A ℓ'}
+  (tos : IsToset _≤_)
+  where
+
+  private
+    prop : ∀ a b → isProp (a ≤ b)
+    prop = IsToset.is-prop-valued tos
+
+    conn : BinaryRelation.isStronglyConnected _≤_
+    conn = IsToset.is-strongly-connected tos
+
+    pre : IsPreorder _≤_
+    pre = isPoset→isPreorder (isToset→isPoset tos)
+
+    toA : (fst P) → A
+    toA = fst (snd P)
+
+  isMinimal→isLeast : ∀ n → isMinimal pre P n → isLeast pre P n
+  isMinimal→isLeast n ism m
+    = ∥₁.rec (prop _ _) (⊎.rec (λ n≤m → n≤m) (λ m≤n → ism m m≤n)) (conn (toA n) (toA m))
+
+  isMaximal→isGreatest : ∀ n → isMaximal pre P n → isGreatest pre P n
+  isMaximal→isGreatest n ism m
+    = ∥₁.rec (prop _ _) (⊎.rec (λ n≤m → ism m n≤m) (λ m≤n → m≤n)) (conn (toA n) (toA m))
+
\ No newline at end of file diff --git a/docs/Cubical.Relation.Binary.Order.StrictPoset.Base.html b/docs/Cubical.Relation.Binary.Order.StrictPoset.Base.html new file mode 100644 index 0000000..253f67c --- /dev/null +++ b/docs/Cubical.Relation.Binary.Order.StrictPoset.Base.html @@ -0,0 +1,128 @@ + +Cubical.Relation.Binary.Order.StrictPoset.Base
{-# OPTIONS --safe #-}
+{-
+  Strict posets are posets where the relation is strict,
+  i.e. irreflexive rather than reflexive
+-}
+module Cubical.Relation.Binary.Order.StrictPoset.Base where
+
+open import Cubical.Foundations.Prelude
+open import Cubical.Foundations.Equiv
+open import Cubical.Foundations.HLevels
+open import Cubical.Foundations.Isomorphism
+open import Cubical.Foundations.Univalence
+open import Cubical.Foundations.Transport
+open import Cubical.Foundations.SIP
+
+open import Cubical.Data.Sigma
+
+open import Cubical.Reflection.RecordEquiv
+open import Cubical.Reflection.StrictEquiv
+
+open import Cubical.Displayed.Base
+open import Cubical.Displayed.Auto
+open import Cubical.Displayed.Record
+open import Cubical.Displayed.Universe
+
+open import Cubical.Relation.Binary.Base
+open import Cubical.Relation.Nullary.Properties
+
+open Iso
+open BinaryRelation
+
+
+private
+  variable
+    ℓ ℓ' ℓ'' ℓ₀ ℓ₀' ℓ₁ ℓ₁' : Level
+
+record IsStrictPoset {A : Type ℓ} (_<_ : A → A → Type ℓ') : Type (ℓ-max ℓ ℓ') where
+  no-eta-equality
+  constructor isstrictposet
+
+  field
+    is-set : isSet A
+    is-prop-valued : isPropValued _<_
+    is-irrefl : isIrrefl _<_
+    is-trans : isTrans _<_
+    is-asym : isAsym _<_
+
+unquoteDecl IsStrictPosetIsoΣ = declareRecordIsoΣ IsStrictPosetIsoΣ (quote IsStrictPoset)
+
+
+record StrictPosetStr (ℓ' : Level) (A : Type ℓ) : Type (ℓ-max ℓ (ℓ-suc ℓ')) where
+
+  constructor strictposetstr
+
+  field
+    _<_     : A → A → Type ℓ'
+    isStrictPoset : IsStrictPoset _<_
+
+  infixl 7 _<_
+
+  open IsStrictPoset isStrictPoset public
+
+StrictPoset : ∀ ℓ ℓ' → Type (ℓ-max (ℓ-suc ℓ) (ℓ-suc ℓ'))
+StrictPoset ℓ ℓ' = TypeWithStr ℓ (StrictPosetStr ℓ')
+
+strictposet : (A : Type ℓ) (_<_ : A → A → Type ℓ') (h : IsStrictPoset _<_) → StrictPoset ℓ ℓ'
+strictposet A _<_ h = A , strictposetstr _<_ h
+
+record IsStrictPosetEquiv {A : Type ℓ₀} {B : Type ℓ₁}
+  (M : StrictPosetStr ℓ₀' A) (e : A ≃ B) (N : StrictPosetStr ℓ₁' B)
+  : Type (ℓ-max (ℓ-max ℓ₀ ℓ₀') ℓ₁')
+  where
+  constructor
+   isstrictposetequiv
+  -- Shorter qualified names
+  private
+    module M = StrictPosetStr M
+    module N = StrictPosetStr N
+
+  field
+    pres< : (x y : A) → x M.< y ≃ equivFun e x N.< equivFun e y
+
+
+StrictPosetEquiv : (M : StrictPoset ℓ₀ ℓ₀') (M : StrictPoset ℓ₁ ℓ₁') → Type (ℓ-max (ℓ-max ℓ₀ ℓ₀') (ℓ-max ℓ₁ ℓ₁'))
+StrictPosetEquiv M N = Σ[ e ∈ ⟨ M ⟩ ≃ ⟨ N ⟩ ] IsStrictPosetEquiv (M .snd) e (N .snd)
+
+isPropIsStrictPoset : {A : Type ℓ} (_<_ : A → A → Type ℓ') → isProp (IsStrictPoset _<_)
+isPropIsStrictPoset _<_ = isOfHLevelRetractFromIso 1 IsStrictPosetIsoΣ
+  (isPropΣ isPropIsSet
+    λ isSetA → isPropΣ (isPropΠ2 (λ _ _ → isPropIsProp))
+      λ isPropValued< → isProp×2 (isPropΠ (λ x → isProp¬ (x < x)))
+                                 (isPropΠ5 (λ _ _ _ _ _ → isPropValued< _ _))
+                                 (isPropΠ3 λ x y _ → isProp¬ (y < x)))
+
+𝒮ᴰ-StrictPoset : DUARel (𝒮-Univ ℓ) (StrictPosetStr ℓ') (ℓ-max ℓ ℓ')
+𝒮ᴰ-StrictPoset =
+  𝒮ᴰ-Record (𝒮-Univ _) IsStrictPosetEquiv
+    (fields:
+      data[ _<_ ∣ autoDUARel _ _ ∣ pres< ]
+      prop[ isStrictPoset ∣ (λ _ _ → isPropIsStrictPoset _) ])
+    where
+    open StrictPosetStr
+    open IsStrictPoset
+    open IsStrictPosetEquiv
+
+StrictPosetPath : (M N : StrictPoset ℓ ℓ') → StrictPosetEquiv M N ≃ (M ≡ N)
+StrictPosetPath = ∫ 𝒮ᴰ-StrictPoset .UARel.ua
+
+-- an easier way of establishing an equivalence of strict posets
+module _ {P : StrictPoset ℓ₀ ℓ₀'} {S : StrictPoset ℓ₁ ℓ₁'} (e : ⟨ P ⟩ ≃ ⟨ S ⟩) where
+  private
+    module P = StrictPosetStr (P .snd)
+    module S = StrictPosetStr (S .snd)
+
+  module _ (isMon : ∀ x y → x P.< y → equivFun e x S.< equivFun e y)
+           (isMonInv : ∀ x y → x S.< y → invEq e x P.< invEq e y) where
+    open IsStrictPosetEquiv
+    open IsStrictPoset
+
+    makeIsStrictPosetEquiv : IsStrictPosetEquiv (P .snd) e (S .snd)
+    pres< makeIsStrictPosetEquiv x y = propBiimpl→Equiv (P.isStrictPoset .is-prop-valued _ _)
+                                                  (S.isStrictPoset .is-prop-valued _ _)
+                                                  (isMon _ _) (isMonInv' _ _)
+      where
+      isMonInv' : ∀ x y → equivFun e x S.< equivFun e y → x P.< y
+      isMonInv' x y ex<ey = transport (λ i → retEq e x i P.< retEq e y i) (isMonInv _ _ ex<ey)
+
\ No newline at end of file diff --git a/docs/Cubical.Relation.Binary.Order.StrictPoset.Properties.html b/docs/Cubical.Relation.Binary.Order.StrictPoset.Properties.html new file mode 100644 index 0000000..de9fad2 --- /dev/null +++ b/docs/Cubical.Relation.Binary.Order.StrictPoset.Properties.html @@ -0,0 +1,96 @@ + +Cubical.Relation.Binary.Order.StrictPoset.Properties
{-# OPTIONS --safe #-}
+module Cubical.Relation.Binary.Order.StrictPoset.Properties where
+
+open import Cubical.Data.Sum as ⊎
+open import Cubical.Data.Empty as ⊥
+
+open import Cubical.Foundations.Prelude
+
+open import Cubical.Functions.Embedding
+
+open import Cubical.HITs.PropositionalTruncation as ∥₁
+
+open import Cubical.Relation.Binary.Base
+open import Cubical.Relation.Binary.Order.Apartness.Base
+open import Cubical.Relation.Binary.Order.Poset.Base
+open import Cubical.Relation.Binary.Order.StrictPoset.Base
+
+private
+  variable
+    ℓ ℓ' ℓ'' : Level
+
+module _
+  {A : Type ℓ}
+  {R : Rel A A ℓ'}
+  where
+
+  open BinaryRelation
+
+  private
+    transrefl : isTrans R → isTrans (ReflClosure R)
+    transrefl trans a b c (inl Rab) (inl Rbc) = inl (trans a b c Rab Rbc)
+    transrefl trans a b c (inl Rab) (inr b≡c) = inl (subst (R a) b≡c Rab)
+    transrefl trans a b c (inr a≡b) (inl Rbc) = inl (subst (λ z → R z c) (sym a≡b) Rbc)
+    transrefl trans a b c (inr a≡b) (inr b≡c) = inr (a≡b ∙ b≡c)
+
+    antisym : isIrrefl R → isTrans R → isAntisym (ReflClosure R)
+    antisym irr trans a b (inl Rab) (inl Rba) = ⊥.rec (irr a (trans a b a Rab Rba))
+    antisym irr trans a b (inl _) (inr b≡a) = sym b≡a
+    antisym irr trans a b (inr a≡b) _ = a≡b
+
+  isStrictPoset→isPosetReflClosure : IsStrictPoset R → IsPoset (ReflClosure R)
+  isStrictPoset→isPosetReflClosure strictposet
+    = isposet (IsStrictPoset.is-set strictposet)
+              (λ a b → isProp⊎ (IsStrictPoset.is-prop-valued strictposet a b)
+                               (IsStrictPoset.is-set strictposet a b)
+                                 λ Rab a≡b
+                                   → IsStrictPoset.is-irrefl strictposet a (subst (R a)
+                                                                           (sym a≡b) Rab))
+              (isReflReflClosure R)
+              (transrefl (IsStrictPoset.is-trans strictposet))
+              (antisym (IsStrictPoset.is-irrefl strictposet)
+                       (IsStrictPoset.is-trans strictposet))
+
+  isStrictPoset→isApartnessSymClosure : IsStrictPoset R
+                                      → isWeaklyLinear R
+                                      → IsApartness (SymClosure R)
+  isStrictPoset→isApartnessSymClosure strictposet weak
+    = isapartness (IsStrictPoset.is-set strictposet)
+                  (λ a b → isProp⊎ (IsStrictPoset.is-prop-valued strictposet a b)
+                                   (IsStrictPoset.is-prop-valued strictposet b a)
+                                   (IsStrictPoset.is-asym strictposet a b))
+                  (λ a x → ⊎.rec (IsStrictPoset.is-irrefl strictposet a)
+                                 (IsStrictPoset.is-irrefl strictposet a) x)
+                  (λ a b c x → ⊎.rec (λ Rab → ∥₁.map (⊎.map (λ Rac → inl Rac)
+                                                             (λ Rcb → inr Rcb))
+                                                      (weak a b c Rab))
+                                     (λ Rba → ∥₁.rec isPropPropTrunc
+                                                     (λ y → ∣ ⊎.rec (λ Rbc → inr (inl Rbc))
+                                                     (λ Rca → inl (inr Rca)) y ∣₁)
+                                                     (weak b a c Rba)) x)
+                  (isSymSymClosure R)
+
+  isStrictPosetInduced : IsStrictPoset R → (B : Type ℓ'') → (f : B ↪ A)
+                       → IsStrictPoset (InducedRelation R (B , f))
+  isStrictPosetInduced strictpos B (f , emb)
+    = isstrictposet (Embedding-into-isSet→isSet (f , emb)
+                                                (IsStrictPoset.is-set strictpos))
+                    (λ a b → IsStrictPoset.is-prop-valued strictpos (f a) (f b))
+                    (λ a → IsStrictPoset.is-irrefl strictpos (f a))
+                    (λ a b c → IsStrictPoset.is-trans strictpos (f a) (f b) (f c))
+                    λ a b → IsStrictPoset.is-asym strictpos (f a) (f b)
+
+StrictPoset→Poset : StrictPoset ℓ ℓ' → Poset ℓ (ℓ-max ℓ ℓ')
+StrictPoset→Poset (_ , strictpos)
+  = _ , posetstr (BinaryRelation.ReflClosure (StrictPosetStr._<_ strictpos))
+                 (isStrictPoset→isPosetReflClosure (StrictPosetStr.isStrictPoset strictpos))
+
+StrictPoset→Apartness : (R : StrictPoset ℓ ℓ')
+                      → BinaryRelation.isWeaklyLinear (StrictPosetStr._<_ (snd R))
+                      → Apartness ℓ ℓ'
+StrictPoset→Apartness (_ , strictpos) weak
+  = _ , apartnessstr (BinaryRelation.SymClosure (StrictPosetStr._<_ strictpos))
+                     (isStrictPoset→isApartnessSymClosure
+                       (StrictPosetStr.isStrictPoset strictpos) weak)
+
\ No newline at end of file diff --git a/docs/Cubical.Relation.Binary.Order.StrictPoset.html b/docs/Cubical.Relation.Binary.Order.StrictPoset.html new file mode 100644 index 0000000..aaa2f4c --- /dev/null +++ b/docs/Cubical.Relation.Binary.Order.StrictPoset.html @@ -0,0 +1,7 @@ + +Cubical.Relation.Binary.Order.StrictPoset
{-# OPTIONS --safe #-}
+module Cubical.Relation.Binary.Order.StrictPoset where
+
+open import Cubical.Relation.Binary.Order.StrictPoset.Base public
+open import Cubical.Relation.Binary.Order.StrictPoset.Properties public
+
\ No newline at end of file diff --git a/docs/Cubical.Relation.Binary.Order.Toset.Base.html b/docs/Cubical.Relation.Binary.Order.Toset.Base.html new file mode 100644 index 0000000..3239a3b --- /dev/null +++ b/docs/Cubical.Relation.Binary.Order.Toset.Base.html @@ -0,0 +1,148 @@ + +Cubical.Relation.Binary.Order.Toset.Base
{-# OPTIONS --safe #-}
+{-
+  Tosets are totally-ordered sets,
+  i.e. strongly connected posets,
+  a poset where every element can be compared
+-}
+module Cubical.Relation.Binary.Order.Toset.Base where
+
+open import Cubical.Foundations.Prelude
+open import Cubical.Foundations.Equiv
+open import Cubical.Foundations.HLevels
+open import Cubical.Foundations.Isomorphism
+open import Cubical.Foundations.Univalence
+open import Cubical.Foundations.Transport
+open import Cubical.Foundations.SIP
+
+open import Cubical.HITs.PropositionalTruncation
+
+open import Cubical.Data.Sigma
+
+open import Cubical.Reflection.RecordEquiv
+open import Cubical.Reflection.StrictEquiv
+
+open import Cubical.Displayed.Base
+open import Cubical.Displayed.Auto
+open import Cubical.Displayed.Record
+open import Cubical.Displayed.Universe
+
+open import Cubical.Relation.Binary.Base
+
+open Iso
+open BinaryRelation
+
+
+private
+  variable
+    ℓ ℓ' ℓ'' ℓ₀ ℓ₀' ℓ₁ ℓ₁' : Level
+
+record IsToset {A : Type ℓ} (_≤_ : A → A → Type ℓ') : Type (ℓ-max ℓ ℓ') where
+  no-eta-equality
+  constructor istoset
+
+  field
+    is-set : isSet A
+    is-prop-valued : isPropValued _≤_
+    is-refl : isRefl _≤_
+    is-trans : isTrans _≤_
+    is-antisym : isAntisym _≤_
+    is-strongly-connected : isStronglyConnected _≤_
+
+unquoteDecl IsTosetIsoΣ = declareRecordIsoΣ IsTosetIsoΣ (quote IsToset)
+
+
+record TosetStr (ℓ' : Level) (A : Type ℓ) : Type (ℓ-max ℓ (ℓ-suc ℓ')) where
+
+  constructor tosetstr
+
+  field
+    _≤_     : A → A → Type ℓ'
+    isToset : IsToset _≤_
+
+  infixl 7 _≤_
+
+  open IsToset isToset public
+
+Toset : ∀ ℓ ℓ' → Type (ℓ-max (ℓ-suc ℓ) (ℓ-suc ℓ'))
+Toset ℓ ℓ' = TypeWithStr ℓ (TosetStr ℓ')
+
+toset : (A : Type ℓ) (_≤_ : A → A → Type ℓ') (h : IsToset _≤_) → Toset ℓ ℓ'
+toset A _≤_ h = A , tosetstr _≤_ h
+
+record IsTosetEquiv {A : Type ℓ₀} {B : Type ℓ₁}
+  (M : TosetStr ℓ₀' A) (e : A ≃ B) (N : TosetStr ℓ₁' B)
+  : Type (ℓ-max (ℓ-max ℓ₀ ℓ₀') ℓ₁')
+  where
+  constructor
+   istosetequiv
+  -- Shorter qualified names
+  private
+    module M = TosetStr M
+    module N = TosetStr N
+
+  field
+    pres≤ : (x y : A) → x M.≤ y ≃ equivFun e x N.≤ equivFun e y
+
+
+TosetEquiv : (M : Toset ℓ₀ ℓ₀') (M : Toset ℓ₁ ℓ₁') → Type (ℓ-max (ℓ-max ℓ₀ ℓ₀') (ℓ-max ℓ₁ ℓ₁'))
+TosetEquiv M N = Σ[ e ∈ ⟨ M ⟩ ≃ ⟨ N ⟩ ] IsTosetEquiv (M .snd) e (N .snd)
+
+isPropIsToset : {A : Type ℓ} (_≤_ : A → A → Type ℓ') → isProp (IsToset _≤_)
+isPropIsToset _≤_ = isOfHLevelRetractFromIso 1 IsTosetIsoΣ
+  (isPropΣ isPropIsSet
+    λ isSetA → isPropΣ (isPropΠ2 (λ _ _ → isPropIsProp))
+      λ isPropValued≤ → isProp×3
+                         (isPropΠ (λ _ → isPropValued≤ _ _))
+                           (isPropΠ5 λ _ _ _ _ _ → isPropValued≤ _ _)
+                             (isPropΠ4 λ _ _ _ _ → isSetA _ _)
+                               (isPropΠ2 λ _ _ → squash₁))
+
+𝒮ᴰ-Toset : DUARel (𝒮-Univ ℓ) (TosetStr ℓ') (ℓ-max ℓ ℓ')
+𝒮ᴰ-Toset =
+  𝒮ᴰ-Record (𝒮-Univ _) IsTosetEquiv
+    (fields:
+      data[ _≤_ ∣ autoDUARel _ _ ∣ pres≤ ]
+      prop[ isToset ∣ (λ _ _ → isPropIsToset _) ])
+    where
+    open TosetStr
+    open IsToset
+    open IsTosetEquiv
+
+TosetPath : (M N : Toset ℓ ℓ') → TosetEquiv M N ≃ (M ≡ N)
+TosetPath = ∫ 𝒮ᴰ-Toset .UARel.ua
+
+-- an easier way of establishing an equivalence of tosets
+module _ {P : Toset ℓ₀ ℓ₀'} {S : Toset ℓ₁ ℓ₁'} (e : ⟨ P ⟩ ≃ ⟨ S ⟩) where
+  private
+    module P = TosetStr (P .snd)
+    module S = TosetStr (S .snd)
+
+  module _ (isMon : ∀ x y → x P.≤ y → equivFun e x S.≤ equivFun e y)
+           (isMonInv : ∀ x y → x S.≤ y → invEq e x P.≤ invEq e y) where
+    open IsTosetEquiv
+    open IsToset
+
+    makeIsTosetEquiv : IsTosetEquiv (P .snd) e (S .snd)
+    pres≤ makeIsTosetEquiv x y = propBiimpl→Equiv (P.isToset .is-prop-valued _ _)
+                                                  (S.isToset .is-prop-valued _ _)
+                                                  (isMon _ _) (isMonInv' _ _)
+      where
+      isMonInv' : ∀ x y → equivFun e x S.≤ equivFun e y → x P.≤ y
+      isMonInv' x y ex≤ey = transport (λ i → retEq e x i P.≤ retEq e y i) (isMonInv _ _ ex≤ey)
+
+
+module TosetReasoning (P' : Toset ℓ ℓ') where
+ private P = fst P'
+ open TosetStr (snd P')
+ open IsToset
+
+ _≤⟨_⟩_ : (x : P) {y z : P} → x ≤ y → y ≤ z → x ≤ z
+ x ≤⟨ p ⟩ q = isToset .is-trans x _ _ p q
+
+ _◾ : (x : P) → x ≤ x
+ x ◾ = isToset .is-refl x
+
+ infixr 0 _≤⟨_⟩_
+ infix  1 _◾
+
\ No newline at end of file diff --git a/docs/Cubical.Relation.Binary.Order.Toset.Properties.html b/docs/Cubical.Relation.Binary.Order.Toset.Properties.html new file mode 100644 index 0000000..dec1b6b --- /dev/null +++ b/docs/Cubical.Relation.Binary.Order.Toset.Properties.html @@ -0,0 +1,93 @@ + +Cubical.Relation.Binary.Order.Toset.Properties
{-# OPTIONS --safe #-}
+module Cubical.Relation.Binary.Order.Toset.Properties where
+
+open import Cubical.Data.Sum as ⊎
+open import Cubical.Data.Empty as ⊥
+
+open import Cubical.Foundations.Prelude
+open import Cubical.Foundations.HLevels
+
+open import Cubical.Functions.Embedding
+
+open import Cubical.HITs.PropositionalTruncation as ∥₁
+
+open import Cubical.Relation.Binary.Base
+open import Cubical.Relation.Binary.Order.Poset.Base
+open import Cubical.Relation.Binary.Order.Toset.Base
+open import Cubical.Relation.Binary.Order.Loset.Base
+
+open import Cubical.Relation.Nullary
+
+private
+  variable
+    ℓ ℓ' ℓ'' : Level
+
+module _
+  {A : Type ℓ}
+  {R : Rel A A ℓ'}
+  where
+
+  open BinaryRelation
+
+  isToset→isPoset : IsToset R → IsPoset R
+  isToset→isPoset toset = isposet
+                          (IsToset.is-set toset)
+                          (IsToset.is-prop-valued toset)
+                          (IsToset.is-refl toset)
+                          (IsToset.is-trans toset)
+                          (IsToset.is-antisym toset)
+  private
+    transirrefl : isTrans R → isAntisym R → isTrans (IrreflKernel R)
+    transirrefl trans anti a b c (Rab , ¬a≡b) (Rbc , ¬b≡c)
+      = trans a b c Rab Rbc
+      , λ a≡c → ¬a≡b (anti a b Rab (subst (R b) (sym a≡c) Rbc))
+
+  isToset→isLosetIrreflKernel : Discrete A → IsToset R → IsLoset (IrreflKernel R)
+  isToset→isLosetIrreflKernel disc toset
+    = isloset (IsToset.is-set toset)
+              (λ a b → isProp× (IsToset.is-prop-valued toset a b)
+                               (isProp¬ (a ≡ b)))
+              (isIrreflIrreflKernel R)
+              (transirrefl (IsToset.is-trans toset)
+                           (IsToset.is-antisym toset))
+              (isIrrefl×isTrans→isAsym (IrreflKernel R)
+                                       (isIrreflIrreflKernel R
+                                       , transirrefl (IsToset.is-trans toset)
+                                                     (IsToset.is-antisym toset)))
+              (λ a c b (Rac , ¬a≡c)
+                → decRec (λ a≡b → ∥₁.map (⊎.rec
+                         (λ Rbc → inr (Rbc , λ b≡c → ¬a≡c (a≡b ∙ b≡c)))
+                                λ Rcb → ⊥.rec (¬a≡c (IsToset.is-antisym toset a c Rac
+                                              (subst (λ x → R c x) (sym a≡b) Rcb))))
+                                  (IsToset.is-strongly-connected toset b c))
+                         (λ ¬a≡b → ∥₁.map (⊎.map (λ Rab → Rab , ¬a≡b)
+                                   (λ Rba → (IsToset.is-trans toset b a c Rba Rac)
+                                   , λ b≡c → ¬a≡b (IsToset.is-antisym toset a b
+                                       (subst (λ x → R a x) (sym b≡c) Rac) Rba)))
+                                 (IsToset.is-strongly-connected toset a b))
+                         (disc a b))
+              (isConnectedStronglyConnectedIrreflKernel R
+                (IsToset.is-strongly-connected toset))
+
+  isTosetInduced : IsToset R → (B : Type ℓ'') → (f : B ↪ A)
+                 → IsToset (InducedRelation R (B , f))
+  isTosetInduced tos B (f , emb)
+    = istoset (Embedding-into-isSet→isSet (f , emb) (IsToset.is-set tos))
+              (λ a b → IsToset.is-prop-valued tos (f a) (f b))
+              (λ a → IsToset.is-refl tos (f a))
+              (λ a b c → IsToset.is-trans tos (f a) (f b) (f c))
+              (λ a b a≤b b≤a → isEmbedding→Inj emb a b
+                (IsToset.is-antisym tos (f a) (f b) a≤b b≤a))
+              λ a b → IsToset.is-strongly-connected tos (f a) (f b)
+
+Toset→Poset : Toset ℓ ℓ' → Poset ℓ ℓ'
+Toset→Poset (_ , tos) = _ , posetstr (TosetStr._≤_ tos)
+                                     (isToset→isPoset (TosetStr.isToset tos))
+
+Toset→Loset : (tos : Toset ℓ ℓ') → Discrete (fst tos) → Loset ℓ (ℓ-max ℓ ℓ')
+Toset→Loset (_ , tos) disc
+  = _ , losetstr (BinaryRelation.IrreflKernel (TosetStr._≤_ tos))
+                       (isToset→isLosetIrreflKernel disc
+                                                    (TosetStr.isToset tos))
+
\ No newline at end of file diff --git a/docs/Cubical.Relation.Binary.Order.Toset.html b/docs/Cubical.Relation.Binary.Order.Toset.html new file mode 100644 index 0000000..7282101 --- /dev/null +++ b/docs/Cubical.Relation.Binary.Order.Toset.html @@ -0,0 +1,7 @@ + +Cubical.Relation.Binary.Order.Toset
{-# OPTIONS --safe #-}
+module Cubical.Relation.Binary.Order.Toset where
+
+open import Cubical.Relation.Binary.Order.Toset.Base public
+open import Cubical.Relation.Binary.Order.Toset.Properties public
+
\ No newline at end of file diff --git a/docs/Cubical.Relation.Binary.Order.html b/docs/Cubical.Relation.Binary.Order.html new file mode 100644 index 0000000..f9ea119 --- /dev/null +++ b/docs/Cubical.Relation.Binary.Order.html @@ -0,0 +1,12 @@ + +Cubical.Relation.Binary.Order
{-# OPTIONS --safe #-}
+module Cubical.Relation.Binary.Order where
+
+open import Cubical.Relation.Binary.Order.Apartness public
+open import Cubical.Relation.Binary.Order.Preorder public
+open import Cubical.Relation.Binary.Order.Poset public
+open import Cubical.Relation.Binary.Order.Toset public
+open import Cubical.Relation.Binary.Order.StrictPoset public
+open import Cubical.Relation.Binary.Order.Loset public
+open import Cubical.Relation.Binary.Order.Properties public
+
\ No newline at end of file diff --git a/docs/Cubical.Relation.Binary.Properties.html b/docs/Cubical.Relation.Binary.Properties.html index 0e3bca3..1a12a37 100644 --- a/docs/Cubical.Relation.Binary.Properties.html +++ b/docs/Cubical.Relation.Binary.Properties.html @@ -7,8 +7,8 @@ private variable - ℓ : Level - A B : Type ℓ + ℓ : Level + A B : Type ℓ -- Pulling back a relation along a function. diff --git a/docs/Realizability.ApplicativeStructure.html b/docs/Realizability.ApplicativeStructure.html index b1fbd57..8d01e48 100644 --- a/docs/Realizability.ApplicativeStructure.html +++ b/docs/Realizability.ApplicativeStructure.html @@ -1,118 +1,131 @@ -Realizability.ApplicativeStructure
{-# OPTIONS --cubical --allow-unsolved-metas #-}
-open import Cubical.Core.Everything
-open import Cubical.Foundations.Prelude
-open import Cubical.Foundations.HLevels
-open import Cubical.Relation.Nullary
-open import Cubical.Data.Nat
-open import Cubical.Data.Nat.Order
-open import Cubical.Data.Fin
-open import Cubical.Data.Vec
-
-module Realizability.ApplicativeStructure where
-
-record ApplicativeStructure {ℓ} (A : Type ℓ) : Type ℓ where
-  infixl 20 _⨾_
-  field
-    isSetA : isSet A
-    _⨾_ : A → A → A
-
-module _ {ℓ} {A : Type ℓ} (as : ApplicativeStructure A) where
-  open ApplicativeStructure as
-  infix 23 `_
-  infixl 22 _̇_
-  data Term (n : ℕ) : Type ℓ where
-    # : Fin n → Term n
-    `_ : A → Term n
-    _̇_ : Term n → Term n → Term n
-
-  upgrade : ∀ {n m} → n < m → Term n → Term m
-  upgrade _ (` a) = ` a
-  upgrade {n} {m} n<m (# k) = # (k .fst , <-trans (k .snd) n<m)
-  upgrade {n} {m} n<m (a ̇ b) = upgrade n<m a ̇ upgrade n<m b
-
-  substitute : ∀ {n} → Term n → Vec A n → A
-  substitute (` a) _ = a
-  substitute {n} (# k) subs = lookup (Fin→FinData n k) subs
-  substitute (a ̇ b) subs = (substitute a subs) ⨾ (substitute b subs)
-
-  apply : ∀ {n} → A → Vec A n → A
-  apply a [] = a
-  apply a (x ∷ xs) = apply' (x ∷ xs) a where
-                            apply' : ∀ {n} → Vec A n → A → A
-                            apply' [] acc = acc
-                            apply' (x ∷ xs) acc = apply' xs (acc ⨾ x)
-
-  applyWorks : ∀ K a b → apply K (a ∷ b ∷ []) ≡ K ⨾ a ⨾ b
-  applyWorks K a b = refl
-
-  record isInterpreted {n} (t : Term n) : Type ℓ where
-    field
-      interpretation : A
-      naturality : ∀ (subs : Vec A n) → apply interpretation subs ≡ substitute t subs
-
-  isCombinatoriallyComplete : Type ℓ
-  isCombinatoriallyComplete = ∀ {n} (t : Term n) → isInterpreted t
-
-  record Feferman : Type ℓ where
-    field
-      s : A
-      k : A
-      kab≡a : ∀ a b → k ⨾ a ⨾ b ≡ a
-      sabc≡ac_bc : ∀ a b c → s ⨾ a ⨾ b ⨾ c ≡ (a ⨾ c) ⨾ (b ⨾ c)
-
-  module _ (completeness : isCombinatoriallyComplete) where
-    open isInterpreted
-
-    preS : Term 3
-    preS = ((# 0) ̇ (# 2)) ̇ ((# 1) ̇ (# 2))
-
-    S : A
-    S = (completeness preS) .interpretation
-
-    preK : Term 2
-    preK = # 0
-
-    K : A
-    K = (completeness preK) .interpretation
-
-    Kab≡a : ∀ a b → K ⨾ a ⨾ b ≡ a
-    Kab≡a a b = (completeness preK) .naturality (a ∷ b ∷ [])
-
-    Sabc≡ac_bc : ∀ a b c → S ⨾ a ⨾ b ⨾ c ≡ (a ⨾ c) ⨾ (b ⨾ c)
-    Sabc≡ac_bc a b c = (completeness preS) .naturality (a ∷ b ∷ c ∷ [])
-    open Feferman
-    completeness→feferman : Feferman
-    completeness→feferman .s = S
-    completeness→feferman .k = K
-    completeness→feferman .kab≡a = Kab≡a
-    completeness→feferman .sabc≡ac_bc = Sabc≡ac_bc
-
-  module _ (feferman : Feferman) where
-    open Feferman feferman
-    λ* : ∀ {n} (e : Term (suc n)) → Term n
-    λ* (` a) = ` k ̇ ` a
-    λ* (a ̇ b) = ` s ̇ (λ* a) ̇ (λ* b)
-    λ* {n} (# y) with (discreteℕ n (y .fst))
-    ... | yes _ = ` s ̇ ` k ̇ ` k
-    ... | no ¬y≡n with (y .fst)
-    ...   | zero = ` k ̇ (# (zero , {!suc-≤-suc (zero-≤ {n = (predℕ n)})!}))
-    ...   | (suc m) = ` k ̇ (# (((suc m) , {!!})))
-
-    λ*-chainTerm : ∀ n → Term n → Term zero
-    λ*-chainTerm zero t = t
-    λ*-chainTerm (suc n) t = λ*-chainTerm n (λ* t)
-
-    λ*-chain : ∀ {n} → Term n → A
-    λ*-chain {n} t = substitute (λ*-chainTerm n t) []
-
-    open isInterpreted
-
-    postulate λ*-naturality : ∀ {n} (t : Term n) (subs : Vec A n) → apply (λ*-chain t) subs ≡ substitute t subs
+Realizability.ApplicativeStructure
{-# OPTIONS --cubical --without-K --allow-unsolved-metas #-}
+open import Cubical.Core.Everything
+open import Cubical.Foundations.Prelude
+open import Cubical.Foundations.HLevels
+open import Cubical.Relation.Nullary
+open import Cubical.Data.Nat
+open import Cubical.Data.Nat.Order
+open import Cubical.Data.Fin
+open import Cubical.Data.Vec
+open import Cubical.Data.Empty renaming (elim to ⊥elim)
+
+module Realizability.ApplicativeStructure where
+
+record ApplicativeStructure {ℓ} (A : Type ℓ) : Type ℓ where
+  infixl 20 _⨾_
+  field
+    isSetA : isSet A
+    _⨾_ : A → A → A
+
+module _ {ℓ} {A : Type ℓ} (as : ApplicativeStructure A) where
+  open ApplicativeStructure as
+  infix 23 `_
+  infixl 22 _̇_
+  data Term (n : ℕ) : Type ℓ where
+    # : Fin n → Term n
+    `_ : A → Term n
+    _̇_ : Term n → Term n → Term n
+
+  upgrade : ∀ {n m} → n < m → Term n → Term m
+  upgrade _ (` a) = ` a
+  upgrade {n} {m} n<m (# k) = # (k .fst , <-trans (k .snd) n<m)
+  upgrade {n} {m} n<m (a ̇ b) = upgrade n<m a ̇ upgrade n<m b
+
+  substitute : ∀ {n} → Term n → Vec A n → A
+  substitute (` a) _ = a
+  substitute {n} (# k) subs = lookup (Fin→FinData n k) subs
+  substitute (a ̇ b) subs = (substitute a subs) ⨾ (substitute b subs)
+
+  apply : ∀ {n} → A → Vec A n → A
+  apply a [] = a
+  apply a (x ∷ xs) = apply' (x ∷ xs) a where
+                            apply' : ∀ {n} → Vec A n → A → A
+                            apply' [] acc = acc
+                            apply' (x ∷ xs) acc = apply' xs (acc ⨾ x)
+
+  applyWorks : ∀ K a b → apply K (a ∷ b ∷ []) ≡ K ⨾ a ⨾ b
+  applyWorks K a b = refl
+
+  record isInterpreted {n} (t : Term n) : Type ℓ where
+    field
+      interpretation : A
+      naturality : ∀ (subs : Vec A n) → apply interpretation subs ≡ substitute t subs
+
+  isCombinatoriallyComplete : Type ℓ
+  isCombinatoriallyComplete = ∀ {n} (t : Term n) → isInterpreted t
+
+  record Feferman : Type ℓ where
+    field
+      s : A
+      k : A
+      kab≡a : ∀ a b → k ⨾ a ⨾ b ≡ a
+      sabc≡ac_bc : ∀ a b c → s ⨾ a ⨾ b ⨾ c ≡ (a ⨾ c) ⨾ (b ⨾ c)
+
+  module _ (completeness : isCombinatoriallyComplete) where
+    open isInterpreted
+
+    preS : Term 3
+    preS = ((# 0) ̇ (# 2)) ̇ ((# 1) ̇ (# 2))
+
+    S : A
+    S = (completeness preS) .interpretation
+
+    preK : Term 2
+    preK = # 0
+
+    K : A
+    K = (completeness preK) .interpretation
+
+    Kab≡a : ∀ a b → K ⨾ a ⨾ b ≡ a
+    Kab≡a a b = (completeness preK) .naturality (a ∷ b ∷ [])
+
+    Sabc≡ac_bc : ∀ a b c → S ⨾ a ⨾ b ⨾ c ≡ (a ⨾ c) ⨾ (b ⨾ c)
+    Sabc≡ac_bc a b c = (completeness preS) .naturality (a ∷ b ∷ c ∷ [])
+    open Feferman
+    completeness→feferman : Feferman
+    completeness→feferman .s = S
+    completeness→feferman .k = K
+    completeness→feferman .kab≡a = Kab≡a
+    completeness→feferman .sabc≡ac_bc = Sabc≡ac_bc
+
+  module _ (feferman : Feferman) where
+    open Feferman feferman
+    {-
+    This goofy definition is there to ensure that λ* computes.
+    For some reason the last branch of pattern-matching cannot definitionally equate y .fst and suc m
+    So we must postulate it.
+    But since we already know that y .fst = suc m we can use discreteℕ to get an actual proof and extract
+    it using fromYes. fromYes then gets a dummy proof
+    -}
+    λ* : ∀ {n} (e : Term (suc n)) → Term n
+    λ* (` a) = ` k ̇ ` a
+    λ* (a ̇ b) = ` s ̇ (λ* a) ̇ (λ* b)
+    λ* {n} (# y) with (discreteℕ (y .fst) zero)
+    ... | yes _ = ` s ̇ ` k ̇ ` k
+    ... | no ¬y≡zero with (y .fst)
+    ...     | zero = ⊥elim (¬y≡zero refl)
+    ...     | (suc m) = # (m , pred-≤-pred (subst (λ y' → suc y' ≤ suc n) (fromYes fsty≡sucm (discreteℕ (y .fst) (suc m))) (y .snd))) where postulate fsty≡sucm : fst y ≡ suc m
+
+    λ*-chainTerm : ∀ n → Term n → Term zero
+    λ*-chainTerm zero t = t
+    λ*-chainTerm (suc n) t = λ*-chainTerm n (λ* t)
+
+    λ*-chain : ∀ {n} → Term n → A
+    λ*-chain {n} t = substitute (λ*-chainTerm n t) []
+
+    ⟦_⟧ : Term zero → A
+    ⟦ ` a ⟧ = a
+    ⟦ a ̇ b ⟧ = ⟦ a ⟧ ⨾ ⟦ b ⟧
+    ⟦ # x ⟧ = ⊥elim {A = λ _ → A} (¬Fin0 x)
+
+    open isInterpreted
+
+    postulate λ*-naturality : ∀ {n} (t : Term n) (subs : Vec A n) → apply (λ*-chain t) subs ≡ substitute t subs
     
-    feferman→completeness : isCombinatoriallyComplete
-    feferman→completeness t .interpretation = λ*-chain t
-    feferman→completeness t .naturality subs = λ*-naturality t subs
+    feferman→completeness : isCombinatoriallyComplete
+    feferman→completeness t .interpretation = λ*-chain t
+    feferman→completeness t .naturality subs = λ*-naturality t subs
     
 
 

\ No newline at end of file
diff --git a/docs/Realizability.Assembly.Base.html b/docs/Realizability.Assembly.Base.html
index cf10fb6..c8d2e21 100644
--- a/docs/Realizability.Assembly.Base.html
+++ b/docs/Realizability.Assembly.Base.html
@@ -2,30 +2,34 @@
 Realizability.Assembly.Base
{-# OPTIONS --cubical #-}
 open import Cubical.Foundations.Prelude
 open import Cubical.Foundations.HLevels
-open import Cubical.Data.Sigma
-open import Cubical.Reflection.RecordEquiv
-open import Realizability.CombinatoryAlgebra
+open import Cubical.Foundations.Structure
+open import Cubical.Data.Sigma
+open import Cubical.HITs.PropositionalTruncation
+open import Cubical.Reflection.RecordEquiv
+open import Realizability.CombinatoryAlgebra
 
-module Realizability.Assembly.Base {ℓ} {A : Type ℓ} (ca : CombinatoryAlgebra A) where
-  record Assembly (X : Type ℓ) : Type (ℓ-suc ℓ) where
-    infix 25 _⊩_
-    field
-      isSetX : isSet X
-      _⊩_ : A → X → Type ℓ
-      ⊩isPropValued : ∀ a x → isProp (a ⊩ x)
-      ⊩surjective : ∀ x → ∃[ a ∈ A ] a ⊩ x
+module Realizability.Assembly.Base {ℓ} {A : Type ℓ} (ca : CombinatoryAlgebra A) where
+  record Assembly (X : Type ℓ) : Type (ℓ-suc ℓ) where
+    infix 25 _⊩_
+    field
+      isSetX : isSet X
+      _⊩_ : A → X → Type ℓ
+      ⊩isPropValued : ∀ a x → isProp (a ⊩ x)
+      ⊩surjective : ∀ x → ∃[ a ∈ A ] a ⊩ x
 
 
-  AssemblyΣ : Type ℓ → Type _
-  AssemblyΣ X =
-    Σ[ isSetX ∈ isSet X ]
-    Σ[ _⊩_ ∈ (A → X → Type ℓ) ]
-    Σ[ ⊩isPropValued ∈ (∀ a x → isProp (a ⊩ x)) ]
-    (∀ x → ∃[ a ∈ A ] a ⊩ x)
+  AssemblyΣ : Type ℓ → Type _
+  AssemblyΣ X =
+    Σ[ isSetX ∈ isSet X ]
+    Σ[ _⊩_ ∈ (A → X → hProp ℓ) ]
+    (∀ x → ∃[ a ∈ A ] ⟨ a ⊩ x ⟩)
+
+  isSetAssemblyΣ : ∀ X → isSet (AssemblyΣ X)
+  isSetAssemblyΣ X = isSetΣ (isProp→isSet isPropIsSet) λ isSetX → isSetΣ (isSetΠ (λ a → isSetΠ λ x → isSetHProp)) λ _⊩_ → isSetΠ λ x → isProp→isSet isPropPropTrunc
   
-  unquoteDecl AssemblyIsoΣ = declareRecordIsoΣ AssemblyIsoΣ (quote Assembly)
+  unquoteDecl AssemblyIsoΣ = declareRecordIsoΣ AssemblyIsoΣ (quote Assembly)
 
-  open Assembly public
+  open Assembly public
 
   
 

\ No newline at end of file
diff --git a/docs/Realizability.Assembly.BinCoproducts.html b/docs/Realizability.Assembly.BinCoproducts.html
index df04939..65f33c6 100644
--- a/docs/Realizability.Assembly.BinCoproducts.html
+++ b/docs/Realizability.Assembly.BinCoproducts.html
@@ -15,36 +15,36 @@
 open import Realizability.Assembly.Morphism ca
 
 infixl 23 _⊕_
-_⊕_ : {A B : Type ℓ} → Assembly A → Assembly B → Assembly (A ⊎ B)
-(as ⊕ bs) .isSetX = isSet⊎ (as .isSetX) (bs .isSetX)
-(as ⊕ bs) ._⊩_ r (inl a) = ∃[ aᵣ ∈ A ] (as ._⊩_ aᵣ a) × (r ≡ pair ⨾ true ⨾ aᵣ)
-(as ⊕ bs) ._⊩_ r (inr b) = ∃[ bᵣ ∈ A ] (bs ._⊩_ bᵣ b) × (r ≡ pair ⨾ false ⨾ bᵣ)
-(as ⊕ bs) .⊩isPropValued r (inl a) = squash₁
-(as ⊕ bs) .⊩isPropValued r (inr b) = squash₁
-(as ⊕ bs) .⊩surjective (inl a) =
+_⊕_ : {A B : Type ℓ} → Assembly A → Assembly B → Assembly (A ⊎ B)
+(as ⊕ bs) .isSetX = isSet⊎ (as .isSetX) (bs .isSetX)
+(as ⊕ bs) ._⊩_ r (inl a) = ∃[ aᵣ ∈ A ] (as ._⊩_ aᵣ a) × (r ≡ pair ⨾ true ⨾ aᵣ)
+(as ⊕ bs) ._⊩_ r (inr b) = ∃[ bᵣ ∈ A ] (bs ._⊩_ bᵣ b) × (r ≡ pair ⨾ false ⨾ bᵣ)
+(as ⊕ bs) .⊩isPropValued r (inl a) = squash₁
+(as ⊕ bs) .⊩isPropValued r (inr b) = squash₁
+(as ⊕ bs) .⊩surjective (inl a) =
                                do
-                               (a~ , a~realizes) ← as .⊩surjective a
-                               return ( pair ⨾ true ⨾ a~
+                               (a~ , a~realizes) ← as .⊩surjective a
+                               return ( pair ⨾ true ⨾ a~
                                       , ∣ a~
                                       , a~realizes
                                       , refl ∣₁
                                       )
-(as ⊕ bs) .⊩surjective (inr b) =
+(as ⊕ bs) .⊩surjective (inr b) =
                                do
-                               (b~ , b~realizes) ← bs .⊩surjective b
-                               return ( pair ⨾ false ⨾ b~
+                               (b~ , b~realizes) ← bs .⊩surjective b
+                               return ( pair ⨾ false ⨾ b~
                                       , ∣ b~
                                       , b~realizes
                                       , refl ∣₁
                                       )
                                         
-κ₁ : {A B : Type ℓ} {as : Assembly A} {bs : Assembly B} → AssemblyMorphism as (as ⊕ bs)
+κ₁ : {A B : Type ℓ} {as : Assembly A} {bs : Assembly B} → AssemblyMorphism as (as ⊕ bs)
 κ₁ .map = inl
-κ₁ .tracker = ∣ pair ⨾ true , (λ x aₓ aₓ⊩x → ∣ aₓ , aₓ⊩x , refl ∣₁) ∣₁
+κ₁ .tracker = ∣ pair ⨾ true , (λ x aₓ aₓ⊩x → ∣ aₓ , aₓ⊩x , refl ∣₁) ∣₁
 
-κ₂ : {A B : Type ℓ} {as : Assembly A} {bs : Assembly B} → AssemblyMorphism bs (as ⊕ bs)
+κ₂ : {A B : Type ℓ} {as : Assembly A} {bs : Assembly B} → AssemblyMorphism bs (as ⊕ bs)
 κ₂ .map b = inr b
-κ₂ .tracker = ∣ pair ⨾ false , (λ x bₓ bₓ⊩x → ∣ bₓ , bₓ⊩x , refl ∣₁) ∣₁
+κ₂ .tracker = ∣ pair ⨾ false , (λ x bₓ bₓ⊩x → ∣ bₓ , bₓ⊩x , refl ∣₁) ∣₁
 
 -- TODO : Universal Property
\ No newline at end of file diff --git a/docs/Realizability.Assembly.BinProducts.html b/docs/Realizability.Assembly.BinProducts.html index 98c7a39..32c3a6e 100644 --- a/docs/Realizability.Assembly.BinProducts.html +++ b/docs/Realizability.Assembly.BinProducts.html @@ -14,29 +14,29 @@ open import Realizability.Assembly.Base ca open import Realizability.Assembly.Morphism ca open CombinatoryAlgebra ca -open Assembly +open Assembly open AssemblyMorphism infixl 23 _⊗_ -_⊗_ : {A B : Type ℓ} → Assembly A → Assembly B → Assembly (A × B) -(as ⊗ bs) .isSetX = isSetΣ (as .isSetX) (λ _ → bs .isSetX) -(as ⊗ bs) ._⊩_ r (a , b) = (as ._⊩_ (pr₁ ⨾ r) a) × (bs ._⊩_ (pr₂ ⨾ r) b) -(as ⊗ bs) .⊩isPropValued r (a , b) = isPropΣ (as .⊩isPropValued (pr₁ ⨾ r) a) - (λ _ → bs .⊩isPropValued (pr₂ ⨾ r) b) -(as ⊗ bs) .⊩surjective (a , b) = do - (b~ , b~realizes) ← bs .⊩surjective b - (a~ , a~realizes) ← as .⊩surjective a +_⊗_ : {A B : Type ℓ} → Assembly A → Assembly B → Assembly (A × B) +(as ⊗ bs) .isSetX = isSetΣ (as .isSetX) (λ _ → bs .isSetX) +(as ⊗ bs) ._⊩_ r (a , b) = (as ._⊩_ (pr₁ ⨾ r) a) × (bs ._⊩_ (pr₂ ⨾ r) b) +(as ⊗ bs) .⊩isPropValued r (a , b) = isPropΣ (as .⊩isPropValued (pr₁ ⨾ r) a) + (λ _ → bs .⊩isPropValued (pr₂ ⨾ r) b) +(as ⊗ bs) .⊩surjective (a , b) = do + (b~ , b~realizes) ← bs .⊩surjective b + (a~ , a~realizes) ← as .⊩surjective a return - ( pair ⨾ a~ ⨾ b~ - , subst (λ x → as ._⊩_ x a) (sym (pr₁pxy≡x a~ b~)) a~realizes - , subst (λ x → bs ._⊩_ x b) (sym (pr₂pxy≡y a~ b~)) b~realizes + ( pair ⨾ a~ ⨾ b~ + , subst (λ x → as ._⊩_ x a) (sym (pr₁pxy≡x a~ b~)) a~realizes + , subst (λ x → bs ._⊩_ x b) (sym (pr₂pxy≡y a~ b~)) b~realizes ) ⟪_,_⟫ : {X Y Z W : Type ℓ} - {xs : Assembly X} - {ys : Assembly Y} - {zs : Assembly Z} - {ws : Assembly W} + {xs : Assembly X} + {ys : Assembly Y} + {zs : Assembly Z} + {ws : Assembly W} (f : AssemblyMorphism xs ys) (g : AssemblyMorphism zs ws) → AssemblyMorphism (xs ⊗ zs) (ys ⊗ ws) @@ -44,59 +44,59 @@ ⟪_,_⟫ {ys = ys} {ws = ws} f g .tracker = (do (f~ , f~tracks) ← f .tracker (g~ , g~tracks) ← g .tracker - return (s ⨾ (s ⨾ (k ⨾ pair) ⨾ (s ⨾ (k ⨾ f~) ⨾ (s ⨾ (k ⨾ pr₁) ⨾ Id))) ⨾ (s ⨾ (k ⨾ g~) ⨾ (s ⨾ (k ⨾ pr₂) ⨾ Id)) + return (s ⨾ (s ⨾ (k ⨾ pair) ⨾ (s ⨾ (k ⨾ f~) ⨾ (s ⨾ (k ⨾ pr₁) ⨾ Id))) ⨾ (s ⨾ (k ⨾ g~) ⨾ (s ⨾ (k ⨾ pr₂) ⨾ Id)) , λ xz r r⊩xz → - ( subst (λ y → ys ._⊩_ y (f .map (xz .fst))) + ( subst (λ y → ys ._⊩_ y (f .map (xz .fst))) (sym (subst _ (sym (t⨾r≡pair_fg f~ g~ r)) - (pr₁pxy≡x (f~ ⨾ (pr₁ ⨾ r)) (g~ ⨾ (pr₂ ⨾ r))))) - (f~tracks (xz .fst) (pr₁ ⨾ r) (r⊩xz .fst))) - , subst (λ y → ws ._⊩_ y (g .map (xz .snd))) + (pr₁pxy≡x (f~ ⨾ (pr₁ ⨾ r)) (g~ ⨾ (pr₂ ⨾ r))))) + (f~tracks (xz .fst) (pr₁ ⨾ r) (r⊩xz .fst))) + , subst (λ y → ws ._⊩_ y (g .map (xz .snd))) (sym (subst _ (sym (t⨾r≡pair_fg f~ g~ r)) - (pr₂pxy≡y (f~ ⨾ (pr₁ ⨾ r)) (g~ ⨾ (pr₂ ⨾ r))))) - (g~tracks (xz .snd) (pr₂ ⨾ r) (r⊩xz .snd)))) + (pr₂pxy≡y (f~ ⨾ (pr₁ ⨾ r)) (g~ ⨾ (pr₂ ⨾ r))))) + (g~tracks (xz .snd) (pr₂ ⨾ r) (r⊩xz .snd)))) where module _ (f~ g~ r : A) where - subf≡fprr : ∀ f pr → (s ⨾ (k ⨾ f) ⨾ (s ⨾ (k ⨾ pr) ⨾ Id) ⨾ r) ≡ (f ⨾ (pr ⨾ r)) + subf≡fprr : ∀ f pr → (s ⨾ (k ⨾ f) ⨾ (s ⨾ (k ⨾ pr) ⨾ Id) ⨾ r) ≡ (f ⨾ (pr ⨾ r)) subf≡fprr f pr = - s ⨾ (k ⨾ f) ⨾ (s ⨾ (k ⨾ pr) ⨾ Id) ⨾ r - ≡⟨ sabc≡ac_bc _ _ _ ⟩ - (k ⨾ f ⨾ r) ⨾ (s ⨾ (k ⨾ pr) ⨾ Id ⨾ r) - ≡⟨ cong (λ x → x ⨾ _) (kab≡a f r) ⟩ - f ⨾ (s ⨾ (k ⨾ pr) ⨾ Id ⨾ r) - ≡⟨ cong (λ x → f ⨾ x) (sabc≡ac_bc _ _ _) ⟩ - f ⨾ (k ⨾ pr ⨾ r ⨾ (Id ⨾ r)) - ≡⟨ cong (λ x → f ⨾ (x ⨾ (Id ⨾ r))) (kab≡a _ _ ) ⟩ - f ⨾ (pr ⨾ (Id ⨾ r)) - ≡⟨ cong (λ x → f ⨾ (pr ⨾ x)) (Ida≡a r) ⟩ - f ⨾ (pr ⨾ r) + s ⨾ (k ⨾ f) ⨾ (s ⨾ (k ⨾ pr) ⨾ Id) ⨾ r + ≡⟨ sabc≡ac_bc _ _ _ ⟩ + (k ⨾ f ⨾ r) ⨾ (s ⨾ (k ⨾ pr) ⨾ Id ⨾ r) + ≡⟨ cong (λ x → x ⨾ _) (kab≡a f r) ⟩ + f ⨾ (s ⨾ (k ⨾ pr) ⨾ Id ⨾ r) + ≡⟨ cong (λ x → f ⨾ x) (sabc≡ac_bc _ _ _) ⟩ + f ⨾ (k ⨾ pr ⨾ r ⨾ (Id ⨾ r)) + ≡⟨ cong (λ x → f ⨾ (x ⨾ (Id ⨾ r))) (kab≡a _ _ ) ⟩ + f ⨾ (pr ⨾ (Id ⨾ r)) + ≡⟨ cong (λ x → f ⨾ (pr ⨾ x)) (Ida≡a r) ⟩ + f ⨾ (pr ⨾ r) ∎ t⨾r≡pair_fg : - s ⨾ (s ⨾ (k ⨾ pair) ⨾ (s ⨾ (k ⨾ f~) ⨾ (s ⨾ (k ⨾ pr₁) ⨾ Id))) ⨾ (s ⨾ (k ⨾ g~) ⨾ (s ⨾ (k ⨾ pr₂) ⨾ Id)) ⨾ r - ≡ pair ⨾ (f~ ⨾ (pr₁ ⨾ r)) ⨾ (g~ ⨾ (pr₂ ⨾ r)) + s ⨾ (s ⨾ (k ⨾ pair) ⨾ (s ⨾ (k ⨾ f~) ⨾ (s ⨾ (k ⨾ pr₁) ⨾ Id))) ⨾ (s ⨾ (k ⨾ g~) ⨾ (s ⨾ (k ⨾ pr₂) ⨾ Id)) ⨾ r + ≡ pair ⨾ (f~ ⨾ (pr₁ ⨾ r)) ⨾ (g~ ⨾ (pr₂ ⨾ r)) t⨾r≡pair_fg = - s ⨾ (s ⨾ (k ⨾ pair) ⨾ (s ⨾ (k ⨾ f~) ⨾ (s ⨾ (k ⨾ pr₁) ⨾ Id))) ⨾ (s ⨾ (k ⨾ g~) ⨾ (s ⨾ (k ⨾ pr₂) ⨾ Id)) ⨾ r - ≡⟨ sabc≡ac_bc _ _ _ ⟩ - s ⨾ (k ⨾ pair) ⨾ (s ⨾ (k ⨾ f~) ⨾ (s ⨾ (k ⨾ pr₁) ⨾ Id)) ⨾ r ⨾ (s ⨾ (k ⨾ g~) ⨾ (s ⨾ (k ⨾ pr₂) ⨾ Id) ⨾ r) - ≡⟨ cong (λ x → x ⨾ (s ⨾ (k ⨾ g~) ⨾ (s ⨾ (k ⨾ pr₂) ⨾ Id) ⨾ r)) (sabc≡ac_bc _ _ _) ⟩ - k ⨾ pair ⨾ r ⨾ (s ⨾ (k ⨾ f~) ⨾ (s ⨾ (k ⨾ pr₁) ⨾ Id) ⨾ r) ⨾ (s ⨾ (k ⨾ g~) ⨾ (s ⨾ (k ⨾ pr₂) ⨾ Id) ⨾ r) - ≡⟨ cong (λ x → x ⨾ (s ⨾ (k ⨾ f~) ⨾ (s ⨾ (k ⨾ pr₁) ⨾ Id) ⨾ r) ⨾ (s ⨾ (k ⨾ g~) ⨾ (s ⨾ (k ⨾ pr₂) ⨾ Id) ⨾ r)) - (kab≡a pair r) ⟩ - pair ⨾ (s ⨾ (k ⨾ f~) ⨾ (s ⨾ (k ⨾ pr₁) ⨾ Id) ⨾ r) ⨾ (s ⨾ (k ⨾ g~) ⨾ (s ⨾ (k ⨾ pr₂) ⨾ Id) ⨾ r) - ≡⟨ cong₂ (λ x y → pair ⨾ x ⨾ y) (subf≡fprr f~ pr₁) (subf≡fprr g~ pr₂) ⟩ - pair ⨾ (f~ ⨾ (pr₁ ⨾ r)) ⨾ (g~ ⨾ (pr₂ ⨾ r)) + s ⨾ (s ⨾ (k ⨾ pair) ⨾ (s ⨾ (k ⨾ f~) ⨾ (s ⨾ (k ⨾ pr₁) ⨾ Id))) ⨾ (s ⨾ (k ⨾ g~) ⨾ (s ⨾ (k ⨾ pr₂) ⨾ Id)) ⨾ r + ≡⟨ sabc≡ac_bc _ _ _ ⟩ + s ⨾ (k ⨾ pair) ⨾ (s ⨾ (k ⨾ f~) ⨾ (s ⨾ (k ⨾ pr₁) ⨾ Id)) ⨾ r ⨾ (s ⨾ (k ⨾ g~) ⨾ (s ⨾ (k ⨾ pr₂) ⨾ Id) ⨾ r) + ≡⟨ cong (λ x → x ⨾ (s ⨾ (k ⨾ g~) ⨾ (s ⨾ (k ⨾ pr₂) ⨾ Id) ⨾ r)) (sabc≡ac_bc _ _ _) ⟩ + k ⨾ pair ⨾ r ⨾ (s ⨾ (k ⨾ f~) ⨾ (s ⨾ (k ⨾ pr₁) ⨾ Id) ⨾ r) ⨾ (s ⨾ (k ⨾ g~) ⨾ (s ⨾ (k ⨾ pr₂) ⨾ Id) ⨾ r) + ≡⟨ cong (λ x → x ⨾ (s ⨾ (k ⨾ f~) ⨾ (s ⨾ (k ⨾ pr₁) ⨾ Id) ⨾ r) ⨾ (s ⨾ (k ⨾ g~) ⨾ (s ⨾ (k ⨾ pr₂) ⨾ Id) ⨾ r)) + (kab≡a pair r) ⟩ + pair ⨾ (s ⨾ (k ⨾ f~) ⨾ (s ⨾ (k ⨾ pr₁) ⨾ Id) ⨾ r) ⨾ (s ⨾ (k ⨾ g~) ⨾ (s ⨾ (k ⨾ pr₂) ⨾ Id) ⨾ r) + ≡⟨ cong₂ (λ x y → pair ⨾ x ⨾ y) (subf≡fprr f~ pr₁) (subf≡fprr g~ pr₂) ⟩ + pair ⨾ (f~ ⨾ (pr₁ ⨾ r)) ⨾ (g~ ⨾ (pr₂ ⨾ r)) ∎ -π₁ : {A B : Type ℓ} {as : Assembly A} {bs : Assembly B} → AssemblyMorphism (as ⊗ bs) as +π₁ : {A B : Type ℓ} {as : Assembly A} {bs : Assembly B} → AssemblyMorphism (as ⊗ bs) as π₁ .map (a , b) = a π₁ .tracker = ∣ pr₁ , (λ (a , b) p (goal , _) → goal) ∣₁ -π₂ : {A B : Type ℓ} {as : Assembly A} {bs : Assembly B} → AssemblyMorphism (as ⊗ bs) bs +π₂ : {A B : Type ℓ} {as : Assembly A} {bs : Assembly B} → AssemblyMorphism (as ⊗ bs) bs π₂ .map (a , b) = b π₂ .tracker = ∣ pr₂ , (λ (a , b) p (_ , goal) → goal) ∣₁ ⟨_,_⟩ : {X Y Z : Type ℓ} - → {xs : Assembly X} {ys : Assembly Y} {zs : Assembly Z} + → {xs : Assembly X} {ys : Assembly Y} {zs : Assembly Z} → AssemblyMorphism zs xs → AssemblyMorphism zs ys → AssemblyMorphism zs (xs ⊗ ys) @@ -106,62 +106,62 @@ ((f~ , f~tracks) : Σ[ f~ ∈ A ] tracks {xs = zs} {ys = xs} f~ (f .map)) ((g~ , g~tracks) : Σ[ g~ ∈ A ] tracks {xs = zs} {ys = ys} g~ (g .map)) where - _⊩X_ = xs ._⊩_ - _⊩Y_ = ys ._⊩_ - _⊩Z_ = zs ._⊩_ + _⊩X_ = xs ._⊩_ + _⊩Y_ = ys ._⊩_ + _⊩Z_ = zs ._⊩_ - t = s ⨾ (s ⨾ (k ⨾ pair) ⨾ (s ⨾ (k ⨾ f~) ⨾ Id)) ⨾ (s ⨾ (k ⨾ g~) ⨾ Id) - untruncated : Σ[ t ∈ A ] (∀ z zᵣ zᵣ⊩z → ((pr₁ ⨾ (t ⨾ zᵣ)) ⊩X (f .map z)) × ((pr₂ ⨾ (t ⨾ zᵣ)) ⊩Y (g .map z))) + t = s ⨾ (s ⨾ (k ⨾ pair) ⨾ (s ⨾ (k ⨾ f~) ⨾ Id)) ⨾ (s ⨾ (k ⨾ g~) ⨾ Id) + untruncated : Σ[ t ∈ A ] (∀ z zᵣ zᵣ⊩z → ((pr₁ ⨾ (t ⨾ zᵣ)) ⊩X (f .map z)) × ((pr₂ ⨾ (t ⨾ zᵣ)) ⊩Y (g .map z))) untruncated = t , λ z zᵣ zᵣ⊩z → goal₁ z zᵣ zᵣ⊩z , goal₂ z zᵣ zᵣ⊩z where module _ (z : Z) (zᵣ : A) (zᵣ⊩z : zᵣ ⊩Z z) where - pr₁⨾tracker⨾zᵣ≡f~⨾zᵣ : pr₁ ⨾ (t ⨾ zᵣ) ≡ f~ ⨾ zᵣ + pr₁⨾tracker⨾zᵣ≡f~⨾zᵣ : pr₁ ⨾ (t ⨾ zᵣ) ≡ f~ ⨾ zᵣ pr₁⨾tracker⨾zᵣ≡f~⨾zᵣ = - pr₁ ⨾ (s ⨾ (s ⨾ (k ⨾ pair) ⨾ (s ⨾ (k ⨾ f~) ⨾ Id)) ⨾ (s ⨾ (k ⨾ g~) ⨾ Id) ⨾ zᵣ) - ≡⟨ cong (λ x → pr₁ ⨾ x) (sabc≡ac_bc _ _ _) ⟩ - pr₁ ⨾ (s ⨾ (k ⨾ pair) ⨾ (s ⨾ (k ⨾ f~) ⨾ Id) ⨾ zᵣ ⨾ (s ⨾ (k ⨾ g~) ⨾ Id ⨾ zᵣ)) - ≡⟨ cong (λ x → pr₁ ⨾ (x ⨾ (s ⨾ (k ⨾ g~) ⨾ Id ⨾ zᵣ))) (sabc≡ac_bc _ _ _) ⟩ - pr₁ ⨾ (k ⨾ pair ⨾ zᵣ ⨾ (s ⨾ (k ⨾ f~) ⨾ Id ⨾ zᵣ) ⨾ (s ⨾ (k ⨾ g~) ⨾ Id ⨾ zᵣ)) - ≡⟨ cong (λ x → pr₁ ⨾ (x ⨾ (s ⨾ (k ⨾ f~) ⨾ Id ⨾ zᵣ) ⨾ (s ⨾ (k ⨾ g~) ⨾ Id ⨾ zᵣ))) (kab≡a _ _) ⟩ - pr₁ ⨾ (pair ⨾ (s ⨾ (k ⨾ f~) ⨾ Id ⨾ zᵣ) ⨾ (s ⨾ (k ⨾ g~) ⨾ Id ⨾ zᵣ)) + pr₁ ⨾ (s ⨾ (s ⨾ (k ⨾ pair) ⨾ (s ⨾ (k ⨾ f~) ⨾ Id)) ⨾ (s ⨾ (k ⨾ g~) ⨾ Id) ⨾ zᵣ) + ≡⟨ cong (λ x → pr₁ ⨾ x) (sabc≡ac_bc _ _ _) ⟩ + pr₁ ⨾ (s ⨾ (k ⨾ pair) ⨾ (s ⨾ (k ⨾ f~) ⨾ Id) ⨾ zᵣ ⨾ (s ⨾ (k ⨾ g~) ⨾ Id ⨾ zᵣ)) + ≡⟨ cong (λ x → pr₁ ⨾ (x ⨾ (s ⨾ (k ⨾ g~) ⨾ Id ⨾ zᵣ))) (sabc≡ac_bc _ _ _) ⟩ + pr₁ ⨾ (k ⨾ pair ⨾ zᵣ ⨾ (s ⨾ (k ⨾ f~) ⨾ Id ⨾ zᵣ) ⨾ (s ⨾ (k ⨾ g~) ⨾ Id ⨾ zᵣ)) + ≡⟨ cong (λ x → pr₁ ⨾ (x ⨾ (s ⨾ (k ⨾ f~) ⨾ Id ⨾ zᵣ) ⨾ (s ⨾ (k ⨾ g~) ⨾ Id ⨾ zᵣ))) (kab≡a _ _) ⟩ + pr₁ ⨾ (pair ⨾ (s ⨾ (k ⨾ f~) ⨾ Id ⨾ zᵣ) ⨾ (s ⨾ (k ⨾ g~) ⨾ Id ⨾ zᵣ)) ≡⟨ pr₁pxy≡x _ _ ⟩ - s ⨾ (k ⨾ f~) ⨾ Id ⨾ zᵣ - ≡⟨ sabc≡ac_bc _ _ _ ⟩ - k ⨾ f~ ⨾ zᵣ ⨾ (Id ⨾ zᵣ) - ≡⟨ cong (λ x → x ⨾ (Id ⨾ zᵣ)) (kab≡a _ _) ⟩ - f~ ⨾ (Id ⨾ zᵣ) - ≡⟨ cong (λ x → f~ ⨾ x) (Ida≡a _) ⟩ - f~ ⨾ zᵣ + s ⨾ (k ⨾ f~) ⨾ Id ⨾ zᵣ + ≡⟨ sabc≡ac_bc _ _ _ ⟩ + k ⨾ f~ ⨾ zᵣ ⨾ (Id ⨾ zᵣ) + ≡⟨ cong (λ x → x ⨾ (Id ⨾ zᵣ)) (kab≡a _ _) ⟩ + f~ ⨾ (Id ⨾ zᵣ) + ≡⟨ cong (λ x → f~ ⨾ x) (Ida≡a _) ⟩ + f~ ⨾ zᵣ ∎ - pr₂⨾tracker⨾zᵣ≡g~⨾zᵣ : pr₂ ⨾ (t ⨾ zᵣ) ≡ g~ ⨾ zᵣ + pr₂⨾tracker⨾zᵣ≡g~⨾zᵣ : pr₂ ⨾ (t ⨾ zᵣ) ≡ g~ ⨾ zᵣ pr₂⨾tracker⨾zᵣ≡g~⨾zᵣ = - pr₂ ⨾ (s ⨾ (s ⨾ (k ⨾ pair) ⨾ (s ⨾ (k ⨾ f~) ⨾ Id)) ⨾ (s ⨾ (k ⨾ g~) ⨾ Id) ⨾ zᵣ) - ≡⟨ cong (λ x → pr₂ ⨾ x) (sabc≡ac_bc _ _ _) ⟩ - pr₂ ⨾ (s ⨾ (k ⨾ pair) ⨾ (s ⨾ (k ⨾ f~) ⨾ Id) ⨾ zᵣ ⨾ (s ⨾ (k ⨾ g~) ⨾ Id ⨾ zᵣ)) - ≡⟨ cong (λ x → pr₂ ⨾ (x ⨾ (s ⨾ (k ⨾ g~) ⨾ Id ⨾ zᵣ))) (sabc≡ac_bc _ _ _) ⟩ - pr₂ ⨾ (k ⨾ pair ⨾ zᵣ ⨾ (s ⨾ (k ⨾ f~) ⨾ Id ⨾ zᵣ) ⨾ (s ⨾ (k ⨾ g~) ⨾ Id ⨾ zᵣ)) - ≡⟨ cong (λ x → pr₂ ⨾ (x ⨾ (s ⨾ (k ⨾ f~) ⨾ Id ⨾ zᵣ) ⨾ (s ⨾ (k ⨾ g~) ⨾ Id ⨾ zᵣ))) (kab≡a _ _) ⟩ - pr₂ ⨾ (pair ⨾ (s ⨾ (k ⨾ f~) ⨾ Id ⨾ zᵣ) ⨾ (s ⨾ (k ⨾ g~) ⨾ Id ⨾ zᵣ)) + pr₂ ⨾ (s ⨾ (s ⨾ (k ⨾ pair) ⨾ (s ⨾ (k ⨾ f~) ⨾ Id)) ⨾ (s ⨾ (k ⨾ g~) ⨾ Id) ⨾ zᵣ) + ≡⟨ cong (λ x → pr₂ ⨾ x) (sabc≡ac_bc _ _ _) ⟩ + pr₂ ⨾ (s ⨾ (k ⨾ pair) ⨾ (s ⨾ (k ⨾ f~) ⨾ Id) ⨾ zᵣ ⨾ (s ⨾ (k ⨾ g~) ⨾ Id ⨾ zᵣ)) + ≡⟨ cong (λ x → pr₂ ⨾ (x ⨾ (s ⨾ (k ⨾ g~) ⨾ Id ⨾ zᵣ))) (sabc≡ac_bc _ _ _) ⟩ + pr₂ ⨾ (k ⨾ pair ⨾ zᵣ ⨾ (s ⨾ (k ⨾ f~) ⨾ Id ⨾ zᵣ) ⨾ (s ⨾ (k ⨾ g~) ⨾ Id ⨾ zᵣ)) + ≡⟨ cong (λ x → pr₂ ⨾ (x ⨾ (s ⨾ (k ⨾ f~) ⨾ Id ⨾ zᵣ) ⨾ (s ⨾ (k ⨾ g~) ⨾ Id ⨾ zᵣ))) (kab≡a _ _) ⟩ + pr₂ ⨾ (pair ⨾ (s ⨾ (k ⨾ f~) ⨾ Id ⨾ zᵣ) ⨾ (s ⨾ (k ⨾ g~) ⨾ Id ⨾ zᵣ)) ≡⟨ pr₂pxy≡y _ _ ⟩ - s ⨾ (k ⨾ g~) ⨾ Id ⨾ zᵣ - ≡⟨ sabc≡ac_bc _ _ _ ⟩ - k ⨾ g~ ⨾ zᵣ ⨾ (Id ⨾ zᵣ) - ≡⟨ cong (λ x → x ⨾ (Id ⨾ zᵣ)) (kab≡a _ _) ⟩ - g~ ⨾ (Id ⨾ zᵣ) - ≡⟨ cong (λ x → g~ ⨾ x) (Ida≡a _) ⟩ - g~ ⨾ zᵣ + s ⨾ (k ⨾ g~) ⨾ Id ⨾ zᵣ + ≡⟨ sabc≡ac_bc _ _ _ ⟩ + k ⨾ g~ ⨾ zᵣ ⨾ (Id ⨾ zᵣ) + ≡⟨ cong (λ x → x ⨾ (Id ⨾ zᵣ)) (kab≡a _ _) ⟩ + g~ ⨾ (Id ⨾ zᵣ) + ≡⟨ cong (λ x → g~ ⨾ x) (Ida≡a _) ⟩ + g~ ⨾ zᵣ ∎ - goal₁ : (pr₁ ⨾ (t ⨾ zᵣ)) ⊩X (f .map z) + goal₁ : (pr₁ ⨾ (t ⨾ zᵣ)) ⊩X (f .map z) goal₁ = subst (λ y → y ⊩X (f .map z)) (sym pr₁⨾tracker⨾zᵣ≡f~⨾zᵣ) (f~tracks z zᵣ zᵣ⊩z) - goal₂ : (pr₂ ⨾ (t ⨾ zᵣ)) ⊩Y (g .map z) + goal₂ : (pr₂ ⨾ (t ⨾ zᵣ)) ⊩Y (g .map z) goal₂ = subst (λ y → y ⊩Y (g .map z)) (sym pr₂⨾tracker⨾zᵣ≡g~⨾zᵣ) (g~tracks z zᵣ zᵣ⊩z) -module _ {X Y : Type ℓ} (xs : Assembly X) (ys : Assembly Y) where +module _ {X Y : Type ℓ} (xs : Assembly X) (ys : Assembly Y) where theπ₁ = π₁ {A = X} {B = Y} {as = xs} {bs = ys} theπ₂ = π₂ {A = X} {B = Y} {as = xs} {bs = ys} - isBinProduct⊗ : ((Z , zs) : Σ[ Z ∈ Type ℓ ] Assembly Z) + isBinProduct⊗ : ((Z , zs) : Σ[ Z ∈ Type ℓ ] Assembly Z) → (f : AssemblyMorphism zs xs) → (g : AssemblyMorphism zs ys) → ∃![ fg ∈ AssemblyMorphism zs (xs ⊗ ys) ] (fg ⊚ theπ₁ ≡ f) × (fg ⊚ theπ₂ ≡ g) diff --git a/docs/Realizability.Assembly.Coequalizers.html b/docs/Realizability.Assembly.Coequalizers.html index d0543b4..047e51e 100644 --- a/docs/Realizability.Assembly.Coequalizers.html +++ b/docs/Realizability.Assembly.Coequalizers.html @@ -17,13 +17,13 @@ module _ {X Y : Type ℓ} - (xs : Assembly X) - (ys : Assembly Y) + (xs : Assembly X) + (ys : Assembly Y) (f g : AssemblyMorphism xs ys) where private - _⊩X_ = xs ._⊩_ - _⊩Y_ = ys ._⊩_ + _⊩X_ = xs ._⊩_ + _⊩Y_ = ys ._⊩_ _⊩coeq_ : (a : A) (x : SetCoequalizer (f .map) (g .map)) → hProp ℓ a ⊩coeq x = @@ -33,20 +33,20 @@ (λ x i → (∃[ y' ∈ Y ] (coeq {f = f .map} {g = g .map} x i ≡ inc y') × (a ⊩Y y')) , squash₁) x - coequalizer : Assembly (SetCoequalizer (f .map) (g .map)) + coequalizer : Assembly (SetCoequalizer (f .map) (g .map)) ⊩coeqSurjective : (x : SetCoequalizer (f .map) (g .map)) → ∃[ a ∈ A ] ((a ⊩coeq x) .fst) - coequalizer .isSetX = squash - coequalizer ._⊩_ a x = (a ⊩coeq x) .fst - coequalizer .⊩isPropValued a x = (a ⊩coeq x) .snd - coequalizer .⊩surjective x = ⊩coeqSurjective x + coequalizer .isSetX = squash + coequalizer ._⊩_ a x = (a ⊩coeq x) .fst + coequalizer .⊩isPropValued a x = (a ⊩coeq x) .snd + coequalizer .⊩surjective x = ⊩coeqSurjective x ⊩coeqSurjective x = setCoequalizerElimProp {C = λ b → ∃[ a ∈ A ] ((a ⊩coeq b) .fst)} (λ x → squash₁) (λ b → do - (b~ , b~realizes) ← ys .⊩surjective b + (b~ , b~realizes) ← ys .⊩surjective b return (b~ , b~⊩coeq_inc_b b b~ b~realizes)) x where b~⊩coeq_inc_b : (b : Y) (b~ : A) (b~realizes : b~ ⊩Y b) → (b~ ⊩coeq inc b) .fst @@ -58,21 +58,21 @@ ιcoequalizer .map = inc ιcoequalizer .tracker = ∣ Id , (λ y yᵣ yᵣ⊩y → subst (λ r → (r ⊩coeq inc y) .fst) (sym (Ida≡a yᵣ)) ∣ y , refl , yᵣ⊩y ∣₁) ∣₁ - coequalizerFactors : ((Z , zs) : Σ[ Z ∈ Type ℓ ] Assembly Z) + coequalizerFactors : ((Z , zs) : Σ[ Z ∈ Type ℓ ] Assembly Z) → (ι' : AssemblyMorphism ys zs) → (f ⊚ ι' ≡ g ⊚ ι') → ∃![ ! ∈ AssemblyMorphism coequalizer zs ] (ιcoequalizer ⊚ ! ≡ ι') coequalizerFactors (Z , zs) ι' f⊚ι'≡g⊚ι' = uniqueExists (λ where - .map → setCoequalizerRec (zs .isSetX) (ι' .map) λ x → λ i → f⊚ι'≡g⊚ι' i .map x + .map → setCoequalizerRec (zs .isSetX) (ι' .map) λ x → λ i → f⊚ι'≡g⊚ι' i .map x .tracker → {!!}) (AssemblyMorphism≡ _ _ (funExt λ x → refl)) (λ ! → isSetAssemblyMorphism ys zs (ιcoequalizer ⊚ !) ι') λ ! ιcoequalizer⊚!≡ι' → AssemblyMorphism≡ _ _ (funExt λ x → setCoequalizerElimProp - {C = λ x → setCoequalizerRec (zs .isSetX) (ι' .map) (λ x₁ i → f⊚ι'≡g⊚ι' i .map x₁) x ≡ ! .map x} - (λ x → zs .isSetX _ _) (λ y → λ i → ιcoequalizer⊚!≡ι' (~ i) .map y) x) + {C = λ x → setCoequalizerRec (zs .isSetX) (ι' .map) (λ x₁ i → f⊚ι'≡g⊚ι' i .map x₁) x ≡ ! .map x} + (λ x → zs .isSetX _ _) (λ y → λ i → ιcoequalizer⊚!≡ι' (~ i) .map y) x) open Coequalizer open IsCoequalizer diff --git a/docs/Realizability.Assembly.Equalizers.html b/docs/Realizability.Assembly.Equalizers.html index 97ebeac..c9c04ab 100644 --- a/docs/Realizability.Assembly.Equalizers.html +++ b/docs/Realizability.Assembly.Equalizers.html @@ -13,19 +13,19 @@ open import Realizability.Assembly.Base ca open import Realizability.Assembly.Morphism ca -module _ {A B : Type ℓ} {as : Assembly A} {bs : Assembly B} (f g : AssemblyMorphism as bs) where - _⊩A_ = as ._⊩_ - equalizer : Assembly (Σ[ a ∈ A ] f .map a ≡ g .map a) - equalizer .isSetX = isSetΣ (as .isSetX) λ x → isProp→isSet (bs .isSetX (f .map x) (g .map x)) - equalizer ._⊩_ r (a , fa≡ga) = as ._⊩_ r a - equalizer .⊩isPropValued r (a , fa≡ga) = as .⊩isPropValued r a - equalizer .⊩surjective (a , fa≡ga) = as .⊩surjective a +module _ {A B : Type ℓ} {as : Assembly A} {bs : Assembly B} (f g : AssemblyMorphism as bs) where + _⊩A_ = as ._⊩_ + equalizer : Assembly (Σ[ a ∈ A ] f .map a ≡ g .map a) + equalizer .isSetX = isSetΣ (as .isSetX) λ x → isProp→isSet (bs .isSetX (f .map x) (g .map x)) + equalizer ._⊩_ r (a , fa≡ga) = as ._⊩_ r a + equalizer .⊩isPropValued r (a , fa≡ga) = as .⊩isPropValued r a + equalizer .⊩surjective (a , fa≡ga) = as .⊩surjective a ιequalizer : AssemblyMorphism equalizer as ιequalizer .map (a , fa≡ga) = a ιequalizer .tracker = ∣ Id , (λ x aₓ aₓ⊩x → subst (λ y → y ⊩A (x .fst)) (sym (Ida≡a aₓ)) aₓ⊩x) ∣₁ - equalizerFactors : ((Z , zs) : Σ[ Z ∈ Type ℓ ] (Assembly Z)) + equalizerFactors : ((Z , zs) : Σ[ Z ∈ Type ℓ ] (Assembly Z)) → (ι' : AssemblyMorphism zs as) → (ι' ⊚ f ≡ ι' ⊚ g) → ∃![ ! ∈ AssemblyMorphism zs equalizer ] (! ⊚ ιequalizer ≡ ι') @@ -36,7 +36,7 @@ (AssemblyMorphism≡ _ _ refl) (λ ! → isSetAssemblyMorphism _ _ (! ⊚ ιequalizer) ι') λ !' !'⊚ι≡ι' → AssemblyMorphism≡ _ _ - (funExt λ z → Σ≡Prop (λ x → bs .isSetX (f .map x) (g .map x)) + (funExt λ z → Σ≡Prop (λ x → bs .isSetX (f .map x) (g .map x)) (λ i → !'⊚ι≡ι' (~ i) .map z)) \ No newline at end of file diff --git a/docs/Realizability.Assembly.Exponentials.html b/docs/Realizability.Assembly.Exponentials.html index 6d5ffbb..ef49719 100644 --- a/docs/Realizability.Assembly.Exponentials.html +++ b/docs/Realizability.Assembly.Exponentials.html @@ -15,55 +15,55 @@ open import Realizability.Assembly.BinProducts ca -- Exponential objects -_⇒_ : {A B : Type ℓ} → (as : Assembly A) → (bs : Assembly B) → Assembly (AssemblyMorphism as bs) -(as ⇒ bs) .isSetX = isSetAssemblyMorphism as bs -(as ⇒ bs) ._⊩_ r f = tracks {xs = as} {ys = bs} r (f .map) -_⇒_ {A} {B} as bs .⊩isPropValued r f = isPropTracks {X = A} {Y = B} {xs = as} {ys = bs} r (f .map) -(as ⇒ bs) .⊩surjective f = f .tracker +_⇒_ : {A B : Type ℓ} → (as : Assembly A) → (bs : Assembly B) → Assembly (AssemblyMorphism as bs) +(as ⇒ bs) .isSetX = isSetAssemblyMorphism as bs +(as ⇒ bs) ._⊩_ r f = tracks {xs = as} {ys = bs} r (f .map) +_⇒_ {A} {B} as bs .⊩isPropValued r f = isPropTracks {X = A} {Y = B} {xs = as} {ys = bs} r (f .map) +(as ⇒ bs) .⊩surjective f = f .tracker -- What a distinguished gentleman -eval : {X Y : Type ℓ} → (xs : Assembly X) → (ys : Assembly Y) → AssemblyMorphism ((xs ⇒ ys) ⊗ xs) ys +eval : {X Y : Type ℓ} → (xs : Assembly X) → (ys : Assembly Y) → AssemblyMorphism ((xs ⇒ ys) ⊗ xs) ys eval xs ys .map (f , x) = f .map x eval {X} {Y} xs ys .tracker = - ∣ (s ⨾ (s ⨾ (k ⨾ pr₁) ⨾ Id) ⨾ (s ⨾ (k ⨾ pr₂) ⨾ Id)) + ∣ (s ⨾ (s ⨾ (k ⨾ pr₁) ⨾ Id) ⨾ (s ⨾ (k ⨾ pr₂) ⨾ Id)) , (λ (f , x) r r⊩fx → subst (λ y → y ⊩Y (f .map x)) (sym (tracker⨾r≡pr₁r⨾pr₂r (f , x) r r⊩fx)) (pr₁r⨾pr₂rTracks (f , x) r r⊩fx)) ∣₁ where - _⊩Y_ = ys ._⊩_ + _⊩Y_ = ys ._⊩_ module _ (fx : (AssemblyMorphism xs ys) × X) (r : A) - (r⊩fx : ((xs ⇒ ys) ⊗ xs) ._⊩_ r (fx .fst , fx .snd)) where + (r⊩fx : ((xs ⇒ ys) ⊗ xs) ._⊩_ r (fx .fst , fx .snd)) where f = fx .fst x = fx .snd - pr₁r⨾pr₂rTracks : (pr₁ ⨾ r ⨾ (pr₂ ⨾ r)) ⊩Y (f .map x) - pr₁r⨾pr₂rTracks = r⊩fx .fst x (pr₂ ⨾ r) (r⊩fx .snd) + pr₁r⨾pr₂rTracks : (pr₁ ⨾ r ⨾ (pr₂ ⨾ r)) ⊩Y (f .map x) + pr₁r⨾pr₂rTracks = r⊩fx .fst x (pr₂ ⨾ r) (r⊩fx .snd) - tracker⨾r≡pr₁r⨾pr₂r : s ⨾ (s ⨾ (k ⨾ pr₁) ⨾ Id) ⨾ (s ⨾ (k ⨾ pr₂) ⨾ Id) ⨾ r ≡ (pr₁ ⨾ r) ⨾ (pr₂ ⨾ r) + tracker⨾r≡pr₁r⨾pr₂r : s ⨾ (s ⨾ (k ⨾ pr₁) ⨾ Id) ⨾ (s ⨾ (k ⨾ pr₂) ⨾ Id) ⨾ r ≡ (pr₁ ⨾ r) ⨾ (pr₂ ⨾ r) tracker⨾r≡pr₁r⨾pr₂r = - s ⨾ (s ⨾ (k ⨾ pr₁) ⨾ Id) ⨾ (s ⨾ (k ⨾ pr₂) ⨾ Id) ⨾ r - ≡⟨ sabc≡ac_bc _ _ _ ⟩ - (s ⨾ (k ⨾ pr₁) ⨾ Id ⨾ r) ⨾ (s ⨾ (k ⨾ pr₂) ⨾ Id ⨾ r) - ≡⟨ cong (λ x → x ⨾ (s ⨾ (k ⨾ pr₂) ⨾ Id ⨾ r)) (sabc≡ac_bc _ _ _) ⟩ - (k ⨾ pr₁ ⨾ r ⨾ (Id ⨾ r)) ⨾ (s ⨾ (k ⨾ pr₂) ⨾ Id ⨾ r) - ≡⟨ cong (λ x → (k ⨾ pr₁ ⨾ r ⨾ (Id ⨾ r)) ⨾ x) (sabc≡ac_bc _ _ _) ⟩ - (k ⨾ pr₁ ⨾ r ⨾ (Id ⨾ r)) ⨾ (k ⨾ pr₂ ⨾ r ⨾ (Id ⨾ r)) - ≡⟨ cong (λ x → (x ⨾ (Id ⨾ r)) ⨾ (k ⨾ pr₂ ⨾ r ⨾ (Id ⨾ r))) (kab≡a _ _) ⟩ - (pr₁ ⨾ (Id ⨾ r)) ⨾ (k ⨾ pr₂ ⨾ r ⨾ (Id ⨾ r)) - ≡⟨ cong (λ x → (pr₁ ⨾ x) ⨾ (k ⨾ pr₂ ⨾ r ⨾ (Id ⨾ r))) (Ida≡a r) ⟩ - (pr₁ ⨾ r) ⨾ (k ⨾ pr₂ ⨾ r ⨾ (Id ⨾ r)) - ≡⟨ cong (λ x → (pr₁ ⨾ r) ⨾ (x ⨾ (Id ⨾ r))) (kab≡a _ _) ⟩ - (pr₁ ⨾ r) ⨾ (pr₂ ⨾ (Id ⨾ r)) - ≡⟨ cong (λ x → (pr₁ ⨾ r) ⨾ (pr₂ ⨾ x)) (Ida≡a r) ⟩ - (pr₁ ⨾ r) ⨾ (pr₂ ⨾ r) + s ⨾ (s ⨾ (k ⨾ pr₁) ⨾ Id) ⨾ (s ⨾ (k ⨾ pr₂) ⨾ Id) ⨾ r + ≡⟨ sabc≡ac_bc _ _ _ ⟩ + (s ⨾ (k ⨾ pr₁) ⨾ Id ⨾ r) ⨾ (s ⨾ (k ⨾ pr₂) ⨾ Id ⨾ r) + ≡⟨ cong (λ x → x ⨾ (s ⨾ (k ⨾ pr₂) ⨾ Id ⨾ r)) (sabc≡ac_bc _ _ _) ⟩ + (k ⨾ pr₁ ⨾ r ⨾ (Id ⨾ r)) ⨾ (s ⨾ (k ⨾ pr₂) ⨾ Id ⨾ r) + ≡⟨ cong (λ x → (k ⨾ pr₁ ⨾ r ⨾ (Id ⨾ r)) ⨾ x) (sabc≡ac_bc _ _ _) ⟩ + (k ⨾ pr₁ ⨾ r ⨾ (Id ⨾ r)) ⨾ (k ⨾ pr₂ ⨾ r ⨾ (Id ⨾ r)) + ≡⟨ cong (λ x → (x ⨾ (Id ⨾ r)) ⨾ (k ⨾ pr₂ ⨾ r ⨾ (Id ⨾ r))) (kab≡a _ _) ⟩ + (pr₁ ⨾ (Id ⨾ r)) ⨾ (k ⨾ pr₂ ⨾ r ⨾ (Id ⨾ r)) + ≡⟨ cong (λ x → (pr₁ ⨾ x) ⨾ (k ⨾ pr₂ ⨾ r ⨾ (Id ⨾ r))) (Ida≡a r) ⟩ + (pr₁ ⨾ r) ⨾ (k ⨾ pr₂ ⨾ r ⨾ (Id ⨾ r)) + ≡⟨ cong (λ x → (pr₁ ⨾ r) ⨾ (x ⨾ (Id ⨾ r))) (kab≡a _ _) ⟩ + (pr₁ ⨾ r) ⨾ (pr₂ ⨾ (Id ⨾ r)) + ≡⟨ cong (λ x → (pr₁ ⨾ r) ⨾ (pr₂ ⨾ x)) (Ida≡a r) ⟩ + (pr₁ ⨾ r) ⨾ (pr₂ ⨾ r) ∎ module _ {X Y Z : Type ℓ} - {xs : Assembly X} - {ys : Assembly Y} - {zs : Assembly Z} + {xs : Assembly X} + {ys : Assembly Y} + {zs : Assembly Z} (f : AssemblyMorphism (zs ⊗ xs) ys) where theEval = eval {X} {Y} xs ys ⇒isExponential : ∃![ g ∈ AssemblyMorphism zs (xs ⇒ ys) ] @@ -73,8 +73,8 @@ .map x → f .map (z , x) .tracker → do (f~ , f~tracks) ← f .tracker - (z~ , z~realizes) ← zs .⊩surjective z - return ( (s ⨾ (k ⨾ f~) ⨾ (s ⨾ (k ⨾ (pair ⨾ z~)) ⨾ Id) + (z~ , z~realizes) ← zs .⊩surjective z + return ( (s ⨾ (k ⨾ f~) ⨾ (s ⨾ (k ⨾ (pair ⨾ z~)) ⨾ Id) , λ x aₓ aₓ⊩x → subst (λ k → k ⊩Y (f .map (z , x))) (sym (eq f~ f~tracks z (z~ , z~realizes) x aₓ aₓ⊩x)) @@ -88,13 +88,13 @@ λ g g×id⊚eval≡f → AssemblyMorphism≡ _ _ (funExt (λ z → AssemblyMorphism≡ _ _ (funExt (λ x → λ i → g×id⊚eval≡f (~ i) .map (z , x))))) where - _⊩X_ = xs ._⊩_ - _⊩Y_ = ys ._⊩_ - _⊩Z_ = zs ._⊩_ - _⊩Z×X_ = (zs ⊗ xs) ._⊩_ + _⊩X_ = xs ._⊩_ + _⊩Y_ = ys ._⊩_ + _⊩Z_ = zs ._⊩_ + _⊩Z×X_ = (zs ⊗ xs) ._⊩_ Z×X = Z × X module _ (f~ : A) - (f~tracks : (∀ (zx : Z×X) (r : A) (rRealizes : (r ⊩Z×X zx)) → ((f~ ⨾ r) ⊩Y (f .map zx)))) + (f~tracks : (∀ (zx : Z×X) (r : A) (rRealizes : (r ⊩Z×X zx)) → ((f~ ⨾ r) ⊩Y (f .map zx)))) (z : Z) (zRealizer : Σ[ z~ ∈ A ] (z~ ⊩Z z)) (x : X) @@ -104,26 +104,26 @@ z~ = zRealizer .fst z~realizes = zRealizer .snd - eq : s ⨾ (k ⨾ f~) ⨾ (s ⨾ (k ⨾ (pair ⨾ z~)) ⨾ Id) ⨾ aₓ ≡ f~ ⨾ (pair ⨾ z~ ⨾ aₓ) + eq : s ⨾ (k ⨾ f~) ⨾ (s ⨾ (k ⨾ (pair ⨾ z~)) ⨾ Id) ⨾ aₓ ≡ f~ ⨾ (pair ⨾ z~ ⨾ aₓ) eq = - s ⨾ (k ⨾ f~) ⨾ (s ⨾ (k ⨾ (pair ⨾ z~)) ⨾ Id) ⨾ aₓ - ≡⟨ sabc≡ac_bc _ _ _ ⟩ - (k ⨾ f~ ⨾ aₓ) ⨾ (s ⨾ (k ⨾ (pair ⨾ z~)) ⨾ Id ⨾ aₓ) - ≡⟨ cong (λ x → x ⨾ (s ⨾ (k ⨾ (pair ⨾ z~)) ⨾ Id ⨾ aₓ)) (kab≡a f~ aₓ) ⟩ - f~ ⨾ (s ⨾ (k ⨾ (pair ⨾ z~)) ⨾ Id ⨾ aₓ) - ≡⟨ cong (λ x → f~ ⨾ x) (sabc≡ac_bc _ _ _) ⟩ - f~ ⨾ ((k ⨾ (pair ⨾ z~) ⨾ aₓ) ⨾ (Id ⨾ aₓ)) - ≡⟨ cong (λ x → f~ ⨾ (x ⨾ (Id ⨾ aₓ))) (kab≡a (pair ⨾ z~) aₓ) ⟩ - f~ ⨾ (pair ⨾ z~ ⨾ (Id ⨾ aₓ)) - ≡⟨ cong (λ x → f~ ⨾ (pair ⨾ z~ ⨾ x)) (Ida≡a aₓ) ⟩ - f~ ⨾ (pair ⨾ z~ ⨾ aₓ) + s ⨾ (k ⨾ f~) ⨾ (s ⨾ (k ⨾ (pair ⨾ z~)) ⨾ Id) ⨾ aₓ + ≡⟨ sabc≡ac_bc _ _ _ ⟩ + (k ⨾ f~ ⨾ aₓ) ⨾ (s ⨾ (k ⨾ (pair ⨾ z~)) ⨾ Id ⨾ aₓ) + ≡⟨ cong (λ x → x ⨾ (s ⨾ (k ⨾ (pair ⨾ z~)) ⨾ Id ⨾ aₓ)) (kab≡a f~ aₓ) ⟩ + f~ ⨾ (s ⨾ (k ⨾ (pair ⨾ z~)) ⨾ Id ⨾ aₓ) + ≡⟨ cong (λ x → f~ ⨾ x) (sabc≡ac_bc _ _ _) ⟩ + f~ ⨾ ((k ⨾ (pair ⨾ z~) ⨾ aₓ) ⨾ (Id ⨾ aₓ)) + ≡⟨ cong (λ x → f~ ⨾ (x ⨾ (Id ⨾ aₓ))) (kab≡a (pair ⨾ z~) aₓ) ⟩ + f~ ⨾ (pair ⨾ z~ ⨾ (Id ⨾ aₓ)) + ≡⟨ cong (λ x → f~ ⨾ (pair ⨾ z~ ⨾ x)) (Ida≡a aₓ) ⟩ + f~ ⨾ (pair ⨾ z~ ⨾ aₓ) ∎ - pair⨾z~⨾aₓtracks : (f~ ⨾ (pair ⨾ z~ ⨾ aₓ)) ⊩Y (f .map (z , x)) + pair⨾z~⨾aₓtracks : (f~ ⨾ (pair ⨾ z~ ⨾ aₓ)) ⊩Y (f .map (z , x)) pair⨾z~⨾aₓtracks = f~tracks (z , x) - (pair ⨾ z~ ⨾ aₓ) + (pair ⨾ z~ ⨾ aₓ) ( (subst (λ y → y ⊩Z z) (sym (pr₁pxy≡x z~ aₓ)) z~realizes) , (subst (λ y → y ⊩X x) (sym (pr₂pxy≡y z~ aₓ)) aₓ⊩x)) \ No newline at end of file diff --git a/docs/Realizability.Assembly.Morphism.html b/docs/Realizability.Assembly.Morphism.html index 51ace4d..c81dc25 100644 --- a/docs/Realizability.Assembly.Morphism.html +++ b/docs/Realizability.Assembly.Morphism.html @@ -14,42 +14,42 @@ open import Realizability.Assembly.Base ca -open Assembly +open Assembly open CombinatoryAlgebra ca open Realizability.CombinatoryAlgebra.Combinators ca renaming (i to Id; ia≡a to Ida≡a) -module _ {X Y : Type ℓ} {xs : Assembly X} {ys : Assembly Y} (t : A) (f : X → Y) where +module _ {X Y : Type ℓ} {xs : Assembly X} {ys : Assembly Y} (t : A) (f : X → Y) where tracks : Type ℓ - tracks = ∀ (x : X) (aₓ : A) → (aₓ ⊩X x) → (t ⨾ aₓ) ⊩Y (f x) where - _⊩X_ = xs ._⊩_ - _⊩Y_ = ys ._⊩_ + tracks = ∀ (x : X) (aₓ : A) → (aₓ ⊩X x) → (t ⨾ aₓ) ⊩Y (f x) where + _⊩X_ = xs ._⊩_ + _⊩Y_ = ys ._⊩_ isPropTracks : isProp tracks isPropTracks = isPropΠ λ x → isPropΠ λ aₓ → isPropΠ λ aₓ⊩x → - ys .⊩isPropValued (t ⨾ aₓ) (f x) + ys .⊩isPropValued (t ⨾ aₓ) (f x) -record AssemblyMorphism {X Y : Type ℓ} (as : Assembly X) (bs : Assembly Y) : Type ℓ where - open Assembly as renaming (_⊩_ to _⊩X_) - open Assembly bs renaming (_⊩_ to _⊩Y_) +record AssemblyMorphism {X Y : Type ℓ} (as : Assembly X) (bs : Assembly Y) : Type ℓ where + open Assembly as renaming (_⊩_ to _⊩X_) + open Assembly bs renaming (_⊩_ to _⊩Y_) field map : X → Y - tracker : ∃[ t ∈ A ] ((x : X) (aₓ : A) → (aₓ ⊩X x) → (t ⨾ aₓ) ⊩Y (map x)) + tracker : ∃[ t ∈ A ] ((x : X) (aₓ : A) → (aₓ ⊩X x) → (t ⨾ aₓ) ⊩Y (map x)) open AssemblyMorphism unquoteDecl AssemblyMorphismIsoΣ = declareRecordIsoΣ AssemblyMorphismIsoΣ (quote AssemblyMorphism) -module _ {X Y : Type ℓ} (xs : Assembly X) (ys : Assembly Y) where +module _ {X Y : Type ℓ} (xs : Assembly X) (ys : Assembly Y) where AssemblyMorphismΣ : Type ℓ - AssemblyMorphismΣ = Σ[ map ∈ (X → Y) ] ∃[ t ∈ A ] ((x : X) (aₓ : A) → (aₓ ⊩X x) → (t ⨾ aₓ) ⊩Y (map x)) where - _⊩X_ = xs ._⊩_ - _⊩Y_ = ys ._⊩_ + AssemblyMorphismΣ = Σ[ map ∈ (X → Y) ] ∃[ t ∈ A ] ((x : X) (aₓ : A) → (aₓ ⊩X x) → (t ⨾ aₓ) ⊩Y (map x)) where + _⊩X_ = xs ._⊩_ + _⊩Y_ = ys ._⊩_ isSetAssemblyMorphismΣ : isSet AssemblyMorphismΣ - isSetAssemblyMorphismΣ = isSetΣ (isSet→ (ys .isSetX)) (λ map → isProp→isSet squash₁) + isSetAssemblyMorphismΣ = isSetΣ (isSet→ (ys .isSetX)) (λ map → isProp→isSet squash₁) AssemblyMorphism≡Σ = isoToPath (AssemblyMorphismIsoΣ {as = xs} {bs = ys}) @@ -57,8 +57,8 @@ isSetAssemblyMorphism = subst (λ t → isSet t) (sym AssemblyMorphism≡Σ) isSetAssemblyMorphismΣ AssemblyMorphismΣ≡ : {X Y : Type ℓ} - {xs : Assembly X} - {ys : Assembly Y} + {xs : Assembly X} + {ys : Assembly Y} (f g : AssemblyMorphismΣ xs ys) → f .fst ≡ g .fst --------------------------------- @@ -66,8 +66,8 @@ AssemblyMorphismΣ≡ f g = Σ≡Prop λ _ → squash₁ module _ {X Y : Type ℓ} - {xs : Assembly X} - {ys : Assembly Y} + {xs : Assembly X} + {ys : Assembly Y} (f g : AssemblyMorphism xs ys) where -- Necessary to please the constraint solver theIso = AssemblyMorphismIsoΣ {X} {Y} {as = xs} {bs = ys} @@ -76,19 +76,19 @@ AssemblyMorphism≡ : (f .map ≡ g .map) → f ≡ g AssemblyMorphism≡ fmap≡gmap i = theIso .inv (thePath (theIso .fun f) (theIso .fun g) (fmap≡gmap) i) -identityMorphism : {X : Type ℓ} (as : Assembly X) → AssemblyMorphism as as +identityMorphism : {X : Type ℓ} (as : Assembly X) → AssemblyMorphism as as identityMorphism as .map x = x -identityMorphism as .tracker = ∣ Id , (λ x aₓ aₓ⊩x → subst (λ y → (as ⊩ y) x) (sym (Ida≡a aₓ)) aₓ⊩x) ∣₁ +identityMorphism as .tracker = ∣ Id , (λ x aₓ aₓ⊩x → subst (λ y → (as ⊩ y) x) (sym (Ida≡a aₓ)) aₓ⊩x) ∣₁ -compositeMorphism : {X Y Z : Type ℓ} {xs : Assembly X} {ys : Assembly Y} {zs : Assembly Z} +compositeMorphism : {X Y Z : Type ℓ} {xs : Assembly X} {ys : Assembly Y} {zs : Assembly Z} → (f : AssemblyMorphism xs ys) → (g : AssemblyMorphism ys zs) → AssemblyMorphism xs zs compositeMorphism f g .map x = g .map (f .map x) compositeMorphism {X} {Y} {Z} {xs} {ys} {zs} f g .tracker = map2 untruncated (f .tracker) (g .tracker) where - open Assembly xs renaming (_⊩_ to _⊩X_) - open Assembly ys renaming (_⊩_ to _⊩Y_) - open Assembly zs renaming (_⊩_ to _⊩Z_) + open Assembly xs renaming (_⊩_ to _⊩X_) + open Assembly ys renaming (_⊩_ to _⊩Y_) + open Assembly zs renaming (_⊩_ to _⊩Z_) module _ (fTracker : Σ[ f~ ∈ A ] tracks {xs = xs} {ys = ys} f~ (f .map)) (gTracker : Σ[ g~ ∈ A ] tracks {xs = ys} {ys = zs} g~ (g .map)) where @@ -98,11 +98,11 @@ g~ = gTracker .fst g~tracks = gTracker .snd - easierVariant : ∀ x aₓ aₓ⊩x → (g~ ⨾ (f~ ⨾ aₓ)) ⊩Z g .map (f .map x) - easierVariant x aₓ aₓ⊩x = g~tracks (f .map x) (f~ ⨾ aₓ) (f~tracks x aₓ aₓ⊩x) + easierVariant : ∀ x aₓ aₓ⊩x → (g~ ⨾ (f~ ⨾ aₓ)) ⊩Z g .map (f .map x) + easierVariant x aₓ aₓ⊩x = g~tracks (f .map x) (f~ ⨾ aₓ) (f~tracks x aₓ aₓ⊩x) goal : ∀ (x : X) (aₓ : A) (aₓ⊩x : aₓ ⊩X x) - → (B g~ f~ ⨾ aₓ) ⊩Z (compositeMorphism f g .map x) + → (B g~ f~ ⨾ aₓ) ⊩Z (compositeMorphism f g .map x) goal x aₓ aₓ⊩x = subst (λ y → y ⊩Z g .map (f .map x)) (sym (Ba≡gfa g~ f~ aₓ)) (easierVariant x aₓ aₓ⊩x) @@ -110,17 +110,17 @@ untruncated : Σ[ t ∈ A ] ((x : X) (aₓ : A) → aₓ ⊩X x - → (t ⨾ aₓ) ⊩Z (compositeMorphism f g) .map x) + → (t ⨾ aₓ) ⊩Z (compositeMorphism f g) .map x) untruncated = B g~ f~ , goal infixl 23 _⊚_ -_⊚_ : {X Y Z : Type ℓ} → {xs : Assembly X} {ys : Assembly Y} {zs : Assembly Z} +_⊚_ : {X Y Z : Type ℓ} → {xs : Assembly X} {ys : Assembly Y} {zs : Assembly Z} → AssemblyMorphism xs ys → AssemblyMorphism ys zs → AssemblyMorphism xs zs f ⊚ g = compositeMorphism f g -module _ {X Y : Type ℓ} (xs : Assembly X) (ys : Assembly Y) where +module _ {X Y : Type ℓ} (xs : Assembly X) (ys : Assembly Y) where ⊚idL : ∀ (f : AssemblyMorphism xs ys) → identityMorphism xs ⊚ f ≡ f ⊚idL f = AssemblyMorphism≡ (identityMorphism xs ⊚ f) f (funExt λ x → refl) @@ -128,10 +128,10 @@ ⊚idR f = AssemblyMorphism≡ (f ⊚ identityMorphism xs) f (funExt λ x → refl) module _ {X Y Z W : Type ℓ} - (xs : Assembly X) - (ys : Assembly Y) - (zs : Assembly Z) - (ws : Assembly W) + (xs : Assembly X) + (ys : Assembly Y) + (zs : Assembly Z) + (ws : Assembly W) (f : AssemblyMorphism xs ys) (g : AssemblyMorphism ys zs) (h : AssemblyMorphism zs ws) where @@ -142,7 +142,7 @@ open Category ASM : Category (ℓ-suc ℓ) ℓ -ASM .ob = Σ[ X ∈ Type ℓ ] Assembly X +ASM .ob = Σ[ X ∈ Type ℓ ] Assembly X ASM .Hom[_,_] x y = AssemblyMorphism (x .snd) (y .snd) ASM .id {x} = identityMorphism (x .snd) ASM ._⋆_ f g = f ⊚ g diff --git a/docs/Realizability.Assembly.Regular.CharLemma.html b/docs/Realizability.Assembly.Regular.CharLemma.html index d5eff24..772f823 100644 --- a/docs/Realizability.Assembly.Regular.CharLemma.html +++ b/docs/Realizability.Assembly.Regular.CharLemma.html @@ -24,15 +24,15 @@ module _ {X Y : Type ℓ} - (xs : Assembly X) - (ys : Assembly Y) + (xs : Assembly X) + (ys : Assembly Y) (e : AssemblyMorphism xs ys) where - _⊩X_ = xs ._⊩_ - _⊩Y_ = ys ._⊩_ + _⊩X_ = xs ._⊩_ + _⊩Y_ = ys ._⊩_ tracksSurjection : (a : A) → Type ℓ - tracksSurjection a = ∀ y b → (b ⊩Y y) → ∃[ x ∈ X ] (e .map x ≡ y) × ((a ⨾ b) ⊩X x) + tracksSurjection a = ∀ y b → (b ⊩Y y) → ∃[ x ∈ X ] (e .map x ≡ y) × ((a ⨾ b) ⊩X x) isSurjectivelyTracked : Type ℓ isSurjectivelyTracked = ∃[ a ∈ A ] tracksSurjection a @@ -41,7 +41,7 @@ isSurjectivelyTracked→isSurjective tracked y = do (a , aTracksSurjection) ← tracked - (b , bRealizes) ← ys .⊩surjective y + (b , bRealizes) ← ys .⊩surjective y (x , ex≡y , ab⊩x) ← aTracksSurjection y b bRealizes return (x , ex≡y) @@ -49,13 +49,13 @@ isPropIsSurjectivelyTracked = isPropPropTrunc CharLemma : Type (ℓ-suc ℓ) -CharLemma = ∀ {X Y} (xs : Assembly X) (ys : Assembly Y) e +CharLemma = ∀ {X Y} (xs : Assembly X) (ys : Assembly Y) e → (isRegularEpic ASM e → isSurjectivelyTracked xs ys e) × (isSurjectivelyTracked xs ys e → isRegularEpic ASM e) module CharLemmaConsequences (cl : CharLemma) where - isRegularEpicASM≃isSurjectivelyTracked : ∀ {X Y} (xs : Assembly X) (ys : Assembly Y) e + isRegularEpicASM≃isSurjectivelyTracked : ∀ {X Y} (xs : Assembly X) (ys : Assembly Y) e → isRegularEpic ASM e ≃ isSurjectivelyTracked xs ys e isRegularEpicASM≃isSurjectivelyTracked xs ys e = propBiimpl→Equiv diff --git a/docs/Realizability.Assembly.Regular.CharLemmaProof.html b/docs/Realizability.Assembly.Regular.CharLemmaProof.html index 72b4635..9501a7f 100644 --- a/docs/Realizability.Assembly.Regular.CharLemmaProof.html +++ b/docs/Realizability.Assembly.Regular.CharLemmaProof.html @@ -25,8 +25,8 @@ module SurjectiveTrackingMakesRegularEpic {X Y : Type ℓ} - (xs : Assembly X) - (ys : Assembly Y) + (xs : Assembly X) + (ys : Assembly Y) (f : AssemblyMorphism xs ys) (fIsSurjectivelyTracked : isSurjectivelyTracked xs ys f) where @@ -37,11 +37,11 @@ module _ {Z} - (zs : Assembly Z) + (zs : Assembly Z) (g : AssemblyMorphism xs zs) (k₁⊚g≡k₂⊚g : k₁ ⊚ g ≡ k₂ ⊚ g) where - _⊩Z_ = zs ._⊩_ + _⊩Z_ = zs ._⊩_ fx≡fx'→gx≡gx' : ∀ x x' → f .map x ≡ f .map x' → g .map x ≡ g .map x' fx≡fx'→gx≡gx' x x' fx≡fx' i = k₁⊚g≡k₂⊚g i .map (x , x' , fx≡fx') @@ -53,7 +53,7 @@ hIsUnique : h ≡ h' hIsUnique = AssemblyMorphism≡ _ _ - (funExt λ y → equivFun (propTruncIdempotent≃ (zs .isSetX _ _)) + (funExt λ y → equivFun (propTruncIdempotent≃ (zs .isSetX _ _)) (do (x , fx≡y) ← fIsSurjection y return (h .map y @@ -79,19 +79,19 @@ (f⁻¹IsSection : section (f .map) f⁻¹) where -- I will fix having to do this one day - uglyCalculation : ∀ b g~ r → (s ⨾ (k ⨾ g~) ⨾ (s ⨾ (k ⨾ r) ⨾ Id) ⨾ b) ≡ g~ ⨾ (r ⨾ b) + uglyCalculation : ∀ b g~ r → (s ⨾ (k ⨾ g~) ⨾ (s ⨾ (k ⨾ r) ⨾ Id) ⨾ b) ≡ g~ ⨾ (r ⨾ b) uglyCalculation b g~ r = - s ⨾ (k ⨾ g~) ⨾ (s ⨾ (k ⨾ r) ⨾ Id) ⨾ b - ≡⟨ sabc≡ac_bc _ _ _ ⟩ - k ⨾ g~ ⨾ b ⨾ (s ⨾ (k ⨾ r) ⨾ Id ⨾ b) - ≡⟨ cong (λ x → x ⨾ _) (kab≡a _ _) ⟩ - g~ ⨾ (s ⨾ (k ⨾ r) ⨾ Id ⨾ b) - ≡⟨ cong (λ x → g~ ⨾ x) (sabc≡ac_bc _ _ _) ⟩ - g~ ⨾ (k ⨾ r ⨾ b ⨾ (Id ⨾ b)) - ≡⟨ cong (λ x → g~ ⨾ (x ⨾ (Id ⨾ b))) (kab≡a _ _) ⟩ - g~ ⨾ (r ⨾ (Id ⨾ b)) - ≡⟨ cong (λ x → g~ ⨾ (r ⨾ x)) (Ida≡a _) ⟩ - g~ ⨾ (r ⨾ b) + s ⨾ (k ⨾ g~) ⨾ (s ⨾ (k ⨾ r) ⨾ Id) ⨾ b + ≡⟨ sabc≡ac_bc _ _ _ ⟩ + k ⨾ g~ ⨾ b ⨾ (s ⨾ (k ⨾ r) ⨾ Id ⨾ b) + ≡⟨ cong (λ x → x ⨾ _) (kab≡a _ _) ⟩ + g~ ⨾ (s ⨾ (k ⨾ r) ⨾ Id ⨾ b) + ≡⟨ cong (λ x → g~ ⨾ x) (sabc≡ac_bc _ _ _) ⟩ + g~ ⨾ (k ⨾ r ⨾ b ⨾ (Id ⨾ b)) + ≡⟨ cong (λ x → g~ ⨾ (x ⨾ (Id ⨾ b))) (kab≡a _ _) ⟩ + g~ ⨾ (r ⨾ (Id ⨾ b)) + ≡⟨ cong (λ x → g~ ⨾ (r ⨾ x)) (Ida≡a _) ⟩ + g~ ⨾ (r ⨾ b) ∎ hMap : Y → Z @@ -113,19 +113,19 @@ (g~ , g~tracks) ← g .tracker (r , rWitness) ← fIsSurjectivelyTracked return - (s ⨾ (k ⨾ g~) ⨾ (s ⨾ (k ⨾ r) ⨾ Id) , + (s ⨾ (k ⨾ g~) ⨾ (s ⨾ (k ⨾ r) ⨾ Id) , (λ y b b⊩y → equivFun - (propTruncIdempotent≃ (zs .⊩isPropValued _ _)) + (propTruncIdempotent≃ (zs .⊩isPropValued _ _)) (do (x , fx≡y , rb⊩x) ← rWitness y b b⊩y return (subst (λ h~ → h~ ⊩Z (h .map y)) (sym (uglyCalculation b g~ r)) - (subst (λ x → (g~ ⨾ (r ⨾ b)) ⊩Z x) + (subst (λ x → (g~ ⨾ (r ⨾ b)) ⊩Z x) (sym (subst (λ y → hMap y ≡ g .map x) fx≡y (hfx≡gx x))) - (g~tracks x (r ⨾ b) rb⊩x)))))) + (g~tracks x (r ⨾ b) rb⊩x)))))) @@ -135,13 +135,13 @@ ∃h : ∃[ h ∈ AssemblyMorphism ys zs ] (f ⊚ h ≡ g) ∃h = do - (f⁻¹ , f⁻¹IsSection) ← choice X Y (xs .isSetX) (ys .isSetX) (f .map) fIsSurjection + (f⁻¹ , f⁻¹IsSection) ← choice X Y (xs .isSetX) (ys .isSetX) (f .map) fIsSurjection return (h f⁻¹ f⁻¹IsSection , f⊚h≡g f⁻¹ f⁻¹IsSection) Σh : Σ[ h ∈ AssemblyMorphism ys zs ] (f ⊚ h ≡ g) Σh = ∃h→Σh ∃h - kernelPairCoeqUnivProp : ∀ {Z} {zs : Assembly Z} → (g : AssemblyMorphism xs zs) → (k₁ ⊚ g ≡ k₂ ⊚ g) → ∃![ ! ∈ AssemblyMorphism ys zs ] (f ⊚ ! ≡ g) + kernelPairCoeqUnivProp : ∀ {Z} {zs : Assembly Z} → (g : AssemblyMorphism xs zs) → (k₁ ⊚ g ≡ k₂ ⊚ g) → ∃![ ! ∈ AssemblyMorphism ys zs ] (f ⊚ ! ≡ g) kernelPairCoeqUnivProp {Z} {zs} g k₁⊚g≡k₂⊚g = uniqueExists (Σh zs g k₁⊚g≡k₂⊚g .fst) diff --git a/docs/Realizability.Assembly.Regular.Cobase.html b/docs/Realizability.Assembly.Regular.Cobase.html new file mode 100644 index 0000000..1254c42 --- /dev/null +++ b/docs/Realizability.Assembly.Regular.Cobase.html @@ -0,0 +1,71 @@ + +Realizability.Assembly.Regular.Cobase
{-# OPTIONS --cubical --allow-unsolved-metas #-}
+
+open import Realizability.CombinatoryAlgebra
+open import Cubical.Foundations.Prelude
+open import Cubical.Foundations.HLevels
+open import Cubical.Functions.Surjection
+open import Cubical.Categories.Regular.Base
+open import Cubical.Categories.Regular.KernelPair
+open import Cubical.Categories.Limits.Pullback
+open import Cubical.Categories.Limits.Coequalizers
+open import Cubical.Data.Sigma
+open import Cubical.HITs.PropositionalTruncation hiding (map)
+open import Cubical.HITs.PropositionalTruncation.Monad
+
+module Realizability.Assembly.Regular.Cobase {ℓ} {A : Type ℓ} (ca : CombinatoryAlgebra A) where
+
+open CombinatoryAlgebra ca
+open Realizability.CombinatoryAlgebra.Combinators ca renaming (i to Id; ia≡a to Ida≡a)
+open import Realizability.Assembly.Base ca
+open import Realizability.Assembly.Morphism ca
+open import Realizability.Assembly.Regular.CharLemma ca
+open import Realizability.Assembly.BinProducts ca
+open import Realizability.Assembly.Coequalizers ca
+open import Realizability.Assembly.Regular.KernelPairs ca
+
+open ASMKernelPairs
+open Pullback
+module
+  PullbackPreservation
+  {X Y Z}
+  (xs : Assembly X)
+  (ys : Assembly Y)
+  (zs : Assembly Z)
+  (e : AssemblyMorphism xs ys)
+  (f : AssemblyMorphism zs ys)
+  (eIsRegular : isRegularEpic ASM e)
+  (cl : CharLemma)
+  (p : Pullback ASM (cospan (X , xs) (Y , ys) (Z , zs) e f)) where
+    p₁ = p .pbPr₁
+    p₂ = p .pbPr₂
+
+    isSurjectivelyTrackedE : isSurjectivelyTracked _ _ e
+    isSurjectivelyTrackedE = cl xs ys e .fst eIsRegular
+
+    eIsSurjection : isSurjection (e .map)
+    eIsSurjection = isSurjectivelyTracked→isSurjective _ _ e isSurjectivelyTrackedE
+
+    isSurjectivelyTrackedP₂ : isSurjectivelyTracked _ _ p₂
+    isSurjectivelyTrackedP₂ =
+      do
+        (f~ , f~tracks) ← f .tracker
+        (b  , bTracksSurjectivity) ← isSurjectivelyTrackedE
+        return
+          (s ⨾ (s ⨾ (k ⨾ pair) ⨾ (s ⨾ (k ⨾ b) ⨾ (s ⨾ (k ⨾ f~) ⨾ Id))) ⨾ Id ,
+          λ z zᵣ zᵣ⊩z →
+            do
+              return ({!!} , {!!} , {!!}))
+
+module _ (cl : CharLemma) where
+  open ASMKernelPairs
+  open PullbackPreservation
+  RegularASM : IsRegular ASM
+  RegularASM = record
+                 { arrowHasKernelPairs = ∣ (λ {xs} {ys} f → makeKernelPair (xs .snd) (ys .snd) f) ∣₁
+                 ; kPairHasCoequalizer = λ {xs} {ys} f kpF → ∣ ASMCoequalizer (kpF .pbOb .snd) (xs .snd) (kpF .pbPr₁) (kpF .pbPr₂) ∣₁
+                 ; regularEpiPreservedPullback = λ {Y} {Z} {X} f e eIsRegular p
+                 → cl (p .pbOb .snd) (Z .snd) (p .pbPr₂) .snd (isSurjectivelyTrackedP₂ (X .snd) (Y .snd) (Z .snd) e f eIsRegular cl p)
+                 }
+
+
\ No newline at end of file diff --git a/docs/Realizability.Assembly.Regular.Everything.html b/docs/Realizability.Assembly.Regular.Everything.html index 122910b..372c62c 100644 --- a/docs/Realizability.Assembly.Regular.Everything.html +++ b/docs/Realizability.Assembly.Regular.Everything.html @@ -4,5 +4,6 @@ open import Realizability.Assembly.Regular.CharLemma open import Realizability.Assembly.Regular.CharLemmaProof -open import Realizability.Assembly.Regular.RegularProof +--open import Realizability.Assembly.Regular.RegularProof +open import Realizability.Assembly.Regular.Cobase \ No newline at end of file diff --git a/docs/Realizability.Assembly.Regular.KernelPairs.html b/docs/Realizability.Assembly.Regular.KernelPairs.html index d430c86..6286384 100644 --- a/docs/Realizability.Assembly.Regular.KernelPairs.html +++ b/docs/Realizability.Assembly.Regular.KernelPairs.html @@ -15,17 +15,17 @@ open import Realizability.Assembly.BinProducts ca open Realizability.CombinatoryAlgebra.Combinators ca renaming (i to Id; ia≡a to Ida≡a) -module ASMKernelPairs {X Y} (xs : Assembly X) (ys : Assembly Y) (f : AssemblyMorphism xs ys) where +module ASMKernelPairs {X Y} (xs : Assembly X) (ys : Assembly Y) (f : AssemblyMorphism xs ys) where xs⊗xs = xs ⊗ xs kernelPairType = Σ[ x ∈ X ] Σ[ x' ∈ X ] f .map x ≡ f .map x' - kernelPairOb : Assembly kernelPairType - kernelPairOb .isSetX = isSetΣ (xs .isSetX) λ x → isSetΣ (xs .isSetX) (λ x' → isProp→isSet (ys .isSetX _ _)) - kernelPairOb ._⊩_ a (x , x' , fx≡fx') = xs⊗xs ._⊩_ a (x , x') - kernelPairOb .⊩isPropValued a (x , x' , fx≡fx') = xs⊗xs .⊩isPropValued a (x , x') - kernelPairOb .⊩surjective (x , x' , fx≡fx') = xs⊗xs .⊩surjective (x , x') + kernelPairOb : Assembly kernelPairType + kernelPairOb .isSetX = isSetΣ (xs .isSetX) λ x → isSetΣ (xs .isSetX) (λ x' → isProp→isSet (ys .isSetX _ _)) + kernelPairOb ._⊩_ a (x , x' , fx≡fx') = xs⊗xs ._⊩_ a (x , x') + kernelPairOb .⊩isPropValued a (x , x' , fx≡fx') = xs⊗xs .⊩isPropValued a (x , x') + kernelPairOb .⊩surjective (x , x' , fx≡fx') = xs⊗xs .⊩surjective (x , x') k₁ : AssemblyMorphism kernelPairOb xs k₁ .map (x , x' , fx≡fx') = x @@ -48,7 +48,7 @@ f .map (k₂ .map (x , x' , fx≡fx')) ∎) - module KPUnivProp {Z} {zs : Assembly Z} + module KPUnivProp {Z} {zs : Assembly Z} (l₁ l₂ : AssemblyMorphism zs xs) (l₁⊚f≡l₂⊚f : l₁ ⊚ f ≡ l₂ ⊚ f) where @@ -75,7 +75,7 @@ ! .map z .snd .fst ∎ - isSet'Y = isSet→isSet' (ys .isSetX) + isSet'Y = isSet→isSet' (ys .isSetX) {- This is an important proof in the sense that it is slightly cubical. Recall the definition of a set : X is a set iff ∀ (x y : X) (p q : x ≡ y) → p ≡ q diff --git a/docs/Realizability.CombinatoryAlgebra.html b/docs/Realizability.CombinatoryAlgebra.html index b3dd343..38fb5d2 100644 --- a/docs/Realizability.CombinatoryAlgebra.html +++ b/docs/Realizability.CombinatoryAlgebra.html @@ -4,160 +4,160 @@ open import Cubical.Foundations.Prelude open import Cubical.Data.Nat -open import Realizability.ApplicativeStructure hiding (S;K) +open import Realizability.ApplicativeStructure hiding (S;K) module Realizability.CombinatoryAlgebra where record CombinatoryAlgebra {ℓ} (A : Type ℓ) : Type ℓ where field - as : ApplicativeStructure A - completeness : isCombinatoriallyComplete as - fefermanStructure : Feferman as - fefermanStructure = completeness→feferman as completeness - open Feferman fefermanStructure public - open ApplicativeStructure as public + as : ApplicativeStructure A + completeness : isCombinatoriallyComplete as + fefermanStructure : Feferman as + fefermanStructure = completeness→feferman as completeness + open Feferman fefermanStructure public + open ApplicativeStructure as public module Combinators {ℓ} {A : Type ℓ} (ca : CombinatoryAlgebra A) where open CombinatoryAlgebra ca i : A - i = s ⨾ k ⨾ k + i = s ⨾ k ⨾ k k' : A - k' = k ⨾ i + k' = k ⨾ i - ia≡a : ∀ a → i ⨾ a ≡ a - ia≡a a = (cong (λ x → x ⨾ a) refl) ∙ (sabc≡ac_bc k k a) ∙ (kab≡a a (k ⨾ a)) + ia≡a : ∀ a → i ⨾ a ≡ a + ia≡a a = (cong (λ x → x ⨾ a) refl) ∙ (sabc≡ac_bc k k a) ∙ (kab≡a a (k ⨾ a)) - k'ab≡b : ∀ a b → k' ⨾ a ⨾ b ≡ b - k'ab≡b a b = k' ⨾ a ⨾ b + k'ab≡b : ∀ a b → k' ⨾ a ⨾ b ≡ b + k'ab≡b a b = k' ⨾ a ⨾ b ≡⟨ refl ⟩ - (k ⨾ i ⨾ a ⨾ b) - ≡⟨ cong (λ x → x ⨾ b) (kab≡a i a) ⟩ - (i ⨾ b) + (k ⨾ i ⨾ a ⨾ b) + ≡⟨ cong (λ x → x ⨾ b) (kab≡a i a) ⟩ + (i ⨾ b) ≡⟨ ia≡a b ⟩ b ∎ true : A - true = k + true = k false : A false = k' if_then_else_ : ∀ c t e → A - if c then t else e = i ⨾ c ⨾ t ⨾ e + if c then t else e = i ⨾ c ⨾ t ⨾ e ifTrueThen : ∀ t e → if true then t else e ≡ t ifTrueThen t e = if true then t else e ≡⟨ refl ⟩ - i ⨾ true ⨾ t ⨾ e - ≡⟨ cong (λ x → i ⨾ x ⨾ t ⨾ e) refl ⟩ - i ⨾ k ⨾ t ⨾ e - ≡⟨ cong (λ x → x ⨾ t ⨾ e) (ia≡a k) ⟩ - k ⨾ t ⨾ e - ≡⟨ kab≡a t e ⟩ + i ⨾ true ⨾ t ⨾ e + ≡⟨ cong (λ x → i ⨾ x ⨾ t ⨾ e) refl ⟩ + i ⨾ k ⨾ t ⨾ e + ≡⟨ cong (λ x → x ⨾ t ⨾ e) (ia≡a k) ⟩ + k ⨾ t ⨾ e + ≡⟨ kab≡a t e ⟩ t ∎ ifFalseElse : ∀ t e → if false then t else e ≡ e ifFalseElse t e = if false then t else e ≡⟨ refl ⟩ - i ⨾ false ⨾ t ⨾ e - ≡⟨ cong (λ x → i ⨾ x ⨾ t ⨾ e) refl ⟩ - i ⨾ k' ⨾ t ⨾ e - ≡⟨ cong (λ x → x ⨾ t ⨾ e) (ia≡a k') ⟩ - k' ⨾ t ⨾ e + i ⨾ false ⨾ t ⨾ e + ≡⟨ cong (λ x → i ⨾ x ⨾ t ⨾ e) refl ⟩ + i ⨾ k' ⨾ t ⨾ e + ≡⟨ cong (λ x → x ⨾ t ⨾ e) (ia≡a k') ⟩ + k' ⨾ t ⨾ e ≡⟨ k'ab≡b t e ⟩ e ∎ -- I used a Scheme script to generate this pair : A - pair = s ⨾ (s ⨾ (k ⨾ (s)) ⨾ (s ⨾ (s ⨾ (k ⨾ (s)) ⨾ (s ⨾ (k ⨾ (k)) ⨾ (k ⨾ (s)))) ⨾ - (s ⨾ (s ⨾ (k ⨾ (s)) ⨾ (s ⨾ (s ⨾ (k ⨾ (s)) ⨾ (s ⨾ (k ⨾ (k)) ⨾ (k ⨾ (s)))) ⨾ - (s ⨾ (s ⨾ (k ⨾ (s)) ⨾ (s ⨾ (s ⨾ (k ⨾ (s)) ⨾ (s ⨾ (k ⨾ (k)) ⨾ (k ⨾ (s)))) ⨾ - (s ⨾ (k ⨾ (k)) ⨾ (k ⨾ (k))))) ⨾ (s ⨾ (k ⨾ (k)) ⨾ (k ⨾ (k)))))) ⨾ (s ⨾ - (s ⨾ (k ⨾ (s)) ⨾ (s ⨾ (k ⨾ (k)) ⨾ (k ⨾ (k)))) ⨾ (s ⨾ (k ⨾ (k)) ⨾ (s ⨾ (k) ⨾ (k))))))) ⨾ - (s ⨾ (s ⨾ (k ⨾ (s)) ⨾ (s ⨾ (k ⨾ (k)) ⨾ (k ⨾ (k)))) ⨾ (s ⨾ (s ⨾ (k ⨾ (s)) ⨾ (k ⨾ (k))) ⨾ (k ⨾ (k)))) + pair = s ⨾ (s ⨾ (k ⨾ (s)) ⨾ (s ⨾ (s ⨾ (k ⨾ (s)) ⨾ (s ⨾ (k ⨾ (k)) ⨾ (k ⨾ (s)))) ⨾ + (s ⨾ (s ⨾ (k ⨾ (s)) ⨾ (s ⨾ (s ⨾ (k ⨾ (s)) ⨾ (s ⨾ (k ⨾ (k)) ⨾ (k ⨾ (s)))) ⨾ + (s ⨾ (s ⨾ (k ⨾ (s)) ⨾ (s ⨾ (s ⨾ (k ⨾ (s)) ⨾ (s ⨾ (k ⨾ (k)) ⨾ (k ⨾ (s)))) ⨾ + (s ⨾ (k ⨾ (k)) ⨾ (k ⨾ (k))))) ⨾ (s ⨾ (k ⨾ (k)) ⨾ (k ⨾ (k)))))) ⨾ (s ⨾ + (s ⨾ (k ⨾ (s)) ⨾ (s ⨾ (k ⨾ (k)) ⨾ (k ⨾ (k)))) ⨾ (s ⨾ (k ⨾ (k)) ⨾ (s ⨾ (k) ⨾ (k))))))) ⨾ + (s ⨾ (s ⨾ (k ⨾ (s)) ⨾ (s ⨾ (k ⨾ (k)) ⨾ (k ⨾ (k)))) ⨾ (s ⨾ (s ⨾ (k ⨾ (s)) ⨾ (k ⨾ (k))) ⨾ (k ⨾ (k)))) pr₁ : A - pr₁ = s ⨾ (s ⨾ k ⨾ k) ⨾ (k ⨾ k) + pr₁ = s ⨾ (s ⨾ k ⨾ k) ⨾ (k ⨾ k) pr₂ : A - pr₂ = s ⨾ (s ⨾ k ⨾ k) ⨾ (k ⨾ k') + pr₂ = s ⨾ (s ⨾ k ⨾ k) ⨾ (k ⨾ k') -- TODO : Prove computation rules - postulate pr₁pxy≡x : ∀ x y → pr₁ ⨾ (pair ⨾ x ⨾ y) ≡ x - postulate pr₂pxy≡y : ∀ x y → pr₂ ⨾ (pair ⨾ x ⨾ y) ≡ y + postulate pr₁pxy≡x : ∀ x y → pr₁ ⨾ (pair ⨾ x ⨾ y) ≡ x + postulate pr₂pxy≡y : ∀ x y → pr₂ ⨾ (pair ⨾ x ⨾ y) ≡ y -- Curry numbers ℕ→curry : ℕ → A ℕ→curry zero = i - ℕ→curry (suc n) = pair ⨾ k' ⨾ (ℕ→curry n) + ℕ→curry (suc n) = pair ⨾ k' ⨾ (ℕ→curry n) Z : A Z = pr₁ - Zzero≡true : Z ⨾ (ℕ→curry zero) ≡ true - Zzero≡true = Z ⨾ (ℕ→curry zero) - ≡⟨ cong (λ x → Z ⨾ x) refl ⟩ - Z ⨾ i - ≡⟨ cong (λ x → x ⨾ i) refl ⟩ - s ⨾ (s ⨾ k ⨾ k) ⨾ (k ⨾ k) ⨾ i - ≡⟨ sabc≡ac_bc (s ⨾ k ⨾ k) (k ⨾ k) i ⟩ - ((s ⨾ k ⨾ k) ⨾ i) ⨾ (k ⨾ k ⨾ i) - ≡⟨ cong (λ x → (x ⨾ i) ⨾ (k ⨾ k ⨾ i)) refl ⟩ - (i ⨾ i) ⨾ (k ⨾ k ⨾ i) - ≡⟨ cong (λ x → x ⨾ (k ⨾ k ⨾ i)) (ia≡a i) ⟩ - i ⨾ (k ⨾ k ⨾ i) - ≡⟨ cong (λ x → i ⨾ x) (kab≡a k i) ⟩ - i ⨾ k - ≡⟨ ia≡a k ⟩ - k + Zzero≡true : Z ⨾ (ℕ→curry zero) ≡ true + Zzero≡true = Z ⨾ (ℕ→curry zero) + ≡⟨ cong (λ x → Z ⨾ x) refl ⟩ + Z ⨾ i + ≡⟨ cong (λ x → x ⨾ i) refl ⟩ + s ⨾ (s ⨾ k ⨾ k) ⨾ (k ⨾ k) ⨾ i + ≡⟨ sabc≡ac_bc (s ⨾ k ⨾ k) (k ⨾ k) i ⟩ + ((s ⨾ k ⨾ k) ⨾ i) ⨾ (k ⨾ k ⨾ i) + ≡⟨ cong (λ x → (x ⨾ i) ⨾ (k ⨾ k ⨾ i)) refl ⟩ + (i ⨾ i) ⨾ (k ⨾ k ⨾ i) + ≡⟨ cong (λ x → x ⨾ (k ⨾ k ⨾ i)) (ia≡a i) ⟩ + i ⨾ (k ⨾ k ⨾ i) + ≡⟨ cong (λ x → i ⨾ x) (kab≡a k i) ⟩ + i ⨾ k + ≡⟨ ia≡a k ⟩ + k ∎ - Zsuc≡false : ∀ n → Z ⨾ (ℕ→curry (suc n)) ≡ false - Zsuc≡false n = Z ⨾ (ℕ→curry (suc n)) - ≡⟨ cong (λ x → Z ⨾ x) refl ⟩ - Z ⨾ (pair ⨾ k' ⨾ (ℕ→curry n)) - ≡⟨ cong (λ x → x ⨾ (pair ⨾ k' ⨾ (ℕ→curry n))) refl ⟩ - pr₁ ⨾ (pair ⨾ k' ⨾ (ℕ→curry n)) + Zsuc≡false : ∀ n → Z ⨾ (ℕ→curry (suc n)) ≡ false + Zsuc≡false n = Z ⨾ (ℕ→curry (suc n)) + ≡⟨ cong (λ x → Z ⨾ x) refl ⟩ + Z ⨾ (pair ⨾ k' ⨾ (ℕ→curry n)) + ≡⟨ cong (λ x → x ⨾ (pair ⨾ k' ⨾ (ℕ→curry n))) refl ⟩ + pr₁ ⨾ (pair ⨾ k' ⨾ (ℕ→curry n)) ≡⟨ pr₁pxy≡x k' (ℕ→curry n) ⟩ false ∎ S : A - S = pair ⨾ k' + S = pair ⨾ k' - Sn≡sucn : ∀ n → S ⨾ (ℕ→curry n) ≡ ℕ→curry (suc n) - Sn≡sucn n = S ⨾ (ℕ→curry n) - ≡⟨ cong (λ x → x ⨾ (ℕ→curry n)) refl ⟩ - pair ⨾ k' ⨾ (ℕ→curry n) + Sn≡sucn : ∀ n → S ⨾ (ℕ→curry n) ≡ ℕ→curry (suc n) + Sn≡sucn n = S ⨾ (ℕ→curry n) + ≡⟨ cong (λ x → x ⨾ (ℕ→curry n)) refl ⟩ + pair ⨾ k' ⨾ (ℕ→curry n) ∎ P : A - P = s ⨾ (s ⨾ (s ⨾ (k ⨾ pr₁) ⨾ i) ⨾ (k ⨾ (ℕ→curry zero))) ⨾ (s ⨾ (k ⨾ (pr₂)) ⨾ i) + P = s ⨾ (s ⨾ (s ⨾ (k ⨾ pr₁) ⨾ i) ⨾ (k ⨾ (ℕ→curry zero))) ⨾ (s ⨾ (k ⨾ (pr₂)) ⨾ i) - postulate Pzero≡zero : P ⨾ (ℕ→curry zero) ≡ ℕ→curry zero - postulate Psucn≡n : ∀ n → P ⨾ (ℕ→curry (suc n)) ≡ ℕ→curry n + postulate Pzero≡zero : P ⨾ (ℕ→curry zero) ≡ ℕ→curry zero + postulate Psucn≡n : ∀ n → P ⨾ (ℕ→curry (suc n)) ≡ ℕ→curry n B : ∀ g f → A - B g f = s ⨾ (k ⨾ g) ⨾ (s ⨾ (k ⨾ f) ⨾ i) + B g f = s ⨾ (k ⨾ g) ⨾ (s ⨾ (k ⨾ f) ⨾ i) - Ba≡gfa : ∀ g f a → B g f ⨾ a ≡ g ⨾ (f ⨾ a) + Ba≡gfa : ∀ g f a → B g f ⨾ a ≡ g ⨾ (f ⨾ a) Ba≡gfa g f a = - s ⨾ (k ⨾ g) ⨾ (s ⨾ (k ⨾ f) ⨾ i) ⨾ a - ≡⟨ sabc≡ac_bc (k ⨾ g) (s ⨾ (k ⨾ f) ⨾ i) a ⟩ - (k ⨾ g ⨾ a) ⨾ (s ⨾ (k ⨾ f) ⨾ i ⨾ a) - ≡⟨ cong (λ x → x ⨾ (s ⨾ (k ⨾ f) ⨾ i ⨾ a)) (kab≡a g a) ⟩ - g ⨾ (s ⨾ (k ⨾ f) ⨾ i ⨾ a) - ≡⟨ cong (λ x → g ⨾ x) (sabc≡ac_bc (k ⨾ f) i a) ⟩ - g ⨾ ((k ⨾ f ⨾ a) ⨾ (i ⨾ a)) - ≡⟨ cong (λ x → g ⨾ (x ⨾ (i ⨾ a))) (kab≡a f a) ⟩ - g ⨾ (f ⨾ (i ⨾ a)) - ≡⟨ cong (λ x → g ⨾ (f ⨾ x)) (ia≡a a) ⟩ - g ⨾ (f ⨾ a) + s ⨾ (k ⨾ g) ⨾ (s ⨾ (k ⨾ f) ⨾ i) ⨾ a + ≡⟨ sabc≡ac_bc (k ⨾ g) (s ⨾ (k ⨾ f) ⨾ i) a ⟩ + (k ⨾ g ⨾ a) ⨾ (s ⨾ (k ⨾ f) ⨾ i ⨾ a) + ≡⟨ cong (λ x → x ⨾ (s ⨾ (k ⨾ f) ⨾ i ⨾ a)) (kab≡a g a) ⟩ + g ⨾ (s ⨾ (k ⨾ f) ⨾ i ⨾ a) + ≡⟨ cong (λ x → g ⨾ x) (sabc≡ac_bc (k ⨾ f) i a) ⟩ + g ⨾ ((k ⨾ f ⨾ a) ⨾ (i ⨾ a)) + ≡⟨ cong (λ x → g ⨾ (x ⨾ (i ⨾ a))) (kab≡a f a) ⟩ + g ⨾ (f ⨾ (i ⨾ a)) + ≡⟨ cong (λ x → g ⨾ (f ⨾ x)) (ia≡a a) ⟩ + g ⨾ (f ⨾ a) ∎ diff --git a/docs/Realizability.Tripos.Everything.html b/docs/Realizability.Tripos.Everything.html new file mode 100644 index 0000000..abc78d0 --- /dev/null +++ b/docs/Realizability.Tripos.Everything.html @@ -0,0 +1,4 @@ + +Realizability.Tripos.Everything
module Realizability.Tripos.Everything where
+open import Realizability.Tripos.Predicate
+
\ No newline at end of file diff --git a/docs/Realizability.Tripos.Predicate.html b/docs/Realizability.Tripos.Predicate.html new file mode 100644 index 0000000..8804cdc --- /dev/null +++ b/docs/Realizability.Tripos.Predicate.html @@ -0,0 +1,339 @@ + +Realizability.Tripos.Predicate
open import Realizability.CombinatoryAlgebra
+open import Cubical.Foundations.Prelude
+open import Cubical.Foundations.HLevels
+open import Cubical.Foundations.Isomorphism
+open import Cubical.Foundations.Equiv
+open import Cubical.Foundations.Univalence
+open import Cubical.Foundations.Function
+open import Cubical.Functions.FunExtEquiv
+open import Cubical.Data.Sigma
+open import Cubical.Data.Sum
+open import Cubical.HITs.PropositionalTruncation
+open import Cubical.HITs.PropositionalTruncation.Monad
+open import Cubical.Relation.Binary.Order
+
+module Realizability.Tripos.Predicate {ℓ} {A : Type ℓ} (ca : CombinatoryAlgebra A) where
+open CombinatoryAlgebra ca
+open Realizability.CombinatoryAlgebra.Combinators ca renaming (i to Id; ia≡a to Ida≡a)
+
+record Predicate {ℓ' ℓ''} (X : Type ℓ') : Type (ℓ-max (ℓ-max (ℓ-suc ℓ) (ℓ-suc ℓ')) (ℓ-suc ℓ'')) where
+  field
+    isSetX : isSet X
+    ∣_∣ : X → A → Type (ℓ-max (ℓ-max ℓ ℓ') ℓ'')
+    isPropValued : ∀ x a → isProp (∣_∣ x a)
+
+open Predicate
+_⊩_ : ∀ {ℓ'} → A → (A → Type ℓ') → Type ℓ'
+a ⊩ ϕ = ϕ a
+
+PredicateΣ : ∀ {ℓ' ℓ''} → (X : Type ℓ') → Type (ℓ-max (ℓ-max (ℓ-suc ℓ) (ℓ-suc ℓ')) (ℓ-suc ℓ''))
+PredicateΣ {ℓ'} {ℓ''} X = Σ[ rel ∈ (X → A → hProp (ℓ-max (ℓ-max ℓ ℓ') ℓ'')) ] (isSet X)
+
+isSetPredicateΣ : ∀ {ℓ' ℓ''} (X : Type ℓ') → isSet (PredicateΣ {ℓ'' = ℓ''} X)
+isSetPredicateΣ X = isSetΣ (isSetΠ (λ x → isSetΠ λ a → isSetHProp)) λ _ → isProp→isSet isPropIsSet
+
+PredicateIsoΣ : ∀ {ℓ' ℓ''} (X : Type ℓ') → Iso (Predicate {ℓ'' = ℓ''} X) (PredicateΣ {ℓ'' = ℓ''} X)
+PredicateIsoΣ {ℓ'} {ℓ''} X =
+  iso
+    (λ p → (λ x a → (a ⊩ ∣ p ∣ x) , p .isPropValued x a) , p .isSetX)
+    (λ p → record { isSetX = p .snd ; ∣_∣ = λ x a → p .fst x a .fst ; isPropValued = λ x a → p .fst x a .snd })
+    (λ b → refl)
+    λ a → refl
+
+Predicate≡PredicateΣ : ∀ {ℓ' ℓ''} (X : Type ℓ') → Predicate {ℓ'' = ℓ''} X ≡ PredicateΣ {ℓ'' = ℓ''} X
+Predicate≡PredicateΣ {ℓ'} {ℓ''} X = isoToPath (PredicateIsoΣ X)
+
+isSetPredicate : ∀ {ℓ' ℓ''} (X : Type ℓ') → isSet (Predicate {ℓ'' = ℓ''} X)
+isSetPredicate {ℓ'} {ℓ''} X = subst (λ predicateType → isSet predicateType) (sym (Predicate≡PredicateΣ X)) (isSetPredicateΣ {ℓ'' = ℓ''} X)
+
+PredicateΣ≡ : ∀ {ℓ' ℓ''} (X : Type ℓ') → (P Q : PredicateΣ {ℓ'' = ℓ''} X) → (P .fst ≡ Q .fst) → P ≡ Q
+PredicateΣ≡ X P Q ∣P∣≡∣Q∣ = Σ≡Prop (λ _ → isPropIsSet) ∣P∣≡∣Q∣
+
+
+module PredicateProperties {ℓ' ℓ''} (X : Type ℓ') where
+  PredicateX = Predicate {ℓ'' = ℓ''} X
+  open Predicate
+  _≤_ : Predicate {ℓ'' = ℓ''} X → Predicate {ℓ'' = ℓ''} X → Type (ℓ-max (ℓ-max ℓ ℓ') ℓ'')
+  ϕ ≤ ψ = ∃[ b ∈ A ] (∀ (x : X) (a : A) → a ⊩ (∣ ϕ ∣ x) → (b ⨾ a) ⊩ ∣ ψ ∣ x)
+
+  isProp≤ : ∀ ϕ ψ → isProp (ϕ ≤ ψ)
+  isProp≤ ϕ ψ = isPropPropTrunc
+
+  isRefl≤ : ∀ ϕ → ϕ ≤ ϕ
+  isRefl≤ ϕ = ∣ Id , (λ x a a⊩ϕx → subst (λ r → r ⊩ ∣ ϕ ∣ x) (sym (Ida≡a a)) a⊩ϕx) ∣₁
+
+  isTrans≤ : ∀ ϕ ψ ξ → ϕ ≤ ψ → ψ ≤ ξ → ϕ ≤ ξ
+  isTrans≤ ϕ ψ ξ ϕ≤ψ ψ≤ξ = do
+                           (a , ϕ≤[a]ψ) ← ϕ≤ψ
+                           (b , ψ≤[b]ξ) ← ψ≤ξ
+                           return
+                             ((B b a) ,
+                             (λ x a' a'⊩ϕx →
+                               subst
+                                 (λ r → r ⊩ ∣ ξ ∣ x)
+                                 (sym (Ba≡gfa b a a'))
+                                 (ψ≤[b]ξ x (a ⨾ a')
+                                 (ϕ≤[a]ψ x a' a'⊩ϕx))))
+    
+
+  open IsPreorder renaming
+    (is-set to isSet
+    ;is-prop-valued to isPropValued
+    ;is-refl to isRefl
+    ;is-trans to isTrans)
+
+  preorder≤ : _
+  preorder≤ = preorder (Predicate X) _≤_ (ispreorder (isSetPredicate X) isProp≤ isRefl≤ isTrans≤)
+
+  infix 25 _⊔_
+  _⊔_ : PredicateX → PredicateX → PredicateX
+  (ϕ ⊔ ψ) .isSetX = ϕ .isSetX
+  ∣ ϕ ⊔ ψ ∣ x a = ∥ ((pair ⨾ k ⨾ a) ⊩ ∣ ϕ ∣ x) ⊎ ((pair ⨾ k' ⨾ a) ⊩ ∣ ψ ∣ x) ∥₁
+  (ϕ ⊔ ψ) .isPropValued x a = isPropPropTrunc
+
+  infix 25 _⊓_
+  _⊓_ : PredicateX → PredicateX → PredicateX
+  (ϕ ⊓ ψ) .isSetX = ϕ .isSetX
+  ∣ ϕ ⊓ ψ ∣ x a = ((pr₁ ⨾ a) ⊩ ∣ ϕ ∣ x) × ((pr₂ ⨾ a) ⊩ ∣ ψ ∣ x)
+  (ϕ ⊓ ψ) .isPropValued x a = isProp× (ϕ .isPropValued x (pr₁ ⨾ a)) (ψ .isPropValued x (pr₂ ⨾ a))
+
+  infix 25 _⇒_
+  _⇒_ : PredicateX → PredicateX → PredicateX
+  (ϕ ⇒ ψ) .isSetX = ϕ .isSetX
+  ∣ ϕ ⇒ ψ ∣ x a = ∀ b → (b ⊩ ∣ ϕ ∣ x) → (a ⨾ b) ⊩ ∣ ψ ∣ x
+  (ϕ ⇒ ψ) .isPropValued x a = isPropΠ λ a → isPropΠ λ a⊩ϕx → ψ .isPropValued _ _
+
+module Morphism {ℓ' ℓ''} {X Y : Type ℓ'} (isSetX : isSet X) (isSetY : isSet Y)  where
+  PredicateX = Predicate {ℓ'' = ℓ''} X
+  PredicateY = Predicate {ℓ'' = ℓ''} Y
+  module PredicatePropertiesX = PredicateProperties {ℓ'' = ℓ''} X
+  module PredicatePropertiesY = PredicateProperties {ℓ'' = ℓ''} Y
+  open PredicatePropertiesX hiding (PredicateX) renaming (_≤_ to _≤X_ ; isProp≤ to isProp≤X)
+  open PredicatePropertiesY hiding (PredicateX) renaming (_≤_ to _≤Y_ ; isProp≤ to isProp≤Y)
+
+  ⋆_ : (X → Y) → (PredicateY → PredicateX)
+  ⋆ f =
+    λ ϕ →
+      record
+        { isSetX = isSetX
+        ; ∣_∣ = λ x a → a ⊩ ∣ ϕ ∣ (f x)
+        ; isPropValued = λ x a → ϕ .isPropValued (f x) a }
+
+  `∀[_] : (X → Y) → (PredicateX → PredicateY)
+  `∀[ f ] =
+    λ ϕ →
+      record
+        { isSetX = isSetY
+        ; ∣_∣ = λ y a → (∀ b x → f x ≡ y → (a ⨾ b) ⊩ ∣ ϕ ∣ x)
+        ; isPropValued = λ y a → isPropΠ λ a' → isPropΠ λ x → isPropΠ λ fx≡y → ϕ .isPropValued x (a ⨾ a') }
+
+  `∃[_] : (X → Y) → (PredicateX → PredicateY)
+  `∃[ f ] =
+    λ ϕ →
+      record
+        { isSetX = isSetY
+        ; ∣_∣ = λ y a → ∃[ x ∈ X ] (f x ≡ y) × (a ⊩ ∣ ϕ ∣ x)
+        ; isPropValued = λ y a → isPropPropTrunc }
+
+  -- Adjunction proofs
+
+  `∃isLeftAdjoint→ : ∀ ϕ ψ f → `∃[ f ] ϕ ≤Y ψ → ϕ ≤X (⋆ f) ψ
+  `∃isLeftAdjoint→ ϕ ψ f p =
+    do
+      (a~ , a~proves) ← p
+      return (a~ , (λ x a a⊩ϕx → a~proves (f x) a ∣ x , refl , a⊩ϕx ∣₁))
+
+
+  `∃isLeftAdjoint← : ∀ ϕ ψ f → ϕ ≤X (⋆ f) ψ → `∃[ f ] ϕ ≤Y ψ
+  `∃isLeftAdjoint← ϕ ψ f p =
+    do
+      (a~ , a~proves) ← p
+      return
+        (a~ ,
+        (λ y b b⊩∃fϕ →
+          equivFun
+            (propTruncIdempotent≃
+              (ψ .isPropValued y (a~ ⨾ b)))
+              (do
+                (x , fx≡y , b⊩ϕx) ← b⊩∃fϕ
+                return (subst (λ y' → (a~ ⨾ b) ⊩ ∣ ψ ∣ y') fx≡y (a~proves x b b⊩ϕx)))))
+
+  `∃isLeftAdjoint : ∀ ϕ ψ f → `∃[ f ] ϕ ≤Y ψ ≡ ϕ ≤X (⋆ f) ψ
+  `∃isLeftAdjoint ϕ ψ f =
+    hPropExt
+      (isProp≤Y (`∃[ f ] ϕ) ψ)
+      (isProp≤X ϕ ((⋆ f) ψ))
+      (`∃isLeftAdjoint→ ϕ ψ f)
+      (`∃isLeftAdjoint← ϕ ψ f)
+
+  `∀isRightAdjoint→ : ∀ ϕ ψ f → ψ ≤Y `∀[ f ] ϕ → (⋆ f) ψ ≤X ϕ
+  `∀isRightAdjoint→ ϕ ψ f p =
+    do
+      (a~ , a~proves) ← p
+      let realizer = (s ⨾ (s ⨾ (k ⨾ a~) ⨾ Id) ⨾ (k ⨾ k))
+      return
+        (realizer ,
+        (λ x a a⊩ψfx →
+          equivFun
+            (propTruncIdempotent≃
+              (ϕ .isPropValued x (realizer ⨾ a) ))
+              (do
+                let ∀prover = a~proves (f x) a a⊩ψfx
+                return
+                  (subst
+                    (λ ϕ~ → ϕ~ ⊩ ∣ ϕ ∣ x)
+                    (sym
+                      (realizer ⨾ a
+                        ≡⟨ refl ⟩
+                       s ⨾ (s ⨾ (k ⨾ a~) ⨾ Id) ⨾ (k ⨾ k) ⨾ a
+                        ≡⟨ sabc≡ac_bc _ _ _ ⟩
+                       s ⨾ (k ⨾ a~) ⨾ Id ⨾ a ⨾ (k ⨾ k ⨾ a)
+                        ≡⟨ cong (λ x → x ⨾ (k ⨾ k ⨾ a)) (sabc≡ac_bc _ _ _) ⟩
+                       k ⨾ a~ ⨾ a ⨾ (Id ⨾ a) ⨾ (k ⨾ k ⨾ a)
+                        ≡⟨ cong (λ x → k ⨾ a~ ⨾ a ⨾ x ⨾ (k ⨾ k ⨾ a)) (Ida≡a a) ⟩
+                       k ⨾ a~ ⨾ a ⨾ a ⨾ (k ⨾ k ⨾ a)
+                        ≡⟨ cong (λ x → k ⨾ a~ ⨾ a ⨾ a ⨾ x) (kab≡a _ _) ⟩
+                       (k ⨾ a~ ⨾ a) ⨾ a ⨾ k
+                        ≡⟨ cong (λ x → x ⨾ a ⨾ k) (kab≡a _ _) ⟩
+                       a~ ⨾ a ⨾ k
+                         ∎))
+                    (∀prover k x refl)))))
+
+  `∀isRightAdjoint← : ∀ ϕ ψ f → (⋆ f) ψ ≤X ϕ → ψ ≤Y `∀[ f ] ϕ
+  `∀isRightAdjoint← ϕ ψ f p =
+    do
+      (a~ , a~proves) ← p
+      let realizer = (s ⨾ (s ⨾ (k ⨾ s) ⨾ (s ⨾ (k ⨾ k) ⨾ (k ⨾ a~))) ⨾ (s ⨾ (k ⨾ k) ⨾ Id))
+      return
+        (realizer ,
+        (λ y b b⊩ψy a x fx≡y →
+          subst
+            (λ r → r ⊩ ∣ ϕ ∣ x)
+            (sym
+              (realizer ⨾ b ⨾ a
+                 ≡⟨ refl ⟩
+               s ⨾ (s ⨾ (k ⨾ s) ⨾ (s ⨾ (k ⨾ k) ⨾ (k ⨾ a~))) ⨾ (s ⨾ (k ⨾ k) ⨾ Id) ⨾ b ⨾ a
+                 ≡⟨ cong (λ x → x ⨾ a) (sabc≡ac_bc _ _ _) ⟩
+               s ⨾ (k ⨾ s) ⨾ (s ⨾ (k ⨾ k) ⨾ (k ⨾ a~)) ⨾ b ⨾ (s ⨾ (k ⨾ k) ⨾ Id ⨾ b) ⨾ a
+                 ≡⟨ cong (λ x → s ⨾ (k ⨾ s) ⨾ (s ⨾ (k ⨾ k) ⨾ (k ⨾ a~)) ⨾ b ⨾ x ⨾ a) (sabc≡ac_bc (k ⨾ k) Id b) ⟩
+               s ⨾ (k ⨾ s) ⨾ (s ⨾ (k ⨾ k) ⨾ (k ⨾ a~)) ⨾ b ⨾ ((k ⨾ k ⨾ b) ⨾ (Id ⨾ b)) ⨾ a
+                 ≡⟨ cong (λ x → s ⨾ (k ⨾ s) ⨾ (s ⨾ (k ⨾ k) ⨾ (k ⨾ a~)) ⨾ b ⨾ (x ⨾ (Id ⨾ b)) ⨾ a) (kab≡a _ _) ⟩
+               s ⨾ (k ⨾ s) ⨾ (s ⨾ (k ⨾ k) ⨾ (k ⨾ a~)) ⨾ b ⨾ (k ⨾ (Id ⨾ b)) ⨾ a
+                 ≡⟨ cong (λ x → s ⨾ (k ⨾ s) ⨾ (s ⨾ (k ⨾ k) ⨾ (k ⨾ a~)) ⨾ b ⨾ (k ⨾ x) ⨾ a) (Ida≡a b) ⟩
+               s ⨾ (k ⨾ s) ⨾ (s ⨾ (k ⨾ k) ⨾ (k ⨾ a~)) ⨾ b ⨾ (k ⨾ b) ⨾ a
+                 ≡⟨ cong (λ x → x ⨾ (k ⨾ b) ⨾ a) (sabc≡ac_bc _ _ _) ⟩
+               k ⨾ s ⨾ b ⨾ (s ⨾ (k ⨾ k) ⨾ (k ⨾ a~) ⨾ b) ⨾ (k ⨾ b) ⨾ a
+                 ≡⟨ cong (λ x → x ⨾ (s ⨾ (k ⨾ k) ⨾ (k ⨾ a~) ⨾ b) ⨾ (k ⨾ b) ⨾ a) (kab≡a _ _) ⟩
+               s ⨾ (s ⨾ (k ⨾ k) ⨾ (k ⨾ a~) ⨾ b) ⨾ (k ⨾ b) ⨾ a
+                 ≡⟨ sabc≡ac_bc _ _ _ ⟩
+               s ⨾ (k ⨾ k) ⨾ (k ⨾ a~) ⨾ b ⨾ a ⨾ (k ⨾ b ⨾ a)
+                 ≡⟨ cong (λ x → s ⨾ (k ⨾ k) ⨾ (k ⨾ a~) ⨾ b ⨾ a ⨾ x) (kab≡a b a) ⟩
+               s ⨾ (k ⨾ k) ⨾ (k ⨾ a~) ⨾ b ⨾ a ⨾ b
+                 ≡⟨ cong (λ x → x ⨾ a ⨾ b) (sabc≡ac_bc (k ⨾ k) (k ⨾ a~) b) ⟩
+               k ⨾ k ⨾ b ⨾ (k ⨾ a~ ⨾ b) ⨾ a ⨾ b
+                 ≡⟨ cong (λ x → x ⨾ (k ⨾ a~ ⨾ b) ⨾ a ⨾ b) (kab≡a _ _) ⟩
+               k ⨾ (k ⨾ a~ ⨾ b) ⨾ a ⨾ b
+                 ≡⟨ cong (λ x → k ⨾ x ⨾ a ⨾ b) (kab≡a _ _) ⟩
+               k ⨾ a~ ⨾ a ⨾ b
+                 ≡⟨ cong (λ x → x ⨾ b) (kab≡a _ _) ⟩
+               a~ ⨾ b
+                   ∎))
+            (a~proves x b (subst (λ x' → b ⊩ ∣ ψ ∣ x') (sym fx≡y) b⊩ψy))))
+
+  `∀isRightAdjoint : ∀ ϕ ψ f → (⋆ f) ψ ≤X ϕ ≡ ψ ≤Y `∀[ f ] ϕ
+  `∀isRightAdjoint ϕ ψ f =
+    hPropExt
+      (isProp≤X ((⋆ f) ψ) ϕ)
+      (isProp≤Y ψ (`∀[ f ] ϕ))
+      (`∀isRightAdjoint← ϕ ψ f)
+      (`∀isRightAdjoint→ ϕ ψ f)
+
+-- The proof is trivial but I am the reader it was left to as an exercise
+module BeckChevalley
+    {ℓ' ℓ'' : Level}
+    (I J K : Type ℓ')
+    (isSetI : isSet I)
+    (isSetJ : isSet J)
+    (isSetK : isSet K)
+    (f : J → I)
+    (g : K → I) where
+
+    module Morphism' = Morphism {ℓ' = ℓ'} {ℓ'' = ℓ''}
+    open Morphism'
+    
+    L = Σ[ k ∈ K ] Σ[ j ∈ J ] (g k ≡ f j)
+
+    isSetL : isSet L
+    isSetL = isSetΣ isSetK λ k → isSetΣ isSetJ λ j → isProp→isSet (isSetI _ _)
+
+    p : L → K
+    p (k , _ , _) = k
+
+    q : L → J
+    q (_ , l , _) = l
+
+    q* = ⋆_ isSetL isSetJ q
+    g* = ⋆_ isSetK isSetI g
+
+    module `f = Morphism' isSetJ isSetI
+    open `f renaming (`∃[_] to `∃[J→I][_]; `∀[_] to `∀[J→I][_])
+
+    module `q = Morphism' isSetL isSetK
+    open `q renaming (`∃[_] to `∃[L→K][_]; `∀[_] to `∀[L→K][_])
+
+    `∃BeckChevalley→ : ∀ ϕ k a → a ⊩ ∣ g* (`∃[J→I][ f ] ϕ) ∣ k → a ⊩ ∣ `∃[L→K][ p ] (q* ϕ) ∣ k
+    `∃BeckChevalley→ ϕ k a p =
+      do
+        (j , fj≡gk , a⊩ϕj) ← p
+        return ((k , (j , (sym fj≡gk))) , (refl , a⊩ϕj))
+
+    `∃BeckChevalley← : ∀ ϕ k a → a ⊩ ∣ `∃[L→K][ p ] (q* ϕ) ∣ k → a ⊩ ∣ g* (`∃[J→I][ f ] ϕ) ∣ k
+    `∃BeckChevalley← ϕ k a p =
+      do
+        (x@(k' , j , gk'≡fj) , k'≡k , a⊩ϕqj) ← p
+        return (j , (subst (λ k → f j ≡ g k) k'≡k (sym gk'≡fj)) , a⊩ϕqj)
+
+    open Iso
+    `∃BeckChevalley : g* ∘ `∃[J→I][ f ] ≡ `∃[L→K][ p ] ∘ q*
+    `∃BeckChevalley =
+      funExt λ ϕ i →
+        PredicateIsoΣ K .inv
+          (PredicateΣ≡ {ℓ'' = ℓ''} K
+            ((λ k a → (∣ (g* ∘ `∃[J→I][ f ]) ϕ ∣ k a) , ((g* ∘ `∃[J→I][ f ]) ϕ .isPropValued k a)) , isSetK)
+            ((λ k a → (∣ (`∃[L→K][ p ] ∘ q*) ϕ ∣ k a) , ((`∃[L→K][ p ] ∘ q*) ϕ .isPropValued k a)) , isSetK)
+            (funExt₂
+              (λ k a →
+                Σ≡Prop
+                  (λ x → isPropIsProp {A = x})
+                  (hPropExt
+                    (g* (`∃[J→I][ f ] ϕ) .isPropValued k a)
+                    (`∃[L→K][ p ] (q* ϕ) .isPropValued k a)
+                    (`∃BeckChevalley→ ϕ k a)
+                    (`∃BeckChevalley← ϕ k a))))
+           i)
+
+    `∀BeckChevalley→ : ∀ ϕ k a → a ⊩ ∣ g* (`∀[J→I][ f ] ϕ) ∣ k → a ⊩ ∣ `∀[L→K][ p ] (q* ϕ) ∣ k
+    `∀BeckChevalley→ ϕ k a p b (k' , j , gk'≡fj) k'≡k = p b j (sym (subst (λ k'' → g k'' ≡ f j) k'≡k gk'≡fj))
+
+    `∀BeckChevalley← : ∀ ϕ k a → a ⊩ ∣ `∀[L→K][ p ] (q* ϕ) ∣ k → a ⊩ ∣ g* (`∀[J→I][ f ] ϕ) ∣ k
+    `∀BeckChevalley← ϕ k a p b j fj≡gk = p b (k , j , sym fj≡gk) refl
+
+    `∀BeckChevalley : g* ∘ `∀[J→I][ f ] ≡ `∀[L→K][ p ] ∘ q*
+    `∀BeckChevalley =
+      funExt λ ϕ i →
+        PredicateIsoΣ K .inv
+          (PredicateΣ≡ {ℓ'' = ℓ''} K
+            ((λ k a → (a ⊩ ∣ g* (`∀[J→I][ f ] ϕ) ∣ k) , (g* (`∀[J→I][ f ] ϕ) .isPropValued k a)) , isSetK)
+            ((λ k a → (a ⊩ ∣ `∀[L→K][ p ] (q* ϕ) ∣ k) , (`∀[L→K][ p ] (q* ϕ) .isPropValued k a)) , isSetK)
+            (funExt₂
+              (λ k a →
+                Σ≡Prop
+                  (λ x → isPropIsProp {A = x})
+                  (hPropExt
+                    (g* (`∀[J→I][ f ] ϕ) .isPropValued k a)
+                    (`∀[L→K][ p ] (q* ϕ) .isPropValued k a)
+                    (`∀BeckChevalley→ ϕ k a)
+                    (`∀BeckChevalley← ϕ k a))))
+          i)
+
\ No newline at end of file diff --git a/docs/index.html b/docs/index.html index 667dee9..4565084 100644 --- a/docs/index.html +++ b/docs/index.html @@ -2,11 +2,12 @@ index
{-# OPTIONS --cubical #-}
 module index where
 
-open import Realizability.Partiality
-open import Realizability.PartialApplicativeStructure
---open import Realizability.PartialCombinatoryAlgebra
-open import Realizability.CombinatoryAlgebra
-open import Realizability.ApplicativeStructure
-open import Realizability.Assembly.Everything
-open import Realizability.Choice
+--open import Realizability.Partiality
+--open import Realizability.PartialApplicativeStructure
+--open import Realizability.PartialCombinatoryAlgebra
+open import Realizability.CombinatoryAlgebra
+open import Realizability.ApplicativeStructure
+open import Realizability.Assembly.Everything
+open import Realizability.Tripos.Everything
+open import Realizability.Choice
\ No newline at end of file diff --git a/src/Realizability/ApplicativeStructure.agda b/src/Realizability/ApplicativeStructure.agda index dc60b2e..4591099 100644 --- a/src/Realizability/ApplicativeStructure.agda +++ b/src/Realizability/ApplicativeStructure.agda @@ -1,4 +1,4 @@ -{-# OPTIONS --cubical --allow-unsolved-metas #-} +{-# OPTIONS --cubical --without-K --allow-unsolved-metas #-} open import Cubical.Core.Everything open import Cubical.Foundations.Prelude open import Cubical.Foundations.HLevels @@ -7,6 +7,7 @@ open import Cubical.Data.Nat open import Cubical.Data.Nat.Order open import Cubical.Data.Fin open import Cubical.Data.Vec +open import Cubical.Data.Empty renaming (elim to ⊥elim) module Realizability.ApplicativeStructure where @@ -89,14 +90,21 @@ module _ {ℓ} {A : Type ℓ} (as : ApplicativeStructure A) where module _ (feferman : Feferman) where open Feferman feferman + {- + This goofy definition is there to ensure that λ* computes. + For some reason the last branch of pattern-matching cannot definitionally equate y .fst and suc m + So we must postulate it. + But since we already know that y .fst = suc m we can use discreteℕ to get an actual proof and extract + it using fromYes. fromYes then gets a dummy proof + -} λ* : ∀ {n} (e : Term (suc n)) → Term n λ* (` a) = ` k ̇ ` a λ* (a ̇ b) = ` s ̇ (λ* a) ̇ (λ* b) - λ* {n} (# y) with (discreteℕ n (y .fst)) + λ* {n} (# y) with (discreteℕ (y .fst) zero) ... | yes _ = ` s ̇ ` k ̇ ` k - ... | no ¬y≡n with (y .fst) - ... | zero = ` k ̇ (# (zero , {!suc-≤-suc (zero-≤ {n = (predℕ n)})!})) - ... | (suc m) = ` k ̇ (# (((suc m) , {!!}))) + ... | no ¬y≡zero with (y .fst) + ... | zero = ⊥elim (¬y≡zero refl) + ... | (suc m) = # (m , pred-≤-pred (subst (λ y' → suc y' ≤ suc n) (fromYes fsty≡sucm (discreteℕ (y .fst) (suc m))) (y .snd))) where postulate fsty≡sucm : fst y ≡ suc m λ*-chainTerm : ∀ n → Term n → Term zero λ*-chainTerm zero t = t @@ -105,6 +113,11 @@ module _ {ℓ} {A : Type ℓ} (as : ApplicativeStructure A) where λ*-chain : ∀ {n} → Term n → A λ*-chain {n} t = substitute (λ*-chainTerm n t) [] + ⟦_⟧ : Term zero → A + ⟦ ` a ⟧ = a + ⟦ a ̇ b ⟧ = ⟦ a ⟧ ⨾ ⟦ b ⟧ + ⟦ # x ⟧ = ⊥elim {A = λ _ → A} (¬Fin0 x) + open isInterpreted postulate λ*-naturality : ∀ {n} (t : Term n) (subs : Vec A n) → apply (λ*-chain t) subs ≡ substitute t subs diff --git a/src/Realizability/Tripos/Everything.agda b/src/Realizability/Tripos/Everything.agda index fe061c9..e016e81 100644 --- a/src/Realizability/Tripos/Everything.agda +++ b/src/Realizability/Tripos/Everything.agda @@ -1 +1,2 @@ module Realizability.Tripos.Everything where +open import Realizability.Tripos.Predicate diff --git a/src/index.agda b/src/index.agda index 3196779..1ade1a4 100644 --- a/src/index.agda +++ b/src/index.agda @@ -1,10 +1,11 @@ {-# OPTIONS --cubical #-} module index where -open import Realizability.Partiality -open import Realizability.PartialApplicativeStructure +--open import Realizability.Partiality +--open import Realizability.PartialApplicativeStructure --open import Realizability.PartialCombinatoryAlgebra open import Realizability.CombinatoryAlgebra open import Realizability.ApplicativeStructure open import Realizability.Assembly.Everything +open import Realizability.Tripos.Everything open import Realizability.Choice