├── .gitignore ├── cs410-22.agda-lib ├── Common ├── NatProperties.agda ├── Category.agda └── Category │ ├── Adjunctions.agda │ └── Solver.agda ├── installation-linux.md ├── installation-win.md ├── README.md ├── Lectures ├── Week1.agda ├── Week4.agda ├── Week2.agda ├── Week5.agda ├── Week7.agda ├── Week3.agda ├── Week9.agda ├── Week8.agda ├── Week6.agda └── Week10.agda └── Coursework ├── Three ├── Bag.agda └── Categories.agda ├── Examples ├── Three.agda ├── strathclyde-shrunk.pgm └── One.agda ├── Three.agda ├── One.agda └── Two.agda /.gitignore: -------------------------------------------------------------------------------- 1 | *.agdai 2 | MAlonzo/** 3 | -------------------------------------------------------------------------------- /cs410-22.agda-lib: -------------------------------------------------------------------------------- 1 | depend: standard-library-1.7.1 2 | include: . 3 | -------------------------------------------------------------------------------- /Common/NatProperties.agda: -------------------------------------------------------------------------------- 1 | module Common.NatProperties where 2 | 3 | open import Data.Nat 4 | open import Data.Nat.Properties 5 | open import Relation.Binary.PropositionalEquality 6 | 7 | ------------------------------------------------------------------------ 8 | -- Properties of ⌊_/2⌋ and ⌈_/2⌉ 9 | ------------------------------------------------------------------------ 10 | 11 | n≡⌊n+n/2⌋ : ∀ n → n ≡ ⌊ n + n /2⌋ 12 | n≡⌊n+n/2⌋ zero = refl 13 | n≡⌊n+n/2⌋ (suc zero) = refl 14 | n≡⌊n+n/2⌋ (suc (suc n)) = 15 | cong suc (trans (n≡⌊n+n/2⌋ _) (cong ⌊_/2⌋ (sym (+-suc n (suc n))))) 16 | 17 | n≡⌈n+n/2⌉ : ∀ n → n ≡ ⌈ n + n /2⌉ 18 | n≡⌈n+n/2⌉ zero = refl 19 | n≡⌈n+n/2⌉ (suc zero) = refl 20 | n≡⌈n+n/2⌉ (suc (suc n)) = 21 | cong suc (trans (n≡⌈n+n/2⌉ _) (cong ⌈_/2⌉ (sym (+-suc n (suc n))))) 22 | -------------------------------------------------------------------------------- /installation-linux.md: -------------------------------------------------------------------------------- 1 | # Installing Agda on some kind of Linux 2 | 3 | This short guide will help you get Agda 2.6.2.2 running on a Linux machine. 4 | 5 | 0\. If using bash: Add "export PATH=$HOME/.cabal/bin:$PATH" to the bottom of your .profile file if it isn't already there. Else if using tcsh: Add "set path = ($home/.cabal/bin $path)" to the bottom of your .cshrc file if it isn't already there. 6 | 7 | 1\. Install the [GHC Haskell compiler](https://www.haskell.org/downloads/) either using a package managager, or using [GHCup](https://www.haskell.org/ghcup/). 8 | 9 | 2\. Run 10 | ``` 11 | cabal update 12 | cabal install alex happy Agda 13 | ``` 14 | This will compile Agda on your machine. The process might take very long time (> 30 minutes) and is quite memory intensive (make sure you have at least 4GB free). 15 | 16 | 4\. Install emacs, probably using a package manager. 17 | 18 | 5\. Run `agda-mode setup`. 19 | 20 | 6\. Get the [agda standard library](https://github.com/agda/agda-stdlib/releases/tag/v1.7.1). Unzip it to a destination of your choice, call that parent directory `$DIR`. 21 | 22 | 7\. Create a directory `~/.agda` by running `mkdir ~/.agda`. 23 | 24 | 8.\ Create the file `~/.agda/libraries` (note: no file extension!) and add the following line to it, replacing `$DIR` with the concrete path: 25 | ``` 26 | $DIR/agda-stdlib-1.7.1/standard-library.agda-lib 27 | ``` 28 | 29 | 8\. (OPTIONAL) Create `~/.agda/defaults` (again no file extension!) and add the following line to it: 30 | ``` 31 | standard-library 32 | ``` 33 | This means that all your files will know about the standard library by default. (The coursework, however, explicitly depends on the standard library, so it doesn't rely on this step.) 34 | 35 | 9\. That's it; if you open a file with a `.agda` extension in Emacs, you should see the Agda menu at the top. Happy hacking! 36 | -------------------------------------------------------------------------------- /installation-win.md: -------------------------------------------------------------------------------- 1 | # Installing Agda on Windows 10 2 | 3 | This short guide will help you get Agda 2.6.2.2 running on a Windows 10 machine. 4 | 5 | 1\. Install the Chocolatey package manager for Windows by following the instructions on the [Chocolatey installation page](https://chocolatey.org/install). Note that you will need an administrator PowerShell prompt. 6 | 7 | 2\. Install the [GHC Haskell compiler](https://community.chocolatey.org/packages/ghc) by running `choco install ghc` in a powershell. 8 | 9 | 3\. Run 10 | ``` 11 | cabal update 12 | cabal install alex happy Agda 13 | ``` 14 | This will compile Agda on your machine. The process might take very long time (> 30 minutes) and is quite memory intensive (make sure you have at least 4GB free). 15 | 16 | 4\. Install emacs. You can get a Windows installer from [here](https://ftp.gnu.org/gnu/emacs/windows/emacs-27/). 17 | 18 | 5\. Create `%appdata%\.emacs` (note: no additional file extension!) and paste in the following: 19 | ``` 20 | (load-file (let ((coding-system-for-read 'utf-8)) 21 | (shell-command-to-string "agda-mode locate"))) 22 | ``` 23 | (`%appdata%` usually expands to `C:\Users\\AppData\Roaming`). 24 | 25 | 6\. Get the [agda standard library](https://github.com/agda/agda-stdlib/releases/tag/v1.7.1). Unzip it to a destination of your choice, call that parent directory `$DIR`. 26 | 27 | 7\. Create `%appdata%\agda\libraries` (note: no file extension!) and add the following line to it, replacing `$DIR` with the concrete path: 28 | ``` 29 | $DIR\agda-stdlib-1.7.1\standard-library.agda-lib 30 | ``` 31 | 32 | 8\. (OPTIONAL) Create `%appdata%\agda\defaults` (again no file extension!) and add the following line to it: 33 | ``` 34 | standard-library 35 | ``` 36 | This means that all your files will know about the standard library by default. (The coursework, however, explicitly depends on the standard library, so it doesn't rely on this step.) 37 | 38 | 9\. Now you are ready to start working on your first coursework :slightly_smiling_face:. Good luck! 39 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # CS410 Advanced Functional Programming 2 | 3 | ## Lectures 4 | 5 | * Lecture 1: [Administrivia and getting started with Agda](https://youtu.be/3FZDy6zX_h4) (20 Sep) 6 | * Lecture 2: [Making use of precise types](https://youtu.be/37ENUdO8IVU) (22 Sep) 7 | * Lecture 3: [Logic in type theory](https://youtu.be/yDeI-HiC0wQ) (27 Sep) 8 | * Lecture 4: [Predicates, and basic equality](https://youtu.be/g2N_-sscq6c) (29 Sep) 9 | * Lecture 5: [Classical logic, and forall and exists](https://youtu.be/IYNFSE1-4yE) (4 Oct) 10 | * Lecture 6: [More about equality](https://youtu.be/NU6Ycmp19DE) (6 Oct) 11 | * Lecture 7: [Inductively defined relations](https://youtu.be/Wku5hdU402o) (11 oct) 12 | * Lecture 8: Discussion of Coursework 1 [no recording] (13 Oct) 13 | * Lecture 9: [Hutton's Razor](https://youtu.be/TbD9bTOTuUE) (18 Oct) 14 | * Lecture 10: [Relating typed and untyped expressions, and proving optimisations correct](https://youtu.be/ZVfpTZ359FM) (20 Oct) 15 | * Lecture 11: [Definition and examples of categories](https://youtu.be/vTZVdo2zRYM) (25 Oct) 16 | * Lecture 12: [Functors](https://youtu.be/a6Ex2N4NJO0) (27 Oct) 17 | * Lecture 13: [The category of categories, and natural transformations](https://youtu.be/HE96WiX_7Ww) (1 Nov) 18 | * Lecture 14: [Monads](https://youtu.be/7ag6f67xc5k) (3 Nov) 19 | * Lecture 15: [Kleisli categories](https://youtu.be/TX0daEBxc0E) (8 Nov) 20 | * Lecture 16: [Adjunctions](https://youtu.be/5x2c04gUQzM) (10 Nov) 21 | * Lecture 17: [Free categories](https://youtu.be/mSOQIz9Ap5o) (15 Nov) 22 | * Lecture 18: [The free-forgetful adjunction for categories, and monads from adjunctions](https://youtu.be/GWLIMXxu-bw) (17 Nov) 23 | * Lecture 19: [Every monad arises from an adjunction](https://youtu.be/IX8GuKzgh8o) (22 Nov) 24 | * Lecture 20: Cancelled due to [deteriorating pension and working conditions in UK higher education](https://www.ucu.org.uk/article/12469/FAQs) (24 Nov) 25 | 26 | ## Coursework 27 | 28 | * [Coursework.One](Coursework/One.agda) due Monday 10 October (beginning of Week 4) 29 | * [Coursework.Two](Coursework/Two.agda) due Monday 31 October (beginning of Week 7) 30 | * [Coursework.Three](Coursework/Three.agda) due Monday 5 October (beginning of Week 12) 31 | -------------------------------------------------------------------------------- /Lectures/Week1.agda: -------------------------------------------------------------------------------- 1 | module Lectures.Week1 where 2 | 3 | {- Administrivia -} 4 | 5 | -- Welcome to CS410 Advanced Functional Programming 6 | 7 | -- The team: 8 | -- Fredrik Nordvall Forsberg 9 | -- Sean Watters 10 | -- Georgi Nakov 11 | -- Conor McBride 12 | 13 | -- Mattermost: 14 | -- https://mattermost.cis.strath.ac.uk/learning/channels/cs410-22-23 15 | 16 | -- One minute papers: 17 | -- please fill them in (will be used for feedback, and taking attendance) 18 | 19 | -- Covid: 20 | -- help yourself to a mask 21 | -- if you are sick, STAY HOME; you can watch on Zoom if you have to 22 | 23 | 24 | -- Timetable: 25 | -- Tue 12noon lab LT1221 26 | -- Tue 2pm lecture LT714 <-- you are here 27 | -- Tue 3pm-5pm lab LT1221 28 | -- Thu 10am lecture SW108 29 | 30 | -- Assessment: 100% Coursework 31 | 32 | -- One 30% due Monday 10 October (W4) 33 | -- Two 30% due Monday 31 October (W7) 34 | -- Three 40% due Monday 5 December (W12) 35 | 36 | -- Submitting the coursework 37 | 38 | -- 1. Make a private repo somewhere, invite me to it 39 | -- 2. Add class repo as new remote 40 | -- 3. Pull from class repo, push to your repo 41 | -- 4. Let me know when you are done 42 | -- 5. Schedule an appointment to discuss at least one coursework 43 | 44 | {- Getting started with Agda -} 45 | 46 | -- This is a comment 47 | 48 | {- And this is a multiline comment. 49 | 50 | Useful key-bindings: 51 | 52 | C-c C-l load file 53 | 54 | -} 55 | 56 | const : {A B : Set} -> A -> B -> A 57 | const a = λ _ → a 58 | 59 | data List (X : Set) : Set where 60 | [] : List X 61 | _::_ : X -> List X -> List X 62 | 63 | append : {X : Set} -> List X -> List X -> List X 64 | append [] ys = ys 65 | append (x :: xs) ys = x :: append xs ys 66 | 67 | open import Data.Nat 68 | open import Data.Bool 69 | 70 | {- 71 | _!!_ : ∀ {A} → List A -> ℕ -> A 72 | [] !! n = {!!} 73 | (x :: xs) !! zero = x 74 | (x :: xs) !! suc n = xs !! n 75 | -} 76 | 77 | open import Data.Maybe 78 | 79 | {- 80 | _!!_ : ∀ {A} → List A -> ℕ -> Maybe A 81 | [] !! n = nothing 82 | (x :: xs) !! zero = just x 83 | (x :: xs) !! suc n = xs !! n 84 | -} 85 | 86 | -- precise version -- (C) 87 | data Vec (X : Set) : ℕ -> Set where 88 | [] : Vec X zero 89 | _::_ : ∀ {n} -> X -> Vec X n -> Vec X (suc n) 90 | 91 | data Fin : ℕ -> Set where 92 | zero : ∀ {n} -> Fin (suc n) 93 | suc : ∀ {n} -> Fin n -> Fin (suc n) 94 | 95 | _!!_ : ∀ {A n} → Vec A n -> Fin n -> A 96 | [] !! () 97 | (x :: xs) !! zero = x 98 | (x :: xs) !! suc n = xs !! n 99 | 100 | 101 | 102 | find : {A : Set}{n : ℕ} -> (A -> Bool) -> Vec A n -> Maybe (Fin n) 103 | find p [] = nothing 104 | find p (x :: xs) with p x 105 | find p (x :: xs) | false with find p xs 106 | find p (x :: xs) | false | just k = just (suc k) 107 | find p (x :: xs) | false | nothing = nothing 108 | find p (x :: xs) | true = just zero 109 | -------------------------------------------------------------------------------- /Coursework/Three/Bag.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --allow-unsolved-metas #-} 2 | module Coursework.Three.Bag where 3 | 4 | open import Data.List 5 | using (List; []; _∷_; _++_; map; foldr) 6 | open import Data.List.Properties 7 | using (++-assoc; ++-identityˡ; ++-identityʳ; 8 | map-++-commute; map-id; map-compose; 9 | foldr-universal) 10 | open import Relation.Binary.PropositionalEquality 11 | 12 | open import Common.Category 13 | open import Common.Category.Adjunctions 14 | 15 | open import Coursework.Three.Categories 16 | 17 | open Monoid 18 | open MonoidMorphism 19 | open Functor 20 | 21 | {- ??? 3.8 Implement bags as /free monoids/: given a set A, we want 22 | Bag A to be the smallest monoid containing the elements of 23 | A. I've given you the first move: the carrier of the monoid 24 | can be taken as lists of elements from A (you can think of 25 | them as a "formal" multiplication of all the elements in 26 | the list). In fact, show that this construction of a monoid 27 | from every set extends to a functor from SET to MONOID. 28 | 29 | In order to not rely on implementation details in the rest 30 | of the library, we construct this functor in an `abstract` 31 | block. This means that outside of abstract blocks in this 32 | file, equations will not reduce; hence in theory we could 33 | in secret supply a more efficient implementation, as long 34 | as we provide the same interface to the outside world. 35 | (3 MARKS) -} 36 | 37 | -- NOTE: Arguably, a better representation of bags would be as free 38 | -- /commutative/ monoids, that is monoids where the order does 39 | -- not matter. 40 | 41 | -- HINT: The import lists for this file are carefully curated. 42 | 43 | 44 | abstract 45 | 46 | BAG : Functor SET MONOID 47 | Carrier (act BAG A) = List A 48 | _∙_ (act BAG A) = {!!} 49 | ε (act BAG A) = {!!} 50 | assoc (act BAG A) {x} {y} {z} = {!!} 51 | identityˡ (act BAG A) {x} = {!!} 52 | identityʳ (act BAG A) {x} = {!!} 53 | fun (fmap BAG f) = {!!} 54 | preserves-ε (fmap BAG f) = {!!} 55 | preserves-∙ (fmap BAG f) = {!!} 56 | identity BAG = {!!} 57 | homomorphism BAG = {!!} 58 | 59 | -- For convenience, let us name the carrier of the constructed monoid 60 | Bag : Set → Set 61 | Bag A = Carrier (act BAG A) 62 | 63 | {- ??? 3.9 Show that your construction is the right one by showing 64 | that BAG is left adjoint to the forgetful functor from 65 | MONOID to SET. We will see soon that this adjunction will 66 | give rise to most of the constructions and properties 67 | needed to build a proof-of-concept database system. 68 | (7 MARKS) -} 69 | 70 | {- MARKING: to 1, from 2, left-inverse-of 3 (with partial credit for partial success), right-inverse-of 1-} 71 | 72 | open Adjunction 73 | 74 | abstract 75 | BagAdjunction : Adjunction BAG FORGET 76 | BagAdjunction = {!!} 77 | 78 | 79 | -- For data entry, we break the abstraction barrier to 80 | -- provide an efficient way to create bags: 81 | fromList : {A : Set} → List A → Carrier (act BAG A) 82 | fromList xs = xs 83 | 84 | -------------------------------------------------------------------------------- /Coursework/Examples/Three.agda: -------------------------------------------------------------------------------- 1 | module Coursework.Examples.Three where 2 | 3 | open import Data.List 4 | open import Data.Nat using (ℕ; _≤″_; less-than-or-equal) 5 | open import Data.Fin 6 | open import Data.String using (String) 7 | open import Relation.Binary.PropositionalEquality 8 | 9 | open import Data.Unit 10 | open import Reflection using (TC; Term; unify; unquoteTC; _>>=_) 11 | 12 | open import Coursework.Three.Bag 13 | 14 | Identifier : Set 15 | Identifier = Fin 16 16 | 17 | pattern !! = less-than-or-equal refl 18 | ! = fromℕ<″ 19 | 20 | -- Buyer seller database 21 | 22 | record Specialty : Set where 23 | constructor mkSpecialty 24 | field 25 | specialty-id : Identifier 26 | description : String 27 | open Specialty 28 | 29 | record Buyer : Set where 30 | constructor mkBuyer 31 | field 32 | buyer-id : Identifier 33 | name : String 34 | specialty-id : Identifier 35 | open Buyer 36 | 37 | record Order : Set where 38 | constructor mkOrder 39 | field 40 | order-id : Identifier 41 | item-name : String 42 | price : ℕ 43 | buyer-id : Identifier 44 | seller-id : Identifier 45 | open Order 46 | 47 | record Seller : Set where 48 | constructor mkSeller 49 | field 50 | seller-id : Identifier 51 | name : String 52 | city : String 53 | open Seller 54 | 55 | specialties : Bag Specialty 56 | specialties = fromList 57 | ( 58 | (mkSpecialty (! 0 !!) "Computer Science") ∷ 59 | (mkSpecialty (! 1 !!) "Business Manegement") ∷ 60 | (mkSpecialty (! 2 !!) "English Literature") ∷ 61 | []) 62 | 63 | buyers : Bag Buyer 64 | buyers = fromList 65 | ( 66 | (mkBuyer (! 0 !!) "Kevin Lee" (! 0 !!)) ∷ 67 | (mkBuyer (! 1 !!) "Edward Johnson" (! 1 !!)) ∷ 68 | (mkBuyer (! 2 !!) "Jane King" (! 0 !!)) ∷ 69 | (mkBuyer (! 3 !!) "William Lewis" (! 0 !!)) ∷ 70 | (mkBuyer (! 4 !!) "Anne Carroll" (! 1 !!)) ∷ 71 | (mkBuyer (! 5 !!) "George Roberts" (! 1 !!)) ∷ 72 | (mkBuyer (! 6 !!) "Clemens Klever" (! 2 !!)) ∷ 73 | []) 74 | 75 | sellers : Bag Seller 76 | sellers = fromList 77 | ( 78 | (mkSeller (! 0 !!) "John Lewis" "Edinburgh") ∷ 79 | (mkSeller (! 1 !!) "Argos" "London") ∷ 80 | (mkSeller (! 2 !!) "Argos" "Glasgow") ∷ 81 | (mkSeller (! 3 !!) "Currys" "Manchester") ∷ 82 | (mkSeller (! 4 !!) "Currys" "Glasgow") ∷ 83 | (mkSeller (! 5 !!) "IKEA" "Edinburgh") ∷ 84 | []) 85 | 86 | orders : Bag Order 87 | orders = fromList 88 | ( 89 | (mkOrder (! 0 !!) "Apple AirPods" 20 (! 2 !!) (! 0 !!)) ∷ 90 | (mkOrder (! 1 !!) "iPhone 11" 1300 (! 4 !!) (! 4 !!)) ∷ 91 | (mkOrder (! 2 !!) "iPhone 11" 1100 (! 1 !!) (! 0 !!)) ∷ 92 | (mkOrder (! 3 !!) "iPhone 11" 1259 (! 1 !!) (! 4 !!)) ∷ 93 | (mkOrder (! 4 !!) "Samsung Galaxy Note 10" 550 (! 1 !!) (! 4 !!)) ∷ 94 | (mkOrder (! 5 !!) "iPhone 11" 2000 (! 3 !!) (! 0 !!)) ∷ 95 | (mkOrder (! 6 !!) "Laptop HP Elitebook" 1000 (! 5 !!) (! 3 !!)) ∷ 96 | (mkOrder (! 7 !!) "iPhone 11" 999 (! 5 !!) (! 2 !!)) ∷ 97 | (mkOrder (! 8 !!) "Laptop HP Elitebook" 10 (! 2 !!) (! 2 !!)) ∷ 98 | (mkOrder (! 9 !!) "Samsung Galaxy Note 10" 550 (! 3 !!) (! 4 !!)) ∷ 99 | (mkOrder (! 10 !!) "Laptop HP Elitebook" 550 (! 0 !!) (! 3 !!)) ∷ 100 | (mkOrder (! 11 !!) "Apple AirPods" 22 (! 6 !!) (! 2 !!)) ∷ 101 | []) 102 | -------------------------------------------------------------------------------- /Lectures/Week4.agda: -------------------------------------------------------------------------------- 1 | module Lectures.Week4 where 2 | 3 | open import Data.Nat using (ℕ; zero; suc; _+_) 4 | open import Data.Nat.Properties using (+-identityʳ; +-suc) 5 | open import Data.Unit using (⊤; tt) 6 | open import Data.Empty 7 | open import Data.Sum 8 | open import Relation.Nullary 9 | open import Relation.Binary.PropositionalEquality 10 | 11 | --------------------------------------------------------------------------- 12 | -- Inductively defined predicates 13 | --------------------------------------------------------------------------- 14 | 15 | --------------------------------------------------------------------- 16 | module ByRecursion where 17 | --------------------------------------------------------------------- 18 | 19 | -- In Week 3, we defined special cases of < by recursion. Here is 20 | -- the general definition: 21 | 22 | _≤_ : ℕ -> ℕ -> Set 23 | zero ≤ m = ⊤ 24 | suc n ≤ zero = ⊥ 25 | suc n ≤ suc m = n ≤ m 26 | 27 | -- It is easy to prove concrete instances: 28 | 29 | 2≤4 : 2 ≤ 4 30 | 2≤4 = tt 31 | 32 | -- And to disprove concrete instances: 33 | 34 | ¬12≤3 : ¬ 12 ≤ 3 35 | ¬12≤3 () 36 | 37 | -- For proving general facts, we resort to "why is it stuck?", as 38 | -- usual: 39 | 40 | n≤1+n : (n : ℕ) -> n ≤ suc n 41 | n≤1+n zero = tt 42 | n≤1+n (suc n) = n≤1+n n 43 | 44 | -- However this can become tedious when we have to "unstick" an 45 | -- assumption given to us, as well as a goal we are trying to prove: 46 | 47 | n≤0⇒n≡0 : ∀ {n} → n ≤ 0 → n ≡ 0 48 | n≤0⇒n≡0 {zero} _ = refl 49 | n≤0⇒n≡0 {suc n} () 50 | 51 | -- Sometimes it is nicer if we can just pattern match on the proof... 52 | 53 | --------------------------------------------------------------------- 54 | module ByInduction where 55 | --------------------------------------------------------------------- 56 | 57 | -- Here is an alternative definition 58 | 59 | data _≤_ : ℕ -> ℕ -> Set where 60 | z≤n : {n : ℕ} -> zero ≤ n 61 | s≤s : {m n : ℕ} -> m ≤ n -> suc m ≤ suc n 62 | 63 | -- Concrete cases are still easy, but requires a little bit more 64 | -- manual work: 65 | 66 | 2≤4 : 2 ≤ 4 67 | 2≤4 = s≤s (s≤s z≤n) 68 | 69 | ¬12≤3 : ¬ 12 ≤ 3 70 | ¬12≤3 (s≤s (s≤s (s≤s ()))) 71 | 72 | -- constructing evidence is basically the same as before 73 | 74 | n≤1+n : (n : ℕ) -> n ≤ suc n 75 | n≤1+n zero = z≤n 76 | n≤1+n (suc n) = s≤s (n≤1+n n) 77 | 78 | n≤m+n : (n : ℕ){m : ℕ} -> n ≤ (n + m) 79 | n≤m+n zero = z≤n 80 | n≤m+n (suc n) = s≤s (n≤m+n n) 81 | 82 | -- but when given evidence, we can now pattern match! 83 | 84 | n≤0⇒n≡0 : ∀ {n} → n ≤ 0 → n ≡ 0 85 | n≤0⇒n≡0 z≤n = refl 86 | 87 | 88 | ------------------------------------------------------------------- 89 | -- ≤ is a partial order 90 | ------------------------------------------------------------------- 91 | 92 | ≤-reflexive : (n : ℕ) -> n ≤ n 93 | ≤-reflexive zero = z≤n 94 | ≤-reflexive (suc n) = s≤s (≤-reflexive n) 95 | 96 | ≤-trans : {n m k : ℕ} -> n ≤ m -> m ≤ k -> n ≤ k 97 | ≤-trans z≤n q = z≤n 98 | ≤-trans (s≤s p) (s≤s q) = s≤s (≤-trans p q) 99 | 100 | ≤-antisym : {n m : ℕ} -> n ≤ m -> m ≤ n -> n ≡ m 101 | ≤-antisym z≤n z≤n = refl 102 | ≤-antisym (s≤s p) (s≤s q) = cong suc (≤-antisym p q) 103 | 104 | ------------------------------------------------------------------- 105 | -- Other properties of ≤ 106 | ------------------------------------------------------------------- 107 | 108 | ≤-propositional : {n m : ℕ} -> isPropositional (n ≤ m) 109 | ≤-propositional z≤n z≤n = refl 110 | ≤-propositional (s≤s p) (s≤s q) = cong s≤s (≤-propositional p q) 111 | 112 | ≤-decidable : (n m : ℕ) -> Dec (n ≤ m) 113 | ≤-decidable zero m = yes z≤n 114 | ≤-decidable (suc n) zero = no λ () 115 | ≤-decidable (suc n) (suc m) with ≤-decidable n m 116 | ... | yes n≤m = yes (s≤s n≤m) 117 | ... | no ¬n≤m = no λ { (s≤s p) → ¬n≤m p } 118 | -------------------------------------------------------------------------------- /Lectures/Week2.agda: -------------------------------------------------------------------------------- 1 | module Lectures.Week2 where 2 | 3 | -- What kind of things can we put into our types, so that they are 4 | -- checked by Agda? 5 | 6 | ---------------------------------------------------------------------- 7 | -- Propositions-as-booleans? 8 | ---------------------------------------------------------------------- 9 | 10 | data Bool : Set where -- can be found in Data.Bool 11 | false true : Bool 12 | 13 | -- We can define for example `and` by pattern matching: 14 | 15 | _&_ : Bool -> Bool -> Bool 16 | false & y = false 17 | true & y = y 18 | 19 | -- but how do we represent eg `(∀ n : ℕ) P(n)`? 20 | 21 | ---------------------------------------------------------------------- 22 | -- Propositions-as-types 23 | ---------------------------------------------------------------------- 24 | 25 | -- Record *evidence* using types instead 26 | 27 | {- Conjunction -} 28 | 29 | -- Q: What is a proof of `A ∧ B`? 30 | 31 | -- A: A proof of A and a proof of B -- a tuple! 32 | 33 | open import Data.Product -- _×_ \times 34 | 35 | -- find definition by clicking above 36 | 37 | _∧_ : Set -> Set -> Set 38 | A ∧ B = A × B 39 | 40 | ex1 : {A B : Set} → A × B → A 41 | ex1 = proj₁ 42 | 43 | ex2 : {A : Set} → A -> A ∧ A 44 | ex2 a = a , a 45 | 46 | {- Implication -} 47 | 48 | -- Q: What is a proof of `A → B`? 49 | 50 | -- A: A method for converting proofs of A into proofs of B -- a function! 51 | 52 | ex3 : {A : Set} → A -> A 53 | ex3 a = a 54 | 55 | ex4 : {A B C D : Set} -> ((A -> B -> C) -> D) -> (A -> C) -> D 56 | ex4 f g = f (λ a _ → g a) 57 | 58 | {- True and False -} 59 | 60 | -- the unit type represents a true proposition 61 | 62 | open import Data.Unit -- ⊤ \top 63 | 64 | -- again find definition by clicking 65 | 66 | ex5 : {B : Set} -> B -> ⊤ 67 | ex5 = _ 68 | 69 | -- the empty type represents a false proposition 70 | 71 | open import Data.Empty -- ⊥ \bot 72 | 73 | ex6 : {B : Set} -> ⊥ -> B 74 | ex6 = λ () -- `⊥-elim` in the library 75 | 76 | {- Disjunction -} 77 | 78 | -- Q: What is a proof of `A ∨ B`? 79 | 80 | -- A: A proof of A, or a proof of B -- a disjoint union 81 | 82 | open import Data.Sum -- _⊎_ \uplus 83 | 84 | _∨_ : Set -> Set -> Set 85 | A ∨ B = A ⊎ B 86 | 87 | ex7 : {A B : Set} -> A ⊎ B -> B ⊎ A 88 | ex7 (inj₁ a) = inj₂ a 89 | ex7 (inj₂ b) = inj₁ b 90 | 91 | {- Negation -} 92 | 93 | -- Q: What is a proof of `¬ A`? 94 | 95 | -- A: A method to show that all proofs of A are impossible -- a function A → ⊥ 96 | 97 | ¬_ : Set -> Set 98 | ¬ A = A -> ⊥ 99 | 100 | ex8 : ¬ (⊤ -> ⊥) 101 | ex8 f = f tt 102 | 103 | ex9 : {A B : Set} -> A -> ¬ A -> B 104 | ex9 a ¬a with ¬a a 105 | ... | () 106 | 107 | ---------------------------------------------------------------------- 108 | -- Predicates in type theory 109 | ---------------------------------------------------------------------- 110 | 111 | -- What is a predicate? 112 | 113 | Pred : Set -> Set1 114 | Pred A = A -> Set 115 | 116 | open import Data.Nat 117 | 118 | isEven : ℕ -> Set 119 | isEven zero = ⊤ 120 | isEven (suc zero) = ⊥ 121 | isEven (suc (suc n)) = isEven n 122 | 123 | test : isEven 4 --(suc (suc .... zero)) 124 | test = tt 125 | 126 | test' : ¬ isEven 5 127 | test' () 128 | 129 | _>1 : ℕ -> Set 130 | zero >1 = ⊥ 131 | suc zero >1 = ⊥ 132 | suc (suc x) >1 = ⊤ 133 | 134 | _<3 : ℕ -> Set 135 | zero <3 = ⊤ 136 | suc zero <3 = ⊤ 137 | suc (suc zero) <3 = ⊤ 138 | suc (suc (suc n)) <3 = ⊥ 139 | 140 | fact : 1 <3 × 2 >1 141 | fact = _ 142 | 143 | {- Equality -} 144 | 145 | {- 146 | data _≡_ {A : Set} (x : A) : A → Set where 147 | refl : x ≡ x 148 | -} 149 | open import Agda.Builtin.Equality 150 | 151 | ex10 : 5 + 3 ≡ 8 152 | ex10 = refl 153 | 154 | ex11 : {x : ℕ} → (p : x ≡ 2) → x + 4 ≡ 6 155 | ex11 refl = refl 156 | 157 | ex11' : {x y : ℕ} → (p : x + y ≡ 2) → (x + y) + 4 ≡ 6 158 | ex11' p rewrite p = refl -- rewrite 159 | 160 | open import Relation.Binary.PropositionalEquality using (cong) 161 | 162 | ex11'' : {A B : Set} → (f : A → B) → {x y : A} → (p : x ≡ y) → f x ≡ f y 163 | ex11'' f refl = refl -- same as `cong` 164 | -------------------------------------------------------------------------------- /Coursework/Three/Categories.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --type-in-type #-} 2 | module Coursework.Three.Categories where 3 | 4 | open import Relation.Binary.PropositionalEquality 5 | open import Axiom.UniquenessOfIdentityProofs.WithK 6 | 7 | import Function as Fun 8 | 9 | open import Common.Category 10 | 11 | {- Monoids -} 12 | 13 | record Monoid : Set₁ where 14 | field 15 | Carrier : Set 16 | _∙_ : Carrier -> Carrier -> Carrier 17 | ε : Carrier 18 | 19 | field 20 | assoc : ∀ {x y z} → (x ∙ y) ∙ z ≡ x ∙ (y ∙ z) 21 | identityˡ : ∀ {x} → ε ∙ x ≡ x 22 | identityʳ : ∀ {x} → x ∙ ε ≡ x 23 | open Monoid 24 | 25 | record MonoidMorphism (A B : Monoid) : Set where 26 | private 27 | module A = Monoid A 28 | module B = Monoid B 29 | 30 | field 31 | fun : Carrier A -> Carrier B 32 | preserves-ε : fun (A.ε) ≡ B.ε 33 | preserves-∙ : ∀ x y → fun (x A.∙ y) ≡ (fun x B.∙ fun y) 34 | open MonoidMorphism 35 | 36 | eqMonoidMorphism : {A B : Monoid} -> {f g : MonoidMorphism A B} -> 37 | fun f ≡ fun g -> f ≡ g 38 | eqMonoidMorphism {A} {B} {f} {g} refl = 39 | eqMonoidMorphism' (ext (λ x → ext λ y → uip _ _)) (uip _ _) 40 | where 41 | module A = Monoid A 42 | module B = Monoid B 43 | eqMonoidMorphism' : 44 | {fun : A.Carrier -> B.Carrier} 45 | {∙-f ∙-g : ∀ x y → fun (x A.∙ y) ≡ (fun x B.∙ fun y)} 46 | {ε-f ε-g : fun (A.ε) ≡ B.ε} -> 47 | ∙-f ≡ ∙-g -> ε-f ≡ ε-g -> 48 | _≡_ {A = MonoidMorphism A B} 49 | (record { fun = fun ; preserves-∙ = ∙-f ; preserves-ε = ε-f }) 50 | (record { fun = fun ; preserves-∙ = ∙-g ; preserves-ε = ε-g }) 51 | eqMonoidMorphism' refl refl = refl 52 | 53 | open Category 54 | open Functor 55 | 56 | MONOID : Category 57 | Obj MONOID = Monoid 58 | Hom MONOID = MonoidMorphism 59 | fun (id MONOID) = Fun.id 60 | preserves-ε (id MONOID) = refl 61 | preserves-∙ (id MONOID) x y = refl 62 | fun (comp MONOID f g) = Fun._∘′_ (fun g) (fun f) 63 | preserves-ε (comp MONOID f g) rewrite preserves-ε f | preserves-ε g = refl 64 | preserves-∙ (comp MONOID f g) x y rewrite preserves-∙ f x y | preserves-∙ g (fun f x) (fun f y) = refl 65 | assoc MONOID = eqMonoidMorphism refl 66 | identityˡ MONOID = eqMonoidMorphism refl 67 | identityʳ MONOID = eqMonoidMorphism refl 68 | 69 | FORGET : Functor MONOID SET 70 | act FORGET = Carrier 71 | fmap FORGET = fun 72 | identity FORGET = refl 73 | homomorphism FORGET = refl 74 | 75 | {- Preorders -} 76 | 77 | record Preorder : Set1 where 78 | field 79 | Carrier : Set 80 | _≤_ : Carrier -> Carrier -> Set 81 | reflexive : ∀ {x} → x ≤ x 82 | transitive : ∀ {x y z} → x ≤ y -> y ≤ z -> x ≤ z 83 | propositional : ∀ {x y} → (p q : x ≤ y) -> p ≡ q 84 | open Preorder 85 | 86 | record MonotoneMap (P Q : Preorder) : Set1 where 87 | private 88 | module P = Preorder P 89 | module Q = Preorder Q 90 | 91 | field 92 | fun : Carrier P -> Carrier Q 93 | monotone : ∀ x y → x P.≤ y -> fun x Q.≤ fun y 94 | open MonotoneMap 95 | 96 | eqMonotoneMap : {P Q : Preorder} -> {f g : MonotoneMap P Q} -> 97 | fun f ≡ fun g -> f ≡ g 98 | eqMonotoneMap {P} {Q} {f} {g} refl 99 | = cong (λ z → record { fun = fun g; monotone = z }) 100 | (ext λ x → ext (λ y → ext λ p → propositional Q _ _)) 101 | 102 | PREORDER : Category 103 | Obj PREORDER = Preorder 104 | Hom PREORDER = MonotoneMap 105 | fun (Category.id PREORDER) = λ x → x 106 | monotone (Category.id PREORDER) x y x≤y = x≤y 107 | fun (comp PREORDER f g) a = fun g (fun f a) 108 | monotone (comp PREORDER f g) x y x≤y = monotone g _ _ (monotone f x y x≤y) 109 | assoc PREORDER = eqMonotoneMap refl 110 | identityˡ PREORDER = eqMonotoneMap refl 111 | identityʳ PREORDER = eqMonotoneMap refl 112 | 113 | {- Categories -} 114 | 115 | idFunctor : {C : Category} -> Functor C C 116 | act idFunctor X = X 117 | fmap idFunctor f = f 118 | identity idFunctor = refl 119 | homomorphism idFunctor = refl 120 | 121 | compFunctor : {A B C : Category} -> Functor A B → Functor B C → Functor A C 122 | act (compFunctor F G) = (act G) Fun.∘′ (act F) 123 | fmap (compFunctor F G) f = fmap G (fmap F f) 124 | identity (compFunctor F G) = trans (cong (fmap G) (identity F)) (identity G) 125 | homomorphism (compFunctor F G) = trans (cong (fmap G) (homomorphism F)) (homomorphism G) 126 | 127 | CAT : Category 128 | Obj CAT = Category 129 | Hom CAT = Functor 130 | id CAT = idFunctor 131 | comp CAT = compFunctor 132 | assoc CAT = eqFunctor refl refl 133 | identityˡ CAT = eqFunctor refl refl 134 | identityʳ CAT = eqFunctor refl refl 135 | 136 | -------------------------------------------------------------------------------- /Lectures/Week5.agda: -------------------------------------------------------------------------------- 1 | module Lectures.Week5 where 2 | 3 | open import Data.Nat 4 | open import Data.Bool 5 | open import Data.Maybe 6 | open import Relation.Binary.PropositionalEquality 7 | 8 | --------------------------------------------------------------------------- 9 | -- Expressions 10 | --------------------------------------------------------------------------- 11 | 12 | data Expr : Set where 13 | num : ℕ -> Expr 14 | bit : Bool -> Expr 15 | _+E_ : Expr -> Expr -> Expr 16 | ifE_then_else_ : Expr -> Expr -> Expr -> Expr 17 | 18 | infixl 4 _+E_ 19 | infix 0 ifE_then_else_ 20 | 21 | ex1 : Expr 22 | ex1 = num 5 +E num 7 23 | 24 | ex2 : Expr 25 | ex2 = bit true +E num 7 26 | 27 | ex3 : Expr 28 | ex3 = ifE bit false then ex2 else num 2 29 | 30 | --------------- 31 | -- Evaluation 32 | --------------- 33 | 34 | data Val : Set where 35 | num : ℕ -> Val 36 | bit : Bool -> Val 37 | 38 | _+V_ : Val -> Val -> Maybe Val 39 | num n +V num n' = just (num (n + n')) 40 | _ +V _ = nothing 41 | 42 | eval : Expr → Maybe Val 43 | eval (num n) = just (num n) 44 | eval (bit b) = just (bit b) 45 | eval (e +E e') = do 46 | v <- eval e 47 | v' <- eval e' 48 | v +V v' 49 | eval (ifE e then et else ef) = do 50 | (bit b) <- eval e where _ → nothing 51 | if b then eval et else eval ef 52 | 53 | eex1 : Maybe Val 54 | eex1 = eval ex1 55 | 56 | eex2 : Maybe Val 57 | eex2 = eval ex2 58 | 59 | --------------------------------------------------------------------------- 60 | -- Typed expressions 61 | --------------------------------------------------------------------------- 62 | 63 | data Ty : Set where 64 | Num : Ty 65 | Bit : Ty 66 | 67 | data TExpr : Ty -> Set where 68 | num : ℕ -> TExpr Num 69 | bit : Bool -> TExpr Bit 70 | _+E_ : TExpr Num -> TExpr Num -> TExpr Num 71 | ifE_then_else_ : {T : Ty} -> TExpr Bit -> TExpr T -> TExpr T -> TExpr T 72 | 73 | tex1 : TExpr Num 74 | tex1 = num 5 +E num 7 75 | 76 | -- tex2 : TExpr Num 77 | -- tex2 = {!bit true!} +E num 7 78 | 79 | tex3 : TExpr Num 80 | tex3 = ifE bit false then tex1 else num 2 81 | 82 | 83 | --------------- 84 | -- Evaluation 85 | --------------- 86 | 87 | TVal : Ty -> Set 88 | TVal Num = ℕ 89 | TVal Bit = Bool 90 | 91 | teval : {T : Ty} -> TExpr T -> TVal T 92 | teval (num n) = n 93 | teval (bit b) = b 94 | teval (e +E e') = teval e + teval e' 95 | teval (ifE e then et else ef) = if teval e then teval et else teval ef 96 | 97 | -------------------------------------------------------------------------- 98 | -- Relating typed and untyped expressions 99 | --------------------------------------------------------------------------- 100 | 101 | ∣_∣ : ∀ {t} → TExpr t -> Expr 102 | ∣ num n ∣ = num n 103 | ∣ bit b ∣ = bit b 104 | ∣ e +E e' ∣ = ∣ e ∣ +E ∣ e' ∣ 105 | ∣ ifE e then et else ef ∣ = ifE ∣ e ∣ then ∣ et ∣ else ∣ ef ∣ 106 | 107 | record Welltyped (e : Expr) : Set where 108 | constructor okay 109 | field 110 | τ : Ty 111 | t : TExpr τ 112 | is-same : ∣ t ∣ ≡ e 113 | 114 | tyEq? : (S T : Ty) -> Maybe (S ≡ T) 115 | tyEq? Num Num = just refl 116 | tyEq? Bit Bit = just refl 117 | tyEq? _ _ = nothing 118 | 119 | infer : (e : Expr) -> Maybe (Welltyped e) 120 | infer (num n) = just (okay Num (num n) refl) 121 | infer (bit b) = just (okay Bit (bit b) refl) 122 | infer (e +E e') = do 123 | okay Num t refl <- infer e where _ -> nothing 124 | okay Num t' refl <- infer e' where _ -> nothing 125 | just (okay Num (t +E t') refl) 126 | infer (ifE e then et else ef) = do 127 | okay Bit b refl <- infer e where _ -> nothing 128 | okay T t refl <- infer et 129 | okay F f refl <- infer ef 130 | refl <- tyEq? T F 131 | just (okay T (ifE b then t else f) refl) 132 | 133 | --------------------------------------------------------------------------- 134 | -- Optimising expressions 135 | --------------------------------------------------------------------------- 136 | 137 | reduce-if : ∀ {t} → TExpr t -> TExpr t 138 | reduce-if (num n) = num n 139 | reduce-if (bit b) = bit b 140 | reduce-if (e +E e') = reduce-if e +E reduce-if e' 141 | reduce-if (ifE e then et else ef) with reduce-if e 142 | ... | bit true = reduce-if et 143 | ... | bit false = reduce-if ef 144 | ... | oe@(ifE _ then _ else _) = ifE oe then reduce-if et else reduce-if ef 145 | 146 | reduce-if-correct : ∀ {t} → (e : TExpr t) → teval (reduce-if e) ≡ teval e 147 | reduce-if-correct (num n) = refl 148 | reduce-if-correct (bit b) = refl 149 | reduce-if-correct (e +E e') 150 | rewrite reduce-if-correct e | reduce-if-correct e' = refl 151 | reduce-if-correct (ifE e then et else ef) 152 | with reduce-if e | reduce-if-correct e 153 | ... | bit false | qqq rewrite sym qqq = reduce-if-correct ef 154 | ... | bit true | qqq rewrite sym qqq = reduce-if-correct et 155 | ... | ifE qq then qq₁ else qq₂ | qqq 156 | rewrite qqq | reduce-if-correct et | reduce-if-correct ef = refl 157 | -------------------------------------------------------------------------------- /Common/Category.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --type-in-type #-} 2 | module Common.Category where 3 | 4 | open import Relation.Binary.PropositionalEquality hiding (Extensionality) 5 | open import Axiom.Extensionality.Propositional 6 | open import Axiom.UniquenessOfIdentityProofs.WithK 7 | import Function as Fun 8 | 9 | ---------------------------- 10 | -- Function extensionality 11 | ---------------------------- 12 | 13 | postulate 14 | ext : Extensionality _ _ 15 | 16 | ---------------------------- 17 | -- Categories 18 | ---------------------------- 19 | 20 | record Category : Set where 21 | eta-equality 22 | 23 | field 24 | Obj : Set 25 | Hom : Obj -> Obj -> Set 26 | 27 | field 28 | id : ∀ {A} → Hom A A 29 | comp : ∀ {A B C} → Hom A B → Hom B C → Hom A C 30 | 31 | field -- laws 32 | assoc : ∀ {A B C D} {f : Hom A B} {g : Hom B C}{h : Hom C D} → 33 | comp f (comp g h) ≡ (comp (comp f g) h) 34 | identityˡ : ∀ {A B} {f : Hom A B} → comp id f ≡ f 35 | identityʳ : ∀ {A B} {f : Hom A B} → comp f id ≡ f 36 | open Category 37 | 38 | ---------------------------- 39 | -- Functors 40 | ---------------------------- 41 | 42 | record Functor (C D : Category) : Set where 43 | eta-equality 44 | private 45 | module C = Category C 46 | module D = Category D 47 | 48 | field 49 | act : C.Obj → D.Obj 50 | fmap : ∀ {X Y} (f : C.Hom X Y) → D.Hom (act X) (act Y) 51 | 52 | field -- laws 53 | identity : ∀ {X} → fmap (C.id {X}) ≡ D.id {act X} 54 | homomorphism : ∀ {X Y Z} {f : C.Hom X Y}{g : C.Hom Y Z} → 55 | fmap (C.comp f g) ≡ D.comp (fmap f) (fmap g) 56 | open Functor 57 | 58 | 59 | -- How to prove Functors equal 60 | eqFunctor : {C D : Category}{F G : Functor C D} -> 61 | (p : act F ≡ act G) -> 62 | (∀ {A B} → subst (λ z → Hom C A B -> Hom D (z A) (z B)) p (fmap F) ≡ (fmap G {A} {B})) -> 63 | F ≡ G 64 | eqFunctor {G = G} refl q with iext (λ {A} → iext (λ {B} → q {A} {B})) 65 | where iext = implicit-extensionality ext 66 | ... | refl = eqFunctor' {G = G} (implicit-extensionality ext λ {A} → uip _ _) (iext (iext (iext (iext (iext (uip _ _)))))) where 67 | iext = implicit-extensionality ext 68 | eqFunctor' : ∀ {C} {D} {G : Functor C D} 69 | {identity' identity'' : {A : Obj C} → fmap G {A} (Category.id C) ≡ Category.id D} 70 | {homomorphism' homomorphism'' : {X Y Z : Obj C} {f : Hom C X Y} {g : Hom C Y Z} → fmap G (comp C f g) ≡ comp D (fmap G f) (fmap G g)} → 71 | (_≡_ {A = ∀ {A} → fmap G {A} (Category.id C) ≡ Category.id D} identity' identity'') -> 72 | (_≡_ {A = {X Y Z : Obj C} {f : Hom C X Y} {g : Hom C Y Z} → fmap G (comp C f g) ≡ comp D (fmap G f) (fmap G g)} homomorphism' homomorphism'') -> 73 | _≡_ {A = Functor C D} (record { act = act G; fmap = fmap G; identity = identity'; homomorphism = homomorphism' }) 74 | (record { act = act G; fmap = fmap G; identity = identity''; homomorphism = homomorphism'' }) 75 | eqFunctor' refl refl = refl 76 | 77 | 78 | 79 | 80 | 81 | 82 | 83 | 84 | 85 | 86 | 87 | 88 | 89 | 90 | ---------------------------- 91 | -- Natural transformations 92 | ---------------------------- 93 | 94 | record NaturalTransformation {C D : Category} 95 | (F G : Functor C D) : Set where 96 | eta-equality 97 | private 98 | module F = Functor F 99 | module G = Functor G 100 | module C = Category C 101 | module D = Category D 102 | 103 | field 104 | transform : ∀ X → D.Hom (F.act X) (G.act X) 105 | natural : ∀ X Y (f : C.Hom X Y) → 106 | D.comp (F.fmap f) (transform Y) ≡ D.comp (transform X) (G.fmap f) 107 | open NaturalTransformation 108 | 109 | -- How to prove natural transformations equal 110 | eqNatTrans : {C D : Category}{F G : Functor C D} -> 111 | (η ρ : NaturalTransformation F G) -> 112 | ((X : Category.Obj C) -> transform η X ≡ transform ρ X) -> 113 | η ≡ ρ 114 | eqNatTrans {C} η ρ p with ext p 115 | ... | refl = eqNatTrans' η ρ refl (ext λ X → ext λ Y → ext λ f → uip _ _) where 116 | eqNatTrans' : {C D : Category}{F G : Functor C D} -> 117 | (η ρ : NaturalTransformation F G) -> 118 | (p : transform η ≡ transform ρ) -> 119 | subst (λ z → (X Y : Category.Obj C)(f : Category.Hom C X Y) → Category.comp D (fmap F f) (z Y) ≡ Category.comp D (z X) (fmap G f)) p (natural η) ≡ (natural ρ) -> 120 | η ≡ ρ 121 | eqNatTrans' η ρ refl refl = refl 122 | 123 | ---------------------------- 124 | -- The category of Sets 125 | ---------------------------- 126 | 127 | SET : Category 128 | Category.Obj SET = Set 129 | Category.Hom SET A B = A -> B 130 | Category.id SET = Fun.id 131 | Category.comp SET f g = g Fun.∘′ f 132 | Category.assoc SET = refl 133 | Category.identityˡ SET = refl 134 | Category.identityʳ SET = refl 135 | -------------------------------------------------------------------------------- /Common/Category/Adjunctions.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --type-in-type #-} 2 | module Common.Category.Adjunctions where 3 | 4 | open import Data.Product 5 | 6 | open import Relation.Binary.PropositionalEquality 7 | open import Function as Fun using (_∘′_) 8 | 9 | open import Common.Category 10 | open import Common.Category.Solver 11 | 12 | ---------------------------- 13 | -- Adjunctions 14 | ---------------------------- 15 | 16 | record Adjunction {C D : Category} 17 | (F : Functor C D) 18 | (G : Functor D C) : Set where 19 | 20 | open Category 21 | open Functor 22 | open NaturalTransformation 23 | 24 | field 25 | to : {X : Obj C}{B : Obj D} -> Hom D (act F X) B -> Hom C X (act G B) 26 | from : {X : Obj C}{B : Obj D} -> Hom C X (act G B) -> Hom D (act F X) B 27 | left-inverse-of : ∀ {X B} → (h : Hom D (act F X) B) -> from (to h) ≡ h 28 | right-inverse-of : ∀ {X B} → (k : Hom C X (act G B)) -> to (from k) ≡ k 29 | 30 | to-natural : {X X' : Obj C}{B B' : Obj D} (f : Hom C X' X)(g : Hom D B B') -> 31 | (λ h → comp C f (comp C h (fmap G g))) ∘′ (to {X} {B}) 32 | ≡ 33 | (to {X'} {B'}) ∘′ (λ k → comp D (fmap F f) (comp D k g)) 34 | 35 | from-natural : {X X' : Obj C}{B B' : Obj D} (f : Hom C X' X)(g : Hom D B B') -> 36 | (λ k → comp D (fmap F f) (comp D k g)) ∘′ (from {X} {B}) 37 | ≡ 38 | (from {X'} {B'}) ∘′ (λ h → comp C f (comp C h (fmap G g))) 39 | from-natural f g = SET ⊧begin 40 | < (λ k → comp D (fmap F f) (comp D k g)) > ∘Syn < from > 41 | ≡⟦ solveCat refl ⟧ 42 | -[ idSyn ]- ∘Syn < (λ k → comp D (fmap F f) (comp D k g)) > ∘Syn < from > 43 | ≡⟦ reduced (rq (sym (ext left-inverse-of)) , rd , rd) ⟧ 44 | -[ < from > ∘Syn < to > ]- ∘Syn < (λ k → comp D (fmap F f) (comp D k g)) > ∘Syn < from > 45 | ≡⟦ solveCat refl ⟧ 46 | < from > ∘Syn -[ < to > ∘Syn < (λ k → comp D (fmap F f) (comp D k g)) > ]- ∘Syn < from > 47 | ≡⟦ reduced (rd , rq (sym (to-natural f g)) , rd) ⟧ 48 | < from > ∘Syn -[ < (λ h → comp C f (comp C h (fmap G g))) > ∘Syn < to > ]- ∘Syn < from > 49 | ≡⟦ solveCat refl ⟧ 50 | < from > ∘Syn < (λ h → comp C f (comp C h (fmap G g))) > ∘Syn -[ < to > ∘Syn < from > ]- 51 | ≡⟦ reduced (rd , rd , rq (ext right-inverse-of)) ⟧ 52 | < from > ∘Syn < (λ h → comp C f (comp C h (fmap G g))) > ∘Syn -[ idSyn ]- 53 | ≡⟦ solveCat refl ⟧ 54 | < from > ∘Syn < (λ h → comp C f (comp C h (fmap G g))) > 55 | ⟦∎⟧ 56 | 57 | --------------------------------------------------------------------------- 58 | -- Special cases of naturality (not very insightful) 59 | --------------------------------------------------------------------------- 60 | 61 | open Category 62 | open Functor 63 | open Adjunction 64 | 65 | to-natural₁ : {C D : Category}{F : Functor C D}{G : Functor D C} -> (adj : Adjunction F G) -> 66 | {X X' : Obj C}(f : Hom C X' X) -> 67 | comp C f (to adj (id D)) ≡ to adj (fmap F f) 68 | to-natural₁ {C} {D} {F} {G} adj f = C ⊧begin 69 | < to adj (id D) > ∘Syn < f > 70 | ≡⟦ solveCat refl ⟧ 71 | -[ (fmapSyn G idSyn ∘Syn < to adj (id D) >) ∘Syn < f > ]- 72 | ≡⟦ reduced (rq (cong-app (to-natural adj f (id D)) (id D))) ⟧ 73 | < to adj (comp D (fmap F f) (comp D (id D) (id D))) > 74 | ≡⟦ reduced (rq (cong (to adj) (eqArr (solveCat {d = compSyn (fmapSyn F < f >) (compSyn idSyn idSyn)} {d' = fmapSyn F < f >} refl)))) ⟧ 75 | < to adj (fmap F f) > 76 | ⟦∎⟧ 77 | 78 | to-natural₂ : {C D : Category}{F : Functor C D}{G : Functor D C} -> (adj : Adjunction F G) -> 79 | {X : Obj C}{B' : Obj D}(g : Hom D (act F X) B') -> 80 | comp C (to adj (id D)) (fmap G g) ≡ to adj g 81 | to-natural₂ {C} {D} {F} {G} adj g = C ⊧begin 82 | fmapSyn G < g > ∘Syn < to adj (id D) > 83 | ≡⟦ solveCat refl ⟧ 84 | (fmapSyn G < g > ∘Syn < to adj (id D) >) ∘Syn idSyn 85 | ≡⟦ reduced (rq (cong-app (to-natural adj (id C) g) (id D))) ⟧ 86 | < to adj (comp D (fmap F (id C)) (comp D (id D) g)) > 87 | ≡⟦ reduced (rq (cong (to adj) ((eqArr (solveCat {d = compSyn (fmapSyn F idSyn) (compSyn idSyn < g >)} {d' = < g >} refl))))) ⟧ 88 | < to adj g > 89 | ⟦∎⟧ 90 | 91 | from-natural₁ : {C D : Category}{F : Functor C D}{G : Functor D C} -> (adj : Adjunction F G) -> 92 | {X : Obj C}{B' : Obj D}(f : Hom C X (act G B')) -> 93 | comp D (fmap F f) (from adj (id C)) ≡ from adj f 94 | from-natural₁ {C} {D} {F} {G} adj f = D ⊧begin 95 | < from adj (id C) > ∘Syn fmapSyn F < f > 96 | ≡⟦ solveCat refl ⟧ 97 | -[ (idSyn ∘Syn < from adj (id C) >) ∘Syn fmapSyn F < f > ]- 98 | ≡⟦ reduced (rq (cong-app (from-natural {C} {D} {F} {G} adj f (id D)) (id C))) ⟧ 99 | < from adj (comp C f (comp C (id C) (fmap G (id D)))) > 100 | ≡⟦ reduced (rq (cong (from adj) (eqArr (solveCat {d = compSyn < f > (compSyn idSyn (fmapSyn G idSyn))} {< f >} refl) ))) ⟧ 101 | < from adj f > 102 | ⟦∎⟧ 103 | 104 | from-natural₂ : {C D : Category}{F : Functor C D}{G : Functor D C} -> (adj : Adjunction F G) -> 105 | {B B' : Obj D}(g : Hom D B B') -> 106 | comp D (from adj (id C)) g ≡ from adj (fmap G g) 107 | from-natural₂ {C} {D} {F} {G} adj g = D ⊧begin 108 | < g > ∘Syn < from adj (id C) > 109 | ≡⟦ solveCat refl ⟧ 110 | -[ (< g > ∘Syn < from adj (id C) >) ∘Syn fmapSyn F idSyn ]- 111 | ≡⟦ reduced (rq (cong-app (from-natural adj (id C) g) (id C))) ⟧ 112 | < from adj (comp C (id C) (comp C (id C) (fmap G g))) > 113 | ≡⟦ reduced (rq (cong (from adj) (eqArr (solveCat {d = compSyn idSyn (compSyn idSyn (fmapSyn G < g >))} {fmapSyn G < g >} refl)))) ⟧ 114 | < from adj (fmap G g) > 115 | ⟦∎⟧ 116 | -------------------------------------------------------------------------------- /Lectures/Week7.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --type-in-type #-} 2 | module Lectures.Week7 where 3 | 4 | open import Data.Nat hiding (_≤_) 5 | open import Function using (_∘_) 6 | open import Data.Product 7 | 8 | open import Relation.Binary.PropositionalEquality 9 | 10 | open import Common.Category 11 | 12 | open import Lectures.Week6 hiding (SET) 13 | 14 | --------------------------------------------------------------------------- 15 | -- Monads, categorically 16 | --------------------------------------------------------------------------- 17 | 18 | record Monad (C : Category) : Set where 19 | open Category C 20 | open Functor 21 | 22 | field 23 | functor : Functor C C 24 | 25 | private 26 | M = functor 27 | 28 | field 29 | returnNT : NaturalTransformation idFunctor M 30 | joinNT : NaturalTransformation (compFunctor M M) M 31 | 32 | return = NaturalTransformation.transform returnNT 33 | join = NaturalTransformation.transform joinNT 34 | 35 | field 36 | returnJoin : {X : Obj} -> comp (return (act M X)) (join X) ≡ id 37 | mapReturnJoin : {X : Obj} -> comp (fmap M (return X)) (join X) ≡ id 38 | joinJoin : {X : Obj} -> comp (join (act M X)) (join X) ≡ comp (fmap M (join X)) (join X) 39 | 40 | open Functor M public 41 | 42 | --------------------------------------------------------------------------- 43 | -- Hutton's Razor is a monad 44 | --------------------------------------------------------------------------- 45 | 46 | module _ where 47 | 48 | open Monad 49 | open NaturalTransformation 50 | 51 | data Expr (X : Set) : Set where 52 | var : X -> Expr X 53 | num : ℕ -> Expr X 54 | _+E_ : Expr X -> Expr X -> Expr X 55 | 56 | mapExpr : {X Y : Set} -> (X -> Y) -> Expr X -> Expr Y 57 | mapExpr f (var x) = var (f x) 58 | mapExpr f (num n) = num n 59 | mapExpr f (e +E e') = mapExpr f e +E mapExpr f e' 60 | 61 | EXPR : Functor SET SET 62 | Functor.act EXPR = Expr 63 | Functor.fmap EXPR = mapExpr 64 | Functor.identity EXPR = ext lemma where 65 | lemma : {A : Set} -> (x : Expr A) → mapExpr (λ x₁ → x₁) x ≡ x 66 | lemma (var x) = refl 67 | lemma (num n) = refl 68 | lemma (e +E e') = cong₂ _+E_ (lemma e) (lemma e') 69 | Functor.homomorphism EXPR {X} {f = f} {g} = ext lemma where 70 | lemma : (x : Expr X) → mapExpr (λ x₁ → g (f x₁)) x ≡ mapExpr g (mapExpr f x) 71 | lemma (var x) = refl 72 | lemma (num n) = refl 73 | lemma (e +E e') = cong₂ _+E_ (lemma e) (lemma e') 74 | 75 | joinExpr : {X : Set} -> Expr (Expr X) -> Expr X 76 | joinExpr (var e) = e 77 | joinExpr (num n) = num n 78 | joinExpr (e +E e') = joinExpr e +E joinExpr e' 79 | 80 | EXPR-MONAD : Monad SET 81 | functor EXPR-MONAD = EXPR 82 | transform (returnNT EXPR-MONAD) X = var 83 | natural (returnNT EXPR-MONAD) X Y f = refl 84 | transform (joinNT EXPR-MONAD) X = joinExpr 85 | natural (joinNT EXPR-MONAD) X Y f = ext lemma 86 | where 87 | lemma : (x : Expr (Expr X)) → joinExpr (mapExpr (mapExpr f) x) ≡ mapExpr f (joinExpr x) 88 | lemma (var e) = refl 89 | lemma (num n) = refl 90 | lemma (ee +E ee') rewrite lemma ee | lemma ee' = refl 91 | returnJoin EXPR-MONAD = refl 92 | mapReturnJoin EXPR-MONAD = ext lemma 93 | where 94 | lemma : {X : Set} → (x : Expr X) → joinExpr (mapExpr var x) ≡ x 95 | lemma (var x) = refl 96 | lemma (num n) = refl 97 | lemma (e +E e') = cong₂ _+E_ (lemma e) (lemma e') 98 | joinJoin EXPR-MONAD = ext lemma 99 | where 100 | lemma : {X : Set} -> (x : Expr (Expr (Expr X))) → joinExpr (joinExpr x) ≡ joinExpr (mapExpr joinExpr x) 101 | lemma (var x) = refl 102 | lemma (num n) = refl 103 | lemma (e +E e') = cong₂ _+E_ (lemma e) (lemma e') 104 | 105 | bindExpr : {X Y : Set} -> (X -> Expr Y) -> Expr X -> Expr Y 106 | bindExpr f = joinExpr ∘ mapExpr f 107 | 108 | 109 | 110 | 111 | 112 | 113 | --------------------------------------------------------------------------- 114 | -- Adding a bottom is a monad 115 | --------------------------------------------------------------------------- 116 | 117 | module _ where 118 | 119 | open Preorder 120 | open MonotoneMap 121 | open Functor 122 | open Monad 123 | open NaturalTransformation 124 | 125 | data Lift (P : Set) : Set where 126 | η : P -> Lift P 127 | ⊥' : Lift P 128 | 129 | data Lift≤ (P : Preorder) : Lift (Carrier P) -> Lift (Carrier P) -> Set where 130 | η< : ∀ {p p'} → _≤_ P p p' -> Lift≤ P (η p) (η p') 131 | bottom : ∀ {x} → Lift≤ P ⊥' x 132 | 133 | Lift-reflexive : (P : Preorder) -> (x : Lift (Carrier P)) → Lift≤ P x x 134 | Lift-reflexive P (η x) = η< (reflexive P {x}) 135 | Lift-reflexive P ⊥' = bottom 136 | 137 | Lift-transitive : (P : Preorder) -> {x y z : Lift (Carrier P)} → 138 | Lift≤ P x y -> Lift≤ P y z -> Lift≤ P x z 139 | Lift-transitive P (η< p) (η< q) = η< (transitive P p q) 140 | Lift-transitive P bottom q = bottom 141 | -- Lift-transitive P bottom bottom = {!!} 142 | 143 | mapLift : {X Y : Set} -> (f : X -> Y) -> Lift X -> Lift Y 144 | mapLift f (η x) = η (f x) 145 | mapLift f ⊥' = ⊥' 146 | 147 | LIFT : Functor PREORDER PREORDER 148 | Carrier (act LIFT P) = Lift (Carrier P) 149 | _≤_ (act LIFT P) = Lift≤ P 150 | reflexive (act LIFT P) = Lift-reflexive P _ 151 | transitive (act LIFT P) = Lift-transitive P 152 | propositional (act LIFT P) (η< p) (η< q) = cong η< (propositional P p q) 153 | propositional (act LIFT P) bottom bottom = refl 154 | fun (fmap LIFT f) = mapLift (fun f) 155 | monotone (fmap LIFT f) (η x) (η y) (η< p) = η< (monotone f x y p) 156 | monotone (fmap LIFT f) ⊥' y bottom = bottom 157 | identity LIFT = eqMonotoneMap (ext λ { (η x) → refl ; ⊥' → refl }) 158 | homomorphism LIFT = eqMonotoneMap (ext λ { (η x) → refl ; ⊥' → refl }) 159 | 160 | LIFT-MONAD : Monad PREORDER 161 | functor LIFT-MONAD = LIFT 162 | fun (transform (returnNT LIFT-MONAD) P) = η 163 | monotone (transform (returnNT LIFT-MONAD) P) x y p = η< p 164 | natural (returnNT LIFT-MONAD) X Y f = eqMonotoneMap refl 165 | fun (transform (joinNT LIFT-MONAD) P) (η x) = x 166 | fun (transform (joinNT LIFT-MONAD) P) ⊥' = ⊥' 167 | monotone (transform (joinNT LIFT-MONAD) P) (η x) (η y) (η< p) = p 168 | monotone (transform (joinNT LIFT-MONAD) P) ⊥' y bottom = bottom 169 | -- We left the following as exercises in the lecture: 170 | natural (joinNT LIFT-MONAD) X Y f = eqMonotoneMap (ext λ { (η x) → refl ; ⊥' → refl }) 171 | returnJoin LIFT-MONAD = eqMonotoneMap refl 172 | mapReturnJoin LIFT-MONAD = eqMonotoneMap (ext λ { (η x) → refl ; ⊥' → refl }) 173 | joinJoin LIFT-MONAD = eqMonotoneMap (ext λ { (η x) → refl ; ⊥' → refl }) 174 | -------------------------------------------------------------------------------- /Common/Category/Solver.agda: -------------------------------------------------------------------------------- 1 | module Common.Category.Solver where 2 | 3 | open import Data.Product 4 | open import Relation.Binary.PropositionalEquality 5 | open import Relation.Binary.Construct.Closure.ReflexiveTransitive 6 | open import Relation.Binary.Construct.Closure.ReflexiveTransitive.Properties 7 | open import Function hiding (id) 8 | 9 | open import Common.Category 10 | 11 | open Category 12 | open Functor 13 | 14 | 15 | -- "syntactic" morphisms 16 | data SynHom (C : Category) : Obj C -> Obj C -> Set 17 | where 18 | <_> : forall {S T} -> Hom C S T -> SynHom C S T 19 | idSyn : ∀ {T} -> SynHom C T T 20 | compSyn : ∀ {R S T} -> SynHom C R S -> SynHom C S T -> SynHom C R T 21 | fmapSyn : ∀ {C' S' T'} → (F : Functor C' C) -> SynHom C' S' T' -> 22 | SynHom C (act F S') (act F T') 23 | -[_]- : ∀ {S T} -> SynHom C S T -> SynHom C S T 24 | 25 | _∘Syn_ : ∀ {C R S T} -> SynHom C S T -> SynHom C R S -> SynHom C R T 26 | f ∘Syn g = compSyn g f 27 | 28 | _；Syn_ : ∀ {C R S T} -> SynHom C R S -> SynHom C S T -> SynHom C R T 29 | _；Syn_ = compSyn 30 | 31 | infixl 4 _；Syn_ 32 | infixr 9 _∘Syn_ 33 | 34 | 35 | -- the morphisms the syntax denotes 36 | ⟦_⟧Sy : ∀ {C S T} → SynHom C S T -> Hom C S T 37 | ⟦ < f > ⟧Sy = f 38 | ⟦_⟧Sy {C = C} idSyn = id C 39 | ⟦_⟧Sy {C = C} (compSyn f g) = comp C ⟦ f ⟧Sy ⟦ g ⟧Sy 40 | ⟦ fmapSyn F f ⟧Sy = fmap F ⟦ f ⟧Sy 41 | ⟦ -[ f ]- ⟧Sy = ⟦ f ⟧Sy 42 | 43 | -- iterated functor application 44 | data MapPile (C : Category) : Obj C -> Obj C -> Set 45 | where 46 | <_> : forall {S T} -> Hom C S T -> MapPile C S T 47 | fmapSyn : ∀ {C' S' T'} → (F : Functor C' C) -> MapPile C' S' T' -> 48 | MapPile C (act F S') (act F T') 49 | 50 | ⟦_⟧MP : ∀ {C S T} → MapPile C S T -> Hom C S T 51 | ⟦ < f > ⟧MP = f 52 | ⟦ fmapSyn F m ⟧MP = fmap F ⟦ m ⟧MP 53 | 54 | ⟦_⟧MPs : ∀ {C S T} → Star (MapPile C) S T -> Hom C S T 55 | ⟦_⟧MPs {C} ε = id C 56 | ⟦_⟧MPs {C} (m ◅ ms) = comp C ⟦ m ⟧MP ⟦ ms ⟧MPs 57 | 58 | -- normalise a syntactic morphism 59 | normSyn : ∀ {C S T} → SynHom C S T -> Star (MapPile C) S T 60 | normSyn < f > = return < f > 61 | normSyn idSyn = ε 62 | normSyn (compSyn d d') = normSyn d ◅◅ normSyn d' 63 | normSyn (fmapSyn F d) = kleisliStar (act F) (return ∘′ fmapSyn F) (normSyn d) 64 | normSyn -[ d ]- = normSyn d 65 | 66 | normSynSound : ∀ {C S T} → (d : SynHom C S T) -> ⟦ d ⟧Sy ≡ ⟦ normSyn d ⟧MPs 67 | normSynSound {C} < f > = sym (identityʳ C {f = f}) 68 | normSynSound idSyn = refl 69 | normSynSound {C} (compSyn d d') = begin 70 | comp C ⟦ d ⟧Sy ⟦ d' ⟧Sy 71 | ≡⟨ cong₂ (comp C) (normSynSound d) (normSynSound d') ⟩ 72 | comp C ⟦ normSyn d ⟧MPs ⟦ normSyn d' ⟧MPs 73 | ≡˘⟨ MPsLemma (normSyn d) (normSyn d') ⟩ 74 | ⟦ normSyn d ◅◅ normSyn d' ⟧MPs 75 | ∎ where 76 | open ≡-Reasoning 77 | MPsLemma : ∀ {C S T U} → 78 | (xs : Star (MapPile C) S T)(ys : Star (MapPile C) T U) -> 79 | ⟦ xs ◅◅ ys ⟧MPs ≡ comp C ⟦ xs ⟧MPs ⟦ ys ⟧MPs 80 | MPsLemma {C} ε ys = sym (identityˡ C) 81 | MPsLemma {C} (x ◅ xs) ys rewrite MPsLemma xs ys = assoc C 82 | 83 | normSynSound {C} (fmapSyn F d) = begin 84 | fmap F ⟦ d ⟧Sy 85 | ≡⟨ cong (fmap F) (normSynSound d) ⟩ 86 | fmap F ⟦ normSyn d ⟧MPs 87 | ≡⟨ kleisliStarLemma F (normSyn d) ⟩ 88 | ⟦ kleisliStar (act F) (return ∘′ fmapSyn F) (normSyn d) ⟧MPs 89 | ∎ where 90 | open ≡-Reasoning 91 | kleisliStarLemma : ∀ {C C' S' T'} (F : Functor C' C) -> 92 | (ms : Star (MapPile C') S' T') -> 93 | fmap F ⟦ ms ⟧MPs ≡ 94 | ⟦ kleisliStar (act F) (return ∘′ fmapSyn F) ms ⟧MPs 95 | kleisliStarLemma F ε = identity F 96 | kleisliStarLemma F (m ◅ ms) rewrite sym (kleisliStarLemma F ms) 97 | = homomorphism F 98 | normSynSound -[ d ]- = normSynSound d 99 | 100 | -- to help with type inference 101 | record _≡Hom_ {C S T} (f g : SynHom C S T) : Set where 102 | constructor homEq 103 | field 104 | eqArr : ⟦ f ⟧Sy ≡ ⟦ g ⟧Sy 105 | open _≡Hom_ public 106 | 107 | solveCat : ∀ {C S T} → {d d' : SynHom C S T} -> 108 | normSyn d ≡ normSyn d' -> d ≡Hom d' 109 | eqArr (solveCat {d = d} {d' = d'} q) = begin 110 | ⟦ d ⟧Sy 111 | ≡⟨ normSynSound d ⟩ 112 | ⟦ normSyn d ⟧MPs 113 | ≡⟨ cong ⟦_⟧MPs q ⟩ 114 | ⟦ normSyn d' ⟧MPs 115 | ≡˘⟨ normSynSound d' ⟩ 116 | ⟦ d' ⟧Sy 117 | ∎ where open ≡-Reasoning 118 | 119 | 120 | HomEq : ∀ {C S T S' T'} → (d : SynHom C S T)(d' : SynHom C S' T') -> Set 121 | HomEq {C} {S} {T} {S'} {T'} d d' = 122 | Σ (S ≡ S') λ { refl → Σ (T ≡ T') λ { refl → d ≡Hom d' } } 123 | 124 | Reduced : ∀ {C S T S' T'} → (d : SynHom C S T)(d' : SynHom C S' T') -> Set 125 | Reduced (idSyn {T}) (idSyn {T'}) = T ≡ T' 126 | Reduced (compSyn f g) (compSyn f' g') = Reduced g g' × Reduced f f' 127 | Reduced d d' = HomEq d d' 128 | 129 | -- Reduced obligations are enough 130 | reduced' : ∀ {C S T S' T'} → (d : SynHom C S T)(d' : SynHom C S' T') -> 131 | Reduced d d' -> HomEq d d' 132 | reduced' idSyn idSyn refl = refl , refl , homEq refl 133 | reduced' {C} (compSyn f g) (compSyn f' g') (rg , rf) 134 | with refl , refl , homEq qf ← reduced' f f' rf 135 | | refl , refl , homEq qg ← reduced' g g' rg 136 | = refl , refl , homEq (cong₂ (comp C) qf qg) 137 | reduced' {C} (compSyn f g) < x > r = r 138 | reduced' {C} (compSyn f g) idSyn r = r 139 | reduced' {C} (compSyn f g) (fmapSyn F d') r = r 140 | reduced' {C} (compSyn f g) -[ d' ]- r = r 141 | reduced' < x > d' r = r 142 | reduced' idSyn < x > r = r 143 | reduced' idSyn (compSyn d' d'') r = r 144 | reduced' idSyn (fmapSyn F d') r = r 145 | reduced' idSyn -[ d' ]- r = r 146 | reduced' (fmapSyn F d) d' r = r 147 | reduced' -[ d ]- d' r = r 148 | 149 | reduced : ∀ {C S T} → {d d' : SynHom C S T} -> Reduced d d' -> d ≡Hom d' 150 | reduced {d = d} {d'} r with refl , refl , q ← reduced' d d' r = q 151 | 152 | 153 | -- convenience constructors 154 | rd : ∀ {C S T} → {d : SynHom C S T} -> HomEq d d 155 | rd = refl , refl , homEq refl 156 | 157 | rq : ∀ {C S T} → {d d' : SynHom C S T} -> ⟦ d ⟧Sy ≡ ⟦ d' ⟧Sy -> HomEq d d' 158 | rq q = refl , refl , homEq q 159 | 160 | -- "semantic" equational reasoning 161 | 162 | open ≡-Reasoning 163 | 164 | _⊧begin_ : ∀ C {S T} → {d d' : SynHom C S T} -> 165 | d ≡Hom d' -> ⟦ d ⟧Sy ≡ ⟦ d' ⟧Sy 166 | C ⊧begin q = eqArr q 167 | 168 | _≡⟦_⟧_ : ∀ {C S T}(d0 : SynHom C S T){d1 d2} -> 169 | d0 ≡Hom d1 -> d1 ≡Hom d2 -> d0 ≡Hom d2 170 | eqArr (d0 ≡⟦ q1 ⟧ q2) = ⟦ d0 ⟧Sy ≡⟨ eqArr q1 ⟩ eqArr q2 171 | 172 | _≡˘⟦_⟧_ : ∀ {C S T}(d0 : SynHom C S T){d1 d2} -> 173 | d1 ≡Hom d0 -> d1 ≡Hom d2 -> d0 ≡Hom d2 174 | eqArr (d0 ≡˘⟦ q1 ⟧ q2) = ⟦ d0 ⟧Sy ≡˘⟨ eqArr q1 ⟩ eqArr q2 175 | 176 | _⟦∎⟧ : ∀ {C S T}(d : SynHom C S T) -> d ≡Hom d 177 | eqArr (d ⟦∎⟧) = refl 178 | 179 | 180 | infix 3 _⟦∎⟧ 181 | infixr 2 _≡⟦_⟧_ _≡˘⟦_⟧_ 182 | infix 1 _⊧begin_ 183 | -------------------------------------------------------------------------------- /Lectures/Week3.agda: -------------------------------------------------------------------------------- 1 | module Lectures.Week3 where 2 | 3 | open import Data.Nat 4 | open import Data.List as List using (List; []; _∷_; _++_; [_]) 5 | open import Data.Vec as Vec hiding (reverse) 6 | open import Data.Empty 7 | open import Data.Unit 8 | open import Data.Sum 9 | open import Data.Product 10 | open import Relation.Binary.PropositionalEquality 11 | hiding (sym; trans; subst) 12 | 13 | open import Lectures.Week2 14 | 15 | ---------------------------------------------------------------------- 16 | -- Classical logic 17 | ---------------------------------------------------------------------- 18 | 19 | -- You might remember the following principles from mathematics. What 20 | -- would a program of such a type look like? 21 | 22 | -- the law of excluded middle 23 | 24 | LEM : Set1 25 | LEM = {P : Set} -> P ⊎ ¬ P 26 | 27 | {- 28 | lem : LEM 29 | lem {P} = {!!} -- not implementable! If it was, we could solve the halting problem 30 | -} 31 | 32 | -- double negation elimination 33 | 34 | DNE : Set1 35 | DNE = {P : Set} -> ¬ ¬ P -> P 36 | 37 | {- 38 | dne : DNE 39 | dne {P} nnp with nnp (\ p -> nnp \ p' -> {!!}) -- does not seem to be implementable either 40 | ... | () 41 | -} 42 | 43 | -- this shows that DNE is as unimplementable as LEM 44 | DNE→LEM : DNE -> LEM 45 | DNE→LEM dne {P} = dne {P ⊎ ¬ P} (λ npnp → npnp (inj₂ \ p -> npnp (inj₁ p))) 46 | 47 | -- ...and vice versa 48 | LEM→DNE : LEM -> DNE 49 | LEM→DNE lem {P} nnp with lem {P} 50 | LEM→DNE lem {P} nnp | inj₁ p = p 51 | LEM→DNE lem {P} nnp | inj₂ np with nnp np 52 | LEM→DNE lem {P} nnp | inj₂ np | () 53 | 54 | 55 | ---------------------------------------------------------------------- 56 | -- Quantifiers: for every, for some 57 | ---------------------------------------------------------------------- 58 | 59 | 60 | {- Universal quantification ∀ -} 61 | 62 | -- Q: What is a proof of (∀ x : A) P(x)? 63 | 64 | -- A: A method which produces a proof of P(a) for any given a : A -- a dependent function! 65 | 66 | ex12 : (n : ℕ) -> isEven n ⊎ isEven (suc n) 67 | ex12 zero = inj₁ tt 68 | ex12 (suc zero) = inj₂ tt 69 | ex12 (suc (suc n)) = ex12 n 70 | 71 | -- Note: `A → B` is "just" (_ : A) -> B 72 | 73 | {- Existential quantification ∃ -} 74 | 75 | -- Q: What is a proof of (∃ x : A) P(x)? 76 | 77 | 78 | -- A: A pair of an a : A and a proof of P(a) -- a dependent pair! 79 | 80 | ex13 : Σ ℕ isEven 81 | ex13 = 42 , tt 82 | 83 | ex13' : Σ ℕ isEven 84 | ex13' = 18 , tt 85 | 86 | ex14 : Σ ℕ (\ n -> isEven n) -> Σ ℕ (λ n → ¬ (isEven n)) 87 | ex14 (zero , _) = 1 , λ x → x 88 | ex14 (suc zero , ()) 89 | ex14 (suc (suc n) , en) = ex14 (n , en) 90 | 91 | -- Note: A × B is "just" Σ[ _ ∈ A ] B 92 | 93 | ---------------------------------------------------------------------- 94 | -- Equality, again 95 | ---------------------------------------------------------------------- 96 | 97 | -- Useful/expected properties of ≡: 98 | 99 | sym : {A : Set} -> {x y : A} -> x ≡ y -> y ≡ x 100 | sym refl = refl 101 | 102 | trans : {A : Set} -> {x y z : A} -> x ≡ y -> y ≡ z -> x ≡ z 103 | trans refl q = q 104 | -- trans p refl = p 105 | -- trans refl refl = refl 106 | 107 | subst : {A : Set} -> (P : A -> Set) -> {x y : A} -> x ≡ y -> P x -> P y 108 | subst P refl px = px 109 | 110 | 111 | -- FUN EXERCISE: basically everything is a special case of subst 112 | 113 | -- "why is it stuck?" 114 | 115 | +-assoc : (n m k : ℕ) -> ((n + m) + k) ≡ (n + (m + k)) 116 | +-assoc zero m k = refl 117 | +-assoc (suc n) m k rewrite (+-assoc n m k) = refl 118 | 119 | open ≡-Reasoning 120 | 121 | *-distribʳ-+ : (m n k : ℕ) -> (n + k) * m ≡ n * m + k * m 122 | *-distribʳ-+ m zero k = refl 123 | *-distribʳ-+ m (suc n) k = begin 124 | (suc n + k) * m 125 | ≡⟨⟩ 126 | m + ((n + k) * m) 127 | ≡⟨ cong (m +_) (*-distribʳ-+ m n k) ⟩ -- \==\< ? \> 128 | m + (n * m + k * m) 129 | ≡⟨ sym (+-assoc m (n * m) (k * m)) ⟩ -- \==\< ? \> 130 | (m + n * m) + k * m 131 | ∎ -- \qed 132 | -- C-u C-u C-c C-s "solve everything you can, with as much normalisation as possible" 133 | 134 | 135 | -- Reversing vectors with an accumulator 136 | 137 | -- we can reverse lists naively (complexity O(n²)) 138 | 139 | revList : {A : Set} -> List A -> List A 140 | revList [] = [] 141 | revList (x ∷ xs) = revList xs List.++ List.[ x ] 142 | 143 | -- we can also reverse lists in a fast way (complexity O(n)): 144 | 145 | revListFast : {A : Set} -> List A -> List A -> List A 146 | revListFast acc [] = acc 147 | revListFast acc (x ∷ xs) = revListFast (x ∷ acc) xs 148 | 149 | -- let's do the same for vectors! 150 | 151 | revAcc : {A : Set}{acc-length m : ℕ} -> Vec A acc-length -> Vec A m -> Vec A (acc-length + m) 152 | revAcc {A} {n} acc [] = subst (Vec A) (lemma n) acc where 153 | lemma : (n : ℕ) → n ≡ n + 0 154 | lemma zero = refl 155 | lemma (suc n) = cong suc (lemma n) 156 | revAcc {A} {n} acc (x ∷ xs) = subst (Vec A) (lemma n _) (revAcc (x ∷ acc) xs) 157 | where 158 | lemma : (n m : ℕ) → suc (n + m) ≡ n + suc m 159 | lemma zero m = refl 160 | lemma (suc n) m = cong suc (lemma n m) 161 | 162 | reverse : {A : Set}{m : ℕ} -> Vec A m -> Vec A m 163 | reverse = revAcc [] 164 | 165 | 166 | t = reverse (1 ∷ 2 ∷ 3 ∷ []) 167 | -- C-c C-n t "normalise" 168 | 169 | 170 | 171 | ---------------------------------------------------------------------- 172 | -- Structural equalities (not covered in lecture) 173 | --------------------------------------------------------------------- 174 | 175 | ----------------------------- 176 | -- When are two pairs equal? 177 | ----------------------------- 178 | 179 | pair-≡ : {A B : Set} {a a' : A}{b b' : B} -> 180 | a ≡ a' -> b ≡ b' -> (a , b) ≡ (a' , b') 181 | pair-≡ refl refl = refl -- if components are equal 182 | 183 | pair-≡-inverse : {A B : Set} {a a' : A}{b b' : B} -> 184 | (a , b) ≡ (a' , b') -> (a ≡ a') × (b ≡ b') 185 | pair-≡-inverse p = (cong proj₁ p , cong proj₂ p) -- *only* if components are equal 186 | 187 | -- So equality of pairs is a pair of equalities 188 | 189 | ----------------------------------- 190 | -- When are dependent pairs equal? 191 | ----------------------------------- 192 | 193 | -- Similarly for dependent pairs: we need to use `subst` and the first 194 | -- equality p to fix up the type of the second equality 195 | 196 | dpair-≡ : {A : Set}{B : A -> Set} {a a' : A}{b : B a}{b' : B a'} -> 197 | (p : a ≡ a') -> (q : subst B p b ≡ b') -> 198 | (a , b) ≡ (a' , b') 199 | dpair-≡ refl refl = refl -- when we pattern match on `p`, the type of `q` gets simplified 200 | 201 | ----------------------------- 202 | -- When are functions equal? 203 | ----------------------------- 204 | 205 | postulate 206 | -- not provable 207 | funext : {A : Set}{B : A -> Set}{f f' : (x : A) -> B x} -> 208 | ((x : A) -> f x ≡ f' x) -> f ≡ f' 209 | 210 | -- We often make use of this assumed fact, since we want to consider 211 | -- functions that have the same "input-output behaviour" as the same 212 | 213 | ----------------------------------- 214 | -- When are equality proofs equal? 215 | ----------------------------------- 216 | 217 | UIP : {A : Set}{x y : A}(p q : x ≡ y) -> p ≡ q 218 | UIP refl refl = refl 219 | 220 | -- "uniqueness of identity proofs"; interesting things possible if we 221 | -- don't insist on this! 222 | -------------------------------------------------------------------------------- /Lectures/Week9.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --type-in-type #-} 2 | module Lectures.Week9 where 3 | 4 | open import Relation.Binary.PropositionalEquality 5 | open import Data.Product 6 | open import Axiom.Extensionality.Propositional 7 | 8 | open import Lectures.Week6 hiding (SET) 9 | open import Lectures.Week7 10 | open import Lectures.Week8 11 | 12 | 13 | open import Common.Category 14 | open import Common.Category.Adjunctions 15 | open import Common.Category.Solver 16 | 17 | --------------------------------------------------------------------------- 18 | -- Free categories 19 | --------------------------------------------------------------------------- 20 | 21 | open Category 22 | open Functor 23 | open Adjunction 24 | 25 | REL : Category 26 | Obj REL = Σ[ A ∈ Set ] (A → A → Set) 27 | Hom REL (A , R) (A' , R')= Σ[ f ∈ (A → A') ] (∀{a b} → R a b → R' (f a) (f b)) 28 | id REL = (id SET) , λ p → p 29 | comp REL (f , p) (g , q) = (comp SET f g) , λ x → q (p x) 30 | assoc REL = refl 31 | identityˡ REL = refl 32 | identityʳ REL = refl 33 | 34 | 35 | 36 | forgetCategory : Functor CAT REL 37 | act forgetCategory C = (Obj C) , (Hom C) 38 | fmap forgetCategory F = (act F) , (fmap F) 39 | identity forgetCategory = refl 40 | homomorphism forgetCategory = refl 41 | 42 | 43 | 44 | data Star {A : Set}(R : A -> A -> Set) : A -> A -> Set where 45 | ε : ∀ {a} → Star R a a 46 | _∷_ : ∀ {a b c} → R a b -> Star R b c -> Star R a c 47 | 48 | _++S_ : {A : Set}{R : A -> A -> Set} -> {a b c : A} -> Star R a b -> Star R b c -> Star R a c 49 | ε ++S ys = ys 50 | (x ∷ xs) ++S ys = x ∷ (xs ++S ys) 51 | 52 | assoc-++S : {A : Set}{R : A -> A -> Set} -> 53 | ∀{a b c d}(f : Star R a b)(g : Star R b c)(h : Star R c d) -> 54 | f ++S (g ++S h) ≡ (f ++S g) ++S h 55 | assoc-++S ε g h = refl 56 | assoc-++S (x ∷ f) g h = cong (x ∷_) (assoc-++S f g h) 57 | 58 | ++S-identityʳ : {A : Set}{R : A -> A -> Set}{a b : A}(f : Star R a b) → f ++S ε ≡ f 59 | ++S-identityʳ ε = refl 60 | ++S-identityʳ (x ∷ f) = cong (x ∷_) (++S-identityʳ f) 61 | 62 | mapS : {A B : Set}{R : A -> A -> Set}{Q : B -> B -> Set} -> 63 | (f : A -> B)(p : ∀ a a' → R a a' -> Q (f a) (f a')) -> 64 | {a a' : A} -> Star R a a' -> Star Q (f a) (f a') 65 | mapS f p ε = ε 66 | mapS f p (x ∷ xs) = p _ _ x ∷ mapS f p xs 67 | 68 | mapS-++ : {A B : Set}{R : A -> A -> Set}{Q : B -> B -> Set} -> 69 | (f : A -> B)(p : ∀ a a' → R a a' -> Q (f a) (f a')) -> 70 | {a b c : A} -> (xs : Star R a b)(ys : Star R b c) -> 71 | mapS {Q = Q} f p (xs ++S ys) ≡ mapS f p xs ++S mapS f p ys 72 | mapS-++ f p ε ys = refl 73 | mapS-++ f p (x ∷ xs) ys = cong (p _ _ x ∷_) (mapS-++ f p xs ys) 74 | 75 | mapS-id : ∀ {A R}{a b : A}(xs : Star R a b) -> mapS (id SET) (λ a b r → r) xs ≡ xs 76 | mapS-id ε = refl 77 | mapS-id (x ∷ xs) = cong (x ∷_) (mapS-id xs) 78 | 79 | mapS-∘ : {A A' A'' : Set} 80 | {R : A -> A -> Set}{R' : A' -> A' -> Set}{R'' : A'' -> A'' -> Set} -> 81 | (f : A -> A')(p : ∀ a a' → R a a' -> R' (f a) (f a')) -> 82 | (f' : A' -> A'')(p' : ∀ a a' → R' a a' -> R'' (f' a) (f' a')) -> 83 | {a b : A} -> (xs : Star R a b) -> 84 | mapS {Q = R''} (comp SET f f') (λ a b r → p' _ _ (p _ _ r)) xs ≡ mapS f' p' (mapS f p xs) 85 | mapS-∘ f p f' p' ε = refl 86 | mapS-∘ f p f' p' (x ∷ xs) = cong (p' (f _) (f _) (p _ _ x) ∷_) (mapS-∘ f p f' p' xs) 87 | 88 | 89 | 90 | freeCategory : Functor REL CAT 91 | Obj (act freeCategory (A , R)) = A 92 | Hom (act freeCategory (A , R)) = Star R 93 | id (act freeCategory (A , R)) = ε 94 | comp (act freeCategory (A , R)) = _++S_ 95 | assoc (act freeCategory (A , R)) {f = f} {g} {h} = assoc-++S f g h 96 | identityˡ (act freeCategory (A , R)) = refl 97 | identityʳ (act freeCategory (A , R)) = ++S-identityʳ _ 98 | act (fmap freeCategory (f , p)) = f 99 | fmap (fmap freeCategory (f , p)) = mapS f (λ _ _ → p) 100 | identity (fmap freeCategory (f , p)) = refl 101 | homomorphism (fmap freeCategory (f , p)) {g = g} = mapS-++ f _ _ g 102 | identity freeCategory = eqFunctor refl (ext mapS-id) 103 | homomorphism freeCategory = eqFunctor refl (ext (mapS-∘ _ _ _ _ )) 104 | 105 | foldStar : {A : Set}{R : A → A → Set}(B : Category) → 106 | (f : A → Obj B)(p :{a b : A} → R a b → Hom B (f a) (f b)) → 107 | {X Y : A} → Star R X Y → Hom B (f X) (f Y) 108 | foldStar B f p ε = id B 109 | foldStar B f p (r ∷ rs) = comp B (p r) (foldStar B f p rs) 110 | 111 | freeCatisFree : Adjunction freeCategory forgetCategory 112 | to freeCatisFree {A , R} {B} F = act F , λ r → fmap F (r ∷ ε) 113 | act (from freeCatisFree {A , R} (f , p)) = f 114 | fmap (from freeCatisFree {A , R} {B} (f , p)) = foldStar B f p 115 | identity (from freeCatisFree (f , p)) = refl 116 | homomorphism (from freeCatisFree {A , R} {B} (f , p)) {f = ε} = sym (identityˡ B) 117 | homomorphism (from freeCatisFree {A , R} {B} (f , p)) {f = r ∷ rs} = 118 | trans (cong (comp B (p r)) (homomorphism (from freeCatisFree {A , R} {B} (f , p)) {f = rs})) (assoc B) 119 | left-inverse-of freeCatisFree {A , R} {B} F = eqFunctor refl (ext lemma) 120 | where 121 | lemma : ∀ {A₁ B₁} → (x : Star R A₁ B₁) → foldStar B (act F) (λ r → fmap F (r ∷ ε)) x ≡ fmap F x 122 | lemma ε = sym (identity F) 123 | lemma (x ∷ rs) rewrite lemma rs = sym (homomorphism F) 124 | right-inverse-of freeCatisFree {A , R} {B} (f , p) = cong (f ,_) (iext (iext (ext λ r → identityʳ B))) 125 | where 126 | iext = implicit-extensionality ext 127 | to-natural freeCatisFree {A , R} {B} f g = refl 128 | 129 | --------------------------------------------------------------------------- 130 | -- Monads from adjunctions 131 | --------------------------------------------------------------------------- 132 | 133 | open Monad 134 | open NaturalTransformation 135 | 136 | 137 | monadFromAdj : (C D : Category)(F : Functor C D)(G : Functor D C) -> 138 | Adjunction F G -> Monad C 139 | functor (monadFromAdj C D F G adj) = comp CAT F G 140 | transform (returnNT (monadFromAdj C D F G adj)) X = to adj (id D) 141 | natural (returnNT (monadFromAdj C D F G adj)) X Y f = trans (to-natural₁ adj f) (sym (to-natural₂ adj (fmap F f))) 142 | transform (joinNT (monadFromAdj C D F G adj)) X = fmap G (from adj (id C)) 143 | natural (joinNT (monadFromAdj C D F G adj)) X Y f = C ⊧begin 144 | fmapSyn G < from adj (id C) > ∘Syn fmapSyn G (fmapSyn F (fmapSyn G (fmapSyn F < f > ))) 145 | ≡⟦ solveCat refl ⟧ 146 | fmapSyn G (< from adj (id C) > ∘Syn fmapSyn F (fmapSyn G (fmapSyn F < f > ))) 147 | ≡⟦ reduced (rq (cong (fmap G) (trans (from-natural₁ adj (fmap G (fmap F f))) (sym (from-natural₂ adj (fmap F f)))))) ⟧ 148 | fmapSyn G (fmapSyn F < f > ∘Syn < from adj (id C) >) 149 | ≡⟦ solveCat refl ⟧ 150 | fmapSyn G (fmapSyn F < f >) ∘Syn fmapSyn G < from adj (id C) > 151 | ⟦∎⟧ 152 | returnJoin (monadFromAdj C D F G adj) = C ⊧begin 153 | -[ fmapSyn G < from adj (id C) > ∘Syn < to adj (id D) > ]- 154 | ≡⟦ reduced (rq (to-natural₂ adj (from adj (id C)))) ⟧ 155 | < to adj (from adj (id C)) > 156 | ≡⟦ reduced (rq (right-inverse-of adj (id C))) ⟧ 157 | idSyn 158 | ⟦∎⟧ 159 | mapReturnJoin (monadFromAdj C D F G adj) = C ⊧begin 160 | fmapSyn G < from adj (id C) > ∘Syn fmapSyn G (fmapSyn F < to adj (id D) >) 161 | ≡⟦ solveCat refl ⟧ 162 | fmapSyn G (< from adj (id C) > ∘Syn fmapSyn F < to adj (id D) >) 163 | ≡⟦ reduced (rq (cong (fmap G) (trans (from-natural₁ adj (to adj (id D))) (left-inverse-of adj (id D))))) ⟧ 164 | fmapSyn G idSyn 165 | ≡⟦ solveCat refl ⟧ 166 | idSyn 167 | ⟦∎⟧ 168 | joinJoin (monadFromAdj C D F G adj) = C ⊧begin 169 | fmapSyn G < from adj (id C) > ∘Syn fmapSyn G < from adj (id C) > 170 | ≡⟦ solveCat refl ⟧ 171 | fmapSyn G (< from adj (id C) > ∘Syn < from adj (id C) >) 172 | ≡⟦ reduced (rq (cong (fmap G) (D ⊧begin 173 | -[ < from adj (id C) > ∘Syn < from adj (id C) > ]- 174 | ≡⟦ reduced (rq (from-natural₂ adj (from adj (id C)))) ⟧ 175 | < from adj (fmap G (from adj (id C))) > 176 | ≡⟦ reduced (rq (sym (from-natural₁ adj (fmap G (from adj (id C)))))) ⟧ 177 | < from adj (id C) > ∘Syn fmapSyn F (fmapSyn G < from adj (id C) >) 178 | ⟦∎⟧))) ⟧ 179 | fmapSyn G (< from adj (id C) > ∘Syn fmapSyn F (fmapSyn G < from adj (id C) >)) 180 | ≡⟦ solveCat refl ⟧ 181 | fmapSyn G < from adj (id C) > ∘Syn fmapSyn G (fmapSyn F (fmapSyn G < from adj (id C) >)) 182 | ⟦∎⟧ 183 | 184 | -------------------------------------------------------------------------------- /Lectures/Week8.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --type-in-type #-} 2 | module Lectures.Week8 where 3 | 4 | open import Data.Nat hiding (_≤_) 5 | open import Function using (_∘_) 6 | open import Data.Product 7 | open import Data.Sum 8 | open import Data.Unit using (⊤; tt) 9 | 10 | open import Relation.Binary.PropositionalEquality 11 | 12 | open import Common.Category 13 | open import Common.Category.Adjunctions 14 | 15 | 16 | open import Lectures.Week7 17 | 18 | --------------------------------------------------------------------------- 19 | -- Kleisli categories 20 | --------------------------------------------------------------------------- 21 | 22 | open import Common.Category.Solver 23 | 24 | module _ {C : Category} where 25 | 26 | open Category 27 | open Monad 28 | open NaturalTransformation 29 | 30 | Kleisli : Monad C -> Category 31 | Obj (Kleisli M) = Obj C 32 | Hom (Kleisli M) X Y = Hom C X (act M Y) 33 | id (Kleisli M) = return M _ 34 | comp (Kleisli M) f g = comp C f (comp C (fmap M g) (join M _)) 35 | identityʳ (Kleisli M) {f = f} = begin 36 | comp C f (comp C (Functor.fmap (functor M) (return M _)) (join M _)) 37 | ≡⟨ cong (comp C f) (mapReturnJoin M) ⟩ 38 | comp C f (id C) 39 | ≡⟨ identityʳ C ⟩ 40 | f ∎ where open ≡-Reasoning 41 | identityˡ (Kleisli M) {f = g} = C ⊧begin 42 | compSyn < return M _ > (compSyn (fmapSyn (functor M) < g >) < join M _ >) 43 | ≡⟦ solveCat refl ⟧ 44 | -[ < return M _ > ；Syn fmapSyn (functor M) < g > ]- ；Syn < join M _ > 45 | ≡⟦ reduced (rd , rq (sym (natural (returnNT M) _ _ g))) ⟧ 46 | -[ < g > ；Syn < return M _ > ]- ；Syn < join M _ > 47 | ≡⟦ solveCat refl ⟧ 48 | < g > ；Syn -[ < return M _ > ；Syn < join M _ > ]- 49 | ≡⟦ reduced ((rq (returnJoin M)) , rd) ⟧ 50 | < g > ；Syn -[ idSyn ]- 51 | ≡⟦ solveCat refl ⟧ 52 | < g > 53 | ⟦∎⟧ 54 | assoc (Kleisli M) {f = f} {g} {h} = C ⊧begin 55 | compSyn < f > (compSyn (fmapSyn (functor M) (compSyn < g > (compSyn (fmapSyn (functor M) < h >) < join M _ >))) < join M _ > ) 56 | ≡⟦ solveCat refl ⟧ 57 | < f > ；Syn fmapSyn (functor M) < g > ；Syn fmapSyn (functor M) (fmapSyn (functor M) < h >) ；Syn -[ fmapSyn (functor M) < join M _ > ；Syn < join M _ > ]- 58 | ≡⟦ reduced (rq (sym (joinJoin M)) , rd , rd , rd) ⟧ 59 | < f > ；Syn fmapSyn (functor M) < g > ；Syn fmapSyn (functor M) (fmapSyn (functor M) < h >) ；Syn -[ < join M _ > ；Syn < join M _ > ]- 60 | ≡⟦ solveCat refl ⟧ 61 | < f > ；Syn fmapSyn (functor M) < g > ；Syn -[ fmapSyn (functor M) (fmapSyn (functor M) < h >) ；Syn < join M _ > ]- ；Syn < join M _ > 62 | ≡⟦ reduced (rd , rq (natural (joinNT M) _ _ h) , rd , rd) ⟧ 63 | < f > ；Syn (fmapSyn (functor M) < g >) ；Syn -[ < join M _ > ；Syn fmapSyn (functor M) < h > ]- ；Syn < join M _ > 64 | ≡⟦ solveCat refl ⟧ 65 | compSyn (compSyn < f > (compSyn (fmapSyn (functor M) < g >) < join M _ >)) 66 | (compSyn (fmapSyn (functor M) < h >) < join M _ >) 67 | ⟦∎⟧ 68 | 69 | --------------------------------------------------------------------------- 70 | -- Interlude: a solver for equations in categories 71 | --------------------------------------------------------------------------- 72 | 73 | open import Common.Category.Solver 74 | 75 | module _ {C : Category} where 76 | 77 | open Category C 78 | open Functor 79 | 80 | {- 81 | 82 | F X 83 | | \ F f 84 | F id | ---------- 85 | | \ 86 | v v 87 | F X ----------> F X 88 | | F f | 89 | | | 90 | g | | g 91 | | | 92 | v F h v F k 93 | F Y ----------> F Y ----------> F Z 94 | | ^ 95 | \------------------------------/ 96 | F (h ; k) 97 | -} 98 | 99 | 100 | example : {X Y Z : Obj}(F : Functor C C) -> 101 | (f : Hom X X)(g : Hom (act F X) (act F Y))(h : Hom Y Y)(k : Hom Y Z) -> 102 | (assumption : comp (fmap F f) g ≡ comp g (fmap F h)) -> 103 | comp (fmap F id) (comp g (fmap F (comp h k))) 104 | ≡ comp (comp (fmap F f) g) (fmap F k) 105 | example F f g h k p = C ⊧begin -- \models 106 | compSyn (fmapSyn F idSyn) (compSyn < g > (fmapSyn F (compSyn < h > < k >))) 107 | ≡⟦ solveCat refl ⟧ -- \[[ \]] 108 | -[ < g > ；Syn fmapSyn F < h > ]- ；Syn fmapSyn F < k > -- \; 109 | ≡⟦ reduced (rd , rq (sym p)) ⟧ 110 | -[ fmapSyn F < f > ；Syn < g > ]- ；Syn fmapSyn F < k > 111 | ≡⟦ solveCat refl ⟧ 112 | compSyn (compSyn (fmapSyn F < f > ) < g > ) (fmapSyn F < k >) 113 | ⟦∎⟧ 114 | 115 | 116 | 117 | 118 | {- Solver summary: 119 | 120 | 1. Basic format to prove f ≡ g: 121 | C ⊧begin fSyn ≡⟦ p₁ ⟧ f₁ ≡⟦ p₂ ⟧ f₂ ≡⟦ ... ⟧ gSyn ⟦∎⟧ 122 | where fSyn, gStn are "syntactic copies" of f, g: 123 | comp replaced by compSyn 124 | id replaced by idSyn 125 | fmap replaced by fmapSyn 126 | other morphisms h replaced by < h > 127 | 2. Reshuffling brackets, identity laws and functors preserving id and 128 | comp you get for free with "solveCat refl" 129 | 3. For interesting equations, place -[ focus ]- and prove with 130 | reduced (rd, ... , rq p , rd ...) 131 | where p proves interesting equation. 132 | -} 133 | 134 | --------------------------------------------------------------------------- 135 | -- Adjunctions 136 | --------------------------------------------------------------------------- 137 | 138 | open Category 139 | open Functor 140 | 141 | open import Lectures.Week6 hiding (SET) 142 | open Preorder 143 | open MonotoneMap 144 | 145 | ----------------- 146 | -- Order, order! 147 | ----------------- 148 | 149 | forget : Functor PREORDER SET 150 | act forget X = Carrier X 151 | fmap forget f = fun f 152 | identity forget = refl 153 | homomorphism forget = refl 154 | 155 | -- Recall smallestOrder : SET → PREORDER 156 | 157 | morphismOutOfSmallestOrder : {X : Set}{P : Preorder} → 158 | Hom SET X (act forget P) → 159 | Hom PREORDER (act smallestOrder X) P 160 | fun (morphismOutOfSmallestOrder f) = f 161 | monotone (morphismOutOfSmallestOrder {P = P} f) x .x refl = reflexive P 162 | 163 | morphismOutOfSmallestOrderAllOfThem : {X : Set}{P : Preorder} → 164 | Hom PREORDER (act smallestOrder X) P → 165 | Hom SET X (act forget P) 166 | morphismOutOfSmallestOrderAllOfThem h = fun h 167 | 168 | -- The "Everything is related to everything else" construction 169 | 170 | chaotic : Functor SET PREORDER 171 | Carrier (act chaotic B) = B 172 | _≤_ (act chaotic B) b b' = ⊤ 173 | reflexive (act chaotic B) = tt 174 | transitive (act chaotic B) _ _ = tt 175 | propositional (act chaotic B) p q = refl 176 | fun (fmap chaotic f) = f 177 | monotone (fmap chaotic f) x y p = tt 178 | identity chaotic = eqMonotoneMap refl 179 | homomorphism chaotic = eqMonotoneMap refl 180 | 181 | morphismsIntoChaotic : {X : Set}{P : Preorder} → 182 | Hom SET (act forget P) X → 183 | Hom PREORDER P (act chaotic X) 184 | fun (morphismsIntoChaotic f) = f 185 | monotone (morphismsIntoChaotic f) x y p = tt 186 | 187 | 188 | ----------------------- 189 | -- Floors and ceilings 190 | ----------------------- 191 | 192 | {- 193 | Consider (ℚ, ≤) and (ℤ, ≤). Are they related? 194 | 195 | Yes, we have inject : (ℤ, ≤) → (ℚ, ≤) (order-preserving). 196 | 197 | [ If we see (ℤ, ≤) and (ℚ, ≤) as "boring" categories with at most one 198 | morphism between objects, inject is a functor.] 199 | 200 | What about (ℚ, ≤) → (ℤ, ≤)? 201 | 202 | floor : (ℚ, ≤) → (ℤ, ≤) 203 | ceiling : (ℚ, ≤) → (ℤ, ≤) 204 | 205 | How do these relate? 206 | 207 | 208 | ceiling q ≤ i in ℤ iff 209 | q ≤ inject i in ℚ 210 | 211 | i ≤ floor q iff 212 | inject i ≤ q 213 | 214 | -} 215 | 216 | 217 | ----------------------- 218 | -- The common pattern 219 | ----------------------- 220 | 221 | open import Common.Category.Adjunctions 222 | open Adjunction 223 | 224 | -- F ⊣ G "F is the left adjoint of G", "G is the right adjoint of F" 225 | 226 | discrete⊣forget : Adjunction smallestOrder forget 227 | to discrete⊣forget = morphismOutOfSmallestOrderAllOfThem 228 | from discrete⊣forget = morphismOutOfSmallestOrder 229 | left-inverse-of discrete⊣forget h = eqMonotoneMap refl 230 | right-inverse-of discrete⊣forget k = refl 231 | to-natural discrete⊣forget f g = refl 232 | 233 | forget⊣chaotic : Adjunction forget chaotic 234 | fun (to forget⊣chaotic f) = f 235 | monotone (to forget⊣chaotic f) = _ 236 | from forget⊣chaotic f = fun f 237 | left-inverse-of forget⊣chaotic h = refl 238 | right-inverse-of forget⊣chaotic h = eqMonotoneMap refl 239 | to-natural forget⊣chaotic f g = ext \ h -> eqMonotoneMap refl 240 | 241 | ----------------------- 242 | -- One more example 243 | ----------------------- 244 | 245 | PAIR : Category -> Category -> Category 246 | Obj (PAIR C D) = Obj C × Obj D 247 | Hom (PAIR C D) (X , Y) (X' , Y')= Hom C X X' × Hom D Y Y' 248 | id (PAIR C D) {X , Y} = id C , id D 249 | comp (PAIR C D) (f , g) (f' , g') = (comp C f f') , (comp D g g') 250 | assoc (PAIR C D) = cong₂ _,_ (assoc C) (assoc D) 251 | identityˡ (PAIR C D) = cong₂ _,_ (identityˡ C) (identityˡ D) 252 | identityʳ (PAIR C D) = cong₂ _,_ (identityʳ C) (identityʳ D) 253 | 254 | diag : {C : Category} -> Functor C (PAIR C C) 255 | act diag X = (X , X) 256 | fmap diag f = (f , f) 257 | identity diag = refl 258 | homomorphism diag = refl 259 | 260 | Either : Functor (PAIR SET SET) SET 261 | act Either (X , Y) = X ⊎ Y 262 | fmap Either (f , g) = Data.Sum.map f g 263 | identity Either = ext λ { (inj₁ x) → refl ; (inj₂ y) → refl } 264 | homomorphism Either = ext λ { (inj₁ x) → refl ; (inj₂ y) → refl } 265 | 266 | Either⊣diag : Adjunction Either (diag {SET}) 267 | to Either⊣diag {X , Y} f = (λ x → f (inj₁ x)) , (λ y → f (inj₂ y)) 268 | from Either⊣diag (h , k) (inj₁ x) = h x 269 | from Either⊣diag (h , k) (inj₂ y) = k y 270 | left-inverse-of Either⊣diag h = ext λ { (inj₁ x) → refl ; (inj₂ y) → refl } 271 | right-inverse-of Either⊣diag (f , g) = refl 272 | to-natural Either⊣diag (f , f') g = refl 273 | -------------------------------------------------------------------------------- /Lectures/Week6.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --type-in-type #-} 2 | module Lectures.Week6 where 3 | 4 | open import Data.Unit hiding (_≤_) 5 | open import Data.Product 6 | open import Data.Maybe 7 | 8 | open import Function as Fun 9 | 10 | open import Relation.Binary.PropositionalEquality 11 | open import Axiom.UniquenessOfIdentityProofs.WithK 12 | 13 | open import Common.Category hiding (SET) 14 | 15 | open Category 16 | 17 | --------------------------------------------------------------------------- 18 | -- The category of sets 19 | --------------------------------------------------------------------------- 20 | 21 | SET : Category 22 | Obj SET = Set 23 | Hom SET A B = A -> B 24 | Category.id SET = λ x → x 25 | comp SET f g = λ x → g (f x) 26 | assoc SET = refl 27 | identityˡ SET = refl 28 | identityʳ SET = refl 29 | 30 | 31 | --------------------------------------------------------------------------- 32 | -- Monoids and monoid morphisms 33 | --------------------------------------------------------------------------- 34 | 35 | record Monoid : Set₁ where 36 | field 37 | Carrier : Set 38 | _∙_ : Carrier -> Carrier -> Carrier 39 | ε : Carrier 40 | 41 | field 42 | assoc : ∀ {x y z} → x ∙ (y ∙ z) ≡ (x ∙ y) ∙ z 43 | identityˡ : ∀ {x} → ε ∙ x ≡ x 44 | identityʳ : ∀ {x} → x ∙ ε ≡ x 45 | open Monoid 46 | 47 | record MonoidMorphism (A B : Monoid) : Set where 48 | private 49 | module A = Monoid A 50 | module B = Monoid B 51 | 52 | field 53 | fun : Carrier A -> Carrier B 54 | preserves-ε : fun (A.ε) ≡ B.ε 55 | preserves-∙ : ∀ x y → fun (x A.∙ y) ≡ (fun x B.∙ fun y) 56 | open MonoidMorphism 57 | 58 | eqMonoidMorphism : {A B : Monoid} -> {f g : MonoidMorphism A B} -> 59 | fun f ≡ fun g -> f ≡ g 60 | eqMonoidMorphism {A} {B} {f} {g} refl = 61 | eqMonoidMorphism' (ext (λ x → ext λ y → uip _ _)) (uip _ _) 62 | where 63 | module A = Monoid A 64 | module B = Monoid B 65 | eqMonoidMorphism' : 66 | {fun : A.Carrier -> B.Carrier} 67 | {∙-f ∙-g : ∀ x y → fun (x A.∙ y) ≡ (fun x B.∙ fun y)} 68 | {ε-f ε-g : fun (A.ε) ≡ B.ε} -> 69 | ∙-f ≡ ∙-g -> ε-f ≡ ε-g -> 70 | _≡_ {A = MonoidMorphism A B} 71 | (record { fun = fun ; preserves-∙ = ∙-f ; preserves-ε = ε-f }) 72 | (record { fun = fun ; preserves-∙ = ∙-g ; preserves-ε = ε-g }) 73 | eqMonoidMorphism' refl refl = refl 74 | 75 | MONOID : Category 76 | Obj MONOID = Monoid 77 | Hom MONOID A B = MonoidMorphism A B 78 | fun (Category.id MONOID) x = x 79 | preserves-ε (Category.id MONOID) = refl 80 | preserves-∙ (Category.id MONOID) x y = refl 81 | fun (comp MONOID f g) a = fun g (fun f a) 82 | preserves-ε (comp MONOID f g) rewrite preserves-ε f = preserves-ε g 83 | preserves-∙ (comp MONOID f g) x y rewrite preserves-∙ f x y = preserves-∙ g (fun f x) (fun f y) 84 | assoc MONOID = eqMonoidMorphism refl 85 | identityˡ MONOID = eqMonoidMorphism refl 86 | identityʳ MONOID = eqMonoidMorphism refl 87 | 88 | 89 | --------------------------------------------------------------------------- 90 | -- Preorders and order-preserving functions 91 | --------------------------------------------------------------------------- 92 | 93 | record Preorder : Set1 where 94 | field 95 | Carrier : Set 96 | _≤_ : Carrier -> Carrier -> Set 97 | reflexive : ∀ {x} → x ≤ x 98 | transitive : ∀ {x y z} → x ≤ y -> y ≤ z -> x ≤ z 99 | propositional : ∀ {x y} → (p q : x ≤ y) -> p ≡ q 100 | open Preorder 101 | 102 | record MonotoneMap (P Q : Preorder) : Set1 where 103 | private 104 | module P = Preorder P 105 | module Q = Preorder Q 106 | 107 | field 108 | fun : Carrier P -> Carrier Q 109 | monotone : ∀ x y → x P.≤ y -> fun x Q.≤ fun y 110 | open MonotoneMap 111 | 112 | eqMonotoneMap : {P Q : Preorder} -> {f g : MonotoneMap P Q} -> 113 | fun f ≡ fun g -> f ≡ g 114 | eqMonotoneMap {P} {Q} {f} {g} refl 115 | = cong (λ z → record { fun = fun g; monotone = z }) 116 | (ext λ x → ext (λ y → ext λ p → propositional Q _ _)) 117 | 118 | PREORDER : Category 119 | Obj PREORDER = Preorder 120 | Hom PREORDER = MonotoneMap 121 | fun (Category.id PREORDER) = λ x → x 122 | monotone (Category.id PREORDER) x y x≤y = x≤y 123 | fun (comp PREORDER f g) a = fun g (fun f a) 124 | monotone (comp PREORDER f g) x y x≤y = monotone g _ _ (monotone f x y x≤y) 125 | assoc PREORDER = eqMonotoneMap refl 126 | identityˡ PREORDER = eqMonotoneMap refl 127 | identityʳ PREORDER = eqMonotoneMap refl 128 | 129 | 130 | --------------------------------------------------------------------------- 131 | -- Discrete categories (not covered in the lecture) 132 | --------------------------------------------------------------------------- 133 | 134 | -- Every set can be seen as a category where there are only identity morphisms 135 | 136 | discrete : Set -> Category 137 | Obj (discrete X) = X 138 | Hom (discrete X) x y = x ≡ y 139 | Category.id (discrete X) = refl 140 | comp (discrete X) refl refl = refl 141 | assoc (discrete X) {f = refl} {refl} {refl} = refl 142 | identityˡ (discrete X) {f = refl} = refl 143 | identityʳ (discrete X) {f = refl} = refl 144 | 145 | 146 | --------------------------------------------------------------------------- 147 | -- Monoids as categories (only alluded to in the lecture) 148 | --------------------------------------------------------------------------- 149 | 150 | -- Every monoid can be seen as a boring category with exactly one 151 | -- object 152 | 153 | monoid : Monoid -> Category 154 | Obj (monoid M) = ⊤ 155 | Hom (monoid M) tt tt = Carrier M 156 | Category.id (monoid M) = ε M 157 | comp (monoid M) = _∙_ M 158 | assoc (monoid M) = assoc M 159 | identityˡ (monoid M) = identityˡ M 160 | identityʳ (monoid M) = identityʳ M 161 | 162 | 163 | --------------------------------------------------------------------------- 164 | -- Preorders as categories (only alluded to in the lecture) 165 | --------------------------------------------------------------------------- 166 | 167 | -- Every preorder can be seen as a boring category where there is at 168 | -- most one morphism between any two objects 169 | 170 | porder : Preorder -> Category 171 | Obj (porder P) = Carrier P 172 | Hom (porder P) = _≤_ P 173 | Category.id (porder P) = reflexive P 174 | comp (porder P) = transitive P 175 | assoc (porder P) = propositional P _ _ 176 | identityˡ (porder P) = propositional P _ _ 177 | identityʳ (porder P) = propositional P _ _ 178 | 179 | 180 | 181 | 182 | 183 | 184 | --------------------------------------------------------------------------- 185 | -- Tree is a functor 186 | --------------------------------------------------------------------------- 187 | 188 | -- an excursion to Haskell 189 | 190 | open Functor 191 | 192 | data Tree (X : Set) : Set where 193 | leaf : Tree X 194 | _<[_]>_ : Tree X -> X -> Tree X -> Tree X 195 | 196 | tree-map : {X Y : Set} → (X → Y) → Tree X → Tree Y 197 | tree-map f leaf = leaf 198 | tree-map f (l <[ x ]> r) = tree-map f l <[ f x ]> tree-map f r 199 | 200 | TREE : Functor SET SET 201 | act TREE = Tree 202 | fmap TREE = tree-map 203 | identity TREE = ext identity-treemap 204 | where 205 | identity-treemap : ∀ {X} (x : Tree X) → 206 | tree-map (Category.id SET) x ≡ Category.id SET x 207 | identity-treemap leaf = refl 208 | identity-treemap (l <[ x ]> r) rewrite identity-treemap l | identity-treemap r = refl 209 | 210 | homomorphism TREE {X} {Y} {Z} {f} {g} = ext helper 211 | where 212 | helper : (x : act TREE X) → 213 | fmap TREE (comp SET f g) x ≡ comp SET (fmap TREE f) (fmap TREE g) x 214 | helper leaf = refl 215 | helper (l <[ x ]> r) rewrite helper l | helper r = refl 216 | 217 | -------------------------------------------------------------------------- 218 | -- Forgetful mappings are functors 219 | --------------------------------------------------------------------------- 220 | 221 | forgetMonoid : Functor MONOID SET 222 | act forgetMonoid = Carrier 223 | fmap forgetMonoid h = fun h 224 | identity forgetMonoid = refl 225 | homomorphism forgetMonoid = refl 226 | 227 | -------------------------------------------------------------------------- 228 | -- "Canonical" constructions are often functors 229 | --------------------------------------------------------------------------- 230 | 231 | smallestOrder : Functor SET PREORDER 232 | Carrier (act smallestOrder X) = X 233 | _≤_ (act smallestOrder X) x y = x ≡ y 234 | reflexive (act smallestOrder X) = refl 235 | transitive (act smallestOrder X) p q = trans p q 236 | propositional (act smallestOrder X) = uip 237 | fun (fmap smallestOrder f) = f 238 | monotone (fmap smallestOrder f) x y x=y = cong f x=y 239 | identity smallestOrder = eqMonotoneMap refl 240 | homomorphism smallestOrder = eqMonotoneMap refl 241 | 242 | -- Exercise: is there a greatest order? ("chaotic") 243 | 244 | -------------------------------------------------------------------------- 245 | -- The category of categories 246 | --------------------------------------------------------------------------- 247 | 248 | compFunctor : {C D E : Category} -> Functor C D → Functor D E → Functor C E 249 | act (compFunctor F G) = act G ∘ act F 250 | fmap (compFunctor F G) = fmap G ∘ fmap F 251 | identity (compFunctor F G) {X} rewrite identity F {X} = identity G 252 | homomorphism (compFunctor F G) {f = f} {g} rewrite homomorphism F {f = f} {g} = homomorphism G 253 | 254 | idFunctor : {C : Category} -> Functor C C 255 | act idFunctor = Fun.id 256 | fmap idFunctor = Fun.id 257 | identity idFunctor = refl 258 | homomorphism idFunctor = refl 259 | 260 | CAT : Category 261 | Obj CAT = Category 262 | Hom CAT = Functor 263 | Category.id CAT = idFunctor 264 | comp CAT = compFunctor 265 | assoc CAT = eqFunctor refl refl 266 | identityˡ CAT = eqFunctor refl refl 267 | identityʳ CAT = eqFunctor refl refl 268 | 269 | -------------------------------------------------------------------------- 270 | -- root is a natural transformation 271 | --------------------------------------------------------------------------- 272 | open NaturalTransformation 273 | 274 | map-Maybe : {X Y : Set} → (X → Y) → Maybe X → Maybe Y 275 | map-Maybe f (just x) = just (f x) 276 | map-Maybe f nothing = nothing 277 | 278 | MAYBE : Functor SET SET 279 | act MAYBE = Maybe 280 | fmap MAYBE = map-Maybe 281 | identity MAYBE = ext λ { (just x) → refl ; nothing → refl } 282 | homomorphism MAYBE = ext λ { (just x) → refl ; nothing → refl } 283 | 284 | root : NaturalTransformation TREE MAYBE 285 | transform root X leaf = nothing 286 | transform root X (l <[ x ]> r) = just x 287 | natural root X Y f = ext λ { leaf → refl ; (x <[ x₁ ]> x₂) → refl } 288 | 289 | -- Exercise: for each C and D, define a category where the objects are 290 | -- functors from C to D, and the morphisms natural transformations 291 | -------------------------------------------------------------------------------- /Lectures/Week10.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --type-in-type #-} 2 | module Lectures.Week10 where 3 | 4 | open import Axiom.UniquenessOfIdentityProofs.WithK 5 | open import Axiom.Extensionality.Propositional 6 | open import Relation.Binary.PropositionalEquality 7 | open import Data.Product 8 | 9 | open import Common.Category 10 | open import Common.Category.Adjunctions 11 | open import Common.Category.Solver 12 | 13 | open import Lectures.Week6 hiding (SET) 14 | open import Lectures.Week7 15 | open import Lectures.Week8 16 | open import Lectures.Week9 17 | 18 | open Category 19 | open NaturalTransformation 20 | open Monad 21 | open Adjunction 22 | 23 | 24 | 25 | --------------------------------------- 26 | -- Pure things are trivially effectful 27 | --------------------------------------- 28 | 29 | EmbedKleisli : {C : Category}(M : Monad C) -> Functor C (Kleisli M) 30 | Functor.act (EmbedKleisli {C} M) X = X 31 | Functor.fmap (EmbedKleisli {C} M) f = comp C f (return M _) 32 | Functor.identity (EmbedKleisli {C} M) = identityˡ C 33 | Functor.homomorphism (EmbedKleisli {C} M) {f = f} {g = g} = C ⊧begin 34 | < return M _ > ∘Syn (< g > ∘Syn < f >) 35 | ≡⟦ solveCat refl ⟧ 36 | -[ < return M _ > ∘Syn < g > ]- ∘Syn < f > 37 | ≡⟦ reduced (rq (natural (returnNT M) _ _ g) , rd) ⟧ 38 | -[ fmapSyn (functor M) < g > ∘Syn < return M _ > ]- ∘Syn < f > 39 | ≡⟦ solveCat refl ⟧ 40 | -[ idSyn ]- ∘Syn fmapSyn (functor M) < g > ∘Syn < return M _ > ∘Syn < f > 41 | ≡⟦ reduced (rq (sym (mapReturnJoin M)) , rd , rd , rd) ⟧ 42 | -[ < join M _ > ∘Syn fmapSyn (functor M) < return M _ > ]- ∘Syn fmapSyn (functor M) < g > ∘Syn < return M _ > ∘Syn < f > 43 | ≡⟦ solveCat refl ⟧ 44 | (< join M _ > ∘Syn fmapSyn (functor M) (< return M _ > ∘Syn < g > )) ∘Syn (< return M _ > ∘Syn < f > ) 45 | ⟦∎⟧ 46 | 47 | ----------------------------------- 48 | -- The bind presentation of monads 49 | ----------------------------------- 50 | 51 | module _ {C : Category} (M : Monad C) where 52 | 53 | open NaturalTransformation 54 | 55 | bind : ∀ {X Y} → Hom C X (act M Y) -> Hom C (act M X) (act M Y) 56 | bind f = comp C (fmap M f) (join M _) 57 | 58 | -- m >>= return ≡ m 59 | bindReturn : ∀ {X} → bind (return M X) ≡ Category.id C 60 | bindReturn = mapReturnJoin M 61 | 62 | -- return a >>= f ≡ f a 63 | returnBind : ∀ {X Y}{f : Hom C X (act M Y)} → comp C (return M _) (bind f) ≡ f 64 | returnBind {f = f} = C ⊧begin 65 | (< join M _ > ∘Syn fmapSyn (functor M) < f >) ∘Syn < return M _ > 66 | ≡⟦ solveCat refl ⟧ 67 | < join M _ > ∘Syn -[ fmapSyn (functor M) < f > ∘Syn < return M _ > ]- 68 | ≡⟦ reduced (rd , rq (sym (natural (returnNT M) _ _ f))) ⟧ 69 | < join M _ > ∘Syn -[ < return M _ > ∘Syn < f > ]- 70 | ≡⟦ solveCat refl ⟧ 71 | -[ < join M _ > ∘Syn < return M _ > ]- ∘Syn < f > 72 | ≡⟦ reduced (rq (returnJoin M) , rd) ⟧ 73 | -[ idSyn ]- ∘Syn < f > 74 | ≡⟦ solveCat refl ⟧ 75 | < f > 76 | ⟦∎⟧ 77 | 78 | -- (m >>= f) >>= g ≡ m >>= (λ x → f x >>= g) 79 | bindBind : ∀ {X Y Z}{f : Hom C X (act M Y)}{g : Hom C Y (act M Z)} → 80 | bind (comp C f (bind g)) ≡ comp C (bind f) (bind g) 81 | bindBind {f = f} {g} = C ⊧begin 82 | < join M _ > ∘Syn fmapSyn (functor M) ((< join M _ > ∘Syn fmapSyn (functor M) < g >) ∘Syn < f >) 83 | ≡⟦ solveCat refl ⟧ 84 | -[ < join M _ > ∘Syn fmapSyn (functor M) < join M _ > ]- ∘Syn fmapSyn (functor M) (fmapSyn (functor M) < g >) ∘Syn fmapSyn (functor M) < f > 85 | ≡⟦ reduced (rq (sym (joinJoin M)) , (rd , rd)) ⟧ 86 | -[ < join M _ > ∘Syn < join M _ > ]- ∘Syn fmapSyn (functor M) (fmapSyn (functor M) < g >) ∘Syn fmapSyn (functor M) < f > 87 | ≡⟦ solveCat refl ⟧ 88 | < join M _ > ∘Syn -[ < join M _ > ∘Syn fmapSyn (functor M) (fmapSyn (functor M) < g >) ]- ∘Syn fmapSyn (functor M) < f > 89 | ≡⟦ reduced (rd , rq (natural (joinNT M) _ _ g) , rd) ⟧ 90 | < join M _ > ∘Syn -[ fmapSyn (functor M) < g > ∘Syn < join M _ > ]- ∘Syn fmapSyn (functor M) < f > 91 | ≡⟦ solveCat refl ⟧ 92 | (< join M _ > ∘Syn fmapSyn (functor M) < g >) ∘Syn (< join M _ > ∘Syn fmapSyn (functor M) < f >) 93 | ⟦∎⟧ 94 | 95 | 96 | ---------------------- 97 | -- Getting back again 98 | ---------------------- 99 | 100 | 101 | ForgetKleisli : {C : Category}(M : Monad C) -> Functor (Kleisli M) C 102 | Functor.act (ForgetKleisli {C} M) X = act M X 103 | Functor.fmap (ForgetKleisli {C} M) f = bind M f 104 | Functor.identity (ForgetKleisli {C} M) = bindReturn M 105 | Functor.homomorphism (ForgetKleisli {C} M) = bindBind M 106 | 107 | 108 | kleisliAdjunction : {C : Category}(M : Monad C) -> Adjunction (EmbedKleisli M) (ForgetKleisli M) 109 | to (kleisliAdjunction M) f = f 110 | from (kleisliAdjunction M) g = g 111 | left-inverse-of (kleisliAdjunction M) h = refl 112 | right-inverse-of (kleisliAdjunction M) h = refl 113 | to-natural (kleisliAdjunction {C} M) f g = ext λ h → C ⊧begin 114 | compSyn < f > (compSyn < h > (compSyn (fmapSyn (functor M) < g >) < join M _ >)) 115 | ≡⟦ solveCat refl ⟧ 116 | -[ idSyn ]- ∘Syn < join M _ > ∘Syn fmapSyn (functor M) < g > ∘Syn < h > ∘Syn < f > 117 | ≡⟦ reduced (rq (sym (returnJoin M)) , rd , rd , rd , rd) ⟧ 118 | -[ < join M _ > ∘Syn < return M _ > ]- ∘Syn < join M _ > ∘Syn fmapSyn (functor M) < g > ∘Syn < h > ∘Syn < f > 119 | ≡⟦ solveCat refl ⟧ 120 | < join M _ > ∘Syn -[ < return M _ > ∘Syn < join M _ > ]- ∘Syn fmapSyn (functor M) < g > ∘Syn < h > ∘Syn < f > 121 | ≡⟦ reduced (rd , rq (natural (returnNT M) _ _ _) , rd , rd , rd) ⟧ 122 | < join M _ > ∘Syn -[ fmapSyn (functor M) < join M _ > ∘Syn < return M _ > ]- ∘Syn fmapSyn (functor M) < g > ∘Syn < h > ∘Syn < f > 123 | ≡⟦ solveCat refl ⟧ 124 | < join M _ > ∘Syn fmapSyn (functor M) < join M _ > ∘Syn -[ < return M _ > ∘Syn fmapSyn (functor M) < g > ]- ∘Syn < h > ∘Syn < f > 125 | ≡⟦ reduced (rd , rd , rq (natural (returnNT M) _ _ _) , rd , rd) ⟧ 126 | < join M _ > ∘Syn fmapSyn (functor M) < join M _ > ∘Syn -[ fmapSyn (functor M) (fmapSyn (functor M) < g >) ∘Syn < return M _ > ]- ∘Syn < h > ∘Syn < f > 127 | ≡⟦ solveCat refl ⟧ 128 | < join M _ > ∘Syn fmapSyn (functor M) < join M _ > ∘Syn fmapSyn (functor M) (fmapSyn (functor M) < g >) ∘Syn -[ < return M _ > ∘Syn < h > ]- ∘Syn < f > 129 | ≡⟦ reduced (rd , rd , rd , rq (natural (returnNT M) _ _ _) , rd) ⟧ 130 | < join M _ > ∘Syn fmapSyn (functor M) < join M _ > ∘Syn fmapSyn (functor M) (fmapSyn (functor M) < g >) ∘Syn -[ fmapSyn (functor M) < h > ∘Syn < return M _ > ]- ∘Syn < f > 131 | ≡⟦ solveCat refl ⟧ 132 | compSyn (compSyn < f > < return M _ >) 133 | (compSyn (fmapSyn (functor M) (compSyn < h > (compSyn (fmapSyn (functor M) < g >) < join M _ >))) < join M _ >) 134 | ⟦∎⟧ 135 | 136 | ---------------------------------------------------------------- 137 | -- Every monad arises from (for example) its Kleisli adjunction 138 | ---------------------------------------------------------------- 139 | 140 | -- equality of monads 141 | eqMonad : {C : Category} (M N : Monad C) → 142 | (p : act M ≡ act N) → 143 | (∀ {A B} → subst (λ z → Hom C A B -> Hom C (z A) (z B)) p (fmap M) ≡ (fmap N {A} {B})) → 144 | ((X : Obj C) → subst (λ z → Hom C (Functor.act {C = C} idFunctor X) (z X)) p (return M X) ≡ return N X) → 145 | ((X : Obj C) → subst (λ z → Hom C (z (z X)) (z X)) p (join M X) ≡ join N X) → 146 | M ≡ N 147 | eqMonad {C} M N refl p q r with eqFunctor {C = C} {F = functor M} {G = functor N} refl p 148 | eqMonad {C} M N refl p q r | refl with eqNatTrans (returnNT M) (returnNT N) q | eqNatTrans (joinNT M) (joinNT N) r 149 | eqMonad {C} M N refl p q r | refl | refl | refl = eqMonad' (iext (uip _ _)) (iext (uip _ _)) (iext (uip _ _)) 150 | where 151 | iext = implicit-extensionality ext 152 | eqMonad' : 153 | {returnNT : NaturalTransformation idFunctor (functor N)} 154 | {joinNT : NaturalTransformation (compFunctor (functor N) (functor N)) (functor N)} 155 | {returnJoin₁ : {X : Obj C} → comp C (transform returnNT (act N X)) (transform joinNT X) ≡ id C} 156 | {mapReturnJoin₁ : {X : Obj C} → comp C (fmap N (transform returnNT X)) (transform joinNT X) ≡ id C} 157 | {joinJoin₁ : {X : Obj C} → comp C (transform joinNT (act N X)) (transform joinNT X) ≡ comp C (fmap N (transform joinNT X)) (transform joinNT X)} 158 | {returnJoin₂ : {X : Obj C} → comp C (transform returnNT (act N X)) (transform joinNT X) ≡ id C} 159 | {mapReturnJoin₂ : {X : Obj C} → comp C (fmap N (transform returnNT X)) (transform joinNT X) ≡ id C} 160 | {joinJoin₂ : {X : Obj C} → comp C (transform joinNT (act N X)) (transform joinNT X) ≡ comp C (fmap N (transform joinNT X)) (transform joinNT X)} → 161 | _≡_ {A = {X : Obj C} → comp C (transform returnNT (act N X)) (transform joinNT X) ≡ id C} returnJoin₁ returnJoin₂ → 162 | _≡_ {A = {X : Obj C} → comp C (fmap N (transform returnNT X)) (transform joinNT X) ≡ id C} mapReturnJoin₁ mapReturnJoin₂ → 163 | _≡_ {A = {X : Obj C} → comp C (transform joinNT (act N X)) (transform joinNT X) ≡ comp C (fmap N (transform joinNT X)) (transform joinNT X)} joinJoin₁ joinJoin₂ → 164 | record 165 | { functor = functor N 166 | ; returnNT = returnNT 167 | ; joinNT = joinNT 168 | ; returnJoin = returnJoin₂ 169 | ; mapReturnJoin = mapReturnJoin₂ 170 | ; joinJoin = joinJoin₂ 171 | } 172 | ≡ 173 | record 174 | { functor = functor N 175 | ; returnNT = returnNT 176 | ; joinNT = joinNT 177 | ; returnJoin = returnJoin₁ 178 | ; mapReturnJoin = mapReturnJoin₁ 179 | ; joinJoin = joinJoin₁ 180 | } 181 | eqMonad' refl refl refl = refl 182 | 183 | 184 | 185 | completeness : {C : Category}(M : Monad C) → 186 | M ≡ (monadFromAdj _ _ _ _ (kleisliAdjunction M)) 187 | completeness {C} M = eqMonad _ _ refl (ext (completenessFmap M)) (completenessReturn M) (completenessJoin M) 188 | where 189 | completenessFmap : {C : Category}(M : Monad C) → 190 | {X Y : Obj C}(h : Hom C X Y) → fmap M h ≡ fmap (monadFromAdj _ _ _ _ (kleisliAdjunction M)) h 191 | completenessFmap {C} M {X} h = C ⊧begin 192 | fmapSyn (functor M) < h > 193 | ≡⟦ solveCat refl ⟧ 194 | fmapSyn (functor M) < h > ；Syn -[ idSyn ]- 195 | ≡⟦ reduced (rq (sym (mapReturnJoin M)) , rd) ⟧ 196 | fmapSyn (functor M) < h > ；Syn -[ fmapSyn (functor M) < return M _ > ；Syn < join M _ > ]- 197 | ≡⟦ solveCat refl ⟧ 198 | compSyn (fmapSyn (functor M) (compSyn < h > < return M _ >)) < join M _ > 199 | ⟦∎⟧ 200 | 201 | completenessReturn : {C : Category}(M : Monad C) → (X : Obj C) → 202 | return M X ≡ return (monadFromAdj _ _ _ _ (kleisliAdjunction M)) X 203 | completenessReturn {C} M X = refl 204 | 205 | 206 | -------------------------------------------------------------------------------- /Coursework/Examples/strathclyde-shrunk.pgm: -------------------------------------------------------------------------------- 1 | P2 2 | 65 61 3 | 255 4 | 0 0 0 0 0 0 0 0 0 0 0 0 14 31 31 31 31 31 31 31 31 31 31 31 31 31 31 31 31 31 31 31 31 31 32 32 32 32 32 32 32 32 32 32 32 32 32 32 32 32 32 32 31 16 0 0 0 0 0 0 0 0 0 0 0 5 | 0 0 0 0 0 0 0 0 0 0 0 0 15 68 97 97 97 97 97 97 97 97 97 97 97 97 97 97 97 97 97 97 97 96 96 96 96 96 96 96 96 96 96 96 96 96 96 96 96 96 96 96 32 31 0 0 0 0 0 0 0 0 0 0 0 6 | 0 0 0 0 0 0 0 0 0 0 0 0 31 142 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 188 31 0 0 0 0 0 0 0 0 0 0 0 7 | 0 0 0 0 0 0 0 0 0 0 0 15 31 195 255 255 255 209 153 134 116 115 115 116 116 116 117 117 118 118 119 119 119 119 120 120 121 121 122 122 123 123 124 124 125 125 124 141 220 255 255 255 253 32 15 0 0 0 0 0 0 0 0 0 0 8 | 0 0 0 0 0 0 0 0 0 0 0 15 83 254 255 214 133 83 98 122 133 134 133 133 133 133 133 132 132 132 132 132 131 131 131 131 130 130 130 130 129 129 129 129 128 128 129 123 74 50 252 255 255 76 32 0 0 0 0 0 0 0 0 0 0 9 | 0 0 0 0 0 0 0 0 0 0 0 31 142 255 200 106 103 150 150 150 150 150 150 150 150 150 150 150 150 150 150 150 150 150 150 150 150 150 150 150 150 150 150 150 150 150 150 150 150 147 32 252 255 183 31 0 0 0 0 0 0 0 0 0 0 10 | 0 0 0 0 0 0 0 0 0 0 14 31 193 251 121 111 150 150 150 150 150 150 150 150 150 150 150 150 150 150 144 110 105 104 137 149 150 150 150 150 150 150 150 150 150 150 150 150 150 150 148 42 255 251 32 15 0 0 0 0 0 0 0 0 0 11 | 0 0 0 0 0 0 0 0 0 0 16 81 253 164 90 149 149 127 168 112 172 132 146 146 150 150 150 150 150 130 50 96 97 82 64 62 150 150 150 150 150 137 131 174 179 91 180 143 132 137 150 94 193 255 72 30 0 0 0 0 0 0 0 0 0 12 | 0 0 0 0 0 0 0 0 0 0 31 142 255 129 121 101 179 215 255 200 246 255 241 113 109 150 150 150 150 131 68 92 97 82 65 91 150 150 150 150 130 85 227 253 255 192 255 255 252 121 116 149 65 255 176 31 0 0 0 0 0 0 0 0 0 13 | 0 0 0 0 0 0 0 0 0 15 32 191 245 87 148 58 218 255 255 200 248 255 255 176 76 150 150 150 122 107 68 92 97 81 65 91 94 150 150 150 130 61 252 255 255 192 255 255 255 144 90 150 55 250 249 32 15 0 0 0 0 0 0 0 0 14 | 0 0 0 0 0 0 0 0 0 16 79 254 175 90 148 58 218 255 255 200 248 255 255 176 76 150 150 116 97 69 68 92 97 81 66 91 56 111 150 150 130 61 252 255 255 192 255 255 255 144 90 150 109 180 255 67 30 0 0 0 0 0 0 0 0 15 | 0 0 0 0 0 0 0 0 0 32 141 255 136 79 112 58 218 255 255 200 248 255 255 176 59 110 107 116 70 78 68 92 97 80 66 91 76 87 62 110 103 61 252 255 255 192 255 255 255 144 61 113 110 75 255 169 31 0 0 0 0 0 0 0 0 16 | 0 0 0 0 0 0 0 0 14 31 189 249 90 134 132 57 218 255 255 200 248 255 255 176 76 137 137 148 103 78 68 92 97 80 66 91 96 94 149 137 117 61 252 255 255 192 255 255 255 144 90 134 134 47 252 246 32 14 0 0 0 0 0 0 0 17 | 0 0 0 0 0 0 0 0 16 77 253 181 89 150 148 58 218 255 255 200 248 255 255 176 76 150 150 150 150 78 68 92 97 79 67 91 96 150 150 150 130 61 252 255 255 192 255 255 255 144 90 150 150 103 189 255 63 30 0 0 0 0 0 0 0 18 | 0 0 0 0 0 0 0 0 31 141 255 139 112 150 148 58 218 252 197 183 191 236 255 176 76 150 150 150 150 60 68 92 97 79 67 77 97 150 150 150 130 61 252 215 198 165 197 221 255 144 90 150 150 144 82 255 162 31 0 0 0 0 0 0 0 19 | 0 0 0 0 0 0 0 15 32 187 252 93 147 150 148 58 198 237 182 178 142 247 147 176 76 150 150 150 150 145 109 103 97 89 64 144 139 150 150 150 130 61 187 169 166 130 138 231 140 144 90 150 150 150 46 254 243 32 13 0 0 0 0 0 0 20 | 0 0 0 0 0 0 0 16 75 252 188 88 150 150 148 57 93 147 115 148 145 126 108 109 76 150 150 150 150 150 150 141 61 97 143 150 150 150 150 150 130 65 118 113 141 150 150 139 104 85 89 150 150 150 97 197 255 58 30 0 0 0 0 0 0 21 | 0 0 0 0 0 0 0 30 140 255 141 85 123 122 121 95 126 127 127 127 127 127 127 127 105 127 127 127 127 127 127 127 127 127 127 127 127 127 127 127 127 120 127 127 127 127 127 127 127 127 116 121 123 124 118 90 255 154 32 0 0 0 0 0 0 22 | 0 0 0 0 0 0 14 31 185 253 111 182 184 185 184 48 55 56 56 56 56 56 56 56 56 56 56 56 49 54 56 56 44 60 68 67 54 68 68 68 68 68 68 68 68 68 68 68 67 44 139 185 185 184 183 44 254 239 32 12 0 0 0 0 0 23 | 0 0 0 0 0 0 15 73 251 195 133 255 255 255 255 255 152 53 68 68 68 68 68 68 68 68 68 68 67 109 50 68 99 69 85 90 64 78 85 85 85 85 85 85 85 85 85 79 94 155 255 255 255 255 255 142 204 255 54 29 0 0 0 0 0 24 | 0 0 0 0 0 0 31 140 255 143 171 255 255 255 255 255 255 244 41 68 68 68 68 68 68 66 55 54 68 80 142 56 114 130 63 112 100 79 81 57 80 85 85 85 85 85 64 143 213 255 255 255 255 255 255 232 98 255 146 31 0 0 0 0 0 25 | 0 0 0 0 0 16 31 183 254 86 229 255 255 255 255 255 255 255 255 117 58 68 68 68 68 68 68 111 78 65 150 55 145 149 74 150 74 104 97 71 85 85 85 85 82 77 147 253 255 255 255 255 255 255 255 194 47 255 235 32 10 0 0 0 0 26 | 0 0 0 0 0 16 71 250 201 47 54 159 255 255 255 255 255 255 255 255 229 40 68 68 68 68 68 62 145 51 150 95 150 150 97 149 89 106 67 85 85 85 85 69 131 192 255 255 255 255 255 255 255 254 149 79 52 212 255 49 26 0 0 0 0 27 | 0 0 0 0 0 30 138 255 143 53 68 66 60 254 255 255 255 255 255 255 255 255 86 62 68 68 68 68 68 111 147 102 138 139 104 143 100 99 85 85 85 84 66 147 246 255 255 255 255 255 255 255 223 145 63 85 77 109 255 137 31 0 0 0 0 28 | 0 0 0 0 15 32 181 254 96 65 68 68 68 41 225 255 255 255 255 255 255 255 255 206 44 68 68 68 56 122 85 106 93 80 98 86 65 69 85 85 74 115 172 255 255 255 255 255 255 255 255 163 104 77 85 85 85 39 255 231 32 11 0 0 0 29 | 0 0 0 0 15 69 250 208 47 68 68 68 68 68 59 123 255 255 255 255 255 255 255 255 254 62 66 68 55 83 103 84 109 84 103 94 120 63 85 62 147 234 255 255 255 255 255 255 255 243 147 63 84 85 85 85 85 51 220 255 45 32 0 0 0 30 | 0 0 0 0 31 138 255 145 52 68 68 68 68 58 67 67 45 252 255 255 255 255 255 255 255 255 176 49 55 68 112 112 106 107 100 87 124 57 96 156 254 255 255 255 255 255 255 255 188 128 70 80 84 85 85 85 85 76 119 255 128 31 0 0 0 31 | 0 0 0 14 31 179 255 102 63 68 68 63 142 168 219 53 68 46 199 255 255 255 255 255 255 255 255 249 46 54 55 82 94 93 87 73 42 131 215 255 255 255 255 255 255 255 253 147 75 81 112 140 193 62 85 85 85 85 43 255 226 31 0 0 0 32 | 0 0 0 16 67 248 215 49 68 68 68 89 250 193 177 255 58 68 63 91 255 255 255 255 255 255 255 255 255 141 55 65 51 62 73 77 148 254 255 255 255 255 255 255 255 217 143 64 85 77 220 210 203 249 66 85 85 85 49 227 255 42 15 0 0 33 | 0 0 0 30 136 255 148 51 65 103 56 67 160 231 165 154 61 58 62 68 39 244 255 255 255 255 255 255 255 255 241 40 58 49 133 194 255 255 255 255 255 255 255 255 159 99 78 80 72 83 177 226 195 181 94 79 79 85 73 133 255 121 32 0 0 34 | 0 0 15 32 177 255 108 62 146 246 219 66 64 187 146 63 66 153 247 50 68 52 167 255 255 255 255 255 255 255 255 255 108 143 248 255 255 255 255 255 255 255 241 147 62 84 119 209 237 79 84 176 162 69 84 157 222 55 84 49 255 222 32 0 0 35 | 0 0 15 65 248 222 51 56 172 254 249 60 150 248 244 57 57 201 254 236 54 68 66 64 254 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 183 124 72 85 66 145 254 246 58 131 218 246 71 76 179 255 243 55 46 235 255 38 15 0 36 | 0 0 31 135 255 148 50 63 203 165 141 249 254 253 255 250 201 247 176 209 63 68 68 68 41 229 255 255 255 255 255 255 255 255 255 255 255 255 255 252 147 72 83 85 85 82 183 172 191 253 251 253 254 242 176 247 184 194 96 70 162 255 113 31 0 37 | 0 14 31 175 255 110 62 68 98 209 121 56 248 207 255 214 150 126 243 165 58 68 68 68 68 58 131 255 255 255 255 255 255 255 255 255 255 255 212 141 65 85 85 85 85 85 94 242 156 63 251 212 255 207 167 151 236 167 75 79 104 255 217 31 0 38 | 0 16 63 246 255 78 68 68 68 57 68 68 174 118 185 176 78 68 66 100 68 68 68 68 68 68 55 155 255 255 255 255 255 255 255 255 255 233 77 79 85 85 85 85 85 85 84 76 79 85 155 117 176 184 116 85 71 147 83 83 87 255 255 36 16 39 | 0 30 134 255 255 77 68 68 68 61 60 67 188 249 254 255 63 62 62 68 68 68 68 68 62 101 167 255 255 255 255 255 255 255 255 255 255 255 250 50 82 85 85 85 85 85 85 82 71 70 160 255 245 255 87 72 78 85 85 82 92 255 255 106 31 40 | 14 31 173 255 255 120 62 68 68 128 242 243 213 87 57 181 255 244 222 64 68 68 68 52 143 228 255 255 255 255 255 255 255 255 255 255 255 255 255 255 158 60 85 85 85 85 85 113 218 222 243 136 78 176 254 211 224 76 85 74 123 255 255 212 31 41 | 31 61 245 255 255 236 40 68 68 71 175 225 209 54 64 152 237 185 177 61 68 65 77 150 254 255 255 255 255 255 255 255 246 255 255 255 255 255 255 255 255 247 46 83 85 85 85 72 181 253 219 61 84 156 246 198 213 68 85 59 151 255 255 255 34 42 | 31 32 218 255 255 255 86 63 68 65 210 176 247 131 61 224 129 206 127 68 56 131 201 255 255 255 255 255 255 255 255 177 105 73 254 255 255 255 255 255 255 255 255 142 64 85 85 84 212 177 218 151 79 194 119 224 153 83 79 80 231 255 255 174 74 43 | 4 31 32 110 255 255 255 33 67 66 55 57 86 58 68 57 99 65 54 59 145 250 255 255 255 255 255 255 255 248 145 59 57 65 46 215 255 255 255 255 255 255 255 255 243 44 84 85 66 79 115 85 85 64 126 106 69 78 62 154 255 251 143 41 16 44 | 0 0 16 31 39 248 255 254 34 62 68 68 68 68 68 68 68 60 110 175 255 255 255 255 255 255 255 255 192 127 56 68 56 65 85 74 95 255 255 255 255 255 255 255 255 255 127 67 85 85 85 85 85 85 85 85 65 80 159 255 210 125 32 15 0 45 | 0 0 0 0 31 32 182 255 255 79 46 68 68 68 68 68 52 145 235 255 255 255 255 255 255 255 253 147 69 66 65 97 150 66 84 85 84 42 233 255 255 255 255 255 255 255 255 237 42 84 85 85 85 85 83 58 126 209 255 157 68 31 15 0 0 46 | 0 0 0 0 0 30 32 73 255 255 186 33 67 68 64 85 155 254 255 255 255 255 255 255 255 208 136 54 68 68 136 208 233 192 155 84 85 85 69 122 255 255 255 255 255 255 255 255 255 112 70 85 85 73 62 144 251 241 141 33 15 16 0 0 0 47 | 0 0 0 0 0 0 0 31 32 234 255 249 39 51 137 211 255 255 255 255 255 255 255 254 151 81 65 67 58 68 57 254 113 190 167 73 84 85 85 84 43 244 255 255 255 255 255 255 255 255 229 43 61 98 172 255 186 105 31 15 0 0 0 0 0 48 | 0 0 0 0 0 0 0 0 31 32 138 255 255 109 88 255 255 255 255 255 255 255 223 142 53 68 67 145 215 79 68 47 254 155 70 74 155 112 84 85 85 63 151 255 255 255 255 255 255 255 237 140 137 230 254 146 49 26 15 0 0 0 0 0 0 49 | 0 0 0 0 0 0 0 0 0 28 31 48 253 255 215 35 244 255 255 255 255 160 94 63 68 68 109 209 252 206 63 144 252 99 85 80 248 255 148 84 85 85 82 50 250 255 255 255 255 179 123 149 254 223 133 32 16 0 0 0 0 0 0 0 0 50 | 0 0 0 0 0 0 0 0 0 0 0 31 32 206 255 254 51 165 255 236 146 53 68 68 68 68 71 149 190 205 208 243 254 252 157 152 177 254 161 72 85 85 85 85 56 179 255 251 144 125 195 255 165 81 30 16 0 0 0 0 0 0 0 0 0 51 | 0 0 0 0 0 0 0 0 0 0 0 0 31 32 96 255 255 144 58 109 60 68 68 68 68 68 62 247 169 129 136 196 253 254 231 172 253 170 122 80 85 85 85 85 85 81 62 127 142 245 247 143 36 15 13 0 0 0 0 0 0 0 0 0 0 52 | 0 0 0 0 0 0 0 0 0 0 0 0 0 11 31 36 245 255 236 32 63 68 68 68 68 68 68 55 105 66 59 236 193 173 155 71 66 177 126 85 85 85 85 85 85 63 88 162 255 200 117 32 15 0 0 0 0 0 0 0 0 0 0 0 0 53 | 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 31 32 166 255 255 73 47 68 68 68 68 68 68 68 67 62 231 246 203 227 76 81 84 85 85 85 85 85 82 58 131 219 254 151 59 30 15 0 0 0 0 0 0 0 0 0 0 0 0 0 54 | 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 27 32 63 254 255 179 33 68 68 68 68 68 154 187 178 188 122 116 255 193 181 70 85 85 85 85 71 66 145 253 234 138 31 16 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 55 | 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 32 32 225 255 248 37 60 68 68 68 167 235 197 197 58 54 150 254 239 156 85 85 84 60 106 181 255 176 95 31 15 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 56 | 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 31 32 122 255 255 101 42 68 68 59 143 221 254 52 69 239 172 194 124 85 79 57 140 237 252 144 42 16 14 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 57 | 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 13 31 42 251 255 209 32 66 58 104 126 147 54 62 132 150 118 74 66 78 154 255 213 127 31 15 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 58 | 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 31 32 193 255 253 48 53 68 68 68 58 65 85 85 84 58 123 205 255 158 71 30 15 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 59 | 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 30 32 82 254 255 158 34 59 68 58 65 81 63 63 143 249 242 142 33 15 13 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 60 | 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 16 31 33 239 255 253 157 76 56 60 96 143 207 255 189 108 32 16 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 61 | 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 31 32 151 255 255 255 255 255 255 255 254 147 51 26 16 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 62 | 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 25 31 54 254 255 255 255 255 225 134 31 16 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 63 | 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 31 32 214 255 255 168 84 31 15 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 64 | 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 30 32 107 143 38 15 12 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 -------------------------------------------------------------------------------- /Coursework/Examples/One.agda: -------------------------------------------------------------------------------- 1 | module Coursework.Examples.One where 2 | 3 | {- 4 | This file contains some sample PGM picture in String format for you to play with. 5 | They are in a separate file to avoid reloading them each time you 6 | typecheck the main file. 7 | 8 | Additional examples can also be found as separate files in the One directory. 9 | -} 10 | 11 | open import Data.String using (String) 12 | 13 | 14 | 15 | feep : String 16 | feep = "P2 17 | 24 7 18 | 15 19 | 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 20 | 0 3 3 3 3 0 0 7 7 7 7 0 0 11 11 11 11 0 0 15 15 15 15 0 21 | 0 3 0 0 0 0 0 7 0 0 0 0 0 11 0 0 0 0 0 15 0 0 15 0 22 | 0 3 3 3 0 0 0 7 7 7 0 0 0 11 11 11 0 0 0 15 15 15 15 0 23 | 0 3 0 0 0 0 0 7 0 0 0 0 0 11 0 0 0 0 0 15 0 0 0 0 24 | 0 3 0 0 0 0 0 7 7 7 7 0 0 11 11 11 11 0 0 15 0 0 0 0 25 | 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0" 26 | 27 | feepWithComment : String 28 | feepWithComment = "P2 29 | # FEEP! 30 | 24 7 31 | 15 32 | 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 33 | 0 3 3 3 3 0 0 7 7 7 7 0 0 11 11 11 11 0 0 15 15 15 15 0 34 | 0 3 0 0 0 0 0 7 0 0 0 0 0 11 0 0 0 0 0 15 0 0 15 0 35 | 0 3 3 3 0 0 0 7 7 7 0 0 0 11 11 11 0 0 0 15 15 15 15 0 36 | 0 3 0 0 0 0 0 7 0 0 0 0 0 11 0 0 0 0 0 15 0 0 0 0 37 | 0 3 0 0 0 0 0 7 7 7 7 0 0 11 11 11 11 0 0 15 0 0 0 0 38 | 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0" 39 | 40 | 41 | l : String 42 | l = "P2 43 | 76 66 44 | 255 45 | 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 46 | 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 47 | 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 248 217 255 255 255 255 241 224 255 255 255 255 234 230 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 254 212 254 255 255 255 255 255 255 255 255 255 244 221 255 255 48 | 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 239 53 0 191 255 255 224 33 4 222 255 255 205 18 15 246 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 252 89 0 143 255 255 255 255 255 255 255 255 231 41 2 210 255 49 | 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 239 53 0 17 222 255 224 33 0 33 241 255 205 18 0 55 253 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 252 89 0 4 186 255 255 255 255 255 255 255 231 41 0 26 233 255 50 | 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 240 54 0 16 202 255 225 34 0 30 222 255 207 19 0 49 237 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 252 92 0 3 165 255 255 255 255 255 255 255 232 43 0 23 213 255 255 51 | 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 240 54 0 16 202 255 225 34 0 31 222 255 207 19 0 50 237 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 252 92 0 3 165 255 255 255 255 255 255 255 232 43 0 23 213 255 255 255 52 | 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 239 54 0 16 202 255 225 34 0 31 222 255 207 19 0 50 237 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 252 92 0 3 165 255 255 255 255 255 255 255 232 43 0 23 213 255 255 255 255 53 | 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 239 54 0 16 202 255 225 34 0 31 222 255 206 19 0 50 237 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 252 92 0 3 165 255 255 255 255 255 255 255 232 43 0 23 213 255 226 187 255 255 54 | 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 239 54 0 16 203 255 225 34 0 31 222 255 206 19 0 50 237 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 252 91 0 3 165 255 255 255 255 255 255 255 232 42 0 23 213 255 213 23 0 201 255 55 | 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 239 54 0 16 203 255 225 34 0 31 222 255 206 19 0 50 237 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 252 91 0 3 166 255 255 255 255 255 255 255 232 42 0 24 213 255 213 23 0 44 242 255 56 | 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 239 53 0 16 203 255 225 34 0 31 222 255 206 19 0 50 237 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 252 91 0 3 166 255 255 255 255 255 255 255 232 42 0 24 214 255 215 25 0 41 231 255 255 57 | 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 239 53 0 16 203 255 225 34 0 31 222 255 206 19 0 50 237 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 252 91 0 3 166 255 255 255 255 255 255 255 232 42 0 24 214 255 215 25 0 41 231 255 255 255 58 | 255 255 255 255 255 255 255 255 255 255 255 255 255 255 239 53 0 16 203 255 225 33 0 31 222 255 206 18 0 50 237 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 252 91 0 3 166 255 255 255 255 255 255 255 232 42 0 24 214 255 215 25 0 41 231 255 255 255 255 59 | 255 255 255 255 255 255 255 255 255 255 255 255 255 238 50 0 19 207 255 224 31 0 34 225 255 205 17 0 54 239 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 252 91 0 3 166 255 255 255 255 255 255 255 231 39 0 27 218 255 215 25 0 41 231 255 203 150 253 255 60 | 255 255 255 255 255 255 255 255 255 255 255 255 237 50 0 19 207 255 255 113 0 34 225 255 255 79 0 54 239 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 252 90 0 3 166 255 255 255 255 255 255 255 255 127 0 27 218 255 215 25 0 41 231 255 190 10 0 196 255 61 | 255 255 255 255 255 255 255 255 255 255 255 237 50 0 19 207 255 255 255 217 116 227 255 255 255 199 121 240 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 252 90 0 3 166 255 255 255 255 255 255 255 255 255 224 115 221 255 215 25 0 41 231 255 189 10 0 68 249 255 62 | 255 255 255 255 255 255 255 255 255 255 239 53 0 17 203 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 252 90 0 3 167 255 255 255 255 255 255 255 255 255 255 255 255 255 215 24 0 46 235 255 194 12 0 69 246 255 255 63 | 255 255 255 255 255 255 255 255 255 239 53 0 17 204 255 208 44 59 231 255 255 186 35 76 245 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 252 90 0 3 167 255 255 255 255 255 255 255 255 255 255 255 255 255 215 24 0 46 235 255 194 12 0 69 246 255 255 255 64 | 255 255 255 255 255 255 255 255 239 53 0 17 204 255 255 100 0 0 140 255 255 65 0 0 175 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 252 90 0 3 167 255 255 255 255 255 255 255 255 255 255 255 255 255 215 24 0 46 235 255 193 12 0 69 246 255 255 255 255 65 | 255 255 255 255 255 255 255 239 52 0 17 204 255 255 255 167 2 9 201 255 255 134 0 18 226 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 252 90 0 5 174 255 255 255 255 255 255 255 255 255 255 255 255 255 216 22 0 46 235 255 193 12 0 69 246 255 255 255 255 255 66 | 255 255 255 255 255 255 239 52 0 17 204 255 255 255 255 255 224 232 255 255 255 255 217 239 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 252 90 0 5 174 255 255 255 255 255 255 255 255 255 255 255 255 255 255 129 0 47 235 255 193 12 0 69 246 255 255 255 255 255 255 67 | 255 255 255 255 255 239 52 0 17 204 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 252 89 0 5 174 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 239 152 238 255 193 12 0 69 246 255 255 255 255 255 255 255 68 | 255 255 255 255 239 52 0 17 204 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 252 89 0 5 174 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 193 11 0 70 246 255 255 255 255 255 255 255 255 69 | 255 255 255 239 52 0 17 204 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 252 89 0 5 174 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 193 11 0 70 246 255 255 255 255 255 255 255 255 255 70 | 255 255 238 52 0 21 209 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 252 89 0 5 174 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 193 11 0 70 246 255 255 255 255 255 255 255 255 255 255 71 | 255 246 49 0 0 25 51 51 51 51 51 51 51 51 56 187 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 90 0 5 174 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 198 9 0 71 247 255 255 255 255 255 255 255 255 255 255 255 72 | 255 222 2 0 0 0 0 0 0 0 0 0 0 0 0 95 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 18 5 175 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 115 0 60 247 255 255 255 255 255 255 255 255 255 255 255 255 73 | 255 255 203 170 170 170 170 170 170 170 170 170 170 89 0 94 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 219 213 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 114 0 114 255 255 255 255 255 255 255 255 255 255 255 255 255 74 | 255 255 255 255 255 255 255 255 255 255 255 255 255 133 0 94 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 114 0 114 255 255 255 255 255 255 255 255 255 255 255 255 255 75 | 255 255 255 255 255 255 255 255 255 255 255 255 255 133 0 94 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 114 0 114 255 255 255 255 255 255 255 255 255 255 255 255 255 76 | 255 255 255 255 255 255 255 255 255 255 255 255 255 133 0 94 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 114 0 114 255 255 255 255 255 255 255 255 255 255 255 255 255 77 | 255 255 255 255 255 255 255 255 255 255 255 255 255 133 0 94 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 114 0 114 255 255 255 255 255 255 255 255 255 255 255 255 255 78 | 255 255 255 255 255 255 255 255 255 255 255 255 255 133 0 94 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 114 0 114 255 255 255 255 255 255 255 255 255 255 255 255 255 79 | 255 255 255 255 255 255 255 255 255 255 255 255 255 133 0 94 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 114 0 114 255 255 255 255 255 255 255 255 255 255 255 255 255 80 | 255 255 255 255 255 255 255 255 255 255 255 255 255 133 0 94 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 114 0 114 255 255 255 255 255 255 255 255 255 255 255 255 255 81 | 255 255 255 255 255 255 255 255 255 255 255 255 255 133 0 94 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 114 0 114 255 255 255 255 255 255 255 255 255 255 255 255 255 82 | 255 255 255 255 255 255 255 255 255 255 255 255 255 133 0 94 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 114 0 114 255 255 255 255 255 255 255 255 255 255 255 255 255 83 | 255 255 255 255 255 255 255 255 255 255 255 255 255 133 0 94 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 114 0 114 255 255 255 255 255 255 255 255 255 255 255 255 255 84 | 255 255 255 255 255 255 255 255 255 255 255 255 255 139 0 87 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 106 0 121 255 255 255 255 255 255 255 255 255 255 255 255 255 85 | 255 255 255 255 255 255 255 255 255 255 255 255 255 152 0 75 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 93 0 134 255 255 255 255 255 255 255 255 255 255 255 255 255 86 | 255 255 255 255 255 255 255 255 255 255 255 255 255 169 0 54 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 72 0 151 255 255 255 255 255 255 255 255 255 255 255 255 255 87 | 255 255 255 255 255 255 255 255 255 255 255 255 255 205 0 16 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 33 0 188 255 255 255 255 255 255 255 255 255 255 255 255 255 88 | 255 255 255 255 255 255 255 255 255 255 255 255 255 244 1 0 227 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 243 2 0 227 255 255 255 255 255 255 255 255 255 255 255 255 255 89 | 255 255 255 255 255 255 255 255 255 255 255 255 255 255 44 0 165 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 181 0 26 255 255 255 255 255 255 255 255 255 255 255 255 255 255 90 | 255 255 255 255 255 255 255 255 255 255 255 255 255 255 110 0 97 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 113 0 94 255 255 255 255 255 255 255 255 255 255 255 255 255 255 91 | 255 255 255 255 255 255 255 255 255 255 255 255 255 255 184 0 16 247 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 252 27 0 168 255 255 255 255 255 255 255 255 255 255 255 255 255 255 92 | 255 255 255 255 255 255 255 255 255 255 255 255 255 255 252 26 0 167 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 185 0 15 246 255 255 255 255 255 255 255 255 255 255 255 255 255 255 93 | 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 121 0 51 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 67 0 104 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 94 | 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 232 9 0 180 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 195 0 4 220 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 95 | 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 112 0 38 248 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 252 49 0 96 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 96 | 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 238 22 0 124 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 140 0 15 231 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 97 | 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 163 0 3 189 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 202 6 0 148 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 98 | 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 92 0 22 219 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 228 30 0 78 254 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 99 | 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 243 45 0 34 230 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 237 45 0 35 237 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 100 | 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 229 32 0 33 217 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 230 47 0 21 217 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 101 | 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 218 32 0 22 188 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 197 28 0 24 208 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 102 | 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 229 46 0 2 122 247 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 250 133 5 0 38 221 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 103 | 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 244 94 0 0 35 176 254 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 183 42 0 0 83 240 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 104 | 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 166 24 0 0 47 163 245 255 255 255 255 255 255 255 255 255 255 255 255 255 255 247 170 54 0 0 19 156 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 105 | 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 240 116 11 0 0 13 91 160 223 255 255 255 255 255 255 255 255 227 164 96 16 0 0 8 108 236 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 106 | 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 234 126 30 0 0 0 0 12 51 69 85 85 70 53 14 0 0 0 0 25 118 230 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 107 | 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 253 190 117 51 3 0 0 0 0 0 0 0 0 2 47 113 185 252 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 108 | 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 248 211 176 156 144 142 155 174 208 247 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 109 | 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 110 | 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255" 111 | -------------------------------------------------------------------------------- /Coursework/Three.agda: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------ 2 | -- CS410 Advanced Functional Programming 2022 3 | -- 4 | -- Coursework 3 5 | ------------------------------------------------------------------------ 6 | 7 | module Coursework.Three where 8 | 9 | ---------------------------------------------------------------------------- 10 | -- COURSEWORK 3 -- TERMINAL OBJECTS AND DATABASES USING ADJUNCTIONS 11 | -- 12 | -- VALUE: 40% (divided over 80 marks, ie each mark is worth 0.5%) 13 | -- DEADLINE: 5pm, Monday 5 December (Week 12) 14 | -- 15 | -- SUBMISSION: Push your solutions to your own repo. Your last commit 16 | -- before the deadline is your submitted version. However do get in 17 | -- touch if you want to negotiate about extensions. 18 | ---------------------------------------------------------------------------- 19 | 20 | -- HINT: your tasks are labelled with the very searchable tag '???' 21 | 22 | -- TIP: It remains a good idea to comment out parts of the file you 23 | -- currently are not working on. 24 | 25 | open import Data.String 26 | open import Data.Bool using (Bool; true; false; _∧_; if_then_else_) 27 | open import Data.Nat as Nat using (ℕ; zero; suc; _<ᵇ_; _≡ᵇ_; _⊔_) 28 | open import Data.Nat.Properties using (+-assoc; +-identityˡ; +-identityʳ) 29 | open import Data.Vec as Vec hiding (filter; splitAt; count; sum) 30 | open import Data.Vec.Properties 31 | open import Data.Fin 32 | open import Data.Fin.Properties 33 | open import Data.Unit hiding (total) 34 | open import Data.Empty 35 | open import Data.Sum hiding (reduce) 36 | open import Data.Sum.Properties 37 | open import Data.Product 38 | open import Function using () renaming (_∘′_ to _∘_) 39 | open import Relation.Nullary 40 | open import Relation.Binary.PropositionalEquality 41 | 42 | open import Common.Category 43 | open import Common.Category.Adjunctions 44 | open import Common.Category.Solver 45 | 46 | open import Coursework.Three.Categories 47 | 48 | open Category 49 | open Functor 50 | open Adjunction 51 | 52 | open Monoid 53 | open MonoidMorphism 54 | 55 | 56 | ------------------------------------------------------------------------ 57 | -- TERMINAL OBJECTS AND GLOBAL ELEMENTS (15 MARKS in total) 58 | ------------------------------------------------------------------------ 59 | 60 | -- Often concepts in category theory can be phrased as so-called 61 | -- universal properties: we can describe an object as the "best" 62 | -- object with a certain property, in the sense that all other objects 63 | -- with the same property uniquely maps into the given object. A simple example 64 | -- is the notion of a *terminal* object: this is an object such that 65 | -- every other object has a unique morphism into it. We can describe 66 | -- this as follows: 67 | 68 | record IsTerminal (C : Category)(X : Obj C) : Set where 69 | field 70 | mediate : (Y : Obj C) → Hom C Y X 71 | mediateUnique : {Y : Obj C} → (h : Hom C Y X) → h ≡ mediate Y 72 | open IsTerminal 73 | 74 | -- This says that an object X is terminal if for every object Y, there 75 | -- is a morphism `mediate Y` from Y to X, and this is the only 76 | -- morphism from Y to X. Some categories have terminal objects, others 77 | -- don't. For example, SET has ⊤ as a terminal object, because any 78 | -- there is exactly one way to give a function Y → ⊤: it must send 79 | -- everything to the only element tt : ⊤. 80 | 81 | ⊤-is-terminal : IsTerminal SET ⊤ 82 | mediate ⊤-is-terminal Y = λ y → tt 83 | mediateUnique ⊤-is-terminal h = refl 84 | 85 | {- ??? 3.1 Show that MONOID has a terminal object. 86 | (2 MARKS) -} 87 | 88 | -- HINT: Since morphisms in MONOID are morphisms in SET with extra 89 | -- structure, it might be a good idea to take the terminal object in 90 | -- SET and give it Monoid structure in order to create the terminal 91 | -- object in Monoid. 92 | 93 | ⊤-Monoid : Monoid 94 | ⊤-Monoid = {!!} 95 | 96 | MONOID-has-terminal-object : IsTerminal MONOID ⊤-Monoid 97 | MONOID-has-terminal-object = {!!} 98 | 99 | {- ??? 3.2 Similarly, show that PREORDER has a terminal object. 100 | (2 MARKS) -} 101 | 102 | open Preorder 103 | open MonotoneMap 104 | 105 | ⊤-Preorder : Preorder 106 | ⊤-Preorder = {!!} 107 | 108 | PREORDER-has-terminal-object : IsTerminal PREORDER ⊤-Preorder 109 | PREORDER-has-terminal-object = {!!} 110 | 111 | {- ??? 3.3 Show that there is a terminal category, too. 112 | (2 MARKS) -} 113 | 114 | ⊤-Cat : Category 115 | ⊤-Cat = {!!} 116 | 117 | CAT-has-terminal-object : IsTerminal CAT ⊤-Cat 118 | CAT-has-terminal-object = {!!} 119 | 120 | -- Objects in an arbitrary category might not have elements, but we 121 | -- can use a terminal object, if there is one, to talk about so-called 122 | -- /global elements/ instead: a global element of X is a morphism from 123 | -- the terminal object into X. This definition is motivated by the 124 | -- following fact: in the category SET, the elements and global 125 | -- elements of a set are "the same", in the sense that the two 126 | -- concepts are isomorphic, as in Coursework.Two: 127 | 128 | record _↔_ (A B : Set) : Set where 129 | field 130 | to : A -> B 131 | from : B -> A 132 | left-inverse-of : (x : A) -> from (to x) ≡ x 133 | right-inverse-of : (y : B) -> to (from y) ≡ y 134 | open _↔_ 135 | 136 | infix 3 _↔_ 137 | 138 | {- ??? 3.4 Prove that elements and global elements are the same thing 139 | in SET. 140 | (1 MARK) -} 141 | 142 | global-elements-in-SET : (X : Set) → Hom SET ⊤ X ↔ X 143 | global-elements-in-SET X = {!!} 144 | 145 | {- ??? 3.5 What are the global elements in PREORDER? Fill in your answer, 146 | and prove it. 147 | (2 MARKS) -} 148 | 149 | global-elements-in-PREORDER : (P : Preorder) → 150 | Hom PREORDER ⊤-Preorder P ↔ {!!} 151 | global-elements-in-PREORDER P = {!!} 152 | 153 | {- ??? 3.6 And what are the global elements in CAT? 154 | (3 MARKS) -} 155 | 156 | global-elements-in-CAT : (C : Category) → 157 | Hom CAT ⊤-Cat C ↔ {!!} 158 | global-elements-in-CAT C = {!!} 159 | 160 | {- ??? 3.7 Just as we are starting to see a pattern, let us see a 161 | perhaps unexpected example: what are the global elements 162 | in MONOID? 163 | (3 MARKS) -} 164 | 165 | global-elements-in-MONOID : (M : Monoid) → 166 | Hom MONOID ⊤-Monoid M ↔ {!!} 167 | global-elements-in-MONOID M = {!!} 168 | 169 | 170 | 171 | 172 | 173 | 174 | ------------------------------------------------------------------------ 175 | -- RELATIONAL ALGEBRA BY WAY OF ADJUNCTIONS (65 MARKS in total) 176 | ------------------------------------------------------------------------ 177 | 178 | -- In the rest of this coursework, we will develop a database library 179 | -- based on a fundamental adjunction between sets and monoids. Much of 180 | -- this is taken from the paper 181 | -- 182 | -- Relational Algebra by Way of Adjunctions 183 | -- Jeremy Gibbons, Fritz Henglein, Ralf Hinze, and Nicolas Wu 184 | -- International Conference on Functional Programming 2018 185 | -- https://www.cs.ox.ac.uk/jeremy.gibbons/publications/reladj.pdf 186 | 187 | --------------------------------------------- 188 | -- The Bag adjunction (10 MARKS in total) 189 | --------------------------------------------- 190 | 191 | -- We want to represent a database as a "bag" of values, so our first 192 | -- task is to define such bags. In order to be able to import this 193 | -- definition in the separate examples file below, we do this in 194 | -- another imported file: 195 | 196 | 197 | {- ??? 3.8--3.9 in Coursework.Three.Bag; solve them there! 198 | (10 MARKS) -} 199 | open import Coursework.Three.Bag 200 | 201 | --------------------------------------------- 202 | -- Using the adjunction (15 MARKS in total) 203 | --------------------------------------------- 204 | 205 | -- Without looking at how we implemented things in the abstract block, 206 | -- we will now extract some useful constructions and properties from 207 | -- the Bag adjunction constructed. 208 | 209 | {- ??? 3.10 First, show that there is an empty bag, and a way to 210 | combine two bags. (This is just using the functor BAG.) 211 | (1 MARK) -} 212 | 213 | empty : {A : Set} → Bag A 214 | empty {A} = {!!} 215 | 216 | _∪_ : {A : Set} → Bag A → Bag A → Bag A 217 | _∪_ {A} = {!!} 218 | 219 | {- ??? 3.11 Next, use the adjunction to construct singleton bags. 220 | (1 MARK) -} 221 | 222 | single : {A : Set} → A → Bag A 223 | single {A} a = {!!} 224 | 225 | {- ??? 3.12 Again using the adjunction, we also get a method for 226 | crushing down a whole bag of monoid elements into a single 227 | element. It is good to remember that this is operation 228 | preserves monoid structure, so derive it as a monoid 229 | morphism before extracting its underlying function. 230 | (1 MARK) -} 231 | 232 | reduceMonoid : (M : Monoid) → MonoidMorphism (act BAG (Carrier M)) M 233 | reduceMonoid M = {!!} 234 | 235 | reduce : (M : Monoid) → Bag (Carrier M) → Carrier M 236 | reduce M = {!!} 237 | 238 | {- ??? 3.13 Prove that reduce preserves empty bags, and unions of bags. 239 | (1 MARK) -} 240 | 241 | reduce-empty : (M : Monoid) → reduce M empty ≡ ε M 242 | reduce-empty = {!!} 243 | 244 | reduce-∪ : (M : Monoid) → (s t : Bag (Carrier M)) → 245 | reduce M (s ∪ t) ≡ _∙_ M (reduce M s) (reduce M t) 246 | reduce-∪ M = {!!} 247 | 248 | {- ??? 3.14 Also prove that if we reduce a singleton, we get the 249 | element back. 250 | (3 MARKS) -} 251 | 252 | reduce-single : (M : Monoid) → (m : Carrier M) → reduce M (single m) ≡ m 253 | reduce-single = {!!} 254 | 255 | {- ??? 3.15 Show that *any* monoid morphism out of Bag A can be 256 | written using reduce and single, and that as a result two 257 | such morphisms are equal if and only if they agree on 258 | singletons. 259 | (5 MARKS) -} 260 | 261 | morphism-out-of-Bag-unique : {A : Set}(M : Monoid) → 262 | (h : MonoidMorphism (act BAG A) M) → 263 | h ≡ comp MONOID (fmap BAG (fun h ∘ single)) (reduceMonoid M) 264 | morphism-out-of-Bag-unique = {!!} 265 | 266 | equal-from-Bag : {A : Set}(B : Monoid) → 267 | (f g : MonoidMorphism (act BAG A) B) → 268 | ((fun f) ∘ single ≡ (fun g) ∘ single) → 269 | f ≡ g 270 | equal-from-Bag = {!!} 271 | 272 | {- ??? 3.16 Let's make some monoids to reduce with! 273 | (3 MARKS) -} 274 | 275 | sum : Monoid 276 | Carrier sum = ℕ 277 | _∙_ sum = Nat._+_ 278 | ε sum = {!!} 279 | assoc sum {x} {y} {z} = {!!} 280 | identityˡ sum = {!!} 281 | identityʳ sum = {!!} 282 | 283 | max : Monoid 284 | Carrier max = ℕ 285 | _∙_ max = _⊔_ 286 | ε max = {!!} 287 | assoc max {x} {y} {z} = {!!} 288 | identityˡ max = {!!} 289 | identityʳ max {x} = {!!} 290 | 291 | all : Monoid 292 | Carrier all = Bool 293 | _∙_ all = _∧_ 294 | ε all = {!!} 295 | assoc all {x} {y} {z} = {!!} 296 | identityˡ all = {!!} 297 | identityʳ all {x} = {!!} 298 | 299 | --------------------------------------------- 300 | -- Relational algebra (20 MARKS in total) 301 | --------------------------------------------- 302 | 303 | {- ??? 3.17 Recall that Bag also has an action on functions, which 304 | preserves empty bags and unions of bags. 305 | (2 MARKS) -} 306 | 307 | Bagmap : {A B : Set} → (A → B) → Bag A → Bag B 308 | Bagmap = {!!} 309 | 310 | Bagmap-id : {A : Set} → Bagmap (λ (x : A) → x) ≡ Category.id SET 311 | Bagmap-id = {!!} 312 | 313 | Bagmap-comp : {A B C : Set} → (f : A → B)(g : B → C) → 314 | Bagmap (g ∘ f) ≡ comp SET (Bagmap f) (Bagmap g) 315 | Bagmap-comp = {!!} 316 | 317 | Bagmap-empty : {A B : Set} → (f : A → B) → Bagmap f empty ≡ empty 318 | Bagmap-empty = {!!} 319 | 320 | Bagmap-∪ : {A B : Set} → (f : A → B) → (s t : Bag A) → 321 | Bagmap f (s ∪ t) ≡ Bagmap f s ∪ Bagmap f t 322 | Bagmap-∪ = {!!} 323 | 324 | {- ??? 3.18 Using more of the adjunction, we can also show that Bagmap 325 | preserves singletons, and commutes with reduce in an 326 | appropriate sense. 327 | (4 MARKS) -} 328 | 329 | Bagmap-single : {A B : Set} → (f : A → B) → (a : A) → 330 | Bagmap f (single a) ≡ single (f a) 331 | Bagmap-single = {!!} 332 | 333 | reduce-natural : {A B : Set} → (f : A → B) → (reduce (act BAG B)) ∘ (Bagmap (Bagmap f)) ≡ Bagmap f ∘ (reduce (act BAG A)) 334 | reduce-natural = {!!} 335 | 336 | -- Using Bagmap, we can now implement projection, ie "SELECT field₁, ..., fieldₙ FROM table": 337 | -- the fields are given by a function `A → B`, and the table by a Bag A: 338 | 339 | project : {A B : Set} → (A → B) → Bag A → Bag B 340 | project = Bagmap 341 | 342 | {- ??? 3.19 Selection. Implement `guard p`, which turns a : A into a 343 | singleton bag if `p a` holds, and an empty bag otherwise. 344 | Use guard, reduce and Bagmap to implement filter, which 345 | should only keep the elements in the bag which satisfies p. 346 | 347 | This corresponds to the SQL construct "... WHERE p". 348 | (2 MARKS) -} 349 | 350 | guard : {A : Set} → (A → Bool) → A → Bag A 351 | guard = {!!} 352 | 353 | flattenBag : {A : Set} → Bag (Bag A) → Bag A 354 | flattenBag = {!!} 355 | 356 | filter : {A : Set} → (A → Bool) → Bag A → Bag A 357 | filter = {!!} 358 | 359 | {- ??? 3.20 Show that filter preserves empty bags and unions of bags. 360 | (2 MARKS) -} 361 | 362 | -- HINT: You've done the hard work for this already. 363 | 364 | filter-empty : {A : Set} → (p : A → Bool) → filter p empty ≡ empty 365 | filter-empty = {!!} 366 | 367 | filter-∪ : {A : Set} → (p : A → Bool) → (s t : Bag A) → 368 | filter p (s ∪ t) ≡ filter p s ∪ filter p t 369 | filter-∪ = {!!} 370 | 371 | {- ??? 3.21 Further show that filter interacts sensibly with 372 | singletons, and commutes with Bagmap in an appropriate 373 | sense. 374 | (4 MARKS) -} 375 | 376 | filter-single : {A : Set} → (p : A → Bool) → (a : A) → 377 | filter p (single a) ≡ guard p a 378 | filter-single = {!!} 379 | 380 | filter-Bag : {A B : Set} → (p : B → Bool) → (f : A → B) → 381 | (filter p) ∘ (Bagmap f) ≡ (Bagmap f) ∘ (filter (p ∘ f)) 382 | filter-Bag = {!!} 383 | 384 | {- ??? 3.22 Use reduce and Bagmap to implement the "cartesian product" 385 | of two bags, containing all combinations of elements from 386 | each bag. Then use the Cartesian product and filter to 387 | implement a the join of two tables on a common field, 388 | assuming this field has decidable equality. 389 | (3 MARKS) -} 390 | 391 | Bag× : {A B : Set} → Bag A × Bag B → Bag (A × B) 392 | Bag× = {!!} 393 | 394 | joinOn : ∀ {K V₁ V₂ : Set} → (eq : (x y : K) → Dec (x ≡ y)) → (f : V₁ → K)(g : V₂ → K) → Bag V₁ → Bag V₂ → Bag (V₁ × V₂) 395 | joinOn = {!!} 396 | 397 | {- ??? 3.23 Examples. Making use of the schemata (= records) and 398 | database instances (= terms of record type) in the 399 | `Coursework.Examples.Three` file, write expressions for 400 | computing the following queries: 401 | (3 MARKS) -} 402 | 403 | open import Coursework.Examples.Three 404 | 405 | eqFin : {n : ℕ} → (x y : Fin n) → Dec (x ≡ y) 406 | eqFin = Data.Fin._≟_ 407 | 408 | _Str≟_ : (s s' : String) → Bool 409 | s Str≟ s' = does (s Data.String.≟ s') 410 | 411 | -- Display the name and price of all orders with a price above £600 412 | -- "SELECT item-name, price FROM orders WHERE 600 < price" 413 | 414 | costs-over-600 : Bag (String × ℕ) 415 | costs-over-600 = {!!} 416 | 417 | -- Retrieve the names of all sellers of Apple AirPods in Glasgow 418 | -- "SELECT name FROM sellers JOIN orders ON seller-id WHERE item-name = 'Apple AirPods' AND city = 'Glasgow'" 419 | 420 | airpod-sellers : Bag String 421 | airpod-sellers = {!!} 422 | 423 | -- Calculate the total spend of purchases that has happened in Edinburgh 424 | -- "SELECT sum(price) FROM sellers JOIN orders where Seller.city = 'Edinburgh'" 425 | 426 | total-spend-in-Edinburgh : ℕ 427 | total-spend-in-Edinburgh = {!!} 428 | 429 | --------------------------------------------- 430 | -- Indexed tables (20 MARKS in total) 431 | --------------------------------------------- 432 | 433 | -- The above implementation of join works, but is rather inefficient: 434 | -- we compute all possible combinations of elements, then throw away 435 | -- all those pairs where the keys do not match. It would be more 436 | -- efficient to first /index/ the bags by their keys, and then just 437 | -- compute small Cartesian products for each key. 438 | 439 | -- Step 1 to achieve this is to build machinery for maps from keys to 440 | -- values. By restricting the possible keys, we can ensure an 441 | -- efficient implementation. We hence consider the following universe 442 | -- of keys: 443 | 444 | data Key : Set where 445 | 0' 1' : Key 446 | Word' : Key 447 | _+'_ _×'_ : Key → Key → Key 448 | 449 | -- Each key has a given size: 450 | 451 | size : Key → ℕ 452 | size 0' = 0 453 | size 1' = 1 454 | size Word' = 16 -- some fixed size 455 | size (p +' q) = size p Nat.+ size q 456 | size (p ×' q) = size p Nat.* size q 457 | 458 | -- ...and a key represents a number smaller than its size. 459 | 460 | ⟦_⟧ : Key → Set 461 | ⟦ k ⟧ = Fin (size k) 462 | 463 | eqKey : (k : Key) → (x y : ⟦ k ⟧) → Dec (x ≡ y) 464 | eqKey k x y = x Data.Fin.≟ y 465 | 466 | -- We can now give a first-order representation of functions ⟦ k ⟧ → V: 467 | 468 | Map : Key → (V : Set) → Set 469 | Map 0' V = ⊤ 470 | Map 1' V = V 471 | Map Word' V = Vec V (size Word') 472 | Map (k +' k') V = Map k V × Map k' V 473 | Map (k ×' k') V = Map k (Map k' V) 474 | 475 | Map' : Key → (V : Set) → Set 476 | Map' k V = ⟦ k ⟧ → V 477 | 478 | {- ??? 3.24 Prove that indeed `Map k V` is isomorphic to `Map' k V`. 479 | (3 MARKS) -} 480 | 481 | Map-to : (k : Key) (V : Set) → Map k V -> Map' k V 482 | Map-to = {!!} 483 | 484 | Map-from : (k : Key) (V : Set) → Map' k V -> Map k V 485 | Map-from = {!!} 486 | 487 | Map-to-from : (k : Key) (V : Set) → (x : Map k V) → Map-from k V (Map-to k V x) ≡ x 488 | Map-to-from = {!!} 489 | 490 | Map-from-to : (k : Key) (V : Set) → (x : Map' k V) → Map-to k V (Map-from k V x) ≡ x 491 | Map-from-to = {!!} 492 | 493 | 494 | Map↔Map' : (k : Key) → (V : Set) → Map k V ↔ Map' k V 495 | Map↔Map' k V = {!!} 496 | 497 | {- ??? 3.25 Use the isomorphism Map↔Map' to get an easy proof that 498 | `Map k` has an action on functions. 499 | (1 MARK) -} 500 | 501 | Mapmap : (k : Key) → {V V' : Set} → (f : V → V') → Map k V → Map k V' 502 | Mapmap = {!!} 503 | 504 | {- ??? 3.26 Use the isomorphism again to construct constant maps. 505 | (1 MARK) -} 506 | 507 | constMap : (k : Key) → (V : Set) → (v : V) → Map k V 508 | constMap = {!!} 509 | 510 | {- ??? 3.27 Show that maps into V₁ × V₂ are the same as a pair of maps 511 | into V₁ and V₂ separately. 512 | (2 MARKS) -} 513 | 514 | mergeMap : (k : Key) → (V₁ V₂ : Set) → Map k V₁ × Map k V₂ → Map k (V₁ × V₂) 515 | mergeMap = {!!} 516 | 517 | mergeMap-inverse : (k : Key) → (V₁ V₂ : Set) → Map k (V₁ × V₂) → Map k V₁ × Map k V₂ 518 | mergeMap-inverse = {!!} 519 | 520 | mergeMap-to-from : (k : Key) → (V₁ V₂ : Set) → (h : Map k V₁ × Map k V₂) → mergeMap-inverse k V₁ V₂ (mergeMap k V₁ V₂ h) ≡ h 521 | mergeMap-to-from = {!!} 522 | 523 | mergeMap-from-to : (k : Key) → (V₁ V₂ : Set) → (h : Map k (V₁ × V₂)) → mergeMap k V₁ V₂ (mergeMap-inverse k V₁ V₂ h) ≡ h 524 | mergeMap-from-to = {!!} 525 | 526 | mergeMap-iso : (k : Key) → (V₁ V₂ : Set) → (Map k V₁ × Map k V₂) ↔ Map k (V₁ × V₂) 527 | mergeMap-iso = {!!} 528 | 529 | -- We are now ready to introduce our indexed notion of Bags: a table 530 | -- is a map from keys to bags of values. 531 | 532 | Table : Key → (V : Set) → Set 533 | Table k V = Map k (Bag V) 534 | 535 | {- ??? 3.28 Use the constructions on maps above to reimplement the 536 | basic relational algebra operations on tables. 537 | (6 MARKS) -} 538 | 539 | emptyTable : ∀ {k} {V} → Table k V 540 | emptyTable = {!!} 541 | 542 | singleTable : ∀ {k} {V} → (v : V) → Table k V 543 | singleTable = {!!} 544 | 545 | unionTable : ∀ {k} {V} → Table k V → Table k V → Table k V 546 | unionTable = {!!} 547 | 548 | projectTable : ∀ {k} {V V'} → (f : V → V') → Table k V → Table k V' 549 | projectTable = {!!} 550 | 551 | filterTable : ∀ {k} {V} → (p : V → Bool) → Table k V → Table k V 552 | filterTable = {!!} 553 | 554 | reduceTable : ∀ {k} (M : Monoid) → Table k (Carrier M) → Map k (Carrier M) 555 | reduceTable = {!!} 556 | 557 | {- ??? 3.29 Use Map-from, project and filter to implement indexing ix, 558 | which given a bag of key-value pairs should return a table 559 | where keys are mapped to the bag of all values associated 560 | to the key. 561 | 562 | Use ix to implement indexBy, the work horse of fast joining. 563 | (3 MARKS) -} 564 | 565 | ix : ∀ {k} {V} → Bag (⟦ k ⟧ × V) → Table k V 566 | ix = {!!} 567 | 568 | indexBy : (k : Key){V : Set} → (V → ⟦ k ⟧) → Bag V → Table k V 569 | indexBy = {!!} 570 | 571 | {- ??? 3.30 We also need a way to turn a table back into a bag again, 572 | by collecting all the values for all the different keys. 573 | Implement this for both maps and tables. 574 | (2 MARKS) -} 575 | 576 | elemsMap : {k : Key} {V : Set} → Map k V → Bag V 577 | elemsMap = {!!} 578 | 579 | elems : {k : Key} {V : Set} → Table k V → Bag V 580 | elems = {!!} 581 | 582 | {- ??? 3.31 Finally we can use indexBy to implement an efficient join on keys. 583 | (1 MARKS) -} 584 | 585 | fastJoinOn : ∀ {k} {V₁ V₂} → (f : V₁ → ⟦ k ⟧)(g : V₂ → ⟦ k ⟧) → Bag V₁ → Bag V₂ → Bag (V₁ × V₂) 586 | fastJoinOn = {!!} 587 | 588 | {- ??? 3.32 An example again. Use indexBy and other table operations to 589 | compute the most expensive purchase for each buyer. 590 | "SELECT name, max(price) FROM buyers JOIN orders ON Buyer.buyer-id = Order.buyer-id" 591 | (1 MARK) -} 592 | 593 | most-expensive-per-buyer : Bag (String × ℕ) 594 | most-expensive-per-buyer = {!!} 595 | -------------------------------------------------------------------------------- /Coursework/One.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --guardedness #-} 2 | ------------------------------------------------------------------------ 3 | -- CS410 Advanced Functional Programming 2022 4 | -- 5 | -- Coursework 1 6 | ------------------------------------------------------------------------ 7 | 8 | module Coursework.One where 9 | 10 | ---------------------------------------------------------------------------- 11 | -- COURSEWORK 1 -- WARMING UP, LOGIC, AND GRAY SCALE IMAGE MANIPULATION 12 | -- 13 | -- VALUE: 30% (divided over 60 marks, ie each mark is worth 0.5%) 14 | -- DEADLINE: 5pm, Monday 10 October (Week 4) 15 | -- 16 | -- SUBMISSION: Create your own clone of CS410 repo somewhere of your 17 | -- choosing (e.g. Gitlab, Github, or Bitbucket), and let Fred know 18 | -- where, so that you can invite the CS410 team to the project. The 19 | -- last commit before the deadline is your submitted version. However 20 | -- do get in touch if you want to negotiate about extensions. 21 | ---------------------------------------------------------------------------- 22 | 23 | -- HINT: These are all the imports from the standard library that you 24 | -- should need, although you might of course have to define your own 25 | -- auxiliary functions. When there is no explicit `using` list, you may 26 | -- go hunting in the module for anything you think you might find useful. 27 | 28 | open import Data.Bool using (Bool; true; false; not; _∧_; _∨_; if_then_else_) 29 | open import Data.Nat using (ℕ; zero; suc; _<ᵇ_; _≤ᵇ_; _+_; ⌊_/2⌋; ⌈_/2⌉) 30 | open import Data.Nat.Properties 31 | open import Common.NatProperties using (n≡⌊n+n/2⌋; n≡⌈n+n/2⌉) 32 | open import Data.List 33 | using (List; []; _∷_; _++_; [_]) 34 | renaming (map to ListMap; splitAt to ListSplitAt) 35 | open import Data.Vec 36 | using (Vec; []; _∷_; lookup) 37 | renaming (map to VecMap; toList to VecToList) 38 | open import Data.Fin 39 | using (Fin; zero; suc; toℕ; fromℕ; inject≤; pred) 40 | renaming (splitAt to FinSplitAt) 41 | open import Data.Product using (_×_; Σ; _,_; proj₁; proj₂; Σ-syntax) 42 | open import Data.Sum using (_⊎_; inj₁; inj₂) 43 | open import Data.Empty using (⊥; ⊥-elim) 44 | open import Data.Unit.Polymorphic using (⊤) 45 | import Data.Maybe -- we refrain from opening this module until we need it 46 | open import Function using (_∘_; id; _$_; case_of_) 47 | open import Relation.Nullary using (¬_; Dec; yes; no) 48 | open import Relation.Binary.PropositionalEquality 49 | using (_≡_; refl; cong; sym; trans; subst) 50 | open import Data.String hiding (show) renaming (_++_ to _S++_) 51 | open import Data.Char hiding (show; toℕ; fromℕ) 52 | open import Data.Nat.Show renaming (readMaybe to readMaybeNat; show to showNat) 53 | open import Data.Fin.Show renaming (readMaybe to readMaybeFin; show to showFin) 54 | import Level 55 | 56 | -- HINT: your tasks are labelled with the very searchable tag '???' 57 | 58 | -- TIP: When you load this file, you will see lots of open goals. You 59 | -- can focus on one at a time by using comments {- ... -} to switch 60 | -- off the later parts of the file until you get there. 61 | 62 | 63 | 64 | ------------------------------------------------------------------------ 65 | -- SOME GOOD OLD FUNCTIONAL PROGRAMMING: TREESORT (10 MARKS in total) 66 | ------------------------------------------------------------------------ 67 | 68 | -- Here is a datatype of node-labelled binary trees: 69 | 70 | data Tree (X : Set) : Set where 71 | leaf : Tree X 72 | _<[_]>_ : Tree X -> X -> Tree X -> Tree X 73 | 74 | 75 | {- ??? 1.1 Implement the insertion of a number into a tree, ensuring that 76 | the numbers in the tree are in increasing order from left to right; 77 | make sure to retain duplicates. 78 | (2 MARKS) -} 79 | 80 | insertTree : ℕ -> Tree ℕ -> Tree ℕ 81 | insertTree = {!!} 82 | 83 | -- HINT: the import list for Data.Nat above might contain useful things 84 | 85 | {- ??? 1.2 Implement the function which takes the elements of a list and 86 | builds an ordered tree from them, using insertTree. 87 | (1 MARK) -} 88 | 89 | makeTree : List ℕ -> Tree ℕ 90 | makeTree = {!!} 91 | 92 | {- ??? 1.3 Implement the function which flattens a tree to a list, 93 | and combine it with makeTree to implement a sorting function. 94 | (1 MARKS) -} 95 | 96 | flatten : {X : Set} -> Tree X -> List X 97 | flatten = {!!} 98 | 99 | treeSort : List ℕ -> List ℕ 100 | treeSort = {!!} 101 | 102 | -- TIP: You can uncomment the following test cases to check your work. They 103 | -- should all typecheck if you got it right. 104 | 105 | {- 106 | _ : treeSort [ 1 ] ≡ [ 1 ] 107 | _ = refl 108 | 109 | _ : treeSort (1 ∷ 2 ∷ 3 ∷ []) ≡ (1 ∷ 2 ∷ 3 ∷ []) 110 | _ = refl 111 | 112 | _ : treeSort (3 ∷ 1 ∷ 2 ∷ []) ≡ (1 ∷ 2 ∷ 3 ∷ []) 113 | _ = refl 114 | 115 | _ : treeSort (3 ∷ 2 ∷ 3 ∷ []) ≡ (2 ∷ 3 ∷ 3 ∷ []) 116 | _ = refl 117 | -} 118 | 119 | {- ??? 1.4 implement a fast version of flatten, taking an accumulating 120 | parameter, never using ++. It should satisfy 121 | 122 | fastFlatten t xs ≡ flatten t ++ xs 123 | 124 | We can use fastFlatten to build a faster version of tree sort. 125 | (2 MARKS) -} 126 | 127 | fastFlatten : {X : Set} -> Tree X -> List X -> List X 128 | fastFlatten leaf = id 129 | fastFlatten (l <[ x ]> r) = fastFlatten l ∘ (x ∷_) ∘ fastFlatten r 130 | 131 | fastTreeSort : List ℕ -> List ℕ 132 | fastTreeSort xs = fastFlatten (makeTree xs) [] 133 | 134 | -- TIP: You can copy and modify the test cases above to check that 135 | -- also fastTreeSort works as intended. 136 | 137 | {- ??? 1.5 *Prove* that fastFlatten correctly implements it 138 | specification. You will need to prove an additional fact about 139 | concatenation separately, and use that in the proof. 140 | (3 MARKS) -} 141 | 142 | fastFlattenCorrect : {X : Set} -> (t : Tree X) -> (xs : List X) -> 143 | fastFlatten t xs ≡ (flatten t ++ xs) 144 | fastFlattenCorrect = {!!} 145 | 146 | {- ??? 1.6 Use fastFlattenCorrect to prove that treeSort and 147 | fastTreeSort agree. If you stop and think, you should see that 148 | there is no need to pattern match here. But, again, you will need 149 | to prove an additional fact about concatenation. 150 | (1 MARK) -} 151 | 152 | fastTreeSortCorrect : (xs : List ℕ) -> fastTreeSort xs ≡ treeSort xs 153 | fastTreeSortCorrect = {!!} 154 | 155 | ------------------------------------------------------------------------ 156 | -- DOUBLEPLUSGOOD NEGATION (20 MARKS in total) 157 | ------------------------------------------------------------------------ 158 | 159 | module Logic where -- To avoid name clashes, we use a local module here 160 | 161 | {- ??? 1.7 Implement the following operations: 162 | (2 MARKS) -} 163 | 164 | orAdjunctionFrom : {P Q R : Set} → (P ⊎ Q -> R) -> ((P -> R) × (Q -> R)) 165 | orAdjunctionFrom = {!!} 166 | 167 | orAdjunctionTo : {P Q R : Set} → ((P -> R) × (Q -> R)) -> (P ⊎ Q -> R) 168 | orAdjunctionTo = {!!} 169 | 170 | {- ??? 1.8 Which of the following operations can be implemented? 171 | For each operation, either give an implementation, or comment 172 | it out, leaving a comment explaining why it cannot be 173 | implemented. 174 | 175 | For full marks, it is not enough to give a handwavy 176 | explanation why something cannot be implemented -- instead, 177 | show how implementing the operation would make a known 178 | non-implementable operation implementable, such as the Law of 179 | Excluded Middle, or Double Negation Elimination. 180 | (4 MARKS) -} 181 | 182 | contrapositive : {P Q : Set} → (P → Q) → (¬ Q → ¬ P) 183 | contrapositive = {!!} 184 | 185 | contrapositiveReverse : {P Q : Set} → (¬ Q → ¬ P) → (P → Q) 186 | contrapositiveReverse = {!!} 187 | 188 | variation1 : {P Q : Set} → (P → ¬ Q) → (Q → ¬ P) 189 | variation1 = {!!} 190 | 191 | variation2 : {P Q : Set} → (¬ P → Q) → (¬ Q → P) 192 | variation2 = {!!} 193 | 194 | {- ??? 1.9 Another principle of classical logic which is not provable in 195 | Agda is Peirce's Law. However show that its double-negation is 196 | provable. 197 | (2 MARKS) -} 198 | 199 | ¬¬Peirce : {P Q : Set} → ¬ ¬ (((P -> Q) -> P) -> P) 200 | ¬¬Peirce = {!!} 201 | 202 | {- ??? 1.10 For each of the following operations, either give an 203 | implementation, or comment it out and leave a comment 204 | explaining why it is impossible to implement. 205 | (4 MARKS) -} 206 | 207 | deMorgan-∀-from : {A : Set}{R : A -> Set} -> ¬ ((x : A) -> R x) -> Σ[ x ∈ A ] (¬ (R x)) 208 | deMorgan-∀-from = {!!} 209 | 210 | deMorgan-∀-to : {A : Set}{R : A -> Set} -> Σ[ x ∈ A ] (¬ (R x)) -> ¬ ((x : A) -> R x) 211 | deMorgan-∀-to = {!!} 212 | 213 | deMorgan-∃-from : {A : Set}{R : A -> Set} -> ((x : A) -> (¬ (R x))) -> ¬ (Σ[ x ∈ A ] (R x)) 214 | deMorgan-∃-from = {!!} 215 | 216 | deMorgan-∃-to : {A : Set}{R : A -> Set} -> ¬ (Σ[ x ∈ A ] (R x)) -> (x : A) → (¬ (R x)) 217 | deMorgan-∃-to = {!!} 218 | 219 | {- ??? 1.11 Show that double negation is a /monad/; a concept you 220 | might remember from Haskell (don't worry if you don't, we'll 221 | get back to it later!). Concretely, you need to implement the 222 | following two operations: 223 | (1 MARK) -} 224 | 225 | return : {P : Set} → P -> ¬ ¬ P 226 | return = {!!} 227 | 228 | _>>=_ : {P Q : Set} → ¬ ¬ P -> (P -> ¬ ¬ Q) -> ¬ ¬ Q 229 | (¬¬p >>= f) = {!!} 230 | 231 | -- TIP: if an operation with name _>>=_ is in scope, Agda allows us to 232 | -- use do-notation (again possibly familiar from Haskell) to write 233 | -- 234 | -- do 235 | -- x <- mx 236 | -- f 237 | -- 238 | -- instead of mx >>= λ x → f. Here is an example (feel free to play 239 | -- around and make a hole in the last line to see what is going on): 240 | 241 | ¬¬-map : {P Q : Set} → (P -> Q) -> ¬ ¬ P -> ¬ ¬ Q 242 | ¬¬-map f ¬¬p = do 243 | p ← ¬¬p 244 | return (f p) 245 | 246 | {- ??? 1.12 Use do-notation and/or ¬¬-map to show that 247 | double negation distributes over 'exists' and 'or' (what about 248 | functions in the reverse directions?). 249 | (2 MARKS) -} 250 | 251 | 252 | ¬¬-distributes-∃ : {A : Set}{S : A → Set} → 253 | Σ[ x ∈ A ] (¬ ¬ (S x)) -> ¬ ¬ (Σ A S) 254 | ¬¬-distributes-∃ = {!!} 255 | 256 | ¬¬-distributes-⊎ : {P Q : Set} → ¬ ¬ P ⊎ ¬ ¬ Q -> ¬ ¬ (P ⊎ Q) 257 | ¬¬-distributes-⊎ = {!!} 258 | 259 | {- ??? 1.13 The Fundamental Interconnectedness of All Things. Prove the 260 | following counter-intuitive fact of classical logic: for any two 261 | things, one must imply the other. 262 | 263 | HINT: You might want to look up the phrase "material 264 | implication", and maybe prove a lemma. 265 | 266 | For full marks, also pay attention to style, e.g., layout, 267 | no excessive brackets, choice of variable names, etc. 268 | (5 MARKS) -} 269 | 270 | dirkGently : (lem : (X : Set) -> X ⊎ ¬ X) -> {P Q : Set} → (P -> Q) ⊎ (Q -> P) 271 | dirkGently lem {P} {Q} = {!!} 272 | 273 | ----------------------------------------------------------------------- 274 | -- maxVal SHADES OF GRAY (30 MARKS in total) 275 | ------------------------------------------------------------------------ 276 | 277 | open Data.Maybe 278 | 279 | {- Our final task is to write a commandline program for manipulating 280 | and displaying grayscale images. This section is deliberately left 281 | more open-ended for you to practice designing and writing slightly 282 | larger programs. Most likely you will have to come up with your own 283 | plan, and implement some auxiliary functions to get there. -} 284 | 285 | {- ??? 1.23 Below, there are four marks available for good style, 286 | sensible reusable supporting functions, and good comments. 287 | (4 MARKS) -} 288 | 289 | {- Let's get started! 290 | 291 | A (plain) Portable GrayMap (PGM) format 292 | [http://netpbm.sourceforge.net/doc/pgm.html] representation of a 293 | grayscale image consists of the following ASCII text: 294 | * The "magic number" P2; 295 | * whitespace (space, tabs, line breaks, etc); 296 | * A natural number w, formatted in decimal as ASCII; 297 | * whitespace; 298 | * A natural number h, formatted in decimal as ASCII; 299 | * whitespace; 300 | * A natural number maxVal, formatted in decimal as ASCII; 301 | * h number of rows separated by line breaks, each row consisting of 302 | w entries separated by whitespace, each entry being a natural 303 | number smaller than or equal to maxVal. 304 | 305 | Each entry in the raster represents a grayscale pixel value, ranging 306 | from 0 = black to maxVal = white (note that 0 is black, not white!). 307 | You can see some examples in the Coursework.Examples.One file, and in the 308 | Examples directory. 309 | -} 310 | 311 | open import Coursework.Examples.One 312 | 313 | {- Notice how data earlier in the file determines the format of the 314 | following data; a dependent type! 315 | -} 316 | 317 | {- ??? 1.14 Your first task is to represent a PGM file as an Agda record, 318 | by completing the following definition with the required fields. 319 | Use vectors from Data.Vec to represent the rows and columns, and 320 | finite numbers from Data.Fin to represent the bounded entries. 321 | (1 MARK) -} 322 | 323 | record PlainPGM : Set where 324 | constructor P2 -- just a suggested name 325 | field 326 | -- ADD YOUR FIELDS HERE 327 | 328 | {- ??? 1.15 To make sure that you understand the file format, write a function 329 | that turns a PlainPGM back into a string. 330 | (2 MARKS) -} 331 | 332 | writePGM : PlainPGM -> String 333 | writePGM = {!!} 334 | 335 | -- HINT: You might find the modules Data.Nat.Show and Data.Fin.Show useful, 336 | -- as well as Data.String. 337 | 338 | {- ??? 1.16 Continuing our quest for understanding, write a function 339 | which generates an "ASCII art" rendering of a PGM file; you 340 | will need to decide on some cutoff points for translating 341 | grayscale pixel intensity into symbols, e.g., you could choose 342 | 100% = '#' 343 | 75% = '%' 344 | 50% = '^' 345 | 25% = '.' 346 | with even more distinctions if you want. 347 | 348 | Hint: Looking back at the spec, what does 0 represent? 349 | (3 MARKS) -} 350 | 351 | viewPGM : PlainPGM -> String 352 | viewPGM = {!!} 353 | 354 | -- HINT: You can now look at a PGM image i by normalising viewPGM in 355 | -- emacs; if you do C-u C-u C-c C-n, emacs will apply the following 356 | -- trivial show function to the resulting string, which will print the 357 | -- newlines correctly: 358 | 359 | show : String -> String 360 | show = id 361 | 362 | {- ??? 1.17 We also want to be able to read images given to us. Since 363 | we have no guarantees that the string we are given actually 364 | represents a valid image, we will have to produce Maybe an 365 | image. However for debugging ease of use, also implement an "unsafe" 366 | version which should return an empty image if readPGM fails. 367 | (4 MARKS) -} 368 | 369 | readPGM : String -> Maybe PlainPGM 370 | readPGM = {!!} 371 | 372 | unsafeReadPGM : String -> PlainPGM 373 | unsafeReadPGM = {!!} 374 | 375 | -- HINT: Again Data.Nat.Show and Data.String are your friends. 376 | 377 | -- HINT: It is polite to be forgiving in what you accept, and not 378 | -- insist on newlines over other whitespace to separate lines, for 379 | -- example. And if you look in Data.String, it is sometimes easy to be 380 | -- polite. 381 | 382 | -- HINT: Since Maybe also is a monad, Agda allows you to use do 383 | -- notation here, which could be helpful. 384 | 385 | {- !!! Congratulations, you have now implemented enough to have a 386 | working running program! If you look at the bottom of this file, 387 | you will see a main function I have prepared for you. You should be 388 | able to compile this file by selecting "Compile" in the Agda menu 389 | and then the "GHC" backend, and then run the produced binary on the 390 | commandline, with the "-ascii" action working. Try it out on one of 391 | the sample files in the One directory, or your favourite PGM file 392 | from the Internet! You can use `convert -compress none` to convert 393 | almost any image into plain PGM format if you have imagemagick 394 | installed. -} 395 | 396 | {- ??? 1.18 Implement "posterization", which literally treats the 397 | world as black-and-white: if the pixel is <= 50%, make it 0%, 398 | otherwise make it 100%. Note that we do not need to produce 399 | Maybe an image here, because we know that the input we get is 400 | correct. 401 | 402 | After implementing this, the "-posterize" action should work if 403 | you recompile the program. 404 | (2 MARKS) -} 405 | 406 | posterize : PlainPGM → PlainPGM 407 | posterize = id -- CHANGE THIS! 408 | 409 | -- TO PONDER: What happens if you posterize an already posterized image? 410 | -- Can you prove it? 411 | 412 | 413 | {- ??? 1.19 Implement rotation, which turns an image sideways (you can 414 | decide if clockwise or anticlockwise). 415 | (4 MARKS) -} 416 | 417 | rotate : PlainPGM → PlainPGM 418 | rotate = id -- CHANGE THIS! 419 | 420 | -- HINT: It might be useful to be able to repeat an element to fill up 421 | -- a vector of a given length, and to be able to "apply" a vector full 422 | -- of functions to a vector full of arguments. 423 | 424 | {- !!! You should now be able to use the "-rotate" action in your program -} 425 | 426 | {- ??? 1.20 Implement shrinking, which halves the size of an image by 427 | replacing each pixel with the average of its neighbours (you 428 | don't have to consider the neighbours in all nine directions, 429 | unless you want to; it is enough to consider for example the 430 | previous neighbor in both directions). 431 | (4 MARKS) -} 432 | 433 | shrink : PlainPGM → PlainPGM 434 | shrink = id -- CHANGE THIS! 435 | 436 | -- HINT: it might be useful to give yourself "random access" to 437 | -- the raster. The function `lookup : ∀ {n} → Vec A n → (Fin n → A)` 438 | -- from Data.Vec makes it possible to see a vector as a function from 439 | -- `Fin n` -- can you go the other way, i.e., implement 440 | -- `tabulate : {n : ℕ} → (Fin n -> A) -> Vec A n`? 441 | -- Another hint: Data.Nat.Properties contain many useful facts. 442 | 443 | {- !!! You should now be able to use the "-shrink" action in your program. 444 | Well done, you have now implemented the basic functionality of the program. 445 | We now move on to some nice extras. -} 446 | 447 | {- ??? 1.21 Allowing comments. The PGM file format actually allows 448 | comments, in the sense that any content following a hash symbol 449 | '#' is ignored until the end of the line. Implement this as a 450 | preprocessing step, so that you can use images downloaded from 451 | the Internet. 452 | (1 MARK) -} 453 | 454 | stripComments : String → String 455 | stripComments = id -- CHANGE THIS! 456 | 457 | {- ??? 1.22 Time for you to shine! Implement a further interesting 458 | operation on PGM images by changing "-youraction" in the main 459 | program below. You could e.g. implement inverting, tiling, 460 | or merging different images, or... 461 | (5 MARKS) -} 462 | 463 | {- Your program here! -} 464 | 465 | 466 | {- Here follows some stuff for doing IO via Haskell functions; you can 467 | safely ignore until the main function below -} 468 | 469 | open import IO using (IO) 470 | import IO.Primitive 471 | open import IO.Finite 472 | open import Foreign.Haskell.Pair 473 | 474 | {-# FOREIGN GHC import qualified System.Environment #-} 475 | {-# FOREIGN GHC import qualified System.FilePath #-} 476 | {-# FOREIGN GHC import qualified Data.Text #-} 477 | {-# FOREIGN GHC import qualified Control.Arrow #-} 478 | 479 | postulate 480 | primGetArgs : IO.Primitive.IO (List String) 481 | splitExtension : String → Pair String String 482 | 483 | {-# COMPILE GHC primGetArgs = fmap Data.Text.pack <$> System.Environment.getArgs #-} 484 | {-# COMPILE GHC splitExtension = (Data.Text.pack Control.Arrow.*** Data.Text.pack) . System.FilePath.splitExtension . Data.Text.unpack #-} 485 | 486 | getArgs : IO (List String) 487 | getArgs = IO.lift primGetArgs 488 | 489 | addExtension : Pair String String → String 490 | addExtension (f , ext) = f S++ ext 491 | 492 | writeFile' : String → String → IO {Level.zero} ⊤ 493 | writeFile' file content = do 494 | IO.putStrLn ("Writing output to " S++ file) IO.>>= \ _ → writeFile file content 495 | 496 | {- Something interesting happening here again! -} 497 | 498 | main : IO.Main 499 | main = IO.run $ 500 | getArgs IO.>>= λ where 501 | (action ∷ file ∷ []) → 502 | readFile file IO.>>= λ contents → 503 | case readPGM (stripComments contents) 504 | of λ { nothing → IO.putStrLn "Error: malformed input file" 505 | ; (just pgm) → act action (splitExtension file) pgm } 506 | _ → IO.putStrLn $ "Usage: One ACTION INPUTFILE" S++ available 507 | where 508 | available : String 509 | available = "\n\nAvailable actions: -ascii -posterize -reflect -rotate" 510 | act : (action : String) -> (file : Pair String String) -> PlainPGM -> IO ⊤ 511 | act "-ascii" out pgm = IO.putStrLn $ viewPGM pgm 512 | act "-posterize" (out , ext) pgm = 513 | writeFile' (addExtension (out S++ "-posterized", ext)) 514 | (writePGM (posterize pgm)) 515 | act "-shrink" (out , ext) pgm = 516 | writeFile' (addExtension (out S++ "-shrunk", ext)) 517 | (writePGM (shrink pgm)) 518 | act "-rotate" (out , ext) pgm = 519 | writeFile' (addExtension (out S++ "-rotated", ext)) 520 | (writePGM (rotate pgm)) 521 | act "-youridea" (out , ext) pgm = IO.putStrLn $ "YOUR IDEA HERE?" 522 | act action out pgm = 523 | IO.putStrLn $ "Error: unknown action " S++ action S++ available 524 | 525 | -- NOTE: You might find that your program is quite inefficient on 526 | -- larger images -- this is okay, for now, although it could be 527 | -- interesting to think about why that is. In general, there is much 528 | -- work to be done to enable efficient compilation of dependently 529 | -- typed programs. 530 | 531 | 532 | {- 533 | To compile: 534 | 535 | Either do C-c C-x C-c in Emacs (or select "Compile" from the Agda 536 | menu), and choose the GHC backend, or run 537 | 538 | agda -c One.agda 539 | 540 | on the command line. If you have unfinished holes from further up 541 | the file, it is easiest to comment them out before compiling. 542 | 543 | To run the resulting program, 544 | 545 | ./One ACTION INPUTFILE 546 | -} 547 | -------------------------------------------------------------------------------- /Coursework/Two.agda: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------ 2 | -- CS410 Advanced Functional Programming 2022 3 | -- 4 | -- Coursework 2 5 | ------------------------------------------------------------------------ 6 | 7 | module Coursework.Two where 8 | 9 | ---------------------------------------------------------------------------- 10 | -- COURSEWORK 2 -- ISOMORPHIC DEFINITIONS, AND PLAYING AROUND WITH HUTTON'S RAZOR 11 | -- 12 | -- VALUE: 30% (divided over 60 marks, ie each mark is worth 0.5%) 13 | -- DEADLINE: 5pm, Monday 31 October (Week 7) 14 | -- 15 | -- SUBMISSION: Push your solutions to your own repo. Your last commit 16 | -- before the deadline is your submitted version. However do get in 17 | -- touch if you want to negotiate about extensions. 18 | ---------------------------------------------------------------------------- 19 | 20 | -- HINT: your tasks are labelled with the very searchable tag '???' 21 | 22 | -- TIP: When you load this file, you will see lots of open goals. You 23 | -- can focus on one at a time by using comments {- ... -} to switch 24 | -- off the later parts of the file until you get there. Later on you 25 | -- might want to switch off earlier parts to make loading later parts 26 | -- faster (don't forget to switch them back on when you are done!). 27 | 28 | open import Data.Nat using (ℕ; zero; suc; _+_; _*_; _∸_; _<ᵇ_) 29 | open import Data.Nat.Properties 30 | using (+-identityʳ; +-identityˡ; +-suc; +-comm; +-assoc) 31 | renaming (_≟_ to decEqNat) 32 | open import Data.Bool using (Bool; true; false; if_then_else_) 33 | open import Data.Bool.Properties using () renaming (_≟_ to decEqBool) 34 | open import Data.List as List using (List; []; _∷_; map) 35 | open import Data.Vec as Vec using (Vec; []; _∷_; map) 36 | open import Data.Unit using (⊤; tt) 37 | open import Data.Empty using (⊥; ⊥-elim) 38 | open import Data.Sum using (_⊎_; inj₁; inj₂) 39 | open import Data.Product using (Σ; Σ-syntax; _×_; proj₁; proj₂; _,_) 40 | open import Data.Maybe as Maybe using (Maybe; just; nothing) 41 | open import Data.String hiding (show; _≤_) 42 | renaming (_++_ to _<>_; replicate to repeat) 43 | import Data.Nat.Show as NS using (show) 44 | import Data.Bool.Show as BS using(show) 45 | open import Function using (id; _∘′_; case_of_) 46 | open import Relation.Binary.PropositionalEquality 47 | using (_≡_; refl; cong; cong₂; cong-app; sym; trans; subst; isPropositional; 48 | module ≡-Reasoning) 49 | open ≡-Reasoning 50 | open import Relation.Nullary using (¬_; Dec; yes; no) 51 | import Relation.Nullary.Decidable as RNC 52 | 53 | ------------------------------------------------------------------------ 54 | -- TIME FOR REFLECTION (20 MARKS in total) 55 | ------------------------------------------------------------------------ 56 | 57 | -- In this part, we are considering three different definitions of the 58 | -- less-than relation on natural numbers. Some of them might be familiar from 59 | -- lectures. We want to show that they are all "the same", in the following 60 | -- sense: 61 | 62 | record _↔_ (A B : Set) : Set where 63 | field 64 | to : A -> B 65 | from : B -> A 66 | left-inverse-of : (x : A) -> from (to x) ≡ x 67 | right-inverse-of : (y : B) -> to (from y) ≡ y 68 | open _↔_ 69 | 70 | infix 3 _↔_ 71 | 72 | -- (There is a similar definition in the standard library's 73 | -- Function.Inverse, but that one is defined in more general terms, 74 | -- and hence more inconvenient to use.) 75 | 76 | -- If A ↔ B, then we say that A and B are *isomorphic*. Intuitively, 77 | -- they contain exactly the same information, as we can translate back 78 | -- and forth between them without losing any information. 79 | 80 | {- ??? 2.1 To get used to the concept, show that Bool ⊎ Bool is 81 | isomorphic to Bool × Bool. Are there any other sets A such 82 | that (A ⊎ A) ↔ (A × A)? 83 | (1 MARK) -} 84 | 85 | -- TIP: if you C-c C-c on an empty result, you get to do a definition 86 | -- by "copattern matching", which is quite convenient: you give a 87 | -- definition for each field in the record. 88 | 89 | coincidence-for-Bool : (Bool ⊎ Bool) ↔ (Bool × Bool) 90 | coincidence-for-Bool = {!!} 91 | 92 | {- ??? 2.2 Slightly more involved, find expressions below 93 | so that the left hand side is isomorphic to the right hand side, 94 | and provide the isomorphisms. 95 | (3 MARKS) -} 96 | 97 | zero-sets : ⊥ ↔ Σ ⊥ {!!} 98 | zero-sets = {!!} 99 | 100 | one-set : {A : Set} → A ↔ Σ ⊤ {!!} 101 | one-set = {!!} 102 | 103 | two-sets : {A B : Set} → (A ⊎ B) ↔ (Σ Bool {!!}) 104 | two-sets = {!!} 105 | 106 | ------------------ 107 | module A where 108 | ------------------ 109 | infix 4 _≤_ 110 | 111 | -- Here is _≤_ defined by pattern matching: 112 | 113 | _≤_ : ℕ -> ℕ -> Set 114 | zero ≤ m = ⊤ 115 | suc n ≤ zero = ⊥ 116 | suc n ≤ suc m = n ≤ m 117 | 118 | {- ??? 2.3 For practice, show that 6 ≤ 23. Why is this so easy? 119 | (1 MARK) -} 120 | 121 | 6≤23 : 6 ≤ 23 122 | 6≤23 = {!!} 123 | 124 | {- ??? 2.4 Show that this definition is propositional, ie that any two 125 | proofs of it are equal. 126 | (1 MARK) -} 127 | 128 | propositional : (n m : ℕ) → isPropositional (n ≤ m) 129 | propositional = {!!} 130 | 131 | ------------------ 132 | module B where 133 | ------------------ 134 | infix 4 _≤_ 135 | 136 | -- Here is _≤_ defined inductively: 137 | 138 | data _≤_ : ℕ -> ℕ -> Set where 139 | z≤n : {n : ℕ} -> zero ≤ n 140 | s≤s : {m n : ℕ} -> m ≤ n -> suc m ≤ suc n 141 | 142 | {- ??? 2.5 For comparision, show that 6 ≤ 23 using this definition. 143 | After you have done it yourself, you could see if Auto can do 144 | it, too. 145 | (1 MARK) -} 146 | 147 | 6≤23 : 6 ≤ 23 148 | 6≤23 = {!!} 149 | 150 | -- It is also not hard to prove that this definition is propositional and 151 | -- transitive. 152 | 153 | propositional : {n m : ℕ} -> isPropositional (n ≤ m) 154 | propositional z≤n z≤n = refl 155 | propositional (s≤s p) (s≤s q) = cong s≤s (propositional p q) 156 | 157 | transitive : ∀ {n m k} → n ≤ m -> m ≤ k -> n ≤ k 158 | transitive z≤n q = z≤n 159 | transitive (s≤s p) (s≤s q) = s≤s (transitive p q) 160 | 161 | ------------------ 162 | module C where 163 | ------------------ 164 | infix 4 _≤_ 165 | 166 | -- Here is a different inductive definition of _≤_. Your task now is 167 | -- to show that these are all "the same" definition. However you 168 | -- will see that they still behave different computationally! 169 | 170 | data _≤_ (m : ℕ) : ℕ → Set where 171 | ≤-refl : m ≤ m 172 | ≤-step : ∀ {n} → m ≤ n → m ≤ suc n 173 | 174 | {- ??? 2.6 Again, to get a feel for this definition, show that 6 ≤ 23. 175 | (1 MARK) -} 176 | 177 | 6≤23 : 6 ≤ 23 178 | 6≤23 = {!!} 179 | 180 | {- ??? 2.7 Show that you can translate back and forth between 181 | A.≤ and B.≤. 182 | (2 MARKS) -} 183 | 184 | A→B : (n m : ℕ) -> n A.≤ m -> n B.≤ m 185 | A→B = {!!} 186 | 187 | B→A : {n m : ℕ} -> n B.≤ m -> n A.≤ m 188 | B→A = {!!} 189 | 190 | {- ??? 2.8 Now put together what you have so far to show that 191 | A.≤ and B.≤ are isomorphic. 192 | (1 MARK) -} 193 | 194 | -- HINT: it is easy to prove equations in propositional types. 195 | 196 | A↔B : (n m : ℕ) -> n A.≤ m ↔ n B.≤ m 197 | A↔B = {!!} 198 | 199 | {- ??? 2.9 Now show that you can translate between B.≤ and C.≤. 200 | (2 MARKS) -} 201 | 202 | B→C : {n m : ℕ} -> n B.≤ m -> n C.≤ m 203 | B→C = {!!} 204 | 205 | C→B : {n m : ℕ} -> n C.≤ m -> n B.≤ m 206 | C→B = {!!} 207 | 208 | {- ??? 2.10 Use the above to get a cheap proof of transitivity 209 | for C.≤. (First try to do it by hand; it's not so easy!) 210 | (1 MARK) -} 211 | 212 | C-transitive : ∀ {n m k} → n C.≤ m -> m C.≤ k -> n C.≤ k 213 | C-transitive p q = {!!} 214 | 215 | 216 | {- ??? 2.11 Now show that C.≤ is also propositional, and finish off the 217 | isomorphism between B.≤ and C.≲. 218 | (3 MARKS) -} 219 | 220 | -- HINT: You might find the following lemma, and its lemma, useful: 221 | 222 | ¬sucn≤n : {n : ℕ} -> ¬ (suc n C.≤ n) 223 | ¬sucn≤n {n} p = {!!} where 224 | peel : ∀ {n m} → suc n C.≤ suc m → n C.≤ m 225 | peel = {!!} 226 | 227 | C-propositional : {n m : ℕ} → isPropositional (n C.≤ m) 228 | C-propositional = {!!} 229 | 230 | B↔C : (n m : ℕ) -> n B.≤ m ↔ n C.≤ m 231 | B↔C = {!!} 232 | 233 | {- ??? 2.12 Show that ↔ is transitive, and hence that A.≤ and C.≲ are 234 | isomorphic. 235 | (1 MARK) -} 236 | 237 | 238 | ↔-trans : {X Y Z : Set} -> X ↔ Y -> Y ↔ Z -> X ↔ Z 239 | ↔-trans p q = {!!} 240 | 241 | A↔C : {n m : ℕ} -> n A.≤ m ↔ n C.≤ m 242 | A↔C = {!!} 243 | 244 | {- ??? 2.13 Finally, let's show that two randomly chosen large numbers 245 | are related by C.≤, and that two other ones are /not/ related by B.≤. 246 | (2 MARKS) -} 247 | 248 | myProof : 1295 C.≤ 35968 249 | myProof = {!!} 250 | 251 | myOtherProof : ¬ 4000 B.≤ 200 252 | myOtherProof p = {!!} 253 | 254 | -- TERMINOLOGY: this proof method, where we swap between a definition 255 | -- that reduces, and one which we can pattern match on, is usually 256 | -- called "small-scale reflection". It has been involved in all (?) 257 | -- efforts to prove substantial theorems succh as the Four Colour 258 | -- Theorem and the Odd Order Theorem. 259 | 260 | 261 | ------------------------------------------------------------------------ 262 | -- EXTENDING HUTTON'S RAZOR (15 MARKS in total) 263 | ------------------------------------------------------------------------ 264 | 265 | -- Here we explore the semantics of a small, but not-so-small-anymore 266 | -- programming language. Compared with Hutton's usual Razor, we have 267 | -- added Booleans with a comparision and if-then-else, and state in 268 | -- the form of one memory cell, which we can read and write. 269 | 270 | ----------------------- 271 | -- The untyped version 272 | ----------------------- 273 | 274 | -- We start with an untyped version of the language. 275 | 276 | module Untyped where 277 | 278 | data Expr : Set where 279 | num : ℕ -> Expr 280 | bit : Bool -> Expr 281 | get : Expr 282 | store_then_ : Expr -> Expr -> Expr 283 | _+E_ : Expr -> Expr -> Expr 284 | _*E_ : Expr -> Expr -> Expr 285 | _ Expr -> Expr 286 | ifE_then_else_ : Expr -> Expr -> Expr -> Expr 287 | 288 | infix 3 _ Val 333 | bit : Bool -> Val 334 | 335 | -- Then we can define our monad. Unsurprisingly, it's a combination 336 | -- of the state monad `Memory -> Memory ×_` (for get and store) and the 337 | -- Maybe monad (for evaluation errors, eg type errors). 338 | 339 | Memory = ℕ 340 | 341 | EvalM : Set -> Set 342 | EvalM A = Memory -> (Memory × Maybe A) 343 | 344 | {- ??? 2.14 Implement the monad operations return and bind. 345 | (2 MARKS) -} 346 | 347 | return : {A : Set} -> A -> EvalM A 348 | return = {!!} 349 | 350 | _>>=_ : {A B : Set} -> EvalM A -> (A -> EvalM B) -> EvalM B 351 | (x >>= f) ρ = {!!} 352 | 353 | _>>_ : {A B : Set} -> EvalM A -> EvalM B -> EvalM B 354 | x >> y = x >>= λ _ → y 355 | 356 | {- ??? 2.15 Prove that they really satisfy the monad laws -- we will 357 | get back to why they are the way they are later in the class, 358 | but we can certainly prove this particular instance already 359 | now. 360 | (2 MARKS) 361 | -} 362 | 363 | returnBind : ∀ {A B} → (a : A)(h : A → EvalM B) → return a >>= h ≡ h a 364 | returnBind = {!!} 365 | 366 | bindReturn : ∀ {A}(m : EvalM A) → ∀ ρ → (m >>= return) ρ ≡ m ρ 367 | bindReturn = {!!} 368 | 369 | bindBind : ∀ {A B C} (m : EvalM A)(g : A → EvalM B)(h : B → EvalM C) → 370 | ∀ ρ → ((m >>= g) >>= h) ρ ≡ (m >>= (λ x → g x >>= h)) ρ 371 | bindBind = {!!} 372 | 373 | {- ??? 2.16 Now implement the specific operations that this monad 374 | supports: failing, getting and storing. 375 | (1 MARK) -} 376 | 377 | fail : {A : Set} -> EvalM A 378 | fail = {!!} 379 | 380 | evalGet : EvalM ℕ 381 | evalGet = {!!} 382 | 383 | evalPut : ℕ -> EvalM ⊤ 384 | evalPut = {!!} 385 | 386 | {- ??? 2.17 Use do-notation to implement evaluation. 387 | (3 MARKS) -} 388 | 389 | -- HINT: In a do-block, Agda let's you write 390 | -- 391 | -- (c x) ← e where y → f y 392 | -- 393 | -- to bind e and match it against the more precise pattern `c x`, using 394 | -- `f` if `e` didn't match `c x` 395 | 396 | eval : Expr -> EvalM Val 397 | eval = {!!} 398 | 399 | -- Here are some test cases you can comment in. Let's only look at 400 | -- the produced value, and starting with 0 in the store. 401 | 402 | eval' : Expr -> Maybe Val 403 | eval' e = proj₂ (eval e 0) 404 | 405 | {- 406 | _ : eval' e1 ≡ just (num 9) 407 | _ = refl 408 | 409 | _ : eval' e2 ≡ just (num 10) 410 | _ = refl 411 | 412 | _ : eval' e3 ≡ just (num 14) 413 | _ = refl 414 | 415 | _ : eval' e4 ≡ just (num 12) 416 | _ = refl 417 | 418 | _ : eval' e4' ≡ just (num 5) 419 | _ = refl 420 | 421 | _ : eval' e5 ≡ just (num 2) 422 | _ = refl 423 | 424 | _ : eval' e6 ≡ just (bit false) 425 | _ = refl 426 | 427 | _ : eval' e7 ≡ just (num 8) 428 | _ = refl 429 | 430 | _ : eval' e8 ≡ just (num 5) 431 | _ = refl 432 | -} 433 | 434 | 435 | --------------------- 436 | -- The typed version 437 | --------------------- 438 | 439 | -- Now let's look at a typed variant of the language. It's going to be 440 | -- easier to work with, because we can get rid of the Maybe when 441 | -- evaluating. 442 | 443 | module Typed where 444 | 445 | -- We will have the smallest possible number of non-trivial types. 446 | 447 | data Ty : Set where 448 | nat : Ty 449 | bool : Ty 450 | 451 | data Expr : Ty -> Set where 452 | num : ℕ -> Expr nat 453 | bit : Bool -> Expr bool 454 | get : Expr nat 455 | store_then_ : ∀ {t} → Expr nat -> Expr t -> Expr t 456 | _+E_ : Expr nat -> Expr nat -> Expr nat 457 | _*E_ : Expr nat -> Expr nat -> Expr nat 458 | _ Expr nat -> Expr bool 459 | ifE_then_else_ : ∀ {t} → Expr bool -> Expr t -> Expr t -> Expr t 460 | 461 | infix 3 _ Set 504 | Val nat = ℕ 505 | Val bool = Bool 506 | 507 | Memory = Val nat 508 | 509 | EvalM : Set → Set 510 | EvalM A = Memory -> (Memory × A) 511 | 512 | {- ??? 2.18 Implement the monad operations for *this* EvalM, and 513 | confirm that they satisfy the monad laws. 514 | (1 MARK) -} 515 | 516 | -- COMMENT: You might find this is already easier than before. 517 | 518 | return : {A : Set} → A -> EvalM A 519 | return a ρ = {!!} 520 | 521 | _>>=_ : {A B : Set} → EvalM A -> (A -> EvalM B) -> EvalM B 522 | (x >>= f) ρ = {!!} 523 | 524 | _>>_ : {A B : Set} → EvalM A -> EvalM B -> EvalM B 525 | x >> y = x >>= (λ _ → y) 526 | 527 | returnBind : ∀ {A B : Set} → (a : A)(h : A → EvalM B) → (return a) >>= h ≡ h a 528 | returnBind = {!!} 529 | 530 | bindReturn : ∀ {A : Set} → (m : EvalM A) → ∀ ρ → (m >>= return) ρ ≡ m ρ 531 | bindReturn = {!!} 532 | 533 | bindBind : ∀ {A B C : Set}(m : EvalM A)(g : A → EvalM B)(h : B → EvalM C) → 534 | ∀ ρ → ((m >>= g) >>= h) ρ ≡ (m >>= (λ x → (g x) >>= h)) ρ 535 | bindBind = {!!} 536 | 537 | {- ??? 2.19 Now implement eval again in our glorious typed setting. 538 | Along the way, implement the get and put operations. 539 | (2 MARKS) -} 540 | 541 | evalGet : EvalM (Val nat) 542 | evalGet = {!!} 543 | 544 | evalPut : Val nat -> EvalM ⊤ 545 | evalPut = {!!} 546 | 547 | eval : ∀ {t} → Expr t -> EvalM (Val t) 548 | eval = {!!} 549 | 550 | -- Note that we now always get a value! No more nothing 551 | 552 | eval₀ : ∀ {t} → Expr t -> Memory -> Val t 553 | eval₀ e ρ = proj₂ (eval e ρ) 554 | 555 | -- We can also extract the final state, of course 556 | 557 | evalState : ∀ {t} → Expr t -> Memory -> Memory 558 | evalState e ρ = proj₁ (eval e ρ) 559 | 560 | -- For testing, here are the test cases from above again: 561 | 562 | eval' : ∀ {t} → Expr t -> Val t 563 | eval' e = eval₀ e 0 564 | 565 | {- 566 | _ : eval' e1 ≡ 9 567 | _ = refl 568 | 569 | _ : eval' e2 ≡ 10 570 | _ = refl 571 | 572 | _ : eval' e3 ≡ 14 573 | _ = refl 574 | 575 | _ : eval' e4 ≡ 12 576 | _ = refl 577 | 578 | _ : eval' e4' ≡ 5 579 | _ = refl 580 | 581 | _ : eval' e5 ≡ 2 582 | _ = refl 583 | 584 | _ : eval' e6 ≡ false 585 | _ = refl 586 | 587 | _ : eval' e7 ≡ 8 588 | _ = refl 589 | 590 | _ : eval' e8 ≡ 5 591 | _ = refl 592 | -} 593 | 594 | module RelatingTypedUntyped where 595 | --reimport what we need 596 | open Typed using (Ty; module Ty; Val; Expr; module Expr) 597 | open Ty; open Expr -- get access to the constructors of these data types again 598 | 599 | -- You might find do-notation for Maybe useful in this section, so: 600 | _>>=_ = Maybe._>>=_ 601 | 602 | {- ??? 2.20 Relate the typed and untyped languages by showing how 603 | one can upgrade an untyped expression to a typed one, 604 | when circumstances are good. (You should return `nothing` 605 | exactly when circumstances are not good.) 606 | (2 MARKS) -} 607 | 608 | typeCheck : (t : Ty) → Untyped.Expr → Maybe (Expr t) 609 | typeCheck = {!!} 610 | 611 | {- ??? 2.21 Show that every typed expression can be achieved by 612 | typechecking an untyped expression. 613 | 614 | (2 MARKS) -} 615 | 616 | -- HINT: You might find it useful to define the following function, 617 | -- which "forgets" about type information, and prove a suitable 618 | -- property of it: 619 | 620 | erase : {t : Ty} → Expr t → Untyped.Expr 621 | erase = {!!} 622 | 623 | typeCheck-complete : {t : Ty} → 624 | (e : Expr t) → Σ[ e' ∈ Untyped.Expr ] (typeCheck t e' ≡ just e) 625 | typeCheck-complete = {!!} 626 | 627 | ------------------------------------------------------------------------ 628 | -- COMPILING HUTTON'S RAZOR (25 MARKS in total) 629 | ------------------------------------------------------------------------ 630 | 631 | module Compilation where 632 | open Typed using (Ty; module Ty; Val; Expr; module Expr; eval; eval₀; evalState) --reimport what we need 633 | open Ty; open Expr -- get access to the constructors of these data types again 634 | 635 | -- Let us now see how we can "compile" our language to a stack-based 636 | -- machine. It's assembly code is given as follows, indexed by lists of 637 | -- the types of the elements of the stack before and after execution: 638 | 639 | data Prog : (before : List Ty) -> (after : List Ty) -> Set where 640 | -- push to the stack 641 | PUSH : ∀ {ts t} → Val t → Prog ts (t ∷ ts) 642 | -- remove top element from stack 643 | POP : ∀ {ts t} → Prog (t ∷ ts) ts 644 | -- arithmetic on the top two elements of the stack 645 | ADD : ∀ {ts} → Prog (nat ∷ nat ∷ ts) (nat ∷ ts) 646 | MUL : ∀ {ts} → Prog (nat ∷ nat ∷ ts) (nat ∷ ts) 647 | -- compare top two elements of the stack 648 | CMP : ∀ {ts} → Prog (nat ∷ nat ∷ ts) (bool ∷ ts) 649 | -- load from memory to top of stack 650 | LOAD : ∀ {ts} → Prog ts (nat ∷ ts) 651 | -- copy to memory from top of stack 652 | SAVE : ∀ {ts} → Prog (nat ∷ ts) (nat ∷ ts) 653 | -- conditionally choose a continuation based on top of stack 654 | BRANCH : ∀ {ts ts'} → Prog ts ts' -> Prog ts ts' -> Prog (bool ∷ ts) ts' 655 | -- sequential execution of programs 656 | _▹_ : ∀ {ts ts' ts''} → Prog ts ts' -> Prog ts' ts'' -> Prog ts ts'' 657 | -- do nothing 658 | NOOP : ∀ {ts} → Prog ts ts 659 | 660 | infixl 4 _▹_ 661 | 662 | {- ??? 2.22 For future debugging but mostly for fun, write a show 663 | function for our assembly code. Every time you print a BRANCH, you 664 | should print "-" in front of each block, and then indent the entire 665 | block 2 spaces. 666 | (2 MARKS) -} 667 | 668 | -- EXAMPLE: the code corresponding to e6 above should be printed 669 | {- 670 | PUSH 7 671 | SAVE 672 | POP 673 | LOAD 674 | LOAD 675 | PUSH 1 676 | ADD 677 | CMP 678 | BRANCH 679 | - PUSH true 680 | BRANCH 681 | - PUSH false 682 | - PUSH true 683 | - PUSH true 684 | -} 685 | 686 | showIndent : ∀ {ts ts'} → ℕ -> Prog ts ts' -> String 687 | showIndent = {!!} 688 | 689 | show : ∀ {ts ts'} → Prog ts ts' -> String 690 | show = showIndent 0 691 | 692 | -- HINT: You can get Agda to print using your show function on a 693 | -- term by doing C-u C-u C-c C-n; easiest is to write a hole, 694 | -- eg 695 | -- 696 | -- test = {!compile Typed.e6!} 697 | -- 698 | -- and then do C-u C-u C-c C-n in the hole. 699 | -- (The C-u C-u in this case means "use the `show` function 700 | -- in scope".) 701 | 702 | {- ??? 2.23 Now show how to compile expressions into programs. 703 | (2 MARKS) -} 704 | 705 | -- HINT: You will get some help already by the types of the stack 706 | -- entries, but the real confidence that you have done the 707 | -- right thing comes later in this file in the form of the run 708 | -- function, and its soundness theorem. 709 | 710 | compile : ∀ {t ts} → Expr t -> Prog ts (t ∷ ts) 711 | compile = {!!} 712 | 713 | -- Let us now explain how to actually run our machine code. First we 714 | -- define what a type-respecting stack is, and hence what a machine 715 | -- configuration is. 716 | 717 | data Stack : List Ty -> Set where 718 | [] : Stack [] 719 | _∷_ : ∀ {ts t} → Val t -> Stack ts -> Stack (t ∷ ts) 720 | 721 | -- COMMENT: See how the stack is indexed by the list of types of the 722 | -- values it contains? 723 | 724 | infixr 5 _∷_ 725 | 726 | -- A configuration is a stack, together with a one-cell memory (all we need) 727 | 728 | record Conf (ts : List Ty) : Set where 729 | constructor ⟨_,_⟩ 730 | field 731 | stack : Stack ts 732 | memory : ℕ 733 | open Conf 734 | 735 | {- ??? 2.24 Implement the run function for our programs. Running a 736 | compiled expression should be the same as evaluating it. 737 | (2 MARKS) -} 738 | 739 | -- COMMENT: See how conveniently the types make sure that we always 740 | -- have enough things on the stack? 741 | 742 | run : ∀ {ts ts'} → Prog ts ts' → Conf ts -> Conf ts' 743 | run = {!!} 744 | 745 | {- ??? 2.25 In fact, *prove* that running a 746 | compiled expression is the same as evaluating it! 747 | (4 MARKS) -} 748 | 749 | soundness : ∀ {t ts} → (ρ : ℕ)(xs : Stack ts) → (e : Expr t) -> 750 | run (compile e) ⟨ xs , ρ ⟩ ≡ ⟨ eval₀ e ρ ∷ xs , evalState e ρ ⟩ 751 | soundness = {!!} 752 | 753 | -------------------------- 754 | -- Optimising the compiler 755 | -------------------------- 756 | 757 | -- It's good to be right, but sometimes it is also important to be 758 | -- fast. Hence let us build an *optimising* compiler from expression 759 | -- to stack programs. We chose to do this at the level of stack 760 | -- programs rather than source expressions, as more optimisations 761 | -- are available to us this way (the flipside however is that we 762 | -- have lost some of the higher-level meaning of the expressions). 763 | 764 | -- As an example, here is an optimisation that removes NOOP 765 | -- instructions from programs. (This is not very useful at the moment, 766 | -- because most likely your compiler have not introduced any 767 | -- NOOPs. However other optimisations you write might replace more 768 | -- complicated expressions by NOOP, in which case it is useful to 769 | -- also be able to remove them.) 770 | 771 | -- We first construct a view of expressions that exposes if they are 772 | -- a NOOP followed by or preceding another expression. Because we 773 | -- want to look deeper into our term, we also exposes the 774 | -- "structural" shapes an expression can have, such as branches and 775 | -- sequential compositions: 776 | 777 | data NOOP-View : {ts ts' : List Ty} → Prog ts ts' → Set where 778 | rightNOOP : ∀ {ts ts'} (p : Prog ts ts') → NOOP-View (p ▹ NOOP) 779 | leftNOOP : ∀ {ts ts'} (p : Prog ts ts') → NOOP-View (NOOP ▹ p) 780 | branch : ∀ {ts ts'} (p p' : Prog ts ts') → NOOP-View (BRANCH p p') 781 | seq : ∀ {ts ts' ts''} (p : Prog ts ts')(p' : Prog ts' ts'') → NOOP-View (p ▹ p') 782 | other : ∀ {ts ts'} (p : Prog ts ts') → NOOP-View p 783 | 784 | -- Next we define how every program can be seen this way: 785 | 786 | noop-view : ∀ {ts ts'} (p : Prog ts ts') → NOOP-View p 787 | noop-view (p ▹ NOOP) = rightNOOP p 788 | noop-view (NOOP ▹ p) = leftNOOP p 789 | noop-view (BRANCH p p') = branch p p' 790 | noop-view (p ▹ p') = seq p p' 791 | noop-view x = other x 792 | 793 | -- Then we can use this view to remove the NOOPs; if the view for 794 | -- example is `rightNOOP p`, then the original expression was `p ▹ 795 | -- NOOP`. 796 | 797 | remove-NOOP : ∀ {ts ts'} → Prog ts ts' → Prog ts ts' 798 | remove-NOOP p with noop-view p 799 | ... | rightNOOP p = remove-NOOP p 800 | ... | leftNOOP p = remove-NOOP p 801 | ... | branch p p' = BRANCH (remove-NOOP p) (remove-NOOP p') 802 | ... | seq p p' = remove-NOOP p ▹ remove-NOOP p' 803 | ... | other .p = p 804 | 805 | -- Next we can prove our optimiser correct, meaning that the 806 | -- optimised program runs the same as the original program. This 807 | -- crucially uses the same view. 808 | 809 | -- Of course, you need to implement the `run` function first! So 810 | -- this is commented out for now. When you have finished `run`, you 811 | -- can comment the below in, and consider it an additional test 812 | -- case. 813 | 814 | {- 815 | remove-NOOP-correct : ∀ {ts ts'} → (p : Prog ts ts') → (c : Conf ts) → 816 | run (remove-NOOP p) c ≡ run p c 817 | remove-NOOP-correct p c with noop-view p 818 | ... | rightNOOP p = remove-NOOP-correct p c 819 | ... | leftNOOP p = remove-NOOP-correct p c 820 | remove-NOOP-correct .(BRANCH p p') ⟨ true ∷ c , ρ ⟩ | branch p p' = remove-NOOP-correct p ⟨ c , ρ ⟩ 821 | remove-NOOP-correct .(BRANCH p p') ⟨ false ∷ c , ρ ⟩ | branch p p' = remove-NOOP-correct p' ⟨ c , ρ ⟩ 822 | ... | seq p p' rewrite remove-NOOP-correct p c | remove-NOOP-correct p' (run p c) = refl 823 | ... | other .p = refl 824 | -} 825 | 826 | -- Okay, but before you start writing your own optimisations, let's 827 | -- set up a framework for applying a whole bunch of optimisations, 828 | -- repeatedly -- earlier optimisations might enable later ones, 829 | -- after all. 830 | 831 | {- ??? 2.26 First, to check if an optimisation did something, we 832 | will need to decide if two programs are equal or not. In 833 | fact, we will only need the positive evidence when they are 834 | equal, so it is enough to implement the following: 835 | (3 MARKS) -} 836 | 837 | -- In case you want to use do-notation for the Maybe monad, here is 838 | -- the required bind operator again: 839 | _>>=_ = Maybe._>>=_ 840 | 841 | eq-ListTy? : (ts ts' : List Ty) → Maybe (ts ≡ ts') 842 | eq-ListTy? = {!!} 843 | 844 | eq-Prog? : ∀ {a b a' b'} → (p : Prog a b)(p' : Prog a' b') → 845 | Maybe (Σ (a ≡ a') λ { refl → Σ (b ≡ b') λ { refl → p ≡ p' } }) 846 | eq-Prog? {a} {b} {a'} {b'} p p' = {!!} 847 | 848 | {- ??? 2.27 Now implement the worker of the optimiser, which takes a 849 | list of optimisers to run, a maximum number of times to run 850 | them, and a program to optimise. It should keep applying all 851 | the optimisers until they no longer have any effect, or the 852 | maximum number is reached. (Can you think of why the maximum 853 | number is needed -- are there "correct" optimisers that never 854 | converge?) 855 | (2 MARKS) -} 856 | 857 | optimiseWorker : ∀ {ts ts'} → 858 | List (Prog ts ts' → Prog ts ts') → 859 | (maxIterations : ℕ) → 860 | Prog ts ts' → Prog ts ts' 861 | optimiseWorker = {!!} 862 | 863 | {- ??? 2.28 Go forth and optimise! Write as many optimisers as you 864 | want, and prove each one of them correct. You could consider 865 | e.g. arithmetic simplifications, factoring out common parts 866 | of branches, getput and putput laws, redundant SAVES, ... 867 | Marks will be awarded based on your average improvement on 868 | the compilation of the test cases above. 869 | 870 | (10 MARKS) 871 | -} 872 | 873 | -- Don't forget to add your optimiser to the list here, or it won't be run! 874 | optimise : ∀ {ts ts'} → Prog ts ts' → Prog ts ts' 875 | optimise p = optimiseWorker (remove-NOOP ∷ []) 100000 p 876 | 877 | -- Here is the size function and the improvement measurement: 878 | 879 | size : ∀ {ts ts'} → Prog ts ts' → ℕ 880 | size (PUSH x) = 1 881 | size POP = 1 882 | size ADD = 1 883 | size MUL = 1 884 | size CMP = 1 885 | size LOAD = 1 886 | size SAVE = 1 887 | size (BRANCH p p') = size p + size p' 888 | size (p ▹ p') = size p + size p' 889 | size NOOP = 1 890 | 891 | -- We divide by the size of the original program to calculate the 892 | -- improvement, so Agda requires us to prove that this is never 0 893 | size-nonzero : ∀ {ts ts'} → (p : Prog ts ts') → RNC.False (decEqNat (size p) 0) 894 | size-nonzero (PUSH x) = tt 895 | size-nonzero POP = tt 896 | size-nonzero ADD = tt 897 | size-nonzero MUL = tt 898 | size-nonzero CMP = tt 899 | size-nonzero LOAD = tt 900 | size-nonzero SAVE = tt 901 | size-nonzero (BRANCH p p') 902 | = RNC.fromWitnessFalse (λ sp+sp'=0 → RNC.toWitnessFalse (size-nonzero p) 903 | (Data.Nat.Properties.m+n≡0⇒m≡0 (size p) sp+sp'=0)) 904 | size-nonzero (p ▹ p') 905 | = RNC.fromWitnessFalse (λ sp+sp'=0 → RNC.toWitnessFalse (size-nonzero p) 906 | (Data.Nat.Properties.m+n≡0⇒m≡0 (size p) sp+sp'=0)) 907 | size-nonzero NOOP = tt 908 | 909 | 910 | averageImprovement = List.sum indivEff / List.length indivEff 911 | where 912 | open import Data.Nat.DivMod 913 | tests : List (Σ[ ts ∈ List Ty ] Σ[ ts' ∈ List Ty ] (Prog ts ts')) 914 | tests = ([] , _ , compile Typed.e1) ∷ 915 | ([] , _ , compile Typed.e2) ∷ 916 | ([] , _ , compile Typed.e3) ∷ 917 | ([] , _ , compile Typed.e4) ∷ 918 | ([] , _ , compile Typed.e5) ∷ 919 | ([] , _ , compile Typed.e6) ∷ 920 | ([] , _ , compile Typed.e7) ∷ 921 | ([] , _ , compile Typed.e8) ∷ [] 922 | indivEff = List.map (λ (_ , _ , p) → _/_ (100 * (size p ∸ (size (optimise p)))) (size p) {size-nonzero p}) tests 923 | 924 | {- Marks will be awarded as follows: an averageImprovement of 925 | > 0 is worth 2 MARKS 926 | > 10 is worth 4 MARKS 927 | > 15 is worth 5 MARKS 928 | > 20 is worth 6 MARKS 929 | > 25 is worth 7 MARKS 930 | > 30 is worth 8 MARKS 931 | > 35 is worth 9 MARKS 932 | > 40 is worth 10 MARKS 933 | -} 934 | --------------------------------------------------------------------------------