Mercurial > hg > Members > kono > Proof > category

comparison src/CCC.agda @ 949:ac53803b3b2a

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
reorganization for apkg
author Shinji KONO <kono@ie.u-ryukyu.ac.jp>
date Mon, 21 Dec 2020 16:40:15 +0900
parents CCC.agda@ba575c73ea48
children bd32a37784b0
comparison
equal deleted inserted replaced
948:dca4b29553cb 949:ac53803b3b2a
1 open import Level
2 open import Category
3 module CCC where
4
5 open import HomReasoning
6 open import cat-utility
7 open import Relation.Binary.PropositionalEquality
8
9
10 open import HomReasoning
11
12 record IsCCC {c₁ c₂ ℓ : Level} (A : Category c₁ c₂ ℓ)
13 ( １ : Obj A )
14 ( ○ : (a : Obj A ) → Hom A a １ )
15 ( _∧_ : Obj A → Obj A → Obj A )
16 ( <_,_> : {a b c : Obj A } → Hom A c a → Hom A c b → Hom A c (a ∧ b) )
17 ( π : {a b : Obj A } → Hom A (a ∧ b) a )
18 ( π' : {a b : Obj A } → Hom A (a ∧ b) b )
19 ( _<=_ : (a b : Obj A ) → Obj A )
20 ( _* : {a b c : Obj A } → Hom A (a ∧ b) c → Hom A a (c <= b) )
21 ( ε : {a b : Obj A } → Hom A ((a <= b ) ∧ b) a )
22 : Set ( c₁ ⊔ c₂ ⊔ ℓ ) where
23 field
24 -- cartesian
25 e2 : {a : Obj A} → ∀ { f : Hom A a １ } → A [ f ≈ ○ a ]
26 e3a : {a b c : Obj A} → { f : Hom A c a }{ g : Hom A c b } → A [ A [ π o < f , g > ] ≈ f ]
27 e3b : {a b c : Obj A} → { f : Hom A c a }{ g : Hom A c b } → A [ A [ π' o < f , g > ] ≈ g ]
28 e3c : {a b c : Obj A} → { h : Hom A c (a ∧ b) } → A [ < A [ π o h ] , A [ π' o h ] > ≈ h ]
29 π-cong : {a b c : Obj A} → { f f' : Hom A c a }{ g g' : Hom A c b } → A [ f ≈ f' ] → A [ g ≈ g' ] → A [ < f , g > ≈ < f' , g' > ]
30 -- closed
31 e4a : {a b c : Obj A} → { h : Hom A (c ∧ b) a } → A [ A [ ε o < A [ (h *) o π ] , π' > ] ≈ h ]
32 e4b : {a b c : Obj A} → { k : Hom A c (a <= b ) } → A [ ( A [ ε o < A [ k o π ] , π' > ] ) * ≈ k ]
33 *-cong : {a b c : Obj A} → { f f' : Hom A (a ∧ b) c } → A [ f ≈ f' ] → A [ f * ≈ f' * ]
34
35 e'2 : A [ ○ １ ≈ id1 A １ ]
36 e'2 = let open ≈-Reasoning A in begin
37 ○ １
38 ≈↑⟨ e2 ⟩
39 id1 A １
40 ∎
41 e''2 : {a b : Obj A} {f : Hom A a b } → A [ A [ ○ b o f ] ≈ ○ a ]
42 e''2 {a} {b} {f} = let open ≈-Reasoning A in begin
43 ○ b o f
44 ≈⟨ e2 ⟩
45 ○ a
46 ∎
47 π-id : {a b : Obj A} → A [ < π , π' > ≈ id1 A (a ∧ b ) ]
48 π-id {a} {b} = let open ≈-Reasoning A in begin
49 < π , π' >
50 ≈↑⟨ π-cong idR idR ⟩
51 < π o id1 A (a ∧ b) , π' o id1 A (a ∧ b) >
52 ≈⟨ e3c ⟩
53 id1 A (a ∧ b )
54 ∎
55 distr-π : {a b c d : Obj A} {f : Hom A c a }{g : Hom A c b } {h : Hom A d c } → A [ A [ < f , g > o h ] ≈ < A [ f o h ] , A [ g o h ] > ]
56 distr-π {a} {b} {c} {d} {f} {g} {h} = let open ≈-Reasoning A in begin
57 < f , g > o h
58 ≈↑⟨ e3c ⟩
59 < π o < f , g > o h , π' o < f , g > o h >
60 ≈⟨ π-cong assoc assoc ⟩
61 < ( π o < f , g > ) o h , (π' o < f , g > ) o h >
62 ≈⟨ π-cong (car e3a ) (car e3b) ⟩
63 < f o h , g o h >
64 ∎
65 _×_ : { a b c d : Obj A } ( f : Hom A a c ) (g : Hom A b d ) → Hom A (a ∧ b) ( c ∧ d )
66 f × g = < (A [ f o π ] ) , (A [ g o π' ]) >
67 distr-* : {a b c d : Obj A } { h : Hom A (a ∧ b) c } { k : Hom A d a } → A [ A [ h * o k ] ≈ ( A [ h o < A [ k o π ] , π' > ] ) * ]
68 distr-* {a} {b} {c} {d} {h} {k} = begin
69 h * o k
70 ≈↑⟨ e4b ⟩
71 ( ε o < (h * o k ) o π , π' > ) *
72 ≈⟨ *-cong ( begin
73 ε o < (h * o k ) o π , π' >
74 ≈↑⟨ cdr ( π-cong assoc refl-hom ) ⟩
75 ε o ( < h * o ( k o π ) , π' > )
76 ≈↑⟨ cdr ( π-cong (cdr e3a) e3b ) ⟩
77 ε o ( < h * o ( π o < k o π , π' > ) , π' o < k o π , π' > > )
78 ≈⟨ cdr ( π-cong assoc refl-hom) ⟩
79 ε o ( < (h * o π) o < k o π , π' > , π' o < k o π , π' > > )
80 ≈↑⟨ cdr ( distr-π ) ⟩
81 ε o ( < h * o π , π' > o < k o π , π' > )
82 ≈⟨ assoc ⟩
83 ( ε o < h * o π , π' > ) o < k o π , π' >
84 ≈⟨ car e4a ⟩
85 h o < k o π , π' >
86 ∎ ) ⟩
87 ( h o < k o π , π' > ) *
88 ∎ where open ≈-Reasoning A
89 α : {a b c : Obj A } → Hom A (( a ∧ b ) ∧ c ) ( a ∧ ( b ∧ c ) )
90 α = < A [ π o π ] , < A [ π' o π ] , π' > >
91 α' : {a b c : Obj A } → Hom A ( a ∧ ( b ∧ c ) ) (( a ∧ b ) ∧ c )
92 α' = < < π , A [ π o π' ] > , A [ π' o π' ] >
93 β : {a b c d : Obj A } { f : Hom A a b} { g : Hom A a c } { h : Hom A a d } → A [ A [ α o < < f , g > , h > ] ≈ < f , < g , h > > ]
94 β {a} {b} {c} {d} {f} {g} {h} = begin
95 α o < < f , g > , h >
96 ≈⟨⟩
97 ( < ( π o π ) , < ( π' o π ) , π' > > ) o < < f , g > , h >
98 ≈⟨ distr-π ⟩
99 < ( ( π o π ) o < < f , g > , h > ) , ( < ( π' o π ) , π' > o < < f , g > , h > ) >
100 ≈⟨ π-cong refl-hom distr-π ⟩
101 < ( ( π o π ) o < < f , g > , h > ) , ( < ( ( π' o π ) o < < f , g > , h > ) , ( π' o < < f , g > , h > ) > ) >
102 ≈↑⟨ π-cong assoc ( π-cong assoc refl-hom ) ⟩
103 < ( π o (π o < < f , g > , h >) ) , ( < ( π' o ( π o < < f , g > , h > ) ) , ( π' o < < f , g > , h > ) > ) >
104 ≈⟨ π-cong (cdr e3a ) ( π-cong (cdr e3a ) e3b ) ⟩
105 < ( π o < f , g > ) , < ( π' o < f , g > ) , h > >
106 ≈⟨ π-cong e3a ( π-cong e3b refl-hom ) ⟩
107 < f , < g , h > >
108 ∎ where open ≈-Reasoning A
109
110
111 record CCC {c₁ c₂ ℓ : Level} (A : Category c₁ c₂ ℓ) : Set ( c₁ ⊔ c₂ ⊔ ℓ ) where
112 field
113 １ : Obj A
114 ○ : (a : Obj A ) → Hom A a １
115 _∧_ : Obj A → Obj A → Obj A
116 <_,_> : {a b c : Obj A } → Hom A c a → Hom A c b → Hom A c (a ∧ b)
117 π : {a b : Obj A } → Hom A (a ∧ b) a
118 π' : {a b : Obj A } → Hom A (a ∧ b) b
119 _<=_ : (a b : Obj A ) → Obj A
120 _* : {a b c : Obj A } → Hom A (a ∧ b) c → Hom A a (c <= b)
121 ε : {a b : Obj A } → Hom A ((a <= b ) ∧ b) a
122 isCCC : IsCCC A １ ○ _∧_ <_,_> π π' _<=_ _* ε
123
124
125
126
127