open import 1Lab.Reflection.Solver open import 1Lab.Reflection open import 1Lab.Prelude hiding (id ; _∘_) open import Cat.Base open import Data.Bool open import Data.List module Cat.Solver where

# Solver for Categories🔗

This module is split pretty cleanly into two halves: the first half implements an algorithm for reducing, in a systematic way, problems involving associativity and identity of composition in a precategory. The latter half, significantly more cursed, uses this infrastructure to automatically solve equality goals of this form.

With a precategory in hand, we by defining a language of composition.

module NbE (Cat : Precategory o h) where open Precategory Cat

data Expr : Ob → Ob → Type (o ⊔ h) where `id : Expr A A _`∘_ : Expr B C → Expr A B → Expr A C _↑ : Hom A B → Expr A B infixr 40 _`∘_ infix 50 _↑

A term of type Expr represents, in a symbolic way, a
composite of morphisms in our category
$C$.
What this means is that, while
$f \circ g$
is some unknowable inhabitant of Hom,
$f `\circ g$
represents an inhabitant of Hom which is
*known* to be a composition of (the trees that represent)
$f$
and
$g$.
We can now define “two” ways of computing the morphism that an Expr represents. The first is a
straightforward embedding:

embed : Expr A B → Hom A B embed `id = id embed (f ↑) = f embed (f `∘ g) = embed f ∘ embed g

The second computation is a bit less obvious. If you’re a programmer,
it should be familiar under the name “continuation passing style”.
Categorically, it can be seen as embedding into the presheaf category of
$C$.
In either case, the difference is that instead of computing a single
morphism, we compute a *transformation of hom-spaces*:

eval : Expr B C → Hom A B → Hom A C eval `id f = f eval (f ↑) g = f ∘ g eval (f `∘ g) h = eval f (eval g h) nf : Expr A B → Hom A B nf e = eval e id eval-sound-k : (e : Expr B C) (f : Hom A B) → eval e id ∘ f ≡ eval e f eval-sound-k `id f = idl _ eval-sound-k (x ↑) f = ap (_∘ f) (idr x) eval-sound-k (f `∘ g) h = eval f (eval g id) ∘ h ≡⟨ ap (_∘ h) (sym (eval-sound-k f (eval g id))) ⟩≡ (eval f id ∘ eval g id) ∘ h ≡⟨ sym (assoc _ _ _) ⟩≡ eval f id ∘ eval g id ∘ h ≡⟨ ap (_ ∘_) (eval-sound-k g h) ⟩≡ eval f id ∘ eval g h ≡⟨ eval-sound-k f _ ⟩≡ eval (f `∘ g) h ∎

Working this out in a back-of-the-envelope calculation, one sees that
`eval f id`

should compute the same morphism as
`embed f`

. Indeed, that’s the case! Since embed is the
“intended semantics”, and eval is an “optimised evaluator”, we call this
result *soundness*. We can prove it by induction on the
expression. Here are the two straightforward cases, and why they
work:

eval-sound : (e : Expr A B) → eval e id ≡ embed e eval-sound `id = refl -- eval `id computes away eval-sound (x ↑) = idr _ -- must show f = f ∘ id

Now comes the complicated part. First, we’ll factor out proving that nested eval is the same as eval of a composition to a helper lemma. Then comes the actual inductive argument: We apply our lemma (still to be defined!), then we can apply the induction hypothesis, getting us to our goal.

eval-sound (f `∘ g) = eval f (eval g id) ≡⟨ sym (eval-sound-k f (eval g id)) ⟩≡ eval f id ∘ eval g id ≡⟨ ap₂ _∘_ (eval-sound f) (eval-sound g) ⟩≡ embed (f `∘ g) ∎

We now have a general theorem for solving associativity and identity problems! If two expressions compute the same transformation of hom-sets, then they represent the same morphism.

abstract solve : (f g : Expr A B) → eval f id ≡ eval g id → embed f ≡ embed g solve f g p = sym (eval-sound f) ·· p ·· (eval-sound g) solve-filler : (f g : Expr A B) → (p : eval f id ≡ eval g id) → Square (eval-sound f) p (solve f g p) (eval-sound g) solve-filler f g p j i = ··-filler (sym (eval-sound f)) p (eval-sound g) j i

# The cursed part🔗

module Reflection where pattern category-args xs = _ hm∷ _ hm∷ _ v∷ xs pattern “id” = def (quote Precategory.id) (category-args (_ h∷ [])) pattern “∘” f g = def (quote Precategory._∘_) (category-args (_ h∷ _ h∷ _ h∷ f v∷ g v∷ [])) mk-category-args : Term → List (Arg Term) → List (Arg Term) mk-category-args cat xs = unknown h∷ unknown h∷ cat v∷ xs “solve” : Term → Term → Term → Term “solve” cat lhs rhs = def (quote NbE.solve) (mk-category-args cat $ infer-hidden 2 $ lhs v∷ rhs v∷ def (quote refl) [] v∷ []) “nf” : Term → Term → Term “nf” cat e = def (quote NbE.nf) (mk-category-args cat $ infer-hidden 2 $ e v∷ []) build-expr : Term → Term build-expr “id” = con (quote NbE.`id) [] build-expr (“∘” f g) = con (quote NbE._`∘_) (build-expr f v∷ build-expr g v∷ [] ) build-expr f = con (quote NbE._↑) (f v∷ []) dont-reduce : List Name dont-reduce = quote Precategory.id ∷ quote Precategory._∘_ ∷ [] cat-solver : Term → SimpleSolver cat-solver cat .SimpleSolver.dont-reduce = dont-reduce cat-solver cat .SimpleSolver.build-expr tm = returnTC $ build-expr tm cat-solver cat .SimpleSolver.invoke-solver = “solve” cat cat-solver cat .SimpleSolver.invoke-normaliser = “nf” cat repr-macro : Term → Term → Term → TC ⊤ repr-macro cat f _ = mk-simple-repr (cat-solver cat) f simplify-macro : Term → Term → Term → TC ⊤ simplify-macro cat f hole = mk-simple-normalise (cat-solver cat) f hole solve-macro : Term → Term → TC ⊤ solve-macro cat hole = mk-simple-solver (cat-solver cat) hole macro repr-cat! : Term → Term → Term → TC ⊤ repr-cat! cat f = Reflection.repr-macro cat f simpl-cat! : Term → Term → Term → TC ⊤ simpl-cat! cat f = Reflection.simplify-macro cat f cat! : Term → Term → TC ⊤ cat! = Reflection.solve-macro

## Demo🔗

As a quick demonstration (and sanity check/future proofing/integration testing/what have you):

module _ (C : Precategory o h) where private module C = Precategory C variable A B : C.Ob a b c d : C.Hom A B test : a C.∘ (b C.∘ (c C.∘ C.id) C.∘ C.id C.∘ (d C.∘ C.id)) ≡ a C.∘ b C.∘ c C.∘ d test = cat! C