diff --git a/#foo.agda# b/#foo.agda#
new file mode 100644
index 0000000..eb6e959
--- /dev/null
+++ b/#foo.agda#
@@ -0,0 +1,2 @@
+A → A ⇀ A
+♯ A → ♯ A → ♯ A
\ No newline at end of file
diff --git a/Makefile b/Makefile
new file mode 100644
index 0000000..0b1e34b
--- /dev/null
+++ b/Makefile
@@ -0,0 +1,10 @@
+check:
+ cd src
+ agda --html --html-dir=docs ./index.agda
+
+commit_message = Commit [Automated by Make]
+commit:
+ git add . && git commit -m '${commit_message}'
+
+push : commit
+ git push origin master
diff --git a/Makefile~ b/Makefile~
new file mode 100644
index 0000000..336d80e
--- /dev/null
+++ b/Makefile~
@@ -0,0 +1,10 @@
+check:
+ cd src
+ agda --html --html-dir=docs ./index.agda
+
+commit_message = Commit [Automated by Make]
+commit: check
+ git add . && git commit -m '${commit_message}'
+
+push : commit
+ git push origin master
diff --git a/docs/Cubical.Data.Fin.Base.html b/docs/Cubical.Data.Fin.Base.html
new file mode 100644
index 0000000..f65df59
--- /dev/null
+++ b/docs/Cubical.Data.Fin.Base.html
@@ -0,0 +1,113 @@
+
+Cubical.Data.Fin.Base {-# OPTIONS --safe #-}
+
+module Cubical.Data.Fin.Base where
+
+open import Cubical.Foundations.Prelude
+open import Cubical.Foundations.Function
+open import Cubical.Foundations.HLevels
+
+import Cubical.Data.Empty as ⊥
+open import Cubical.Data.Nat using ( ℕ ; zero ; suc ; _+_ ; znots )
+open import Cubical.Data.Nat.Order
+open import Cubical.Data.Nat.Order.Recursive using () renaming ( _≤_ to _≤′_ )
+open import Cubical.Data.Sigma
+open import Cubical.Data.Sum using ( _⊎_ ; _⊎?_ ; inl ; inr )
+
+open import Cubical.Relation.Nullary
+
+
+
+
+
+
+
+
+Fin : ℕ → Type₀
+Fin n = Σ[ k ∈ ℕ ] k < n
+
+private
+ variable
+ ℓ : Level
+ k : ℕ
+
+fzero : Fin ( suc k )
+fzero = ( 0 , suc-≤-suc zero-≤ )
+
+fone : Fin ( suc ( suc k ))
+fone = ( 1 , suc-≤-suc ( suc-≤-suc zero-≤ ))
+
+fzero≠fone : ¬ fzero { k = suc k } ≡ fone
+fzero≠fone p = znots ( cong fst p )
+
+
+
+fsuc : Fin k → Fin ( suc k )
+fsuc ( k , l ) = ( suc k , suc-≤-suc l )
+
+
+toℕ : Fin k → ℕ
+toℕ = fst
+
+
+toℕ-injective : ∀{ fj fk : Fin k } → toℕ fj ≡ toℕ fk → fj ≡ fk
+toℕ-injective { fj = fj } { fk } = Σ≡Prop (λ _ → isProp≤ )
+
+
+
+fromℕ≤ : ( m n : ℕ ) → m ≤′ n → Fin ( suc n )
+fromℕ≤ zero _ _ = fzero
+fromℕ≤ ( suc m ) ( suc n ) m≤n = fsuc ( fromℕ≤ m n m≤n )
+
+
+fsplit
+ : ∀( fj : Fin ( suc k ))
+ → ( fzero ≡ fj ) ⊎ ( Σ[ fk ∈ Fin k ] fsuc fk ≡ fj )
+fsplit ( 0 , k<sn ) = inl ( toℕ-injective refl )
+fsplit ( suc k , k<sn ) = inr (( k , pred-≤-pred k<sn ) , toℕ-injective refl )
+
+inject< : ∀ { m n } ( m<n : m < n ) → Fin m → Fin n
+inject< m<n ( k , k<m ) = k , <-trans k<m m<n
+
+flast : Fin ( suc k )
+flast { k = k } = k , suc-≤-suc ≤-refl
+
+
+¬Fin0 : ¬ Fin 0
+¬Fin0 ( k , k<0 ) = ¬-<-zero k<0
+
+
+elim
+ : ∀( P : ∀{ k } → Fin k → Type ℓ )
+ → (∀{ k } → P { suc k } fzero )
+ → (∀{ k } { fn : Fin k } → P fn → P ( fsuc fn ))
+ → { k : ℕ } → ( fn : Fin k ) → P fn
+elim P fz fs { zero } = ⊥.rec ∘ ¬Fin0
+elim P fz fs { suc k } fj
+ = case fsplit fj return (λ _ → P fj ) of λ
+ { ( inl p ) → subst P p fz
+ ; ( inr ( fk , p )) → subst P p ( fs ( elim P fz fs fk ))
+ }
+
+any? : ∀ { n } { P : Fin n → Type ℓ } → (∀ i → Dec ( P i )) → Dec ( Σ ( Fin n ) P )
+any? { n = zero } { P = _} P? = no (λ ( x , _) → ¬Fin0 x )
+any? { n = suc n } { P = P } P? =
+ mapDec
+ (λ
+ { ( inl P0 ) → fzero , P0
+ ; ( inr ( x , Px )) → fsuc x , Px
+ }
+ )
+ (λ n h → n ( helper h ))
+ ( P? fzero ⊎? any? ( P? ∘ fsuc ))
+ where
+ helper : Σ ( Fin ( suc n )) P → P fzero ⊎ Σ ( Fin n ) λ z → P ( fsuc z )
+ helper ( x , Px ) with fsplit x
+ ... | inl x≡0 = inl ( subst P ( sym x≡0 ) Px )
+ ... | inr ( k , x≡sk ) = inr ( k , subst P ( sym x≡sk ) Px )
+
+FinPathℕ : { n : ℕ } ( x : Fin n ) ( y : ℕ ) → fst x ≡ y → Σ[ p ∈ _ ] ( x ≡ ( y , p ))
+FinPathℕ { n = n } x y p =
+ (( fst ( snd x )) , ( cong (λ y → fst ( snd x ) + y ) ( cong suc ( sym p )) ∙ snd ( snd x )))
+ , ( Σ≡Prop (λ _ → isProp≤ ) p )
+Cubical.Data.Fin.Literals {-# OPTIONS --no-exact-split --safe #-}
+module Cubical.Data.Fin.Literals where
+
+open import Agda.Builtin.Nat
+ using ( suc )
+open import Agda.Builtin.FromNat
+ renaming ( Number to HasFromNat )
+open import Cubical.Data.Fin.Base
+ using ( Fin ; fromℕ≤ )
+open import Cubical.Data.Nat.Order.Recursive
+ using ( _≤_ )
+
+instance
+ fromNatFin : { n : _} → HasFromNat ( Fin ( suc n ))
+ fromNatFin { n } = record
+ { Constraint = λ m → m ≤ n
+ ; fromNat = λ m ⦃ m≤n ⦄ → fromℕ≤ m n m≤n
+ }
+Cubical.Data.Fin.Properties {-# OPTIONS --safe #-}
+
+module Cubical.Data.Fin.Properties where
+
+open import Cubical.Core.Everything
+
+open import Cubical.Functions.Embedding
+open import Cubical.Functions.Surjection
+open import Cubical.Foundations.Equiv
+open import Cubical.Foundations.Function
+open import Cubical.Foundations.HLevels
+open import Cubical.Foundations.Isomorphism
+open import Cubical.Foundations.Prelude
+open import Cubical.Foundations.Univalence
+open import Cubical.Foundations.Transport
+
+open import Cubical.HITs.PropositionalTruncation renaming ( rec to ∥∥rec )
+
+open import Cubical.Data.Fin.Base as Fin
+open import Cubical.Data.Nat
+open import Cubical.Data.Nat.Order
+open import Cubical.Data.Empty as Empty
+open import Cubical.Data.Unit
+open import Cubical.Data.Sum
+open import Cubical.Data.Sigma
+open import Cubical.Data.FinData.Base renaming ( Fin to FinData ) hiding ( ¬Fin0 ; toℕ )
+
+open import Cubical.Relation.Nullary
+
+open import Cubical.Induction.WellFounded
+
+open import Cubical.Relation.Nullary
+
+private
+ variable
+ a b ℓ : Level
+ n : ℕ
+ A : Type a
+
+
+isPropFin0 : isProp ( Fin 0 )
+isPropFin0 = Empty.rec ∘ ¬Fin0
+
+
+isContrFin1 : isContr ( Fin 1 )
+isContrFin1
+ = fzero , λ
+ { ( zero , _) → toℕ-injective refl
+ ; ( suc k , sk<1 ) → Empty.rec ( ¬-<-zero ( pred-≤-pred sk<1 ))
+ }
+
+Unit≃Fin1 : Unit ≃ Fin 1
+Unit≃Fin1 =
+ isoToEquiv
+ ( iso
+ ( const fzero )
+ ( const tt )
+ ( isContrFin1 . snd )
+ ( isContrUnit . snd )
+ )
+
+
+isSetFin : ∀{ k } → isSet ( Fin k )
+isSetFin { k } = isSetΣ isSetℕ (λ _ → isProp→isSet isProp≤ )
+
+discreteFin : ∀ { n } → Discrete ( Fin n )
+discreteFin { n } ( x , hx ) ( y , hy ) with discreteℕ x y
+... | yes prf = yes ( Σ≡Prop (λ _ → isProp≤ ) prf )
+... | no prf = no λ h → prf ( cong fst h )
+
+inject<-ne : ∀ { n } ( i : Fin n ) → ¬ inject< ≤-refl i ≡ ( n , ≤-refl )
+inject<-ne { n } ( k , k<n ) p = <→≢ k<n ( cong fst p )
+
+Fin-fst-≡ : ∀ { n } { i j : Fin n } → fst i ≡ fst j → i ≡ j
+Fin-fst-≡ = Σ≡Prop (λ _ → isProp≤ )
+
+private
+ subst-app : ( B : A → Type b ) ( f : ( x : A ) → B x ) { x y : A } ( x≡y : x ≡ y ) →
+ subst B x≡y ( f x ) ≡ f y
+ subst-app B f { x = x } =
+ J (λ y e → subst B e ( f x ) ≡ f y ) ( substRefl { B = B } ( f x ))
+
+
+module _ ( P : ∀ { k } → Fin k → Type ℓ )
+ ( fz : ∀ { k } → P { suc k } fzero )
+ ( fs : ∀ { k } { fn : Fin k } → P fn → P ( fsuc fn ))
+ { k : ℕ } where
+ elim-fzero : Fin.elim P fz fs { k = suc k } fzero ≡ fz
+ elim-fzero =
+ subst P ( toℕ-injective _) fz ≡⟨ cong (λ p → subst P p fz ) ( isSetFin _ _ _ _) ⟩
+ subst P refl fz ≡⟨ substRefl { B = P } fz ⟩
+ fz ∎
+
+ elim-fsuc : ( fk : Fin k ) → Fin.elim P fz fs ( fsuc fk ) ≡ fs ( Fin.elim P fz fs fk )
+ elim-fsuc fk =
+ subst P ( toℕ-injective (λ _ → toℕ ( fsuc fk′ ))) ( fs ( Fin.elim P fz fs fk′ ))
+ ≡⟨ cong (λ p → subst P p ( fs ( Fin.elim P fz fs fk′ )) ) ( isSetFin _ _ _ _) ⟩
+ subst P ( cong fsuc fk′≡fk ) ( fs ( Fin.elim P fz fs fk′ ))
+ ≡⟨ subst-app _ (λ fj → fs ( Fin.elim P fz fs fj )) fk′≡fk ⟩
+ fs ( Fin.elim P fz fs fk )
+ ∎
+ where
+ fk′ = fst fk , pred-≤-pred ( snd ( fsuc fk ))
+ fk′≡fk : fk′ ≡ fk
+ fk′≡fk = toℕ-injective refl
+
+
+
+
+expand : ℕ → ℕ → ℕ → ℕ
+expand 0 k m = m
+expand ( suc o ) k m = k + expand o k m
+
+expand≡ : ∀ k m o → expand o k m ≡ o · k + m
+expand≡ k m zero = refl
+expand≡ k m ( suc o )
+ = cong ( k +_ ) ( expand≡ k m o ) ∙ +-assoc k ( o · k ) m
+
+
+
+expand× : ∀{ k } → ( Fin k × ℕ ) → ℕ
+expand× { k } ( f , o ) = expand o k ( toℕ f )
+
+private
+ lemma₀ : ∀{ k m n r } → r ≡ n → k + m ≡ n → k ≤ r
+ lemma₀ { k = k } { m } p q = m , +-comm m k ∙ q ∙ sym p
+
+ expand×Inj : ∀ k → { t1 t2 : Fin ( suc k ) × ℕ } → expand× t1 ≡ expand× t2 → t1 ≡ t2
+ expand×Inj k { f1 , zero } { f2 , zero } p i
+ = toℕ-injective { fj = f1 } { f2 } p i , zero
+ expand×Inj k { f1 , suc o1 } {( r , r<sk ) , zero } p
+ = Empty.rec ( <-asym r<sk ( lemma₀ refl p ))
+ expand×Inj k {( r , r<sk ) , zero } { f2 , suc o2 } p
+ = Empty.rec ( <-asym r<sk ( lemma₀ refl ( sym p )))
+ expand×Inj k { f1 , suc o1 } { f2 , suc o2 }
+ = cong (λ { ( f , o ) → ( f , suc o ) })
+ ∘ expand×Inj k { f1 , o1 } { f2 , o2 }
+ ∘ inj-m+ { suc k }
+
+ expand×Emb : ∀ k → isEmbedding ( expand× { k })
+ expand×Emb 0 = Empty.rec ∘ ¬Fin0 ∘ fst
+ expand×Emb ( suc k )
+ = injEmbedding isSetℕ ( expand×Inj k )
+
+
+
+Residue : ℕ → ℕ → Type₀
+Residue k n = Σ[ tup ∈ Fin k × ℕ ] expand× tup ≡ n
+
+
+
+isPropResidue : ∀ k n → isProp ( Residue k n )
+isPropResidue k = isEmbedding→hasPropFibers ( expand×Emb k )
+
+
+Fin→Residue : ∀{ k } → ( f : Fin k ) → Residue k ( toℕ f )
+Fin→Residue f = ( f , 0 ) , refl
+
+
+
+Residue+k : ( k n : ℕ ) → Residue k n → Residue k ( k + n )
+Residue+k k n (( f , o ) , p ) = ( f , suc o ) , cong ( k +_ ) p
+
+Residue-k : ( k n : ℕ ) → Residue k ( k + n ) → Residue k n
+Residue-k k n ((( r , r<k ) , zero ) , p ) = Empty.rec ( <-asym r<k ( lemma₀ p refl ))
+Residue-k k n (( f , suc o ) , p ) = (( f , o ) , inj-m+ p )
+
+Residue+k-k
+ : ( k n : ℕ )
+ → ( R : Residue k ( k + n ))
+ → Residue+k k n ( Residue-k k n R ) ≡ R
+Residue+k-k k n ((( r , r<k ) , zero ) , p ) = Empty.rec ( <-asym r<k ( lemma₀ p refl ))
+Residue+k-k k n (( f , suc o ) , p )
+ = Σ≡Prop (λ tup → isSetℕ ( expand× tup ) ( k + n )) refl
+
+Residue-k+k
+ : ( k n : ℕ )
+ → ( R : Residue k n )
+ → Residue-k k n ( Residue+k k n R ) ≡ R
+Residue-k+k k n (( f , o ) , p )
+ = Σ≡Prop (λ tup → isSetℕ ( expand× tup ) n ) refl
+
+private
+ Residue≃ : ∀ k n → Residue k n ≃ Residue k ( k + n )
+ Residue≃ k n
+ = Residue+k k n
+ , isoToIsEquiv ( iso ( Residue+k k n ) ( Residue-k k n )
+ ( Residue+k-k k n ) ( Residue-k+k k n ))
+
+Residue≡ : ∀ k n → Residue k n ≡ Residue k ( k + n )
+Residue≡ k n = ua ( Residue≃ k n )
+
+
+module Reduce ( k₀ : ℕ ) where
+ k : ℕ
+ k = suc k₀
+
+ base : ∀ n ( n<k : n < k ) → Residue k n
+ base n n<k = Fin→Residue ( n , n<k )
+
+ step : ∀ n → Residue k n → Residue k ( k + n )
+ step n = transport ( Residue≡ k n )
+
+ reduce : ∀ n → Residue k n
+ reduce = +induction k₀ ( Residue k ) base step
+
+ reduce≡
+ : ∀ n → transport ( Residue≡ k n ) ( reduce n ) ≡ reduce ( k + n )
+ reduce≡ n
+ = sym ( +inductionStep k₀ _ base step n )
+
+ reduceP
+ : ∀ n → PathP (λ i → Residue≡ k n i ) ( reduce n ) ( reduce ( k + n ))
+ reduceP n = toPathP ( reduce≡ n )
+
+open Reduce using ( reduce ; reduce≡ ) public
+
+extract : ∀{ k n } → Residue k n → Fin k
+extract = fst ∘ fst
+
+private
+ lemma₅
+ : ∀ k n ( R : Residue k n )
+ → extract R ≡ extract ( transport ( Residue≡ k n ) R )
+ lemma₅ k n = sym ∘ cong extract ∘ uaβ ( Residue≃ k n )
+
+
+extract≡ : ∀ k n → extract ( reduce k n ) ≡ extract ( reduce k ( suc k + n ))
+extract≡ k n
+ = lemma₅ ( suc k ) n ( reduce k n ) ∙ cong extract ( Reduce.reduce≡ k n )
+
+isContrResidue : ∀{ k n } → isContr ( Residue ( suc k ) n )
+isContrResidue { k } { n } = inhProp→isContr ( reduce k n ) ( isPropResidue ( suc k ) n )
+
+
+
+_%_ : ℕ → ℕ → ℕ
+n % zero = n
+n % ( suc k ) = toℕ ( extract ( reduce k n ))
+
+_/_ : ℕ → ℕ → ℕ
+n / zero = zero
+n / ( suc k ) = reduce k n . fst . snd
+
+moddiv : ∀ n k → ( n / k ) · k + n % k ≡ n
+moddiv n zero = refl
+moddiv n ( suc k ) = sym ( expand≡ _ _ ( n / suc k )) ∙ reduce k n . snd
+
+n%k≡n[modk] : ∀ n k → Σ[ o ∈ ℕ ] o · k + n % k ≡ n
+n%k≡n[modk] n k = ( n / k ) , moddiv n k
+
+n%sk<sk : ( n k : ℕ ) → ( n % suc k ) < suc k
+n%sk<sk n k = extract ( reduce k n ) . snd
+
+fznotfs : ∀ { m : ℕ } { k : Fin m } → ¬ fzero ≡ fsuc k
+fznotfs { m } p = subst F p tt
+ where
+ F : Fin ( suc m ) → Type₀
+ F ( zero , _) = Unit
+ F ( suc _ , _) = ⊥
+
+fsuc-inj : { fj fk : Fin n } → fsuc fj ≡ fsuc fk → fj ≡ fk
+fsuc-inj = toℕ-injective ∘ injSuc ∘ cong toℕ
+
+punchOut : ∀ { m } { i j : Fin ( suc m )} → ( ¬ i ≡ j ) → Fin m
+punchOut {_} { i } { j } p with fsplit i | fsplit j
+punchOut {_} { i } { j } p | inl prfi | inl prfj =
+ Empty.elim ( p ( i ≡⟨ sym prfi ⟩ fzero ≡⟨ prfj ⟩ j ∎ ))
+punchOut {_} { i } { j } p | inl prfi | inr ( kj , prfj ) =
+ kj
+punchOut { zero } { i } { j } p | inr ( ki , prfi ) | inl prfj =
+ Empty.elim ( p (
+ i ≡⟨ sym ( isContrFin1 . snd i ) ⟩
+ c ≡⟨ isContrFin1 . snd j ⟩
+ j ∎
+ ))
+ where c = isContrFin1 . fst
+punchOut { suc _} { i } { j } p | inr ( ki , prfi ) | inl prfj =
+ fzero
+punchOut { zero } { i } { j } p | inr ( ki , prfi ) | inr ( kj , prfj ) =
+ Empty.elim (( p (
+ i ≡⟨ sym ( isContrFin1 . snd i ) ⟩
+ c ≡⟨ isContrFin1 . snd j ⟩
+ j ∎ )
+ ))
+ where c = isContrFin1 . fst
+punchOut { suc _} { i } { j } p | inr ( ki , prfi ) | inr ( kj , prfj ) =
+ fsuc ( punchOut { i = ki } { j = kj }
+ (λ q → p ( i ≡⟨ sym prfi ⟩ fsuc ki ≡⟨ cong fsuc q ⟩ fsuc kj ≡⟨ prfj ⟩ j ∎ ))
+ )
+
+punchOut-inj
+ : ∀ { m } { i j k : Fin ( suc m )} ( i≢j : ¬ i ≡ j ) ( i≢k : ¬ i ≡ k )
+ → punchOut i≢j ≡ punchOut i≢k → j ≡ k
+punchOut-inj {_} { i } { j } { k } i≢j i≢k p with fsplit i | fsplit j | fsplit k
+punchOut-inj { zero } { i } { j } { k } i≢j i≢k p | _ | _ | _ =
+ Empty.elim ( i≢j ( i ≡⟨ sym ( isContrFin1 . snd i ) ⟩ c ≡⟨ isContrFin1 . snd j ⟩ j ∎ ))
+ where c = isContrFin1 . fst
+punchOut-inj { suc _} { i } { j } { k } i≢j i≢k p | inl prfi | inl prfj | _ =
+ Empty.elim ( i≢j ( i ≡⟨ sym prfi ⟩ fzero ≡⟨ prfj ⟩ j ∎ ))
+punchOut-inj { suc _} { i } { j } { k } i≢j i≢k p | inl prfi | _ | inl prfk =
+ Empty.elim ( i≢k ( i ≡⟨ sym prfi ⟩ fzero ≡⟨ prfk ⟩ k ∎ ))
+punchOut-inj { suc _} { i } { j } { k } i≢j i≢k p | inl prfi | inr ( kj , prfj ) | inr ( kk , prfk ) =
+ j ≡⟨ sym prfj ⟩
+ fsuc kj ≡⟨ cong fsuc p ⟩
+ fsuc kk ≡⟨ prfk ⟩
+ k ∎
+punchOut-inj { suc _} { i } { j } { k } i≢j i≢k p | inr ( ki , prfi ) | inl prfj | inl prfk =
+ j ≡⟨ sym prfj ⟩
+ fzero ≡⟨ prfk ⟩
+ k ∎
+punchOut-inj { suc _} { i } { j } { k } i≢j i≢k p | inr ( ki , prfi ) | inr ( kj , prfj ) | inr ( kk , prfk ) =
+ j ≡⟨ sym prfj ⟩
+ fsuc kj ≡⟨ cong fsuc lemma4 ⟩
+ fsuc kk ≡⟨ prfk ⟩
+ k ∎
+ where
+ lemma1 = λ q → i≢j ( i ≡⟨ sym prfi ⟩ fsuc ki ≡⟨ cong fsuc q ⟩ fsuc kj ≡⟨ prfj ⟩ j ∎ )
+ lemma2 = λ q → i≢k ( i ≡⟨ sym prfi ⟩ fsuc ki ≡⟨ cong fsuc q ⟩ fsuc kk ≡⟨ prfk ⟩ k ∎ )
+ lemma3 = fsuc-inj p
+ lemma4 = punchOut-inj lemma1 lemma2 lemma3
+punchOut-inj { suc m } { i } { j } { k } i≢j i≢k p | inr ( ki , prfi ) | inl prfj | inr ( kk , prfk ) =
+ Empty.rec ( fznotfs p )
+punchOut-inj { suc _} { i } { j } { k } i≢j i≢k p | inr ( ki , prfi ) | inr ( kj , prfj ) | inl prfk =
+ Empty.rec ( fznotfs ( sym p ))
+
+pigeonhole-special
+ : ∀ { n }
+ → ( f : Fin ( suc n ) → Fin n )
+ → Σ[ i ∈ Fin ( suc n ) ] Σ[ j ∈ Fin ( suc n ) ] ( ¬ i ≡ j ) × ( f i ≡ f j )
+pigeonhole-special { zero } f = Empty.rec ( ¬Fin0 ( f fzero ))
+pigeonhole-special { suc n } f =
+ proof ( any?
+ (λ ( i : Fin ( suc n )) →
+ discreteFin ( f ( inject< ≤-refl i )) ( f ( suc n , ≤-refl ))
+ ))
+ where
+ proof
+ : Dec ( Σ ( Fin ( suc n )) (λ z → f ( inject< ≤-refl z ) ≡ f ( suc n , ≤-refl )))
+ → Σ[ i ∈ Fin ( suc ( suc n )) ] Σ[ j ∈ Fin ( suc ( suc n )) ] ( ¬ i ≡ j ) × ( f i ≡ f j )
+ proof ( yes ( i , prf )) = inject< ≤-refl i , ( suc n , ≤-refl ) , inject<-ne i , prf
+ proof ( no h ) =
+ let
+ g : Fin ( suc n ) → Fin n
+ g k = punchOut
+ { i = f ( suc n , ≤-refl )}
+ { j = f ( inject< ≤-refl k )}
+ (λ p → h ( k , Fin-fst-≡ ( sym ( cong fst p ))))
+ i , j , i≢j , p = pigeonhole-special g
+ in
+ inject< ≤-refl i
+ , inject< ≤-refl j
+ , (λ q → i≢j ( Fin-fst-≡ ( cong fst q )))
+ , punchOut-inj
+ { i = f ( suc n , ≤-refl )}
+ { j = f ( inject< ≤-refl i )}
+ { k = f ( inject< ≤-refl j )}
+ (λ q → h ( i , Fin-fst-≡ ( sym ( cong fst q ))))
+ (λ q → h ( j , Fin-fst-≡ ( sym ( cong fst q ))))
+ ( Fin-fst-≡ ( cong fst p ))
+
+pigeonhole
+ : ∀ { m n }
+ → m < n
+ → ( f : Fin n → Fin m )
+ → Σ[ i ∈ Fin n ] Σ[ j ∈ Fin n ] ( ¬ i ≡ j ) × ( f i ≡ f j )
+pigeonhole { m } { n } ( zero , sm≡n ) f =
+ transport transport-prf ( pigeonhole-special f′ )
+ where
+ f′ : Fin ( suc m ) → Fin m
+ f′ = subst (λ h → Fin h → Fin m ) ( sym sm≡n ) f
+
+ f′≡f : PathP (λ i → Fin ( sm≡n i ) → Fin m ) f′ f
+ f′≡f i = transport-fillerExt ( cong (λ h → Fin h → Fin m ) ( sym sm≡n )) ( ~ i ) f
+
+ transport-prf
+ : ( Σ[ i ∈ Fin ( suc m ) ] Σ[ j ∈ Fin ( suc m ) ] ( ¬ i ≡ j ) × ( f′ i ≡ f′ j ))
+ ≡ ( Σ[ i ∈ Fin n ] Σ[ j ∈ Fin n ] ( ¬ i ≡ j ) × ( f i ≡ f j ))
+ transport-prf φ =
+ Σ[ i ∈ Fin ( sm≡n φ ) ] Σ[ j ∈ Fin ( sm≡n φ ) ]
+ ( ¬ i ≡ j ) × ( f′≡f φ i ≡ f′≡f φ j )
+pigeonhole { m } { n } ( suc k , prf ) f =
+ let
+ g : Fin ( suc n′ ) → Fin n′
+ g k = fst ( f′ k ) , <-trans ( snd ( f′ k )) m<n′
+ i , j , ¬q , r = pigeonhole-special g
+ in transport transport-prf ( i , j , ¬q , Σ≡Prop (λ _ → isProp≤ ) ( cong fst r ))
+ where
+ n′ : ℕ
+ n′ = k + suc m
+
+ n≡sn′ : n ≡ suc n′
+ n≡sn′ =
+ n ≡⟨ sym prf ⟩
+ suc ( k + suc m ) ≡⟨ refl ⟩
+ suc n′ ∎
+
+ m<n′ : m < n′
+ m<n′ = k , injSuc ( suc ( k + suc m ) ≡⟨ prf ⟩ n ≡⟨ n≡sn′ ⟩ suc n′ ∎ )
+
+ f′ : Fin ( suc n′ ) → Fin m
+ f′ = subst (λ h → Fin h → Fin m ) n≡sn′ f
+
+ f′≡f : PathP (λ i → Fin ( n≡sn′ ( ~ i )) → Fin m ) f′ f
+ f′≡f i = transport-fillerExt ( cong (λ h → Fin h → Fin m ) n≡sn′ ) ( ~ i ) f
+
+ transport-prf
+ : ( Σ[ i ∈ Fin ( suc n′ ) ] Σ[ j ∈ Fin ( suc n′ ) ] ( ¬ i ≡ j ) × ( f′ i ≡ f′ j ))
+ ≡ ( Σ[ i ∈ Fin n ] Σ[ j ∈ Fin n ] ( ¬ i ≡ j ) × ( f i ≡ f j ))
+ transport-prf φ =
+ Σ[ i ∈ Fin ( n≡sn′ ( ~ φ )) ] Σ[ j ∈ Fin ( n≡sn′ ( ~ φ )) ]
+ ( ¬ i ≡ j ) × ( f′≡f φ i ≡ f′≡f φ j )
+
+Fin-inj′ : { n m : ℕ } → n < m → ¬ Fin m ≡ Fin n
+Fin-inj′ n<m p =
+ let
+ i , j , i≢j , q = pigeonhole n<m ( transport p )
+ in i≢j (
+ i ≡⟨ refl ⟩
+ fst ( pigeonhole n<m ( transport p )) ≡⟨ transport-p-inj { p = p } q ⟩
+ fst ( snd ( pigeonhole n<m ( transport p ))) ≡⟨ refl ⟩
+ j ∎
+ )
+ where
+ transport-p-inj
+ : ∀ { A B : Type ℓ } { x y : A } { p : A ≡ B }
+ → transport p x ≡ transport p y
+ → x ≡ y
+ transport-p-inj { x = x } { y = y } { p = p } q =
+ x ≡⟨ sym ( transport⁻Transport p x ) ⟩
+ transport ( sym p ) ( transport p x ) ≡⟨ cong ( transport ( sym p )) q ⟩
+ transport ( sym p ) ( transport p y ) ≡⟨ transport⁻Transport p y ⟩
+ y ∎
+
+Fin-inj : ( n m : ℕ ) → Fin n ≡ Fin m → n ≡ m
+Fin-inj n m p with n ≟ m
+... | eq prf = prf
+... | lt n<m = Empty.rec ( Fin-inj′ n<m ( sym p ))
+... | gt n>m = Empty.rec ( Fin-inj′ n>m p )
+
+≤-·sk-cancel : ∀ { m } { k } { n } → m · suc k ≤ n · suc k → m ≤ n
+≤-·sk-cancel { m } { k } { n } ( d , p ) = o , inj-·sm { m = k } goal where
+ r = d % suc k
+ o = d / suc k
+ resn·k : Residue ( suc k ) ( n · suc k )
+ resn·k = (( r , n%sk<sk d k ) , ( o + m )) , reason where
+ reason = expand× (( r , n%sk<sk d k ) , o + m ) ≡⟨ expand≡ ( suc k ) r ( o + m ) ⟩
+ ( o + m ) · suc k + r ≡[ i ]⟨ +-comm ( ·-distribʳ o m ( suc k ) ( ~ i )) r i ⟩
+ r + ( o · suc k + m · suc k ) ≡⟨ +-assoc r ( o · suc k ) ( m · suc k ) ⟩
+ ( r + o · suc k ) + m · suc k ≡⟨ cong ( _+ m · suc k ) ( +-comm r ( o · suc k ) ∙ moddiv d ( suc k )) ⟩
+ d + m · suc k ≡⟨ p ⟩
+ n · suc k ∎
+
+ residuek·n : ∀ k n → ( r : Residue ( suc k ) ( n · suc k )) → (( fzero , n ) , expand≡ ( suc k ) 0 n ∙ +-zero _) ≡ r
+ residuek·n _ _ = isContr→isProp isContrResidue _
+
+ r≡0 : r ≡ 0
+ r≡0 = cong ( toℕ ∘ extract ) ( sym ( residuek·n k n resn·k ))
+ d≡o·sk : d ≡ o · suc k
+ d≡o·sk = sym ( moddiv d ( suc k )) ∙∙ cong ( o · suc k +_ ) r≡0 ∙∙ +-zero _
+ goal : ( o + m ) · suc k ≡ n · suc k
+ goal = sym ( ·-distribʳ o m ( suc k )) ∙∙ cong ( _+ m · suc k ) ( sym d≡o·sk ) ∙∙ p
+
+<-·sk-cancel : ∀ { m } { k } { n } → m · suc k < n · suc k → m < n
+<-·sk-cancel { m } { k } { n } p = goal where
+ ≤-helper : m ≤ n
+ ≤-helper = ≤-·sk-cancel ( pred-≤-pred ( <≤-trans p ( ≤-suc ≤-refl )))
+ goal : m < n
+ goal = case <-split ( suc-≤-suc ≤-helper ) of λ
+ { ( inl g ) → g
+ ; ( inr e ) → Empty.rec ( ¬m<m ( subst (λ m → m · suc k < n · suc k ) e p ))
+ }
+
+factorEquiv : ∀ { n } { m } → Fin n × Fin m ≃ Fin ( n · m )
+factorEquiv { zero } { m } = uninhabEquiv ( ¬Fin0 ∘ fst ) ¬Fin0
+factorEquiv { suc n } { m } = intro , isEmbedding×isSurjection→isEquiv ( isEmbeddingIntro , isSurjectionIntro ) where
+ intro : Fin ( suc n ) × Fin m → Fin ( suc n · m )
+ intro ( nn , mm ) = nm , subst (λ nm₁ → nm₁ < suc n · m ) ( sym ( expand≡ _ ( toℕ nn ) ( toℕ mm ))) nm<n·m where
+ nm : ℕ
+ nm = expand× ( nn , toℕ mm )
+ nm<n·m : toℕ mm · suc n + toℕ nn < suc n · m
+ nm<n·m =
+ toℕ mm · suc n + toℕ nn <≤⟨ <-k+ ( snd nn ) ⟩
+ toℕ mm · suc n + suc n ≡≤⟨ +-comm _ ( suc n ) ⟩
+ suc ( toℕ mm ) · suc n ≤≡⟨ ≤-·k ( snd mm ) ⟩
+ m · suc n ≡⟨ ·-comm _ ( suc n ) ⟩
+ suc n · m ∎ where open <-Reasoning
+
+ intro-injective : ∀ { o } { p } → intro o ≡ intro p → o ≡ p
+ intro-injective { o } { p } io≡ip = λ i → io′≡ip′ i . fst , toℕ-injective { fj = snd o } { fk = snd p } ( cong snd io′≡ip′ ) i where
+ io′≡ip′ : ( fst o , toℕ ( snd o )) ≡ ( fst p , toℕ ( snd p ))
+ io′≡ip′ = expand×Inj _ ( cong fst io≡ip )
+ isEmbeddingIntro : isEmbedding intro
+ isEmbeddingIntro = injEmbedding isSetFin intro-injective
+
+ elimF : ∀ nm → fiber intro nm
+ elimF nm = (( nn , nn<n ) , ( mm , mm<m )) , toℕ-injective ( reduce n ( toℕ nm ) . snd ) where
+ mm = toℕ nm / suc n
+ nn = toℕ nm % suc n
+
+ nmmoddiv : mm · suc n + nn ≡ toℕ nm
+ nmmoddiv = moddiv _ ( suc n )
+ nn<n : nn < suc n
+ nn<n = n%sk<sk ( toℕ nm ) _
+
+ nmsnd : mm · suc n + nn < suc n · m
+ nmsnd = subst (λ l → l < suc n · m ) ( sym nmmoddiv ) ( snd nm )
+ mm·sn<m·sn : mm · suc n < m · suc n
+ mm·sn<m·sn =
+ mm · suc n ≤<⟨ nn , +-comm nn ( mm · suc n ) ⟩
+ mm · suc n + nn <≡⟨ nmsnd ⟩
+ suc n · m ≡⟨ ·-comm ( suc n ) m ⟩
+ m · suc n ∎ where open <-Reasoning
+ mm<m : mm < m
+ mm<m = <-·sk-cancel mm·sn<m·sn
+
+ isSurjectionIntro : isSurjection intro
+ isSurjectionIntro = ∣_∣₁ ∘ elimF
+
+
+
+
+o<m→o<m+n : ( m n o : ℕ ) → o < m → o < ( m + n )
+o<m→o<m+n m n o ( k , p ) = ( n + k ) , ( n + k + suc o ≡⟨ sym ( +-assoc n k _) ⟩
+ n + ( k + suc o ) ≡⟨ cong (λ - → n + - ) p ⟩
+ n + m ≡⟨ +-comm n m ⟩
+ m + n ∎ )
+
+∸-<-lemma : ( m n o : ℕ ) → o < m + n → m ≤ o → o ∸ m < n
+∸-<-lemma zero n o o<m+n m<o = o<m+n
+∸-<-lemma ( suc m ) n zero o<m+n m<o = Empty.rec ( ¬-<-zero m<o )
+∸-<-lemma ( suc m ) n ( suc o ) o<m+n m<o =
+ ∸-<-lemma m n o ( pred-≤-pred o<m+n ) ( pred-≤-pred m<o )
+
+
+
+_≤?_ : ( m n : ℕ ) → ( m < n ) ⊎ ( n ≤ m )
+_≤?_ m n with m ≟ n
+_≤?_ m n | lt m<n = inl m<n
+_≤?_ m n | eq m=n = inr ( subst (λ - → - ≤ m ) m=n ≤-refl )
+_≤?_ m n | gt n<m = inr ( <-weaken n<m )
+
+¬-<-and-≥ : { m n : ℕ } → m < n → ¬ n ≤ m
+¬-<-and-≥ { m } { zero } m<n n≤m = ¬-<-zero m<n
+¬-<-and-≥ { zero } { suc n } m<n n≤m = ¬-<-zero n≤m
+¬-<-and-≥ { suc m } { suc n } m<n n≤m = ¬-<-and-≥ ( pred-≤-pred m<n ) ( pred-≤-pred n≤m )
+
+m+n∸n=m : ( n m : ℕ ) → ( m + n ) ∸ n ≡ m
+m+n∸n=m zero k = +-zero k
+m+n∸n=m ( suc m ) k = ( k + suc m ) ∸ suc m ≡⟨ cong (λ - → - ∸ suc m ) ( +-suc k m ) ⟩
+ suc ( k + m ) ∸ ( suc m ) ≡⟨ refl ⟩
+ ( k + m ) ∸ m ≡⟨ m+n∸n=m m k ⟩
+ k ∎
+
+∸-lemma : { m n : ℕ } → m ≤ n → m + ( n ∸ m ) ≡ n
+∸-lemma { zero } { k } _ = refl { x = k }
+∸-lemma { suc m } { zero } m≤k = Empty.rec ( ¬-<-and-≥ ( suc-≤-suc zero-≤ ) m≤k )
+∸-lemma { suc m } { suc k } m≤k =
+ suc m + ( suc k ∸ suc m ) ≡⟨ refl ⟩
+ suc ( m + ( suc k ∸ suc m )) ≡⟨ refl ⟩
+ suc ( m + ( k ∸ m )) ≡⟨ cong suc ( ∸-lemma ( pred-≤-pred m≤k )) ⟩
+ suc k ∎
+
+Fin+≅Fin⊎Fin : ( m n : ℕ ) → Iso ( Fin ( m + n )) ( Fin m ⊎ Fin n )
+Iso.fun ( Fin+≅Fin⊎Fin m n ) = f
+ where
+ f : Fin ( m + n ) → Fin m ⊎ Fin n
+ f ( k , k<m+n ) with k ≤? m
+ f ( k , k<m+n ) | inl k<m = inl ( k , k<m )
+ f ( k , k<m+n ) | inr k≥m = inr ( k ∸ m , ∸-<-lemma m n k k<m+n k≥m )
+Iso.inv ( Fin+≅Fin⊎Fin m n ) = g
+ where
+ g : Fin m ⊎ Fin n → Fin ( m + n )
+ g ( inl ( k , k<m )) = k , o<m→o<m+n m n k k<m
+ g ( inr ( k , k<n )) = m + k , <-k+ k<n
+Iso.rightInv ( Fin+≅Fin⊎Fin m n ) = sec-f-g
+ where
+ sec-f-g : _
+ sec-f-g ( inl ( k , k<m )) with k ≤? m
+ sec-f-g ( inl ( k , k<m )) | inl _ = cong inl ( Σ≡Prop (λ _ → isProp≤ ) refl )
+ sec-f-g ( inl ( k , k<m )) | inr m≤k = Empty.rec ( ¬-<-and-≥ k<m m≤k )
+ sec-f-g ( inr ( k , k<n )) with ( m + k ) ≤? m
+ sec-f-g ( inr ( k , k<n )) | inl p = Empty.rec ( ¬m+n<m { m } { k } p )
+ sec-f-g ( inr ( k , k<n )) | inr k≥m = cong inr ( Σ≡Prop (λ _ → isProp≤ ) rem )
+ where
+ rem : ( m + k ) ∸ m ≡ k
+ rem = subst (λ - → - ∸ m ≡ k ) ( +-comm k m ) ( m+n∸n=m m k )
+Iso.leftInv ( Fin+≅Fin⊎Fin m n ) = ret-f-g
+ where
+ ret-f-g : _
+ ret-f-g ( k , k<m+n ) with k ≤? m
+ ret-f-g ( k , k<m+n ) | inl _ = Σ≡Prop (λ _ → isProp≤ ) refl
+ ret-f-g ( k , k<m+n ) | inr m≥k = Σ≡Prop (λ _ → isProp≤ ) ( ∸-lemma m≥k )
+
+Fin+≡Fin⊎Fin : ( m n : ℕ ) → Fin ( m + n ) ≡ Fin m ⊎ Fin n
+Fin+≡Fin⊎Fin m n = isoToPath ( Fin+≅Fin⊎Fin m n )
+
+
+
+sucFin : { N : ℕ } → Fin N → Fin ( suc N )
+sucFin ( k , n , p ) = suc k , n , ( +-suc _ _ ∙ cong suc p )
+
+FinData→Fin : ( N : ℕ ) → FinData N → Fin N
+FinData→Fin zero ()
+FinData→Fin ( suc N ) zero = 0 , suc-≤-suc zero-≤
+FinData→Fin ( suc N ) ( suc k ) = sucFin ( FinData→Fin N k )
+
+Fin→FinData : ( N : ℕ ) → Fin N → FinData N
+Fin→FinData zero ( k , n , p ) = Empty.rec ( snotz ( sym ( +-suc n k ) ∙ p ))
+Fin→FinData ( suc N ) ( 0 , n , p ) = zero
+Fin→FinData ( suc N ) (( suc k ) , n , p ) = suc ( Fin→FinData N ( k , n , p' )) where
+ p' : n + suc k ≡ N
+ p' = injSuc ( sym ( +-suc n ( suc k )) ∙ p )
+
+secFin : ( n : ℕ ) → section ( FinData→Fin n ) ( Fin→FinData n )
+secFin 0 ( k , n , p ) = Empty.rec ( snotz ( sym ( +-suc n k ) ∙ p ))
+secFin ( suc N ) ( 0 , n , p ) = Fin-fst-≡ refl
+secFin ( suc N ) ( suc k , n , p ) = Fin-fst-≡ ( cong suc ( cong fst ( secFin N ( k , n , p' )))) where
+ p' : n + suc k ≡ N
+ p' = injSuc ( sym ( +-suc n ( suc k )) ∙ p )
+
+retFin : ( n : ℕ ) → retract ( FinData→Fin n ) ( Fin→FinData n )
+retFin 0 ()
+retFin ( suc N ) zero = refl
+retFin ( suc N ) ( suc k ) = cong FinData.suc ( cong ( Fin→FinData N ) ( Fin-fst-≡ refl ) ∙ retFin N k )
+
+FinDataIsoFin : ( N : ℕ ) → Iso ( FinData N ) ( Fin N )
+Iso.fun ( FinDataIsoFin N ) = FinData→Fin N
+Iso.inv ( FinDataIsoFin N ) = Fin→FinData N
+Iso.rightInv ( FinDataIsoFin N ) = secFin N
+Iso.leftInv ( FinDataIsoFin N ) = retFin N
+
+FinData≃Fin : ( N : ℕ ) → FinData N ≃ Fin N
+FinData≃Fin N = isoToEquiv ( FinDataIsoFin N )
+
+FinData≡Fin : ( N : ℕ ) → FinData N ≡ Fin N
+FinData≡Fin N = ua ( FinData≃Fin N )
+
+
+
+DecFin : ( n : ℕ ) → Dec ( Fin n )
+DecFin 0 = no ¬Fin0
+DecFin ( suc n ) = yes fzero
+
+
+
+Dec∥Fin∥ : ( n : ℕ ) → Dec ∥ Fin n ∥₁
+Dec∥Fin∥ n = Dec∥∥ ( DecFin n )
+
+
+
+Fin>0→isInhab : ( n : ℕ ) → 0 < n → Fin n
+Fin>0→isInhab 0 p = Empty.rec ( ¬-<-zero p )
+Fin>0→isInhab ( suc n ) p = fzero
+
+Fin>1→hasNonEqualTerm : ( n : ℕ ) → 1 < n → Σ[ i ∈ Fin n ] Σ[ j ∈ Fin n ] ¬ i ≡ j
+Fin>1→hasNonEqualTerm 0 p = Empty.rec ( snotz ( ≤0→≡0 p ))
+Fin>1→hasNonEqualTerm 1 p = Empty.rec ( snotz ( ≤0→≡0 ( pred-≤-pred p )))
+Fin>1→hasNonEqualTerm ( suc ( suc n )) _ = fzero , fone , fzero≠fone
+
+isEmpty→Fin≡0 : ( n : ℕ ) → ¬ Fin n → 0 ≡ n
+isEmpty→Fin≡0 0 _ = refl
+isEmpty→Fin≡0 ( suc n ) p = Empty.rec ( p fzero )
+
+isInhab→Fin>0 : ( n : ℕ ) → Fin n → 0 < n
+isInhab→Fin>0 0 i = Empty.rec ( ¬Fin0 i )
+isInhab→Fin>0 ( suc n ) _ = suc-≤-suc zero-≤
+
+hasNonEqualTerm→Fin>1 : ( n : ℕ ) → ( i j : Fin n ) → ¬ i ≡ j → 1 < n
+hasNonEqualTerm→Fin>1 0 i _ _ = Empty.rec ( ¬Fin0 i )
+hasNonEqualTerm→Fin>1 1 i j p = Empty.rec ( p ( isContr→isProp isContrFin1 i j ))
+hasNonEqualTerm→Fin>1 ( suc ( suc n )) _ _ _ = suc-≤-suc ( suc-≤-suc zero-≤ )
+
+Fin≤1→isProp : ( n : ℕ ) → n ≤ 1 → isProp ( Fin n )
+Fin≤1→isProp 0 _ = isPropFin0
+Fin≤1→isProp 1 _ = isContr→isProp isContrFin1
+Fin≤1→isProp ( suc ( suc n )) p = Empty.rec ( ¬-<-zero ( pred-≤-pred p ))
+
+isProp→Fin≤1 : ( n : ℕ ) → isProp ( Fin n ) → n ≤ 1
+isProp→Fin≤1 0 _ = ≤-solver 0 1
+isProp→Fin≤1 1 _ = ≤-solver 1 1
+isProp→Fin≤1 ( suc ( suc n )) p = Empty.rec ( fzero≠fone ( p fzero fone ))
+Cubical.Data.Fin {-# OPTIONS --safe #-}
+
+module Cubical.Data.Fin where
+
+open import Cubical.Data.Fin.Base public
+open import Cubical.Data.Fin.Properties public
+open import Cubical.Data.Fin.Literals public
+Cubical.Data.FinData.Properties
+{-# OPTIONS --safe #-}
+module Cubical.Data.FinData.Properties where
+
+
+
+
+open import Cubical.Foundations.Function
+open import Cubical.Foundations.Prelude
+open import Cubical.Foundations.Transport
+open import Cubical.Foundations.Isomorphism
+open import Cubical.Foundations.Equiv
+open import Cubical.Foundations.Powerset
+open import Cubical.Foundations.Isomorphism
+
+open import Cubical.Data.Sum
+open import Cubical.Data.Sigma
+open import Cubical.Data.FinData.Base as Fin
+open import Cubical.Data.Nat renaming ( zero to ℕzero ; suc to ℕsuc
+ ; znots to ℕznots ; snotz to ℕsnotz )
+open import Cubical.Data.Nat.Order
+open import Cubical.Data.Empty as ⊥
+open import Cubical.Data.Maybe
+
+open import Cubical.Relation.Nullary
+
+open import Cubical.Structures.Pointed
+
+private
+ variable
+ ℓ ℓ' : Level
+ A : Type ℓ
+ m n k : ℕ
+
+toℕ<n : ∀ { n } ( i : Fin n ) → toℕ i < n
+toℕ<n { n = ℕsuc n } zero = n , +-comm n 1
+toℕ<n { n = ℕsuc n } ( suc i ) = toℕ<n i . fst , +-suc _ _ ∙ cong ℕsuc ( toℕ<n i . snd )
+
+znots : ∀{ k } { m : Fin k } → ¬ ( zero ≡ ( suc m ))
+znots { k } { m } x = subst ( Fin.rec ( Fin k ) ⊥ ) x m
+
+znotsP : ∀ { k0 k1 : ℕ } { k : k0 ≡ k1 } { m1 : Fin k1 }
+ → ¬ PathP (λ i → Fin ( ℕsuc ( k i ))) zero ( suc m1 )
+znotsP p = ℕznots ( congP (λ i → toℕ ) p )
+
+snotz : ∀{ k } { m : Fin k } → ¬ (( suc m ) ≡ zero )
+snotz { k } { m } x = subst ( Fin.rec ⊥ ( Fin k )) x m
+
+snotzP : ∀ { k0 k1 : ℕ } { k : k0 ≡ k1 } { m0 : Fin k0 }
+ → ¬ PathP (λ i → Fin ( ℕsuc ( k i ))) ( suc m0 ) zero
+snotzP p = ℕsnotz ( congP (λ i → toℕ ) p )
+
+
+fromℕ' : ( n : ℕ ) → ( k : ℕ ) → ( k < n ) → Fin n
+fromℕ' ℕzero k infkn = ⊥.rec ( ¬-<-zero infkn )
+fromℕ' ( ℕsuc n ) ℕzero infkn = zero
+fromℕ' ( ℕsuc n ) ( ℕsuc k ) infkn = suc ( fromℕ' n k ( pred-≤-pred infkn ))
+
+toFromId' : ( n : ℕ ) → ( k : ℕ ) → ( infkn : k < n ) → toℕ ( fromℕ' n k infkn ) ≡ k
+toFromId' ℕzero k infkn = ⊥.rec ( ¬-<-zero infkn )
+toFromId' ( ℕsuc n ) ℕzero infkn = refl
+toFromId' ( ℕsuc n ) ( ℕsuc k ) infkn = cong ℕsuc ( toFromId' n k ( pred-≤-pred infkn ))
+
+fromToId' : ( n : ℕ ) → ( k : Fin n ) → ( r : toℕ k < n ) → fromℕ' n ( toℕ k ) r ≡ k
+fromToId' ( ℕsuc n ) zero r = refl
+fromToId' ( ℕsuc n ) ( suc k ) r = cong suc ( fromToId' n k ( pred-≤-pred r ))
+
+inj-toℕ : { n : ℕ } → { k l : Fin n } → ( toℕ k ≡ toℕ l ) → k ≡ l
+inj-toℕ { ℕsuc n } { zero } { zero } x = refl
+inj-toℕ { ℕsuc n } { zero } { suc l } x = ⊥.rec ( ℕznots x )
+inj-toℕ { ℕsuc n } { suc k } { zero } x = ⊥.rec ( ℕsnotz x )
+inj-toℕ { ℕsuc n } { suc k } { suc l } x = cong suc ( inj-toℕ ( injSuc x ))
+
+inj-cong : { n : ℕ } → { k l : Fin n } → ( p : toℕ k ≡ toℕ l ) → cong toℕ ( inj-toℕ p ) ≡ p
+inj-cong p = isSetℕ _ _ _ _
+
+isPropFin0 : isProp ( Fin 0 )
+isPropFin0 = ⊥.rec ∘ ¬Fin0
+
+isContrFin1 : isContr ( Fin 1 )
+isContrFin1 . fst = zero
+isContrFin1 . snd zero = refl
+
+injSucFin : ∀ { n } { p q : Fin n } → suc p ≡ suc q → p ≡ q
+injSucFin { ℕsuc ℕzero } { zero } { zero } pf = refl
+injSucFin { ℕsuc ( ℕsuc n )} pf = cong predFin pf
+
+injSucFinP : ∀ { n0 n1 : ℕ } { pn : n0 ≡ n1 } { p0 : Fin n0 } { p1 : Fin n1 }
+ → PathP (λ i → Fin ( ℕsuc ( pn i ))) ( suc p0 ) ( suc p1 )
+ → PathP (λ i → Fin ( pn i )) p0 p1
+injSucFinP { one } { one } { pn } { zero } { zero } sucp =
+ transport (λ j → PathP (λ i → Fin ( eqn j i )) zero zero ) refl
+ where eqn : refl ≡ pn
+ eqn = isSetℕ one one refl pn
+injSucFinP { one } { ℕsuc ( ℕsuc n1 )} { pn } { p0 } { p1 } sucp = ⊥.rec ( ℕznots ( injSuc pn ))
+injSucFinP { ℕsuc ( ℕsuc n0 )} { one } { pn } { p0 } { p1 } sucp = ⊥.rec ( ℕsnotz ( injSuc pn ))
+injSucFinP { ℕsuc ( ℕsuc n0 )} { ℕsuc ( ℕsuc n1 )} { pn } { p0 } { p1 } sucp =
+ transport (λ j → PathP (λ i → Fin ( eqn j i )) p0 p1 ) (
+ congP (λ i → predFin ) (
+ transport (λ j → PathP (λ i → Fin ( ℕsuc ( eqn ( ~ j ) i ))) ( suc p0 ) ( suc p1 )) sucp
+ )
+ )
+ where pn' : 2 + n0 ≡ 2 + n1
+ pn' = cong ℕsuc ( injSuc pn )
+ eqn : pn' ≡ pn
+ eqn = isSetℕ ( 2 + n0 ) ( 2 + n1 ) pn' pn
+
+discreteFin : ∀{ k } → Discrete ( Fin k )
+discreteFin zero zero = yes refl
+discreteFin zero ( suc y ) = no znots
+discreteFin ( suc x ) zero = no snotz
+discreteFin ( suc x ) ( suc y ) with discreteFin x y
+... | yes p = yes ( cong suc p )
+... | no ¬p = no (λ q → ¬p ( injSucFin q ))
+
+isSetFin : ∀{ k } → isSet ( Fin k )
+isSetFin = Discrete→isSet discreteFin
+
+isWeaken? : ∀ { n } ( p : Fin ( ℕsuc n )) → Dec ( Σ[ q ∈ Fin n ] p ≡ weakenFin q )
+isWeaken? { ℕzero } zero = no λ ( q , eqn ) → case q of λ ()
+isWeaken? { ℕsuc n } zero = yes ( zero , refl )
+isWeaken? { ℕsuc n } ( suc p ) with isWeaken? { n } p
+... | yes ( q , p≡wq ) = yes ( suc q , cong suc p≡wq )
+... | no p≢wq = no λ
+ { ( zero , sp≡wq ) → snotz sp≡wq
+ ; ( suc q , sp≡wq ) → p≢wq ( q , cong predFin sp≡wq )
+ }
+
+data biEq { n : ℕ } ( i j : Fin n ) : Type where
+ eq : i ≡ j → biEq i j
+ ¬eq : ¬ i ≡ j → biEq i j
+
+data triEq { n : ℕ } ( i j a : Fin n ) : Type where
+ leq : a ≡ i → triEq i j a
+ req : a ≡ j → triEq i j a
+ ¬eq : ( ¬ a ≡ i ) × ( ¬ a ≡ j ) → triEq i j a
+
+biEq? : ( i j : Fin n ) → biEq i j
+biEq? i j = case ( discreteFin i j ) return (λ _ → biEq i j )
+ of λ { ( yes p ) → eq p ; ( no ¬p ) → ¬eq ¬p }
+
+triEq? : ( i j a : Fin n ) → triEq i j a
+triEq? i j a =
+ case ( discreteFin a i ) return (λ _ → triEq i j a ) of
+ λ { ( yes p ) → leq p
+ ; ( no ¬p ) →
+ case ( discreteFin a j ) return (λ _ → triEq i j a ) of
+ λ { ( yes q ) → req q
+ ; ( no ¬q ) → ¬eq ( ¬p , ¬q ) }}
+
+
+weakenRespToℕ : ∀ { n } ( i : Fin n ) → toℕ ( weakenFin i ) ≡ toℕ i
+weakenRespToℕ zero = refl
+weakenRespToℕ ( suc i ) = cong ℕsuc ( weakenRespToℕ i )
+
+toFin : { n : ℕ } ( m : ℕ ) → m < n → Fin n
+toFin { n = ℕzero } _ m<0 = ⊥.rec ( ¬-<-zero m<0 )
+toFin { n = ℕsuc n } _ ( ℕzero , _) = fromℕ n
+toFin { n = ℕsuc n } m ( ℕsuc k , p ) = weakenFin ( toFin m ( k , cong predℕ p ))
+
+toFin0≡0 : { n : ℕ } ( p : 0 < ℕsuc n ) → toFin 0 p ≡ zero
+toFin0≡0 ( ℕzero , p ) = subst (λ x → fromℕ x ≡ zero ) ( cong predℕ p ) refl
+toFin0≡0 { ℕzero } ( ℕsuc k , p ) = ⊥.rec ( ℕsnotz ( +-comm 1 k ∙ ( cong predℕ p )))
+toFin0≡0 { ℕsuc n } ( ℕsuc k , p ) =
+ subst (λ x → weakenFin x ≡ zero ) ( sym ( toFin0≡0 ( k , cong predℕ p ))) refl
+
+genδ-FinVec : ( n k : ℕ ) → ( a b : A ) → FinVec A n
+genδ-FinVec ( ℕsuc n ) ℕzero a b zero = a
+genδ-FinVec ( ℕsuc n ) ℕzero a b ( suc x ) = b
+genδ-FinVec ( ℕsuc n ) ( ℕsuc k ) a b zero = b
+genδ-FinVec ( ℕsuc n ) ( ℕsuc k ) a b ( suc x ) = genδ-FinVec n k a b x
+
+δℕ-FinVec : ( n k : ℕ ) → FinVec ℕ n
+δℕ-FinVec n k = genδ-FinVec n k 1 0
+
+
+genδ-FinVec' : ( n k : ℕ ) → ( a b : A ) → FinVec A n
+genδ-FinVec' n k a b x with discreteℕ ( toℕ x ) k
+... | yes p = a
+... | no ¬p = b
+
+
+enum : ( m : ℕ ) → m < n → Fin n
+enum { n = ℕzero } _ m<0 = ⊥.rec ( ¬-<-zero m<0 )
+enum { n = ℕsuc n } 0 _ = zero
+enum { n = ℕsuc n } ( ℕsuc m ) p = suc ( enum m ( pred-≤-pred p ))
+
+enum∘toℕ : ( i : Fin n )( p : toℕ i < n ) → enum ( toℕ i ) p ≡ i
+enum∘toℕ { n = ℕsuc n } zero _ = refl
+enum∘toℕ { n = ℕsuc n } ( suc i ) p t = suc ( enum∘toℕ i ( pred-≤-pred p ) t )
+
+toℕ∘enum : ( m : ℕ )( p : m < n ) → toℕ ( enum m p ) ≡ m
+toℕ∘enum { n = ℕzero } _ m<0 = ⊥.rec ( ¬-<-zero m<0 )
+toℕ∘enum { n = ℕsuc n } 0 _ = refl
+toℕ∘enum { n = ℕsuc n } ( ℕsuc m ) p i = ℕsuc ( toℕ∘enum m ( pred-≤-pred p ) i )
+
+enumExt : { m m' : ℕ }( p : m < n )( p' : m' < n ) → m ≡ m' → enum m p ≡ enum m' p'
+enumExt p p' q i = enum ( q i ) ( isProp→PathP (λ i → isProp≤ { m = ℕsuc ( q i )}) p p' i )
+
+enumInj : ( p : m < k ) ( q : n < k ) → enum m p ≡ enum n q → m ≡ n
+enumInj p q path = sym ( toℕ∘enum _ p ) ∙ cong toℕ path ∙ toℕ∘enum _ q
+
+enumIndStep :
+ ( P : Fin n → Type ℓ )
+ → ( k : ℕ )( p : ℕsuc k < n )
+ → (( m : ℕ )( q : m < n )( q' : m ≤ k ) → P ( enum m q ))
+ → P ( enum ( ℕsuc k ) p )
+ → (( m : ℕ )( q : m < n )( q' : m ≤ ℕsuc k ) → P ( enum m q ))
+enumIndStep P k p f x m q q' =
+ case ( ≤-split q' ) return (λ _ → P ( enum m q )) of
+ λ { ( inl r' ) → f m q ( pred-≤-pred r' )
+ ; ( inr r' ) → subst P ( enumExt p q ( sym r' )) x }
+
+enumElim :
+ ( P : Fin n → Type ℓ )
+ → ( k : ℕ )( p : k < n )( h : ℕsuc k ≡ n )
+ → (( m : ℕ )( q : m < n )( q' : m ≤ k ) → P ( enum m q ))
+ → ( i : Fin n ) → P i
+enumElim P k p h f i =
+ subst P ( enum∘toℕ i ( toℕ<n i )) ( f ( toℕ i ) ( toℕ<n i )
+ ( pred-≤-pred ( subst (λ a → toℕ i < a ) ( sym h ) ( toℕ<n i ))))
+
+
+++FinAssoc : { n m k : ℕ } ( U : FinVec A n ) ( V : FinVec A m ) ( W : FinVec A k )
+ → PathP (λ i → FinVec A ( +-assoc n m k i )) ( U ++Fin ( V ++Fin W )) (( U ++Fin V ) ++Fin W )
+++FinAssoc { n = ℕzero } _ _ _ = refl
+++FinAssoc { n = ℕsuc n } U V W i zero = U zero
+++FinAssoc { n = ℕsuc n } U V W i ( suc ind ) = ++FinAssoc ( U ∘ suc ) V W i ind
+
+++FinRid : { n : ℕ } ( U : FinVec A n ) ( V : FinVec A 0 )
+ → PathP (λ i → FinVec A ( +-zero n i )) ( U ++Fin V ) U
+++FinRid { n = ℕzero } U V = funExt λ i → ⊥.rec ( ¬Fin0 i )
+++FinRid { n = ℕsuc n } U V i zero = U zero
+++FinRid { n = ℕsuc n } U V i ( suc ind ) = ++FinRid ( U ∘ suc ) V i ind
+
+++FinElim : { P : A → Type ℓ' } { n m : ℕ } ( U : FinVec A n ) ( V : FinVec A m )
+ → (∀ i → P ( U i )) → (∀ i → P ( V i )) → ∀ i → P (( U ++Fin V ) i )
+++FinElim { n = ℕzero } _ _ _ PVHyp i = PVHyp i
+++FinElim { n = ℕsuc n } _ _ PUHyp _ zero = PUHyp zero
+++FinElim { P = P } { n = ℕsuc n } U V PUHyp PVHyp ( suc i ) =
+ ++FinElim { P = P } ( U ∘ suc ) V (λ i → PUHyp ( suc i )) PVHyp i
+
+++FinPres∈ : { n m : ℕ } { α : FinVec A n } { β : FinVec A m } ( S : ℙ A )
+ → (∀ i → α i ∈ S ) → (∀ i → β i ∈ S ) → ∀ i → ( α ++Fin β ) i ∈ S
+++FinPres∈ { n = ℕzero } S hα hβ i = hβ i
+++FinPres∈ { n = ℕsuc n } S hα hβ zero = hα zero
+++FinPres∈ { n = ℕsuc n } S hα hβ ( suc i ) = ++FinPres∈ S ( hα ∘ suc ) hβ i
+
+
+
+
++Shuffle : ( m n : ℕ ) → Fin ( m + n ) → Fin ( n + m )
++Shuffle m n i with <Dec ( toℕ i ) m
+... | yes i<m = toFin ( n + ( toℕ i )) ( <-k+ i<m )
+... | no ¬i<m = toFin ( toℕ i ∸ m )
+ ( subst (λ x → toℕ i ∸ m < x ) ( +-comm m n ) ( ≤<-trans ( ∸-≤ ( toℕ i ) m ) ( toℕ<n i )))
+
+
+finSucMaybeIso : Iso ( Fin ( ℕ.suc n )) ( Maybe ( Fin n ))
+Iso.fun finSucMaybeIso zero = nothing
+Iso.fun finSucMaybeIso ( suc i ) = just i
+Iso.inv finSucMaybeIso nothing = zero
+Iso.inv finSucMaybeIso ( just i ) = suc i
+Iso.rightInv finSucMaybeIso nothing = refl
+Iso.rightInv finSucMaybeIso ( just i ) = refl
+Iso.leftInv finSucMaybeIso zero = refl
+Iso.leftInv finSucMaybeIso ( suc i ) = refl
+
+finSuc≡Maybe : Fin ( ℕ.suc n ) ≡ Maybe ( Fin n )
+finSuc≡Maybe = isoToPath finSucMaybeIso
+
+finSuc≡Maybe∙ : ( Fin ( ℕ.suc n ) , zero ) ≡ Maybe∙ ( Fin n )
+finSuc≡Maybe∙ = pointed-sip _ _ (( isoToEquiv finSucMaybeIso ) , refl )
+
+
+module FinSumChar where
+
+ fun : ( n m : ℕ ) → Fin n ⊎ Fin m → Fin ( n + m )
+ fun ℕzero m ( inr i ) = i
+ fun ( ℕsuc n ) m ( inl zero ) = zero
+ fun ( ℕsuc n ) m ( inl ( suc i )) = suc ( fun n m ( inl i ))
+ fun ( ℕsuc n ) m ( inr i ) = suc ( fun n m ( inr i ))
+
+ invSucAux : ( n m : ℕ ) → Fin n ⊎ Fin m → Fin ( ℕsuc n ) ⊎ Fin m
+ invSucAux n m ( inl i ) = inl ( suc i )
+ invSucAux n m ( inr i ) = inr i
+
+ inv : ( n m : ℕ ) → Fin ( n + m ) → Fin n ⊎ Fin m
+ inv ℕzero m i = inr i
+ inv ( ℕsuc n ) m zero = inl zero
+ inv ( ℕsuc n ) m ( suc i ) = invSucAux n m ( inv n m i )
+
+ ret : ( n m : ℕ ) ( i : Fin n ⊎ Fin m ) → inv n m ( fun n m i ) ≡ i
+ ret ℕzero m ( inr i ) = refl
+ ret ( ℕsuc n ) m ( inl zero ) = refl
+ ret ( ℕsuc n ) m ( inl ( suc i )) = subst (λ x → invSucAux n m x ≡ inl ( suc i ))
+ ( sym ( ret n m ( inl i ))) refl
+ ret ( ℕsuc n ) m ( inr i ) = subst (λ x → invSucAux n m x ≡ inr i ) ( sym ( ret n m ( inr i ))) refl
+
+ sec : ( n m : ℕ ) ( i : Fin ( n + m )) → fun n m ( inv n m i ) ≡ i
+ sec ℕzero m i = refl
+ sec ( ℕsuc n ) m zero = refl
+ sec ( ℕsuc n ) m ( suc i ) = helperPath ( inv n m i ) ∙ cong suc ( sec n m i )
+ where
+ helperPath : ∀ x → fun ( ℕsuc n ) m ( invSucAux n m x ) ≡ suc ( fun n m x )
+ helperPath ( inl _) = refl
+ helperPath ( inr _) = refl
+
+ Equiv : ( n m : ℕ ) → Fin n ⊎ Fin m ≃ Fin ( n + m )
+ Equiv n m = isoToEquiv ( iso ( fun n m ) ( inv n m ) ( sec n m ) ( ret n m ))
+
+ ++FinInl : ( n m : ℕ ) ( U : FinVec A n ) ( W : FinVec A m ) ( i : Fin n )
+ → U i ≡ ( U ++Fin W ) ( fun n m ( inl i ))
+ ++FinInl ( ℕsuc n ) m U W zero = refl
+ ++FinInl ( ℕsuc n ) m U W ( suc i ) = ++FinInl n m ( U ∘ suc ) W i
+
+ ++FinInr : ( n m : ℕ ) ( U : FinVec A n ) ( W : FinVec A m ) ( i : Fin m )
+ → W i ≡ ( U ++Fin W ) ( fun n m ( inr i ))
+ ++FinInr ℕzero ( ℕsuc m ) U W i = refl
+ ++FinInr ( ℕsuc n ) m U W i = ++FinInr n m ( U ∘ suc ) W i
+
+
+module FinProdChar where
+
+ open Iso
+ sucProdToSumIso : ( n m : ℕ ) → Iso ( Fin ( ℕsuc n ) × Fin m ) ( Fin m ⊎ ( Fin n × Fin m ))
+ fun ( sucProdToSumIso n m ) ( zero , j ) = inl j
+ fun ( sucProdToSumIso n m ) ( suc i , j ) = inr ( i , j )
+ inv ( sucProdToSumIso n m ) ( inl j ) = zero , j
+ inv ( sucProdToSumIso n m ) ( inr ( i , j )) = suc i , j
+ rightInv ( sucProdToSumIso n m ) ( inl j ) = refl
+ rightInv ( sucProdToSumIso n m ) ( inr ( i , j )) = refl
+ leftInv ( sucProdToSumIso n m ) ( zero , j ) = refl
+ leftInv ( sucProdToSumIso n m ) ( suc i , j ) = refl
+
+ Equiv : ( n m : ℕ ) → ( Fin n × Fin m ) ≃ Fin ( n · m )
+ Equiv ℕzero m = uninhabEquiv (λ x → ¬Fin0 ( fst x )) ¬Fin0
+ Equiv ( ℕsuc n ) m = Fin ( ℕsuc n ) × Fin m ≃⟨ isoToEquiv ( sucProdToSumIso n m ) ⟩
+ Fin m ⊎ ( Fin n × Fin m ) ≃⟨ isoToEquiv ( ⊎Iso idIso ( equivToIso ( Equiv n m ))) ⟩
+ Fin m ⊎ Fin ( n · m ) ≃⟨ FinSumChar.Equiv m ( n · m ) ⟩
+ Fin ( m + n · m ) ■
+
+
+
+∀Dec :
+ ( P : Fin m → Type ℓ )
+ → ( dec : ( i : Fin m ) → Dec ( P i ))
+ → (( i : Fin m ) → P i ) ⊎ ( Σ[ i ∈ Fin m ] ¬ P i )
+∀Dec { m = 0 } _ _ = inl λ ()
+∀Dec { m = ℕsuc m } P dec = helper ( dec zero ) ( ∀Dec _ ( dec ∘ suc ))
+ where
+ helper :
+ Dec ( P zero )
+ → (( i : Fin m ) → P ( suc i )) ⊎ ( Σ[ i ∈ Fin m ] ¬ P ( suc i ))
+ → (( i : Fin ( ℕsuc m )) → P i ) ⊎ ( Σ[ i ∈ Fin ( ℕsuc m ) ] ¬ P i )
+ helper ( yes p ) ( inl q ) = inl λ { zero → p ; ( suc i ) → q i }
+ helper ( yes _) ( inr q ) = inr ( suc ( q . fst ) , q . snd )
+ helper ( no ¬p ) _ = inr ( zero , ¬p )
+
+∀Dec2 :
+ ( P : Fin m → Fin n → Type ℓ )
+ → ( dec : ( i : Fin m )( j : Fin n ) → Dec ( P i j ))
+ → (( i : Fin m )( j : Fin n ) → P i j ) ⊎ ( Σ[ i ∈ Fin m ] Σ[ j ∈ Fin n ] ¬ P i j )
+∀Dec2 { m = 0 } { n = n } _ _ = inl λ ()
+∀Dec2 { m = ℕsuc m } { n = n } P dec = helper ( ∀Dec ( P zero ) ( dec zero )) ( ∀Dec2 ( P ∘ suc ) ( dec ∘ suc ))
+ where
+ helper :
+ (( j : Fin n ) → P zero j ) ⊎ ( Σ[ j ∈ Fin n ] ¬ P zero j )
+ → (( i : Fin m )( j : Fin n ) → P ( suc i ) j ) ⊎ ( Σ[ i ∈ Fin m ] Σ[ j ∈ Fin n ] ¬ P ( suc i ) j )
+ → (( i : Fin ( ℕsuc m ))( j : Fin n ) → P i j ) ⊎ ( Σ[ i ∈ Fin ( ℕsuc m ) ] Σ[ j ∈ Fin n ] ¬ P i j )
+ helper ( inl p ) ( inl q ) = inl λ { zero j → p j ; ( suc i ) j → q i j }
+ helper ( inl _) ( inr q ) = inr ( suc ( q . fst ) , q . snd . fst , q . snd . snd )
+ helper ( inr p ) _ = inr ( zero , p )
+
\ No newline at end of file
diff --git a/docs/Cubical.Data.FinData.html b/docs/Cubical.Data.FinData.html
new file mode 100644
index 0000000..a5cf723
--- /dev/null
+++ b/docs/Cubical.Data.FinData.html
@@ -0,0 +1,7 @@
+
+Cubical.Data.FinData {-# OPTIONS --safe #-}
+module Cubical.Data.FinData where
+
+open import Cubical.Data.FinData.Base public
+open import Cubical.Data.FinData.Properties public
+Cubical.Data.Maybe.Properties {-# OPTIONS --safe #-}
+module Cubical.Data.Maybe.Properties where
+
+open import Cubical.Foundations.Prelude
+open import Cubical.Foundations.HLevels
+open import Cubical.Foundations.Equiv
+open import Cubical.Foundations.Function using ( _∘_ ; idfun )
+open import Cubical.Foundations.Isomorphism
+open import Cubical.Foundations.Pointed.Base using ( Pointed ; _→∙_ ; pt )
+open import Cubical.Foundations.Structure using ( ⟨_⟩ )
+
+open import Cubical.Functions.Embedding using ( isEmbedding )
+
+open import Cubical.Data.Empty as ⊥ using ( ⊥ ; isProp⊥ )
+open import Cubical.Data.Unit
+open import Cubical.Data.Nat using ( suc )
+open import Cubical.Data.Sum using ( _⊎_ ; inl ; inr )
+open import Cubical.Data.Sigma using ( ΣPathP )
+
+open import Cubical.Relation.Nullary using ( ¬_ ; Discrete ; yes ; no )
+
+open import Cubical.Data.Maybe.Base as Maybe
+
+Maybe∙ : ∀ { ℓ } ( A : Type ℓ ) → Pointed ℓ
+Maybe∙ A . fst = Maybe A
+Maybe∙ A . snd = nothing
+
+
+
+module _ { ℓ } ( A : Type ℓ ) { ℓ' } ( B : Pointed ℓ' ) where
+
+ freelyPointedIso : Iso ( Maybe∙ A →∙ B ) ( A → ⟨ B ⟩ )
+ Iso.fun freelyPointedIso f∙ = fst f∙ ∘ just
+ Iso.inv freelyPointedIso f = Maybe.rec ( pt B ) f , refl
+ Iso.rightInv freelyPointedIso f = refl
+ Iso.leftInv freelyPointedIso f∙ =
+ ΣPathP
+ ( funExt ( Maybe.elim _ ( sym ( snd f∙ )) (λ a → refl ))
+ , λ i j → snd f∙ ( ~ i ∨ j ))
+
+map-Maybe-id : ∀ { ℓ } { A : Type ℓ } → ∀ m → map-Maybe ( idfun A ) m ≡ m
+map-Maybe-id nothing = refl
+map-Maybe-id ( just _) = refl
+
+
+module MaybePath { ℓ } { A : Type ℓ } where
+ Cover : Maybe A → Maybe A → Type ℓ
+ Cover nothing nothing = Lift Unit
+ Cover nothing ( just _) = Lift ⊥
+ Cover ( just _) nothing = Lift ⊥
+ Cover ( just a ) ( just a' ) = a ≡ a'
+
+ reflCode : ( c : Maybe A ) → Cover c c
+ reflCode nothing = lift tt
+ reflCode ( just b ) = refl
+
+ encode : ∀ c c' → c ≡ c' → Cover c c'
+ encode c _ = J (λ c' _ → Cover c c' ) ( reflCode c )
+
+ encodeRefl : ∀ c → encode c c refl ≡ reflCode c
+ encodeRefl c = JRefl (λ c' _ → Cover c c' ) ( reflCode c )
+
+ decode : ∀ c c' → Cover c c' → c ≡ c'
+ decode nothing nothing _ = refl
+ decode ( just _) ( just _) p = cong just p
+
+ decodeRefl : ∀ c → decode c c ( reflCode c ) ≡ refl
+ decodeRefl nothing = refl
+ decodeRefl ( just _) = refl
+
+ decodeEncode : ∀ c c' → ( p : c ≡ c' ) → decode c c' ( encode c c' p ) ≡ p
+ decodeEncode c _ =
+ J (λ c' p → decode c c' ( encode c c' p ) ≡ p )
+ ( cong ( decode c c ) ( encodeRefl c ) ∙ decodeRefl c )
+
+ encodeDecode : ∀ c c' → ( d : Cover c c' ) → encode c c' ( decode c c' d ) ≡ d
+ encodeDecode nothing nothing _ = refl
+ encodeDecode ( just a ) ( just a' ) =
+ J (λ a' p → encode ( just a ) ( just a' ) ( cong just p ) ≡ p ) ( encodeRefl ( just a ))
+
+ Cover≃Path : ∀ c c' → Cover c c' ≃ ( c ≡ c' )
+ Cover≃Path c c' = isoToEquiv
+ ( iso ( decode c c' ) ( encode c c' ) ( decodeEncode c c' ) ( encodeDecode c c' ))
+
+ Cover≡Path : ∀ c c' → Cover c c' ≡ ( c ≡ c' )
+ Cover≡Path c c' = isoToPath
+ ( iso ( decode c c' ) ( encode c c' ) ( decodeEncode c c' ) ( encodeDecode c c' ))
+
+ isOfHLevelCover : ( n : HLevel )
+ → isOfHLevel ( suc ( suc n )) A
+ → ∀ c c' → isOfHLevel ( suc n ) ( Cover c c' )
+ isOfHLevelCover n p nothing nothing = isOfHLevelLift ( suc n ) ( isOfHLevelUnit ( suc n ))
+ isOfHLevelCover n p nothing ( just a' ) = isOfHLevelLift ( suc n ) ( isProp→isOfHLevelSuc n isProp⊥ )
+ isOfHLevelCover n p ( just a ) nothing = isOfHLevelLift ( suc n ) ( isProp→isOfHLevelSuc n isProp⊥ )
+ isOfHLevelCover n p ( just a ) ( just a' ) = p a a'
+
+isOfHLevelMaybe : ∀ { ℓ } ( n : HLevel ) { A : Type ℓ }
+ → isOfHLevel ( suc ( suc n )) A
+ → isOfHLevel ( suc ( suc n )) ( Maybe A )
+isOfHLevelMaybe n lA c c' =
+ isOfHLevelRetract ( suc n )
+ ( MaybePath.encode c c' )
+ ( MaybePath.decode c c' )
+ ( MaybePath.decodeEncode c c' )
+ ( MaybePath.isOfHLevelCover n lA c c' )
+
+private
+ variable
+ ℓ : Level
+ A : Type ℓ
+
+fromJust-def : A → Maybe A → A
+fromJust-def a nothing = a
+fromJust-def _ ( just a ) = a
+
+just-inj : ( x y : A ) → just x ≡ just y → x ≡ y
+just-inj x _ eq = cong ( fromJust-def x ) eq
+
+isEmbedding-just : isEmbedding ( just { A = A })
+isEmbedding-just w z = MaybePath.Cover≃Path ( just w ) ( just z ) . snd
+
+¬nothing≡just : ∀ { x : A } → ¬ ( nothing ≡ just x )
+¬nothing≡just { A = A } { x = x } p = lower ( subst ( caseMaybe ( Maybe A ) ( Lift ⊥ )) p ( just x ))
+
+¬just≡nothing : ∀ { x : A } → ¬ ( just x ≡ nothing )
+¬just≡nothing { A = A } { x = x } p = lower ( subst ( caseMaybe ( Lift ⊥ ) ( Maybe A )) p ( just x ))
+
+isProp-x≡nothing : ( x : Maybe A ) → isProp ( x ≡ nothing )
+isProp-x≡nothing nothing x w =
+ subst isProp ( MaybePath.Cover≡Path nothing nothing ) ( isOfHLevelLift 1 isPropUnit ) x w
+isProp-x≡nothing ( just _) p _ = ⊥.rec ( ¬just≡nothing p )
+
+isProp-nothing≡x : ( x : Maybe A ) → isProp ( nothing ≡ x )
+isProp-nothing≡x nothing x w =
+ subst isProp ( MaybePath.Cover≡Path nothing nothing ) ( isOfHLevelLift 1 isPropUnit ) x w
+isProp-nothing≡x ( just _) p _ = ⊥.rec ( ¬nothing≡just p )
+
+isContr-nothing≡nothing : isContr ( nothing { A = A } ≡ nothing )
+isContr-nothing≡nothing = inhProp→isContr refl ( isProp-x≡nothing _)
+
+discreteMaybe : Discrete A → Discrete ( Maybe A )
+discreteMaybe eqA nothing nothing = yes refl
+discreteMaybe eqA nothing ( just a' ) = no ¬nothing≡just
+discreteMaybe eqA ( just a ) nothing = no ¬just≡nothing
+discreteMaybe eqA ( just a ) ( just a' ) with eqA a a'
+... | yes p = yes ( cong just p )
+... | no ¬p = no (λ p → ¬p ( just-inj _ _ p ))
+
+module SumUnit where
+ Maybe→SumUnit : Maybe A → Unit ⊎ A
+ Maybe→SumUnit nothing = inl tt
+ Maybe→SumUnit ( just a ) = inr a
+
+ SumUnit→Maybe : Unit ⊎ A → Maybe A
+ SumUnit→Maybe ( inl _) = nothing
+ SumUnit→Maybe ( inr a ) = just a
+
+ Maybe→SumUnit→Maybe : ( x : Maybe A ) → SumUnit→Maybe ( Maybe→SumUnit x ) ≡ x
+ Maybe→SumUnit→Maybe nothing = refl
+ Maybe→SumUnit→Maybe ( just _) = refl
+
+ SumUnit→Maybe→SumUnit : ( x : Unit ⊎ A ) → Maybe→SumUnit ( SumUnit→Maybe x ) ≡ x
+ SumUnit→Maybe→SumUnit ( inl _) = refl
+ SumUnit→Maybe→SumUnit ( inr _) = refl
+
+Maybe≡SumUnit : Maybe A ≡ Unit ⊎ A
+Maybe≡SumUnit = isoToPath ( iso Maybe→SumUnit SumUnit→Maybe SumUnit→Maybe→SumUnit Maybe→SumUnit→Maybe )
+ where open SumUnit
+
+congMaybeEquiv : ∀ { ℓ ℓ' } { A : Type ℓ } { B : Type ℓ' }
+ → A ≃ B → Maybe A ≃ Maybe B
+congMaybeEquiv e = isoToEquiv isom
+ where
+ open Iso
+ isom : Iso _ _
+ isom . fun = map-Maybe ( equivFun e )
+ isom . inv = map-Maybe ( invEq e )
+ isom . rightInv nothing = refl
+ isom . rightInv ( just b ) = cong just ( secEq e b )
+ isom . leftInv nothing = refl
+ isom . leftInv ( just a ) = cong just ( retEq e a )
+Cubical.Data.Maybe {-# OPTIONS --safe #-}
+module Cubical.Data.Maybe where
+
+open import Cubical.Data.Maybe.Base public
+open import Cubical.Data.Maybe.Properties public
+Cubical.Data.Nat.Order.Recursive {-# OPTIONS --safe #-}
+module Cubical.Data.Nat.Order.Recursive where
+
+open import Cubical.Foundations.Prelude
+open import Cubical.Foundations.Function
+open import Cubical.Foundations.HLevels
+open import Cubical.Foundations.Transport
+
+open import Cubical.Data.Empty as Empty
+open import Cubical.Data.Sigma
+open import Cubical.Data.Sum as Sum
+open import Cubical.Data.Unit
+
+open import Cubical.Data.Nat.Base
+open import Cubical.Data.Nat.Properties
+
+open import Cubical.Induction.WellFounded
+
+open import Cubical.Relation.Nullary
+
+infix 4 _≤_ _<_
+
+_≤_ : ℕ → ℕ → Type₀
+zero ≤ _ = Unit
+suc m ≤ zero = ⊥
+suc m ≤ suc n = m ≤ n
+
+_<_ : ℕ → ℕ → Type₀
+m < n = suc m ≤ n
+
+_≤?_ : ( m n : ℕ ) → Dec ( m ≤ n )
+zero ≤? _ = yes tt
+suc m ≤? zero = no λ ()
+suc m ≤? suc n = m ≤? n
+
+data Trichotomy ( m n : ℕ ) : Type₀ where
+ lt : m < n → Trichotomy m n
+ eq : m ≡ n → Trichotomy m n
+ gt : n < m → Trichotomy m n
+
+private
+ variable
+ ℓ : Level
+ R : Type ℓ
+ P : ℕ → Type ℓ
+ k l m n : ℕ
+
+isProp≤ : isProp ( m ≤ n )
+isProp≤ { zero } = isPropUnit
+isProp≤ { suc m } { zero } = isProp⊥
+isProp≤ { suc m } { suc n } = isProp≤ { m } { n }
+
+≤-k+ : m ≤ n → k + m ≤ k + n
+≤-k+ { k = zero } m≤n = m≤n
+≤-k+ { k = suc k } m≤n = ≤-k+ { k = k } m≤n
+
+≤-+k : m ≤ n → m + k ≤ n + k
+≤-+k { m } { n } { k } m≤n
+ = transport (λ i → +-comm k m i ≤ +-comm k n i ) ( ≤-k+ { m } { n } { k } m≤n )
+
+≤-refl : ∀ m → m ≤ m
+≤-refl zero = _
+≤-refl ( suc m ) = ≤-refl m
+
+≤-trans : k ≤ m → m ≤ n → k ≤ n
+≤-trans { zero } _ _ = _
+≤-trans { suc k } { suc m } { suc n } = ≤-trans { k } { m } { n }
+
+≤-antisym : m ≤ n → n ≤ m → m ≡ n
+≤-antisym { zero } { zero } _ _ = refl
+≤-antisym { suc m } { suc n } m≤n n≤m = cong suc ( ≤-antisym m≤n n≤m )
+
+≤-k+-cancel : k + m ≤ k + n → m ≤ n
+≤-k+-cancel { k = zero } m≤n = m≤n
+≤-k+-cancel { k = suc k } m≤n = ≤-k+-cancel { k } m≤n
+
+≤-+k-cancel : m + k ≤ n + k → m ≤ n
+≤-+k-cancel { m } { k } { n }
+ = ≤-k+-cancel { k } { m } { n } ∘ transport λ i → +-comm m k i ≤ +-comm n k i
+
+¬m<m : ¬ m < m
+¬m<m { suc m } = ¬m<m { m }
+
+≤0→≡0 : n ≤ 0 → n ≡ 0
+≤0→≡0 { zero } _ = refl
+
+¬m+n<m : ¬ m + n < m
+¬m+n<m { suc m } = ¬m+n<m { m }
+
+<-weaken : m < n → m ≤ n
+<-weaken { zero } _ = _
+<-weaken { suc m } { suc n } = <-weaken { m }
+
+<-trans : k < m → m < n → k < n
+<-trans { k } { m } { n } k<m m<n
+ = ≤-trans { suc k } { m } { n } k<m ( <-weaken { m } m<n )
+
+<-asym : m < n → ¬ n < m
+<-asym { m } m<n n<m = ¬m<m { m } ( <-trans { m } {_} { m } m<n n<m )
+
+<→≢ : n < m → ¬ n ≡ m
+<→≢ { n } { m } p q = ¬m<m { m = m } ( subst { x = n } ( _< m ) q p )
+
+Trichotomy-suc : Trichotomy m n → Trichotomy ( suc m ) ( suc n )
+Trichotomy-suc ( lt m<n ) = lt m<n
+Trichotomy-suc ( eq m≡n ) = eq ( cong suc m≡n )
+Trichotomy-suc ( gt n<m ) = gt n<m
+
+_≟_ : ∀ m n → Trichotomy m n
+zero ≟ zero = eq refl
+zero ≟ suc n = lt _
+suc m ≟ zero = gt _
+suc m ≟ suc n = Trichotomy-suc ( m ≟ n )
+
+k≤k+n : ∀ k → k ≤ k + n
+k≤k+n zero = _
+k≤k+n ( suc k ) = k≤k+n k
+
+n≤k+n : ∀ n → n ≤ k + n
+n≤k+n { k } n = transport (λ i → n ≤ +-comm n k i ) ( k≤k+n n )
+
+≤-split : m ≤ n → ( m < n ) ⊎ ( m ≡ n )
+≤-split { zero } { zero } m≤n = inr refl
+≤-split { zero } { suc n } m≤n = inl _
+≤-split { suc m } { suc n } m≤n
+ = Sum.map ( idfun _) ( cong suc ) ( ≤-split { m } { n } m≤n )
+
+module WellFounded where
+ wf-< : WellFounded _<_
+ wf-rec-< : ∀ n → WFRec _<_ ( Acc _<_ ) n
+
+ wf-< n = acc ( wf-rec-< n )
+
+ wf-rec-< ( suc n ) m m≤n with ≤-split { m } { n } m≤n
+ ... | inl m<n = wf-rec-< n m m<n
+ ... | inr m≡n = subst⁻ ( Acc _<_ ) m≡n ( wf-< n )
+
+wf-elim : (∀ n → (∀ m → m < n → P m ) → P n ) → ∀ n → P n
+wf-elim = WFI.induction WellFounded.wf-<
+
+wf-rec : (∀ n → (∀ m → m < n → R ) → R ) → ℕ → R
+wf-rec { R = R } = wf-elim { P = λ _ → R }
+
+module Minimal where
+ Least : ∀{ ℓ } → ( ℕ → Type ℓ ) → ( ℕ → Type ℓ )
+ Least P m = P m × (∀ n → n < m → ¬ P n )
+
+ isPropLeast : (∀ m → isProp ( P m )) → ∀ m → isProp ( Least P m )
+ isPropLeast pP m
+ = isPropΣ ( pP m ) (λ _ → isPropΠ3 λ _ _ _ → isProp⊥ )
+
+ Least→ : Σ _ ( Least P ) → Σ _ P
+ Least→ = map-snd fst
+
+ search
+ : (∀ m → Dec ( P m ))
+ → ∀ n → ( Σ[ m ∈ ℕ ] Least P m ) ⊎ (∀ m → m < n → ¬ P m )
+ search dec zero = inr (λ _ b _ → b )
+ search { P = P } dec ( suc n ) with search dec n
+ ... | inl tup = inl tup
+ ... | inr ¬P<n with dec n
+ ... | yes Pn = inl ( n , Pn , ¬P<n )
+ ... | no ¬Pn = inr λ m m≤n
+ → case ≤-split m≤n of λ where
+ ( inl m<n ) → ¬P<n m m<n
+ ( inr m≡n ) → subst⁻ ( ¬_ ∘ P ) m≡n ¬Pn
+
+ →Least : (∀ m → Dec ( P m )) → Σ _ P → Σ _ ( Least P )
+ →Least dec ( n , Pn ) with search dec n
+ ... | inl least = least
+ ... | inr ¬P<n = n , Pn , ¬P<n
+
+ Least-unique : ∀ m n → Least P m → Least P n → m ≡ n
+ Least-unique m n ( Pm , ¬P<m ) ( Pn , ¬P<n ) with m ≟ n
+ ... | lt m<n = Empty.rec ( ¬P<n m m<n Pm )
+ ... | eq m≡n = m≡n
+ ... | gt n<m = Empty.rec ( ¬P<m n n<m Pn )
+
+ isPropΣLeast : (∀ m → isProp ( P m )) → isProp ( Σ _ ( Least P ))
+ isPropΣLeast pP ( m , LPm ) ( n , LPn )
+ = ΣPathP λ where
+ . fst → Least-unique m n LPm LPn
+ . snd → isOfHLevel→isOfHLevelDep 1 ( isPropLeast pP )
+ LPm LPn ( Least-unique m n LPm LPn )
+
+ Decidable→Collapsible
+ : (∀ m → isProp ( P m )) → (∀ m → Dec ( P m )) → Collapsible ( Σ ℕ P )
+ Decidable→Collapsible pP dP = λ where
+ . fst → Least→ ∘ →Least dP
+ . snd x y → cong Least→ ( isPropΣLeast pP ( →Least dP x ) ( →Least dP y ))
+
+open Minimal using ( Decidable→Collapsible ) public
+Cubical.Data.Nat.Order {-# OPTIONS --no-exact-split --safe #-}
+module Cubical.Data.Nat.Order where
+
+open import Cubical.Foundations.Prelude
+open import Cubical.Foundations.Function
+open import Cubical.Foundations.HLevels
+
+
+open import Cubical.Data.Empty as ⊥
+open import Cubical.Data.Sigma
+open import Cubical.Data.Sum as ⊎
+
+open import Cubical.Data.Nat.Base
+open import Cubical.Data.Nat.Properties
+
+open import Cubical.Induction.WellFounded
+
+open import Cubical.Relation.Nullary
+
+private
+ variable
+ ℓ : Level
+
+infix 4 _≤_ _<_ _≥_ _>_
+
+_≤_ : ℕ → ℕ → Type₀
+m ≤ n = Σ[ k ∈ ℕ ] k + m ≡ n
+
+_<_ : ℕ → ℕ → Type₀
+m < n = suc m ≤ n
+
+_≥_ : ℕ → ℕ → Type₀
+m ≥ n = n ≤ m
+
+_>_ : ℕ → ℕ → Type₀
+m > n = n < m
+
+data Trichotomy ( m n : ℕ ) : Type₀ where
+ lt : m < n → Trichotomy m n
+ eq : m ≡ n → Trichotomy m n
+ gt : n < m → Trichotomy m n
+
+private
+ variable
+ k l m n : ℕ
+
+private
+ witness-prop : ∀ j → isProp ( j + m ≡ n )
+ witness-prop { m } { n } j = isSetℕ ( j + m ) n
+
+isProp≤ : isProp ( m ≤ n )
+isProp≤ { m } { n } ( k , p ) ( l , q )
+ = Σ≡Prop witness-prop lemma
+ where
+ lemma : k ≡ l
+ lemma = inj-+m ( p ∙ ( sym q ))
+
+zero-≤ : 0 ≤ n
+zero-≤ { n } = n , +-zero n
+
+suc-≤-suc : m ≤ n → suc m ≤ suc n
+suc-≤-suc ( k , p ) = k , ( +-suc k _) ∙ ( cong suc p )
+
+≤-+k : m ≤ n → m + k ≤ n + k
+≤-+k { m } { k = k } ( i , p )
+ = i , +-assoc i m k ∙ cong ( _+ k ) p
+
+≤SumRight : n ≤ k + n
+≤SumRight { n } { k } = ≤-+k zero-≤
+
+≤-k+ : m ≤ n → k + m ≤ k + n
+≤-k+ { m } { n } { k }
+ = subst ( _≤ k + n ) ( +-comm m k )
+ ∘ subst ( m + k ≤_ ) ( +-comm n k )
+ ∘ ≤-+k
+
+≤SumLeft : n ≤ n + k
+≤SumLeft { n } { k } = subst ( n ≤_ ) ( +-comm k n ) ( ≤-+k zero-≤ )
+
+pred-≤-pred : suc m ≤ suc n → m ≤ n
+pred-≤-pred ( k , p ) = k , injSuc (( sym ( +-suc k _)) ∙ p )
+
+≤-refl : m ≤ m
+≤-refl = 0 , refl
+
+≤-suc : m ≤ n → m ≤ suc n
+≤-suc ( k , p ) = suc k , cong suc p
+
+suc-< : suc m < n → m < n
+suc-< p = pred-≤-pred ( ≤-suc p )
+
+≤-sucℕ : n ≤ suc n
+≤-sucℕ = ≤-suc ≤-refl
+
+≤-predℕ : predℕ n ≤ n
+≤-predℕ { zero } = ≤-refl
+≤-predℕ { suc n } = ≤-suc ≤-refl
+
+≤-trans : k ≤ m → m ≤ n → k ≤ n
+≤-trans { k } { m } { n } ( i , p ) ( j , q ) = i + j , l2 ∙ ( l1 ∙ q )
+ where
+ l1 : j + i + k ≡ j + m
+ l1 = ( sym ( +-assoc j i k )) ∙ ( cong ( j +_ ) p )
+ l2 : i + j + k ≡ j + i + k
+ l2 = cong ( _+ k ) ( +-comm i j )
+
+≤-antisym : m ≤ n → n ≤ m → m ≡ n
+≤-antisym { m } ( i , p ) ( j , q ) = ( cong ( _+ m ) l3 ) ∙ p
+ where
+ l1 : j + i + m ≡ m
+ l1 = ( sym ( +-assoc j i m )) ∙ (( cong ( j +_ ) p ) ∙ q )
+ l2 : j + i ≡ 0
+ l2 = m+n≡n→m≡0 l1
+ l3 : 0 ≡ i
+ l3 = sym ( snd ( m+n≡0→m≡0×n≡0 l2 ))
+
+≤-+-≤ : m ≤ n → l ≤ k → m + l ≤ n + k
+≤-+-≤ p q = ≤-trans ( ≤-+k p ) ( ≤-k+ q )
+
+≤-k+-cancel : k + m ≤ k + n → m ≤ n
+≤-k+-cancel { k } { m } ( l , p ) = l , inj-m+ ( sub k m ∙ p )
+ where
+ sub : ∀ k m → k + ( l + m ) ≡ l + ( k + m )
+ sub k m = +-assoc k l m ∙ cong ( _+ m ) ( +-comm k l ) ∙ sym ( +-assoc l k m )
+
+≤-+k-cancel : m + k ≤ n + k → m ≤ n
+≤-+k-cancel { m } { k } { n } ( l , p ) = l , cancelled
+ where
+ cancelled : l + m ≡ n
+ cancelled = inj-+m ( sym ( +-assoc l m k ) ∙ p )
+
+≤-+k-trans : ( m + k ≤ n ) → m ≤ n
+≤-+k-trans { m } { k } { n } p = ≤-trans ( k , +-comm k m ) p
+
+≤-k+-trans : ( k + m ≤ n ) → m ≤ n
+≤-k+-trans { m } { k } { n } p = ≤-trans ( m , refl ) p
+
+≤-·k : m ≤ n → m · k ≤ n · k
+≤-·k { m } { n } { k } ( d , r ) = d · k , reason where
+ reason : d · k + m · k ≡ n · k
+ reason = d · k + m · k ≡⟨ ·-distribʳ d m k ⟩
+ ( d + m ) · k ≡⟨ cong ( _· k ) r ⟩
+ n · k ∎
+
+<-k+-cancel : k + m < k + n → m < n
+<-k+-cancel { k } { m } { n } = ≤-k+-cancel ∘ subst ( _≤ k + n ) ( sym ( +-suc k m ))
+
+¬-<-zero : ¬ m < 0
+¬-<-zero ( k , p ) = snotz (( sym ( +-suc k _)) ∙ p )
+
+¬m<m : ¬ m < m
+¬m<m { m } = ¬-<-zero ∘ ≤-+k-cancel { k = m }
+
+≤0→≡0 : n ≤ 0 → n ≡ 0
+≤0→≡0 { zero } ineq = refl
+≤0→≡0 { suc n } ineq = ⊥.rec ( ¬-<-zero ineq )
+
+predℕ-≤-predℕ : m ≤ n → ( predℕ m ) ≤ ( predℕ n )
+predℕ-≤-predℕ { zero } { zero } ineq = ≤-refl
+predℕ-≤-predℕ { zero } { suc n } ineq = zero-≤
+predℕ-≤-predℕ { suc m } { zero } ineq = ⊥.rec ( ¬-<-zero ineq )
+predℕ-≤-predℕ { suc m } { suc n } ineq = pred-≤-pred ineq
+
+¬m+n<m : ¬ m + n < m
+¬m+n<m { m } { n } = ¬-<-zero ∘ <-k+-cancel ∘ subst ( m + n <_ ) ( sym ( +-zero m ))
+
+<-weaken : m < n → m ≤ n
+<-weaken ( k , p ) = suc k , sym ( +-suc k _) ∙ p
+
+≤<-trans : l ≤ m → m < n → l < n
+≤<-trans p = ≤-trans ( suc-≤-suc p )
+
+<≤-trans : l < m → m ≤ n → l < n
+<≤-trans = ≤-trans
+
+<-trans : l < m → m < n → l < n
+<-trans p = ≤<-trans ( <-weaken p )
+
+<-asym : m < n → ¬ n ≤ m
+<-asym m<n = ¬m<m ∘ <≤-trans m<n
+
+<-+k : m < n → m + k < n + k
+<-+k p = ≤-+k p
+
+<-k+ : m < n → k + m < k + n
+<-k+ { m } { n } { k } p = subst (λ km → km ≤ k + n ) ( +-suc k m ) ( ≤-k+ p )
+
+<-+k-trans : ( m + k < n ) → m < n
+<-+k-trans { m } { k } { n } p = ≤<-trans ( k , +-comm k m ) p
+
+<-k+-trans : ( k + m < n ) → m < n
+<-k+-trans { m } { k } { n } p = ≤<-trans ( m , refl ) p
+
+<-+-< : m < n → k < l → m + k < n + l
+<-+-< m<n k<l = <-trans ( <-+k m<n ) ( <-k+ k<l )
+
+<-+-≤ : m < n → k ≤ l → m + k < n + l
+<-+-≤ p q = <≤-trans ( <-+k p ) ( ≤-k+ q )
+
+<-·sk : m < n → m · suc k < n · suc k
+<-·sk { m } { n } { k } ( d , r ) = ( d · suc k + k ) , reason where
+ reason : ( d · suc k + k ) + suc ( m · suc k ) ≡ n · suc k
+ reason = ( d · suc k + k ) + suc ( m · suc k ) ≡⟨ sym ( +-assoc ( d · suc k ) k _) ⟩
+ d · suc k + ( k + suc ( m · suc k )) ≡[ i ]⟨ d · suc k + +-suc k ( m · suc k ) i ⟩
+ d · suc k + suc m · suc k ≡⟨ ·-distribʳ d ( suc m ) ( suc k ) ⟩
+ ( d + suc m ) · suc k ≡⟨ cong ( _· suc k ) r ⟩
+ n · suc k ∎
+
+∸-≤ : ∀ m n → m ∸ n ≤ m
+∸-≤ m zero = ≤-refl
+∸-≤ zero ( suc n ) = ≤-refl
+∸-≤ ( suc m ) ( suc n ) = ≤-trans ( ∸-≤ m n ) ( 1 , refl )
+
+≤-∸-+-cancel : m ≤ n → ( n ∸ m ) + m ≡ n
+≤-∸-+-cancel { zero } { n } _ = +-zero _
+≤-∸-+-cancel { suc m } { zero } m≤n = ⊥.rec ( ¬-<-zero m≤n )
+≤-∸-+-cancel { suc m } { suc n } m+1≤n+1 = +-suc _ _ ∙ cong suc ( ≤-∸-+-cancel ( pred-≤-pred m+1≤n+1 ))
+
+≤-∸-suc : m ≤ n → suc ( n ∸ m ) ≡ suc n ∸ m
+≤-∸-suc { zero } { n } m≤n = refl
+≤-∸-suc { suc m } { zero } m≤n = ⊥.rec ( ¬-<-zero m≤n )
+≤-∸-suc { suc m } { suc n } m+1≤n+1 = ≤-∸-suc ( pred-≤-pred m+1≤n+1 )
+
+≤-∸-k : m ≤ n → k + ( n ∸ m ) ≡ ( k + n ) ∸ m
+≤-∸-k { m } { n } { zero } r = refl
+≤-∸-k { m } { n } { suc k } r = cong suc ( ≤-∸-k r ) ∙ ≤-∸-suc ( ≤-trans r ( k , refl ))
+
+left-≤-max : m ≤ max m n
+left-≤-max { zero } { n } = zero-≤
+left-≤-max { suc m } { zero } = ≤-refl
+left-≤-max { suc m } { suc n } = suc-≤-suc left-≤-max
+
+right-≤-max : n ≤ max m n
+right-≤-max { zero } { m } = zero-≤
+right-≤-max { suc n } { zero } = ≤-refl
+right-≤-max { suc n } { suc m } = suc-≤-suc right-≤-max
+
+min-≤-left : min m n ≤ m
+min-≤-left { zero } { n } = ≤-refl
+min-≤-left { suc m } { zero } = zero-≤
+min-≤-left { suc m } { suc n } = suc-≤-suc min-≤-left
+
+min-≤-right : min m n ≤ n
+min-≤-right { zero } { n } = zero-≤
+min-≤-right { suc m } { zero } = ≤-refl
+min-≤-right { suc m } { suc n } = suc-≤-suc min-≤-right
+
+≤Dec : ∀ m n → Dec ( m ≤ n )
+≤Dec zero n = yes ( n , +-zero _)
+≤Dec ( suc m ) zero = no ¬-<-zero
+≤Dec ( suc m ) ( suc n ) with ≤Dec m n
+... | yes m≤n = yes ( suc-≤-suc m≤n )
+... | no m≰n = no λ m+1≤n+1 → m≰n ( pred-≤-pred m+1≤n+1 )
+
+≤Stable : ∀ m n → Stable ( m ≤ n )
+≤Stable m n = Dec→Stable ( ≤Dec m n )
+
+<Dec : ∀ m n → Dec ( m < n )
+<Dec m n = ≤Dec ( suc m ) n
+
+<Stable : ∀ m n → Stable ( m < n )
+<Stable m n = Dec→Stable ( <Dec m n )
+
+Trichotomy-suc : Trichotomy m n → Trichotomy ( suc m ) ( suc n )
+Trichotomy-suc ( lt m<n ) = lt ( suc-≤-suc m<n )
+Trichotomy-suc ( eq m=n ) = eq ( cong suc m=n )
+Trichotomy-suc ( gt n<m ) = gt ( suc-≤-suc n<m )
+
+_≟_ : ∀ m n → Trichotomy m n
+zero ≟ zero = eq refl
+zero ≟ suc n = lt ( n , +-comm n 1 )
+suc m ≟ zero = gt ( m , +-comm m 1 )
+suc m ≟ suc n = Trichotomy-suc ( m ≟ n )
+
+splitℕ-≤ : ( m n : ℕ ) → ( m ≤ n ) ⊎ ( n < m )
+splitℕ-≤ m n with m ≟ n
+... | lt x = inl ( <-weaken x )
+... | eq x = inl ( 0 , x )
+... | gt x = inr x
+
+splitℕ-< : ( m n : ℕ ) → ( m < n ) ⊎ ( n ≤ m )
+splitℕ-< m n with m ≟ n
+... | lt x = inl x
+... | eq x = inr ( 0 , ( sym x ))
+... | gt x = inr ( <-weaken x )
+
+≤CaseInduction : { P : ℕ → ℕ → Type ℓ } { n m : ℕ }
+ → ( n ≤ m → P n m ) → ( m ≤ n → P n m )
+ → P n m
+≤CaseInduction { n = n } { m = m } p q with n ≟ m
+... | lt x = p ( <-weaken x )
+... | eq x = p ( subst ( n ≤_ ) x ≤-refl )
+... | gt x = q ( <-weaken x )
+
+<-split : m < suc n → ( m < n ) ⊎ ( m ≡ n )
+<-split { n = zero } = inr ∘ snd ∘ m+n≡0→m≡0×n≡0 ∘ snd ∘ pred-≤-pred
+<-split { zero } { suc n } = λ _ → inl ( suc-≤-suc zero-≤ )
+<-split { suc m } { suc n } = ⊎.map suc-≤-suc ( cong suc ) ∘ <-split ∘ pred-≤-pred
+
+≤-split : m ≤ n → ( m < n ) ⊎ ( m ≡ n )
+≤-split p = <-split ( suc-≤-suc p )
+
+≤→< : m ≤ n → ¬ m ≡ n → m < n
+≤→< p q =
+ case ( ≤-split p ) of
+ λ { ( inl r ) → r
+ ; ( inr r ) → ⊥.rec ( q r ) }
+
+≤-suc-≢ : m ≤ suc n → ( m ≡ suc n → ⊥ ) → m ≤ n
+≤-suc-≢ p ¬q = pred-≤-pred ( ≤→< p ¬q )
+
+≤-+-split : ∀ n m k → k ≤ n + m → ( n ≤ k ) ⊎ ( m ≤ ( n + m ) ∸ k )
+≤-+-split n m k k≤n+m with n ≟ k
+... | eq p = inl ( 0 , p )
+... | lt n<k = inl ( <-weaken n<k )
+... | gt k<n with m ≟ (( n + m ) ∸ k )
+... | eq p = inr ( 0 , p )
+... | lt m<n+m∸k = inr ( <-weaken m<n+m∸k )
+... | gt n+m∸k<m =
+ ⊥.rec ( ¬m<m ( transport (λ i → ≤-∸-+-cancel k≤n+m i < +-comm m n i ) ( <-+-< n+m∸k<m k<n )))
+
+<-asym'-case : Trichotomy m n → ¬ m < n → n ≤ m
+<-asym'-case ( lt p ) q = ⊥.rec ( q p )
+<-asym'-case ( eq p ) _ = _ , sym p
+<-asym'-case ( gt p ) _ = <-weaken p
+
+<-asym' : ¬ m < n → n ≤ m
+<-asym' = <-asym'-case ( _≟_ _ _)
+
+private
+ acc-suc : Acc _<_ n → Acc _<_ ( suc n )
+ acc-suc a
+ = acc λ y y<sn
+ → case <-split y<sn of λ
+ { ( inl y<n ) → access a y y<n
+ ; ( inr y≡n ) → subst _ ( sym y≡n ) a
+ }
+
+<-wellfounded : WellFounded _<_
+<-wellfounded zero = acc λ _ → ⊥.rec ∘ ¬-<-zero
+<-wellfounded ( suc n ) = acc-suc ( <-wellfounded n )
+
+<→≢ : n < m → ¬ n ≡ m
+<→≢ { n } { m } p q = ¬m<m ( subst ( _< m ) q p )
+
+module _
+ ( b₀ : ℕ )
+ ( P : ℕ → Type₀ )
+ ( base : ∀ n → n < suc b₀ → P n )
+ ( step : ∀ n → P n → P ( suc b₀ + n ))
+ where
+ open WFI ( <-wellfounded )
+
+ private
+ dichotomy : ∀ b n → ( n < b ) ⊎ ( Σ[ m ∈ ℕ ] n ≡ b + m )
+ dichotomy b n
+ = case n ≟ b return (λ _ → ( n < b ) ⊎ ( Σ[ m ∈ ℕ ] n ≡ b + m )) of λ
+ { ( lt o ) → inl o
+ ; ( eq p ) → inr ( 0 , p ∙ sym ( +-zero b ))
+ ; ( gt ( m , p )) → inr ( suc m , sym p ∙ +-suc m b ∙ +-comm ( suc m ) b )
+ }
+
+ dichotomy<≡ : ∀ b n → ( n<b : n < b ) → dichotomy b n ≡ inl n<b
+ dichotomy<≡ b n n<b
+ = case dichotomy b n return (λ d → d ≡ inl n<b ) of λ
+ { ( inl x ) → cong inl ( isProp≤ x n<b )
+ ; ( inr ( m , p )) → ⊥.rec ( <-asym n<b ( m , sym ( p ∙ +-comm b m )))
+ }
+
+ dichotomy+≡ : ∀ b m n → ( p : n ≡ b + m ) → dichotomy b n ≡ inr ( m , p )
+ dichotomy+≡ b m n p
+ = case dichotomy b n return (λ d → d ≡ inr ( m , p )) of λ
+ { ( inl n<b ) → ⊥.rec ( <-asym n<b ( m , +-comm m b ∙ sym p ))
+ ; ( inr ( m' , q ))
+ → cong inr ( Σ≡Prop (λ x → isSetℕ n ( b + x )) ( inj-m+ { m = b } ( sym q ∙ p )))
+ }
+
+ b = suc b₀
+
+ lemma₁ : ∀{ x y z } → x ≡ suc z + y → y < x
+ lemma₁ { y = y } { z } p = z , +-suc z y ∙ sym p
+
+ subStep : ( n : ℕ ) → (∀ m → m < n → P m ) → ( n < b ) ⊎ ( Σ[ m ∈ ℕ ] n ≡ b + m ) → P n
+ subStep n _ ( inl l ) = base n l
+ subStep n rec ( inr ( m , p ))
+ = transport ( cong P ( sym p )) ( step m ( rec m ( lemma₁ p )))
+
+ wfStep : ( n : ℕ ) → (∀ m → m < n → P m ) → P n
+ wfStep n rec = subStep n rec ( dichotomy b n )
+
+ wfStepLemma₀ : ∀ n ( n<b : n < b ) rec → wfStep n rec ≡ base n n<b
+ wfStepLemma₀ n n<b rec = cong ( subStep n rec ) ( dichotomy<≡ b n n<b )
+
+ wfStepLemma₁ : ∀ n rec → wfStep ( b + n ) rec ≡ step n ( rec n ( lemma₁ refl ))
+ wfStepLemma₁ n rec
+ = cong ( subStep ( b + n ) rec ) ( dichotomy+≡ b n ( b + n ) refl )
+ ∙ transportRefl _
+
+ +induction : ∀ n → P n
+ +induction = induction wfStep
+
+ +inductionBase : ∀ n → ( l : n < b ) → +induction n ≡ base n l
+ +inductionBase n l = induction-compute wfStep n ∙ wfStepLemma₀ n l _
+
+ +inductionStep : ∀ n → +induction ( b + n ) ≡ step n ( +induction n )
+ +inductionStep n = induction-compute wfStep ( b + n ) ∙ wfStepLemma₁ n _
+
+module <-Reasoning where
+
+ infixr 2 _<⟨_⟩_ _≤<⟨_⟩_ _≤⟨_⟩_ _<≤⟨_⟩_ _≡<⟨_⟩_ _≡≤⟨_⟩_ _<≡⟨_⟩_ _≤≡⟨_⟩_
+ _<⟨_⟩_ : ∀ k → k < n → n < m → k < m
+ _ <⟨ p ⟩ q = <-trans p q
+
+ _≤<⟨_⟩_ : ∀ k → k ≤ n → n < m → k < m
+ _ ≤<⟨ p ⟩ q = ≤<-trans p q
+
+ _≤⟨_⟩_ : ∀ k → k ≤ n → n ≤ m → k ≤ m
+ _ ≤⟨ p ⟩ q = ≤-trans p q
+
+ _<≤⟨_⟩_ : ∀ k → k < n → n ≤ m → k < m
+ _ <≤⟨ p ⟩ q = <≤-trans p q
+
+ _≡≤⟨_⟩_ : ∀ k → k ≡ l → l ≤ m → k ≤ m
+ _ ≡≤⟨ p ⟩ q = subst (λ k → k ≤ _) ( sym p ) q
+
+ _≡<⟨_⟩_ : ∀ k → k ≡ l → l < m → k < m
+ _ ≡<⟨ p ⟩ q = _ ≡≤⟨ cong suc p ⟩ q
+
+ _≤≡⟨_⟩_ : ∀ k → k ≤ l → l ≡ m → k ≤ m
+ _ ≤≡⟨ p ⟩ q = subst (λ l → _ ≤ l ) q p
+
+ _<≡⟨_⟩_ : ∀ k → k < l → l ≡ m → k < m
+ _ <≡⟨ p ⟩ q = _ ≤≡⟨ p ⟩ q
+
+
+
+suc∸-fst : ( n m : ℕ ) → m < n → suc ( n ∸ m ) ≡ ( suc n ) ∸ m
+suc∸-fst zero zero p = refl
+suc∸-fst zero ( suc m ) p = ⊥.rec ( ¬-<-zero p )
+suc∸-fst ( suc n ) zero p = refl
+suc∸-fst ( suc n ) ( suc m ) p = ( suc∸-fst n m ( pred-≤-pred p ))
+
+n∸m≡0 : ( n m : ℕ ) → n ≤ m → ( n ∸ m ) ≡ 0
+n∸m≡0 zero zero p = refl
+n∸m≡0 ( suc n ) zero p = ⊥.rec ( ¬-<-zero p )
+n∸m≡0 zero ( suc m ) p = refl
+n∸m≡0 ( suc n ) ( suc m ) p = n∸m≡0 n m ( pred-≤-pred p )
+
+n∸n≡0 : ( n : ℕ ) → n ∸ n ≡ 0
+n∸n≡0 zero = refl
+n∸n≡0 ( suc n ) = n∸n≡0 n
+
+n∸l>0 : ( n l : ℕ ) → ( l < n ) → 0 < ( n ∸ l )
+n∸l>0 zero zero r = ⊥.rec ( ¬-<-zero r )
+n∸l>0 zero ( suc l ) r = ⊥.rec ( ¬-<-zero r )
+n∸l>0 ( suc n ) zero r = suc-≤-suc zero-≤
+n∸l>0 ( suc n ) ( suc l ) r = n∸l>0 n l ( pred-≤-pred r )
+
+
+
+≤-solver-type : ( m n : ℕ ) → Trichotomy m n → Type
+≤-solver-type m n ( lt p ) = m ≤ n
+≤-solver-type m n ( eq p ) = m ≤ n
+≤-solver-type m n ( gt p ) = n < m
+
+≤-solver-case : ( m n : ℕ ) → ( p : Trichotomy m n ) → ≤-solver-type m n p
+≤-solver-case m n ( lt p ) = <-weaken p
+≤-solver-case m n ( eq p ) = _ , p
+≤-solver-case m n ( gt p ) = p
+
+≤-solver : ( m n : ℕ ) → ≤-solver-type m n ( m ≟ n )
+≤-solver m n = ≤-solver-case m n ( m ≟ n )
+
+
+
+
+data _≤'_ : ℕ → ℕ → Type where
+ z≤ : ∀ { n } → zero ≤' n
+ s≤s : ∀ { m n } → m ≤' n → suc m ≤' suc n
+
+_<'_ : ℕ → ℕ → Type
+m <' n = suc m ≤' n
+
+
+pattern z<s { n } = s≤s ( z≤ { n })
+pattern s<s { m } { n } m<n = s≤s { m } { n } m<n
+
+¬-<'-zero : ¬ m <' 0
+¬-<'-zero { zero } ()
+¬-<'-zero { suc m } ()
+
+≤'Dec : ∀ m n → Dec ( m ≤' n )
+≤'Dec zero n = yes z≤
+≤'Dec ( suc m ) zero = no ¬-<'-zero
+≤'Dec ( suc m ) ( suc n ) with ≤'Dec m n
+... | yes m≤'n = yes ( s≤s m≤'n )
+... | no m≰'n = no λ { ( s≤s m≤'n ) → m≰'n m≤'n }
+
+≤'IsPropValued : ∀ m n → isProp ( m ≤' n )
+≤'IsPropValued zero n z≤ z≤ = refl
+≤'IsPropValued ( suc m ) zero ()
+≤'IsPropValued ( suc m ) ( suc n ) ( s≤s x ) ( s≤s y ) = cong s≤s ( ≤'IsPropValued m n x y )
+
+≤-∸-≤ : ∀ m n l → m ≤ n → m ∸ l ≤ n ∸ l
+≤-∸-≤ m n zero r = r
+≤-∸-≤ zero zero ( suc l ) r = ≤-refl
+≤-∸-≤ zero ( suc n ) ( suc l ) r = ( n ∸ l ) , ( +-zero _)
+≤-∸-≤ ( suc m ) zero ( suc l ) r = ⊥.rec ( ¬-<-zero r )
+≤-∸-≤ ( suc m ) ( suc n ) ( suc l ) r = ≤-∸-≤ m n l ( pred-≤-pred r )
+
+<-∸-< : ∀ m n l → m < n → l < n → m ∸ l < n ∸ l
+<-∸-< m n zero r q = r
+<-∸-< zero zero ( suc l ) r q = ⊥.rec ( ¬-<-zero r )
+<-∸-< zero ( suc n ) ( suc l ) r q = n∸l>0 ( suc n ) ( suc l ) q
+<-∸-< ( suc m ) zero ( suc l ) r q = ⊥.rec ( ¬-<-zero r )
+<-∸-< ( suc m ) ( suc n ) ( suc l ) r q = <-∸-< m n l ( pred-≤-pred r ) ( pred-≤-pred q )
+
+≤-∸-≥ : ∀ n l k → l ≤ k → n ∸ k ≤ n ∸ l
+≤-∸-≥ n zero zero r = ≤-refl
+≤-∸-≥ n zero ( suc k ) r = ∸-≤ n ( suc k )
+≤-∸-≥ n ( suc l ) zero r = ⊥.rec ( ¬-<-zero r )
+≤-∸-≥ zero ( suc l ) ( suc k ) r = ≤-refl
+≤-∸-≥ ( suc n ) ( suc l ) ( suc k ) r = ≤-∸-≥ n l k ( pred-≤-pred r )
+Cubical.Data.Prod.Base {-# OPTIONS --safe #-}
+module Cubical.Data.Prod.Base where
+
+open import Cubical.Core.Everything
+
+open import Cubical.Foundations.Prelude
+open import Cubical.Foundations.Function
+
+
+
+
+
+
+
+
+
+
+
+
+
+private
+ variable
+ ℓ ℓ' : Level
+
+data _×_ ( A : Type ℓ ) ( B : Type ℓ' ) : Type ( ℓ-max ℓ ℓ' ) where
+ _,_ : A → B → A × B
+
+infixr 5 _×_
+
+proj₁ : { A : Type ℓ } { B : Type ℓ' } → A × B → A
+proj₁ ( x , _) = x
+
+proj₂ : { A : Type ℓ } { B : Type ℓ' } → A × B → B
+proj₂ (_ , x ) = x
+
+
+private
+ variable
+ A : Type ℓ
+ B C : A → Type ℓ
+
+intro : (∀ a → B a ) → (∀ a → C a ) → ∀ a → B a × C a
+intro f g a = f a , g a
+
+map : { B : Type ℓ } { D : B → Type ℓ' }
+ → (∀ a → C a ) → (∀ b → D b ) → ( x : A × B ) → C ( proj₁ x ) × D ( proj₂ x )
+map f g = intro ( f ∘ proj₁ ) ( g ∘ proj₂ )
+
+
+×-η : { A : Type ℓ } { B : Type ℓ' } ( x : A × B ) → x ≡ (( proj₁ x ) , ( proj₂ x ))
+×-η ( x , x₁ ) = refl
+
+
+
+
+record _×ω_ { a } ( A : Type a ) ( B : Typeω ) : Typeω where
+ constructor _,_
+ field
+ fst : A
+ snd : B
+Cubical.Data.Sum.Properties {-# OPTIONS --safe #-}
+module Cubical.Data.Sum.Properties where
+
+open import Cubical.Core.Everything
+open import Cubical.Foundations.Prelude
+open import Cubical.Foundations.HLevels
+open import Cubical.Functions.Embedding
+open import Cubical.Foundations.Equiv
+open import Cubical.Foundations.Isomorphism
+open import Cubical.Data.Empty
+open import Cubical.Data.Nat
+open import Cubical.Data.Sigma
+open import Cubical.Relation.Nullary
+
+open import Cubical.Data.Sum.Base
+
+open Iso
+
+
+private
+ variable
+ ℓa ℓb ℓc ℓd ℓe : Level
+ A : Type ℓa
+ B : Type ℓb
+ C : Type ℓc
+ D : Type ℓd
+ E : A ⊎ B → Type ℓe
+
+
+
+module ⊎Path { ℓ ℓ' } { A : Type ℓ } { B : Type ℓ' } where
+
+ Cover : A ⊎ B → A ⊎ B → Type ( ℓ-max ℓ ℓ' )
+ Cover ( inl a ) ( inl a' ) = Lift { j = ℓ-max ℓ ℓ' } ( a ≡ a' )
+ Cover ( inl _) ( inr _) = Lift ⊥
+ Cover ( inr _) ( inl _) = Lift ⊥
+ Cover ( inr b ) ( inr b' ) = Lift { j = ℓ-max ℓ ℓ' } ( b ≡ b' )
+
+ reflCode : ( c : A ⊎ B ) → Cover c c
+ reflCode ( inl a ) = lift refl
+ reflCode ( inr b ) = lift refl
+
+ encode : ∀ c c' → c ≡ c' → Cover c c'
+ encode c _ = J (λ c' _ → Cover c c' ) ( reflCode c )
+
+ encodeRefl : ∀ c → encode c c refl ≡ reflCode c
+ encodeRefl c = JRefl (λ c' _ → Cover c c' ) ( reflCode c )
+
+ decode : ∀ c c' → Cover c c' → c ≡ c'
+ decode ( inl a ) ( inl a' ) ( lift p ) = cong inl p
+ decode ( inl a ) ( inr b' ) ()
+ decode ( inr b ) ( inl a' ) ()
+ decode ( inr b ) ( inr b' ) ( lift q ) = cong inr q
+
+ decodeRefl : ∀ c → decode c c ( reflCode c ) ≡ refl
+ decodeRefl ( inl a ) = refl
+ decodeRefl ( inr b ) = refl
+
+ decodeEncode : ∀ c c' → ( p : c ≡ c' ) → decode c c' ( encode c c' p ) ≡ p
+ decodeEncode c _ =
+ J (λ c' p → decode c c' ( encode c c' p ) ≡ p )
+ ( cong ( decode c c ) ( encodeRefl c ) ∙ decodeRefl c )
+
+ encodeDecode : ∀ c c' → ( d : Cover c c' ) → encode c c' ( decode c c' d ) ≡ d
+ encodeDecode ( inl a ) ( inl _) ( lift d ) =
+ J (λ a' p → encode ( inl a ) ( inl a' ) ( cong inl p ) ≡ lift p ) ( encodeRefl ( inl a )) d
+ encodeDecode ( inr a ) ( inr _) ( lift d ) =
+ J (λ a' p → encode ( inr a ) ( inr a' ) ( cong inr p ) ≡ lift p ) ( encodeRefl ( inr a )) d
+
+ Cover≃Path : ∀ c c' → Cover c c' ≃ ( c ≡ c' )
+ Cover≃Path c c' =
+ isoToEquiv ( iso ( decode c c' ) ( encode c c' ) ( decodeEncode c c' ) ( encodeDecode c c' ))
+
+ isOfHLevelCover : ( n : HLevel )
+ → isOfHLevel ( suc ( suc n )) A
+ → isOfHLevel ( suc ( suc n )) B
+ → ∀ c c' → isOfHLevel ( suc n ) ( Cover c c' )
+ isOfHLevelCover n p q ( inl a ) ( inl a' ) = isOfHLevelLift ( suc n ) ( p a a' )
+ isOfHLevelCover n p q ( inl a ) ( inr b' ) =
+ isOfHLevelLift ( suc n ) ( isProp→isOfHLevelSuc n isProp⊥ )
+ isOfHLevelCover n p q ( inr b ) ( inl a' ) =
+ isOfHLevelLift ( suc n ) ( isProp→isOfHLevelSuc n isProp⊥ )
+ isOfHLevelCover n p q ( inr b ) ( inr b' ) = isOfHLevelLift ( suc n ) ( q b b' )
+
+isEmbedding-inl : isEmbedding ( inl { A = A } { B = B })
+isEmbedding-inl w z = snd ( compEquiv LiftEquiv ( ⊎Path.Cover≃Path ( inl w ) ( inl z )))
+
+isEmbedding-inr : isEmbedding ( inr { A = A } { B = B })
+isEmbedding-inr w z = snd ( compEquiv LiftEquiv ( ⊎Path.Cover≃Path ( inr w ) ( inr z )))
+
+isOfHLevel⊎ : ( n : HLevel )
+ → isOfHLevel ( suc ( suc n )) A
+ → isOfHLevel ( suc ( suc n )) B
+ → isOfHLevel ( suc ( suc n )) ( A ⊎ B )
+isOfHLevel⊎ n lA lB c c' =
+ isOfHLevelRetract ( suc n )
+ ( ⊎Path.encode c c' )
+ ( ⊎Path.decode c c' )
+ ( ⊎Path.decodeEncode c c' )
+ ( ⊎Path.isOfHLevelCover n lA lB c c' )
+
+isSet⊎ : isSet A → isSet B → isSet ( A ⊎ B )
+isSet⊎ = isOfHLevel⊎ 0
+
+isGroupoid⊎ : isGroupoid A → isGroupoid B → isGroupoid ( A ⊎ B )
+isGroupoid⊎ = isOfHLevel⊎ 1
+
+is2Groupoid⊎ : is2Groupoid A → is2Groupoid B → is2Groupoid ( A ⊎ B )
+is2Groupoid⊎ = isOfHLevel⊎ 2
+
+discrete⊎ : Discrete A → Discrete B → Discrete ( A ⊎ B )
+discrete⊎ decA decB ( inl a ) ( inl a' ) =
+ mapDec ( cong inl ) (λ p q → p ( isEmbedding→Inj isEmbedding-inl _ _ q )) ( decA a a' )
+discrete⊎ decA decB ( inl a ) ( inr b' ) = no (λ p → lower ( ⊎Path.encode ( inl a ) ( inr b' ) p ))
+discrete⊎ decA decB ( inr b ) ( inl a' ) = no ((λ p → lower ( ⊎Path.encode ( inr b ) ( inl a' ) p )))
+discrete⊎ decA decB ( inr b ) ( inr b' ) =
+ mapDec ( cong inr ) (λ p q → p ( isEmbedding→Inj isEmbedding-inr _ _ q )) ( decB b b' )
+
+⊎Iso : Iso A C → Iso B D → Iso ( A ⊎ B ) ( C ⊎ D )
+fun ( ⊎Iso iac ibd ) ( inl x ) = inl ( iac . fun x )
+fun ( ⊎Iso iac ibd ) ( inr x ) = inr ( ibd . fun x )
+inv ( ⊎Iso iac ibd ) ( inl x ) = inl ( iac . inv x )
+inv ( ⊎Iso iac ibd ) ( inr x ) = inr ( ibd . inv x )
+rightInv ( ⊎Iso iac ibd ) ( inl x ) = cong inl ( iac . rightInv x )
+rightInv ( ⊎Iso iac ibd ) ( inr x ) = cong inr ( ibd . rightInv x )
+leftInv ( ⊎Iso iac ibd ) ( inl x ) = cong inl ( iac . leftInv x )
+leftInv ( ⊎Iso iac ibd ) ( inr x ) = cong inr ( ibd . leftInv x )
+
+⊎-equiv : A ≃ C → B ≃ D → ( A ⊎ B ) ≃ ( C ⊎ D )
+⊎-equiv p q = isoToEquiv ( ⊎Iso ( equivToIso p ) ( equivToIso q ))
+
+⊎-swap-Iso : Iso ( A ⊎ B ) ( B ⊎ A )
+fun ⊎-swap-Iso ( inl x ) = inr x
+fun ⊎-swap-Iso ( inr x ) = inl x
+inv ⊎-swap-Iso ( inl x ) = inr x
+inv ⊎-swap-Iso ( inr x ) = inl x
+rightInv ⊎-swap-Iso ( inl _) = refl
+rightInv ⊎-swap-Iso ( inr _) = refl
+leftInv ⊎-swap-Iso ( inl _) = refl
+leftInv ⊎-swap-Iso ( inr _) = refl
+
+⊎-swap-≃ : A ⊎ B ≃ B ⊎ A
+⊎-swap-≃ = isoToEquiv ⊎-swap-Iso
+
+⊎-assoc-Iso : Iso (( A ⊎ B ) ⊎ C ) ( A ⊎ ( B ⊎ C ))
+fun ⊎-assoc-Iso ( inl ( inl x )) = inl x
+fun ⊎-assoc-Iso ( inl ( inr x )) = inr ( inl x )
+fun ⊎-assoc-Iso ( inr x ) = inr ( inr x )
+inv ⊎-assoc-Iso ( inl x ) = inl ( inl x )
+inv ⊎-assoc-Iso ( inr ( inl x )) = inl ( inr x )
+inv ⊎-assoc-Iso ( inr ( inr x )) = inr x
+rightInv ⊎-assoc-Iso ( inl _) = refl
+rightInv ⊎-assoc-Iso ( inr ( inl _)) = refl
+rightInv ⊎-assoc-Iso ( inr ( inr _)) = refl
+leftInv ⊎-assoc-Iso ( inl ( inl _)) = refl
+leftInv ⊎-assoc-Iso ( inl ( inr _)) = refl
+leftInv ⊎-assoc-Iso ( inr _) = refl
+
+⊎-assoc-≃ : ( A ⊎ B ) ⊎ C ≃ A ⊎ ( B ⊎ C )
+⊎-assoc-≃ = isoToEquiv ⊎-assoc-Iso
+
+⊎-⊥-Iso : Iso ( A ⊎ ⊥ ) A
+fun ⊎-⊥-Iso ( inl x ) = x
+inv ⊎-⊥-Iso x = inl x
+rightInv ⊎-⊥-Iso _ = refl
+leftInv ⊎-⊥-Iso ( inl _) = refl
+
+⊎-⊥-≃ : A ⊎ ⊥ ≃ A
+⊎-⊥-≃ = isoToEquiv ⊎-⊥-Iso
+
+Π⊎Iso : Iso (( x : A ⊎ B ) → E x ) ((( a : A ) → E ( inl a )) × (( b : B ) → E ( inr b )))
+fun Π⊎Iso f . fst a = f ( inl a )
+fun Π⊎Iso f . snd b = f ( inr b )
+inv Π⊎Iso ( g1 , g2 ) ( inl a ) = g1 a
+inv Π⊎Iso ( g1 , g2 ) ( inr b ) = g2 b
+rightInv Π⊎Iso ( g1 , g2 ) i . fst a = g1 a
+rightInv Π⊎Iso ( g1 , g2 ) i . snd b = g2 b
+leftInv Π⊎Iso f i ( inl a ) = f ( inl a )
+leftInv Π⊎Iso f i ( inr b ) = f ( inr b )
+
+Σ⊎Iso : Iso ( Σ ( A ⊎ B ) E ) (( Σ A (λ a → E ( inl a ))) ⊎ ( Σ B (λ b → E ( inr b ))))
+fun Σ⊎Iso ( inl a , ea ) = inl ( a , ea )
+fun Σ⊎Iso ( inr b , eb ) = inr ( b , eb )
+inv Σ⊎Iso ( inl ( a , ea )) = ( inl a , ea )
+inv Σ⊎Iso ( inr ( b , eb )) = ( inr b , eb )
+rightInv Σ⊎Iso ( inl ( a , ea )) = refl
+rightInv Σ⊎Iso ( inr ( b , eb )) = refl
+leftInv Σ⊎Iso ( inl a , ea ) = refl
+leftInv Σ⊎Iso ( inr b , eb ) = refl
+
+Π⊎≃ : (( x : A ⊎ B ) → E x ) ≃ (( a : A ) → E ( inl a )) × (( b : B ) → E ( inr b ))
+Π⊎≃ = isoToEquiv Π⊎Iso
+
+Σ⊎≃ : ( Σ ( A ⊎ B ) E ) ≃ (( Σ A (λ a → E ( inl a ))) ⊎ ( Σ B (λ b → E ( inr b ))))
+Σ⊎≃ = isoToEquiv Σ⊎Iso
+
+map-⊎ : ( A → C ) → ( B → D ) → A ⊎ B → C ⊎ D
+map-⊎ f _ ( inl a ) = inl ( f a )
+map-⊎ _ g ( inr b ) = inr ( g b )
+Cubical.Data.Sum {-# OPTIONS --safe #-}
+module Cubical.Data.Sum where
+
+open import Cubical.Data.Sum.Base public
+open import Cubical.Data.Sum.Properties public
+Cubical.Data.Unit.Properties {-# OPTIONS --safe #-}
+module Cubical.Data.Unit.Properties where
+
+open import Cubical.Core.Everything
+
+open import Cubical.Foundations.Prelude
+open import Cubical.Foundations.Function
+open import Cubical.Foundations.HLevels
+open import Cubical.Foundations.Isomorphism
+open import Cubical.Foundations.Equiv
+
+open import Cubical.Data.Nat
+open import Cubical.Data.Unit.Base
+open import Cubical.Data.Prod.Base
+
+open import Cubical.Foundations.Isomorphism
+open import Cubical.Foundations.Equiv
+open import Cubical.Foundations.Univalence
+
+open import Cubical.Reflection.StrictEquiv
+
+open Iso
+
+private
+ variable
+ ℓ ℓ' : Level
+
+isContrUnit : isContr Unit
+isContrUnit = tt , λ { tt → refl }
+
+isPropUnit : isProp Unit
+isPropUnit _ _ i = tt
+
+isSetUnit : isSet Unit
+isSetUnit = isProp→isSet isPropUnit
+
+isOfHLevelUnit : ( n : HLevel ) → isOfHLevel n Unit
+isOfHLevelUnit n = isContr→isOfHLevel n isContrUnit
+
+module _ ( A : Type ℓ ) where
+ UnitToType≃ : ( Unit → A ) ≃ A
+ unquoteDef UnitToType≃ = defStrictEquiv UnitToType≃ (λ f → f _) const
+
+UnitToTypePath : ∀ { ℓ } ( A : Type ℓ ) → ( Unit → A ) ≡ A
+UnitToTypePath A = ua ( UnitToType≃ A )
+
+module _ ( A : Unit → Type ℓ ) where
+
+ open Iso
+
+ ΠUnitIso : Iso (( x : Unit ) → A x ) ( A tt )
+ fun ΠUnitIso f = f tt
+ inv ΠUnitIso a tt = a
+ rightInv ΠUnitIso a = refl
+ leftInv ΠUnitIso f = refl
+
+ ΠUnit : (( x : Unit ) → A x ) ≃ A tt
+ ΠUnit = isoToEquiv ΠUnitIso
+
+module _ ( A : Unit* { ℓ } → Type ℓ' ) where
+
+ open Iso
+
+ ΠUnit*Iso : Iso (( x : Unit* ) → A x ) ( A tt* )
+ fun ΠUnit*Iso f = f tt*
+ inv ΠUnit*Iso a tt* = a
+ rightInv ΠUnit*Iso a = refl
+ leftInv ΠUnit*Iso f = refl
+
+ ΠUnit* : (( x : Unit* ) → A x ) ≃ A tt*
+ ΠUnit* = isoToEquiv ΠUnit*Iso
+
+fiberUnitIso : { A : Type ℓ } → Iso ( fiber (λ ( a : A ) → tt ) tt ) A
+fun fiberUnitIso = fst
+inv fiberUnitIso a = a , refl
+rightInv fiberUnitIso _ = refl
+leftInv fiberUnitIso _ = refl
+
+isContr→Iso2 : { A : Type ℓ } { B : Type ℓ' } → isContr A → Iso ( A → B ) B
+fun ( isContr→Iso2 iscontr ) f = f ( fst iscontr )
+inv ( isContr→Iso2 iscontr ) b _ = b
+rightInv ( isContr→Iso2 iscontr ) _ = refl
+leftInv ( isContr→Iso2 iscontr ) f = funExt λ x → cong f ( snd iscontr x )
+
+diagonal-unit : Unit ≡ Unit × Unit
+diagonal-unit = isoToPath ( iso (λ x → tt , tt ) (λ x → tt ) (λ {( tt , tt ) i → tt , tt }) λ { tt i → tt })
+
+fibId : ( A : Type ℓ ) → ( fiber (λ ( x : A ) → tt ) tt ) ≡ A
+fibId A = ua e
+ where
+ unquoteDecl e = declStrictEquiv e fst (λ a → a , refl )
+
+isContr→≃Unit : { A : Type ℓ } → isContr A → A ≃ Unit
+isContr→≃Unit contr = isoToEquiv ( iso (λ _ → tt ) (λ _ → fst contr ) (λ _ → refl ) λ _ → snd contr _)
+
+isContr→≡Unit : { A : Type₀ } → isContr A → A ≡ Unit
+isContr→≡Unit contr = ua ( isContr→≃Unit contr )
+
+isContrUnit* : ∀ { ℓ } → isContr ( Unit* { ℓ })
+isContrUnit* = tt* , λ _ → refl
+
+isPropUnit* : ∀ { ℓ } → isProp ( Unit* { ℓ })
+isPropUnit* _ _ = refl
+
+isSetUnit* : ∀ { ℓ } → isSet ( Unit* { ℓ })
+isSetUnit* _ _ _ _ = refl
+
+isOfHLevelUnit* : ∀ { ℓ } ( n : HLevel ) → isOfHLevel n ( Unit* { ℓ })
+isOfHLevelUnit* zero = tt* , λ _ → refl
+isOfHLevelUnit* ( suc zero ) _ _ = refl
+isOfHLevelUnit* ( suc ( suc zero )) _ _ _ _ _ _ = tt*
+isOfHLevelUnit* ( suc ( suc ( suc n ))) = isOfHLevelPlus 3 ( isOfHLevelUnit* n )
+
+Unit≃Unit* : ∀ { ℓ } → Unit ≃ Unit* { ℓ }
+Unit≃Unit* = invEquiv ( isContr→≃Unit isContrUnit* )
+
+isContr→≃Unit* : { A : Type ℓ } → isContr A → A ≃ Unit* { ℓ }
+isContr→≃Unit* contr = compEquiv ( isContr→≃Unit contr ) Unit≃Unit*
+
+isContr→≡Unit* : { A : Type ℓ } → isContr A → A ≡ Unit*
+isContr→≡Unit* contr = ua ( isContr→≃Unit* contr )
+Cubical.Data.Unit {-# OPTIONS --safe #-}
+module Cubical.Data.Unit where
+
+open import Cubical.Data.Unit.Base public
+open import Cubical.Data.Unit.Properties public
+Cubical.Data.Vec.Properties {-# OPTIONS --safe #-}
+module Cubical.Data.Vec.Properties where
+
+open import Cubical.Foundations.Prelude
+open import Cubical.Foundations.Equiv
+open import Cubical.Foundations.Isomorphism
+open import Cubical.Foundations.HLevels
+open import Cubical.Foundations.Univalence
+
+import Cubical.Data.Empty as ⊥
+open import Cubical.Data.Unit
+open import Cubical.Data.Nat
+open import Cubical.Data.Sigma
+open import Cubical.Data.Sum
+open import Cubical.Data.Vec.Base
+open import Cubical.Data.FinData
+open import Cubical.Relation.Nullary
+
+open Iso
+
+private
+ variable
+ ℓ : Level
+ A : Type ℓ
+
+
+
+
+++-assoc : ∀ { m n k } ( xs : Vec A m ) ( ys : Vec A n ) ( zs : Vec A k ) →
+ PathP (λ i → Vec A ( +-assoc m n k ( ~ i ))) (( xs ++ ys ) ++ zs ) ( xs ++ ys ++ zs )
+++-assoc { m = zero } [] ys zs = refl
+++-assoc { m = suc m } ( x ∷ xs ) ys zs i = x ∷ ++-assoc xs ys zs i
+
+
+
+FinVec→Vec : { n : ℕ } → FinVec A n → Vec A n
+FinVec→Vec { n = zero } xs = []
+FinVec→Vec { n = suc _} xs = xs zero ∷ FinVec→Vec (λ x → xs ( suc x ))
+
+Vec→FinVec : { n : ℕ } → Vec A n → FinVec A n
+Vec→FinVec xs f = lookup f xs
+
+FinVec→Vec→FinVec : { n : ℕ } ( xs : FinVec A n ) → Vec→FinVec ( FinVec→Vec xs ) ≡ xs
+FinVec→Vec→FinVec { n = zero } xs = funExt λ f → ⊥.rec ( ¬Fin0 f )
+FinVec→Vec→FinVec { n = suc n } xs = funExt goal
+ where
+ goal : ( f : Fin ( suc n ))
+ → Vec→FinVec ( xs zero ∷ FinVec→Vec (λ x → xs ( suc x ))) f ≡ xs f
+ goal zero = refl
+ goal ( suc f ) i = FinVec→Vec→FinVec (λ x → xs ( suc x )) i f
+
+Vec→FinVec→Vec : { n : ℕ } ( xs : Vec A n ) → FinVec→Vec ( Vec→FinVec xs ) ≡ xs
+Vec→FinVec→Vec { n = zero } [] = refl
+Vec→FinVec→Vec { n = suc n } ( x ∷ xs ) i = x ∷ Vec→FinVec→Vec xs i
+
+FinVecIsoVec : ( n : ℕ ) → Iso ( FinVec A n ) ( Vec A n )
+FinVecIsoVec n = iso FinVec→Vec Vec→FinVec Vec→FinVec→Vec FinVec→Vec→FinVec
+
+FinVec≃Vec : ( n : ℕ ) → FinVec A n ≃ Vec A n
+FinVec≃Vec n = isoToEquiv ( FinVecIsoVec n )
+
+FinVec≡Vec : ( n : ℕ ) → FinVec A n ≡ Vec A n
+FinVec≡Vec n = ua ( FinVec≃Vec n )
+
+isContrVec0 : isContr ( Vec A 0 )
+isContrVec0 = [] , λ { [] → refl }
+
+
+module VecPath { A : Type ℓ }
+ where
+
+ code : { n : ℕ } → ( v v' : Vec A n ) → Type ℓ
+ code [] [] = Unit*
+ code ( a ∷ v ) ( a' ∷ v' ) = ( a ≡ a' ) × ( v ≡ v' )
+
+
+ reflEncode : { n : ℕ } → ( v : Vec A n ) → code v v
+ reflEncode [] = tt*
+ reflEncode ( a ∷ v ) = refl , refl
+
+ encode : { n : ℕ } → ( v v' : Vec A n ) → ( v ≡ v' ) → code v v'
+ encode v v' p = J (λ v' _ → code v v' ) ( reflEncode v ) p
+
+ encodeRefl : { n : ℕ } → ( v : Vec A n ) → encode v v refl ≡ reflEncode v
+ encodeRefl v = JRefl (λ v' _ → code v v' ) ( reflEncode v )
+
+
+ decode : { n : ℕ } → ( v v' : Vec A n ) → ( r : code v v' ) → ( v ≡ v' )
+ decode [] [] _ = refl
+ decode ( a ∷ v ) ( a' ∷ v' ) ( p , q ) = cong₂ _∷_ p q
+
+ decodeRefl : { n : ℕ } → ( v : Vec A n ) → decode v v ( reflEncode v ) ≡ refl
+ decodeRefl [] = refl
+ decodeRefl ( a ∷ v ) = refl
+
+
+ ≡Vec≃codeVec : { n : ℕ } → ( v v' : Vec A n ) → ( v ≡ v' ) ≃ ( code v v' )
+ ≡Vec≃codeVec v v' = isoToEquiv is
+ where
+ is : Iso ( v ≡ v' ) ( code v v' )
+ fun is = encode v v'
+ inv is = decode v v'
+ rightInv is = sect v v'
+ where
+ sect : { n : ℕ } → ( v v' : Vec A n ) → ( r : code v v' )
+ → encode v v' ( decode v v' r ) ≡ r
+ sect [] [] tt* = encodeRefl []
+ sect ( a ∷ v ) ( a' ∷ v' ) ( p , q ) = J (λ a' p → encode ( a ∷ v ) ( a' ∷ v' ) ( decode ( a ∷ v ) ( a' ∷ v' ) ( p , q )) ≡ ( p , q ))
+ ( J (λ v' q → encode ( a ∷ v ) ( a ∷ v' ) ( decode ( a ∷ v ) ( a ∷ v' ) ( refl , q )) ≡ ( refl , q ))
+ ( encodeRefl ( a ∷ v )) q ) p
+ leftInv is = retr v v'
+ where
+ retr : { n : ℕ } → ( v v' : Vec A n ) → ( p : v ≡ v' )
+ → decode v v' ( encode v v' p ) ≡ p
+ retr v v' p = J (λ v' p → decode v v' ( encode v v' p ) ≡ p )
+ ( cong ( decode v v ) ( encodeRefl v ) ∙ decodeRefl v ) p
+
+
+ isOfHLevelVec : ( h : HLevel ) ( n : ℕ )
+ → isOfHLevel ( suc ( suc h )) A → isOfHLevel ( suc ( suc h )) ( Vec A n )
+ isOfHLevelVec h zero ofLevelA [] [] = isOfHLevelRespectEquiv ( suc h ) ( invEquiv ( ≡Vec≃codeVec [] [] ))
+ ( isOfHLevelUnit* ( suc h ))
+ isOfHLevelVec h ( suc n ) ofLevelA ( x ∷ v ) ( x' ∷ v' ) = isOfHLevelRespectEquiv ( suc h ) ( invEquiv ( ≡Vec≃codeVec _ _))
+ ( isOfHLevelΣ ( suc h ) ( ofLevelA x x' ) (λ _ → isOfHLevelVec h n ofLevelA v v' ))
+
+
+ discreteA→discreteVecA : Discrete A → ( n : ℕ ) → Discrete ( Vec A n )
+ discreteA→discreteVecA DA zero [] [] = yes refl
+ discreteA→discreteVecA DA ( suc n ) ( a ∷ v ) ( a' ∷ v' ) with ( DA a a' ) | ( discreteA→discreteVecA DA n v v' )
+ ... | yes p | yes q = yes ( invIsEq ( snd ( ≡Vec≃codeVec ( a ∷ v ) ( a' ∷ v' ))) ( p , q ))
+ ... | yes p | no ¬q = no (λ r → ¬q ( snd ( funIsEq ( snd ( ≡Vec≃codeVec ( a ∷ v ) ( a' ∷ v' ))) r )))
+ ... | no ¬p | yes q = no (λ r → ¬p ( fst ( funIsEq ( snd ( ≡Vec≃codeVec ( a ∷ v ) ( a' ∷ v' ))) r )))
+ ... | no ¬p | no ¬q = no (λ r → ¬q ( snd ( funIsEq ( snd ( ≡Vec≃codeVec ( a ∷ v ) ( a' ∷ v' ))) r )))
+
+ ≢-∷ : { m : ℕ } → ( Discrete A ) → ( a : A ) → ( v : Vec A m ) → ( a' : A ) → ( v' : Vec A m ) →
+ ( a ∷ v ≡ a' ∷ v' → ⊥.⊥ ) → ( a ≡ a' → ⊥.⊥ ) ⊎ ( v ≡ v' → ⊥.⊥ )
+ ≢-∷ { m } discreteA a v a' v' ¬r with ( discreteA a a' )
+ | ( discreteA→discreteVecA discreteA m v v' )
+ ... | yes p | yes q = ⊥.rec ( ¬r ( cong₂ _∷_ p q ))
+ ... | yes p | no ¬q = inr ¬q
+ ... | no ¬p | y = inl ¬p
+Cubical.Data.Vec {-# OPTIONS --safe #-}
+module Cubical.Data.Vec where
+
+open import Cubical.Data.Vec.Base public
+open import Cubical.Data.Vec.Properties public
+Cubical.Foundations.Equiv.Fiberwise {-# OPTIONS --safe #-}
+module Cubical.Foundations.Equiv.Fiberwise where
+
+open import Cubical.Core.Everything
+
+open import Cubical.Foundations.Prelude
+open import Cubical.Foundations.Equiv
+open import Cubical.Foundations.Equiv.Properties
+open import Cubical.Foundations.Isomorphism
+open import Cubical.Foundations.HLevels
+open import Cubical.Data.Sigma
+
+private
+ variable
+ ℓ ℓ' ℓ'' : Level
+
+module _ { A : Type ℓ } ( P : A → Type ℓ' ) ( Q : A → Type ℓ'' )
+ ( f : ∀ x → P x → Q x )
+ where
+ private
+ total : ( Σ A P ) → ( Σ A Q )
+ total = (\ p → p . fst , f ( p . fst ) ( p . snd ))
+
+
+ fibers-total : ∀ { xv } → Iso ( fiber total ( xv )) ( fiber ( f ( xv . fst )) ( xv . snd ))
+ fibers-total { xv } = iso h g h-g g-h
+ where
+ h : ∀ { xv } → fiber total xv → fiber ( f ( xv . fst )) ( xv . snd )
+ h { xv } ( p , eq ) = J (\ xv eq → fiber ( f ( xv . fst )) ( xv . snd )) (( p . snd ) , refl ) eq
+ g : ∀ { xv } → fiber ( f ( xv . fst )) ( xv . snd ) → fiber total xv
+ g { xv } ( p , eq ) = ( xv . fst , p ) , (\ i → _ , eq i )
+ h-g : ∀ { xv } y → h { xv } ( g { xv } y ) ≡ y
+ h-g { x , v } ( p , eq ) = J (λ _ eq₁ → h ( g ( p , eq₁ )) ≡ ( p , eq₁ )) ( JRefl (λ xv₁ eq₁ → fiber ( f ( xv₁ . fst )) ( xv₁ . snd )) (( p , refl ))) ( eq )
+ g-h : ∀ { xv } y → g { xv } ( h { xv } y ) ≡ y
+ g-h { xv } (( a , p ) , eq ) = J (λ _ eq₁ → g ( h (( a , p ) , eq₁ )) ≡ (( a , p ) , eq₁ ))
+ ( cong g ( JRefl (λ xv₁ eq₁ → fiber ( f ( xv₁ . fst )) ( xv₁ . snd )) ( p , refl )))
+ eq
+
+ fiberEquiv : ( [tf] : isEquiv total )
+ → ∀ x → isEquiv ( f x )
+ fiberEquiv [tf] x . equiv-proof y = isContrRetract ( fibers-total . Iso.inv ) ( fibers-total . Iso.fun ) ( fibers-total . Iso.rightInv )
+ ( [tf] . equiv-proof ( x , y ))
+
+ totalEquiv : ( fx-equiv : ∀ x → isEquiv ( f x ))
+ → isEquiv total
+ totalEquiv fx-equiv . equiv-proof ( x , v ) = isContrRetract ( fibers-total . Iso.fun ) ( fibers-total . Iso.inv ) ( fibers-total . Iso.leftInv )
+ ( fx-equiv x . equiv-proof v )
+
+
+module _ { U : Type ℓ } ( _~_ : U → U → Type ℓ' )
+ ( idTo~ : ∀ { A B } → A ≡ B → A ~ B )
+ ( c : ∀ A → ∃![ X ∈ U ] ( A ~ X ))
+ where
+
+ isContrToUniv : ∀ { A B } → isEquiv ( idTo~ { A } { B })
+ isContrToUniv { A } { B }
+ = fiberEquiv (λ z → A ≡ z ) (λ z → A ~ z ) (\ B → idTo~ { A } { B })
+ (λ { . equiv-proof y
+ → isContrΣ ( isContrSingl _)
+ \ a → isContr→isContrPath ( c A ) _ _
+ })
+ B
+
+
+
+recognizeId : { A : Type ℓ } { a : A } ( Eq : A → Type ℓ' )
+ → Eq a
+ → isContr ( Σ _ Eq )
+ → ( x : A ) → ( a ≡ x ) ≃ ( Eq x )
+recognizeId { A = A } { a = a } Eq eqRefl eqContr x = ( fiberMap x ) , ( isEquivFiberMap x )
+ where
+ fiberMap : ( x : A ) → a ≡ x → Eq x
+ fiberMap x = J (λ x p → Eq x ) eqRefl
+
+ mapOnSigma : Σ[ x ∈ A ] a ≡ x → Σ _ Eq
+ mapOnSigma pair = fst pair , fiberMap ( fst pair ) ( snd pair )
+
+ equivOnSigma : ( x : A ) → isEquiv mapOnSigma
+ equivOnSigma x = isEquivFromIsContr mapOnSigma ( isContrSingl a ) eqContr
+
+ isEquivFiberMap : ( x : A ) → isEquiv ( fiberMap x )
+ isEquivFiberMap = fiberEquiv (λ x → a ≡ x ) Eq fiberMap ( equivOnSigma x )
+
+fundamentalTheoremOfId : { A : Type ℓ } ( Eq : A → A → Type ℓ' )
+ → (( x : A ) → Eq x x )
+ → (( x : A ) → isContr ( Σ[ y ∈ A ] Eq x y ))
+ → ( x y : A ) → ( x ≡ y ) ≃ ( Eq x y )
+fundamentalTheoremOfId Eq eqRefl eqContr x = recognizeId ( Eq x ) ( eqRefl x ) ( eqContr x )
+
+fundamentalTheoremOfIdβ :
+ { A : Type ℓ } ( Eq : A → A → Type ℓ' )
+ → ( eqRefl : ( x : A ) → Eq x x )
+ → ( eqContr : ( x : A ) → isContr ( Σ[ y ∈ A ] Eq x y ))
+ → ( x : A )
+ → fst ( fundamentalTheoremOfId Eq eqRefl eqContr x x ) refl ≡ eqRefl x
+fundamentalTheoremOfIdβ Eq eqRefl eqContr x = JRefl (λ y p → Eq x y ) ( eqRefl x )
+Cubical.Foundations.Equiv.Properties
+{-# OPTIONS --safe #-}
+module Cubical.Foundations.Equiv.Properties where
+
+open import Cubical.Core.Everything
+
+open import Cubical.Data.Sigma
+
+open import Cubical.Foundations.Prelude
+open import Cubical.Foundations.Function
+open import Cubical.Foundations.Equiv
+open import Cubical.Foundations.Equiv.HalfAdjoint
+open import Cubical.Foundations.Univalence
+open import Cubical.Foundations.Isomorphism
+open import Cubical.Foundations.Path
+open import Cubical.Foundations.HLevels
+
+open import Cubical.Functions.FunExtEquiv
+
+private
+ variable
+ ℓ ℓ' ℓ'' : Level
+ A B C : Type ℓ
+
+isEquivInvEquiv : isEquiv (λ ( e : A ≃ B ) → invEquiv e )
+isEquivInvEquiv = isoToIsEquiv goal where
+ open Iso
+ goal : Iso ( A ≃ B ) ( B ≃ A )
+ goal . fun = invEquiv
+ goal . inv = invEquiv
+ goal . rightInv g = equivEq refl
+ goal . leftInv f = equivEq refl
+
+invEquivEquiv : ( A ≃ B ) ≃ ( B ≃ A )
+invEquivEquiv = _ , isEquivInvEquiv
+
+isEquivCong : { x y : A } ( e : A ≃ B ) → isEquiv (λ ( p : x ≡ y ) → cong ( equivFun e ) p )
+isEquivCong e = isoToIsEquiv ( congIso ( equivToIso e ))
+
+congEquiv : { x y : A } ( e : A ≃ B ) → ( x ≡ y ) ≃ ( equivFun e x ≡ equivFun e y )
+congEquiv e = isoToEquiv ( congIso ( equivToIso e ))
+
+equivAdjointEquiv : ( e : A ≃ B ) → ∀ { a b } → ( a ≡ invEq e b ) ≃ ( equivFun e a ≡ b )
+equivAdjointEquiv e = compEquiv ( congEquiv e ) ( compPathrEquiv ( secEq e _))
+
+invEq≡→equivFun≡ : ( e : A ≃ B ) → ∀ { a b } → invEq e b ≡ a → equivFun e a ≡ b
+invEq≡→equivFun≡ e = equivFun ( equivAdjointEquiv e ) ∘ sym
+
+isEquivPreComp : ( e : A ≃ B ) → isEquiv (λ ( φ : B → C ) → φ ∘ equivFun e )
+isEquivPreComp e = snd ( equiv→ ( invEquiv e ) ( idEquiv _))
+
+preCompEquiv : ( e : A ≃ B ) → ( B → C ) ≃ ( A → C )
+preCompEquiv e = (λ φ → φ ∘ fst e ) , isEquivPreComp e
+
+isEquivPostComp : ( e : A ≃ B ) → isEquiv (λ ( φ : C → A ) → e . fst ∘ φ )
+isEquivPostComp e = snd ( equivΠCod (λ _ → e ))
+
+postCompEquiv : ( e : A ≃ B ) → ( C → A ) ≃ ( C → B )
+postCompEquiv e = _ , isEquivPostComp e
+
+
+
+hasSection : ( A → B ) → Type _
+hasSection { A = A } { B = B } f = Σ[ g ∈ ( B → A ) ] section f g
+
+hasRetract : ( A → B ) → Type _
+hasRetract { A = A } { B = B } f = Σ[ g ∈ ( B → A ) ] retract f g
+
+isEquiv→isContrHasSection : { f : A → B } → isEquiv f → isContr ( hasSection f )
+fst ( isEquiv→isContrHasSection isEq ) = invIsEq isEq , secIsEq isEq
+snd ( isEquiv→isContrHasSection isEq ) ( f , ε ) i = (λ b → fst ( p b i )) , (λ b → snd ( p b i ))
+ where p : ∀ b → ( invIsEq isEq b , secIsEq isEq b ) ≡ ( f b , ε b )
+ p b = isEq . equiv-proof b . snd ( f b , ε b )
+
+isEquiv→hasSection : { f : A → B } → isEquiv f → hasSection f
+isEquiv→hasSection = fst ∘ isEquiv→isContrHasSection
+
+isContr-hasSection : ( e : A ≃ B ) → isContr ( hasSection ( fst e ))
+isContr-hasSection e = isEquiv→isContrHasSection ( snd e )
+
+isEquiv→isContrHasRetract : { f : A → B } → isEquiv f → isContr ( hasRetract f )
+fst ( isEquiv→isContrHasRetract isEq ) = invIsEq isEq , retIsEq isEq
+snd ( isEquiv→isContrHasRetract { f = f } isEq ) ( g , η ) =
+ λ i → (λ b → p b i ) , (λ a → q a i )
+ where p : ∀ b → invIsEq isEq b ≡ g b
+ p b = sym ( η ( invIsEq isEq b )) ∙' cong g ( secIsEq isEq b )
+
+ ieSq : ∀ a → Square ( cong g ( secIsEq isEq ( f a )))
+ refl
+ ( cong ( g ∘ f ) ( retIsEq isEq a ))
+ refl
+ ieSq a k j = g ( commSqIsEq isEq a k j )
+
+ ηSq : ∀ a → Square ( η ( invIsEq isEq ( f a )))
+ ( η a )
+ ( cong ( g ∘ f ) ( retIsEq isEq a ))
+ ( retIsEq isEq a )
+ ηSq a i j = η ( retIsEq isEq a i ) j
+
+ pSq : ∀ b → Square ( η ( invIsEq isEq b ))
+ refl
+ ( cong g ( secIsEq isEq b ))
+ ( p b )
+ pSq b i j = compPath'-filler ( sym ( η ( invIsEq isEq b ))) ( cong g ( secIsEq isEq b )) j i
+ q : ∀ a → Square ( retIsEq isEq a ) ( η a ) ( p ( f a )) refl
+ q a i j = hcomp (λ k → λ { ( i = i0 ) → ηSq a j k
+ ; ( i = i1 ) → η a ( j ∧ k )
+ ; ( j = i0 ) → pSq ( f a ) i k
+ ; ( j = i1 ) → η a k
+ })
+ ( ieSq a j i )
+
+isEquiv→hasRetract : { f : A → B } → isEquiv f → hasRetract f
+isEquiv→hasRetract = fst ∘ isEquiv→isContrHasRetract
+
+isContr-hasRetract : ( e : A ≃ B ) → isContr ( hasRetract ( fst e ))
+isContr-hasRetract e = isEquiv→isContrHasRetract ( snd e )
+
+isEquiv→retractIsEquiv : { f : A → B } { g : B → A } → isEquiv f → retract f g → isEquiv g
+isEquiv→retractIsEquiv { f = f } { g = g } isEquiv-f retract-g = subst isEquiv f⁻¹≡g ( snd f⁻¹ )
+ where f⁻¹ = invEquiv ( f , isEquiv-f )
+
+ retract-f⁻¹ : retract f ( fst f⁻¹ )
+ retract-f⁻¹ = snd ( isEquiv→hasRetract isEquiv-f )
+
+ f⁻¹≡g : fst f⁻¹ ≡ g
+ f⁻¹≡g =
+ cong fst
+ ( isContr→isProp ( isEquiv→isContrHasRetract isEquiv-f )
+ ( fst f⁻¹ , retract-f⁻¹ )
+ ( g , retract-g ))
+
+
+isEquiv→sectionIsEquiv : { f : A → B } { g : B → A } → isEquiv f → section f g → isEquiv g
+isEquiv→sectionIsEquiv { f = f } { g = g } isEquiv-f section-g = subst isEquiv f⁻¹≡g ( snd f⁻¹ )
+ where f⁻¹ = invEquiv ( f , isEquiv-f )
+
+ section-f⁻¹ : section f ( fst f⁻¹ )
+ section-f⁻¹ = snd ( isEquiv→hasSection isEquiv-f )
+
+ f⁻¹≡g : fst f⁻¹ ≡ g
+ f⁻¹≡g =
+ cong fst
+ ( isContr→isProp ( isEquiv→isContrHasSection isEquiv-f )
+ ( fst f⁻¹ , section-f⁻¹ )
+ ( g , section-g ))
+
+cong≃ : ( F : Type ℓ → Type ℓ' ) → ( A ≃ B ) → F A ≃ F B
+cong≃ F e = pathToEquiv ( cong F ( ua e ))
+
+cong≃-char : ( F : Type ℓ → Type ℓ' ) { A B : Type ℓ } ( e : A ≃ B ) → ua ( cong≃ F e ) ≡ cong F ( ua e )
+cong≃-char F e = ua-pathToEquiv ( cong F ( ua e ))
+
+cong≃-idEquiv : ( F : Type ℓ → Type ℓ' ) ( A : Type ℓ ) → cong≃ F ( idEquiv A ) ≡ idEquiv ( F A )
+cong≃-idEquiv F A = cong≃ F ( idEquiv A ) ≡⟨ cong (λ p → pathToEquiv ( cong F p )) uaIdEquiv ⟩
+ pathToEquiv refl ≡⟨ pathToEquivRefl ⟩
+ idEquiv ( F A ) ∎
+
+isPropIsHAEquiv : { f : A → B } → isProp ( isHAEquiv f )
+isPropIsHAEquiv { f = f } ishaef = goal ishaef where
+ equivF : isEquiv f
+ equivF = isHAEquiv→isEquiv ishaef
+
+ rCoh1 : ( sec : hasSection f ) → Type _
+ rCoh1 ( g , ε ) = Σ[ η ∈ retract f g ] ∀ x → cong f ( η x ) ≡ ε ( f x )
+
+ rCoh2 : ( sec : hasSection f ) → Type _
+ rCoh2 ( g , ε ) = Σ[ η ∈ retract f g ] ∀ x → Square ( ε ( f x )) refl ( cong f ( η x )) refl
+
+ rCoh3 : ( sec : hasSection f ) → Type _
+ rCoh3 ( g , ε ) = ∀ x → Σ[ ηx ∈ g ( f x ) ≡ x ] Square ( ε ( f x )) refl ( cong f ηx ) refl
+
+ rCoh4 : ( sec : hasSection f ) → Type _
+ rCoh4 ( g , ε ) = ∀ x → Path ( fiber f ( f x )) ( g ( f x ) , ε ( f x )) ( x , refl )
+
+ characterization : isHAEquiv f ≃ Σ _ rCoh4
+ characterization =
+ isHAEquiv f
+
+ ≃⟨ isoToEquiv ( iso (λ e → ( e . g , e . rinv ) , ( e . linv , e . com ))
+ (λ e → record { g = e . fst . fst ; rinv = e . fst . snd
+ ; linv = e . snd . fst ; com = e . snd . snd })
+ (λ _ → refl ) λ _ → refl ) ⟩
+ Σ _ rCoh1
+
+ ≃⟨ Σ-cong-equiv-snd (λ s → Σ-cong-equiv-snd
+ λ η → equivΠCod
+ λ x → compEquiv ( flipSquareEquiv { a₀₀ = f x }) ( invEquiv slideSquareEquiv )) ⟩
+ Σ _ rCoh2
+ ≃⟨ Σ-cong-equiv-snd (λ s → invEquiv Σ-Π-≃ ) ⟩
+ Σ _ rCoh3
+ ≃⟨ Σ-cong-equiv-snd (λ s → equivΠCod λ x → ΣPath≃PathΣ ) ⟩
+ Σ _ rCoh4
+ ■
+ where open isHAEquiv
+
+ goal : isProp ( isHAEquiv f )
+ goal = subst isProp ( sym ( ua characterization ))
+ ( isPropΣ ( isContr→isProp ( isEquiv→isContrHasSection equivF ))
+ λ s → isPropΠ λ x → isProp→isSet ( isContr→isProp ( equivF . equiv-proof ( f x ))) _ _)
+
+
+conjugatePathEquiv : { A : Type ℓ } { a b : A } ( p : a ≡ b ) → ( a ≡ a ) ≃ ( b ≡ b )
+conjugatePathEquiv p = compEquiv ( compPathrEquiv p ) ( compPathlEquiv ( sym p ))
+
+
+compr≡Equiv : { A : Type ℓ } { a b c : A } ( p q : a ≡ b ) ( r : b ≡ c ) → ( p ≡ q ) ≃ ( p ∙ r ≡ q ∙ r )
+compr≡Equiv p q r = congEquiv ((λ s → s ∙ r ) , compPathr-isEquiv r )
+
+
+compl≡Equiv : { A : Type ℓ } { a b c : A } ( p : a ≡ b ) ( q r : b ≡ c ) → ( q ≡ r ) ≃ ( p ∙ q ≡ p ∙ r )
+compl≡Equiv p q r = congEquiv ((λ s → p ∙ s ) , ( compPathl-isEquiv p ))
+
+isEquivFromIsContr : { A : Type ℓ } { B : Type ℓ' }
+ → ( f : A → B ) → isContr A → isContr B
+ → isEquiv f
+isEquivFromIsContr f isContrA isContrB =
+ subst isEquiv (λ i x → isContr→isProp isContrB ( fst B≃A x ) ( f x ) i ) ( snd B≃A )
+ where B≃A = isContr→Equiv isContrA isContrB
+
+isEquiv[f∘equivFunA≃B]→isEquiv[f] : { A : Type ℓ } { B : Type ℓ' } { C : Type ℓ'' }
+ → ( f : B → C ) ( A≃B : A ≃ B )
+ → isEquiv ( f ∘ equivFun A≃B )
+ → isEquiv f
+isEquiv[f∘equivFunA≃B]→isEquiv[f] f ( g , gIsEquiv ) f∘gIsEquiv =
+ precomposesToId→Equiv f _ w w'
+ where
+ w : f ∘ g ∘ equivFun ( invEquiv (_ , f∘gIsEquiv )) ≡ idfun _
+ w = ( cong fst ( invEquiv-is-linv (_ , f∘gIsEquiv )))
+
+ w' : isEquiv ( g ∘ equivFun ( invEquiv (_ , f∘gIsEquiv )))
+ w' = ( snd ( compEquiv ( invEquiv (_ , f∘gIsEquiv ) ) (_ , gIsEquiv )))
+
+isEquiv[equivFunA≃B∘f]→isEquiv[f] : { A : Type ℓ } { B : Type ℓ' } { C : Type ℓ'' }
+ → ( f : C → A ) ( A≃B : A ≃ B )
+ → isEquiv ( equivFun A≃B ∘ f )
+ → isEquiv f
+isEquiv[equivFunA≃B∘f]→isEquiv[f] f ( g , gIsEquiv ) g∘fIsEquiv =
+ composesToId→Equiv _ f w w'
+ where
+ w : equivFun ( invEquiv (_ , g∘fIsEquiv )) ∘ g ∘ f ≡ idfun _
+ w = ( cong fst ( invEquiv-is-rinv (_ , g∘fIsEquiv )))
+
+ w' : isEquiv ( equivFun ( invEquiv (_ , g∘fIsEquiv )) ∘ g )
+ w' = snd ( compEquiv (_ , gIsEquiv ) ( invEquiv (_ , g∘fIsEquiv )))
+
\ No newline at end of file
diff --git a/docs/Cubical.Foundations.Pointed.FunExt.html b/docs/Cubical.Foundations.Pointed.FunExt.html
new file mode 100644
index 0000000..af0e758
--- /dev/null
+++ b/docs/Cubical.Foundations.Pointed.FunExt.html
@@ -0,0 +1,50 @@
+
+Cubical.Foundations.Pointed.FunExt {-# OPTIONS --safe #-}
+module Cubical.Foundations.Pointed.FunExt where
+
+open import Cubical.Foundations.Prelude
+open import Cubical.Foundations.Isomorphism
+open import Cubical.Foundations.Equiv
+
+open import Cubical.Foundations.Pointed.Base
+open import Cubical.Foundations.Pointed.Properties
+open import Cubical.Foundations.Pointed.Homotopy
+
+private
+ variable
+ ℓ ℓ' : Level
+
+module _ { A : Pointed ℓ } { B : typ A → Type ℓ' } { ptB : B ( pt A )} where
+
+
+ funExt∙P : { f g : Π∙ A B ptB } → f ∙∼P g → f ≡ g
+ funExt∙P ( h , h∙ ) i . fst x = h x i
+ funExt∙P ( h , h∙ ) i . snd = h∙ i
+
+
+ funExt∙P⁻ : { f g : Π∙ A B ptB } → f ≡ g → f ∙∼P g
+ funExt∙P⁻ p . fst a i = p i . fst a
+ funExt∙P⁻ p . snd i = p i . snd
+
+
+ funExt∙PIso : ( f g : Π∙ A B ptB ) → Iso ( f ∙∼P g ) ( f ≡ g )
+ Iso.fun ( funExt∙PIso f g ) = funExt∙P { f = f } { g = g }
+ Iso.inv ( funExt∙PIso f g ) = funExt∙P⁻ { f = f } { g = g }
+ Iso.rightInv ( funExt∙PIso f g ) p i j = p j
+ Iso.leftInv ( funExt∙PIso f g ) h _ = h
+
+
+ funExt∙P≃ : ( f g : Π∙ A B ptB ) → ( f ∙∼P g ) ≃ ( f ≡ g )
+ funExt∙P≃ f g = isoToEquiv ( funExt∙PIso f g )
+
+
+ funExt∙≃ : ( f g : Π∙ A B ptB ) → ( f ∙∼ g ) ≃ ( f ≡ g )
+ funExt∙≃ f g = compEquiv ( ∙∼≃∙∼P f g ) ( funExt∙P≃ f g )
+
+
+ funExt∙ : { f g : Π∙ A B ptB } → f ∙∼ g → f ≡ g
+ funExt∙ { f = f } { g = g } = equivFun ( funExt∙≃ f g )
+
+ funExt∙⁻ : { f g : Π∙ A B ptB } → f ≡ g → f ∙∼ g
+ funExt∙⁻ { f = f } { g = g } = equivFun ( invEquiv ( funExt∙≃ f g ))
+Cubical.Foundations.Pointed.Homogeneous
+{-# OPTIONS --safe #-}
+module Cubical.Foundations.Pointed.Homogeneous where
+
+open import Cubical.Foundations.Prelude
+open import Cubical.Foundations.Equiv
+open import Cubical.Foundations.Isomorphism
+open import Cubical.Foundations.Univalence
+open import Cubical.Foundations.Path
+open import Cubical.Data.Sigma
+open import Cubical.Data.Empty as ⊥
+open import Cubical.Relation.Nullary
+
+open import Cubical.Foundations.GroupoidLaws
+open import Cubical.Foundations.Pointed.Base
+open import Cubical.Foundations.Pointed.Properties
+open import Cubical.Structures.Pointed
+
+
+isHomogeneous : ∀ { ℓ } → Pointed ℓ → Type ( ℓ-suc ℓ )
+isHomogeneous { ℓ } ( A , x ) = ∀ y → Path ( Pointed ℓ ) ( A , x ) ( A , y )
+
+
+
+→∙Homogeneous≡ : ∀ { ℓ ℓ' } { A∙ : Pointed ℓ } { B∙ : Pointed ℓ' } { f∙ g∙ : A∙ →∙ B∙ }
+ ( h : isHomogeneous B∙ ) → f∙ . fst ≡ g∙ . fst → f∙ ≡ g∙
+→∙Homogeneous≡ { A∙ = A∙ @(_ , a₀ )} { B∙ @( B , _)} { f∙ @(_ , f₀ )} { g∙ @(_ , g₀ )} h p =
+ subst (λ Q∙ → PathP (λ i → A∙ →∙ Q∙ i ) f∙ g∙ ) ( sym ( flipSquare fix )) badPath
+ where
+ badPath : PathP (λ i → A∙ →∙ ( B , ( sym f₀ ∙∙ funExt⁻ p a₀ ∙∙ g₀ ) i )) f∙ g∙
+ badPath i . fst = p i
+ badPath i . snd j = doubleCompPath-filler ( sym f₀ ) ( funExt⁻ p a₀ ) g₀ j i
+
+ fix : PathP (λ i → B∙ ≡ ( B , ( sym f₀ ∙∙ funExt⁻ p a₀ ∙∙ g₀ ) i )) refl refl
+ fix i =
+ hcomp
+ (λ j → λ
+ { ( i = i0 ) → lCancel ( h ( pt B∙ )) j
+ ; ( i = i1 ) → lCancel ( h ( pt B∙ )) j
+ })
+ ( sym ( h ( pt B∙ )) ∙ h (( sym f₀ ∙∙ funExt⁻ p a₀ ∙∙ g₀ ) i ))
+
+→∙Homogeneous≡Path : ∀ { ℓ ℓ' } { A∙ : Pointed ℓ } { B∙ : Pointed ℓ' } { f∙ g∙ : A∙ →∙ B∙ }
+ ( h : isHomogeneous B∙ ) → ( p q : f∙ ≡ g∙ ) → cong fst p ≡ cong fst q → p ≡ q
+→∙Homogeneous≡Path { A∙ = A∙ @( A , a₀ )} { B∙ @( B , b )} { f∙ @( f , f₀ )} { g∙ @( g , g₀ )} h p q r =
+ transport (λ k
+ → PathP (λ i
+ → PathP (λ j → ( A , a₀ ) →∙ newPath-refl p q r i j ( ~ k ))
+ ( f , f₀ ) ( g , g₀ )) p q )
+ ( badPath p q r )
+ where
+ newPath : ( p q : f∙ ≡ g∙ ) ( r : cong fst p ≡ cong fst q )
+ → Square ( refl { x = b }) refl refl refl
+ newPath p q r i j =
+ hcomp (λ k → λ {( i = i0 ) → cong snd p j k
+ ; ( i = i1 ) → cong snd q j k
+ ; ( j = i0 ) → f₀ k
+ ; ( j = i1 ) → g₀ k })
+ ( r i j a₀ )
+
+ newPath-refl : ( p q : f∙ ≡ g∙ ) ( r : cong fst p ≡ cong fst q )
+ → PathP (λ i → ( PathP (λ j → B∙ ≡ ( B , newPath p q r i j ))) refl refl ) refl refl
+ newPath-refl p q r i j k =
+ hcomp (λ w → λ { ( i = i0 ) → lCancel ( h b ) w k
+ ; ( i = i1 ) → lCancel ( h b ) w k
+ ; ( j = i0 ) → lCancel ( h b ) w k
+ ; ( j = i1 ) → lCancel ( h b ) w k
+ ; ( k = i0 ) → lCancel ( h b ) w k
+ ; ( k = i1 ) → B , newPath p q r i j })
+ (( sym ( h b ) ∙ h ( newPath p q r i j )) k )
+
+ badPath : ( p q : f∙ ≡ g∙ ) ( r : cong fst p ≡ cong fst q )
+ → PathP (λ i →
+ PathP (λ j → A∙ →∙ ( B , newPath p q r i j ))
+ ( f , f₀ ) ( g , g₀ ))
+ p q
+ fst ( badPath p q r i j ) = r i j
+ snd ( badPath p q s i j ) k =
+ hcomp (λ r → λ { ( i = i0 ) → snd ( p j ) ( r ∧ k )
+ ; ( i = i1 ) → snd ( q j ) ( r ∧ k )
+ ; ( j = i0 ) → f₀ ( k ∧ r )
+ ; ( j = i1 ) → g₀ ( k ∧ r )
+ ; ( k = i0 ) → s i j a₀ })
+ ( s i j a₀ )
+
+→∙HomogeneousSquare : ∀ { ℓ ℓ' } { A∙ : Pointed ℓ } { B∙ : Pointed ℓ' } { f∙ g∙ h∙ l∙ : A∙ →∙ B∙ }
+ ( h : isHomogeneous B∙ ) → ( s : f∙ ≡ h∙ ) ( t : g∙ ≡ l∙ ) ( p : f∙ ≡ g∙ ) ( q : h∙ ≡ l∙ )
+ → Square ( cong fst p ) ( cong fst q ) ( cong fst s ) ( cong fst t )
+ → Square p q s t
+→∙HomogeneousSquare { f∙ = f∙ } { g∙ = g∙ } { h∙ = h∙ } { l∙ = l∙ } h =
+ J (λ h∙ s → ( t : g∙ ≡ l∙ ) ( p : f∙ ≡ g∙ ) ( q : h∙ ≡ l∙ ) →
+ Square ( cong fst p ) ( cong fst q ) ( cong fst s ) ( cong fst t ) →
+ Square p q s t )
+ ( J (λ l∙ t → ( p : f∙ ≡ g∙ ) ( q : f∙ ≡ l∙ )
+ → Square ( cong fst p ) ( cong fst q ) refl ( cong fst t )
+ → Square p q refl t )
+ ( →∙Homogeneous≡Path { f∙ = f∙ } { g∙ = g∙ } h ))
+
+isHomogeneousPi : ∀ { ℓ ℓ' } { A : Type ℓ } { B∙ : A → Pointed ℓ' }
+ → (∀ a → isHomogeneous ( B∙ a )) → isHomogeneous ( Πᵘ∙ A B∙ )
+isHomogeneousPi h f i . fst = ∀ a → typ ( h a ( f a ) i )
+isHomogeneousPi h f i . snd a = pt ( h a ( f a ) i )
+
+isHomogeneousΠ∙ : ∀ { ℓ ℓ' } ( A : Pointed ℓ ) ( B : typ A → Type ℓ' )
+ → ( b₀ : B ( pt A ))
+ → (( a : typ A ) ( x : B a ) → isHomogeneous ( B a , x ))
+ → ( f : Π∙ A B b₀ )
+ → isHomogeneous ( Π∙ A B b₀ , f )
+fst ( isHomogeneousΠ∙ A B b₀ h f g i ) =
+ Σ[ r ∈ (( a : typ A ) → fst (( h a ( fst f a ) ( fst g a )) i )) ]
+ r ( pt A ) ≡ hcomp (λ k → λ {( i = i0 ) → snd f k
+ ; ( i = i1 ) → snd g k })
+ ( snd ( h ( pt A ) ( fst f ( pt A )) ( fst g ( pt A )) i ))
+snd ( isHomogeneousΠ∙ A B b₀ h f g i ) =
+ (λ a → snd ( h a ( fst f a ) ( fst g a ) i ))
+ , λ j → hcomp (λ k → λ { ( i = i0 ) → snd f ( k ∧ j )
+ ; ( i = i1 ) → snd g ( k ∧ j )
+ ; ( j = i0 ) → snd ( h ( pt A ) ( fst f ( pt A ))
+ ( fst g ( pt A )) i )})
+ ( snd ( h ( pt A ) ( fst f ( pt A )) ( fst g ( pt A )) i ))
+
+isHomogeneous→∙ : ∀ { ℓ ℓ' } { A∙ : Pointed ℓ } { B∙ : Pointed ℓ' }
+ → isHomogeneous B∙ → isHomogeneous ( A∙ →∙ B∙ ∙ )
+isHomogeneous→∙ { A∙ = A∙ } { B∙ } h f∙ =
+ ΣPathP
+ ( (λ i → Π∙ A∙ (λ a → T a i ) ( t₀ i ))
+ , PathPIsoPath _ _ _ . Iso.inv
+ ( →∙Homogeneous≡ h
+ ( PathPIsoPath (λ i → ( a : typ A∙ ) → T a i ) (λ _ → pt B∙ ) _ . Iso.fun
+ (λ i a → pt ( h ( f∙ . fst a ) i ))))
+ )
+ where
+ T : ∀ a → typ B∙ ≡ typ B∙
+ T a i = typ ( h ( f∙ . fst a ) i )
+
+ t₀ : PathP (λ i → T ( pt A∙ ) i ) ( pt B∙ ) ( pt B∙ )
+ t₀ = cong pt ( h ( f∙ . fst ( pt A∙ ))) ▷ f∙ . snd
+
+isHomogeneousProd : ∀ { ℓ ℓ' } { A∙ : Pointed ℓ } { B∙ : Pointed ℓ' }
+ → isHomogeneous A∙ → isHomogeneous B∙ → isHomogeneous ( A∙ ×∙ B∙ )
+isHomogeneousProd hA hB ( a , b ) i . fst = typ ( hA a i ) × typ ( hB b i )
+isHomogeneousProd hA hB ( a , b ) i . snd . fst = pt ( hA a i )
+isHomogeneousProd hA hB ( a , b ) i . snd . snd = pt ( hB b i )
+
+isHomogeneousPath : ∀ { ℓ } ( A : Type ℓ ) { x y : A } ( p : x ≡ y ) → isHomogeneous (( x ≡ y ) , p )
+isHomogeneousPath A { x } { y } p q
+ = pointed-sip (( x ≡ y ) , p ) (( x ≡ y ) , q ) ( eqv , compPathr-cancel p q )
+ where eqv : ( x ≡ y ) ≃ ( x ≡ y )
+ eqv = compPathlEquiv ( q ∙ sym p )
+
+module HomogeneousDiscrete { ℓ } { A∙ : Pointed ℓ } ( dA : Discrete ( typ A∙ )) ( y : typ A∙ ) where
+
+
+ switch : typ A∙ → typ A∙
+ switch x with dA x ( pt A∙ )
+ ... | yes _ = y
+ ... | no _ with dA x y
+ ... | yes _ = pt A∙
+ ... | no _ = x
+
+ switch-ptA∙ : switch ( pt A∙ ) ≡ y
+ switch-ptA∙ with dA ( pt A∙ ) ( pt A∙ )
+ ... | yes _ = refl
+ ... | no ¬p = ⊥.rec ( ¬p refl )
+
+ switch-idp : ∀ x → switch ( switch x ) ≡ x
+ switch-idp x with dA x ( pt A∙ )
+ switch-idp x | yes p with dA y ( pt A∙ )
+ switch-idp x | yes p | yes q = q ∙ sym p
+ switch-idp x | yes p | no _ with dA y y
+ switch-idp x | yes p | no _ | yes _ = sym p
+ switch-idp x | yes p | no _ | no ¬p = ⊥.rec ( ¬p refl )
+ switch-idp x | no ¬p with dA x y
+ switch-idp x | no ¬p | yes p with dA y ( pt A∙ )
+ switch-idp x | no ¬p | yes p | yes q = ⊥.rec ( ¬p ( p ∙ q ))
+ switch-idp x | no ¬p | yes p | no _ with dA ( pt A∙ ) ( pt A∙ )
+ switch-idp x | no ¬p | yes p | no _ | yes _ = sym p
+ switch-idp x | no ¬p | yes p | no _ | no ¬q = ⊥.rec ( ¬q refl )
+ switch-idp x | no ¬p | no ¬q with dA x ( pt A∙ )
+ switch-idp x | no ¬p | no ¬q | yes p = ⊥.rec ( ¬p p )
+ switch-idp x | no ¬p | no ¬q | no _ with dA x y
+ switch-idp x | no ¬p | no ¬q | no _ | yes q = ⊥.rec ( ¬q q )
+ switch-idp x | no ¬p | no ¬q | no _ | no _ = refl
+
+ switch-eqv : typ A∙ ≃ typ A∙
+ switch-eqv = isoToEquiv ( iso switch switch switch-idp switch-idp )
+
+isHomogeneousDiscrete : ∀ { ℓ } { A∙ : Pointed ℓ } ( dA : Discrete ( typ A∙ )) → isHomogeneous A∙
+isHomogeneousDiscrete { ℓ } { A∙ } dA y
+ = pointed-sip ( typ A∙ , pt A∙ ) ( typ A∙ , y ) ( switch-eqv , switch-ptA∙ )
+ where open HomogeneousDiscrete { ℓ } { A∙ } dA y
+
\ No newline at end of file
diff --git a/docs/Cubical.Foundations.Pointed.Homotopy.html b/docs/Cubical.Foundations.Pointed.Homotopy.html
new file mode 100644
index 0000000..ee5bf81
--- /dev/null
+++ b/docs/Cubical.Foundations.Pointed.Homotopy.html
@@ -0,0 +1,121 @@
+
+Cubical.Foundations.Pointed.Homotopy {-# OPTIONS --safe #-}
+module Cubical.Foundations.Pointed.Homotopy where
+
+
+
+open import Cubical.Foundations.Prelude
+open import Cubical.Foundations.GroupoidLaws
+open import Cubical.Foundations.Isomorphism
+open import Cubical.Foundations.Equiv
+open import Cubical.Foundations.Equiv.Fiberwise
+open import Cubical.Foundations.Equiv.Properties
+open import Cubical.Foundations.Path
+open import Cubical.Foundations.Transport
+open import Cubical.Foundations.Univalence
+open import Cubical.Foundations.Pointed.Base
+open import Cubical.Foundations.Pointed.Properties
+open import Cubical.Homotopy.Base
+open import Cubical.Data.Sigma
+
+private
+ variable
+ ℓ ℓ' : Level
+
+module _ { A : Pointed ℓ } { B : typ A → Type ℓ' } { ptB : B ( pt A )} where
+
+ ⋆ = pt A
+
+
+ _∙∼_ : ( f g : Π∙ A B ptB ) → Type ( ℓ-max ℓ ℓ' )
+ ( f₁ , f₂ ) ∙∼ ( g₁ , g₂ ) = Π∙ A (λ x → f₁ x ≡ g₁ x ) ( f₂ ∙ g₂ ⁻¹ )
+
+
+ _∙∼P_ : ( f g : Π∙ A B ptB ) → Type ( ℓ-max ℓ ℓ' )
+ ( f₁ , f₂ ) ∙∼P ( g₁ , g₂ ) = Σ[ h ∈ f₁ ∼ g₁ ] PathP (λ i → h ⋆ i ≡ ptB ) f₂ g₂
+
+
+
+ private
+ module _ ( f g : Π∙ A B ptB ) ( H : f . fst ∼ g . fst ) where
+
+ f₁ = fst f
+ f₂ = snd f
+ g₁ = fst g
+ g₂ = snd g
+
+
+ P : Type ℓ'
+ P = H ⋆ ≡ f₂ ∙ g₂ ⁻¹
+
+
+ Q : Type ℓ'
+ Q = PathP (λ i → H ⋆ i ≡ ptB ) f₂ g₂
+
+
+
+ p = H ⋆
+ r = f₂
+ s = g₂
+ P≡Q : P ≡ Q
+ P≡Q = p ≡ r ∙ s ⁻¹
+ ≡⟨ isoToPath symIso ⟩
+ r ∙ s ⁻¹ ≡ p
+ ≡⟨ cong ( r ∙ s ⁻¹ ≡_ ) ( rUnit p ∙∙ cong ( p ∙_ ) ( sym ( rCancel s )) ∙∙ assoc p s ( s ⁻¹ )) ⟩
+ r ∙ s ⁻¹ ≡ ( p ∙ s ) ∙ s ⁻¹
+ ≡⟨ sym ( ua ( compr≡Equiv r ( p ∙ s ) ( s ⁻¹ ))) ⟩
+ r ≡ p ∙ s
+ ≡⟨ ua ( compl≡Equiv ( p ⁻¹ ) r ( p ∙ s )) ⟩
+ p ⁻¹ ∙ r ≡ p ⁻¹ ∙ ( p ∙ s )
+ ≡⟨ cong ( p ⁻¹ ∙ r ≡_ ) ( assoc ( p ⁻¹ ) p s ∙∙ ( cong ( _∙ s ) ( lCancel p )) ∙∙ sym ( lUnit s )) ⟩
+ p ⁻¹ ∙ r ≡ s
+ ≡⟨ cong (λ z → p ⁻¹ ∙ z ≡ s ) ( rUnit r ) ⟩
+ p ⁻¹ ∙ ( r ∙ refl ) ≡ s
+ ≡⟨ cong ( _≡ s ) ( sym ( doubleCompPath-elim' ( p ⁻¹ ) r refl )) ⟩
+ p ⁻¹ ∙∙ r ∙∙ refl ≡ s
+ ≡⟨ sym ( ua ( Square≃doubleComp r s p refl )) ⟩
+ PathP (λ i → p i ≡ ptB ) r s ∎
+
+
+
+ φ : P → Q
+ φ = transport P≡Q
+
+
+ totφ : ( f g : Π∙ A B ptB ) → f ∙∼ g → f ∙∼P g
+ totφ f g p . fst = p . fst
+ totφ f g p . snd = φ f g ( p . fst ) ( p . snd )
+
+
+ ∙∼→∙∼P : ( f g : Π∙ A B ptB ) → ( f ∙∼ g ) → ( f ∙∼P g )
+ ∙∼→∙∼P f g = totφ f g
+
+
+ ∙∼≃∙∼P : ( f g : Π∙ A B ptB ) → ( f ∙∼ g ) ≃ ( f ∙∼P g )
+ ∙∼≃∙∼P f g = Σ-cong-equiv-snd (λ H → pathToEquiv ( P≡Q f g H ))
+
+
+ ∙∼P→∙∼ : { f g : Π∙ A B ptB } → f ∙∼P g → f ∙∼ g
+ ∙∼P→∙∼ { f = f } { g = g } = invEq ( ∙∼≃∙∼P f g )
+
+
+ ∙∼≡∙∼P : ( f g : Π∙ A B ptB ) → ( f ∙∼ g ) ≡ ( f ∙∼P g )
+ ∙∼≡∙∼P f g = ua ( ∙∼≃∙∼P f g )
+
+
+
+ _∙∼Σ_ : ( f g : Π∙ A B ptB ) → Type ( ℓ-max ℓ ℓ' )
+ f ∙∼Σ g = Σ[ H ∈ f . fst ∼ g . fst ] ( P f g H )
+
+ _∙∼PΣ_ : ( f g : Π∙ A B ptB ) → Type ( ℓ-max ℓ ℓ' )
+ f ∙∼PΣ g = Σ[ H ∈ f . fst ∼ g . fst ] ( Q f g H )
+
+ ∙∼≡∙∼Σ : ( f g : Π∙ A B ptB ) → f ∙∼ g ≡ f ∙∼Σ g
+ ∙∼≡∙∼Σ f g = refl
+
+ ∙∼P≡∙∼PΣ : ( f g : Π∙ A B ptB ) → f ∙∼P g ≡ f ∙∼PΣ g
+ ∙∼P≡∙∼PΣ f g = refl
+Cubical.Foundations.Pointed.Properties {-# OPTIONS --safe #-}
+module Cubical.Foundations.Pointed.Properties where
+
+open import Cubical.Foundations.Prelude
+open import Cubical.Foundations.Pointed.Base
+open import Cubical.Foundations.Function
+open import Cubical.Foundations.GroupoidLaws
+open import Cubical.Foundations.Isomorphism
+open import Cubical.Foundations.Equiv
+open import Cubical.Foundations.Isomorphism
+
+open import Cubical.Data.Sigma
+
+private
+ variable
+ ℓ ℓ' ℓA ℓB ℓC ℓD : Level
+
+
+Π∙ : ( A : Pointed ℓ ) ( B : typ A → Type ℓ' ) ( ptB : B ( pt A )) → Type ( ℓ-max ℓ ℓ' )
+Π∙ A B ptB = Σ[ f ∈ (( a : typ A ) → B a ) ] f ( pt A ) ≡ ptB
+
+
+Πᵘ∙ : ( A : Type ℓ ) ( B : A → Pointed ℓ' ) → Pointed ( ℓ-max ℓ ℓ' )
+Πᵘ∙ A B . fst = ∀ a → typ ( B a )
+Πᵘ∙ A B . snd a = pt ( B a )
+
+
+Πᵖ∙ : ( A : Pointed ℓ ) ( B : typ A → Pointed ℓ' ) → Pointed ( ℓ-max ℓ ℓ' )
+Πᵖ∙ A B . fst = Π∙ A ( typ ∘ B ) ( pt ( B ( pt A )))
+Πᵖ∙ A B . snd . fst a = pt ( B a )
+Πᵖ∙ A B . snd . snd = refl
+
+
+Σ∙ : ( A : Pointed ℓ ) ( B : typ A → Type ℓ' ) ( ptB : B ( pt A )) → Pointed ( ℓ-max ℓ ℓ' )
+Σ∙ A B ptB . fst = Σ[ a ∈ typ A ] B a
+Σ∙ A B ptB . snd . fst = pt A
+Σ∙ A B ptB . snd . snd = ptB
+
+
+Σᵖ∙ : ( A : Pointed ℓ ) ( B : typ A → Pointed ℓ' ) → Pointed ( ℓ-max ℓ ℓ' )
+Σᵖ∙ A B = Σ∙ A ( typ ∘ B ) ( pt ( B ( pt A )))
+
+_×∙_ : ( A∙ : Pointed ℓ ) ( B∙ : Pointed ℓ' ) → Pointed ( ℓ-max ℓ ℓ' )
+( A∙ ×∙ B∙ ) . fst = ( typ A∙ ) × ( typ B∙ )
+( A∙ ×∙ B∙ ) . snd . fst = pt A∙
+( A∙ ×∙ B∙ ) . snd . snd = pt B∙
+
+
+_∘∙_ : { A : Pointed ℓA } { B : Pointed ℓB } { C : Pointed ℓC }
+ ( g : B →∙ C ) ( f : A →∙ B ) → ( A →∙ C )
+(( g , g∙ ) ∘∙ ( f , f∙ )) . fst x = g ( f x )
+(( g , g∙ ) ∘∙ ( f , f∙ )) . snd = ( cong g f∙ ) ∙ g∙
+
+
+post∘∙ : ∀ { ℓX ℓ ℓ' } ( X : Pointed ℓX ) { A : Pointed ℓ } { B : Pointed ℓ' }
+ → ( A →∙ B ) → (( X →∙ A ∙ ) →∙ ( X →∙ B ∙ ))
+post∘∙ X f . fst g = f ∘∙ g
+post∘∙ X f . snd =
+ ΣPathP
+ ( ( funExt λ _ → f . snd )
+ , ( sym ( lUnit ( f . snd )) ◁ λ i j → f . snd ( i ∨ j )))
+
+
+id∙ : ( A : Pointed ℓA ) → ( A →∙ A )
+id∙ A . fst x = x
+id∙ A . snd = refl
+
+
+const∙ : ( A : Pointed ℓA ) ( B : Pointed ℓB ) → ( A →∙ B )
+const∙ _ B . fst _ = B . snd
+const∙ _ B . snd = refl
+
+
+∘∙-idˡ : { A : Pointed ℓA } { B : Pointed ℓB } ( f : A →∙ B ) → f ∘∙ id∙ A ≡ f
+∘∙-idˡ f = ΣPathP ( refl , ( lUnit ( f . snd )) ⁻¹ )
+
+
+∘∙-idʳ : { A : Pointed ℓA } { B : Pointed ℓB } ( f : A →∙ B ) → id∙ B ∘∙ f ≡ f
+∘∙-idʳ f = ΣPathP ( refl , ( rUnit ( f . snd )) ⁻¹ )
+
+
+∘∙-assoc : { A : Pointed ℓA } { B : Pointed ℓB } { C : Pointed ℓC } { D : Pointed ℓD }
+ ( h : C →∙ D ) ( g : B →∙ C ) ( f : A →∙ B )
+ → ( h ∘∙ g ) ∘∙ f ≡ h ∘∙ ( g ∘∙ f )
+∘∙-assoc ( h , h∙ ) ( g , g∙ ) ( f , f∙ ) = ΣPathP ( refl , q )
+ where
+ q : ( cong ( h ∘ g ) f∙ ) ∙ ( cong h g∙ ∙ h∙ ) ≡ cong h ( cong g f∙ ∙ g∙ ) ∙ h∙
+ q = ( ( cong ( h ∘ g ) f∙ ) ∙ ( cong h g∙ ∙ h∙ )
+ ≡⟨ refl ⟩
+ ( cong h ( cong g f∙ )) ∙ ( cong h g∙ ∙ h∙ )
+ ≡⟨ assoc ( cong h ( cong g f∙ )) ( cong h g∙ ) h∙ ⟩
+ ( cong h ( cong g f∙ ) ∙ cong h g∙ ) ∙ h∙
+ ≡⟨ cong (λ p → p ∙ h∙ ) (( cong-∙ h ( cong g f∙ ) g∙ ) ⁻¹ ) ⟩
+ ( cong h ( cong g f∙ ∙ g∙ ) ∙ h∙ ) ∎ )
+
+module _ { ℓ ℓ' : Level } { A : Pointed ℓ } { B : Pointed ℓ' } ( f : A →∙ B ) where
+ isInIm∙ : ( x : typ B ) → Type ( ℓ-max ℓ ℓ' )
+ isInIm∙ x = Σ[ z ∈ typ A ] fst f z ≡ x
+
+ isInKer∙ : ( x : fst A ) → Type ℓ'
+ isInKer∙ x = fst f x ≡ snd B
+
+pre∘∙equiv : ∀ { ℓ ℓ' } { A : Pointed ℓ } { B C : Pointed ℓ' }
+ → ( B ≃∙ C ) → Iso ( A →∙ B ) ( A →∙ C )
+pre∘∙equiv { A = A } { B = B } { C = C } eq = main
+ where
+ module _ { ℓ ℓ' : Level } ( A : Pointed ℓ ) ( B C : Pointed ℓ' )
+ ( eq : ( B ≃∙ C )) where
+ to : ( A →∙ B ) → ( A →∙ C )
+ to = ≃∙map eq ∘∙_
+
+ from : ( A →∙ C ) → ( A →∙ B )
+ from = ≃∙map ( invEquiv∙ eq ) ∘∙_
+
+ lem : { ℓ : Level } { B : Pointed ℓ }
+ → ≃∙map ( invEquiv∙ { A = B } (( idEquiv ( fst B )) , refl )) ≡ id∙ B
+ lem = ΣPathP ( refl , ( sym ( lUnit _)))
+
+ J-lem : { ℓ ℓ' : Level } { A : Pointed ℓ } { B C : Pointed ℓ' }
+ → ( eq : ( B ≃∙ C ))
+ → retract ( to A B C eq ) ( from _ _ _ eq )
+ × section ( to A B C eq ) ( from _ _ _ eq )
+ J-lem { A = A } { B = B } { C = C } =
+ Equiv∙J (λ B eq → retract ( to A B C eq ) ( from _ _ _ eq )
+ × section ( to A B C eq ) ( from _ _ _ eq ))
+ ((λ f → ((λ i → ( lem i ∘∙ ( id∙ C ∘∙ f )))
+ ∙ λ i → ∘∙-idʳ ( ∘∙-idʳ f i ) i ))
+ , λ f → ((λ i → ( id∙ C ∘∙ ( lem i ∘∙ f )))
+ ∙ λ i → ∘∙-idʳ ( ∘∙-idʳ f i ) i ))
+
+ main : Iso ( A →∙ B ) ( A →∙ C )
+ Iso.fun main = to A B C eq
+ Iso.inv main = from A B C eq
+ Iso.rightInv main = J-lem eq . snd
+ Iso.leftInv main = J-lem eq . fst
+
+post∘∙equiv : ∀ { ℓ ℓC } { A B : Pointed ℓ } { C : Pointed ℓC }
+ → ( A ≃∙ B ) → Iso ( A →∙ C ) ( B →∙ C )
+post∘∙equiv { A = A } { B = B } { C = C } eq = main
+ where
+ module _ { ℓ ℓC : Level } ( A B : Pointed ℓ ) ( C : Pointed ℓC )
+ ( eq : ( A ≃∙ B )) where
+ to : ( A →∙ C ) → ( B →∙ C )
+ to = _∘∙ ≃∙map ( invEquiv∙ eq )
+
+ from : ( B →∙ C ) → ( A →∙ C )
+ from = _∘∙ ≃∙map eq
+
+ lem : { ℓ : Level } { B : Pointed ℓ }
+ → ≃∙map ( invEquiv∙ { A = B } (( idEquiv ( fst B )) , refl )) ≡ id∙ B
+ lem = ΣPathP ( refl , ( sym ( lUnit _)))
+
+ J-lem : { ℓ ℓC : Level } { A B : Pointed ℓ } { C : Pointed ℓC }
+ → ( eq : ( A ≃∙ B ))
+ → retract ( to A B C eq ) ( from _ _ _ eq )
+ × section ( to A B C eq ) ( from _ _ _ eq )
+ J-lem { B = B } { C = C } =
+ Equiv∙J (λ A eq → retract ( to A B C eq ) ( from _ _ _ eq )
+ × section ( to A B C eq ) ( from _ _ _ eq ))
+ ((λ f → ((λ i → ( f ∘∙ lem i ) ∘∙ id∙ B )
+ ∙ λ i → ∘∙-idˡ ( ∘∙-idˡ f i ) i ))
+ , λ f → (λ i → ( f ∘∙ id∙ B ) ∘∙ lem i )
+ ∙ λ i → ∘∙-idˡ ( ∘∙-idˡ f i ) i )
+
+ main : Iso ( A →∙ C ) ( B →∙ C )
+ Iso.fun main = to A B C eq
+ Iso.inv main = from A B C eq
+ Iso.rightInv main = J-lem eq . snd
+ Iso.leftInv main = J-lem eq . fst
+
+flip→∙∙ : { A : Pointed ℓ } { B : Pointed ℓ' } { C : Pointed ℓA }
+ → ( A →∙ ( B →∙ C ∙ )) → B →∙ ( A →∙ C ∙ )
+fst ( fst ( flip→∙∙ f ) x ) a = fst f a . fst x
+snd ( fst ( flip→∙∙ f ) x ) i = snd f i . fst x
+fst ( snd ( flip→∙∙ f ) i ) a = fst f a . snd i
+snd ( snd ( flip→∙∙ f ) i ) j = snd f j . snd i
+
+flip→∙∙Iso : { A : Pointed ℓ } { B : Pointed ℓ' } { C : Pointed ℓA }
+ → Iso ( A →∙ ( B →∙ C ∙ )) ( B →∙ ( A →∙ C ∙ ))
+Iso.fun flip→∙∙Iso = flip→∙∙
+Iso.inv flip→∙∙Iso = flip→∙∙
+Iso.rightInv flip→∙∙Iso _ = refl
+Iso.leftInv flip→∙∙Iso _ = refl
+
+≃∙→ret/sec∙ : ∀ { ℓ } { A B : Pointed ℓ }
+ ( f : A ≃∙ B ) → (( ≃∙map ( invEquiv∙ f ) ∘∙ ≃∙map f ) ≡ idfun∙ A )
+ × ( ≃∙map f ∘∙ ≃∙map ( invEquiv∙ f ) ≡ idfun∙ B )
+≃∙→ret/sec∙ { A = A } { B = B } =
+ Equiv∙J (λ A f → (( ≃∙map ( invEquiv∙ f ) ∘∙ ≃∙map f ) ≡ idfun∙ A )
+ × ( ≃∙map f ∘∙ ≃∙map ( invEquiv∙ f ) ≡ idfun∙ B ))
+ (( ΣPathP ( refl , sym ( lUnit _) ∙ sym ( rUnit refl )))
+ , ( ΣPathP ( refl , sym ( rUnit _) ∙ sym ( rUnit refl ))))
+Cubical.Foundations.Pointed {-# OPTIONS --safe #-}
+module Cubical.Foundations.Pointed where
+
+open import Cubical.Foundations.Pointed.Base public
+open import Cubical.Foundations.Pointed.Properties public
+open import Cubical.Foundations.Pointed.FunExt public
+open import Cubical.Foundations.Pointed.Homotopy public
+
+open import Cubical.Foundations.Pointed.Homogeneous
+Cubical.Foundations.Powerset
+{-# OPTIONS --safe #-}
+module Cubical.Foundations.Powerset 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.Structure
+open import Cubical.Foundations.Function
+open import Cubical.Foundations.Univalence using ( hPropExt )
+
+open import Cubical.Data.Sigma
+
+private
+ variable
+ ℓ : Level
+ X : Type ℓ
+
+ℙ : Type ℓ → Type ( ℓ-suc ℓ )
+ℙ X = X → hProp _
+
+isSetℙ : isSet ( ℙ X )
+isSetℙ = isSetΠ λ x → isSetHProp
+
+infix 5 _∈_
+
+_∈_ : { X : Type ℓ } → X → ℙ X → Type ℓ
+x ∈ A = ⟨ A x ⟩
+
+_⊆_ : { X : Type ℓ } → ℙ X → ℙ X → Type ℓ
+A ⊆ B = ∀ x → x ∈ A → x ∈ B
+
+∈-isProp : ( A : ℙ X ) ( x : X ) → isProp ( x ∈ A )
+∈-isProp A = snd ∘ A
+
+⊆-isProp : ( A B : ℙ X ) → isProp ( A ⊆ B )
+⊆-isProp A B = isPropΠ2 (λ x _ → ∈-isProp B x )
+
+⊆-refl : ( A : ℙ X ) → A ⊆ A
+⊆-refl A x = idfun ( x ∈ A )
+
+subst-∈ : ( A : ℙ X ) { x y : X } → x ≡ y → x ∈ A → y ∈ A
+subst-∈ A = subst ( _∈ A )
+
+⊆-refl-consequence : ( A B : ℙ X ) → A ≡ B → ( A ⊆ B ) × ( B ⊆ A )
+⊆-refl-consequence A B p = subst ( A ⊆_ ) p ( ⊆-refl A )
+ , subst ( B ⊆_ ) ( sym p ) ( ⊆-refl B )
+
+⊆-extensionality : ( A B : ℙ X ) → ( A ⊆ B ) × ( B ⊆ A ) → A ≡ B
+⊆-extensionality A B ( φ , ψ ) =
+ funExt (λ x → TypeOfHLevel≡ 1 ( hPropExt ( A x . snd ) ( B x . snd ) ( φ x ) ( ψ x )))
+
+⊆-extensionalityEquiv : ( A B : ℙ X ) → ( A ⊆ B ) × ( B ⊆ A ) ≃ ( A ≡ B )
+⊆-extensionalityEquiv A B = isoToEquiv ( iso ( ⊆-extensionality A B )
+ ( ⊆-refl-consequence A B )
+ (λ _ → isSetℙ A B _ _)
+ (λ _ → isPropΣ ( ⊆-isProp A B ) (λ _ → ⊆-isProp B A ) _ _))
+
\ No newline at end of file
diff --git a/docs/Cubical.Foundations.SIP.html b/docs/Cubical.Foundations.SIP.html
new file mode 100644
index 0000000..c3b5bb8
--- /dev/null
+++ b/docs/Cubical.Foundations.SIP.html
@@ -0,0 +1,126 @@
+
+Cubical.Foundations.SIP
+{-# OPTIONS --safe #-}
+module Cubical.Foundations.SIP where
+
+open import Cubical.Foundations.Prelude
+open import Cubical.Foundations.Univalence renaming ( ua-pathToEquiv to ua-pathToEquiv' )
+open import Cubical.Foundations.Transport
+open import Cubical.Foundations.Function
+open import Cubical.Foundations.Path
+open import Cubical.Foundations.Isomorphism
+open import Cubical.Foundations.Equiv
+open import Cubical.Data.Sigma
+
+open import Cubical.Foundations.Structure public
+
+private
+ variable
+ ℓ ℓ₁ ℓ₂ ℓ₃ ℓ₄ ℓ₅ : Level
+ S : Type ℓ₁ → Type ℓ₂
+
+
+
+
+
+SNS : ( S : Type ℓ₁ → Type ℓ₂ ) ( ι : StrEquiv S ℓ₃ ) → Type ( ℓ-max ( ℓ-max ( ℓ-suc ℓ₁ ) ℓ₂ ) ℓ₃ )
+SNS { ℓ₁ } S ι = ∀ { X : Type ℓ₁ } ( s t : S X ) → ι ( X , s ) ( X , t ) ( idEquiv X ) ≃ ( s ≡ t )
+
+
+
+
+_≃[_]_ : ( A : TypeWithStr ℓ₁ S ) ( ι : StrEquiv S ℓ₂ ) ( B : TypeWithStr ℓ₁ S ) → Type ( ℓ-max ℓ₁ ℓ₂ )
+A ≃[ ι ] B = Σ[ e ∈ typ A ≃ typ B ] ( ι A B e )
+
+
+
+
+
+UnivalentStr : ( S : Type ℓ₁ → Type ℓ₂ ) ( ι : StrEquiv S ℓ₃ ) → Type ( ℓ-max ( ℓ-max ( ℓ-suc ℓ₁ ) ℓ₂ ) ℓ₃ )
+UnivalentStr { ℓ₁ } S ι =
+ { A B : TypeWithStr ℓ₁ S } ( e : typ A ≃ typ B )
+ → ι A B e ≃ PathP (λ i → S ( ua e i )) ( str A ) ( str B )
+
+
+
+
+UnivalentStr→SNS : ( S : Type ℓ₁ → Type ℓ₂ ) ( ι : StrEquiv S ℓ₃ )
+ → UnivalentStr S ι → SNS S ι
+UnivalentStr→SNS S ι θ { X = X } s t =
+ ι ( X , s ) ( X , t ) ( idEquiv X )
+ ≃⟨ θ ( idEquiv X ) ⟩
+ PathP (λ i → S ( ua ( idEquiv X ) i )) s t
+ ≃⟨ pathToEquiv (λ j → PathP (λ i → S ( uaIdEquiv { A = X } j i )) s t ) ⟩
+ s ≡ t
+ ■
+
+
+SNS→UnivalentStr : ( ι : StrEquiv S ℓ₃ ) → SNS S ι → UnivalentStr S ι
+SNS→UnivalentStr { S = S } ι θ { A = A } { B = B } e = EquivJ P C e ( str A ) ( str B )
+ where
+ Y = typ B
+
+ P : ( X : Type _) → X ≃ Y → Type _
+ P X e' = ( s : S X ) ( t : S Y ) → ι ( X , s ) ( Y , t ) e' ≃ PathP (λ i → S ( ua e' i )) s t
+
+ C : ( s t : S Y ) → ι ( Y , s ) ( Y , t ) ( idEquiv Y ) ≃ PathP (λ i → S ( ua ( idEquiv Y ) i )) s t
+ C s t =
+ ι ( Y , s ) ( Y , t ) ( idEquiv Y )
+ ≃⟨ θ s t ⟩
+ s ≡ t
+ ≃⟨ pathToEquiv (λ j → PathP (λ i → S ( uaIdEquiv { A = Y } ( ~ j ) i )) s t ) ⟩
+ PathP (λ i → S ( ua ( idEquiv Y ) i )) s t
+ ■
+
+TransportStr : { S : Type ℓ → Type ℓ₁ } ( α : EquivAction S ) → Type ( ℓ-max ( ℓ-suc ℓ ) ℓ₁ )
+TransportStr { ℓ } { S = S } α =
+ { X Y : Type ℓ } ( e : X ≃ Y ) ( s : S X ) → equivFun ( α e ) s ≡ subst S ( ua e ) s
+
+TransportStr→UnivalentStr : { S : Type ℓ → Type ℓ₁ } ( α : EquivAction S )
+ → TransportStr α → UnivalentStr S ( EquivAction→StrEquiv α )
+TransportStr→UnivalentStr { S = S } α τ { X , s } { Y , t } e =
+ equivFun ( α e ) s ≡ t
+ ≃⟨ pathToEquiv ( cong ( _≡ t ) ( τ e s )) ⟩
+ subst S ( ua e ) s ≡ t
+ ≃⟨ invEquiv ( PathP≃Path _ _ _) ⟩
+ PathP (λ i → S ( ua e i )) s t
+ ■
+
+UnivalentStr→TransportStr : { S : Type ℓ → Type ℓ₁ } ( α : EquivAction S )
+ → UnivalentStr S ( EquivAction→StrEquiv α ) → TransportStr α
+UnivalentStr→TransportStr { S = S } α θ e s =
+ invEq ( θ e ) ( transport-filler ( cong S ( ua e )) s )
+
+invTransportStr : { S : Type ℓ → Type ℓ₂ } ( α : EquivAction S ) ( τ : TransportStr α )
+ { X Y : Type ℓ } ( e : X ≃ Y ) ( t : S Y ) → invEq ( α e ) t ≡ subst⁻ S ( ua e ) t
+invTransportStr { S = S } α τ e t =
+ sym ( transport⁻Transport ( cong S ( ua e )) ( invEq ( α e ) t ))
+ ∙∙ sym ( cong ( subst⁻ S ( ua e )) ( τ e ( invEq ( α e ) t )))
+ ∙∙ cong ( subst⁻ S ( ua e )) ( secEq ( α e ) t )
+
+
+
+
+
+
+module _ { S : Type ℓ₁ → Type ℓ₂ } { ι : StrEquiv S ℓ₃ }
+ ( θ : UnivalentStr S ι ) ( A B : TypeWithStr ℓ₁ S )
+ where
+
+ sip : A ≃[ ι ] B → A ≡ B
+ sip ( e , p ) i = ua e i , θ e . fst p i
+
+ SIP : A ≃[ ι ] B ≃ ( A ≡ B )
+ SIP =
+ sip , isoToIsEquiv ( compIso ( Σ-cong-iso ( invIso univalenceIso ) ( equivToIso ∘ θ )) ΣPathIsoPathΣ )
+
+ sip⁻ : A ≡ B → A ≃[ ι ] B
+ sip⁻ = invEq SIP
+
\ No newline at end of file
diff --git a/docs/Cubical.Functions.Embedding.html b/docs/Cubical.Functions.Embedding.html
new file mode 100644
index 0000000..a30b362
--- /dev/null
+++ b/docs/Cubical.Functions.Embedding.html
@@ -0,0 +1,442 @@
+
+Cubical.Functions.Embedding {-# OPTIONS --safe #-}
+module Cubical.Functions.Embedding where
+
+open import Cubical.Foundations.Prelude
+open import Cubical.Foundations.Function
+open import Cubical.Foundations.Equiv
+open import Cubical.Foundations.Equiv.Properties
+open import Cubical.Foundations.Equiv.HalfAdjoint
+open import Cubical.Foundations.HLevels
+open import Cubical.Foundations.Isomorphism
+open import Cubical.Foundations.Path
+open import Cubical.Foundations.Powerset
+open import Cubical.Foundations.Prelude
+open import Cubical.Foundations.Transport
+open import Cubical.Foundations.Univalence using ( ua ; univalence ; pathToEquiv )
+open import Cubical.Functions.Fibration
+
+open import Cubical.Data.Sigma
+open import Cubical.Functions.Fibration
+open import Cubical.Functions.FunExtEquiv
+open import Cubical.Relation.Nullary using ( Discrete ; yes ; no )
+open import Cubical.Structures.Axioms
+
+open import Cubical.Reflection.StrictEquiv
+
+open import Cubical.Data.Nat using ( ℕ ; zero ; suc )
+open import Cubical.Data.Sigma
+
+private
+ variable
+ ℓ ℓ' ℓ'' : Level
+ A B C : Type ℓ
+ f h : A → B
+ w x : A
+ y z : B
+
+
+
+
+
+
+
+
+isEmbedding : ( A → B ) → Type _
+isEmbedding f = ∀ w x → isEquiv { A = w ≡ x } ( cong f )
+
+isPropIsEmbedding : isProp ( isEmbedding f )
+isPropIsEmbedding { f = f } = isPropΠ2 λ _ _ → isPropIsEquiv ( cong f )
+
+
+isEmbedding→Inj
+ : { f : A → B }
+ → isEmbedding f
+ → ∀ w x → f w ≡ f x → w ≡ x
+isEmbedding→Inj { f = f } embb w x p
+ = equiv-proof ( embb w x ) p . fst . fst
+
+
+
+
+
+
+hasPropFibers : ( A → B ) → Type _
+hasPropFibers f = ∀ y → isProp ( fiber f y )
+
+
+hasPropFibersOfImage : ( A → B ) → Type _
+hasPropFibersOfImage f = ∀ x → isProp ( fiber f ( f x ))
+
+
+_↪_ : Type ℓ' → Type ℓ'' → Type ( ℓ-max ℓ' ℓ'' )
+A ↪ B = Σ[ f ∈ ( A → B ) ] isEmbedding f
+
+hasPropFibersIsProp : isProp ( hasPropFibers f )
+hasPropFibersIsProp = isPropΠ (λ _ → isPropIsProp )
+
+private
+ lemma₀ : ( p : y ≡ z ) → fiber f y ≡ fiber f z
+ lemma₀ { f = f } p = λ i → fiber f ( p i )
+
+ lemma₁ : isEmbedding f → ∀ x → isContr ( fiber f ( f x ))
+ lemma₁ { f = f } iE x = value , path
+ where
+ value : fiber f ( f x )
+ value = ( x , refl )
+
+ path : ∀( fi : fiber f ( f x )) → value ≡ fi
+ path ( w , p ) i
+ = case equiv-proof ( iE w x ) p of λ
+ { (( q , sq ) , _)
+ → hfill (λ j → λ { ( i = i0 ) → ( x , refl )
+ ; ( i = i1 ) → ( w , sq j )
+ })
+ ( inS ( q ( ~ i ) , λ j → f ( q ( ~ i ∨ j ))))
+ i1
+ }
+
+isEmbedding→hasPropFibers : isEmbedding f → hasPropFibers f
+isEmbedding→hasPropFibers iE y ( x , p )
+ = subst (λ f → isProp f ) ( lemma₀ p ) ( isContr→isProp ( lemma₁ iE x )) ( x , p )
+
+private
+ fibCong→PathP
+ : { f : A → B }
+ → ( p : f w ≡ f x )
+ → ( fi : fiber ( cong f ) p )
+ → PathP (λ i → fiber f ( p i )) ( w , refl ) ( x , refl )
+ fibCong→PathP p ( q , r ) i = q i , λ j → r j i
+
+ PathP→fibCong
+ : { f : A → B }
+ → ( p : f w ≡ f x )
+ → ( pp : PathP (λ i → fiber f ( p i )) ( w , refl ) ( x , refl ))
+ → fiber ( cong f ) p
+ PathP→fibCong p pp = (λ i → fst ( pp i )) , (λ j i → snd ( pp i ) j )
+
+PathP≡fibCong
+ : { f : A → B }
+ → ( p : f w ≡ f x )
+ → PathP (λ i → fiber f ( p i )) ( w , refl ) ( x , refl ) ≡ fiber ( cong f ) p
+PathP≡fibCong p
+ = isoToPath ( iso ( PathP→fibCong p ) ( fibCong→PathP p ) (λ _ → refl ) (λ _ → refl ))
+
+hasPropFibers→isEmbedding : hasPropFibers f → isEmbedding f
+hasPropFibers→isEmbedding { f = f } iP w x . equiv-proof p
+ = subst isContr ( PathP≡fibCong p ) ( isProp→isContrPathP (λ i → iP ( p i )) fw fx )
+ where
+ fw : fiber f ( f w )
+ fw = ( w , refl )
+
+ fx : fiber f ( f x )
+ fx = ( x , refl )
+
+hasPropFibersOfImage→hasPropFibers : hasPropFibersOfImage f → hasPropFibers f
+hasPropFibersOfImage→hasPropFibers { f = f } fibImg y a b =
+ subst (λ y → isProp ( fiber f y )) ( snd a ) ( fibImg ( fst a )) a b
+
+hasPropFibersOfImage→isEmbedding : hasPropFibersOfImage f → isEmbedding f
+hasPropFibersOfImage→isEmbedding = hasPropFibers→isEmbedding ∘ hasPropFibersOfImage→hasPropFibers
+
+isEmbedding≡hasPropFibers : isEmbedding f ≡ hasPropFibers f
+isEmbedding≡hasPropFibers
+ = isoToPath
+ ( iso isEmbedding→hasPropFibers
+ hasPropFibers→isEmbedding
+ (λ _ → hasPropFibersIsProp _ _)
+ (λ _ → isPropIsEmbedding _ _))
+
+
+
+module _
+ { f : A → B }
+ ( isSetB : isSet B )
+ where
+
+ module _
+ ( inj : ∀{ w x } → f w ≡ f x → w ≡ x )
+ where
+
+ injective→hasPropFibers : hasPropFibers f
+ injective→hasPropFibers y ( x , fx≡y ) ( x' , fx'≡y ) =
+ Σ≡Prop
+ (λ _ → isSetB _ _)
+ ( inj ( fx≡y ∙ sym ( fx'≡y )))
+
+ injEmbedding : isEmbedding f
+ injEmbedding = hasPropFibers→isEmbedding injective→hasPropFibers
+
+ retractableIntoSet→isEmbedding : hasRetract f → isEmbedding f
+ retractableIntoSet→isEmbedding ( g , ret ) = injEmbedding inj
+ where
+ inj : f w ≡ f x → w ≡ x
+ inj { w = w } { x = x } p = sym ( ret w ) ∙∙ cong g p ∙∙ ret x
+
+isEquiv→hasPropFibers : isEquiv f → hasPropFibers f
+isEquiv→hasPropFibers e b = isContr→isProp ( equiv-proof e b )
+
+isEquiv→isEmbedding : isEquiv f → isEmbedding f
+isEquiv→isEmbedding e = λ _ _ → congEquiv (_ , e ) . snd
+
+Equiv→Embedding : A ≃ B → A ↪ B
+Equiv→Embedding ( f , isEquivF ) = ( f , isEquiv→isEmbedding isEquivF )
+
+iso→isEmbedding : ∀ { ℓ } { A B : Type ℓ }
+ → ( isom : Iso A B )
+
+ → isEmbedding ( Iso.fun isom )
+iso→isEmbedding { A = A } { B } isom = ( isEquiv→isEmbedding ( equivIsEquiv ( isoToEquiv isom )))
+
+isEmbedding→Injection :
+ ∀ { ℓ } { A B C : Type ℓ }
+ → ( a : A → B )
+ → ( e : isEmbedding a )
+
+ → ∀ { f g : C → A } →
+ ∀ x → ( a ( f x ) ≡ a ( g x )) ≡ ( f x ≡ g x )
+isEmbedding→Injection a e { f = f } { g } x = sym ( ua ( cong a , e ( f x ) ( g x )))
+
+Embedding-into-Discrete→Discrete : A ↪ B → Discrete B → Discrete A
+Embedding-into-Discrete→Discrete ( f , isEmbeddingF ) _≟_ x y with f x ≟ f y
+... | yes p = yes ( invIsEq ( isEmbeddingF x y ) p )
+... | no ¬p = no ( ¬p ∘ cong f )
+
+Embedding-into-isProp→isProp : A ↪ B → isProp B → isProp A
+Embedding-into-isProp→isProp ( f , isEmbeddingF ) isProp-B x y
+ = invIsEq ( isEmbeddingF x y ) ( isProp-B ( f x ) ( f y ))
+
+Embedding-into-isSet→isSet : A ↪ B → isSet B → isSet A
+Embedding-into-isSet→isSet ( f , isEmbeddingF ) isSet-B x y p q =
+ p ≡⟨ sym ( retIsEq isEquiv-cong-f p ) ⟩
+ cong-f⁻¹ ( cong f p ) ≡⟨ cong cong-f⁻¹ cong-f-p≡cong-f-q ⟩
+ cong-f⁻¹ ( cong f q ) ≡⟨ retIsEq isEquiv-cong-f q ⟩
+ q ∎
+ where
+ cong-f-p≡cong-f-q = isSet-B ( f x ) ( f y ) ( cong f p ) ( cong f q )
+ isEquiv-cong-f = isEmbeddingF x y
+ cong-f⁻¹ = invIsEq isEquiv-cong-f
+
+Embedding-into-hLevel→hLevel
+ : ∀ n → A ↪ B → isOfHLevel ( suc n ) B → isOfHLevel ( suc n ) A
+Embedding-into-hLevel→hLevel zero = Embedding-into-isProp→isProp
+Embedding-into-hLevel→hLevel ( suc n ) ( f , isEmbeddingF ) Blvl x y
+ = isOfHLevelRespectEquiv ( suc n ) ( invEquiv equiv ) subLvl
+ where
+ equiv : ( x ≡ y ) ≃ ( f x ≡ f y )
+ equiv . fst = cong f
+ equiv . snd = isEmbeddingF x y
+ subLvl : isOfHLevel ( suc n ) ( f x ≡ f y )
+ subLvl = Blvl ( f x ) ( f y )
+
+
+
+Embedding→Subset : { X : Type ℓ } → Σ[ A ∈ Type ℓ ] ( A ↪ X ) → ℙ X
+Embedding→Subset (_ , f , isEmbeddingF ) x = fiber f x , isEmbedding→hasPropFibers isEmbeddingF x
+
+Subset→Embedding : { X : Type ℓ } → ℙ X → Σ[ A ∈ Type ℓ ] ( A ↪ X )
+Subset→Embedding { X = X } A = D , fst , Ψ
+ where
+ D = Σ[ x ∈ X ] x ∈ A
+
+ Ψ : isEmbedding fst
+ Ψ w x = isEmbeddingFstΣProp ( ∈-isProp A )
+
+Subset→Embedding→Subset : { X : Type ℓ } → section ( Embedding→Subset { ℓ } { X }) ( Subset→Embedding { ℓ } { X })
+Subset→Embedding→Subset _ = funExt λ x → Σ≡Prop (λ _ → isPropIsProp ) ( ua ( FiberIso.fiberEquiv _ x ))
+
+Embedding→Subset→Embedding : { X : Type ℓ } → retract ( Embedding→Subset { ℓ } { X }) ( Subset→Embedding { ℓ } { X })
+Embedding→Subset→Embedding { ℓ = ℓ } { X = X } ( A , f , ψ ) =
+ cong ( equivFun Σ-assoc-≃ ) ( Σ≡Prop (λ _ → isPropIsEmbedding ) ( retEq ( fibrationEquiv X ℓ ) ( A , f )))
+
+Subset≃Embedding : { X : Type ℓ } → ℙ X ≃ ( Σ[ A ∈ Type ℓ ] ( A ↪ X ))
+Subset≃Embedding = isoToEquiv ( iso Subset→Embedding Embedding→Subset
+ Embedding→Subset→Embedding Subset→Embedding→Subset )
+
+Subset≡Embedding : { X : Type ℓ } → ℙ X ≡ ( Σ[ A ∈ Type ℓ ] ( A ↪ X ))
+Subset≡Embedding = ua Subset≃Embedding
+
+isEmbedding-∘ : isEmbedding f → isEmbedding h → isEmbedding ( f ∘ h )
+isEmbedding-∘ { f = f } { h = h } Embf Embh w x
+ = compEquiv ( cong h , Embh w x ) ( cong f , Embf ( h w ) ( h x )) . snd
+
+compEmbedding : ( B ↪ C ) → ( A ↪ B ) → ( A ↪ C )
+( compEmbedding ( g , _ ) ( f , _ )). fst = g ∘ f
+( compEmbedding (_ , g↪ ) (_ , f↪ )). snd = isEmbedding-∘ g↪ f↪
+
+isEmbedding→embedsFibersIntoSingl
+ : isEmbedding f
+ → ∀ z → fiber f z ↪ singl z
+isEmbedding→embedsFibersIntoSingl { f = f } isE z = e , isEmbE where
+ e : fiber f z → singl z
+ e x = f ( fst x ) , sym ( snd x )
+
+ isEmbE : isEmbedding e
+ isEmbE u v = goal where
+
+ Dom′ : ∀ u v → Type _
+ Dom′ u v = Σ[ p ∈ fst u ≡ fst v ] PathP (λ i → f ( p i ) ≡ z ) ( snd u ) ( snd v )
+ Cod′ : ∀ u v → Type _
+ Cod′ u v = Σ[ p ∈ f ( fst u ) ≡ f ( fst v ) ] PathP (λ i → p i ≡ z ) ( snd u ) ( snd v )
+ ΣeqCf : Dom′ u v ≃ Cod′ u v
+ ΣeqCf = Σ-cong-equiv-fst (_ , isE _ _)
+
+ dom→ : u ≡ v → Dom′ u v
+ dom→ p = cong fst p , cong snd p
+ dom← : Dom′ u v → u ≡ v
+ dom← p i = p . fst i , p . snd i
+
+ cod→ : e u ≡ e v → Cod′ u v
+ cod→ p = cong fst p , cong ( sym ∘ snd ) p
+ cod← : Cod′ u v → e u ≡ e v
+ cod← p i = p . fst i , sym ( p . snd i )
+
+ goal : isEquiv ( cong e )
+ goal . equiv-proof x . fst . fst =
+ dom← ( equivCtr ΣeqCf ( cod→ x ) . fst )
+ goal . equiv-proof x . fst . snd j =
+ cod← ( equivCtr ΣeqCf ( cod→ x ) . snd j )
+ goal . equiv-proof x . snd ( g , p ) i . fst =
+ dom← ( equivCtrPath ΣeqCf ( cod→ x ) ( dom→ g , cong cod→ p ) i . fst )
+ goal . equiv-proof x . snd ( g , p ) i . snd j =
+ cod← ( equivCtrPath ΣeqCf ( cod→ x ) ( dom→ g , cong cod→ p ) i . snd j )
+
+isEmbedding→hasPropFibers′ : isEmbedding f → hasPropFibers f
+isEmbedding→hasPropFibers′ { f = f } iE z =
+ Embedding-into-isProp→isProp ( isEmbedding→embedsFibersIntoSingl iE z ) isPropSingl
+
+universeEmbedding :
+ ∀ { ℓ ℓ' : Level }
+ → ( F : Type ℓ → Type ℓ' )
+ → (∀ X → F X ≃ X )
+ → isEmbedding F
+universeEmbedding F liftingEquiv = hasPropFibersOfImage→isEmbedding propFibersF where
+ lemma : ∀ A B → ( F A ≡ F B ) ≃ ( B ≡ A )
+ lemma A B = ( F A ≡ F B ) ≃⟨ univalence ⟩
+ ( F A ≃ F B ) ≃⟨ equivComp ( liftingEquiv A ) ( liftingEquiv B ) ⟩
+ ( A ≃ B ) ≃⟨ invEquivEquiv ⟩
+ ( B ≃ A ) ≃⟨ invEquiv univalence ⟩
+ ( B ≡ A ) ■
+ fiberSingl : ∀ X → fiber F ( F X ) ≃ singl X
+ fiberSingl X = Σ-cong-equiv-snd (λ _ → lemma _ _)
+ propFibersF : hasPropFibersOfImage F
+ propFibersF X = Embedding-into-isProp→isProp ( Equiv→Embedding ( fiberSingl X )) isPropSingl
+
+liftEmbedding : ( ℓ ℓ' : Level )
+ → isEmbedding ( Lift { i = ℓ } { j = ℓ' })
+liftEmbedding ℓ ℓ' = universeEmbedding ( Lift { j = ℓ' }) (λ _ → invEquiv LiftEquiv )
+
+module FibrationIdentityPrinciple { B : Type ℓ } { ℓ' } where
+
+
+
+
+ Fibration′ = Fibration B ( ℓ-max ℓ ℓ' )
+
+ module Lifted ( f g : Fibration′ ) where
+ f≃g′ : Type ( ℓ-max ℓ ℓ' )
+ f≃g′ = ∀ b → fiber ( f . snd ) b ≃ fiber ( g . snd ) b
+
+ Fibration′IP : f≃g′ ≃ ( f ≡ g )
+ Fibration′IP =
+ f≃g′
+ ≃⟨ equivΠCod (λ _ → invEquiv univalence ) ⟩
+ (∀ b → fiber ( f . snd ) b ≡ fiber ( g . snd ) b )
+ ≃⟨ funExtEquiv ⟩
+ fiber ( f . snd ) ≡ fiber ( g . snd )
+ ≃⟨ invEquiv ( congEquiv ( fibrationEquiv B ℓ' )) ⟩
+ f ≡ g
+ ■
+
+
+ L : Type _ → Type _
+ L = Lift { i = ℓ' } { j = ℓ }
+
+ liftFibration : Fibration B ℓ' → Fibration′
+ liftFibration ( A , f ) = L A , f ∘ lower
+
+ hasPropFibersLiftFibration : hasPropFibers liftFibration
+ hasPropFibersLiftFibration ( A , f ) =
+ Embedding-into-isProp→isProp ( Equiv→Embedding fiberChar )
+ ( isPropΣ ( isEmbedding→hasPropFibers ( liftEmbedding _ _) A )
+ λ _ → isEquiv→hasPropFibers ( snd ( invEquiv ( preCompEquiv LiftEquiv ))) _)
+ where
+ fiberChar : fiber liftFibration ( A , f )
+ ≃ ( Σ[ ( E , eq ) ∈ fiber L A ] fiber ( _∘ lower ) ( transport⁻ (λ i → eq i → B ) f ))
+ fiberChar =
+ fiber liftFibration ( A , f )
+ ≃⟨ Σ-cong-equiv-snd (λ _ → invEquiv ΣPath≃PathΣ ) ⟩
+ ( Σ[ ( E , g ) ∈ Fibration B ℓ' ] Σ[ eq ∈ ( L E ≡ A ) ] PathP (λ i → eq i → B ) ( g ∘ lower ) f )
+ ≃⟨ boringSwap ⟩
+ ( Σ[ ( E , eq ) ∈ fiber L A ] Σ[ g ∈ ( E → B ) ] PathP (λ i → eq i → B ) ( g ∘ lower ) f )
+ ≃⟨ Σ-cong-equiv-snd (λ _ → Σ-cong-equiv-snd λ _ → pathToEquiv ( PathP≡Path⁻ _ _ _)) ⟩
+ ( Σ[ ( E , eq ) ∈ fiber L A ] fiber ( _∘ lower ) ( transport⁻ (λ i → eq i → B ) f ))
+ ■ where
+ unquoteDecl boringSwap =
+ declStrictEquiv boringSwap
+ (λ (( E , g ) , ( eq , p )) → (( E , eq ) , ( g , p )))
+ (λ (( E , g ) , ( eq , p )) → (( E , eq ) , ( g , p )))
+
+ isEmbeddingLiftFibration : isEmbedding liftFibration
+ isEmbeddingLiftFibration = hasPropFibers→isEmbedding hasPropFibersLiftFibration
+
+
+ module _ ( f g : Fibration B ℓ' ) where
+ open Lifted ( liftFibration f ) ( liftFibration g )
+ f≃g : Type ( ℓ-max ℓ ℓ' )
+ f≃g = ∀ b → fiber ( f . snd ) b ≃ fiber ( g . snd ) b
+
+ FibrationIP : f≃g ≃ ( f ≡ g )
+ FibrationIP =
+ f≃g ≃⟨ equivΠCod (λ b → equivComp ( Σ-cong-equiv-fst LiftEquiv )
+ ( Σ-cong-equiv-fst LiftEquiv )) ⟩
+ f≃g′ ≃⟨ Fibration′IP ⟩
+ ( liftFibration f ≡ liftFibration g ) ≃⟨ invEquiv (_ , isEmbeddingLiftFibration _ _) ⟩
+ ( f ≡ g ) ■
+
+_≃Fib_ : { B : Type ℓ } ( f g : Fibration B ℓ' ) → Type ( ℓ-max ℓ ℓ' )
+_≃Fib_ = FibrationIdentityPrinciple.f≃g
+
+FibrationIP : { B : Type ℓ } ( f g : Fibration B ℓ' ) → f ≃Fib g ≃ ( f ≡ g )
+FibrationIP = FibrationIdentityPrinciple.FibrationIP
+
+Embedding : ( B : Type ℓ' ) → ( ℓ : Level ) → Type ( ℓ-max ℓ' ( ℓ-suc ℓ ))
+Embedding B ℓ = Σ[ A ∈ Type ℓ ] A ↪ B
+
+module EmbeddingIdentityPrinciple { B : Type ℓ } { ℓ' } ( f g : Embedding B ℓ' ) where
+ open Σ f renaming ( fst to F )
+ open Σ g renaming ( fst to G )
+ open Σ ( f . snd ) renaming ( fst to ffun ; snd to isEmbF )
+ open Σ ( g . snd ) renaming ( fst to gfun ; snd to isEmbG )
+ f≃g : Type _
+ f≃g = (∀ b → fiber ffun b → fiber gfun b ) ×
+ (∀ b → fiber gfun b → fiber ffun b )
+ toFibr : Embedding B ℓ' → Fibration B ℓ'
+ toFibr ( A , ( f , _)) = ( A , f )
+
+ isEmbeddingToFibr : isEmbedding toFibr
+ isEmbeddingToFibr w x = fullEquiv . snd where
+
+ fullEquiv : ( w ≡ x ) ≃ ( toFibr w ≡ toFibr x )
+ fullEquiv = compEquiv ( congEquiv ( invEquiv Σ-assoc-≃ )) ( invEquiv ( Σ≡PropEquiv (λ _ → isPropIsEmbedding )))
+
+ EmbeddingIP : f≃g ≃ ( f ≡ g )
+ EmbeddingIP =
+ f≃g
+ ≃⟨ strictIsoToEquiv ( invIso toProdIso ) ⟩
+ (∀ b → ( fiber ffun b → fiber gfun b ) × ( fiber gfun b → fiber ffun b ))
+ ≃⟨ equivΠCod (λ _ → isEquivPropBiimpl→Equiv ( isEmbedding→hasPropFibers isEmbF _)
+ ( isEmbedding→hasPropFibers isEmbG _)) ⟩
+ (∀ b → ( fiber ( f . snd . fst ) b ) ≃ ( fiber ( g . snd . fst ) b ))
+ ≃⟨ FibrationIP ( toFibr f ) ( toFibr g ) ⟩
+ ( toFibr f ≡ toFibr g )
+ ≃⟨ invEquiv (_ , isEmbeddingToFibr _ _) ⟩
+ f ≡ g
+ ■
+
+_≃Emb_ : { B : Type ℓ } ( f g : Embedding B ℓ' ) → Type _
+_≃Emb_ = EmbeddingIdentityPrinciple.f≃g
+
+EmbeddingIP : { B : Type ℓ } ( f g : Embedding B ℓ' ) → f ≃Emb g ≃ ( f ≡ g )
+EmbeddingIP = EmbeddingIdentityPrinciple.EmbeddingIP
+Cubical.Functions.Fibration {-# OPTIONS --safe #-}
+module Cubical.Functions.Fibration where
+
+open import Cubical.Foundations.Prelude
+open import Cubical.Foundations.HLevels using ( isOfHLevel→isOfHLevelDep )
+open import Cubical.Foundations.Function
+open import Cubical.Foundations.GroupoidLaws
+open import Cubical.Foundations.Equiv
+open import Cubical.Foundations.Equiv.Properties
+open import Cubical.Foundations.Isomorphism
+open import Cubical.Foundations.Path
+open import Cubical.Foundations.Univalence
+open import Cubical.Foundations.Transport
+open import Cubical.Data.Sigma
+
+private
+ variable
+ ℓ ℓb : Level
+ B : Type ℓb
+
+module FiberIso { ℓ } ( p⁻¹ : B → Type ℓ ) ( x : B ) where
+
+ p : Σ B p⁻¹ → B
+ p = fst
+
+ fwd : fiber p x → p⁻¹ x
+ fwd (( x' , y ) , q ) = subst (λ z → p⁻¹ z ) q y
+
+ bwd : p⁻¹ x → fiber p x
+ bwd y = ( x , y ) , refl
+
+ fwd-bwd : ∀ x → fwd ( bwd x ) ≡ x
+ fwd-bwd y = transportRefl y
+
+ bwd-fwd : ∀ x → bwd ( fwd x ) ≡ x
+ bwd-fwd (( x' , y ) , q ) i = h ( r i )
+ where h : Σ[ s ∈ singl x ] p⁻¹ ( s . fst ) → fiber p x
+ h (( x , p ) , y ) = ( x , y ) , sym p
+ r : Path ( Σ[ s ∈ singl x ] p⁻¹ ( s . fst ))
+ (( x , refl ) , subst p⁻¹ q y )
+ (( x' , sym q ) , y )
+ r = ΣPathP ( isContrSingl x . snd ( x' , sym q )
+ , toPathP ( transport⁻Transport (λ i → p⁻¹ ( q i )) y ))
+
+
+ fiberEquiv : fiber p x ≃ p⁻¹ x
+ fiberEquiv = isoToEquiv ( iso fwd bwd fwd-bwd bwd-fwd )
+
+open FiberIso using ( fiberEquiv ) public
+
+module _ { ℓ } { E : Type ℓ } ( p : E → B ) where
+
+
+ totalEquiv : E ≃ Σ B ( fiber p )
+ totalEquiv = isoToEquiv isom
+ where isom : Iso E ( Σ B ( fiber p ))
+ Iso.fun isom x = p x , x , refl
+ Iso.inv isom ( b , x , q ) = x
+ Iso.leftInv isom x i = x
+ Iso.rightInv isom ( b , x , q ) i = q i , x , λ j → q ( i ∧ j )
+
+module _ ( B : Type ℓb ) ( ℓ : Level ) where
+ private
+ ℓ' = ℓ-max ℓb ℓ
+
+
+ fibrationEquiv : ( Σ[ E ∈ Type ℓ' ] ( E → B )) ≃ ( B → Type ℓ' )
+ fibrationEquiv = isoToEquiv isom
+ where isom : Iso ( Σ[ E ∈ Type ℓ' ] ( E → B )) ( B → Type ℓ' )
+ Iso.fun isom ( E , p ) = fiber p
+ Iso.inv isom p⁻¹ = Σ B p⁻¹ , fst
+ Iso.rightInv isom p⁻¹ i x = ua ( fiberEquiv p⁻¹ x ) i
+ Iso.leftInv isom ( E , p ) i = ua e ( ~ i ) , fst ∘ ua-unglue e ( ~ i )
+ where e = totalEquiv p
+
+
+module ForSets { E : Type ℓ } { isSetB : isSet B } ( f : E → B ) where
+ module _ { x x' } { px : x ≡ x' } { a' : fiber f x } { b' : fiber f x' } where
+
+ fibersEqIfRepsEq : fst a' ≡ fst b'
+ → PathP (λ i → fiber f ( px i )) a' b'
+ fibersEqIfRepsEq p = ΣPathP ( p ,
+ ( isOfHLevel→isOfHLevelDep 1
+ (λ ( v , w ) → isSetB ( f v ) w )
+ ( snd a' ) ( snd b' )
+ (λ i → ( p i , px i ))))
+
+open import Cubical.Foundations.Function
+
+fiberPath : ∀ { ℓ ℓ' } { A : Type ℓ } { B : Type ℓ' } { f : A → B } { b : B } ( h h' : fiber f b ) →
+ ( Σ[ p ∈ ( fst h ≡ fst h' ) ] ( PathP (λ i → f ( p i ) ≡ b ) ( snd h ) ( snd h' )))
+ ≡ fiber ( cong f ) ( h . snd ∙∙ refl ∙∙ sym ( h' . snd ))
+fiberPath h h' = cong ( Σ ( h . fst ≡ h' . fst )) ( funExt λ p → flipSquarePath ∙ PathP≡doubleCompPathʳ _ _ _ _)
+
+fiber≡ : ∀ { ℓ ℓ' } { A : Type ℓ } { B : Type ℓ' } { f : A → B } { b : B } ( h h' : fiber f b )
+ → ( h ≡ h' ) ≡ fiber ( cong f ) ( h . snd ∙∙ refl ∙∙ sym ( h' . snd ))
+fiber≡ { f = f } { b = b } h h' =
+ ΣPath≡PathΣ ⁻¹ ∙
+ fiberPath h h'
+
+fiberCong : ∀ { ℓ ℓ' } { A : Type ℓ } { B : Type ℓ' } ( f : A → B ) { a₀ a₁ : A } ( q : f a₀ ≡ f a₁ )
+ → fiber ( cong f ) q ≡ Path ( fiber f ( f a₁ )) ( a₀ , q ) ( a₁ , refl )
+fiberCong f q =
+ cong ( fiber ( cong f )) ( cong sym ( lUnit ( sym q )))
+ ∙ sym ( fiber≡ (_ , q ) (_ , refl ))
+
+FibrationStr : ( B : Type ℓb ) → Type ℓ → Type ( ℓ-max ℓ ℓb )
+FibrationStr B A = A → B
+
+Fibration : ( B : Type ℓb ) → ( ℓ : Level ) → Type ( ℓ-max ℓb ( ℓ-suc ℓ ))
+Fibration { ℓb = ℓb } B ℓ = Σ[ A ∈ Type ℓ ] FibrationStr B A
+Cubical.Functions.Surjection {-# OPTIONS --safe #-}
+module Cubical.Functions.Surjection where
+
+open import Cubical.Foundations.Prelude
+open import Cubical.Foundations.HLevels
+open import Cubical.Foundations.Isomorphism
+open import Cubical.Foundations.Equiv
+open import Cubical.Foundations.Univalence
+open import Cubical.Foundations.Function
+open import Cubical.Functions.Embedding
+
+open import Cubical.Data.Sigma
+open import Cubical.Data.Unit
+open import Cubical.HITs.PropositionalTruncation as PT
+
+private variable
+ ℓ ℓ' : Level
+ A B C : Type ℓ
+ f : A → B
+
+isSurjection : ( A → B ) → Type _
+isSurjection f = ∀ b → ∥ fiber f b ∥₁
+
+_↠_ : Type ℓ → Type ℓ' → Type ( ℓ-max ℓ ℓ' )
+A ↠ B = Σ[ f ∈ ( A → B ) ] isSurjection f
+
+section→isSurjection : { g : B → A } → section f g → isSurjection f
+section→isSurjection { g = g } s b = ∣ g b , s b ∣₁
+
+isPropIsSurjection : isProp ( isSurjection f )
+isPropIsSurjection = isPropΠ λ _ → squash₁
+
+isEquiv→isSurjection : isEquiv f → isSurjection f
+isEquiv→isSurjection e b = ∣ fst ( equiv-proof e b ) ∣₁
+
+isEquiv→isEmbedding×isSurjection : isEquiv f → isEmbedding f × isSurjection f
+isEquiv→isEmbedding×isSurjection e = isEquiv→isEmbedding e , isEquiv→isSurjection e
+
+isEmbedding×isSurjection→isEquiv : isEmbedding f × isSurjection f → isEquiv f
+equiv-proof ( isEmbedding×isSurjection→isEquiv { f = f } ( emb , sur )) b =
+ inhProp→isContr ( PT.rec fib' (λ x → x ) fib ) fib'
+ where
+ hpf : hasPropFibers f
+ hpf = isEmbedding→hasPropFibers emb
+
+ fib : ∥ fiber f b ∥₁
+ fib = sur b
+
+ fib' : isProp ( fiber f b )
+ fib' = hpf b
+
+isEquiv≃isEmbedding×isSurjection : isEquiv f ≃ isEmbedding f × isSurjection f
+isEquiv≃isEmbedding×isSurjection = isoToEquiv ( iso
+ isEquiv→isEmbedding×isSurjection
+ isEmbedding×isSurjection→isEquiv
+ (λ _ → isOfHLevelΣ 1 isPropIsEmbedding (\ _ → isPropIsSurjection ) _ _)
+ (λ _ → isPropIsEquiv _ _ _))
+
+
+
+
+rightCancellable : ( f : A → B ) → Type _
+rightCancellable { ℓ } { A } { ℓ' } { B } f = ∀ { C : Type ( ℓ-suc ( ℓ-max ℓ ℓ' ))}
+ → ∀ ( g g' : B → C ) → (∀ x → g ( f x ) ≡ g' ( f x )) → ∀ y → g y ≡ g' y
+
+
+epi⇒surjective : ( f : A → B ) → rightCancellable f → isSurjection f
+epi⇒surjective f rc y = transport ( fact₂ y ) tt*
+ where hasPreimage : ( A → B ) → B → _
+ hasPreimage f y = ∥ fiber f y ∥₁
+
+ fact₁ : ∀ x → Unit* ≡ hasPreimage f ( f x )
+ fact₁ x = hPropExt isPropUnit*
+ isPropPropTrunc
+ (λ _ → ∣ ( x , refl ) ∣₁ )
+ (λ _ → tt* )
+
+ fact₂ : ∀ y → Unit* ≡ hasPreimage f y
+ fact₂ = rc _ _ fact₁
+
+
+leftFactorSurjective : ( g : A → B ) ( h : B → C )
+ → isSurjection ( h ∘ g )
+ → isSurjection h
+leftFactorSurjective g h sur-h∘g c = PT.rec isPropPropTrunc (λ ( x , hgx≡c ) → ∣ g x , hgx≡c ∣₁ ) ( sur-h∘g c )
+
+compSurjection : ( f : A ↠ B ) ( g : B ↠ C )
+ → A ↠ C
+compSurjection ( f , sur-f ) ( g , sur-g ) =
+ (λ x → g ( f x )) ,
+ λ c → PT.rec isPropPropTrunc
+ (λ ( b , gb≡c ) → PT.rec isPropPropTrunc (λ ( a , fa≡b ) → ∣ a , ( cong g fa≡b ∙ gb≡c ) ∣₁ ) ( sur-f b ))
+ ( sur-g c )
+Cubical.HITs.PropositionalTruncation.MagicTrick
+{-# OPTIONS --safe #-}
+
+module Cubical.HITs.PropositionalTruncation.MagicTrick where
+
+open import Cubical.Foundations.Prelude
+open import Cubical.Foundations.Function
+open import Cubical.Foundations.Path
+open import Cubical.Foundations.Pointed
+open import Cubical.Foundations.Pointed.Homogeneous
+
+open import Cubical.HITs.PropositionalTruncation.Base
+open import Cubical.HITs.PropositionalTruncation.Properties
+
+module Recover { ℓ } ( A∙ : Pointed ℓ ) ( h : isHomogeneous A∙ ) where
+ private
+ A = typ A∙
+ a = pt A∙
+
+ toEquivPtd : ∥ A ∥₁ → Σ[ B∙ ∈ Pointed ℓ ] ( A , a ) ≡ B∙
+ toEquivPtd = rec isPropSingl (λ x → ( A , x ) , h x )
+ private
+ B∙ : ∥ A ∥₁ → Pointed ℓ
+ B∙ tx = fst ( toEquivPtd tx )
+
+
+ private
+ obvs : ∀ x → B∙ ∣ x ∣₁ ≡ ( A , x )
+ obvs x = refl
+
+
+
+ recover : ∀ ( tx : ∥ A ∥₁ ) → typ ( B∙ tx )
+ recover tx = pt ( B∙ tx )
+
+ recover∣∣ : ∀ ( x : A ) → recover ∣ x ∣₁ ≡ x
+ recover∣∣ x = refl
+
+ private
+
+
+
+ obvs2 : A → A
+ obvs2 = recover ∘ ∣_∣₁
+
+
+
+ recover-squash₁ : ∀ x y →
+ PathP (λ i → typ ( B∙ ( squash₁ ∣ x ∣₁ ∣ y ∣₁ i ))) x y
+ recover-squash₁ x y = cong recover ( squash₁ ∣ x ∣₁ ∣ y ∣₁ )
+
+
+
+
+
+private
+ open import Cubical.Data.Nat
+ open Recover ( ℕ , zero ) ( isHomogeneousDiscrete discreteℕ )
+
+
+ module _ where
+ private
+ hidden : ℕ
+ hidden = 17
+
+ ∣hidden∣ : ∥ ℕ ∥₁
+ ∣hidden∣ = ∣ hidden ∣₁
+
+
+ test : recover ∣hidden∣ ≡ 17
+ test = refl
+
+
+
+
+
+
\ No newline at end of file
diff --git a/docs/Cubical.HITs.PropositionalTruncation.Properties.html b/docs/Cubical.HITs.PropositionalTruncation.Properties.html
new file mode 100644
index 0000000..bac77cf
--- /dev/null
+++ b/docs/Cubical.HITs.PropositionalTruncation.Properties.html
@@ -0,0 +1,570 @@
+
+Cubical.HITs.PropositionalTruncation.Properties
+{-# OPTIONS --safe #-}
+module Cubical.HITs.PropositionalTruncation.Properties where
+
+open import Cubical.Core.Everything
+
+open import Cubical.Foundations.Prelude
+open import Cubical.Foundations.Equiv
+open import Cubical.Foundations.Function
+open import Cubical.Foundations.HLevels
+open import Cubical.Foundations.Isomorphism
+open import Cubical.Foundations.Univalence
+
+open import Cubical.Data.Sigma
+open import Cubical.Data.Sum hiding ( rec ; elim ; map )
+open import Cubical.Data.Nat using ( ℕ ; zero ; suc )
+open import Cubical.Data.FinData using ( Fin ; zero ; suc )
+
+open import Cubical.HITs.PropositionalTruncation.Base
+
+private
+ variable
+ ℓ ℓ' : Level
+ A B C : Type ℓ
+ A′ : Type ℓ'
+
+∥∥-isPropDep : ( P : A → Type ℓ ) → isOfHLevelDep 1 (λ x → ∥ P x ∥₁ )
+∥∥-isPropDep P = isOfHLevel→isOfHLevelDep 1 (λ _ → squash₁ )
+
+rec : { P : Type ℓ } → isProp P → ( A → P ) → ∥ A ∥₁ → P
+rec Pprop f ∣ x ∣₁ = f x
+rec Pprop f ( squash₁ x y i ) = Pprop ( rec Pprop f x ) ( rec Pprop f y ) i
+
+rec2 : { P : Type ℓ } → isProp P → ( A → B → P ) → ∥ A ∥₁ → ∥ B ∥₁ → P
+rec2 Pprop f ∣ x ∣₁ ∣ y ∣₁ = f x y
+rec2 Pprop f ∣ x ∣₁ ( squash₁ y z i ) = Pprop ( rec2 Pprop f ∣ x ∣₁ y ) ( rec2 Pprop f ∣ x ∣₁ z ) i
+rec2 Pprop f ( squash₁ x y i ) z = Pprop ( rec2 Pprop f x z ) ( rec2 Pprop f y z ) i
+
+rec3 : { P : Type ℓ } → isProp P → ( A → B → C → P ) → ∥ A ∥₁ → ∥ B ∥₁ → ∥ C ∥₁ → P
+rec3 Pprop f ∣ x ∣₁ ∣ y ∣₁ ∣ z ∣₁ = f x y z
+rec3 Pprop f ∣ x ∣₁ ∣ y ∣₁ ( squash₁ z w i ) = Pprop ( rec3 Pprop f ∣ x ∣₁ ∣ y ∣₁ z ) ( rec3 Pprop f ∣ x ∣₁ ∣ y ∣₁ w ) i
+rec3 Pprop f ∣ x ∣₁ ( squash₁ y z i ) w = Pprop ( rec3 Pprop f ∣ x ∣₁ y w ) ( rec3 Pprop f ∣ x ∣₁ z w ) i
+rec3 Pprop f ( squash₁ x y i ) z w = Pprop ( rec3 Pprop f x z w ) ( rec3 Pprop f y z w ) i
+
+
+
+
+
+
+recFin : { m : ℕ } { P : Fin m → Type ℓ }
+ { B : Type ℓ' } ( isPropB : isProp B )
+ → ((∀ i → P i ) → B )
+
+ → ((∀ i → ∥ P i ∥₁ ) → B )
+recFin { m = zero } _ untruncHyp _ = untruncHyp (λ ())
+recFin { m = suc m } { P = P } { B = B } isPropB untruncHyp truncFam =
+ curriedishTrunc ( truncFam zero ) ( truncFam ∘ suc )
+ where
+ curriedish : P zero → (∀ i → ∥ P ( suc i ) ∥₁ ) → B
+ curriedish p₀ = recFin isPropB
+ (λ famSuc → untruncHyp (λ { zero → p₀ ; ( suc i ) → famSuc i }))
+
+ curriedishTrunc : ∥ P zero ∥₁ → (∀ i → ∥ P ( suc i ) ∥₁ ) → B
+ curriedishTrunc = rec ( isProp→ isPropB ) curriedish
+
+recFin2 : { m1 m2 : ℕ } { P : Fin m1 → Fin m2 → Type ℓ }
+ { B : Type ℓ' } ( isPropB : isProp B )
+ → ((∀ i j → P i j ) → B )
+
+ → (∀ i j → ∥ P i j ∥₁ )
+ → B
+recFin2 { m1 = zero } _ untruncHyp _ = untruncHyp λ ()
+recFin2 { m1 = suc m1 } { P = P } { B = B } isPropB untruncHyp truncFam =
+ curriedishTrunc ( truncFam zero ) ( truncFam ∘ suc )
+ where
+ curriedish : (∀ j → P zero j ) → (∀ i j → ∥ P ( suc i ) j ∥₁ ) → B
+ curriedish p₀ truncFamSuc = recFin2 isPropB
+ (λ famSuc → untruncHyp λ { zero → p₀ ; ( suc i ) → famSuc i })
+ truncFamSuc
+
+ curriedishTrunc : (∀ j → ∥ P zero j ∥₁ ) → (∀ i j → ∥ P ( suc i ) j ∥₁ ) → B
+ curriedishTrunc = recFin ( isProp→ isPropB ) curriedish
+
+
+elim : { P : ∥ A ∥₁ → Type ℓ } → (( a : ∥ A ∥₁ ) → isProp ( P a ))
+ → (( x : A ) → P ∣ x ∣₁ ) → ( a : ∥ A ∥₁ ) → P a
+elim Pprop f ∣ x ∣₁ = f x
+elim Pprop f ( squash₁ x y i ) =
+ isOfHLevel→isOfHLevelDep 1 Pprop
+ ( elim Pprop f x ) ( elim Pprop f y ) ( squash₁ x y ) i
+
+elim2 : { P : ∥ A ∥₁ → ∥ B ∥₁ → Type ℓ }
+ ( Pprop : ( x : ∥ A ∥₁ ) ( y : ∥ B ∥₁ ) → isProp ( P x y ))
+ ( f : ( a : A ) ( b : B ) → P ∣ a ∣₁ ∣ b ∣₁ )
+ ( x : ∥ A ∥₁ ) ( y : ∥ B ∥₁ ) → P x y
+elim2 Pprop f =
+ elim (λ _ → isPropΠ (λ _ → Pprop _ _))
+ (λ a → elim (λ _ → Pprop _ _) ( f a ))
+
+elim3 : { P : ∥ A ∥₁ → ∥ B ∥₁ → ∥ C ∥₁ → Type ℓ }
+ ( Pprop : (( x : ∥ A ∥₁ ) ( y : ∥ B ∥₁ ) ( z : ∥ C ∥₁ ) → isProp ( P x y z )))
+ ( g : ( a : A ) ( b : B ) ( c : C ) → P ( ∣ a ∣₁ ) ∣ b ∣₁ ∣ c ∣₁ )
+ ( x : ∥ A ∥₁ ) ( y : ∥ B ∥₁ ) ( z : ∥ C ∥₁ ) → P x y z
+elim3 Pprop g = elim2 (λ _ _ → isPropΠ (λ _ → Pprop _ _ _))
+ (λ a b → elim (λ _ → Pprop _ _ _) ( g a b ))
+
+
+elimFin : { m : ℕ } { P : Fin m → Type ℓ }
+ { B : (∀ i → ∥ P i ∥₁ ) → Type ℓ' }
+ ( isPropB : ∀ x → isProp ( B x ))
+ → (( x : ∀ i → P i ) → B (λ i → ∣ x i ∣₁ ))
+
+ → (( x : ∀ i → ∥ P i ∥₁ ) → B x )
+elimFin { m = zero } { B = B } _ untruncHyp _ = subst B ( funExt (λ ())) ( untruncHyp (λ ()))
+elimFin { m = suc m } { P = P } { B = B } isPropB untruncHyp x =
+ subst B ( funExt (λ { zero → refl ; ( suc i ) → refl }))
+ ( curriedishTrunc ( x zero ) ( x ∘ suc ))
+ where
+ curriedish : ( x₀ : P zero ) ( xₛ : ∀ i → ∥ P ( suc i ) ∥₁ )
+ → B (λ { zero → ∣ x₀ ∣₁ ; ( suc i ) → xₛ i })
+ curriedish x₀ xₛ = subst B ( funExt (λ { zero → refl ; ( suc i ) → refl }))
+ ( elimFin (λ xₛ → isPropB (λ { zero → ∣ x₀ ∣₁ ; ( suc i ) → xₛ i }))
+ (λ y → subst B ( funExt (λ { zero → refl ; ( suc i ) → refl }))
+ ( untruncHyp (λ { zero → x₀ ; ( suc i ) → y i }))) xₛ )
+
+ curriedishTrunc : ( x₀ : ∥ P zero ∥₁ ) ( xₛ : ∀ i → ∥ P ( suc i ) ∥₁ )
+ → B (λ { zero → x₀ ; ( suc i ) → xₛ i })
+ curriedishTrunc = elim (λ _ → isPropΠ λ _ → isPropB _)
+ λ x₀ xₛ → subst B ( funExt (λ { zero → refl ; ( suc i ) → refl }))
+ ( curriedish x₀ xₛ )
+
+isPropPropTrunc : isProp ∥ A ∥₁
+isPropPropTrunc x y = squash₁ x y
+
+propTrunc≃ : A ≃ B → ∥ A ∥₁ ≃ ∥ B ∥₁
+propTrunc≃ e =
+ propBiimpl→Equiv
+ isPropPropTrunc isPropPropTrunc
+ ( rec isPropPropTrunc (λ a → ∣ e . fst a ∣₁ ))
+ ( rec isPropPropTrunc (λ b → ∣ invEq e b ∣₁ ))
+
+propTruncIdempotent≃ : isProp A → ∥ A ∥₁ ≃ A
+propTruncIdempotent≃ { A = A } hA = isoToEquiv f
+ where
+ f : Iso ∥ A ∥₁ A
+ Iso.fun f = rec hA ( idfun A )
+ Iso.inv f x = ∣ x ∣₁
+ Iso.rightInv f _ = refl
+ Iso.leftInv f = elim (λ _ → isProp→isSet isPropPropTrunc _ _) (λ _ → refl )
+
+propTruncIdempotent : isProp A → ∥ A ∥₁ ≡ A
+propTruncIdempotent hA = ua ( propTruncIdempotent≃ hA )
+
+
+elim' : { P : ∥ A ∥₁ → Type ℓ } → (( a : ∥ A ∥₁ ) → isProp ( P a )) →
+ (( x : A ) → P ∣ x ∣₁ ) → ( a : ∥ A ∥₁ ) → P a
+elim' { P = P } Pprop f a =
+ rec ( Pprop a ) (λ x → transp (λ i → P ( squash₁ ∣ x ∣₁ a i )) i0 ( f x )) a
+
+map : ( A → B ) → ( ∥ A ∥₁ → ∥ B ∥₁ )
+map f = rec squash₁ ( ∣_∣₁ ∘ f )
+
+map2 : ( A → B → C ) → ( ∥ A ∥₁ → ∥ B ∥₁ → ∥ C ∥₁ )
+map2 f = rec ( isPropΠ λ _ → squash₁ ) ( map ∘ f )
+
+
+
+
+
+
+module SetElim ( Bset : isSet B ) where
+ Bset' : isSet' B
+ Bset' = isSet→isSet' Bset
+
+ rec→Set : ( f : A → B ) ( kf : 2-Constant f ) → ∥ A ∥₁ → B
+ helper : ( f : A → B ) ( kf : 2-Constant f ) → ( t u : ∥ A ∥₁ )
+ → rec→Set f kf t ≡ rec→Set f kf u
+
+ rec→Set f kf ∣ x ∣₁ = f x
+ rec→Set f kf ( squash₁ t u i ) = helper f kf t u i
+
+ helper f kf ∣ x ∣₁ ∣ y ∣₁ = kf x y
+ helper f kf ( squash₁ t u i ) v
+ = Bset' ( helper f kf t v ) ( helper f kf u v ) ( helper f kf t u ) refl i
+ helper f kf t ( squash₁ u v i )
+ = Bset' ( helper f kf t u ) ( helper f kf t v ) refl ( helper f kf u v ) i
+
+ kcomp : ( f : ∥ A ∥₁ → B ) → 2-Constant ( f ∘ ∣_∣₁ )
+ kcomp f x y = cong f ( squash₁ ∣ x ∣₁ ∣ y ∣₁ )
+
+ Fset : isSet ( A → B )
+ Fset = isSetΠ ( const Bset )
+
+ Kset : ( f : A → B ) → isSet ( 2-Constant f )
+ Kset f = isSetΠ (λ _ → isSetΠ (λ _ → isProp→isSet ( Bset _ _)))
+
+ setRecLemma
+ : ( f : ∥ A ∥₁ → B )
+ → rec→Set ( f ∘ ∣_∣₁ ) ( kcomp f ) ≡ f
+ setRecLemma f i t
+ = elim { P = λ t → rec→Set ( f ∘ ∣_∣₁ ) ( kcomp f ) t ≡ f t }
+ (λ t → Bset _ _) (λ x → refl ) t i
+
+ mkKmap : ( ∥ A ∥₁ → B ) → Σ ( A → B ) 2-Constant
+ mkKmap f = f ∘ ∣_∣₁ , kcomp f
+
+ fib : ( g : Σ ( A → B ) 2-Constant ) → fiber mkKmap g
+ fib ( g , kg ) = rec→Set g kg , refl
+
+ eqv : ( g : Σ ( A → B ) 2-Constant ) → ∀ fi → fib g ≡ fi
+ eqv g ( f , p ) =
+ Σ≡Prop (λ f → isOfHLevelΣ 2 Fset Kset _ _)
+ ( cong ( uncurry rec→Set ) ( sym p ) ∙ setRecLemma f )
+
+ trunc→Set≃ : ( ∥ A ∥₁ → B ) ≃ ( Σ ( A → B ) 2-Constant )
+ trunc→Set≃ . fst = mkKmap
+ trunc→Set≃ . snd . equiv-proof g = fib g , eqv g
+
+
+
+
+ e : B → Σ ( A → B ) 2-Constant
+ e b = const b , λ _ _ → refl
+
+ eval : A → ( γ : Σ ( A → B ) 2-Constant ) → B
+ eval a₀ ( g , _) = g a₀
+
+ e-eval : ∀ ( a₀ : A ) γ → e ( eval a₀ γ ) ≡ γ
+ e-eval a₀ ( g , kg ) i . fst a₁ = kg a₀ a₁ i
+ e-eval a₀ ( g , kg ) i . snd a₁ a₂ = Bset' refl ( kg a₁ a₂ ) ( kg a₀ a₁ ) ( kg a₀ a₂ ) i
+
+ e-isEquiv : A → isEquiv ( e { A = A })
+ e-isEquiv a₀ = isoToIsEquiv ( iso e ( eval a₀ ) ( e-eval a₀ ) λ _ → refl )
+
+ preEquiv₁ : ∥ A ∥₁ → B ≃ Σ ( A → B ) 2-Constant
+ preEquiv₁ t = e , rec ( isPropIsEquiv e ) e-isEquiv t
+
+ preEquiv₂ : ( ∥ A ∥₁ → Σ ( A → B ) 2-Constant ) ≃ Σ ( A → B ) 2-Constant
+ preEquiv₂ = isoToEquiv ( iso to const (λ _ → refl ) retr )
+ where
+ to : ( ∥ A ∥₁ → Σ ( A → B ) 2-Constant ) → Σ ( A → B ) 2-Constant
+ to f . fst x = f ∣ x ∣₁ . fst x
+ to f . snd x y i = f ( squash₁ ∣ x ∣₁ ∣ y ∣₁ i ) . snd x y i
+
+ retr : retract to const
+ retr f i t . fst x = f ( squash₁ ∣ x ∣₁ t i ) . fst x
+ retr f i t . snd x y
+ = Bset'
+ (λ j → f ( squash₁ ∣ x ∣₁ ∣ y ∣₁ j ) . snd x y j )
+ ( f t . snd x y )
+ (λ j → f ( squash₁ ∣ x ∣₁ t j ) . fst x )
+ (λ j → f ( squash₁ ∣ y ∣₁ t j ) . fst y )
+ i
+
+ trunc→Set≃₂ : ( ∥ A ∥₁ → B ) ≃ Σ ( A → B ) 2-Constant
+ trunc→Set≃₂ = compEquiv ( equivΠCod preEquiv₁ ) preEquiv₂
+
+open SetElim public using ( rec→Set ; trunc→Set≃ )
+
+elim→Set
+ : { P : ∥ A ∥₁ → Type ℓ }
+ → (∀ t → isSet ( P t ))
+ → ( f : ( x : A ) → P ∣ x ∣₁ )
+ → ( kf : ∀ x y → PathP (λ i → P ( squash₁ ∣ x ∣₁ ∣ y ∣₁ i )) ( f x ) ( f y ))
+ → ( t : ∥ A ∥₁ ) → P t
+elim→Set { A = A } { P = P } Pset f kf t
+ = rec→Set ( Pset t ) g gk t
+ where
+ g : A → P t
+ g x = transp (λ i → P ( squash₁ ∣ x ∣₁ t i )) i0 ( f x )
+
+ gk : 2-Constant g
+ gk x y i = transp (λ j → P ( squash₁ ( squash₁ ∣ x ∣₁ ∣ y ∣₁ i ) t j )) i0 ( kf x y i )
+
+elim2→Set :
+ { P : ∥ A ∥₁ → ∥ B ∥₁ → Type ℓ }
+ → (∀ t u → isSet ( P t u ))
+ → ( f : ( x : A ) ( y : B ) → P ∣ x ∣₁ ∣ y ∣₁ )
+ → ( kf₁ : ∀ x y v → PathP (λ i → P ( squash₁ ∣ x ∣₁ ∣ y ∣₁ i ) ∣ v ∣₁ ) ( f x v ) ( f y v ))
+ → ( kf₂ : ∀ x v w → PathP (λ i → P ∣ x ∣₁ ( squash₁ ∣ v ∣₁ ∣ w ∣₁ i )) ( f x v ) ( f x w ))
+ → ( sf : ∀ x y v w → SquareP (λ i j → P ( squash₁ ∣ x ∣₁ ∣ y ∣₁ i ) ( squash₁ ∣ v ∣₁ ∣ w ∣₁ j ))
+ ( kf₂ x v w ) ( kf₂ y v w ) ( kf₁ x y v ) ( kf₁ x y w ))
+ → ( t : ∥ A ∥₁ ) → ( u : ∥ B ∥₁ ) → P t u
+elim2→Set { A = A } { B = B } { P = P } Pset f kf₁ kf₂ sf =
+ elim→Set (λ _ → isSetΠ (λ _ → Pset _ _)) mapHelper squareHelper
+ where
+ mapHelper : ( x : A ) ( u : ∥ B ∥₁ ) → P ∣ x ∣₁ u
+ mapHelper x = elim→Set (λ _ → Pset _ _) ( f x ) ( kf₂ x )
+
+ squareHelper : ( x y : A )
+ → PathP (λ i → ( u : ∥ B ∥₁ ) → P ( squash₁ ∣ x ∣₁ ∣ y ∣₁ i ) u ) ( mapHelper x ) ( mapHelper y )
+ squareHelper x y i = elim→Set (λ _ → Pset _ _) (λ v → kf₁ x y v i ) λ v w → sf x y v w i
+
+RecHProp : ( P : A → hProp ℓ ) ( kP : ∀ x y → P x ≡ P y ) → ∥ A ∥₁ → hProp ℓ
+RecHProp P kP = rec→Set isSetHProp P kP
+
+module GpdElim ( Bgpd : isGroupoid B ) where
+ Bgpd' : isGroupoid' B
+ Bgpd' = isGroupoid→isGroupoid' Bgpd
+
+ module _ ( f : A → B ) ( 3kf : 3-Constant f ) where
+ open 3-Constant 3kf
+
+ rec→Gpd : ∥ A ∥₁ → B
+ pathHelper : ( t u : ∥ A ∥₁ ) → rec→Gpd t ≡ rec→Gpd u
+ triHelper₁
+ : ( t u v : ∥ A ∥₁ )
+ → Square ( pathHelper t u ) ( pathHelper t v ) refl ( pathHelper u v )
+ triHelper₂
+ : ( t u v : ∥ A ∥₁ )
+ → Square ( pathHelper t v ) ( pathHelper u v ) ( pathHelper t u ) refl
+
+ rec→Gpd ∣ x ∣₁ = f x
+ rec→Gpd ( squash₁ t u i ) = pathHelper t u i
+
+ pathHelper ∣ x ∣₁ ∣ y ∣₁ = link x y
+ pathHelper ( squash₁ t u j ) v = triHelper₂ t u v j
+ pathHelper ∣ x ∣₁ ( squash₁ u v j ) = triHelper₁ ∣ x ∣₁ u v j
+
+ triHelper₁ ∣ x ∣₁ ∣ y ∣₁ ∣ z ∣₁ = coh₁ x y z
+ triHelper₁ ( squash₁ s t i ) u v
+ = Bgpd'
+ ( triHelper₁ s u v )
+ ( triHelper₁ t u v )
+ ( triHelper₂ s t u )
+ ( triHelper₂ s t v )
+ (λ i → refl )
+ (λ i → pathHelper u v )
+ i
+ triHelper₁ ∣ x ∣₁ ( squash₁ t u i ) v
+ = Bgpd'
+ ( triHelper₁ ∣ x ∣₁ t v )
+ ( triHelper₁ ∣ x ∣₁ u v )
+ ( triHelper₁ ∣ x ∣₁ t u )
+ (λ i → pathHelper ∣ x ∣₁ v )
+ (λ i → refl )
+ ( triHelper₂ t u v )
+ i
+ triHelper₁ ∣ x ∣₁ ∣ y ∣₁ ( squash₁ u v i )
+ = Bgpd'
+ ( triHelper₁ ∣ x ∣₁ ∣ y ∣₁ u )
+ ( triHelper₁ ∣ x ∣₁ ∣ y ∣₁ v )
+ (λ i → link x y )
+ ( triHelper₁ ∣ x ∣₁ u v )
+ (λ i → refl )
+ ( triHelper₁ ∣ y ∣₁ u v )
+ i
+
+ triHelper₂ ∣ x ∣₁ ∣ y ∣₁ ∣ z ∣₁ = coh₂ x y z
+ triHelper₂ ( squash₁ s t i ) u v
+ = Bgpd'
+ ( triHelper₂ s u v )
+ ( triHelper₂ t u v )
+ ( triHelper₂ s t v )
+ (λ i → pathHelper u v )
+ ( triHelper₂ s t u )
+ (λ i → refl )
+ i
+ triHelper₂ ∣ x ∣₁ ( squash₁ t u i ) v
+ = Bgpd'
+ ( triHelper₂ ∣ x ∣₁ t v )
+ ( triHelper₂ ∣ x ∣₁ u v )
+ (λ i → pathHelper ∣ x ∣₁ v )
+ ( triHelper₂ t u v )
+ ( triHelper₁ ∣ x ∣₁ t u )
+ (λ i → refl )
+ i
+ triHelper₂ ∣ x ∣₁ ∣ y ∣₁ ( squash₁ u v i )
+ = Bgpd'
+ ( triHelper₂ ∣ x ∣₁ ∣ y ∣₁ u )
+ ( triHelper₂ ∣ x ∣₁ ∣ y ∣₁ v )
+ ( triHelper₁ ∣ x ∣₁ u v )
+ ( triHelper₁ ∣ y ∣₁ u v )
+ (λ i → link x y )
+ (λ i → refl )
+ i
+
+ preEquiv₁ : ( ∥ A ∥₁ → Σ ( A → B ) 3-Constant ) ≃ Σ ( A → B ) 3-Constant
+ preEquiv₁ = isoToEquiv ( iso fn const (λ _ → refl ) retr )
+ where
+ open 3-Constant
+
+ fn : ( ∥ A ∥₁ → Σ ( A → B ) 3-Constant ) → Σ ( A → B ) 3-Constant
+ fn f . fst x = f ∣ x ∣₁ . fst x
+ fn f . snd . link x y i = f ( squash₁ ∣ x ∣₁ ∣ y ∣₁ i ) . snd . link x y i
+ fn f . snd . coh₁ x y z i j
+ = f ( squash₁ ∣ x ∣₁ ( squash₁ ∣ y ∣₁ ∣ z ∣₁ i ) j ) . snd . coh₁ x y z i j
+
+ retr : retract fn const
+ retr f i t . fst x = f ( squash₁ ∣ x ∣₁ t i ) . fst x
+ retr f i t . snd . link x y j
+ = f ( squash₁ ( squash₁ ∣ x ∣₁ ∣ y ∣₁ j ) t i ) . snd . link x y j
+ retr f i t . snd . coh₁ x y z
+ = Bgpd'
+ (λ k j → f ( cb k j i0 ) . snd . coh₁ x y z k j )
+ (λ k j → f ( cb k j i1 ) . snd . coh₁ x y z k j )
+ (λ k j → f ( cb i0 j k ) . snd . link x y j )
+ (λ k j → f ( cb i1 j k ) . snd . link x z j )
+ (λ _ → refl )
+ (λ k j → f ( cb j i1 k ) . snd . link y z j )
+ i
+ where
+ cb : I → I → I → ∥ _ ∥₁
+ cb i j k = squash₁ ( squash₁ ∣ x ∣₁ ( squash₁ ∣ y ∣₁ ∣ z ∣₁ i ) j ) t k
+
+ e : B → Σ ( A → B ) 3-Constant
+ e b . fst _ = b
+ e b . snd = record
+ { link = λ _ _ _ → b
+ ; coh₁ = λ _ _ _ _ _ → b
+ }
+
+ eval : A → Σ ( A → B ) 3-Constant → B
+ eval a₀ ( g , _) = g a₀
+
+ module _ where
+ open 3-Constant
+ e-eval : ∀( a₀ : A ) γ → e ( eval a₀ γ ) ≡ γ
+ e-eval a₀ ( g , 3kg ) i . fst x = 3kg . link a₀ x i
+ e-eval a₀ ( g , 3kg ) i . snd . link x y = λ j → 3kg . coh₁ a₀ x y j i
+ e-eval a₀ ( g , 3kg ) i . snd . coh₁ x y z
+ = Bgpd'
+ (λ _ _ → g a₀ )
+ ( 3kg . coh₁ x y z )
+ (λ k j → 3kg . coh₁ a₀ x y j k )
+ (λ k j → 3kg . coh₁ a₀ x z j k )
+ (λ _ → refl )
+ (λ k j → 3kg . coh₁ a₀ y z j k )
+ i
+
+ e-isEquiv : A → isEquiv ( e { A = A })
+ e-isEquiv a₀ = isoToIsEquiv ( iso e ( eval a₀ ) ( e-eval a₀ ) λ _ → refl )
+
+ preEquiv₂ : ∥ A ∥₁ → B ≃ Σ ( A → B ) 3-Constant
+ preEquiv₂ t = e , rec ( isPropIsEquiv e ) e-isEquiv t
+
+ trunc→Gpd≃ : ( ∥ A ∥₁ → B ) ≃ Σ ( A → B ) 3-Constant
+ trunc→Gpd≃ = compEquiv ( equivΠCod preEquiv₂ ) preEquiv₁
+
+open GpdElim using ( rec→Gpd ; trunc→Gpd≃ ) public
+
+squash₁ᵗ
+ : ∀( x y z : A )
+ → Square ( squash₁ ∣ x ∣₁ ∣ y ∣₁ ) ( squash₁ ∣ x ∣₁ ∣ z ∣₁ ) refl ( squash₁ ∣ y ∣₁ ∣ z ∣₁ )
+squash₁ᵗ x y z i = squash₁ ∣ x ∣₁ ( squash₁ ∣ y ∣₁ ∣ z ∣₁ i )
+
+elim→Gpd
+ : ( P : ∥ A ∥₁ → Type ℓ )
+ → (∀ t → isGroupoid ( P t ))
+ → ( f : ( x : A ) → P ∣ x ∣₁ )
+ → ( kf : ∀ x y → PathP (λ i → P ( squash₁ ∣ x ∣₁ ∣ y ∣₁ i )) ( f x ) ( f y ))
+ → ( 3kf : ∀ x y z
+ → SquareP (λ i j → P ( squash₁ᵗ x y z i j )) ( kf x y ) ( kf x z ) refl ( kf y z ))
+ → ( t : ∥ A ∥₁ ) → P t
+elim→Gpd { A = A } P Pgpd f kf 3kf t = rec→Gpd ( Pgpd t ) g 3kg t
+ where
+ g : A → P t
+ g x = transp (λ i → P ( squash₁ ∣ x ∣₁ t i )) i0 ( f x )
+
+ open 3-Constant
+
+ 3kg : 3-Constant g
+ 3kg . link x y i
+ = transp (λ j → P ( squash₁ ( squash₁ ∣ x ∣₁ ∣ y ∣₁ i ) t j )) i0 ( kf x y i )
+ 3kg . coh₁ x y z i j
+ = transp (λ k → P ( squash₁ ( squash₁ᵗ x y z i j ) t k )) i0 ( 3kf x y z i j )
+
+RecHSet : ( P : A → TypeOfHLevel ℓ 2 ) → 3-Constant P → ∥ A ∥₁ → TypeOfHLevel ℓ 2
+RecHSet P 3kP = rec→Gpd ( isOfHLevelTypeOfHLevel 2 ) P 3kP
+
+∥∥-IdempotentL-⊎-≃ : ∥ ∥ A ∥₁ ⊎ A′ ∥₁ ≃ ∥ A ⊎ A′ ∥₁
+∥∥-IdempotentL-⊎-≃ = isoToEquiv ∥∥-IdempotentL-⊎-Iso
+ where ∥∥-IdempotentL-⊎-Iso : Iso ( ∥ ∥ A ∥₁ ⊎ A′ ∥₁ ) ( ∥ A ⊎ A′ ∥₁ )
+ Iso.fun ∥∥-IdempotentL-⊎-Iso x = rec squash₁ lem x
+ where lem : ∥ A ∥₁ ⊎ A′ → ∥ A ⊎ A′ ∥₁
+ lem ( inl x ) = map (λ a → inl a ) x
+ lem ( inr x ) = ∣ inr x ∣₁
+ Iso.inv ∥∥-IdempotentL-⊎-Iso x = map lem x
+ where lem : A ⊎ A′ → ∥ A ∥₁ ⊎ A′
+ lem ( inl x ) = inl ∣ x ∣₁
+ lem ( inr x ) = inr x
+ Iso.rightInv ∥∥-IdempotentL-⊎-Iso x = squash₁ ( Iso.fun ∥∥-IdempotentL-⊎-Iso ( Iso.inv ∥∥-IdempotentL-⊎-Iso x )) x
+ Iso.leftInv ∥∥-IdempotentL-⊎-Iso x = squash₁ ( Iso.inv ∥∥-IdempotentL-⊎-Iso ( Iso.fun ∥∥-IdempotentL-⊎-Iso x )) x
+
+∥∥-IdempotentL-⊎ : ∥ ∥ A ∥₁ ⊎ A′ ∥₁ ≡ ∥ A ⊎ A′ ∥₁
+∥∥-IdempotentL-⊎ = ua ∥∥-IdempotentL-⊎-≃
+
+∥∥-IdempotentR-⊎-≃ : ∥ A ⊎ ∥ A′ ∥₁ ∥₁ ≃ ∥ A ⊎ A′ ∥₁
+∥∥-IdempotentR-⊎-≃ = isoToEquiv ∥∥-IdempotentR-⊎-Iso
+ where ∥∥-IdempotentR-⊎-Iso : Iso ( ∥ A ⊎ ∥ A′ ∥₁ ∥₁ ) ( ∥ A ⊎ A′ ∥₁ )
+ Iso.fun ∥∥-IdempotentR-⊎-Iso x = rec squash₁ lem x
+ where lem : A ⊎ ∥ A′ ∥₁ → ∥ A ⊎ A′ ∥₁
+ lem ( inl x ) = ∣ inl x ∣₁
+ lem ( inr x ) = map (λ a → inr a ) x
+ Iso.inv ∥∥-IdempotentR-⊎-Iso x = map lem x
+ where lem : A ⊎ A′ → A ⊎ ∥ A′ ∥₁
+ lem ( inl x ) = inl x
+ lem ( inr x ) = inr ∣ x ∣₁
+ Iso.rightInv ∥∥-IdempotentR-⊎-Iso x = squash₁ ( Iso.fun ∥∥-IdempotentR-⊎-Iso ( Iso.inv ∥∥-IdempotentR-⊎-Iso x )) x
+ Iso.leftInv ∥∥-IdempotentR-⊎-Iso x = squash₁ ( Iso.inv ∥∥-IdempotentR-⊎-Iso ( Iso.fun ∥∥-IdempotentR-⊎-Iso x )) x
+
+∥∥-IdempotentR-⊎ : ∥ A ⊎ ∥ A′ ∥₁ ∥₁ ≡ ∥ A ⊎ A′ ∥₁
+∥∥-IdempotentR-⊎ = ua ∥∥-IdempotentR-⊎-≃
+
+∥∥-Idempotent-⊎ : { A : Type ℓ } { A′ : Type ℓ' } → ∥ ∥ A ∥₁ ⊎ ∥ A′ ∥₁ ∥₁ ≡ ∥ A ⊎ A′ ∥₁
+∥∥-Idempotent-⊎ { A = A } { A′ } = ∥ ∥ A ∥₁ ⊎ ∥ A′ ∥₁ ∥₁ ≡⟨ ∥∥-IdempotentR-⊎ ⟩
+ ∥ ∥ A ∥₁ ⊎ A′ ∥₁ ≡⟨ ∥∥-IdempotentL-⊎ ⟩
+ ∥ A ⊎ A′ ∥₁ ∎
+
+∥∥-IdempotentL-×-≃ : ∥ ∥ A ∥₁ × A′ ∥₁ ≃ ∥ A × A′ ∥₁
+∥∥-IdempotentL-×-≃ = isoToEquiv ∥∥-IdempotentL-×-Iso
+ where ∥∥-IdempotentL-×-Iso : Iso ( ∥ ∥ A ∥₁ × A′ ∥₁ ) ( ∥ A × A′ ∥₁ )
+ Iso.fun ∥∥-IdempotentL-×-Iso x = rec squash₁ lem x
+ where lem : ∥ A ∥₁ × A′ → ∥ A × A′ ∥₁
+ lem ( a , a′ ) = map2 (λ a a′ → a , a′ ) a ∣ a′ ∣₁
+ Iso.inv ∥∥-IdempotentL-×-Iso x = map lem x
+ where lem : A × A′ → ∥ A ∥₁ × A′
+ lem ( a , a′ ) = ∣ a ∣₁ , a′
+ Iso.rightInv ∥∥-IdempotentL-×-Iso x = squash₁ ( Iso.fun ∥∥-IdempotentL-×-Iso ( Iso.inv ∥∥-IdempotentL-×-Iso x )) x
+ Iso.leftInv ∥∥-IdempotentL-×-Iso x = squash₁ ( Iso.inv ∥∥-IdempotentL-×-Iso ( Iso.fun ∥∥-IdempotentL-×-Iso x )) x
+
+∥∥-IdempotentL-× : ∥ ∥ A ∥₁ × A′ ∥₁ ≡ ∥ A × A′ ∥₁
+∥∥-IdempotentL-× = ua ∥∥-IdempotentL-×-≃
+
+∥∥-IdempotentR-×-≃ : ∥ A × ∥ A′ ∥₁ ∥₁ ≃ ∥ A × A′ ∥₁
+∥∥-IdempotentR-×-≃ = isoToEquiv ∥∥-IdempotentR-×-Iso
+ where ∥∥-IdempotentR-×-Iso : Iso ( ∥ A × ∥ A′ ∥₁ ∥₁ ) ( ∥ A × A′ ∥₁ )
+ Iso.fun ∥∥-IdempotentR-×-Iso x = rec squash₁ lem x
+ where lem : A × ∥ A′ ∥₁ → ∥ A × A′ ∥₁
+ lem ( a , a′ ) = map2 (λ a a′ → a , a′ ) ∣ a ∣₁ a′
+ Iso.inv ∥∥-IdempotentR-×-Iso x = map lem x
+ where lem : A × A′ → A × ∥ A′ ∥₁
+ lem ( a , a′ ) = a , ∣ a′ ∣₁
+ Iso.rightInv ∥∥-IdempotentR-×-Iso x = squash₁ ( Iso.fun ∥∥-IdempotentR-×-Iso ( Iso.inv ∥∥-IdempotentR-×-Iso x )) x
+ Iso.leftInv ∥∥-IdempotentR-×-Iso x = squash₁ ( Iso.inv ∥∥-IdempotentR-×-Iso ( Iso.fun ∥∥-IdempotentR-×-Iso x )) x
+
+∥∥-IdempotentR-× : ∥ A × ∥ A′ ∥₁ ∥₁ ≡ ∥ A × A′ ∥₁
+∥∥-IdempotentR-× = ua ∥∥-IdempotentR-×-≃
+
+∥∥-Idempotent-× : { A : Type ℓ } { A′ : Type ℓ' } → ∥ ∥ A ∥₁ × ∥ A′ ∥₁ ∥₁ ≡ ∥ A × A′ ∥₁
+∥∥-Idempotent-× { A = A } { A′ } = ∥ ∥ A ∥₁ × ∥ A′ ∥₁ ∥₁ ≡⟨ ∥∥-IdempotentR-× ⟩
+ ∥ ∥ A ∥₁ × A′ ∥₁ ≡⟨ ∥∥-IdempotentL-× ⟩
+ ∥ A × A′ ∥₁ ∎
+
+∥∥-Idempotent-×-≃ : { A : Type ℓ } { A′ : Type ℓ' } → ∥ ∥ A ∥₁ × ∥ A′ ∥₁ ∥₁ ≃ ∥ A × A′ ∥₁
+∥∥-Idempotent-×-≃ { A = A } { A′ } = compEquiv ∥∥-IdempotentR-×-≃ ∥∥-IdempotentL-×-≃
+
+∥∥-×-≃ : { A : Type ℓ } { A′ : Type ℓ' } → ∥ A ∥₁ × ∥ A′ ∥₁ ≃ ∥ A × A′ ∥₁
+∥∥-×-≃ { A = A } { A′ } = compEquiv ( invEquiv ( propTruncIdempotent≃ ( isProp× isPropPropTrunc isPropPropTrunc ))) ∥∥-Idempotent-×-≃
+
+∥∥-× : { A : Type ℓ } { A′ : Type ℓ' } → ∥ A ∥₁ × ∥ A′ ∥₁ ≡ ∥ A × A′ ∥₁
+∥∥-× = ua ∥∥-×-≃
+
+
+rec2→Set : { A B C : Type ℓ } ( Cset : isSet C )
+ → ( f : A → B → C )
+ → (∀ ( a a' : A ) ( b b' : B ) → f a b ≡ f a' b' )
+ → ∥ A ∥₁ → ∥ B ∥₁ → C
+rec2→Set { A = A } { B = B } { C = C } Cset f fconst = curry ( g ∘ ∥∥-×-≃ . fst )
+ where
+ g : ∥ A × B ∥₁ → C
+ g = rec→Set Cset ( uncurry f ) λ x y → fconst ( fst x ) ( fst y ) ( snd x ) ( snd y )
+
\ No newline at end of file
diff --git a/docs/Cubical.HITs.PropositionalTruncation.html b/docs/Cubical.HITs.PropositionalTruncation.html
new file mode 100644
index 0000000..30cfd97
--- /dev/null
+++ b/docs/Cubical.HITs.PropositionalTruncation.html
@@ -0,0 +1,9 @@
+
+Cubical.HITs.PropositionalTruncation {-# OPTIONS --safe #-}
+module Cubical.HITs.PropositionalTruncation where
+
+open import Cubical.HITs.PropositionalTruncation.Base public
+open import Cubical.HITs.PropositionalTruncation.Properties public
+
+open import Cubical.HITs.PropositionalTruncation.MagicTrick
+Cubical.Homotopy.Base {-# OPTIONS --safe #-}
+
+module Cubical.Homotopy.Base where
+
+open import Cubical.Foundations.Prelude
+open import Cubical.Foundations.Equiv.Properties
+
+private
+ variable
+ ℓ ℓ' : Level
+
+_∼_ : { X : Type ℓ } { Y : X → Type ℓ' } → ( f g : ( x : X ) → Y x ) → Type ( ℓ-max ℓ ℓ' )
+_∼_ { X = X } f g = ( x : X ) → f x ≡ g x
+
+funExt∼ : { X : Type ℓ } { Y : X → Type ℓ' } { f g : ( x : X ) → Y x } ( H : f ∼ g ) → f ≡ g
+funExt∼ = funExt
+
+∼-refl : { X : Type ℓ } { Y : X → Type ℓ' } { f : ( x : X ) → Y x } → f ∼ f
+∼-refl { f = f } = λ x → refl { x = f x }
+Cubical.Induction.WellFounded {-# OPTIONS --safe #-}
+
+module Cubical.Induction.WellFounded where
+
+open import Cubical.Foundations.Prelude
+
+Rel : ∀{ ℓ } → Type ℓ → ∀ ℓ' → Type _
+Rel A ℓ = A → A → Type ℓ
+
+module _ { ℓ ℓ' } { A : Type ℓ } ( _<_ : A → A → Type ℓ' ) where
+ WFRec : ∀{ ℓ'' } → ( A → Type ℓ'' ) → A → Type _
+ WFRec P x = ∀ y → y < x → P y
+
+ data Acc ( x : A ) : Type ( ℓ-max ℓ ℓ' ) where
+ acc : WFRec Acc x → Acc x
+
+ WellFounded : Type _
+ WellFounded = ∀ x → Acc x
+
+
+module _ { ℓ ℓ' } { A : Type ℓ } { _<_ : A → A → Type ℓ' } where
+ isPropAcc : ∀ x → isProp ( Acc _<_ x )
+ isPropAcc x ( acc p ) ( acc q )
+ = λ i → acc (λ y y<x → isPropAcc y ( p y y<x ) ( q y y<x ) i )
+
+ access : ∀{ x } → Acc _<_ x → WFRec _<_ ( Acc _<_ ) x
+ access ( acc r ) = r
+
+ private
+ wfi : ∀{ ℓ'' } { P : A → Type ℓ'' }
+ → ∀ x → ( wf : Acc _<_ x )
+ → (∀ x → (∀ y → y < x → P y ) → P x )
+ → P x
+ wfi x ( acc p ) e = e x λ y y<x → wfi y ( p y y<x ) e
+
+ module WFI ( wf : WellFounded _<_ ) where
+ module _ { ℓ'' } { P : A → Type ℓ'' } ( e : ∀ x → (∀ y → y < x → P y ) → P x ) where
+ private
+ wfi-compute : ∀ x ax → wfi x ax e ≡ e x (λ y _ → wfi y ( wf y ) e )
+ wfi-compute x ( acc p )
+ = λ i → e x (λ y y<x → wfi y ( isPropAcc y ( p y y<x ) ( wf y ) i ) e )
+
+ induction : ∀ x → P x
+ induction x = wfi x ( wf x ) e
+
+ induction-compute : ∀ x → induction x ≡ ( e x λ y _ → induction y )
+ induction-compute x = wfi-compute x ( wf x )
+Cubical.Structures.Axioms
+{-# OPTIONS --safe #-}
+module Cubical.Structures.Axioms where
+
+open import Cubical.Foundations.Prelude
+open import Cubical.Foundations.Equiv
+open import Cubical.Foundations.Function
+open import Cubical.Foundations.HLevels
+open import Cubical.Foundations.Isomorphism
+open import Cubical.Foundations.Univalence
+open import Cubical.Foundations.Path
+open import Cubical.Foundations.SIP
+open import Cubical.Data.Sigma
+
+private
+ variable
+ ℓ ℓ₁ ℓ₁' ℓ₂ : Level
+
+AxiomsStructure : ( S : Type ℓ → Type ℓ₁ )
+ ( axioms : ( X : Type ℓ ) → S X → Type ℓ₂ )
+ → Type ℓ → Type ( ℓ-max ℓ₁ ℓ₂ )
+AxiomsStructure S axioms X = Σ[ s ∈ S X ] ( axioms X s )
+
+AxiomsEquivStr : { S : Type ℓ → Type ℓ₁ } ( ι : StrEquiv S ℓ₁' )
+ ( axioms : ( X : Type ℓ ) → S X → Type ℓ₂ )
+ → StrEquiv ( AxiomsStructure S axioms ) ℓ₁'
+AxiomsEquivStr ι axioms ( X , ( s , a )) ( Y , ( t , b )) e = ι ( X , s ) ( Y , t ) e
+
+axiomsUnivalentStr : { S : Type ℓ → Type ℓ₁ }
+ ( ι : ( A B : TypeWithStr ℓ S ) → A . fst ≃ B . fst → Type ℓ₁' )
+ { axioms : ( X : Type ℓ ) → S X → Type ℓ₂ }
+ ( axioms-are-Props : ( X : Type ℓ ) ( s : S X ) → isProp ( axioms X s ))
+ ( θ : UnivalentStr S ι )
+ → UnivalentStr ( AxiomsStructure S axioms ) ( AxiomsEquivStr ι axioms )
+axiomsUnivalentStr { S = S } ι { axioms = axioms } axioms-are-Props θ { X , s , a } { Y , t , b } e =
+ ι ( X , s ) ( Y , t ) e
+ ≃⟨ θ e ⟩
+ PathP (λ i → S ( ua e i )) s t
+ ≃⟨ invEquiv ( Σ-contractSnd λ _ → isOfHLevelPathP' 0 ( axioms-are-Props _ _) _ _) ⟩
+ Σ[ p ∈ PathP (λ i → S ( ua e i )) s t ] PathP (λ i → axioms ( ua e i ) ( p i )) a b
+ ≃⟨ ΣPath≃PathΣ ⟩
+ PathP (λ i → AxiomsStructure S axioms ( ua e i )) ( s , a ) ( t , b )
+ ■
+
+inducedStructure : { S : Type ℓ → Type ℓ₁ }
+ { ι : ( A B : TypeWithStr ℓ S ) → A . fst ≃ B . fst → Type ℓ₁' }
+ ( θ : UnivalentStr S ι )
+ { axioms : ( X : Type ℓ ) → S X → Type ℓ₂ }
+ ( A : TypeWithStr ℓ ( AxiomsStructure S axioms )) ( B : TypeWithStr ℓ S )
+ → ( typ A , str A . fst ) ≃[ ι ] B
+ → TypeWithStr ℓ ( AxiomsStructure S axioms )
+inducedStructure θ { axioms } A B eqv =
+ B . fst , B . snd , subst ( uncurry axioms ) ( sip θ _ _ eqv ) ( A . snd . snd )
+
+transferAxioms : { S : Type ℓ → Type ℓ₁ }
+ { ι : ( A B : TypeWithStr ℓ S ) → A . fst ≃ B . fst → Type ℓ₁' }
+ ( θ : UnivalentStr S ι )
+ { axioms : ( X : Type ℓ ) → S X → Type ℓ₂ }
+ ( A : TypeWithStr ℓ ( AxiomsStructure S axioms )) ( B : TypeWithStr ℓ S )
+ → ( typ A , str A . fst ) ≃[ ι ] B
+ → axioms ( fst B ) ( snd B )
+transferAxioms θ { axioms } A B eqv =
+ subst ( uncurry axioms ) ( sip θ _ _ eqv ) ( A . snd . snd )
+
\ No newline at end of file
diff --git a/docs/Cubical.Structures.Pointed.html b/docs/Cubical.Structures.Pointed.html
new file mode 100644
index 0000000..c22c1bb
--- /dev/null
+++ b/docs/Cubical.Structures.Pointed.html
@@ -0,0 +1,61 @@
+
+Cubical.Structures.Pointed
+{-# OPTIONS --safe #-}
+module Cubical.Structures.Pointed where
+
+open import Cubical.Foundations.Prelude
+open import Cubical.Foundations.Equiv
+open import Cubical.Foundations.Equiv.Properties
+open import Cubical.Foundations.Univalence
+open import Cubical.Foundations.SIP
+
+open import Cubical.Foundations.Pointed.Base
+
+private
+ variable
+ ℓ : Level
+
+
+
+PointedStructure : Type ℓ → Type ℓ
+PointedStructure X = X
+
+PointedEquivStr : StrEquiv PointedStructure ℓ
+PointedEquivStr A B f = equivFun f ( pt A ) ≡ pt B
+
+pointedUnivalentStr : UnivalentStr { ℓ } PointedStructure PointedEquivStr
+pointedUnivalentStr f = invEquiv ( ua-ungluePath-Equiv f )
+
+pointedSIP : ( A B : Pointed ℓ ) → A ≃[ PointedEquivStr ] B ≃ ( A ≡ B )
+pointedSIP = SIP pointedUnivalentStr
+
+pointed-sip : ( A B : Pointed ℓ ) → A ≃[ PointedEquivStr ] B → ( A ≡ B )
+pointed-sip A B = equivFun ( pointedSIP A B )
+
+pointed-sip-idEquiv∙ : ( A : Pointed ℓ ) → pointed-sip A A ( idEquiv∙ A ) ≡ refl
+fst ( pointed-sip-idEquiv∙ A i j ) = uaIdEquiv i j
+snd ( pointed-sip-idEquiv∙ A i j ) = glue { φ = i ∨ ~ j ∨ j } (λ _ → pt A ) ( pt A )
+
+
+abstract
+ pointed-sip⁻ : ( A B : Pointed ℓ ) → ( A ≡ B ) → A ≃[ PointedEquivStr ] B
+ pointed-sip⁻ A B = invEq ( pointedSIP A B )
+
+ pointed-sip⁻-refl : ( A : Pointed ℓ ) → pointed-sip⁻ A A refl ≡ idEquiv∙ A
+ pointed-sip⁻-refl A = sym ( invEq ( equivAdjointEquiv ( pointedSIP A A )) ( pointed-sip-idEquiv∙ A ))
+
+pointedEquivAction : EquivAction { ℓ } PointedStructure
+pointedEquivAction e = e
+
+pointedTransportStr : TransportStr { ℓ } pointedEquivAction
+pointedTransportStr e s = sym ( transportRefl _)
+
\ No newline at end of file
diff --git a/docs/Realizability.PartialApplicativeStructure.html b/docs/Realizability.PartialApplicativeStructure.html
new file mode 100644
index 0000000..898be6e
--- /dev/null
+++ b/docs/Realizability.PartialApplicativeStructure.html
@@ -0,0 +1,128 @@
+
+Realizability.PartialApplicativeStructure {-# 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.Vec
+open import Cubical.Data.Nat
+open import Cubical.Data.Fin
+
+module Realizability.PartialApplicativeStructure { 𝓢 } where
+
+open import Realizability.Partiality { 𝓢 }
+open ♯_
+record PartialApplicativeStructure { ℓ } ( A : Type ℓ ) : Type ( ℓ-max ℓ ( ℓ-suc 𝓢 )) where
+ field
+ isSetA : isSet A
+ _⨾_ : A → A → ♯ A
+
+module _ { ℓ } { A : Type ℓ } ( pas : PartialApplicativeStructure A ) where
+ open PartialApplicativeStructure pas
+ infix 22 `_
+ infix 23 _̇_
+ data Term : ℕ → Type ℓ where
+ # : ∀ { n } → Fin n → Term n
+ `_ : A → Term zero
+ _̇_ : ∀ { n m } → Term m → Term n → Term ( max m n )
+
+ foo : ∀ a → Term 0
+ foo a = ` a
+
+ bar : Term 1
+ bar = # fzero
+
+ baz : Term 2
+ baz = ( # { n = 1 } fzero ) ̇ ( # { n = 2 } fone )
+
+ baz' : Term 1
+ baz' = ( # { n = 1 } fzero ) ̇ ( # { n = 1 } fzero )
+
+ isClosed : ∀ { n } → Term n → Type
+ isClosed { n } _ = n ≡ zero
+
+ isClosed-foo : ∀ a → isClosed ( foo a )
+ isClosed-foo a = refl
+
+ ClosedTerm : Type ℓ
+ ClosedTerm = Term zero
+
+ infix 23 _↓_
+ data _↓_ : ClosedTerm → ClosedTerm → Type ℓ where
+ ↓-refl : ∀ a → ( ` a ) ↓ ( ` a )
+ ↓-appl : ∀ { a b c s t } → s ↓ ( ` b ) → t ↓ ( ` c ) → ( s ̇ t ) ↓ a
+
+ infix 23 _denotes
+ _denotes : ClosedTerm → Type ℓ
+ t denotes = Σ[ a ∈ _ ] t ↓ a
+
+ denotationOf : ∀ { t } → t denotes → ClosedTerm
+ denotationOf { t } ( a , _) = a
+
+ record _＝_ ( a b : ClosedTerm ) : Type ℓ where
+ field
+ a-denotes : a denotes
+ b-denotes : b denotes
+ denote-≡ : denotationOf a-denotes ≡ denotationOf b-denotes
+
+
+
+ postulate substitute-app : ∀ { m n } → Term m → Term n → Vec ( ♯ A ) ( max m n ) → ♯ A
+
+ substitute : ∀ { n } → Term n → Vec ( ♯ A ) n → ♯ A
+ substitute ( ` a ) _ = return a
+ substitute { n } ( # k ) subs = lookup ( Fin→FinData n k ) subs
+ substitute ( a ̇ b ) subs = substitute-app a b subs
+
+
+
+
+ applicationChain : ∀ { n } → A → Vec A n → ♯ A
+ applicationChain a [] = return a
+ applicationChain a ( x ∷ xs ) = applicationChain' a ( x ∷ xs ) ( return a ) where
+ applicationChain' : ∀ { n } → A → Vec A n → ♯ A → ♯ A
+ applicationChain' _ [] acc = acc
+ applicationChain' a ( x ∷ xs ) acc = applicationChain' x xs ( acc >>= λ x → x ⨾ a )
+
+ record isInterpreted { n } ( t : Term n ) : Type ( ℓ-max ℓ ( ℓ-suc 𝓢 )) where
+ field
+ interpretation : A
+ applicationChainSupported : ∀ ( subs : Vec A n ) → applicationChain interpretation subs . support
+ naturality : ∀ ( subs : Vec A n ) → applicationChain interpretation subs ≈ substitute t ( map return subs )
+
+ isCombinatoriallyComplete : Type ( ℓ-max ℓ ( ℓ-suc 𝓢 ))
+ isCombinatoriallyComplete = ∀ { n } ( t : Term n ) → isInterpreted t
+
+
+
+
+ preK : Term 2
+ preK = # 0
+
+
+
+
+
+
+ preS : Term 3
+ preS = (( # { 3 } 0 ) ̇ ( # { 3 } 2 )) ̇ (( # { 3 } 1 ) ̇ ( # { 3 } 2 ))
+
+
+
+ module _ ( completeness : isCombinatoriallyComplete ) where
+ open isInterpreted
+ K : A
+ K = completeness preK . interpretation
+
+ S : A
+ S = completeness preS . interpretation
+
+ Kab-supported : ∀ a b → applicationChain K ( a ∷ b ∷ [] ) . support
+ Kab-supported a b = completeness preK . applicationChainSupported ( a ∷ b ∷ [] )
+
+ Kab≈a : ∀ a b → applicationChain K ( a ∷ b ∷ [] ) ≈ return a
+ Kab≈a a b = completeness preK . naturality ( a ∷ b ∷ [] )
+
+ Sabc≈ac_bc : ∀ a b c → applicationChain S ( a ∷ b ∷ c ∷ [] ) ≈ ( substitute preS ( map return ( a ∷ b ∷ c ∷ [] )))
+ Sabc≈ac_bc a b c = completeness preS . naturality ( a ∷ b ∷ c ∷ [] )
+Realizability.PartialCombinatoryAlgebra {-# OPTIONS --cubical #-}
-open import Cubical.Core.Everything
-open import Cubical.Foundations.Prelude
-open import Realizability.Partiality
-open import Realizability.BinaryApplicativeStructure
+Realizability.PartialCombinatoryAlgebra {-# OPTIONS --cubical --allow-unsolved-metas #-}
+open import Cubical.Core.Everything
+open import Cubical.Foundations.Prelude
-module Realizability.PartialCombinatoryAlgebra where
+module Realizability.PartialCombinatoryAlgebra { 𝓢 } where
-record PartialCombinatoryAlgebra { ℓ } ( A : Type ℓ ) ( pas : PartialApplicativeStructure A ) : Type ℓ where
- open PartialApplicativeStructure pas
- field
- s : A
- k : A
- kab≡a : ∀ ( a b : ♯ A ) → ( η k ) ̇ a ̇ b ≡ a
- sabc≡ac_bc : ∀ a b c → ( η s ) ̇ a ̇ b ̇ c ≡ ( a ̇ c ) ̇ ( b ̇ c )
+open import Realizability.Partiality { 𝓢 }
open import Cubical.Core.Everything
open import Cubical.Foundations.Prelude
open import Cubical.Data.Nat
-open import Cubical.Foundations.HLevels
-
-module Realizability.Partiality where
-
-
-
-
-
-data ♯_ { ℓ } ( A : Type ℓ ) : Type ℓ
-data _⊑_ { ℓ } { A : Type ℓ } : ♯ A → ♯ A → Type ℓ
-data ♯_ A where
- η : A → ♯ A
- ⊥ : ♯ A
- ⨆ : ( s : ℕ → ♯ A )
- → (∀ n → ( s n ) ⊑ ( s ( suc n )))
- → ♯ A
- α : ∀ x y
- → x ⊑ y
- → y ⊑ x
- → x ≡ y
- setTrunc : isSet ( ♯ A )
-data _⊑_ { ℓ } { A } where
- ⊑-refl : ∀ x → x ⊑ x
- ⊑-trans : ∀ x y z → x ⊑ y → y ⊑ z → x ⊑ z
- ⊑-bottom : ∀ x → ⊥ ⊑ x
- ⊑-ub : ∀ s p → (∀ n → s n ⊑ ( ⨆ s p ))
- ⊑-lub : ∀ s p x → (∀ n → s n ⊑ x ) → ( ⨆ s p ) ⊑ x
- propTrunc : ∀ x y → isProp ( x ⊑ y )
-
-infix 20 _⊑_
-infix 21 ♯_
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-module _ { ℓ } ( A : Type ℓ ) where
-
- record PartialityAlgebra { ℓ' ℓ'' } ( X : Type ℓ' ) ( _⊑X_ : X → X → Type ℓ'' ) : Type ( ℓ-max ( ℓ-max ℓ' ℓ'' ) ( ℓ-max ℓ ℓ' )) where
- field
-
- isSetX : isSet X
- isProp⊑ : ∀ x y → isProp ( x ⊑X y )
- ηX : A → X
- ⊥X : X
- ⨆X : ( s : ℕ → X ) → (∀ n → ( s n ) ⊑X ( s ( suc n ))) → X
-
-
-
- αX : ∀ x y → x ⊑X y → y ⊑X x → x ≡ y
- ⊑X-refl : ∀ x → x ⊑X x
- ⊑X-trans : ∀ x y z → x ⊑X y → y ⊑X z → x ⊑X z
- ⊑X-bottom : ∀ x → ⊥X ⊑X x
- ⊑X-ub : ( s : ℕ → X ) → ( p : (∀ n → ( s n ) ⊑X ( s ( suc n )))) → ( n : ℕ ) → ( s n ) ⊑X ( ⨆X s p )
- ⊑X-lub : ∀ x → ( s : ℕ → X ) → ( p : (∀ n → ( s n ) ⊑X ( s ( suc n )))) → (∀ n → s n ⊑X x ) → ( ⨆X s p ) ⊑X x
-
-
- record PartialityAlgebraHomomorphism { 𝔁 𝔂 𝔁' 𝔂' } { X : Type 𝔁 } { _⊑X_ : X → X → Type 𝔁' } { Y : Type 𝔂 } { _⊑Y_ : Y → Y → Type 𝔂' } ( XAlgebra : PartialityAlgebra X _⊑X_ ) ( YAlgebra : PartialityAlgebra Y _⊑Y_ ) : Type ( ℓ-max ( ℓ-max ( ℓ-max 𝔁 ℓ ) 𝔂 ) ( ℓ-max ( ℓ-max ℓ 𝔁' ) 𝔂' )) where
- open PartialityAlgebra XAlgebra
- open PartialityAlgebra YAlgebra renaming ( ⊥X to ⊥Y ; ηX to ηY ; ⨆X to ⨆Y )
- field
- map : X → Y
- monotone : ∀ x x' → x ⊑X x' → ( map x ) ⊑Y ( map x' )
- ⊥-preserve : map ⊥X ≡ ⊥Y
- η-preserve : ∀ a → map ( ηX a ) ≡ ηY a
- ⨆-preserve : ( s : ℕ → X )
- → ( p : (∀ n → ( s n ) ⊑X ( s ( suc n ))))
- → map ( ⨆X s p ) ≡ ⨆Y (λ n → map ( s n )) (λ n → monotone ( s n ) ( s ( suc n )) ( p n ))
-
- open PartialityAlgebra
- ♯A-PartialityAlgebra : PartialityAlgebra ( ♯ A ) ( _⊑_ { A = A })
- ♯A-PartialityAlgebra . isSetX = setTrunc
- ♯A-PartialityAlgebra . isProp⊑ = propTrunc
- ♯A-PartialityAlgebra . ηX = η
- ♯A-PartialityAlgebra . ⊥X = ⊥
- ♯A-PartialityAlgebra . ⨆X = ⨆
- ♯A-PartialityAlgebra . αX = α
- ♯A-PartialityAlgebra . ⊑X-refl = ⊑-refl
- ♯A-PartialityAlgebra . ⊑X-trans = ⊑-trans
- ♯A-PartialityAlgebra . ⊑X-bottom = ⊑-bottom
- ♯A-PartialityAlgebra . ⊑X-ub = ⊑-ub
- ♯A-PartialityAlgebra . ⊑X-lub x s p = ⊑-lub s p x
-
-
-
-
-
-
-
-
- record isInitial { 𝔂 𝔂' } { Y : Type 𝔂 } { _⊑Y_ : Y → Y → Type 𝔂' } ( initial : PartialityAlgebra Y _⊑Y_ ) : Typeω where
- field
- morph : ∀ { 𝔁 𝔁' } → ( X : Type 𝔁 ) → ( _⊑X_ : X → X → Type 𝔁' ) → ( object : PartialityAlgebra X _⊑X_ ) → PartialityAlgebraHomomorphism initial object
- uniqueness : ∀ { 𝔁 𝔁' } → ( X : Type 𝔁 ) → ( _⊑X_ : X → X → Type 𝔁' ) → ( object : PartialityAlgebra X _⊑X_ ) → isContr ( PartialityAlgebraHomomorphism initial object )
-
-
- open PartialityAlgebraHomomorphism
-
- module _ { 𝔁 𝔁' } ( X : Type 𝔁 ) ( _⊑X_ : X → X → Type 𝔁' ) ( object : PartialityAlgebra X _⊑X_ ) where
- {-# TERMINATING #-}
- ♯A-morphs : PartialityAlgebraHomomorphism ♯A-PartialityAlgebra object
- ♯A-morphs . map ( η a ) = object . ηX a
- ♯A-morphs . map ⊥ = object . ⊥X
- ♯A-morphs . map ( ⨆ s p ) = object . ⨆X (λ n → ♯A-morphs . map ( s n )) λ n → ♯A-morphs . monotone ( s n ) ( s ( suc n )) ( p n )
- ♯A-morphs . map ( α x y x⊑y y⊑x i ) = object . αX ( ♯A-morphs . map x ) ( ♯A-morphs . map y ) ( ♯A-morphs . monotone x y x⊑y ) ( ♯A-morphs . monotone y x y⊑x ) i
- ♯A-morphs . map ( setTrunc x y p q i j ) = object . isSetX ( ♯A-morphs . map x ) ( ♯A-morphs . map y ) ( cong ( ♯A-morphs . map ) p ) ( cong ( ♯A-morphs . map ) q ) i j
- ♯A-morphs . monotone x x ( ⊑-refl x ) = object . ⊑X-refl ( ♯A-morphs . map x )
- ♯A-morphs . monotone x z ( ⊑-trans x y z x⊑y y⊑z ) = object . ⊑X-trans ( ♯A-morphs . map x ) ( ♯A-morphs . map y ) ( ♯A-morphs . map z ) ( ♯A-morphs . monotone _ _ x⊑y ) ( ♯A-morphs . monotone _ _ y⊑z )
- ♯A-morphs . monotone _ x ( ⊑-bottom x ) = object . ⊑X-bottom ( ♯A-morphs . map x )
- ♯A-morphs . monotone _ _ ( ⊑-ub s p index ) = object . ⊑X-ub (λ n → ♯A-morphs . map ( s n )) (λ n → ♯A-morphs . monotone _ _ ( p n )) index
- ♯A-morphs . monotone _ _ ( ⊑-lub s p x fam ) = object . ⊑X-lub ( ♯A-morphs . map x ) (λ n → ♯A-morphs . map ( s n )) (λ n → ♯A-morphs . monotone _ _ ( p n )) (λ n → ♯A-morphs . monotone _ _ ( fam n ))
- ♯A-morphs . monotone _ _ ( propTrunc x y p q i ) = object . isProp⊑ ( ♯A-morphs . map x ) ( ♯A-morphs . map y ) ( ♯A-morphs . monotone _ _ p ) ( ♯A-morphs . monotone _ _ q ) i
- ♯A-morphs . ⊥-preserve = refl
- ♯A-morphs . η-preserve a = refl
- ♯A-morphs . ⨆-preserve s p = refl
-
- open isInitial
- ♯A-isInitial : isInitial ♯A-PartialityAlgebra
- ♯A-isInitial . morph = ♯A-morphs
- ♯A-isInitial . uniqueness X _⊑X_ object . fst = ♯A-isInitial . morph X _⊑X_ object
- ♯A-isInitial . uniqueness X _⊑X_ object . snd f = {!!}
-
-
-_⇀_ : ∀ { ℓ ℓ' } → Type ℓ → Type ℓ' → Type ( ℓ-max ℓ ℓ' )
-A ⇀ B = A → ♯ B
-
-
-return : ∀ { ℓ } → { A : Type ℓ } → A → ♯ A
-return = η
-
-
-_>>=_ : ∀ { ℓ ℓ' } → { A : Type ℓ } { B : Type ℓ' } → ♯ A → ( A → ♯ B ) → ♯ B
-( η a ) >>= f = ( f a )
-⊥ >>= f = ⊥
-( ⨆ s p ) >>= f = ⨆ (λ n → ( s n ) >>= f ) λ n → {!!}
-( α x y x⊑y y⊑x i ) >>= f = α ( x >>= f ) ( y >>= f ) {!!} {!!} i
-( setTrunc x y p q i j ) >>= f = setTrunc ( x >>= f ) ( y >>= f ) ( cong (λ x → x >>= f ) p ) ( cong (λ x → x >>= f ) q ) i j
+open import Cubical.Data.Unit
+open import Cubical.Data.Sigma
+open import Cubical.Foundations.HLevels
+open import Cubical.Foundations.Function
+open import Cubical.Foundations.Isomorphism
+open import Cubical.Foundations.Univalence
+open import Cubical.Foundations.Structure
+open import Cubical.Foundations.SIP
+
+module Realizability.Partiality { 𝓢 } where
+
+infix 20 ♯_
+
+record ♯_ { ℓ } ( A : Type ℓ ) : Type ( ℓ-max ℓ ( ℓ-suc 𝓢 )) where
+ field
+ support : Type 𝓢
+ isProp-support : isProp support
+ force : support → A
+
+open ♯_
+
+return : ∀ { ℓ } { A : Type ℓ } → A → ♯ A
+return a . support = Unit*
+return a . isProp-support = isPropUnit*
+return a . force _ = a
+
+infixl 21 _>>=_
+_>>=_ : ∀ { ℓ } { A B : Type ℓ } → ♯ A → ( A → ♯ B ) → ♯ B
+( ♯a >>= f ) . support = Σ[ s ∈ ( ♯a . support ) ] (( f ( ♯a . force s )) . support )
+( ♯a >>= f ) . isProp-support = isPropΣ ( ♯a . isProp-support ) λ x → f ( ♯a . force x ) . isProp-support
+( ♯a >>= f ) . force ( s , s' ) = f ( ♯a . force s ) . force s'
+
+map-♯ : ∀ { ℓ } { A B : Type ℓ } → ( A → B ) → ( ♯ A → ♯ B )
+map-♯ f ♯a . support = ♯a . support
+map-♯ f ♯a . isProp-support = ♯a . isProp-support
+map-♯ f ♯a . force s = f ( ♯a . force s )
+
+
+
+join : ∀ { ℓ } { A : Type ( ℓ-max ℓ ( ℓ-suc 𝓢 ))} → ♯ ♯ A → ♯ A
+join { ℓ } { A } ♯♯a = ♯♯a >>= ( idfun ( ♯ A ))
+
+♯-id : ∀ { ℓ } { A : Type ℓ } → map-♯ ( idfun A ) ≡ ( idfun ( ♯ A ))
+♯-id = refl
+
+♯-∘ : ∀ { ℓ } { A B C : Type ℓ } → ( f : A → B ) → ( g : B → C ) → map-♯ ( g ∘ f ) ≡ map-♯ g ∘ map-♯ f
+♯-∘ f g = refl
+
+infixl 21 _>=>_
+_>=>_ : ∀ { ℓ } { A B C : Type ℓ } → ( A → ♯ B ) → ( B → ♯ C ) → ( A → ♯ C )
+( f >=> g ) a = do
+ b ← f a
+ g b
+
+isTotal : ∀ { ℓ } { A B : Type ℓ } → ( f : A → ♯ B ) → Type ( ℓ-max 𝓢 ℓ )
+isTotal f = ∀ x → ( f x ) . support
+
+range : ∀ { ℓ } { A B : Type ℓ } → ( f : A → ♯ B ) → B → Type ( ℓ-max ℓ ( ℓ-suc 𝓢 ))
+range { A = A } f b = ∃[ a ∈ A ] f a ≡ return b
+
+domain : ∀ { ℓ } { A B : Type ℓ } → ( f : A → ♯ B ) → A → Type _
+domain f a = ( f a ) . support
+
+record _≈_ { ℓ } { A : Type ℓ } ( x y : ♯ A ) : Type ( ℓ-max ℓ ( ℓ-suc 𝓢 )) where
+ field
+ support-≃ : x . support ≃ y . support
+ force-≡ : x . force ≡ y . force ∘ ( support-≃ . fst )
+open _≈_
+
+
+
+return-left-identity : ∀ { ℓ } { A B : Type ℓ } ( f : A → ♯ B ) ( x : A ) → ( return >=> f ) x ≈ f x
+return-left-identity f x . support-≃ = isoToEquiv ( iso (λ ( tt* , support ) → support ) (λ support → ( tt* , support )) (λ b → refl ) (λ ( tt* , support ) → refl ))
+return-left-identity f x . force-≡ i ( tt* , fx-support ) = f x . force fx-support
+
+return-right-identity : ∀ { ℓ } { A B : Type ℓ } ( f : A → ♯ B ) ( x : A ) → ( f >=> return ) x ≈ f x
+return-right-identity f x . support-≃ = isoToEquiv ( iso (λ ( support , tt* ) → support ) (λ support → ( support , tt* )) (λ b → refl ) λ ( support , tt* ) → refl )
+return-right-identity f x . force-≡ i ( fx-support , tt* ) = f x . force fx-support
+
+
+>=>-assoc : ∀ { ℓ } { A B C D : Type ℓ } ( f : A → ♯ B ) ( g : B → ♯ C ) ( h : C → ♯ D ) ( x : A ) → ( f >=> g >=> h ) x ≈ ( f >=> ( g >=> h )) x
+>=>-assoc f g h x . support-≃ = isoToEquiv ( iso (λ (( fx-support , g-fx-forces-support ) , hgfx-support ) → fx-support , ( g-fx-forces-support , hgfx-support )) (λ ( fx-support , ( g-fx-forces-support , hgfx-support )) → ( fx-support , g-fx-forces-support ) , hgfx-support ) (λ b → refl ) λ a → refl )
+>=>-assoc f g h x . force-≡ i (( fx-support , gfx-support ) , hgfx-support ) = ( h (( g (( f x ) . force fx-support )) . force gfx-support )) . force hgfx-support
+
module index where
open import Realizability.Partiality
-open import Realizability.BinaryApplicativeStructure
-open import Realizability.PartialCombinatoryAlgebra
+open import Realizability.PartialApplicativeStructure
+open import Realizability.PartialCombinatoryAlgebra