tag) with the given attributes around some HTML.
380 | anchorage :: [Attribute] -> Html -> Html
381 | anchorage attrs html = Html5.a html !! attrs
382 |
383 | -- File position anchor (unique, reliable).
384 | posAttributes :: [Attribute]
385 | posAttributes = concat
386 | [ [Attr.id $ stringValue $ show pos ]
387 | , toList $ link <$> definitionSite mi
388 | , Attr.class_ (stringValue $ unwords classes) <$ guard (not $ null classes)
389 | ]
390 |
391 | -- Named anchor (not reliable, but useful in the general case for outside refs).
392 | nameAttributes :: [Attribute]
393 | nameAttributes = [ Attr.id $ stringValue $ fromMaybe __IMPOSSIBLE__ $ mDefSiteAnchor ]
394 |
395 | classes = concat
396 | [ concatMap noteClasses (note mi)
397 | , otherAspectClasses (toList $ otherAspects mi)
398 | , concatMap aspectClasses (aspect mi)
399 | ]
400 |
401 | aspectClasses (Name mKind op) = kindClass ++ opClass
402 | where
403 | kindClass = toList $ fmap showKind mKind
404 |
405 | showKind (Constructor Inductive) = "InductiveConstructor"
406 | showKind (Constructor CoInductive) = "CoinductiveConstructor"
407 | showKind k = show k
408 |
409 | opClass = ["Operator" | op]
410 | aspectClasses a = [show a]
411 |
412 |
413 | otherAspectClasses = map show
414 |
415 | -- Notes are not included.
416 | noteClasses _s = []
417 |
418 | -- Should we output a named anchor?
419 | -- Only if we are at the definition site now (@here@)
420 | -- and such a pretty named anchor exists (see 'defSiteAnchor').
421 | hereAnchor :: Bool
422 | hereAnchor = here && isJust mDefSiteAnchor
423 |
424 | mDefinitionSite :: Maybe DefinitionSite
425 | mDefinitionSite = definitionSite mi
426 |
427 | -- Are we at the definition site now?
428 | here :: Bool
429 | here = maybe False defSiteHere mDefinitionSite
430 |
431 | mDefSiteAnchor :: Maybe String
432 | mDefSiteAnchor = maybe __IMPOSSIBLE__ defSiteAnchor mDefinitionSite
433 |
434 | link (DefinitionSite m defPos _here aName) = Attr.href $ stringValue $
435 | -- If the definition site points to the top of a file,
436 | -- we drop the anchor part and just link to the file.
437 | applyUnless (defPos <= 1)
438 | (++ "#" ++ Network.URI.Encode.encode anchor)
439 | (maybe id () u $ Network.URI.Encode.encode $ modToFile m "")
440 | where
441 | u = Map.lookup m moduleToURL
442 | -- Use named anchors for external links as they should be more stable(?)
443 | anchor | Just a <- aName, Just u' <- u, u' /= "" = a
444 | | otherwise = show defPos
445 |
--------------------------------------------------------------------------------
/shake/LICENSE.agda:
--------------------------------------------------------------------------------
1 | The files under HTML/ are modified versions of Agda's HTML backend.
2 | Agda is distributed with the following license:
3 |
4 | Copyright (c) 2005-2024 remains with the authors.
5 | Agda 2 was originally written by Ulf Norell,
6 | partially based on code from Agda 1 by Catarina Coquand and Makoto Takeyama,
7 | and from Agdalight by Ulf Norell and Andreas Abel.
8 | Cubical Agda was originally contributed by Andrea Vezzosi.
9 |
10 | Agda 2 is currently actively developed mainly by Andreas Abel,
11 | Guillaume Allais, Liang-Ting Chen, Jesper Cockx, Matthew Daggitt,
12 | Nils Anders Danielsson, Amélia Liao, Ulf Norell, and
13 | Andrés Sicard-Ramírez.
14 |
15 | Further, Agda 2 has received contributions by, amongst others,
16 | Arthur Adjedj, Stevan Andjelkovic,
17 | Marcin Benke, Jean-Philippe Bernardy, Guillaume Brunerie,
18 | James Chapman, Jonathan Coates,
19 | Dominique Devriese, Péter Diviánszky, Robert Estelle,
20 | Olle Fredriksson, Adam Gundry, Daniel Gustafsson, Philipp Hausmann,
21 | Alan Jeffrey, Phil de Joux,
22 | Wolfram Kahl, Wen Kokke, John Leo, Fredrik Lindblad,
23 | Víctor López Juan, Ting-Gan Lua, Francesco Mazzoli, Stefan Monnier,
24 | Guilhem Moulin, Konstantin Nisht, Fredrik Nordvall Forsberg,
25 | Josselin Poiret, Nicolas Pouillard, Jonathan Prieto, Christian Sattler,
26 | Makoto Takeyama, Andrea Vezzosi, Noam Zeilberger, and Tesla Ice Zhang.
27 | The full list of contributors is available at
28 | https://github.com/agda/agda/graphs/contributors or from the git
29 | repository via ``git shortlog -sne``.
30 |
31 | Permission is hereby granted, free of charge, to any person obtaining
32 | a copy of this software and associated documentation files (the
33 | "Software"), to deal in the Software without restriction, including
34 | without limitation the rights to use, copy, modify, merge, publish,
35 | distribute, sublicense, and/or sell copies of the Software, and to
36 | permit persons to whom the Software is furnished to do so, subject to
37 | the following conditions:
38 |
39 | The above copyright notice and this permission notice shall be
40 | included in all copies or substantial portions of the Software.
41 |
42 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
43 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
44 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
45 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
46 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
47 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
48 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
49 |
--------------------------------------------------------------------------------
/shake/Main.hs:
--------------------------------------------------------------------------------
1 | import Agda.Compiler.Backend hiding (getEnv)
2 | import Agda.Interaction.Imports
3 | import Agda.Interaction.Library.Base
4 | import Agda.Interaction.Options
5 | import Agda.TypeChecking.Errors
6 | import Agda.Utils.FileName
7 | import Agda.Utils.Monad
8 |
9 | import Control.Monad.Error.Class
10 |
11 | import Data.Foldable
12 | import Data.List
13 | import Data.Map qualified as Map
14 | import Data.Text qualified as T
15 |
16 | import Development.Shake
17 | import Development.Shake.Classes
18 | import Development.Shake.FilePath
19 |
20 | import HTML.Backend
21 | import HTML.Base
22 |
23 | import Text.HTML.TagSoup
24 | import Text.Pandoc
25 | import Text.Pandoc.Walk
26 |
27 | newtype CompileDirectory = CompileDirectory (FilePath, FilePath)
28 | deriving (Show, Typeable, Eq, Hashable, Binary, NFData)
29 | type instance RuleResult CompileDirectory = ()
30 |
31 | sourceDir, source1labDir, buildDir, htmlDir, siteDir, everything, everything1lab :: FilePath
32 | sourceDir = "src"
33 | source1labDir = "src-1lab"
34 | buildDir = "_build"
35 | htmlDir = buildDir "html"
36 | siteDir = buildDir "site"
37 | everything = sourceDir "Everything.agda"
38 | everything1lab = source1labDir "Everything-1lab.agda"
39 |
40 | myHtmlBackend :: Backend
41 | myHtmlBackend = Backend htmlBackend'
42 | { options = initialHtmlFlags
43 | { htmlFlagDir = htmlDir
44 | , htmlFlagHighlightOccurrences = True
45 | , htmlFlagCssFile = Just "style.css"
46 | , htmlFlagHighlight = HighlightCode
47 | , htmlFlagLibToURL = \ (LibName lib version) ->
48 | let v = intercalate "." (map show version) in
49 | Map.lookup lib $ Map.fromList
50 | [ ("agda-builtins", "https://agda.github.io/agda-stdlib/master")
51 | , ("standard-library", "https://agda.github.io/agda-stdlib/v" <> v)
52 | , ("cubical", "https://agda.github.io/cubical")
53 | , ("1lab", "https://1lab.dev")
54 | , ("cubical-experiments", "")
55 | ]
56 | }
57 | }
58 |
59 | filenameToModule :: FilePath -> String
60 | filenameToModule f = dropExtensions f
61 |
62 | makeEverythingFile :: [FilePath] -> String
63 | makeEverythingFile = unlines . map (\ m -> "import " <> filenameToModule m)
64 |
65 | readFileText :: FilePath -> Action T.Text
66 | readFileText = fmap T.pack . readFile'
67 |
68 | importToModule :: String -> String
69 | importToModule s = innerText tags
70 | where tags = parseTags s
71 |
72 | patchBlock :: Block -> Block
73 | -- Add anchor links next to headers
74 | patchBlock (Header i a@(ident, _, _) inl) | ident /= "" = Header i a $
75 | inl ++ [Link ("", ["anchor"], [("aria-hidden", "true")]) [] ("#" <> ident, "")]
76 | patchBlock b = b
77 |
78 | main :: IO ()
79 | main = shakeArgs shakeOptions do
80 | -- I realise this is not how a Shakefile should be structured, but I got
81 | -- bored trying to figure it out and this is good enough for now.
82 | -- I should probably look into Development.Shake.Forward ...
83 | compileModule <- addOracle \ (CompileDirectory (sourceDir, everything)) -> do
84 | librariesFile <- getEnv "AGDA_LIBRARIES_FILE"
85 | sourceFiles <- filter (not . ("Everything*" ?==)) <$>
86 | getDirectoryFiles sourceDir ["//*.agda", "//*.lagda.md"]
87 | writeFile' everything (makeEverythingFile sourceFiles)
88 | traced "agda" do
89 | root <- absolute sourceDir
90 | runTCMTopPrettyErrors do
91 | setCommandLineOptions' root defaultOptions
92 | { optOverrideLibrariesFile = librariesFile
93 | , optDefaultLibs = False
94 | }
95 | stBackends `setTCLens` [myHtmlBackend]
96 | sourceFile <- srcFromPath =<< liftIO (absolute everything)
97 | source <- parseSource sourceFile
98 | checkResult <- typeCheckMain TypeCheck source
99 | callBackend "HTML" IsMain checkResult
100 | moduleTemplate <- readFileText "module.html"
101 | for_ sourceFiles \ sourceFile -> do
102 | let
103 | htmlFile = dropExtensions sourceFile <.> "html"
104 | literateFile = dropExtensions sourceFile <.> takeExtension sourceFile -- .lagda.md → .md
105 | contents <- case takeExtensions sourceFile of
106 | ".lagda.md" -> do
107 | markdown <- readFileText (htmlDir literateFile)
108 | traced "pandoc" $ runIOorExplode do
109 | pandoc <- readMarkdown def {
110 | readerExtensions = foldr enableExtension pandocExtensions [Ext_autolink_bare_uris]
111 | } markdown
112 | pandoc <- pure $ walk patchBlock pandoc
113 | writeHtml5String def pandoc
114 | ".agda" -> do
115 | html <- readFileText (htmlDir htmlFile)
116 | pure $ "" <> html <> "
"
117 | _ -> fail ("unknown extension for file " <> sourceFile)
118 | writeFile' (siteDir htmlFile)
119 | $ T.unpack
120 | $ T.replace "@contents@" contents
121 | $ T.replace "@moduleName@" (T.pack $ filenameToModule sourceFile)
122 | $ T.replace "@path@" (T.pack $ sourceDir sourceFile)
123 | $ moduleTemplate
124 |
125 | siteDir "index.html" %> \ index -> do
126 | compileModule (CompileDirectory (sourceDir, everything))
127 | compileModule (CompileDirectory (source1labDir, everything1lab))
128 | indexTemplate <- readFileText "index.html"
129 | everythingAgda <- (<>)
130 | <$> readFileLines (htmlDir "Everything.html")
131 | <*> readFileLines (htmlDir "Everything-1lab.html")
132 | writeFile' index
133 | $ T.unpack
134 | $ T.replace "@contents@" (T.pack $ unlines $ sortOn importToModule $ everythingAgda)
135 | $ indexTemplate
136 | copyFile' "style.css" (siteDir "style.css")
137 | copyFile' "main.js" (siteDir "main.js")
138 | copyFile' (htmlDir "highlight-hover.js") (siteDir "highlight-hover.js")
139 |
140 | phony "all" do
141 | need [siteDir "index.html"]
142 |
143 | want ["all"]
144 |
145 | runTCMTopPrettyErrors :: TCM a -> IO a
146 | runTCMTopPrettyErrors tcm = do
147 | r <- runTCMTop' $ (Just <$> tcm) `catchError` \err -> do
148 | warnings <- fmap (map show) . prettyTCWarnings' =<< getAllWarningsOfTCErr err
149 | errors <- show <$> prettyError err
150 | let everything = filter (not . null) $ warnings ++ [errors]
151 | unless (null errors) . liftIO . putStr $ unlines everything
152 | pure Nothing
153 |
154 | maybe (fail "Agda compilation failed") pure r
155 |
--------------------------------------------------------------------------------
/shake/cubical-experiments-shake.cabal:
--------------------------------------------------------------------------------
1 | cabal-version: 3.4
2 | name: cubical-experiments-shake
3 | version: 0.1.0.0
4 | license: AGPL-3.0-or-later
5 | author: Naïm Favier
6 | maintainer: n@monade.li
7 | category: Development
8 | build-type: Simple
9 |
10 | executable cubical-experiments-shake
11 | ghc-options: -Wall -Wno-name-shadowing
12 | main-is: Main.hs
13 | other-modules: HTML.Base,
14 | HTML.Backend,
15 | build-depends: base,
16 | Agda,
17 | shake,
18 | blaze-html,
19 | containers,
20 | deepseq,
21 | directory,
22 | filepath,
23 | mtl,
24 | pandoc,
25 | pandoc-types,
26 | regex-tdfa,
27 | silently,
28 | split,
29 | tagsoup,
30 | text,
31 | transformers,
32 | uri-encode,
33 | hs-source-dirs: .
34 | default-language: GHC2021
35 | default-extensions:
36 | BangPatterns
37 | BlockArguments
38 | ConstraintKinds
39 | DefaultSignatures
40 | DeriveFoldable
41 | DeriveFunctor
42 | DeriveGeneric
43 | DeriveTraversable
44 | DerivingStrategies
45 | ExistentialQuantification
46 | FlexibleContexts
47 | FlexibleInstances
48 | FunctionalDependencies
49 | GADTs
50 | GeneralizedNewtypeDeriving
51 | InstanceSigs
52 | LambdaCase
53 | MultiParamTypeClasses
54 | MultiWayIf
55 | NamedFieldPuns
56 | OverloadedStrings
57 | PatternSynonyms
58 | RankNTypes
59 | RecordWildCards
60 | ScopedTypeVariables
61 | StandaloneDeriving
62 | TupleSections
63 | TypeFamilies
64 | TypeOperators
65 | TypeSynonymInstances
66 | ViewPatterns
67 |
--------------------------------------------------------------------------------
/src-1lab/AdjunctionCommaIso.agda:
--------------------------------------------------------------------------------
1 | open import Cat.Functor.Adjoint
2 | open import Cat.Functor.Equivalence
3 | open import Cat.Instances.Comma
4 | open import Cat.Prelude
5 |
6 | import Cat.Reasoning
7 |
8 | open ↓Hom
9 | open ↓Obj
10 | open Functor
11 | open is-iso
12 | open is-precat-iso
13 |
14 | -- An adjunction F ⊣ G induces an isomorphism of comma categories F ↓ 1 ≅ 1 ↓ G
15 | module AdjunctionCommaIso where
16 |
17 | module _
18 | {oc ℓc od ℓd} {C : Precategory oc ℓc} {D : Precategory od ℓd}
19 | {F : Functor C D} {G : Functor D C} (F⊣G : F ⊣ G)
20 | where
21 |
22 | module C = Cat.Reasoning C
23 | module D = Cat.Reasoning D
24 |
25 | to : Functor (F ↓ Id) (Id ↓ G)
26 | to .F₀ o .x = o .x
27 | to .F₀ o .y = o .y
28 | to .F₀ o .map = L-adjunct F⊣G (o .map)
29 | to .F₁ f .α = f .α
30 | to .F₁ f .β = f .β
31 | to .F₁ {a} {b} f .sq =
32 | L-adjunct F⊣G (b .map) C.∘ f .α ≡˘⟨ L-adjunct-naturall F⊣G _ _ ⟩
33 | L-adjunct F⊣G (b .map D.∘ F .F₁ (f .α)) ≡⟨ ap (L-adjunct F⊣G) (f .sq) ⟩
34 | L-adjunct F⊣G (f .β D.∘ a .map) ≡⟨ L-adjunct-naturalr F⊣G _ _ ⟩
35 | G .F₁ (f .β) C.∘ L-adjunct F⊣G (a .map) ∎
36 | to .F-id = trivial!
37 | to .F-∘ _ _ = trivial!
38 |
39 | to-is-precat-iso : is-precat-iso to
40 | to-is-precat-iso .has-is-ff = is-iso→is-equiv is where
41 | is : ∀ {a b} → is-iso (to .F₁ {a} {b})
42 | is .from f .α = f .α
43 | is .from f .β = f .β
44 | is {a} {b} .from f .sq = Equiv.injective (adjunct-hom-equiv F⊣G) $
45 | L-adjunct F⊣G (b .map D.∘ F .F₁ (f .α)) ≡⟨ L-adjunct-naturall F⊣G _ _ ⟩
46 | L-adjunct F⊣G (b .map) C.∘ f .α ≡⟨ f .sq ⟩
47 | G .F₁ (f .β) C.∘ L-adjunct F⊣G (a .map) ≡˘⟨ L-adjunct-naturalr F⊣G _ _ ⟩
48 | L-adjunct F⊣G (f .β D.∘ a .map) ∎
49 | is .rinv f = trivial!
50 | is .linv f = trivial!
51 | to-is-precat-iso .has-is-iso = is-iso→is-equiv is where
52 | is : is-iso (to .F₀)
53 | is .from o .x = o .x
54 | is .from o .y = o .y
55 | is .from o .map = R-adjunct F⊣G (o .map)
56 | is .rinv o = ↓Obj-path _ _ refl refl (L-R-adjunct F⊣G _)
57 | is .linv o = ↓Obj-path _ _ refl refl (R-L-adjunct F⊣G _)
58 |
--------------------------------------------------------------------------------
/src-1lab/Applicative.agda:
--------------------------------------------------------------------------------
1 | open import 1Lab.Equiv
2 | open import 1Lab.Extensionality
3 | open import 1Lab.HLevel
4 | open import 1Lab.HLevel.Closure
5 | open import 1Lab.Path
6 | open import 1Lab.Reflection.HLevel
7 | open import 1Lab.Reflection.Record
8 | open import 1Lab.Type
9 | open import 1Lab.Type.Sigma
10 |
11 | -- Applicative fully determines the underlying Functor.
12 | module Applicative {ℓ} where
13 |
14 | private variable
15 | A B C : Type ℓ
16 |
17 | _∘'_ : ∀ {ℓ₁ ℓ₂ ℓ₃} {A : Type ℓ₁} {B : Type ℓ₂} {C : Type ℓ₃}
18 | → (B → C) → (A → B) → A → C
19 | f ∘' g = λ z → f (g z)
20 |
21 | record applicative (F : Type ℓ → Type ℓ) : Type (lsuc ℓ) where
22 | infixl 8 _<*>_
23 | field
24 | sets : is-set (F A)
25 | pure : A → F A
26 | _<*>_ : F (A → B) → F A → F B
27 | <*>-identity : ∀ {u : F A}
28 | → pure id <*> u ≡ u
29 | <*>-composition : ∀ {u : F (B → C)} {v : F (A → B)} {w : F A}
30 | → pure _∘'_ <*> u <*> v <*> w ≡ u <*> (v <*> w)
31 | <*>-homomorphism : ∀ {f : A → B} {x : A}
32 | → pure f <*> pure x ≡ pure (f x)
33 | <*>-interchange : ∀ {u : F (A → B)} {x : A}
34 | → u <*> pure x ≡ pure (λ f → f x) <*> u
35 |
36 | record applicative-functor (F : Type ℓ → Type ℓ) (app : applicative F) : Type (lsuc ℓ) where
37 | open applicative app
38 | infixl 8 _<$>_
39 | field
40 | _<$>_ : (A → B) → F A → F B
41 | <$>-identity : ∀ {x : F A}
42 | → id <$> x ≡ x
43 | <$>-composition : ∀ {f : B → C} {g : A → B} {x : F A}
44 | → f <$> (g <$> x) ≡ f ∘' g <$> x
45 | pure-natural : ∀ {f : A → B} {x : A}
46 | → f <$> pure x ≡ pure (f x)
47 | <*>-extranatural-A : ∀ {f : F (B → C)} {g : A → B} {x : F A}
48 | → f <*> (g <$> x) ≡ (_∘' g) <$> f <*> x
49 | <*>-natural-B : ∀ {g : B → C} {f : F (A → B)} {x : F A}
50 | → g <$> (f <*> x) ≡ (g ∘'_) <$> f <*> x
51 |
52 | open applicative-functor
53 | unquoteDecl eqv = declare-record-iso eqv (quote applicative-functor)
54 |
55 | applicative-functor-path
56 | : ∀ {F : Type ℓ → Type ℓ} {app} {a b : applicative-functor F app}
57 | → (∀ {A B} (f : A → B) x → a ._<$>_ f x ≡ b ._<$>_ f x)
58 | → a ≡ b
59 | applicative-functor-path {F = F} {app = app} p = Iso.injective eqv (Σ-prop-path! (ext λ f → p f))
60 | where instance
61 | F-sets : ∀ {x} → H-Level (F x) 2
62 | F-sets = hlevel-instance (app .applicative.sets)
63 |
64 | applicative-determines-functor : ∀ {F} (app : applicative F)
65 | → is-contr (applicative-functor F app)
66 | applicative-determines-functor {F} app = p where
67 | open applicative app
68 | p : is-contr (applicative-functor F app)
69 | p .centre ._<$>_ f x = pure f <*> x
70 | p .centre .<$>-identity = <*>-identity
71 | p .centre .<$>-composition {f = f} {g = g} {x = x} =
72 | pure f <*> (pure g <*> x) ≡⟨ sym <*>-composition ⟩
73 | pure _∘'_ <*> pure f <*> pure g <*> x ≡⟨ ap (λ y → y <*> pure g <*> x) <*>-homomorphism ⟩
74 | pure (f ∘'_) <*> pure g <*> x ≡⟨ ap (_<*> x) <*>-homomorphism ⟩
75 | pure (f ∘' g) <*> x ∎
76 | p .centre .pure-natural = <*>-homomorphism
77 | p .centre .<*>-extranatural-A {f = f} {g = g} {x = x} =
78 | f <*> (pure g <*> x) ≡⟨ sym <*>-composition ⟩
79 | pure _∘'_ <*> f <*> pure g <*> x ≡⟨ ap (_<*> x) <*>-interchange ⟩
80 | pure (_$ g) <*> (pure _∘'_ <*> f) <*> x ≡⟨ ap (_<*> x) (p .centre .<$>-composition) ⟩
81 | pure (_∘' g) <*> f <*> x ∎
82 | p .centre .<*>-natural-B {g = g} {f = f} {x = x} =
83 | pure g <*> (f <*> x) ≡⟨ sym <*>-composition ⟩
84 | pure _∘'_ <*> pure g <*> f <*> x ≡⟨ ap (λ y → y <*> f <*> x) <*>-homomorphism ⟩
85 | pure (g ∘'_) <*> f <*> x ∎
86 | p .paths app' = applicative-functor-path λ f x →
87 | pure f <*> x ≡⟨ ap (_<*> x) (sym A.pure-natural) ⟩
88 | (f ∘'_) A.<$> pure id <*> x ≡˘⟨ A.<*>-natural-B ⟩
89 | f A.<$> (pure id <*> x) ≡⟨ ap (f A.<$>_) <*>-identity ⟩
90 | f A.<$> x ∎
91 | where module A = applicative-functor app'
92 |
--------------------------------------------------------------------------------
/src-1lab/CoherentlyConstant.agda:
--------------------------------------------------------------------------------
1 | open import 1Lab.Prelude hiding (∥_∥³; ∥-∥³-elim-set; ∥-∥³-elim-prop; ∥-∥³-rec; ∥-∥³-is-prop; ∥-∥-rec-groupoid)
2 | open import 1Lab.Path.Reasoning
3 |
4 | -- Coherently constant maps into groupoids, now at https://1lab.dev/1Lab.HIT.Truncation.html#maps-into-groupoids
5 | module CoherentlyConstant where
6 |
7 | data ∥_∥³ {ℓ} (A : Type ℓ) : Type ℓ where
8 | inc : A → ∥ A ∥³
9 | iconst : ∀ a b → inc a ≡ inc b
10 | icoh : ∀ a b c → PathP (λ i → inc a ≡ iconst b c i) (iconst a b) (iconst a c)
11 | squash : is-groupoid ∥ A ∥³
12 |
13 | ∥-∥³-elim-set
14 | : ∀ {ℓ ℓ'} {A : Type ℓ} {P : ∥ A ∥³ → Type ℓ'}
15 | → (∀ a → is-set (P a))
16 | → (f : (a : A) → P (inc a))
17 | → (∀ a b → PathP (λ i → P (iconst a b i)) (f a) (f b))
18 | → ∀ a → P a
19 | ∥-∥³-elim-set {P = P} sets f fconst = go where
20 | go : ∀ a → P a
21 | go (inc x) = f x
22 | go (iconst a b i) = fconst a b i
23 | go (icoh a b c i j) = is-set→squarep (λ i j → sets (icoh a b c i j))
24 | refl (λ i → go (iconst a b i)) (λ i → go (iconst a c i)) (λ i → go (iconst b c i))
25 | i j
26 | go (squash a b p q r s i j k) = is-hlevel→is-hlevel-dep 2 (λ _ → is-hlevel-suc 2 (sets _))
27 | (go a) (go b)
28 | (λ k → go (p k)) (λ k → go (q k))
29 | (λ j k → go (r j k)) (λ j k → go (s j k))
30 | (squash a b p q r s) i j k
31 |
32 | ∥-∥³-elim-prop
33 | : ∀ {ℓ ℓ'} {A : Type ℓ} {P : ∥ A ∥³ → Type ℓ'}
34 | → (∀ a → is-prop (P a))
35 | → (f : (a : A) → P (inc a))
36 | → ∀ a → P a
37 | ∥-∥³-elim-prop props f = ∥-∥³-elim-set (λ _ → is-hlevel-suc 1 (props _)) f
38 | (λ _ _ → is-prop→pathp (λ _ → props _) _ _)
39 |
40 | ∥-∥³-rec
41 | : ∀ {ℓ ℓ'} {A : Type ℓ} {B : Type ℓ'}
42 | → is-groupoid B
43 | → (f : A → B)
44 | → (fconst : ∀ x y → f x ≡ f y)
45 | → (∀ x y z → fconst x y ∙ fconst y z ≡ fconst x z)
46 | → ∥ A ∥³ → B
47 | ∥-∥³-rec {A = A} {B} bgrpd f fconst fcoh = go where
48 | go : ∥ A ∥³ → B
49 | go (inc x) = f x
50 | go (iconst a b i) = fconst a b i
51 | go (icoh a b c i j) = ∙→square (sym (fcoh a b c)) i j
52 | go (squash x y a b p q i j k) = bgrpd
53 | (go x) (go y)
54 | (λ i → go (a i)) (λ i → go (b i))
55 | (λ i j → go (p i j)) (λ i j → go (q i j))
56 | i j k
57 |
58 | ∥-∥³-is-prop : ∀ {ℓ} {A : Type ℓ} → is-prop ∥ A ∥³
59 | ∥-∥³-is-prop = is-contr-if-inhabited→is-prop $
60 | ∥-∥³-elim-prop (λ _ → hlevel 1)
61 | (λ a → contr (inc a) (∥-∥³-elim-set (λ _ → squash _ _) (iconst a) (icoh a)))
62 |
63 | ∥-∥-rec-groupoid
64 | : ∀ {ℓ ℓ'} {A : Type ℓ} {B : Type ℓ'}
65 | → is-groupoid B
66 | → (f : A → B)
67 | → (fconst : ∀ x y → f x ≡ f y)
68 | → (∀ x y z → fconst x y ∙ fconst y z ≡ fconst x z)
69 | → ∥ A ∥ → B
70 | ∥-∥-rec-groupoid bgrpd f fconst fcoh =
71 | ∥-∥³-rec bgrpd f fconst fcoh ∘ ∥-∥-rec ∥-∥³-is-prop inc
72 |
--------------------------------------------------------------------------------
/src-1lab/EasyParametricity.lagda.md:
--------------------------------------------------------------------------------
1 |
2 | Imports
3 |
4 | ```agda
5 | open import Cat.Prelude hiding (J)
6 | open import Cat.Diagram.Limit.Base
7 | open import Cat.Instances.Discrete
8 | open import Cat.Instances.Shape.Join
9 | open import Cat.Instances.Product
10 |
11 | open import Data.Sum
12 |
13 | import Cat.Reasoning
14 | import Cat.Functor.Reasoning
15 | import Cat.Functor.Bifunctor
16 |
17 | open Precategory
18 | open Functor
19 | open make-is-limit
20 | ```
21 |
22 |
23 | This module formalises a few very interesting results from Jem Lord's recent work on
24 | [*Easy Parametricity*](https://hott-uf.github.io/2025/abstracts/HoTTUF_2025_paper_21.pdf),
25 | presented at [HoTT/UF 2025](https://hott-uf.github.io/2025/).
26 |
27 | ```agda
28 | module EasyParametricity {u} where
29 |
30 | U = Type u
31 | 𝟘 = Lift u ⊥
32 | 𝟙 = Lift u ⊤
33 |
34 | -- We think of functions f : U → A as "bridges" from f 𝟘 to f 𝟙.
35 | record Bridge {ℓ} (A : Type ℓ) (x y : A) : Type (ℓ ⊔ lsuc u) where
36 | no-eta-equality
37 | constructor bridge
38 | pattern
39 | field
40 | app : U → A
41 | app𝟘 : app 𝟘 ≡ x
42 | app𝟙 : app 𝟙 ≡ y
43 |
44 | -- Every function preserves bridges.
45 | ap-bridge
46 | : ∀ {ℓ ℓ'} {A : Type ℓ} {B : Type ℓ'} (f : A → B) {x y : A}
47 | → Bridge A x y → Bridge B (f x) (f y)
48 | ap-bridge f (bridge app app𝟘 app𝟙) = bridge (f ⊙ app) (ap f app𝟘) (ap f app𝟙)
49 |
50 | postulate
51 | -- An immediate consequence of Jem Lord's parametricity axiom: a function
52 | -- out of U into a U-small type cannot tell 0 and 1 apart; this is all we need here.
53 | -- In other words, U-small types are bridge-discrete.
54 | parametricity : ∀ {A : U} {x y : A} → Bridge A x y → x ≡ y
55 |
56 | -- The type of formal composites r ∘ l : A → B in C. We want to think of this
57 | -- as the type of factorisations of some morphism f : A → B, but it turns out
58 | -- to be unnecessary to track f in the type.
59 | record Factorisation {o ℓ} (C : Precategory o ℓ) (A B : C .Ob) : Type (o ⊔ ℓ) where
60 | constructor factor
61 | module C = Precategory C
62 | field
63 | X : C.Ob
64 | l : C.Hom A X
65 | r : C.Hom X B
66 |
67 | module _
68 | {o ℓ} {C : Precategory o ℓ}
69 | (let module C = Precategory C)
70 | where
71 |
72 | module _ {A B : C.Ob} (f : C.Hom A B) where
73 |
74 | -- The two factorisations id ∘ f and f ∘ id.
75 | _∘id id∘_ : Factorisation C A B
76 | _∘id = factor A C.id f
77 | id∘_ = factor B f C.id
78 |
79 | module _
80 | (C-complete : is-complete u lzero C)
81 | (C-category : is-category C)
82 | {A B : C.Ob} (f : C.Hom A B)
83 | where
84 |
85 | -- In a U-complete univalent category, every type of factorisations is bridge-codiscrete.
86 | -- We define a bridge from id ∘ f to f ∘ id.
87 |
88 | factorisation-bridge : Bridge (Factorisation C A B) (id∘ f) (f ∘id)
89 | factorisation-bridge = bridge b b0 b1 where
90 |
91 | b : U → Factorisation C A B
92 | b P = fac (C-complete diagram) module b where
93 |
94 | -- This is the interesting part: given a type P : U, we construct the
95 | -- wide pullback of P-many copies of f.
96 | -- Since we only care about the cases where P is a proposition, we
97 | -- can just take the discrete or codiscrete category on P and adjoin a
98 | -- terminal object to get our diagram shape.
99 | J : Precategory u lzero
100 | J = Codisc' P ▹
101 |
102 | diagram : Functor J C
103 | diagram .F₀ (inl _) = A
104 | diagram .F₀ (inr _) = B
105 | diagram .F₁ {inl _} {inl _} _ = C.id
106 | diagram .F₁ {inl _} {inr _} _ = f
107 | diagram .F₁ {inr _} {inr _} _ = C.id
108 | diagram .F-id {inl _} = refl
109 | diagram .F-id {inr _} = refl
110 | diagram .F-∘ {inl _} {inl _} {inl _} _ _ = sym (C.idl _)
111 | diagram .F-∘ {inl _} {inl _} {inr _} _ _ = sym (C.idr _)
112 | diagram .F-∘ {inl _} {inr _} {inr _} _ _ = sym (C.idl _)
113 | diagram .F-∘ {inr _} {inr _} {inr _} _ _ = sym (C.idl _)
114 |
115 | -- Given a limit of this diagram (which exists by the assumption of U-completeness),
116 | -- we get a factorisation of f as the universal map followed by the projection to B.
117 | fac : Limit diagram → Factorisation C A B
118 | fac lim = factor X l r where
119 | module lim = Limit lim
120 | X : C.Ob
121 | X = lim.apex
122 | l : C.Hom A X
123 | l = lim.universal (λ { (inl _) → C.id; (inr _) → f }) λ where
124 | {inl _} {inl _} _ → C.idl _
125 | {inl _} {inr _} _ → C.idr _
126 | {inr _} {inr _} _ → C.idl _
127 | r : C.Hom X B
128 | r = lim.cone ._=>_.η (inr tt)
129 |
130 | -- We check that the endpoints of the bridge are what we expect: when P
131 | -- is empty, we are taking the limit of the single-object diagram B, so
132 | -- our factorisation is A → B → B.
133 | b0 : b 𝟘 ≡ id∘ f
134 | b0 = ap (b.fac 𝟘) (Limit-is-prop C-category (C-complete _) (to-limit lim)) where
135 | lim : is-limit (b.diagram 𝟘) B _
136 | lim = to-is-limit λ where
137 | .ψ (inr _) → C.id
138 | .commutes {inr _} {inr _} _ → C.idl _
139 | .universal eps comm → eps (inr _)
140 | .factors {inr _} eps comm → C.idl _
141 | .unique eps comm other fac → sym (C.idl _) ∙ fac (inr _)
142 |
143 | -- When P is contractible, we are taking the limit of the arrow diagram
144 | -- A → B, so our factorisation is A → A → B.
145 | b1 : b 𝟙 ≡ f ∘id
146 | b1 = ap (b.fac 𝟙) (Limit-is-prop C-category (C-complete _) (to-limit lim)) where
147 | lim : is-limit (b.diagram 𝟙) A _
148 | lim = to-is-limit λ where
149 | .ψ (inl _) → C.id
150 | .ψ (inr _) → f
151 | .commutes {inl _} {inl _} _ → C.idl _
152 | .commutes {inl _} {inr _} _ → C.idr _
153 | .commutes {inr _} {inr _} _ → C.idl _
154 | .universal eps comm → eps (inl (lift tt))
155 | .factors {inl _} eps comm → C.idl _
156 | .factors {inr _} eps comm → comm {inl _} {inr _} _
157 | .unique eps comm other fac → sym (C.idl _) ∙ fac (inl _)
158 |
159 | -- Theorem 1: let C be a U-complete univalent category and D a locally
160 | -- U-small category.
161 | module _
162 | {o o' ℓ} {C : Precategory o ℓ} {D : Precategory o' u}
163 | (let module C = Cat.Reasoning C) (let module D = Cat.Reasoning D)
164 | (C-complete : is-complete u lzero C)
165 | (C-category : is-category C)
166 | where
167 |
168 | -- 1.a: naturality of transformations between functors C → D is free.
169 | -- (This is a special case of 1.b.)
170 | module _
171 | (F G : Functor C D)
172 | (let module F = Cat.Functor.Reasoning F) (let module G = Cat.Functor.Reasoning G)
173 | (η : ∀ x → D.Hom (F.₀ x) (G.₀ x))
174 | where
175 |
176 | natural : is-natural-transformation F G η
177 | natural A B f = G.introl refl ∙ z0≡z1 ∙ (D.refl⟩∘⟨ F.elimr refl) where
178 |
179 | -- Given a factorisation A → X → B, we define the map
180 | -- F A
181 | -- ↓
182 | -- η X : F X → G X
183 | -- ↓
184 | -- G B
185 | -- which recovers the naturality square for f as the factorisation varies
186 | -- from id ∘ f to f ∘ id.
187 | z : Factorisation C A B → D.Hom (F.₀ A) (G.₀ B)
188 | z (factor X l r) = G.₁ r D.∘ η X D.∘ F.₁ l
189 |
190 | -- As a result, we get a bridge from one side of the naturality square
191 | -- to the other; since D is locally U-small, the Hom-sets of D are bridge-discrete,
192 | -- so we get the desired equality.
193 | z0≡z1 : z (id∘ f) ≡ z (f ∘id)
194 | z0≡z1 = parametricity (ap-bridge z (factorisation-bridge C-complete C-category f))
195 |
196 | -- 1.b: dinaturality of transformations between bifunctors C^op × C → D is free.
197 | module _
198 | (F G : Functor (C ^op ×ᶜ C) D)
199 | (let module F = Cat.Functor.Bifunctor F) (let module G = Cat.Functor.Bifunctor G)
200 | (η : ∀ x → D.Hom (F.₀ (x , x)) (G.₀ (x , x)))
201 | where
202 |
203 | dinatural
204 | : ∀ A B (f : C.Hom A B)
205 | → G.first f D.∘ η B D.∘ F.second f ≡ G.second f D.∘ η A D.∘ F.first f
206 | dinatural A B f = z0≡z1 where
207 |
208 | -- Given a factorisation A → X → B, we define the map
209 | -- F B A → F X X → G X X → G A B
210 | -- which interpolates between the two sides of the dinaturality hexagon.
211 | z : Factorisation C A B → D.Hom (F.₀ (B , A)) (G.₀ (A , B))
212 | z (factor X l r) = G.₁ (l , r) D.∘ η X D.∘ F.₁ (r , l)
213 |
214 | z0≡z1 : z (id∘ f) ≡ z (f ∘id)
215 | z0≡z1 = parametricity (ap-bridge z (factorisation-bridge C-complete C-category f))
216 | ```
217 |
--------------------------------------------------------------------------------
/src-1lab/ErasureOpen.lagda.md:
--------------------------------------------------------------------------------
1 | ```agda
2 | open import 1Lab.Prelude hiding (map)
3 | open import 1Lab.Reflection.Induction
4 | ```
5 |
6 | Investigating the fact that Agda's erasure modality is an open modality.
7 | Terminology is borrowed and some proofs are extracted from the paper
8 | [Modalities in homotopy type theory](https://arxiv.org/abs/1706.07526)
9 | by Rijke, Shulman and Spitters.
10 | The erasure modality was previously investigated in
11 | [Logical properties of a modality for erasure](https://www.cse.chalmers.se/~nad/publications/danielsson-erased.pdf)
12 | by Danielsson.
13 |
14 | ```agda
15 | module ErasureOpen where
16 |
17 | private variable
18 | ℓ ℓ' : Level
19 | A B : Type ℓ
20 | ```
21 |
22 | ## Erasure as an open modality
23 |
24 | The `Erased` monadic modality, internalising `@0`:
25 |
26 | ```agda
27 | record Erased (@0 A : Type ℓ) : Type ℓ where
28 | constructor [_]
29 | field
30 | @0 erased : A
31 |
32 | open Erased
33 |
34 | η : {@0 A : Type ℓ} → A → Erased A
35 | η x = [ x ]
36 |
37 | μ : {@0 A : Type ℓ} → Erased (Erased A) → Erased A
38 | μ [ [ x ] ] = [ x ]
39 | ```
40 |
41 | ...is equivalent to the **open** modality `○` induced by the following subsingleton:
42 |
43 | ```agda
44 | data Compiling : Type where
45 | @0 compiling : Compiling
46 |
47 | Compiling-is-prop : is-prop Compiling
48 | Compiling-is-prop compiling compiling = refl
49 |
50 | ○_ : Type ℓ → Type ℓ
51 | ○ A = Compiling → A
52 |
53 | ○'_ : ○ Type ℓ → Type ℓ
54 | ○' A = (c : Compiling) → A c
55 |
56 | infix 30 ○_ ○'_
57 |
58 | ○→Erased : ○ A → Erased A
59 | ○→Erased a .erased = a compiling
60 |
61 | -- Agda considers clauses that match on erased constructors as erased.
62 | Erased→○ : Erased A → ○ A
63 | Erased→○ a compiling = a .erased
64 |
65 | ○≃Erased : ○ A ≃ Erased A
66 | ○≃Erased = Iso→Equiv (○→Erased ,
67 | iso Erased→○ (λ _ → refl) (λ _ → funext λ where compiling → refl))
68 |
69 | η○ : A → ○ A
70 | η○ a _ = a
71 | ```
72 |
73 | Since Agda allows erased matches for the empty type, the empty type is
74 | modal; in other words, we are not not `Compiling`.
75 |
76 | ```agda
77 | ¬¬compiling : ¬ ¬ Compiling
78 | ¬¬compiling ¬c with ○→Erased ¬c
79 | ... | ()
80 | ```
81 |
82 | ## Open and closed modalities
83 |
84 | The corresponding **closed** modality `●` is given by the join with `Compiling`,
85 | which is equivalent to the following higher inductive type.
86 |
87 | ```agda
88 | data ●_ (A : Type ℓ) : Type ℓ where
89 | -- At runtime, we only have A.
90 | η● : A → ● A
91 | -- At compile time, we also have an erased "cone" that glues all of A together,
92 | -- so that ● A is contractible.
93 | @0 tip : ● A
94 | @0 cone : (a : A) → η● a ≡ tip
95 |
96 | infix 30 ●_
97 |
98 | unquoteDecl ●-elim = make-elim ●-elim (quote ●_)
99 |
100 | @0 ●-contr : is-contr (● A)
101 | ●-contr {A = A} = contr tip λ a → sym (ps a) where
102 | ps : (a : ● A) → a ≡ tip
103 | ps = ●-elim cone refl λ a i j → cone a (i ∨ j)
104 | ```
105 |
106 | The rest of this file investigates some properties of open and closed
107 | modalities that are not specific to the `Compiling` proposition we use here.
108 |
109 |
110 | Some common definitions about higher modalities
111 |
112 | ```agda
113 | module Modality
114 | {○_ : ∀ {ℓ} → Type ℓ → Type ℓ}
115 | (η○ : ∀ {ℓ} {A : Type ℓ} → A → ○ A)
116 | (○-elim : ∀ {ℓ ℓ'} {A : Type ℓ} {P : ○ A → Type ℓ'}
117 | → ((a : A) → ○ P (η○ a)) → (a : ○ A) → ○ P a)
118 | (○-elim-β : ∀ {ℓ ℓ'} {A : Type ℓ} {P : ○ A → Type ℓ'} {pη : (a : A) → ○ P (η○ a)}
119 | → (a : A) → ○-elim {P = P} pη (η○ a) ≡ pη a)
120 | (○-≡-modal : ∀ {ℓ} {A : Type ℓ} {x y : ○ A} → is-equiv (η○ {A = x ≡ y}))
121 | where
122 |
123 | modal : Type ℓ → Type ℓ
124 | modal A = is-equiv (η○ {A = A})
125 |
126 | modal-map : (A → B) → Type _
127 | modal-map {B = B} f = (b : B) → modal (fibre f b)
128 |
129 | connected : Type ℓ → Type ℓ
130 | connected A = is-contr (○ A)
131 |
132 | connected-map : (A → B) → Type _
133 | connected-map {B = B} f = (b : B) → connected (fibre f b)
134 |
135 | modal+connected→contr : modal A → connected A → is-contr A
136 | modal+connected→contr A-mod A-conn = Equiv→is-hlevel 0 (η○ , A-mod) A-conn
137 |
138 | modal+connected→equiv : {f : A → B} → modal-map f → connected-map f → is-equiv f
139 | modal+connected→equiv f-mod f-conn .is-eqv b = modal+connected→contr (f-mod b) (f-conn b)
140 |
141 | elim-modal
142 | : ∀ {ℓ ℓ'} {A : Type ℓ} {P : ○ A → Type ℓ'}
143 | → (∀ a → modal (P a))
144 | → ((a : A) → P (η○ a)) → (a : ○ A) → P a
145 | elim-modal P-modal pη a = equiv→inverse (P-modal a) (○-elim (λ a → η○ (pη a)) a)
146 |
147 | elim-modal-β
148 | : ∀ {ℓ ℓ'} {A : Type ℓ} {P : ○ A → Type ℓ'} P-modal {pη : (a : A) → P (η○ a)}
149 | → (a : A) → elim-modal {P = P} P-modal pη (η○ a) ≡ pη a
150 | elim-modal-β P-modal {pη} a =
151 | ap (equiv→inverse (P-modal (η○ a))) (○-elim-β a)
152 | ∙ equiv→unit (P-modal (η○ a)) (pη a)
153 |
154 | map : (A → B) → ○ A → ○ B
155 | map f = ○-elim (η○ ∘ f)
156 |
157 | map-≃ : A ≃ B → (○ A) ≃ (○ B)
158 | map-≃ e = map (e .fst) , is-iso→is-equiv λ where
159 | .is-iso.from → map (Equiv.from e)
160 | .is-iso.rinv → elim-modal (λ _ → ○-≡-modal) λ b →
161 | ap (map (e .fst)) (○-elim-β b) ∙ ○-elim-β (Equiv.from e b) ∙ ap η○ (Equiv.ε e b)
162 | .is-iso.linv → elim-modal (λ _ → ○-≡-modal) λ a →
163 | ap (map (Equiv.from e)) (○-elim-β a) ∙ ○-elim-β (e .fst a) ∙ ap η○ (Equiv.η e a)
164 |
165 | retract-○→modal : (η⁻¹ : ○ A → A) → is-left-inverse η⁻¹ η○ → modal A
166 | retract-○→modal η⁻¹ ret = is-iso→is-equiv $
167 | iso η⁻¹ (elim-modal (λ _ → ○-≡-modal) λ a → ap η○ (ret a)) ret
168 |
169 | retract→modal
170 | : (f : A → B) (g : B → A)
171 | → is-left-inverse f g → modal A → modal B
172 | retract→modal {B = B} f g ret A-modal = retract-○→modal η⁻¹ linv where
173 | η⁻¹ : ○ B → B
174 | η⁻¹ = f ∘ elim-modal (λ _ → A-modal) g
175 | linv : is-left-inverse η⁻¹ η○
176 | linv b = ap f (elim-modal-β (λ _ → A-modal) b) ∙ ret b
177 |
178 | modal-≃ : B ≃ A → modal A → modal B
179 | modal-≃ e = retract→modal (Equiv.from e) (Equiv.to e) (Equiv.η e)
180 |
181 | connected-≃ : B ≃ A → connected A → connected B
182 | connected-≃ e A-conn = Equiv→is-hlevel 0 (map-≃ e) A-conn
183 |
184 | ≡-modal : modal A → ∀ {x y : A} → modal (x ≡ y)
185 | ≡-modal A-modal = modal-≃ (ap-equiv (η○ , A-modal)) ○-≡-modal
186 |
187 | PathP-modal : {A : I → Type ℓ} → modal (A i0) → ∀ {x y} → modal (PathP A x y)
188 | PathP-modal {A = A} A-modal {x} {y} = subst modal (sym (PathP≡Path⁻ A x y)) (≡-modal A-modal)
189 |
190 | reflection-modal : modal (○ A)
191 | reflection-modal = is-iso→is-equiv λ where
192 | .is-iso.from → ○-elim id
193 | .is-iso.rinv → elim-modal (λ _ → ○-≡-modal) λ a → ap η○ (○-elim-β a)
194 | .is-iso.linv → ○-elim-β
195 |
196 | Π-modal : {B : A → Type ℓ} → (∀ a → modal (B a)) → modal ((a : A) → B a)
197 | Π-modal B-modal = retract-○→modal
198 | (λ f a → elim-modal (λ _ → B-modal _) (_$ a) f)
199 | (λ f → funext λ a → elim-modal-β (λ _ → B-modal _) f)
200 |
201 | Σ-modal : {B : A → Type ℓ} → modal A → (∀ a → modal (B a)) → modal (Σ A B)
202 | Σ-modal {B = B} A-modal B-modal = retract-○→modal
203 | (Equiv.from Σ-Π-distrib
204 | ( elim-modal (λ _ → A-modal) fst
205 | , elim-modal (λ _ → B-modal _) λ (a , b) →
206 | subst B (sym (elim-modal-β (λ _ → A-modal) (a , b))) b))
207 | λ (a , b) →
208 | elim-modal-β (λ _ → A-modal) (a , b)
209 | ,ₚ elim-modal-β (λ _ → B-modal _) (a , b) ◁ to-pathp⁻ refl
210 |
211 | η-connected : connected-map (η○ {A = A})
212 | η-connected a = contr
213 | (○-elim {P = fibre η○} (λ a → η○ (a , refl)) a)
214 | (elim-modal (λ _ → ○-≡-modal) λ (a' , p) →
215 | J (λ a p → ○-elim (λ x → η○ (x , refl)) a ≡ η○ (a' , p)) (○-elim-β a') p)
216 |
217 | ○Σ○≃○Σ : {B : A → Type ℓ} → (○ (Σ A λ a → ○ B a)) ≃ (○ (Σ A B))
218 | ○Σ○≃○Σ .fst = ○-elim λ (a , b) → map (a ,_) b
219 | ○Σ○≃○Σ .snd = is-iso→is-equiv λ where
220 | .is-iso.from → map (Σ-map₂ η○)
221 | .is-iso.rinv → elim-modal (λ _ → ○-≡-modal) λ (a , b) →
222 | ap (○-elim _) (○-elim-β (a , b)) ∙ ○-elim-β (a , η○ b) ∙ ○-elim-β b
223 | .is-iso.linv → elim-modal (λ _ → ○-≡-modal) λ (a , b) →
224 | ap (map _) (○-elim-β (a , b)) ∙ elim-modal
225 | {P = λ b → ○-elim _ (○-elim _ b) ≡ η○ (a , b)} (λ _ → ○-≡-modal)
226 | (λ b → ap (○-elim _) (○-elim-β b) ∙ ○-elim-β (a , b)) b
227 |
228 | Σ-connected : {B : A → Type ℓ} → connected A → (∀ a → connected (B a)) → connected (Σ A B)
229 | Σ-connected A-conn B-conn = Equiv→is-hlevel 0 (○Σ○≃○Σ e⁻¹)
230 | (connected-≃ (Σ-contract B-conn) A-conn)
231 |
232 | -- Additional properties of *lex* modalities
233 |
234 | module _ (○-lex : ∀ {ℓ} {A : Type ℓ} {a b : A} → (○ (a ≡ b)) ≃ (η○ a ≡ η○ b)) where
235 | ≡-connected : connected A → {x y : A} → connected (x ≡ y)
236 | ≡-connected A-conn = Equiv→is-hlevel 0 ○-lex (Path-is-hlevel 0 A-conn)
237 |
238 | PathP-connected : {A : I → Type ℓ} → connected (A i0) → ∀ {x y} → connected (PathP A x y)
239 | PathP-connected {A = A} A-conn {x} {y} =
240 | subst connected (sym (PathP≡Path⁻ A x y)) (≡-connected A-conn)
241 | ```
242 |
243 |
244 | `○` and `●` are higher modalities, so we can instantiate this module
245 | for both of them.
246 |
247 | ```agda
248 | ○-elim-○
249 | : ∀ {ℓ ℓ'} {A : Type ℓ} {P : ○ A → Type ℓ'}
250 | → ((a : A) → ○ P (η○ a)) → (a : ○ A) → ○ P a
251 | ○-elim-○ {P = P} pη a c =
252 | subst P (funext λ _ → ap a (Compiling-is-prop _ _)) (pη (a c) c)
253 |
254 | ○-≡-modal : {x y : ○ A} → is-equiv (η○ {A = x ≡ y})
255 | ○-≡-modal = is-iso→is-equiv λ where
256 | .is-iso.from p i compiling → p compiling i compiling
257 | .is-iso.rinv p i compiling j compiling → p compiling j compiling
258 | .is-iso.linv p i j compiling → p j compiling
259 |
260 | ●-elim-●
261 | : ∀ {ℓ ℓ'} {A : Type ℓ} {P : ● A → Type ℓ'}
262 | → ((a : A) → ● P (η● a)) → (a : ● A) → ● P a
263 | ●-elim-● pη = ●-elim pη tip λ _ → is-contr→pathp (λ _ → ●-contr) _ _
264 |
265 | ●-≡-modal : {x y : ● A} → is-equiv (η● {A = x ≡ y})
266 | ●-≡-modal = is-iso→is-equiv λ where
267 | .is-iso.from → ●-elim id (is-contr→is-prop ●-contr _ _)
268 | λ p → is-contr→is-set ●-contr _ _ _ _
269 | .is-iso.rinv → ●-elim (λ _ → refl) (sym (●-contr .paths _))
270 | λ p → is-set→squarep (λ _ _ → is-contr→is-set ●-contr) _ _ _ _
271 | .is-iso.linv _ → refl
272 |
273 | module ○ = Modality η○ ○-elim-○ (λ _ → funext λ _ → transport-refl _) ○-≡-modal
274 | module ● = Modality η● ●-elim-● (λ _ → refl) ●-≡-modal
275 | ```
276 |
277 | Open and closed modalities are lex.
278 |
279 | ```agda
280 | ○-lex : {a b : A} → ○ (a ≡ b) ≃ (η○ a ≡ η○ b)
281 | ○-lex = funext≃
282 |
283 | module ●-ids {A : Type ℓ} {a : A} where
284 | code : ● A → Type ℓ
285 | code = ●-elim (λ b → ● (a ≡ b)) (Lift _ ⊤) (λ b → ua (is-contr→≃ ●-contr (hlevel 0)))
286 |
287 | code-refl : code (η● a)
288 | code-refl = η● refl
289 |
290 | decode : ∀ b → code b → η● a ≡ b
291 | decode = ●.elim-modal (λ _ → ●.Π-modal λ _ → ●-≡-modal)
292 | λ a → ●.elim-modal (λ _ → ●-≡-modal) (ap η●)
293 |
294 | decode-over : ∀ b (c : code b) → PathP (λ i → code (decode b c i)) code-refl c
295 | decode-over = ●.elim-modal (λ _ → ●.Π-modal λ _ → ●.PathP-modal ●.reflection-modal)
296 | λ a → ●.elim-modal (λ _ → ●.PathP-modal ●.reflection-modal)
297 | λ p i → η● λ j → p (i ∧ j)
298 |
299 | ids : is-based-identity-system (η● a) code code-refl
300 | ids .to-path {b} = decode b
301 | ids .to-path-over {b} = decode-over b
302 |
303 | ●-lex : {a b : A} → ● (a ≡ b) ≃ (η● a ≡ η● b)
304 | ●-lex = based-identity-system-gives-path ●-ids.ids
305 | ```
306 |
307 | Some equivalences specific to open and closed modalities:
308 |
309 |
310 | `●-modal A ≃ ○ (is-contr A) ≃ is-contr (○ A) = ○-connected A`
311 |
312 |
313 | ```agda
314 | @0 ●-modal→contr : ●.modal A → is-contr A
315 | ●-modal→contr A-modal = Equiv→is-hlevel 0 (η● , A-modal) ●-contr
316 |
317 | contr→●-modal : @0 is-contr A → ●.modal A
318 | contr→●-modal A-contr = ●.retract-○→modal
319 | (●-elim id (A-contr .centre) λ a → sym (A-contr .paths a))
320 | λ _ → refl
321 |
322 | contr→○-connected : @0 is-contr A → ○.connected A
323 | contr→○-connected A-contr = contr (Erased→○ [ A-contr .centre ]) λ a →
324 | funext λ where compiling → A-contr .paths _
325 |
326 | @0 ○-connected→contr : ○.connected A → is-contr A
327 | ○-connected→contr A-conn = contr (A-conn .centre compiling) λ a →
328 | A-conn .paths (η○ a) $ₚ compiling
329 |
330 | ○-connected→●-modal : ○.connected A → ●.modal A
331 | ○-connected→●-modal A-conn = contr→●-modal (○-connected→contr A-conn)
332 | ```
333 |
334 | ## Artin gluing
335 |
336 | We prove an **Artin gluing** theorem: every type `A` is equivalent to a
337 | certain pullback of `○ A` and `● A` over `● ○ A`, which we call `Fracture A`.
338 | Handwaving, this corresponds to decomposing a type into its "compile time"
339 | part and its "runtime" part.
340 |
341 | ```agda
342 | ○→●○ : ○ A → ● ○ A
343 | ○→●○ = η●
344 |
345 | ●→●○ : ● A → ● ○ A
346 | ●→●○ = ●.map η○
347 |
348 | Fracture : Type ℓ → Type ℓ
349 | Fracture A = Σ (○ A × ● A) λ (o , c) → ○→●○ o ≡ ●→●○ c
350 |
351 | module _ {A : Type ℓ} where
352 | fracture : A → Fracture A
353 | fracture a = (η○ a , η● a) , refl
354 | ```
355 |
356 | The idea is to prove that the fibres of the `fracture` map are both
357 | `●`-modal and `●`-connected, and hence contractible.
358 |
359 | For the modal part, we observe that an element of the fibre of `fracture`
360 | at a triple `(o : ○ A, c : ● A, p)` can be rearranged into an element
361 | of the fibre of `η○` at `o` (which is `○`-connected, hence `●`-modal) together with
362 | a dependent path whose type is `●`-modal by standard results about higher modalities.
363 |
364 | ```agda
365 | fracture-modal : ●.modal-map fracture
366 | fracture-modal ((o , c) , p) = ●.modal-≃ e $
367 | ●.Σ-modal (○-connected→●-modal (○.η-connected _)) λ _ →
368 | ●.PathP-modal $ ●.Σ-modal ●.reflection-modal λ _ → ●-≡-modal
369 | where
370 | e : fibre fracture ((o , c) , p)
371 | ≃ Σ (fibre η○ o) λ (a , q) →
372 | PathP (λ i → Σ (● A) λ c → ○→●○ (q i) ≡ ●→●○ c) (η● a , refl) (c , p)
373 | e = Σ-ap-snd (λ _ → ap-equiv (Σ-assoc e⁻¹) ∙e Σ-pathp≃ e⁻¹) ∙e Σ-assoc
374 | ```
375 |
376 | Almost symmetrically, for the connected part, we rearrange the fibre
377 | into an element of the fibre of `η●` at `c` (which is `●`-connected) together
378 | with a dependent path in the fibres of `○→●○`. Since the latter is
379 | defined as `η●` its fibres are `●`-connected as well, hence the path type
380 | is `●`-connected because `●` is lex.
381 |
382 | ```agda
383 | fracture-connected : ●.connected-map fracture
384 | fracture-connected ((o , c) , p) = ●.connected-≃ e $
385 | ●.Σ-connected (●.η-connected _) λ _ →
386 | ●.PathP-connected ●-lex (●.η-connected _)
387 | where
388 | e : fibre fracture ((o , c) , p)
389 | ≃ Σ (fibre η● c) λ (a , q) →
390 | PathP (λ i → Σ (○ A) λ o → ○→●○ o ≡ ●→●○ (q i)) (η○ a , refl) (o , p)
391 | e = Σ-ap-snd (λ _ → ap-equiv (Σ-ap-fst ×-swap ∙e Σ-assoc e⁻¹) ∙e Σ-pathp≃ e⁻¹) ∙e Σ-assoc
392 |
393 | fracture-is-equiv : is-equiv fracture
394 | fracture-is-equiv = ●.modal+connected→equiv fracture-modal fracture-connected
395 |
396 | Artin-gluing : A ≃ Fracture A
397 | Artin-gluing = fracture , fracture-is-equiv
398 | ```
399 |
--------------------------------------------------------------------------------
/src-1lab/FirstGroupCohomology.agda:
--------------------------------------------------------------------------------
1 | open import 1Lab.Path.Reasoning
2 | open import 1Lab.Prelude
3 |
4 | open import Algebra.Group.Cat.Base
5 | open import Algebra.Group.Concrete
6 | open import Algebra.Group.Ab
7 |
8 | open import Cat.Prelude
9 |
10 | open import Homotopy.Space.Delooping
11 |
12 | -- This now lives at https://1lab.dev/Algebra.Group.Concrete.Abelian.html#first-abelian-group-cohomology
13 | module FirstGroupCohomology where
14 |
15 | open Precategory
16 |
17 | π₁BG≡G : ∀ {ℓ} (G : Group ℓ) → π₁B (Concrete G) ≡ G
18 | π₁BG≡G G = π₁B≡π₀₊₁ (Concrete G) ∙ sym (G≡π₁B G)
19 |
20 | -- Any two loops commute in the delooping of an abelian group.
21 | ab→square : ∀ {ℓ} {H : Group ℓ} (H-ab : is-commutative-group H)
22 | → {x : Deloop H} (p q : x ≡ x) → Square p q q p
23 | ab→square {H = H} H-ab {x} = Deloop-elim-prop H (λ x → (p q : x ≡ x) → Square p q q p) (λ _ → hlevel 1)
24 | (λ p q → commutes→square (subst is-commutative-group (sym (π₁BG≡G H)) H-ab p q)) x
25 |
26 | module _ {ℓ} (G : Group ℓ) (H : Group ℓ) (H-ab : is-commutative-group H) where
27 | -- The first cohomology of G with coefficients in H.
28 | -- We will show that it is equivalent to the set of group homomorphisms from G
29 | -- to H, assuming that H is abelian.
30 | H¹[G,H] = ∥ (Deloop G → Deloop H) ∥₀
31 |
32 | unpoint : (Deloop∙ G →∙ Deloop∙ H) → H¹[G,H]
33 | unpoint (f , _) = inc f
34 |
35 | work : ∀ f → f base ≡ base → is-contr (fibre unpoint (inc f))
36 | work f ptf .centre = (f , ptf) , refl
37 | work f ptf .paths ((g , ptg) , g≡f) = Σ-prop-path! (Σ-pathp
38 | (funext (Deloop-elim-set G _ (λ _ → hlevel 2) (ptf ∙ sym ptg) λ z → rec!
39 | (λ g≡f → J
40 | (λ g _ → ∀ ptg → Square (ap f (path z)) (ptf ∙ sym ptg) (ptf ∙ sym ptg) (ap g (path z)))
41 | (λ _ → ab→square H-ab _ _)
42 | (sym g≡f) ptg)
43 | (∥-∥₀-path.to g≡f)))
44 | (flip₂ (∙-filler'' ptf (sym ptg))))
45 |
46 | unpoint-is-equiv : is-equiv unpoint
47 | unpoint-is-equiv .is-eqv = ∥-∥₀-elim (λ _ → hlevel 2)
48 | λ f → rec! (work f) (Deloop-is-connected (f base))
49 |
50 | unpoint≃ : H¹[G,H] ≃ (Deloop∙ G →∙ Deloop∙ H)
51 | unpoint≃ = (unpoint , unpoint-is-equiv) e⁻¹
52 |
53 | delooping : (Deloop∙ G →∙ Deloop∙ H) ≃ Hom (Groups ℓ) (π₁B (Concrete G)) (π₁B (Concrete H))
54 | delooping = _ , π₁F-is-ff {_} {Concrete G} {Concrete H}
55 |
56 | first-group-cohomology : H¹[G,H] ≃ Hom (Groups ℓ) G H
57 | first-group-cohomology = unpoint≃ ∙e delooping
58 | ∙e path→equiv (ap₂ (Hom (Groups ℓ)) (π₁BG≡G G) (π₁BG≡G H))
59 |
60 | -- As a cool application, the space of endomorphisms of the delooping of ℤ/2ℤ has
61 | -- exactly two connected components!
62 | -- (But note that there is no type with exactly two endomorphisms: it would be a set,
63 | -- and nⁿ = 2 has no integer solutions.)
64 |
--------------------------------------------------------------------------------
/src-1lab/Goat.agda:
--------------------------------------------------------------------------------
1 | open import 1Lab.Prelude
2 | open import Data.Dec
3 | open import Data.Nat
4 |
5 | {-
6 | A formalisation of https://en.wikipedia.org/wiki/Wolf,_goat_and_cabbage_problem
7 | to demonstrate proof by reflection.
8 | -}
9 | module Goat where
10 |
11 | holds : ∀ {ℓ} (A : Type ℓ) ⦃ _ : Dec A ⦄ → Type
12 | holds _ ⦃ yes _ ⦄ = ⊤
13 | holds _ ⦃ no _ ⦄ = ⊥
14 |
15 | data Side : Type where
16 | left right : Side
17 |
18 | left≠right : ¬ left ≡ right
19 | left≠right p = subst (λ { left → ⊤; right → ⊥ }) p tt
20 |
21 | instance
22 | Discrete-Side : Discrete Side
23 | Discrete-Side {left} {left} = yes refl
24 | Discrete-Side {left} {right} = no left≠right
25 | Discrete-Side {right} {left} = no (left≠right ∘ sym)
26 | Discrete-Side {right} {right} = yes refl
27 |
28 | cross : Side → Side
29 | cross left = right
30 | cross right = left
31 |
32 | record State : Type where
33 | constructor state
34 | field
35 | farmer wolf goat cabbage : Side
36 |
37 | open State
38 |
39 | count-left : Side → Nat
40 | count-left left = 1
41 | count-left right = 0
42 | count-lefts : State → Nat
43 | count-lefts (state f w g c) = count-left f + count-left w + count-left g + count-left c
44 |
45 | is-valid : State → Type
46 | is-valid s@(state f w g c) = count-lefts s ≡ 2 → f ≡ g
47 |
48 | record Valid-state : Type where
49 | constructor valid
50 | field
51 | has-state : State
52 | ⦃ has-valid ⦄ : holds (is-valid has-state)
53 |
54 | open Valid-state
55 |
56 | data Move : State → State → Type where
57 | go-alone : ∀ {s} → Move s (record s { farmer = cross (s .farmer) })
58 | take-wolf : ∀ {s} → Move s (record s { farmer = cross (s .farmer); wolf = cross (s .wolf) })
59 | take-goat : ∀ {s} → Move s (record s { farmer = cross (s .farmer); goat = cross (s .goat) })
60 | take-cabbage : ∀ {s} → Move s (record s { farmer = cross (s .farmer); cabbage = cross (s .cabbage) })
61 |
62 | data Moves : Valid-state → Valid-state → Type where
63 | done : ∀ {s} → Moves s s
64 | _∷_ : ∀ {a b c} ⦃ _ : holds (is-valid b) ⦄ → Move (a .has-state) b → Moves (valid b) c → Moves a c
65 |
66 | infixr 6 _∷_
67 |
68 | initial final : Valid-state
69 | initial = valid (state left left left left)
70 | final = valid (state right right right right)
71 |
72 | goal : Moves initial final
73 | goal = take-goat ∷ go-alone ∷ take-wolf ∷ take-goat ∷ take-cabbage ∷ go-alone ∷ take-goat ∷ done
74 | -- goal = {! take-wolf ∷ ? !} -- No instance of type holds (is-valid ...) was found in scope.
75 |
--------------------------------------------------------------------------------
/src-1lab/Hats.agda:
--------------------------------------------------------------------------------
1 | open import 1Lab.Path.Reasoning
2 | open import 1Lab.Prelude
3 |
4 | open import Algebra.Monoid.Category
5 | open import Algebra.Group
6 |
7 | open import Data.List hiding (lookup)
8 | open import Data.Fin
9 | open import Data.Fin.Closure
10 |
11 | open is-iso
12 |
13 | {-
14 | This is a formalisation of a hat puzzle whose statement you can read at any
15 | of these places:
16 |
17 | https://www.jsoftware.com/pipermail/general/2007-June/030272.html
18 | https://www.cut-the-knot.org/blue/PuzzleWithHats.shtml
19 | https://twitter.com/gro_tsen/status/1618989823100096512
20 |
21 | 🎩 SPOILERS AHEAD! 🎩
22 | -}
23 | module Hats where
24 |
25 | -- We assume there's at least one person, and that everyone has a unique
26 | -- "name" between 0 and n - 1, known to everyone else.
27 | module _ (n-1 : Nat) where
28 | private
29 | n = suc n-1
30 | Person = Fin n
31 | Hat = Fin n
32 | Hats = Person → Hat
33 |
34 | record Strategy : Type where
35 | -- `guess i xs` is the guess made by the ith person upon seeing the n - 1
36 | -- other hats given by `xs` (a vector of numbers from 0 to n - 1).
37 | field
38 | guess : Person → (Fin n-1 → Hat) → Hat
39 |
40 | -- The relation `hats ✓ i` means that the ith person guesses correctly,
41 | -- given the assignment `hats`.
42 | _✓_ : Hats → Person → Type
43 | hats ✓ i = guess i (delete hats i) ≡ hats i
44 |
45 | -- We are interested in strategies where at least one person guesses
46 | -- correctly for every assignment of hats.
47 | field
48 | one-right : ∀ hats → Σ Person λ i → hats ✓ i
49 |
50 | -- First, note that, given this requirement, there can be at *most* one
51 | -- correct guess for every assignment of hats.
52 | -- This follows from a probabilistic argument: every person guesses correctly
53 | -- with probability 1/n, so the total number of correct guesses across all
54 | -- hat assignments is nⁿ.
55 | -- In order to conclude, we use the fact that any surjection between finite
56 | -- sets of equal cardinality is an equivalence.
57 | exactly-one-right : ∀ hats → is-contr (Σ Person λ i → hats ✓ i)
58 | exactly-one-right hats = Equiv→is-hlevel 0 (Fibre-equiv _ hats e⁻¹) (p-is-equiv .is-eqv hats)
59 | where
60 | probability : ∀ i → Iso (Σ Hats (_✓ i)) (Fin n-1 → Hat)
61 | probability i .fst (hats , _) = delete hats i
62 | probability i .snd .from other .fst = other [ i ≔ guess i other ]
63 | probability i .snd .from other .snd =
64 | guess i ⌜ delete (other [ i ≔ guess i other ]) i ⌝ ≡⟨ ap! (funext (delete-insert _ i _)) ⟩
65 | guess i other ≡˘⟨ insert-lookup _ i _ ⟩
66 | (other [ i ≔ guess i other ]) i ∎
67 | probability i .snd .rinv _ = funext (delete-insert _ i _)
68 | probability i .snd .linv (hats , r) = Σ-prop-path! (funext (insert-delete _ i _ (sym r)))
69 |
70 | only-one : Σ Hats (λ hats → Σ Person (hats ✓_)) ≃ Hats
71 | only-one =
72 | Σ _ (λ hats → Σ _ λ i → hats ✓ i) ≃⟨ Σ-swap₂ ⟩
73 | Σ _ (λ i → Σ _ λ hats → hats ✓ i) ≃⟨ Σ-ap-snd (Iso→Equiv ∘ probability) ⟩
74 | Fin n × (Fin n-1 → Fin n) ≃˘⟨ Fin-suc-Π ⟩
75 | (Fin n → Fin n) ≃∎
76 |
77 | p : Σ Hats (λ hats → Σ Person (hats ✓_)) → Hats
78 | p = fst
79 | p-is-equiv : is-equiv p
80 | p-is-equiv = Finite-surjection→equiv (inc only-one) p
81 | λ other → inc ((other , one-right other) , refl)
82 |
83 | open Strategy public
84 |
85 | -- n-hypercubes of order m. We won't use the extra degree of generality,
86 | -- but it doesn't hurt.
87 | Hypercube : Nat → Type
88 | Hypercube m = (Fin n → Fin m) → Fin m
89 |
90 | -- Latin hypercubes, or n-ary quasigroups.
91 | -- Every number appears exactly once on each "line"; equivalently,
92 | -- every partial application to n - 1 coordinates is an automorphism.
93 | is-latin : ∀ {m} → Hypercube m → Type
94 | is-latin {m} h = ∀ (i : Fin n) (xs : Fin n-1 → Fin m) → is-equiv λ x → h (xs [ i ≔ x ])
95 |
96 | Latin-hypercube : Nat → Type
97 | Latin-hypercube m = Σ (Hypercube m) is-latin
98 |
99 | -- Every latin n-hypercube h of order n induces a strategy where everyone
100 | -- guesses that the multiplication of all the hats is equal to their index.
101 | latin→strategy : Latin-hypercube n → Strategy
102 | latin→strategy (h , lat) .guess i other = equiv→inverse (lat i other) i
103 | latin→strategy (h , lat) .one-right hats =
104 | h hats , Equiv.from (eqv (h hats)) refl
105 | where
106 | module L i = Equiv (_ , lat i (delete hats i))
107 | eqv : ∀ (i : Fin n) → (L.from i i ≡ hats i) ≃ (h hats ≡ i)
108 | eqv i =
109 | L.from i i ≡ hats i ≃⟨ Equiv.adjunct (L.inverse i) ⟩
110 | i ≡ L.to i (hats i) ≃⟨ sym-equiv ⟩
111 | L.to i (hats i) ≡ i ≃⟨ ∙-pre-equiv (sym (ap h (funext (insert-delete hats i _ refl)))) ⟩
112 | h hats ≡ i ≃∎
113 |
114 | -- In particular, every group structure on Fin n induces a strategy since
115 | -- group multiplication is an n-ary equivalence.
116 | group→latin : Group-on (Fin n) → Latin-hypercube n
117 | group→latin G = mul , mul-equiv
118 | where
119 | open Group-on G hiding (magma-hlevel)
120 |
121 | mul : ∀ {m} → (Fin m → Fin n) → Fin n
122 | mul xs = fold underlying-monoid (tabulate xs)
123 |
124 | mul-equiv : ∀ {m} (i : Fin (suc m)) (xs : Fin m → Fin n)
125 | → is-equiv (λ x → mul (xs [ i ≔ x ]))
126 | mul-equiv i xs with fin-view i
127 | mul-equiv _ xs | zero = ⋆-equivr _
128 | mul-equiv {suc m} _ xs | suc i = ∘-is-equiv (mul-equiv i (xs ∘ fsuc)) (⋆-equivl _)
129 |
130 | group→strategy : Group-on (Fin n) → Strategy
131 | group→strategy = latin→strategy ∘ group→latin
132 |
--------------------------------------------------------------------------------
/src-1lab/Madeleine.agda:
--------------------------------------------------------------------------------
1 | open import 1Lab.Prelude
2 | open import 1Lab.Classical
3 | open import Data.Sum
4 | open import Data.Dec
5 | open import Data.Bool
6 | open import Meta.Invariant
7 |
8 | module Madeleine where
9 |
10 | axiom = ∀ {ℓ} {P Q : Type ℓ} ⦃ _ : H-Level P 1 ⦄ ⦃ _ : H-Level Q 1 ⦄ → ∥ P ⊎ Q ∥ → P ⊎ Q
11 |
12 | lem→axiom : LEM → axiom
13 | lem→axiom lem {P = P} {Q} pq with lem (elΩ P)
14 | ... | yes a = inl (□-out! a)
15 | ... | no ¬a = inr (rec! (λ { (inl p) → absurd (¬a (inc p)); (inr q) → q }) pq)
16 |
17 | module _ (ε : axiom) where
18 |
19 | module _ {ℓ} {X : Type ℓ} ⦃ _ : H-Level X 2 ⦄ (a₀ a₁ : X) where
20 | E : X → Type _
21 | E x = (a₀ ≡ x) ⊎ (a₁ ≡ x)
22 |
23 | E' : Type _
24 | E' = Σ X λ x → ∥ E x ∥
25 |
26 | r : Bool → E'
27 | r true = a₀ , inc (inl refl)
28 | r false = a₁ , inc (inr refl)
29 |
30 | s : E' → Bool
31 | s (x , e) with ε e
32 | ... | inl _ = true
33 | ... | inr _ = false
34 |
35 | r-s : ∀ e → r (s e) ≡ e
36 | r-s (x , e) with ε e
37 | ... | inl p = Σ-prop-path! p
38 | ... | inr p = Σ-prop-path! p
39 |
40 | discrete : Dec (a₀ ≡ a₁)
41 | discrete = invmap
42 | (λ p → ap fst (right-inverse→injective r r-s p))
43 | (λ p → ap s (Σ-prop-path! p))
44 | (s (r true) ≡? s (r false))
45 |
46 | lem : LEM
47 | lem P = invmap (λ p → subst ∣_∣ (sym p) _) (λ p → Ω-ua _ (λ _ → p))
48 | (discrete P ⊤Ω)
49 |
--------------------------------------------------------------------------------
/src-1lab/MonoidalFibres.agda:
--------------------------------------------------------------------------------
1 | open import 1Lab.Prelude
2 | open import Homotopy.Connectedness
3 | open import Cat.Prelude
4 | open import Cat.Functor.Base
5 | open import Cat.Functor.Properties
6 |
7 | -- eso + full-on-isos functors have monoidal fibres.
8 | module MonoidalFibres where
9 |
10 | private variable
11 | o ℓ : Level
12 | C D : Precategory o ℓ
13 |
14 | monoidal-fibres
15 | : ∀ {F : Functor C D}
16 | → is-category C → is-category D
17 | → is-eso F → is-full-on-isos F
18 | → ∀ y → is-connected (Essential-fibre F y)
19 | monoidal-fibres {D = D} {F = F} ccat dcat eso full≅ y =
20 | case eso y of λ y′ Fy′≅y → is-connected∙→is-connected {X = _ , y′ , Fy′≅y} λ (x , Fx≅y) → do
21 | (x≅y′ , eq) ← full≅ (Fy′≅y Iso⁻¹ ∘Iso Fx≅y)
22 | pure (Σ-pathp (ccat .to-path x≅y′)
23 | (≅-pathp _ _ (transport (λ i → PathP (λ j → Hom (F-map-path F ccat dcat x≅y′ (~ i) j) y) (Fx≅y .to) (Fy′≅y .to))
24 | (Hom-pathp-refll-iso (sym (ap from (Iso-swapl (sym eq))))))))
25 | where open Univalent dcat
26 |
--------------------------------------------------------------------------------
/src-1lab/Mystery.agda:
--------------------------------------------------------------------------------
1 | open import 1Lab.Classical
2 | open import 1Lab.Prelude
3 |
4 | open import Data.Dec
5 |
6 | -- A weird constructive principle equivalent to Markov's principle + WLEM + ¬¬-shift
7 | -- https://types.pl/@ncf/112854858302377592
8 | -- https://x.com/ncfavier/status/1817846740944314834
9 | module Mystery where
10 |
11 | TNE : ∀ {ℓ} {P : Type ℓ} → ¬ ¬ ¬ P → ¬ P
12 | TNE h p = h λ k → k p
13 |
14 | case01 : ∀ {ℓ} {A : Type ℓ} → A → A → Nat → A
15 | case01 z s zero = z
16 | case01 z s (suc n) = s
17 |
18 | mystery MP DNS : Type
19 |
20 | mystery = (P : Nat → Ω) → (¬ ∀ n → ∣ P n ∣) → ∃ _ λ n → ¬ ∣ P n ∣
21 |
22 | MP = (P : Nat → Ω) → (∀ n → Dec ∣ P n ∣) → (¬ ∀ n → ∣ P n ∣) → ∃ _ λ n → ¬ ∣ P n ∣
23 |
24 | DNS = (P : Nat → Ω) → (∀ n → ¬ ¬ ∣ P n ∣) → ¬ ¬ ∀ n → ∣ P n ∣
25 |
26 | mystery→MP : mystery → MP
27 | mystery→MP m P _ = m P
28 |
29 | mystery→WLEM : mystery → WLEM
30 | mystery→WLEM m P = case m (case01 P (¬Ω P)) (λ h → h 1 (h 0)) of λ where
31 | zero p → yes p
32 | (suc _) p → no p
33 |
34 | mystery→DNS : mystery → DNS
35 | mystery→DNS m P h k = case m P k of h
36 |
37 | MP+WLEM+DNS→mystery : MP × WLEM × DNS → mystery
38 | MP+WLEM+DNS→mystery (mp , wlem , dns) P h =
39 | mp (λ n → ¬Ω ¬Ω P n) (λ n → wlem (¬Ω P n)) (λ k → dns P k h)
40 | <&> Σ-map id TNE
41 |
42 | mystery≃MP+WLEM+DNS : mystery ≃ (MP × WLEM × DNS)
43 | mystery≃MP+WLEM+DNS = prop-ext!
44 | ⟨ mystery→MP , ⟨ mystery→WLEM , mystery→DNS ⟩ ⟩
45 | MP+WLEM+DNS→mystery
46 |
--------------------------------------------------------------------------------
/src-1lab/Möbius.agda:
--------------------------------------------------------------------------------
1 | open import 1Lab.Prelude
2 |
3 | open import Data.Int renaming (Int to ℤ)
4 |
5 | open import Homotopy.Space.Circle hiding (Cover ; decode)
6 |
7 | -- https://math.stackexchange.com/questions/4940313/giving-calculating-explicit-homomorphism-between-fundamental-groups
8 | module Möbius where
9 |
10 | data Möbius : Type where
11 | up down : Möbius
12 | seam : up ≡ down
13 | top : up ≡ down
14 | bottom : down ≡ up
15 | surf : PathP (λ i → top i ≡ bottom i) seam (sym seam)
16 |
17 | Cover : Möbius → Type
18 | Cover up = ℤ
19 | Cover down = ℤ
20 | Cover (seam i) = ℤ
21 | Cover (top i) = ua suc-equiv i
22 | Cover (bottom i) = ua suc-equiv i
23 | Cover (surf i j) = ua suc-equiv i
24 |
25 | decode : ∀ {x} → up ≡ x → Cover x
26 | decode p = subst Cover p 0
27 |
28 | ι : S¹ → Möbius
29 | ι = S¹-rec up (top ∙ bottom)
30 |
31 | ι* : ℤ → ℤ
32 | ι* = decode ∘ ap ι ∘ loopⁿ
33 |
34 | _ : ι* 1 ≡ 2
35 | _ = refl
36 |
--------------------------------------------------------------------------------
/src-1lab/ObjectClassifier.agda:
--------------------------------------------------------------------------------
1 | open import 1Lab.Type
2 | open import 1Lab.Type.Sigma
3 | open import 1Lab.Type.Pointed
4 | open import 1Lab.Path
5 | open import 1Lab.HLevel
6 | open import 1Lab.HLevel.Closure
7 | open import 1Lab.Equiv
8 |
9 | -- Univalence from object classifiers in the sense of higher topos theory.
10 | module ObjectClassifier where
11 |
12 | -- The type of arrows/bundles/fibrations.
13 | Bundle : ∀ ℓ → Type (lsuc ℓ)
14 | Bundle ℓ
15 | = Σ (Type ℓ) λ A
16 | → Σ (Type ℓ) λ B
17 | → A → B
18 |
19 | -- The standard pullback construction (HoTT book 2.15.11).
20 | record Pullback {ℓ ℓ'} {B : Type ℓ} {C D : Type ℓ'} (s : B → D) (q : C → D) : Type (ℓ ⊔ ℓ') where
21 | constructor pb
22 | field
23 | pb₁ : B
24 | pb₂ : C
25 | pbeq : s pb₁ ≡ q pb₂
26 |
27 | open Pullback
28 |
29 | pb-path : ∀ {ℓ ℓ'} {B : Type ℓ} {C D : Type ℓ'} {s : B → D} {q : C → D} → {a b : Pullback s q}
30 | → (p1 : a .pb₁ ≡ b .pb₁) → (p2 : a .pb₂ ≡ b .pb₂) → PathP (λ i → s (p1 i) ≡ q (p2 i)) (a .pbeq) (b .pbeq)
31 | → a ≡ b
32 | pb-path p1 p2 pe i = pb (p1 i) (p2 i) (pe i)
33 |
34 | -- The morphisms of interest between bundles p : A → B and q : C → D are pairs
35 | -- r : A → C, s : B → D that make a *pullback square*:
36 | -- r
37 | -- A ------> C
38 | -- | ⯾ |
39 | -- p | | q
40 | -- v v
41 | -- B ------> D
42 | -- s
43 | -- Rather than laboriously state the universal property of a pullback, we take it
44 | -- on faith that the construction above has the universal property (this is
45 | -- exercise 2.11 in the HoTT book) and simply define "being a pullback" as having
46 | -- r and p factor through an equivalence A ≃ Pullback s q.
47 | -- This completely determines r by the factorisation r = pb₂ ∘ e .fst, so we can
48 | -- omit it by contractibility of singletons.
49 | _⇒_ : ∀ {ℓ} {ℓ'} → Bundle ℓ → Bundle ℓ' → Type (ℓ ⊔ ℓ')
50 | (A , B , p) ⇒ (C , D , q)
51 | = Σ (B → D) λ s
52 | → Σ (A ≃ Pullback s q) λ e
53 | → p ≡ pb₁ ∘ e .fst
54 |
55 | -- An object classifier is a *universal* bundle U∙ → U such that any other
56 | -- bundle has a unique map (i.e. pullback square) into it.
57 | -- Categorically, it is a terminal object in the category of arrows and pullback squares.
58 | is-classifier : ∀ {ℓ} → Bundle (lsuc ℓ) → Type (lsuc ℓ)
59 | is-classifier {ℓ} u = ∀ (p : Bundle ℓ) → is-contr (p ⇒ u)
60 |
61 | -- The projection from the type of pointed types to the type of types is our
62 | -- universal bundle: the fibre above A : Type ℓ is equivalent to A itself.
63 | Type↓ : ∀ ℓ → Bundle (lsuc ℓ)
64 | Type↓ ℓ = Type∙ ℓ , Type ℓ , fst
65 |
66 | Type↓-fibre : ∀ {ℓ} (A : Type ℓ) → A ≃ Pullback {B = Lift ℓ ⊤} {C = Type∙ ℓ} (λ _ → A) fst
67 | Type↓-fibre A = Iso→Equiv λ where
68 | .fst a → pb _ (A , a) refl
69 | .snd .is-iso.from (pb _ (A' , a) eq) → transport (sym eq) a
70 | .snd .is-iso.linv → transport-refl
71 | .snd .is-iso.rinv (pb _ (A' , a) eq) → pb-path refl (sym (Σ-path (sym eq) refl)) λ i j → eq (i ∧ j)
72 |
73 | postulate
74 | -- We assume that Type↓ is an object classifier in the sense above, and show that
75 | -- this makes it a univalent universe.
76 | Type↓-is-classifier : ∀ {ℓ} → is-classifier (Type↓ ℓ)
77 |
78 | -- Every type is trivially a bundle over the unit type.
79 | ! : ∀ {ℓ} → Type ℓ → Bundle ℓ
80 | ! A = A , Lift _ ⊤ , _
81 |
82 | -- The key observation is that the type of pullback squares from ! A to Type↓ is
83 | -- equivalent to the type of types equipped with an equivalence to A.
84 | -- Since the former was assumed to be contractible, so is the latter.
85 | lemma : ∀ {ℓ} (A : Type ℓ) → (! A ⇒ Type↓ ℓ) ≃ Σ (Type ℓ) (λ B → A ≃ B)
86 | lemma {ℓ} A = Iso→Equiv λ where
87 | .fst (ty , e , _) → ty _ , e ∙e Type↓-fibre (ty _) e⁻¹
88 | .snd .is-iso.from (B , e) → (λ _ → B) , e ∙e Type↓-fibre B , refl
89 | .snd .is-iso.linv (ty , e , _) → Σ-pathp refl (Σ-pathp (Σ-prop-path is-equiv-is-prop
90 | (funext λ _ → Equiv.ε (Type↓-fibre (ty _)) _)) refl)
91 | .snd .is-iso.rinv (B , e) → Σ-pathp refl (Σ-prop-path is-equiv-is-prop
92 | (funext λ _ → Equiv.η (Type↓-fibre B) _))
93 |
94 | -- Equivalences form an identity system, which is another way to state univalence.
95 | univalence : ∀ {ℓ} (A : Type ℓ) → is-contr (Σ (Type ℓ) λ B → A ≃ B)
96 | univalence {ℓ} A = Equiv→is-hlevel 0 (lemma A e⁻¹) (Type↓-is-classifier (! A))
97 |
--------------------------------------------------------------------------------
/src-1lab/PointwiseMonoidal.agda:
--------------------------------------------------------------------------------
1 | open import Cat.Prelude
2 | open import Cat.Functor.Base
3 | open import Cat.Functor.Compose
4 | open import Cat.Functor.Constant
5 | open import Cat.Functor.Equivalence.Path
6 | open import Cat.Monoidal.Base
7 | open import Cat.Monoidal.Diagram.Monoid
8 | open import Cat.Instances.Product
9 | open import Cat.Displayed.Base
10 | open import Cat.Displayed.Total
11 |
12 | open Monoidal-category
13 | open Precategory
14 | open Functor
15 | open _=>_
16 |
17 | -- ⚠️ WIP ⚠️
18 | module PointwiseMonoidal
19 | {o o′ ℓ ℓ′} (C : Precategory o ℓ) (D : Precategory o′ ℓ′)
20 | (M : Monoidal-category D)
21 | where
22 |
23 | Pointwise : Monoidal-category Cat[ C , D ]
24 | Pointwise = pw where
25 | prod : Functor (Cat[ C , D ] ×ᶜ Cat[ C , D ]) Cat[ C , D ]
26 | prod .F₀ (a , b) = M .-⊗- F∘ Cat⟨ a , b ⟩
27 | prod .F₁ {x = x} {y = y} (na , nb) = M .-⊗- ▸ nat where
28 | nat : Cat⟨ x .fst , x .snd ⟩ => Cat⟨ y .fst , y .snd ⟩
29 | nat .η x = (na .η x) , (nb .η x)
30 | nat .is-natural x y f i = (na .is-natural x y f i) , (nb .is-natural x y f i)
31 | prod .F-id = ext λ _ → M .-⊗- .F-id
32 | prod .F-∘ f g = ext λ _ → M .-⊗- .F-∘ _ _
33 | pw : Monoidal-category Cat[ C , D ]
34 | pw .-⊗- = prod
35 | pw .Unit = Const (M .Unit)
36 | pw .unitor-l = {! M .unitor-l !}
37 | pw .unitor-r = {! !}
38 | pw .associator = {! !}
39 | pw .triangle = {! !}
40 | pw .pentagon = {! !}
41 |
42 | MonCD→CMonD : Functor (∫ Mon[ Pointwise ]) (Cat[ C , ∫ Mon[ M ] ])
43 | MonCD→CMonD .F₀ (F , mon) .F₀ c = F .F₀ c , {! !}
44 | MonCD→CMonD .F₀ (F , mon) .F₁ = {! !}
45 | MonCD→CMonD .F₀ (F , mon) .F-id = {! !}
46 | MonCD→CMonD .F₀ (F , mon) .F-∘ = {! !}
47 | MonCD→CMonD .F₁ = {! !}
48 | MonCD→CMonD .F-id = {! !}
49 | MonCD→CMonD .F-∘ = {! !}
50 |
51 | MonCD≡CMonD : ∫ Mon[ Pointwise ] ≡ Cat[ C , ∫ Mon[ M ] ]
52 | MonCD≡CMonD = Precategory-path MonCD→CMonD {! !}
53 |
--------------------------------------------------------------------------------
/src-1lab/PostcomposeNotFull.agda:
--------------------------------------------------------------------------------
1 | open import Cat.Instances.Shape.Involution
2 | open import Cat.Instances.Shape.Interval
3 | open import Cat.Functor.Properties
4 | open import Cat.Functor.Compose
5 | open import Cat.Prelude
6 |
7 | open import Data.Bool
8 |
9 | open Precategory
10 | open Functor
11 | open _=>_
12 |
13 | module PostcomposeNotFull where
14 |
15 | {-
16 | We prove that it is NOT the case that, for every full functor p, the
17 | postcomposition functor p ∘ — is full.
18 | -}
19 |
20 | claim =
21 | ∀ {o ℓ o' ℓ' od ℓd} {C : Precategory o ℓ} {C' : Precategory o' ℓ'} {D : Precategory od ℓd}
22 | → (p : Functor C C') → is-full p → is-full (postcompose p {D = D})
23 |
24 | module _ (assume : claim) where
25 | {-
26 | The counterexample consists of the following category (identities omitted):
27 | https://q.uiver.app/#q=WzAsMixbMCwwLCJhIl0sWzAsMSwiYiJdLFswLDBdLFsxLDEsIiIsMix7InJhZGl1cyI6LTN9XSxbMCwxLCIiLDAseyJjdXJ2ZSI6LTF9XSxbMCwxLCIiLDEseyJjdXJ2ZSI6MX1dXQ==
28 | where the loops on a and b are involutions, the involution on a swaps
29 | the two morphisms a ⇉ b, and the involution on b leaves them alone.
30 | There is a full functor p from C to the walking arrow that collapses
31 | all the morphisms, and there are two inclusion functors F and G from
32 | the walking involution into C. A natural transformation p ∘ F ⇒ p ∘ G
33 | is trivial, but a natural transformation F ⇒ G is a "ℤ/2ℤ-equivariant"
34 | morphism a → b, that is one that commutes with the involutions on a and b.
35 | There is no such thing in C, hence the action of p ∘ — on natural
36 | transformations (whiskering) cannot be surjective.
37 | -}
38 |
39 | C : Precategory lzero lzero
40 | C .Ob = Bool
41 | C .Hom true true = Bool
42 | C .Hom true false = Bool
43 | C .Hom false true = ⊥
44 | C .Hom false false = Bool
45 | C .Hom-set true true = hlevel 2
46 | C .Hom-set true false = hlevel 2
47 | C .Hom-set false true = hlevel 2
48 | C .Hom-set false false = hlevel 2
49 | C .id {true} = false
50 | C .id {false} = false
51 | C ._∘_ {true} {true} {true} = xor
52 | C ._∘_ {false} {false} {false} = xor
53 | C ._∘_ {true} {true} {false} f g = xor g f
54 | C ._∘_ {true} {false} {false} f g = g
55 | C .idr {true} {true} f = xor-falser f
56 | C .idr {true} {false} f = refl
57 | C .idr {false} {false} f = xor-falser f
58 | C .idl {true} {true} f = refl
59 | C .idl {true} {false} f = refl
60 | C .idl {false} {false} f = refl
61 | C .assoc {true} {true} {true} {true} f g h = xor-associative f g h
62 | C .assoc {false} {false} {false} {false} f g h = xor-associative f g h
63 | C .assoc {true} {true} {true} {false} f true true = sym (not-involutive f)
64 | C .assoc {true} {true} {true} {false} f true false = refl
65 | C .assoc {true} {true} {true} {false} f false h = refl
66 | C .assoc {true} {true} {false} {false} f g h = refl
67 | C .assoc {true} {false} {false} {false} f g h = refl
68 |
69 | p : Functor C (0≤1 ^op)
70 | p .F₀ o = o
71 | p .F₁ {true} {true} = _
72 | p .F₁ {true} {false} = _
73 | p .F₁ {false} {true} ()
74 | p .F₁ {false} {false} = _
75 | p .F-id {true} = refl
76 | p .F-id {false} = refl
77 | p .F-∘ {true} {true} {true} f g = refl
78 | p .F-∘ {true} {true} {false} f g = refl
79 | p .F-∘ {true} {false} {false} f g = refl
80 | p .F-∘ {false} {false} {false} f g = refl
81 |
82 | p-is-full : is-full p
83 | p-is-full {true} {true} _ = inc (false , refl)
84 | p-is-full {true} {false} _ = inc (false , refl)
85 | p-is-full {false} {false} _ = inc (false , refl)
86 |
87 | p*-is-full : is-full (postcompose p {D = ∙⤮∙})
88 | p*-is-full = assume p p-is-full
89 |
90 | F G : Functor ∙⤮∙ C
91 | F .F₀ _ = true
92 | F .F₁ f = f
93 | F .F-id = refl
94 | F .F-∘ _ _ = refl
95 | G .F₀ _ = false
96 | G .F₁ f = f
97 | G .F-id = refl
98 | G .F-∘ _ _ = refl
99 |
100 | impossible : F => G → ⊥
101 | impossible θ = not-no-fixed (sym (θ .is-natural _ _ true))
102 |
103 | pθ : p F∘ F => p F∘ G
104 | pθ .η = _
105 | pθ .is-natural _ _ _ = refl
106 |
107 | θ : ∥ F => G ∥
108 | θ = fst <$> p*-is-full pθ
109 |
110 | contradiction : ⊥
111 | contradiction = rec! impossible θ
112 |
--------------------------------------------------------------------------------
/src-1lab/PresheafExponential.agda:
--------------------------------------------------------------------------------
1 | open import Cat.Prelude
2 | open import Cat.Functor.Base
3 | open import Cat.Functor.Naturality
4 | open import Cat.Instances.Presheaf.Limits
5 | open import Cat.Instances.Presheaf.Exponentials
6 | open import Cat.Diagram.Exponential
7 | open import Cat.Diagram.Product
8 | import Cat.Reasoning
9 |
10 | module PresheafExponential {ℓ} {C : Precategory ℓ ℓ} where
11 |
12 | module C = Cat.Reasoning C
13 | module PSh = Cat.Reasoning (PSh ℓ C)
14 | open Binary-products (PSh ℓ C) (PSh-products _ C)
15 | open Cartesian-closed (PSh-closed C)
16 |
17 | open Functor
18 | open _=>_
19 |
20 | module _ b a where
21 | open Exponential (has-exp a b)
22 | renaming (B^A to infixr 50 _^_)
23 | using () public
24 |
25 | module _ (K L M : PSh.Ob) where
26 |
27 | internal-currying : M ^ (K ⊗₀ L) PSh.≅ (M ^ K) ^ L
28 | internal-currying = PSh.make-iso
29 | (λ where
30 | .η n f .η q (v , y) .η p (u , x) → f .η p (v C.∘ u , x , L .F₁ u y)
31 | .η n f .η q (v , y) .is-natural → {! !}
32 | .η n f .is-natural → {! !}
33 | .is-natural → {! !})
34 | (λ where
35 | .η n g .η q (v , x , y) → g .η q (v , y) .η q (C.id , x)
36 | .η n g .is-natural → {! !}
37 | .is-natural → {! !})
38 | (ext λ n g q v y p u x →
39 | ⌜ g .η p (v C.∘ u , L .F₁ u y) ⌝ .η p (C.id , x) ≡⟨ g .is-natural _ _ u $ₚ (v , y) ηₚ p $ₚ (C.id , x) ⟩
40 | (M ^ K) .F₁ u (g .η q (v , y)) .η p (C.id , x) ≡⟨⟩
41 | g .η q (v , y) .η p (⌜ u C.∘ C.id ⌝ , x) ≡⟨ ap! (C.idr u) ⟩
42 | g .η q (v , y) .η p (u , x) ∎)
43 | {! !}
44 |
--------------------------------------------------------------------------------
/src-1lab/Probability.agda:
--------------------------------------------------------------------------------
1 | open import 1Lab.Prelude
2 |
3 | open import Data.Dec
4 | open import Data.Fin
5 | open import Data.Fin.Closure
6 |
7 | module Probability where
8 |
9 | -- “I have two children, (at least) one of whom is a boy born on a Tuesday -
10 | -- what is the probability that both children are boys?”
11 |
12 | -- Simplifying assumptions: gender is binary; gender and day of birth are
13 | -- uniformly distributed.
14 | Gender = Fin 2
15 | Day = Fin 7
16 | Child = Fin 2
17 |
18 | Sample = Child → Day × Gender
19 |
20 | count : (A : Sample → Type) → ⦃ ∀ {s} → Finite (A s) ⦄ → Nat
21 | count A = cardinality {A = Σ Sample A}
22 |
23 | condition : Sample → Type
24 | condition s = ∃[ i ∈ Child ] s i ≡ (1 , 1)
25 |
26 | event : Sample → Type
27 | event s = (i : Child) → s i .snd ≡ 1
28 |
29 | answer : Nat × Nat -- formal fraction
30 | answer = count (λ s → event s × condition s) , count condition
31 |
32 | _ : answer ≡ (13 , 27)
33 | _ = refl
34 |
--------------------------------------------------------------------------------
/src-1lab/Skeletons.agda:
--------------------------------------------------------------------------------
1 | open import Cat.Functor.Base
2 | open import Cat.Functor.Equivalence
3 | open import Cat.Functor.FullSubcategory
4 | open import Cat.Functor.Properties
5 | open import Cat.Instances.FinSets
6 | open import Cat.Instances.Sets
7 | open import Cat.Prelude
8 | open import Cat.Skeletal
9 | open import Data.Bool
10 | open import Data.Fin
11 | open import Data.Nat
12 |
13 | import Cat.Reasoning
14 |
15 | open Functor
16 | open is-precat-iso
17 |
18 | {-
19 | Formalising parts of https://math.stackexchange.com/a/4943344, with
20 | finite-dimensional real vector spaces replaced with finite sets
21 | (the situation is exactly the same).
22 | -}
23 | module Skeletons where
24 |
25 | module Sets {ℓ} = Cat.Reasoning (Sets ℓ)
26 |
27 | {-
28 | In the role of the skeletal category whose objects are natural numbers
29 | representing ℝⁿ and whose morphisms are matrices, we use the skeletal
30 | category whose objects are natural numbers representing the standard
31 | finite sets [n] and whose morphisms are functions.
32 | -}
33 | S : Precategory lzero lzero
34 | S = FinSets
35 |
36 | S-is-skeletal : is-skeletal S
37 | S-is-skeletal = FinSets-is-skeletal
38 |
39 | {-
40 | In the role of the univalent category of finite-dimensional real vector
41 | spaces, we use the univalent category of finite sets, here realised as
42 | the *essential image* of the inclusion of S into sets.
43 | Explicitly, an object of C is a set X such that there merely exists a
44 | natural number n such that X ≃ [n].
45 | Equivalently, an object of C is a set X equipped with a natural number
46 | n such that ∥ X ≃ [n] ∥ (we can extract n from the truncation because
47 | the statements X ≃ [n] are mutually exclusive for distinct n).
48 | C is a Rezk completion of S.
49 | -}
50 | C : Precategory (lsuc lzero) lzero
51 | C = Essential-image Fin→Sets
52 |
53 | C-is-category : is-category C
54 | C-is-category = Essential-image-is-category Fin→Sets Sets-is-category
55 |
56 | {-
57 | Finally, if we remove the truncation (but do not change the morphisms),
58 | we get a skeletal category *isomorphic* to S, because we can contract X
59 | away. This is entirely analogous to the way that the naïve definition
60 | of the image of a function using Σ instead of ∃ yields the domain of
61 | the function (https://1lab.dev/1Lab.Counterexamples.Sigma.html).
62 | -}
63 | C' : Precategory (lsuc lzero) lzero
64 | C' = Restrict {C = Sets _} λ X → Σ[ n ∈ Nat ] Fin→Sets .F₀ n Sets.≅ X
65 |
66 | S→C' : Functor S C'
67 | S→C' .F₀ n = el! (Fin n) , n , Sets.id-iso
68 | S→C' .F₁ f = f
69 | S→C' .F-id = refl
70 | S→C' .F-∘ _ _ = refl
71 |
72 | S≡C' : is-precat-iso S→C'
73 | S≡C' .has-is-ff = id-equiv
74 | S≡C' .has-is-iso = inverse-is-equiv (e .snd) where
75 | e : (Σ[ X ∈ Set lzero ] Σ[ n ∈ Nat ] Fin→Sets .F₀ n Sets.≅ X) ≃ Nat
76 | e = Σ-swap₂ ∙e Σ-contract λ n → is-contr-ΣR Sets-is-category
77 |
78 | {-
79 | Since C is a Rezk completion of S, we should expect to have a fully
80 | faithful and essentially surjective functor S → C.
81 | -}
82 |
83 | S→C : Functor S C
84 | S→C = Essential-inc Fin→Sets
85 |
86 | S→C-is-ff : is-fully-faithful S→C
87 | S→C-is-ff = ff→Essential-inc-ff Fin→Sets Fin→Sets-is-ff
88 |
89 | S→C-is-eso : is-eso S→C
90 | S→C-is-eso = Essential-inc-eso Fin→Sets
91 |
92 | {-
93 | However, this functor is *not* an equivalence of categories: in order
94 | to obtain a functor going the other way, we would have to choose an
95 | enumeration of every finite set in a coherent way. This is a form of
96 | global choice, which is just false in homotopy type theory
97 | (https://1lab.dev/1Lab.Counterexamples.GlobalChoice.html).
98 | -}
99 |
100 | module _ (S≃C : is-equivalence S→C) where private
101 | open is-equivalence S≃C renaming (F⁻¹ to C→S)
102 | module C = Cat.Reasoning C
103 |
104 | module _ (X : Set lzero) (e : ∥ ⌞ X ⌟ ≃ Fin 2 ∥) where
105 | c : C.Ob
106 | c = X , ((λ e → 2 , equiv→iso (e e⁻¹)) <$> e)
107 |
108 | chosen : ⌞ X ⌟
109 | chosen with C→S .F₀ c | counit.ε c | counit-iso c
110 | ... | suc n | ε | _ = ε 0
111 | ... | zero | ε | ε-inv = absurd (case e of λ e →
112 | zero≠suc (Fin-injective (iso→equiv (sub-iso→super-iso _ (C.invertible→iso ε ε-inv)) ∙e e)))
113 |
114 | b : Bool
115 | b = chosen (el! Bool) enumeration
116 |
117 | swap : Bool ≡ Bool
118 | swap = ua (not , not-is-equiv)
119 |
120 | p : PathP (λ i → swap i) b b
121 | p = ap₂ chosen (n-ua _) prop!
122 |
123 | ¬S≃C : ⊥
124 | ¬S≃C = not-no-fixed (from-pathp⁻ p)
125 |
--------------------------------------------------------------------------------
/src-1lab/SplitMonoSet.agda:
--------------------------------------------------------------------------------
1 | open import Cat.Prelude
2 | import Cat.Reasoning
3 | open import 1Lab.Classical
4 | open import Data.Dec
5 | open import Data.Sum
6 |
7 | -- If every split monomorphism with inhabited domain splits in Sets then excluded middle holds.
8 | module SplitMonoSet where
9 |
10 | module Sets = Cat.Reasoning (Sets lzero)
11 |
12 | module _ (every-mono-splits : ∀ {A B} (a : ∥ ⌞ A ⌟ ∥) (f : Sets.Hom A B) (f-mono : Sets.is-monic {a = A} {B} f) → Sets.is-split-monic {a = A} {B} f) where
13 | lem : LEM
14 | lem P = ∥-∥-out! do
15 | Sets.make-retract f⁻¹ ret ← f-split
16 | pure (go (f⁻¹ (inr tt)) λ p → ret $ₚ inr p)
17 | where
18 | A : Set lzero
19 | A = el! (⊤ ⊎ ⌞ P ⌟)
20 | B : Set lzero
21 | B = el! (⊤ ⊎ ⊤)
22 | f : Sets.Hom A B
23 | f = ⊎-map _ _
24 | f-mono : Sets.is-monic {a = A} {B} f
25 | f-mono = embedding→monic {f = f} $ injective→is-embedding! λ where
26 | {inl _} {inl _} p → refl
27 | {inl _} {inr _} p → absurd (inl≠inr p)
28 | {inr _} {inl _} p → absurd (inr≠inl p)
29 | {inr _} {inr _} p → ap inr prop!
30 | f-split : Sets.is-split-monic {a = A} {B} f
31 | f-split = every-mono-splits (inc (inl _)) f λ {c} → f-mono {c}
32 | go : (f⁻¹r : ∣ A ∣) → (∀ p → f⁻¹r ≡ inr p) → Dec ∣ P ∣
33 | go (inl _) l = no λ p → inl≠inr (l p)
34 | go (inr p) l = yes p
35 |
--------------------------------------------------------------------------------
/src-1lab/SyntheticCategoricalDuality.lagda.md:
--------------------------------------------------------------------------------
1 | ```agda
2 | open import 1Lab.Reflection.Regularity
3 | open import 1Lab.Path.Cartesian
4 | open import 1Lab.Reflection hiding (absurd)
5 |
6 | open import Cat.Functor.Equivalence.Path
7 | open import Cat.Functor.Equivalence
8 | open import Cat.Prelude hiding (_[_↦_])
9 |
10 | open import Data.Fin
11 | ```
12 |
13 | A synthetic account of categorical duality, based on an idea by [**David Wärn**](https://dwarn.se/).
14 |
15 | The theory of categories has a fundamental S₂-symmetry that swaps "source"
16 | and "target", which can be expressed synthetically by defining categories
17 | in the context of the delooping BS₂.
18 | By choosing as our delooping the type of 2-element types, this amounts
19 | to defining categories relative to an arbitrary 2-element type X, which
20 | we can think of as the set {source, target} except we've forgotten
21 | which is which.
22 | Then, instantiating this with a chosen 2-element type recovers usual
23 | categories, and the non-trivial symmetry of BS₂ automatically gives
24 | a symmetry of the type of categories which coincides with the usual
25 | categorical opposite.
26 |
27 | ```agda
28 | module SyntheticCategoricalDuality where
29 | ```
30 |
31 | Some auxiliary definitions
32 |
33 | ```agda
34 | private variable
35 | ℓ o h : Level
36 | X O : Type ℓ
37 | H : O → Type ℓ
38 | a b c : O
39 | i j k : X
40 |
41 | excluded-middle : ∀ {x y z : Bool} → x ≠ y → y ≠ z → x ≡ z
42 | excluded-middle {true} {y} {true} x≠y y≠z = refl
43 | excluded-middle {true} {y} {false} x≠y y≠z = absurd (x≠y (sym (x≠false→x≡true y y≠z)))
44 | excluded-middle {false} {y} {true} x≠y y≠z = absurd (x≠y (sym (x≠true→x≡false y y≠z)))
45 | excluded-middle {false} {y} {false} x≠y y≠z = refl
46 |
47 | instance
48 | Extensional-Bool-map
49 | : ∀ {ℓ ℓr} {C : Bool → Type ℓ} → ⦃ e : ∀ {b} → Extensional (C b) ℓr ⦄
50 | → Extensional ((b : Bool) → C b) ℓr
51 | Extensional-Bool-map ⦃ e ⦄ .Pathᵉ f g =
52 | e .Pathᵉ (f false) (g false) × e .Pathᵉ (f true) (g true)
53 | Extensional-Bool-map ⦃ e ⦄ .reflᵉ f =
54 | e .reflᵉ (f false) , e .reflᵉ (f true)
55 | Extensional-Bool-map ⦃ e ⦄ .idsᵉ .to-path (false≡ , true≡) = funext λ where
56 | true → e .idsᵉ .to-path true≡
57 | false → e .idsᵉ .to-path false≡
58 | Extensional-Bool-map ⦃ e ⦄ .idsᵉ .to-path-over (false≡ , true≡) =
59 | Σ-pathp (e .idsᵉ .to-path-over false≡) (e .idsᵉ .to-path-over true≡)
60 |
61 | Extensional-Bool-homotopy
62 | : ∀ {ℓ ℓr} {C : Bool → Type ℓ} → ⦃ e : ∀ {b} {x y : C b} → Extensional (x ≡ y) ℓr ⦄
63 | → {f g : (b : Bool) → C b}
64 | → Extensional (f ≡ g) ℓr
65 | Extensional-Bool-homotopy ⦃ e ⦄ {f} {g} .Pathᵉ p q =
66 | e .Pathᵉ (p $ₚ false) (q $ₚ false) × e .Pathᵉ (p $ₚ true) (q $ₚ true)
67 | Extensional-Bool-homotopy ⦃ e ⦄ .reflᵉ p =
68 | e .reflᵉ (p $ₚ false) , e .reflᵉ (p $ₚ true)
69 | Extensional-Bool-homotopy ⦃ e ⦄ .idsᵉ .to-path (false≡ , true≡) = funext-square λ where
70 | true → e .idsᵉ .to-path true≡
71 | false → e .idsᵉ .to-path false≡
72 | Extensional-Bool-homotopy ⦃ e ⦄ .idsᵉ .to-path-over (false≡ , true≡) =
73 | Σ-pathp (e .idsᵉ .to-path-over false≡) (e .idsᵉ .to-path-over true≡)
74 |
75 | Bool-η : (b : Bool → O) → if (b true) (b false) ≡ b
76 | Bool-η b = ext (refl , refl)
77 | ```
78 | Some more auxiliary definitions
86 |
87 | ```agda
88 | private instance
89 | Finite-X : Finite X
90 | Finite-X = ⦇ Equiv→listing (e <&> _e⁻¹) auto ⦈
91 |
92 | Discrete-X : Discrete X
93 | Discrete-X = Finite→Discrete
94 |
95 | H-Level-X : H-Level X 2
96 | H-Level-X = Finite→H-Level
97 |
98 | _[_↦_] : (X → O) → X → O → X → O
99 | _[_↦_] b x m i = ifᵈ i ≡? x then m else b i
100 |
101 | assign-id : (b : X → O) → (x : X) → b [ x ↦ b x ] ≡ b
102 | assign-id b x = ext go where
103 | go : ∀ i → (b [ x ↦ b x ]) i ≡ b i
104 | go i with i ≡? x
105 | ... | yes p = ap b (sym p)
106 | ... | no _ = refl
107 |
108 | assign-const : (b : X → O) (i j : X) → j ≠ i → b [ j ↦ b i ] ≡ λ _ → b i
109 | assign-const b i j j≠i = ext go where
110 | go : ∀ k → (b [ j ↦ b i ]) k ≡ b i
111 | go k with k ≡? j
112 | ... | yes _ = refl
113 | ... | no k≠j = ap b $ ∥-∥-out! do
114 | e ← e
115 | pure (subst (λ X → {x y z : X} → x ≠ y → y ≠ z → x ≡ z)
116 | (ua (e e⁻¹)) excluded-middle k≠j j≠i)
117 |
118 | degenerate
119 | : (H : (X → O) → Type h) (b : X → O) (x : X) (f : H b) (id : H (λ _ → b x)) (i : X)
120 | → H (b [ i ↦ b x ])
121 | -- degenerate H b x f id i with i ≡ᵢ? x
122 | -- ... | yes reflᵢ = subst H (sym (assign-id b x)) f
123 | -- ... | no i≠x = subst H (sym (assign-const b x i (i≠x ⊙ Id≃path.from))) id
124 | -- NOTE performing the with-translation manually somehow results in fewer transports when X = Bool and x = i.
125 | -- I'm not sure what's happening here...
126 | degenerate H b x f id i = go (i ≡ᵢ? x) where
127 | go : Dec (i ≡ᵢ x) → H (b [ i ↦ b x ])
128 | go (yes reflᵢ) = subst H (sym (assign-id b x)) f
129 | go (no i≠x) = subst H (sym (assign-const b x i (i≠x ⊙ Id≃path.from))) id
130 | ```
131 | Some lemmas about paths between X-precategories
167 |
168 | ```agda
169 | private
170 | hom-set : ∀ (C : XPrecategory) {b} → is-set (C .XPrecategory.Hom b)
171 | hom-set C = C .XPrecategory.Hom-set _
172 |
173 | instance
174 | hlevel-proj-xhom : hlevel-projection (quote XPrecategory.Hom)
175 | hlevel-proj-xhom .hlevel-projection.has-level = quote hom-set
176 | hlevel-proj-xhom .hlevel-projection.get-level _ = pure (lit (nat 2))
177 | hlevel-proj-xhom .hlevel-projection.get-argument (c v∷ _) = pure c
178 | hlevel-proj-xhom .hlevel-projection.get-argument _ = typeError []
179 |
180 | private unquoteDecl record-iso = declare-record-iso record-iso (quote XPrecategory)
181 |
182 | XPrecategory-path
183 | : ∀ {C D : XPrecategory} (let module C = XPrecategory C; module D = XPrecategory D)
184 | → (ob≡ : C.Ob ≡ D.Ob)
185 | → (hom≡ : PathP (λ i → (X → ob≡ i) → Type h) C.Hom D.Hom)
186 | → (id≡ : PathP (λ i → ∀ {x} → hom≡ i (λ _ → x)) C.id D.id)
187 | → (compose≡ : PathP (λ i → ∀ (b : X → ob≡ i) (m : ob≡ i) (f : ∀ x → hom≡ i (b [ x ↦ m ])) → hom≡ i b) C.compose D.compose)
188 | → C ≡ D
189 | XPrecategory-path ob≡ hom≡ id≡ compose≡ = Iso.injective record-iso
190 | $ Σ-pathp ob≡ $ Σ-pathp hom≡ $ Σ-pathp prop!
191 | $ Σ-pathp id≡ $ Σ-pathp compose≡ $ hlevel 0 .centre
192 | ```
193 | blocks... */
43 | text-align: initial;
44 | }
45 |
46 | pre, code {
47 | font-family: JuliaMono, monospace;
48 | }
49 |
50 | details {
51 | border-inline-start: 4px solid var(--accent);
52 | padding-inline-start: 8px;
53 | }
54 |
55 | details > summary::after {
56 | content: '(click to unfold)';
57 | color: var(--comment);
58 | }
59 |
60 | details[open] > summary::after {
61 | content: '(click to fold)';
62 | }
63 |
64 | .anchor::before {
65 | content: '🔗';
66 | display: inline-block;
67 | font-size: 80%;
68 | margin-left: 10px;
69 | opacity: 0.3;
70 | }
71 |
72 | .anchor:hover {
73 | text-decoration: none;
74 | }
75 |
76 | h1:hover > .anchor::before, h2:hover > .anchor::before, h3:hover > .anchor::before, h4:hover > .anchor::before, h5:hover > .anchor::before, h6:hover > .anchor::before {
77 | opacity: 1;
78 | }
79 |
80 | :any-link {
81 | text-decoration: none;
82 | color: var(--module);
83 | }
84 |
85 | /* Aspects. */
86 | .Agda .Comment { color: var(--comment) }
87 | .Agda .Background { }
88 | .Agda .Markup { }
89 | .Agda .Keyword { color: var(--keyword); font-weight: bold; }
90 | .Agda .String { color: var(--literal) }
91 | .Agda .Number { color: var(--literal) }
92 | .Agda .Symbol { color: var(--symbol) }
93 | .Agda .PrimitiveType { color: var(--defined) }
94 | .Agda .Pragma { color: var(--keyword) }
95 | .Agda .Operator {}
96 | .Agda .Hole { background: #490764 }
97 | .Agda .Macro { color: var(--defined) }
98 |
99 | /* NameKinds. */
100 | .Agda .Bound { color: var(--bound) }
101 | .Agda .Generalizable { color: var(--bound) }
102 | .Agda .InductiveConstructor { color: var(--constructor) }
103 | .Agda .CoinductiveConstructor { color: var(--constructor) }
104 | .Agda .Datatype { color: var(--defined) }
105 | .Agda .Field { color: var(--constructor) }
106 | .Agda .Function { color: var(--defined) }
107 | .Agda .Module { color: var(--module) }
108 | .Agda .Postulate { color: var(--defined) }
109 | .Agda .Primitive { color: var(--defined) }
110 | .Agda .Record { color: var(--defined) }
111 |
112 | /* OtherAspects. */
113 | .Agda .DottedPattern {}
114 | .Agda .UnsolvedMeta { color: var(--foreground); background: yellow }
115 | .Agda .UnsolvedConstraint { color: var(--foreground); background: yellow }
116 | .Agda .TerminationProblem { color: var(--foreground); background: #FFA07A }
117 | .Agda .IncompletePattern { color: var(--foreground); background: #F5DEB3 }
118 | .Agda .Error { color: red; text-decoration: underline }
119 | .Agda .TypeChecks { color: var(--foreground); background: #ADD8E6 }
120 | .Agda .Deadcode { color: var(--foreground); background: #808080 }
121 | .Agda .ShadowingInTelescope { color: var(--foreground); background: #808080 }
122 |
123 | /* Standard attributes. */
124 | .Agda a { text-decoration: none }
125 | .Agda a[href]:hover { background-color: #444; }
126 | .Agda [href].hover-highlight { background-color: #444; }
127 |
--------------------------------------------------------------------------------