├── .envrc ├── .gitignore ├── README.md ├── conceptual-mathematics.agda-lib ├── flake.lock ├── flake.nix └── src ├── Categories.agda ├── Category ├── MON.agda ├── Monoid.agda ├── PERM.agda └── SET.agda ├── Isomorphisms.agda ├── Old └── Isomorphisms.agda ├── Permutations.agda ├── SectionsAndRetractions.agda ├── Session4 └── Section4.agda └── Session5 └── Section3.agda /.envrc: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | use flake 4 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .direnv 2 | *.agdai 3 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Conceptual Mathematics 2 | 3 | # Curriculum 4 | 5 | - Week 1 6 | - Article 2.i: Isomorphisms - isomorphisms 7 | - Week 2 8 | - Article 2.ii: Isomorphisms - choice and determination 9 | - Article 2.iii: Isomorphisms - retracts, sections, and idempotents 10 | - Week 3 11 | - Article 2.iv: Isomorphisms - isomorphisms and automorphisms 12 | - Discussion: 13 | - Every section has a retraction and every retraction has a section 14 | - Sections and retractions are two parts of an inverse 15 | - Every section maps from a smaller object to a larger object (embeds) 16 | - Every retraction maps from a larger object to a smaller object (exemplifies) 17 | - If a function f has a section s and a retraction r then r = s; f has an inverse which is both the section and retraction f-1 = r = s 18 | - Isomorphisms give us a notion of equal cardinality, we can use this to prove that for A -f-> B there are as many isomorphisms f as there are automorphisms on A 19 | - Day 2 20 | - Categories can pack a lot more structure than `SET` can! Eg, `PERM` 21 | requires a big commuting square for all its morphisms, and these are 22 | quite restrictive. It took us 30 minutes to find a `PERM` morphism! 23 | - A permutation morphism needs to preserve cycles. For every cycle in the 24 | domain, there must be a cycle *of the same length* in the codomain. 25 | - The embed / exemplify metaphor for sections and retractions are a really 26 | good intuition! They hold in `PERM` too! 27 | -------------------------------------------------------------------------------- /conceptual-mathematics.agda-lib: -------------------------------------------------------------------------------- 1 | name: conceptual-mathematics 2 | include: 3 | src 4 | depend: 5 | standard-library 6 | -------------------------------------------------------------------------------- /flake.lock: -------------------------------------------------------------------------------- 1 | { 2 | "nodes": { 3 | "flake-utils": { 4 | "locked": { 5 | "lastModified": 1638122382, 6 | "narHash": "sha256-sQzZzAbvKEqN9s0bzWuYmRaA03v40gaJ4+iL1LXjaeI=", 7 | "owner": "numtide", 8 | "repo": "flake-utils", 9 | "rev": "74f7e4319258e287b0f9cb95426c9853b282730b", 10 | "type": "github" 11 | }, 12 | "original": { 13 | "owner": "numtide", 14 | "repo": "flake-utils", 15 | "type": "github" 16 | } 17 | }, 18 | "nixpkgs": { 19 | "locked": { 20 | "lastModified": 1641671388, 21 | "narHash": "sha256-aHoO6CpPLJK8hLkPJrpMnCRnj3YbfQZ7HNcXcnI83E0=", 22 | "owner": "nixos", 23 | "repo": "nixpkgs", 24 | "rev": "32356ce11b8cc5cc421b68138ae8c730cc8ad4a2", 25 | "type": "github" 26 | }, 27 | "original": { 28 | "owner": "nixos", 29 | "ref": "nixpkgs-unstable", 30 | "repo": "nixpkgs", 31 | "type": "github" 32 | } 33 | }, 34 | "root": { 35 | "inputs": { 36 | "flake-utils": "flake-utils", 37 | "nixpkgs": "nixpkgs" 38 | } 39 | } 40 | }, 41 | "root": "root", 42 | "version": 7 43 | } 44 | -------------------------------------------------------------------------------- /flake.nix: -------------------------------------------------------------------------------- 1 | { 2 | description = "Conceptual mathematics: learning category theory once and for all"; 3 | 4 | inputs = { 5 | nixpkgs.url = github:nixos/nixpkgs/nixpkgs-unstable; 6 | flake-utils.url = github:numtide/flake-utils; 7 | }; 8 | 9 | outputs = inputs: 10 | with inputs.flake-utils.lib; 11 | eachDefaultSystem (system: 12 | 13 | let 14 | pkgs = import inputs.nixpkgs { 15 | inherit system; 16 | }; 17 | utils = inputs.flake-utils.lib; 18 | in 19 | { 20 | # nix develop 21 | devShell = 22 | pkgs.mkShell { 23 | buildInputs = with pkgs; [ 24 | (agda.withPackages (ps: [ 25 | ps.standard-library 26 | ]) 27 | ) 28 | ]; 29 | }; 30 | }); 31 | } 32 | -------------------------------------------------------------------------------- /src/Categories.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --type-in-type #-} 2 | 3 | module Categories where 4 | 5 | open import Relation.Binary.Structures using (IsEquivalence) 6 | open import Relation.Binary.Bundles using (Setoid) 7 | open import Relation.Binary 8 | import Relation.Binary.Reasoning.Setoid as SetoidR 9 | 10 | record Category : Set where 11 | infix 6 _~>_ 12 | infix 2 _≈_ 13 | 14 | field 15 | -- Objects and arrows in the category 16 | Obj : Set 17 | _~>_ : (A B : Obj) → Set 18 | 19 | -- The meaning of equality of morphisms 20 | _≈_ 21 | : {A B : Obj} 22 | → A ~> B 23 | → A ~> B 24 | → Set 25 | 26 | -- _≈_ forms a equivalence relationship 27 | ≈-equiv : {A B : Obj} → IsEquivalence (_≈_ {A} {B}) 28 | 29 | -- Id and composition 30 | id : {A : Obj} → A ~> A 31 | _∘_ : {A B C : Obj} → B ~> C → A ~> B → A ~> C 32 | 33 | ∘-cong 34 | : ∀ {A B C} {g g' : B ~> C} {f f' : A ~> B} 35 | → g ≈ g' 36 | → f ≈ f' 37 | → g ∘ f ≈ g' ∘ f' 38 | 39 | -- Laws 40 | id-r : {A B : Obj} (f : A ~> B) → f ∘ id ≈ f 41 | id-l : {A B : Obj} (f : A ~> B) → id ∘ f ≈ f 42 | ∘-assoc 43 | : {A B C D : Obj} 44 | → (h : C ~> D) 45 | → (g : B ~> C) 46 | → (f : A ~> B) 47 | → h ∘ (g ∘ f) ≈ (h ∘ g) ∘ f 48 | 49 | -- "Forward" composition 50 | _>>_ : {A B C : Obj} → A ~> B → B ~> C → A ~> C 51 | _>>_ f g = g ∘ f 52 | 53 | >>-assoc 54 | : {A B C D : Obj} 55 | → (f : A ~> B) 56 | → (g : B ~> C) 57 | → (h : C ~> D) 58 | → f >> (g >> h) ≈ (f >> g) >> h 59 | >>-assoc f g h = IsEquivalence.sym ≈-equiv (∘-assoc h g f) 60 | 61 | setoid : {X Y : Obj} → Setoid _ _ 62 | Setoid.Carrier (setoid {X} {Y}) = X ~> Y 63 | Setoid._≈_ setoid = _≈_ 64 | Setoid.isEquivalence setoid = ≈-equiv 65 | 66 | module HomReasoning {A B : Obj} where 67 | open SetoidR (setoid {A} {B}) public 68 | open IsEquivalence (≈-equiv {A} {B}) public 69 | 70 | open Category 71 | 72 | 73 | infix 2 _[_≈_] 74 | _[_≈_] : (r : Category) {A B : Obj r} → (r ~> A) B → (r ~> A) B → Set 75 | _[_≈_] = _≈_ 76 | 77 | -- Notational convenience for arrows in a category. Helpful when dealing with 78 | -- multiple categories at once. 79 | -- eg we can talk about a set arrow via `SET [ Bool , Int ]` 80 | infix 5 _[_,_] 81 | _[_,_] : (C : Category) -> Obj C -> Obj C -> Set 82 | C [ X , Y ] = _~>_ C X Y 83 | 84 | -- Notational convenience for composition. 85 | -- eg we can talk about a set composition `SET [ show ∘ length ] : SET [ List A , String ]` 86 | infix 5 _[_∘_] 87 | _[_∘_] : (C : Category) -> {X Y Z : Obj C} -> C [ Y , Z ] -> C [ X , Y ] -> C [ X , Z ] 88 | _[_∘_] = _∘_ 89 | 90 | -- Notational convenience for "forward" composition. 91 | -- eg we can talk about a set composition `SET [ length >> show ] : SET [ List A , String ]` 92 | infix 5 _[_>>_] 93 | _[_>>_] : (C : Category) -> {X Y Z : Obj C} -> C [ X , Y ] -> C [ Y , Z ] -> C [ X , Z ] 94 | _[_>>_] = _>>_ 95 | 96 | -------------------------------------------------------------------------------- /src/Category/MON.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --type-in-type #-} 2 | 3 | module Category.MON where 4 | 5 | open import Algebra.Bundles using (Monoid) 6 | open import Categories 7 | open import Relation.Binary.Bundles 8 | 9 | open import Relation.Binary.Structures 10 | 11 | import Relation.Binary.Reasoning.Setoid as SetoidR 12 | 13 | record MonArr (S T : Monoid _ _) : Set where 14 | open Monoid S using (_∙_) renaming (_≈_ to _≋_) 15 | open Monoid T using (_≈_) renaming (_∙_ to _×_) 16 | field 17 | map : Monoid.Carrier S → Monoid.Carrier T 18 | commutes 19 | : (a b : Monoid.Carrier S) 20 | → map (a ∙ b) ≈ map a × map b 21 | preserves-≈ 22 | : (a a' : Monoid.Carrier S) 23 | → a ≋ a' 24 | → map a ≈ map a' 25 | 26 | open Category hiding (setoid) 27 | open MonArr 28 | open Monoid hiding (_∙_) 29 | 30 | MON : Category 31 | Obj MON = Monoid _ _ 32 | _~>_ MON = MonArr 33 | _≈_ MON {A = A} {B = B} f g = forall (a : Carrier A) → B ._≈_ (map f a) (map g a) 34 | IsEquivalence.refl (≈-equiv MON {B = B}) a = B .refl 35 | IsEquivalence.sym (≈-equiv MON {B = B}) f a = B .sym (f a) 36 | IsEquivalence.trans (≈-equiv MON {B = B}) f g a = B .trans (f a) (g a) 37 | map (id MON) a = a 38 | commutes (id MON {A = A}) a b = A .refl 39 | preserves-≈ (id MON {A = A}) a a' eq = eq 40 | map ((MON ∘ g) f) a = map g (map f a) 41 | commutes (_∘_ MON {A = A} {B} {C} g f) a a' = 42 | begin 43 | map g (map f (a × a')) 44 | ≈⟨ preserves-≈ g _ _ (commutes f a a') ⟩ 45 | map g (map f a ⊗ map f a') 46 | ≈⟨ commutes g _ _ ⟩ 47 | map g (map f a) ∙ map g (map f a') 48 | ∎ 49 | where 50 | open SetoidR (setoid C) public 51 | open Monoid A using () renaming (_∙_ to _×_) 52 | open Monoid B using () renaming (_∙_ to _⊗_) 53 | open Monoid C 54 | preserves-≈ (_∘_ MON g f) a a' eq = 55 | g .preserves-≈ _ _ (f .preserves-≈ _ _ eq) 56 | ∘-cong MON {A = A} {B} {C} {g} {g'} {f} {f'} geq feq a = 57 | begin 58 | map g (map f a) 59 | ≈⟨ g .preserves-≈ _ _ (feq _) ⟩ 60 | map g (map f' a) 61 | ≈⟨ geq _ ⟩ 62 | map g' (map f' a) 63 | ∎ 64 | where 65 | open SetoidR (setoid C) 66 | id-r MON {B = B} f a = B .refl 67 | id-l MON {B = B} f a = B .refl 68 | ∘-assoc MON {D = D} h g f a = D .refl 69 | 70 | -------------------------------------------------------------------------------- /src/Category/Monoid.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --type-in-type #-} 2 | 3 | open import Algebra.Bundles using (Monoid) 4 | 5 | module Category.Monoid {c l} (M : Monoid c l) where 6 | 7 | open import Categories 8 | open Category hiding (setoid) 9 | open Monoid M renaming (_≈_ to _≈M≈_) 10 | open import Relation.Binary.Bundles 11 | 12 | data One : Set where 13 | one : One 14 | 15 | open import Relation.Binary.Structures 16 | 17 | -- A one element category, whose morphisms are monoidal elements that get 18 | -- multiplied in. 19 | monoidCategory : Category 20 | Obj monoidCategory = One 21 | _~>_ monoidCategory _ _ = Carrier 22 | _≈_ monoidCategory = _≈M≈_ 23 | ≈-equiv monoidCategory = Setoid.isEquivalence setoid 24 | id monoidCategory = ε 25 | _∘_ monoidCategory = _∙_ 26 | ∘-cong monoidCategory = ∙-cong 27 | id-r monoidCategory = identityʳ 28 | id-l monoidCategory = identityˡ 29 | ∘-assoc monoidCategory f g h = sym (assoc f g h) 30 | 31 | -------------------------------------------------------------------------------- /src/Category/PERM.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --type-in-type #-} 2 | 3 | module Category.PERM where 4 | 5 | open import Categories 6 | open import Relation.Binary.PropositionalEquality as Eq using (_≡_; refl; cong; sym; trans) 7 | open import Relation.Binary.Structures 8 | open import Category.SET 9 | import Isomorphisms 10 | open import Isomorphisms SET 11 | 12 | 13 | module _ where 14 | 15 | open Isomorphisms.Isomorphism 16 | open Category 17 | open Eq.≡-Reasoning using (begin_; _≡⟨⟩_; _∎; step-≡) 18 | 19 | record PermObj : Set where 20 | field 21 | carrier : Set 22 | auto : Automorphism carrier 23 | 24 | open Isomorphism 25 | open PermObj 26 | 27 | record PermArrow ( A B : PermObj ) : Set where 28 | field 29 | map : carrier A → carrier B 30 | map-commutes 31 | : (a : carrier A) 32 | → map (forward (auto A) a) ≡ forward (auto B) (map a) 33 | 34 | open PermArrow 35 | 36 | 37 | PERM : Category 38 | Obj PERM = PermObj 39 | _~>_ PERM = PermArrow 40 | _≈_ PERM f g = forall a → map f a ≡ map g a 41 | IsEquivalence.refl (≈-equiv PERM) _ = refl 42 | IsEquivalence.sym (≈-equiv PERM) f a = Eq.sym (f a) 43 | IsEquivalence.trans (≈-equiv PERM) f g a = Eq.trans (f a) (g a) 44 | map (id PERM) = id SET 45 | map-commutes (id PERM) a = refl 46 | map ((PERM ∘ g) f) a = map g (map f a) 47 | map-commutes (_∘_ PERM {A} {B} {C} 48 | g@record { map = gmap ; map-commutes = glaw } 49 | f@record { map = fmap ; map-commutes = flaw }) a = 50 | let perm t = forward (auto t) 51 | in 52 | begin 53 | gmap (fmap (perm A a)) 54 | ≡⟨ cong gmap (flaw a) ⟩ 55 | gmap (perm B (fmap a)) 56 | ≡⟨ glaw (fmap a) ⟩ 57 | perm C (gmap (fmap a)) 58 | ∎ 59 | ∘-cong PERM {f' = f'} gg' ff' a 60 | rewrite ff' a 61 | | gg' (map f' a) 62 | = refl 63 | id-r PERM f a = refl 64 | id-l PERM f a = refl 65 | ∘-assoc PERM f g h a = refl 66 | 67 | 68 | module Ex where 69 | open import SectionsAndRetractions PERM 70 | open Isomorphism 71 | open Category PERM 72 | open Choice 73 | open PermObj 74 | open PermArrow 75 | open Isomorphisms.Isomorphism 76 | 77 | 78 | 79 | data Bool : Set where 80 | true : Bool 81 | false : Bool 82 | 83 | data Three : Set where 84 | this : Three 85 | that : Three 86 | other : Three 87 | 88 | data Four : Set where 89 | fone : Four 90 | ftwo : Four 91 | fthree : Four 92 | ffour : Four 93 | 94 | four-shuf : Four → Four 95 | four-shuf fone = ftwo 96 | four-shuf ftwo = fone 97 | four-shuf fthree = ffour 98 | four-shuf ffour = fthree 99 | 100 | four-pairs : Obj 101 | carrier four-pairs = Four 102 | forward (auto four-pairs) = four-shuf 103 | backward (auto four-pairs) = four-shuf 104 | fInverse (auto four-pairs) fone = refl 105 | fInverse (auto four-pairs) ftwo = refl 106 | fInverse (auto four-pairs) fthree = refl 107 | fInverse (auto four-pairs) ffour = refl 108 | bInverse (auto four-pairs) fone = refl 109 | bInverse (auto four-pairs) ftwo = refl 110 | bInverse (auto four-pairs) fthree = refl 111 | bInverse (auto four-pairs) ffour = refl 112 | 113 | data One : Set where 114 | one : One 115 | 116 | shuffle-3 : Three → Three 117 | shuffle-3 this = that 118 | shuffle-3 that = this 119 | shuffle-3 other = other 120 | 121 | 122 | 123 | shuffle-3-auto : Automorphism Three 124 | forward shuffle-3-auto = shuffle-3 125 | backward shuffle-3-auto = shuffle-3 126 | fInverse shuffle-3-auto this = refl 127 | fInverse shuffle-3-auto that = refl 128 | fInverse shuffle-3-auto other = refl 129 | bInverse shuffle-3-auto this = refl 130 | bInverse shuffle-3-auto that = refl 131 | bInverse shuffle-3-auto other = refl 132 | 133 | shuffle-3-obj : Obj 134 | carrier shuffle-3-obj = _ 135 | auto shuffle-3-obj = shuffle-3-auto 136 | 137 | not : Bool → Bool 138 | not true = false 139 | not false = true 140 | 141 | not-auto : Automorphism Bool 142 | forward not-auto = not 143 | backward not-auto = not 144 | fInverse not-auto true = refl 145 | fInverse not-auto false = refl 146 | bInverse not-auto true = refl 147 | bInverse not-auto false = refl 148 | 149 | not-obj : Obj 150 | carrier not-obj = Bool 151 | auto not-obj = not-auto 152 | 153 | two-to-three : not-obj ~> shuffle-3-obj 154 | map two-to-three true = this 155 | map two-to-three false = that 156 | map-commutes two-to-three true = refl 157 | map-commutes two-to-three false = refl 158 | 159 | four-to-bool : four-pairs ~> not-obj 160 | map four-to-bool fone = false 161 | map four-to-bool ftwo = true 162 | map four-to-bool fthree = false 163 | map four-to-bool ffour = true 164 | map-commutes four-to-bool fone = refl 165 | map-commutes four-to-bool ftwo = refl 166 | map-commutes four-to-bool fthree = refl 167 | map-commutes four-to-bool ffour = refl 168 | 169 | four-to-bool' : four-pairs ~> not-obj 170 | map four-to-bool' fone = true 171 | map four-to-bool' ftwo = false 172 | map four-to-bool' fthree = true 173 | map four-to-bool' ffour = false 174 | map-commutes four-to-bool' fone = refl 175 | map-commutes four-to-bool' ftwo = refl 176 | map-commutes four-to-bool' fthree = refl 177 | map-commutes four-to-bool' ffour = refl 178 | 179 | bool-to-four : not-obj ~> four-pairs 180 | map bool-to-four true = fone 181 | map bool-to-four false = ftwo 182 | map-commutes bool-to-four true = refl 183 | map-commutes bool-to-four false = refl 184 | 185 | open Choice 186 | 187 | zoo : HasSection four-to-bool 188 | map (s zoo) true = ffour 189 | map (s zoo) false = fthree 190 | map-commutes (s zoo) true = refl 191 | map-commutes (s zoo) false = refl 192 | commute zoo true = refl 193 | commute zoo false = refl 194 | 195 | open Determination 196 | b24r : HasRetract bool-to-four 197 | map (r b24r) fone = true 198 | map (r b24r) ftwo = false 199 | map (r b24r) fthree = true 200 | map (r b24r) ffour = false 201 | map-commutes (r b24r) fone = refl 202 | map-commutes (r b24r) ftwo = refl 203 | map-commutes (r b24r) fthree = refl 204 | map-commutes (r b24r) ffour = refl 205 | commute b24r true = refl 206 | commute b24r false = refl 207 | 208 | 209 | one-auto : Automorphism One 210 | one-auto = reflexiveIso 211 | 212 | one-obj : Obj 213 | carrier one-obj = One 214 | auto one-obj = one-auto 215 | 216 | -------------------------------------------------------------------------------- /src/Category/SET.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --type-in-type #-} 2 | 3 | module Category.SET where 4 | 5 | open import Categories 6 | import Relation.Binary.PropositionalEquality as Eq 7 | open Eq using (_≡_; refl) 8 | open import Relation.Binary.Structures 9 | 10 | 11 | open Category 12 | 13 | SET : Category 14 | Obj SET = Set 15 | _~>_ SET S T = S → T 16 | _≈_ SET {A} f g = forall (a : A) → f a ≡ g a 17 | IsEquivalence.refl (≈-equiv SET) _ = refl 18 | IsEquivalence.sym (≈-equiv SET) f a = Eq.sym (f a) 19 | IsEquivalence.trans (≈-equiv SET) f g a = Eq.trans (f a) (g a) 20 | id SET = \a → a 21 | _∘_ SET = \g f a → g (f a) 22 | ∘-cong SET {f' = f'} gg' ff' a rewrite ff' a | gg' (f' a) = refl 23 | id-r SET _ _ = refl 24 | id-l SET _ _ = refl 25 | ∘-assoc SET _ _ _ _ = refl 26 | 27 | -------------------------------------------------------------------------------- /src/Isomorphisms.agda: -------------------------------------------------------------------------------- 1 | open import Categories 2 | 3 | module Isomorphisms (C : Category) where 4 | 5 | import Relation.Binary.PropositionalEquality as Eq 6 | open import Function using (_$_) 7 | 8 | open Category C 9 | open HomReasoning 10 | 11 | record Isomorphism (A B : Obj) : Set where 12 | field 13 | forward : C [ A , B ] 14 | backward : C [ B , A ] 15 | fInverse : forward ∘ backward ≈ id 16 | bInverse : backward ∘ forward ≈ id 17 | 18 | open Isomorphism 19 | 20 | reflexiveIso : {A : Obj} → Isomorphism A A 21 | forward reflexiveIso = id 22 | backward reflexiveIso = id 23 | fInverse reflexiveIso = id-l id 24 | bInverse reflexiveIso = id-l id 25 | 26 | symmetricIso : {A B : Obj} → Isomorphism A B → Isomorphism B A 27 | forward (symmetricIso iso) = backward iso 28 | backward (symmetricIso iso) = forward iso 29 | fInverse (symmetricIso iso) = bInverse iso 30 | bInverse (symmetricIso iso) = fInverse iso 31 | 32 | transitiveIso 33 | : {X Y Z : Obj} 34 | → Isomorphism X Y 35 | → Isomorphism Y Z 36 | → Isomorphism X Z 37 | forward (transitiveIso fiso giso) = forward fiso >> forward giso 38 | backward (transitiveIso fiso giso) = backward giso >> backward fiso 39 | fInverse (transitiveIso fiso giso) = 40 | begin 41 | forward (transitiveIso fiso giso) ∘ backward (transitiveIso fiso giso) 42 | ≡⟨⟩ 43 | (forward giso ∘ forward fiso) ∘ backward (transitiveIso fiso giso) 44 | ≡⟨⟩ 45 | (forward giso ∘ forward fiso) ∘ (backward fiso ∘ backward giso) 46 | ≈⟨ sym $ ∘-assoc _ _ _ ⟩ 47 | forward giso ∘ (forward fiso ∘ (backward fiso ∘ backward giso)) 48 | ≈⟨ ∘-cong refl $ ∘-assoc _ _ _ ⟩ 49 | forward giso ∘ ((forward fiso ∘ backward fiso) ∘ backward giso) 50 | ≈⟨ ∘-cong refl $ ∘-cong (fInverse fiso) refl ⟩ 51 | forward giso ∘ (id ∘ backward giso) 52 | ≈⟨ ∘-cong refl (id-l $ backward giso) ⟩ 53 | forward giso ∘ backward giso 54 | ≈⟨ fInverse giso ⟩ 55 | id 56 | ∎ 57 | bInverse (transitiveIso fiso giso) = 58 | begin 59 | backward (transitiveIso fiso giso) ∘ forward (transitiveIso fiso giso) 60 | ≡⟨⟩ 61 | (backward fiso ∘ backward giso) ∘ (forward giso ∘ forward fiso) 62 | ≈⟨ sym $ ∘-assoc _ _ _ ⟩ 63 | backward fiso ∘ (backward giso ∘ (forward giso ∘ forward fiso)) 64 | ≈⟨ ∘-cong refl $ ∘-assoc _ _ _ ⟩ 65 | backward fiso ∘ ((backward giso ∘ forward giso) ∘ forward fiso) 66 | ≈⟨ ∘-cong refl $ ∘-cong (bInverse giso) refl ⟩ 67 | backward fiso ∘ (id ∘ forward fiso) 68 | ≈⟨ ∘-cong refl (id-l $ forward fiso) ⟩ 69 | backward fiso ∘ forward fiso 70 | ≈⟨ bInverse fiso ⟩ 71 | id 72 | ∎ 73 | 74 | 75 | Automorphism : Obj -> Set 76 | Automorphism A = Isomorphism A A 77 | 78 | -------------------------------------------------------------------------------- /src/Old/Isomorphisms.agda: -------------------------------------------------------------------------------- 1 | module Old.Isomorphisms where 2 | 3 | open import Function 4 | open import Data.Empty 5 | open import Data.Product 6 | import Relation.Binary.PropositionalEquality as Eq 7 | open Eq using (_≡_; refl; cong; sym; trans) 8 | open Eq.≡-Reasoning using (begin_; _≡⟨⟩_; _∎; step-≡) 9 | open import Function.Reasoning 10 | 11 | record Isomorphism (A B : Set) : Set where 12 | field 13 | forward : A → B 14 | backward : B → A 15 | fInverse : (x : B) -> (forward ∘ backward) x ≡ id x 16 | bInverse : (x : A) -> (backward ∘ forward) x ≡ id x 17 | 18 | data SetB : Set where 19 | Feather : SetB 20 | Stone : SetB 21 | Flower : SetB 22 | 23 | data SetA : Set where 24 | Mother : SetA 25 | Father : SetA 26 | Child : SetA 27 | 28 | abIso : Isomorphism SetA SetB 29 | Isomorphism.forward abIso Mother = Feather 30 | Isomorphism.forward abIso Father = Stone 31 | Isomorphism.forward abIso Child = Flower 32 | Isomorphism.backward abIso Feather = Mother 33 | Isomorphism.backward abIso Stone = Father 34 | Isomorphism.backward abIso Flower = Child 35 | Isomorphism.fInverse abIso Feather = refl 36 | Isomorphism.fInverse abIso Stone = refl 37 | Isomorphism.fInverse abIso Flower = refl 38 | Isomorphism.bInverse abIso Mother = refl 39 | Isomorphism.bInverse abIso Father = refl 40 | Isomorphism.bInverse abIso Child = refl 41 | 42 | reflexiveIso : {A : Set} -> Isomorphism A A 43 | reflexiveIso = record 44 | { forward = λ z → z 45 | ; backward = λ z → z 46 | ; fInverse = λ x → refl 47 | ; bInverse = λ x → refl 48 | } 49 | 50 | symmetricIso : {A B : Set } -> Isomorphism A B -> Isomorphism B A 51 | symmetricIso record { forward = f ; backward = g ; fInverse = fInverse ; bInverse = gInverse } = 52 | record 53 | { forward = g 54 | ; backward = f 55 | ; fInverse = gInverse 56 | ; bInverse = fInverse 57 | } 58 | 59 | transitiveIso : {A B C : Set } -> Isomorphism A B -> Isomorphism B C -> Isomorphism A C 60 | transitiveIso 61 | record { forward = f₁ ; backward = g₁ ; fInverse = fInverse₁ ; bInverse = gInverse₁ } 62 | record { forward = f ; backward = g ; fInverse = fInverse ; bInverse = gInverse } = 63 | record 64 | { forward = λ z → f (f₁ z) 65 | ; backward = λ z → g₁ (g z) 66 | ; fInverse = λ x → 67 | begin 68 | f (f₁ (g₁ (g x))) 69 | ≡⟨ cong f $ fInverse₁ (g x) ⟩ 70 | f (id (g x)) 71 | ≡⟨⟩ 72 | f (g x) 73 | ≡⟨ fInverse x ⟩ 74 | id x 75 | ∎ 76 | ; bInverse = λ x → 77 | begin 78 | g₁ (g (f (f₁ x))) 79 | ≡⟨ cong g₁ $ gInverse (f₁ x) ⟩ 80 | g₁ (id (f₁ x)) 81 | ≡⟨ gInverse₁ x ⟩ 82 | id x 83 | ∎ 84 | } 85 | 86 | open Isomorphism 87 | 88 | uniqInv : { A B : Set } -> 89 | (gIso : Isomorphism A B) -> (kIso : Isomorphism A B) -> 90 | ((a : A ) -> (gIso .forward a ≡ kIso .forward a)) -> 91 | (x : B) -> 92 | gIso .backward x ≡ kIso .backward x 93 | uniqInv 94 | record { forward = f₁ ; backward = g₁ ; fInverse = fInverse₁ ; bInverse = gInverse₁ } -- gIso 95 | record { forward = f ; backward = g ; fInverse = fInverse ; bInverse = gInverse } -- kIso 96 | fEq x = 97 | let feq = fEq (g₁ x) 98 | i1 = gInverse (g₁ x) 99 | in 100 | begin 101 | g₁ x 102 | ≡⟨ sym i1 ⟩ 103 | g (f (g₁ x)) 104 | ≡⟨ cong g (sym feq) ⟩ 105 | g (f₁ (g₁ x)) 106 | ≡⟨ cong g (fInverse₁ x) ⟩ 107 | g x 108 | ∎ 109 | 110 | leftIsoCancellation : {A B : Set} -> 111 | (iso : Isomorphism A B) -> 112 | (h : B -> A) -> 113 | (k : B -> A) -> 114 | ((x : B) -> (iso .forward ∘ h) x ≡ (iso .forward ∘ k) x) -> 115 | (x : B) -> h x ≡ k x 116 | leftIsoCancellation record { forward = f ; backward = g ; fInverse = fInverse ; bInverse = gInverse } h k isoEq x = 117 | begin 118 | h x 119 | ≡⟨ sym (gInverse (h x)) ⟩ 120 | g (f (h x)) 121 | ≡⟨ cong g (isoEq x) ⟩ 122 | g (f (k x)) 123 | ≡⟨ gInverse (k x) ⟩ 124 | k x 125 | ∎ 126 | 127 | rightIsoCancellation : {A B : Set} -> 128 | (iso : Isomorphism A B) -> 129 | (h : B -> A) -> 130 | (k : B -> A) -> 131 | ((x : A) -> (h ∘ iso .forward) x ≡ (k ∘ iso .forward) x) -> 132 | (x : B) -> h x ≡ k x 133 | rightIsoCancellation record { forward = f ; backward = g ; fInverse = fInverse ; bInverse = bInverse } h k isoEq x = 134 | begin 135 | h x 136 | ≡⟨ cong h (sym (fInverse x)) ⟩ 137 | h (f (g x)) 138 | ≡⟨ isoEq (g x) ⟩ 139 | k (f (g x)) 140 | ≡⟨ cong k (fInverse x) ⟩ 141 | k x 142 | ∎ 143 | 144 | open import Data.Bool 145 | 146 | counterExample : Isomorphism Bool Bool 147 | counterExample = 148 | record 149 | { forward = not 150 | ; backward = not 151 | ; fInverse = λ { false → refl ; true -> refl } 152 | ; bInverse = λ { false → refl ; true -> refl } 153 | } 154 | 155 | invalidIsoCancellation : 156 | (∀ {A h k a} -> (iso : Isomorphism A A) 157 | -> (h ∘ (forward iso)) a ≡ ((forward iso) ∘ k) a -> h a ≡ k a 158 | ) -> ⊥ 159 | invalidIsoCancellation eq 160 | with (eq {Bool} {const true} {const false} {true} counterExample refl) 161 | ... | () 162 | 163 | 164 | record Determination {A B C : Set} (h : A -> C) (f : A -> B) : Set where 165 | constructor determines 166 | field 167 | r : B -> C 168 | determinationProof : (a : A) -> (r ∘ f) a ≡ h a 169 | 170 | HasRetract : {A B : Set} (f : A -> B) -> Set 171 | HasRetract = Determination id 172 | 173 | record Choice {A B C : Set} (h : A -> C) (g : B -> C) : Set where 174 | constructor chooses 175 | field 176 | s : A -> B 177 | choiceProof : (a : A) -> (g ∘ s) a ≡ h a 178 | 179 | HasSection : {A B : Set} (f : A -> B) -> Set 180 | HasSection = Choice id 181 | 182 | choiceForEverySection : 183 | {A B : Set} -> {f : A -> B} -> 184 | HasSection f -> 185 | ∀ {T : Set} -> (y : T -> B) -> Σ (T -> A) (λ (x : T -> A) -> (t : T) -> (f ∘ x) t ≡ y t) 186 | choiceForEverySection {f = f} section {T} y = 187 | let open Choice section 188 | sec = s 189 | secEq = choiceProof 190 | in s ∘ y , \a -> 191 | begin 192 | (f ∘ (s ∘ y)) a 193 | ≡⟨⟩ 194 | ((f ∘ s) ∘ y) a 195 | ≡⟨ secEq (y a) ⟩ 196 | y a 197 | ∎ 198 | 199 | determinationForEveryRetraction : 200 | {A B : Set} -> {f : A -> B} -> 201 | HasRetract f -> 202 | ∀ {T : Set} -> (y : A -> T) -> Σ (B -> T) (λ (x : B -> T) -> (t : A) -> (x ∘ f) t ≡ y t) 203 | determinationForEveryRetraction {f = f} ret {T} y = 204 | let open Determination ret 205 | r' = r 206 | retEq = determinationProof 207 | in y ∘ r , \a -> 208 | begin 209 | ( (y ∘ r) ∘ f ) a 210 | ≡⟨⟩ 211 | ( y ∘ (r ∘ f) ) a 212 | ≡⟨ cong y (retEq a) ⟩ 213 | y a 214 | ∎ 215 | 216 | monomorphicChoice : 217 | {A B : Set} {f : A -> B} {T : Set} {x1 x2 : T -> A} -> 218 | HasRetract f -> 219 | (t : T) -> 220 | (f ∘ x1) t ≡ (f ∘ x2) t 221 | -> x1 t ≡ x2 t 222 | monomorphicChoice {f = f} {x1 = x1} {x2 = x2} retF t eq = 223 | let open Determination retF 224 | r = r 225 | retEq = determinationProof 226 | in 227 | begin 228 | x1 t 229 | ≡⟨ sym $ retEq (x1 t) ⟩ 230 | ((r ∘ f) ∘ x1) t 231 | ≡⟨ cong r eq ⟩ 232 | ((r ∘ f) ∘ x2) t 233 | ≡⟨ retEq (x2 t) ⟩ 234 | x2 t 235 | ∎ 236 | 237 | epimorphicDetermination : 238 | {A B : Set} {f : A -> B} {T : Set} -> {t1 t2 : B -> T} -> 239 | HasSection f -> 240 | ((a : A) -> (t1 ∘ f) a ≡ (t2 ∘ f) a) -> 241 | (b : B) -> 242 | t1 b ≡ t2 b 243 | epimorphicDetermination {f = f} {t1 = t1} {t2 = t2} secF eq b = 244 | let open Choice secF 245 | s = s 246 | secEq = choiceProof 247 | in 248 | begin 249 | t1 b 250 | ≡⟨ sym $ cong t1 $ secEq b ⟩ 251 | (t1 ∘ (f ∘ s)) b 252 | ≡⟨ eq (s b) ⟩ 253 | ((t2 ∘ f) ∘ s) b 254 | ≡⟨ cong t2 $ secEq b ⟩ 255 | t2 b 256 | ∎ 257 | 258 | retractionComposition : 259 | {A B C : Set} -> {f : A -> B} -> {g : B -> C} -> 260 | HasRetract f -> 261 | HasRetract g -> 262 | HasRetract (g ∘ f) 263 | retractionComposition {f = f} record { r = r₁ ; determinationProof = retEq₁ } record { r = r ; determinationProof = retEq } = 264 | record 265 | { r = r₁ ∘ r 266 | ; determinationProof = \a -> trans (cong r₁ $ retEq (f a)) (retEq₁ a) 267 | } 268 | 269 | record Idempotent {A : Set } (e : A -> A) : Set where 270 | field 271 | idempotentProof : e ∘ e ≡ e 272 | 273 | idempotentSplit : 274 | {A B : Set} -> {s : A -> B} -> {r : B -> A} -> 275 | s ∘ r ≡ id -> 276 | Idempotent (s ∘ r) 277 | idempotentSplit {s = s} {r = r} proof rewrite proof = 278 | record { idempotentProof = refl } 279 | 280 | -- examples 281 | -- f : Int -> Bool 282 | -- s : Bool -> Int 283 | -- f = isEven 284 | -- s = toBinary 285 | -- isEven . toBinary = id 286 | 287 | open import Agda.Builtin.Nat 288 | open import Data.String 289 | 290 | isOdd : Nat -> Bool 291 | isOdd zero = false 292 | isOdd (suc n) = not $ isOdd n 293 | 294 | toBinary : Bool -> Nat 295 | toBinary false = zero 296 | toBinary true = suc zero 297 | 298 | sectionExample : HasSection (isOdd) 299 | Choice.s sectionExample = toBinary 300 | Choice.choiceProof sectionExample = λ {true -> refl; false -> refl} 301 | 302 | -- sectionExample2 : HasSection (toBinary) 303 | -- Choice.s sectionExample2 = isOdd 304 | -- Choice.choiceProof sectionExample2 zero = refl 305 | -- Choice.choiceProof sectionExample2 (suc zero) = refl 306 | -- Choice.choiceProof sectionExample2 (suc (suc a)) = 307 | 308 | JSON = String 309 | 310 | data World : Set where 311 | WorldLiteral : World 312 | 313 | record Request : Set where 314 | field hello : World 315 | 316 | open import Data.Maybe 317 | 318 | parseJson : JSON -> Maybe Request 319 | parseJson "{ hello: world }" = just $ record { hello = WorldLiteral } 320 | parseJson _ = nothing 321 | 322 | serializeJson : Maybe Request -> JSON 323 | serializeJson (just record { hello = WorldLiteral }) = "{ hello: world }" 324 | serializeJson nothing = "{}" 325 | 326 | retractExample : HasRetract serializeJson 327 | Determination.r retractExample = parseJson 328 | Determination.determinationProof retractExample = 329 | λ 330 | { nothing -> refl 331 | ; (just (record {hello = WorldLiteral})) -> refl 332 | } 333 | 334 | -- 4. Isomorphisms and automorphisms 335 | 336 | record HasIsomorphism {A B : Set} (f : A -> B) : Set where 337 | field 338 | f-section : HasSection f 339 | f-retraction : HasRetract f 340 | iso-proof : (b : B) -> f-section .Choice.s b ≡ f-retraction .Determination.r b 341 | 342 | f-inverse : B -> A 343 | f-inverse = f-section .Choice.s 344 | 345 | f-inverse-proof-l : (a : A) -> f-inverse (f a) ≡ a 346 | f-inverse-proof-l a = 347 | begin 348 | (f-inverse (f a)) 349 | ≡⟨ iso-proof (f a) ⟩ 350 | ((Determination.r f-retraction ∘ f) a) 351 | ≡⟨ Determination.determinationProof f-retraction a ⟩ 352 | a 353 | ∎ 354 | 355 | f-inverse-proof-r : (b : B) -> f (f-inverse b) ≡ b 356 | f-inverse-proof-r b = 357 | begin 358 | f (f-inverse b) 359 | ≡⟨ Choice.choiceProof f-section b ⟩ 360 | b 361 | ∎ 362 | 363 | open HasIsomorphism 364 | 365 | isomorphismComposition : 366 | {A B C : Set} -> {f : A -> B} -> {g : B -> C} -> 367 | HasIsomorphism f -> 368 | HasIsomorphism g -> 369 | HasIsomorphism (g ∘ f) 370 | isomorphismComposition 371 | {f = f} 372 | {g = g} 373 | record { f-section = f-section₁ ; f-retraction = f-retraction₁ ; iso-proof = iso-proof₁ } 374 | record { f-section = f-section ; f-retraction = f-retraction ; iso-proof = iso-proof } = 375 | let gs = f-section .Choice.s 376 | fs = f-section₁ .Choice.s 377 | gSecProof = f-section .Choice.choiceProof 378 | fSecProof = f-section₁ .Choice.choiceProof 379 | gr = Determination.r f-retraction 380 | fr = Determination.r f-retraction₁ 381 | gRetProof = Determination.determinationProof f-retraction 382 | fRetProof = Determination.determinationProof f-retraction₁ 383 | in record { f-section = 384 | chooses 385 | (fs ∘ gs) 386 | λ c → 387 | begin 388 | g (f (fs (gs c))) 389 | ≡⟨ cong g (fSecProof (gs c)) ⟩ 390 | g (f-section .Choice.s c) 391 | ≡⟨ gSecProof c ⟩ 392 | c 393 | ∎ 394 | ; f-retraction = 395 | determines 396 | (fr ∘ gr) 397 | λ a → 398 | begin 399 | (fr ∘ gr ∘ g ∘ f) a 400 | ≡⟨ cong fr (gRetProof (f a))⟩ 401 | (fr ∘ f) a 402 | ≡⟨ fRetProof a ⟩ 403 | a 404 | ∎ 405 | ; iso-proof = 406 | λ b → 407 | begin 408 | (fs ∘ gs) b 409 | ≡⟨ iso-proof₁ (gs b) ⟩ 410 | (fr ∘ gs) b 411 | ≡⟨ cong fr (iso-proof b)⟩ 412 | (fr ∘ gr) b 413 | ∎ 414 | } 415 | 416 | ex10 : {A B C : Set} -> {f : A -> B} -> {g : B -> C} -> HasIsomorphism f -> HasIsomorphism g -> HasIsomorphism (g ∘ f) 417 | ex10 {f = f} {g} f-iso g-iso = 418 | record 419 | { f-section = chooses (f-inverse f-iso ∘ f-inverse g-iso) $ \ a -> 420 | begin 421 | (g ∘ f ∘ f-inverse f-iso ∘ f-inverse g-iso) a 422 | ≡⟨ cong g $ f-inverse-proof-r f-iso $ f-inverse g-iso a ⟩ 423 | (g ∘ f-inverse g-iso) a 424 | ≡⟨ f-inverse-proof-r g-iso a ⟩ 425 | a 426 | ∎ 427 | ; f-retraction = determines (f-inverse f-iso ∘ f-inverse g-iso) $ \ a -> 428 | begin 429 | (f-inverse f-iso ∘ f-inverse g-iso ∘ g ∘ f) a 430 | ≡⟨ cong (f-inverse f-iso) $ f-inverse-proof-l g-iso (f a) ⟩ 431 | (f-inverse f-iso ∘ f) a 432 | ≡⟨ f-inverse-proof-l f-iso a ⟩ 433 | a 434 | ∎ 435 | ; iso-proof = \ b -> refl 436 | } 437 | 438 | ex11 : HasIsomorphism (forward abIso) 439 | ex11 = record 440 | { f-section = chooses (backward abIso) (fInverse abIso) 441 | ; f-retraction = determines (backward abIso) (bInverse abIso) 442 | ; iso-proof = \x -> refl 443 | } 444 | 445 | -- do it with copatterns! 446 | ex11' : HasIsomorphism (forward abIso) 447 | Choice.s (f-section ex11') = backward abIso 448 | Choice.choiceProof (f-section ex11') = fInverse abIso 449 | Determination.r (f-retraction ex11') = backward abIso 450 | Determination.determinationProof (f-retraction ex11') = bInverse abIso 451 | iso-proof ex11' x = refl 452 | 453 | isPapa : SetA -> Bool 454 | isPapa Father = true 455 | isPapa _ = false 456 | 457 | ex11₂ : HasIsomorphism isPapa -> ⊥ 458 | ex11₂ iso with (trans (sym $ f-inverse-proof-l iso Mother) $ f-inverse-proof-l iso Child) 459 | ... | () 460 | 461 | Automorphism : Set -> Set 462 | Automorphism A = Isomorphism A A 463 | 464 | hasIso-to-Iso : {A B : Set} {f : A -> B} -> HasIsomorphism f -> Isomorphism A B 465 | forward (hasIso-to-Iso {f = f} iso) = f 466 | backward (hasIso-to-Iso iso) = f-inverse iso 467 | fInverse (hasIso-to-Iso iso) = f-inverse-proof-r iso 468 | bInverse (hasIso-to-Iso iso) = f-inverse-proof-l iso 469 | 470 | 471 | sym-sym-id : {A B : Set} -> (iso : Isomorphism A B) -> iso ≡ symmetricIso (symmetricIso iso) 472 | sym-sym-id iso = refl 473 | 474 | postulate 475 | extensionality : {S : Set}{T : S -> Set} 476 | {f g : (x : S) -> T x} -> 477 | ((x : S) -> f x ≡ g x) -> 478 | f ≡ g 479 | 480 | uip : {A : Set} -> {x y : A} -> (p q : x ≡ y) -> p ≡ q 481 | uip refl refl = refl 482 | 483 | iso-ext 484 | : {A B : Set} {f-iso g-iso : Isomorphism A B} 485 | -> ((a : A) -> forward f-iso a ≡ forward g-iso a) 486 | -> ((b : B) -> backward f-iso b ≡ backward g-iso b) 487 | -> f-iso ≡ g-iso 488 | iso-ext 489 | {f-iso = record { fInverse = fInverse₁ ; bInverse = bInverse₁ }} 490 | {g-iso = record { fInverse = fInverse ; bInverse = bInverse }} 491 | f-eq b-eq rewrite extensionality f-eq 492 | | extensionality b-eq 493 | | extensionality (\a -> uip (fInverse a) (fInverse₁ a)) 494 | | extensionality (\a -> uip (bInverse a) (bInverse₁ a)) 495 | = refl 496 | 497 | 498 | sym-fwd-id : {A B : Set} -> (iso : Isomorphism A B) -> reflexiveIso ≡ transitiveIso iso (symmetricIso iso) 499 | sym-fwd-id iso = iso-ext (sym ∘ bInverse iso) \b -> 500 | begin 501 | backward reflexiveIso b 502 | ≡⟨⟩ 503 | b 504 | ≡⟨ sym $ bInverse iso b ⟩ 505 | (backward iso ∘ forward iso) b 506 | ≡⟨⟩ 507 | (backward iso ∘ backward (symmetricIso iso)) b 508 | ≡⟨⟩ 509 | backward (transitiveIso iso (symmetricIso iso)) b 510 | ∎ 511 | 512 | sym-bwd-id : {A B : Set} -> (iso : Isomorphism A B) -> reflexiveIso ≡ transitiveIso (symmetricIso iso) iso 513 | sym-bwd-id iso = 514 | begin 515 | reflexiveIso 516 | ≡⟨ sym-fwd-id (symmetricIso iso) ⟩ 517 | transitiveIso (symmetricIso iso) (symmetricIso (symmetricIso iso)) 518 | ≡⟨ cong (transitiveIso (symmetricIso iso)) $ sym $ sym-sym-id iso ⟩ 519 | transitiveIso (symmetricIso iso) iso 520 | ∎ 521 | 522 | trans-reflex-iso : {A B : Set} -> (iso : Isomorphism A B) -> iso ≡ transitiveIso iso reflexiveIso 523 | trans-reflex-iso _ = iso-ext (\a -> refl) (\b -> refl) 524 | 525 | trans-iso 526 | : {A B C D : Set} 527 | -> (isoAB : Isomorphism A B) 528 | -> (isoBC : Isomorphism B C) 529 | -> (isoCD : Isomorphism C D) 530 | -> transitiveIso isoAB (transitiveIso isoBC isoCD) ≡ transitiveIso (transitiveIso isoAB isoBC) isoCD 531 | trans-iso _ _ _ = iso-ext (\a -> refl) (\b -> refl) 532 | 533 | 534 | -- This is not an iff; the number of autos are the same as the number of isos 535 | -- ONLY IF it has isos in the first place! 536 | autoIsos : {A B : Set} {f : A -> B} -> HasIsomorphism f -> Isomorphism (Automorphism A) (Isomorphism A B) 537 | autoIsos {A} {B} {f} f-iso = 538 | let F : Automorphism A -> Isomorphism A B 539 | F α = transitiveIso α $ hasIso-to-Iso f-iso 540 | 541 | S : Isomorphism A B -> Automorphism A 542 | S g = transitiveIso g $ symmetricIso $ hasIso-to-Iso f-iso 543 | in record { forward = F 544 | ; backward = S 545 | ; fInverse = \a -> 546 | let iso-of-f = hasIso-to-Iso f-iso 547 | in 548 | begin 549 | transitiveIso (transitiveIso a (symmetricIso iso-of-f)) iso-of-f 550 | ≡⟨ sym $ trans-iso a (symmetricIso iso-of-f) iso-of-f ⟩ 551 | transitiveIso a (transitiveIso (symmetricIso iso-of-f) iso-of-f) 552 | ≡⟨ cong (transitiveIso a) $ sym $ sym-bwd-id iso-of-f ⟩ 553 | transitiveIso a reflexiveIso 554 | ≡⟨ sym $ trans-reflex-iso a ⟩ 555 | a 556 | ∎ 557 | ; bInverse = \a -> 558 | let iso-of-f = hasIso-to-Iso f-iso 559 | in 560 | begin 561 | transitiveIso (transitiveIso a iso-of-f) (symmetricIso iso-of-f) 562 | ≡⟨ sym $ trans-iso a iso-of-f (symmetricIso iso-of-f) ⟩ 563 | transitiveIso a (transitiveIso iso-of-f $ symmetricIso iso-of-f) 564 | ≡⟨ cong (transitiveIso a) $ sym $ sym-fwd-id iso-of-f ⟩ 565 | transitiveIso a reflexiveIso 566 | ≡⟨ sym $ trans-reflex-iso a ⟩ 567 | a 568 | ∎ 569 | } 570 | 571 | -------------------------------------------------------------------------------- /src/Permutations.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --type-in-type #-} 2 | module Permutations where 3 | 4 | open import Function hiding (id) 5 | open import Data.Empty 6 | open import Data.Product 7 | import Relation.Binary.PropositionalEquality as Eq 8 | open Eq using (_≡_; refl; cong; sym; trans) 9 | open Eq.≡-Reasoning using (begin_; _≡⟨⟩_; _∎; step-≡) 10 | open import Function.Reasoning 11 | open import Old.Isomorphisms 12 | 13 | record Category : Set where 14 | infix 6 _~>_ 15 | field 16 | Obj : Set 17 | _~>_ : (A B : Obj) → Set 18 | 19 | id : {A : Obj} → A ~> A 20 | _>>_ : {A B C : Obj} → A ~> B → B ~> C → A ~> C 21 | 22 | id-l : {A B : Obj} (f : A ~> B) → id >> f ≡ f 23 | id-r : {A B : Obj} (f : A ~> B) → f >> id ≡ f 24 | >>-assoc : {A B C D : Obj} (f : A ~> B) → (g : B ~> C) → (h : C ~> D) → f >> (g >> h) ≡ (f >> g) >> h 25 | 26 | 27 | infix 5 _[_,_] 28 | _[_,_] : (C : Category) -> Category.Obj C -> Category.Obj C -> Set 29 | C [ X , Y ] = Category._~>_ C X Y 30 | 31 | infix 5 _[_>>_] 32 | _[_>>_] : (C : Category) -> {X Y Z : Category.Obj C} -> C [ X , Y ] -> C [ Y , Z ] -> C [ X , Z ] 33 | C [ f >> g ] = Category._>>_ C f g 34 | 35 | 36 | SET : Category 37 | SET = record 38 | { Obj = Set 39 | ; _~>_ = \ S T → S → T 40 | ; id = \ x → x 41 | ; _>>_ = λ f g x → g (f x) 42 | ; id-l = \f -> refl 43 | ; id-r = \f -> refl 44 | ; >>-assoc = \f g h -> refl 45 | } 46 | 47 | -- f ∘ α ≡ β ∘ f 48 | open Category 49 | 50 | record PermObj : Set where 51 | field 52 | permCarrier : Set 53 | permAuto : Automorphism permCarrier 54 | 55 | open Isomorphism 56 | open PermObj 57 | 58 | record PermArrow ( A B : PermObj ) : Set where 59 | field 60 | ⟳_ : permCarrier A -> permCarrier B 61 | permArrowLaw : (x : permCarrier A) -> (⟳_ ∘ forward (permAuto A)) x ≡ (forward (permAuto B) ∘ ⟳_) x 62 | 63 | open PermArrow 64 | 65 | PERM : Category 66 | Category.Obj PERM = PermObj 67 | Category._~>_ PERM = PermArrow 68 | ⟳ (Category.id PERM) = SET .id 69 | permArrowLaw (Category.id PERM) x = refl 70 | (_>>_ PERM {A = A} {B = B} {C = C} 71 | record { ⟳_ = f⟳ ; permArrowLaw = flaw }) 72 | record { ⟳_ = g⟳ ; permArrowLaw = glaw } = 73 | record { ⟳_ = g⟳ ∘ f⟳ 74 | ; permArrowLaw = λ x → 75 | begin 76 | (g⟳ ∘ f⟳ ∘ forward (permAuto A)) x 77 | ≡⟨ cong g⟳ (flaw x)⟩ 78 | (g⟳ ∘ (forward (permAuto B)) ∘ f⟳) x 79 | ≡⟨ glaw (f⟳ x) ⟩ 80 | (forward (permAuto C) ∘ g⟳ ∘ f⟳) x 81 | ∎ 82 | } 83 | Category.id-l PERM = ? 84 | Category.id-r PERM = ? 85 | Category.>>-assoc PERM = ? 86 | 87 | -------------------------------------------------------------------------------- /src/SectionsAndRetractions.agda: -------------------------------------------------------------------------------- 1 | open import Categories 2 | 3 | module SectionsAndRetractions (C : Category) where 4 | 5 | open Category C 6 | 7 | record Determination {X Y Z : Obj} (h : X ~> Z) (f : X ~> Y) : Set where 8 | constructor determines 9 | field 10 | r : Y ~> Z 11 | commute : r ∘ f ≈ h 12 | 13 | HasRetract : {A B : Obj} (f : A ~> B) -> Set 14 | HasRetract = Determination id 15 | 16 | record Choice {X Y Z : Obj} (h : X ~> Z) (g : Y ~> Z) : Set where 17 | constructor chooses 18 | field 19 | s : X ~> Y 20 | commute : g ∘ s ≈ h 21 | 22 | HasSection : {A B : Obj} (f : A ~> B) -> Set 23 | HasSection = Choice id 24 | 25 | -------------------------------------------------------------------------------- /src/Session4/Section4.agda: -------------------------------------------------------------------------------- 1 | module Session4.Section4 where 2 | 3 | open import Categories 4 | open import Category.MON 5 | open Category MON 6 | 7 | open import Algebra.Bundles using (Monoid) 8 | open import Algebra.Structures 9 | open Monoid 10 | 11 | open import Relation.Binary.Structures 12 | import Relation.Binary.PropositionalEquality as Eq 13 | open Eq using (_≡_) 14 | 15 | module _ where 16 | 17 | open import Data.Rational 18 | open import Data.Integer using (0ℤ; 1ℤ; +_) 19 | open import Data.Rational.Properties 20 | 21 | 22 | ratPlus : Obj 23 | Carrier ratPlus = _ 24 | _≈_ ratPlus = _ 25 | _∙_ ratPlus = _ 26 | ε ratPlus = _ 27 | isMonoid ratPlus = +-0-isMonoid 28 | 29 | ratTimes : Obj 30 | Carrier ratTimes = _ 31 | _≈_ ratTimes = _ 32 | _∙_ ratTimes = _ 33 | ε ratTimes = _ 34 | isMonoid ratTimes = *-1-isMonoid 35 | 36 | open import Data.Rational.Solver 37 | open +-*-Solver 38 | 39 | d : ratPlus ~> ratPlus 40 | MonArr.map d x = x + x 41 | MonArr.commutes d = solve 2 (\a b → (a :+ b) :+ (a :+ b) := (a :+ a) :+ (b :+ b)) Eq.refl 42 | MonArr.preserves-≈ d a a' eq rewrite eq = Eq.refl 43 | 44 | open import Isomorphisms MON 45 | open Isomorphism 46 | 47 | half : ℚ 48 | half = normalize 1 2 49 | 50 | h : ratPlus ~> ratPlus 51 | MonArr.map h x = x * half 52 | MonArr.commutes h = solve 2 (\a b → (a :+ b) :* con half := (a :* con half) :+ (b :* con half)) Eq.refl 53 | MonArr.preserves-≈ h a b eq rewrite eq = Eq.refl 54 | 55 | ex1 : Isomorphism ratPlus ratPlus 56 | forward ex1 = d 57 | backward ex1 = h 58 | fInverse ex1 = solve 1 (\a → a :* con half :+ a :* con half := a) Eq.refl 59 | bInverse ex1 = solve 1 (\a → (a :+ a) :* con half := a) Eq.refl 60 | 61 | module Ex3 where 62 | mQ : ℚ → ℚ 63 | mQ x = - x 64 | 65 | open Isomorphism 66 | 67 | m : ratPlus ~> ratPlus 68 | MonArr.map m = mQ 69 | MonArr.commutes m a b = 70 | begin 71 | - (a + b) 72 | ≡⟨ neg-distrib-+ a b ⟩ 73 | - a + - b 74 | ∎ 75 | where open Eq.≡-Reasoning 76 | MonArr.preserves-≈ m a a' x rewrite x = Eq.refl 77 | 78 | open import Data.Nat using (zero; suc) 79 | neg-neg : ∀ a → - (- a) ≡ a 80 | neg-neg (mkℚ (+_ zero) denominator-1 isCoprime) = Eq.refl 81 | neg-neg (mkℚ +[1+ n ] denominator-1 isCoprime) = Eq.refl 82 | neg-neg (mkℚ (Data.Integer.-[1+_] n) denominator-1 isCoprime) = Eq.refl 83 | 84 | minv : Isomorphism ratPlus ratPlus 85 | forward minv = m 86 | backward minv = m 87 | fInverse minv = neg-neg 88 | bInverse minv = neg-neg 89 | 90 | 91 | module Ex2 where 92 | 93 | data Oddity : Set where 94 | even : Oddity 95 | odd : Oddity 96 | 97 | _o+_ : Oddity → Oddity → Oddity 98 | even o+ a = a 99 | odd o+ even = odd 100 | odd o+ odd = even 101 | 102 | data Signedness : Set where 103 | positive : Signedness 104 | negative : Signedness 105 | 106 | _s*_ : Signedness → Signedness → Signedness 107 | positive s* b = b 108 | negative s* positive = negative 109 | negative s* negative = positive 110 | 111 | open IsMonoid 112 | open import Data.Product 113 | 114 | odd+ : Obj 115 | Carrier odd+ = Oddity 116 | _≈_ odd+ = _≡_ 117 | _∙_ odd+ = _o+_ 118 | ε odd+ = even 119 | IsEquivalence.refl (IsMagma.isEquivalence (IsSemigroup.isMagma (isSemigroup (isMonoid odd+)))) = Eq.refl 120 | IsEquivalence.sym (IsMagma.isEquivalence (IsSemigroup.isMagma (isSemigroup (isMonoid odd+)))) = Eq.sym 121 | IsEquivalence.trans (IsMagma.isEquivalence (IsSemigroup.isMagma (isSemigroup (isMonoid odd+)))) = Eq.trans 122 | IsMagma.∙-cong (IsSemigroup.isMagma (isSemigroup (isMonoid odd+))) eq1 eq2 rewrite eq1 | eq2 = Eq.refl 123 | IsSemigroup.assoc (isSemigroup (isMonoid odd+)) = λ { even even even → Eq.refl 124 | ; even even odd → Eq.refl 125 | ; even odd even → Eq.refl 126 | ; even odd odd → Eq.refl 127 | ; odd even even → Eq.refl 128 | ; odd even odd → Eq.refl 129 | ; odd odd even → Eq.refl 130 | ; odd odd odd → Eq.refl 131 | } 132 | proj₁ (identity (isMonoid odd+)) x = Eq.refl 133 | proj₂ (identity (isMonoid odd+)) even = Eq.refl 134 | proj₂ (identity (isMonoid odd+)) odd = Eq.refl 135 | 136 | sign* : Obj 137 | Carrier sign* = Signedness 138 | _≈_ sign* = _≡_ 139 | _∙_ sign* = _s*_ 140 | ε sign* = positive 141 | IsEquivalence.refl (IsMagma.isEquivalence (IsSemigroup.isMagma (isSemigroup (isMonoid sign*)))) = Eq.refl 142 | IsEquivalence.sym (IsMagma.isEquivalence (IsSemigroup.isMagma (isSemigroup (isMonoid sign*)))) = Eq.sym 143 | IsEquivalence.trans (IsMagma.isEquivalence (IsSemigroup.isMagma (isSemigroup (isMonoid sign*)))) = Eq.trans 144 | IsMagma.∙-cong (IsSemigroup.isMagma (isSemigroup (isMonoid sign*))) eq1 eq2 rewrite eq1 | eq2 = Eq.refl 145 | IsSemigroup.assoc (isSemigroup (isMonoid sign*)) = λ { positive positive positive → Eq.refl 146 | ; positive positive negative → Eq.refl 147 | ; positive negative positive → Eq.refl 148 | ; positive negative negative → Eq.refl 149 | ; negative positive positive → Eq.refl 150 | ; negative positive negative → Eq.refl 151 | ; negative negative positive → Eq.refl 152 | ; negative negative negative → Eq.refl 153 | } 154 | proj₁ (identity (isMonoid sign*)) x = Eq.refl 155 | proj₂ (identity (isMonoid sign*)) positive = Eq.refl 156 | proj₂ (identity (isMonoid sign*)) negative = Eq.refl 157 | 158 | open import Isomorphisms MON 159 | open Isomorphism 160 | 161 | ex2 : Isomorphism odd+ sign* 162 | MonArr.map (forward ex2) even = positive 163 | MonArr.map (forward ex2) odd = negative 164 | MonArr.commutes (forward ex2) even even = Eq.refl 165 | MonArr.commutes (forward ex2) even odd = Eq.refl 166 | MonArr.commutes (forward ex2) odd even = Eq.refl 167 | MonArr.commutes (forward ex2) odd odd = Eq.refl 168 | MonArr.preserves-≈ (forward ex2) even even x = Eq.refl 169 | MonArr.preserves-≈ (forward ex2) odd odd x = Eq.refl 170 | MonArr.map (backward ex2) positive = even 171 | MonArr.map (backward ex2) negative = odd 172 | MonArr.commutes (backward ex2) positive positive = Eq.refl 173 | MonArr.commutes (backward ex2) positive negative = Eq.refl 174 | MonArr.commutes (backward ex2) negative positive = Eq.refl 175 | MonArr.commutes (backward ex2) negative negative = Eq.refl 176 | MonArr.preserves-≈ (backward ex2) positive positive x = Eq.refl 177 | MonArr.preserves-≈ (backward ex2) negative negative x = Eq.refl 178 | fInverse ex2 positive = Eq.refl 179 | fInverse ex2 negative = Eq.refl 180 | bInverse ex2 even = Eq.refl 181 | bInverse ex2 odd = Eq.refl 182 | 183 | -------------------------------------------------------------------------------- /src/Session5/Section3.agda: -------------------------------------------------------------------------------- 1 | 2 | module Session5.Section3 where 3 | 4 | open import Categories 5 | open import Category.SET 6 | open import SectionsAndRetractions SET 7 | 8 | open Category SET 9 | 10 | data One : Set where 11 | one : One 12 | 13 | import Relation.Binary.PropositionalEquality as Eq 14 | open Eq using (_≡_; refl; cong; sym) 15 | open Eq.≡-Reasoning 16 | 17 | ex1 : ∀ {A B C} {h : A → C} {g : B → C} {f : A → B} → (h ≈ g ∘ f) → (a1 a2 : One → A) → f ∘ a1 ≈ f ∘ a2 → h ∘ a1 ≈ h ∘ a2 18 | ex1 {h = h} {g} {f} hgfeq a1 a2 feq x = 19 | begin 20 | (h ∘ a1) x 21 | ≡⟨ hgfeq (a1 x) ⟩ 22 | ((g ∘ f) ∘ a1) x 23 | ≡⟨⟩ 24 | (g ∘ (f ∘ a1)) x 25 | ≡⟨ cong g (feq x) ⟩ 26 | (g ∘ (f ∘ a2)) x 27 | ≡⟨⟩ 28 | ((g ∘ f) ∘ a2) x 29 | ≡⟨ sym (hgfeq (a2 x)) ⟩ 30 | (h ∘ a2) x 31 | ∎ 32 | 33 | open import Data.Product 34 | 35 | ex2-a : ∀ {A B C} {h : A → C} {g : B → C} {f : A → B} → (h ≈ g ∘ f) → (a : A) → Σ B (\b → h a ≡ g b) 36 | proj₁ (ex2-a {h = h} {g} {f} hgfeq a) = f a 37 | proj₂ (ex2-a {h = h} {g} {f} hgfeq a) rewrite hgfeq a = refl 38 | 39 | data Void : Set where 40 | 41 | const : {A B : Set} → A → B → A 42 | const a _ = a 43 | 44 | data Bool : Set where 45 | true : Bool 46 | false : Bool 47 | 48 | -- Intuition: no! Not if g is const. 49 | ex2-b : (∀ {A B C} {h : A → C} {g : B → C} → (a : A) → Σ B (\b → h a ≡ g b) → Σ (A → B) (\f → h ≈ g ∘ f)) → Void 50 | ex2-b hyp with hyp {h = id} {g = const true} true (true , refl) 51 | ... | _ , snd with snd false 52 | ... | () 53 | 54 | 55 | --------------------------------------------------------------------------------