mirror of
https://github.com/nmvdw/HITs-Examples
synced 2025-11-03 15:13:51 +01:00
Added Agda code for some HITs
This commit is contained in:
Niels
98
Agda-HITs/CL/CL.agda
Normal file
98
Agda-HITs/CL/CL.agda
Normal file
@@ -0,0 +1,98 @@
|
||||
{-# OPTIONS --without-K --rewriting #-}
|
||||
|
||||
open import HoTT
|
||||
|
||||
module CL where
|
||||
|
||||
private
|
||||
data CL' : Set where
|
||||
K' : CL'
|
||||
S' : CL'
|
||||
app' : CL' -> CL' -> CL'
|
||||
|
||||
CL : Set
|
||||
CL = CL'
|
||||
|
||||
K : CL
|
||||
K = K'
|
||||
|
||||
Sc : CL
|
||||
Sc = S'
|
||||
|
||||
app : CL -> CL -> CL
|
||||
app = app'
|
||||
|
||||
postulate
|
||||
KConv : {x y : CL} -> app (app K x) y == x
|
||||
SConv : {x y z : CL} -> app (app (app Sc x) y) z == app (app x z) (app y z)
|
||||
|
||||
CLind : (Y : CL -> Set)
|
||||
(KY : Y K)
|
||||
(SY : Y Sc)
|
||||
(appY : (x y : CL) -> Y x -> Y y -> Y (app x y))
|
||||
(KConvY : (x y : CL) (a : Y x) (b : Y y) -> PathOver Y KConv (appY (app K x) y (appY K x KY a) b) a)
|
||||
(SConvY : (x y z : CL) (a : Y x) (b : Y y) (c : Y z) ->
|
||||
PathOver Y SConv
|
||||
(appY
|
||||
(app (app Sc x) y)
|
||||
z
|
||||
(appY
|
||||
(app Sc x)
|
||||
y
|
||||
(appY Sc x SY a)
|
||||
b
|
||||
)
|
||||
c
|
||||
)
|
||||
(appY (app x z) (app y z) (appY x z a c) (appY y z b c))
|
||||
)
|
||||
(x : CL) -> Y x
|
||||
CLind Y KY SY appY _ _ K' = KY
|
||||
CLind Y KY SY appY _ _ S' = SY
|
||||
CLind Y KY SY appY KConvY SConvY (app' x x₁) = appY x x₁ (CLind Y KY SY appY KConvY SConvY x) (CLind Y KY SY appY KConvY SConvY x₁)
|
||||
|
||||
postulate
|
||||
CLind_βKConv : (Y : CL -> Set)
|
||||
(KY : Y K)
|
||||
(SY : Y Sc)
|
||||
(appY : (x y : CL) -> Y x -> Y y -> Y (app x y))
|
||||
(KConvY : (x y : CL) (a : Y x) (b : Y y) -> PathOver Y KConv (appY (app K x) y (appY K x KY a) b) a)
|
||||
(SConvY : (x y z : CL) (a : Y x) (b : Y y) (c : Y z) ->
|
||||
PathOver Y SConv
|
||||
(appY
|
||||
(app (app Sc x) y)
|
||||
z
|
||||
(appY
|
||||
(app Sc x)
|
||||
y
|
||||
(appY Sc x SY a)
|
||||
b
|
||||
)
|
||||
c
|
||||
)
|
||||
(appY (app x z) (app y z) (appY x z a c) (appY y z b c))
|
||||
)
|
||||
(x y : CL) ->
|
||||
apd (CLind Y KY SY appY KConvY SConvY) KConv == KConvY x y (CLind Y KY SY appY KConvY SConvY x) (CLind Y KY SY appY KConvY SConvY y)
|
||||
CLind_βSConv : (Y : CL -> Set)
|
||||
(KY : Y K)
|
||||
(SY : Y Sc)
|
||||
(appY : (x y : CL) -> Y x -> Y y -> Y (app x y))
|
||||
(KConvY : (x y : CL) (a : Y x) (b : Y y) -> PathOver Y KConv (appY (app K x) y (appY K x KY a) b) a)
|
||||
(SConvY : (x y z : CL) (a : Y x) (b : Y y) (c : Y z) ->
|
||||
PathOver Y SConv
|
||||
(appY
|
||||
(app (app Sc x) y)
|
||||
z
|
||||
(appY
|
||||
(app Sc x)
|
||||
y
|
||||
(appY Sc x SY a)
|
||||
b
|
||||
)
|
||||
c
|
||||
)
|
||||
(appY (app x z) (app y z) (appY x z a c) (appY y z b c))
|
||||
)
|
||||
(x y z : CL) ->
|
||||
apd (CLind Y KY SY appY KConvY SConvY) SConv == SConvY x y z (CLind Y KY SY appY KConvY SConvY x) (CLind Y KY SY appY KConvY SConvY y) (CLind Y KY SY appY KConvY SConvY z)
|
||||
122
Agda-HITs/CL/Thms.agda
Normal file
122
Agda-HITs/CL/Thms.agda
Normal file
@@ -0,0 +1,122 @@
|
||||
{-# OPTIONS --without-K --rewriting #-}
|
||||
|
||||
open import HoTT
|
||||
open import CL
|
||||
|
||||
module Thms where
|
||||
|
||||
trans-cst : (A : Set) {x y : A} (B : Set) (p : x == y) (z : B) -> transport (\x -> B) p z == z
|
||||
trans-cst A B idp z = idp
|
||||
|
||||
I : CL
|
||||
I = app (app Sc K) K
|
||||
|
||||
IConv : {x : CL} -> app I x == x
|
||||
IConv {x} = SConv ∙ KConv
|
||||
|
||||
B : CL
|
||||
B = app (app Sc (app K Sc)) K
|
||||
|
||||
BConv : {x y z : CL} -> app (app (app B x) y) z == app x (app y z)
|
||||
BConv {x} {y} {z} =
|
||||
ap (λ p -> app (app p y) z) SConv
|
||||
∙ ap (λ p -> app (app (app (p) (app K x)) y) z) KConv
|
||||
∙ SConv
|
||||
∙ ap (λ p -> app p (app y z)) KConv
|
||||
|
||||
M : CL
|
||||
M = app (app Sc I) I
|
||||
|
||||
MConv : {x : CL} -> app M x == app x x
|
||||
MConv {x} =
|
||||
SConv
|
||||
∙ ap (λ p -> app p (app I x)) IConv
|
||||
∙ ap (app x) IConv
|
||||
|
||||
T : CL
|
||||
T = app (app B (app Sc I)) K
|
||||
|
||||
TConv : {x y : CL} -> app (app T x) y == app y x
|
||||
TConv {x} {y} =
|
||||
ap (λ p -> app p y) BConv
|
||||
∙ SConv
|
||||
∙ ap (λ p -> app p (app (app K x) y)) IConv
|
||||
∙ ap (app y) KConv
|
||||
|
||||
C : CL
|
||||
C =
|
||||
app
|
||||
(app
|
||||
B
|
||||
(app
|
||||
T
|
||||
(app
|
||||
(app
|
||||
B
|
||||
B
|
||||
)
|
||||
T
|
||||
)
|
||||
)
|
||||
)
|
||||
(app
|
||||
(app
|
||||
B
|
||||
B
|
||||
)
|
||||
T
|
||||
)
|
||||
|
||||
CConv : {x y z : CL} -> app (app (app C x) y) z == app (app x z) y
|
||||
CConv {x} {y} {z} =
|
||||
ap (λ p -> app (app p y) z) BConv
|
||||
∙ ap (λ p -> app (app p y) z) TConv
|
||||
∙ ap (λ p -> app (app (app p (app (app B B) T)) y) z) BConv
|
||||
∙ ap (λ p -> app p z) BConv
|
||||
∙ ap (λ p -> app p z) TConv
|
||||
∙ ap (λ p -> app (app p x) z) BConv
|
||||
∙ BConv
|
||||
∙ TConv
|
||||
|
||||
W : CL
|
||||
W = app (app C Sc) I
|
||||
|
||||
WConv : {x y : CL} -> app (app W x) y == app (app x y) y
|
||||
WConv {x} {y} =
|
||||
ap (λ p -> app p y) CConv
|
||||
∙ SConv
|
||||
∙ ap (app (app x y)) IConv
|
||||
|
||||
B' : CL
|
||||
B' = app C B
|
||||
|
||||
B'Conv : {x y z : CL} -> app (app (app B' x) y) z == app y (app x z)
|
||||
B'Conv {x} {y} {z} =
|
||||
ap (λ p -> app p z) CConv
|
||||
∙ BConv
|
||||
|
||||
V : CL
|
||||
V = app (app B C) T
|
||||
|
||||
VConv : {x y z : CL} -> app (app (app V x) y) z == app (app z x) y
|
||||
VConv {x} {y} {z} =
|
||||
ap (λ p -> app (app p y) z) BConv
|
||||
∙ CConv
|
||||
∙ ap (λ p -> app p y) TConv
|
||||
|
||||
Y : CL
|
||||
Y = app (app B' (app B' M)) M
|
||||
|
||||
YConv : {x : CL} -> app Y x == app x (app Y x)
|
||||
YConv {x} =
|
||||
B'Conv
|
||||
∙ MConv
|
||||
∙ B'Conv
|
||||
∙ ap (app x) (! B'Conv)
|
||||
|
||||
fixpoint : (x : CL) -> Σ CL (λ y -> app x y == y)
|
||||
fixpoint x = app Y x , ! YConv
|
||||
|
||||
S' : CL
|
||||
S' = app C Sc
|
||||
|
||||
Reference in New Issue
Block a user