Permalink
Browse files

finish library revisions

  • Loading branch information...
1 parent c06ab31 commit 11914dd8dd01c16398101e77268c40e4a91ccdaa @dlicata335 committed Jan 16, 2013
View
18 README
@@ -1,18 +1,18 @@
oldlib
a bunch of stuff using an older version of lib/
- some of this needs to be resuccitated
+ some of this needs to be resuccitated, like joseph's code in applications/torus2
lib
basic constructions of homotopy type theory
-applications
- applications of homotopy type theory to proving/formalizing/reasoning
- Currently includes:
- (1) a proof that higher fundamental groups are abelian
+homotopy
+ applications of homotopy type theory to formalizing homotopy theory
+
+programming
+ applications of homotopy type theory to programming
+
+computational-interp
+ code having to do with the computational interpretation or 2tt
misc
miscellaneous little experiments
- Currently includes:
- (1) a proof that set extensionality (univalence) implies functional extensionality
- (2) a start at a translation of Voevodsky's basic definitions into Agda
- (3) working out the contradiction between univalence and UIP
@@ -0,0 +1,32 @@
+{-# OPTIONS --type-in-type --without-K #-}
+
+open import lib.Prelude
+open Paths
+
+module computational-interp.JFromSubst where
+
+ j-transport : {A : Set} {M : A} (C : (x : A) -> Path M x -> Set)
+ -> {N : A} -> (P : Path M N)
+ -> (C M id)
+ -> C N P
+ j-transport {A}{M}C {N} α =
+ transport (\ (p : Σ \ y -> Path M y) -> C (fst p) (snd p))
+ (pair≃ α (transport-Path-right α id))
+
+
+ j-transport-compute : {A : Set} {M : A} (C : (x : A) -> Path M x -> Set)
+ -> (M0 : C M id)
+ -> j-transport C id M0 ≃ M0
+ j-transport-compute {A}{M} C M0 =
+ transport (λ (p : Σ (λ y Path M y)) C (fst p) (snd p))
+ (pair≃ id (transport-Path-right id id)) M0 ≃〈 id 〉 -- transport-Path-post id id ≡ id
+ transport (λ (p : Σ (λ y Path M y)) C (fst p) (snd p))
+ (pair≃ id id) M0 ≃〈 id 〉 -- pair≃ id id ≃ id
+ transport (λ (p : Σ (λ y Path M y)) C (fst p) (snd p))
+ id M0 ≃〈 id 〉
+ M0 ∎
+
+
+
+
+
@@ -0,0 +1,99 @@
+
+{-# OPTIONS --type-in-type --without-K #-}
+
+open import lib.Prelude hiding (_×_ ; fst ; snd; _,_; fst≃; snd≃; pair≃ ; transport-×; ×≃η; ×≃β1; ×≃β2; ∘-×)
+open Paths
+
+module computational-interp.ProdHigherBetaEta where
+
+ -- derived form
+ record _×_ (A : Set) (B : Set) : Set where
+ constructor _,_
+ field
+ fst : A
+ snd : B
+ open _×_
+
+ transport-× : {Γ : Set} {θ1 θ2 : Γ} (δ : θ1 ≃ θ2)
+ (A : Γ -> Set) (B : (γ : Γ) -> Set)
+ -> transport (\ γ -> A γ × B γ) δ
+ ≃ (\ p -> (transport A δ (fst p) , transport B δ (snd p)))
+ transport-× id A B = id
+
+ fst≃ : {A B : Set} {p q : A × B} -> p ≃ q -> (fst p) ≃ (fst q)
+ fst≃ = ap fst
+
+ snd≃ : {A B : Set} {p q : A × B} -> p ≃ q -> (snd p) ≃ (snd q)
+ snd≃ = ap snd
+
+ pair≃ : {A B : Set} {p q : A × B} -> (fst p) ≃ (fst q) -> (snd p) ≃ (snd q) -> p ≃ q
+ pair≃ a b = ap2 _,_ a b
+
+ ap-ap2-o : {A B C D : Set} (g : C -> D) (f : A -> B -> C)
+ {M N : A} (α : M ≃ N)
+ {M' N' : B} (β : M' ≃ N')
+ -> ap2 (\ x y -> g (f x y)) α β ≃ ap g (ap2 f α β)
+ ap-ap2-o _ _ id id = id
+
+ ap2-ap-o : {A B C A' : Set} (f : A -> B -> C) (g1 : A' -> A) (g2 : A' -> B)
+ {M N : A'} (α : M ≃ N)
+ -> ap (\ x -> f (g1 x) (g2 x)) α ≃ ap2 f (ap g1 α) (ap g2 α)
+ ap2-ap-o _ _ _ id = id
+
+ ×≃η : {A B : Set} {p q : A × B} -> (α : p ≃ q) -> (pair≃ (fst≃ α) (snd≃ α)) ≃ α
+ ×≃η α = ap-id _ ∘ ! (ap2-ap-o _,_ fst snd α)
+
+ ×≃β1 : {A B : Set} {p q : A × B}
+ (α : Id (fst p) (fst q))
+ (β : Id (snd p) (snd q))
+ -> Id (fst≃ (pair≃ α β)) α
+ ×≃β1 α β = ap2-β1 α β ∘ ! (ap-ap2-o fst _,_ α β)
+
+ ×≃β2 : {A B : Set} {p q : A × B}
+ (α : Id (fst p) (fst q))
+ (β : Id (snd p) (snd q))
+ -> (snd≃ (pair≃ α β)) ≃
+ β
+ ×≃β2 {p = x , y} {q = .x , .y} id id = id
+
+ ∘-× : {A : Set} {M N P Q R S : A} (a : N ≃ P) (b : R ≃ S) (c : M ≃ N) (d : Q ≃ R)
+ -> pair≃ a b ∘ pair≃ c d ≃ pair≃ (a ∘ c) (b ∘ d)
+ ∘-× id id id id = id
+
+ -- ap-×-fst : {A B : Set} {N M : A} -> (f : A -> B) -> (y : B) -> (α : M ≃ N) ->
+ -- ap (λ x → f (x) , y) α ≃
+ -- nondep-pair≃ (ap (λ x → f x) α) (ap (λ _ → y) α)
+ -- ap-×-fst _ _ id = id
+
+ -- ap-×-snd : {A B : Set} {N M : A} -> (f : A -> B) -> (y : B) -> (α : M ≃ N) ->
+ -- ap (λ x → y , f (x)) α ≃
+ -- nondep-pair≃ (ap (λ _ → y) α) (ap (λ x → f (x)) α)
+ -- ap-×-snd _ _ id = id
+
+ module ThreeCells where
+
+ pair≃3 : {A B : Set} {p q : A × B}
+ {α1 α2 : Id (fst p) (fst q)}
+ {β1 β2 : Id (snd p) (snd q)}
+ -> α1 ≃ α2
+ -> β1 ≃ β2
+ -> (pair≃ α1 β1) ≃ (pair≃ α2 β2)
+ pair≃3 a b = ap2 pair≃ a b
+
+ fst≃3 : {A B : Set} {p q : A × B} {α β : p ≃ q}
+ -> α ≃ β
+ -> fst≃ α ≃ fst≃ β
+ fst≃3 a = ap fst≃ a
+
+ snd≃3 : {A B : Set} {p q : A × B} {α β : p ≃ q}
+ -> α ≃ β
+ -> snd≃ α ≃ snd≃ β
+ snd≃3 a = ap snd≃ a
+
+ ×β3-1 : {A B : Set} {p q : A × B}
+ {α1 α2 : Id (fst p) (fst q)}
+ {β1 β2 : Id (snd p) (snd q)}
+ (γ : α1 ≃ α2)
+ (γ' : β1 ≃ β2)
+ -> fst≃3 (pair≃3 γ γ') ≃ ! (×≃β1 α2 β2) ∘ γ ∘ ×≃β1 α1 β1
+ ×β3-1 γ γ' = {!ap2-ap (λ≃ \ x -> λ≃ \ y -> ×≃β1 x y) γ γ' !} ∘ ! (ap-ap2-o fst≃ pair≃ γ γ')
@@ -0,0 +1,114 @@
+{-# OPTIONS --type-in-type --without-K #-}
+
+open import lib.Prelude
+open Paths
+open
+
+module homotopy.HigherHomotopyAbelian (A : Set) (base : A) where
+
+ Ω1 : Set
+ Ω1 = base ≃ base
+
+ Ω2 : Set
+ Ω2 = Path{Ω1} id id
+
+ _⊙_ : Ω2 Ω2 Ω2
+ a ⊙ b = ap∘ a b
+
+ ⊙-unit-l : (p : Ω2) (id ⊙ p) ≃ p
+ ⊙-unit-l p = ∘-unit-l p ∘ ap∘-unit-l p -- because we know the base is id, the adjustment cancels
+
+ ⊙-unit-r : (a : Ω2) (a ⊙ id) ≃ a
+ ⊙-unit-r a = ap∘-unit-r a
+
+ interchange : (a b c d : _) ((a ∘ b) ⊙ (c ∘ d)) ≃ ((a ⊙ c) ∘ (b ⊙ d))
+ interchange a b c d = ichange-type d c b a
+
+ same : (a b : Ω2) (a ∘ b) ≃ (a ⊙ b)
+ same a b = (( a ∘ b) ≃〈 ap (λ x x ∘ b) (! (⊙-unit-r a)) 〉
+ ((a ⊙ id) ∘ b) ≃〈 ap (λ x (a ⊙ id) ∘ x) (! (⊙-unit-l b)) 〉
+ ((a ⊙ id) ∘ (id ⊙ b)) ≃〈 ! (interchange a id id b) 〉
+ ((a ∘ id) ⊙ (id ∘ b)) ≃〈 ap (λ x x ⊙ (id ∘ b)) (∘-unit-r a) 〉
+ (a ⊙ (id ∘ b)) ≃〈 ap (λ x a ⊙ x) (∘-unit-l b) 〉
+ (a ⊙ b)
+ ∎)
+
+ abelian : (a b : Ω2) (a ∘ b) ≃ (b ∘ a)
+ abelian a b = (a ∘ b) ≃〈 ap (λ x x ∘ b) (! (⊙-unit-l a)) 〉
+ ((id ⊙ a) ∘ b) ≃〈 ap (λ x (id ⊙ a) ∘ x) (! (⊙-unit-r b)) 〉
+ ((id ⊙ a) ∘ (b ⊙ id)) ≃〈 ! (interchange id b a id) 〉
+ ((id ∘ b) ⊙ (a ∘ id)) ≃〈 ap (λ x x ⊙ (a ∘ id)) (∘-unit-l b) 〉
+ (b ⊙ (a ∘ id)) ≃〈 ap (λ x b ⊙ x) (∘-unit-r a) 〉
+ (b ⊙ a) ≃〈 ! (same b a) 〉
+ (b ∘ a)
+ ∎
+
+ {-
+ -- for reference, this is the minimal generalization of the IH that goes through
+ -- for proving the interchange law
+ ichange : (p q : Ω1)
+ → (a : Path p q) (r : Ω1) (b : Path q r) (p' q' : Ω1)
+ (c : Path p' q') (r' : Ω1) (d : Path q' r')
+ → Path (aptrans (trans a b) (trans c d)) (trans (aptrans a c) (aptrans b d))
+ ichange p q a = jay
+ (λ p' q' a' →
+ (r : Ω1) (b : Path q' r) (p0 q0 : Ω1) (c : Path p0 q0) (r' : Ω1)
+ (d : Path q0 r') →
+ Path (aptrans (trans a' b) (trans c d))
+ (trans (aptrans a' c) (aptrans b d)))
+ a
+ (λ pq r b →
+ jay
+ (λ pq' r' b' →
+ (p' q' : Ω1) (c : Path p' q') (r0 : Ω1) (d : Path q' r0) →
+ Path (aptrans (trans id b') (trans c d))
+ (trans (aptrans id c) (aptrans b' d)))
+ b
+ (λ pqr p' q' c →
+ jay
+ (λ p0 q0 c' →
+ (r' : Ω1) (d : Path q0 r') →
+ Path (aptrans id (trans c' d))
+ (trans (aptrans id c') (aptrans id d)))
+ c
+ (λ p'q' r' d →
+ jay
+ (λ p'q0 r0 d' →
+ Path (aptrans id (trans id d'))
+ (trans id (aptrans id d')))
+ d (λ _ → id))))
+ -}
+
+ -- ENH: can you relax the restriction that the base point is identity?
+ -- abelian' : {loop : Path base base} {a b : Path loop loop} → Path (trans a b) (trans b a)
+
+ -- shorter proof by Favonia
+ module BifunctorLemma where
+
+ bifunctor-lemma : {A B C : Set}
+ (f : A -> B -> C)
+ {a a' : A} {b b' : B}
+ (α : a ≃ a') (β : b ≃ b')
+ -> (ap (\ x -> f a' x) β ∘ ap (\ x -> f x b) α)
+ ≃ (ap (\ x -> f x b') α ∘ ap (\ x -> f a x) β)
+ bifunctor-lemma f id id = id
+
+ bifunctor-lemma-∘ : (α β : Ω2)
+ -> (ap (\ x -> id ∘ x) β ∘ ap (\ x -> x ∘ id) α)
+ ≃ (ap (\ x -> x ∘ id) α ∘ ap (\ x -> id ∘ x) β)
+ bifunctor-lemma-∘ α β = bifunctor-lemma _∘_ {id} {id} {id} {id} α β
+
+ commute : (α β : Ω2) -> (α ∘ β) ≃ (β ∘ α)
+ commute α β = α ∘ β ≃〈 ap (λ f f α ∘ β) (! is-id-ap-2) 〉
+ ap (λ x x ∘ id) α ∘ β ≃〈 ap (λ f ap (λ x x ∘ id) α ∘ f β) (! is-id-ap-1) 〉
+ ap (λ x x ∘ id) α ∘ ap (λ x id ∘ x) β ≃〈 ! (bifunctor-lemma-∘ α β) 〉
+ ap (λ x id ∘ x) β ∘ ap (\ x -> x ∘ id) α ≃〈 ap (λ f f β ∘ ap (λ x x ∘ id) α) is-id-ap-1
+ β ∘ ap (\ x -> x ∘ id) α ≃〈 ap (λ f β ∘ f α) is-id-ap-2
+ β ∘ α ∎ where
+ is-id-ap-1 : ap (\ (x : Ω1) -> id ∘ x) ≃ (\ (x : Ω2) -> x)
+ is-id-ap-1 = λ≃ (\ x ∘-unit-l x ∘ ap-by-id (\ y ! (∘-unit-l y)) x)
+
+ is-id-ap-2 : ap (\ (x : Ω1) -> x ∘ id) ≃ (\ (x : Ω2) -> x)
+ is-id-ap-2 = λ≃ ap-id -- cancels definitionally on this side
+
+
View
@@ -0,0 +1,49 @@
+{-# OPTIONS --type-in-type --without-K #-}
+
+open import lib.Prelude
+open import homotopy.HigherHomotopyAbelian
+open Paths
+
+module homotopy.Hopf where
+
+ module S² =1
+ open S²1
+
+ module A1 = homotopy.HigherHomotopyAbelian S² base
+
+ module Four where
+ ichange : Path {Path {Path base base} id id}
+ (ap∘ (loop ∘ loop) (loop ∘ loop))
+ (ap∘ loop loop ∘ ap∘ loop loop)
+ ichange = ichange-type loop loop loop loop
+
+ loop4 = ((loop ∘ loop) ∘ (loop ∘ loop))
+
+ nontriv-loop4 : loop4 ≃ loop4
+ nontriv-loop4 = loop4 ≃〈 A1.same (loop ∘ loop) (loop ∘ loop) 〉
+ ap∘ (loop ∘ loop) (loop ∘ loop) ≃〈 ichange 〉
+ ap∘ loop loop ∘ ap∘ loop loop ≃〈 ap2 _∘_ (! (A1.same loop loop)) (! (A1.same loop loop)) 〉
+ loop4 ∎
+
+ ap∘-inv-r : (a : id{_}{base} ≃ id{_}{base})
+ -> ap∘ a (! a) ≃ id
+ ap∘-inv-r a = !-inv-r a ∘ ! (A1.same a (! a))
+
+ ap∘-inv-l : (a : id{_}{base} ≃ id{_}{base})
+ -> ap∘ (! a) a ≃ id
+ ap∘-inv-l a = !-inv-l a ∘ ! (A1.same (! a) a)
+
+ nontriv : Path {Path {Path base base} id id} id id
+ nontriv = id ≃〈 ! (ap2 ap∘ (!-inv-r loop) (!-inv-r loop)) 〉
+ ap∘ (loop ∘ ! loop) (loop ∘ ! loop) ≃〈 ichange-type (! loop) loop (! loop) loop 〉
+ ap∘ loop loop ∘ ap∘ (! loop) (! loop) ≃〈 ! (ap2 (λ x y x ∘ y) (A1.same loop loop) (A1.same (! loop) (! loop))) 〉
+ (loop ∘ loop) ∘ ! loop ∘ ! loop ≃〈 ap (λ x (loop ∘ loop) ∘ x) (! (!-∘ loop loop)) 〉
+ (loop ∘ loop) ∘ ! (loop ∘ loop) ≃〈 !-inv-r (loop ∘ loop) 〉
+ (id ∎)
+
+ module S³ =1
+ openusing (S³)
+
+ hopf-map : S³ -> S²
+ hopf-map = S³.S³-rec S².base nontriv
+
View
@@ -0,0 +1,62 @@
+
+{-# OPTIONS --type-in-type --without-K #-}
+
+open import lib.Prelude
+open Paths
+
+module homotopy.Pi1Either where
+
+module CaseForInl (A : Type) (B : Type) (a : A) where
+
+ Cover : Either A B -> Type
+ Cover (Inl a') = Path a a'
+ Cover (Inr _) = Void
+
+ encode : {e : Either A B} -> Path (Inl a) e -> Cover e
+ encode α = transport Cover α id
+
+ inj : {a' : A} Path (Inl a) (Inl a') Path a a'
+ inj {a'} = encode {Inl a'}
+
+ dis : {b : B} Path (Inl a) (Inr b) Void
+ dis {b} = encode {Inr b}
+
+ decode : {e : Either A B} Cover e Path (Inl a) e
+ decode {Inl a'} α = ap Inl α
+ decode {Inr _} ()
+
+ encode-decode : {e : Either A B} (c : Cover e)
+ encode{e} (decode{e} c) ≃ c
+ encode-decode {Inl a'} α =
+ encode{Inl a'} (decode{Inl a'} α) -- (1)
+ ≃〈 id 〉
+ transport Cover (ap Inl α) id -- (2)
+ ≃〈 ap≃ (! (transport-ap-assoc' Cover Inl α)) 〉
+ transport (Cover o Inl) α id -- (3)
+ ≃〈 id 〉
+ transport (λ a' Id a a') α id -- (4)
+ ≃〈 transport-Path-right α id 〉
+ α ∘ id -- (5)
+ ≃〈 id 〉
+ α ∎ -- (6)
+ encode-decode {Inr _} ()
+
+ decode-encode : {e : Either A B} (α : Path (Inl a) e)
+ Path (decode{e} (encode{e} α)) α
+ decode-encode {e} α =
+ path-induction
+ (λ e' α' -> Path (decode{e'} (encode{e'} α')) α')
+ id α
+
+ eq : {e : Either A B} -> Path (Path (Inl a) e) (Cover e)
+ eq{e} = ua (improve
+ (hequiv encode decode
+ decode-encode (encode-decode{e})))
+
+ injEquiv : {a' : A}
+ Path (Path{Either A B} (Inl a) (Inl a')) (Path a a')
+ injEquiv = eq
+
+ disEquiv : {b : B}
+ Path (Path{Either A B} (Inl a) (Inr b)) Void
+ disEquiv = eq
Oops, something went wrong.

0 comments on commit 11914dd

Please sign in to comment.