Skip to content

Commit e73259a

Browse files
maxsnewmaxsnew
committed
Free Functor and Functor Solver
1 parent 455a792 commit e73259a

File tree

4 files changed

+410
-0
lines changed

4 files changed

+410
-0
lines changed

‎Cubical/Categories/Constructions/Free/Functor.agda

Lines changed: 234 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,234 @@
1+
-- Free functor between categories generated from two graphs and a function on nodes between them
2+
{-# OPTIONS --safe --lossy-unification #-}
3+
module Cubical.Categories.Constructions.Free.Functor where
4+
5+
open import Cubical.Foundations.Prelude hiding (J)
6+
open import Cubical.Foundations.Id hiding (_≡_; isSet; subst)
7+
renaming (refl to reflId; _∙_ to _∙Id_; transport to transportId; funExt to funExtId)
8+
open import Cubical.Foundations.Path
9+
open import Cubical.Foundations.Transport
10+
open import Cubical.Foundations.GroupoidLaws
11+
open import Cubical.Foundations.Function renaming (_∘_ to _∘f_)
12+
open import Cubical.Foundations.HLevels
13+
open import Cubical.Categories.Category.Base
14+
open import Cubical.Categories.Constructions.Free.Category
15+
open import Cubical.Categories.Functor.Base hiding (Id)
16+
open import Cubical.Categories.NaturalTransformation.Base hiding (_⟦_⟧)
17+
open import Cubical.Categories.UnderlyingGraph
18+
open import Cubical.Data.Empty
19+
open import Cubical.Data.Graph.Base
20+
open import Cubical.Data.Sigma
21+
22+
private
23+
variable
24+
ℓ ℓ' ℓc ℓc' ℓd ℓd' ℓg ℓg' ℓh ℓh' : Level
25+
26+
open Category
27+
open Functor
28+
open NatTrans
29+
open NatIso
30+
open isIso
31+
32+
module FreeFunctor (G : Graph ℓg ℓg') (H : Graph ℓh ℓh') (ϕ : G .Node → H .Node) where
33+
module FreeCatG = FreeCategory G
34+
open FreeCatG.Exp
35+
FG = FreeCatG.FreeCat
36+
Exp = FreeCatG.Exp
37+
data FExp : H .Node → H .Node → Type (((ℓ-max ℓg (ℓ-max ℓg' (ℓ-max ℓh ℓh'))))) where
38+
-- free category on H with a functor from G to H freely added
39+
↑_ : ∀ {A B} → H .Edge A B → FExp A B
40+
idₑ : ∀ {A} → FExp A A
41+
_⋆ₑ_ : ∀ {A B C} → FExp A B → FExp B C → FExp A C
42+
F⟪_⟫ : ∀ {A B} → Exp A B → FExp (ϕ A) (ϕ B)
43+
44+
⋆ₑIdL : ∀ {A B} (e : FExp A B) → idₑ ⋆ₑ e ≡ e
45+
⋆ₑIdR : ∀ {A B} (e : FExp A B) → e ⋆ₑ idₑ ≡ e
46+
⋆ₑAssoc : ∀ {A B C D} (e : FExp A B)(f : FExp B C)(g : FExp C D)
47+
→ (e ⋆ₑ f) ⋆ₑ g ≡ e ⋆ₑ (f ⋆ₑ g)
48+
F-idₑ : ∀ {A} → F⟪ idₑ {A = A} ⟫ ≡ idₑ
49+
F-seqₑ : ∀ {A B C} (f : Exp A B)(g : Exp B C) → F⟪ f ⋆ₑ g ⟫ ≡ (F⟪ f ⟫ ⋆ₑ F⟪ g ⟫)
50+
51+
isSetFExp : ∀ {A B} → isSet (FExp A B)
52+
53+
FH : Category _ _
54+
FH .ob = H .Node
55+
FH .Hom[_,_] = FExp
56+
FH .id = idₑ
57+
FH ._⋆_ = _⋆ₑ_
58+
FH .⋆IdL = ⋆ₑIdL
59+
FH .⋆IdR = ⋆ₑIdR
60+
FH .⋆Assoc = ⋆ₑAssoc
61+
FH .isSetHom = isSetFExp
62+
63+
Fϕ : Functor FG FH
64+
Fϕ .F-ob = ϕ
65+
Fϕ .F-hom = F⟪_⟫
66+
Fϕ .F-id = F-idₑ
67+
Fϕ .F-seq = F-seqₑ
68+
69+
-- The universal interpretation
70+
ηG = FreeCatG.η
71+
72+
ηH : Interp H FH
73+
ηH $g x = x
74+
ηH <$g> x = ↑ x
75+
76+
Fϕ-homo : GraphHom G (Ugr FH)
77+
Fϕ-homo $g x = ϕ x
78+
Fϕ-homo <$g> x = F⟪ ↑ x ⟫
79+
80+
ηϕ : Id (Fϕ .F-ob ∘f ηG ._$g_) (ηH ._$g_ ∘f ϕ)
81+
ηϕ = reflId
82+
83+
module _ {𝓒 : Category ℓc ℓc'}{𝓓 : Category ℓd ℓd'} {𝓕 : Functor 𝓒 𝓓} where
84+
module Semantics (ıG : Interp G 𝓒) (ıH : Interp H 𝓓)
85+
(ıϕ : Id (𝓕 .F-ob ∘f ıG ._$g_) (ıH ._$g_ ∘f ϕ))
86+
where
87+
semG = FreeCatG.Semantics.sem 𝓒 ıG
88+
89+
semH-hom : ∀ {A B} → FExp A B → 𝓓 [ ıH $g A , ıH $g B ]
90+
semH-hom (↑ x) = ıH <$g> x
91+
semH-hom idₑ = 𝓓 .id
92+
semH-hom (e ⋆ₑ e₁) = semH-hom e ⋆⟨ 𝓓 ⟩ semH-hom e₁
93+
semH-hom (F⟪_⟫ {A}{B} x) = transportId (λ (f : G .Node → 𝓓 .ob) → 𝓓 [ f A , f B ]) ıϕ (𝓕 ⟪ semG ⟪ x ⟫ ⟫)
94+
-- preserves 1-cells
95+
semH-hom (⋆ₑIdL f i) = 𝓓 .⋆IdL (semH-hom f) i
96+
semH-hom (⋆ₑIdR f i) = 𝓓 .⋆IdR (semH-hom f) i
97+
semH-hom (⋆ₑAssoc f f' f'' i) = 𝓓 .⋆Assoc (semH-hom f) (semH-hom f') (semH-hom f'') i
98+
semH-hom (F-idₑ {A} i) = unbound i
99+
where
100+
unbound : transportId (λ f → 𝓓 [ f A , f A ]) ıϕ (𝓕 ⟪ semG ⟪ idₑ ⟫ ⟫) ≡ 𝓓 .id
101+
unbound = J (λ g p → transportId (λ f → 𝓓 [ f A , f A ]) p (𝓕 ⟪ semG ⟪ idₑ ⟫ ⟫) ≡ 𝓓 .id) ((𝓕 ∘F semG) .F-id) ıϕ
102+
semH-hom (F-seqₑ {A}{B}{C} e e' i) = unbound i
103+
where
104+
unbound : transportId (λ f → 𝓓 [ f A , f C ]) ıϕ (𝓕 ⟪ semG ⟪ e ⋆ₑ e' ⟫ ⟫)
105+
≡ (transportId (λ f → 𝓓 [ f A , f B ]) ıϕ (𝓕 ⟪ semG ⟪ e ⟫ ⟫)) ⋆⟨ 𝓓 ⟩ (transportId (λ f → 𝓓 [ f B , f C ]) ıϕ (𝓕 ⟪ semG ⟪ e' ⟫ ⟫))
106+
unbound = J (λ g p → transportId (λ f → 𝓓 [ f A , f C ]) p (𝓕 ⟪ semG ⟪ e ⋆ₑ e' ⟫ ⟫) ≡ (transportId (λ f → 𝓓 [ f A , f B ]) p (𝓕 ⟪ semG ⟪ e ⟫ ⟫)) ⋆⟨ 𝓓 ⟩ (transportId (λ f → 𝓓 [ f B , f C ]) p (𝓕 ⟪ semG ⟪ e' ⟫ ⟫)))
107+
((𝓕 ∘F semG) .F-seq e e')
108+
ıϕ
109+
semH-hom (isSetFExp f g p q i j) = 𝓓 .isSetHom (semH-hom f) (semH-hom g) (cong semH-hom p) (cong semH-hom q) i j
110+
111+
semH : Functor FH 𝓓
112+
semH .F-ob = ıH ._$g_
113+
semH .F-hom = semH-hom
114+
semH .F-id = refl
115+
semH .F-seq f g = refl
116+
117+
semϕ : Id (𝓕 ∘F semG) (semH ∘F Fϕ)
118+
semϕ = pathToId (FreeCatG.free-cat-functor-ind (funcComp 𝓕 semG) (funcComp semH Fϕ) (GrHom≡ aoo aoe)) where
119+
𝓕G = (𝓕 .F-ob ∘f ıG ._$g_)
120+
Hϕ = (ıH ._$g_ ∘f ϕ)
121+
122+
aoo-gen : ∀ (v : Node G) f g
123+
→ Id {A = G .Node → 𝓓 .ob} f g
124+
→ Path _ (f v) (g v)
125+
aoo-gen v f g = J ((λ f' _ → Path _ (f v) (f' v))) refl
126+
aoo : (v : Node G) → Path _ (((𝓕 ∘F semG) ∘Interp ηG) $g v) (((semH ∘F Fϕ) ∘Interp ηG) $g v)
127+
aoo v = aoo-gen v 𝓕G Hϕ ıϕ
128+
129+
aoe : {v w : Node G} (e : G .Edge v w) →
130+
PathP (λ i → 𝓓 .Hom[_,_] (aoo v i) (aoo w i))
131+
(𝓕 ⟪ semG ⟪ ↑ e ⟫ ⟫)
132+
(semH ⟪ Fϕ ⟪ ↑ e ⟫ ⟫)
133+
aoe {v}{w} e = toPathP lem where
134+
lem : Path _
135+
(transportPath (λ i → 𝓓 [ aoo-gen v 𝓕G Hϕ ıϕ i , aoo-gen w 𝓕G Hϕ ıϕ i ]) (𝓕 ⟪ ıG <$g> e ⟫))
136+
(transportId (λ f → 𝓓 [ f v , f w ]) ıϕ (𝓕 ⟪ ıG <$g> e ⟫))
137+
lem = J (λ f p → Path _
138+
((transportPath (λ i → 𝓓 [ aoo-gen v 𝓕G f p i , aoo-gen w 𝓕G f p i ]) (𝓕 ⟪ ıG <$g> e ⟫)))
139+
((transportId (λ f → 𝓓 [ f v , f w ]) p (𝓕 ⟪ ıG <$g> e ⟫))))
140+
(transportRefl (𝓕 ⟪ ıG <$g> e ⟫))
141+
ıϕ
142+
143+
module Uniqueness (arb𝓒 : Functor FG 𝓒)
144+
(arb𝓓 : Functor FH 𝓓)
145+
(arb𝓕 : Path (Functor FG 𝓓) (𝓕 ∘F arb𝓒) (arb𝓓 ∘F Fϕ)) -- arb𝓕 .F-ob : Id {G .Node → 𝓓 .ob} ((𝓕 ∘F arb𝓒) ∘Interp ηG)
146+
(arb𝓒-agree : arb𝓒 ∘Interp ηG ≡ ıG)
147+
(arb𝓓-agree : arb𝓓 ∘Interp ηH ≡ ıH)
148+
(arb𝓕-agree : Square {A = G .Node → 𝓓 .ob} (λ i x → arb𝓕 i ⟅ x ⟆)
149+
(idToPath ıϕ)
150+
(λ i x → 𝓕 ⟅ arb𝓒-agree i $g x ⟆)
151+
(λ i x → arb𝓓-agree i $g (ϕ x)))
152+
where
153+
sem-uniq-G : arb𝓒 ≡ semG
154+
sem-uniq-G = FreeCatG.Semantics.sem-uniq _ _ arb𝓒-agree
155+
156+
sem-uniq-H : arb𝓓 ≡ semH
157+
sem-uniq-H = Functor≡ aoo aom where
158+
aoo : (v : H .Node) → arb𝓓 ⟅ v ⟆ ≡ ıH $g v
159+
aoo = (λ v i → arb𝓓-agree i $g v)
160+
161+
aom-type : ∀ {v w} → (f : FH [ v , w ]) → Type _
162+
aom-type {v}{w} f = PathP (λ i → 𝓓 [ aoo v i , aoo w i ]) (arb𝓓 ⟪ f ⟫) (semH ⟪ f ⟫)
163+
164+
aom-id : ∀ {v} → aom-type {v} idₑ
165+
aom-id = arb𝓓 .F-id ◁ λ i → 𝓓 .id
166+
167+
aom-seq : ∀ {v w x} → {f : FH [ v , w ]} {g : FH [ w , x ]}
168+
→ aom-type f
169+
→ aom-type g
170+
→ aom-type (f ⋆ₑ g)
171+
aom-seq hypf hypg = arb𝓓 .F-seq _ _ ◁ λ i → hypf i ⋆⟨ 𝓓 ⟩ hypg i
172+
ıϕp = idToPath ıϕ
173+
174+
aom-F : ∀ {v w}
175+
→ (e : FG [ v , w ])
176+
→ PathP (λ i → 𝓓 [ (arb𝓓-agree i $g (ϕ v)) , (arb𝓓-agree i $g (ϕ w)) ])
177+
(arb𝓓 ⟪ Fϕ ⟪ e ⟫ ⟫)
178+
(transportId (λ (f : G .Node → 𝓓 .ob) → 𝓓 [ f v , f w ]) ıϕ (𝓕 ⟪ semG ⟪ e ⟫ ⟫))
179+
aom-F {v}{w} e = pathified ▷ λ i → substIdToPath {B = λ (f : G .Node → 𝓓 .ob) → 𝓓 [ f v , f w ]} ıϕ i (𝓕 ⟪ semG ⟪ e ⟫ ⟫)
180+
where
181+
pathified : PathP (λ i → 𝓓 [ arb𝓓-agree i $g ϕ v , arb𝓓-agree i $g ϕ w ]) (arb𝓓 ⟪ Fϕ ⟪ e ⟫ ⟫) (transportPath (λ i → 𝓓 [ ıϕp i v , ıϕp i w ]) (𝓕 ⟪ semG ⟪ e ⟫ ⟫))
182+
pathified = toPathP⁻ ((
183+
fromPathP⁻ lem'
184+
∙ cong (transport⁻ (λ i → 𝓓 [ arb𝓕 (~ i) ⟅ v ⟆ , arb𝓕 (~ i) ⟅ w ⟆ ])) (fromPathP⁻ lem𝓒)
185+
∙ sym (transportComposite ((λ i → 𝓓 [ 𝓕 ⟅ arb𝓒-agree (~ i) $g v ⟆ , 𝓕 ⟅ arb𝓒-agree (~ i) $g w ⟆ ])) (λ i → 𝓓 [ arb𝓕 i ⟅ v ⟆ , arb𝓕 i ⟅ w ⟆ ]) ((𝓕 ⟪ semG ⟪ e ⟫ ⟫)))
186+
∙ ((λ i → transport (substOf-sems-agreeϕ i) (𝓕 ⟪ semG ⟪ e ⟫ ⟫)))
187+
∙ transportComposite (λ i → 𝓓 [ ıϕp i v , ıϕp i w ]) (λ i → 𝓓 [ arb𝓓-agree (~ i) $g ϕ v , arb𝓓-agree (~ i) $g ϕ w ]) (𝓕 ⟪ semG ⟪ e ⟫ ⟫)
188+
))
189+
where
190+
lem' : PathP (λ i → 𝓓 [ arb𝓕 (~ i) ⟅ v ⟆ , arb𝓕 (~ i) ⟅ w ⟆ ])
191+
(arb𝓓 ⟪ Fϕ ⟪ e ⟫ ⟫)
192+
(𝓕 ⟪ arb𝓒 ⟪ e ⟫ ⟫)
193+
lem' i = arb𝓕 (~ i) ⟪ e ⟫
194+
195+
lem𝓒 : PathP (λ i → 𝓓 [ 𝓕 ⟅ arb𝓒-agree i $g v ⟆ , 𝓕 ⟅ arb𝓒-agree i $g w ⟆ ])
196+
(𝓕 ⟪ arb𝓒 ⟪ e ⟫ ⟫)
197+
(𝓕 ⟪ semG ⟪ e ⟫ ⟫)
198+
lem𝓒 i = 𝓕 ⟪ sem-uniq-G i ⟪ e ⟫ ⟫
199+
200+
substOf-sems-agreeϕ : ((λ i → 𝓓 [ 𝓕 ⟅ arb𝓒-agree (~ i) $g v ⟆ , 𝓕 ⟅ arb𝓒-agree (~ i) $g w ⟆ ]) ∙ (λ i → 𝓓 [ arb𝓕 i ⟅ v ⟆ , arb𝓕 i ⟅ w ⟆ ]))
201+
≡ ((λ i → 𝓓 [ ıϕp i v , ıϕp i w ]) ∙ (λ i → 𝓓 [ arb𝓓-agree (~ i) $g ϕ v , arb𝓓-agree (~ i) $g ϕ w ]))
202+
substOf-sems-agreeϕ =
203+
sym (cong-∙ A (λ i x → 𝓕 ⟅ arb𝓒-agree (~ i) $g x ⟆) λ i x → arb𝓕 i ⟅ x ⟆)
204+
-- Square (λ i z → ıϕ i z) (λ i → _⟅_⟆ (semϕ' i)) (λ i z → 𝓕 ⟅ sems-agree𝓒 (~ i) $g z ⟆) (λ i x → sems-agree𝓓 (~ i) $g ϕ x)
205+
∙ cong (cong A) (Square→compPath λ i j x → arb𝓕-agree (~ i) j x)
206+
∙ cong-∙ A (λ i x → ıϕp i x) (λ i x → arb𝓓-agree (~ i) $g ϕ x) where
207+
the-type = (G .Node → 𝓓 .ob)
208+
A = (λ (f : the-type) → 𝓓 [ f v , f w ])
209+
aom : ∀ {v w : H .Node} (f : FH [ v , w ]) → aom-type f
210+
aom (↑ x) = λ i → arb𝓓-agree i <$g> x
211+
aom idₑ = aom-id
212+
aom (f ⋆ₑ g) = aom-seq (aom f) (aom g)
213+
aom F⟪ x ⟫ = aom-F x
214+
-- Just some isSet→SquareP nonsense
215+
aom (⋆ₑIdL f i) = isSet→SquareP (λ i j → 𝓓 .isSetHom) (aom-seq aom-id (aom f)) (aom f) (λ i → arb𝓓 ⟪ ⋆ₑIdL f i ⟫) (λ i → (semH ⟪ ⋆ₑIdL f i ⟫)) i
216+
aom (⋆ₑIdR f i) = isSet→SquareP (λ i j → 𝓓 .isSetHom) (aom-seq (aom f) aom-id) (aom f ) (λ i → arb𝓓 ⟪ ⋆ₑIdR f i ⟫) (λ i → semH ⟪ ⋆ₑIdR f i ⟫) i
217+
aom (⋆ₑAssoc f f₁ f₂ i) = isSet→SquareP (λ i j → 𝓓 .isSetHom) (aom-seq (aom-seq (aom f) (aom f₁)) (aom f₂)) (aom-seq (aom f) (aom-seq (aom f₁) (aom f₂))) (λ i → arb𝓓 ⟪ ⋆ₑAssoc f f₁ f₂ i ⟫) (λ i → semH ⟪ ⋆ₑAssoc f f₁ f₂ i ⟫) i
218+
aom (F-idₑ i) = isSet→SquareP (λ i j → 𝓓 .isSetHom) (aom-F idₑ) aom-id (λ i → arb𝓓 ⟪ F-idₑ i ⟫) (λ i → semH ⟪ F-idₑ i ⟫) i
219+
aom (F-seqₑ f g i) = isSet→SquareP (λ i j → 𝓓 .isSetHom) (aom-F (f ⋆ₑ g)) (aom-seq (aom-F f) (aom-F g)) (λ i → arb𝓓 ⟪ F-seqₑ f g i ⟫) (λ i → semH ⟪ F-seqₑ f g i ⟫) i
220+
aom (isSetFExp f f₁ x y i j) k = isSet→SquareP (λ i j → (isOfHLevelPathP {A = λ k → 𝓓 [ aoo _ k , aoo _ k ]} 2 (𝓓 .isSetHom) (arb𝓓 ⟪ isSetFExp f f₁ x y i j ⟫) ((semH ⟪ isSetFExp f f₁ x y i j ⟫))))
221+
(λ j k → aom (x j) k)
222+
(λ j k → aom (y j) k)
223+
(λ i k → aom f k)
224+
(λ i k → aom f₁ k)
225+
i j k
226+
227+
-- TODO
228+
-- sem-uniq-ϕ : Square arb𝓕
229+
-- (idToPath semϕ)
230+
-- (λ i → 𝓕 ∘F sem-uniq-G i)
231+
-- (λ i → sem-uniq-H i ∘F Fϕ)
232+
-- sem-uniq-ϕ = {!!}
233+
234+
-- TODO: uniqueness of the uniqueness paths above

‎Cubical/Tactics/FunctorSolver/Examples.agda

Lines changed: 36 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,36 @@
1+
{-# OPTIONS --safe #-}
2+
module Cubical.Tactics.FunctorSolver.Examples where
3+
4+
open import Cubical.Foundations.Prelude
5+
6+
open import Cubical.Categories.Category
7+
open import Cubical.Categories.Functor
8+
open import Cubical.Tactics.FunctorSolver.Reflection
9+
10+
private
11+
variable
12+
ℓ ℓ' : Level
13+
C D : Category ℓ ℓ'
14+
F : Functor C D
15+
16+
module Examples (F : Functor C D) where
17+
open Category
18+
open Functor
19+
20+
_ : ∀ {A B}{f : D [ A , B ]}
21+
→ D .id ∘⟨ D ⟩ f ≡ f ∘⟨ D ⟩ D .id
22+
_ = solveFunctor! C D F
23+
24+
_ : ∀ {A}
25+
→ D .id ≡ F ⟪ (C .id {A}) ⟫
26+
_ = solveFunctor! C D F
27+
28+
29+
_ : {W X Y : C .ob}
30+
→ {Z : D .ob}
31+
→ {f : C [ W , X ]}
32+
→ {g : C [ X , Y ]}
33+
→ {h : D [ F ⟅ Y ⟆ , Z ]}
34+
→ h ∘⟨ D ⟩ F ⟪ (g ∘⟨ C ⟩ C .id) ∘⟨ C ⟩ f ⟫ ∘⟨ D ⟩ F ⟪ C .id ⟫
35+
≡ D .id ∘⟨ D ⟩ h ∘⟨ D ⟩ F ⟪ C .id ∘⟨ C ⟩ g ⟫ ∘⟨ D ⟩ F ⟪ f ∘⟨ C ⟩ C .id ⟫
36+
_ = solveFunctor! C D F

‎Cubical/Tactics/FunctorSolver/Reflection.agda

Lines changed: 81 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,81 @@
1+
{-# OPTIONS --safe #-}
2+
3+
module Cubical.Tactics.FunctorSolver.Reflection where
4+
5+
open import Cubical.Foundations.Prelude
6+
7+
open import Agda.Builtin.Reflection hiding (Type)
8+
open import Agda.Builtin.String
9+
open import Cubical.Categories.Category
10+
open import Cubical.Categories.Functor
11+
open import Cubical.Categories.Constructions.Free.Category
12+
open import Cubical.Categories.Constructions.Free.Functor
13+
open import Cubical.Data.Bool
14+
open import Cubical.Data.List
15+
open import Cubical.Data.Maybe
16+
open import Cubical.Data.Sigma
17+
open import Cubical.Data.Unit
18+
open import Cubical.Reflection.Base
19+
open import Cubical.Tactics.FunctorSolver.Solver
20+
open import Cubical.Tactics.Reflection
21+
22+
private
23+
variable
24+
ℓ ℓ' : Level
25+
26+
module ReflectionSolver where
27+
module _ (domain : Term) (codomain : Term) (functor : Term) where
28+
-- the two implicit levels and the category
29+
pattern category-args xs =
30+
_ h∷ _ h∷ _ v∷ xs
31+
32+
-- the four implicit levels, the two implicit categories and the functor
33+
pattern functor-args functor xs =
34+
_ h∷ _ h∷ _ h∷ _ h∷ _ h∷ _ h∷ functor v∷ xs
35+
36+
pattern “id” =
37+
def (quote Category.id) (category-args (_ h∷ []))
38+
39+
pattern “⋆” f g =
40+
def (quote Category._⋆_) (category-args (_ h∷ _ h∷ _ h∷ f v∷ g v∷ []))
41+
42+
pattern “F” functor f =
43+
def (quote Functor.F-hom) (functor-args functor (_ h∷ _ h∷ f v∷ []))
44+
45+
-- Parse the input into an exp
46+
buildDomExpression : Term → Term
47+
buildDomExpression “id” = con (quote FreeCategory.idₑ) []
48+
buildDomExpression (“⋆” f g) = con (quote FreeCategory._⋆ₑ_) (buildDomExpression f v∷ buildDomExpression g v∷ [])
49+
buildDomExpression f = con (quote FreeCategory.↑_) (f v∷ [])
50+
51+
buildCodExpression : Term → TC Term
52+
buildCodExpression “id” = returnTC (con (quote FreeFunctor.idₑ) [])
53+
buildCodExpression (“⋆” f g) = ((λ fe ge → (con (quote FreeFunctor._⋆ₑ_) (fe v∷ ge v∷ []))) <$> buildCodExpression f) <*> buildCodExpression g
54+
buildCodExpression (“F” functor' f) = do
55+
unify functor functor'
56+
returnTC (con (quote FreeFunctor.F⟪_⟫) (buildDomExpression f v∷ []))
57+
buildCodExpression f = returnTC (con (quote FreeFunctor.↑_) (f v∷ []))
58+
59+
solve-macro : Bool -- ^ whether to give the more detailed but messier error message on failure
60+
→ Term -- ^ The term denoting the domain category
61+
→ Term -- ^ The term denoting the codomain category
62+
→ Term -- ^ The term denoting the functor
63+
→ Term -- ^ The hole whose goal should be an equality between morphisms in the codomain category
64+
→ TC Unit
65+
solve-macro b dom cod fctor =
66+
equation-solver (quote Category.id ∷ quote Category._⋆_ ∷ quote Functor.F-hom ∷ []) mk-call b where
67+
68+
mk-call : Term → Term → TC Term
69+
mk-call lhs rhs = do
70+
l-e ← buildCodExpression dom cod fctor lhs
71+
r-e ← buildCodExpression dom cod fctor rhs
72+
-- unify l-e r-e
73+
returnTC (def (quote Eval.solve) (
74+
dom v∷ cod v∷ fctor v∷
75+
l-e v∷ r-e v∷ def (quote refl) [] v∷ []))
76+
macro
77+
solveFunctor! : Term → Term → Term → Term → TC _
78+
solveFunctor! = ReflectionSolver.solve-macro false
79+
80+
solveFunctorDebug! : Term → Term → Term → Term → TC _
81+
solveFunctorDebug! = ReflectionSolver.solve-macro true

0 commit comments

Comments
 (0)